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 - `=&=...`; 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")) +;; ))