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

Separated out print-usage into a new support namespace.

Browse source 
Also new unit tests.
This commit is contained in:
Simon Brooke 2018-07-18 15:04:33 +01:00
parent 9db4e48638
commit 0e613f6d40
5 changed files with 479 additions and 42 deletions
Download patch file Download diff file Expand all files Collapse all files

38
src/adl_support/core.clj
View file

@ -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

52
src/adl_support/print_usage.clj Normal file
View file

@ -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)))))))))

114
src/adl_support/utils.clj
View file

@ -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

18
test/adl_support/core_test.clj
View file

@ -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"))
))

299
test/adl_support/utils_test.clj Normal file
View file

@ -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"))
))