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

All unit tests passing.

Browse source
This commit is contained in:
Simon Brooke 2019-11-12 15:10:26 +00:00
parent 5af9a7349c
commit e2aa979458
4 changed files with 82 additions and 69 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
src/adl/to_hugsql_queries.clj
View file

@ -101,8 +101,7 @@
(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, ":<!"
;; you have to use a query signature.
":! :n")] ":! :n")]
(hash-map (hash-map
(keyword query-name) (keyword query-name)
@ -159,7 +158,7 @@
(defn search-query [entity application] (defn search-query [entity application]
"Generate an appropriate search query for string fields of this `entity`" "Generate an appropriate search query for string fields of this `entity` within this `application`"
(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)

25
src/adl/validator.clj
View file

@ -10,7 +10,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; ;;;;
;;;; squirrel-parse.to-adl: validate Application Description Language. ;;;; Application Description Language: validator for ADL structure
;;;; ;;;;
;;;; This program is free software; you can redistribute it and/or ;;;; This program is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU General Public License ;;;; modify it under the terms of the GNU General Public License
@ -55,7 +55,7 @@
: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
@ -66,7 +66,6 @@
(if (:tag ~o) (str "Tag: " (:tag ~o) "; ")) (if (:tag ~o) (str "Tag: " (:tag ~o) "; "))
(if (:name (:attrs ~o)) (str "Name: " (:name (:attrs ~o)) ";")) (if (:name (:attrs ~o)) (str "Name: " (:name (:attrs ~o)) ";"))
(if-not (or (:tag ~o) (:name (:attrs ~o))) (str "Context: " ~o)))) (if-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 '%)
@ -211,17 +210,21 @@
documentation-validations documentation-validations
reference-validations)]]}) reference-validations)]]})
(v/defvalidator documentation-content-validator
{:default-message-format "%s must be a sequence containing only strings and references"}
[value]
(let
[no-strings (remove string? value)]
(and
(every? map? no-strings)
(map #(b/valid? % reference-validations) no-strings))))
(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. TODO:
should HTML markup within a documentation element be allowed? If so, are should HTML markup within a documentation element be allowed? If so, are
there restrictions?" there restrictions?"
{:tag [v/required [#(= % :documentation)]] {:tag [v/required [#(= % :documentation)]]
:content [[v/every #(disjunct-valid? :content documentation-content-validator})
%
v/string
reference-validations)]]
})
(def content-validations (def content-validations
{:tag [v/required [#(= % :content)]]}) {:tag [v/required [#(= % :content)]]})
@ -337,7 +340,7 @@
[:attrs :target] [v/string v/required] [:attrs :target] [v/string v/required]
[:attrs :value] [v/string v/required] [:attrs :value] [v/string v/required]
[:attrs :kind] v/string [:attrs :kind] v/string
:content [[v/every documentation-validations]]}) :content [[v/every #(b/valid? % documentation-validations)]]})
(def typedef-validations (def typedef-validations
"the definition of a defined type. At this stage a defined type is either "the definition of a defined type. At this stage a defined type is either
@ -384,7 +387,7 @@
{:tag [v/required [#(= % :group)]] {:tag [v/required [#(= % :group)]]
[:attrs :name] [v/string v/required] [:attrs :name] [v/string v/required]
[:attrs :parent] v/string [:attrs :parent] v/string
:content [[v/every documentation-validations]]}) :content [[v/every #(b/valid? % documentation-validations)]]})
(def property-validations (def property-validations
"a property (field) of an entity (table) "a property (field) of an entity (table)
@ -608,7 +611,7 @@
(def key-validations (def key-validations
{:tag [v/required [#(= % :key)]] {:tag [v/required [#(= % :key)]]
:content [[v/every property-validations]]}) :content [[v/every #(b/validate % property-validations)]]})
(def entity-validations (def entity-validations

117
test/adl/to_hugsql_queries_test.clj
View file

@ -13,11 +13,23 @@
(string? b)) (string? b))
(let (let
[pattern #"[\s]+" [pattern #"[\s]+"
aa (s/replace a pattern " ") aa (s/replace (s/trim a) pattern " ")
bb (s/replace b pattern " ")] bb (s/replace (s/trim b) pattern " ")]
(= aa bb)) (= aa bb))
(= a b))) (= a b)))
(string-equal-ignore-whitespace?
"-- :name create-address! :<!\n-- :doc creates a new address record\nINSERT INTO address (street,\n\ttown,\n\tpostcode)\nVALUES (:street,\n\t:town,\n\t:postcode)\nreturning postcode,\n\tid" "-- :name create-address! :<!\n -- :doc creates a new address record\n INSERT INTO address (street,\n town,\n postcode)\n VALUES (':street',\n ':town',\n ':postcode')\n returning\n postcode,\n id")
(s/replace
"-- :name create-address! :<!\n-- :doc creates a new address record\nINSERT INTO address (street,\n\ttown,\n\tpostcode)\nVALUES (:street,\n\t:town,\n\t:postcode)\nreturning postcode,\n\tid"
#"[\s]+"
" ")
(s/replace
(s/trim "-- :name update-address! :! :n\n -- :doc updates an existing address record\n UPDATE address\n SET street = :street,\n town = :town,\n postcode = :postcode\n WHERE address.id = :id\n AND address.postcode = :postcode\n\n")
#"[\s]+"
" ")
(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"},
@ -112,6 +124,7 @@
(deftest entity-tests (deftest entity-tests
;; NOTE: generally identical to `complex-key-tests`, below, except that the key is not complex
(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
@ -130,17 +143,6 @@
:name "id"}, :name "id"},
:content :content
[{:tag :generator, :attrs {:action "native"}, :content nil}]} [{: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, {:tag :property,
:attrs :attrs
@ -149,6 +151,13 @@
{:tag :property, {:tag :property,
:attrs {:size "64", :type "string", :name "town"}, :attrs {:size "64", :type "string", :name "town"},
:content nil} :content nil}
{:tag :property,
:attrs
{:required "true",
:distinct "user",
:type "string",
:size "12"
:name "postcode"}}
]}]} ]}]}
entity (child-with-tag application :entity)] entity (child-with-tag application :entity)]
(testing "keys name extraction" (testing "keys name extraction"
@ -164,19 +173,19 @@
actual (has-non-key-properties? entity)] actual (has-non-key-properties? entity)]
(is (string-equal-ignore-whitespace? actual expected)))) (is (string-equal-ignore-whitespace? actual expected))))
(testing "insert query generation" (testing "insert query generation"
(let [expected "-- :name create-address! :! :n (let [expected "-- :name create-address! :<!
-- :doc creates a new address record -- :doc creates a new address record
INSERT INTO address (street, INSERT INTO address (street,
town, town,
postcode) postcode)
VALUES (':street', VALUES (:street,
':town', :town,
':postcode') :postcode)
returning id\n\n" returning id"
actual (:query (first (vals (insert-query entity))))] actual (:query (first (vals (insert-query entity))))]
(is (string-equal-ignore-whitespace? actual expected)))) (is (string-equal-ignore-whitespace? actual expected))))
(testing "insert query signature" (testing "insert query signature"
(let [expected ":! :n" (let [expected ":<!"
actual (:signature (first (vals (insert-query entity))))] actual (:signature (first (vals (insert-query entity))))]
(is (string-equal-ignore-whitespace? actual expected)))) (is (string-equal-ignore-whitespace? actual expected))))
(testing "update query generation" (testing "update query generation"
@ -186,7 +195,7 @@
SET street = :street, SET street = :street,
town = :town, town = :town,
postcode = :postcode postcode = :postcode
WHERE address.id = :id\n\n" WHERE address.id = :id"
actual (:query (first (vals (update-query entity))))] actual (:query (first (vals (update-query entity))))]
(is (string-equal-ignore-whitespace? actual expected)))) (is (string-equal-ignore-whitespace? actual expected))))
(testing "update query signature" (testing "update query signature"
@ -194,28 +203,32 @@
actual (:signature (first (vals (update-query entity))))] actual (:signature (first (vals (update-query entity))))]
(is (string-equal-ignore-whitespace? actual expected)))) (is (string-equal-ignore-whitespace? actual expected))))
(testing "search query generation" (testing "search query generation"
(let [expected "-- :name search-strings-addres :? :1 (let [expected "-- :name search-strings-address :? :*
-- :doc selects existing address records having any string field matching `:pattern` by substring match -- :doc selects existing address records having any string field matching the parameter of the same name by substring match
SELECT * FROM address SELECT DISTINCT * FROM lv_address
WHERE street LIKE '%:pattern%' WHERE true
OR town LIKE '%:pattern%' --~ (if (:street params) (str \"AND street LIKE '%\" (:street params) \"%' \"))
OR postcode LIKE '%:pattern%' --~ (if (:town params) (str \"AND town LIKE '%\" (:town params) \"%' \"))
ORDER BY address.street, --~ (if (:postcode params) (str \"AND postcode LIKE '%\" (:postcode params) \"%' \"))
address.postcode, --~ (if (:id params) (str \"AND id = :id\"))
address.id ORDER BY lv_address.street,
lv_address.postcode,
lv_address.id
--~ (if (:offset params) \"OFFSET :offset \") --~ (if (:offset params) \"OFFSET :offset \")
--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")\n\n" --~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")"
actual (:query (first (vals (search-query entity application))))] actual (:query (first (vals (search-query entity application))))]
(is (string-equal-ignore-whitespace? actual expected)))) (is (string-equal-ignore-whitespace? actual expected))))
(testing "search query signature" (testing "search query signature"
(let [expected ":? :1" (let [expected ":? :*"
actual (:signature (first (vals (search-query entity))))] actual (:signature (first (vals (search-query entity application))))]
(is (string-equal-ignore-whitespace? actual expected)))) (is (string-equal-ignore-whitespace? actual expected))))
(testing "select query generation" (testing "select query generation"
(let [expected "-- :name get-addres :? :1 (let [expected "-- :name get-address :? :1
-- :doc selects an existing addres record -- :doc selects an existing address record
SELECT * FROM address SELECT * FROM address\nWHERE address.id = :id
WHERE address.id = :id\n\n" ORDER BY address.street,
address.postcode,
address.id"
actual (:query (first (vals (select-query entity))))] actual (:query (first (vals (select-query entity))))]
(is (string-equal-ignore-whitespace? actual expected)))) (is (string-equal-ignore-whitespace? actual expected))))
(testing "select query signature" (testing "select query signature"
@ -224,13 +237,13 @@
(is (string-equal-ignore-whitespace? actual expected)))) (is (string-equal-ignore-whitespace? actual expected))))
(testing "list query generation" (testing "list query generation"
(let [expected "-- :name list-address :? :* (let [expected "-- :name list-address :? :*
-- :doc lists all existing addres records -- :doc lists all existing address records
SELECT * FROM address SELECT DISTINCT lv_address.* FROM lv_address
ORDER BY address.street, ORDER BY lv_address.street,
address.postcode, lv_address.postcode,
address.id lv_address.id
--~ (if (:offset params) \"OFFSET :offset \") --~ (if (:offset params) \"OFFSET :offset \")
--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")\n\n" --~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")"
actual (:query (first (vals (list-query entity))))] actual (:query (first (vals (list-query entity))))]
(is (string-equal-ignore-whitespace? actual expected)))) (is (string-equal-ignore-whitespace? actual expected))))
(testing "list query signature" (testing "list query signature"
@ -241,8 +254,7 @@
(let [expected "-- :name delete-address! :! :n (let [expected "-- :name delete-address! :! :n
-- :doc deletes an existing address record -- :doc deletes an existing address record
DELETE FROM address DELETE FROM address
WHERE address.id = :id WHERE address.id = :id"
ANDaddress.postcode = :postcode"
actual (:query (first (vals (delete-query entity))))] actual (:query (first (vals (delete-query entity))))]
(is (string-equal-ignore-whitespace? actual expected)))) (is (string-equal-ignore-whitespace? actual expected))))
(testing "delete query signature" (testing "delete query signature"
@ -279,9 +291,7 @@
:generator "assigned" :generator "assigned"
:type "string", :type "string",
:size "12" :size "12"
:name "postcode"}, :name "postcode"}}
:content
[{:tag :generator, :attrs {:action "native"}, :content nil}]}
]} ]}
{:tag :property, {:tag :property,
:attrs :attrs
@ -303,14 +313,14 @@
actual (key-names entity)] actual (key-names entity)]
(is (string-equal-ignore-whitespace? actual expected)))) (is (string-equal-ignore-whitespace? actual expected))))
(testing "insert query generation - compound key, non system generated field in key" (testing "insert query generation - compound key, non system generated field in key"
(let [expected "-- :name create-address! :! :n (let [expected "-- :name create-address! :<!
-- :doc creates a new address record -- :doc creates a new address record
INSERT INTO address (street, INSERT INTO address (street,
town, town,
postcode) postcode)
VALUES (':street', VALUES (:street,
':town', :town,
':postcode') :postcode)
returning returning
postcode, postcode,
id" id"
@ -321,9 +331,10 @@
-- :doc updates an existing address record -- :doc updates an existing address record
UPDATE address UPDATE address
SET street = :street, SET street = :street,
town = :town town = :town,
postcode = :postcode
WHERE address.id = :id WHERE address.id = :id
AND address.postcode = ':postcode'\n\n" AND address.postcode = :postcode\n\n"
actual (:query (first (vals (update-query entity))))] actual (:query (first (vals (update-query entity))))]
(is (string-equal-ignore-whitespace? actual expected)))) (is (string-equal-ignore-whitespace? actual expected))))
(testing "search query generation - user-distinct field in key" (testing "search query generation - user-distinct field in key"

4
test/adl/validator_test.clj
View file

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