From 83f23dd05584ebbebdf10fa09b6f74b72174c2b0 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 4 Jul 2018 19:01:18 +0100 Subject: [PATCH] Work on asynchronous select widget loading. Not working yet, but significant progress. --- .gitignore | 6 + resources/js/select-widget-support.js | 14 ++ src/adl/to_hugsql_queries.clj | 2 +- src/adl/to_json_routes.clj | 23 +- src/adl/to_selmer_routes.clj | 4 +- src/adl/to_selmer_templates.clj | 290 +++++++++++++++----------- 6 files changed, 210 insertions(+), 129 deletions(-) create mode 100644 resources/js/select-widget-support.js diff --git a/.gitignore b/.gitignore index 0c08a8a..7f97479 100644 --- a/.gitignore +++ b/.gitignore @@ -11,3 +11,9 @@ pom.xml.asc .hg/ resources/auto/ + +generated/resources/sql/ + +generated/resources/templates/auto/ + +generated/src/clj/youyesyet/routes/ diff --git a/resources/js/select-widget-support.js b/resources/js/select-widget-support.js new file mode 100644 index 0000000..4d75ab0 --- /dev/null +++ b/resources/js/select-widget-support.js @@ -0,0 +1,14 @@ + /** + * update the select menu with id `wid` from this `data` whose fields include + * this `entity_key` and these `fields` + */ + function updateMenuOptions(wid, entity_key, fields, data){ + $('#' + wid).children().filter(function(){ + return $(this).attr('selected') === undefined; + }).remove().end(); + + $.each(data, function(key, entry){ + $('#' + wid).append( + $('').attr('value', key).text(entry)); + }); + } diff --git a/src/adl/to_hugsql_queries.clj b/src/adl/to_hugsql_queries.clj index 6011417..3bb67e3 100644 --- a/src/adl/to_hugsql_queries.clj +++ b/src/adl/to_hugsql_queries.clj @@ -144,7 +144,7 @@ "Generate an appropriate search query for string fields of this `entity`" (let [entity-name (safe-name (:name (:attrs entity)) :sql) pretty-name (singularise entity-name) - query-name (str "search-strings-" pretty-name) + query-name (str "search-strings-" entity-name) signature ":? :1" properties (remove #(#{"link"}(:type (:attrs %))) (all-properties entity))] (hash-map diff --git a/src/adl/to_json_routes.clj b/src/adl/to_json_routes.clj index 7b192ed..ac7c5e9 100644 --- a/src/adl/to_json_routes.clj +++ b/src/adl/to_json_routes.clj @@ -65,13 +65,20 @@ "Generate and return the function body for the handler for this `query`." [query] (list - [{:keys ['params]}] - (list 'do (list (symbol (str "db/" (:name query))) 'params)) - (case - (:type query) - (:delete-1 :update-1) - '(response/found "/") - nil))) + [{:keys ['params 'form-params]}] + (list 'let + (vector + 'result + (list + (symbol (str "db/" (:name query))) + 'db/*db* + (list 'support/massage-params + 'params 'form-params (key-names (:entity query))))) + (case + (:type query) + (:delete-1 :update-1) + '(response/found "/") + (list 'response/ok 'result))))) (defn generate-handler-src @@ -155,7 +162,7 @@ "`.")) :select-1 (generate-handler-src - handler-name query :post + handler-name query :get (str "select one record from the `" (-> query :entity :attrs :name) "` table. Expects the following key(s) to be present in `params`: `" diff --git a/src/adl/to_selmer_routes.clj b/src/adl/to_selmer_routes.clj index ea6f7ed..411327b 100644 --- a/src/adl/to_selmer_routes.clj +++ b/src/adl/to_selmer_routes.clj @@ -69,7 +69,7 @@ (vector 'r) (list 'let (vector 'p - (list 'support/massage-params (list :params 'r))) + (list 'support/massage-params (list :params 'r) (list :form-params 'r) (key-names e))) ;; 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 @@ -112,7 +112,7 @@ (symbol (str "db/search-strings-" - (singularise (:name (:attrs e))))) + (:name (:attrs e)))) (symbol "db/*db*") 'p) (list diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj index 640af91..f3ea3d2 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 @@ -114,8 +113,7 @@ (flatten (list "{% endblock %}" - (emit-content filename spec entity application :foot) - ))))) + (emit-content filename spec entity application :foot)))))) (defn prompt @@ -191,20 +189,18 @@ #(and (= (:tag %) :entity) (= (:name (:attrs %)) farname)))) - fs-distinct (flatten - (list - (children farside #(#{"user" "all"} (:distinct (:attrs %)))) - (children - (first - (children farside #(= (:tag %) :key))) - #(#{"user" "all"} (:distinct (:attrs %)))))) + fs-distinct (user-distinct-properties farside) farkey (or (:farkey (:attrs property)) - (:name (:attrs (first (children (children farside #(= (:tag %) :key)))))) + (first (key-names farside)) "id")] - [(str "{% for record in " farname " %}{% endfor %}")])) + [(str "{% for r in " farname " %}{% endfor %}")])) (defn widget-type @@ -216,23 +212,30 @@ typedef (:type (:attrs typedef)) (:type (:attrs property)))] - (case t - ("integer" "real" "money") "number" - ("uploadable" "image") "file" - "boolean" "checkbox" - "date" "date" - "time" "time" - "text" ;; default - )))) + (if + (= (-> property :attrs :distinct) "system") + "hidden" ;; <- this is slightly wrong. There are some circumstances in which + ;; system-distinct properties might be user-editable + (case t + ("integer" "real" "money") "number" + ("uploadable" "image") "file" + ("entity" "link") "select" + "boolean" "checkbox" + "date" "date" + "time" "time" + "text" ;; default + ))))) (defn select-widget + ;; TODO: rewrite for selectize https://github.com/selectize/selectize.js/blob/master/docs/usage.md + ;; https://gist.github.com/zabolotnov87/11142887 [property form entity application] (let [farname (:entity (:attrs property)) farside (first (children application #(= (:name (:attrs %)) farname))) magnitude (try (read-string (:magnitude (:attrs farside))) (catch Exception _ 7)) async? (and (number? magnitude) (> magnitude 1)) - widget-name (:name (:attrs property))] + widget-name (safe-name (:name (:attrs property)) :sql)] {:tag :div :attrs {:class "select-box" :farside farname :found (if farside "true" "false")} :content @@ -245,18 +248,25 @@ async? {:tag :input :attrs - {:name (str widget-name "-search-box") - :onchange "/* javascript to repopulate the select widget */"}}) + {:name (str widget-name "_search_box") + :onchange (str "$.getJSON(\"/auto/json/seach-strings-" (-> farside :attrs :name) + "?" + (s/join (str "=\" + " widget-name "_search_box.text + \"&") + (user-distinct-property-names farside)) + (str "=\" + " widget-name "_search_box.text") + ", null, function (data) {updateMenuOptions(\"" + widget-name "\", \"" + (first (key-names farside)) + "\", [\"" + (s/join "\", \"" (user-distinct-property-names farside)) + "\"], data);})")}}) {:tag :select :attrs (merge {:id widget-name :name widget-name} (if (= (:type (:attrs property)) "link") - {:multiple "multiple"}) - (if - async? - {:comment "JavaScript stuff to fix up aynchronous loading"})) + {:multiple "multiple"})) :content (apply vector (get-options property form entity application))})))})) @@ -279,14 +289,41 @@ "%}"))))) +(defn compose-widget-para + [p f e a w content] + {:tag :p + :attrs {:class "widget"} + :content [{:tag :label + :attrs {:for w} + :content [(prompt p f e a)]} + (compose-if-member-of-tag p e a true) + content + "{% else %}" + (compose-if-member-of-tag p e a false) + {:tag :span + :attrs {:id w + :name w + :class "pseudo-widget disabled"} + :content [(str "{{record." w "}}")]} + "{% else %}" + {:tag :span + :attrs {:id w + :name w + :class "pseudo-widget not-authorised"} + :content [(str "You are not permitted to view " w " of " (:name (:attrs e)))]} + "{% endifmemberof %}" + "{% endifmemberof %}"]}) + + (defn widget "Generate a widget for this `field-or-property` of this `form` for this `entity` taken from within this `application`." [field-or-property form entity application] (let - [widget-name (if (= (:tag field-or-property) :property) - (:name (:attrs field-or-property)) - (:property (:attrs field-or-property))) + [widget-name (safe-name + (if (= (:tag field-or-property) :property) + (:name (:attrs field-or-property)) + (:property (:attrs field-or-property))) :sql) property (if (= (:tag field-or-property) :property) field-or-property @@ -296,65 +333,54 @@ (:property (:attrs field-or-property))))) permissions (find-permissions field-or-property property form entity application) typedef (typedef property application) + w-type (widget-type property application typedef) visible-to (visible-to permissions) ;; if the form isn't actually a form, no widget is writable. - writable-by (if (= (:tag form) :form) (writable-by permissions)) - select? (#{"entity" "list" "link"} (:type (:attrs property)))] - (if - (= (:distinct (:attrs property)) "system") + writable-by (if (= (:tag form) :form) (writable-by permissions))] + (case w-type + "hidden" {:tag :input :attrs {:id widget-name :name widget-name :type "hidden" :value (str "{{record." widget-name "}}")}} - {:tag :p - :attrs {:class "widget"} - :content [{:tag :label - :attrs {:for widget-name} - :content [(prompt field-or-property form entity application)]} - (compose-if-member-of-tag property entity application true) - (cond - select? - (select-widget property form entity application) - true - {:tag :input - :attrs (merge - {:id widget-name - :name widget-name - :type (widget-type property application typedef) - :value (str "{{record." widget-name "}}") - :maxlength (:size (:attrs property)) - :size (cond - (nil? (:size (:attrs property))) - "16" - (try - (> (read-string - (:size (:attrs property))) 60) - (catch Exception _ false)) - "60" - true - (:size (:attrs property)))} - (if - (:minimum (:attrs typedef)) - {:min (:minimum (:attrs typedef))}) - (if - (:maximum (:attrs typedef)) - {:max (:maximum (:attrs typedef))}))}) - "{% else %}" - (compose-if-member-of-tag property entity application false) - {:tag :span - :attrs {:id widget-name - :name widget-name - :class "pseudo-widget disabled"} - :content [(str "{{record." widget-name "}}")]} - "{% else %}" - {:tag :span - :attrs {:id widget-name - :name widget-name - :class "pseudo-widget not-authorised"} - :content [(str "You are not permitted to view " widget-name " of " (:name (:attrs entity)))]} - "{% endifmemberof %}" - "{% endifmemberof %}"]}))) + "select" + (compose-widget-para field-or-property form entity application widget-name + (select-widget property form entity application)) + ;; all others + (compose-widget-para + field-or-property form entity application widget-name + {:tag :input + :attrs (merge + {:id widget-name + :name widget-name + :type w-type + :value (str "{{record." widget-name "}}") + :maxlength (:size (:attrs property)) + :size (cond + (nil? (:size (:attrs property))) + "16" + (try + (> (read-string + (:size (:attrs property))) 60) + (catch Exception _ false)) + "60" + true + (:size (:attrs property)))} + (if + (:minimum (:attrs typedef)) + {:min (:minimum (:attrs typedef))}) + (if + (:maximum (:attrs typedef)) + {:max (:maximum (:attrs typedef))}))})))) + + +(defn compose-select-script-header [entity application] + ["{% block extra-head %}" + {:tag :script :attrs {:type "text/javascript"} + :content + [(slurp "resources/js/select-widget-support.js")]} + "{% endblock %}"]) (defn form-to-template @@ -362,29 +388,35 @@ taken from this `application`. If `form` is nill, generate a default form template for the entity." [form entity application] - {: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) - (children-with-tag (child-with-tag entity :key) :properties)) - (map - #(widget % form entity application) - (remove - #(let - [property (filter - (fn [p] (= (:name (:attrs p)) (:property (:attrs %)))) - (descendants-with-tag entity :property))] - (= (:distict (:attrs property)) :system)) - (children-with-tag form :field))) - (save-widget form entity application) - (delete-widget form entity application)))}]}) + (merge + {: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) + (children-with-tag (child-with-tag entity :key) :properties)) + (map + #(widget % form entity application) + (remove + #(let + [property (filter + (fn [p] (= (:name (:attrs p)) (:property (:attrs %)))) + (descendants-with-tag entity :property))] + (= (:distict (:attrs property)) :system)) + (children-with-tag form :field))) + (save-widget form entity application) + (delete-widget form entity application)))}]}} + (if + (some #(= "select" (widget-type % application)) (properties entity)) + {:header (compose-select-script-header entity application)} + {}))) (defn page-to-template @@ -542,7 +574,8 @@ taken from this `application`. If `list` is nill, generate a default list template for the entity." [list-spec entity application] - {:tag :form + {:content + {:tag :form :attrs {:id "content" :class "list"} :content [(big-link (str "Add a new " (pretty-name entity)) (editor-name entity application)) @@ -551,7 +584,7 @@ :content [(list-thead list-spec entity application) (list-tbody list-spec entity application) - (list-tfoot list-spec entity application)]}]}) + (list-tfoot list-spec entity application)]}]}}) (defn entity-to-templates @@ -590,7 +623,6 @@ (form-to-template nil entity application)}))))) - (defn application-to-template [application] (let @@ -629,7 +661,6 @@ first-class-entities)))}})) - (defn write-template-file [filename template application] (let [filepath (str *output-path* "resources/templates/auto/" filename)] @@ -641,11 +672,23 @@ filepath (s/join "\n" - (list - (file-header filename application) - (with-out-str - (x/emit-element template)) - (file-footer filename application)))) + (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)) (catch Exception any (let [report (str @@ -659,10 +702,21 @@ (with-out-str (println (str "")) (p/pprint template))) - (println report))))) + (println report) + (throw any))))) (str filepath))) +;; (def a (x/parse "../youyesyet/youyesyet.canonical.adl.xml")) +;; (def e (child-with-tag a :entity)) +;; (def f (child-with-tag e :form)) +;; (write-template-file "froboz" (form-to-template f e a) a) +;; (def t (form-to-template f e a)) +;; (map type t) +;; t + + + (defn to-selmer-templates "Generate all [Selmer](https://github.com/yogthos/Selmer) templates implied by this ADL `application` spec." [application]