diff --git a/src/adl_support/core.clj b/src/adl_support/core.clj index 2a3630b..ccfee77 100644 --- a/src/adl_support/core.clj +++ b/src/adl_support/core.clj @@ -53,9 +53,9 @@ (cond (nil? v) {} (= v "") {} - (number? vr) {k vr} + (number? vr) {(keyword k) vr} true - {k v}))) + {(keyword k) v}))) (defn massage-params @@ -65,22 +65,24 @@ 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] - (reduce - merge - ;; do the keyfields first, from params - (reduce - merge - {} - (map - #(massage-value % params) - (filter - #(key-fields (str (name %))) - (keys params)))) - ;; then merge in everything from form-params, potentially overriding what - ;; we got from params. - (map - #(massage-value % form-params) - (keys form-params)))) + (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))))) (defn diff --git a/src/adl_support/print_usage.clj b/src/adl_support/print_usage.clj new file mode 100644 index 0000000..4d05f47 --- /dev/null +++ b/src/adl_support/print_usage.clj @@ -0,0 +1,52 @@ +(ns adl-support.print-usage + (:require [clojure.string :refer [join]])) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; adl-support.print-usage: functions used by ADL-generated code. +;;;; +;;;; 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 print-usage + "Print a UN*X style usage message. `project-name` should be the base name of + the executable jar file you generate, `parsed-options` should be options as + parsed by [clojure.tools.cli](https://github.com/clojure/tools.cli). If + `extra-args` is supplied, it should be a map of name, documentation pairs + for each additional argument which may be supplied." + ([project-name parsed-options] + (print-usage project-name parsed-options {})) + ([project-name parsed-options extra-args] + (println + (join + "\n" + (flatten + (list + (join " " + (concat + (list + "Usage: java -jar " + (str + project-name + "-" + (or (System/getProperty (str project-name ".version")) "[VERSION]") + "-standalone.jar") + "-options") + (map name (keys extra-args)))) + "where options include:" + (:summary parsed-options) + (doall + (map + #(str " " (name %) "\t\t" (extra-args %)) + (keys extra-args))))))))) + diff --git a/src/adl_support/utils.clj b/src/adl_support/utils.clj index 4a0ae45..91cec89 100644 --- a/src/adl_support/utils.clj +++ b/src/adl_support/utils.clj @@ -27,7 +27,7 @@ (def ^:dynamic *locale* "The locale for which files will be generated." - "en-GB") + "en_GB.UTF-8") (def ^:dynamic *output-path* "The path to which generated files will be written." @@ -108,7 +108,7 @@ (-> % :attrs :entity) (-> property :attrs :entity))))) (s/join - "_" (map #(:name (:attrs %)) (list property e1 e2))) + "_" (cons "ln" (map #(:name (:attrs %)) (list property e1 e2)))) (link-table-name e1 e2)))) @@ -170,7 +170,6 @@ (first (children-with-tag element tag predicate)))) - (defn typedef "If this `property` is of type `defined`, return its type definition from this `application`, else nil." @@ -246,13 +245,17 @@ (permission-groups permissions #(#{"read" "insert" "noedit" "edit" "all"} (:permission (:attrs %))))) -(defn writable-by +(defn writeable-by "Return a list of names of groups to which are granted write access, given these `permissions`, else nil. - TODO: TOTHINKABOUT: properties are also writable by `insert` and `noedit`, but only if the + TODO: TOTHINKABOUT: properties are also writeable by `insert` and `noedit`, but only if the current value is nil." - [permissions] - (permission-groups permissions #(#{"edit" "all"} (:permission (:attrs %))))) + ([permissions] + (writeable-by permissions true)) + ([permissions has-value?] + (let + [privileges (if has-value? #{"edit" "all"} #{"edit" "all" "insert" "noedit"})] + (permission-groups permissions #(privileges (:permission (:attrs %))))))) (defn singularise @@ -274,11 +277,14 @@ (defn capitalise "Return a string like `s` but with each token capitalised." [s] - (s/join - " " - (map - #(apply str (cons (Character/toUpperCase (first %)) (rest %))) - (s/split s #"[ \t\r\n]+")))) + (if + (string? s) + (s/join + " " + (map + #(apply str (cons (Character/toUpperCase (first %)) (rest %))) + (s/split s #"[ \t\r\n]+"))) + s)) (defn pretty-name @@ -288,7 +294,7 @@ (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 entity." + `o` is expected to be either a string or an element." ([o] (if (element? o) @@ -308,6 +314,45 @@ (safe-name string)))))) +(defn property-for-field + "Return the property within this `entity` which matches this `field`." + [field entity] + (child-with-tag + entity + :property + #(= + (-> field :attrs :property) + (-> % :attrs :name)))) + + +(defn prompt + "Return an appropriate prompt for the given `field-or-property` taken from this + `form` of this `entity` of this `application`, in the context of the current + binding of `*locale*`. TODO: something more sophisticated about i18n" + [field-or-property form entity application] + (let [property (case (:tag field-or-property) + :property field-or-property + :field (property-for-field field-or-property entity) + nil)] + (capitalise + (or + (:prompt + (:attrs + (child-with-tag + field-or-property + :prompt + #(= (:locale (:attrs %)) *locale*)))) + (:prompt + (:attrs + (child-with-tag + property + :prompt + #(= (:locale (:attrs %)) *locale*)))) + (:name (:attrs property)) + (:property (:attrs field-or-property)) + "Missing prompt")))) + + (defmacro properties "Return all the properties of this `entity`." [entity] @@ -315,16 +360,30 @@ (defn descendants-with-tag - "Return all descendants of this `element`, recursively, which have this `tag`." - [element tag] - (flatten - (remove - empty? - (cons - (children element #(= (:tag %) tag)) - (map - #(descendants-with-tag % tag) - (children element)))))) + "Return all descendants of this `element`, recursively, which have this `tag`. + If `predicate` is specified, return only those also satisfying this `predicate`." + ([element tag] + (flatten + (remove + empty? + (cons + (children element #(= (:tag %) tag)) + (map + #(descendants-with-tag % tag) + (children element)))))) + ([element tag predicate] + (filter + predicate + (descendants-with-tag element tag)))) + + +(defn descendant-with-tag + "Return the first descendant of this `element`, recursively, which has this `tag`. + If `predicate` is specified, return the first also satisfying this `predicate`." + ([element tag] + (first (descendants-with-tag element tag))) + ([element tag predicate] + (first (descendants-with-tag element tag predicate)))) (defn find-permissions @@ -396,13 +455,20 @@ (= (count properties) (count links)))) -(defn key-names [entity] +(defn key-names + ([entity] (set (remove nil? (map #(:name (:attrs %)) (key-properties entity))))) + ([entity as-keywords?] + (let [names (key-names entity)] + (if + as-keywords? + (set (map keyword names)) + names)))) (defn base-type diff --git a/test/adl_support/core_test.clj b/test/adl_support/core_test.clj index 073b364..b86e00e 100644 --- a/test/adl_support/core_test.clj +++ b/test/adl_support/core_test.clj @@ -24,3 +24,21 @@ (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")) + )) diff --git a/test/adl_support/utils_test.clj b/test/adl_support/utils_test.clj new file mode 100644 index 0000000..13280ca --- /dev/null +++ b/test/adl_support/utils_test.clj @@ -0,0 +1,299 @@ +(ns adl-support.utils-test + (:require [clojure.test :refer :all] + [adl-support.utils :refer :all])) + +;; Yes, there's MASSES in utils which ought to be tested. I'll add more tests over time. + +(deftest child-with-tag-tests + (testing "child-with-tag" + (let [expected {:tag :prompt + :attrs {:prompt "test" + :locale "en_GB.UTF-8"}} + actual (child-with-tag {:tag :property + :attrs {:name "not test"} + :content [{:tag :prompt + :attrs {:prompt "test" + :locale "en_GB.UTF-8"}}]} + :prompt)] + (is (= expected actual) "Basic search for one child which exists")) + (let [expected nil + actual (child-with-tag {:tag :property + :attrs {:name "not test"} + :content [{:tag :prompt + :attrs {:prompt "test" + :locale "en_GB.UTF-8"}}]} + :frobox)] + (is (= expected actual) "Basic search for one child which doesn't exist")) + (let [expected nil + actual (child-with-tag nil :frobox)] + (is (= expected actual) "Basic search with nil element")) + (let [expected {:tag :prompt + :attrs {:prompt "test" + :locale "en_GB.UTF-8"}} + actual (child-with-tag {:tag :property + :attrs {:name "not test"} + :content [{:tag :frobox} + {:tag :prompt + :attrs {:prompt "test" + :locale "en_GB.UTF-8"}}]} + :prompt)] + (is (= expected actual) "Basic search for one child which exists but is not first")) + (let [expected {:tag :prompt + :attrs {:prompt "test" + :locale "en_GB.UTF-8"}} + actual (child-with-tag {:tag :property + :attrs {:name "not test"} + :content [{:tag :prompt + :attrs {:prompt "essai" + :locale "fr-FR"}} + {:tag :prompt + :attrs {:prompt "test" + :locale "en_GB.UTF-8"}}]} + :prompt + #(= (-> % :attrs :locale) "en_GB.UTF-8"))] + (is (= expected actual) "Conditional search for one child which exists (1)")) + (let [*locale* "fr-FR" + expected {:tag :prompt + :attrs {:prompt "essai" + :locale "fr-FR"}} + actual (child-with-tag {:tag :property + :attrs {:name "not test"} + :content [{:tag :prompt + :attrs {:prompt "essai" + :locale "fr-FR"}} + {:tag :prompt + :attrs {:prompt "test" + :locale "en_GB.UTF-8"}}]} + :prompt + #(= (-> % :attrs :locale) "fr-FR"))] + (is (= expected actual) "Conditional search for one child which exists (2)")) + )) + + +(deftest prompt-tests + (testing "Prompts for fields and properties" + (let [*locale* "en_GB.UTF-8" + expected "Test" + actual (prompt {:tag :property + :attrs {:name "not test"} + :content [{:tag :prompt + :attrs {:prompt "test" + :locale "en_GB.UTF-8"}}]} + {} + {} + {})] + (is (= expected actual) "Basic property with one prompt in current locale")) + (let [*locale* "en_GB.UTF-8" + expected "Test" + actual (prompt {:tag :field + :attrs {:property "not-test"} + :content [{:tag :prompt + :attrs {:prompt "test" + :locale "en_GB.UTF-8"}}]} + {} + {} + {})] + (is (= expected actual) "Basic field with one prompt in current locale")) + (let [*locale* "en_GB.UTF-8" + expected "Test" + actual (prompt {:tag :field + :attrs {:property "not-test"}} + {} + {:tag :entity + :content [{:tag :property + :attrs {:name "not-test"} + :content [{:tag :prompt + :attrs {:prompt "test" + :locale "en_GB.UTF-8"}}]}]} + {})] + (is (= expected actual) "Basic field with no prompt, in context of entity + with appropriate property with prompt in current locale")) + (let [*locale* "en_GB.UTF-8" + expected "Home" + actual (prompt {:tag :field, + :attrs {:property "dwelling_id"}} + {} + {:tag :entity, + :attrs + {:volatility "5", + :magnitude "6", + :name "electors", + :table "electors"}, + :content + [{:tag :documentation, + :attrs nil, + :content + ["All electors known to the system; electors are\n people believed to be entitled to vote in the current\n campaign."]} + {:tag :key, + :attrs nil, + :content + [{:tag :property, + :attrs + {:distinct "system", + :immutable "true", + :column "id", + :name "id", + :type "integer", + :required "true"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "id"}, + :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 + {:farkey "id", + :entity "dwellings", + :column "dwelling_id", + :name "dwelling_id", + :type "entity", + :required "true"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "Home"}, + :content nil}]} + {:tag :property, + :attrs {:column "phone", :name "phone", :type "string", :size "16"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "Phone"}, + :content nil}]} + {:tag :property, + :attrs + {:column "email", :name "email", :type "string", :size "128"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "Email"}, + :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}]} + {:tag :property, + :attrs {:type "text", :name "signature"}, + :content + [{:tag :documentation, + :attrs nil, + :content + ["The signature of this elector, captured as SVG text,\n as evidence they have consented to us holding data on them.\n Null if they have not."]}]} + {:tag :list, + :attrs {:name "Electors", :properties "listed"}, + :content + [{:tag :field, + :attrs {:property "id"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "id"}, + :content nil}]} + {:tag :field, + :attrs {:property "name"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "Name"}, + :content nil}]} + {:tag :field, + :attrs {:property "dwelling_id"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "Home"}, + :content nil}]} + {:tag :field, + :attrs {:property "phone"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "Phone"}, + :content nil}]} + {:tag :field, + :attrs {:property "email"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "eMail"}, + :content nil}]} + {:tag :field, + :attrs {:property "gender"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "Gender"}, + :content nil}]}]} + {:tag :form, + :attrs {:name "Elector", :properties "listed"}, + :content + [{:tag :field, + :attrs {:property "id"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "id"}, + :content nil}]} + {:tag :field, + :attrs {:property "name"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "Name"}, + :content nil}]} + {:tag :field, + :attrs {:property "dwelling_id"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "Home"}, + :content nil}]} + {:tag :field, + :attrs {:property "phone"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "Phone"}, + :content nil}]} + {:tag :field, + :attrs {:property "email"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "eMail"}, + :content nil}]} + {:tag :field, + :attrs {:property "gender"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "Gender"}, + :content nil}]}]} + {:tag :permission, + :attrs {:permission "read", :group "canvassers"}, + :content nil} + {:tag :permission, + :attrs {:permission "read", :group "teamorganisers"}, + :content nil} + {:tag :permission, + :attrs {:permission "read", :group "issueexperts"}, + :content nil} + {:tag :permission, + :attrs {:permission "read", :group "analysts"}, + :content nil} + {:tag :permission, + :attrs {:permission "read", :group "issueeditors"}, + :content nil} + {:tag :permission, + :attrs {:permission "all", :group "admin"}, + :content nil}]} + + {})] + (is (= expected actual) "With realistic clutter: field with no prompt, in context of entity + with appropriate property with prompt in current locale")) + )) +