").append(n.parseHTML(a)).find(d):a)}).complete(c&&function(a,b){g.each(c,e||[a.responseText,b,a])}),this},n.expr.filters.animated=function(a){return n.grep(n.timers,function(b){return a===b.elem}).length};var dd=a.document.documentElement;function ed(a){return n.isWindow(a)?a:9===a.nodeType?a.defaultView||a.parentWindow:!1}n.offset={setOffset:function(a,b,c){var d,e,f,g,h,i,j,k=n.css(a,"position"),l=n(a),m={};"static"===k&&(a.style.position="relative"),h=l.offset(),f=n.css(a,"top"),i=n.css(a,"left"),j=("absolute"===k||"fixed"===k)&&n.inArray("auto",[f,i])>-1,j?(d=l.position(),g=d.top,e=d.left):(g=parseFloat(f)||0,e=parseFloat(i)||0),n.isFunction(b)&&(b=b.call(a,c,h)),null!=b.top&&(m.top=b.top-h.top+g),null!=b.left&&(m.left=b.left-h.left+e),"using"in b?b.using.call(a,m):l.css(m)}},n.fn.extend({offset:function(a){if(arguments.length)return void 0===a?this:this.each(function(b){n.offset.setOffset(this,a,b)});var b,c,d={top:0,left:0},e=this[0],f=e&&e.ownerDocument;if(f)return b=f.documentElement,n.contains(b,e)?(typeof e.getBoundingClientRect!==L&&(d=e.getBoundingClientRect()),c=ed(f),{top:d.top+(c.pageYOffset||b.scrollTop)-(b.clientTop||0),left:d.left+(c.pageXOffset||b.scrollLeft)-(b.clientLeft||0)}):d},position:function(){if(this[0]){var a,b,c={top:0,left:0},d=this[0];return"fixed"===n.css(d,"position")?b=d.getBoundingClientRect():(a=this.offsetParent(),b=this.offset(),n.nodeName(a[0],"html")||(c=a.offset()),c.top+=n.css(a[0],"borderTopWidth",!0),c.left+=n.css(a[0],"borderLeftWidth",!0)),{top:b.top-c.top-n.css(d,"marginTop",!0),left:b.left-c.left-n.css(d,"marginLeft",!0)}}},offsetParent:function(){return this.map(function(){var a=this.offsetParent||dd;while(a&&!n.nodeName(a,"html")&&"static"===n.css(a,"position"))a=a.offsetParent;return a||dd})}}),n.each({scrollLeft:"pageXOffset",scrollTop:"pageYOffset"},function(a,b){var c=/Y/.test(b);n.fn[a]=function(d){return W(this,function(a,d,e){var f=ed(a);return void 0===e?f?b in f?f[b]:f.document.documentElement[d]:a[d]:void(f?f.scrollTo(c?n(f).scrollLeft():e,c?e:n(f).scrollTop()):a[d]=e)},a,d,arguments.length,null)}}),n.each(["top","left"],function(a,b){n.cssHooks[b]=Mb(l.pixelPosition,function(a,c){return c?(c=Kb(a,b),Ib.test(c)?n(a).position()[b]+"px":c):void 0})}),n.each({Height:"height",Width:"width"},function(a,b){n.each({padding:"inner"+a,content:b,"":"outer"+a},function(c,d){n.fn[d]=function(d,e){var f=arguments.length&&(c||"boolean"!=typeof d),g=c||(d===!0||e===!0?"margin":"border");return W(this,function(b,c,d){var e;return n.isWindow(b)?b.document.documentElement["client"+a]:9===b.nodeType?(e=b.documentElement,Math.max(b.body["scroll"+a],e["scroll"+a],b.body["offset"+a],e["offset"+a],e["client"+a])):void 0===d?n.css(b,c,g):n.style(b,c,d,g)},b,f?d:void 0,f,null)}})}),n.fn.size=function(){return this.length},n.fn.andSelf=n.fn.addBack,"function"==typeof define&&define.amd&&define("jquery",[],function(){return n});var fd=a.jQuery,gd=a.$;return n.noConflict=function(b){return a.$===n&&(a.$=gd),b&&a.jQuery===n&&(a.jQuery=fd),n},typeof b===L&&(a.jQuery=a.$=n),n});
diff --git a/doc/js/page_effects.js b/doc/js/page_effects.js
new file mode 100644
index 0000000..fdacbf8
--- /dev/null
+++ b/doc/js/page_effects.js
@@ -0,0 +1,112 @@
+function visibleInParent(element) {
+ var position = $(element).position().top
+ return position > -50 && position < ($(element).offsetParent().height() - 50)
+}
+
+function hasFragment(link, fragment) {
+ return $(link).attr("href").indexOf("#" + fragment) != -1
+}
+
+function findLinkByFragment(elements, fragment) {
+ return $(elements).filter(function(i, e) { return hasFragment(e, fragment)}).first()
+}
+
+function scrollToCurrentVarLink(elements) {
+ var elements = $(elements);
+ var parent = elements.offsetParent();
+
+ if (elements.length == 0) return;
+
+ var top = elements.first().position().top;
+ var bottom = elements.last().position().top + elements.last().height();
+
+ if (top >= 0 && bottom <= parent.height()) return;
+
+ if (top < 0) {
+ parent.scrollTop(parent.scrollTop() + top);
+ }
+ else if (bottom > parent.height()) {
+ parent.scrollTop(parent.scrollTop() + bottom - parent.height());
+ }
+}
+
+function setCurrentVarLink() {
+ $('.secondary a').parent().removeClass('current')
+ $('.anchor').
+ filter(function(index) { return visibleInParent(this) }).
+ each(function(index, element) {
+ findLinkByFragment(".secondary a", element.id).
+ parent().
+ addClass('current')
+ });
+ scrollToCurrentVarLink('.secondary .current');
+}
+
+var hasStorage = (function() { try { return localStorage.getItem } catch(e) {} }())
+
+function scrollPositionId(element) {
+ var directory = window.location.href.replace(/[^\/]+\.html$/, '')
+ return 'scroll::' + $(element).attr('id') + '::' + directory
+}
+
+function storeScrollPosition(element) {
+ if (!hasStorage) return;
+ localStorage.setItem(scrollPositionId(element) + "::x", $(element).scrollLeft())
+ localStorage.setItem(scrollPositionId(element) + "::y", $(element).scrollTop())
+}
+
+function recallScrollPosition(element) {
+ if (!hasStorage) return;
+ $(element).scrollLeft(localStorage.getItem(scrollPositionId(element) + "::x"))
+ $(element).scrollTop(localStorage.getItem(scrollPositionId(element) + "::y"))
+}
+
+function persistScrollPosition(element) {
+ recallScrollPosition(element)
+ $(element).scroll(function() { storeScrollPosition(element) })
+}
+
+function sidebarContentWidth(element) {
+ var widths = $(element).find('.inner').map(function() { return $(this).innerWidth() })
+ return Math.max.apply(Math, widths)
+}
+
+function calculateSize(width, snap, margin, minimum) {
+ if (width == 0) {
+ return 0
+ }
+ else {
+ return Math.max(minimum, (Math.ceil(width / snap) * snap) + (margin * 2))
+ }
+}
+
+function resizeSidebars() {
+ var primaryWidth = sidebarContentWidth('.primary')
+ var secondaryWidth = 0
+
+ if ($('.secondary').length != 0) {
+ secondaryWidth = sidebarContentWidth('.secondary')
+ }
+
+ // snap to grid
+ primaryWidth = calculateSize(primaryWidth, 32, 13, 160)
+ secondaryWidth = calculateSize(secondaryWidth, 32, 13, 160)
+
+ $('.primary').css('width', primaryWidth)
+ $('.secondary').css('width', secondaryWidth).css('left', primaryWidth + 1)
+
+ if (secondaryWidth > 0) {
+ $('#content').css('left', primaryWidth + secondaryWidth + 2)
+ }
+ else {
+ $('#content').css('left', primaryWidth + 1)
+ }
+}
+
+$(window).ready(resizeSidebars)
+$(window).ready(setCurrentVarLink)
+$(window).ready(function() { persistScrollPosition('.primary')})
+$(window).ready(function() {
+ $('#content').scroll(setCurrentVarLink)
+ $(window).resize(setCurrentVarLink)
+})
diff --git a/pkg/README b/pkg/README
new file mode 100644
index 0000000..90f52ef
--- /dev/null
+++ b/pkg/README
@@ -0,0 +1 @@
+this directory is required by the release process
diff --git a/project.clj b/project.clj
index 6b7163c..118b206 100644
--- a/project.clj
+++ b/project.clj
@@ -1,20 +1,25 @@
-(defproject adl-support "0.1.3"
+(defproject adl-support "0.1.5"
:description "A small library of functions called by generated ADL code."
:url "https://github.com/simon-brooke/adl-support"
:license {:name "MIT License"
:url "https://opensource.org/licenses/MIT"}
: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"]
+ :plugins [[lein-codox "0.10.4"]
[lein-release "1.0.5"]]
- ;; `lein release` doesn't work with `git flow release`. To use
- ;; `lein release`, first merge `develop` into `master`, and then, in branch
- ;; `master`, run `lein release`
+ :deploy-repositories [["releases" :clojars]
+ ["snapshots" :clojars]]
+ :codox {:metadata {:doc "FIXME: write docs"}
+ :output-path "doc"}
+
+ ;; `lein release` doesn't play nice with `git flow release`. Run `lein release` in the
+ ;; `develop` branch, then merge the release tag into the `master` branch.
:release-tasks [["vcs" "assert-committed"]
["clean"]
diff --git a/src/adl_support/core.clj b/src/adl_support/core.clj
index 328ff6c..bb3ae8f 100644
--- a/src/adl_support/core.clj
+++ b/src/adl_support/core.clj
@@ -1,6 +1,12 @@
-(ns adl-support.core
- (:require [clojure.java.io :as io]
- [clojure.string :refer [split]]))
+(ns ^{:doc "Application Description Language support - utility functions likely
+ to be useful in user-written code."
+ :author "Simon Brooke"}
+ adl-support.core
+ (:require [clojure.core.memoize :as memo]
+ [clojure.data.json :as json]
+ [clojure.java.io :as io]
+ [clojure.string :refer [split join]]
+ [clojure.tools.logging]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
@@ -26,71 +32,64 @@
(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."
[k m]
(let [v (m k)
vr (if
(string? v)
(try
- (read-string v)
+ (json/read-str v)
(catch Exception _ nil)))]
(cond
(nil? v) {}
(= v "") {}
- (number? vr) {(keyword k) vr}
+ (and
+ (number? vr)
+ ;; there's a problem that json/read-str will read "07777 888999" as 7777
+ (re-matches #"^[0-9.]+$" v)) {(keyword k) vr}
true
{(keyword k) v})))
-(defn massage-params
+(defn raw-massage-params
+ "Sending empty strings, or numbers as strings, to the database often isn't
+ helpful. Massage these `params` and `form-params` to eliminate these problems.
+ Date and time fields also need massaging."
+ ([request entity]
+ (let
+ [params (:params request)
+ form-params (:form-params request)
+ p (reduce
+ 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))))))
+ ([request]
+ (raw-massage-params request nil)))
+
+
+(def massage-params
"Sending empty strings, or numbers as strings, to the database often isn't
helpful. Massage these `params` and `form-params` to eliminate these problems.
We must take key field values out of just params, but we should take all other
values out of form-params - because we need the key to load the form in
the first place, but just accepting values of other params would allow spoofing."
- [params form-params key-fields]
- (let
- [ks (set (map keyword key-fields))]
- (reduce
- merge
- ;; do the keyfields first, from params
- (reduce
- merge
- {}
- (map
- #(massage-value % params)
- (filter
- #(ks (keyword %))
- (keys params))))
- ;; then merge in everything from form-params, potentially overriding what
- ;; we got from params.
- (map
- #(massage-value % form-params)
- (keys form-params)))))
+ (memo/ttl raw-massage-params {} :ttl/threshold 5000))
(defn
@@ -105,6 +104,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
@@ -116,10 +152,68 @@
`(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 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 intro]
+ `(try
+ {:result ~form}
+ (catch Exception any#
+ {:error (compose-exception-reason any# ~intro)})))
+ ([form]
+ `(do-or-return-reason ~form nil)))
+
+
+(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* (compose-reason-and-log any# ~intro ))
+ nil))))
+
diff --git a/src/adl_support/filters.clj b/src/adl_support/filters.clj
new file mode 100644
index 0000000..7c31b55
--- /dev/null
+++ b/src/adl_support/filters.clj
@@ -0,0 +1,66 @@
+(ns ^{:doc "Application Description Language support - custom Selmer filters
+ used in generated templates."
+ :author "Simon Brooke"}
+ adl-support.filters
+ (:require [clojure.string :as s]
+ [selmer.filters :as f]
+ [selmer.parser :as p]))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;
+;;;; adl-support.filters: selmer filters required by ADL selmer views.
+;;;;
+;;;; 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
+;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(def ^:dynamic *default-international-dialing-prefix*
+ "The international dialing prefix to use, if none is specified."
+ "44")
+
+(defn telephone
+ "If `arg` is, or appears to be, a valid telephone number, convert it into
+ a `tel:` link, else leave it be."
+ [^String arg]
+ (let [number
+ (s/replace
+ (s/replace
+ arg
+ #"^0"
+ (str "+" *default-international-dialing-prefix* "-"))
+ #"\s+" "-")]
+ (if (re-matches #"[0-9 +-]*" arg)
+ [:safe (str "" arg "")]
+ arg)))
+
+
+;; (telephone "07768 130255")
+;; (telephone "Freddy")
+
+(defn email
+ "If `arg` is, or appears to be, a valid email address, convert it into
+ a `mailto:` link, else leave it be."
+ [^String arg]
+ (if (re-matches #"^[A-Za-z0-9._%+-]+@[A-Za-z0-9.-]+\.[A-Za-z]{2,6}$" arg)
+ [:safe (str "" arg "")]
+ arg))
+
+
+;; (email "simon@journeyman.cc")
+;; (email "simon@journeyman")
+;; (email "simon@journeyman.cc.")
+
+(f/add-filter! :telephone telephone)
+
+(f/add-filter! :email email)
+
+;; (p/render "{{p|telephone}}" {:p "07768 130255"})
diff --git a/src/adl_support/forms_support.clj b/src/adl_support/forms_support.clj
new file mode 100644
index 0000000..101f577
--- /dev/null
+++ b/src/adl_support/forms_support.clj
@@ -0,0 +1,124 @@
+(ns ^{:doc "Application Description Language support - functions useful in
+ generating forms."
+ :author "Simon Brooke"}
+ adl-support.forms-support
+ (:require [adl-support.core :refer :all]
+ [adl-support.utils :refer [descendants-with-tag 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
+ "Use the function `f` and these `params` to fetch an `entity` record from the database."
+ [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#]})))
+
+
+(defmacro get-menu-options
+ "Fetch options for a menu of `entity-name` from the database, using this
+ `get-q` query and this `list-q` query, using the key `fk`, where the current
+ value is this `value`."
+ [entity-name get-q list-q fk value]
+ `(remove
+ nil?
+ (flatten
+ (list
+ (if
+ ~value
+ (do-or-log-error
+ (apply
+ ~get-q
+ (list db/*db* {~fk ~value}))
+ :message
+ (str "Error while fetching " ~entity-name " record '" ~value "'")))
+ (do-or-log-error
+ (apply
+ ~list-q
+ (list db/*db*)
+ {})
+ :message
+ (str "Error while fetching " ~entity-name " list"))))))
+
+
+(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))
+
+
+(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))))
+
+
+(defmacro prepare-insertion-params
+ "Params for insertion into the database must have keys for all fields in the
+ insert query, even if the value of some of those keys is nil. Massage these
+ `params` to have a value for each field in these `fields`."
+ ;; TODO: should intelligently handle dates and times, but that might imply
+ ;; access to ADL at runtime!
+ [params fields]
+ `(merge
+ (reduce merge {} (map #(hash-map (keyword %) nil) ~fields))
+ ~params))
+
+
+(defn property-defaults
+ "Get a map of property names and default values for all properties of this
+ `entity` which have explicit defaults."
+ [entity]
+ (reduce
+ merge {}
+ (map
+ #(hash-map (keyword (-> % :attrs :name)) (-> % :attrs :default))
+ (descendants-with-tag entity :property #(-> % :attrs :default)))))
diff --git a/src/adl_support/print_usage.clj b/src/adl_support/print_usage.clj
index 4d05f47..366f70a 100644
--- a/src/adl_support/print_usage.clj
+++ b/src/adl_support/print_usage.clj
@@ -1,4 +1,6 @@
-(ns adl-support.print-usage
+(ns ^{:doc "Application Description Language support - print a usage message."
+ :author "Simon Brooke"}
+ adl-support.print-usage
(:require [clojure.string :refer [join]]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
diff --git a/src/adl_support/rest_support.clj b/src/adl_support/rest_support.clj
new file mode 100644
index 0000000..56c1ade
--- /dev/null
+++ b/src/adl_support/rest_support.clj
@@ -0,0 +1,83 @@
+(ns ^{:doc "Application Description Language support - functions useful in
+ generating JSON route handlers."
+ :author "Simon Brooke"}
+ adl-support.rest-support
+ (: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.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.
+;;;;
+;;;; 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
+;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(defmacro if-valid-user
+ "Evaluate this `form` only if there is a valid user in the session of
+ this `request`; otherwise return the `error-return` value."
+ ;; TODO: candidate for moving to adl-support.core
+ ([form request error-return]
+ `(log/debug "if-valid-user: " (-> ~request :session :user))
+ `(if
+ (-> ~request :session :user)
+ ~form
+ ~error-return))
+ ([form request]
+ (if-valid-user form request nil)))
+
+
+(defmacro valid-user-or-forbid
+ "Evaluate this `form` only if there is a valid user in the session of
+ this `request`; otherwise return an HTTP forbidden response."
+ ;; TODO: candidate for moving to adl-support.core
+ [form request]
+ `(if-valid-user
+ ~form
+ ~request
+ {:status 403
+ :body (json/write-str "You must be logged in to do that")}))
+
+
+(defmacro with-params-or-error
+ "Evaluate this `form` only if these `params` contain all these `required` keys;
+ otherwise return an HTTP 400 response."
+ ;; TODO: candidate for moving to adl-support.core
+ [form params required]
+ `(if-not
+ (some #(not (% ~params)) ~required)
+ ~form
+ {:status 400
+ :body (json/write-str (str "The following params are required: " ~required))}))
+
+
+;; (with-params-or-error (/ 1 0) {:a 1 :b 2} #{:a :b :c})
+;; (with-params-or-error "hello" {:a 1 :b 2} #{:a :b })
+
+(defmacro do-or-server-fail
+ "Evaluate this `form`; if it succeeds, return an HTTP response with this
+ status code and the JSON-formatted result as body; if it fails, return an
+ HTTP 500 response."
+ [form status]
+ `(let [r# (do-or-return-reason ~form)]
+ (if
+ (some #(= :result %) (keys r#)) ;; :result might legitimately be bound to nil
+ {:status ~status
+ :body (:result r#)}
+ {:status 500
+ :body r#})))
+
+
diff --git a/src/adl_support/tags.clj b/src/adl_support/tags.clj
index ccf9908..c808500 100644
--- a/src/adl_support/tags.clj
+++ b/src/adl_support/tags.clj
@@ -1,4 +1,7 @@
-(ns adl-support.tags
+(ns ^{:doc "Application Description Language support - custom Selmer tags used
+ in generated templates."
+ :author "Simon Brooke"}
+ adl-support.tags
(:require [selmer.parser :as p]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
diff --git a/src/adl_support/utils.clj b/src/adl_support/utils.clj
index 191961d..b22cbf1 100644
--- a/src/adl_support/utils.clj
+++ b/src/adl_support/utils.clj
@@ -1,7 +1,8 @@
-(ns ^{:doc "Application Description Language support library - utility functions."
+(ns ^{:doc "Application Description Language support - 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
@@ -79,37 +86,11 @@
(defn sort-by-name
+ "Sort these `elements` by their `:name` attribute."
[elements]
(sort #(compare (:name (:attrs %1)) (:name (:attrs %2))) elements))
-(defn link-table-name
- "Canonical name of a link table between entity `e1` and entity `e2`. However, there
- may be different links between the same two tables with different semantics; if
- `property` is specified, and if more than one property in `e1` links to `e2`, generate
- a more specific link name."
- ([e1 e2]
- (s/join
- "_"
- (cons
- "ln"
- (sort
- (list
- (:name (:attrs e1)) (:name (:attrs e2)))))))
- ([property e1 e2]
- (if (count
- (descendants
- e1
- #(and
- (= (-> % :attrs :type) "link")
- (=
- (-> % :attrs :entity)
- (-> property :attrs :entity)))))
- (s/join
- "_" (cons "ln" (map #(:name (:attrs %)) (list property e1 e2))))
- (link-table-name e1 e2))))
-
-
(defn children
"Return the children of this `element`; if `predicate` is passed, return only those
children satisfying the predicate."
@@ -281,36 +262,128 @@
" "
(map
#(apply str (cons (Character/toUpperCase (first %)) (rest %)))
- (s/split s #"[ \t\r\n]+")))
+ (s/split s #"[^a-zA-Z0-9]+")))
s))
(defn pretty-name
- [entity]
- (capitalise (singularise (:name (:attrs entity)))))
+ "Return a version of the name of this `element` (entity, field,
+ form, list, page, property) suitable for use in text visible to the user."
+ [element]
+ (capitalise (singularise (:name (:attrs element)))))
(defn safe-name
"Return a safe name for the object `o`, given the specified `convention`.
- `o` is expected to be either a string or an element."
+ `o` is expected to be either a string or an element. Recognised values for
+ `convention` are: #{:c :c-sharp :java :sql}"
([o]
- (if
+ (cond
(element? o)
(safe-name (:name (:attrs o)))
+ true
(s/replace (str o) #"[^a-zA-Z0-9-]" "")))
([o convention]
- (if
+ (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)
+ (and (property? o) (= convention :sql))
+ ;; if it's a property, it's entitle to have a different column name
+ ;; from its property name.
+ (safe-name (or (-> o :attrs :column) (-> o :attrs :name)) :sql)
(element? o)
(safe-name (:name (:attrs o)) convention)
- (let [string (str o)]
+ true
+ (let [string (str o)
+ capitalised (capitalise string)]
(case convention
(:sql :c) (s/replace string #"[^a-zA-Z0-9_]" "_")
- :c-sharp (s/replace (capitalise string) #"[^a-zA-Z0-9]" "")
+ :c-sharp (s/replace capitalised #"[^a-zA-Z0-9]" "")
:java (let
- [camel (s/replace (capitalise string) #"[^a-zA-Z0-9]" "")]
+ [camel (s/replace capitalised #"[^a-zA-Z0-9]" "")]
(apply str (cons (Character/toLowerCase (first camel)) (rest camel))))
(safe-name string))))))
+;; (safe-name "address-id" :sql)
+;; (safe-name {:tag :property :attrs {:name "address-id"}} :sql)
+
+
+(defn unique-link?
+ "True if there is exactly one link between entities `e1` and `e2`."
+ [e1 e2]
+ (let [n1 (count (children-with-tag e1 :property
+ #(and (= (-> % :attrs :type) "link")
+ (= (-> % :attrs :entity)(-> e2 :attrs :name)))))
+ n2 (count (children-with-tag e2 :property
+ #(and (= (-> % :attrs :type) "link")
+ (= (-> % :attrs :entity)(-> e1 :attrs :name)))))]
+ (= (max n1 n2) 1)))
+
+
+(defn link-related-query-name
+ "link is tricky. If there's exactly than one link between the two
+ entities, we need to generate the same name from both
+ ends of the link"
+ [property nearside farside]
+ (if (unique-link? nearside farside)
+ (let [ordered (sort-by #(-> % :attrs :name) (list nearside farside))]
+ (str "list-"
+ (safe-name (first ordered) :sql)
+ "-by-"
+ (safe-name (nth ordered 1) :sql)))
+ (str "list-"
+ (safe-name property :sql) "-by-"
+ (singularise (safe-name nearside :sql)))))
+
+
+(defn link-table-name
+ "Canonical name of a link table between entity `e1` and entity `e2`. However, there
+ may be different links between the same two tables with different semantics; if
+ `property` is specified, and if more than one property in `e1` links to `e2`, generate
+ a more specific link name."
+ ([e1 e2]
+ (s/join
+ "_"
+ (cons
+ "ln"
+ (sort
+ (list
+ (:name (:attrs e1)) (:name (:attrs e2)))))))
+ ([property e1 e2]
+ (if (unique-link? e1 e2)
+ (link-table-name e1 e2)
+ (s/join
+ "_" (cons "ln" (map #(:name (:attrs %)) (list property e1)))))))
+
+
+(defn 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."
+ [property nearside farside]
+ (if
+ (and
+ (property? property)
+ (entity? nearside)
+ (entity? farside))
+ (case (-> property :attrs :type)
+ "link" (link-related-query-name property nearside farside)
+ "list" (str "list-"
+ (safe-name farside :sql) "-by-"
+ (singularise (safe-name nearside :sql)))
+ "entity" (str "list-"
+ (safe-name nearside :sql) "-by-"
+ (singularise (safe-name farside :sql)))
+ ;; default
+ (str "ERROR-bad-property-type-"
+ (-> ~property :attrs :type) "-of-"
+ (-> ~property :attrs :name)))
+ (do
+ (*warn* "Argument passed to `list-related-query-name` was a non-entity")
+ nil)))
+
(defn property-for-field
"Return the property within this `entity` which matches this `field`."
@@ -396,13 +469,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 (#{"link" "list"} (:type (:attrs property))))
+ (not (system-generated? property))))
(defmacro all-properties
@@ -426,6 +509,14 @@
(user-distinct-properties entity))))
+(defn column-name
+ "Return, as a string, the name for the column which represents this `property`."
+ [property]
+ (safe-name
+ (or (-> property :attrs :column) (-> property :attrs :name))
+ :sql))
+
+
(defmacro insertable-properties
"Return all the properties of this `entity` (including key properties) into
which user-supplied data can be inserted"
@@ -435,6 +526,17 @@
(all-properties ~entity)))
+(defn required-properties
+ "Return the properties of this `entity` which are required and are not
+ system generated."
+ [entity]
+ (filter
+ #(and
+ (= (:required (:attrs %)) "true")
+ (not (system-generated? %)))
+ (descendants-with-tag entity :property)))
+
+
(defmacro key-properties
[entity]
`(children-with-tag (first (children-with-tag ~entity :key)) :property))
@@ -523,14 +625,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 b86e00e..cd0d4c8 100644
--- a/test/adl_support/core_test.clj
+++ b/test/adl_support/core_test.clj
@@ -2,43 +2,60 @@
(: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}
- actual (massage-params {:id 67} {} #{:id})]
- (is (= expected actual) "numeric param"))
- (let [expected {:id 67}
- actual (massage-params {:id "67"} {} #{:id})]
- (is (= expected actual) "string param"))
- (let [expected {:id 67}
- actual (massage-params {"id" "67"} {} #{:id})]
- (is (= expected actual) "string keyword"))
- (let [expected {:id 67}
- actual (massage-params {:id 60} {:id 67} #{:id})]
- (is (= expected actual) "params and form-params differ"))
(let [expected {:id 67 :offset 0 :limit 50}
- actual (massage-params {:id 60} {:id "67" :offset "0" :limit "50"} #{:id})]
- (is (= expected actual) "Limit and offset in form-params"))
- ))
+ actual (massage-params {:params {:id "67" :offset "0" :limit "50"} :form-params {}})]
+ (is (= expected actual) "Request with no form params"))
+ (let [expected {:id 67 :offset 0 :limit 50}
+ actual (massage-params {:params {:id "0" :offset "1000" :limit "150"}
+ :form-params {:id "67" :offset "0" :limit "50"}})]
+ (is (= expected actual) "Request with form params, params and form params differ"))
+ (let [expected {:phone "07777 888999"}
+ actual (massage-params {:params {:phone "07777 888999"}})]
+ (is (= expected actual) "A phone number with a space in needs to be treated as a string"))))
+
+
+(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"))
+ (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?
+;; (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"))
+;; ))
diff --git a/test/adl_support/forms_support_test.clj b/test/adl_support/forms_support_test.clj
new file mode 100644
index 0000000..20f94c4
--- /dev/null
+++ b/test/adl_support/forms_support_test.clj
@@ -0,0 +1,34 @@
+(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..."))))
+
+
+(deftest prepare-insertion-params-tests
+ (testing "prepare-insertion-params"
+ (is (= {:test1 nil :test2 nil}
+ (prepare-insertion-params {} #{:test1 :test2}))
+ "Empty params; set")
+ (is (= {:test1 nil :test2 nil}
+ (prepare-insertion-params {} '(:test1 :test2)))
+ "Empty params; list")
+ (is (= {:test1 nil :test2 nil :test3 6}
+ (prepare-insertion-params {:test3 6} #{:test1 :test2}))
+ "Unlisted param; set")
+ (is (= {:test1 "foo" :test2 nil}
+ (prepare-insertion-params {:test1 "foo"} '(:test1 :test2)))
+ "Listed param; list")
+ (is (= {:test1 "foo" :test2 6}
+ (prepare-insertion-params {:test1 "foo" :test2 6} '(:test1 :test2)))
+ "Listed params; list")))
diff --git a/test/adl_support/rest_support_test.clj b/test/adl_support/rest_support_test.clj
new file mode 100644
index 0000000..2f51709
--- /dev/null
+++ b/test/adl_support/rest_support_test.clj
@@ -0,0 +1,38 @@
+(ns adl-support.rest-support-test
+ (:require [clojure.test :refer :all]
+ [adl-support.rest-support :refer :all]))
+
+
+(deftest if-valid-user-tests
+ (testing "correct handling of if-valid-user"
+ (let [expected "hello"
+ actual (if-valid-user "hello" {:session {:user {:id 4}}} "goodbye")]
+ (is (= expected actual) "User in session"))
+ (let [expected "goodbye"
+ actual (if-valid-user "hello" {:session {}} "goodbye")]
+ (is (= expected actual) "No user in session"))))
+
+
+(deftest valid-user-or-forbid-tests
+ (testing "valid-user-or-forbid"
+ (let [expected "hello"
+ 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 {}}))]
+ (is (= expected actual) "No user in session"))))
+
+
+(deftest with-params-or-error-tests
+ (let [expected "hello"
+ actual (with-params-or-error "hello" {:a 1 :b 2} #{:a :b})]
+ (is (= expected actual) "All requirements satisfied"))
+ (let [expected "hello"
+ actual (with-params-or-error "hello" {:a 1 :b 2 :c 3} #{:a :b})]
+ (is (= expected actual) "Unrequired parameter present"))
+ (let [expected 400
+ actual (:status (with-params-or-error "hello" {:a 1 :b 2} #{:a :b :c}))]
+ (is (= expected actual) "Some requirements unsatisfied"))
+ (let [expected 400
+ actual (:status (with-params-or-error (/ 1 0) {:a 1 :b 2} #{:a :b :c}))]
+ (is (= expected actual) "Exception should not be throwen")))
diff --git a/test/adl_support/utils_test.clj b/test/adl_support/utils_test.clj
index 13280ca..4499eb7 100644
--- a/test/adl_support/utils_test.clj
+++ b/test/adl_support/utils_test.clj
@@ -1,9 +1,17 @@
(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.
+(deftest singularise-tests
+ (testing "Singularise"
+ (is (= "address" (singularise "addresses")))
+ (is (= "address" (singularise "address")))
+ (is (= "expertise" (singularise "expertise")))))
+
+
(deftest child-with-tag-tests
(testing "child-with-tag"
(let [expected {:tag :prompt
@@ -297,3 +305,296 @@
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}]}]}
+ property (child e2 #(= (-> % :attrs :name) "gender"))
+ expected "list-electors-by-gender"
+ actual (list-related-query-name property e2 e1)]
+ (is (= expected actual) "just checking..."))
+ (let [e1 {:tag :entity
+ :attrs {:name "dwellings"}
+ :content [{:tag :key
+ :content [{:tag :property
+ :attrs {:name "id" :type "integer" :distinct "system"}}]}
+ {:tag :property
+ :attrs {:name "address" :type "entity" :entity "addresses"}}]}
+ e2 {:tag :entity
+ :attrs {:name "addresses"}
+ :content [{:tag :key
+ :content [{:tag :property
+ :attrs {:name "id" :type "integer" :distinct "system"}}]}
+ {:tag :property
+ :attrs {:name "dwellings" :type "list" :entity "dwellings"}}]}]
+ (let [property {:tag :property
+ :attrs {:name "address" :type "entity" :entity "addresses"}}
+ expected "list-dwellings-by-address"
+ actual (list-related-query-name property e1 e2)]
+ (is (= expected actual) "Entity property"))
+ (let [property {:tag :property
+ :attrs {:name "dwellings" :type "list" :entity "dwellings"}}
+ expected "list-dwellings-by-address"
+ actual (list-related-query-name property e2 e1)]
+ (is (= expected actual) "List property")))
+ (let [e1 {:tag :entity
+ :attrs {:name "teams"}
+ :content [{:tag :key
+ :content [{:tag :property
+ :attrs {:name "id" :type "integer" :distinct "system"}}]}
+ {:tag :property
+ :attrs {:name "members" :type "link" :entity "canvassers"}}
+ {:tag :property
+ :attrs {:name "organisers" :type "link" :entity "canvassers"}}]}
+ e2 {:tag :entity
+ :attrs {:name "canvassers"}
+ :content [{:tag :key
+ :content [{:tag :property
+ :attrs {:name "id" :type "integer" :distinct "system"}}]}
+ {:tag :property
+ :attrs {:name "memberships" :type "link" :entity "teams"}}]}]
+ (let [property {:tag :property
+ :attrs {:name "members" :type "link" :entity "canvassers"}}
+ expected "list-members-by-team"
+ actual (list-related-query-name property e1 e2)]
+ (is (= actual expected) "Link property - members"))
+ (let [property {:tag :property
+ :attrs {:name "organisers" :type "link" :entity "canvassers"}}
+ expected "list-organisers-by-team"
+ actual (list-related-query-name property e1 e2)]
+ (is (= actual expected) "Link property - organisers"))
+ (let [property {:tag :property
+ :attrs {:name "memberships" :type "link" :entity "teams"}}
+ expected "list-memberships-by-canvasser"
+ actual (list-related-query-name property e2 e1)]
+ (is (= actual expected) "Link property - membersips")))))
+
+
+(deftest link-table-name-tests
+ (testing "link-table-name"
+ (let [e1 {:tag :entity
+ :attrs {:name "teams"}
+ :content [{:tag :key
+ :content [{:tag :property
+ :attrs {:name "id" :type "integer" :distinct "system"}}]}
+ {:tag :property
+ :attrs {:name "members" :type "link" :entity "canvassers"}}
+ {:tag :property
+ :attrs {:name "organisers" :type "link" :entity "canvassers"}}]}
+ e2 {:tag :entity
+ :attrs {:name "canvassers"}
+ :content [{:tag :key
+ :content [{:tag :property
+ :attrs {:name "id" :type "integer" :distinct "system"}}]}
+ {:tag :property
+ :attrs {:name "memberships" :type "link" :entity "teams"}}
+ {:tag :property
+ :attrs {:name "roles" :type "link" :entity "roles"}}]}
+ e3 {:tag :entity
+ :attrs {:name "roles"}
+ :content [{:tag :key
+ :content [{:tag :property
+ :type "string"
+ :distinct "all"
+ :name "id"}]}]}]
+ (let [property {:tag :property
+ :attrs {:name "members" :type "link" :entity "canvassers"}}
+ expected "ln_members_teams"
+ actual (link-table-name property e1 e2)]
+ (is (= actual expected) "Link property - members"))
+ (let [property {:tag :property
+ :attrs {:name "organisers" :type "link" :entity "canvassers"}}
+ expected "ln_organisers_teams"
+ actual (link-table-name property e1 e2)]
+ (is (= actual expected) "Link property - organisers"))
+ (let [property {:tag :property
+ :attrs {:name "memberships" :type "link" :entity "teams"}}
+ expected "ln_memberships_canvassers"
+ actual (link-table-name property e2 e1)]
+ (is (= actual expected) "Link property - membersips"))
+ (let [property {:tag :property
+ :attrs {:name "roles" :type "link" :entity "roles"}}
+ expected "ln_canvassers_roles"
+ actual (link-table-name property e2 e3)]
+ (is (= actual expected) "Link property - roles")))))
+
+
+(deftest unique-link-tests
+ (testing "unique-link?"
+ (let [e1 {:tag :entity
+ :attrs {:name "teams"}
+ :content [{:tag :key
+ :content [{:tag :property
+ :attrs {:name "id" :type "integer" :distinct "system"}}]}
+ {:tag :property
+ :attrs {:name "members" :type "link" :entity "canvassers"}}
+ {:tag :property
+ :attrs {:name "organisers" :type "link" :entity "canvassers"}}]}
+ e2 {:tag :entity
+ :attrs {:name "canvassers"}
+ :content [{:tag :key
+ :content [{:tag :property
+ :attrs {:name "id" :type "integer" :distinct "system"}}]}
+ {:tag :property
+ :attrs {:name "memberships" :type "link" :entity "teams"}}
+ {:tag :property
+ :attrs {:name "roles" :type "link" :entity "roles"}}]}
+ e3 {:tag :entity
+ :attrs {:name "roles"}
+ :content [{:tag :key
+ :content [{:tag :property
+ :type "string"
+ :distinct "all"
+ :name "id"}]}]}]
+ (is (= false (unique-link? e1 e2)) "There are two logical links, three link properties, between e1 and e2")
+ (is (= true (unique-link? e2 e3)) "There is only one link between e2 and e3"))))
+
+(deftest capitalise-tests
+ (testing "capitalise"
+ (is (= (capitalise "the quick brown fox jumped over the lazy dog") "The Quick Brown Fox Jumped Over The Lazy Dog"))))
+
+(deftest safe-name-tests
+ (testing "safe-name"
+ (let [e1 {:tag :entity
+ :attrs {:name "canvass-teams" :table "team"}
+ :content [{:tag :key
+ :content [{:tag :property
+ :attrs {:name "id" :type "integer" :distinct "system"}}]}
+ {:tag :property
+ :attrs {:name "members" :type "link" :entity "canvassers"}}
+ {:tag :property
+ :attrs {:name "organisers" :type "link" :entity "canvassers"}}]}
+ p1 {:tag :property
+ :attrs {:name "id" :type "integer" :distinct "system"}}
+ p2 {:tag :property
+ :attrs {:name "with_underscore" :column "with-hyphen" :type "integer"}}]
+ (is
+ (= (safe-name "the quick brown fox jumped over the lazy dog")
+ "thequickbrownfoxjumpedoverthelazydog")
+ "absent a convention, spaces are suppressed")
+ (is
+ (= (safe-name "the quick brown fox jumped over the lazy dog" :c)
+ "the_quick_brown_fox_jumped_over_the_lazy_dog")
+ "in :c convention, spaces are replaced with underscores")
+ (is
+ (= (safe-name "the quick brown fox jumped over the lazy dog" :c-sharp)
+ "TheQuickBrownFoxJumpedOverTheLazyDog")
+ "in :c-sharp convention spaces are suppressed and all words camel cased")
+ (is
+ (= (safe-name "the quick brown fox jumped over the lazy dog" :java)
+ "theQuickBrownFoxJumpedOverTheLazyDog")
+ "in :java convention spaces are suppressed and embedded words camel cased")
+ (is
+ (= (safe-name "the quick brown fox jumped over the lazy dog" :sql)
+ "the_quick_brown_fox_jumped_over_the_lazy_dog")
+ "in :sql convention, spaces are replaced with underscores")
+ (is (= (safe-name e1) "canvass-teams"))
+ (is (= (safe-name e1 :c) "canvass_teams")
+ "In :c convention, hyphen is replaced by underscore")
+ (is (= (safe-name e1 :c-sharp) "CanvassTeams")
+ "In :c-sharp convention, hyphen is suppressed and words capitalised")
+ (is (= (safe-name e1 :java) "canvassTeams")
+ "In :java convention, hyphen is suppressed and embedded words capitalised")
+ (is (= (safe-name e1 :sql) "team")
+ "In :sql convention, the :table attribute is preferred")
+ (is (= (safe-name p1) "id"))
+ (is (= (safe-name p1 :c) "id"))
+ (is (= (safe-name p1 :c-sharp) "Id"))
+ (is (= (safe-name p1 :java) "id"))
+ (is (= (safe-name p1 :sql) "id"))
+ (is (= (safe-name p2) "withunderscore")
+ "Absent a convention, underscore is not considered safe")
+ (is (= (safe-name p2 :c) "with_underscore")
+ "In :c convention, underscore is considered safe")
+ (is (= (safe-name p2 :c-sharp) "WithUnderscore")
+ "In :c-sharp convention, initial letters are capialised and underscore is suppressed")
+ (is (= (safe-name p2 :java) "withUnderscore")
+ "In :java convention, underscore is suppressed and embedded words capitalised")
+ (is (= (safe-name p2 :sql) "with_hyphen")
+ "In :sql convention, the column-name variant is preferred, and hyphens replaced with underscores"))))
+
+
+(deftest key-names-tests
+ (testing "key-names"
+ (let [e1 {:tag :entity
+ :attrs {:name "canvass-teams" :table "team"}
+ :content [{:tag :key
+ :content [{:tag :property
+ :attrs {:name "id" :type "integer" :distinct "system"}}]}
+ {:tag :property
+ :attrs {:name "members" :type "link" :entity "canvassers"}}
+ {:tag :property
+ :attrs {:name "organisers" :type "link" :entity "canvassers"}}]}
+ e2 {:tag :entity
+ :attrs {:name "canvass-teams" :table "team"}
+ :content [{:tag :key
+ :content [{:tag :property
+ :attrs {:name "id" :type "integer" :distinct "system"}}
+ {:tag :property
+ :attrs {:name "shard" :type "string" :default "SW"}}]}
+ {:tag :property
+ :attrs {:name "members" :type "link" :entity "canvassers"}}
+ {:tag :property
+ :attrs {:name "organisers" :type "link" :entity "canvassers"}}]}]
+ (is (= (key-names e1) #{"id"}))
+ (is (= (key-names e1 true) #{:id}))
+ (is (= (key-names e2) #{"id" "shard"}))
+ (is (= (key-names e2 true) #{:id :shard})))))
+