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"]
-                 [selmer "1.10.6"]]
+                 [org.clojure/tools.logging "0.4.1"]
+                 [selmer "1.11.8"]]
 
-  :plugins [[lein-codox "0.10.3"]
-            [lein-release "1.0.5"]]
+  :plugins [[lein-codox "0.10.4"]
+            [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."
@@ -142,28 +119,13 @@
        ~error-return)))
 
 
-(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
-         (str (.getName (.getClass any#))
-              ": "
-              (.getMessage any#)
-              (with-out-str
-                (-> any# .printStackTrace))))
-       {:error
-        (s/join
+(defmacro compose-exception-reason
+  "Compose and return a sensible reason message for this `exception`."
+  [exception]
+  `(join
     "\n\tcaused by: "
     (reverse
-            (loop [ex# any# result# ()]
+     (loop [ex# ~exception result# ()]
        (if-not (nil? ex#)
          (recur
           (.getCause ex#)
@@ -171,5 +133,78 @@
                  (.getName (.getClass ex#))
                  ": "
                  (.getMessage ex#)) result#))
-                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."
+  [form]
+  `(try
+     {:result ~form}
+     (catch Exception any#
+       {:error (compose-exception-reason any#)})))
+
+
+(defmacro do-or-log-and-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. Additionally, log the exception"
+  [form]
+  `(try
+     {:result ~form}
+     (catch Exception any#
+       {:error (compose-reason-and-log any#)})))
+
+
+(defmacro do-or-warn
+  "Evaluate this `form`; if any exception is thrown, show it to the user
+  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)
    (not (#{"link"} (:type (:attrs property))))
-    (not (= (:distinct (:attrs property)) "system"))))
+   (not (system-generated? property))))
 
 
 (defmacro all-properties

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"))
+;;     ))