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

A lot of UI work.

Browse source
This commit is contained in:
Simon Brooke 2018-07-02 10:54:57 +01:00
parent 96c273ee06
commit 40fa2aacb9
4 changed files with 260 additions and 156 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
src/adl/to_hugsql_queries.clj
View file

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

34
src/adl/to_json_routes.clj
View file

@ -1,14 +1,14 @@
(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 [clojure.java.io :refer [file make-parents writer]] (:require [adl-support.utils :refer :all]
[clojure.pprint :refer [pprint]] [adl.to-hugsql-queries :refer [queries]]
[clojure.string :as s]
[clojure.xml :as x]
[clj-time.core :as t] [clj-time.core :as t]
[clj-time.format :as f] [clj-time.format :as f]
[adl-support.utils :refer :all] [clojure.java.io :refer [file make-parents writer]]
[adl.to-hugsql-queries :refer [queries]])) [clojure.pprint :refer [pprint]]
[clojure.string :as s]
[clojure.xml :as x]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; ;;;;
@ -47,8 +47,9 @@
(list (list
:require :require
'[adl-support.core :as support] '[adl-support.core :as support]
'[clojure.java.io :as io]
'[clojure.core.memoize :as memo] '[clojure.core.memoize :as memo]
'[clojure.java.io :as io]
'[clojure.tools.logging :as log]
'[compojure.core :refer [defroutes GET POST]] '[compojure.core :refer [defroutes GET POST]]
'[hugsql.core :as hugsql] '[hugsql.core :as hugsql]
'[noir.response :as nresponse] '[noir.response :as nresponse]
@ -66,7 +67,24 @@
[query] [query]
(list (list
[{:keys ['params]}] [{: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 (case
(:type query) (:type query)
(:delete-1 :update-1) (:delete-1 :update-1)

366
src/adl/to_selmer_routes.clj
View file

@ -2,12 +2,12 @@
:author "Simon Brooke"} :author "Simon Brooke"}
adl.to-selmer-routes adl.to-selmer-routes
(:require [adl-support.utils :refer :all] (: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.java.io :refer [file make-parents writer]]
[clojure.pprint :refer [pprint]] [clojure.pprint :refer [pprint]]
[clojure.string :as s] [clojure.string :as s]
[clojure.xml :as x] [clojure.xml :as x]
[clj-time.core :as t]
[clj-time.format :as f]
)) ))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -42,131 +42,209 @@
(defn file-header (defn file-header
[application] [application]
(list (list
'ns 'ns
(symbol (str (:name (:attrs application)) ".routes.auto")) (symbol (str (:name (:attrs application)) ".routes.auto"))
(str "User interface routes for " (pretty-name application) (str "User interface routes for " (pretty-name application)
" auto-generated by [Application Description Language framework](https://github.com/simon-brooke/adl) at " " auto-generated by [Application Description Language framework](https://github.com/simon-brooke/adl) at "
(f/unparse (f/formatters :basic-date-time) (t/now))) (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 (list
:require 'if
'[adl-support.core :as support] (list
'[clojure.java.io :as io] 'some
'[compojure.core :refer [defroutes GET POST]] (set (map #(-> % :attrs :name) (all-properties e)))
'[hugsql.core :as hugsql] (list 'keys 'p))
'[noir.response :as nresponse] (list
'[noir.util.route :as route] 'support/do-or-log-error
'[ring.util.http-response :as response] (list
(vector (symbol (str (:name (:attrs application)) ".layout")) :as 'l) (symbol
(vector (symbol (str (:name (:attrs application)) ".db.core")) :as 'db) (str
(vector (symbol (str (:name (:attrs application)) ".routes.manual")) :as 'm)))) "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 (defn make-handler
[f e a] [f e a]
(let [n (path-part f e a)] (let [n (path-part f e a)]
(list (list
'defn 'defn
(symbol n) (symbol n)
(vector 'r) (vector 'r)
(list 'let (vector (list
'p 'let
(list 'merge (vector
{:offset 0 :limit 25} 'p
(list 'support/massage-params (list :params 'r)))) (list 'merge
;; TODO: we must take key params out of just params, {:offset 0 :limit 25}
;; but we should take all other params out of form-params - because we need the key to (list 'support/massage-params (list :params 'r) (list :form-params 'r) (key-names e)))
;; load the form in the first place, but just accepting values of other params would 'c (case (:tag f)
;; allow spoofing. :form (make-form-handler-content f e a n)
(list :page (make-page-handler-content f e a n)
'l/render :list (make-list-handler-content f e a n)))
(list 'support/resolve-template (str n ".html")) (list
'(:session r) 'l/render
(merge (list 'support/resolve-template (str n ".html"))
{:title (capitalise (:name (:attrs f))) '(:session 'r)
:params 'p} (list 'merge
(case (:tag f) {:title (capitalise (:name (:attrs f)))
(:form :page) :params 'p}
(reduce 'c))))))
merge
{:record ;; (def a (x/parse "../youyesyet/youyesyet.canonical.adl.xml"))
;; TODO: this breaks. We need to check for the presence of the ;; (def e (child-with-tag a :entity))
;; actual key in the params. ;; (def f (child-with-tag e :form))
(list 'if (list 'empty? (list 'remove 'nil? (list 'vals 'p))) [] ;; (def n (path-part f e a))
(list ;; (vector
(symbol ;; 'p
(str "db/get-" (singularise (:name (:attrs e))))) ;; (list 'merge
(symbol "db/*db*") ;; {:offset 0 :limit 25}
'p))} ;; (list 'support/massage-params (list :params 'r))))
(map ;; (make-handler f e a)
(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 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 m
(str "/" n) (str "/" n)
'request 'request
(list
'route/restricted
(list (list
'route/restricted 'apply
(list (list 'resolve-handler n)
'apply (list 'list 'request)))))
(list 'resolve-handler n)
(list 'list 'request)))))
(defn make-defroutes (defn make-defroutes
[application] [application]
(let [routes (flatten (let [routes (flatten
(map (map
(fn [e] (fn [e]
(map (map
(fn [c] (fn [c]
(path-part c e application)) (path-part c e application))
(filter (fn [c] (#{:form :list :page} (:tag c))) (children e)))) (filter (fn [c] (#{:form :list :page} (:tag c))) (children e))))
(children-with-tag application :entity)))] (children-with-tag application :entity)))]
(cons (cons
'defroutes 'defroutes
(cons
'auto-selmer-routes
(cons (cons
'auto-selmer-routes '(GET
(cons "/admin"
'(GET request
"/admin" (route/restricted
request (apply (resolve-handler "index") (list request))))
(route/restricted (interleave
(apply (resolve-handler "index") (list request)))) (map
(interleave (fn [r] (make-route 'GET r))
(map (sort routes))
(fn [r] (make-route 'GET r)) (map
(sort routes)) (fn [r] (make-route 'POST r))
(map (sort routes))))))))
(fn [r] (make-route 'POST r))
(sort routes))))))))
(defn generate-handler-resolver (defn generate-handler-resolver
@ -175,17 +253,27 @@
were doing could write this more elegantly." were doing could write this more elegantly."
[application] [application]
(list (list
'defn 'defn
'raw-resolve-handler 'raw-resolve-handler
"Prefer the manually-written version of the handler with name `n`, if it exists, to the automatically generated one" "Prefer the manually-written version of the handler with name `n`, if it exists, to the automatically generated one"
(vector 'n) (vector 'n)
(list 'try (list 'try
(list 'eval (list 'symbol (list 'str (:name (:attrs application)) ".routes.manual/" 'n))) (list 'eval (list 'symbol (list 'str (:name (:attrs application)) ".routes.manual/" 'n)))
(list 'catch (list 'catch
'Exception '_ 'Exception '_
(list 'eval (list 'eval
(list 'symbol (list 'symbol
(list 'str (:name (:attrs application)) ".routes.auto/" 'n))))))) (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 (defn to-selmer-routes
@ -200,25 +288,19 @@
(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
(fn [e] #(make-handlers % application)
(doall (sort
(map #(compare (:name (:attrs %1))(:name (:attrs %2)))
(fn [c] (children-with-tag application :entity))))
(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))))
(pprint (pprint
(generate-handler-resolver application)) (generate-handler-resolver application))
(println) (println)
(pprint '(def resolve-handler (pprint '(def resolve-handler
(memoize raw-resolve-handler))) (memoize raw-resolve-handler)))
@ -230,10 +312,10 @@
(catch (catch
Exception any Exception any
(println (println
(str (str
"ERROR: Exception " "ERROR: Exception "
(.getName (.getClass any)) (.getName (.getClass any))
(.getMessage any) (.getMessage any)
" while printing " " while printing "
filepath)))))) filepath))))))

12
src/adl/to_selmer_templates.clj
View file

@ -523,13 +523,13 @@
[ [
{:tag :div :attrs {:class "back-link-container"} {:tag :div :attrs {:class "back-link-container"}
:content :content
["{% ifunequal offset 0 %}" ["{% ifequal params.offset \"0\" %}"
{:tag :a :attrs {:id "prev-selector" :class "back-link"} {:tag :a
:content ["Previous"]}
"{% else %}"
{:tag :a
:attrs {:id "back-link" :class "back-link" :href "{{servlet-context}}/admin"} :attrs {:id "back-link" :class "back-link" :href "{{servlet-context}}/admin"}
:content ["Back"]} :content ["Back"]}
"{% else %}"
{:tag :a :attrs {:id "prev-selector" :class "back-link"}
:content ["Previous"]}
"{% endifunequal %}"]} "{% endifunequal %}"]}
]} ]}
:big-links :big-links
@ -564,7 +564,7 @@
ow.value='0'; ow.value='0';
}); });
{% ifunequal offset 0 %} {% ifunequal params.offset \"0\" %}
document.getElementById('prev-selector').addEventListener('click', function () { document.getElementById('prev-selector').addEventListener('click', function () {
ow.value=(parseInt(ow.value)-parseInt(lw.value)); ow.value=(parseInt(ow.value)-parseInt(lw.value));
console.log('Updated offset to ' + ow.value); console.log('Updated offset to ' + ow.value);