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

Compare commits

base: simon:b944aa6bf16f462868eecbecca4fba58bc64167e
Branches Tags
simon:develop
simon:master
simon:feature/3
simon:feature/5
...
compare: simon:0a23cacd048508e3addccc3574ddc87194e9f2fd
Branches Tags
simon:develop
simon:master
simon:feature/3
simon:feature/5

11 commits
b944aa6bf1 ... 0a23cacd04

Author SHA1 Message Date
Simon Brooke 0a23cacd04 Further work on Postgres transform, still not perfect. 
Current unit tests are almost worthless; need new tests.
 2025-05-23 17:56:00 +01:00
Simon Brooke 38f9c0f0e4 Merge branch 'develop' of ssh://git.journeyman.cc:4022/simon/adl into develop; 
Fixed yet another validator test.
 2025-05-23 10:17:04 +01:00
Simon Brooke b4b20d1d7a Added todo element (child of documentation) to DTD. Upversioned to 1.4.2 2025-05-18 12:46:15 +01:00
Simon Brooke 5868215e6b Merge branch 'feature/9-10' into develop 2019-12-28 14:20:58 +00:00
Simon Brooke 69ead0f5eb #10: fixes bug 10, all tests pass, no regression expected. 2019-12-28 14:20:50 +00:00
Simon Brooke b472bd4950 #9: Fixes bug 9, all tests pass... 
But I'm not utterly confident there won't be regressions.
 2019-12-28 14:12:18 +00:00
Simon Brooke 8f24c314a1 Now creating a complete database initialisation script that runs. 2019-11-16 13:15:27 +00:00
Simon Brooke c2d006ac3b A number of improvements, but still not generating clean PSQL. 2019-11-15 15:27:24 +00:00
Simon Brooke dd4120bb91 Run lein ancient and updated dependencies. 
to_psql_tests do NOT yet pass (new file, never has passed)
 2019-11-12 16:19:01 +00:00
Simon Brooke 481fb5f535 Ignore .orig files. 2019-11-12 15:13:30 +00:00
Simon Brooke e2aa979458 All unit tests passing. 2019-11-12 15:10:26 +00:00
10 changed files with 1016 additions and 359 deletions
Show stats Expand all files Collapse all files

4
.gitignore vendored
View file

@ -27,3 +27,7 @@ node_modules/
generated/ generated/
*.orig
*.out

2
project.clj
View file

@ -8,7 +8,7 @@
:dependencies [[adl-support "0.1.8-SNAPSHOT"] :dependencies [[adl-support "0.1.8-SNAPSHOT"]
[bouncer "1.0.1"] [bouncer "1.0.1"]
[clojure-saxon "0.9.4"] [clojure-saxon "0.9.4"]
[environ "1.2.0"] [environ "1.1.0"]
[hiccup "1.0.5"] [hiccup "1.0.5"]
[org.clojure/clojure "1.12.0"] [org.clojure/clojure "1.12.0"]
[org.clojure/math.combinatorics "0.3.0"] [org.clojure/math.combinatorics "0.3.0"]

507
src/adl/to_hugsql_queries.clj
View file

@ -31,78 +31,78 @@
;;;; ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def expanded-token "_expanded") (def expanded-token "_expanded")
(defn where-clause (defn where-clause
"Generate an appropriate `where` clause for queries on this `entity`; "Generate an appropriate `where` clause for queries on this `entity`;
if `properties` are passed, filter on those properties, otherwise the key if `properties` are passed, filter on those properties, otherwise the key
properties." properties."
([entity] ([entity]
(where-clause entity (key-properties entity))) (where-clause entity (key-properties entity)))
([entity properties] ([entity properties]
(let (let
[entity-name (safe-name entity :sql) [entity-name (safe-name entity :sql)
property-names (map #(:name (:attrs %)) properties)] property-names (map #(:name (:attrs %)) properties)]
(when-not (empty? property-names) (when-not (empty? property-names)
(str (str
"WHERE " "WHERE "
(s/join (s/join
"\n\tAND " "\n\tAND "
(map (map
#(str entity-name "." (safe-name % :sql) " = :" %) #(str entity-name "." (safe-name % :sql) " = :" %)
property-names))))))) property-names)))))))
(defn order-by-clause (defn order-by-clause
"Generate an appropriate `order by` clause for queries on this `entity`" "Generate an appropriate `order by` clause for queries on this `entity`"
([entity] ([entity]
(order-by-clause entity "" false)) (order-by-clause entity "" false))
([entity prefix] ([entity prefix]
(order-by-clause entity prefix false)) (order-by-clause entity prefix false))
([entity prefix expanded?] ([entity prefix expanded?]
(let (let
[entity-name (safe-name entity :sql) [entity-name (safe-name entity :sql)
preferred (filter #(#{"user" "all"} (-> % :attrs :distinct)) preferred (filter #(#{"user" "all"} (-> % :attrs :distinct))
(descendants-with-tag entity :property))] (descendants-with-tag entity :property))]
(if (if
(empty? preferred) (empty? preferred)
"" ""
(str (str
"ORDER BY " prefix entity-name "." "ORDER BY " prefix entity-name "."
(s/join (s/join
(str ",\n\t" prefix entity-name ".") (str ",\n\t" prefix entity-name ".")
(map (map
#(if #(if
(and expanded? (= "entity" (-> % :attrs :type))) (and expanded? (= "entity" (-> % :attrs :type)))
(str (safe-name % :sql) expanded-token) (str (safe-name % :sql) expanded-token)
(safe-name % :sql)) (safe-name % :sql))
(order-preserving-set (order-preserving-set
(concat (concat
preferred preferred
(key-properties entity)))))))))) (key-properties entity))))))))))
;; (def a (x/parse "../youyesyet/youyesyet.adl.xml")) ;; (def a (x/parse "../youyesyet/youyesyet.adl.xml"))
;; (def e (child-with-tag a :entity #(= "dwellings" (-> % :attrs :name)))) ;; (def e (child-with-tag a :entity #(= "dwellings" (-> % :attrs :name))))
;; (order-by-clause e "" true) ;; (order-by-clause e "" true)
(defn insert-query (defn insert-query
"Generate an appropriate `insert` query for this `entity`. "Generate an appropriate `insert` query for this `entity`.
TODO: this depends on the idea that system-unique properties TODO: this depends on the idea that system-unique properties
are not insertable, which is... dodgy." are not insertable, which is... dodgy."
[entity] [entity]
(let [entity-name (safe-name entity :sql) (let [entity-name (safe-name entity :sql)
pretty-name (singularise entity-name) pretty-name (singularise entity-name)
insertable-property-names (map insertable-property-names (map
#(safe-name % :sql) #(safe-name % :sql)
(insertable-properties entity)) (insertable-properties entity))
query-name (str "create-" pretty-name "!") query-name (str "create-" pretty-name "!")
signature (if (has-primary-key? entity) signature (if (has-primary-key? entity)
":? :1" ;; bizarrely, if you want to return the keys, ":? :1" ;; bizarrely, if you want to return the keys,
;; you have to use a query signature. ;; you have to use a query signature.
":! :n")] ":! :n")]
(hash-map (hash-map
(keyword query-name) (keyword query-name)
{:name query-name {:name query-name
:signature signature :signature signature
@ -117,26 +117,26 @@
(s/join ",\n\t" (map keyword insertable-property-names)) (s/join ",\n\t" (map keyword insertable-property-names))
")" ")"
(if (if
(has-primary-key? entity) (has-primary-key? entity)
(str "\nreturning " (str "\nreturning "
(s/join (s/join
",\n\t" ",\n\t"
(map (map
#(safe-name % :sql) #(safe-name % :sql)
(key-names entity))))))}))) (key-names entity))))))})))
(defn update-query (defn update-query
"Generate an appropriate `update` query for this `entity`" "Generate an appropriate `update` query for this `entity`"
[entity] [entity]
(let [entity-name (safe-name entity :sql) (let [entity-name (safe-name entity :sql)
pretty-name (singularise entity-name) pretty-name (singularise entity-name)
property-names (map property-names (map
#(-> % :attrs :name) #(-> % :attrs :name)
(insertable-properties entity)) (insertable-properties entity))
query-name (str "update-" pretty-name "!") query-name (str "update-" pretty-name "!")
signature ":! :n"] signature ":! :n"]
(hash-map (hash-map
(keyword query-name) (keyword query-name)
{:name query-name {:name query-name
:signature signature :signature signature
@ -148,10 +148,10 @@
"UPDATE " entity-name "\n" "UPDATE " entity-name "\n"
"SET " "SET "
(s/join (s/join
",\n\t" ",\n\t"
(map (map
#(str (safe-name % :sql) " = " (keyword %)) #(str (safe-name % :sql) " = " (keyword %))
property-names)) property-names))
"\n" "\n"
(where-clause entity))}))) (where-clause entity))})))
@ -168,66 +168,67 @@
pretty-name (singularise entity-name) pretty-name (singularise entity-name)
query-name (str "search-strings-" entity-name) query-name (str "search-strings-" entity-name)
signature ":? :*" signature ":? :*"
properties (remove #(#{"(safe-name entity :sql)"} (:type (:attrs %))) (all-properties entity))] properties (remove #(#{"(safe-name entity :sql)"}(:type (:attrs %))) (all-properties entity))]
(hash-map (hash-map
(keyword query-name) (keyword query-name)
{:name query-name {:name query-name
:signature signature :signature signature
:entity entity :entity entity
:type :text-search :type :text-search
:query :query
(s/join (s/join
"\n" "\n"
(remove (remove
empty? empty?
(list (list
(str "-- :name " query-name " " signature) (str "-- :name " query-name " " signature)
(str (str
"-- :doc selects existing " "-- :doc selects existing "
pretty-name pretty-name
" records having any string field matching the parameter of the same name by substring match") " records having any string field matching the parameter of the same name by substring match")
(str "SELECT DISTINCT * FROM lv_" entity-name) (str "SELECT DISTINCT * FROM lv_" entity-name)
(s/join (s/join
"\n\t--~ " "\n\t--~ "
(cons (cons
"WHERE true" "WHERE true"
(filter (filter
string? string?
(map (map
#(let #(let
[sn (safe-name % :sql)] [sn (safe-name % :sql)]
(str (str
"(if (:" (-> % :attrs :name) " params) (str \"AND " "(if (:" (-> % :attrs :name) " params) (str \"AND "
(case (-> % :attrs :type) (case (-> % :attrs :type)
("string" "text") ("string" "text")
(str (str
sn sn
" LIKE '%\" (:" (-> % :attrs :name) " params) \"%' ") " LIKE '%\" (:" (-> % :attrs :name) " params) \"%' ")
("date" "time" "timestamp") ("date" "time" "timestamp")
(str (str
sn sn
" = ':" (-> % :attrs :name) "'") " = ':" (-> % :attrs :name) "'")
"entity" "entity"
(str (str
sn sn
"_expanded LIKE '%\" (:" (-> % :attrs :name) " params) \"%'") "_expanded LIKE '%\" (:" (-> % :attrs :name) " params) \"%'")
(str (str
sn sn
" = :" " = :"
(-> % :attrs :name))) (-> % :attrs :name)))
"\"))")) "\"))"))
properties)))) properties))))
(order-by-clause entity "lv_" true) (order-by-clause entity "lv_" true)
"--~ (if (:offset params) \"OFFSET :offset \")" "--~ (if (:offset params) \"OFFSET :offset \")"
"--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))})))) "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))}))))
;; (search-query e a) ;; (search-query e a)
(defn select-query (defn select-query
"Generate an appropriate `select` query for this `entity`" "Generate an appropriate `select` query for this `entity`"
([entity properties] ([entity properties]
(if-not (if-not
(empty? properties) (empty? properties)
(let [entity-name (safe-name entity :sql) (let [entity-name (safe-name entity :sql)
pretty-name (singularise entity-name) pretty-name (singularise entity-name)
query-name (if (= properties (key-properties entity)) query-name (if (= properties (key-properties entity))
@ -237,32 +238,32 @@
(map #(:name (:attrs %)) properties)))) (map #(:name (:attrs %)) properties))))
signature ":? :1"] signature ":? :1"]
(hash-map (hash-map
(keyword query-name) (keyword query-name)
{:name query-name {:name query-name
:signature signature :signature signature
:entity entity :entity entity
:type :select-1 :type :select-1
:query :query
(s/join (s/join
"\n" "\n"
(remove (remove
empty? empty?
(list (list
(str "-- :name " query-name " " signature) (str "-- :name " query-name " " signature)
(str "-- :doc selects an existing " pretty-name " record") (str "-- :doc selects an existing " pretty-name " record")
(str "SELECT * FROM " entity-name) (str "SELECT * FROM " entity-name)
(where-clause entity properties) (where-clause entity properties)
(order-by-clause entity))))})) (order-by-clause entity))))}))
{})) {}))
([entity] ([entity]
(let [distinct-fields (distinct-properties entity)] (let [distinct-fields (distinct-properties entity)]
(apply (apply
merge merge
(cons (cons
(select-query entity (key-properties entity)) (select-query entity (key-properties entity))
(map (map
#(select-query entity %) #(select-query entity %)
(combinations distinct-fields (count distinct-fields)))))))) (combinations distinct-fields (count distinct-fields))))))))
(defn list-query (defn list-query
@ -275,23 +276,23 @@
query-name (str "list-" entity-name) query-name (str "list-" entity-name)
signature ":? :*"] signature ":? :*"]
(hash-map (hash-map
(keyword query-name) (keyword query-name)
{:name query-name {:name query-name
:signature signature :signature signature
:entity entity :entity entity
:type :select-many :type :select-many
:query :query
(s/join (s/join
"\n" "\n"
(remove (remove
empty? empty?
(list (list
(str "-- :name " query-name " " signature) (str "-- :name " query-name " " signature)
(str "-- :doc lists all existing " pretty-name " records") (str "-- :doc lists all existing " pretty-name " records")
(str "SELECT DISTINCT lv_" entity-name ".* FROM lv_" entity-name) (str "SELECT DISTINCT lv_" entity-name ".* FROM lv_" entity-name)
(order-by-clause entity "lv_" false) (order-by-clause entity "lv_" false)
"--~ (if (:offset params) \"OFFSET :offset \")" "--~ (if (:offset params) \"OFFSET :offset \")"
"--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))}))) "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))})))
(defn foreign-queries (defn foreign-queries
@ -363,22 +364,22 @@
"Generate an appropriate `delete` query for this `entity`" "Generate an appropriate `delete` query for this `entity`"
[entity] [entity]
(if (if
(has-primary-key? entity) (has-primary-key? entity)
(let [entity-name (safe-name entity :sql) (let [entity-name (safe-name entity :sql)
pretty-name (singularise entity-name) pretty-name (singularise entity-name)
query-name (str "delete-" pretty-name "!") query-name (str "delete-" pretty-name "!")
signature ":! :n"] signature ":! :n"]
(hash-map (hash-map
(keyword query-name) (keyword query-name)
{:name query-name {:name query-name
:signature signature :signature signature
:entity entity :entity entity
:type :delete-1 :type :delete-1
:query :query
(str "-- :name " query-name " " signature "\n" (str "-- :name " query-name " " signature "\n"
"-- :doc deletes an existing " pretty-name " record\n" "-- :doc deletes an existing " pretty-name " record\n"
"DELETE FROM " entity-name "\n" "DELETE FROM " entity-name "\n"
(where-clause entity))})))) (where-clause entity))}))))
(defn queries (defn queries
@ -387,18 +388,18 @@
([application entity] ([application entity]
(merge (merge
;; TODO: queries that look through link tables ;; TODO: queries that look through link tables
(insert-query entity) (insert-query entity)
(update-query entity) (update-query entity)
(delete-query entity) (delete-query entity)
(select-query entity) (select-query entity)
(list-query entity) (list-query entity)
(search-query entity application) (search-query entity application)
(foreign-queries entity application))) (foreign-queries entity application)))
([application] ([application]
(apply (apply
merge merge
(map #(queries application %) (map #(queries application %)
(children-with-tag application :entity))))) (children-with-tag application :entity)))))
(defn to-hugsql-queries (defn to-hugsql-queries
@ -407,25 +408,25 @@
(let [filepath (str *output-path* "resources/sql/queries.auto.sql")] (let [filepath (str *output-path* "resources/sql/queries.auto.sql")]
(make-parents filepath) (make-parents filepath)
(do-or-warn (do-or-warn
(do (do
(spit (spit
filepath filepath
(s/join (s/join
"\n\n" "\n\n"
(cons (cons
(emit-header (emit-header
"--" "--"
"File queries.sql" "File queries.sql"
(str "autogenerated by adl.to-hugsql-queries at " (t/now)) (str "autogenerated by adl.to-hugsql-queries at " (t/now))
"See [Application Description Language](https://github.com/simon-brooke/adl).") "See [Application Description Language](https://github.com/simon-brooke/adl).")
(map (map
:query :query
(sort (sort
#(compare (:name %1) (:name %2)) #(compare (:name %1) (:name %2))
(vals (vals
(queries application))))))) (queries application)))))))
(if (pos? *verbosity*) (if (pos? *verbosity*)
(*warn* (str "\tGenerated " filepath))))))) (*warn* (str "\tGenerated " filepath)))))))
(defn generate-documentation (defn generate-documentation
@ -433,68 +434,68 @@
[query] [query]
(let [v (volatility (:entity query))] (let [v (volatility (:entity query))]
(s/join (s/join
" " " "
(list (list
(case (case
(:type query) (:type query)
:delete-1 :delete-1
(str "delete one record from the `" (str "delete one record from the `"
(-> query :entity :attrs :name) (-> query :entity :attrs :name)
"` table. Expects the following key(s) to be present in `params`: `" "` table. Expects the following key(s) to be present in `params`: `"
(-> query :entity key-names) (-> query :entity key-names)
"`.") "`.")
:insert-1 :insert-1
(str "insert one record to the `" (str "insert one record to the `"
(-> query :entity :attrs :name) (-> query :entity :attrs :name)
"` table. Expects the following key(s) to be present in `params`: `" "` table. Expects the following key(s) to be present in `params`: `"
(pr-str (pr-str
(map (map
#(keyword (:name (:attrs %))) #(keyword (:name (:attrs %)))
(-> query :entity insertable-properties))) (-> query :entity insertable-properties )))
"`. Returns a map containing the keys `" "`. Returns a map containing the keys `"
(-> query :entity key-names) (-> query :entity key-names)
"` identifying the record created.") "` identifying the record created.")
:select-1 :select-1
(str "select one record from the `" (str "select one record from the `"
(-> query :entity :attrs :name) (-> query :entity :attrs :name)
"` table. Expects the following key(s) to be present in `params`: `" "` table. Expects the following key(s) to be present in `params`: `"
(-> query :entity key-names) (-> query :entity key-names)
"`. Returns a map containing the following keys: `" "`. Returns a map containing the following keys: `"
(map #(keyword (:name (:attrs %))) (-> query :entity all-properties)) (map #(keyword (:name (:attrs %))) (-> query :entity all-properties))
"`.") "`.")
:select-many :select-many
(str "select all records from the `" (str "select all records from the `"
(-> query :entity :attrs :name) (-> query :entity :attrs :name)
"` table. If the keys `(:limit :offset)` are present in the request then they will be used to page through the data. Returns a sequence of maps each containing the following keys: `" "` table. If the keys `(:limit :offset)` are present in the request then they will be used to page through the data. Returns a sequence of maps each containing the following keys: `"
(pr-str (pr-str
(map (map
#(keyword (:name (:attrs %))) #(keyword (:name (:attrs %)))
(-> query :entity all-properties))) (-> query :entity all-properties)))
"`.") "`.")
:text-search :text-search
(str "select all records from the `" (str "select all records from the `"
(-> query :entity :attrs :name) (-> query :entity :attrs :name)
;; TODO: this doc-string is out of date ;; TODO: this doc-string is out of date
"` table with any text field matching the value of the key `:pattern` which should be in the request. If the keys `(:limit :offset)` are present in the request then they will be used to page through the data. Returns a sequence of maps each containing the following keys: `" "` table with any text field matching the value of the key `:pattern` which should be in the request. If the keys `(:limit :offset)` are present in the request then they will be used to page through the data. Returns a sequence of maps each containing the following keys: `"
(pr-str (pr-str
(map (map
#(keyword (:name (:attrs %))) #(keyword (:name (:attrs %)))
(-> query :entity all-properties))) (-> query :entity all-properties)))
"`.") "`.")
:update-1 :update-1
(str "update one record in the `" (str "update one record in the `"
(-> query :entity :attrs :name) (-> query :entity :attrs :name)
"` table. Expects the following key(s) to be present in `params`: `" "` table. Expects the following key(s) to be present in `params`: `"
(pr-str (pr-str
(distinct (distinct
(sort (sort
(map (map
#(keyword (:name (:attrs %))) #(keyword (:name (:attrs %)))
(flatten (flatten
(cons (cons
(-> query :entity key-properties) (-> query :entity key-properties)
(-> query :entity insertable-properties))))))) (-> query :entity insertable-properties)))))))
"`.")) "`."))
(if-not (if-not
(zero? v) (zero? v)
(str "Results will be held in cache for " v " seconds.")))))) (str "Results will be held in cache for " v " seconds."))))))

170
src/adl/to_psql.clj
View file

@ -1,13 +1,20 @@
(ns ^{:doc "Application Description Language: generate Postgres database definition." (ns ^{:doc "Application Description Language: generate Postgres database definition."
:author "Simon Brooke"} :author "Simon Brooke"}
adl.to-psql adl.to-psql
(:require [adl-support.core :refer :all] (:require
[adl-support.utils :refer :all] [adl-support.core :refer [*warn* do-or-warn]]
;; [adl.to-hugsql-queries :refer [queries]] [adl-support.utils :refer [*output-path* *verbosity* all-properties child
[clojure.java.io :refer [make-parents]] child-with-tag children-with-tag emit-header
[clojure.string :as s] entity-for-property entity? find-permissions
[clj-time.core :as t] is-quotable-type? key-names key-properties
[clj-time.format :as f])) link-table-name properties property-for-field
safe-name singularise sort-by-name
system-generated? typedef unique-link?
user-distinct-properties]] ;; [adl.to-hugsql-queries :refer [queries]]
[clj-time.core :as t]
[clj-time.format :as f]
[clojure.java.io :refer [make-parents]]
[clojure.string :as s]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; ;;;;
@ -161,7 +168,7 @@
#(if (selector (:permission (:attrs %))) #(if (selector (:permission (:attrs %)))
(safe-name (:group (:attrs %)) :sql)) (safe-name (:group (:attrs %)) :sql))
permissions)))] permissions)))]
(if-not (when-not
(empty? group-names) (empty? group-names)
(s/join (s/join
" " " "
@ -193,11 +200,12 @@
([property entity application] ([property entity application]
(emit-property property entity application false)) (emit-property property entity application false))
([property entity application key?] ([property entity application key?]
(let [default (:default (:attrs property))] (let [default (:default (:attrs property))
(if type (-> property :attrs :type)]
(when
(and (and
(= (:tag property) :property) (= (:tag property) :property)
(not (#{"link"} (:type (:attrs property))))) (not (#{"link" "list"} type)))
(s/join (s/join
" " " "
(remove (remove
@ -207,14 +215,14 @@
"\t" "\t"
(field-name property) (field-name property)
(emit-field-type property entity application key?) (emit-field-type property entity application key?)
(if (when
default default
(list (list
"DEFAULT" "DEFAULT"
(if (if
(is-quotable-type? property application) (is-quotable-type? property application)
(str "'" default "'") ;; TODO: but if the default value seems to be a function invocation, should it be quoted? (str "'" default "'") ;; TODO: but if the default value seems to be a function invocation, should it be quoted?
;; it's quite common for 'now()' to be the default for a date, time or timestamp field. ;; it's quite common for `now()` to be the default for a date, time or timestamp field.
default))) default)))
(if (if
key? key?
@ -223,20 +231,25 @@
(defn compose-convenience-entity-field (defn compose-convenience-entity-field
[field entity application] ([field entity application]
(let [farside (entity-for-property (property-for-field field entity) application)] (compose-convenience-entity-field field entity application nil))
([field entity application table-alias]
(let [property (case (:tag field)
:field (property-for-field field entity)
:property field)
farside (entity-for-property property application)]
(flatten (flatten
(map (map
(fn [f] (fn [p]
(if (if
(= (:type (:attrs f)) "entity") (= (:type (:attrs p)) "entity")
(compose-convenience-entity-field f farside application) (compose-convenience-entity-field p farside application (field-name property))
(str (safe-name (:table (:attrs farside))) "." (field-name f)))) (str (or table-alias (safe-name farside :sql)) "." (field-name p))))
(user-distinct-properties farside))))) (user-distinct-properties farside))))))
(defn compose-convenience-view-select-list (defn compose-convenience-view-from-list
"Compose the body of an SQL `SELECT` statement for a convenience view of this "Compose the FROM list of an SQL `SELECT` statement for a convenience view of this
`entity` within this `application`, recursively. `top-level?` should be set `entity` within this `application`, recursively. `top-level?` should be set
only on first invocation." only on first invocation."
[entity application top-level?] [entity application top-level?]
@ -244,15 +257,17 @@
nil? nil?
(flatten (flatten
(cons (cons
(safe-name (:table (:attrs entity)) :sql) (safe-name entity :sql)
(map (map
(fn [f] (fn [f]
(if (when
(= (:type (:attrs f)) "entity") (= (:type (:attrs f)) "entity")
(compose-convenience-view-select-list (let [farside (child application #(and (entity? %) (= (:name (:attrs %))(:entity (:attrs f)))))
(child application #(and (entity? %) (= (:name (:attrs %))(:entity (:attrs f))))) tablename (safe-name farside :sql)
application fieldname (field-name f)]
false))) (if (= tablename fieldname)
tablename
(str tablename " AS " fieldname)))))
(if (if
top-level? top-level?
(all-properties entity) (all-properties entity)
@ -271,19 +286,19 @@
(flatten (flatten
(map (map
(fn [f] (fn [f]
(if (when
(= (:type (:attrs f)) "entity") (= (:type (:attrs f)) "entity")
(let [farside (entity-for-property f application)] (let [farside (entity-for-property f application)]
(cons (cons
(str (str
(safe-name (:table (:attrs entity)) :sql) (safe-name entity :sql)
"." "."
(field-name f) (field-name f)
" = " " = "
(safe-name (:table (:attrs farside)) :sql) (safe-name farside :sql)
"." "."
(safe-name (first (key-names farside)) :sql)) (safe-name (first (key-names farside)) :sql))
#(compose-convenience-where-clause farside application false))))) (compose-convenience-where-clause farside application false)))))
(if (if
top-level? top-level?
(all-properties entity) (all-properties entity)
@ -291,24 +306,29 @@
(defn emit-convenience-entity-field (defn emit-convenience-entity-field
[field entity application] ([property entity application]
(str (emit-convenience-entity-field property entity application (field-name property)))
(s/join ([property entity application table-alias]
" ||', '|| " (when
(compose-convenience-entity-field field entity application)) (= "entity" (-> property :attrs :type))
" AS " (str
(field-name field) (s/join
"_expanded")) " ||', '|| "
(compose-convenience-entity-field property entity application table-alias))
" AS "
(field-name property)
"_expanded"))))
(defn emit-convenience-view (defn emit-convenience-view
"Emit a convenience view of this `entity` of this `application` for use in generating lists, "Emit a convenience view of this `entity` of this `application` for use in generating lists,
menus, et cetera." menus, et cetera."
[entity application] [entity application]
(let [view-name (safe-name (str "lv_" (:table (:attrs entity))) :sql) (let [table-name (safe-name entity :sql)
entity-fields (filter view-name (safe-name (str "lv_" table-name) :sql)
#(= (:type (:attrs %)) "entity") entity-properties (filter
(properties entity))] #(= (:type (:attrs %)) "entity")
(properties entity))]
(s/join (s/join
"\n" "\n"
(remove (remove
@ -325,21 +345,23 @@
"SELECT " "SELECT "
(s/join (s/join
",\n\t" ",\n\t"
(flatten (remove
(map nil?
#(if (flatten
(= (:type (:attrs %)) "entity") (map
(list #(if
(emit-convenience-entity-field % entity application) (= (:type (:attrs %)) "entity")
(str (safe-name entity) "." (field-name %))) (list
(str (safe-name entity) "." (field-name %))) (emit-convenience-entity-field % entity application (field-name %))
(filter (str table-name "." (field-name %)))
#(not= (:type (:attrs %)) "link") (str table-name "." (field-name %)))
(all-properties entity) ))))) (remove
#(#{"link" "list"} (:type (:attrs %)))
(all-properties entity) ))))))
(str (str
"FROM " (s/join ", " (set (compose-convenience-view-select-list entity application true)))) "FROM " (s/join ", " (set (compose-convenience-view-from-list entity application true))))
(if-not (when-not
(empty? entity-fields) (empty? entity-properties)
(str (str
"WHERE " "WHERE "
(s/join (s/join
@ -349,14 +371,14 @@
(let (let
[farside (entity-for-property f application)] [farside (entity-for-property f application)]
(str (str
(safe-name (:table (:attrs entity)) :sql) (safe-name entity :sql)
"." "."
(field-name f) (field-name f)
" = " " = "
(safe-name (:table (:attrs farside)) :sql) (safe-name farside :sql)
"." "."
(safe-name (first (key-names farside)) :sql)))) (safe-name (first (key-names farside)) :sql))))
entity-fields)))) entity-properties))))
";" ";"
(emit-permissions-grant view-name :SELECT (find-permissions entity application)))))))) (emit-permissions-grant view-name :SELECT (find-permissions entity application))))))))
@ -378,8 +400,8 @@
(field-name property) (field-name property)
") \n\tREFERENCES" ") \n\tREFERENCES"
(str (str
(safe-name (:table (:attrs farside)) :sql) (safe-name farside :sql)
"(" (field-name (first (key-properties farside))) ")") "( " (field-name (first (key-properties farside))) " )")
;; TODO: ought to handle the `cascade` attribute, even though it's rarely used ;; TODO: ought to handle the `cascade` attribute, even though it's rarely used
"\n\tON DELETE" "\n\tON DELETE"
(case (case
@ -415,7 +437,7 @@
"Emit a table declaration for this `entity` of this `application`, "Emit a table declaration for this `entity` of this `application`,
documented with this `doc-comment` if specified." documented with this `doc-comment` if specified."
([entity application doc-comment] ([entity application doc-comment]
(let [table-name (safe-name (:table (:attrs entity)) :sql) (let [table-name (safe-name entity :sql)
permissions (children-with-tag entity :permission)] permissions (children-with-tag entity :permission)]
(s/join (s/join
"\n" "\n"
@ -435,9 +457,9 @@
(str (str
(s/join (s/join
",\n" ",\n"
(flatten (remove
(remove nil?
nil? (flatten
(list (list
(map (map
#(emit-property % entity application true) #(emit-property % entity application true)
@ -457,7 +479,7 @@
application application
(str (str
"primary table " "primary table "
(:table (:attrs entity)) (safe-name entity :sql)
" for entity " " for entity "
(:name (:attrs entity)))))) (:name (:attrs entity))))))
@ -488,7 +510,7 @@
(= (:name (:attrs %)) (:entity (:attrs property))))) (= (:name (:attrs %)) (:entity (:attrs property)))))
unique? (unique-link? e1 e2) unique? (unique-link? e1 e2)
link-table-name (link-table-name property e1 e2)] link-table-name (link-table-name property e1 e2)]
(if (when
;; we haven't already emitted this one... ;; we haven't already emitted this one...
(not (@emitted-link-tables link-table-name)) (not (@emitted-link-tables link-table-name))
(let [permissions (flatten (let [permissions (flatten
@ -506,7 +528,7 @@
[(construct-link-property e1) [(construct-link-property e1)
(construct-link-property e2)] (construct-link-property e2)]
permissions)))}] permissions)))}]
(if-not unique? (when-not unique?
(*warn* (*warn*
(str "WARNING: Manually check link tables between " (str "WARNING: Manually check link tables between "
(-> e1 :attrs :name) (-> e1 :attrs :name)
@ -547,8 +569,8 @@
(defn emit-group-declaration (defn emit-group-declaration
"Emit a declaration for this authorisation `group` within this `application`." "Emit a declaration for this authorisation `group`."
[group application] [group]
(list (list
(emit-header (emit-header
"--" "--"
@ -585,7 +607,7 @@
(list (list
(emit-file-header application) (emit-file-header application)
(map (map
#(emit-group-declaration % application) #(emit-group-declaration %)
(sort-by-name (sort-by-name
(children-with-tag application :group))) (children-with-tag application :group)))
(map (map
@ -611,7 +633,7 @@
(make-parents filepath) (make-parents filepath)
(do-or-warn (do-or-warn
(spit filepath (emit-application application)) (spit filepath (emit-application application))
(if (when
(pos? *verbosity*) (pos? *verbosity*)
(*warn* (str "\tGenerated " filepath)))))) (*warn* (str "\tGenerated " filepath))))))

2
src/adl/to_selmer_routes.clj
View file

@ -176,7 +176,7 @@
(*warn* (*warn*
(str (str
"Entity '" "Entity '"
(-> entity :attrs :name) (or (-> entity :attrs :name) entity)
"' passed to compose-fetch-auxlist-data is a non-entity"))) "' passed to compose-fetch-auxlist-data is a non-entity")))
(if-not (if-not
(entity? farside) (entity? farside)

101
src/adl/to_swagger.clj
View file

@ -2,7 +2,7 @@
:author "Simon Brooke"} :author "Simon Brooke"}
adl.to-swagger adl.to-swagger
(:require [adl-support.utils :refer :all] (:require [adl-support.utils :refer :all]
[adl.to-hugsql-queries :refer [queries]] [adl.to-hugsql-queries :refer [generate-documentation queries]]
[clj-time.core :as t] [clj-time.core :as t]
[clj-time.format :as f] [clj-time.format :as f]
[clojure.java.io :refer [file make-parents writer]] [clojure.java.io :refer [file make-parents writer]]
@ -43,21 +43,98 @@
(list (list
'ns 'ns
(symbol (str (safe-name (:name (:attrs application))) ".routes.auto-api")) (symbol (str (safe-name (:name (:attrs application))) ".routes.auto-api"))
(str "API routes for " (:name (:attrs application)) (str "Swagger routes for " (:name (:attrs application))
" auto-generated by [Application Description Language framework](https://github.com/simon-brooke/adl) at " " auto-generated by [Application Description Language framework](https://github.com/simon-brooke/adl) at "
(f/unparse (f/formatters :basic-date-time) (t/now))) (f/unparse (f/formatters :basic-date-time) (t/now)))
(list (list
:require :require
'[adl-support.core :as support] '[reitit.swagger :as swagger]
'[clj-http.client :as client] '[reitit.swagger-ui :as swagger-ui]
'[clojure.tools.logging :as log] '[reitit.ring.coercion :as coercion]
'[compojure.api.sweet :refer :all] '[reitit.coercion.spec :as spec-coercion]
'[hugsql.core :as hugsql] '[reitit.ring.middleware.muuntaja :as muuntaja]
'[reitit.ring.middleware.multipart :as multipart]
'[reitit.ring.middleware.parameters :as parameters]
'[placenames.middleware.formats :as formats]
'[placenames.middleware.exception :as exception]
'[placenames.routes.auto-jason :as aj]
'[ring.util.http-response :refer :all] '[ring.util.http-response :refer :all]
'[noir.response :as nresponse] '[clojure.java.io :as io])))
'[noir.util.route :as route]
'[ring.util.http-response :as response]
'[schema.core :as s]
(vector (symbol (str (safe-name (:name (:attrs application))) ".db.core")) :as 'db))))
(defn def-routes
"Generate Swagger routes for all queries implied by this ADL `application` spec."
;; THIS ISN'T NEARLY FINISHED!
([application]
(list 'defn 'auto-api-routes []
["/api"
{:coercion spec-coercion/coercion
:muuntaja formats/instance
:swagger {:id ::api}
:middleware [;; query-params & form-params
parameters/parameters-middleware
;; content-negotiation
muuntaja/format-negotiate-middleware
;; encoding response body
muuntaja/format-response-middleware
;; exception handling
exception/exception-middleware
;; decoding request body
muuntaja/format-request-middleware
;; coercing response bodys
coercion/coerce-response-middleware
;; coercing request parameters
coercion/coerce-request-middleware
;; multipart
multipart/multipart-middleware]}]
(map #(def-routes application %)
(children-with-tag application :entity)))
([application entity]
[(str "/" (safe-name entity))
{:get (make-get-route entity)
(cons
'defroutes
(cons
'auto-rest-routes
(map
#(let [handler (handlers-map %)]
(list
(symbol (s/upper-case (name (:method handler))))
(str "/json/auto/" (safe-name (:name handler)))
'request
(list
'route/restricted
(list (:name handler) 'request))))
(sort
(keys handlers-map)))))}])))
(defn to-swagger
"Generate a Swagger API for all queries implied by this ADL `application` spec."
[application]
(let [filepath (str
*output-path*
"src/"
(safe-name (:name (:attrs application)))
"/routes/auto_api.clj")]
(make-parents filepath)
(do-or-warn
(do
(spit
filepath
(s/join
"\n\n"
(cons
(file-header application)
(map
(fn [q]
(str
;; THIS ISN'T NEARLY FINISHED!
))
(sort
#(compare (:name %1) (:name %2))
(vals
(queries application)))))))
(if (pos? *verbosity*)
(*warn* (str "\tGenerated " filepath)))))))

27
src/adl/validator.clj
View file

@ -43,7 +43,7 @@
(symbol? validation) (symbol? validation)
(try (try
(b/validate o validation) (b/validate o validation)
(catch java.lang.ClassCastException _ (catch java.lang.ClassCastException c
;; The validator regularly barfs on strings, which are perfectly ;; The validator regularly barfs on strings, which are perfectly
;; valid content of some elements. I need a way to validate ;; valid content of some elements. I need a way to validate
;; elements where they're not tolerated! ;; elements where they're not tolerated!
@ -227,10 +227,10 @@
Markdown (which may include a string representation of HTML markup) should Markdown (which may include a string representation of HTML markup) should
be." be."
{:tag [v/required [#(= % :documentation)]] {:tag [v/required [#(= % :documentation)]]
:content [[v/every #(disjunct-valid? :content [[v/every #(disjunct-valid?
% %
v/string v/string
reference-validations)]]}) reference-validations)]]})
;; (def sample-documentation {:tag :documentation ;; (def sample-documentation {:tag :documentation
;; :content ["Every animal should have a breed." ;; :content ["Every animal should have a breed."
@ -328,6 +328,8 @@
[:attrs :name] [v/string v/required] [:attrs :name] [v/string v/required]
[:attrs :value] [v/string v/required]}) [:attrs :value] [v/string v/required]})
(def generator-validations (def generator-validations
"marks a property which is auto-generated by some part of the system. "marks a property which is auto-generated by some part of the system.
This is based on the Hibernate construct, except that the Hibernate This is based on the Hibernate construct, except that the Hibernate
@ -469,14 +471,13 @@
[:attrs :column] v/string [:attrs :column] v/string
[:attrs :concrete] [[v/member #{"true", "false"}]] [:attrs :concrete] [[v/member #{"true", "false"}]]
:content [[v/every #(disjunct-valid? % :content [[v/every #(disjunct-valid? %
documentation-validations documentation-validations
generator-validations generator-validations
permission-validations permission-validations
option-validations option-validations
prompt-validations prompt-validations
help-validations help-validations
ifmissing-validations)]] ifmissing-validations)]]})
})
;; (disjunct-valid? sample-option documentation-validations ;; (disjunct-valid? sample-option documentation-validations
;; generator-validations ;; generator-validations

5
test/adl/to_hugsql_queries_test.clj
View file

@ -62,6 +62,7 @@
actual (order-by-clause entity)] actual (order-by-clause entity)]
(is (string-equal-ignore-whitespace? actual expected)))))) (is (string-equal-ignore-whitespace? actual expected))))))
(deftest keys-name-extraction-tests (deftest keys-name-extraction-tests
(let [application {:tag :application, (let [application {:tag :application,
:attrs {:version "0.1.1", :name "test-app"}, :attrs {:version "0.1.1", :name "test-app"},
@ -241,7 +242,9 @@
(testing "delete query signature" (testing "delete query signature"
(let [expected ":! :n" (let [expected ":! :n"
actual (:signature (first (vals (delete-query entity))))] actual (:signature (first (vals (delete-query entity))))]
(is (string-equal-ignore-whitespace? actual expected)))))) (is (string-equal-ignore-whitespace? actual expected))))
))
(deftest complex-key-tests (deftest complex-key-tests
(let [application {:tag :application, (let [application {:tag :application,

549
test/adl/to_psql_test.clj Normal file
View file

@ -0,0 +1,549 @@
(ns adl.to-psql-test
(:require
[adl-support.utils :refer [child child-with-tag]]
[adl.to-psql :refer [emit-convenience-entity-field emit-convenience-view
emit-property emit-table]]
[clojure.test :refer [deftest is testing]]))
;; (deftest link-property-test
;; (testing "No field generated for link property"
(deftest to-psql-tests
(let [application {:tag :application,
:attrs {:version "0.1.1",
:name "youyesyet",
:xmlns:adl "http://www.journeyman.cc/adl/1.4.7/",
:xmlns:html "http://www.w3.org/1999/xhtml",
:xmlns "http://www.journeyman.cc/adl/1.4.7/"}
:content
[{:tag :typedef,
:attrs
{:size "16",
:pattern
"^([Gg][Ii][Rr] 0[Aa]{2})|((([A-Za-z][0-9]{1,2})|(([A-Za-z][A-Ha-hJ-Yj-y][0-9]{1,2})|(([AZa-z][0-9][A-Za-z])|([A-Za-z][A-Ha-hJ-Yj-y][0-9]?[A-Za-z]))))[0-9][A-Za-z]{2})$",
:type "string",
:name "postcode"},
:content
[{:tag :documentation,
:attrs nil,
:content
["See\n https://assets.publishing.service.gov.uk/government/uploads/system/uploads/attachment_data/file/488478/Bulk_Data_Transfer_-_additional_validation_valid_from_12_November_2015.pdf,\n section 3"]}
{:tag :help,
:attrs {:locale "en_GB.UTF-8"},
:content ["A valid postcode."]}]}
{:tag :entity,
:attrs
{:volatility "6",
:magnitude "6",
:name "addresses",
:table "addresses"},
:content
[{:tag :documentation,
:attrs nil,
:content
["Addresses of all buildings which contain\n dwellings."]}
{: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",
:size "256",
:column "address",
:name "address",
:type "string",
:required "true"},
:content
[{:tag :prompt,
:attrs {:locale "en_GB.UTF-8", :prompt "Address"},
:content nil}]}
{:tag :property,
:attrs
{:distinct "user",
:size "16",
:column "postcode",
:name "postcode",
:typedef "postcode",
:type "defined"},
:content
[{:tag :prompt,
:attrs {:locale "en_GB.UTF-8", :prompt "Postcode"},
:content nil}]}
{:tag :property,
:attrs
{:farkey "id",
:entity "districts",
:column "district_id",
:name "district_id",
:type "entity"},
:content
[{:tag :prompt,
:attrs {:locale "en_GB.UTF-8", :prompt "District"},
:content nil}]}
{:tag :property,
:attrs {:column "latitude", :name "latitude", :type "real"},
:content
[{:tag :prompt,
:attrs {:locale "en_GB.UTF-8", :prompt "Latitude"},
:content nil}]}
{:tag :property,
:attrs {:column "longitude", :name "longitude", :type "real"},
:content
[{:tag :prompt,
:attrs {:locale "en_GB.UTF-8", :prompt "Longitude"},
:content nil}]}
{:tag :property,
:attrs
{:farkey "address_id",
:entity "dwellings",
:name "dwellings",
:type "list"},
:content nil}
{:tag :property,
:attrs {:column "locality", :name "locality", :type "integer"},
:content
[{:tag :documentation,
:attrs nil,
:content
["Locality indexing; see issue #44. Note that\n this property should be generated automatically from the\n latitude and longitude: (+ (* 10000 ;; left-shift the\n latitude component four digits (integer (* latitude 1000)))\n (- ;; invert the sign of the longitude component, since ;;\n we're interested in localities West of Greenwich. (integer (*\n longitude 1000)))) We'll use a trigger to insert this. I\n don't think it will ever appear in the user interface; it's\n an implementation detail, not of interest to\n users."]}
{:tag :generator, :attrs {:action "native"}, :content nil}]}
{:tag :list,
:attrs {:name "Addresses", :properties "listed"},
:content
[{:tag :field,
:attrs {:property "address"},
:content
[{:tag :prompt,
:attrs {:locale "en_GB.UTF-8", :prompt "Address"},
:content nil}]}
{:tag :field,
:attrs {:property "postcode"},
:content
[{:tag :prompt,
:attrs {:locale "en_GB.UTF-8", :prompt "Postcode"},
:content nil}]}
{:tag :field,
:attrs {:property "district_id"},
:content
[{:tag :prompt,
:attrs {:locale "en_GB.UTF-8", :prompt "District"},
:content nil}]}]}
{:tag :form,
:attrs {:name "Address", :properties "listed"},
:content
[{:tag :field,
:attrs {:property "address"},
:content
[{:tag :prompt,
:attrs {:locale "en_GB.UTF-8", :prompt "Address"},
:content nil}]}
{:tag :field,
:attrs {:property "postcode"},
:content
[{:tag :prompt,
:attrs {:locale "en_GB.UTF-8", :prompt "Postcode"},
:content nil}]}
{:tag :field,
:attrs {:property "district_id"},
:content
[{:tag :prompt,
:attrs {:locale "en_GB.UTF-8", :prompt "District"},
:content nil}]}
{:tag :field,
:attrs {:property "latitude"},
:content
[{:tag :prompt,
:attrs {:locale "en_GB.UTF-8", :prompt "Latitude"},
:content nil}]}
{:tag :field,
:attrs {:property "longitude"},
:content
[{:tag :prompt,
:attrs {:locale "en_GB.UTF-8", :prompt "Longitude"},
:content nil}]}
{:tag :auxlist,
:attrs
{:canadd "true",
:onselect "form-dwellings-Dwelling",
:property "dwellings"},
:content
[{:tag :field,
:attrs {:property "sub-address"},
:content
[{:tag :prompt,
:attrs {:locale "en_GB.UTF-8", :prompt "Sub-address"},
: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}]}
{:tag :entity,
:attrs
{:volatility "6",
:magnitude "6",
:name "dwellings",
:table "dwellings"},
:content
[{:tag :documentation,
:attrs nil,
:content
["All dwellings within addresses in the system; a\n dwelling is a house, flat or appartment in which electors live.\n Every address should have at least one dwelling; essentially,\n an address maps onto a street door and dwellings map onto\n what's behind that door. So a tenement or a block of flats\n would be one address with many dwellings."]}
{: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",
:farkey "id",
:entity "addresses",
:column "address_id",
:name "address_id",
:type "entity",
:required "true"},
:content
[{:tag :prompt,
:attrs {:locale "en_GB.UTF-8", :prompt "Building Address"},
:content nil}]}
{:tag :property,
:attrs
{:distinct "user",
:name "sub-address",
:size "32",
:type "string",
:required "false"},
:content
[{:tag :documentation,
:attrs nil,
:content
["\n The part of the address which identifies the flat or\n apartment within the building, if in a multiple occupancy\n building.\n "]}]}
{:tag :property,
:attrs {:entity "electors", :name "electors", :type "list"},
:content nil}
{:tag :list,
:attrs {:name "Dwellings", :properties "listed"},
:content
[{:tag :field,
:attrs {:property "address_id"},
:content
[{:tag :prompt,
:attrs {:locale "en_GB.UTF-8", :prompt "Building Address"},
:content nil}]}
{:tag :field,
:attrs {:property "sub-address"},
:content
[{:tag :prompt,
:attrs {:locale "en_GB.UTF-8", :prompt "Sub address"},
:content nil}]}]}
{:tag :form,
:attrs {:name "Dwelling", :properties "listed"},
:content
[{:tag :field,
:attrs {:property "address_id"},
:content
[{:tag :prompt,
:attrs {:locale "en_GB.UTF-8", :prompt "Building Address"},
:content nil}]}
{:tag :field,
:attrs {:property "sub-address"},
:content
[{:tag :prompt,
:attrs
{:locale "en_GB.UTF-8",
:prompt "Sub address (e.g. flat number)"},
: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}]}
{:tag :entity,
:attrs
{:volatility "7",
:magnitude "4",
:name "districts",
:table "districts"},
:content
[{:tag :documentation,
:attrs nil,
:content
["Electoral districts: TODO: Shape (polygon)\n information will need to be added, for use in\n maps."]}
{: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",
:size "64",
:column "name",
:name "name",
:type "string",
:required "true"},
:content
[{:tag :prompt,
:attrs {:locale "en_GB.UTF-8", :prompt "name"},
:content nil}]}
{:tag :permission,
:attrs {:permission "read", :group "public"},
:content nil}
{:tag :permission,
:attrs {:permission "all", :group "admin"},
:content nil}
{:tag :list,
:attrs {:name "Districts", :properties "listed"},
:content
[{:tag :field,
:attrs {:property "name"},
:content
[{:tag :prompt,
:attrs {:locale "en_GB.UTF-8", :prompt "name"},
:content nil}]}]}
{:tag :form,
:attrs {:name "District", :properties "listed"},
:content
[{:tag :field,
:attrs {:property "name"},
:content
[{:tag :prompt,
:attrs {:locale "en_GB.UTF-8", :prompt "name"},
: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}]}
]}
address-entity (child-with-tag application :entity #(= (-> % :attrs :name) "addresses"))
dwelling-entity (child-with-tag application :entity #(= (-> % :attrs :name) "dwellings"))]
(testing "varchar field"
(let [property (child-with-tag address-entity :property #(= (-> % :attrs :name) "address"))
expected "\t address VARCHAR(256) NOT NULL"
actual (emit-property property address-entity application false)]
(is (= actual expected))))
(testing "integer field"
(let [property (child-with-tag address-entity :property #(= (-> % :attrs :name) "locality"))
expected "\t locality INTEGER"
actual (emit-property property address-entity application false)]
(is (= actual expected))))
(testing "real field"
(let [property (child-with-tag address-entity :property #(= (-> % :attrs :name) "longitude"))
expected "\t longitude DOUBLE PRECISION"
actual (emit-property property address-entity application false)]
(is (= actual expected))))
(testing "list field"
(let [property (child-with-tag address-entity :property #(= (-> % :attrs :name) "dwellings"))
actual (emit-property property address-entity application false)]
(is (nil? actual))))
(testing "entity field"
(let [property (child-with-tag address-entity :property #(= (-> % :attrs :name) "district_id"))
expected "\t district_id INTEGER"
actual (emit-property property address-entity application false)]
(is (= actual expected))))
;; (testing "pattern field"
;; (let [property (child-with-tag address-entity :property #(= (-> % :attrs :name) "postcode"))
;; expected #"\t postcode VARCHAR(16) CONSTRAINT pattern_\d+ CHECK (postcode ~* '^([Gg][Ii][Rr] 0[Aa]{2})|((([A-Za-z][0-9]{1,2})|(([A-Za-z][A-Ha-hJ-Yj-y][0-9]{1,2})|(([AZa-z][0-9][A-Za-z])|([A-Za-z][A-Ha-hJ-Yj-y][0-9]?[A-Za-z]))))[0-9][A-Za-z]{2})$')"
;; actual (emit-property property address-entity application false)]
;; ;; slightly tricky because the pattern name is gensymed.
;; (is (= actual expected))
;; (is (string? (re-find expected actual)))))
(testing "Table creation"
(let [expected "------------------------------------------------------------------------\n--\tTest doc \n--\t\n--\tAll dwellings within addresses in the system; a\n--\t dwelling is a house, flat or appartment in which electors live.\n--\t Every address should have at least one dwelling; essentially,\n--\t an address maps onto a street door and dwellings map onto\n--\t what's behind that door. So a tenement or a block of flats\n--\t would be one address with many dwellings. \n------------------------------------------------------------------------\nCREATE TABLE dwellings\n(\n\t id SERIAL NOT NULL PRIMARY KEY,\n\t address_id INTEGER NOT NULL,\n\t sub_address VARCHAR(32)\n);\nGRANT SELECT ON dwellings TO admin,\n\tanalysts,\n\tcanvassers,\n\tissueeditors,\n\tissueexperts,\n\tteamorganisers ;\nGRANT INSERT ON dwellings TO admin ;\nGRANT UPDATE ON dwellings TO admin ;\nGRANT DELETE ON dwellings TO admin ;"
actual (emit-table dwelling-entity application "Test doc")]
(is (= actual expected))))
(testing "Convenience entity field - is an entity field, should emit"
(let [property (child-with-tag address-entity :property #(= (-> % :attrs :name) "district_id"))
expected "district_id.name AS district_id_expanded"
actual (emit-convenience-entity-field property address-entity application)]
(is (= actual expected))))
(testing "Convenience entity field - is not an entity field, should not emit"
(let [farside dwelling-entity
property (child-with-tag address-entity :property #(= (-> % :attrs :name) "dwellings"))
expected nil
actual (emit-convenience-entity-field property address-entity application)]
(is (= actual expected))))
))
(deftest bug-9-test
(testing "Correct reference to aliased tables in convenience view select queries
see [bug 9](https://github.com/simon-brooke/adl/issues/9)"
(let [app
{:tag :application,
:attrs {:version "0.0.1",
:name "pastoralist",
:xmlns:adl "http://www.journeyman.cc/adl/1.4.7/",
:xmlns:html "http://www.w3.org/1999/xhtml",
:xmlns "http://www.journeyman.cc/adl/1.4.7/"},
:content [{:tag :documentation,
:attrs nil,
:content ["A web-app intended to be used by pastoralists in managing
pastures, grazing, and animals."]}
{:tag :entity,
:attrs {:volatility "5", :magnitude "9", :name "animal" :table "animal"},
:content
[{: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 {:entity "animal", :type "entity", :name "dam"},
:content nil}
{:tag :property,
:attrs {:entity "animal", :type "entity", :name "sire"},
:content nil}
{:tag :property,
:attrs
{:required "true",
:distinct "user",
:size "64",
:type "string",
:name "animal-identifier"},
:content
[{:tag :prompt,
:attrs {:locale "en_GB.UTF-8", :prompt "Ear-tag Number"},
:content nil}]}
{:tag :property,
:attrs {:distinct "user", :size "64", :type "string", :name "name"},
:content nil}]}]}
animal (child app #(= (-> % :attrs :name) "animal"))
dam (child animal #(= (-> % :attrs :name) "dam"))]
(let [actual (emit-convenience-view animal app)
should-find #"dam.animal_identifier"
should-not-find #"animal.name AS dam_expanded"]
;; (print actual) ;; see what we've got
(is (re-find should-find actual))
(is (nil? (re-find should-not-find actual)))))))
(deftest bug-10-test
(testing "Correct table names in convenience view select queries
see [bug 10](https://github.com/simon-brooke/adl/issues/10)"
(let [app
{:tag :application,
:attrs {:version "0.0.1",
:name "pastoralist",
:xmlns:adl "http://www.journeyman.cc/adl/1.4.7/",
:xmlns:html "http://www.w3.org/1999/xhtml",
:xmlns "http://www.journeyman.cc/adl/1.4.7/"},
:content [{:tag :documentation,
:attrs nil,
:content ["A web-app intended to be used by pastoralists in managing
pastures, grazing, and animals."]}
{:tag :entity,
:attrs
{:volatility "5",
:magnitude "3",
:name "event-type",
:table "event-type"},
:content
[{: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 {:size "80", :type "string", :name "summary"},
:content nil}
{:tag :property,
:attrs {:type "text", :name "description"},
:content nil}
{:tag :property,
:attrs {:default "1", :type "integer", :name "n-holdings"},}
{:tag :property,
:attrs {:default "1", :type "integer", :name "n-pastures"}}
{:tag :property,
:attrs {:default "1", :type "integer", :name "n-animals"}}]}]}
should-find #"event_type.description"
should-not-find #"event-type.description"
actual (emit-convenience-view (child app #(= (-> % :attrs :name) "event-type")) app)]
(is (re-find should-find actual))
(is (nil? (re-find should-not-find actual))))))

8
test/adl/validator_test.clj
View file

@ -125,10 +125,10 @@
(let [xml {:tag :group, (let [xml {:tag :group,
:attrs {:name "public"}, :attrs {:name "public"},
:content :content
[{:tag :documentation, :attrs nil, :content ["All users"]}]} [{:tag :documentation, :content ["All users"]}]}
expected true expected nil
actual (binding [*out* (writer "/dev/null")] actual (binding [*out* (writer "/dev/null")]
(valid? xml group-validations))] (first (validate xml group-validations)))]
(is (= actual expected))))) (is (= actual expected)))))
(deftest validator-entity (deftest validator-entity
@ -334,7 +334,7 @@
:content nil}]}]} :content nil}]}]}
expected true expected true
actual (binding [*out* (writer "/dev/null")] actual (binding [*out* (writer "/dev/null")]
(valid? xml entity-validations))] (valid? xml property-validations))]
(is (= actual expected))))) (is (= actual expected)))))