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

Work on asynchronous select widget loading.

Browse source 
Not working yet, but significant progress.
This commit is contained in:
Simon Brooke 2018-07-04 19:01:18 +01:00
parent a4e0fd1c9a
commit 83f23dd055
6 changed files with 210 additions and 129 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
.gitignore vendored
View file

@ -11,3 +11,9 @@ pom.xml.asc
.hg/ .hg/
resources/auto/ resources/auto/
generated/resources/sql/
generated/resources/templates/auto/
generated/src/clj/youyesyet/routes/

14
resources/js/select-widget-support.js Normal file
View file

@ -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(
$('<option></option>').attr('value', key).text(entry));
});
}

2
src/adl/to_hugsql_queries.clj
View file

@ -144,7 +144,7 @@
"Generate an appropriate search query for string fields of this `entity`" "Generate an appropriate search query for string fields of this `entity`"
(let [entity-name (safe-name (:name (:attrs entity)) :sql) (let [entity-name (safe-name (:name (:attrs entity)) :sql)
pretty-name (singularise entity-name) pretty-name (singularise entity-name)
query-name (str "search-strings-" pretty-name) query-name (str "search-strings-" entity-name)
signature ":? :1" signature ":? :1"
properties (remove #(#{"link"}(:type (:attrs %))) (all-properties entity))] properties (remove #(#{"link"}(:type (:attrs %))) (all-properties entity))]
(hash-map (hash-map

23
src/adl/to_json_routes.clj
View file

@ -65,13 +65,20 @@
"Generate and return the function body for the handler for this `query`." "Generate and return the function body for the handler for this `query`."
[query] [query]
(list (list
[{:keys ['params]}] [{:keys ['params 'form-params]}]
(list 'do (list (symbol (str "db/" (:name query))) 'params)) (list 'let
(case (vector
(:type query) 'result
(:delete-1 :update-1) (list
'(response/found "/") (symbol (str "db/" (:name query)))
nil))) '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 (defn generate-handler-src
@ -155,7 +162,7 @@
"`.")) "`."))
:select-1 :select-1
(generate-handler-src (generate-handler-src
handler-name query :post handler-name query :get
(str "select one record from the `" (str "select one record from the `"
(-> query :entity :attrs :name) (-> query :entity :attrs :name)
"` table. Expects the following key(s) to be present in `params`: `" "` table. Expects the following key(s) to be present in `params`: `"

4
src/adl/to_selmer_routes.clj
View file

@ -69,7 +69,7 @@
(vector 'r) (vector 'r)
(list 'let (vector (list 'let (vector
'p '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, ;; 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 ;; 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 ;; load the form in the first place, but just accepting values of other params would
@ -112,7 +112,7 @@
(symbol (symbol
(str (str
"db/search-strings-" "db/search-strings-"
(singularise (:name (:attrs e))))) (:name (:attrs e))))
(symbol "db/*db*") (symbol "db/*db*")
'p) 'p)
(list (list

290
src/adl/to_selmer_templates.clj
View file

@ -99,8 +99,7 @@
"See [Application Description Language](https://github.com/simon-brooke/adl)." "See [Application Description Language](https://github.com/simon-brooke/adl)."
"-->") "-->")
(emit-content filename spec entity application :head) (emit-content filename spec entity application :head)
(emit-content filename spec entity application :top) (emit-content filename spec entity application :top))))))
"{% block content %}")))))
(defn file-footer (defn file-footer
@ -114,8 +113,7 @@
(flatten (flatten
(list (list
"{% endblock %}" "{% endblock %}"
(emit-content filename spec entity application :foot) (emit-content filename spec entity application :foot))))))
)))))
(defn prompt (defn prompt
@ -191,20 +189,18 @@
#(and #(and
(= (:tag %) :entity) (= (:tag %) :entity)
(= (:name (:attrs %)) farname)))) (= (:name (:attrs %)) farname))))
fs-distinct (flatten fs-distinct (user-distinct-properties farside)
(list
(children farside #(#{"user" "all"} (:distinct (:attrs %))))
(children
(first
(children farside #(= (:tag %) :key)))
#(#{"user" "all"} (:distinct (:attrs %))))))
farkey (or farkey (or
(:farkey (:attrs property)) (:farkey (:attrs property))
(:name (:attrs (first (children (children farside #(= (:tag %) :key)))))) (first (key-names farside))
"id")] "id")]
[(str "{% for record in " farname " %}<option value='{{record." farkey "}}'>" [(str "{% for r in " farname " %}<option value='{{r."
(s/join " " (map #(str "{{record." (:name (:attrs %)) "}}") fs-distinct)) farkey
"</option>{% endfor %}")])) "}}' {% ifequal record."
(-> property :attrs :name)
" r." farkey "%}selected{% endifequal %}>"
(s/join " " (map #(str "{{r." (:name (:attrs %)) "}}") fs-distinct))
"</option>{% endfor %}")]))
(defn widget-type (defn widget-type
@ -216,23 +212,30 @@
typedef typedef
(:type (:attrs typedef)) (:type (:attrs typedef))
(:type (:attrs property)))] (:type (:attrs property)))]
(case t (if
("integer" "real" "money") "number" (= (-> property :attrs :distinct) "system")
("uploadable" "image") "file" "hidden" ;; <- this is slightly wrong. There are some circumstances in which
"boolean" "checkbox" ;; system-distinct properties might be user-editable
"date" "date" (case t
"time" "time" ("integer" "real" "money") "number"
"text" ;; default ("uploadable" "image") "file"
)))) ("entity" "link") "select"
"boolean" "checkbox"
"date" "date"
"time" "time"
"text" ;; default
)))))
(defn select-widget (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] [property form entity application]
(let [farname (:entity (:attrs property)) (let [farname (:entity (:attrs property))
farside (first (children application #(= (:name (:attrs %)) farname))) farside (first (children application #(= (:name (:attrs %)) farname)))
magnitude (try (read-string (:magnitude (:attrs farside))) (catch Exception _ 7)) magnitude (try (read-string (:magnitude (:attrs farside))) (catch Exception _ 7))
async? (and (number? magnitude) (> magnitude 1)) async? (and (number? magnitude) (> magnitude 1))
widget-name (:name (:attrs property))] widget-name (safe-name (:name (:attrs property)) :sql)]
{:tag :div {:tag :div
:attrs {:class "select-box" :farside farname :found (if farside "true" "false")} :attrs {:class "select-box" :farside farname :found (if farside "true" "false")}
:content :content
@ -245,18 +248,25 @@
async? async?
{:tag :input {:tag :input
:attrs :attrs
{:name (str widget-name "-search-box") {:name (str widget-name "_search_box")
:onchange "/* javascript to repopulate the select widget */"}}) :onchange (str "$.getJSON(\"/auto/json/seach-strings-" (-> farside :attrs :name)
"?"
(s/join (str "=\" + " widget-name "_search_box.text + \"&amp;")
(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 {:tag :select
:attrs (merge :attrs (merge
{:id widget-name {:id widget-name
:name widget-name} :name widget-name}
(if (if
(= (:type (:attrs property)) "link") (= (:type (:attrs property)) "link")
{:multiple "multiple"}) {:multiple "multiple"}))
(if
async?
{:comment "JavaScript stuff to fix up aynchronous loading"}))
:content (apply vector (get-options property form entity application))})))})) :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 (defn widget
"Generate a widget for this `field-or-property` of this `form` for this `entity` "Generate a widget for this `field-or-property` of this `form` for this `entity`
taken from within this `application`." taken from within this `application`."
[field-or-property form entity application] [field-or-property form entity application]
(let (let
[widget-name (if (= (:tag field-or-property) :property) [widget-name (safe-name
(:name (:attrs field-or-property)) (if (= (:tag field-or-property) :property)
(:property (:attrs field-or-property))) (:name (:attrs field-or-property))
(:property (:attrs field-or-property))) :sql)
property (if property (if
(= (:tag field-or-property) :property) (= (:tag field-or-property) :property)
field-or-property field-or-property
@ -296,65 +333,54 @@
(:property (:attrs field-or-property))))) (:property (:attrs field-or-property)))))
permissions (find-permissions field-or-property property form entity application) permissions (find-permissions field-or-property property form entity application)
typedef (typedef property application) typedef (typedef property application)
w-type (widget-type property application typedef)
visible-to (visible-to permissions) visible-to (visible-to permissions)
;; if the form isn't actually a form, no widget is writable. ;; if the form isn't actually a form, no widget is writable.
writable-by (if (= (:tag form) :form) (writable-by permissions)) writable-by (if (= (:tag form) :form) (writable-by permissions))]
select? (#{"entity" "list" "link"} (:type (:attrs property)))] (case w-type
(if "hidden"
(= (:distinct (:attrs property)) "system")
{:tag :input {:tag :input
:attrs {:id widget-name :attrs {:id widget-name
:name widget-name :name widget-name
:type "hidden" :type "hidden"
:value (str "{{record." widget-name "}}")}} :value (str "{{record." widget-name "}}")}}
{:tag :p "select"
:attrs {:class "widget"} (compose-widget-para field-or-property form entity application widget-name
:content [{:tag :label (select-widget property form entity application))
:attrs {:for widget-name} ;; all others
:content [(prompt field-or-property form entity application)]} (compose-widget-para
(compose-if-member-of-tag property entity application true) field-or-property form entity application widget-name
(cond {:tag :input
select? :attrs (merge
(select-widget property form entity application) {:id widget-name
true :name widget-name
{:tag :input :type w-type
:attrs (merge :value (str "{{record." widget-name "}}")
{:id widget-name :maxlength (:size (:attrs property))
:name widget-name :size (cond
:type (widget-type property application typedef) (nil? (:size (:attrs property)))
:value (str "{{record." widget-name "}}") "16"
:maxlength (:size (:attrs property)) (try
:size (cond (> (read-string
(nil? (:size (:attrs property))) (:size (:attrs property))) 60)
"16" (catch Exception _ false))
(try "60"
(> (read-string true
(:size (:attrs property))) 60) (:size (:attrs property)))}
(catch Exception _ false)) (if
"60" (:minimum (:attrs typedef))
true {:min (:minimum (:attrs typedef))})
(:size (:attrs property)))} (if
(if (:maximum (:attrs typedef))
(:minimum (:attrs typedef)) {:max (:maximum (:attrs typedef))}))}))))
{:min (:minimum (:attrs typedef))})
(if
(:maximum (:attrs typedef)) (defn compose-select-script-header [entity application]
{:max (:maximum (:attrs typedef))}))}) ["{% block extra-head %}"
"{% else %}" {:tag :script :attrs {:type "text/javascript"}
(compose-if-member-of-tag property entity application false) :content
{:tag :span [(slurp "resources/js/select-widget-support.js")]}
:attrs {:id widget-name "{% endblock %}"])
: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 %}"]})))
(defn form-to-template (defn form-to-template
@ -362,29 +388,35 @@
taken from this `application`. If `form` is nill, generate a default form taken from this `application`. If `form` is nill, generate a default form
template for the entity." template for the entity."
[form entity application] [form entity application]
{:tag :div (merge
:attrs {:id "content" :class "edit"} {:content
:content {:tag :div
[{:tag :form :attrs {:id "content" :class "edit"}
:attrs {:action (str "{{servlet-context}}/" (editor-name entity application)) :content
:method "POST"} [{:tag :form
:content (flatten :attrs {:action (str "{{servlet-context}}/" (editor-name entity application))
(list :method "POST"}
(csrf-widget) :content (flatten
(map (list
#(widget % form entity application) (csrf-widget)
(children-with-tag (child-with-tag entity :key) :properties)) (map
(map #(widget % form entity application)
#(widget % form entity application) (children-with-tag (child-with-tag entity :key) :properties))
(remove (map
#(let #(widget % form entity application)
[property (filter (remove
(fn [p] (= (:name (:attrs p)) (:property (:attrs %)))) #(let
(descendants-with-tag entity :property))] [property (filter
(= (:distict (:attrs property)) :system)) (fn [p] (= (:name (:attrs p)) (:property (:attrs %))))
(children-with-tag form :field))) (descendants-with-tag entity :property))]
(save-widget form entity application) (= (:distict (:attrs property)) :system))
(delete-widget form entity application)))}]}) (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 (defn page-to-template
@ -542,7 +574,8 @@
taken from this `application`. If `list` is nill, generate a default list taken from this `application`. If `list` is nill, generate a default list
template for the entity." template for the entity."
[list-spec entity application] [list-spec entity application]
{:tag :form {:content
{:tag :form
:attrs {:id "content" :class "list"} :attrs {:id "content" :class "list"}
:content :content
[(big-link (str "Add a new " (pretty-name entity)) (editor-name entity application)) [(big-link (str "Add a new " (pretty-name entity)) (editor-name entity application))
@ -551,7 +584,7 @@
:content :content
[(list-thead list-spec entity application) [(list-thead list-spec entity application)
(list-tbody 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 (defn entity-to-templates
@ -590,7 +623,6 @@
(form-to-template nil entity application)}))))) (form-to-template nil entity application)})))))
(defn application-to-template (defn application-to-template
[application] [application]
(let (let
@ -629,7 +661,6 @@
first-class-entities)))}})) first-class-entities)))}}))
(defn write-template-file (defn write-template-file
[filename template application] [filename template application]
(let [filepath (str *output-path* "resources/templates/auto/" filename)] (let [filepath (str *output-path* "resources/templates/auto/" filename)]
@ -641,11 +672,23 @@
filepath filepath
(s/join (s/join
"\n" "\n"
(list (flatten
(file-header filename application) (list
(with-out-str (file-header filename application)
(x/emit-element template)) (map
(file-footer filename application)))) #(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)) (if (> *verbosity* 0) (println "\tGenerated " filepath))
(catch Exception any (catch Exception any
(let [report (str (let [report (str
@ -659,10 +702,21 @@
(with-out-str (with-out-str
(println (str "<!-- " report "-->")) (println (str "<!-- " report "-->"))
(p/pprint template))) (p/pprint template)))
(println report))))) (println report)
(throw any)))))
(str filepath))) (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 (defn to-selmer-templates
"Generate all [Selmer](https://github.com/yogthos/Selmer) templates implied by this ADL `application` spec." "Generate all [Selmer](https://github.com/yogthos/Selmer) templates implied by this ADL `application` spec."
[application] [application]