Lots of work on trying to get all validator tests to pass.
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:
parent
5af9a7349c
commit
b944aa6bf1
10
project.clj
10
project.clj
|
|
@ -5,14 +5,14 @@
|
|||
: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"}
|
||||
|
||||
:dependencies [[adl-support "0.1.6"]
|
||||
:dependencies [[adl-support "0.1.8-SNAPSHOT"]
|
||||
[bouncer "1.0.1"]
|
||||
[clojure-saxon "0.9.4"]
|
||||
[environ "1.1.0"]
|
||||
[environ "1.2.0"]
|
||||
[hiccup "1.0.5"]
|
||||
[org.clojure/clojure "1.8.0"]
|
||||
[org.clojure/math.combinatorics "0.1.4"]
|
||||
[org.clojure/tools.cli "0.3.7"]]
|
||||
[org.clojure/clojure "1.12.0"]
|
||||
[org.clojure/math.combinatorics "0.3.0"]
|
||||
[org.clojure/tools.cli "1.1.230"]]
|
||||
|
||||
:aot [adl.main]
|
||||
|
||||
|
|
|
|||
|
|
@ -1,14 +1,12 @@
|
|||
(ns ^{:doc "Application Description Language - generate HUGSQL queries file."
|
||||
:author "Simon Brooke"}
|
||||
:author "Simon Brooke"}
|
||||
adl.to-hugsql-queries
|
||||
(:require [adl-support.core :refer :all]
|
||||
[adl-support.utils :refer :all]
|
||||
[clojure.java.io :refer [file make-parents]]
|
||||
[clojure.math.combinatorics :refer [combinations]]
|
||||
[clojure.string :as s]
|
||||
[clojure.xml :as x]
|
||||
[clj-time.core :as t]
|
||||
[clj-time.format :as f]))
|
||||
(:require [adl-support.core :refer :all]
|
||||
[adl-support.utils :refer :all]
|
||||
[clojure.java.io :refer [make-parents]]
|
||||
[clojure.math.combinatorics :refer [combinations]]
|
||||
[clojure.string :as s]
|
||||
[clj-time.core :as t]))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;;;
|
||||
|
|
@ -33,78 +31,78 @@
|
|||
;;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(def expanded-token "_expanded")
|
||||
(def expanded-token "_expanded")
|
||||
|
||||
|
||||
(defn where-clause
|
||||
"Generate an appropriate `where` clause for queries on this `entity`;
|
||||
(defn where-clause
|
||||
"Generate an appropriate `where` clause for queries on this `entity`;
|
||||
if `properties` are passed, filter on those properties, otherwise the key
|
||||
properties."
|
||||
([entity]
|
||||
(where-clause entity (key-properties entity)))
|
||||
([entity properties]
|
||||
(let
|
||||
([entity]
|
||||
(where-clause entity (key-properties entity)))
|
||||
([entity properties]
|
||||
(let
|
||||
[entity-name (safe-name entity :sql)
|
||||
property-names (map #(:name (:attrs %)) properties)]
|
||||
(if-not (empty? property-names)
|
||||
(str
|
||||
(when-not (empty? property-names)
|
||||
(str
|
||||
"WHERE "
|
||||
(s/join
|
||||
"\n\tAND "
|
||||
(map
|
||||
#(str entity-name "." (safe-name % :sql) " = :" %)
|
||||
property-names)))))))
|
||||
"\n\tAND "
|
||||
(map
|
||||
#(str entity-name "." (safe-name % :sql) " = :" %)
|
||||
property-names)))))))
|
||||
|
||||
|
||||
(defn order-by-clause
|
||||
"Generate an appropriate `order by` clause for queries on this `entity`"
|
||||
([entity]
|
||||
(order-by-clause entity "" false))
|
||||
([entity prefix]
|
||||
(order-by-clause entity prefix false))
|
||||
([entity prefix expanded?]
|
||||
(let
|
||||
(defn order-by-clause
|
||||
"Generate an appropriate `order by` clause for queries on this `entity`"
|
||||
([entity]
|
||||
(order-by-clause entity "" false))
|
||||
([entity prefix]
|
||||
(order-by-clause entity prefix false))
|
||||
([entity prefix expanded?]
|
||||
(let
|
||||
[entity-name (safe-name entity :sql)
|
||||
preferred (filter #(#{"user" "all"} (-> % :attrs :distinct))
|
||||
(descendants-with-tag entity :property))]
|
||||
(if
|
||||
(if
|
||||
(empty? preferred)
|
||||
""
|
||||
(str
|
||||
""
|
||||
(str
|
||||
"ORDER BY " prefix entity-name "."
|
||||
(s/join
|
||||
(str ",\n\t" prefix entity-name ".")
|
||||
(map
|
||||
#(if
|
||||
(and expanded? (= "entity" (-> % :attrs :type)))
|
||||
(str (safe-name % :sql) expanded-token)
|
||||
(safe-name % :sql))
|
||||
(order-preserving-set
|
||||
(concat
|
||||
preferred
|
||||
(key-properties entity))))))))))
|
||||
(str ",\n\t" prefix entity-name ".")
|
||||
(map
|
||||
#(if
|
||||
(and expanded? (= "entity" (-> % :attrs :type)))
|
||||
(str (safe-name % :sql) expanded-token)
|
||||
(safe-name % :sql))
|
||||
(order-preserving-set
|
||||
(concat
|
||||
preferred
|
||||
(key-properties entity))))))))))
|
||||
|
||||
;; (def a (x/parse "../youyesyet/youyesyet.adl.xml"))
|
||||
;; (def e (child-with-tag a :entity #(= "dwellings" (-> % :attrs :name))))
|
||||
;; (order-by-clause e "" true)
|
||||
|
||||
|
||||
(defn insert-query
|
||||
"Generate an appropriate `insert` query for this `entity`.
|
||||
(defn insert-query
|
||||
"Generate an appropriate `insert` query for this `entity`.
|
||||
TODO: this depends on the idea that system-unique properties
|
||||
are not insertable, which is... dodgy."
|
||||
[entity]
|
||||
(let [entity-name (safe-name entity :sql)
|
||||
pretty-name (singularise entity-name)
|
||||
insertable-property-names (map
|
||||
[entity]
|
||||
(let [entity-name (safe-name entity :sql)
|
||||
pretty-name (singularise entity-name)
|
||||
insertable-property-names (map
|
||||
#(safe-name % :sql)
|
||||
(insertable-properties entity))
|
||||
query-name (str "create-" pretty-name "!")
|
||||
signature (if (has-primary-key? entity)
|
||||
":? :1" ;; bizarrely, if you want to return the keys,
|
||||
query-name (str "create-" pretty-name "!")
|
||||
signature (if (has-primary-key? entity)
|
||||
":? :1" ;; bizarrely, if you want to return the keys,
|
||||
;; you have to use a query signature.
|
||||
":! :n")]
|
||||
(hash-map
|
||||
":! :n")]
|
||||
(hash-map
|
||||
(keyword query-name)
|
||||
{:name query-name
|
||||
:signature signature
|
||||
|
|
@ -119,26 +117,26 @@
|
|||
(s/join ",\n\t" (map keyword insertable-property-names))
|
||||
")"
|
||||
(if
|
||||
(has-primary-key? entity)
|
||||
(has-primary-key? entity)
|
||||
(str "\nreturning "
|
||||
(s/join
|
||||
",\n\t"
|
||||
(map
|
||||
#(safe-name % :sql)
|
||||
(key-names entity))))))})))
|
||||
",\n\t"
|
||||
(map
|
||||
#(safe-name % :sql)
|
||||
(key-names entity))))))})))
|
||||
|
||||
|
||||
(defn update-query
|
||||
"Generate an appropriate `update` query for this `entity`"
|
||||
[entity]
|
||||
(let [entity-name (safe-name entity :sql)
|
||||
pretty-name (singularise entity-name)
|
||||
property-names (map
|
||||
(defn update-query
|
||||
"Generate an appropriate `update` query for this `entity`"
|
||||
[entity]
|
||||
(let [entity-name (safe-name entity :sql)
|
||||
pretty-name (singularise entity-name)
|
||||
property-names (map
|
||||
#(-> % :attrs :name)
|
||||
(insertable-properties entity))
|
||||
query-name (str "update-" pretty-name "!")
|
||||
signature ":! :n"]
|
||||
(hash-map
|
||||
query-name (str "update-" pretty-name "!")
|
||||
signature ":! :n"]
|
||||
(hash-map
|
||||
(keyword query-name)
|
||||
{:name query-name
|
||||
:signature signature
|
||||
|
|
@ -150,114 +148,121 @@
|
|||
"UPDATE " entity-name "\n"
|
||||
"SET "
|
||||
(s/join
|
||||
",\n\t"
|
||||
(map
|
||||
#(str (safe-name % :sql) " = " (keyword %))
|
||||
property-names))
|
||||
",\n\t"
|
||||
(map
|
||||
#(str (safe-name % :sql) " = " (keyword %))
|
||||
property-names))
|
||||
"\n"
|
||||
(where-clause entity))})))
|
||||
|
||||
|
||||
(defn search-query [entity application]
|
||||
"Generate an appropriate search query for string fields of this `entity`"
|
||||
(defn search-query
|
||||
"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)
|
||||
pretty-name (singularise entity-name)
|
||||
query-name (str "search-strings-" entity-name)
|
||||
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
|
||||
(keyword query-name)
|
||||
{:name query-name
|
||||
:signature signature
|
||||
:entity entity
|
||||
:type :text-search
|
||||
:query
|
||||
(s/join
|
||||
"\n"
|
||||
(remove
|
||||
empty?
|
||||
(list
|
||||
(str "-- :name " query-name " " signature)
|
||||
(str
|
||||
"-- :doc selects existing "
|
||||
pretty-name
|
||||
" records having any string field matching the parameter of the same name by substring match")
|
||||
(str "SELECT DISTINCT * FROM lv_" entity-name)
|
||||
(s/join
|
||||
"\n\t--~ "
|
||||
(cons
|
||||
"WHERE true"
|
||||
(filter
|
||||
string?
|
||||
(map
|
||||
#(let
|
||||
[sn (safe-name % :sql)]
|
||||
(str
|
||||
"(if (:" (-> % :attrs :name) " params) (str \"AND "
|
||||
(case (-> % :attrs :type)
|
||||
("string" "text")
|
||||
(str
|
||||
sn
|
||||
" LIKE '%\" (:" (-> % :attrs :name) " params) \"%' ")
|
||||
("date" "time" "timestamp")
|
||||
(str
|
||||
sn
|
||||
" = ':" (-> % :attrs :name) "'")
|
||||
"entity"
|
||||
(str
|
||||
sn
|
||||
"_expanded LIKE '%\" (:" (-> % :attrs :name) " params) \"%'")
|
||||
(str
|
||||
sn
|
||||
" = :"
|
||||
(-> % :attrs :name)))
|
||||
"\"))"))
|
||||
properties))))
|
||||
(order-by-clause entity "lv_" true)
|
||||
"--~ (if (:offset params) \"OFFSET :offset \")"
|
||||
"--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))})))
|
||||
(keyword query-name)
|
||||
{:name query-name
|
||||
:signature signature
|
||||
:entity entity
|
||||
:type :text-search
|
||||
:query
|
||||
(s/join
|
||||
"\n"
|
||||
(remove
|
||||
empty?
|
||||
(list
|
||||
(str "-- :name " query-name " " signature)
|
||||
(str
|
||||
"-- :doc selects existing "
|
||||
pretty-name
|
||||
" records having any string field matching the parameter of the same name by substring match")
|
||||
(str "SELECT DISTINCT * FROM lv_" entity-name)
|
||||
(s/join
|
||||
"\n\t--~ "
|
||||
(cons
|
||||
"WHERE true"
|
||||
(filter
|
||||
string?
|
||||
(map
|
||||
#(let
|
||||
[sn (safe-name % :sql)]
|
||||
(str
|
||||
"(if (:" (-> % :attrs :name) " params) (str \"AND "
|
||||
(case (-> % :attrs :type)
|
||||
("string" "text")
|
||||
(str
|
||||
sn
|
||||
" LIKE '%\" (:" (-> % :attrs :name) " params) \"%' ")
|
||||
("date" "time" "timestamp")
|
||||
(str
|
||||
sn
|
||||
" = ':" (-> % :attrs :name) "'")
|
||||
"entity"
|
||||
(str
|
||||
sn
|
||||
"_expanded LIKE '%\" (:" (-> % :attrs :name) " params) \"%'")
|
||||
(str
|
||||
sn
|
||||
" = :"
|
||||
(-> % :attrs :name)))
|
||||
"\"))"))
|
||||
properties))))
|
||||
(order-by-clause entity "lv_" true)
|
||||
"--~ (if (:offset params) \"OFFSET :offset \")"
|
||||
"--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))}))))
|
||||
|
||||
;; (search-query e a)
|
||||
|
||||
|
||||
(defn select-query
|
||||
"Generate an appropriate `select` query for this `entity`"
|
||||
([entity properties]
|
||||
(if-not
|
||||
(empty? properties)
|
||||
(empty? properties)
|
||||
(let [entity-name (safe-name entity :sql)
|
||||
pretty-name (singularise entity-name)
|
||||
query-name (if (= properties (key-properties entity))
|
||||
(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"]
|
||||
(hash-map
|
||||
(keyword query-name)
|
||||
{:name query-name
|
||||
:signature signature
|
||||
:entity entity
|
||||
:type :select-1
|
||||
:query
|
||||
(s/join
|
||||
"\n"
|
||||
(remove
|
||||
empty?
|
||||
(list
|
||||
(str "-- :name " query-name " " signature)
|
||||
(str "-- :doc selects an existing " pretty-name " record")
|
||||
(str "SELECT * FROM " entity-name)
|
||||
(where-clause entity properties)
|
||||
(order-by-clause entity))))}))
|
||||
(keyword query-name)
|
||||
{:name query-name
|
||||
:signature signature
|
||||
:entity entity
|
||||
:type :select-1
|
||||
:query
|
||||
(s/join
|
||||
"\n"
|
||||
(remove
|
||||
empty?
|
||||
(list
|
||||
(str "-- :name " query-name " " signature)
|
||||
(str "-- :doc selects an existing " pretty-name " record")
|
||||
(str "SELECT * FROM " entity-name)
|
||||
(where-clause entity properties)
|
||||
(order-by-clause entity))))}))
|
||||
{}))
|
||||
([entity]
|
||||
(let [distinct-fields (distinct-properties entity)]
|
||||
(apply
|
||||
merge
|
||||
(cons
|
||||
(select-query entity (key-properties entity))
|
||||
(map
|
||||
#(select-query entity %)
|
||||
(combinations distinct-fields (count distinct-fields))))))))
|
||||
merge
|
||||
(cons
|
||||
(select-query entity (key-properties entity))
|
||||
(map
|
||||
#(select-query entity %)
|
||||
(combinations distinct-fields (count distinct-fields))))))))
|
||||
|
||||
|
||||
(defn list-query
|
||||
|
|
@ -270,23 +275,23 @@
|
|||
query-name (str "list-" entity-name)
|
||||
signature ":? :*"]
|
||||
(hash-map
|
||||
(keyword query-name)
|
||||
{:name query-name
|
||||
:signature signature
|
||||
:entity entity
|
||||
:type :select-many
|
||||
:query
|
||||
(s/join
|
||||
"\n"
|
||||
(remove
|
||||
empty?
|
||||
(list
|
||||
(str "-- :name " query-name " " signature)
|
||||
(str "-- :doc lists all existing " pretty-name " records")
|
||||
(str "SELECT DISTINCT lv_" entity-name ".* FROM lv_" entity-name)
|
||||
(order-by-clause entity "lv_" false)
|
||||
"--~ (if (:offset params) \"OFFSET :offset \")"
|
||||
"--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))})))
|
||||
(keyword query-name)
|
||||
{:name query-name
|
||||
:signature signature
|
||||
:entity entity
|
||||
:type :select-many
|
||||
:query
|
||||
(s/join
|
||||
"\n"
|
||||
(remove
|
||||
empty?
|
||||
(list
|
||||
(str "-- :name " query-name " " signature)
|
||||
(str "-- :doc lists all existing " pretty-name " records")
|
||||
(str "SELECT DISTINCT lv_" entity-name ".* FROM lv_" entity-name)
|
||||
(order-by-clause entity "lv_" false)
|
||||
"--~ (if (:offset params) \"OFFSET :offset \")"
|
||||
"--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))})))
|
||||
|
||||
|
||||
(defn foreign-queries
|
||||
|
|
@ -297,84 +302,83 @@
|
|||
entity-safe (safe-name entity :sql)
|
||||
links (filter #(:entity (:attrs %)) (children-with-tag entity :property))]
|
||||
(apply
|
||||
merge
|
||||
(map
|
||||
#(let [far-name (:entity (:attrs %))
|
||||
far-entity (first
|
||||
(children
|
||||
application
|
||||
(fn [x]
|
||||
(and
|
||||
(= (:tag x) :entity)
|
||||
(= (:name (:attrs x)) far-name)))))
|
||||
pretty-far (singularise far-name)
|
||||
safe-far (safe-name far-entity :sql)
|
||||
farkey (-> % :attrs :farkey)
|
||||
link-type (-> % :attrs :type)
|
||||
link-field (-> % :attrs :name)
|
||||
query-name (list-related-query-name % entity far-entity false)
|
||||
signature ":? :*"]
|
||||
(hash-map
|
||||
(keyword query-name)
|
||||
{:name query-name
|
||||
:signature signature
|
||||
:entity entity
|
||||
:type :select-one-to-many
|
||||
:far-entity far-entity
|
||||
:query
|
||||
(s/join
|
||||
"\n"
|
||||
(remove
|
||||
empty?
|
||||
(case link-type
|
||||
"entity" (list
|
||||
(str "-- :name " query-name " " signature)
|
||||
(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 "WHERE lv_" entity-safe "." (safe-name % :sql) " = :id")
|
||||
(order-by-clause entity "lv_" false))
|
||||
"link" (let [ltn
|
||||
(link-table-name % entity far-entity)]
|
||||
(list
|
||||
(str "-- :name " query-name " " signature)
|
||||
(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 "WHERE lv_" safe-far "."
|
||||
(safe-name (first (key-names far-entity)) :sql)
|
||||
" = " ltn "." (singularise safe-far) "_id")
|
||||
(str "\tAND " ltn "." (singularise entity-safe) "_id = :id")
|
||||
(order-by-clause far-entity "lv_" false)))
|
||||
"list" (list
|
||||
(str "-- :name " query-name " " signature)
|
||||
(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 "WHERE lv_" safe-far "." (safe-name (first (key-names far-entity)) :sql) " = :id")
|
||||
(order-by-clause far-entity "lv_" false))
|
||||
(list (str "ERROR: unexpected type " link-type " of property " %)))))
|
||||
}))
|
||||
links))))
|
||||
merge
|
||||
(map
|
||||
#(let [far-name (:entity (:attrs %))
|
||||
far-entity (first
|
||||
(children
|
||||
application
|
||||
(fn [x]
|
||||
(and
|
||||
(= (:tag x) :entity)
|
||||
(= (:name (:attrs x)) far-name)))))
|
||||
pretty-far (singularise far-name)
|
||||
safe-far (safe-name far-entity :sql)
|
||||
farkey (-> % :attrs :farkey)
|
||||
link-type (-> % :attrs :type)
|
||||
link-field (-> % :attrs :name)
|
||||
query-name (list-related-query-name % entity far-entity false)
|
||||
signature ":? :*"]
|
||||
(hash-map
|
||||
(keyword query-name)
|
||||
{:name query-name
|
||||
:signature signature
|
||||
:entity entity
|
||||
:type :select-one-to-many
|
||||
:far-entity far-entity
|
||||
:query
|
||||
(s/join
|
||||
"\n"
|
||||
(remove
|
||||
empty?
|
||||
(case link-type
|
||||
"entity" (list
|
||||
(str "-- :name " query-name " " signature)
|
||||
(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 "WHERE lv_" entity-safe "." (safe-name % :sql) " = :id")
|
||||
(order-by-clause entity "lv_" false))
|
||||
"link" (let [ltn
|
||||
(link-table-name % entity far-entity)]
|
||||
(list
|
||||
(str "-- :name " query-name " " signature)
|
||||
(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 "WHERE lv_" safe-far "."
|
||||
(safe-name (first (key-names far-entity)) :sql)
|
||||
" = " ltn "." (singularise safe-far) "_id")
|
||||
(str "\tAND " ltn "." (singularise entity-safe) "_id = :id")
|
||||
(order-by-clause far-entity "lv_" false)))
|
||||
"list" (list
|
||||
(str "-- :name " query-name " " signature)
|
||||
(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 "WHERE lv_" safe-far "." (safe-name (first (key-names far-entity)) :sql) " = :id")
|
||||
(order-by-clause far-entity "lv_" false))
|
||||
(list (str "ERROR: unexpected type " link-type " of property " %)))))}))
|
||||
links))))
|
||||
|
||||
|
||||
(defn delete-query
|
||||
"Generate an appropriate `delete` query for this `entity`"
|
||||
[entity]
|
||||
(if
|
||||
(has-primary-key? entity)
|
||||
(has-primary-key? entity)
|
||||
(let [entity-name (safe-name entity :sql)
|
||||
pretty-name (singularise entity-name)
|
||||
query-name (str "delete-" pretty-name "!")
|
||||
signature ":! :n"]
|
||||
(hash-map
|
||||
(keyword query-name)
|
||||
{:name query-name
|
||||
:signature signature
|
||||
:entity entity
|
||||
:type :delete-1
|
||||
:query
|
||||
(str "-- :name " query-name " " signature "\n"
|
||||
"-- :doc deletes an existing " pretty-name " record\n"
|
||||
"DELETE FROM " entity-name "\n"
|
||||
(where-clause entity))}))))
|
||||
(keyword query-name)
|
||||
{:name query-name
|
||||
:signature signature
|
||||
:entity entity
|
||||
:type :delete-1
|
||||
:query
|
||||
(str "-- :name " query-name " " signature "\n"
|
||||
"-- :doc deletes an existing " pretty-name " record\n"
|
||||
"DELETE FROM " entity-name "\n"
|
||||
(where-clause entity))}))))
|
||||
|
||||
|
||||
(defn queries
|
||||
|
|
@ -383,18 +387,18 @@
|
|||
([application entity]
|
||||
(merge
|
||||
;; TODO: queries that look through link tables
|
||||
(insert-query entity)
|
||||
(update-query entity)
|
||||
(delete-query entity)
|
||||
(select-query entity)
|
||||
(list-query entity)
|
||||
(search-query entity application)
|
||||
(foreign-queries entity application)))
|
||||
(insert-query entity)
|
||||
(update-query entity)
|
||||
(delete-query entity)
|
||||
(select-query entity)
|
||||
(list-query entity)
|
||||
(search-query entity application)
|
||||
(foreign-queries entity application)))
|
||||
([application]
|
||||
(apply
|
||||
merge
|
||||
(map #(queries application %)
|
||||
(children-with-tag application :entity)))))
|
||||
merge
|
||||
(map #(queries application %)
|
||||
(children-with-tag application :entity)))))
|
||||
|
||||
|
||||
(defn to-hugsql-queries
|
||||
|
|
@ -403,25 +407,25 @@
|
|||
(let [filepath (str *output-path* "resources/sql/queries.auto.sql")]
|
||||
(make-parents filepath)
|
||||
(do-or-warn
|
||||
(do
|
||||
(spit
|
||||
filepath
|
||||
(s/join
|
||||
"\n\n"
|
||||
(cons
|
||||
(emit-header
|
||||
"--"
|
||||
"File queries.sql"
|
||||
(str "autogenerated by adl.to-hugsql-queries at " (t/now))
|
||||
"See [Application Description Language](https://github.com/simon-brooke/adl).")
|
||||
(map
|
||||
:query
|
||||
(sort
|
||||
#(compare (:name %1) (:name %2))
|
||||
(vals
|
||||
(queries application)))))))
|
||||
(if (pos? *verbosity*)
|
||||
(*warn* (str "\tGenerated " filepath)))))))
|
||||
(do
|
||||
(spit
|
||||
filepath
|
||||
(s/join
|
||||
"\n\n"
|
||||
(cons
|
||||
(emit-header
|
||||
"--"
|
||||
"File queries.sql"
|
||||
(str "autogenerated by adl.to-hugsql-queries at " (t/now))
|
||||
"See [Application Description Language](https://github.com/simon-brooke/adl).")
|
||||
(map
|
||||
:query
|
||||
(sort
|
||||
#(compare (:name %1) (:name %2))
|
||||
(vals
|
||||
(queries application)))))))
|
||||
(if (pos? *verbosity*)
|
||||
(*warn* (str "\tGenerated " filepath)))))))
|
||||
|
||||
|
||||
(defn generate-documentation
|
||||
|
|
@ -429,68 +433,68 @@
|
|||
[query]
|
||||
(let [v (volatility (:entity query))]
|
||||
(s/join
|
||||
" "
|
||||
(list
|
||||
(case
|
||||
(:type query)
|
||||
:delete-1
|
||||
(str "delete one record from the `"
|
||||
(-> query :entity :attrs :name)
|
||||
"` table. Expects the following key(s) to be present in `params`: `"
|
||||
(-> query :entity key-names)
|
||||
"`.")
|
||||
:insert-1
|
||||
(str "insert one record to the `"
|
||||
(-> query :entity :attrs :name)
|
||||
"` table. Expects the following key(s) to be present in `params`: `"
|
||||
(pr-str
|
||||
(map
|
||||
#(keyword (:name (:attrs %)))
|
||||
(-> query :entity insertable-properties )))
|
||||
"`. Returns a map containing the keys `"
|
||||
(-> query :entity key-names)
|
||||
"` identifying the record created.")
|
||||
:select-1
|
||||
(str "select one record from the `"
|
||||
(-> query :entity :attrs :name)
|
||||
"` table. Expects the following key(s) to be present in `params`: `"
|
||||
(-> query :entity key-names)
|
||||
"`. Returns a map containing the following keys: `"
|
||||
(map #(keyword (:name (:attrs %))) (-> query :entity all-properties))
|
||||
"`.")
|
||||
:select-many
|
||||
(str "select all records from the `"
|
||||
(-> 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: `"
|
||||
(pr-str
|
||||
(map
|
||||
#(keyword (:name (:attrs %)))
|
||||
(-> query :entity all-properties)))
|
||||
"`.")
|
||||
:text-search
|
||||
(str "select all records from the `"
|
||||
(-> query :entity :attrs :name)
|
||||
" "
|
||||
(list
|
||||
(case
|
||||
(:type query)
|
||||
:delete-1
|
||||
(str "delete one record from the `"
|
||||
(-> query :entity :attrs :name)
|
||||
"` table. Expects the following key(s) to be present in `params`: `"
|
||||
(-> query :entity key-names)
|
||||
"`.")
|
||||
:insert-1
|
||||
(str "insert one record to the `"
|
||||
(-> query :entity :attrs :name)
|
||||
"` table. Expects the following key(s) to be present in `params`: `"
|
||||
(pr-str
|
||||
(map
|
||||
#(keyword (:name (:attrs %)))
|
||||
(-> query :entity insertable-properties)))
|
||||
"`. Returns a map containing the keys `"
|
||||
(-> query :entity key-names)
|
||||
"` identifying the record created.")
|
||||
:select-1
|
||||
(str "select one record from the `"
|
||||
(-> query :entity :attrs :name)
|
||||
"` table. Expects the following key(s) to be present in `params`: `"
|
||||
(-> query :entity key-names)
|
||||
"`. Returns a map containing the following keys: `"
|
||||
(map #(keyword (:name (:attrs %))) (-> query :entity all-properties))
|
||||
"`.")
|
||||
:select-many
|
||||
(str "select all records from the `"
|
||||
(-> 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: `"
|
||||
(pr-str
|
||||
(map
|
||||
#(keyword (:name (:attrs %)))
|
||||
(-> query :entity all-properties)))
|
||||
"`.")
|
||||
:text-search
|
||||
(str "select all records from the `"
|
||||
(-> query :entity :attrs :name)
|
||||
;; 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: `"
|
||||
(pr-str
|
||||
(map
|
||||
#(keyword (:name (:attrs %)))
|
||||
(-> query :entity all-properties)))
|
||||
"`.")
|
||||
:update-1
|
||||
(str "update one record in the `"
|
||||
(-> query :entity :attrs :name)
|
||||
"` table. Expects the following key(s) to be present in `params`: `"
|
||||
(pr-str
|
||||
(distinct
|
||||
(sort
|
||||
(map
|
||||
#(keyword (:name (:attrs %)))
|
||||
(flatten
|
||||
(cons
|
||||
(-> query :entity key-properties)
|
||||
(-> query :entity insertable-properties)))))))
|
||||
"`."))
|
||||
(if-not
|
||||
(zero? v)
|
||||
(str "Results will be held in cache for " v " seconds."))))))
|
||||
"` 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
|
||||
(map
|
||||
#(keyword (:name (:attrs %)))
|
||||
(-> query :entity all-properties)))
|
||||
"`.")
|
||||
:update-1
|
||||
(str "update one record in the `"
|
||||
(-> query :entity :attrs :name)
|
||||
"` table. Expects the following key(s) to be present in `params`: `"
|
||||
(pr-str
|
||||
(distinct
|
||||
(sort
|
||||
(map
|
||||
#(keyword (:name (:attrs %)))
|
||||
(flatten
|
||||
(cons
|
||||
(-> query :entity key-properties)
|
||||
(-> query :entity insertable-properties)))))))
|
||||
"`."))
|
||||
(if-not
|
||||
(zero? v)
|
||||
(str "Results will be held in cache for " v " seconds."))))))
|
||||
|
|
|
|||
|
|
@ -3,10 +3,9 @@
|
|||
adl.to-psql
|
||||
(:require [adl-support.core :refer :all]
|
||||
[adl-support.utils :refer :all]
|
||||
[adl.to-hugsql-queries :refer [queries]]
|
||||
[clojure.java.io :refer [file make-parents writer]]
|
||||
;; [adl.to-hugsql-queries :refer [queries]]
|
||||
[clojure.java.io :refer [make-parents]]
|
||||
[clojure.string :as s]
|
||||
[clojure.xml :as x]
|
||||
[clj-time.core :as t]
|
||||
[clj-time.format :as f]))
|
||||
|
||||
|
|
@ -220,7 +219,7 @@
|
|||
(if
|
||||
key?
|
||||
"NOT NULL PRIMARY KEY"
|
||||
(if (= (:required (:attrs property)) "true") "NOT NULL"))))))))))
|
||||
(when (= (:required (:attrs property)) "true") "NOT NULL"))))))))))
|
||||
|
||||
|
||||
(defn compose-convenience-entity-field
|
||||
|
|
@ -259,6 +258,7 @@
|
|||
(all-properties entity)
|
||||
(user-distinct-properties entity)))))))
|
||||
|
||||
(declare compose-convenience-where-clause)
|
||||
|
||||
(defn compose-convenience-where-clause
|
||||
"Compose an SQL `WHERE` clause for a convenience view of this
|
||||
|
|
|
|||
|
|
@ -1,12 +1,12 @@
|
|||
(ns ^{:doc "Application Description Language: validator for ADL structure.
|
||||
TODO: this is at present largely a failed experiment."
|
||||
:author "Simon Brooke"}
|
||||
adl.validator
|
||||
(:require [adl-support.utils :refer :all]
|
||||
adl.validator
|
||||
(:require [adl-support.utils :refer []]
|
||||
[clojure.set :refer [union]]
|
||||
[clojure.xml :refer [parse]]
|
||||
[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"
|
||||
[o validation]
|
||||
(if
|
||||
(symbol? validation)
|
||||
(symbol? validation)
|
||||
(try
|
||||
(b/validate o validation)
|
||||
(catch java.lang.ClassCastException c
|
||||
(catch java.lang.ClassCastException _
|
||||
;; The validator regularly barfs on strings, which are perfectly
|
||||
;; valid content of some elements. I need a way to validate
|
||||
;; elements where they're not tolerated!
|
||||
(if (string? o) [nil o]))
|
||||
(when (string? o) [nil o]))
|
||||
(catch Exception e
|
||||
[{:error (.getName (.getClass e))
|
||||
:message (.getMessage e)
|
||||
|
|
@ -55,27 +55,26 @@
|
|||
:context o} 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
|
||||
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
|
||||
do we identify the one which ought not to have failed?"
|
||||
[o & validations]
|
||||
`(println
|
||||
(println
|
||||
(str
|
||||
(if (:tag ~o) (str "Tag: " (:tag ~o) "; "))
|
||||
(if (:name (:attrs ~o)) (str "Name: " (:name (:attrs ~o)) ";"))
|
||||
(if-not (or (:tag ~o) (:name (:attrs ~o))) (str "Context: " ~o))))
|
||||
(when (:tag o) (str "Tag: " (:tag o) "; "))
|
||||
(when (:name (:attrs o)) (str "Name: " (:name (:attrs o)) ";"))
|
||||
(when-not (or (:tag o) (:name (:attrs o))) (str "Context: " o))))
|
||||
|
||||
`(empty?
|
||||
(remove :tag (remove nil? (map first (map
|
||||
#(try-validate ~o '%)
|
||||
~validations))))))
|
||||
(empty?
|
||||
(remove :tag (remove nil? (map first (map
|
||||
#(try-validate o '%)
|
||||
validations))))))
|
||||
|
||||
;;; 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
|
||||
"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"})
|
||||
|
||||
(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
|
||||
min and max values
|
||||
* `string`: varchar java.sql.Types.VARCHAR
|
||||
|
|
@ -129,8 +128,8 @@
|
|||
* `text`: text or java.sql.Types.LONGVARCHAR
|
||||
memo java.sql.Types.CLOB"
|
||||
(union
|
||||
defineable-data-types
|
||||
#{"boolean" "text"}))
|
||||
defineable-data-types
|
||||
#{"boolean" "text"}))
|
||||
|
||||
(def complex-data-types
|
||||
"data types which are more complex than SimpleDataTypes...
|
||||
|
|
@ -170,7 +169,7 @@
|
|||
(def sequences #{"canonical", "reverse-canonical"})
|
||||
|
||||
(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.
|
||||
|
||||
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
|
||||
: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
|
||||
"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.
|
||||
|
||||
A specification element is intended chiefly to declare the reference
|
||||
|
|
@ -208,26 +216,33 @@
|
|||
[:attrs :name] [v/string v/required]
|
||||
[:attrs :abbr] [v/string v/required]
|
||||
:content [[v/every #(disjunct-valid?
|
||||
%
|
||||
documentation-validations
|
||||
reference-validations)]]})
|
||||
|
||||
|
||||
(def documentation-validations
|
||||
"contains documentation on the element which immediately contains it. TODO:
|
||||
should HTML markup within a documentation element be allowed? If so, are
|
||||
there restrictions?"
|
||||
"contains documentation on the element which immediately contains it. For
|
||||
the time being, HTML markup is not permitted within documentation, but
|
||||
Markdown (which may include a string representation of HTML markup) should
|
||||
be."
|
||||
{:tag [v/required [#(= % :documentation)]]
|
||||
:content [[v/every #(disjunct-valid?
|
||||
%
|
||||
:content [[v/every #(disjunct-valid?
|
||||
%
|
||||
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
|
||||
{:tag [v/required [#(= % :content)]]})
|
||||
|
||||
(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
|
||||
per locale; if there are more than one all those matching the locale may
|
||||
be concatenated, or just one may be used.
|
||||
|
|
@ -267,7 +282,7 @@
|
|||
|
||||
|
||||
(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
|
||||
per locale; if there are more than one all those matching the locale may
|
||||
be concatenated, or just one may be used.
|
||||
|
|
@ -293,6 +308,17 @@
|
|||
(b/valid? % documentation-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
|
||||
"pragmatic advice to generators of lists and forms, in the form of
|
||||
name/value pairs which may contain anything. Over time some pragmas
|
||||
|
|
@ -302,8 +328,6 @@
|
|||
[:attrs :name] [v/string v/required]
|
||||
[:attrs :value] [v/string v/required]})
|
||||
|
||||
|
||||
|
||||
(def generator-validations
|
||||
"marks a property which is auto-generated by some part of the system.
|
||||
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 :class] v/string
|
||||
:content [[v/every #(disjunct-valid? %
|
||||
documentation-validations
|
||||
param-validations)]]})
|
||||
documentation-validations
|
||||
param-validations)]]})
|
||||
|
||||
|
||||
(def in-implementation-validations
|
||||
|
|
@ -359,22 +383,22 @@
|
|||
[:attrs :name] [v/required v/string]
|
||||
[:attrs :type] [[v/member defineable-data-types]]
|
||||
[:attrs :size] [[#(if
|
||||
(string? %)
|
||||
(string? %)
|
||||
(integer? (read-string %))
|
||||
(integer? %))]]
|
||||
[:attrs :pattern] v/string
|
||||
[:attrs :minimum] [[#(if
|
||||
(string? %)
|
||||
(string? %)
|
||||
(integer? (read-string %))
|
||||
(integer? %))]]
|
||||
[:attrs :maximum] [[#(if
|
||||
(string? %)
|
||||
(string? %)
|
||||
(integer? (read-string %))
|
||||
(integer? %))]]
|
||||
:content [[v/every #(or
|
||||
(b/valid? % documentation-validations)
|
||||
(b/valid? % in-implementation-validations)
|
||||
(b/valid? % help-validations))]]})
|
||||
(b/valid? % documentation-validations)
|
||||
(b/valid? % in-implementation-validations)
|
||||
(b/valid? % help-validations))]]})
|
||||
|
||||
(def group-validations
|
||||
"a group of people with similar permissions to one another
|
||||
|
|
@ -387,7 +411,7 @@
|
|||
:content [[v/every documentation-validations]]})
|
||||
|
||||
(def property-validations
|
||||
"a property (field) of an entity (table)
|
||||
"a property (field) of an entity (table)
|
||||
|
||||
* `name`: the name of this property.
|
||||
* `type`: the type of this property.
|
||||
|
|
@ -425,35 +449,55 @@
|
|||
committed to persistent store, the value which it holds before
|
||||
it has been committed"
|
||||
{: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 :entity] v/string
|
||||
[:attrs :farkey] v/string
|
||||
[:attrs :required] [[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
|
||||
(empty? %) ;; it's allowed to be missing
|
||||
true
|
||||
(empty? %) ;; it's allowed to be missing
|
||||
true
|
||||
(string? %)
|
||||
(integer? (read-string %))
|
||||
true
|
||||
:else
|
||||
(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 :concrete] [[v/member #{"true", "false"}]]
|
||||
[:attrs :cascade] [[v/member cascade-actions]]
|
||||
;; :content [[v/every #(disjunct-valid? %
|
||||
;; documentation-validations
|
||||
;; generator-validations
|
||||
;; permission-validations
|
||||
;; option-validations
|
||||
;; prompt-validations
|
||||
;; help-validations
|
||||
;; ifmissing-validations)]]
|
||||
:content [[v/every #(disjunct-valid? %
|
||||
documentation-validations
|
||||
generator-validations
|
||||
permission-validations
|
||||
option-validations
|
||||
prompt-validations
|
||||
help-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
|
||||
"permissions policy on an entity, a page, form, list or field
|
||||
|
|
@ -486,10 +530,10 @@
|
|||
{:tag [v/required [#(= % :field)]]
|
||||
[:attrs :property] [v/string v/required] ;; and it must also be the name of a property in the current entity
|
||||
:content [[v/every #(or
|
||||
(b/valid? % documentation-validations)
|
||||
(b/valid? % prompt-validations)
|
||||
(b/valid? % permission-validations)
|
||||
(b/valid? % help-validations))]]})
|
||||
(b/valid? % documentation-validations)
|
||||
(b/valid? % prompt-validations)
|
||||
(b/valid? % permission-validations)
|
||||
(b/valid? % help-validations))]]})
|
||||
|
||||
(def verb-validations
|
||||
"a verb is something that may be done through a form. Probably the verbs 'store'
|
||||
|
|
@ -526,12 +570,12 @@
|
|||
[:attrs :onselect] v/string
|
||||
[:attrs :canadd] v/boolean
|
||||
:content [[v/every #(or
|
||||
(b/valid? % documentation-validations)
|
||||
(b/valid? % prompt-validations)
|
||||
(b/valid? % field-validations)
|
||||
(b/valid? % fieldgroup-validations)
|
||||
(b/valid? % auxlist-validations)
|
||||
(b/valid? % verb-validations))]]})
|
||||
(b/valid? % documentation-validations)
|
||||
(b/valid? % prompt-validations)
|
||||
(b/valid? % field-validations)
|
||||
(b/valid? % fieldgroup-validations)
|
||||
(b/valid? % auxlist-validations)
|
||||
(b/valid? % verb-validations))]]})
|
||||
|
||||
(def fieldgroup-validations
|
||||
"a group of fields and other controls within a form or list, which the
|
||||
|
|
@ -539,14 +583,14 @@
|
|||
{:tag [v/required [#(= % :fieldgroup)]]
|
||||
[:attrs :name] [v/string v/required]
|
||||
:content [[v/every #(or
|
||||
(b/valid? % documentation-validations)
|
||||
(b/valid? % prompt-validations)
|
||||
(b/valid? % permission-validations)
|
||||
(b/valid? % help-validations)
|
||||
(b/valid? % field-validations)
|
||||
(b/valid? % fieldgroup-validations)
|
||||
(b/valid? % auxlist-validations)
|
||||
(b/valid? % verb-validations))]]})
|
||||
(b/valid? % documentation-validations)
|
||||
(b/valid? % prompt-validations)
|
||||
(b/valid? % permission-validations)
|
||||
(b/valid? % help-validations)
|
||||
(b/valid? % field-validations)
|
||||
(b/valid? % fieldgroup-validations)
|
||||
(b/valid? % auxlist-validations)
|
||||
(b/valid? % verb-validations))]]})
|
||||
|
||||
|
||||
(def form-validations
|
||||
|
|
@ -556,16 +600,16 @@
|
|||
[:attrs :properties] [v/required [v/member #{"all", "user-distinct", "listed"}]]
|
||||
[:attrs :canadd] [[v/member #{"true", "false"}]]
|
||||
:content [[v/every #(disjunct-valid? %
|
||||
documentation-validations
|
||||
head-validations
|
||||
top-validations
|
||||
foot-validations
|
||||
field-validations
|
||||
fieldgroup-validations
|
||||
auxlist-validations
|
||||
verb-validations
|
||||
permission-validations
|
||||
pragma-validations)]]})
|
||||
documentation-validations
|
||||
head-validations
|
||||
top-validations
|
||||
foot-validations
|
||||
field-validations
|
||||
fieldgroup-validations
|
||||
auxlist-validations
|
||||
verb-validations
|
||||
permission-validations
|
||||
pragma-validations)]]})
|
||||
|
||||
(def page-validations
|
||||
"a page on which an entity may be displayed"
|
||||
|
|
@ -573,16 +617,16 @@
|
|||
[:attrs :name] [v/required v/string]
|
||||
[:attrs :properties] [v/required [v/member #{"all", "user-distinct", "listed"}]]
|
||||
:content [[v/every #(disjunct-valid? %
|
||||
documentation-validations
|
||||
head-validations
|
||||
top-validations
|
||||
foot-validations
|
||||
field-validations
|
||||
fieldgroup-validations
|
||||
auxlist-validations
|
||||
verb-validations
|
||||
permission-validations
|
||||
pragma-validations)]]})
|
||||
documentation-validations
|
||||
head-validations
|
||||
top-validations
|
||||
foot-validations
|
||||
field-validations
|
||||
fieldgroup-validations
|
||||
auxlist-validations
|
||||
verb-validations
|
||||
permission-validations
|
||||
pragma-validations)]]})
|
||||
|
||||
(def list-validations
|
||||
"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 :onselect] v/string
|
||||
:content [[v/every #(disjunct-valid? %
|
||||
documentation-validations
|
||||
head-validations
|
||||
top-validations
|
||||
foot-validations
|
||||
field-validations
|
||||
fieldgroup-validations
|
||||
auxlist-validations
|
||||
verb-validations
|
||||
permission-validations
|
||||
pragma-validations
|
||||
order-validations)]]})
|
||||
documentation-validations
|
||||
head-validations
|
||||
top-validations
|
||||
foot-validations
|
||||
field-validations
|
||||
fieldgroup-validations
|
||||
auxlist-validations
|
||||
verb-validations
|
||||
permission-validations
|
||||
pragma-validations
|
||||
order-validations)]]})
|
||||
|
||||
(def key-validations
|
||||
{:tag [v/required [#(= % :key)]]
|
||||
|
|
@ -632,15 +676,15 @@
|
|||
[:attrs :table] v/string
|
||||
[:attrs :foreign] [[v/member #{"true", "false"}]]
|
||||
:content [[v/every #(disjunct-valid? %
|
||||
documentation-validations
|
||||
prompt-validations
|
||||
content-validations
|
||||
key-validations
|
||||
property-validations
|
||||
permission-validations
|
||||
form-validations
|
||||
page-validations
|
||||
list-validations)]]})
|
||||
documentation-validations
|
||||
prompt-validations
|
||||
content-validations
|
||||
key-validations
|
||||
property-validations
|
||||
permission-validations
|
||||
form-validations
|
||||
page-validations
|
||||
list-validations)]]})
|
||||
|
||||
(def application-validations
|
||||
{:tag [v/required [#(= % :application)]]
|
||||
|
|
@ -649,12 +693,12 @@
|
|||
[:attrs :revision] v/string
|
||||
[:attrs :currency] v/string
|
||||
:content [[v/every #(disjunct-valid? %
|
||||
specification-validations
|
||||
documentation-validations
|
||||
content-validations
|
||||
typedef-validations
|
||||
group-validations
|
||||
entity-validations)]]})
|
||||
specification-validations
|
||||
documentation-validations
|
||||
content-validations
|
||||
typedef-validations
|
||||
group-validations
|
||||
entity-validations)]]})
|
||||
|
||||
|
||||
(defn valid-adl?
|
||||
|
|
|
|||
|
|
@ -1,109 +1,104 @@
|
|||
(ns adl.to-hugsql-queries-test
|
||||
(:require [clojure.string :as s]
|
||||
[clojure.test :refer :all]
|
||||
[adl.to-hugsql-queries :refer :all]
|
||||
[adl-support.utils :refer :all]))
|
||||
[clojure.test :refer [deftest is testing]]
|
||||
[adl.to-hugsql-queries :refer [delete-query insert-query list-query order-by-clause search-query select-query update-query]]
|
||||
[adl-support.utils :refer [child-with-tag has-non-key-properties? has-primary-key? key-names]]))
|
||||
|
||||
(defn string-equal-ignore-whitespace?
|
||||
"I don't want unit tests to fail just because emitted whitespace changes."
|
||||
[a b]
|
||||
(if
|
||||
(and
|
||||
(string? a)
|
||||
(string? b))
|
||||
(let
|
||||
(and
|
||||
(string? a)
|
||||
(string? b))
|
||||
(let
|
||||
[pattern #"[\s]+"
|
||||
aa (s/replace a pattern " ")
|
||||
bb (s/replace b pattern " ")]
|
||||
(= aa bb))
|
||||
(= aa bb))
|
||||
(= a b)))
|
||||
|
||||
(deftest order-by-tests
|
||||
(let [application {:tag :application,
|
||||
:attrs {:version "0.1.1", :name "test-app"},
|
||||
:content
|
||||
[{:tag :entity,
|
||||
:attrs {:name "address"},
|
||||
:content
|
||||
[{:tag :key,
|
||||
:attrs nil,
|
||||
:content
|
||||
[{:tag :property,
|
||||
:attrs
|
||||
{:immutable "true",
|
||||
:required "true",
|
||||
:distinct "system",
|
||||
:type "integer",
|
||||
:name "id"},
|
||||
:content
|
||||
[{:tag :generator, :attrs {:action "native"}, :content nil}]}
|
||||
{:tag :property,
|
||||
:attrs
|
||||
{:immutable "true",
|
||||
:required "true",
|
||||
:distinct "all",
|
||||
:generator "assigned"
|
||||
:type "string",
|
||||
:size "12"
|
||||
:name "postcode"},
|
||||
:content
|
||||
[{:tag :generator, :attrs {:action "native"}, :content nil}]}
|
||||
]}
|
||||
{:tag :property,
|
||||
:attrs
|
||||
{:distinct "user", :size "128", :type "string", :name "street"},
|
||||
:content nil}
|
||||
{:tag :property,
|
||||
:attrs {:size "64", :type "string", :name "town"},
|
||||
:content nil}
|
||||
]}]}
|
||||
:attrs {:version "0.1.1", :name "test-app"},
|
||||
:content
|
||||
[{:tag :entity,
|
||||
:attrs {:name "address"},
|
||||
:content
|
||||
[{:tag :key,
|
||||
:attrs nil,
|
||||
:content
|
||||
[{:tag :property,
|
||||
:attrs
|
||||
{:immutable "true",
|
||||
:required "true",
|
||||
:distinct "system",
|
||||
:type "integer",
|
||||
:name "id"},
|
||||
:content
|
||||
[{:tag :generator, :attrs {:action "native"}, :content nil}]}
|
||||
{:tag :property,
|
||||
:attrs
|
||||
{:immutable "true",
|
||||
:required "true",
|
||||
:distinct "all",
|
||||
:generator "assigned"
|
||||
:type "string",
|
||||
:size "12"
|
||||
:name "postcode"},
|
||||
:content
|
||||
[{:tag :generator, :attrs {:action "native"}, :content nil}]}]}
|
||||
{:tag :property,
|
||||
:attrs
|
||||
{:distinct "user", :size "128", :type "string", :name "street"},
|
||||
:content nil}
|
||||
{:tag :property,
|
||||
:attrs {:size "64", :type "string", :name "town"},
|
||||
:content nil}]}]}
|
||||
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, address.postcode, address.id"
|
||||
actual (order-by-clause entity)]
|
||||
(is (string-equal-ignore-whitespace? actual expected))))))
|
||||
|
||||
|
||||
(deftest keys-name-extraction-tests
|
||||
(let [application {:tag :application,
|
||||
:attrs {:version "0.1.1", :name "test-app"},
|
||||
:content
|
||||
[{:tag :entity,
|
||||
:attrs {:name "address"},
|
||||
:content
|
||||
[{:tag :key,
|
||||
:attrs nil,
|
||||
:content
|
||||
[{:tag :property,
|
||||
:attrs
|
||||
{:immutable "true",
|
||||
:required "true",
|
||||
:distinct "system",
|
||||
:type "integer",
|
||||
:name "id"},
|
||||
:content
|
||||
[{:tag :generator, :attrs {:action "native"}, :content nil}]}
|
||||
{:tag :property,
|
||||
:attrs
|
||||
{:immutable "true",
|
||||
:required "true",
|
||||
:distinct "all",
|
||||
:generator "assigned"
|
||||
:type "string",
|
||||
:size "12"
|
||||
:name "postcode"},
|
||||
:content
|
||||
[{:tag :generator, :attrs {:action "native"}, :content nil}]}
|
||||
]}
|
||||
{:tag :property,
|
||||
:attrs
|
||||
{:distinct "user", :size "128", :type "string", :name "street"},
|
||||
:content nil}
|
||||
{:tag :property,
|
||||
:attrs {:size "64", :type "string", :name "town"},
|
||||
:content nil}
|
||||
]}]}
|
||||
(let [application {:tag :application,
|
||||
:attrs {:version "0.1.1", :name "test-app"},
|
||||
:content
|
||||
[{:tag :entity,
|
||||
:attrs {:name "address"},
|
||||
:content
|
||||
[{:tag :key,
|
||||
:attrs nil,
|
||||
:content
|
||||
[{:tag :property,
|
||||
:attrs
|
||||
{:immutable "true",
|
||||
:required "true",
|
||||
:distinct "system",
|
||||
:type "integer",
|
||||
:name "id"},
|
||||
:content
|
||||
[{:tag :generator, :attrs {:action "native"}, :content nil}]}
|
||||
{:tag :property,
|
||||
:attrs
|
||||
{:immutable "true",
|
||||
:required "true",
|
||||
:distinct "all",
|
||||
:generator "assigned"
|
||||
:type "string",
|
||||
:size "12"
|
||||
:name "postcode"},
|
||||
:content
|
||||
[{:tag :generator, :attrs {:action "native"}, :content nil}]}]}
|
||||
{:tag :property,
|
||||
:attrs
|
||||
{:distinct "user", :size "128", :type "string", :name "street"},
|
||||
:content nil}
|
||||
{:tag :property,
|
||||
:attrs {:size "64", :type "string", :name "town"},
|
||||
:content nil}]}]}
|
||||
entity (child-with-tag application :entity)]
|
||||
(testing "keys name extraction"
|
||||
(let [expected #{"id" "postcode"}
|
||||
|
|
@ -113,43 +108,41 @@
|
|||
|
||||
(deftest entity-tests
|
||||
(let [application {:tag :application,
|
||||
:attrs {:version "0.1.1", :name "test-app"},
|
||||
:content
|
||||
[{:tag :entity,
|
||||
:attrs {:name "address"},
|
||||
:content
|
||||
[{:tag :key,
|
||||
:attrs nil,
|
||||
:content
|
||||
[{:tag :property,
|
||||
:attrs
|
||||
{:immutable "true",
|
||||
:required "true",
|
||||
:distinct "system",
|
||||
:type "integer",
|
||||
:name "id"},
|
||||
:content
|
||||
[{:tag :generator, :attrs {:action "native"}, :content nil}]}
|
||||
{:tag :property,
|
||||
:attrs
|
||||
{:immutable "true",
|
||||
:required "true",
|
||||
:distinct "all",
|
||||
:generator "assigned"
|
||||
:type "string",
|
||||
:size "12"
|
||||
:name "postcode"},
|
||||
:content
|
||||
[{:tag :generator, :attrs {:action "native"}, :content nil}]}
|
||||
]}
|
||||
{:tag :property,
|
||||
:attrs
|
||||
{:distinct "user", :size "128", :type "string", :name "street"},
|
||||
:content nil}
|
||||
{:tag :property,
|
||||
:attrs {:size "64", :type "string", :name "town"},
|
||||
:content nil}
|
||||
]}]}
|
||||
:attrs {:version "0.1.1", :name "test-app"},
|
||||
:content
|
||||
[{:tag :entity,
|
||||
:attrs {:name "address"},
|
||||
:content
|
||||
[{:tag :key,
|
||||
:attrs nil,
|
||||
:content
|
||||
[{:tag :property,
|
||||
:attrs
|
||||
{:immutable "true",
|
||||
:required "true",
|
||||
:distinct "system",
|
||||
:type "integer",
|
||||
:name "id"},
|
||||
:content
|
||||
[{:tag :generator, :attrs {:action "native"}, :content nil}]}
|
||||
{:tag :property,
|
||||
:attrs
|
||||
{:immutable "true",
|
||||
:required "true",
|
||||
:distinct "all",
|
||||
:generator "assigned"
|
||||
:type "string",
|
||||
:size "12"
|
||||
:name "postcode"},
|
||||
:content
|
||||
[{:tag :generator, :attrs {:action "native"}, :content nil}]}]}
|
||||
{:tag :property,
|
||||
:attrs
|
||||
{:distinct "user", :size "128", :type "string", :name "street"},
|
||||
:content nil}
|
||||
{:tag :property,
|
||||
:attrs {:size "64", :type "string", :name "town"},
|
||||
:content nil}]}]}
|
||||
entity (child-with-tag application :entity)]
|
||||
(testing "keys name extraction"
|
||||
(let [expected #{"id"}
|
||||
|
|
@ -248,49 +241,45 @@
|
|||
(testing "delete query signature"
|
||||
(let [expected ":! :n"
|
||||
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
|
||||
(let [application {:tag :application,
|
||||
:attrs {:version "0.1.1", :name "test-app"},
|
||||
:content
|
||||
[{:tag :entity,
|
||||
:attrs {:name "address"},
|
||||
:content
|
||||
[{:tag :key,
|
||||
:attrs nil,
|
||||
:content
|
||||
[{:tag :property,
|
||||
:attrs
|
||||
{:immutable "true",
|
||||
:required "true",
|
||||
:distinct "system",
|
||||
:type "integer",
|
||||
:name "id"},
|
||||
:content
|
||||
[{:tag :generator, :attrs {:action "native"}, :content nil}]}
|
||||
{:tag :property,
|
||||
:attrs
|
||||
{:immutable "true",
|
||||
:required "true",
|
||||
:distinct "all",
|
||||
:generator "assigned"
|
||||
:type "string",
|
||||
:size "12"
|
||||
:name "postcode"},
|
||||
:content
|
||||
[{:tag :generator, :attrs {:action "native"}, :content nil}]}
|
||||
]}
|
||||
{:tag :property,
|
||||
:attrs
|
||||
{:distinct "user", :size "128", :type "string", :name "street"},
|
||||
:content nil}
|
||||
{:tag :property,
|
||||
:attrs {:size "64", :type "string", :name "town"},
|
||||
:content nil}
|
||||
]}]}
|
||||
:attrs {:version "0.1.1", :name "test-app"},
|
||||
:content
|
||||
[{:tag :entity,
|
||||
:attrs {:name "address"},
|
||||
:content
|
||||
[{:tag :key,
|
||||
:attrs nil,
|
||||
:content
|
||||
[{:tag :property,
|
||||
:attrs
|
||||
{:immutable "true",
|
||||
:required "true",
|
||||
:distinct "system",
|
||||
:type "integer",
|
||||
:name "id"},
|
||||
:content
|
||||
[{:tag :generator, :attrs {:action "native"}, :content nil}]}
|
||||
{:tag :property,
|
||||
:attrs
|
||||
{:immutable "true",
|
||||
:required "true",
|
||||
:distinct "all",
|
||||
:generator "assigned"
|
||||
:type "string",
|
||||
:size "12"
|
||||
:name "postcode"},
|
||||
:content
|
||||
[{:tag :generator, :attrs {:action "native"}, :content nil}]}]}
|
||||
{:tag :property,
|
||||
:attrs
|
||||
{:distinct "user", :size "128", :type "string", :name "street"},
|
||||
:content nil}
|
||||
{:tag :property,
|
||||
:attrs {:size "64", :type "string", :name "town"},
|
||||
:content nil}]}]}
|
||||
entity (child-with-tag application :entity)]
|
||||
(testing "user distinct properties should provide the default ordering"
|
||||
(let [expected "ORDER BY address.street,
|
||||
|
|
|
|||
|
|
@ -1,9 +1,10 @@
|
|||
(ns adl.validator-test
|
||||
(:require [clojure.java.io :refer [writer]]
|
||||
[clojure.test :refer :all]
|
||||
[clojure.xml :refer [parse]]
|
||||
[adl.validator :refer :all]
|
||||
[bouncer.core :refer [valid?]]))
|
||||
(:require
|
||||
[adl.validator :refer :all]
|
||||
[bouncer.core :refer [valid? validate]]
|
||||
[clojure.java.io :refer [writer]]
|
||||
[clojure.test :refer :all]
|
||||
[clojure.xml :refer [parse]]))
|
||||
|
||||
;; OK, so where we're up to: documentation breaks validation of the
|
||||
;; element that contains it if the documentation is non-empty.
|
||||
|
|
@ -262,9 +263,9 @@
|
|||
:name "id"},
|
||||
:content
|
||||
[{:tag :generator, :attrs {:action "native"}, :content nil}]}]}
|
||||
expected true
|
||||
actual (binding [*out* (writer "/dev/null")]
|
||||
(valid? xml key-validations))]
|
||||
expected nil
|
||||
actual (first (binding [*out* (writer "/dev/null")]
|
||||
(validate xml key-validations)))]
|
||||
(is (= actual expected)))))
|
||||
|
||||
(deftest validator-property
|
||||
|
|
@ -340,14 +341,14 @@
|
|||
(deftest validator-option
|
||||
(testing "Validation of option element"
|
||||
(let [xml {: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}]}
|
||||
:attrs {:value "Female"},
|
||||
:content
|
||||
[{:tag :prompt,
|
||||
:attrs {:locale "fr-FR", :prompt "Femme"},
|
||||
:content nil}
|
||||
{:tag :prompt,
|
||||
:attrs {:locale "en-GB", :prompt "Female"},
|
||||
:content nil}]}
|
||||
expected true
|
||||
actual (binding [*out* (writer "/dev/null")]
|
||||
(valid? xml option-validations))]
|
||||
|
|
@ -378,8 +379,8 @@
|
|||
(deftest validator-page
|
||||
(testing "Validation of page element"
|
||||
(let [xml {:tag :page,
|
||||
:attrs {:properties "all", :name "inspect-person"},
|
||||
:content nil}
|
||||
:attrs {:properties "all", :name "inspect-person"},
|
||||
:content nil}
|
||||
expected true
|
||||
actual (binding [*out* (writer "/dev/null")]
|
||||
(valid? xml page-validations))]
|
||||
|
|
|
|||
Loading…
Reference in a new issue