Probably more to do before 1.4.4 release, but stonking progress.
This commit is contained in:
parent
5ec60e524c
commit
7dc3f2dbb8
|
|
@ -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]]
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
|
|
|||
|
|
@ -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]]
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
|
@ -50,8 +48,9 @@
|
|||
(f/unparse (f/formatters :basic-date-time) (t/now)))
|
||||
(list
|
||||
:require
|
||||
'[adl-support.forms-support :refer :all]
|
||||
'[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]
|
||||
|
|
@ -66,56 +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 [entity-name (singularise (:name (:attrs e)))]
|
||||
;; TODO: as yet makes no attempt to save the record
|
||||
(list 'let
|
||||
(vector
|
||||
'record (list
|
||||
'get-current-value
|
||||
(symbol (str "db/get-" entity-name))
|
||||
'params
|
||||
entity-name))
|
||||
'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
|
||||
|
|
@ -129,110 +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 'request))
|
||||
'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
|
||||
|
|
@ -255,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))))))))
|
||||
|
||||
|
||||
|
|
@ -286,43 +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)
|
||||
(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)
|
||||
(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
|
||||
(pos? *verbosity*)
|
||||
(*warn* (str "\tGenerated " filepath))))))
|
||||
(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
|
||||
|
|
@ -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)
|
||||
": "
|
||||
(.getMessage any)
|
||||
" -->"))))
|
||||
(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 %}"))
|
||||
|
||||
|
||||
|
|
@ -393,9 +411,9 @@
|
|||
|
||||
|
||||
(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."
|
||||
"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
|
||||
|
|
@ -407,7 +425,9 @@
|
|||
:property field-or-property
|
||||
:field (property-for-field field-or-property entity)
|
||||
;; default
|
||||
nil)]
|
||||
nil)
|
||||
typedef (typedef property application)
|
||||
w-type (widget-type property application typedef)]
|
||||
(if
|
||||
property
|
||||
(case w-type
|
||||
|
|
@ -418,22 +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-input-widget-para property form entity application widget-name)))))
|
||||
(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
|
||||
|
|
@ -462,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
|
||||
|
|
@ -477,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
|
||||
|
|
@ -487,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))
|
||||
|
|
@ -505,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
|
||||
|
|
@ -533,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
|
||||
|
|
@ -552,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
|
||||
|
|
@ -593,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\" %}")
|
||||
|
|
@ -601,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\" %}"))))})
|
||||
|
|
@ -613,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
|
||||
|
|
@ -673,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"
|
||||
|
|
@ -693,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
|
||||
|
|
@ -741,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
|
||||
|
|
@ -754,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)))))}
|
||||
|
|
@ -768,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
|
||||
|
|
@ -815,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
|
||||
|
|
@ -847,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
|
||||
|
|
@ -902,48 +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
|
||||
(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)))
|
||||
(catch Exception any
|
||||
(let [report (str
|
||||
"ERROR: Exception "
|
||||
(.getName (.getClass any))
|
||||
(.getMessage any)
|
||||
" while printing "
|
||||
filepath)]
|
||||
(do-or-warn
|
||||
(spit
|
||||
filepath
|
||||
(with-out-str
|
||||
(*warn* (str "<!-- " report "-->"))
|
||||
(p/pprint template)))
|
||||
(catch Exception _ nil))
|
||||
(*warn* report)
|
||||
(throw any)))))
|
||||
(str filepath)))
|
||||
(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"))
|
||||
|
|
@ -957,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
|
||||
|
|
@ -972,16 +1060,10 @@
|
|||
(templates-map %)
|
||||
(let [filename (str (name %) ".html")]
|
||||
(do-or-warn
|
||||
(write-template-file filename (templates-map %) application)
|
||||
(catch Exception any
|
||||
(*warn*
|
||||
(str
|
||||
"ERROR: Exception "
|
||||
(.getName (.getClass any))
|
||||
" "
|
||||
(.getMessage any)
|
||||
" while writing "
|
||||
filename))))))
|
||||
(write-template-file
|
||||
filename
|
||||
(templates-map %)
|
||||
application))))
|
||||
(keys templates-map)))))
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue