From 7dc3f2dbb825655c0b0e48d6993906f2d48aca62 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 29 Jul 2018 00:37:18 +0100 Subject: [PATCH] Probably more to do before 1.4.4 release, but stonking progress. --- src/adl/to_hugsql_queries.clj | 2 +- src/adl/to_json_routes.clj | 2 +- src/adl/to_psql.clj | 2 +- src/adl/to_selmer_routes.clj | 394 +++++++++++++++----------- src/adl/to_selmer_templates.clj | 474 +++++++++++++++++++------------- 5 files changed, 517 insertions(+), 357 deletions(-) diff --git a/src/adl/to_hugsql_queries.clj b/src/adl/to_hugsql_queries.clj index 427bcfd..4b07240 100644 --- a/src/adl/to_hugsql_queries.clj +++ b/src/adl/to_hugsql_queries.clj @@ -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]] diff --git a/src/adl/to_json_routes.clj b/src/adl/to_json_routes.clj index 0f872e6..1918abc 100644 --- a/src/adl/to_json_routes.clj +++ b/src/adl/to_json_routes.clj @@ -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] diff --git a/src/adl/to_psql.clj b/src/adl/to_psql.clj index 395b517..898a9ea 100644 --- a/src/adl/to_psql.clj +++ b/src/adl/to_psql.clj @@ -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]] diff --git a/src/adl/to_selmer_routes.clj b/src/adl/to_selmer_routes.clj index bd2e808..8bab130 100644 --- a/src/adl/to_selmer_routes.clj +++ b/src/adl/to_selmer_routes.clj @@ -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)))))) diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj index 8e17824..595adf5 100644 --- a/src/adl/to_selmer_templates.clj +++ b/src/adl/to_selmer_templates.clj @@ -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 "")) - (catch Exception any - (str - "")))) + (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) " %}