Merge remote-tracking branch 'origin/develop' into develop

This commit is contained in:
Simon Brooke 2018-07-04 19:08:06 +01:00
commit 981ff1d5fc
4 changed files with 358 additions and 200 deletions

View file

@ -183,6 +183,10 @@
(str
(safe-name (-> % :attrs :name) :sql)
" = ':" (-> % :attrs :name) "'")
"entity"
(str
(safe-name (-> % :attrs :name) :sql)
"_expanded LIKE '%:" (-> % :attrs :name) "%'")
(str
(safe-name (-> % :attrs :name) :sql)
" = :"

View file

@ -1,14 +1,14 @@
(ns ^{:doc "Application Description Language: generate RING routes for REST requests."
:author "Simon Brooke"}
adl.to-json-routes
(:require [clojure.java.io :refer [file make-parents writer]]
[clojure.pprint :refer [pprint]]
[clojure.string :as s]
[clojure.xml :as x]
(:require [adl-support.utils :refer :all]
[adl.to-hugsql-queries :refer [queries]]
[clj-time.core :as t]
[clj-time.format :as f]
[adl-support.utils :refer :all]
[adl.to-hugsql-queries :refer [queries]]))
[clojure.java.io :refer [file make-parents writer]]
[clojure.pprint :refer [pprint]]
[clojure.string :as s]
[clojure.xml :as x]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
@ -47,8 +47,9 @@
(list
:require
'[adl-support.core :as support]
'[clojure.java.io :as io]
'[clojure.core.memoize :as memo]
'[clojure.java.io :as io]
'[clojure.tools.logging :as log]
'[compojure.core :refer [defroutes GET POST]]
'[hugsql.core :as hugsql]
'[noir.response :as nresponse]

View file

@ -2,12 +2,12 @@
:author "Simon Brooke"}
adl.to-selmer-routes
(:require [adl-support.utils :refer :all]
[clj-time.core :as t]
[clj-time.format :as f]
[clojure.java.io :refer [file make-parents writer]]
[clojure.pprint :refer [pprint]]
[clojure.string :as s]
[clojure.xml :as x]
[clj-time.core :as t]
[clj-time.format :as f]
))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -42,23 +42,128 @@
(defn file-header
[application]
(list
'ns
(symbol (str (:name (:attrs application)) ".routes.auto"))
(str "User interface routes for " (pretty-name application)
" auto-generated by [Application Description Language framework](https://github.com/simon-brooke/adl) at "
(f/unparse (f/formatters :basic-date-time) (t/now)))
'ns
(symbol (str (:name (:attrs application)) ".routes.auto"))
(str "User interface routes for " (pretty-name application)
" auto-generated by [Application Description Language framework](https://github.com/simon-brooke/adl) at "
(f/unparse (f/formatters :basic-date-time) (t/now)))
(list
:require
'[adl-support.core :as support]
'[clojure.java.io :as io]
'[clojure.set :refer [subset?]]
'[clojure.tools.logging :as log]
'[compojure.core :refer [defroutes GET POST]]
'[hugsql.core :as hugsql]
'[noir.response :as nresponse]
'[noir.util.route :as route]
'[ring.util.http-response :as response]
(vector (symbol (str (:name (:attrs application)) ".layout")) :as 'l)
(vector (symbol (str (:name (:attrs application)) ".db.core")) :as 'db)
(vector (symbol (str (:name (:attrs application)) ".routes.manual")) :as 'm))))
(defn make-form-handler-content
[f e a n]
(let [warning (str "Error while fetching " (singularise (:name (:attrs e))) " record")]
;; 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) (set (list 'keys 'p)))
(list
(symbol
(str "db/get-" (singularise (:name (:attrs e)))))
(symbol "db/*db*")
'p))
:message warning
:error-return {:warnings [warning]}))
(reduce
merge
{:warnings (list :warnings 'record)
:record (list 'assoc 'record :warnings nil)}
(map
(fn [p]
(hash-map
(keyword (-> p :attrs :entity))
(list 'support/do-or-log-error
(list (symbol (str "db/list-" (:entity (:attrs p)))) (symbol "db/*db*"))
:message (str "Error while fetching "
(singularise (:entity (:attrs p)))
" record"))))
(filter #(#{"entity" "link"} (:type (:attrs %)))
(descendants-with-tag e :property)))))))
(defn make-page-handler-content
[f e a n]
(let [warning (str "Error while fetching " (singularise (:name (:attrs e))) " record")]
(list 'let
(vector 'record (list
'support/handler-content-log-error
(list 'if (list 'subset? (list 'keys 'p) (key-names e)) []
(list
(symbol
(str "db/get-" (singularise (:name (:attrs e)))))
(symbol "db/*db*")
'p))
:message warning
:error-return {:warnings [warning]}))
{:warnings (list :warnings 'record)
:record (list 'assoc 'record :warnings nil)})))
(defn make-list-handler-content
[f e a n]
(list
'let
(vector
'records
(list
:require
'[adl-support.core :as support]
'[clojure.java.io :as io]
'[compojure.core :refer [defroutes GET POST]]
'[hugsql.core :as hugsql]
'[noir.response :as nresponse]
'[noir.util.route :as route]
'[ring.util.http-response :as response]
(vector (symbol (str (:name (:attrs application)) ".layout")) :as 'l)
(vector (symbol (str (:name (:attrs application)) ".db.core")) :as 'db)
(vector (symbol (str (:name (:attrs application)) ".routes.manual")) :as 'm))))
'if
(list
'some
(set (map #(-> % :attrs :name) (all-properties e)))
(list 'keys 'p))
(list
'support/do-or-log-error
(list
(symbol
(str
"db/search-strings-"
(singularise (:name (:attrs e)))))
(symbol "db/*db*")
'p)
:message (str
"Error while searching "
(singularise (:name (:attrs e)))
" records")
:error-return {:warnings [(str
"Error while searching "
(singularise (:name (:attrs e)))
" records")]})
(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]
@ -122,47 +227,59 @@
(:name (:attrs e))))
(symbol "db/*db*") {}))})))))))
;; (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))
;; (vector
;; 'p
;; (list 'merge
;; {:offset 0 :limit 25}
;; (list 'support/massage-params (list :params 'r))))
;; (make-handler f e a)
(defn make-route
"Make a route for method `m` to request the resource with name `n`."
[m n]
(list
m
(str "/" n)
'request
m
(str "/" n)
'request
(list
'route/restricted
(list
'route/restricted
(list
'apply
(list 'resolve-handler n)
(list 'list 'request)))))
'apply
(list 'resolve-handler n)
(list 'list 'request)))))
(defn make-defroutes
[application]
(let [routes (flatten
(map
(fn [e]
(map
(fn [c]
(path-part c e application))
(filter (fn [c] (#{:form :list :page} (:tag c))) (children e))))
(children-with-tag application :entity)))]
(map
(fn [e]
(map
(fn [c]
(path-part c e application))
(filter (fn [c] (#{:form :list :page} (:tag c))) (children e))))
(children-with-tag application :entity)))]
(cons
'defroutes
'defroutes
(cons
'auto-selmer-routes
(cons
'auto-selmer-routes
(cons
'(GET
"/admin"
request
(route/restricted
(apply (resolve-handler "index") (list request))))
(interleave
(map
(fn [r] (make-route 'GET r))
(sort routes))
(map
(fn [r] (make-route 'POST r))
(sort routes))))))))
'(GET
"/admin"
request
(route/restricted
(apply (resolve-handler "index") (list request))))
(interleave
(map
(fn [r] (make-route 'GET r))
(sort routes))
(map
(fn [r] (make-route 'POST r))
(sort routes))))))))
(defn generate-handler-resolver
@ -171,17 +288,27 @@
were doing could write this more elegantly."
[application]
(list
'defn
'raw-resolve-handler
"Prefer the manually-written version of the handler with name `n`, if it exists, to the automatically generated one"
(vector 'n)
(list 'try
(list 'eval (list 'symbol (list 'str (:name (:attrs application)) ".routes.manual/" 'n)))
(list 'catch
'Exception '_
(list 'eval
(list 'symbol
(list 'str (:name (:attrs application)) ".routes.auto/" 'n)))))))
'defn
'raw-resolve-handler
"Prefer the manually-written version of the handler with name `n`, if it exists, to the automatically generated one"
(vector 'n)
(list 'try
(list 'eval (list 'symbol (list 'str (:name (:attrs application)) ".routes.manual/" 'n)))
(list 'catch
'Exception '_
(list 'eval
(list 'symbol
(list 'str (:name (:attrs application)) ".routes.auto/" 'n)))))))
(defn make-handlers
[e application]
(doall
(map
(fn [c]
(pprint (make-handler c e application))
(println))
(filter (fn [c] (#{:form :list :page} (:tag c))) (children e)))))
(defn to-selmer-routes
@ -196,25 +323,19 @@
(pprint '(defn index
[r]
(l/render
(support/resolve-template
"application-index.html")
(:session r)
{:title "Administrative menu"})))
(support/resolve-template
"application-index.html")
(:session r)
{:title "Administrative menu"})))
(println)
(doall
(map
(fn [e]
(doall
(map
(fn [c]
(pprint (make-handler c e application))
(println))
(filter (fn [c] (#{:form :list :page} (:tag c))) (children e)))))
(sort
#(compare (:name (:attrs %1))(:name (:attrs %2)))
(children-with-tag application :entity))))
(map
#(make-handlers % application)
(sort
#(compare (:name (:attrs %1))(:name (:attrs %2)))
(children-with-tag application :entity))))
(pprint
(generate-handler-resolver application))
(generate-handler-resolver application))
(println)
(pprint '(def resolve-handler
(memoize raw-resolve-handler)))
@ -226,10 +347,10 @@
(catch
Exception any
(println
(str
"ERROR: Exception "
(.getName (.getClass any))
(.getMessage any)
" while printing "
filepath))))))
(str
"ERROR: Exception "
(.getName (.getClass any))
(.getMessage any)
" while printing "
filepath))))))

View file

@ -39,7 +39,7 @@
{:tag :div
:attrs {:class "big-link-container"}
:content
[{:tag :a :attrs {:href url}
[{:tag :a :attrs {:href url :class "big-link"}
:content (if
(vector? content)
content
@ -62,22 +62,24 @@
([filename application k]
(emit-content filename nil nil application k))
([filename spec entity application k]
(let [content (:content
(first
(or (children-with-tag spec k)
(children-with-tag entity k)
(children-with-tag
(first
(children-with-tag application :content))
k))))]
(let [content
(:content
(first
(or (children-with-tag spec k)
(children-with-tag entity k)
(children-with-tag
(child-with-tag application :content)
k))))]
(if
content
(list
(flatten
(list
(str "{% block " (name k) " %}")
(map
(doall
(map
#(with-out-str (x/emit-element %))
content)
"{% endblock %}")))))
content))
"{% endblock %}"))))))
(defn file-header
@ -484,7 +486,7 @@
:content
[{:tag :input
:attrs {:type "submit"
:id "search"
:id "search-widget"
:value "Search"}}]})))}]})
@ -540,51 +542,77 @@
"{% endfor %}"]})
(defn- list-page-control
"What this needs to do is emit an HTML control which, when selected, requests the
next or previous page keeping the same search parameters; so it essentially needs
to be a submit button, not a link."
[forward?]
{:tag :div
:attrs {:class (if forward? "big-link-container" "back-link-container")}
:content
[{:tag :input
:attrs {:id "page"
:name "page"
:disabled (if
forward?
false
"{% ifequal offset 0 %} false {% else %} true {% endifequal %}")
;; TODO: real thought needs to happen on doing i18n for this!
:value (if forward? "Next" "Previous")}}]})
(defn- list-tfoot
"Return a table footer element for the list view for this `list-spec` of this `entity` within
this `application`."
[list-spec entity application]
{:tag :tfoot
:content
[(list-page-control false)
(list-page-control true)]})
(defn list-to-template
"Generate a template as specified by this `list` element for this `entity`,
taken from this `application`. If `list` is nill, generate a default list
template for the entity."
[list-spec entity application]
{:content
{:tag :form
:attrs {:id "content" :class "list"}
:content
[(big-link (str "Add a new " (pretty-name entity)) (editor-name entity application))
{:tag :table
:attrs {:caption (:name (:attrs entity))}
(let [form-name
(str
"list-"
(:name (:attrs entity))
"-"
(:name (:attrs list-spec)))]
{:back-links
{:tag :div
:content
[
{:tag :div :attrs {:class "back-link-container"}
:content
["{% ifequal params.offset \"0\" %}"
{:tag :a
:attrs {:id "back-link" :class "back-link" :href "{{servlet-context}}/admin"}
:content ["Back"]}
"{% else %}"
{:tag :a :attrs {:id "prev-selector" :class "back-link"}
:content ["Previous"]}
"{% endifunequal %}"]}
]}
:big-links
{:tag :div
:content
[{:tag :div :attrs {:class "big-link-container"}
:content
[{:tag :a :attrs {:id "next-selector" :role "button" :class "big-link"}
:content ["Next"]}]}
(big-link (str "Add a new " (pretty-name entity)) (editor-name entity application))]}
:content
[(list-thead list-spec entity application)
(list-tbody list-spec entity application)
(list-tfoot list-spec entity application)]}]}})
{:tag :form
:attrs {:id form-name :class "list"
:action (str "{{servlet-context}}/" form-name)
:method "POST"}
:content
[(csrf-widget)
{:tag :input :attrs {:id "offset" :type "hidden" :value "{{params.offset|default:0}}"}}
{:tag :input :attrs {:id "limit" :type "hidden" :value "{{params.limit|default:50}}"}}
{:tag :table
:attrs {:caption (:name (:attrs entity))}
:content
[(list-thead list-spec entity application)
(list-tbody list-spec entity application)
]}]}
:extra-script
(str "
var form = document.getElementById('" form-name "');
var ow = document.getElementById('offset');
var lw = document.getElementById('limit');
form.addEventListener('submit', function() {
ow.value='0';
});
{% ifunequal params.offset \"0\" %}
document.getElementById('prev-selector').addEventListener('click', function () {
ow.value=(parseInt(ow.value)-parseInt(lw.value));
console.log('Updated offset to ' + ow.value);
form.submit();
});
{% endifunequal %}
document.getElementById('next-selector').addEventListener('click', function () {
ow.value=(parseInt(ow.value)+parseInt(lw.value));
console.log('Updated offset to ' + ow.value);
form.submit();
});")}))
(defn entity-to-templates
@ -628,80 +656,84 @@
(let
[first-class-entities
(sort-by
#(:name (:attrs %))
(filter
#(children-with-tag % :list)
(children-with-tag application :entity)))]
#(:name (:attrs %))
(filter
#(children-with-tag % :list)
(children-with-tag application :entity)))]
{:application-index
{:tag :dl
:attrs {:class "index"}
:content
(apply
{:content
{:tag :dl
:attrs {:class "index"}
:content
(apply
vector
(interleave
(map
#(hash-map
:tag :dt
:content
[{:tag :a
:attrs {:href (path-part :list % application)}
:content [(pretty-name %)]}])
first-class-entities)
(map
#(hash-map
:tag :dd
:content (apply
vector
(map
(fn [d]
(hash-map
:tag :p
:content (:content d)))
(children-with-tag % :documentation))))
first-class-entities)))}}))
(map
#(hash-map
:tag :dt
:content
[{:tag :a
:attrs {:href (path-part :list % application)}
:content [(pretty-name %)]}])
first-class-entities)
(map
#(hash-map
:tag :dd
:content (apply
vector
(map
(fn [d]
(hash-map
:tag :p
:content (:content d)))
(children-with-tag % :documentation))))
first-class-entities)))}}}))
(defn write-template-file
[filename template application]
(let [filepath (str *output-path* "resources/templates/auto/" filename)]
(make-parents filepath)
(if
template
(try
(spit
filepath
(s/join
(do
(spit
filepath
(s/join
"\n"
(flatten
(list
(file-header filename application)
(map
#(cond
(:tag %)
(with-out-str
(x/emit-element %))
(string? %)
%
true
(str ";; WTF? " %))
(:header template))
"{% block content %}"
(with-out-str
(x/emit-element (:content template)))
(file-footer filename application)))))
(if (> *verbosity* 0) (println "\tGenerated " filepath))
(list
(file-header filename application)
(doall
(map
#(let [content (template %)]
(list
(str "{% block " (name %) " %}")
(cond (string? content)
content
(map? content)
(with-out-str
(x/emit-element content))
true
(str "<!-- don't know what to do with '" content "' -->"))
"{% endblock %}"))
(keys template)))
(file-footer filename application)))))
(if (> *verbosity* 0) (println "\tGenerated " filepath)))
(catch Exception any
(let [report (str
"ERROR: Exception "
(.getName (.getClass any))
(.getMessage any)
" while printing "
filename)]
(spit
filepath
(with-out-str
(println (str "<!-- " report "-->"))
(p/pprint template)))
"ERROR: Exception "
(.getName (.getClass any))
(.getMessage any)
" while printing "
filepath)]
(try
(spit
filepath
(with-out-str
(println (str "<!-- " report "-->"))
(p/pprint template)))
(catch Exception _ nil))
(println report)
(throw any)))))
(str filepath)))