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

Merge branch 'feature/5' into develop

Browse source
This commit is contained in:
Simon Brooke 2018-07-29 01:22:29 +01:00
parent 31848e75ca 7dc3f2dbb8
commit 6ba1ad60c9
8 changed files with 760 additions and 598 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

7
project.clj
View file

@ -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.

5
src/adl/main.clj
View file

@ -92,7 +92,6 @@
(defn process
"Process these parsed `options`."
[options]
(do
(let [p (:path (:options options))
op (if (.endsWith p "/") p (str p "/"))]
(binding [*output-path* op
@ -110,7 +109,7 @@
(s/to-selmer-routes application)
(t/to-selmer-templates application))
(*warn* (str "ERROR: File not found: " %)))
(-> options :arguments)))))))
(:arguments options))))))
(defn -main
@ -121,7 +120,7 @@
(cond
(empty? args)
(usage options)
(not (empty? (:errors options)))
(seq (:errors options))
(do
(doall
(map

27
src/adl/to_hugsql_queries.clj
View file

@ -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,8 +46,7 @@
(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
@ -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,7 +383,8 @@
[application]
(let [filepath (str *output-path* "resources/sql/queries.auto.sql")]
(make-parents filepath)
(try
(do-or-warn
(do
(spit
filepath
(s/join
@ -396,20 +396,11 @@
(str "autogenerated by adl.to-hugsql-queries at " (t/now))
"See [Application Description Language](https://github.com/simon-brooke/adl).")
(map
#(:query %)
: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))))))
(if (pos? *verbosity*)
(*warn* (str "\tGenerated " filepath)))))))

68
src/adl/to_json_routes.clj
View file

@ -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
[{:keys ['params 'form-params]}]
(case
(:type query)
(:delete-1 :update-1)
(list
action
`(log/debug (str ~(:name query) " called with params " ~'params "."))
'(response/found "/"))
['request]
(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))))))
['params '(massage-params request)]
(list
'valid-user-or-forbid
(list
'with-params-or-error
(list
'do-or-server-fail
(list
(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))))))

41
src/adl/to_psql.clj
View file

@ -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))))))

206
src/adl/to_selmer_routes.clj
View file

@ -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,23 +65,17 @@
(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]}))
'get-current-value
(symbol (str "db/get-" entity-name))
'params
entity-name))
(reduce
merge
{:error (list :warnings 'record)
@ -99,28 +93,15 @@
'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")))))))
(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
@ -138,7 +119,7 @@
:record (list 'assoc 'record :warnings nil)})))
(defn make-list-handler-content
(defn make-list-get-handler-content
[f e a n]
(list
'let
@ -190,57 +171,137 @@
{:records 'records})))
(defn make-handler
(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 (path-part 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
(list 'keywordize-keys (list :params 'request))
(list 'keywordize-keys (list :form-params 'request))
(key-names e true)))
(list 'support/massage-params 'request))
(list
'l/render
(list 'support/resolve-template (str n ".html"))
(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-handler-content f e a n)
:page (make-page-handler-content f e a n)
:list (make-list-handler-content f e a n))))))))
: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,16 +355,27 @@
(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
(do-or-warn
(with-open [output (writer filepath)]
(binding [*out* output]
(pprint (file-header application))
@ -319,9 +391,7 @@
(doall
(map
#(make-handlers % application)
(sort
#(compare (:name (:attrs %1))(:name (:attrs %2)))
(children-with-tag application :entity))))
entities))
(pprint
(generate-handler-resolver application))
(println)
@ -330,15 +400,7 @@
(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))))))
(if
(pos? *verbosity*)
(*warn* (str "\tGenerated " filepath))))))

371
src/adl/to_selmer_templates.clj
View file

@ -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,46 +374,14 @@
"{% endif %}")))})
(defn widget
"Generate a widget for this `field-or-property` of this `form` for this `entity`
taken from within this `application`."
[field-or-property form entity application]
(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
[widget-name (safe-name
(if (= (:tag field-or-property) :property)
(:name (:attrs field-or-property))
(:property (:attrs field-or-property))) :sql)
property (case
(:tag field-or-property)
:property field-or-property
: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))]
(if
property
(case w-type
"hidden"
{:tag :input
:attrs {:id widget-name
:name widget-name
:type "hidden"
:value (str "{{record." widget-name "}}")}}
"select"
(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 "}}")]})
;; all others
[typedef (typedef property application)
w-type (widget-type property application typedef)]
(compose-widget-para
property form entity application widget-name
{:tag :input
@ -415,18 +401,70 @@
"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))}))})))))
{: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`, in context of a para also
containing its label."
[field-or-property form entity application]
(let
[widget-name (safe-name
(if (= (:tag field-or-property) :property)
(:name (:attrs field-or-property))
(:property (:attrs field-or-property))) :sql)
property (case
(:tag field-or-property)
:property field-or-property
:field (property-for-field field-or-property entity)
;; default
nil)
typedef (typedef property application)
w-type (widget-type property application typedef)]
(if
property
(case w-type
"hidden"
{:tag :input
:attrs {:id widget-name
:name widget-name
:type "hidden"
:value (str "{{record." widget-name "}}")}}
"select"
(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 "}}")]})
;; all others
(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 ["&nbsp;"]})))}]}
(list-tbody (-> property :attrs :name) auxlist farside application)]}]})))
(list-tbody
(-> property :attrs :name)
auxlist
farside
application)]}]})))
(defn compose-form-auxlists
@ -548,7 +602,9 @@
vector
(cons
{:tag :form
:attrs {:action (str "{{servlet-context}}/" (editor-name entity application))
:attrs {:action (str
"{{servlet-context}}/"
(editor-name entity application))
:method "POST"}
:content (apply
vector
@ -559,13 +615,18 @@
(csrf-widget)
(map
#(widget % form entity application)
(children-with-tag (child-with-tag entity :key) :property))
(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 %))))
[property
(filter
(fn
[p]
(= (:name (:attrs p)) (:property (:attrs %))))
(descendants-with-tag entity :property))]
(= (:distict (:attrs property)) :system))
(children-with-tag form :field)))
@ -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\" %}"))))})
@ -614,29 +679,45 @@
(map
(fn [field]
(let
[property (child-with-tag entity :property #(=
[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))]
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) "}}")]
["{{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))))
#(=
"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"
#(=
"text-area"
(widget-type (property-for-field % entity) application)))
(embed-script-fragment
"js/text-area-md-support.js"
[["{{page}}" (-> form :attrs :name)]]))))))}})
@ -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
@ -813,21 +906,33 @@
(merge
(if
forms
(apply merge (map #(assoc {} (keyword (path-part % entity application))
(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))
(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))
(apply
merge
(map #(assoc
{}
(keyword (path-part % entity application))
(list-to-template % entity application))
lists))
{(keyword (str "list-" (:name (:attrs entity))))
@ -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,10 +1002,13 @@
(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-or-warn
(do
(make-parents filepath)
(spit
@ -917,24 +1027,10 @@
"{% 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)))
(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)))))

309
test/adl/to_hugsql_queries_test.clj
View file

@ -19,141 +19,10 @@
(= 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,
:content
[{:tag :property,
:attrs
{:immutable "true",
:required "true",
:distinct "system",
:type "integer",
:name "id"},
:content
[{:tag :generator, :attrs {:action "native"}, :content nil}]}]}
{:tag :property,
:attrs
{: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}]}]
(testing "user distinct properties should provide the default ordering"
(let [expected
"ORDER BY address.street,
address.postcode,
address.id"
actual (order-by-clause xml)]
(is (string-equal-ignore-whitespace? actual expected))))
(testing "keys name extraction"
(let [expected '("id")
actual (key-names xml)]
(is (string-equal-ignore-whitespace? actual expected))))
(testing "primary key test"
(let [expected true
actual (has-primary-key? xml)]
(is (string-equal-ignore-whitespace? actual expected))))
(testing "non-key properties test"
(let [expected true
actual (has-non-key-properties? xml)]
(is (string-equal-ignore-whitespace? actual expected))))
(testing "insert query generation"
(let [expected "-- :name create-addres! :! :n
-- :doc creates a new addres record
INSERT INTO address (street,
town,
postcode)
VALUES (':street',
':town',
':postcode')
returning id\n\n"
actual (:query (first (vals (insert-query xml))))]
(is (string-equal-ignore-whitespace? actual expected))))
(testing "insert query signature"
(let [expected ":! :n"
actual (:signature (first (vals (insert-query xml))))]
(is (string-equal-ignore-whitespace? actual expected))))
(testing "update query generation"
(let [expected "-- :name update-addres! :! :n
-- :doc updates an existing addres record
UPDATE address
SET street = :street,
town = :town,
postcode = :postcode
WHERE address.id = :id\n\n"
actual (:query (first (vals (update-query xml))))]
(is (string-equal-ignore-whitespace? actual expected))))
(testing "update query signature"
(let [expected ":! :n"
actual (:signature (first (vals (update-query xml))))]
(is (string-equal-ignore-whitespace? actual expected))))
(testing "search query generation"
(let [expected "-- :name search-strings-addres :? :1
-- :doc selects existing address records having any string field matching `:pattern` by substring match
SELECT * FROM address
WHERE street LIKE '%:pattern%'
OR town LIKE '%:pattern%'
OR postcode LIKE '%:pattern%'
ORDER BY address.street,
address.postcode,
address.id
--~ (if (:offset params) \"OFFSET :offset \")
--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")\n\n"
actual (:query (first (vals (search-query xml))))]
(is (string-equal-ignore-whitespace? actual expected))))
(testing "search query signature"
(let [expected ":? :1"
actual (:signature (first (vals (search-query xml))))]
(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))))]
(is (string-equal-ignore-whitespace? actual expected))))
(testing "select query signature"
(let [expected ":? :1"
actual (:signature (first (vals (select-query xml))))]
(is (string-equal-ignore-whitespace? actual expected))))
(testing "list query generation"
(let [expected "-- :name list-address :? :*
-- :doc lists all existing addres records
SELECT * FROM address
ORDER BY address.street,
address.postcode,
address.id
--~ (if (:offset params) \"OFFSET :offset \")
--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")\n\n"
actual (:query (first (vals (list-query xml))))]
(is (string-equal-ignore-whitespace? actual expected))))
(testing "list query signature"
(let [expected ":? :*"
actual (:signature (first (vals (list-query xml))))]
(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))))]
(is (string-equal-ignore-whitespace? actual expected))))
(testing "delete query signature"
(let [expected ":! :n"
actual (:signature (first (vals (delete-query xml))))]
(is (string-equal-ignore-whitespace? actual expected))))
))
(deftest complex-key-tests
(let [xml {:tag :entity,
[{:tag :entity,
:attrs {:name "address"},
:content
[{:tag :key,
@ -187,20 +56,168 @@
{: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 entity)]
(is (string-equal-ignore-whitespace? actual expected))))
(testing "keys name extraction"
(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? entity)]
(is (string-equal-ignore-whitespace? actual expected))))
(testing "non-key properties test"
(let [expected true
actual (has-non-key-properties? entity)]
(is (string-equal-ignore-whitespace? actual expected))))
(testing "insert query generation"
(let [expected "-- :name create-address! :! :n
-- :doc creates a new address record
INSERT INTO address (street,
town,
postcode)
VALUES (':street',
':town',
':postcode')
returning id\n\n"
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 entity))))]
(is (string-equal-ignore-whitespace? actual expected))))
(testing "update query generation"
(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 entity))))]
(is (string-equal-ignore-whitespace? actual expected))))
(testing "update query signature"
(let [expected ":! :n"
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
-- :doc selects existing address records having any string field matching `:pattern` by substring match
SELECT * FROM address
WHERE street LIKE '%:pattern%'
OR town LIKE '%:pattern%'
OR postcode LIKE '%:pattern%'
ORDER BY address.street,
address.postcode,
address.id
--~ (if (:offset params) \"OFFSET :offset \")
--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")\n\n"
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 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 entity))))]
(is (string-equal-ignore-whitespace? actual expected))))
(testing "select query signature"
(let [expected ":? :1"
actual (:signature (first (vals (select-query entity))))]
(is (string-equal-ignore-whitespace? actual expected))))
(testing "list query generation"
(let [expected "-- :name list-address :? :*
-- :doc lists all existing addres records
SELECT * FROM address
ORDER BY address.street,
address.postcode,
address.id
--~ (if (:offset params) \"OFFSET :offset \")
--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")\n\n"
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 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 entity))))]
(is (string-equal-ignore-whitespace? actual expected))))
(testing "delete query signature"
(let [expected ":! :n"
actual (:signature (first (vals (delete-query entity))))]
(is (string-equal-ignore-whitespace? actual expected))))
))
(deftest complex-key-tests
(let [application {:tag :application,
:attrs {:version "0.1.1", :name "test-app"},
:content
[{:tag :entity,
:attrs {:name "address"},
:content
[{:tag :key,
:attrs nil,
:content
[{:tag :property,
:attrs
{:immutable "true",
:required "true",
:distinct "system",
:type "integer",
:name "id"},
:content
[{:tag :generator, :attrs {:action "native"}, :content nil}]}
{:tag :property,
:attrs
{:immutable "true",
:required "true",
:distinct "all",
:generator "assigned"
:type "string",
:size "12"
:name "postcode"},
:content
[{:tag :generator, :attrs {:action "native"}, :content nil}]}
]}
{:tag :property,
:attrs
{:distinct "user", :size "128", :type "string", :name "street"},
:content nil}
{:tag :property,
:attrs {:size "64", :type "string", :name "town"},
:content nil}
]}]}
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))))))