Merge branch 'feature/3' into develop
This commit is contained in:
commit
c1d1bf59e8
|
|
@ -44,14 +44,16 @@
|
|||
(where-clause entity (key-properties entity)))
|
||||
([entity properties]
|
||||
(let
|
||||
[entity-name (:name (:attrs entity))
|
||||
[entity-name (safe-name entity :sql)
|
||||
property-names (map #(:name (:attrs %)) properties)]
|
||||
(if-not (empty? property-names)
|
||||
(str
|
||||
"WHERE "
|
||||
(s/join
|
||||
"\n\tAND"
|
||||
(map #(str entity-name "." % " = :" %) property-names)))))))
|
||||
(map
|
||||
#(str entity-name "." (safe-name % :sql) " = :" %)
|
||||
property-names)))))))
|
||||
|
||||
|
||||
(defn order-by-clause
|
||||
|
|
@ -62,7 +64,7 @@
|
|||
(order-by-clause entity prefix false))
|
||||
([entity prefix expanded?]
|
||||
(let
|
||||
[entity-name (safe-name (:name (:attrs entity)) :sql)
|
||||
[entity-name (safe-name entity :sql)
|
||||
preferred (filter #(#{"user" "all"} (-> % :attrs :distinct))
|
||||
(children entity #(= (:tag %) :property)))]
|
||||
(if
|
||||
|
|
@ -89,10 +91,10 @@
|
|||
TODO: this depends on the idea that system-unique properties
|
||||
are not insertable, which is... dodgy."
|
||||
[entity]
|
||||
(let [entity-name (safe-name (:name (:attrs entity)) :sql)
|
||||
(let [entity-name (safe-name entity :sql)
|
||||
pretty-name (singularise entity-name)
|
||||
insertable-property-names (map
|
||||
#(safe-name (:name (:attrs %)) :sql)
|
||||
#(safe-name % :sql)
|
||||
(insertable-properties entity))
|
||||
query-name (str "create-" pretty-name "!")
|
||||
signature (if (has-primary-key? entity)
|
||||
|
|
@ -126,9 +128,11 @@
|
|||
(defn update-query
|
||||
"Generate an appropriate `update` query for this `entity`"
|
||||
[entity]
|
||||
(let [entity-name (safe-name (:name (:attrs entity)) :sql)
|
||||
(let [entity-name (safe-name entity :sql)
|
||||
pretty-name (singularise entity-name)
|
||||
property-names (map #(:name (:attrs %)) (insertable-properties entity))
|
||||
property-names (map
|
||||
#(-> % :attrs :name)
|
||||
(insertable-properties entity))
|
||||
query-name (str "update-" pretty-name "!")
|
||||
signature ":! :n"]
|
||||
(hash-map
|
||||
|
|
@ -142,18 +146,22 @@
|
|||
"-- :doc updates an existing " pretty-name " record\n"
|
||||
"UPDATE " entity-name "\n"
|
||||
"SET "
|
||||
(s/join ",\n\t" (map #(str (safe-name % :sql) " = " (keyword %)) property-names))
|
||||
(s/join
|
||||
",\n\t"
|
||||
(map
|
||||
#(str (safe-name % :sql) " = " (keyword %))
|
||||
property-names))
|
||||
"\n"
|
||||
(where-clause entity))})))
|
||||
|
||||
|
||||
(defn search-query [entity application]
|
||||
"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 entity :sql)
|
||||
pretty-name (singularise entity-name)
|
||||
query-name (str "search-strings-" entity-name)
|
||||
signature ":? :*"
|
||||
properties (remove #(#{"link"}(:type (:attrs %))) (all-properties entity))]
|
||||
properties (remove #(#{"(safe-name entity :sql)"}(:type (:attrs %))) (all-properties entity))]
|
||||
(hash-map
|
||||
(keyword query-name)
|
||||
{:name query-name
|
||||
|
|
@ -180,7 +188,7 @@
|
|||
string?
|
||||
(map
|
||||
#(let
|
||||
[sn (safe-name (-> % :attrs :name) :sql)]
|
||||
[sn (safe-name % :sql)]
|
||||
(str
|
||||
"(if (:" (-> % :attrs :name) " params) (str \"AND "
|
||||
(case (-> % :attrs :type)
|
||||
|
|
@ -214,7 +222,7 @@
|
|||
([entity properties]
|
||||
(if-not
|
||||
(empty? properties)
|
||||
(let [entity-name (safe-name (:name (:attrs entity)) :sql)
|
||||
(let [entity-name (safe-name entity :sql)
|
||||
pretty-name (singularise entity-name)
|
||||
query-name (if (= properties (key-properties entity))
|
||||
(str "get-" pretty-name)
|
||||
|
|
@ -254,7 +262,7 @@
|
|||
Parameters `:limit` and `:offset` may be supplied. If not present limit defaults
|
||||
to 100 and offset to 0."
|
||||
[entity]
|
||||
(let [entity-name (safe-name (:name (:attrs entity)) :sql)
|
||||
(let [entity-name (safe-name entity :sql)
|
||||
pretty-name (singularise entity-name)
|
||||
query-name (str "list-" entity-name)
|
||||
signature ":? :*"]
|
||||
|
|
@ -282,7 +290,8 @@
|
|||
[entity application]
|
||||
(let [entity-name (:name (:attrs entity))
|
||||
pretty-name (singularise entity-name)
|
||||
links (filter #(#{"link" "entity"} (:type (:attrs %))) (children-with-tag entity :property))]
|
||||
entity-safe (safe-name entity :sql)
|
||||
links (filter #(#{"list" "link" "entity"} (:type (:attrs %))) (children-with-tag entity :property))]
|
||||
(apply
|
||||
merge
|
||||
(map
|
||||
|
|
@ -295,10 +304,11 @@
|
|||
(= (:tag x) :entity)
|
||||
(= (:name (:attrs x)) far-name)))))
|
||||
pretty-far (singularise far-name)
|
||||
safe-far (safe-name far-entity :sql)
|
||||
farkey (-> % :attrs :farkey)
|
||||
link-type (-> % :attrs :type)
|
||||
link-field (-> % :attrs :name)
|
||||
query-name (str "list-" entity-name "-by-" pretty-far)
|
||||
query-name (list-related-query-name % entity far-entity)
|
||||
signature ":? :*"]
|
||||
(hash-map
|
||||
(keyword query-name)
|
||||
|
|
@ -315,23 +325,27 @@
|
|||
(case link-type
|
||||
"entity" (list
|
||||
(str "-- :name " query-name " " signature)
|
||||
(str "-- :doc lists all existing " pretty-name " records related to a given " pretty-far)
|
||||
(str "SELECT lv_" entity-name ".* \nFROM lv_" entity-name ", " entity-name)
|
||||
(str "WHERE lv_" entity-name "." (first (key-names entity)) " = "
|
||||
entity-name "." (first (key-names entity))
|
||||
"\n\tAND " entity-name "." link-field " = :id")
|
||||
(str "-- :doc lists all existing " pretty-far " records related to a given " pretty-name)
|
||||
(str "SELECT lv_" entity-safe ".* \nFROM lv_" entity-safe)
|
||||
(str "WHERE lv_" entity-safe "." (safe-name % :sql) " = :id")
|
||||
(order-by-clause entity "lv_" false))
|
||||
"link" (let [link-table-name
|
||||
(link-table-name % entity far-entity)]
|
||||
(list
|
||||
(str "-- :name " query-name " " signature)
|
||||
(str "-- :doc links all existing " pretty-name " records related to a given " pretty-far)
|
||||
(str "SELECT * \nFROM " entity-name ", " link-table-name)
|
||||
(str "WHERE " entity-name "."
|
||||
(first (key-names entity))
|
||||
" = " link-table-name "." (singularise entity-name) "_id")
|
||||
(str "\tAND " link-table-name "." (singularise far-name) "_id = :id")
|
||||
(order-by-clause entity)))
|
||||
(str "-- :doc links all existing " pretty-far " records related to a given " pretty-name)
|
||||
(str "SELECT lv_" safe-far ".* \nFROM lv_" safe-far ", " link-table-name)
|
||||
(str "WHERE lv_" safe-far "."
|
||||
(safe-name (first (key-names far-entity)) :sql)
|
||||
" = " link-table-name "." (singularise safe-far) "_id")
|
||||
(str "\tAND " link-table-name "." (singularise entity-safe) "_id = :id")
|
||||
(order-by-clause far-entity "lv_" false)))
|
||||
"list" (list
|
||||
(str "-- :name " query-name " " signature)
|
||||
(str "-- :doc lists all existing " pretty-far " records related to a given " pretty-name)
|
||||
(str "SELECT lv_" safe-far ".* \nFROM lv_" safe-far)
|
||||
(str "WHERE lv_" safe-far "." (safe-name (first (key-names far-entity)) :sql) " = :id")
|
||||
(order-by-clause far-entity "lv_" false))
|
||||
(list (str "ERROR: unexpected type " link-type " of property " %)))))
|
||||
}))
|
||||
links))))
|
||||
|
|
@ -341,7 +355,7 @@
|
|||
"Generate an appropriate `delete` query for this `entity`"
|
||||
(if
|
||||
(has-primary-key? entity)
|
||||
(let [entity-name (:name (:attrs entity))
|
||||
(let [entity-name (safe-name entity :sql)
|
||||
pretty-name (singularise entity-name)
|
||||
query-name (str "delete-" pretty-name "!")
|
||||
signature ":! :n"]
|
||||
|
|
|
|||
|
|
@ -466,6 +466,7 @@
|
|||
#(and
|
||||
(entity? %)
|
||||
(= (:name (:attrs %)) (:entity (:attrs property)))))
|
||||
unique? (unique-link? e1 e2)
|
||||
link-table-name (link-table-name property e1 e2)]
|
||||
(if
|
||||
;; we haven't already emitted this one...
|
||||
|
|
@ -485,6 +486,13 @@
|
|||
[(construct-link-property e1)
|
||||
(construct-link-property e2)]
|
||||
permissions)))}]
|
||||
(if-not unique?
|
||||
(*warn*
|
||||
(str "WARNING: Manually check link tables between "
|
||||
(-> e1 :attrs :name)
|
||||
" and "
|
||||
(-> e2 :attrs :name)
|
||||
" for redundancy")))
|
||||
;; mark it as emitted
|
||||
(swap! emitted-link-tables conj link-table-name)
|
||||
;; emit it
|
||||
|
|
@ -498,7 +506,7 @@
|
|||
(:name (:attrs e1))
|
||||
" with "
|
||||
(:name (:attrs e2))))
|
||||
;; and immediately emit its referential integrity links
|
||||
;; and immediately emit its referential integrity links
|
||||
(emit-referential-integrity-links link-entity application)))))))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -65,58 +65,146 @@
|
|||
(vector (symbol (str (:name (:attrs application)) ".routes.manual")) :as 'm))))
|
||||
|
||||
|
||||
(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))
|
||||
(reduce
|
||||
merge
|
||||
{:error (list :warnings 'record)
|
||||
:record (list 'dissoc 'record :warnings)}
|
||||
(map
|
||||
(fn [property]
|
||||
(defn compose-fetch-record
|
||||
[e]
|
||||
(let
|
||||
[entity-name (singularise (:name (:attrs e)))
|
||||
warning (str
|
||||
"Error while fetching "
|
||||
entity-name
|
||||
" record")]
|
||||
(list
|
||||
'if
|
||||
(list
|
||||
'all-keys-present?
|
||||
'params (key-names e true))
|
||||
(list
|
||||
'support/do-or-log-error
|
||||
(list
|
||||
(query-name e :get)
|
||||
(symbol "db/*db*")
|
||||
'params)
|
||||
:message warning
|
||||
:error-return {:warnings [warning]}))))
|
||||
|
||||
|
||||
(defn compose-get-menu-options
|
||||
[property application]
|
||||
;; TODO: doesn't handle the case of type="link"
|
||||
(case (-> property :attrs :type)
|
||||
"entity" (if-let [e (child-with-tag
|
||||
application
|
||||
:entity
|
||||
#(= (-> % :attrs :name)
|
||||
(-> property :attrs :entity)))]
|
||||
(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)))))))
|
||||
'get-menu-options
|
||||
(singularise (-> e :attrs :name))
|
||||
(query-name e :search-strings)
|
||||
(query-name e :search-strings)
|
||||
(keyword (-> property :attrs :farkey))
|
||||
(list (keyword (-> property :attrs :name)) 'params)))
|
||||
{})
|
||||
"link" (list
|
||||
'do
|
||||
(list
|
||||
'comment
|
||||
"Can't yet handle link properties")
|
||||
{})
|
||||
"list" (list
|
||||
'do
|
||||
(list
|
||||
'comment
|
||||
"Can't yet handle link properties")
|
||||
{})
|
||||
(list
|
||||
'do
|
||||
(list
|
||||
'comment
|
||||
(str "Unexpected type " (-> property :atts :type)))
|
||||
{})))
|
||||
|
||||
|
||||
(defn compose-fetch-auxlist-data
|
||||
[auxlist entity application]
|
||||
(let [p-name (-> auxlist :attrs :property)
|
||||
property (child-with-tag entity
|
||||
:property
|
||||
#(= (-> % :attrs :name) p-name))
|
||||
f-name (-> property :attrs :entity)
|
||||
farside (child-with-tag application
|
||||
:entity
|
||||
#(= (-> % :attrs :name) f-name))]
|
||||
(if (and (entity? entity) (entity? farside))
|
||||
(list 'if (list 'all-keys-present? 'params (key-names entity true))
|
||||
(hash-map
|
||||
(keyword (auxlist-data-name auxlist))
|
||||
(list
|
||||
(symbol (str "db/" (list-related-query-name property entity farside)))
|
||||
'db/*db*
|
||||
{:id
|
||||
(list
|
||||
(case (-> property :attrs :type)
|
||||
"link" :id
|
||||
"list" (keyword (-> property :attrs :name)))
|
||||
'params)})))
|
||||
(do
|
||||
(if-not
|
||||
(entity? entity)
|
||||
(*warn*
|
||||
(str
|
||||
"Entity '"
|
||||
(-> entity :attrs :name)
|
||||
"' passed to compose-fetch-auxlist-data is a non-entity")))
|
||||
(if-not
|
||||
(entity? farside)
|
||||
(*warn*
|
||||
(str
|
||||
"Entity '"
|
||||
f-name
|
||||
"' (" farside ")
|
||||
found in compose-fetch-auxlist-data is a non-entity")))
|
||||
nil))))
|
||||
|
||||
|
||||
(defn make-form-get-handler-content
|
||||
[f e a n]
|
||||
(list
|
||||
'let
|
||||
(vector
|
||||
'record (compose-fetch-record e))
|
||||
(list
|
||||
'reduce
|
||||
'merge
|
||||
{:error (list :warnings 'record)
|
||||
:record (list 'dissoc 'record :warnings)}
|
||||
(cons
|
||||
'list
|
||||
(concat
|
||||
(map
|
||||
#(compose-get-menu-options % a)
|
||||
(filter #(:entity (:attrs %))
|
||||
(descendants-with-tag e :property)))
|
||||
(map
|
||||
#(compose-fetch-auxlist-data % e a)
|
||||
(descendants-with-tag f :auxlist))
|
||||
(list
|
||||
(list 'if (list :error 'request)
|
||||
{:error (list :error 'request)})
|
||||
(list 'if (list :message 'request)
|
||||
{:message (list :message 'request)})))))))
|
||||
|
||||
|
||||
(defn make-page-get-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*")
|
||||
'params))
|
||||
:message warning
|
||||
:error-return {:warnings [warning]}))
|
||||
{:warnings (list :warnings 'record)
|
||||
:record (list 'assoc 'record :warnings nil)})))
|
||||
(list
|
||||
'let
|
||||
(vector
|
||||
'record (compose-fetch-record e))
|
||||
{:warnings (list :warnings 'record)
|
||||
:record (list 'assoc 'record :warnings nil)}))
|
||||
|
||||
|
||||
(defn make-list-get-handler-content
|
||||
|
|
@ -130,45 +218,55 @@
|
|||
(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})))
|
||||
(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*") 'params)
|
||||
: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
|
||||
|
|
@ -211,49 +309,58 @@
|
|||
[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
|
||||
'let
|
||||
(vector
|
||||
'insert-params (list
|
||||
'prepare-insertion-params
|
||||
'params
|
||||
(set
|
||||
(map
|
||||
#(-> % :attrs :name)
|
||||
(insertable-properties e))))
|
||||
'result
|
||||
(list
|
||||
'do-or-server-fail
|
||||
(list
|
||||
'if
|
||||
(list 'all-keys-present? 'params (key-names e true))
|
||||
'valid-user-or-forbid
|
||||
(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
|
||||
'with-params-or-error
|
||||
(list
|
||||
'if
|
||||
(list 'all-keys-present? 'params (key-names e true))
|
||||
(list
|
||||
'do-or-server-fail
|
||||
(list
|
||||
update-name
|
||||
'db/*db*
|
||||
'insert-params)
|
||||
200)
|
||||
(list
|
||||
'do-or-server-fail
|
||||
(list
|
||||
create-name
|
||||
'db/*db*
|
||||
'insert-params)
|
||||
201))
|
||||
'params
|
||||
(set
|
||||
(map
|
||||
#(keyword (:name (:attrs %)))
|
||||
(required-properties e))))
|
||||
'request))
|
||||
(list
|
||||
(set [200 400])
|
||||
(list :status 'result))
|
||||
(list
|
||||
(symbol (handler-name f e a :get))
|
||||
(list
|
||||
'assoc
|
||||
'request
|
||||
:params
|
||||
(list
|
||||
'merge
|
||||
'params
|
||||
'result)))
|
||||
'result))))
|
||||
(symbol (handler-name f e a :get))
|
||||
(list 'merge
|
||||
(list
|
||||
'assoc
|
||||
'request
|
||||
:params
|
||||
(list
|
||||
'merge
|
||||
'params
|
||||
'result))
|
||||
(list 'case (:status 'result)
|
||||
200 {:message "Record stored"}
|
||||
201 (str "Record created: " (list :body 'result))
|
||||
{:error (list :body 'result)}))))))
|
||||
|
||||
|
||||
(defn make-post-handler
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@
|
|||
:author "Simon Brooke"}
|
||||
adl.to-selmer-templates
|
||||
(:require [adl-support.core :refer :all]
|
||||
[adl-support.forms-support :refer :all]
|
||||
[adl.to-hugsql-queries :refer [expanded-token]]
|
||||
[adl-support.utils :refer :all]
|
||||
[clojure.java.io :refer [file make-parents resource]]
|
||||
|
|
@ -65,7 +66,6 @@
|
|||
|
||||
(defn emit-content
|
||||
([content]
|
||||
(do-or-warn
|
||||
(cond
|
||||
(nil? content)
|
||||
nil
|
||||
|
|
@ -77,8 +77,7 @@
|
|||
(seq? content)
|
||||
(map emit-content (remove nil? content))
|
||||
true
|
||||
(str "<!-- don't know what to do with '" content "' -->"))
|
||||
(str "Failed while writing " content)))
|
||||
(str "<!-- don't know what to do with '" content "' -->")))
|
||||
([filename application k]
|
||||
(emit-content filename nil nil application k))
|
||||
([filename spec entity application k]
|
||||
|
|
@ -374,6 +373,20 @@
|
|||
"{% endif %}")))})
|
||||
|
||||
|
||||
(defn get-size-for-widget
|
||||
"Return, as an integer, the fieldwidth for the input widget for this
|
||||
`property`."
|
||||
[property]
|
||||
(let [s (try
|
||||
(read-string
|
||||
(:size (:attrs property)))
|
||||
(catch Exception _ 16))]
|
||||
(if
|
||||
(not (integer? s))
|
||||
16
|
||||
s)))
|
||||
|
||||
|
||||
(defn compose-input-widget-para
|
||||
"Generate an input widget for this `field-or-property` of this `form` for
|
||||
this `entity` taken from within this `application`, in context of a para
|
||||
|
|
@ -390,17 +403,14 @@
|
|||
: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)))}
|
||||
:maxlength (str (max (get-size-for-widget property) 16))
|
||||
:size (str (min (get-size-for-widget property) 60))}
|
||||
(case (-> property :attrs :type)
|
||||
"real"
|
||||
{:step 0.000001} ;; this is a bit arbitrary!
|
||||
"integer"
|
||||
{:step 1}
|
||||
nil)
|
||||
;; TODO: should match pattern from typedef
|
||||
(if
|
||||
(:minimum (:attrs typedef))
|
||||
|
|
@ -479,10 +489,12 @@
|
|||
|
||||
|
||||
(defn edit-link
|
||||
[entity application parameters]
|
||||
[source entity application parameters]
|
||||
(str
|
||||
"{{servlet-context}}/"
|
||||
(editor-name entity application)
|
||||
(or
|
||||
(-> source :attrs :onselect)
|
||||
(editor-name entity application))
|
||||
"?"
|
||||
(s/join
|
||||
"&"
|
||||
|
|
@ -494,7 +506,7 @@
|
|||
|
||||
(defn list-tbody
|
||||
"Return a table body element for the list view for this `list-spec` of
|
||||
this `entity` within this `application`, using data from this source."
|
||||
this `entity` within this `application`, using data from this `source`."
|
||||
[source list-spec entity application]
|
||||
{:tag :tbody
|
||||
:content
|
||||
|
|
@ -502,40 +514,50 @@
|
|||
{:tag :tr
|
||||
:content
|
||||
(apply
|
||||
vector
|
||||
vector
|
||||
(remove
|
||||
nil?
|
||||
(concat
|
||||
(map
|
||||
(fn [field]
|
||||
{:tag :td :content
|
||||
(let
|
||||
[p (first
|
||||
(filter
|
||||
#(=
|
||||
(:name (:attrs %))
|
||||
(:property (:attrs field)))
|
||||
(all-properties entity)))
|
||||
s (safe-name (:name (:attrs p)) :sql)
|
||||
e (first
|
||||
(filter
|
||||
#(= (:name (:attrs %)) (:entity (:attrs p)))
|
||||
(children-with-tag application :entity)))
|
||||
c (str "{{ record." s " }}")]
|
||||
(if
|
||||
(= (:type (:attrs p)) "entity")
|
||||
[{:tag :a
|
||||
:attrs {:href (edit-link
|
||||
e
|
||||
(map
|
||||
(fn [field]
|
||||
{:tag :td :content
|
||||
(let
|
||||
[p (first
|
||||
(filter
|
||||
#(=
|
||||
(:name (:attrs %))
|
||||
(:property (:attrs field)))
|
||||
(all-properties entity)))
|
||||
s (safe-name (:name (:attrs p)) :sql)
|
||||
e (first
|
||||
(filter
|
||||
#(= (:name (:attrs %)) (:entity (:attrs p)))
|
||||
(children-with-tag application :entity)))
|
||||
c (str "{{ record." s " }}")]
|
||||
(if
|
||||
(= (:type (:attrs p)) "entity")
|
||||
[{:tag :a
|
||||
:attrs {:href (edit-link
|
||||
source
|
||||
(child-with-tag
|
||||
application
|
||||
(list (:name (:attrs p))))}
|
||||
:content [(str "{{ record." s "_expanded }}")]}]
|
||||
[c]))})
|
||||
(children-with-tag list-spec :field))
|
||||
[{:tag :td
|
||||
:entity
|
||||
#(= (-> % :attrs :name)(-> p :attrs :entity)))
|
||||
application
|
||||
(list (:name (:attrs p))))}
|
||||
:content [(str "{{ record." s "_expanded }}")]}]
|
||||
[c]))})
|
||||
(children-with-tag list-spec :field))
|
||||
[{:tag :td
|
||||
:content
|
||||
[{:tag :a
|
||||
:attrs
|
||||
{:href (edit-link entity application (key-names entity))}
|
||||
:content ["View"]}]}]))}
|
||||
[(if
|
||||
(or (= (:tag list-spec) :list)
|
||||
(-> list-spec :attrs :onselect))
|
||||
{:tag :a
|
||||
:attrs
|
||||
{:href (edit-link source entity application (key-names entity))}
|
||||
:content ["View"]}
|
||||
" ")]}])))}
|
||||
"{% endfor %}"]})
|
||||
|
||||
|
||||
|
|
@ -545,42 +567,70 @@
|
|||
entity
|
||||
:property
|
||||
#(=
|
||||
(-> % :attrs :name)
|
||||
(-> auxlist :attrs :property)))
|
||||
(-> % :attrs :name)
|
||||
(-> auxlist :attrs :property)))
|
||||
farside (child-with-tag
|
||||
application
|
||||
:entity
|
||||
#(=
|
||||
(-> % :attrs :name)
|
||||
(-> property :attrs :entity)))]
|
||||
(-> % :attrs :name)
|
||||
(-> property :attrs :entity)))]
|
||||
(if
|
||||
(and property farside)
|
||||
{:tag :div
|
||||
:attrs {:class "auxlist"}
|
||||
:content
|
||||
[{:tag :h2
|
||||
:content [(prompt auxlist form entity application)]}
|
||||
{:tag :table
|
||||
:content
|
||||
[{:tag :thead
|
||||
:content
|
||||
[{:tag :tr
|
||||
:content
|
||||
(apply
|
||||
vector
|
||||
(flatten
|
||||
(list
|
||||
(map
|
||||
#(hash-map
|
||||
:tag :th
|
||||
:content [(prompt % form entity application)])
|
||||
(children-with-tag auxlist :field))
|
||||
{:tag :th :content [" "]})))}]}
|
||||
(list-tbody
|
||||
(-> property :attrs :name)
|
||||
auxlist
|
||||
farside
|
||||
application)]}]})))
|
||||
(apply
|
||||
vector
|
||||
(remove
|
||||
nil?
|
||||
(flatten
|
||||
(list
|
||||
;; only show auxlists if we've got keys
|
||||
(str "{% if all "
|
||||
(s/join " " (map #(str "params." %) (key-names entity)))
|
||||
" %}")
|
||||
;; only show the body of auxlists if the list is non-empty
|
||||
(str "{% if " (auxlist-data-name auxlist) "|not-empty %}")
|
||||
|
||||
{:tag :h2
|
||||
:content [(prompt auxlist form entity application)]}
|
||||
{:tag :table
|
||||
:content
|
||||
[{:tag :thead
|
||||
:content
|
||||
[{:tag :tr
|
||||
:content
|
||||
(apply
|
||||
vector
|
||||
(remove
|
||||
nil?
|
||||
(flatten
|
||||
(list
|
||||
(map
|
||||
#(hash-map
|
||||
:tag :th
|
||||
:content [(prompt % form entity application)])
|
||||
(children-with-tag auxlist :field))
|
||||
{:tag :th :content [" "]}))))}]}
|
||||
(list-tbody
|
||||
(auxlist-data-name auxlist)
|
||||
auxlist
|
||||
farside
|
||||
application)]}
|
||||
"{% endif %}"
|
||||
(if
|
||||
(= (-> auxlist :attrs :canadd) "true")
|
||||
(wrap-in-if-member-of
|
||||
(big-link (str
|
||||
"Add a new "
|
||||
(pretty-name property))
|
||||
(editor-name farside application))
|
||||
:writeable
|
||||
farside
|
||||
application)
|
||||
)
|
||||
"{% endif %}"))))})))
|
||||
|
||||
|
||||
(defn compose-form-auxlists
|
||||
|
|
@ -1030,11 +1080,12 @@
|
|||
(if
|
||||
(pos? *verbosity*)
|
||||
(*warn* "\tGenerated " filepath))
|
||||
(str filepath))))))
|
||||
(str filepath))
|
||||
(str "While generating " filepath)))))
|
||||
|
||||
|
||||
;; (def a (x/parse "../youyesyet/youyesyet.canonical.adl.xml"))
|
||||
;; (def e (child-with-tag a :entity))
|
||||
;; (def e (child-with-tag a :entity #(= (-> % :attrs :name) "teams")))
|
||||
;; (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))
|
||||
|
|
|
|||
Loading…
Reference in a new issue