Refactoring in progress...

This commit is contained in:
Simon Brooke 2018-07-28 16:27:46 +01:00
parent 31848e75ca
commit 5ec60e524c
8 changed files with 263 additions and 261 deletions

View file

@ -5,7 +5,7 @@
: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.3"] :dependencies [[adl-support "0.1.4-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.1.0"]
@ -19,7 +19,10 @@
:main adl.main :main adl.main
:plugins [[lein-codox "0.10.3"] :plugins [[lein-codox "0.10.3"]
[lein-release "1.0.5"]] [lein-kibit "0.1.6"]
[lein-release "1.0.5"]
;; [uncomplexor "0.1.0-SNAPSHOT"]
]
;; :lein-release {:scm :git ;; :lein-release {:scm :git
;; :deploy-via :clojars} ;; :deploy-via :clojars fails - with an scp error. ;; :deploy-via :clojars} ;; :deploy-via :clojars fails - with an scp error.

View file

@ -92,25 +92,24 @@
(defn process (defn process
"Process these parsed `options`." "Process these parsed `options`."
[options] [options]
(do (let [p (:path (:options options))
(let [p (:path (:options options)) op (if (.endsWith p "/") p (str p "/"))]
op (if (.endsWith p "/") p (str p "/"))] (binding [*output-path* op
(binding [*output-path* op *locale* (-> options :options :locale)
*locale* (-> options :options :locale) *verbosity* (-> options :options :verbosity)]
*verbosity* (-> options :options :verbosity)] (make-parents *output-path*)
(make-parents *output-path*) (doall
(doall (map
(map #(if
#(if (.exists (java.io.File. %))
(.exists (java.io.File. %)) (let [application (x/parse (canonicalise %))]
(let [application (x/parse (canonicalise %))] (h/to-hugsql-queries application)
(h/to-hugsql-queries application) (j/to-json-routes application)
(j/to-json-routes application) (p/to-psql application)
(p/to-psql application) (s/to-selmer-routes application)
(s/to-selmer-routes application) (t/to-selmer-templates application))
(t/to-selmer-templates application)) (*warn* (str "ERROR: File not found: " %)))
(*warn* (str "ERROR: File not found: " %))) (:arguments options))))))
(-> options :arguments)))))))
(defn -main (defn -main
@ -121,7 +120,7 @@
(cond (cond
(empty? args) (empty? args)
(usage options) (usage options)
(not (empty? (:errors options))) (seq (:errors options))
(do (do
(doall (doall
(map (map

View file

@ -46,13 +46,12 @@
(let (let
[entity-name (:name (:attrs entity)) [entity-name (:name (:attrs entity))
property-names (map #(:name (:attrs %)) properties)] property-names (map #(:name (:attrs %)) properties)]
(if (if-not (empty? property-names)
(not (empty? property-names))
(str (str
"WHERE " "WHERE "
(s/join (s/join
"\n\tAND" "\n\tAND"
(map #(str entity-name "." % " = :" %) property-names))))))) (map #(str entity-name "." % " = :" %) property-names)))))))
(defn order-by-clause (defn order-by-clause
@ -213,8 +212,8 @@
(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 (if-not
(not (empty? properties)) (empty? properties)
(let [entity-name (safe-name (:name (:attrs entity)) :sql) (let [entity-name (safe-name (:name (:attrs 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))
@ -384,32 +383,24 @@
[application] [application]
(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)
(try (do-or-warn
(spit (do
(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 (> *verbosity* 0) (if (pos? *verbosity*)
(*warn* (str "\tGenerated " filepath))) (*warn* (str "\tGenerated " filepath)))))))
(catch
Exception any
(*warn*
(str
"ERROR: Exception "
(.getName (.getClass any))
(.getMessage any)
" while printing "
filepath))))))

View file

@ -53,7 +53,8 @@
(f/unparse (f/formatters :basic-date-time) (t/now))) (f/unparse (f/formatters :basic-date-time) (t/now)))
(list (list
:require :require
'[adl-support.core :as support] '[adl-support.core :refer :all]
'[adl-support.rest-support :refer :all]
'[clojure.core.memoize :as memo] '[clojure.core.memoize :as memo]
'[clojure.java.io :as io] '[clojure.java.io :as io]
'[clojure.tools.logging :as log] '[clojure.tools.logging :as log]
@ -72,28 +73,38 @@
(defn generate-handler-body (defn generate-handler-body
"Generate and return the function body for the handler for this `query`." "Generate and return the function body for the handler for this `query`."
[query] [query]
(let [action (list (list
(symbol (str "db/" (:name query))) ['request]
'db/*db* (list
(list 'support/massage-params 'let
'params ['params '(massage-params request)]
'form-params
(key-names (:entity query))))]
(list (list
[{:keys ['params 'form-params]}] 'valid-user-or-forbid
(case (list
(:type query) 'with-params-or-error
(:delete-1 :update-1) (list
'do-or-server-fail
(list (list
action (symbol (str "db/" (:name query)))
`(log/debug (str ~(:name query) " called with params " ~'params ".")) 'db/*db*
'(response/found "/")) 'params)
(list (case (:type query)
'let :insert-1 201 ;; created
(vector 'result action) :delete-1 204 ;; no content
`(log/debug (~(symbol (str "db/" (:name query) "-sqlvec")) ~'params)) ;; default
`(log/debug (str ~(str "'" (:name query) "' with params ") ~'params " returned " (count ~'result) " records.")) 200)) ;; OK
(list 'response/ok 'result)))))) 'params
(set
(map
#(keyword (:name (:attrs %)))
(case (:type query)
(:insert-1 :update-1)
(-> query :entity insertable-properties)
(:select-1 :delete-1)
(-> query :entity key-properties)
;; default
nil))))
'request))))
(defn generate-handler-src (defn generate-handler-src
@ -262,7 +273,7 @@
(let [handlers-map (make-handlers-map application) (let [handlers-map (make-handlers-map application)
filepath (str *output-path* "src/clj/" (:name (:attrs application)) "/routes/auto_json.clj")] filepath (str *output-path* "src/clj/" (:name (:attrs application)) "/routes/auto_json.clj")]
(make-parents filepath) (make-parents filepath)
(try (do-or-warn
(with-open [output (writer filepath)] (with-open [output (writer filepath)]
(binding [*out* output] (binding [*out* output]
(pprint (file-header application)) (pprint (file-header application))
@ -275,16 +286,7 @@
h) h)
(sort (keys handlers-map)))) (sort (keys handlers-map))))
(pprint (defroutes handlers-map)))) (pprint (defroutes handlers-map))))
(if (> *verbosity* 0) (if (pos? *verbosity*)
(*warn* (str "\tGenerated " filepath))) (*warn* (str "\tGenerated " filepath))))))
(catch
Exception any
(*warn*
(str
"ERROR: Exception "
(.getName (.getClass any))
(.getMessage any)
" while printing "
filepath))))))

View file

@ -111,7 +111,12 @@
(defn emit-field-type (defn emit-field-type
[property entity application key?] [property entity application key?]
(case (:type (:attrs property)) (case (:type (:attrs property))
"integer" (if key? "SERIAL" "INTEGER") "integer" (if
(and
key?
(system-generated? property))
"SERIAL"
"INTEGER")
"real" "DOUBLE PRECISION" "real" "DOUBLE PRECISION"
("string" "image" "uploadable") ("string" "image" "uploadable")
(str "VARCHAR(" (:size (:attrs property)) ")") (str "VARCHAR(" (:size (:attrs property)) ")")
@ -150,8 +155,8 @@
#(if (selector (:permission (:attrs %))) #(if (selector (:permission (:attrs %)))
(safe-name (:group (:attrs %)) :sql)) (safe-name (:group (:attrs %)) :sql))
permissions)))] permissions)))]
(if (if-not
(not (empty? group-names)) (empty? group-names)
(s/join (s/join
" " " "
(list (list
@ -318,12 +323,12 @@
(str (safe-name entity) "." (field-name %))) (str (safe-name entity) "." (field-name %)))
(str (safe-name entity) "." (field-name %))) (str (safe-name entity) "." (field-name %)))
(filter (filter
#(not (= (:type (:attrs %)) "link")) #(not= (:type (:attrs %)) "link")
(all-properties entity) ))))) (all-properties entity) )))))
(str (str
"FROM " (s/join ", " (set (compose-convenience-view-select-list entity application true)))) "FROM " (s/join ", " (set (compose-convenience-view-select-list entity application true))))
(if (if-not
(not (empty? entity-fields)) (empty? entity-fields)
(str (str
"WHERE " "WHERE "
(s/join (s/join
@ -408,7 +413,7 @@
(list (list
doc-comment doc-comment
(map (map
#(:content %) :content
(children-with-tag entity :documentation)))) (children-with-tag entity :documentation))))
(s/join (s/join
" " " "
@ -427,7 +432,7 @@
(map (map
#(emit-property % entity application false) #(emit-property % entity application false)
(filter (filter
#(not (= (:type (:attrs %)) "link")) #(not= (:type (:attrs %)) "link")
(children-with-tag entity :property))))))) (children-with-tag entity :property)))))))
"\n);") "\n);")
(map (map
@ -532,7 +537,7 @@
(str "(https://github.com/simon-brooke/adl) at " (str "(https://github.com/simon-brooke/adl) at "
(f/unparse (f/formatters :basic-date-time) (t/now))) (f/unparse (f/formatters :basic-date-time) (t/now)))
(map (map
#(:content %) :content
(children-with-tag application :documentation)))) (children-with-tag application :documentation))))
@ -568,18 +573,10 @@
(:name (:attrs application)) (:name (:attrs application))
".postgres.sql")] ".postgres.sql")]
(make-parents filepath) (make-parents filepath)
(try (do-or-warn
(spit filepath (emit-application application)) (spit filepath (emit-application application))
(if (> *verbosity* 0) (if
(*warn* (str "\tGenerated " filepath))) (pos? *verbosity*)
(catch (*warn* (str "\tGenerated " filepath))))))
Exception any
(*warn*
(str
"ERROR: Exception "
(.getName (.getClass any))
(.getMessage any)
" while printing "
filepath))))))

View file

@ -50,6 +50,7 @@
(f/unparse (f/formatters :basic-date-time) (t/now))) (f/unparse (f/formatters :basic-date-time) (t/now)))
(list (list
:require :require
'[adl-support.forms-support :refer :all]
'[adl-support.core :as support] '[adl-support.core :as support]
'[clojure.java.io :as io] '[clojure.java.io :as io]
'[clojure.set :refer [subset?]] '[clojure.set :refer [subset?]]
@ -67,21 +68,15 @@
(defn make-form-handler-content (defn make-form-handler-content
[f e a n] [f e a n]
(let [warning (list 'str (str "Error while fetching " (singularise (:name (:attrs e))) " record ") 'params)] (let [entity-name (singularise (:name (:attrs e)))]
;; TODO: as yet makes no attempt to save the record ;; TODO: as yet makes no attempt to save the record
(list 'let (list 'let
(vector (vector
'record (list 'record (list
'support/do-or-log-error 'get-current-value
;;(list 'if (list 'subset? (key-names e) (list 'set (list 'keys 'params))) (symbol (str "db/get-" entity-name))
(list 'params
(symbol entity-name))
(str "db/get-" (singularise (:name (:attrs e)))))
(symbol "db/*db*")
'params)
;;)
:message warning
:error-return {:warnings [warning]}))
(reduce (reduce
merge merge
{:error (list :warnings 'record) {:error (list :warnings 'record)
@ -199,10 +194,7 @@
(vector 'request) (vector 'request)
(list 'let (vector (list 'let (vector
'params 'params
(list 'support/massage-params (list 'support/massage-params 'request))
(list 'keywordize-keys (list :params 'request))
(list 'keywordize-keys (list :form-params 'request))
(key-names e true)))
(list (list
'l/render 'l/render
(list 'support/resolve-template (str n ".html")) (list 'support/resolve-template (str n ".html"))
@ -303,7 +295,7 @@
[application] [application]
(let [filepath (str *output-path* "src/clj/" (:name (:attrs application)) "/routes/auto.clj")] (let [filepath (str *output-path* "src/clj/" (:name (:attrs application)) "/routes/auto.clj")]
(make-parents filepath) (make-parents filepath)
(try (do-or-warn
(with-open [output (writer filepath)] (with-open [output (writer filepath)]
(binding [*out* output] (binding [*out* output]
(pprint (file-header application)) (pprint (file-header application))
@ -330,15 +322,7 @@
(println) (println)
(pprint (make-defroutes application)) (pprint (make-defroutes application))
(println))) (println)))
(if (> *verbosity* 0) (if
(*warn* (str "\tGenerated " filepath))) (pos? *verbosity*)
(catch (*warn* (str "\tGenerated " filepath))))))
Exception any
(*warn*
(str
"ERROR: Exception "
(.getName (.getClass any))
(.getMessage any)
" while printing "
filepath))))))

View file

@ -62,7 +62,7 @@
(defn emit-content (defn emit-content
([content] ([content]
(try (do-or-warn
(cond (cond
(nil? content) (nil? content)
nil nil
@ -82,7 +82,7 @@
"';\n" "';\n"
(-> any .getClass .getName) (-> any .getClass .getName)
": " ": "
(-> any .getMessage) (.getMessage any)
" -->")))) " -->"))))
([filename application k] ([filename application k]
(emit-content filename nil nil application k)) (emit-content filename nil nil application k))
@ -356,9 +356,46 @@
"{% endif %}")))}) "{% endif %}")))})
(defn compose-input-widget-para
"Generate an input widget for this `field-or-property` of this `form` for
this `entity` taken from within this `application`, in context of a para
also containing its label."
[property form entity application widget-name]
(let
[typedef (typedef property application)
w-type (widget-type property application typedef)]
(compose-widget-para
property form entity application widget-name
{:tag :input
:attrs (merge
{:id widget-name
:name widget-name
:type w-type
:value (str "{{record." widget-name "}}")
:maxlength (:size (:attrs property))
:size (cond
(nil? (:size (:attrs property)))
"16"
(try
(> (read-string
(:size (:attrs property))) 60)
(catch Exception _ false))
"60"
true
(:size (:attrs property)))}
;; TODO: should match pattern from typedef
(if
(:minimum (:attrs typedef))
{:min (:minimum (:attrs typedef))})
(if
(:maximum (:attrs typedef))
{:max (:maximum (:attrs typedef))}))})))
(defn widget (defn widget
"Generate a widget for this `field-or-property` of this `form` for this `entity` "Generate a widget for this `field-or-property` of this `form` for this `entity`
taken from within this `application`." taken from within this `application`, in context of a para also containing its
label."
[field-or-property form entity application] [field-or-property form entity application]
(let (let
[widget-name (safe-name [widget-name (safe-name
@ -370,13 +407,7 @@
:property field-or-property :property field-or-property
:field (property-for-field field-or-property entity) :field (property-for-field field-or-property entity)
;; default ;; default
nil) nil)]
permissions (find-permissions field-or-property property form entity application)
typedef (typedef property application)
w-type (widget-type property application typedef)
visible-to (visible-to permissions)
;; if the form isn't actually a form, no widget is writeable.
writeable-by (if (= (:tag form) :form) (writeable-by permissions))]
(if (if
property property
(case w-type (case w-type
@ -396,31 +427,7 @@
:attrs {:rows "8" :cols "60" :id widget-name :name widget-name} :attrs {:rows "8" :cols "60" :id widget-name :name widget-name}
:content [(str "{{record." widget-name "}}")]}) :content [(str "{{record." widget-name "}}")]})
;; all others ;; all others
(compose-widget-para (compose-input-widget-para property form entity application widget-name)))))
property form entity application widget-name
{:tag :input
:attrs (merge
{:id widget-name
:name widget-name
:type w-type
:value (str "{{record." widget-name "}}")
:maxlength (:size (:attrs property))
:size (cond
(nil? (:size (:attrs property)))
"16"
(try
(> (read-string
(:size (:attrs property))) 60)
(catch Exception _ false))
"60"
true
(:size (:attrs property)))}
(if
(:minimum (:attrs typedef))
{:min (:minimum (:attrs typedef))})
(if
(:maximum (:attrs typedef))
{:max (:maximum (:attrs typedef))}))})))))
(defn embed-script-fragment (defn embed-script-fragment
@ -898,7 +905,7 @@
(let [filepath (str *output-path* "resources/templates/auto/" filename)] (let [filepath (str *output-path* "resources/templates/auto/" filename)]
(if (if
template template
(try (do-or-warn
(do (do
(make-parents filepath) (make-parents filepath)
(spit (spit
@ -917,7 +924,9 @@
"{% endblock %}")) "{% endblock %}"))
(keys template))) (keys template)))
(file-footer filename application))))) (file-footer filename application)))))
(if (> *verbosity* 0) (*warn* "\tGenerated " filepath))) (if
(pos? *verbosity*)
(*warn* "\tGenerated " filepath)))
(catch Exception any (catch Exception any
(let [report (str (let [report (str
"ERROR: Exception " "ERROR: Exception "
@ -925,7 +934,7 @@
(.getMessage any) (.getMessage any)
" while printing " " while printing "
filepath)] filepath)]
(try (do-or-warn
(spit (spit
filepath filepath
(with-out-str (with-out-str
@ -962,7 +971,7 @@
#(if #(if
(templates-map %) (templates-map %)
(let [filename (str (name %) ".html")] (let [filename (str (name %) ".html")]
(try (do-or-warn
(write-template-file filename (templates-map %) application) (write-template-file filename (templates-map %) application)
(catch Exception any (catch Exception any
(*warn* (*warn*

View file

@ -19,54 +19,67 @@
(= a b))) (= a b)))
(deftest entity-tests (deftest entity-tests
(let [xml {:tag :entity, (let [application {:tag :application,
:attrs {:name "address"}, :attrs {:version "0.1.1", :name "test-app"},
:content :content
[{:tag :key, [{:tag :entity,
:attrs nil, :attrs {:name "address"},
:content :content
[{:tag :property, [{:tag :key,
:attrs :attrs nil,
{:immutable "true",
:required "true",
:distinct "system",
:type "integer",
:name "id"},
:content :content
[{:tag :generator, :attrs {:action "native"}, :content nil}]}]} [{:tag :property,
{:tag :property, :attrs
:attrs {:immutable "true",
{:distinct "user", :size "128", :type "string", :name "street"}, :required "true",
:content nil} :distinct "system",
{:tag :property, :type "integer",
:attrs {:size "64", :type "string", :name "town"}, :name "id"},
:content nil} :content
{:tag :property, [{:tag :generator, :attrs {:action "native"}, :content nil}]}
:attrs {:tag :property,
{:distinct "user", :size "12", :type "string", :name "postcode"}, :attrs
:content nil}]}] {: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 (let [expected
"ORDER BY address.street, "ORDER BY address.street,
address.postcode, address.postcode,
address.id" address.id"
actual (order-by-clause xml)] actual (order-by-clause entity)]
(is (string-equal-ignore-whitespace? actual expected)))) (is (string-equal-ignore-whitespace? actual expected))))
(testing "keys name extraction" (testing "keys name extraction"
(let [expected '("id") (let [expected #{"id"}
actual (key-names xml)] actual (key-names entity)]
(is (string-equal-ignore-whitespace? actual expected)))) (is (string-equal-ignore-whitespace? actual expected))))
(testing "primary key test" (testing "primary key test"
(let [expected true (let [expected true
actual (has-primary-key? xml)] actual (has-primary-key? entity)]
(is (string-equal-ignore-whitespace? actual expected)))) (is (string-equal-ignore-whitespace? actual expected))))
(testing "non-key properties test" (testing "non-key properties test"
(let [expected true (let [expected true
actual (has-non-key-properties? xml)] 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-addres! :! :n (let [expected "-- :name create-address! :! :n
-- :doc creates a new addres record -- :doc creates a new address record
INSERT INTO address (street, INSERT INTO address (street,
town, town,
postcode) postcode)
@ -74,25 +87,25 @@
':town', ':town',
':postcode') ':postcode')
returning id\n\n" returning id\n\n"
actual (:query (first (vals (insert-query xml))))] 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 ":! :n"
actual (:signature (first (vals (insert-query xml))))] 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"
(let [expected "-- :name update-addres! :! :n (let [expected "-- :name update-address! :! :n
-- :doc updates an existing addres record -- :doc updates an existing address record
UPDATE address UPDATE address
SET street = :street, SET street = :street,
town = :town, town = :town,
postcode = :postcode postcode = :postcode
WHERE address.id = :id\n\n" WHERE address.id = :id\n\n"
actual (:query (first (vals (update-query xml))))] 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"
(let [expected ":! :n" (let [expected ":! :n"
actual (:signature (first (vals (update-query xml))))] 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-addres :? :1
@ -106,22 +119,22 @@
address.id 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\")\n\n"
actual (:query (first (vals (search-query xml))))] 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 ":? :1"
actual (:signature (first (vals (search-query xml))))] actual (:signature (first (vals (search-query entity))))]
(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-addres :? :1
-- :doc selects an existing addres record -- :doc selects an existing addres record
SELECT * FROM address SELECT * FROM address
WHERE address.id = :id\n\n" WHERE address.id = :id\n\n"
actual (:query (first (vals (select-query xml))))] 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"
(let [expected ":? :1" (let [expected ":? :1"
actual (:signature (first (vals (select-query xml))))] actual (:signature (first (vals (select-query entity))))]
(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 :? :*
@ -132,75 +145,79 @@
address.id 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\")\n\n"
actual (:query (first (vals (list-query xml))))] 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"
(let [expected ":? :*" (let [expected ":? :*"
actual (:signature (first (vals (list-query xml))))] actual (:signature (first (vals (list-query entity))))]
(is (string-equal-ignore-whitespace? actual expected)))) (is (string-equal-ignore-whitespace? actual expected))))
(testing "delete query generation" (testing "delete query generation"
(let [expected "-- :name delete-addres! :! :n (let [expected "-- :name delete-addres! :! :n
-- :doc updates an existing addres record -- :doc updates an existing addres record
DELETE FROM address DELETE FROM address
WHERE address.id = :id\n\n" WHERE address.id = :id\n\n"
actual (:query (first (vals (delete-query xml))))] 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"
(let [expected ":! :n" (let [expected ":! :n"
actual (:signature (first (vals (delete-query xml))))] 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 [xml {:tag :entity, (let [application {:tag :application,
:attrs {:name "address"}, :attrs {:version "0.1.1", :name "test-app"},
:content :content
[{:tag :key, [{:tag :entity,
:attrs nil, :attrs {:name "address"},
:content :content
[{:tag :property, [{:tag :key,
:attrs :attrs nil,
{:immutable "true",
:required "true",
:distinct "system",
:type "integer",
:name "id"},
:content :content
[{:tag :generator, :attrs {:action "native"}, :content nil}]} [{: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, {:tag :property,
:attrs :attrs
{:immutable "true", {:distinct "user", :size "128", :type "string", :name "street"},
:required "true", :content nil}
:distinct "all", {:tag :property,
:generator "assigned" :attrs {:size "64", :type "string", :name "town"},
:type "string", :content nil}
:size "12" ]}]}
:name "postcode"}, entity (child-with-tag application :entity)]
: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}
]}]
(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,
address.postcode, address.postcode,
address.id" address.id"
actual (order-by-clause xml)] actual (order-by-clause entity)]
(is (string-equal-ignore-whitespace? actual expected)))) (is (string-equal-ignore-whitespace? actual expected))))
(testing "keys name extraction" (testing "keys name extraction"
(let [expected '("id" "postcode") (let [expected #{"id" "postcode"}
actual (key-names xml)] 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-addres! :! :n (let [expected "-- :name create-address! :! :n
-- :doc creates a new addres record -- :doc creates a new address record
INSERT INTO address (street, INSERT INTO address (street,
town, town,
postcode) postcode)
@ -209,17 +226,17 @@
':postcode') ':postcode')
returning id, returning id,
postcode\n\n" postcode\n\n"
actual (:query (first (vals (insert-query xml))))] actual (:query (first (vals (insert-query entity))))]
(is (string-equal-ignore-whitespace? actual expected)))) (is (string-equal-ignore-whitespace? actual expected))))
(testing "update query generation - compound key" (testing "update query generation - compound key"
(let [expected "-- :name update-addres! :! :n (let [expected "-- :name update-address! :! :n
-- :doc updates an existing addres record -- :doc updates an existing address record
UPDATE address UPDATE address
SET street = :street, SET street = :street,
town = :town town = :town
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 xml))))] 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"
(let [expected "-- :name search-strings-addres :? :1 (let [expected "-- :name search-strings-addres :? :1
@ -233,7 +250,7 @@
address.id 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\")\n\n"
actual (:query (first (vals (search-query xml))))] actual (:query (first (vals (search-query entity application))))]
(is (string-equal-ignore-whitespace? actual expected)))) (is (string-equal-ignore-whitespace? actual expected))))
(testing "delete query generation - compound key" (testing "delete query generation - compound key"
(let [expected "-- :name delete-addres! :! :n (let [expected "-- :name delete-addres! :! :n
@ -241,6 +258,6 @@
DELETE FROM address DELETE FROM address
WHERE address.id = :id WHERE address.id = :id
AND address.postcode = ':postcode'\n\n" AND address.postcode = ':postcode'\n\n"
actual (:query (first (vals (delete-query xml))))] actual (:query (first (vals (delete-query entity))))]
(is (string-equal-ignore-whitespace? actual expected)))))) (is (string-equal-ignore-whitespace? actual expected))))))