Merge remote-tracking branch 'origin/develop' into develop

src/adl/to_hugsql_queries.clj

@@ -183,6 +183,10 @@
                           (str
                             (safe-name (-> % :attrs :name) :sql)
                             " = ':" (-> % :attrs :name) "'")
+                          "entity"
+                          (str
+                           (safe-name (-> % :attrs :name) :sql)
+                            "_expanded LIKE '%:" (-> % :attrs :name) "%'")
                           (str
                             (safe-name (-> % :attrs :name) :sql)
                             " = :"

src/adl/to_json_routes.clj

@@ -1,14 +1,14 @@
 (ns ^{:doc "Application Description Language: generate RING routes for REST requests."
       :author "Simon Brooke"}
   adl.to-json-routes
-  (:require [clojure.java.io :refer [file make-parents writer]]
+  (:require [adl-support.utils :refer :all]
-            [clojure.pprint :refer [pprint]]
+            [adl.to-hugsql-queries :refer [queries]]
-            [clojure.string :as s]
-            [clojure.xml :as x]
             [clj-time.core :as t]
             [clj-time.format :as f]
-            [adl-support.utils :refer :all]
+            [clojure.java.io :refer [file make-parents writer]]
-            [adl.to-hugsql-queries :refer [queries]]))
+            [clojure.pprint :refer [pprint]]
+            [clojure.string :as s]
+            [clojure.xml :as x]))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;;
@@ -47,8 +47,9 @@
     (list
       :require
       '[adl-support.core :as support]
-      '[clojure.java.io :as io]
       '[clojure.core.memoize :as memo]
+      '[clojure.java.io :as io]
+      '[clojure.tools.logging :as log]
       '[compojure.core :refer [defroutes GET POST]]
       '[hugsql.core :as hugsql]
       '[noir.response :as nresponse]

src/adl/to_selmer_routes.clj

@@ -2,12 +2,12 @@
       :author "Simon Brooke"}
   adl.to-selmer-routes
   (:require [adl-support.utils :refer :all]
+            [clj-time.core :as t]
+            [clj-time.format :as f]
             [clojure.java.io :refer [file make-parents writer]]
             [clojure.pprint :refer [pprint]]
             [clojure.string :as s]
             [clojure.xml :as x]
-            [clj-time.core :as t]
-            [clj-time.format :as f]
             ))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -51,6 +51,8 @@
     :require
     '[adl-support.core :as support]
     '[clojure.java.io :as io]
+    '[clojure.set :refer [subset?]]
+    '[clojure.tools.logging :as log]
     '[compojure.core :refer [defroutes GET POST]]
     '[hugsql.core :as hugsql]
     '[noir.response :as nresponse]
@@ -60,6 +62,109 @@
     (vector (symbol (str (:name (:attrs application)) ".db.core")) :as 'db)
     (vector (symbol (str (:name (:attrs application)) ".routes.manual")) :as 'm))))
 
+
+(defn make-form-handler-content
+  [f e a n]
+  (let [warning (str "Error while fetching " (singularise (:name (:attrs e))) " record")]
+    ;; TODO: as yet makes no attempt to save the record
+    (list 'let
+          (vector
+           'record (list
+                    'support/do-or-log-error
+                    (list 'if (list 'subset? (key-names e) (set (list 'keys 'p)))
+                          (list
+                           (symbol
+                            (str "db/get-" (singularise (:name (:attrs e)))))
+                           (symbol "db/*db*")
+                           'p))
+                    :message warning
+                    :error-return {:warnings [warning]}))
+          (reduce
+           merge
+           {:warnings (list :warnings 'record)
+            :record (list 'assoc 'record :warnings nil)}
+           (map
+            (fn [p]
+              (hash-map
+               (keyword (-> p :attrs :entity))
+               (list 'support/do-or-log-error
+                     (list (symbol (str "db/list-" (:entity (:attrs p)))) (symbol "db/*db*"))
+                     :message (str "Error while fetching "
+                                   (singularise (:entity (:attrs p)))
+                                   " record"))))
+            (filter #(#{"entity" "link"} (:type (:attrs %)))
+                    (descendants-with-tag e :property)))))))
+
+
+(defn make-page-handler-content
+  [f e a n]
+  (let [warning (str "Error while fetching " (singularise (:name (:attrs e))) " record")]
+    (list 'let
+          (vector 'record (list
+                           'support/handler-content-log-error
+                           (list 'if (list 'subset? (list 'keys 'p) (key-names e)) []
+                                 (list
+                                  (symbol
+                                   (str "db/get-" (singularise (:name (:attrs e)))))
+                                  (symbol "db/*db*")
+                                  'p))
+                           :message warning
+                           :error-return {:warnings [warning]}))
+           {:warnings (list :warnings 'record)
+            :record (list 'assoc 'record :warnings nil)})))
+
+
+(defn make-list-handler-content
+  [f e a n]
+  (list
+   'let
+   (vector
+    'records
+    (list
+     'if
+     (list
+      'some
+      (set (map #(-> % :attrs :name) (all-properties e)))
+      (list 'keys 'p))
+     (list
+      'support/do-or-log-error
+      (list
+       (symbol
+        (str
+         "db/search-strings-"
+         (singularise (:name (:attrs e)))))
+       (symbol "db/*db*")
+       'p)
+      :message (str
+                "Error while searching "
+                (singularise (:name (:attrs e)))
+                " records")
+      :error-return {:warnings [(str
+                                 "Error while searching "
+                                 (singularise (:name (:attrs e)))
+                                 " records")]})
+     (list
+      'support/do-or-log-error
+      (list
+       (symbol
+        (str
+         "db/list-"
+         (:name (:attrs e))))
+       (symbol "db/*db*") {})
+      :message (str
+                "Error while fetching "
+                (singularise (:name (:attrs e)))
+                " records")
+      :error-return {:warnings [(str
+                                 "Error while fetching "
+                                 (singularise (:name (:attrs e)))
+                                 " records")]})))
+   (list 'if
+         (list :warnings 'records)
+         'records
+         {:records 'records})))
+
+
 (defn make-handler
   [f e a]
   (let [n (path-part f e a)]
@@ -122,6 +227,18 @@
                            (:name (:attrs e))))
                        (symbol "db/*db*") {}))})))))))
 
+;; (def a (x/parse "../youyesyet/youyesyet.canonical.adl.xml"))
+;; (def e (child-with-tag a :entity))
+;; (def f (child-with-tag e :form))
+;; (def n (path-part f e a))
+;; (vector
+;;  'p
+;;  (list 'merge
+;;        {:offset 0 :limit 25}
+;;        (list 'support/massage-params (list :params 'r))))
+;; (make-handler f e a)
+
+
 (defn make-route
   "Make a route for method `m` to request the resource with name `n`."
   [m n]
@@ -184,6 +301,16 @@
                            (list 'str (:name (:attrs application)) ".routes.auto/" 'n)))))))
 
 
+(defn make-handlers
+  [e application]
+  (doall
+   (map
+    (fn [c]
+      (pprint (make-handler c e application))
+      (println))
+    (filter (fn [c] (#{:form :list :page} (:tag c))) (children e)))))
+
+
 (defn to-selmer-routes
   [application]
   (let [filepath (str *output-path* "src/clj/" (:name (:attrs application)) "/routes/auto.clj")]
@@ -203,13 +330,7 @@
           (println)
           (doall
            (map
-              (fn [e]
+            #(make-handlers % application)
-                (doall
-                  (map
-                    (fn [c]
-                      (pprint (make-handler c e application))
-                      (println))
-                    (filter (fn [c] (#{:form :list :page} (:tag c))) (children e)))))
             (sort
              #(compare (:name (:attrs %1))(:name (:attrs %2)))
              (children-with-tag application :entity))))

src/adl/to_selmer_templates.clj

@@ -39,7 +39,7 @@
   {:tag :div
    :attrs {:class "big-link-container"}
    :content
-   [{:tag :a :attrs {:href url}
+   [{:tag :a :attrs {:href url :class "big-link"}
      :content (if
                 (vector? content)
                 content
@@ -62,22 +62,24 @@
   ([filename application k]
    (emit-content filename nil nil application k))
   ([filename spec entity application k]
-   (let [content (:content
+   (let [content
+         (:content
           (first
            (or (children-with-tag spec k)
                (children-with-tag entity k)
                (children-with-tag
-                           (first
+                (child-with-tag application :content)
-                             (children-with-tag application :content))
                 k))))]
      (if
        content
+       (flatten
         (list
          (str "{% block " (name k) " %}")
+         (doall
           (map
            #(with-out-str (x/emit-element %))
-           content)
+           content))
-         "{% endblock %}")))))
+         "{% endblock %}"))))))
 
 
 (defn file-header
@@ -484,7 +486,7 @@
             :content
             [{:tag :input
               :attrs {:type "submit"
-                      :id "search"
+                      :id "search-widget"
                       :value "Search"}}]})))}]})
 
 
@@ -540,51 +542,77 @@
     "{% endfor %}"]})
 
 
-(defn- list-page-control
-  "What this needs to do is emit an HTML control which, when selected, requests the
-  next or previous page keeping the same search parameters; so it essentially needs
-  to be a submit button, not a link."
-  [forward?]
-  {:tag :div
-   :attrs {:class (if forward? "big-link-container" "back-link-container")}
-   :content
-   [{:tag :input
-     :attrs {:id "page"
-             :name "page"
-             :disabled (if
-                         forward?
-                         false
-                         "{% ifequal offset 0 %} false {% else %} true {% endifequal %}")
-             ;; TODO: real thought needs to happen on doing i18n for this!
-             :value (if forward? "Next" "Previous")}}]})
-
-
-(defn- list-tfoot
-  "Return a table footer element for the list view for this `list-spec` of this `entity` within
-  this `application`."
-  [list-spec entity application]
-  {:tag :tfoot
-   :content
-   [(list-page-control false)
-    (list-page-control true)]})
-
-
 (defn list-to-template
   "Generate a template as specified by this `list` element for this `entity`,
   taken from this `application`. If `list` is nill, generate a default list
   template for the entity."
   [list-spec entity application]
-  {:content
+  (let [form-name
-   {:tag :form
+        (str
-   :attrs {:id "content" :class "list"}
+         "list-"
+         (:name (:attrs entity))
+         "-"
+         (:name (:attrs list-spec)))]
+    {:back-links
+     {:tag :div
       :content
-   [(big-link (str "Add a new " (pretty-name entity)) (editor-name entity application))
+      [
+       {:tag :div :attrs {:class "back-link-container"}
+        :content
+        ["{% ifequal params.offset \"0\" %}"
+          {:tag :a
+          :attrs {:id "back-link" :class "back-link" :href "{{servlet-context}}/admin"}
+          :content ["Back"]}
+         "{% else %}"
+          {:tag :a :attrs {:id "prev-selector" :class "back-link"}
+          :content ["Previous"]}
+         "{% endifunequal %}"]}
+       ]}
+     :big-links
+     {:tag :div
+      :content
+      [{:tag :div :attrs {:class "big-link-container"}
+        :content
+        [{:tag :a :attrs {:id "next-selector" :role "button" :class "big-link"}
+          :content ["Next"]}]}
+       (big-link (str "Add a new " (pretty-name entity)) (editor-name entity application))]}
+     :content
+     {:tag :form
+      :attrs {:id form-name :class "list"
+              :action (str "{{servlet-context}}/" form-name)
+              :method "POST"}
+      :content
+      [(csrf-widget)
+       {:tag :input :attrs {:id "offset" :type "hidden" :value "{{params.offset|default:0}}"}}
+       {:tag :input :attrs {:id "limit" :type "hidden" :value "{{params.limit|default:50}}"}}
        {:tag :table
         :attrs {:caption (:name (:attrs entity))}
         :content
           [(list-thead list-spec entity application)
            (list-tbody list-spec entity application)
-      (list-tfoot list-spec entity application)]}]}})
+           ]}]}
+     :extra-script
+     (str "
+          var form = document.getElementById('" form-name "');
+          var ow = document.getElementById('offset');
+          var lw = document.getElementById('limit');
+          form.addEventListener('submit', function() {
+            ow.value='0';
+          });
+
+          {% ifunequal params.offset \"0\" %}
+          document.getElementById('prev-selector').addEventListener('click', function () {
+            ow.value=(parseInt(ow.value)-parseInt(lw.value));
+            console.log('Updated offset to ' + ow.value);
+            form.submit();
+          });
+          {% endifunequal %}
+
+          document.getElementById('next-selector').addEventListener('click', function () {
+            ow.value=(parseInt(ow.value)+parseInt(lw.value));
+            console.log('Updated offset to ' + ow.value);
+            form.submit();
+          });")}))
 
 
 (defn entity-to-templates
@@ -633,6 +661,7 @@
        #(children-with-tag % :list)
        (children-with-tag application :entity)))]
     {:application-index
+     {:content
       {:tag :dl
        :attrs {:class "index"}
        :content
@@ -658,16 +687,16 @@
                           :tag :p
                           :content (:content d)))
                        (children-with-tag % :documentation))))
-            first-class-entities)))}}))
+          first-class-entities)))}}}))
 
 
 (defn write-template-file
   [filename template application]
   (let [filepath (str *output-path* "resources/templates/auto/" filename)]
-    (make-parents filepath)
     (if
       template
       (try
+        (do
           (spit
            filepath
            (s/join
@@ -675,33 +704,36 @@
             (flatten
              (list
               (file-header filename application)
+              (doall
                (map
-                  #(cond
+                #(let [content (template %)]
-                     (:tag %)
+                   (list
+                    (str "{% block " (name %) " %}")
+                    (cond (string? content)
+                          content
+                          (map? content)
                           (with-out-str
-                       (x/emit-element %))
+                            (x/emit-element content))
-                     (string? %)
-                     %
                           true
-                     (str ";; WTF? " %))
+                          (str "<!-- don't know what to do with '" content "' -->"))
-                  (:header template))
+                    "{% endblock %}"))
-                "{% block content %}"
+                   (keys template)))
-                (with-out-str
-                  (x/emit-element (:content template)))
               (file-footer filename application)))))
-        (if (> *verbosity* 0) (println "\tGenerated " filepath))
+          (if (> *verbosity* 0) (println "\tGenerated " filepath)))
         (catch Exception any
           (let [report (str
                         "ERROR: Exception "
                         (.getName (.getClass any))
                         (.getMessage any)
                         " while printing "
-                         filename)]
+                        filepath)]
+            (try
               (spit
                filepath
                (with-out-str
                  (println (str "<!-- " report "-->"))
                  (p/pprint template)))
+              (catch Exception _ nil))
             (println report)
             (throw any)))))
     (str filepath)))