Merge branch 'feature/5' into develop
This commit is contained in:
commit
6ba1ad60c9
|
|
@ -5,7 +5,7 @@
|
|||
: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.3"]
|
||||
:dependencies [[adl-support "0.1.4-SNAPSHOT"]
|
||||
[bouncer "1.0.1"]
|
||||
[clojure-saxon "0.9.4"]
|
||||
[environ "1.1.0"]
|
||||
|
|
@ -19,7 +19,10 @@
|
|||
:main adl.main
|
||||
|
||||
: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
|
||||
;; :deploy-via :clojars} ;; :deploy-via :clojars fails - with an scp error.
|
||||
|
|
|
|||
|
|
@ -92,25 +92,24 @@
|
|||
(defn process
|
||||
"Process these parsed `options`."
|
||||
[options]
|
||||
(do
|
||||
(let [p (:path (:options options))
|
||||
op (if (.endsWith p "/") p (str p "/"))]
|
||||
(binding [*output-path* op
|
||||
*locale* (-> options :options :locale)
|
||||
*verbosity* (-> options :options :verbosity)]
|
||||
(make-parents *output-path*)
|
||||
(doall
|
||||
(map
|
||||
#(if
|
||||
(.exists (java.io.File. %))
|
||||
(let [application (x/parse (canonicalise %))]
|
||||
(h/to-hugsql-queries application)
|
||||
(j/to-json-routes application)
|
||||
(p/to-psql application)
|
||||
(s/to-selmer-routes application)
|
||||
(t/to-selmer-templates application))
|
||||
(*warn* (str "ERROR: File not found: " %)))
|
||||
(-> options :arguments)))))))
|
||||
(let [p (:path (:options options))
|
||||
op (if (.endsWith p "/") p (str p "/"))]
|
||||
(binding [*output-path* op
|
||||
*locale* (-> options :options :locale)
|
||||
*verbosity* (-> options :options :verbosity)]
|
||||
(make-parents *output-path*)
|
||||
(doall
|
||||
(map
|
||||
#(if
|
||||
(.exists (java.io.File. %))
|
||||
(let [application (x/parse (canonicalise %))]
|
||||
(h/to-hugsql-queries application)
|
||||
(j/to-json-routes application)
|
||||
(p/to-psql application)
|
||||
(s/to-selmer-routes application)
|
||||
(t/to-selmer-templates application))
|
||||
(*warn* (str "ERROR: File not found: " %)))
|
||||
(:arguments options))))))
|
||||
|
||||
|
||||
(defn -main
|
||||
|
|
@ -121,7 +120,7 @@
|
|||
(cond
|
||||
(empty? args)
|
||||
(usage options)
|
||||
(not (empty? (:errors options)))
|
||||
(seq (:errors options))
|
||||
(do
|
||||
(doall
|
||||
(map
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
(ns ^{:doc "Application Description Language - generate HUGSQL queries file."
|
||||
:author "Simon Brooke"}
|
||||
adl.to-hugsql-queries
|
||||
(:require [adl-support.core :refer [*warn*]]
|
||||
(:require [adl-support.core :refer :all]
|
||||
[adl-support.utils :refer :all]
|
||||
[clojure.java.io :refer [file make-parents]]
|
||||
[clojure.math.combinatorics :refer [combinations]]
|
||||
|
|
@ -46,13 +46,12 @@
|
|||
(let
|
||||
[entity-name (:name (:attrs entity))
|
||||
property-names (map #(:name (:attrs %)) properties)]
|
||||
(if
|
||||
(not (empty? property-names))
|
||||
(if-not (empty? property-names)
|
||||
(str
|
||||
"WHERE "
|
||||
(s/join
|
||||
"\n\tAND"
|
||||
(map #(str entity-name "." % " = :" %) property-names)))))))
|
||||
"WHERE "
|
||||
(s/join
|
||||
"\n\tAND"
|
||||
(map #(str entity-name "." % " = :" %) property-names)))))))
|
||||
|
||||
|
||||
(defn order-by-clause
|
||||
|
|
@ -213,8 +212,8 @@
|
|||
(defn select-query
|
||||
"Generate an appropriate `select` query for this `entity`"
|
||||
([entity properties]
|
||||
(if
|
||||
(not (empty? properties))
|
||||
(if-not
|
||||
(empty? properties)
|
||||
(let [entity-name (safe-name (:name (:attrs entity)) :sql)
|
||||
pretty-name (singularise entity-name)
|
||||
query-name (if (= properties (key-properties entity))
|
||||
|
|
@ -384,32 +383,24 @@
|
|||
[application]
|
||||
(let [filepath (str *output-path* "resources/sql/queries.auto.sql")]
|
||||
(make-parents filepath)
|
||||
(try
|
||||
(spit
|
||||
(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 (> *verbosity* 0)
|
||||
(*warn* (str "\tGenerated " filepath)))
|
||||
(catch
|
||||
Exception any
|
||||
(*warn*
|
||||
(str
|
||||
"ERROR: Exception "
|
||||
(.getName (.getClass any))
|
||||
(.getMessage any)
|
||||
" while printing "
|
||||
filepath))))))
|
||||
"\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)))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
(ns ^{:doc "Application Description Language: generate RING routes for REST requests."
|
||||
:author "Simon Brooke"}
|
||||
adl.to-json-routes
|
||||
(:require [adl-support.core :refer [*warn*]]
|
||||
(:require [adl-support.core :refer :all]
|
||||
[adl-support.utils :refer :all]
|
||||
[adl.to-hugsql-queries :refer [queries]]
|
||||
[clj-time.core :as t]
|
||||
|
|
@ -53,7 +53,8 @@
|
|||
(f/unparse (f/formatters :basic-date-time) (t/now)))
|
||||
(list
|
||||
:require
|
||||
'[adl-support.core :as support]
|
||||
'[adl-support.core :refer :all]
|
||||
'[adl-support.rest-support :refer :all]
|
||||
'[clojure.core.memoize :as memo]
|
||||
'[clojure.java.io :as io]
|
||||
'[clojure.tools.logging :as log]
|
||||
|
|
@ -72,28 +73,38 @@
|
|||
(defn generate-handler-body
|
||||
"Generate and return the function body for the handler for this `query`."
|
||||
[query]
|
||||
(let [action (list
|
||||
(symbol (str "db/" (:name query)))
|
||||
'db/*db*
|
||||
(list 'support/massage-params
|
||||
'params
|
||||
'form-params
|
||||
(key-names (:entity query))))]
|
||||
(list
|
||||
['request]
|
||||
(list
|
||||
'let
|
||||
['params '(massage-params request)]
|
||||
(list
|
||||
[{:keys ['params 'form-params]}]
|
||||
(case
|
||||
(:type query)
|
||||
(:delete-1 :update-1)
|
||||
'valid-user-or-forbid
|
||||
(list
|
||||
'with-params-or-error
|
||||
(list
|
||||
'do-or-server-fail
|
||||
(list
|
||||
action
|
||||
`(log/debug (str ~(:name query) " called with params " ~'params "."))
|
||||
'(response/found "/"))
|
||||
(list
|
||||
'let
|
||||
(vector 'result action)
|
||||
`(log/debug (~(symbol (str "db/" (:name query) "-sqlvec")) ~'params))
|
||||
`(log/debug (str ~(str "'" (:name query) "' with params ") ~'params " returned " (count ~'result) " records."))
|
||||
(list 'response/ok 'result))))))
|
||||
(symbol (str "db/" (:name query)))
|
||||
'db/*db*
|
||||
'params)
|
||||
(case (:type query)
|
||||
:insert-1 201 ;; created
|
||||
:delete-1 204 ;; no content
|
||||
;; default
|
||||
200)) ;; OK
|
||||
'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
|
||||
|
|
@ -262,7 +273,7 @@
|
|||
(let [handlers-map (make-handlers-map application)
|
||||
filepath (str *output-path* "src/clj/" (:name (:attrs application)) "/routes/auto_json.clj")]
|
||||
(make-parents filepath)
|
||||
(try
|
||||
(do-or-warn
|
||||
(with-open [output (writer filepath)]
|
||||
(binding [*out* output]
|
||||
(pprint (file-header application))
|
||||
|
|
@ -275,16 +286,7 @@
|
|||
h)
|
||||
(sort (keys handlers-map))))
|
||||
(pprint (defroutes handlers-map))))
|
||||
(if (> *verbosity* 0)
|
||||
(*warn* (str "\tGenerated " filepath)))
|
||||
(catch
|
||||
Exception any
|
||||
(*warn*
|
||||
(str
|
||||
"ERROR: Exception "
|
||||
(.getName (.getClass any))
|
||||
(.getMessage any)
|
||||
" while printing "
|
||||
filepath))))))
|
||||
(if (pos? *verbosity*)
|
||||
(*warn* (str "\tGenerated " filepath))))))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
(ns ^{:doc "Application Description Language: generate Postgres database definition."
|
||||
:author "Simon Brooke"}
|
||||
adl.to-psql
|
||||
(:require [adl-support.core :refer [*warn*]]
|
||||
(: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]]
|
||||
|
|
@ -111,7 +111,12 @@
|
|||
(defn emit-field-type
|
||||
[property entity application key?]
|
||||
(case (:type (:attrs property))
|
||||
"integer" (if key? "SERIAL" "INTEGER")
|
||||
"integer" (if
|
||||
(and
|
||||
key?
|
||||
(system-generated? property))
|
||||
"SERIAL"
|
||||
"INTEGER")
|
||||
"real" "DOUBLE PRECISION"
|
||||
("string" "image" "uploadable")
|
||||
(str "VARCHAR(" (:size (:attrs property)) ")")
|
||||
|
|
@ -150,8 +155,8 @@
|
|||
#(if (selector (:permission (:attrs %)))
|
||||
(safe-name (:group (:attrs %)) :sql))
|
||||
permissions)))]
|
||||
(if
|
||||
(not (empty? group-names))
|
||||
(if-not
|
||||
(empty? group-names)
|
||||
(s/join
|
||||
" "
|
||||
(list
|
||||
|
|
@ -318,12 +323,12 @@
|
|||
(str (safe-name entity) "." (field-name %)))
|
||||
(str (safe-name entity) "." (field-name %)))
|
||||
(filter
|
||||
#(not (= (:type (:attrs %)) "link"))
|
||||
#(not= (:type (:attrs %)) "link")
|
||||
(all-properties entity) )))))
|
||||
(str
|
||||
"FROM " (s/join ", " (set (compose-convenience-view-select-list entity application true))))
|
||||
(if
|
||||
(not (empty? entity-fields))
|
||||
(if-not
|
||||
(empty? entity-fields)
|
||||
(str
|
||||
"WHERE "
|
||||
(s/join
|
||||
|
|
@ -408,7 +413,7 @@
|
|||
(list
|
||||
doc-comment
|
||||
(map
|
||||
#(:content %)
|
||||
:content
|
||||
(children-with-tag entity :documentation))))
|
||||
(s/join
|
||||
" "
|
||||
|
|
@ -427,7 +432,7 @@
|
|||
(map
|
||||
#(emit-property % entity application false)
|
||||
(filter
|
||||
#(not (= (:type (:attrs %)) "link"))
|
||||
#(not= (:type (:attrs %)) "link")
|
||||
(children-with-tag entity :property)))))))
|
||||
"\n);")
|
||||
(map
|
||||
|
|
@ -532,7 +537,7 @@
|
|||
(str "(https://github.com/simon-brooke/adl) at "
|
||||
(f/unparse (f/formatters :basic-date-time) (t/now)))
|
||||
(map
|
||||
#(:content %)
|
||||
:content
|
||||
(children-with-tag application :documentation))))
|
||||
|
||||
|
||||
|
|
@ -568,18 +573,10 @@
|
|||
(:name (:attrs application))
|
||||
".postgres.sql")]
|
||||
(make-parents filepath)
|
||||
(try
|
||||
(do-or-warn
|
||||
(spit filepath (emit-application application))
|
||||
(if (> *verbosity* 0)
|
||||
(*warn* (str "\tGenerated " filepath)))
|
||||
(catch
|
||||
Exception any
|
||||
(*warn*
|
||||
(str
|
||||
"ERROR: Exception "
|
||||
(.getName (.getClass any))
|
||||
(.getMessage any)
|
||||
" while printing "
|
||||
filepath))))))
|
||||
(if
|
||||
(pos? *verbosity*)
|
||||
(*warn* (str "\tGenerated " filepath))))))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,8 +1,9 @@
|
|||
(ns ^{:doc "Application Description Language: generate routes for user interface requests."
|
||||
:author "Simon Brooke"}
|
||||
adl.to-selmer-routes
|
||||
(:require [adl-support.core :refer [*warn*]]
|
||||
(:require [adl-support.core :refer :all]
|
||||
[adl-support.utils :refer :all]
|
||||
[adl-support.forms-support :refer :all]
|
||||
[clj-time.core :as t]
|
||||
[clj-time.format :as f]
|
||||
[clojure.java.io :refer [file make-parents writer]]
|
||||
|
|
@ -34,11 +35,8 @@
|
|||
;;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;; Generally. there's one route in the generated file for each Selmer
|
||||
;;; template which has been generated.
|
||||
|
||||
;;; TODO: there must be some more idiomatic way of generating all these
|
||||
;;; functions.
|
||||
;;; Generally. there are two routes - one for GET, one for POST - in the
|
||||
;;; generated file for each Selmer template which has been generated.
|
||||
|
||||
(defn file-header
|
||||
[application]
|
||||
|
|
@ -51,6 +49,8 @@
|
|||
(list
|
||||
:require
|
||||
'[adl-support.core :as support]
|
||||
'[adl-support.forms-support :refer :all]
|
||||
'[adl-support.rest-support :refer :all]
|
||||
'[clojure.java.io :as io]
|
||||
'[clojure.set :refer [subset?]]
|
||||
'[clojure.tools.logging :as log]
|
||||
|
|
@ -65,62 +65,43 @@
|
|||
(vector (symbol (str (:name (:attrs application)) ".routes.manual")) :as 'm))))
|
||||
|
||||
|
||||
(defn make-form-handler-content
|
||||
(defn make-form-get-handler-content
|
||||
[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
|
||||
(list 'let
|
||||
(vector
|
||||
'record (list
|
||||
'support/do-or-log-error
|
||||
;;(list 'if (list 'subset? (key-names e) (list 'set (list 'keys 'params)))
|
||||
(list
|
||||
(symbol
|
||||
(str "db/get-" (singularise (:name (:attrs e)))))
|
||||
(symbol "db/*db*")
|
||||
'params)
|
||||
;;)
|
||||
:message warning
|
||||
:error-return {:warnings [warning]}))
|
||||
'record (list
|
||||
'get-current-value
|
||||
(symbol (str "db/get-" entity-name))
|
||||
'params
|
||||
entity-name))
|
||||
(reduce
|
||||
merge
|
||||
{:error (list :warnings 'record)
|
||||
:record (list 'dissoc 'record :warnings)}
|
||||
(map
|
||||
(fn [property]
|
||||
(hash-map
|
||||
(keyword (-> property :attrs :name))
|
||||
(list
|
||||
'flatten
|
||||
(list
|
||||
'remove
|
||||
'nil?
|
||||
(list
|
||||
'list
|
||||
;; Get the current value of the property, if it's an entity
|
||||
(if (= (-> property :attrs :type) "entity")
|
||||
(list 'support/do-or-log-error
|
||||
(list
|
||||
(symbol
|
||||
(str "db/get-" (singularise (:entity (:attrs property)))))
|
||||
(symbol "db/*db*")
|
||||
(hash-map (keyword (-> property :attrs :farkey))
|
||||
(list (keyword (-> property :attrs :name)) 'record)))
|
||||
:message (str "Error while fetching "
|
||||
(singularise (:entity (:attrs property)))
|
||||
" record " (hash-map (keyword (-> property :attrs :farkey))
|
||||
(list (keyword (-> property :attrs :name)) 'record)))))
|
||||
;;; and the potential values of the property
|
||||
(list 'support/do-or-log-error
|
||||
(list (symbol (str "db/list-" (:entity (:attrs property)))) (symbol "db/*db*"))
|
||||
:message (str "Error while fetching "
|
||||
(singularise (:entity (:attrs property)))
|
||||
" list")))))))
|
||||
(filter #(:entity (:attrs %))
|
||||
(descendants-with-tag e :property)))))))
|
||||
merge
|
||||
{:error (list :warnings 'record)
|
||||
:record (list 'dissoc 'record :warnings)}
|
||||
(map
|
||||
(fn [property]
|
||||
(hash-map
|
||||
(keyword (-> property :attrs :name))
|
||||
(list
|
||||
'flatten
|
||||
(list
|
||||
'remove
|
||||
'nil?
|
||||
(list
|
||||
'list
|
||||
;; Get the current value of the property, if it's an entity
|
||||
(if (= (-> property :attrs :type) "entity")
|
||||
(list 'get-menu-options
|
||||
(-> e :attrs :name)
|
||||
(-> property :attrs :farkey)
|
||||
(list (keyword (-> property :attrs :name)) 'params))))))))
|
||||
(filter #(:entity (:attrs %))
|
||||
(descendants-with-tag e :property)))))))
|
||||
|
||||
|
||||
(defn make-page-handler-content
|
||||
(defn make-page-get-handler-content
|
||||
[f e a n]
|
||||
(let [warning (str "Error while fetching " (singularise (:name (:attrs e))) " record")]
|
||||
(list 'let
|
||||
|
|
@ -134,113 +115,193 @@
|
|||
'params))
|
||||
:message warning
|
||||
:error-return {:warnings [warning]}))
|
||||
{:warnings (list :warnings 'record)
|
||||
:record (list 'assoc 'record :warnings nil)})))
|
||||
{:warnings (list :warnings 'record)
|
||||
:record (list 'assoc 'record :warnings nil)})))
|
||||
|
||||
|
||||
(defn make-list-handler-content
|
||||
(defn make-list-get-handler-content
|
||||
[f e a n]
|
||||
(list
|
||||
'let
|
||||
(vector
|
||||
'records
|
||||
(list
|
||||
'if
|
||||
(list
|
||||
'some
|
||||
(set (map #(keyword (-> % :attrs :name)) (all-properties e)))
|
||||
(list 'keys 'params))
|
||||
(list 'do
|
||||
(list (symbol "log/debug") (list (symbol (str "db/search-strings-" (:name (:attrs e)) "-sqlvec")) 'params))
|
||||
(list
|
||||
'support/do-or-log-error
|
||||
(list
|
||||
(symbol (str "db/search-strings-" (:name (:attrs e))))
|
||||
(symbol "db/*db*")
|
||||
'params)
|
||||
:message (str
|
||||
"Error while searching "
|
||||
(singularise (:name (:attrs e)))
|
||||
" records")
|
||||
:error-return {:warnings [(str
|
||||
"Error while searching "
|
||||
(singularise (:name (:attrs e)))
|
||||
" records")]}))
|
||||
(list 'do
|
||||
(list (symbol "log/debug") (list (symbol (str "db/list-" (:name (:attrs e)) "-sqlvec")) 'params))
|
||||
(list
|
||||
'support/do-or-log-error
|
||||
(list
|
||||
(symbol
|
||||
(str
|
||||
"db/list-"
|
||||
(:name (:attrs e))))
|
||||
(symbol "db/*db*") {})
|
||||
:message (str
|
||||
"Error while fetching "
|
||||
(singularise (:name (:attrs e)))
|
||||
" records")
|
||||
:error-return {:warnings [(str
|
||||
"Error while fetching "
|
||||
(singularise (:name (:attrs e)))
|
||||
" records")]}))))
|
||||
(list 'if
|
||||
(list :warnings 'records)
|
||||
'records
|
||||
{:records 'records})))
|
||||
|
||||
|
||||
(defn make-handler
|
||||
[f e a]
|
||||
(let [n (path-part f e a)]
|
||||
'let
|
||||
(vector
|
||||
'records
|
||||
(list
|
||||
'defn
|
||||
(symbol n)
|
||||
(vector 'request)
|
||||
(list 'let (vector
|
||||
'params
|
||||
(list 'support/massage-params
|
||||
(list 'keywordize-keys (list :params 'request))
|
||||
(list 'keywordize-keys (list :form-params 'request))
|
||||
(key-names e true)))
|
||||
'if
|
||||
(list
|
||||
'some
|
||||
(set (map #(keyword (-> % :attrs :name)) (all-properties e)))
|
||||
(list 'keys 'params))
|
||||
(list 'do
|
||||
(list (symbol "log/debug") (list (symbol (str "db/search-strings-" (:name (:attrs e)) "-sqlvec")) 'params))
|
||||
(list
|
||||
'support/do-or-log-error
|
||||
(list
|
||||
'l/render
|
||||
(list 'support/resolve-template (str n ".html"))
|
||||
(list 'merge
|
||||
{:title (capitalise (:name (:attrs f)))
|
||||
:params 'params}
|
||||
(case (:tag f)
|
||||
:form (make-form-handler-content f e a n)
|
||||
:page (make-page-handler-content f e a n)
|
||||
:list (make-list-handler-content f e a n))))))))
|
||||
(symbol (str "db/search-strings-" (:name (:attrs e))))
|
||||
(symbol "db/*db*")
|
||||
'params)
|
||||
:message (str
|
||||
"Error while searching "
|
||||
(singularise (:name (:attrs e)))
|
||||
" records")
|
||||
:error-return {:warnings [(str
|
||||
"Error while searching "
|
||||
(singularise (:name (:attrs e)))
|
||||
" records")]}))
|
||||
(list 'do
|
||||
(list (symbol "log/debug") (list (symbol (str "db/list-" (:name (:attrs e)) "-sqlvec")) 'params))
|
||||
(list
|
||||
'support/do-or-log-error
|
||||
(list
|
||||
(symbol
|
||||
(str
|
||||
"db/list-"
|
||||
(:name (:attrs e))))
|
||||
(symbol "db/*db*") {})
|
||||
:message (str
|
||||
"Error while fetching "
|
||||
(singularise (:name (:attrs e)))
|
||||
" records")
|
||||
:error-return {:warnings [(str
|
||||
"Error while fetching "
|
||||
(singularise (:name (:attrs e)))
|
||||
" records")]}))))
|
||||
(list 'if
|
||||
(list :warnings 'records)
|
||||
'records
|
||||
{:records 'records})))
|
||||
|
||||
|
||||
(defn handler-name
|
||||
"Generate the name of the appropriate handler function for form `f` of
|
||||
entity `e` of application `a` for method `m`, where `f`, `e`, and `a`
|
||||
are expected to be elements and `m` is expected to be one of the keywords
|
||||
`:put` `:get`."
|
||||
[f e a m]
|
||||
(str (s/lower-case (name m)) "-" (path-part f e a)))
|
||||
|
||||
|
||||
(defn make-get-handler
|
||||
[f e a]
|
||||
(let [n (handler-name f e a :get)]
|
||||
(list
|
||||
'defn
|
||||
(symbol n)
|
||||
(vector 'request)
|
||||
(list 'let (vector
|
||||
'params
|
||||
(list 'support/massage-params 'request))
|
||||
(list
|
||||
'l/render
|
||||
(list 'support/resolve-template (str (path-part f e a) ".html"))
|
||||
(list 'merge
|
||||
{:title (capitalise (:name (:attrs f)))
|
||||
:params 'params}
|
||||
(case (:tag f)
|
||||
:form (make-form-get-handler-content f e a n)
|
||||
:page (make-page-get-handler-content f e a n)
|
||||
:list (make-list-get-handler-content f e a n))))))))
|
||||
|
||||
|
||||
(defn make-form-post-handler-content
|
||||
;; Literally the only thing the post handler has to do is to
|
||||
;; generate the database store operation. Then it can hand off
|
||||
;; to the get handler.
|
||||
[f e a n]
|
||||
(let
|
||||
[create-name (query-name e :create)
|
||||
update-name (query-name e :update)]
|
||||
(list
|
||||
'let
|
||||
(vector
|
||||
'result
|
||||
(list
|
||||
'valid-user-or-forbid
|
||||
(list
|
||||
'with-params-or-error
|
||||
(list
|
||||
'do-or-server-fail
|
||||
(list
|
||||
'if
|
||||
(list 'all-keys-present? 'params (key-names e true))
|
||||
(list
|
||||
update-name
|
||||
'db/*db*
|
||||
'params)
|
||||
(list
|
||||
create-name
|
||||
'db/*db*
|
||||
'params))
|
||||
200) ;; OK
|
||||
'params
|
||||
(set
|
||||
(map
|
||||
#(keyword (:name (:attrs %)))
|
||||
(insertable-properties e))))
|
||||
'request))
|
||||
(list
|
||||
'if
|
||||
(list
|
||||
(set [200 400])
|
||||
(list :status 'result))
|
||||
(list
|
||||
(symbol (handler-name f e a :get))
|
||||
(list
|
||||
'assoc
|
||||
'request
|
||||
:params
|
||||
(list
|
||||
'merge
|
||||
'params
|
||||
'result)))
|
||||
'result))))
|
||||
|
||||
|
||||
(defn make-post-handler
|
||||
[f e a]
|
||||
(let [n (handler-name f e a :post)]
|
||||
(list
|
||||
'defn
|
||||
(symbol n)
|
||||
(vector 'request)
|
||||
(case
|
||||
(:tag f)
|
||||
(:page :list) (list (symbol (handler-name f e a :get)) 'request)
|
||||
:form (list
|
||||
'let
|
||||
(vector
|
||||
'params
|
||||
(list 'support/massage-params 'request))
|
||||
(make-form-post-handler-content f e a n))))))
|
||||
|
||||
|
||||
;; (def a (x/parse "../youyesyet/youyesyet.canonical.adl.xml"))
|
||||
;; (def e (child-with-tag a :entity))
|
||||
;; (def f (child-with-tag e :form))
|
||||
;; (def n (path-part f e a))
|
||||
;; (make-handler f e a)
|
||||
;; (def n (handler-name f e a :post))
|
||||
;; (make-post-handler f e a)
|
||||
;; (vector
|
||||
;; 'p
|
||||
;; (list 'merge
|
||||
;; {:offset 0 :limit 25}
|
||||
;; (list 'support/massage-params (list :params 'r))))
|
||||
;; (make-handler f e a)
|
||||
;; (make-get-handler f e a)
|
||||
|
||||
|
||||
(defn make-route
|
||||
"Make a route for method `m` to request the resource with name `n`."
|
||||
[m n]
|
||||
(list
|
||||
m
|
||||
(symbol (s/upper-case (name m)))
|
||||
(str "/" n)
|
||||
'request
|
||||
(list
|
||||
'route/restricted
|
||||
(list
|
||||
'apply
|
||||
(list 'resolve-handler n)
|
||||
(list 'resolve-handler (str (s/lower-case (name m)) "-" n))
|
||||
(list 'list 'request)))))
|
||||
|
||||
|
||||
(defn make-defroutes
|
||||
[application]
|
||||
(let [routes (flatten
|
||||
|
|
@ -263,10 +324,10 @@
|
|||
(apply (resolve-handler "index") (list request))))
|
||||
(interleave
|
||||
(map
|
||||
(fn [r] (make-route 'GET r))
|
||||
(fn [r] (make-route :get r))
|
||||
(sort routes))
|
||||
(map
|
||||
(fn [r] (make-route 'POST r))
|
||||
(fn [r] (make-route :post r))
|
||||
(sort routes))))))))
|
||||
|
||||
|
||||
|
|
@ -294,51 +355,52 @@
|
|||
(doall
|
||||
(map
|
||||
(fn [c]
|
||||
(pprint (make-handler c e application))
|
||||
(println))
|
||||
;; do all get handlers before post handlers, so that the post
|
||||
;; handlers can call the get handlers.
|
||||
(pprint (make-get-handler c e application))
|
||||
(println "\n")
|
||||
(pprint (make-post-handler c e application))
|
||||
(println "\n"))
|
||||
(filter (fn [c] (#{:form :list :page} (:tag c))) (children e)))))
|
||||
|
||||
|
||||
(defn to-selmer-routes
|
||||
[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")
|
||||
entities (sort
|
||||
#(compare (:name (:attrs %1))(:name (:attrs %2)))
|
||||
(children-with-tag application :entity))]
|
||||
(make-parents filepath)
|
||||
(try
|
||||
(with-open [output (writer filepath)]
|
||||
(binding [*out* output]
|
||||
(pprint (file-header application))
|
||||
(println)
|
||||
(pprint '(defn index
|
||||
[r]
|
||||
(l/render
|
||||
(support/resolve-template
|
||||
"application-index.html")
|
||||
(:session r)
|
||||
{:title "Administrative menu"})))
|
||||
(println)
|
||||
(doall
|
||||
(map
|
||||
#(make-handlers % application)
|
||||
(sort
|
||||
#(compare (:name (:attrs %1))(:name (:attrs %2)))
|
||||
(children-with-tag application :entity))))
|
||||
(pprint
|
||||
(generate-handler-resolver application))
|
||||
(println)
|
||||
(pprint '(def resolve-handler
|
||||
(memoize raw-resolve-handler)))
|
||||
(println)
|
||||
(pprint (make-defroutes application))
|
||||
(println)))
|
||||
(if (> *verbosity* 0)
|
||||
(*warn* (str "\tGenerated " filepath)))
|
||||
(catch
|
||||
Exception any
|
||||
(*warn*
|
||||
(str
|
||||
"ERROR: Exception "
|
||||
(.getName (.getClass any))
|
||||
(.getMessage any)
|
||||
" while printing "
|
||||
filepath))))))
|
||||
(do-or-warn
|
||||
(with-open [output (writer filepath)]
|
||||
(binding [*out* output]
|
||||
(pprint (file-header application))
|
||||
(println)
|
||||
(pprint '(defn index
|
||||
[r]
|
||||
(l/render
|
||||
(support/resolve-template
|
||||
"application-index.html")
|
||||
(:session r)
|
||||
{:title "Administrative menu"})))
|
||||
(println)
|
||||
(doall
|
||||
(map
|
||||
#(make-handlers % application)
|
||||
entities))
|
||||
(pprint
|
||||
(generate-handler-resolver application))
|
||||
(println)
|
||||
(pprint '(def resolve-handler
|
||||
(memoize raw-resolve-handler)))
|
||||
(println)
|
||||
(pprint (make-defroutes application))
|
||||
(println)))
|
||||
(if
|
||||
(pos? *verbosity*)
|
||||
(*warn* (str "\tGenerated " filepath))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
(ns ^{:doc "Application Description Language - generate Selmer templates for the HTML pages implied by an ADL file."
|
||||
(ns ^{:doc "Application Description Language - generate Selmer templates for
|
||||
the HTML pages implied by an ADL file."
|
||||
:author "Simon Brooke"}
|
||||
adl.to-selmer-templates
|
||||
(:require [adl-support.core :refer [*warn*]]
|
||||
(:require [adl-support.core :refer :all]
|
||||
[adl.to-hugsql-queries :refer [expanded-token]]
|
||||
[adl-support.utils :refer :all]
|
||||
[clojure.java.io :refer [file make-parents resource]]
|
||||
|
|
@ -41,7 +42,9 @@
|
|||
{:tag :div
|
||||
:attrs {:class "big-link-container"}
|
||||
:content
|
||||
[{:tag :a :attrs {:href (str "{{servlet-context}}/" url) :class "big-link"}
|
||||
[{:tag :a
|
||||
:attrs {:href (str "{{servlet-context}}/" url)
|
||||
:class "big-link"}
|
||||
:content (if
|
||||
(vector? content)
|
||||
content
|
||||
|
|
@ -62,7 +65,7 @@
|
|||
|
||||
(defn emit-content
|
||||
([content]
|
||||
(try
|
||||
(do-or-warn
|
||||
(cond
|
||||
(nil? content)
|
||||
nil
|
||||
|
|
@ -75,15 +78,7 @@
|
|||
(map emit-content (remove nil? content))
|
||||
true
|
||||
(str "<!-- don't know what to do with '" content "' -->"))
|
||||
(catch Exception any
|
||||
(str
|
||||
"<!-- failed while trying to emit \n'"
|
||||
(with-out-str (p/pprint content))
|
||||
"';\n"
|
||||
(-> any .getClass .getName)
|
||||
": "
|
||||
(-> any .getMessage)
|
||||
" -->"))))
|
||||
(str "Failed while writing " content)))
|
||||
([filename application k]
|
||||
(emit-content filename nil nil application k))
|
||||
([filename spec entity application k]
|
||||
|
|
@ -143,7 +138,8 @@
|
|||
|
||||
|
||||
(defn csrf-widget
|
||||
"For the present, just return the standard cross site scripting protection field statement"
|
||||
"For the present, just return the standard cross site scripting protection
|
||||
field statement"
|
||||
[]
|
||||
"{% csrf-field %}")
|
||||
|
||||
|
|
@ -179,16 +175,20 @@
|
|||
|
||||
|
||||
(defn save-widget
|
||||
"Return an appropriate 'save' widget for this `form` operating on this `entity` taken
|
||||
from this `application`.
|
||||
TODO: should be suppressed unless a member of a group which can insert or edit."
|
||||
"Return an appropriate 'save' widget for this `form` operating on this
|
||||
`entity` taken from this `application`.
|
||||
TODO: should be suppressed unless a member of a group which can insert
|
||||
or edit."
|
||||
[form entity application]
|
||||
(wrap-in-if-member-of
|
||||
{:tag :p
|
||||
:attrs {:class "widget action-safe"}
|
||||
:content [{:tag :label
|
||||
:attrs {:for "save-button" :class "action-safe"}
|
||||
:content [(str "To save this " (:name (:attrs entity)) " record")]}
|
||||
:content [(str
|
||||
"To save this "
|
||||
(:name (:attrs entity))
|
||||
" record")]}
|
||||
{:tag :input
|
||||
:attrs {:id "save-button"
|
||||
:name "save-button"
|
||||
|
|
@ -201,16 +201,20 @@
|
|||
|
||||
|
||||
(defn delete-widget
|
||||
"Return an appropriate 'save' widget for this `form` operating on this `entity` taken
|
||||
from this `application`.
|
||||
"Return an appropriate 'save' widget for this `form` operating on this
|
||||
`entity` taken from this `application`.
|
||||
TODO: should be suppressed unless member of a group which can delete."
|
||||
[form entity application]
|
||||
(wrap-in-if-member-of
|
||||
{:tag :p
|
||||
:attrs {:class "widget action-dangerous"}
|
||||
:content [{:tag :label
|
||||
:attrs {:for "delete-button" :class "action-dangerous"}
|
||||
:content [(str "To delete this " (:name (:attrs entity)) " record")]}
|
||||
:attrs {:for "delete-button"
|
||||
:class "action-dangerous"}
|
||||
:content [(str
|
||||
"To delete this "
|
||||
(:name (:attrs entity))
|
||||
" record")]}
|
||||
{:tag :input
|
||||
:attrs {:id "delete-button"
|
||||
:name "delete-button"
|
||||
|
|
@ -223,7 +227,8 @@
|
|||
|
||||
|
||||
(defn select-property
|
||||
"Return the property on which we will by default do a user search on this `entity`."
|
||||
"Return the property on which we will by default do a user search on this
|
||||
`entity`."
|
||||
[entity]
|
||||
(descendant-with-tag
|
||||
entity
|
||||
|
|
@ -241,8 +246,8 @@
|
|||
|
||||
|
||||
(defn get-options
|
||||
"Produce template code to get options for this `property` of this `entity` taken from
|
||||
this `application`."
|
||||
"Produce template code to get options for this `property` of this `entity`
|
||||
taken from this `application`."
|
||||
[property form entity application]
|
||||
(let
|
||||
[type (:type (:attrs property))
|
||||
|
|
@ -258,9 +263,9 @@
|
|||
(:farkey (:attrs property))
|
||||
(first (key-names farside))
|
||||
"id")]
|
||||
;; Yes, I know it looks BONKERS generating this as an HTML string. But there is a
|
||||
;; reason. We don't know whether the `selected` attribute should be present or
|
||||
;; absent until rendering.
|
||||
;; Yes, I know it looks BONKERS generating this as an HTML string. But
|
||||
;; there is a reason. We don't know whether the `selected` attribute
|
||||
;; should be present or absent until rendering.
|
||||
[(str "{% for option in " (-> property :attrs :name)
|
||||
" %}<option value='{{option."
|
||||
farkey
|
||||
|
|
@ -281,7 +286,9 @@
|
|||
(:type (:attrs typedef))
|
||||
(:type (:attrs property)))]
|
||||
(if
|
||||
(and (= (-> property :attrs :distinct) "system") (= (-> property :attrs :immutable) "true"))
|
||||
(and
|
||||
(= (-> property :attrs :distinct) "system")
|
||||
(= (-> property :attrs :immutable) "true"))
|
||||
"hidden"
|
||||
(case t
|
||||
("integer" "real" "money") "number"
|
||||
|
|
@ -298,8 +305,13 @@
|
|||
(defn select-widget
|
||||
[property form entity application]
|
||||
(let [farname (:entity (:attrs property))
|
||||
farside (first (children application #(= (:name (:attrs %)) farname)))
|
||||
magnitude (try (read-string (:magnitude (:attrs farside))) (catch Exception _ 7))
|
||||
farside (first
|
||||
(children
|
||||
application
|
||||
#(= (:name (:attrs %)) farname)))
|
||||
magnitude (try
|
||||
(read-string (:magnitude (:attrs farside)))
|
||||
(catch Exception _ 7))
|
||||
async? (and (number? magnitude) (> magnitude 1))
|
||||
widget-name (safe-name (:name (:attrs property)) :sql)]
|
||||
{:tag :select
|
||||
|
|
@ -309,7 +321,9 @@
|
|||
(if
|
||||
(= (:type (:attrs property)) "link")
|
||||
{:multiple "multiple"}))
|
||||
:content (apply vector (get-options property form entity application))}))
|
||||
:content (apply
|
||||
vector
|
||||
(get-options property form entity application))}))
|
||||
|
||||
|
||||
(defn compose-readable-or-not-authorised
|
||||
|
|
@ -326,7 +340,11 @@
|
|||
:attrs {:id w
|
||||
:name w
|
||||
:class "pseudo-widget not-authorised"}
|
||||
:content [(str "You are not permitted to view " w " of " (:name (:attrs e)))]}
|
||||
:content [(str
|
||||
"You are not permitted to view "
|
||||
w
|
||||
" of "
|
||||
(:name (:attrs e)))]}
|
||||
"{% endifmemberof %}"))
|
||||
|
||||
|
||||
|
|
@ -356,9 +374,46 @@
|
|||
"{% 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
|
||||
"Generate a widget for this `field-or-property` of this `form` for this `entity`
|
||||
taken from within this `application`."
|
||||
"Generate a 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."
|
||||
[field-or-property form entity application]
|
||||
(let
|
||||
[widget-name (safe-name
|
||||
|
|
@ -371,12 +426,8 @@
|
|||
:field (property-for-field field-or-property entity)
|
||||
;; default
|
||||
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))]
|
||||
w-type (widget-type property application typedef)]
|
||||
(if
|
||||
property
|
||||
(case w-type
|
||||
|
|
@ -387,46 +438,33 @@
|
|||
:type "hidden"
|
||||
:value (str "{{record." widget-name "}}")}}
|
||||
"select"
|
||||
(compose-widget-para property form entity application widget-name
|
||||
(select-widget property form entity application))
|
||||
(compose-widget-para
|
||||
property
|
||||
form
|
||||
entity
|
||||
application
|
||||
widget-name
|
||||
(select-widget property form entity application))
|
||||
"text-area"
|
||||
(compose-widget-para
|
||||
property form entity application widget-name
|
||||
{:tag :textarea
|
||||
:attrs {:rows "8" :cols "60" :id widget-name :name widget-name}
|
||||
:content [(str "{{record." widget-name "}}")]})
|
||||
property form entity application widget-name
|
||||
{:tag :textarea
|
||||
:attrs {:rows "8" :cols "60" :id widget-name :name widget-name}
|
||||
:content [(str "{{record." widget-name "}}")]})
|
||||
;; all others
|
||||
(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)))}
|
||||
(if
|
||||
(:minimum (:attrs typedef))
|
||||
{:min (:minimum (:attrs typedef))})
|
||||
(if
|
||||
(:maximum (:attrs typedef))
|
||||
{:max (:maximum (:attrs typedef))}))})))))
|
||||
(compose-input-widget-para
|
||||
property
|
||||
form
|
||||
entity
|
||||
application
|
||||
widget-name)))))
|
||||
|
||||
|
||||
(defn embed-script-fragment
|
||||
"Return the content of the file at `resource-path`, with these `substitutions`
|
||||
made into it in order. Substitutions should be pairss [`pattern` `value`],
|
||||
where `pattern` is a string, a char, or a regular expression."
|
||||
"Return the content of the file at `resource-path`, with these
|
||||
`substitutions` made into it in order. Substitutions should be pairs
|
||||
[`pattern` `value`], where `pattern` is a string, a char, or a regular
|
||||
expression."
|
||||
([resource-path substitutions]
|
||||
(let [v (slurp (resource resource-path))]
|
||||
(reduce
|
||||
|
|
@ -455,8 +493,8 @@
|
|||
|
||||
|
||||
(defn list-tbody
|
||||
"Return a table body element for the list view for this `list-spec` of this `entity` within
|
||||
this `application`, using data from this source."
|
||||
"Return a table body element for the list view for this `list-spec` of
|
||||
this `entity` within this `application`, using data from this source."
|
||||
[source list-spec entity application]
|
||||
{:tag :tbody
|
||||
:content
|
||||
|
|
@ -470,7 +508,12 @@
|
|||
(fn [field]
|
||||
{:tag :td :content
|
||||
(let
|
||||
[p (first (filter #(= (:name (:attrs %)) (:property (:attrs field))) (all-properties entity)))
|
||||
[p (first
|
||||
(filter
|
||||
#(=
|
||||
(:name (:attrs %))
|
||||
(:property (:attrs field)))
|
||||
(all-properties entity)))
|
||||
s (safe-name (:name (:attrs p)) :sql)
|
||||
e (first
|
||||
(filter
|
||||
|
|
@ -480,7 +523,10 @@
|
|||
(if
|
||||
(= (:type (:attrs p)) "entity")
|
||||
[{:tag :a
|
||||
:attrs {:href (edit-link e application (list (:name (:attrs p))))}
|
||||
:attrs {:href (edit-link
|
||||
e
|
||||
application
|
||||
(list (:name (:attrs p))))}
|
||||
:content [(str "{{ record." s "_expanded }}")]}]
|
||||
[c]))})
|
||||
(children-with-tag list-spec :field))
|
||||
|
|
@ -498,11 +544,15 @@
|
|||
(let [property (child-with-tag
|
||||
entity
|
||||
:property
|
||||
#(= (-> % :attrs :name) (-> auxlist :attrs :property)))
|
||||
#(=
|
||||
(-> % :attrs :name)
|
||||
(-> auxlist :attrs :property)))
|
||||
farside (child-with-tag
|
||||
application
|
||||
:entity
|
||||
#(= (-> % :attrs :name)(-> property :attrs :entity)))]
|
||||
#(=
|
||||
(-> % :attrs :name)
|
||||
(-> property :attrs :entity)))]
|
||||
(if
|
||||
(and property farside)
|
||||
{:tag :div
|
||||
|
|
@ -526,7 +576,11 @@
|
|||
:content [(prompt % form entity application)])
|
||||
(children-with-tag auxlist :field))
|
||||
{:tag :th :content [" "]})))}]}
|
||||
(list-tbody (-> property :attrs :name) auxlist farside application)]}]})))
|
||||
(list-tbody
|
||||
(-> property :attrs :name)
|
||||
auxlist
|
||||
farside
|
||||
application)]}]})))
|
||||
|
||||
|
||||
(defn compose-form-auxlists
|
||||
|
|
@ -545,33 +599,40 @@
|
|||
:attrs {:id "content" :class "edit"}
|
||||
:content
|
||||
(apply
|
||||
vector
|
||||
(cons
|
||||
{:tag :form
|
||||
:attrs {:action (str "{{servlet-context}}/" (editor-name entity application))
|
||||
:method "POST"}
|
||||
:content (apply
|
||||
vector
|
||||
(remove
|
||||
nil?
|
||||
(flatten
|
||||
(list
|
||||
(csrf-widget)
|
||||
(map
|
||||
#(widget % form entity application)
|
||||
(children-with-tag (child-with-tag entity :key) :property))
|
||||
(map
|
||||
#(widget % form entity application)
|
||||
(remove
|
||||
#(let
|
||||
[property (filter
|
||||
(fn [p] (= (:name (:attrs p)) (:property (:attrs %))))
|
||||
(descendants-with-tag entity :property))]
|
||||
(= (:distict (:attrs property)) :system))
|
||||
(children-with-tag form :field)))
|
||||
(save-widget form entity application)
|
||||
(delete-widget form entity application)))))}
|
||||
(compose-form-auxlists form entity application)))}})
|
||||
vector
|
||||
(cons
|
||||
{:tag :form
|
||||
:attrs {:action (str
|
||||
"{{servlet-context}}/"
|
||||
(editor-name entity application))
|
||||
:method "POST"}
|
||||
:content (apply
|
||||
vector
|
||||
(remove
|
||||
nil?
|
||||
(flatten
|
||||
(list
|
||||
(csrf-widget)
|
||||
(map
|
||||
#(widget % form entity application)
|
||||
(children-with-tag
|
||||
(child-with-tag entity :key)
|
||||
:property))
|
||||
(map
|
||||
#(widget % form entity application)
|
||||
(remove
|
||||
#(let
|
||||
[property
|
||||
(filter
|
||||
(fn
|
||||
[p]
|
||||
(= (:name (:attrs p)) (:property (:attrs %))))
|
||||
(descendants-with-tag entity :property))]
|
||||
(= (:distict (:attrs property)) :system))
|
||||
(children-with-tag form :field)))
|
||||
(save-widget form entity application)
|
||||
(delete-widget form entity application)))))}
|
||||
(compose-form-auxlists form entity application)))}})
|
||||
|
||||
|
||||
(defn compose-form-extra-head
|
||||
|
|
@ -586,7 +647,9 @@
|
|||
(child-with-tag
|
||||
form
|
||||
:field
|
||||
#(= "text-area" (widget-type (property-for-field % entity) application)))
|
||||
#(=
|
||||
"text-area"
|
||||
(widget-type (property-for-field % entity) application)))
|
||||
"
|
||||
{% script \"/js/lib/node_modules/simplemde/dist/simplemde.min.js\" %}
|
||||
{% style \"/js/lib/node_modules/simplemde/dist/simplemde.min.css\" %}")
|
||||
|
|
@ -594,7 +657,9 @@
|
|||
(child-with-tag
|
||||
form
|
||||
:field
|
||||
#(= "select" (widget-type (property-for-field % entity) application)))
|
||||
#(=
|
||||
"select"
|
||||
(widget-type (property-for-field % entity) application)))
|
||||
"
|
||||
{% script \"/js/lib/node_modules/selectize/dist/js/standalone/selectize.min.js\" %}
|
||||
{% style \"/js/lib/node_modules/selectize/dist/css/selectize.css\" %}"))))})
|
||||
|
|
@ -606,38 +671,54 @@
|
|||
{:tag :script :attrs {:type "text/javascript"}
|
||||
:content
|
||||
(apply
|
||||
vector
|
||||
(remove
|
||||
nil?
|
||||
(flatten
|
||||
(list
|
||||
(map
|
||||
(fn [field]
|
||||
(let
|
||||
[property (child-with-tag entity :property #(=
|
||||
(-> field :attrs :property)
|
||||
(-> % :attrs :name)))
|
||||
farname (:entity (:attrs property))
|
||||
farside (first (children application #(= (:name (:attrs %)) farname)))
|
||||
magnitude (try (read-string (:magnitude (:attrs farside))) (catch Exception _ 7))]
|
||||
(if
|
||||
(> magnitude 2)
|
||||
(embed-script-fragment
|
||||
"js/selectize-one.js"
|
||||
[["{{widget_id}}" (-> property :attrs :name)]
|
||||
["{{widget_value}}" (str "{{record." (-> property :attrs :name) "}}")]
|
||||
["{{entity}}" farname]
|
||||
["{{field}}" (select-field-name farside)]
|
||||
["{{key}}" (first (key-names farside))]]))))
|
||||
(children-with-tag
|
||||
form :field
|
||||
#(= "select" (widget-type (property-for-field % entity) application))))
|
||||
(if
|
||||
(child-with-tag
|
||||
form :field
|
||||
#(= "text-area" (widget-type (property-for-field % entity) application)))
|
||||
(embed-script-fragment "js/text-area-md-support.js"
|
||||
[["{{page}}" (-> form :attrs :name)]]))))))}})
|
||||
vector
|
||||
(remove
|
||||
nil?
|
||||
(flatten
|
||||
(list
|
||||
(map
|
||||
(fn [field]
|
||||
(let
|
||||
[property (child-with-tag
|
||||
entity
|
||||
:property
|
||||
#(=
|
||||
(-> field :attrs :property)
|
||||
(-> % :attrs :name)))
|
||||
farname (:entity (:attrs property))
|
||||
farside (first
|
||||
(children
|
||||
application
|
||||
#(= (:name (:attrs %)) farname)))
|
||||
magnitude (try
|
||||
(read-string
|
||||
(:magnitude
|
||||
(:attrs farside)))
|
||||
(catch Exception _ 7))]
|
||||
(if
|
||||
(> magnitude 2)
|
||||
(embed-script-fragment
|
||||
"js/selectize-one.js"
|
||||
[["{{widget_id}}" (-> property :attrs :name)]
|
||||
["{{widget_value}}"
|
||||
(str "{{record." (-> property :attrs :name) "}}")]
|
||||
["{{entity}}" farname]
|
||||
["{{field}}" (select-field-name farside)]
|
||||
["{{key}}" (first (key-names farside))]]))))
|
||||
(children-with-tag
|
||||
form :field
|
||||
#(=
|
||||
"select"
|
||||
(widget-type (property-for-field % entity) application))))
|
||||
(if
|
||||
(child-with-tag
|
||||
form :field
|
||||
#(=
|
||||
"text-area"
|
||||
(widget-type (property-for-field % entity) application)))
|
||||
(embed-script-fragment
|
||||
"js/text-area-md-support.js"
|
||||
[["{{page}}" (-> form :attrs :name)]]))))))}})
|
||||
|
||||
|
||||
(defn form-to-template
|
||||
|
|
@ -666,7 +747,8 @@
|
|||
(children
|
||||
entity
|
||||
(fn [p] (and (= (:tag p) :property)
|
||||
(= (:name (:attrs p)) (:property (:attrs field)))))))
|
||||
(= (:name (:attrs p))
|
||||
(:property (:attrs field)))))))
|
||||
input-type (case (:type (:attrs property))
|
||||
("integer" "real" "money") "number"
|
||||
("date" "timestamp") "date"
|
||||
|
|
@ -686,8 +768,8 @@
|
|||
|
||||
|
||||
(defn- list-thead
|
||||
"Return a table head element for the list view for this `list-spec` of this `entity` within
|
||||
this `application`."
|
||||
"Return a table head element for the list view for this `list-spec` of
|
||||
this `entity` within this `application`."
|
||||
[list-spec entity application]
|
||||
{:tag :thead
|
||||
:content
|
||||
|
|
@ -734,7 +816,8 @@
|
|||
:content
|
||||
[{:tag :div :attrs {:class "back-link-container"}
|
||||
:content
|
||||
[{:tag :a :attrs {:id "prev-selector" :class "back-link"}
|
||||
[{:tag :a
|
||||
:attrs {:id "prev-selector" :class "back-link"}
|
||||
:content ["Previous"]}]}]}
|
||||
:big-links
|
||||
{:tag :div
|
||||
|
|
@ -747,10 +830,16 @@
|
|||
(list
|
||||
{:tag :div :attrs {:class "big-link-container"}
|
||||
:content
|
||||
[{:tag :a :attrs {:id "next-selector" :role "button" :class "big-link"}
|
||||
[{:tag :a
|
||||
:attrs {:id "next-selector"
|
||||
:role "button"
|
||||
:class "big-link"}
|
||||
:content ["Next"]}]}
|
||||
(wrap-in-if-member-of
|
||||
(big-link (str "Add a new " (pretty-name entity)) (editor-name entity application))
|
||||
(big-link (str
|
||||
"Add a new "
|
||||
(pretty-name entity))
|
||||
(editor-name entity application))
|
||||
:writeable
|
||||
entity
|
||||
application)))))}
|
||||
|
|
@ -761,8 +850,12 @@
|
|||
:method "POST"}
|
||||
:content
|
||||
[(csrf-widget)
|
||||
{:tag :input :attrs {:id "offset" :name "offset" :type "hidden" :value "{{params.offset|default:0}}"}}
|
||||
{:tag :input :attrs {:id "limit" :name "limit" :type "hidden" :value "{{params.limit|default:50}}"}}
|
||||
{:tag :input
|
||||
:attrs {:id "offset" :name "offset" :type "hidden"
|
||||
:value "{{params.offset|default:0}}"}}
|
||||
{:tag :input
|
||||
:attrs {:id "limit" :name "limit" :type "hidden"
|
||||
:value "{{params.limit|default:50}}"}}
|
||||
{:tag :table
|
||||
:attrs {:caption (:name (:attrs entity))}
|
||||
:content
|
||||
|
|
@ -808,30 +901,42 @@
|
|||
lists (children-with-tag entity :list)]
|
||||
(if
|
||||
(and
|
||||
(= (:tag entity) :entity) ;; it seems to be an ADL entity
|
||||
(not (link-table? entity)))
|
||||
(= (:tag entity) :entity) ;; it seems to be an ADL entity
|
||||
(not (link-table? entity)))
|
||||
(merge
|
||||
(if
|
||||
forms
|
||||
(apply merge (map #(assoc {} (keyword (path-part % entity application))
|
||||
(form-to-template % entity application))
|
||||
forms))
|
||||
{(keyword (str "form-" (:name (:attrs entity))))
|
||||
(form-to-template nil entity application)})
|
||||
(if
|
||||
pages
|
||||
(apply merge (map #(assoc {} (keyword (path-part % entity application))
|
||||
(page-to-template % entity application))
|
||||
pages))
|
||||
{(keyword (str "page-" (:name (:attrs entity))))
|
||||
(page-to-template nil entity application)})
|
||||
(if
|
||||
lists
|
||||
(apply merge (map #(assoc {} (keyword (path-part % entity application))
|
||||
(list-to-template % entity application))
|
||||
lists))
|
||||
{(keyword (str "list-" (:name (:attrs entity))))
|
||||
(form-to-template nil entity application)})))))
|
||||
(if
|
||||
forms
|
||||
(apply
|
||||
merge
|
||||
(map #(assoc
|
||||
{}
|
||||
(keyword (path-part % entity application))
|
||||
(form-to-template % entity application))
|
||||
forms))
|
||||
{(keyword (str "form-" (:name (:attrs entity))))
|
||||
(form-to-template nil entity application)})
|
||||
(if
|
||||
pages
|
||||
(apply
|
||||
merge
|
||||
(map #(assoc
|
||||
{}
|
||||
(keyword (path-part % entity application))
|
||||
(page-to-template % entity application))
|
||||
pages))
|
||||
{(keyword (str "page-" (:name (:attrs entity))))
|
||||
(page-to-template nil entity application)})
|
||||
(if
|
||||
lists
|
||||
(apply
|
||||
merge
|
||||
(map #(assoc
|
||||
{}
|
||||
(keyword (path-part % entity application))
|
||||
(list-to-template % entity application))
|
||||
lists))
|
||||
{(keyword (str "list-" (:name (:attrs entity))))
|
||||
(form-to-template nil entity application)})))))
|
||||
|
||||
|
||||
(defn emit-entity-dt
|
||||
|
|
@ -840,7 +945,9 @@
|
|||
{:tag :dt
|
||||
:content
|
||||
[{:tag :a
|
||||
:attrs {:href (str "{{servlet-context}}/" (path-part :list entity application))}
|
||||
:attrs {:href (str
|
||||
"{{servlet-context}}/"
|
||||
(path-part :list entity application))}
|
||||
:content [(pretty-name entity)]}]}
|
||||
:readable
|
||||
entity
|
||||
|
|
@ -895,46 +1002,35 @@
|
|||
|
||||
(defn write-template-file
|
||||
[filename template application]
|
||||
(let [filepath (str *output-path* "resources/templates/auto/" filename)]
|
||||
(let [filepath (str
|
||||
*output-path*
|
||||
"resources/templates/auto/"
|
||||
filename)]
|
||||
(if
|
||||
template
|
||||
(try
|
||||
(do
|
||||
(make-parents filepath)
|
||||
(spit
|
||||
filepath
|
||||
(s/join
|
||||
"\n"
|
||||
(flatten
|
||||
(list
|
||||
(file-header filename application)
|
||||
(doall
|
||||
(map
|
||||
#(let [content (template %)]
|
||||
(list
|
||||
(str "{% block " (name %) " %}")
|
||||
(emit-content content)
|
||||
"{% endblock %}"))
|
||||
(keys template)))
|
||||
(file-footer filename application)))))
|
||||
(if (> *verbosity* 0) (*warn* "\tGenerated " filepath)))
|
||||
(catch Exception any
|
||||
(let [report (str
|
||||
"ERROR: Exception "
|
||||
(.getName (.getClass any))
|
||||
(.getMessage any)
|
||||
" while printing "
|
||||
filepath)]
|
||||
(try
|
||||
(spit
|
||||
filepath
|
||||
(with-out-str
|
||||
(*warn* (str "<!-- " report "-->"))
|
||||
(p/pprint template)))
|
||||
(catch Exception _ nil))
|
||||
(*warn* report)
|
||||
(throw any)))))
|
||||
(str filepath)))
|
||||
(do-or-warn
|
||||
(do
|
||||
(make-parents filepath)
|
||||
(spit
|
||||
filepath
|
||||
(s/join
|
||||
"\n"
|
||||
(flatten
|
||||
(list
|
||||
(file-header filename application)
|
||||
(doall
|
||||
(map
|
||||
#(let [content (template %)]
|
||||
(list
|
||||
(str "{% block " (name %) " %}")
|
||||
(emit-content content)
|
||||
"{% endblock %}"))
|
||||
(keys template)))
|
||||
(file-footer filename application)))))
|
||||
(if
|
||||
(pos? *verbosity*)
|
||||
(*warn* "\tGenerated " filepath))
|
||||
(str filepath))))))
|
||||
|
||||
|
||||
;; (def a (x/parse "../youyesyet/youyesyet.canonical.adl.xml"))
|
||||
|
|
@ -948,7 +1044,8 @@
|
|||
|
||||
|
||||
(defn to-selmer-templates
|
||||
"Generate all [Selmer](https://github.com/yogthos/Selmer) templates implied by this ADL `application` spec."
|
||||
"Generate all [Selmer](https://github.com/yogthos/Selmer) templates implied
|
||||
by this ADL `application` spec."
|
||||
[application]
|
||||
(let
|
||||
[templates-map (reduce
|
||||
|
|
@ -962,17 +1059,11 @@
|
|||
#(if
|
||||
(templates-map %)
|
||||
(let [filename (str (name %) ".html")]
|
||||
(try
|
||||
(write-template-file filename (templates-map %) application)
|
||||
(catch Exception any
|
||||
(*warn*
|
||||
(str
|
||||
"ERROR: Exception "
|
||||
(.getName (.getClass any))
|
||||
" "
|
||||
(.getMessage any)
|
||||
" while writing "
|
||||
filename))))))
|
||||
(do-or-warn
|
||||
(write-template-file
|
||||
filename
|
||||
(templates-map %)
|
||||
application))))
|
||||
(keys templates-map)))))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -19,54 +19,67 @@
|
|||
(= a b)))
|
||||
|
||||
(deftest entity-tests
|
||||
(let [xml {:tag :entity,
|
||||
:attrs {:name "address"},
|
||||
(let [application {:tag :application,
|
||||
:attrs {:version "0.1.1", :name "test-app"},
|
||||
:content
|
||||
[{:tag :key,
|
||||
:attrs nil,
|
||||
[{:tag :entity,
|
||||
:attrs {:name "address"},
|
||||
:content
|
||||
[{:tag :property,
|
||||
:attrs
|
||||
{:immutable "true",
|
||||
:required "true",
|
||||
:distinct "system",
|
||||
:type "integer",
|
||||
:name "id"},
|
||||
[{:tag :key,
|
||||
:attrs nil,
|
||||
: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}
|
||||
{:tag :property,
|
||||
:attrs
|
||||
{:distinct "user", :size "12", :type "string", :name "postcode"},
|
||||
: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,
|
||||
: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,
|
||||
address.postcode,
|
||||
address.id"
|
||||
actual (order-by-clause xml)]
|
||||
actual (order-by-clause entity)]
|
||||
(is (string-equal-ignore-whitespace? actual expected))))
|
||||
(testing "keys name extraction"
|
||||
(let [expected '("id")
|
||||
actual (key-names xml)]
|
||||
(let [expected #{"id"}
|
||||
actual (key-names entity)]
|
||||
(is (string-equal-ignore-whitespace? actual expected))))
|
||||
(testing "primary key test"
|
||||
(let [expected true
|
||||
actual (has-primary-key? xml)]
|
||||
actual (has-primary-key? entity)]
|
||||
(is (string-equal-ignore-whitespace? actual expected))))
|
||||
(testing "non-key properties test"
|
||||
(let [expected true
|
||||
actual (has-non-key-properties? xml)]
|
||||
actual (has-non-key-properties? entity)]
|
||||
(is (string-equal-ignore-whitespace? actual expected))))
|
||||
(testing "insert query generation"
|
||||
(let [expected "-- :name create-addres! :! :n
|
||||
-- :doc creates a new addres record
|
||||
(let [expected "-- :name create-address! :! :n
|
||||
-- :doc creates a new address record
|
||||
INSERT INTO address (street,
|
||||
town,
|
||||
postcode)
|
||||
|
|
@ -74,25 +87,25 @@
|
|||
':town',
|
||||
':postcode')
|
||||
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))))
|
||||
(testing "insert query signature"
|
||||
(let [expected ":! :n"
|
||||
actual (:signature (first (vals (insert-query xml))))]
|
||||
actual (:signature (first (vals (insert-query entity))))]
|
||||
(is (string-equal-ignore-whitespace? actual expected))))
|
||||
(testing "update query generation"
|
||||
(let [expected "-- :name update-addres! :! :n
|
||||
-- :doc updates an existing addres record
|
||||
(let [expected "-- :name update-address! :! :n
|
||||
-- :doc updates an existing address record
|
||||
UPDATE address
|
||||
SET street = :street,
|
||||
town = :town,
|
||||
postcode = :postcode
|
||||
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))))
|
||||
(testing "update query signature"
|
||||
(let [expected ":! :n"
|
||||
actual (:signature (first (vals (update-query xml))))]
|
||||
actual (:signature (first (vals (update-query entity))))]
|
||||
(is (string-equal-ignore-whitespace? actual expected))))
|
||||
(testing "search query generation"
|
||||
(let [expected "-- :name search-strings-addres :? :1
|
||||
|
|
@ -106,22 +119,22 @@
|
|||
address.id
|
||||
--~ (if (:offset params) \"OFFSET :offset \")
|
||||
--~ (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))))
|
||||
(testing "search query signature"
|
||||
(let [expected ":? :1"
|
||||
actual (:signature (first (vals (search-query xml))))]
|
||||
actual (:signature (first (vals (search-query entity))))]
|
||||
(is (string-equal-ignore-whitespace? actual expected))))
|
||||
(testing "select query generation"
|
||||
(let [expected "-- :name get-addres :? :1
|
||||
-- :doc selects an existing addres record
|
||||
SELECT * FROM address
|
||||
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))))
|
||||
(testing "select query signature"
|
||||
(let [expected ":? :1"
|
||||
actual (:signature (first (vals (select-query xml))))]
|
||||
actual (:signature (first (vals (select-query entity))))]
|
||||
(is (string-equal-ignore-whitespace? actual expected))))
|
||||
(testing "list query generation"
|
||||
(let [expected "-- :name list-address :? :*
|
||||
|
|
@ -132,75 +145,79 @@
|
|||
address.id
|
||||
--~ (if (:offset params) \"OFFSET :offset \")
|
||||
--~ (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))))
|
||||
(testing "list query signature"
|
||||
(let [expected ":? :*"
|
||||
actual (:signature (first (vals (list-query xml))))]
|
||||
actual (:signature (first (vals (list-query entity))))]
|
||||
(is (string-equal-ignore-whitespace? actual expected))))
|
||||
(testing "delete query generation"
|
||||
(let [expected "-- :name delete-addres! :! :n
|
||||
-- :doc updates an existing addres record
|
||||
DELETE FROM address
|
||||
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))))
|
||||
(testing "delete query signature"
|
||||
(let [expected ":! :n"
|
||||
actual (:signature (first (vals (delete-query xml))))]
|
||||
actual (:signature (first (vals (delete-query entity))))]
|
||||
(is (string-equal-ignore-whitespace? actual expected))))
|
||||
|
||||
))
|
||||
|
||||
(deftest complex-key-tests
|
||||
(let [xml {:tag :entity,
|
||||
:attrs {:name "address"},
|
||||
(let [application {:tag :application,
|
||||
:attrs {:version "0.1.1", :name "test-app"},
|
||||
:content
|
||||
[{:tag :key,
|
||||
:attrs nil,
|
||||
[{:tag :entity,
|
||||
:attrs {:name "address"},
|
||||
:content
|
||||
[{:tag :property,
|
||||
:attrs
|
||||
{:immutable "true",
|
||||
:required "true",
|
||||
:distinct "system",
|
||||
:type "integer",
|
||||
:name "id"},
|
||||
[{:tag :key,
|
||||
:attrs nil,
|
||||
: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,
|
||||
: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}
|
||||
]}]
|
||||
{: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,
|
||||
address.postcode,
|
||||
address.id"
|
||||
actual (order-by-clause xml)]
|
||||
actual (order-by-clause entity)]
|
||||
(is (string-equal-ignore-whitespace? actual expected))))
|
||||
(testing "keys name extraction"
|
||||
(let [expected '("id" "postcode")
|
||||
actual (key-names xml)]
|
||||
(let [expected #{"id" "postcode"}
|
||||
actual (key-names entity)]
|
||||
(is (string-equal-ignore-whitespace? actual expected))))
|
||||
(testing "insert query generation - compound key, non system generated field in key"
|
||||
(let [expected "-- :name create-addres! :! :n
|
||||
-- :doc creates a new addres record
|
||||
(let [expected "-- :name create-address! :! :n
|
||||
-- :doc creates a new address record
|
||||
INSERT INTO address (street,
|
||||
town,
|
||||
postcode)
|
||||
|
|
@ -209,17 +226,17 @@
|
|||
':postcode')
|
||||
returning id,
|
||||
postcode\n\n"
|
||||
actual (:query (first (vals (insert-query xml))))]
|
||||
actual (:query (first (vals (insert-query entity))))]
|
||||
(is (string-equal-ignore-whitespace? actual expected))))
|
||||
(testing "update query generation - compound key"
|
||||
(let [expected "-- :name update-addres! :! :n
|
||||
-- :doc updates an existing addres record
|
||||
(let [expected "-- :name update-address! :! :n
|
||||
-- :doc updates an existing address record
|
||||
UPDATE address
|
||||
SET street = :street,
|
||||
town = :town
|
||||
WHERE address.id = :id
|
||||
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))))
|
||||
(testing "search query generation - user-distinct field in key"
|
||||
(let [expected "-- :name search-strings-addres :? :1
|
||||
|
|
@ -233,7 +250,7 @@
|
|||
address.id
|
||||
--~ (if (:offset params) \"OFFSET :offset \")
|
||||
--~ (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))))
|
||||
(testing "delete query generation - compound key"
|
||||
(let [expected "-- :name delete-addres! :! :n
|
||||
|
|
@ -241,6 +258,6 @@
|
|||
DELETE FROM address
|
||||
WHERE address.id = :id
|
||||
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))))))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue