simon/adl-support
1
0
Fork 0
Code Issues Pull requests Actions Packages Projects Releases Wiki Activity

Work on ADL issue #3, auxlists.

Browse source
This commit is contained in:
Simon Brooke 2018-07-30 00:40:10 +01:00
parent 387c15b8a1
commit d0d3c24e5c
7 changed files with 189 additions and 91 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

80
src/adl_support/core.clj
View file

@ -101,6 +101,43 @@
(def resolve-template (memoize raw-resolve-template))
(defmacro compose-exception-reason
"Compose and return a sensible reason message for this `exception`."
([exception intro]
`(str
~intro
(if ~intro ": ")
(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#))))))
([exception]
`(compose-exception-reason ~exception nil)))
(defmacro compose-reason-and-log
"Compose a reason message for this `exception`, log it (with its
stacktrace), and return the reason message."
([exception intro]
`(let [reason# (compose-exception-reason ~exception ~intro)]
(clojure.tools.logging/error
reason#
"\n"
(with-out-str
(-> ~exception .printStackTrace)))
reason#))
([exception]
`(compose-reason-and-log ~exception nil)))
(defmacro do-or-log-error
"Evaluate the supplied `form` in a try/catch block. If the
keyword param `:message` is supplied, the value will be used
@ -112,54 +149,23 @@
`(try
~form
(catch Exception any#
(clojure.tools.logging/error
(str ~message
(with-out-str
(-> any# .printStackTrace))))
(compose-reason-and-log any# ~message)
~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."
[form]
([form intro]
`(try
{:result ~form}
(catch Exception any#
{:error (compose-exception-reason any#)})))
{:error (compose-exception-reason any# ~intro)})))
([form]
`(do-or-return-reason ~form nil)))
(defmacro do-or-log-and-return-reason
@ -205,6 +211,6 @@
`(try
~form
(catch Exception any#
(*warn* (str ~intro ":\n\t" (compose-reason-and-log any#)))
(*warn* (compose-reason-and-log any# ~intro ))
nil))))

44
src/adl_support/forms_support.clj
View file

@ -57,13 +57,9 @@
: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]
[entity-name get-q list-q fk value]
`(remove
nil?
(flatten
@ -72,45 +68,25 @@
~value
(do-or-log-error
(apply
(symbol (str "db/" (query-name ~entity-name :get)))
~get-q
(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*))
~list-q
(list db/*db*)
{})
:message
(str "Error while fetching " ~entity-name " list"))))))
;; (macroexpand '(get-menu-options "addresses" :address-id 7))
(defmacro auxlist-data-name
"The name to which data for this `auxlist` will be bound in the
Selmer params."
[auxlist]
`(safe-name (str "auxlist-" (-> ~auxlist :attrs :property)) :clojure))
;; (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`."

62
src/adl_support/utils.clj
View file

@ -1,7 +1,8 @@
(ns ^{:doc "Application Description Language support library - utility functions."
:author "Simon Brooke"}
adl-support.utils
(:require [clojure.math.numeric-tower :refer [expt]]
(:require [adl-support.core :refer [*warn*]]
[clojure.math.numeric-tower :refer [expt]]
[clojure.pprint :as p]
[clojure.string :as s]))
@ -42,6 +43,12 @@
(and (map? o) (:tag o) (:attrs o)))
(defmacro entity?
"True if `o` is a Clojure representation of an ADL entity."
[o]
`(= (:tag ~o) :entity))
(defn wrap-lines
"Wrap lines in this `text` to this `width`; return a list of lines."
;; Shamelessly adapted from https://www.rosettacode.org/wiki/Word_wrap#Clojure
@ -294,22 +301,45 @@
"Return a safe name for the object `o`, given the specified `convention`.
`o` is expected to be either a string or an element."
([o]
(if
(element? o)
(safe-name (:name (:attrs o)))
(s/replace (str o) #"[^a-zA-Z0-9-]" "")))
(cond
(element? o)
(safe-name (:name (:attrs o)))
true
(s/replace (str o) #"[^a-zA-Z0-9-]" "")))
([o convention]
(if
(element? o)
(safe-name (:name (:attrs o)) convention)
(let [string (str o)]
(case convention
(:sql :c) (s/replace string #"[^a-zA-Z0-9_]" "_")
:c-sharp (s/replace (capitalise string) #"[^a-zA-Z0-9]" "")
:java (let
[camel (s/replace (capitalise string) #"[^a-zA-Z0-9]" "")]
(apply str (cons (Character/toLowerCase (first camel)) (rest camel))))
(safe-name string))))))
(cond
(and (entity? o) (= convention :sql))
;; if it's an entity, it's permitted to have a different table name
;; from its entity name. This isn't actually likely, but...
(safe-name (or (-> o :attrs :table) (-> o :attrs :name)) :sql)
(element? o)
(safe-name (:name (:attrs o)))
true
(let [string (str o)]
(case convention
(:sql :c) (s/replace string #"[^a-zA-Z0-9_]" "_")
:c-sharp (s/replace (capitalise string) #"[^a-zA-Z0-9]" "")
:java (let
[camel (s/replace (capitalise string) #"[^a-zA-Z0-9]" "")]
(apply str (cons (Character/toLowerCase (first camel)) (rest camel))))
(safe-name string))))))
(defmacro list-related-query-name
"Return the canonical name of the HugSQL query to return all records on
`farside` which match a given record on `nearside`, where `nearide` and
`farside` are both entities."
[nearside farside]
`(if
(and (entity? ~nearside) (entity? ~farside))
(str
"list-"
(safe-name ~farside :sql)
"-by-"
(singularise (safe-name ~nearside :sql)))
(do
(*warn* "Argument passed to `list-related-query-name` was a non-entity")
nil)))
(defn property-for-field

5
test/adl_support/core_test.clj
View file

@ -52,7 +52,10 @@
(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"))))
(is (= expected actual) "Exception thrown"))
(let [expected {:error "Hello: java.lang.ArithmeticException: Divide by zero"}
actual (do-or-return-reason (/ 1 0) "Hello")]
(is (= expected actual) "Exception thrown, with intro"))))
;; These work in REPL, but break in tests. Why?

16
test/adl_support/forms_support_test.clj Normal file
View file

@ -0,0 +1,16 @@
(ns adl-support.forms-support-test
(:require [clojure.test :refer :all]
[adl-support.forms-support :refer :all]))
(deftest auxlist-data-name-test
(testing "auxlist-data-name"
(let [auxlist {:tag :auxlist,
:attrs {:property "dwellings"},
:content [{:tag :field,
:attrs {:name "sub-address"},
:content nil}]}
expected "auxlist-dwellings"
actual (auxlist-data-name auxlist)]
(is (= expected actual) "Just checking..."))))

6
test/adl_support/rest_support_test.clj
View file

@ -1,6 +1,6 @@
(ns adl-support.core-test
(ns adl-support.rest-support-test
(:require [clojure.test :refer :all]
[adl-support.rest_support :refer :all]))
[adl-support.rest-support :refer :all]))
(deftest if-valid-user-tests
@ -19,7 +19,7 @@
actual (valid-user-or-forbid "hello" {:session {:user {:id 4}}})]
(is (= expected actual) "User in session"))
(let [expected 403
actual (:status (valid-user-or-forbid "hello" {:session {:user {:id 4}}}))]
actual (:status (valid-user-or-forbid "hello" {:session {}}))]
(is (= expected actual) "No user in session"))))

67
test/adl_support/utils_test.clj
View file

@ -1,5 +1,6 @@
(ns adl-support.utils-test
(:require [clojure.test :refer :all]
[adl-support.core :refer [*warn*]]
[adl-support.utils :refer :all]))
;; Yes, there's MASSES in utils which ought to be tested. I'll add more tests over time.
@ -304,3 +305,69 @@
with appropriate property with prompt in current locale"))
))
(deftest list-related-query-name-tests
(testing "list-related-query-name"
(let [e1 {:tag :entity,
:attrs {:volatility "6", :magnitude "1", :name "genders", :table "genders"},
:content [{:tag :documentation,
:content ["All genders which may be assigned to\n electors."]}
{:tag :key, :attrs nil,
:content [{:tag :property,
:attrs {:distinct "all", :size "32", :type "string", :name "id"},
:content [{:tag :prompt,
:attrs {:locale "en_GB.UTF-8",
:prompt "Gender"},
:content nil}]}]}
{:tag :list, :attrs {:name "Genders", :properties "all"}}
{:tag :form, :attrs {:name "Gender", :properties "all"}}]}
e2 {:tag :entity,
:attrs {:volatility "6", :magnitude "1", :name "electors", :table "electors"},
:content [{:tag :documentation,
:attrs nil,
:content
["All electors known to the system; electors are
people believed to be entitled to vote in the current
campaign."]}
{:tag :key,
:attrs nil,
:content
[{:tag :property,
:attrs
{:distinct "system",
:immutable "true",
:column "id",
:name "id",
:type "integer",
:required "true"},
:content
[{:tag :generator, :attrs {:action "native"}, :content nil}]}]}
{:tag :property,
:attrs
{:distinct "user",
:column "name",
:name "name",
:type "string",
:required "true",
:size "64"},
:content
[{:tag :prompt,
:attrs {:locale "en_GB.UTF-8", :prompt "Name"},
:content nil}]}
{:tag :property,
:attrs
{:default "Unknown",
:farkey "id",
:entity "genders",
:column "gender",
:type "entity",
:name "gender"},
:content
[{:tag :prompt,
:attrs {:locale "en_GB.UTF-8", :prompt "Gender"},
:content nil}]}]}
expected "list-electors-by-gender"
actual (list-related-query-name e1 e2)]
(is (= expected actual) "just checking..."))))