From 16f953741b4ad56d20dec773d890a72ccae1d87d Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 30 Jun 2018 20:05:55 +0100 Subject: [PATCH 1/3] Tactical commit --- src/adl/to_selmer_templates.clj | 202 +++++++++++++++++++------------- 1 file changed, 121 insertions(+), 81 deletions(-) diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj index 17aa062..f0e4ee7 100644 --- a/src/adl/to_selmer_templates.clj +++ b/src/adl/to_selmer_templates.clj @@ -99,8 +99,7 @@ "See [Application Description Language](https://github.com/simon-brooke/adl)." "-->") (emit-content filename spec entity application :head) - (emit-content filename spec entity application :top) - "{% block content %}"))))) + (emit-content filename spec entity application :top)))))) (defn file-footer @@ -110,12 +109,8 @@ (file-footer filename nil nil application)) ([filename spec entity application] (s/join - "\n" - (flatten - (list - "{% endblock %}" - (emit-content filename spec entity application :foot) - ))))) + "\n" + (emit-content filename spec entity application :foot)))) (defn prompt @@ -362,25 +357,26 @@ [keyfields (children ;; there should only be one key; its keys are properties (first (children entity #(= (:tag %) :key))))] - {:tag :div - :attrs {:id "content" :class "edit"} - :content - [{:tag :form - :attrs {:action (str "{{servlet-context}}/" (editor-name entity application)) - :method "POST"} - :content (flatten - (list - (csrf-widget) - (map - #(widget % form entity application) - keyfields) - (map - #(widget % form entity application) - (remove - #(= (:distict (:attrs %)) :system) - (fields entity))) - (save-widget form entity application) - (delete-widget form entity application)))}]})) + {:content + {:tag :div + :attrs {:id "content" :class "edit"} + :content + [{:tag :form + :attrs {:action (str "{{servlet-context}}/" (editor-name entity application)) + :method "POST"} + :content (flatten + (list + (csrf-widget) + (map + #(widget % form entity application) + keyfields) + (map + #(widget % form entity application) + (remove + #(= (:distict (:attrs %)) :system) + (fields entity))) + (save-widget form entity application) + (delete-widget form entity application)))}]}})) @@ -536,16 +532,46 @@ taken from this `application`. If `list` is nill, generate a default list template for the entity." [list-spec entity application] - {: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)))] + {: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 "{{offset|0}}"}} + {:tag :input :attrs {:id "limit" :type "hidden" :value "{{limit|50}}"}} + (big-link (str "Add a new " (pretty-name entity)) (editor-name entity application)) + {:tag :table + :attrs {:caption (:name (:attrs entity))} + :content + [(list-thead list-spec entity application) + (list-tbody list-spec entity application) + (list-tfoot list-spec entity application)]}]} + :extra-script + (str "var form = document.getElementById('" form-name "'); + var ow = document.getElementById('offset'); + var lw = document.getElementById('limit'); + + document.getElementById('next-selector').addEventListener('click', function () { + ow.text=(parseInt(ow.text)+parseInt(lw.text)); + //form.submit(); + });")})) (defn entity-to-templates @@ -589,35 +615,36 @@ [application] (let [first-class-entities (filter - #(children-with-tag % :list) - (children-with-tag application :entity))] - {:application-index - {:tag :dl - :attrs {:class "index"} - :content - (apply + #(children-with-tag % :list) + (children-with-tag application :entity))] + {:content + {:application-index + {: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)))}}})) @@ -627,26 +654,39 @@ template (try (spit - (str *output-path* filename) - (s/join - "\n" - (list - (file-header filename application) - (with-out-str - (x/emit-element template)) - (file-footer filename application)))) + (str *output-path* filename) + (s/join + "\n" + (flatten + (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 "")) + "{% endblock %}") + (keys template)))) + (file-footer filename application))))) (catch Exception any (spit - (str *output-path* filename) - (with-out-str - (println - (str - "")) - (p/pprint template)))))) + (str *output-path* filename) + (with-out-str + (println + (str + "")) + (p/pprint template)))))) filename) From 96c273ee063d737e02f866cb285afab622144201 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 1 Jul 2018 01:36:49 +0100 Subject: [PATCH 2/3] Work on list paging - not complete, but promising --- .gitignore | 4 + src/adl/to_selmer_routes.clj | 6 +- src/adl/to_selmer_templates.clj | 215 ++++++++++++++++---------------- 3 files changed, 114 insertions(+), 111 deletions(-) diff --git a/.gitignore b/.gitignore index 0c08a8a..b7b0702 100644 --- a/.gitignore +++ b/.gitignore @@ -11,3 +11,7 @@ pom.xml.asc .hg/ resources/auto/ + +generated/resources/sql/ + +generated/src/clj/youyesyet/routes/ diff --git a/src/adl/to_selmer_routes.clj b/src/adl/to_selmer_routes.clj index ea6f7ed..5958082 100644 --- a/src/adl/to_selmer_routes.clj +++ b/src/adl/to_selmer_routes.clj @@ -69,7 +69,9 @@ (vector 'r) (list 'let (vector 'p - (list 'support/massage-params (list :params 'r))) + (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 @@ -86,6 +88,8 @@ (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 diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj index a701a74..606c4da 100644 --- a/src/adl/to_selmer_templates.clj +++ b/src/adl/to_selmer_templates.clj @@ -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 @@ -448,7 +450,7 @@ :content [{:tag :input :attrs {:type "submit" - :id "search" + :id "search-widget" :value "Search"}}]})))}]}) @@ -504,35 +506,6 @@ "{% 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 @@ -544,7 +517,22 @@ (:name (:attrs entity)) "-" (:name (:attrs list-spec)))] - {:big-links + {:back-links + {:tag :div + :content + [ + {: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 + :attrs {:id "back-link" :class "back-link" :href "{{servlet-context}}/admin"} + :content ["Back"]} + "{% endifunequal %}"]} + ]} + :big-links {:tag :div :content [{:tag :div :attrs {:class "big-link-container"} @@ -558,25 +546,36 @@ :action (str "{{servlet-context}}/" form-name) :method "POST"} :content - [ - (csrf-widget) - {:tag :input :attrs {:id "offset" :type "hidden" :value "{{offset|0}}"}} - {:tag :input :attrs {:id "limit" :type "hidden" :value "{{limit|50}}"}} - (big-link (str "Add a new " (pretty-name entity)) (editor-name entity application)) + [(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) - (list-tfoot list-spec entity application)]}]} + [(list-thead list-spec entity application) + (list-tbody list-spec entity application) + ]}]} :extra-script - (str "var form = document.getElementById('" form-name "'); + (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 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.text=(parseInt(ow.text)+parseInt(lw.text)); - //form.submit(); + ow.value=(parseInt(ow.value)+parseInt(lw.value)); + console.log('Updated offset to ' + ow.value); + form.submit(); });")})) @@ -621,15 +620,16 @@ (let [first-class-entities (sort-by - #(:name (:attrs %)) - (filter - #(children-with-tag % :list) - (children-with-tag application :entity)))] - {:content - {:tag :dl - :attrs {:class "index"} - :content - (apply + #(:name (:attrs %)) + (filter + #(children-with-tag % :list) + (children-with-tag application :entity)))] + {:application-index + {:content + {:tag :dl + :attrs {:class "index"} + :content + (apply vector (interleave (map @@ -651,60 +651,55 @@ :tag :p :content (:content d))) (children-with-tag % :documentation)))) - first-class-entities)))}})) + first-class-entities)))}}})) (defn write-template-file [filename template application] - (if - template - (try - (spit - (str *output-path* filename) - (s/join - "\n" - (flatten - (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 "")) - "{% endblock %}") - (keys template)))) - (file-footer filename application))))) - (catch Exception any - (spit - filepath - (s/join + (let [filepath (str *output-path* "resources/templates/auto/" filename)] + (if + template + (try + (do + (spit + filepath + (s/join "\n" - (list + (flatten + (list (file-header filename application) - (with-out-str - (x/emit-element template)) - (file-footer filename application)))) - (if (> *verbosity* 0) (println "\tGenerated " filepath)) + (doall + (map + #(let [content (template %)] + (list + (str "{% block " (name %) " %}") + (cond (string? content) + content + (map? content) + (with-out-str + (x/emit-element content)) + true + (str "")) + "{% 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 "")) - (p/pprint template))) - (println report))))) + "ERROR: Exception " + (.getName (.getClass any)) + (.getMessage any) + " while printing " + filepath)] + (try + (spit + filepath + (with-out-str + (println (str "")) + (p/pprint template))) + (catch Exception _ nil)) + (println report) + (throw any))))) (str filepath))) From 40fa2aacb9030a6d803f091a07137116576225e6 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 2 Jul 2018 10:54:57 +0100 Subject: [PATCH 3/3] A lot of UI work. --- src/adl/to_hugsql_queries.clj | 4 + src/adl/to_json_routes.clj | 34 ++- src/adl/to_selmer_routes.clj | 366 +++++++++++++++++++------------- src/adl/to_selmer_templates.clj | 12 +- 4 files changed, 260 insertions(+), 156 deletions(-) diff --git a/src/adl/to_hugsql_queries.clj b/src/adl/to_hugsql_queries.clj index 6011417..6bcaa68 100644 --- a/src/adl/to_hugsql_queries.clj +++ b/src/adl/to_hugsql_queries.clj @@ -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) " = :" diff --git a/src/adl/to_json_routes.clj b/src/adl/to_json_routes.clj index 7b192ed..76e3cfb 100644 --- a/src/adl/to_json_routes.clj +++ b/src/adl/to_json_routes.clj @@ -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) diff --git a/src/adl/to_selmer_routes.clj b/src/adl/to_selmer_routes.clj index 5958082..bcd985c 100644 --- a/src/adl/to_selmer_routes.clj +++ b/src/adl/to_selmer_routes.clj @@ -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)))))) diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj index 606c4da..47ca965 100644 --- a/src/adl/to_selmer_templates.clj +++ b/src/adl/to_selmer_templates.clj @@ -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);