From 387c15b8a1c3afcc5295e01adedf9b1bf27ced44 Mon Sep 17 00:00:00 2001
From: Simon Brooke <simon@journeyman.cc>
Date: Sun, 29 Jul 2018 00:37:57 +0100
Subject: [PATCH] Much progress
---
project.clj | 8 +-
src/adl_support/core.clj | 151 ++++++++++++++++++------------
src/adl_support/forms_support.clj | 118 +++++++++++++++++++++++
src/adl_support/rest_support.clj | 6 +-
src/adl_support/utils.clj | 28 ++++--
test/adl_support/core_test.clj | 63 ++++++++-----
6 files changed, 279 insertions(+), 95 deletions(-)
create mode 100644 src/adl_support/forms_support.clj
diff --git a/project.clj b/project.clj
index f867a49..b193d12 100644
--- a/project.clj
+++ b/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
diff --git a/src/adl_support/core.clj b/src/adl_support/core.clj
index 45348e2..141fe3c 100644
--- a/src/adl_support/core.clj
+++ b/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
- {}
- (map
- #(massage-value % params)
- (keys params)))]
+ merge
+ {}
+ (map
+ #(massage-value % params)
+ (keys params)))]
(if
(empty? (keys form-params))
p
(reduce
- merge
- ;; do the keyfields first, from params
- p
- ;; then merge in everything from form-params, potentially overriding what
- ;; we got from params.
- (map
- #(massage-value % form-params)
- (keys form-params))))))
+ merge
+ ;; do the keyfields first, from params
+ p
+ ;; then merge in everything from form-params, potentially overriding what
+ ;; we got from params.
+ (map
+ #(massage-value % 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
- (str (.getName (.getClass any#))
- ": "
- (.getMessage any#)
- (with-out-str
- (-> any# .printStackTrace))))
- {:error
- (s/join
- "\n\tcaused by: "
- (reverse
- (loop [ex# any# result# ()]
- (if-not (nil? ex#)
- (recur
- (.getCause ex#)
- (cons (str
- (.getName (.getClass ex#))
- ": "
- (.getMessage ex#)) result#))
- result#))))})))
+ {: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))))
diff --git a/src/adl_support/forms_support.clj b/src/adl_support/forms_support.clj
new file mode 100644
index 0000000..88c9279
--- /dev/null
+++ b/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))))
diff --git a/src/adl_support/rest_support.clj b/src/adl_support/rest_support.clj
index 4a9a39f..dc3ee93 100644
--- a/src/adl_support/rest_support.clj
+++ b/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.
diff --git a/src/adl_support/utils.clj b/src/adl_support/utils.clj
index 191961d..b132c82 100644
--- a/src/adl_support/utils.clj
+++ b/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"))))
+ (= (:tag property) :property)
+ (not (#{"link"} (:type (:attrs property))))
+ (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)))
- (s/join
+ (and (map? form) (#{:list :form :page} (:tag form)))
+ (s/join
"-"
(flatten
- (list
- (name (:tag form)) (:name (:attrs entity)) (s/split (:name (:attrs form)) #"[ \n\r\t]+"))))
- (keyword? form)
- (path-part (first (children-with-tag entity form)) entity application)))
+ (list
+ (name (:tag form)) (:name (:attrs entity)) (s/split (:name (:attrs form)) #"[ \n\r\t]+"))))
+ (keyword? form)
+ (path-part (first (children-with-tag entity form)) entity application)))
(defn editor-name
diff --git a/test/adl_support/core_test.clj b/test/adl_support/core_test.clj
index 2527d0d..0a8ea05 100644
--- a/test/adl_support/core_test.clj
+++ b/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"))
+;; ))