From 40fa2aacb9030a6d803f091a07137116576225e6 Mon Sep 17 00:00:00 2001
From: Simon Brooke <simon@journeyman.cc>
Date: Mon, 2 Jul 2018 10:54:57 +0100
Subject: [PATCH] A lot of UI work.

---
 src/adl/to_hugsql_queries.clj   |   4 +
 src/adl/to_json_routes.clj      |  34 ++-
 src/adl/to_selmer_routes.clj    | 366 +++++++++++++++++++-------------
 src/adl/to_selmer_templates.clj |  12 +-
 4 files changed, 260 insertions(+), 156 deletions(-)

diff --git a/src/adl/to_hugsql_queries.clj b/src/adl/to_hugsql_queries.clj
index 6011417..6bcaa68 100644
--- a/src/adl/to_hugsql_queries.clj
+++ b/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)
                             " = :"
diff --git a/src/adl/to_json_routes.clj b/src/adl/to_json_routes.clj
index 7b192ed..76e3cfb 100644
--- a/src/adl/to_json_routes.clj
+++ b/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]]
-            [clojure.pprint :refer [pprint]]
-            [clojure.string :as s]
-            [clojure.xml :as x]
+  (:require [adl-support.utils :refer :all]
+            [adl.to-hugsql-queries :refer [queries]]
             [clj-time.core :as t]
             [clj-time.format :as f]
-            [adl-support.utils :refer :all]
-            [adl.to-hugsql-queries :refer [queries]]))
+            [clojure.java.io :refer [file make-parents writer]]
+            [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]
@@ -66,7 +67,24 @@
   [query]
   (list
     [{:keys ['params]}]
-    (list 'do (list (symbol (str "db/" (:name query))) 'params))
+    (list 'do
+          (list
+           'log/debug
+           (list 'str
+                 "Calling query '"
+                 (:name query)
+                 "' with params "
+                 (list 'map
+                       (list 'fn ['p]
+                             ;; user-distinct is a reasonable proxy for 'not-too-secret' -
+                             ;; this will only appear in debug logs.
+                         (list 'if
+                               (list (user-distinct-property-names (:entity query))
+                                     (list 'str (list 'name 'p)))
+                               (list 'params 'p)
+                               "[ELIDED]"))
+                       '(keys params))))
+          (list (symbol (str "db/" (:name query))) 'params))
     (case
       (:type query)
       (:delete-1 :update-1)
diff --git a/src/adl/to_selmer_routes.clj b/src/adl/to_selmer_routes.clj
index 5958082..bcd985c 100644
--- a/src/adl/to_selmer_routes.clj
+++ b/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]
             ))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -42,131 +42,209 @@
 (defn file-header
   [application]
   (list
-    'ns
-    (symbol (str (:name (:attrs application)) ".routes.auto"))
-    (str "User interface routes for " (pretty-name application)
-         " auto-generated by [Application Description Language framework](https://github.com/simon-brooke/adl) at "
-         (f/unparse (f/formatters :basic-date-time) (t/now)))
+   'ns
+   (symbol (str (:name (:attrs application)) ".routes.auto"))
+   (str "User interface routes for " (pretty-name application)
+        " auto-generated by [Application Description Language framework](https://github.com/simon-brooke/adl) at "
+        (f/unparse (f/formatters :basic-date-time) (t/now)))
+   (list
+    :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]
+    '[noir.util.route :as route]
+    '[ring.util.http-response :as response]
+    (vector (symbol (str (:name (:attrs application)) ".layout")) :as 'l)
+    (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
-      :require
-      '[adl-support.core :as support]
-      '[clojure.java.io :as io]
-      '[compojure.core :refer [defroutes GET POST]]
-      '[hugsql.core :as hugsql]
-      '[noir.response :as nresponse]
-      '[noir.util.route :as route]
-      '[ring.util.http-response :as response]
-      (vector (symbol (str (:name (:attrs application)) ".layout")) :as 'l)
-      (vector (symbol (str (:name (:attrs application)) ".db.core")) :as 'db)
-      (vector (symbol (str (:name (:attrs application)) ".routes.manual")) :as 'm))))
+     '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)]
     (list
-      'defn
-      (symbol n)
-      (vector 'r)
-      (list 'let (vector
-                   'p
-                   (list 'merge
-                         {:offset 0 :limit 25}
-                         (list 'support/massage-params (list :params 'r))))
-            ;; TODO: we must take key params out of just params,
-            ;; but we should take all other params out of form-params - because we need the key to
-            ;; load the form in the first place, but just accepting values of other params would
-            ;; allow spoofing.
-            (list
-              'l/render
-              (list 'support/resolve-template (str n ".html"))
-              '(:session r)
-              (merge
-                {:title (capitalise (:name (:attrs f)))
-                 :params  'p}
-                (case (:tag f)
-                  (:form :page)
-                  (reduce
-                    merge
-                    {:record
-                     ;; TODO: this breaks. We need to check for the presence of the
-                     ;; actual key in the params.
-                     (list 'if (list 'empty? (list 'remove 'nil? (list 'vals 'p))) []
-                           (list
-                             (symbol
-                               (str "db/get-" (singularise (:name (:attrs e)))))
-                             (symbol "db/*db*")
-                             'p))}
-                    (map
-                      (fn [p]
-                        (hash-map
-                          (keyword (-> p :attrs :entity))
-                          (list (symbol (str "db/list-" (:entity (:attrs p)))) (symbol "db/*db*"))))
-                      (filter #(#{"entity" "link"} (:type (:attrs %)))
-                              (descendants-with-tag e :property))))
-                  :list
-                  {:records
-                   (list
-                     'if
-                     (list
-                       'not
-                       (list
-                         'empty?
-                         (list 'remove 'nil? (list 'vals 'p))))
-                     (list
-                       (symbol
-                         (str
-                           "db/search-strings-"
-                           (singularise (:name (:attrs e)))))
-                       (symbol "db/*db*")
-                       'p)
-                     (list
-                       (symbol
-                         (str
-                           "db/list-"
-                           (:name (:attrs e))))
-                       (symbol "db/*db*") {}))})))))))
+     'defn
+     (symbol n)
+     (vector 'r)
+     (list
+      'let
+      (vector
+       'p
+       (list 'merge
+             {:offset 0 :limit 25}
+             (list 'support/massage-params (list :params 'r) (list :form-params 'r) (key-names e)))
+       'c (case (:tag f)
+          :form (make-form-handler-content f e a n)
+          :page (make-page-handler-content f e a n)
+          :list (make-list-handler-content f e a n)))
+      (list
+       'l/render
+       (list 'support/resolve-template (str n ".html"))
+       '(:session 'r)
+       (list 'merge
+        {:title (capitalise (:name (:attrs f)))
+         :params  'p}
+        'c))))))
+
+;; (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]
   (list
-    m
-    (str "/" n)
-    'request
+   m
+   (str "/" n)
+   'request
+   (list
+    'route/restricted
     (list
-      'route/restricted
-      (list
-        'apply
-        (list 'resolve-handler n)
-        (list 'list 'request)))))
+     'apply
+     (list 'resolve-handler n)
+     (list 'list 'request)))))
 
 (defn make-defroutes
   [application]
   (let [routes (flatten
-                 (map
-                   (fn [e]
-                     (map
-                       (fn [c]
-                         (path-part c e application))
-                       (filter (fn [c] (#{:form :list :page} (:tag c))) (children e))))
-                   (children-with-tag application :entity)))]
+                (map
+                 (fn [e]
+                   (map
+                    (fn [c]
+                      (path-part c e application))
+                    (filter (fn [c] (#{:form :list :page} (:tag c))) (children e))))
+                 (children-with-tag application :entity)))]
     (cons
-      'defroutes
+     'defroutes
+     (cons
+      'auto-selmer-routes
       (cons
-        'auto-selmer-routes
-        (cons
-          '(GET
-             "/admin"
-             request
-             (route/restricted
-               (apply (resolve-handler "index") (list request))))
-          (interleave
-            (map
-              (fn [r] (make-route 'GET r))
-              (sort routes))
-            (map
-              (fn [r] (make-route 'POST r))
-              (sort routes))))))))
+       '(GET
+         "/admin"
+         request
+         (route/restricted
+          (apply (resolve-handler "index") (list request))))
+       (interleave
+        (map
+         (fn [r] (make-route 'GET r))
+         (sort routes))
+        (map
+         (fn [r] (make-route 'POST r))
+         (sort routes))))))))
 
 
 (defn generate-handler-resolver
@@ -175,17 +253,27 @@
   were doing could write this more elegantly."
   [application]
   (list
-    'defn
-    'raw-resolve-handler
-    "Prefer the manually-written version of the handler with name `n`, if it exists, to the automatically generated one"
-    (vector 'n)
-    (list 'try
-          (list 'eval (list 'symbol (list 'str (:name (:attrs application)) ".routes.manual/" 'n)))
-          (list 'catch
-                'Exception '_
-                (list 'eval
-                      (list 'symbol
-                            (list 'str (:name (:attrs application)) ".routes.auto/" 'n)))))))
+   'defn
+   'raw-resolve-handler
+   "Prefer the manually-written version of the handler with name `n`, if it exists, to the automatically generated one"
+   (vector 'n)
+   (list 'try
+         (list 'eval (list 'symbol (list 'str (:name (:attrs application)) ".routes.manual/" 'n)))
+         (list 'catch
+               'Exception '_
+               (list 'eval
+                     (list 'symbol
+                           (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
@@ -200,25 +288,19 @@
           (pprint '(defn index
                      [r]
                      (l/render
-                       (support/resolve-template
-                         "application-index.html")
-                       (:session r)
-                       {:title "Administrative menu"})))
+                      (support/resolve-template
+                       "application-index.html")
+                      (:session r)
+                      {:title "Administrative menu"})))
           (println)
           (doall
-            (map
-              (fn [e]
-                (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))))
+           (map
+            #(make-handlers % application)
+            (sort
+             #(compare (:name (:attrs %1))(:name (:attrs %2)))
+             (children-with-tag application :entity))))
           (pprint
-            (generate-handler-resolver application))
+           (generate-handler-resolver application))
           (println)
           (pprint '(def resolve-handler
                      (memoize raw-resolve-handler)))
@@ -230,10 +312,10 @@
       (catch
         Exception any
         (println
-          (str
-            "ERROR: Exception "
-            (.getName (.getClass any))
-            (.getMessage any)
-            " while printing "
-            filepath))))))
+         (str
+          "ERROR: Exception "
+          (.getName (.getClass any))
+          (.getMessage any)
+          " while printing "
+          filepath))))))
 
diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj
index 606c4da..47ca965 100644
--- a/src/adl/to_selmer_templates.clj
+++ b/src/adl/to_selmer_templates.clj
@@ -523,13 +523,13 @@
       [
        {:tag :div :attrs {:class "back-link-container"}
         :content
-        ["{% ifunequal offset 0 %}"
-         {:tag :a :attrs {:id "prev-selector" :class "back-link"}
-          :content ["Previous"]}
-         "{% else %}"
-         {:tag :a
+        ["{% 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
@@ -564,7 +564,7 @@
             ow.value='0';
           });
 
-          {% ifunequal offset 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);