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

Lots of work on trying to get all validator tests to pass.

Browse source 
Three still fail, but substantial progress. The to-husql-queries
tests are failing much worse, but are not a current target (nor is
the validator, frankly, but it irks me that it is so broken)
This commit is contained in:
Simon Brooke 2025-05-22 11:43:48 +01:00
parent 5af9a7349c
commit b944aa6bf1
6 changed files with 677 additions and 639 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
project.clj
View file

@ -5,14 +5,14 @@
:license {:name "GNU Lesser General Public License, version 3.0 or (at your option) any later version" :license {:name "GNU Lesser General Public License, version 3.0 or (at your option) any later version"
:url "https://www.gnu.org/licenses/lgpl-3.0.en.html"} :url "https://www.gnu.org/licenses/lgpl-3.0.en.html"}
:dependencies [[adl-support "0.1.6"] :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.1.0"] [environ "1.2.0"]
[hiccup "1.0.5"] [hiccup "1.0.5"]
[org.clojure/clojure "1.8.0"] [org.clojure/clojure "1.12.0"]
[org.clojure/math.combinatorics "0.1.4"] [org.clojure/math.combinatorics "0.3.0"]
[org.clojure/tools.cli "0.3.7"]] [org.clojure/tools.cli "1.1.230"]]
:aot [adl.main] :aot [adl.main]

658
src/adl/to_hugsql_queries.clj
View file

@ -1,14 +1,12 @@
(ns ^{:doc "Application Description Language - generate HUGSQL queries file." (ns ^{:doc "Application Description Language - generate HUGSQL queries file."
:author "Simon Brooke"} :author "Simon Brooke"}
adl.to-hugsql-queries adl.to-hugsql-queries
(:require [adl-support.core :refer :all] (:require [adl-support.core :refer :all]
[adl-support.utils :refer :all] [adl-support.utils :refer :all]
[clojure.java.io :refer [file make-parents]] [clojure.java.io :refer [make-parents]]
[clojure.math.combinatorics :refer [combinations]] [clojure.math.combinatorics :refer [combinations]]
[clojure.string :as s] [clojure.string :as s]
[clojure.xml :as x] [clj-time.core :as t]))
[clj-time.core :as t]
[clj-time.format :as f]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; ;;;;
@ -33,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)]
(if-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
@ -119,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
@ -150,114 +148,121 @@
"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))})))
(defn search-query [entity application] (defn search-query
"Generate an appropriate search query for string fields of this `entity`" "Generate an appropriate search query for string fields of this `entity`.
Unused second argument was `application`, and is retained for backward
compatibility."
([entity _]
(search-query 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)
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))
(str "get-" pretty-name) (str "get-" pretty-name)
(str "get-" pretty-name "-by-" (s/join "=" (map #(:name (:attrs %)) properties)))) (str "get-" pretty-name "-by-"
(s/join "="
(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
@ -270,23 +275,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
@ -297,84 +302,83 @@
entity-safe (safe-name entity :sql) entity-safe (safe-name entity :sql)
links (filter #(:entity (:attrs %)) (children-with-tag entity :property))] links (filter #(:entity (:attrs %)) (children-with-tag entity :property))]
(apply (apply
merge merge
(map (map
#(let [far-name (:entity (:attrs %)) #(let [far-name (:entity (:attrs %))
far-entity (first far-entity (first
(children (children
application application
(fn [x] (fn [x]
(and (and
(= (:tag x) :entity) (= (:tag x) :entity)
(= (:name (:attrs x)) far-name))))) (= (:name (:attrs x)) far-name)))))
pretty-far (singularise far-name) pretty-far (singularise far-name)
safe-far (safe-name far-entity :sql) safe-far (safe-name far-entity :sql)
farkey (-> % :attrs :farkey) farkey (-> % :attrs :farkey)
link-type (-> % :attrs :type) link-type (-> % :attrs :type)
link-field (-> % :attrs :name) link-field (-> % :attrs :name)
query-name (list-related-query-name % entity far-entity false) query-name (list-related-query-name % entity far-entity false)
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-one-to-many :type :select-one-to-many
:far-entity far-entity :far-entity far-entity
:query :query
(s/join (s/join
"\n" "\n"
(remove (remove
empty? empty?
(case link-type (case link-type
"entity" (list "entity" (list
(str "-- :name " query-name " " signature) (str "-- :name " query-name " " signature)
(str "-- :doc lists all existing " pretty-far " records related to a given " pretty-name) (str "-- :doc lists all existing " pretty-far " records related to a given " pretty-name)
(str "SELECT DISTINCT lv_" entity-safe ".* \nFROM lv_" entity-safe) (str "SELECT DISTINCT lv_" entity-safe ".* \nFROM lv_" entity-safe)
(str "WHERE lv_" entity-safe "." (safe-name % :sql) " = :id") (str "WHERE lv_" entity-safe "." (safe-name % :sql) " = :id")
(order-by-clause entity "lv_" false)) (order-by-clause entity "lv_" false))
"link" (let [ltn "link" (let [ltn
(link-table-name % entity far-entity)] (link-table-name % entity far-entity)]
(list (list
(str "-- :name " query-name " " signature) (str "-- :name " query-name " " signature)
(str "-- :doc links all existing " pretty-far " records related to a given " pretty-name) (str "-- :doc links all existing " pretty-far " records related to a given " pretty-name)
(str "SELECT DISTINCT lv_" safe-far ".* \nFROM lv_" safe-far ", " ltn) (str "SELECT DISTINCT lv_" safe-far ".* \nFROM lv_" safe-far ", " ltn)
(str "WHERE lv_" safe-far "." (str "WHERE lv_" safe-far "."
(safe-name (first (key-names far-entity)) :sql) (safe-name (first (key-names far-entity)) :sql)
" = " ltn "." (singularise safe-far) "_id") " = " ltn "." (singularise safe-far) "_id")
(str "\tAND " ltn "." (singularise entity-safe) "_id = :id") (str "\tAND " ltn "." (singularise entity-safe) "_id = :id")
(order-by-clause far-entity "lv_" false))) (order-by-clause far-entity "lv_" false)))
"list" (list "list" (list
(str "-- :name " query-name " " signature) (str "-- :name " query-name " " signature)
(str "-- :doc lists all existing " pretty-far " records related to a given " pretty-name) (str "-- :doc lists all existing " pretty-far " records related to a given " pretty-name)
(str "SELECT DISTINCT lv_" safe-far ".* \nFROM lv_" safe-far) (str "SELECT DISTINCT lv_" safe-far ".* \nFROM lv_" safe-far)
(str "WHERE lv_" safe-far "." (safe-name (first (key-names far-entity)) :sql) " = :id") (str "WHERE lv_" safe-far "." (safe-name (first (key-names far-entity)) :sql) " = :id")
(order-by-clause far-entity "lv_" false)) (order-by-clause far-entity "lv_" false))
(list (str "ERROR: unexpected type " link-type " of property " %))))) (list (str "ERROR: unexpected type " link-type " of property " %)))))}))
})) links))))
links))))
(defn delete-query (defn delete-query
"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
@ -383,18 +387,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
@ -403,25 +407,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
@ -429,68 +433,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."))))))

8
src/adl/to_psql.clj
View file

@ -3,10 +3,9 @@
adl.to-psql adl.to-psql
(:require [adl-support.core :refer :all] (:require [adl-support.core :refer :all]
[adl-support.utils :refer :all] [adl-support.utils :refer :all]
[adl.to-hugsql-queries :refer [queries]] ;; [adl.to-hugsql-queries :refer [queries]]
[clojure.java.io :refer [file make-parents writer]] [clojure.java.io :refer [make-parents]]
[clojure.string :as s] [clojure.string :as s]
[clojure.xml :as x]
[clj-time.core :as t] [clj-time.core :as t]
[clj-time.format :as f])) [clj-time.format :as f]))
@ -220,7 +219,7 @@
(if (if
key? key?
"NOT NULL PRIMARY KEY" "NOT NULL PRIMARY KEY"
(if (= (:required (:attrs property)) "true") "NOT NULL")))))))))) (when (= (:required (:attrs property)) "true") "NOT NULL"))))))))))
(defn compose-convenience-entity-field (defn compose-convenience-entity-field
@ -259,6 +258,7 @@
(all-properties entity) (all-properties entity)
(user-distinct-properties entity))))))) (user-distinct-properties entity)))))))
(declare compose-convenience-where-clause)
(defn compose-convenience-where-clause (defn compose-convenience-where-clause
"Compose an SQL `WHERE` clause for a convenience view of this "Compose an SQL `WHERE` clause for a convenience view of this

290
src/adl/validator.clj
View file

@ -1,12 +1,12 @@
(ns ^{:doc "Application Description Language: validator for ADL structure. (ns ^{:doc "Application Description Language: validator for ADL structure.
TODO: this is at present largely a failed experiment." TODO: this is at present largely a failed experiment."
:author "Simon Brooke"} :author "Simon Brooke"}
adl.validator adl.validator
(:require [adl-support.utils :refer :all] (:require [adl-support.utils :refer []]
[clojure.set :refer [union]] [clojure.set :refer [union]]
[clojure.xml :refer [parse]] [clojure.xml :refer [parse]]
[bouncer.core :as b] [bouncer.core :as b]
[bouncer.validators :as v])) [bouncer.validators :as v :refer [every member required string]]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; ;;;;
@ -40,14 +40,14 @@
"Pass this `validation` and the object `o` to bouncer" "Pass this `validation` and the object `o` to bouncer"
[o validation] [o validation]
(if (if
(symbol? validation) (symbol? validation)
(try (try
(b/validate o validation) (b/validate o validation)
(catch java.lang.ClassCastException c (catch java.lang.ClassCastException _
;; 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!
(if (string? o) [nil o])) (when (string? o) [nil o]))
(catch Exception e (catch Exception e
[{:error (.getName (.getClass e)) [{:error (.getName (.getClass e))
:message (.getMessage e) :message (.getMessage e)
@ -55,27 +55,26 @@
:context o} o])) :context o} o]))
[(str "Error: not a symbol" validation) o])) [(str "Error: not a symbol" validation) o]))
(defmacro disjunct-valid? (defn disjunct-valid?
"Yes, this is a horrible hack. I should be returning the error structure "Yes, this is a horrible hack. I should be returning the error structure
not printing it. But I can't see how to make that work with `bouncer`. not printing it. But I can't see how to make that work with `bouncer`.
OK, so: most of the validators will (usually) fail, and that's OK. How OK, so: most of the validators will (usually) fail, and that's OK. How
do we identify the one which ought not to have failed?" do we identify the one which ought not to have failed?"
[o & validations] [o & validations]
`(println (println
(str (str
(if (:tag ~o) (str "Tag: " (:tag ~o) "; ")) (when (:tag o) (str "Tag: " (:tag o) "; "))
(if (:name (:attrs ~o)) (str "Name: " (:name (:attrs ~o)) ";")) (when (:name (:attrs o)) (str "Name: " (:name (:attrs o)) ";"))
(if-not (or (:tag ~o) (:name (:attrs ~o))) (str "Context: " ~o)))) (when-not (or (:tag o) (:name (:attrs o))) (str "Context: " o))))
`(empty? (empty?
(remove :tag (remove nil? (map first (map (remove :tag (remove nil? (map first (map
#(try-validate ~o '%) #(try-validate o '%)
~validations)))))) validations))))))
;;; the remainder of this file is a fairly straight translation of the ADL 1.4 DTD into Clojure ;;; the remainder of this file is a fairly straight translation of the ADL 1.4 DTD into Clojure
(declare documentation-validations fieldgroup-validations)
(declare documentation-validations fieldgroup-validations )
(def permissions (def permissions
"permissions a group may have on an entity, list, page, form or field "permissions a group may have on an entity, list, page, form or field
@ -106,7 +105,7 @@
#{"all", "all-delete-orphan", "delete", "manual", "save-update"}) #{"all", "all-delete-orphan", "delete", "manual", "save-update"})
(def defineable-data-types (def defineable-data-types
"data types which can be used in a typedef to provide validation - "data types which can be used in a typedef to provide validation -
e.g. a string can be used with a regexp or a scalar can be used with e.g. a string can be used with a regexp or a scalar can be used with
min and max values min and max values
* `string`: varchar java.sql.Types.VARCHAR * `string`: varchar java.sql.Types.VARCHAR
@ -129,8 +128,8 @@
* `text`: text or java.sql.Types.LONGVARCHAR * `text`: text or java.sql.Types.LONGVARCHAR
memo java.sql.Types.CLOB" memo java.sql.Types.CLOB"
(union (union
defineable-data-types defineable-data-types
#{"boolean" "text"})) #{"boolean" "text"}))
(def complex-data-types (def complex-data-types
"data types which are more complex than SimpleDataTypes... "data types which are more complex than SimpleDataTypes...
@ -170,7 +169,7 @@
(def sequences #{"canonical", "reverse-canonical"}) (def sequences #{"canonical", "reverse-canonical"})
(def reference-validations (def reference-validations
"The 'specification' and 'reference' elements are for documentation only, "The 'specification' and 'reference' elements are for documentation only,
and do not contribute to the engineering of the application described. and do not contribute to the engineering of the application described.
A reference element is a reference to a specifying document. A reference element is a reference to a specifying document.
@ -191,9 +190,18 @@
[:attrs :property] v/string ;; and should be the name of a property in that entity [:attrs :property] v/string ;; and should be the name of a property in that entity
:content [[v/every documentation-validations]]}) :content [[v/every documentation-validations]]})
;; (def sample-reference {:tag :reference
;; :attrs {:abbr "foo"
;; :section "bar"
;; :entity "animal"
;; :property "breed"}
;; :content [{:tag :documentation
;; :content ["Every animal should have a breed."]}]})
;; (b/validate sample-reference reference-validations)
(def specification-validations (def specification-validations
"The 'specification' and 'reference' elements are for documentation only, "The 'specification' and 'reference' elements are for documentation only,
and do not contribute to the engineering of the application described. and do not contribute to the engineering of the application described.
A specification element is intended chiefly to declare the reference A specification element is intended chiefly to declare the reference
@ -208,26 +216,33 @@
[:attrs :name] [v/string v/required] [:attrs :name] [v/string v/required]
[:attrs :abbr] [v/string v/required] [:attrs :abbr] [v/string v/required]
:content [[v/every #(disjunct-valid? :content [[v/every #(disjunct-valid?
%
documentation-validations documentation-validations
reference-validations)]]}) reference-validations)]]})
(def documentation-validations (def documentation-validations
"contains documentation on the element which immediately contains it. TODO: "contains documentation on the element which immediately contains it. For
should HTML markup within a documentation element be allowed? If so, are the time being, HTML markup is not permitted within documentation, but
there restrictions?" Markdown (which may include a string representation of HTML markup) should
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
;; :content ["Every animal should have a breed."
;; sample-reference]})
;; (b/validate sample-documentation documentation-validations)
;; (b/valid? sample-documentation documentation-validations)
(def content-validations (def content-validations
{:tag [v/required [#(= % :content)]]}) {:tag [v/required [#(= % :content)]]})
(def help-validations (def help-validations
"helptext about a property of an entity, or a field of a page, form or "helptext about a property of an entity, or a field of a page, form or
list, or a typedef. Typically there will be only one of these per property list, or a typedef. Typically there will be only one of these per property
per locale; if there are more than one all those matching the locale may per locale; if there are more than one all those matching the locale may
be concatenated, or just one may be used. be concatenated, or just one may be used.
@ -267,7 +282,7 @@
(def prompt-validations (def prompt-validations
"a prompt for a property or field; used as the prompt text for a widget "a prompt for a property or field; used as the prompt text for a widget
which edits it. Typically there will be only one of these per property which edits it. Typically there will be only one of these per property
per locale; if there are more than one all those matching the locale may per locale; if there are more than one all those matching the locale may
be concatenated, or just one may be used. be concatenated, or just one may be used.
@ -293,6 +308,17 @@
(b/valid? % documentation-validations) (b/valid? % documentation-validations)
(b/valid? % prompt-validations))]]}) (b/valid? % prompt-validations))]]})
(def sample-option {:tag :option,
:attrs {:value "Female"},
:content
[{:tag :prompt,
:attrs {:locale "fr-FR", :prompt "Femme"},
:content nil}
{:tag :prompt,
:attrs {:locale "en-GB", :prompt "Female"},
:content nil}]})
(b/validate sample-option option-validations)
(def pragma-validations (def pragma-validations
"pragmatic advice to generators of lists and forms, in the form of "pragmatic advice to generators of lists and forms, in the form of
name/value pairs which may contain anything. Over time some pragmas name/value pairs which may contain anything. Over time some pragmas
@ -302,8 +328,6 @@
[: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
@ -320,8 +344,8 @@
[:attrs :action] [v/string v/required [v/member generator-actions]] [:attrs :action] [v/string v/required [v/member generator-actions]]
[:attrs :class] v/string [:attrs :class] v/string
:content [[v/every #(disjunct-valid? % :content [[v/every #(disjunct-valid? %
documentation-validations documentation-validations
param-validations)]]}) param-validations)]]})
(def in-implementation-validations (def in-implementation-validations
@ -359,22 +383,22 @@
[:attrs :name] [v/required v/string] [:attrs :name] [v/required v/string]
[:attrs :type] [[v/member defineable-data-types]] [:attrs :type] [[v/member defineable-data-types]]
[:attrs :size] [[#(if [:attrs :size] [[#(if
(string? %) (string? %)
(integer? (read-string %)) (integer? (read-string %))
(integer? %))]] (integer? %))]]
[:attrs :pattern] v/string [:attrs :pattern] v/string
[:attrs :minimum] [[#(if [:attrs :minimum] [[#(if
(string? %) (string? %)
(integer? (read-string %)) (integer? (read-string %))
(integer? %))]] (integer? %))]]
[:attrs :maximum] [[#(if [:attrs :maximum] [[#(if
(string? %) (string? %)
(integer? (read-string %)) (integer? (read-string %))
(integer? %))]] (integer? %))]]
:content [[v/every #(or :content [[v/every #(or
(b/valid? % documentation-validations) (b/valid? % documentation-validations)
(b/valid? % in-implementation-validations) (b/valid? % in-implementation-validations)
(b/valid? % help-validations))]]}) (b/valid? % help-validations))]]})
(def group-validations (def group-validations
"a group of people with similar permissions to one another "a group of people with similar permissions to one another
@ -387,7 +411,7 @@
:content [[v/every documentation-validations]]}) :content [[v/every documentation-validations]]})
(def property-validations (def property-validations
"a property (field) of an entity (table) "a property (field) of an entity (table)
* `name`: the name of this property. * `name`: the name of this property.
* `type`: the type of this property. * `type`: the type of this property.
@ -425,35 +449,55 @@
committed to persistent store, the value which it holds before committed to persistent store, the value which it holds before
it has been committed" it has been committed"
{:tag [v/required [#(= % :property)]] {:tag [v/required [#(= % :property)]]
[:attrs :name] [v/required v/string]
[:attrs :type] [v/required [v/member all-data-types]]
;; [:attrs :default] [] ;; it's allowed, but I don't have anything particular to say about it
[:attrs :typedef] v/string
[:attrs :distinct] [v/string [v/member #{"none", "all", "user", "system"}]] [:attrs :distinct] [v/string [v/member #{"none", "all", "user", "system"}]]
[:attrs :entity] v/string [:attrs :entity] v/string
[:attrs :farkey] v/string [:attrs :farkey] v/string
[:attrs :required] [[v/member #{"true", "false"}]]
[:attrs :immutable] [[v/member #{"true", "false"}]] [:attrs :immutable] [[v/member #{"true", "false"}]]
[:attrs :name] [v/required v/string]
[:attrs :required] [[v/member #{"true", "false"}]]
[:attrs :size] [[#(cond [:attrs :size] [[#(cond
(empty? %) ;; it's allowed to be missing (empty? %) ;; it's allowed to be missing
true true
(string? %) (string? %)
(integer? (read-string %)) (integer? (read-string %))
true :else
(integer? %))]] (integer? %))]]
[:attrs :type] [v/required [v/member all-data-types]]
;; [:attrs :default] [] ;; it's allowed, but I don't have anything particular to say about it
[:attrs :typedef] v/string
[:attrs :cascade] [[v/member cascade-actions]]
[:attrs :column] v/string [:attrs :column] v/string
[:attrs :concrete] [[v/member #{"true", "false"}]] [:attrs :concrete] [[v/member #{"true", "false"}]]
[:attrs :cascade] [[v/member cascade-actions]] :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
;; generator-validations
;; permission-validations
;; option-validations
;; prompt-validations
;; help-validations
;; ifmissing-validations)
;; (def sample-property {:tag :property,
;; :attrs
;; {:immutable "true",
;; :required "true",
;; :distinct "system",
;; :type "integer",
;; :name "id"},
;; :content
;; [{:tag :generator, :attrs {:action "native"}, :content nil}]})
;; (b/validate sample-property property-validations)
(def permission-validations (def permission-validations
"permissions policy on an entity, a page, form, list or field "permissions policy on an entity, a page, form, list or field
@ -486,10 +530,10 @@
{:tag [v/required [#(= % :field)]] {:tag [v/required [#(= % :field)]]
[:attrs :property] [v/string v/required] ;; and it must also be the name of a property in the current entity [:attrs :property] [v/string v/required] ;; and it must also be the name of a property in the current entity
:content [[v/every #(or :content [[v/every #(or
(b/valid? % documentation-validations) (b/valid? % documentation-validations)
(b/valid? % prompt-validations) (b/valid? % prompt-validations)
(b/valid? % permission-validations) (b/valid? % permission-validations)
(b/valid? % help-validations))]]}) (b/valid? % help-validations))]]})
(def verb-validations (def verb-validations
"a verb is something that may be done through a form. Probably the verbs 'store' "a verb is something that may be done through a form. Probably the verbs 'store'
@ -526,12 +570,12 @@
[:attrs :onselect] v/string [:attrs :onselect] v/string
[:attrs :canadd] v/boolean [:attrs :canadd] v/boolean
:content [[v/every #(or :content [[v/every #(or
(b/valid? % documentation-validations) (b/valid? % documentation-validations)
(b/valid? % prompt-validations) (b/valid? % prompt-validations)
(b/valid? % field-validations) (b/valid? % field-validations)
(b/valid? % fieldgroup-validations) (b/valid? % fieldgroup-validations)
(b/valid? % auxlist-validations) (b/valid? % auxlist-validations)
(b/valid? % verb-validations))]]}) (b/valid? % verb-validations))]]})
(def fieldgroup-validations (def fieldgroup-validations
"a group of fields and other controls within a form or list, which the "a group of fields and other controls within a form or list, which the
@ -539,14 +583,14 @@
{:tag [v/required [#(= % :fieldgroup)]] {:tag [v/required [#(= % :fieldgroup)]]
[:attrs :name] [v/string v/required] [:attrs :name] [v/string v/required]
:content [[v/every #(or :content [[v/every #(or
(b/valid? % documentation-validations) (b/valid? % documentation-validations)
(b/valid? % prompt-validations) (b/valid? % prompt-validations)
(b/valid? % permission-validations) (b/valid? % permission-validations)
(b/valid? % help-validations) (b/valid? % help-validations)
(b/valid? % field-validations) (b/valid? % field-validations)
(b/valid? % fieldgroup-validations) (b/valid? % fieldgroup-validations)
(b/valid? % auxlist-validations) (b/valid? % auxlist-validations)
(b/valid? % verb-validations))]]}) (b/valid? % verb-validations))]]})
(def form-validations (def form-validations
@ -556,16 +600,16 @@
[:attrs :properties] [v/required [v/member #{"all", "user-distinct", "listed"}]] [:attrs :properties] [v/required [v/member #{"all", "user-distinct", "listed"}]]
[:attrs :canadd] [[v/member #{"true", "false"}]] [:attrs :canadd] [[v/member #{"true", "false"}]]
:content [[v/every #(disjunct-valid? % :content [[v/every #(disjunct-valid? %
documentation-validations documentation-validations
head-validations head-validations
top-validations top-validations
foot-validations foot-validations
field-validations field-validations
fieldgroup-validations fieldgroup-validations
auxlist-validations auxlist-validations
verb-validations verb-validations
permission-validations permission-validations
pragma-validations)]]}) pragma-validations)]]})
(def page-validations (def page-validations
"a page on which an entity may be displayed" "a page on which an entity may be displayed"
@ -573,16 +617,16 @@
[:attrs :name] [v/required v/string] [:attrs :name] [v/required v/string]
[:attrs :properties] [v/required [v/member #{"all", "user-distinct", "listed"}]] [:attrs :properties] [v/required [v/member #{"all", "user-distinct", "listed"}]]
:content [[v/every #(disjunct-valid? % :content [[v/every #(disjunct-valid? %
documentation-validations documentation-validations
head-validations head-validations
top-validations top-validations
foot-validations foot-validations
field-validations field-validations
fieldgroup-validations fieldgroup-validations
auxlist-validations auxlist-validations
verb-validations verb-validations
permission-validations permission-validations
pragma-validations)]]}) pragma-validations)]]})
(def list-validations (def list-validations
"a list on which entities of a given type are listed "a list on which entities of a given type are listed
@ -594,17 +638,17 @@
[:attrs :properties] [v/required [v/member #{"all", "user-distinct", "listed"}]] [:attrs :properties] [v/required [v/member #{"all", "user-distinct", "listed"}]]
[:attrs :onselect] v/string [:attrs :onselect] v/string
:content [[v/every #(disjunct-valid? % :content [[v/every #(disjunct-valid? %
documentation-validations documentation-validations
head-validations head-validations
top-validations top-validations
foot-validations foot-validations
field-validations field-validations
fieldgroup-validations fieldgroup-validations
auxlist-validations auxlist-validations
verb-validations verb-validations
permission-validations permission-validations
pragma-validations pragma-validations
order-validations)]]}) order-validations)]]})
(def key-validations (def key-validations
{:tag [v/required [#(= % :key)]] {:tag [v/required [#(= % :key)]]
@ -632,15 +676,15 @@
[:attrs :table] v/string [:attrs :table] v/string
[:attrs :foreign] [[v/member #{"true", "false"}]] [:attrs :foreign] [[v/member #{"true", "false"}]]
:content [[v/every #(disjunct-valid? % :content [[v/every #(disjunct-valid? %
documentation-validations documentation-validations
prompt-validations prompt-validations
content-validations content-validations
key-validations key-validations
property-validations property-validations
permission-validations permission-validations
form-validations form-validations
page-validations page-validations
list-validations)]]}) list-validations)]]})
(def application-validations (def application-validations
{:tag [v/required [#(= % :application)]] {:tag [v/required [#(= % :application)]]
@ -649,12 +693,12 @@
[:attrs :revision] v/string [:attrs :revision] v/string
[:attrs :currency] v/string [:attrs :currency] v/string
:content [[v/every #(disjunct-valid? % :content [[v/every #(disjunct-valid? %
specification-validations specification-validations
documentation-validations documentation-validations
content-validations content-validations
typedef-validations typedef-validations
group-validations group-validations
entity-validations)]]}) entity-validations)]]})
(defn valid-adl? (defn valid-adl?

313
test/adl/to_hugsql_queries_test.clj
View file

@ -1,109 +1,104 @@
(ns adl.to-hugsql-queries-test (ns adl.to-hugsql-queries-test
(:require [clojure.string :as s] (:require [clojure.string :as s]
[clojure.test :refer :all] [clojure.test :refer [deftest is testing]]
[adl.to-hugsql-queries :refer :all] [adl.to-hugsql-queries :refer [delete-query insert-query list-query order-by-clause search-query select-query update-query]]
[adl-support.utils :refer :all])) [adl-support.utils :refer [child-with-tag has-non-key-properties? has-primary-key? key-names]]))
(defn string-equal-ignore-whitespace? (defn string-equal-ignore-whitespace?
"I don't want unit tests to fail just because emitted whitespace changes." "I don't want unit tests to fail just because emitted whitespace changes."
[a b] [a b]
(if (if
(and (and
(string? a) (string? a)
(string? b)) (string? b))
(let (let
[pattern #"[\s]+" [pattern #"[\s]+"
aa (s/replace a pattern " ") aa (s/replace a pattern " ")
bb (s/replace b pattern " ")] bb (s/replace b pattern " ")]
(= aa bb)) (= aa bb))
(= a b))) (= a b)))
(deftest order-by-tests (deftest order-by-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"},
:content :content
[{:tag :entity, [{:tag :entity,
:attrs {:name "address"}, :attrs {:name "address"},
:content :content
[{:tag :key, [{:tag :key,
:attrs nil, :attrs nil,
:content :content
[{:tag :property, [{:tag :property,
:attrs :attrs
{:immutable "true", {:immutable "true",
:required "true", :required "true",
:distinct "system", :distinct "system",
:type "integer", :type "integer",
:name "id"}, :name "id"},
:content :content
[{:tag :generator, :attrs {:action "native"}, :content nil}]} [{:tag :generator, :attrs {:action "native"}, :content nil}]}
{:tag :property, {:tag :property,
:attrs :attrs
{:immutable "true", {:immutable "true",
:required "true", :required "true",
:distinct "all", :distinct "all",
:generator "assigned" :generator "assigned"
:type "string", :type "string",
:size "12" :size "12"
:name "postcode"}, :name "postcode"},
:content :content
[{:tag :generator, :attrs {:action "native"}, :content nil}]} [{:tag :generator, :attrs {:action "native"}, :content nil}]}]}
]} {:tag :property,
{:tag :property, :attrs
:attrs {:distinct "user", :size "128", :type "string", :name "street"},
{:distinct "user", :size "128", :type "string", :name "street"}, :content nil}
:content nil} {:tag :property,
{:tag :property, :attrs {:size "64", :type "string", :name "town"},
:attrs {:size "64", :type "string", :name "town"}, :content nil}]}]}
:content nil}
]}]}
entity (child-with-tag application :entity)] entity (child-with-tag application :entity)]
(testing "user distinct properties should provide the default ordering" (testing "user distinct properties should provide the default ordering"
(let [expected (let [expected
"ORDER BY address.street, address.postcode, address.id" "ORDER BY address.street, address.postcode, address.id"
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"},
:content :content
[{:tag :entity, [{:tag :entity,
:attrs {:name "address"}, :attrs {:name "address"},
:content :content
[{:tag :key, [{:tag :key,
:attrs nil, :attrs nil,
:content :content
[{:tag :property, [{:tag :property,
:attrs :attrs
{:immutable "true", {:immutable "true",
:required "true", :required "true",
:distinct "system", :distinct "system",
:type "integer", :type "integer",
:name "id"}, :name "id"},
:content :content
[{:tag :generator, :attrs {:action "native"}, :content nil}]} [{:tag :generator, :attrs {:action "native"}, :content nil}]}
{:tag :property, {:tag :property,
:attrs :attrs
{:immutable "true", {:immutable "true",
:required "true", :required "true",
:distinct "all", :distinct "all",
:generator "assigned" :generator "assigned"
:type "string", :type "string",
:size "12" :size "12"
:name "postcode"}, :name "postcode"},
:content :content
[{:tag :generator, :attrs {:action "native"}, :content nil}]} [{:tag :generator, :attrs {:action "native"}, :content nil}]}]}
]} {:tag :property,
{:tag :property, :attrs
:attrs {:distinct "user", :size "128", :type "string", :name "street"},
{:distinct "user", :size "128", :type "string", :name "street"}, :content nil}
:content nil} {:tag :property,
{:tag :property, :attrs {:size "64", :type "string", :name "town"},
:attrs {:size "64", :type "string", :name "town"}, :content nil}]}]}
:content nil}
]}]}
entity (child-with-tag application :entity)] entity (child-with-tag application :entity)]
(testing "keys name extraction" (testing "keys name extraction"
(let [expected #{"id" "postcode"} (let [expected #{"id" "postcode"}
@ -113,43 +108,41 @@
(deftest entity-tests (deftest entity-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"},
:content :content
[{:tag :entity, [{:tag :entity,
:attrs {:name "address"}, :attrs {:name "address"},
:content :content
[{:tag :key, [{:tag :key,
:attrs nil, :attrs nil,
:content :content
[{:tag :property, [{:tag :property,
:attrs :attrs
{:immutable "true", {:immutable "true",
:required "true", :required "true",
:distinct "system", :distinct "system",
:type "integer", :type "integer",
:name "id"}, :name "id"},
:content :content
[{:tag :generator, :attrs {:action "native"}, :content nil}]} [{:tag :generator, :attrs {:action "native"}, :content nil}]}
{:tag :property, {:tag :property,
:attrs :attrs
{:immutable "true", {:immutable "true",
:required "true", :required "true",
:distinct "all", :distinct "all",
:generator "assigned" :generator "assigned"
:type "string", :type "string",
:size "12" :size "12"
:name "postcode"}, :name "postcode"},
:content :content
[{:tag :generator, :attrs {:action "native"}, :content nil}]} [{:tag :generator, :attrs {:action "native"}, :content nil}]}]}
]} {:tag :property,
{:tag :property, :attrs
:attrs {:distinct "user", :size "128", :type "string", :name "street"},
{:distinct "user", :size "128", :type "string", :name "street"}, :content nil}
:content nil} {:tag :property,
{:tag :property, :attrs {:size "64", :type "string", :name "town"},
:attrs {:size "64", :type "string", :name "town"}, :content nil}]}]}
:content nil}
]}]}
entity (child-with-tag application :entity)] entity (child-with-tag application :entity)]
(testing "keys name extraction" (testing "keys name extraction"
(let [expected #{"id"} (let [expected #{"id"}
@ -248,49 +241,45 @@
(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,
:attrs {:version "0.1.1", :name "test-app"}, :attrs {:version "0.1.1", :name "test-app"},
:content :content
[{:tag :entity, [{:tag :entity,
:attrs {:name "address"}, :attrs {:name "address"},
:content :content
[{:tag :key, [{:tag :key,
:attrs nil, :attrs nil,
:content :content
[{:tag :property, [{:tag :property,
:attrs :attrs
{:immutable "true", {:immutable "true",
:required "true", :required "true",
:distinct "system", :distinct "system",
:type "integer", :type "integer",
:name "id"}, :name "id"},
:content :content
[{:tag :generator, :attrs {:action "native"}, :content nil}]} [{:tag :generator, :attrs {:action "native"}, :content nil}]}
{:tag :property, {:tag :property,
:attrs :attrs
{:immutable "true", {:immutable "true",
:required "true", :required "true",
:distinct "all", :distinct "all",
:generator "assigned" :generator "assigned"
:type "string", :type "string",
:size "12" :size "12"
:name "postcode"}, :name "postcode"},
:content :content
[{:tag :generator, :attrs {:action "native"}, :content nil}]} [{:tag :generator, :attrs {:action "native"}, :content nil}]}]}
]} {:tag :property,
{:tag :property, :attrs
:attrs {:distinct "user", :size "128", :type "string", :name "street"},
{:distinct "user", :size "128", :type "string", :name "street"}, :content nil}
:content nil} {:tag :property,
{:tag :property, :attrs {:size "64", :type "string", :name "town"},
:attrs {:size "64", :type "string", :name "town"}, :content nil}]}]}
:content nil}
]}]}
entity (child-with-tag application :entity)] entity (child-with-tag application :entity)]
(testing "user distinct properties should provide the default ordering" (testing "user distinct properties should provide the default ordering"
(let [expected "ORDER BY address.street, (let [expected "ORDER BY address.street,

37
test/adl/validator_test.clj
View file

@ -1,9 +1,10 @@
(ns adl.validator-test (ns adl.validator-test
(:require [clojure.java.io :refer [writer]] (:require
[clojure.test :refer :all] [adl.validator :refer :all]
[clojure.xml :refer [parse]] [bouncer.core :refer [valid? validate]]
[adl.validator :refer :all] [clojure.java.io :refer [writer]]
[bouncer.core :refer [valid?]])) [clojure.test :refer :all]
[clojure.xml :refer [parse]]))
;; OK, so where we're up to: documentation breaks validation of the ;; OK, so where we're up to: documentation breaks validation of the
;; element that contains it if the documentation is non-empty. ;; element that contains it if the documentation is non-empty.
@ -262,9 +263,9 @@
:name "id"}, :name "id"},
:content :content
[{:tag :generator, :attrs {:action "native"}, :content nil}]}]} [{:tag :generator, :attrs {:action "native"}, :content nil}]}]}
expected true expected nil
actual (binding [*out* (writer "/dev/null")] actual (first (binding [*out* (writer "/dev/null")]
(valid? xml key-validations))] (validate xml key-validations)))]
(is (= actual expected))))) (is (= actual expected)))))
(deftest validator-property (deftest validator-property
@ -340,14 +341,14 @@
(deftest validator-option (deftest validator-option
(testing "Validation of option element" (testing "Validation of option element"
(let [xml {:tag :option, (let [xml {:tag :option,
:attrs {:value "Female"}, :attrs {:value "Female"},
:content :content
[{:tag :prompt, [{:tag :prompt,
:attrs {:locale "fr-FR", :prompt "Femme"}, :attrs {:locale "fr-FR", :prompt "Femme"},
:content nil} :content nil}
{:tag :prompt, {:tag :prompt,
:attrs {:locale "en-GB", :prompt "Female"}, :attrs {:locale "en-GB", :prompt "Female"},
:content nil}]} :content nil}]}
expected true expected true
actual (binding [*out* (writer "/dev/null")] actual (binding [*out* (writer "/dev/null")]
(valid? xml option-validations))] (valid? xml option-validations))]
@ -378,8 +379,8 @@
(deftest validator-page (deftest validator-page
(testing "Validation of page element" (testing "Validation of page element"
(let [xml {:tag :page, (let [xml {:tag :page,
:attrs {:properties "all", :name "inspect-person"}, :attrs {:properties "all", :name "inspect-person"},
:content nil} :content nil}
expected true expected true
actual (binding [*out* (writer "/dev/null")] actual (binding [*out* (writer "/dev/null")]
(valid? xml page-validations))] (valid? xml page-validations))]