A lot of UI work.
This commit is contained in:
parent
96c273ee06
commit
40fa2aacb9
|
|
@ -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)
|
||||
" = :"
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
|
@ -66,7 +67,24 @@
|
|||
[query]
|
||||
(list
|
||||
[{:keys ['params]}]
|
||||
(list 'do (list (symbol (str "db/" (:name query))) 'params))
|
||||
(list 'do
|
||||
(list
|
||||
'log/debug
|
||||
(list 'str
|
||||
"Calling query '"
|
||||
(:name query)
|
||||
"' with params "
|
||||
(list 'map
|
||||
(list 'fn ['p]
|
||||
;; user-distinct is a reasonable proxy for 'not-too-secret' -
|
||||
;; this will only appear in debug logs.
|
||||
(list 'if
|
||||
(list (user-distinct-property-names (:entity query))
|
||||
(list 'str (list 'name 'p)))
|
||||
(list 'params 'p)
|
||||
"[ELIDED]"))
|
||||
'(keys params))))
|
||||
(list (symbol (str "db/" (:name query))) 'params))
|
||||
(case
|
||||
(:type query)
|
||||
(:delete-1 :update-1)
|
||||
|
|
|
|||
|
|
@ -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,131 +42,209 @@
|
|||
(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]
|
||||
(let [n (path-part f e a)]
|
||||
(list
|
||||
'defn
|
||||
(symbol n)
|
||||
(vector 'r)
|
||||
(list 'let (vector
|
||||
'p
|
||||
(list 'merge
|
||||
{:offset 0 :limit 25}
|
||||
(list 'support/massage-params (list :params 'r))))
|
||||
;; TODO: we must take key params out of just params,
|
||||
;; but we should take all other params out of form-params - because we need the key to
|
||||
;; load the form in the first place, but just accepting values of other params would
|
||||
;; allow spoofing.
|
||||
(list
|
||||
'l/render
|
||||
(list 'support/resolve-template (str n ".html"))
|
||||
'(:session r)
|
||||
(merge
|
||||
{:title (capitalise (:name (:attrs f)))
|
||||
:params 'p}
|
||||
(case (:tag f)
|
||||
(:form :page)
|
||||
(reduce
|
||||
merge
|
||||
{:record
|
||||
;; TODO: this breaks. We need to check for the presence of the
|
||||
;; actual key in the params.
|
||||
(list 'if (list 'empty? (list 'remove 'nil? (list 'vals 'p))) []
|
||||
(list
|
||||
(symbol
|
||||
(str "db/get-" (singularise (:name (:attrs e)))))
|
||||
(symbol "db/*db*")
|
||||
'p))}
|
||||
(map
|
||||
(fn [p]
|
||||
(hash-map
|
||||
(keyword (-> p :attrs :entity))
|
||||
(list (symbol (str "db/list-" (:entity (:attrs p)))) (symbol "db/*db*"))))
|
||||
(filter #(#{"entity" "link"} (:type (:attrs %)))
|
||||
(descendants-with-tag e :property))))
|
||||
:list
|
||||
{:records
|
||||
(list
|
||||
'if
|
||||
(list
|
||||
'not
|
||||
(list
|
||||
'empty?
|
||||
(list 'remove 'nil? (list 'vals 'p))))
|
||||
(list
|
||||
(symbol
|
||||
(str
|
||||
"db/search-strings-"
|
||||
(singularise (:name (:attrs e)))))
|
||||
(symbol "db/*db*")
|
||||
'p)
|
||||
(list
|
||||
(symbol
|
||||
(str
|
||||
"db/list-"
|
||||
(:name (:attrs e))))
|
||||
(symbol "db/*db*") {}))})))))))
|
||||
'defn
|
||||
(symbol n)
|
||||
(vector 'r)
|
||||
(list
|
||||
'let
|
||||
(vector
|
||||
'p
|
||||
(list 'merge
|
||||
{:offset 0 :limit 25}
|
||||
(list 'support/massage-params (list :params 'r) (list :form-params 'r) (key-names e)))
|
||||
'c (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)))
|
||||
(list
|
||||
'l/render
|
||||
(list 'support/resolve-template (str n ".html"))
|
||||
'(:session 'r)
|
||||
(list 'merge
|
||||
{:title (capitalise (:name (:attrs f)))
|
||||
:params 'p}
|
||||
'c))))))
|
||||
|
||||
;; (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
|
||||
|
|
@ -175,17 +253,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
|
||||
|
|
@ -200,25 +288,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)))
|
||||
|
|
@ -230,10 +312,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))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -523,13 +523,13 @@
|
|||
[
|
||||
{:tag :div :attrs {:class "back-link-container"}
|
||||
:content
|
||||
["{% ifunequal offset 0 %}"
|
||||
{:tag :a :attrs {:id "prev-selector" :class "back-link"}
|
||||
:content ["Previous"]}
|
||||
"{% else %}"
|
||||
{:tag :a
|
||||
["{% 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
|
||||
|
|
@ -564,7 +564,7 @@
|
|||
ow.value='0';
|
||||
});
|
||||
|
||||
{% ifunequal offset 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);
|
||||
|
|
|
|||
Loading…
Reference in a new issue