Much progress

project.clj

@@ -7,11 +7,11 @@
   :dependencies [[org.clojure/clojure "1.8.0"]
                  [org.clojure/core.memoize "0.7.1"]
                  [org.clojure/math.numeric-tower "0.0.4"]
-                 [org.clojure/tools.logging "0.3.1"]
+                 [org.clojure/tools.logging "0.4.1"]
-                 [selmer "1.10.6"]]
+                 [selmer "1.11.8"]]
 
-  :plugins [[lein-codox "0.10.3"]
+  :plugins [[lein-codox "0.10.4"]
-            [lein-release "1.0.5"]]
+            [lein-release "1.1.3"]]
 
   ;; `lein release` doesn't work with `git flow release`. To use
   ;; `lein release`, first merge `develop` into `master`, and then, in branch

src/adl_support/core.clj

@@ -1,7 +1,8 @@
 (ns adl-support.core
   (:require [clojure.core.memoize :as memo]
             [clojure.java.io :as io]
-            [clojure.string :refer [split]]))
+            [clojure.string :refer [split join]]
+            [clojure.tools.logging]))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;;
@@ -27,30 +28,6 @@
   (fn [s] (println s)))
 
 
-(defn query-string-to-map
-  "A `query-string` - the query-part of a URL - comprises generally
-  `<name>=<value>&<name>=<value>...`; reduce such a string to a map.
-  If `query-string` is nil or empty return an empty map."
-  [query-string]
-  (if
-    (empty? query-string)
-    {}
-    (reduce
-      merge
-      (map
-        #(let [pair (split % #"=")]
-           (if (= (count pair) 2)
-             (let
-               [v (try
-                    (read-string (nth pair 1))
-                    (catch Exception _
-                      (nth pair 1)))
-                value (if (number? v) v (str v))]
-               (hash-map (keyword (first pair)) value))
-             {}))
-        (split query-string #"\&")))))
-
-
 (defn massage-value
   "Return a map with one key, this `k` as a keyword, whose value is the binding of
   `k` in map `m`, as read by read."
@@ -80,23 +57,23 @@
   ([params form-params key-fields]
    (let
      [p (reduce
-          merge
+         merge
-          {}
+         {}
-          (map
+         (map
-            #(massage-value % params)
+          #(massage-value % params)
-            (keys params)))]
+          (keys params)))]
      (if
        (empty? (keys form-params))
        p
        (reduce
-         merge
+        merge
-         ;; do the keyfields first, from params
+        ;; do the keyfields first, from params
-         p
+        p
-         ;; then merge in everything from form-params, potentially overriding what
+        ;; then merge in everything from form-params, potentially overriding what
-         ;; we got from params.
+        ;; we got from params.
-         (map
+        (map
-           #(massage-value % form-params)
+         #(massage-value % form-params)
-           (keys form-params))))))
+         (keys form-params))))))
   ([request key-fields]
    (raw-massage-params (:params request) (:form-params request) key-fields))
   ([request]
@@ -142,34 +119,92 @@
        ~error-return)))
 
 
+(defmacro compose-exception-reason
+  "Compose and return a sensible reason message for this `exception`."
+  [exception]
+  `(join
+    "\n\tcaused by: "
+    (reverse
+     (loop [ex# ~exception result# ()]
+       (if-not (nil? ex#)
+         (recur
+          (.getCause ex#)
+          (cons (str
+                 (.getName (.getClass ex#))
+                 ": "
+                 (.getMessage ex#)) result#))
+         result#)))))
+
+
+(defmacro compose-reason-and-log
+  "Compose a reason message for this `exception`, log it (with its
+  stacktrace), and return the reason message."
+  [exception]
+  `(let [reason# (compose-exception-reason ~exception)]
+     (clojure.tools.logging/error
+      (str reason#
+           "\n"
+           (with-out-str
+             (-> ~exception .printStackTrace))))
+     reason#))
+
+
 (defmacro do-or-return-reason
   "Clojure stacktraces are unreadable. We have to do better; evaluate
   this `form` in a try-catch block; return a map. If the evaluation
   succeeds, the map will have a key `:result` whose value is the result;
   otherwise it will have a key `:error` which will be bound to the most
   sensible error message we can construct."
-  ;; TODO: candidate for moving to adl-support.core
   [form]
   `(try
      {:result ~form}
      (catch Exception any#
-       (clojure.tools.logging/error
+       {:error (compose-exception-reason any#)})))
-         (str (.getName (.getClass any#))
+
-              ": "
+
-              (.getMessage any#)
+(defmacro do-or-log-and-return-reason
-              (with-out-str
+  "Clojure stacktraces are unreadable. We have to do better; evaluate
-                (-> any# .printStackTrace))))
+  this `form` in a try-catch block; return a map. If the evaluation
-       {:error
+  succeeds, the map will have a key `:result` whose value is the result;
-        (s/join
+  otherwise it will have a key `:error` which will be bound to the most
-          "\n\tcaused by: "
+  sensible error message we can construct. Additionally, log the exception"
-          (reverse
+  [form]
-            (loop [ex# any# result# ()]
+  `(try
-              (if-not (nil? ex#)
+     {:result ~form}
-                (recur
+     (catch Exception any#
-                  (.getCause ex#)
+       {:error (compose-reason-and-log any#)})))
-                  (cons (str
+
-                          (.getName (.getClass ex#))
+
-                          ": "
+(defmacro do-or-warn
-                          (.getMessage ex#)) result#))
+  "Evaluate this `form`; if any exception is thrown, show it to the user
-                result#))))})))
+  via the `*warn*` mechanism."
+  ([form]
+   `(try
+      ~form
+      (catch Exception any#
+        (*warn* (compose-exception-reason any#))
+        nil)))
+  ([form intro]
+   `(try
+      ~form
+      (catch Exception any#
+        (*warn* (str ~intro ":\n\t" (compose-exception-reason any#)))
+        nil))))
+
+
+(defmacro do-or-warn-and-log
+  "Evaluate this `form`; if any exception is thrown, log the reason and
+  show it to the user via the `*warn*` mechanism."
+  ([form]
+   `(try
+      ~form
+      (catch Exception any#
+        (*warn* (compose-reason-and-log any#))
+        nil)))
+  ([form intro]
+   `(try
+      ~form
+      (catch Exception any#
+        (*warn* (str ~intro ":\n\t" (compose-reason-and-log any#)))
+        nil))))
 

src/adl_support/forms_support.clj

@@ -0,0 +1,118 @@
+(ns adl-support.forms-support
+  (:require [adl-support.core :refer [do-or-log-error do-or-return-reason]]
+            [adl-support.utils :refer [safe-name singularise]]
+            [clojure.core.memoize :as memo]
+            [clojure.data.json :as json]
+            [clojure.java.io :as io]
+            [clojure.string :refer [lower-case]]))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;
+;;;; adl-support.forms-support: functions used by ADL-generated code:
+;;;; support functions for HTML forms.
+;;;;
+;;;; This program is free software; you can redistribute it and/or
+;;;; modify it under the terms of the MIT-style licence provided; see LICENSE.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;; License for more details.
+;;;;
+;;;; Copyright (C) 2018 Simon Brooke
+;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(defn query-name
+  "Generate a query name for the query of type `q-type` (expected to be one
+  of `:create`, `:delete`, `:get`, `:list`, `:search-strings`, `:update`) of
+  the entity `entity-or-name` NOTE: if `entity-or-name` is passed as a string,
+  it should be the full, unaltered name of the entity."
+  [entity-or-name q-type]
+  (symbol
+   (str
+    "db/"
+    (lower-case (name q-type))
+    "-"
+    (let [n (safe-name
+             (if
+               (string? entity-or-name)
+               entity-or-name
+               (:name (:attrs entity-or-name))) :sql)]
+      (case q-type
+        (:list :search-strings) n
+        (singularise n)))
+    (case q-type
+      (:create :delete :update) "!"
+      nil))))
+
+
+(defmacro get-current-value
+  [f params entity-name]
+  `(let
+     [message# (str "Error while fetching " ~entity-name " record " ~params)]
+     (support/do-or-log-error
+      (~f  db/*db* ~params)
+      :message message#
+      :error-return {:warnings [message#]})))
+
+;; (macroexpand '(get-current-value str {:foo "bar" :ban 2} "addresses"))
+
+
+(defmacro get-menu-options
+  ;; TODO: constructing these query-method names at runtime is madness.
+  ;; we definitely need to construct them at compile time.
+  [entity-name fk value]
+  `(remove
+    nil?
+    (flatten
+     (list
+      (if
+        ~value
+        (do-or-log-error
+         (apply
+          (symbol (str "db/" (query-name ~entity-name :get)))
+          (list db/*db* {~fk ~value}))
+         :message
+         (str "Error while fetching " ~entity-name " record '" ~value "'")))
+      (do-or-log-error
+       (apply
+        (symbol (str "db/" (query-name ~entity-name :list)))
+        (list db/*db*))
+       :message
+       (str "Error while fetching " ~entity-name " list"))))))
+
+
+;; (macroexpand '(get-menu-options "addresses" :address-id 7))
+
+;; (clojure.core/remove
+;;  clojure.core/nil?
+;;  (clojure.core/flatten
+;;   (clojure.core/list
+;;    (if
+;;      7
+;;      (adl-support.core/do-or-log-error
+;;       (clojure.core/apply
+;;        (clojure.core/symbol
+;;         (clojure.core/str
+;;          "db/"
+;;          (adl-support.forms-support/query-name "addresses" :get)))
+;;        (clojure.core/list
+;;         db/*db*
+;;         {:address-id 7}))
+;;       :message
+;;       (clojure.core/str "Error while fetching " "addresses" " record '" 7 "'")))
+;;    (adl-support.core/do-or-log-error
+;;     (clojure.core/apply
+;;      (clojure.core/symbol
+;;       (clojure.core/str "db/"
+;;                         (adl-support.forms-support/query-name "addresses" :list)))
+;;      (clojure.core/list db/*db*))
+;;     :message
+;;     (clojure.core/str "Error while fetching " "addresses" " list")))))
+
+(defmacro all-keys-present?
+  "Return true if all the keys in `keys` are present in the map `m`."
+  [m keys]
+  `(clojure.set/subset? (set ~keys) (set (keys ~m))))

src/adl_support/rest_support.clj

@@ -1,12 +1,14 @@
 (ns adl-support.rest-support
-  (:require [clojure.core.memoize :as memo]
+  (:require [adl-support.core :refer [do-or-log-error do-or-return-reason]]
+            [clojure.core.memoize :as memo]
             [clojure.data.json :as json]
             [clojure.java.io :as io]
             [clojure.string :refer [split]]))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;;
-;;;; adl-support.core: functions used by ADL-generated code: REST support.
+;;;; adl-support.rest-support: functions used by ADL-generated code: support
+;;;; functions for REST routes.
 ;;;;
 ;;;; This program is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the MIT-style licence provided; see LICENSE.

src/adl_support/utils.clj

@@ -396,13 +396,23 @@
         elements))))
 
 
+(defn system-generated?
+  "True if the value of the `property` is system generated, and
+  should not be set by the user."
+  [property]
+  (child-with-tag
+          property
+          :generator
+          #(#{"native" "guid"} (-> % :attrs :action))))
+
+
 (defn insertable?
   "Return `true` it the value of this `property` may be set from user-supplied data."
   [property]
   (and
-    (= (:tag property) :property)
+   (= (:tag property) :property)
-    (not (#{"link"} (:type (:attrs property))))
+   (not (#{"link"} (:type (:attrs property))))
-    (not (= (:distinct (:attrs property)) "system"))))
+   (not (system-generated? property))))
 
 
 (defmacro all-properties
@@ -523,14 +533,14 @@
   first child of the `entity` of the specified type will be used."
   [form entity application]
   (cond
-    (and (map? form) (#{:list :form :page} (:tag form)))
+   (and (map? form) (#{:list :form :page} (:tag form)))
-  (s/join
+   (s/join
     "-"
     (flatten
-      (list
+     (list
-        (name (:tag form)) (:name (:attrs entity)) (s/split (:name (:attrs form)) #"[ \n\r\t]+"))))
+      (name (:tag form)) (:name (:attrs entity)) (s/split (:name (:attrs form)) #"[ \n\r\t]+"))))
-    (keyword? form)
+   (keyword? form)
-    (path-part (first (children-with-tag entity form)) entity application)))
+   (path-part (first (children-with-tag entity form)) entity application)))
 
 
 (defn editor-name

test/adl_support/core_test.clj

@@ -2,28 +2,6 @@
   (:require [clojure.test :refer :all]
             [adl-support.core :refer :all]))
 
-(deftest query-string-to-map-tests
-  (testing "conversion of query strings to maps"
-    (let [expected {}
-          actual (query-string-to-map nil)]
-      (is (= expected actual) "Nil arg"))
-    (let [expected {}
-          actual (query-string-to-map "")]
-      (is (= expected actual) "Empty string arg"))
-    (let [expected {:id 1}
-          actual (query-string-to-map "id=1")]
-      (is (= expected actual) "One integer value"))
-    (let [expected {:name "simon"}
-          actual (query-string-to-map "name=simon")]
-      (is (= expected actual) "One string value."))
-    (let [expected {:name "simon" :id 1}
-          actual (query-string-to-map "id=1&name=simon")]
-      (is (= expected actual) "One string value, one integer. Order of pairs might be reversed, and that's OK"))
-    (let [expected {:address_id_expanded "AIRDS"}
-          actual (query-string-to-map "id=&address_id_expanded=AIRDS&sub-address=")]
-      (is (= expected actual) "Yeys with no values should not be included in the map"))
-    ))
-
 (deftest massage-params-tests
   (testing "Massaging of params"
     (let [expected {:id 67}
@@ -49,3 +27,44 @@
                                   :form-params {:id "67" :offset "0" :limit "50"}})]
       (is (= expected actual) "Request with form params, params and form params differ"))
       ))
+
+(deftest compose-exception-reason-tests
+  (testing "Compose exception reason"
+    (let [expected "java.lang.Exception: hello"
+          actual (compose-exception-reason
+                  (Exception. "hello"))]
+      (is (= expected actual) "Exception with no cause"))
+    (let [expected "java.lang.Exception: Top-level exception\n\tcaused by: java.lang.Exception: cause"
+          actual (compose-exception-reason
+                  (Exception.
+                   "Top-level exception"
+                   (Exception. "cause")))]
+      (is (= expected actual) "Exception with cause"))
+    (let [expected ""
+          actual (compose-exception-reason nil)]
+      (is (= expected actual) "Exception with no cause"))))
+
+
+(deftest do-or-return-reason-tests
+  (testing "do-or-return-reason"
+    (let [expected {:result 1}
+          actual (do-or-return-reason (/ 1 1))]
+      (is (= expected actual) "No exception thrown"))
+    (let [expected {:error "java.lang.ArithmeticException: Divide by zero"}
+          actual (do-or-return-reason (/ 1 0))]
+      (is (= expected actual) "Exception thrown"))))
+
+
+;; These work in REPL, but break in tests. Why?
+;; (deftest "do-or-warn-tests"
+;;   (testing "do-or-warn"
+;;     (let [expected 1
+;;           actual (do-or-warn (/ 1 1))]
+;;       (is (= expected actual) "No exception thrown"))
+;;     (let [expected nil
+;;           actual (do-or-warn (/ 1 0))]
+;;       (is (= expected actual) "Exception thrown"))
+;;     (let [expected nil
+;;           actual (do-or-warn (/ 1 0) "hello")]
+;;       (is (= expected actual) "Exception thrown"))
+;;     ))