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

Probably more to do before 1.4.4 release, but stonking progress.

Browse source
This commit is contained in:
Simon Brooke 2018-07-29 00:37:18 +01:00
parent 5ec60e524c
commit 7dc3f2dbb8
5 changed files with 517 additions and 357 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
src/adl/to_hugsql_queries.clj
View file

@ -1,7 +1,7 @@
(ns ^{:doc "Application Description Language - generate HUGSQL queries file." (ns ^{:doc "Application Description Language - generate HUGSQL queries file."
:author "Simon Brooke"} :author "Simon Brooke"}
adl.to-hugsql-queries adl.to-hugsql-queries
(:require [adl-support.core :refer [*warn*]] (:require [adl-support.core :refer :all]
[adl-support.utils :refer :all] [adl-support.utils :refer :all]
[clojure.java.io :refer [file make-parents]] [clojure.java.io :refer [file make-parents]]
[clojure.math.combinatorics :refer [combinations]] [clojure.math.combinatorics :refer [combinations]]

2
src/adl/to_json_routes.clj
View file

@ -1,7 +1,7 @@
(ns ^{:doc "Application Description Language: generate RING routes for REST requests." (ns ^{:doc "Application Description Language: generate RING routes for REST requests."
:author "Simon Brooke"} :author "Simon Brooke"}
adl.to-json-routes adl.to-json-routes
(:require [adl-support.core :refer [*warn*]] (:require [adl-support.core :refer :all]
[adl-support.utils :refer :all] [adl-support.utils :refer :all]
[adl.to-hugsql-queries :refer [queries]] [adl.to-hugsql-queries :refer [queries]]
[clj-time.core :as t] [clj-time.core :as t]

2
src/adl/to_psql.clj
View file

@ -1,7 +1,7 @@
(ns ^{:doc "Application Description Language: generate Postgres database definition." (ns ^{:doc "Application Description Language: generate Postgres database definition."
:author "Simon Brooke"} :author "Simon Brooke"}
adl.to-psql adl.to-psql
(:require [adl-support.core :refer [*warn*]] (:require [adl-support.core :refer :all]
[adl-support.utils :refer :all] [adl-support.utils :refer :all]
[adl.to-hugsql-queries :refer [queries]] [adl.to-hugsql-queries :refer [queries]]
[clojure.java.io :refer [file make-parents writer]] [clojure.java.io :refer [file make-parents writer]]

394
src/adl/to_selmer_routes.clj
View file

@ -1,8 +1,9 @@
(ns ^{:doc "Application Description Language: generate routes for user interface requests." (ns ^{:doc "Application Description Language: generate routes for user interface requests."
:author "Simon Brooke"} :author "Simon Brooke"}
adl.to-selmer-routes adl.to-selmer-routes
(:require [adl-support.core :refer [*warn*]] (:require [adl-support.core :refer :all]
[adl-support.utils :refer :all] [adl-support.utils :refer :all]
[adl-support.forms-support :refer :all]
[clj-time.core :as t] [clj-time.core :as t]
[clj-time.format :as f] [clj-time.format :as f]
[clojure.java.io :refer [file make-parents writer]] [clojure.java.io :refer [file make-parents writer]]
@ -34,11 +35,8 @@
;;;; ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Generally. there's one route in the generated file for each Selmer ;;; Generally. there are two routes - one for GET, one for POST - in the
;;; template which has been generated. ;;; generated file for each Selmer template which has been generated.
;;; TODO: there must be some more idiomatic way of generating all these
;;; functions.
(defn file-header (defn file-header
[application] [application]
@ -50,8 +48,9 @@
(f/unparse (f/formatters :basic-date-time) (t/now))) (f/unparse (f/formatters :basic-date-time) (t/now)))
(list (list
:require :require
'[adl-support.forms-support :refer :all]
'[adl-support.core :as support] '[adl-support.core :as support]
'[adl-support.forms-support :refer :all]
'[adl-support.rest-support :refer :all]
'[clojure.java.io :as io] '[clojure.java.io :as io]
'[clojure.set :refer [subset?]] '[clojure.set :refer [subset?]]
'[clojure.tools.logging :as log] '[clojure.tools.logging :as log]
@ -66,56 +65,43 @@
(vector (symbol (str (:name (:attrs application)) ".routes.manual")) :as 'm)))) (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] [f e a n]
(let [entity-name (singularise (:name (:attrs e)))] (let [entity-name (singularise (:name (:attrs e)))]
;; TODO: as yet makes no attempt to save the record ;; TODO: as yet makes no attempt to save the record
(list 'let (list 'let
(vector (vector
'record (list 'record (list
'get-current-value 'get-current-value
(symbol (str "db/get-" entity-name)) (symbol (str "db/get-" entity-name))
'params 'params
entity-name)) entity-name))
(reduce (reduce
merge merge
{:error (list :warnings 'record) {:error (list :warnings 'record)
:record (list 'dissoc 'record :warnings)} :record (list 'dissoc 'record :warnings)}
(map (map
(fn [property] (fn [property]
(hash-map (hash-map
(keyword (-> property :attrs :name)) (keyword (-> property :attrs :name))
(list (list
'flatten 'flatten
(list (list
'remove 'remove
'nil? 'nil?
(list (list
'list 'list
;; Get the current value of the property, if it's an entity ;; Get the current value of the property, if it's an entity
(if (= (-> property :attrs :type) "entity") (if (= (-> property :attrs :type) "entity")
(list 'support/do-or-log-error (list 'get-menu-options
(list (-> e :attrs :name)
(symbol (-> property :attrs :farkey)
(str "db/get-" (singularise (:entity (:attrs property))))) (list (keyword (-> property :attrs :name)) 'params))))))))
(symbol "db/*db*") (filter #(:entity (:attrs %))
(hash-map (keyword (-> property :attrs :farkey)) (descendants-with-tag e :property)))))))
(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)))))))
(defn make-page-handler-content (defn make-page-get-handler-content
[f e a n] [f e a n]
(let [warning (str "Error while fetching " (singularise (:name (:attrs e))) " record")] (let [warning (str "Error while fetching " (singularise (:name (:attrs e))) " record")]
(list 'let (list 'let
@ -129,110 +115,193 @@
'params)) 'params))
:message warning :message warning
:error-return {:warnings [warning]})) :error-return {:warnings [warning]}))
{:warnings (list :warnings 'record) {:warnings (list :warnings 'record)
:record (list 'assoc 'record :warnings nil)}))) :record (list 'assoc 'record :warnings nil)})))
(defn make-list-handler-content (defn make-list-get-handler-content
[f e a n] [f e a n]
(list (list
'let 'let
(vector (vector
'records '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)]
(list (list
'defn 'if
(symbol n) (list
(vector 'request) 'some
(list 'let (vector (set (map #(keyword (-> % :attrs :name)) (all-properties e)))
'params (list 'keys 'params))
(list 'support/massage-params 'request)) (list 'do
(list (symbol "log/debug") (list (symbol (str "db/search-strings-" (:name (:attrs e)) "-sqlvec")) 'params))
(list
'support/do-or-log-error
(list (list
'l/render (symbol (str "db/search-strings-" (:name (:attrs e))))
(list 'support/resolve-template (str n ".html")) (symbol "db/*db*")
(list 'merge 'params)
{:title (capitalise (:name (:attrs f))) :message (str
:params 'params} "Error while searching "
(case (:tag f) (singularise (:name (:attrs e)))
:form (make-form-handler-content f e a n) " records")
:page (make-page-handler-content f e a n) :error-return {:warnings [(str
:list (make-list-handler-content f e a n)))))))) "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 a (x/parse "../youyesyet/youyesyet.canonical.adl.xml"))
;; (def e (child-with-tag a :entity)) ;; (def e (child-with-tag a :entity))
;; (def f (child-with-tag e :form)) ;; (def f (child-with-tag e :form))
;; (def n (path-part f e a)) ;; (def n (handler-name f e a :post))
;; (make-handler f e a) ;; (make-post-handler f e a)
;; (vector ;; (vector
;; 'p ;; 'p
;; (list 'merge ;; (list 'merge
;; {:offset 0 :limit 25} ;; {:offset 0 :limit 25}
;; (list 'support/massage-params (list :params 'r)))) ;; (list 'support/massage-params (list :params 'r))))
;; (make-handler f e a) ;; (make-get-handler f e a)
(defn make-route (defn make-route
"Make a route for method `m` to request the resource with name `n`." "Make a route for method `m` to request the resource with name `n`."
[m n] [m n]
(list (list
m (symbol (s/upper-case (name m)))
(str "/" n) (str "/" n)
'request 'request
(list (list
'route/restricted 'route/restricted
(list (list
'apply 'apply
(list 'resolve-handler n) (list 'resolve-handler (str (s/lower-case (name m)) "-" n))
(list 'list 'request))))) (list 'list 'request)))))
(defn make-defroutes (defn make-defroutes
[application] [application]
(let [routes (flatten (let [routes (flatten
@ -255,10 +324,10 @@
(apply (resolve-handler "index") (list request)))) (apply (resolve-handler "index") (list request))))
(interleave (interleave
(map (map
(fn [r] (make-route 'GET r)) (fn [r] (make-route :get r))
(sort routes)) (sort routes))
(map (map
(fn [r] (make-route 'POST r)) (fn [r] (make-route :post r))
(sort routes)))))))) (sort routes))))))))
@ -286,43 +355,52 @@
(doall (doall
(map (map
(fn [c] (fn [c]
(pprint (make-handler c e application)) ;; do all get handlers before post handlers, so that the post
(println)) ;; 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))))) (filter (fn [c] (#{:form :list :page} (:tag c))) (children e)))))
(defn to-selmer-routes (defn to-selmer-routes
[application] [application]
(let [filepath (str *output-path* "src/clj/" (:name (:attrs application)) "/routes/auto.clj")] (let [filepath (str
*output-path*
"src/clj/"
(:name (:attrs application))
"/routes/auto.clj")
entities (sort
#(compare (:name (:attrs %1))(:name (:attrs %2)))
(children-with-tag application :entity))]
(make-parents filepath) (make-parents filepath)
(do-or-warn (do-or-warn
(with-open [output (writer filepath)] (with-open [output (writer filepath)]
(binding [*out* output] (binding [*out* output]
(pprint (file-header application)) (pprint (file-header application))
(println) (println)
(pprint '(defn index (pprint '(defn index
[r] [r]
(l/render (l/render
(support/resolve-template (support/resolve-template
"application-index.html") "application-index.html")
(:session r) (:session r)
{:title "Administrative menu"}))) {:title "Administrative menu"})))
(println) (println)
(doall (doall
(map (map
#(make-handlers % application) #(make-handlers % application)
(sort entities))
#(compare (:name (:attrs %1))(:name (:attrs %2))) (pprint
(children-with-tag application :entity)))) (generate-handler-resolver application))
(pprint (println)
(generate-handler-resolver application)) (pprint '(def resolve-handler
(println) (memoize raw-resolve-handler)))
(pprint '(def resolve-handler (println)
(memoize raw-resolve-handler))) (pprint (make-defroutes application))
(println) (println)))
(pprint (make-defroutes application)) (if
(println))) (pos? *verbosity*)
(if (*warn* (str "\tGenerated " filepath))))))
(pos? *verbosity*)
(*warn* (str "\tGenerated " filepath))))))

474
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"} :author "Simon Brooke"}
adl.to-selmer-templates adl.to-selmer-templates
(:require [adl-support.core :refer [*warn*]] (:require [adl-support.core :refer :all]
[adl.to-hugsql-queries :refer [expanded-token]] [adl.to-hugsql-queries :refer [expanded-token]]
[adl-support.utils :refer :all] [adl-support.utils :refer :all]
[clojure.java.io :refer [file make-parents resource]] [clojure.java.io :refer [file make-parents resource]]
@ -41,7 +42,9 @@
{:tag :div {:tag :div
:attrs {:class "big-link-container"} :attrs {:class "big-link-container"}
:content :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 :content (if
(vector? content) (vector? content)
content content
@ -75,15 +78,7 @@
(map emit-content (remove nil? content)) (map emit-content (remove nil? content))
true true
(str "<!-- don't know what to do with '" content "' -->")) (str "<!-- don't know what to do with '" content "' -->"))
(catch Exception any (str "Failed while writing " content)))
(str
"<!-- failed while trying to emit \n'"
(with-out-str (p/pprint content))
"';\n"
(-> any .getClass .getName)
": "
(.getMessage any)
" -->"))))
([filename application k] ([filename application k]
(emit-content filename nil nil application k)) (emit-content filename nil nil application k))
([filename spec entity application k] ([filename spec entity application k]
@ -143,7 +138,8 @@
(defn csrf-widget (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 %}") "{% csrf-field %}")
@ -179,16 +175,20 @@
(defn save-widget (defn save-widget
"Return an appropriate 'save' widget for this `form` operating on this `entity` taken "Return an appropriate 'save' widget for this `form` operating on this
from this `application`. `entity` taken from this `application`.
TODO: should be suppressed unless a member of a group which can insert or edit." TODO: should be suppressed unless a member of a group which can insert
or edit."
[form entity application] [form entity application]
(wrap-in-if-member-of (wrap-in-if-member-of
{:tag :p {:tag :p
:attrs {:class "widget action-safe"} :attrs {:class "widget action-safe"}
:content [{:tag :label :content [{:tag :label
:attrs {:for "save-button" :class "action-safe"} :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 {:tag :input
:attrs {:id "save-button" :attrs {:id "save-button"
:name "save-button" :name "save-button"
@ -201,16 +201,20 @@
(defn delete-widget (defn delete-widget
"Return an appropriate 'save' widget for this `form` operating on this `entity` taken "Return an appropriate 'save' widget for this `form` operating on this
from this `application`. `entity` taken from this `application`.
TODO: should be suppressed unless member of a group which can delete." TODO: should be suppressed unless member of a group which can delete."
[form entity application] [form entity application]
(wrap-in-if-member-of (wrap-in-if-member-of
{:tag :p {:tag :p
:attrs {:class "widget action-dangerous"} :attrs {:class "widget action-dangerous"}
:content [{:tag :label :content [{:tag :label
:attrs {:for "delete-button" :class "action-dangerous"} :attrs {:for "delete-button"
:content [(str "To delete this " (:name (:attrs entity)) " record")]} :class "action-dangerous"}
:content [(str
"To delete this "
(:name (:attrs entity))
" record")]}
{:tag :input {:tag :input
:attrs {:id "delete-button" :attrs {:id "delete-button"
:name "delete-button" :name "delete-button"
@ -223,7 +227,8 @@
(defn select-property (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] [entity]
(descendant-with-tag (descendant-with-tag
entity entity
@ -241,8 +246,8 @@
(defn get-options (defn get-options
"Produce template code to get options for this `property` of this `entity` taken from "Produce template code to get options for this `property` of this `entity`
this `application`." taken from this `application`."
[property form entity application] [property form entity application]
(let (let
[type (:type (:attrs property)) [type (:type (:attrs property))
@ -258,9 +263,9 @@
(:farkey (:attrs property)) (:farkey (:attrs property))
(first (key-names farside)) (first (key-names farside))
"id")] "id")]
;; Yes, I know it looks BONKERS generating this as an HTML string. But there is a ;; Yes, I know it looks BONKERS generating this as an HTML string. But
;; reason. We don't know whether the `selected` attribute should be present or ;; there is a reason. We don't know whether the `selected` attribute
;; absent until rendering. ;; should be present or absent until rendering.
[(str "{% for option in " (-> property :attrs :name) [(str "{% for option in " (-> property :attrs :name)
" %}<option value='{{option." " %}<option value='{{option."
farkey farkey
@ -281,7 +286,9 @@
(:type (:attrs typedef)) (:type (:attrs typedef))
(:type (:attrs property)))] (:type (:attrs property)))]
(if (if
(and (= (-> property :attrs :distinct) "system") (= (-> property :attrs :immutable) "true")) (and
(= (-> property :attrs :distinct) "system")
(= (-> property :attrs :immutable) "true"))
"hidden" "hidden"
(case t (case t
("integer" "real" "money") "number" ("integer" "real" "money") "number"
@ -298,8 +305,13 @@
(defn select-widget (defn select-widget
[property form entity application] [property form entity application]
(let [farname (:entity (:attrs property)) (let [farname (:entity (:attrs property))
farside (first (children application #(= (:name (:attrs %)) farname))) farside (first
magnitude (try (read-string (:magnitude (:attrs farside))) (catch Exception _ 7)) (children
application
#(= (:name (:attrs %)) farname)))
magnitude (try
(read-string (:magnitude (:attrs farside)))
(catch Exception _ 7))
async? (and (number? magnitude) (> magnitude 1)) async? (and (number? magnitude) (> magnitude 1))
widget-name (safe-name (:name (:attrs property)) :sql)] widget-name (safe-name (:name (:attrs property)) :sql)]
{:tag :select {:tag :select
@ -309,7 +321,9 @@
(if (if
(= (:type (:attrs property)) "link") (= (:type (:attrs property)) "link")
{:multiple "multiple"})) {: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 (defn compose-readable-or-not-authorised
@ -326,7 +340,11 @@
:attrs {:id w :attrs {:id w
:name w :name w
:class "pseudo-widget not-authorised"} :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 %}")) "{% endifmemberof %}"))
@ -393,9 +411,9 @@
(defn widget (defn widget
"Generate a widget for this `field-or-property` of this `form` for this `entity` "Generate a widget for this `field-or-property` of this `form` for this
taken from within this `application`, in context of a para also containing its `entity` taken from within this `application`, in context of a para also
label." containing its label."
[field-or-property form entity application] [field-or-property form entity application]
(let (let
[widget-name (safe-name [widget-name (safe-name
@ -407,7 +425,9 @@
:property field-or-property :property field-or-property
:field (property-for-field field-or-property entity) :field (property-for-field field-or-property entity)
;; default ;; default
nil)] nil)
typedef (typedef property application)
w-type (widget-type property application typedef)]
(if (if
property property
(case w-type (case w-type
@ -418,22 +438,33 @@
:type "hidden" :type "hidden"
:value (str "{{record." widget-name "}}")}} :value (str "{{record." widget-name "}}")}}
"select" "select"
(compose-widget-para property form entity application widget-name (compose-widget-para
(select-widget property form entity application)) property
form
entity
application
widget-name
(select-widget property form entity application))
"text-area" "text-area"
(compose-widget-para (compose-widget-para
property form entity application widget-name property form entity application widget-name
{:tag :textarea {:tag :textarea
:attrs {:rows "8" :cols "60" :id widget-name :name widget-name} :attrs {:rows "8" :cols "60" :id widget-name :name widget-name}
:content [(str "{{record." widget-name "}}")]}) :content [(str "{{record." widget-name "}}")]})
;; all others ;; all others
(compose-input-widget-para property form entity application widget-name))))) (compose-input-widget-para
property
form
entity
application
widget-name)))))
(defn embed-script-fragment (defn embed-script-fragment
"Return the content of the file at `resource-path`, with these `substitutions` "Return the content of the file at `resource-path`, with these
made into it in order. Substitutions should be pairss [`pattern` `value`], `substitutions` made into it in order. Substitutions should be pairs
where `pattern` is a string, a char, or a regular expression." [`pattern` `value`], where `pattern` is a string, a char, or a regular
expression."
([resource-path substitutions] ([resource-path substitutions]
(let [v (slurp (resource resource-path))] (let [v (slurp (resource resource-path))]
(reduce (reduce
@ -462,8 +493,8 @@
(defn list-tbody (defn list-tbody
"Return a table body element for the list view for this `list-spec` of this `entity` within "Return a table body element for the list view for this `list-spec` of
this `application`, using data from this source." this `entity` within this `application`, using data from this source."
[source list-spec entity application] [source list-spec entity application]
{:tag :tbody {:tag :tbody
:content :content
@ -477,7 +508,12 @@
(fn [field] (fn [field]
{:tag :td :content {:tag :td :content
(let (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) s (safe-name (:name (:attrs p)) :sql)
e (first e (first
(filter (filter
@ -487,7 +523,10 @@
(if (if
(= (:type (:attrs p)) "entity") (= (:type (:attrs p)) "entity")
[{:tag :a [{: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 }}")]}] :content [(str "{{ record." s "_expanded }}")]}]
[c]))}) [c]))})
(children-with-tag list-spec :field)) (children-with-tag list-spec :field))
@ -505,11 +544,15 @@
(let [property (child-with-tag (let [property (child-with-tag
entity entity
:property :property
#(= (-> % :attrs :name) (-> auxlist :attrs :property))) #(=
(-> % :attrs :name)
(-> auxlist :attrs :property)))
farside (child-with-tag farside (child-with-tag
application application
:entity :entity
#(= (-> % :attrs :name)(-> property :attrs :entity)))] #(=
(-> % :attrs :name)
(-> property :attrs :entity)))]
(if (if
(and property farside) (and property farside)
{:tag :div {:tag :div
@ -533,7 +576,11 @@
:content [(prompt % form entity application)]) :content [(prompt % form entity application)])
(children-with-tag auxlist :field)) (children-with-tag auxlist :field))
{:tag :th :content ["&nbsp;"]})))}]} {:tag :th :content ["&nbsp;"]})))}]}
(list-tbody (-> property :attrs :name) auxlist farside application)]}]}))) (list-tbody
(-> property :attrs :name)
auxlist
farside
application)]}]})))
(defn compose-form-auxlists (defn compose-form-auxlists
@ -552,33 +599,40 @@
:attrs {:id "content" :class "edit"} :attrs {:id "content" :class "edit"}
:content :content
(apply (apply
vector vector
(cons (cons
{:tag :form {:tag :form
:attrs {:action (str "{{servlet-context}}/" (editor-name entity application)) :attrs {:action (str
:method "POST"} "{{servlet-context}}/"
:content (apply (editor-name entity application))
vector :method "POST"}
(remove :content (apply
nil? vector
(flatten (remove
(list nil?
(csrf-widget) (flatten
(map (list
#(widget % form entity application) (csrf-widget)
(children-with-tag (child-with-tag entity :key) :property)) (map
(map #(widget % form entity application)
#(widget % form entity application) (children-with-tag
(remove (child-with-tag entity :key)
#(let :property))
[property (filter (map
(fn [p] (= (:name (:attrs p)) (:property (:attrs %)))) #(widget % form entity application)
(descendants-with-tag entity :property))] (remove
(= (:distict (:attrs property)) :system)) #(let
(children-with-tag form :field))) [property
(save-widget form entity application) (filter
(delete-widget form entity application)))))} (fn
(compose-form-auxlists form entity application)))}}) [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 (defn compose-form-extra-head
@ -593,7 +647,9 @@
(child-with-tag (child-with-tag
form form
:field :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\" %} {% script \"/js/lib/node_modules/simplemde/dist/simplemde.min.js\" %}
{% style \"/js/lib/node_modules/simplemde/dist/simplemde.min.css\" %}") {% style \"/js/lib/node_modules/simplemde/dist/simplemde.min.css\" %}")
@ -601,7 +657,9 @@
(child-with-tag (child-with-tag
form form
:field :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\" %} {% script \"/js/lib/node_modules/selectize/dist/js/standalone/selectize.min.js\" %}
{% style \"/js/lib/node_modules/selectize/dist/css/selectize.css\" %}"))))}) {% style \"/js/lib/node_modules/selectize/dist/css/selectize.css\" %}"))))})
@ -613,38 +671,54 @@
{:tag :script :attrs {:type "text/javascript"} {:tag :script :attrs {:type "text/javascript"}
:content :content
(apply (apply
vector vector
(remove (remove
nil? nil?
(flatten (flatten
(list (list
(map (map
(fn [field] (fn [field]
(let (let
[property (child-with-tag entity :property #(= [property (child-with-tag
(-> field :attrs :property) entity
(-> % :attrs :name))) :property
farname (:entity (:attrs property)) #(=
farside (first (children application #(= (:name (:attrs %)) farname))) (-> field :attrs :property)
magnitude (try (read-string (:magnitude (:attrs farside))) (catch Exception _ 7))] (-> % :attrs :name)))
(if farname (:entity (:attrs property))
(> magnitude 2) farside (first
(embed-script-fragment (children
"js/selectize-one.js" application
[["{{widget_id}}" (-> property :attrs :name)] #(= (:name (:attrs %)) farname)))
["{{widget_value}}" (str "{{record." (-> property :attrs :name) "}}")] magnitude (try
["{{entity}}" farname] (read-string
["{{field}}" (select-field-name farside)] (:magnitude
["{{key}}" (first (key-names farside))]])))) (:attrs farside)))
(children-with-tag (catch Exception _ 7))]
form :field (if
#(= "select" (widget-type (property-for-field % entity) application)))) (> magnitude 2)
(if (embed-script-fragment
(child-with-tag "js/selectize-one.js"
form :field [["{{widget_id}}" (-> property :attrs :name)]
#(= "text-area" (widget-type (property-for-field % entity) application))) ["{{widget_value}}"
(embed-script-fragment "js/text-area-md-support.js" (str "{{record." (-> property :attrs :name) "}}")]
[["{{page}}" (-> form :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 (defn form-to-template
@ -673,7 +747,8 @@
(children (children
entity entity
(fn [p] (and (= (:tag p) :property) (fn [p] (and (= (:tag p) :property)
(= (:name (:attrs p)) (:property (:attrs field))))))) (= (:name (:attrs p))
(:property (:attrs field)))))))
input-type (case (:type (:attrs property)) input-type (case (:type (:attrs property))
("integer" "real" "money") "number" ("integer" "real" "money") "number"
("date" "timestamp") "date" ("date" "timestamp") "date"
@ -693,8 +768,8 @@
(defn- list-thead (defn- list-thead
"Return a table head element for the list view for this `list-spec` of this `entity` within "Return a table head element for the list view for this `list-spec` of
this `application`." this `entity` within this `application`."
[list-spec entity application] [list-spec entity application]
{:tag :thead {:tag :thead
:content :content
@ -741,7 +816,8 @@
:content :content
[{:tag :div :attrs {:class "back-link-container"} [{:tag :div :attrs {:class "back-link-container"}
:content :content
[{:tag :a :attrs {:id "prev-selector" :class "back-link"} [{:tag :a
:attrs {:id "prev-selector" :class "back-link"}
:content ["Previous"]}]}]} :content ["Previous"]}]}]}
:big-links :big-links
{:tag :div {:tag :div
@ -754,10 +830,16 @@
(list (list
{:tag :div :attrs {:class "big-link-container"} {:tag :div :attrs {:class "big-link-container"}
:content :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"]}]} :content ["Next"]}]}
(wrap-in-if-member-of (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 :writeable
entity entity
application)))))} application)))))}
@ -768,8 +850,12 @@
:method "POST"} :method "POST"}
:content :content
[(csrf-widget) [(csrf-widget)
{:tag :input :attrs {:id "offset" :name "offset" :type "hidden" :value "{{params.offset|default:0}}"}} {:tag :input
{:tag :input :attrs {:id "limit" :name "limit" :type "hidden" :value "{{params.limit|default:50}}"}} :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 {:tag :table
:attrs {:caption (:name (:attrs entity))} :attrs {:caption (:name (:attrs entity))}
:content :content
@ -815,30 +901,42 @@
lists (children-with-tag entity :list)] lists (children-with-tag entity :list)]
(if (if
(and (and
(= (:tag entity) :entity) ;; it seems to be an ADL entity (= (:tag entity) :entity) ;; it seems to be an ADL entity
(not (link-table? entity))) (not (link-table? entity)))
(merge (merge
(if (if
forms forms
(apply merge (map #(assoc {} (keyword (path-part % entity application)) (apply
(form-to-template % entity application)) merge
forms)) (map #(assoc
{(keyword (str "form-" (:name (:attrs entity)))) {}
(form-to-template nil entity application)}) (keyword (path-part % entity application))
(if (form-to-template % entity application))
pages forms))
(apply merge (map #(assoc {} (keyword (path-part % entity application)) {(keyword (str "form-" (:name (:attrs entity))))
(page-to-template % entity application)) (form-to-template nil entity application)})
pages)) (if
{(keyword (str "page-" (:name (:attrs entity)))) pages
(page-to-template nil entity application)}) (apply
(if merge
lists (map #(assoc
(apply merge (map #(assoc {} (keyword (path-part % entity application)) {}
(list-to-template % entity application)) (keyword (path-part % entity application))
lists)) (page-to-template % entity application))
{(keyword (str "list-" (:name (:attrs entity)))) pages))
(form-to-template nil entity application)}))))) {(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 (defn emit-entity-dt
@ -847,7 +945,9 @@
{:tag :dt {:tag :dt
:content :content
[{:tag :a [{: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)]}]} :content [(pretty-name entity)]}]}
:readable :readable
entity entity
@ -902,48 +1002,35 @@
(defn write-template-file (defn write-template-file
[filename template application] [filename template application]
(let [filepath (str *output-path* "resources/templates/auto/" filename)] (let [filepath (str
*output-path*
"resources/templates/auto/"
filename)]
(if (if
template template
(do-or-warn (do-or-warn
(do (do
(make-parents filepath) (make-parents filepath)
(spit (spit
filepath filepath
(s/join (s/join
"\n" "\n"
(flatten (flatten
(list (list
(file-header filename application) (file-header filename application)
(doall (doall
(map (map
#(let [content (template %)] #(let [content (template %)]
(list (list
(str "{% block " (name %) " %}") (str "{% block " (name %) " %}")
(emit-content content) (emit-content content)
"{% endblock %}")) "{% endblock %}"))
(keys template))) (keys template)))
(file-footer filename application))))) (file-footer filename application)))))
(if (if
(pos? *verbosity*) (pos? *verbosity*)
(*warn* "\tGenerated " filepath))) (*warn* "\tGenerated " filepath))
(catch Exception any (str filepath))))))
(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)))
;; (def a (x/parse "../youyesyet/youyesyet.canonical.adl.xml")) ;; (def a (x/parse "../youyesyet/youyesyet.canonical.adl.xml"))
@ -957,7 +1044,8 @@
(defn to-selmer-templates (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] [application]
(let (let
[templates-map (reduce [templates-map (reduce
@ -972,16 +1060,10 @@
(templates-map %) (templates-map %)
(let [filename (str (name %) ".html")] (let [filename (str (name %) ".html")]
(do-or-warn (do-or-warn
(write-template-file filename (templates-map %) application) (write-template-file
(catch Exception any filename
(*warn* (templates-map %)
(str application))))
"ERROR: Exception "
(.getName (.getClass any))
" "
(.getMessage any)
" while writing "
filename))))))
(keys templates-map))))) (keys templates-map)))))