Moved utils into the support project. Also greatly improved CLI.
This commit is contained in:
parent
2d7e39ca29
commit
fc79e74fb8
|
|
@ -3,9 +3,12 @@
|
|||
:url "http://example.com/FIXME"
|
||||
:license {:name "GNU General Public License,version 2.0 or (at your option) any later version"
|
||||
:url "https://www.gnu.org/licenses/old-licenses/gpl-2.0.en.html"}
|
||||
:dependencies [[org.clojure/clojure "1.8.0"]
|
||||
:dependencies [[adl-support "0.1.0-SNAPSHOT"]
|
||||
[org.clojure/clojure "1.8.0"]
|
||||
[org.clojure/math.combinatorics "0.1.4"]
|
||||
[org.clojure/tools.cli "0.3.7"]
|
||||
[bouncer "1.0.1"]
|
||||
[environ "1.1.0"]
|
||||
[hiccup "1.0.5"]]
|
||||
:aot [adl.main]
|
||||
:main adl.main
|
||||
|
|
|
|||
106
src/adl/main.clj
106
src/adl/main.clj
|
|
@ -1,13 +1,17 @@
|
|||
(ns ^{:doc "Application Description Language - command line invocation."
|
||||
:author "Simon Brooke"}
|
||||
adl.main
|
||||
(:require [adl.utils :refer :all]
|
||||
(:require [adl-support.utils :refer :all]
|
||||
[adl.to-hugsql-queries :as h]
|
||||
[adl.to-json-routes :as j]
|
||||
[adl.to-psql :as p]
|
||||
[adl.to-selmer-routes :as s]
|
||||
[adl.to-selmer-templates :as t]
|
||||
[clojure.xml :as x])
|
||||
[clojure.java.io :refer [make-parents]]
|
||||
[clojure.string :refer [join]]
|
||||
[clojure.tools.cli :refer [parse-opts]]
|
||||
[clojure.xml :as x]
|
||||
[environ.core :refer [env]])
|
||||
(:gen-class))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
@ -33,22 +37,96 @@
|
|||
;;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defn print-usage [_]
|
||||
(println "Argument should be a pathname to an ADL file"))
|
||||
(def cli-options
|
||||
[["-a" "--abstract-key-name-convention [string]" "the abstract key name convention to use for generated key fields (TODO: not yet implemented)"
|
||||
:default "id"]
|
||||
["-h" "--help" "Show this message"
|
||||
:default false]
|
||||
["-l" "--locale [LOCALE]" "set the locale to generate"
|
||||
:default (env :lang)]
|
||||
["-p" "--path [PATH]" "The path under which generated files should be written"
|
||||
:default "generated"]
|
||||
["-v" "--verbosity [LEVEL]" nil "Verbosity level - integer value required"
|
||||
:parse-fn #(Integer/parseInt %)
|
||||
:default 0]
|
||||
])
|
||||
|
||||
|
||||
(defn- doc-part
|
||||
"An `option` in cli-options comprises a sequence of strings followed by
|
||||
keyword/value pairs. Return all the strings before the first keyword."
|
||||
[option]
|
||||
(if
|
||||
(keyword? (first option)) nil
|
||||
(cons (first option) (doc-part (rest option)))))
|
||||
|
||||
(defn map-part
|
||||
"An `option` in cli-options comprises a sequence of strings followed by
|
||||
keyword/value pairs. Return the keyword/value pairs as a map."
|
||||
[option]
|
||||
(cond
|
||||
(empty? option) nil
|
||||
(keyword? (first option)) (apply hash-map option)
|
||||
true
|
||||
(map-part (rest option))))
|
||||
|
||||
(defn print-usage []
|
||||
(println
|
||||
(join
|
||||
"\n"
|
||||
(flatten
|
||||
(list
|
||||
(join
|
||||
(list
|
||||
"Usage: java -jar adl-"
|
||||
(or (System/getProperty "adl.version") "[VERSION]")
|
||||
"-SNAPSHOT-standalone.jar -options [adl-file]"))
|
||||
"where options include:"
|
||||
(map
|
||||
#(let
|
||||
[doc-part (doc-part %)
|
||||
default (:default (map-part %))
|
||||
default-string (if default (str "; (default: " default ")"))]
|
||||
(str "\t" (join ", " (butlast doc-part)) ": " (last doc-part) default-string))
|
||||
cli-options))))))
|
||||
|
||||
|
||||
(defn -main
|
||||
"Expects as arg the path-name of an ADL file."
|
||||
[& args]
|
||||
(cond
|
||||
(empty? args)
|
||||
(print-usage args)
|
||||
(.exists (java.io.File. (first args)))
|
||||
(let [application (x/parse (first args))]
|
||||
(h/to-hugsql-queries application)
|
||||
(j/to-json-routes application)
|
||||
(p/to-psql application)
|
||||
(s/to-selmer-routes application)
|
||||
(t/to-selmer-templates application))))
|
||||
(let [options (parse-opts args cli-options)]
|
||||
(cond
|
||||
(empty? args)
|
||||
(print-usage)
|
||||
(not (empty? (:errors options)))
|
||||
(do
|
||||
(doall
|
||||
(map
|
||||
println
|
||||
(:errors options)))
|
||||
(print-usage))
|
||||
(-> options :options :help)
|
||||
(print-usage)
|
||||
true
|
||||
(do
|
||||
(let [p (:path (:options options))
|
||||
op (if (.endsWith p "/") p (str p "/"))]
|
||||
(binding [*output-path* op
|
||||
*locale* (-> options :options :locale)
|
||||
*verbosity* (-> options :options :verbosity)]
|
||||
(make-parents *output-path*)
|
||||
(doall
|
||||
(map
|
||||
#(if
|
||||
(.exists (java.io.File. %))
|
||||
(let [application (x/parse %)]
|
||||
(h/to-hugsql-queries application)
|
||||
(j/to-json-routes application)
|
||||
(p/to-psql application)
|
||||
(s/to-selmer-routes application)
|
||||
(t/to-selmer-templates application))
|
||||
(println (str "ERROR: File not found: " %)))
|
||||
(-> options :arguments)))))))))
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@
|
|||
[clojure.xml :as x]
|
||||
[clj-time.core :as t]
|
||||
[clj-time.format :as f]
|
||||
[adl.utils :refer :all]))
|
||||
[adl-support.utils :refer :all]))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;;;
|
||||
|
|
@ -58,9 +58,9 @@
|
|||
(order-by-clause entity ""))
|
||||
([entity prefix]
|
||||
(let
|
||||
[entity-name (:name (:attrs entity))
|
||||
[entity-name (safe-name (:name (:attrs entity)) :sql)
|
||||
preferred (map
|
||||
#(:name (:attrs %))
|
||||
#(safe-name (:name (:attrs %)) :sql)
|
||||
(filter #(#{"user" "all"} (-> % :attrs :distinct))
|
||||
(children entity #(= (:tag %) :property))))]
|
||||
(if
|
||||
|
|
@ -70,7 +70,9 @@
|
|||
"ORDER BY " prefix entity-name "."
|
||||
(s/join
|
||||
(str ",\n\t" prefix entity-name ".")
|
||||
(flatten (cons preferred (key-names entity)))))))))
|
||||
(map
|
||||
#(safe-name % :sql)
|
||||
(flatten (cons preferred (key-names entity))))))))))
|
||||
|
||||
|
||||
(defn insert-query
|
||||
|
|
@ -78,9 +80,11 @@
|
|||
TODO: this depends on the idea that system-unique properties
|
||||
are not insertable, which is... dodgy."
|
||||
[entity]
|
||||
(let [entity-name (:name (:attrs entity))
|
||||
(let [entity-name (safe-name (:name (:attrs entity)) :sql)
|
||||
pretty-name (singularise entity-name)
|
||||
insertable-property-names (map #(:name (:attrs %)) (insertable-properties entity))
|
||||
insertable-property-names (map
|
||||
#(safe-name (:name (:attrs %)) :sql)
|
||||
(insertable-properties entity))
|
||||
query-name (str "create-" pretty-name "!")
|
||||
signature ":! :n"]
|
||||
(hash-map
|
||||
|
|
@ -99,7 +103,12 @@
|
|||
")"
|
||||
(if
|
||||
(has-primary-key? entity)
|
||||
(str "\nreturning " (s/join ",\n\t" (key-names entity)))))})))
|
||||
(str "\nreturning "
|
||||
(s/join
|
||||
",\n\t"
|
||||
(map
|
||||
#(safe-name % :sql)
|
||||
(key-names entity))))))})))
|
||||
|
||||
|
||||
(defn update-query
|
||||
|
|
@ -109,7 +118,7 @@
|
|||
(and
|
||||
(has-primary-key? entity)
|
||||
(has-non-key-properties? entity))
|
||||
(let [entity-name (:name (:attrs entity))
|
||||
(let [entity-name (safe-name (:name (:attrs entity)) :sql)
|
||||
pretty-name (singularise entity-name)
|
||||
property-names (map #(:name (:attrs %)) (insertable-properties entity))
|
||||
query-name (str "update-" pretty-name "!")
|
||||
|
|
@ -125,7 +134,7 @@
|
|||
"-- :doc updates an existing " pretty-name " record\n"
|
||||
"UPDATE " entity-name "\n"
|
||||
"SET "
|
||||
(s/join ",\n\t" (map #(str % " = " (keyword %)) property-names))
|
||||
(s/join ",\n\t" (map #(str (safe-name % :sql) " = " (keyword %)) property-names))
|
||||
"\n"
|
||||
(where-clause entity))}))
|
||||
{}))
|
||||
|
|
@ -133,7 +142,7 @@
|
|||
|
||||
(defn search-query [entity]
|
||||
"Generate an appropriate search query for string fields of this `entity`"
|
||||
(let [entity-name (:name (:attrs entity))
|
||||
(let [entity-name (safe-name (:name (:attrs entity)) :sql)
|
||||
pretty-name (singularise entity-name)
|
||||
query-name (str "search-strings-" pretty-name)
|
||||
signature ":? :1"
|
||||
|
|
@ -162,9 +171,21 @@
|
|||
(filter
|
||||
string?
|
||||
(map
|
||||
#(if
|
||||
(#{"string" "date" "text"} (:type (:attrs %)))
|
||||
(str (-> % :attrs :name) " LIKE '%params." (-> % :attrs :name) "%'"))
|
||||
#(case (:type (:attrs %))
|
||||
("string" "text")
|
||||
(str
|
||||
(safe-name (-> % :attrs :name) :sql)
|
||||
" LIKE '%params."
|
||||
(-> % :attrs :name) "%'")
|
||||
("date" "time" "timestamp")
|
||||
(str
|
||||
(safe-name (-> % :attrs :name) :sql)
|
||||
" = 'params."
|
||||
(-> % :attrs :name) "'")
|
||||
(str
|
||||
(safe-name (-> % :attrs :name) :sql)
|
||||
" = params."
|
||||
(-> % :attrs :name)))
|
||||
properties)))
|
||||
(order-by-clause entity "lv_")
|
||||
"--~ (if (:offset params) \"OFFSET :offset \")"
|
||||
|
|
@ -176,7 +197,7 @@
|
|||
([entity properties]
|
||||
(if
|
||||
(not (empty? properties))
|
||||
(let [entity-name (:name (:attrs entity))
|
||||
(let [entity-name (safe-name (:name (:attrs entity)) :sql)
|
||||
pretty-name (singularise entity-name)
|
||||
query-name (if (= properties (key-properties entity))
|
||||
(str "get-" pretty-name)
|
||||
|
|
@ -216,7 +237,7 @@
|
|||
Parameters `:limit` and `:offset` may be supplied. If not present limit defaults
|
||||
to 100 and offset to 0."
|
||||
[entity]
|
||||
(let [entity-name (:name (:attrs entity))
|
||||
(let [entity-name (safe-name (:name (:attrs entity)) :sql)
|
||||
pretty-name (singularise entity-name)
|
||||
query-name (str "list-" entity-name)
|
||||
signature ":? :*"]
|
||||
|
|
@ -417,22 +438,34 @@
|
|||
(defn to-hugsql-queries
|
||||
"Generate all [HugSQL](https://www.hugsql.org/) queries implied by this ADL `application` spec."
|
||||
[application]
|
||||
(let [file-path (str *output-path* "resources/sql/queries.sql")]
|
||||
(make-parents file-path)
|
||||
(spit
|
||||
file-path
|
||||
(s/join
|
||||
"\n\n"
|
||||
(cons
|
||||
(emit-header
|
||||
"--"
|
||||
"File queries.sql"
|
||||
(str "autogenerated by adl.to-hugsql-queries at " (t/now))
|
||||
"See [Application Description Language](https://github.com/simon-brooke/adl).")
|
||||
(map
|
||||
#(:query %)
|
||||
(sort
|
||||
#(compare (:name %1) (:name %2))
|
||||
(vals
|
||||
(queries application)))))))))
|
||||
(let [filepath (str *output-path* "resources/sql/queries.auto.sql")]
|
||||
(make-parents filepath)
|
||||
(try
|
||||
(spit
|
||||
filepath
|
||||
(s/join
|
||||
"\n\n"
|
||||
(cons
|
||||
(emit-header
|
||||
"--"
|
||||
"File queries.sql"
|
||||
(str "autogenerated by adl.to-hugsql-queries at " (t/now))
|
||||
"See [Application Description Language](https://github.com/simon-brooke/adl).")
|
||||
(map
|
||||
#(:query %)
|
||||
(sort
|
||||
#(compare (:name %1) (:name %2))
|
||||
(vals
|
||||
(queries application)))))))
|
||||
(if (> *verbosity* 0)
|
||||
(println (str "\tGenerated " filepath)))
|
||||
(catch
|
||||
Exception any
|
||||
(println
|
||||
(str
|
||||
"ERROR: Exception "
|
||||
(.getName (.getClass any))
|
||||
(.getMessage any)
|
||||
" while printing "
|
||||
filepath))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@
|
|||
[clojure.xml :as x]
|
||||
[clj-time.core :as t]
|
||||
[clj-time.format :as f]
|
||||
[adl.utils :refer :all]
|
||||
[adl-support.utils :refer :all]
|
||||
[adl.to-hugsql-queries :refer [queries]]))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
@ -37,7 +37,6 @@
|
|||
;;; to-hugsql-queries, because essentially we need one JSON entry point to wrap
|
||||
;;; each query.
|
||||
|
||||
|
||||
(defn file-header [application]
|
||||
(list
|
||||
'ns
|
||||
|
|
@ -47,6 +46,7 @@
|
|||
(f/unparse (f/formatters :basic-date-time) (t/now)))
|
||||
(list
|
||||
:require
|
||||
'[adl-support.core :as support]
|
||||
'[clojure.java.io :as io]
|
||||
'[compojure.core :refer [defroutes GET POST]]
|
||||
'[hugsql.core :as hugsql]
|
||||
|
|
@ -221,25 +221,37 @@
|
|||
(defn to-json-routes
|
||||
[application]
|
||||
(let [handlers-map (make-handlers-map application)
|
||||
filepath (str *output-path* (:name (:attrs application)) "/routes/auto_json.clj")]
|
||||
filepath (str *output-path* "src/clj/" (:name (:attrs application)) "/routes/auto_json.clj")]
|
||||
(make-parents filepath)
|
||||
(with-open [output (writer filepath)]
|
||||
(binding [*out* output]
|
||||
(doall
|
||||
(map
|
||||
(fn [f]
|
||||
(pprint f)
|
||||
(println "\n"))
|
||||
(list
|
||||
(file-header application)
|
||||
(declarations handlers-map)
|
||||
(defroutes handlers-map))))
|
||||
(doall
|
||||
(map
|
||||
(fn [h]
|
||||
(pprint (:src (handlers-map h)))
|
||||
(println)
|
||||
h)
|
||||
(sort (keys handlers-map))))))))
|
||||
(try
|
||||
(with-open [output (writer filepath)]
|
||||
(binding [*out* output]
|
||||
(doall
|
||||
(map
|
||||
(fn [f]
|
||||
(pprint f)
|
||||
(println "\n"))
|
||||
(list
|
||||
(file-header application)
|
||||
(declarations handlers-map)
|
||||
(defroutes handlers-map))))
|
||||
(doall
|
||||
(map
|
||||
(fn [h]
|
||||
(pprint (:src (handlers-map h)))
|
||||
(println)
|
||||
h)
|
||||
(sort (keys handlers-map))))))
|
||||
(if (> *verbosity* 0)
|
||||
(println (str "\tGenerated " filepath)))
|
||||
(catch
|
||||
Exception any
|
||||
(println
|
||||
(str
|
||||
"ERROR: Exception "
|
||||
(.getName (.getClass any))
|
||||
(.getMessage any)
|
||||
" while printing "
|
||||
filepath))))))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@
|
|||
[clojure.xml :as x]
|
||||
[clj-time.core :as t]
|
||||
[clj-time.format :as f]
|
||||
[adl.utils :refer :all]
|
||||
[adl-support.utils :refer :all]
|
||||
[adl.to-hugsql-queries :refer [queries]]))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
@ -47,65 +47,65 @@
|
|||
;; that the argument passed as `property` is indeed a property.
|
||||
(str (emit-field-type typedef nil application false)
|
||||
(cond
|
||||
(:pattern (:attrs typedef))
|
||||
(str
|
||||
" CONSTRAINT "
|
||||
(gensym "pattern_")
|
||||
" CHECK ("
|
||||
(:name (:attrs property))
|
||||
" ~* '"
|
||||
(:pattern (:attrs typedef))
|
||||
"')")
|
||||
(and (:maximum (:attrs typedef))(:minimum (:attrs typedef)))
|
||||
;; TODO: if base type is date, time or timestamp, values should be quoted.
|
||||
(str
|
||||
" CONSTRAINT "
|
||||
(gensym "minmax_")
|
||||
" CHECK ("
|
||||
(:minimum (:attrs typedef))
|
||||
" < "
|
||||
(:name (:attrs property))
|
||||
" AND "
|
||||
(:name (:attrs property))
|
||||
" < "
|
||||
(str
|
||||
" CONSTRAINT "
|
||||
(gensym "pattern_")
|
||||
" CHECK ("
|
||||
(:name (:attrs property))
|
||||
" ~* '"
|
||||
(:pattern (:attrs typedef))
|
||||
"')")
|
||||
(and (:maximum (:attrs typedef))(:minimum (:attrs typedef)))
|
||||
;; TODO: if base type is date, time or timestamp, values should be quoted.
|
||||
(str
|
||||
" CONSTRAINT "
|
||||
(gensym "minmax_")
|
||||
" CHECK ("
|
||||
(:minimum (:attrs typedef))
|
||||
" < "
|
||||
(:name (:attrs property))
|
||||
" AND "
|
||||
(:name (:attrs property))
|
||||
" < "
|
||||
(:maximum (:attrs typedef))
|
||||
")")
|
||||
(:maximum (:attrs typedef))
|
||||
")")
|
||||
(:maximum (:attrs typedef))
|
||||
(str
|
||||
" CONSTRAINT "
|
||||
(gensym "max_")
|
||||
" CHECK ("
|
||||
(:name (:attrs property))
|
||||
" < "
|
||||
(:maximum (:attrs typedef))
|
||||
")")
|
||||
(:minimum (:attrs typedef))
|
||||
(str
|
||||
" CONSTRAINT "
|
||||
(gensym "min_")
|
||||
" CHECK ("
|
||||
(str
|
||||
" CONSTRAINT "
|
||||
(gensym "max_")
|
||||
" CHECK ("
|
||||
(:name (:attrs property))
|
||||
" < "
|
||||
(:maximum (:attrs typedef))
|
||||
")")
|
||||
(:minimum (:attrs typedef))
|
||||
" < "
|
||||
(:name (:attrs property)))))))
|
||||
(str
|
||||
" CONSTRAINT "
|
||||
(gensym "min_")
|
||||
" CHECK ("
|
||||
(:minimum (:attrs typedef))
|
||||
" < "
|
||||
(:name (:attrs property)))))))
|
||||
|
||||
|
||||
(defn emit-entity-field-type
|
||||
[property application]
|
||||
(let [farside (child
|
||||
application
|
||||
#(and
|
||||
(entity? %)
|
||||
(= (:name (:attrs %)) (:entity (:attrs property)))))
|
||||
application
|
||||
#(and
|
||||
(entity? %)
|
||||
(= (:name (:attrs %)) (:entity (:attrs property)))))
|
||||
key-properties (children-with-tag
|
||||
(first (children-with-tag farside :key))
|
||||
:property)]
|
||||
(first (children-with-tag farside :key))
|
||||
:property)]
|
||||
(if
|
||||
(> (count key-properties) 1)
|
||||
(str
|
||||
"-- ERROR: cannot generate link to entity "
|
||||
(:name (:attrs farside))
|
||||
" with compound primary key\n")
|
||||
(emit-field-type (first key-properties) farside application false))))
|
||||
"-- ERROR: cannot generate link to entity "
|
||||
(:name (:attrs farside))
|
||||
" with compound primary key\n")
|
||||
(emit-field-type (first key-properties) farside application false))))
|
||||
|
||||
|
||||
(defn emit-field-type
|
||||
|
|
@ -114,24 +114,24 @@
|
|||
"integer" (if key? "SERIAL" "INTEGER")
|
||||
"real" "DOUBLE PRECISION"
|
||||
("string" "image" "uploadable")
|
||||
(str "VARCHAR(" (:size (:attrs property)) ")")
|
||||
(str "VARCHAR(" (:size (:attrs property)) ")")
|
||||
"defined" (emit-defined-field-type property application)
|
||||
"entity" (emit-entity-field-type property application)
|
||||
("date" "time" "timestamp" "boolean" "text" "money")
|
||||
(.toUpperCase (:type (:attrs property)))
|
||||
(.toUpperCase (:type (:attrs property)))
|
||||
(str "-- ERROR: unknown type " (:type (:attrs property)))))
|
||||
|
||||
|
||||
(defn emit-link-field
|
||||
[property entity application]
|
||||
(emit-property
|
||||
{:tag :property
|
||||
:attrs {:name (str (:name (:attrs entity)) "_id")
|
||||
:type "entity"
|
||||
:entity (:name (:attrs entity))
|
||||
:cascade (:cascade (:attrs property))}}
|
||||
entity
|
||||
application))
|
||||
{:tag :property
|
||||
:attrs {:name (str (:name (:attrs entity)) "_id")
|
||||
:type "entity"
|
||||
:entity (:name (:attrs entity))
|
||||
:cascade (:cascade (:attrs property))}}
|
||||
entity
|
||||
application))
|
||||
|
||||
|
||||
(defn emit-permissions-grant
|
||||
|
|
@ -182,68 +182,68 @@
|
|||
(let [default (:default (:attrs property))]
|
||||
(if
|
||||
(and
|
||||
(= (:tag property) :property)
|
||||
(not (#{"link"} (:type (:attrs property)))))
|
||||
(= (:tag property) :property)
|
||||
(not (#{"link"} (:type (:attrs property)))))
|
||||
(s/join
|
||||
" "
|
||||
(remove
|
||||
nil?
|
||||
(flatten
|
||||
(list
|
||||
"\t"
|
||||
(field-name property)
|
||||
(emit-field-type property entity application key?)
|
||||
(if
|
||||
default
|
||||
" "
|
||||
(remove
|
||||
nil?
|
||||
(flatten
|
||||
(list
|
||||
"DEFAULT"
|
||||
"\t"
|
||||
(field-name property)
|
||||
(emit-field-type property entity application key?)
|
||||
(if
|
||||
(is-quotable-type? property application)
|
||||
(str "'" default "'") ;; TODO: but if the default value seems to be a function invocation, should it be quoted?
|
||||
;; it's quite common for 'now()' to be the default for a date, time or timestamp field.
|
||||
default)))
|
||||
(if
|
||||
key?
|
||||
"NOT NULL PRIMARY KEY"
|
||||
(if (= (:required (:attrs property)) "true") "NOT NULL"))))))))))
|
||||
default
|
||||
(list
|
||||
"DEFAULT"
|
||||
(if
|
||||
(is-quotable-type? property application)
|
||||
(str "'" default "'") ;; TODO: but if the default value seems to be a function invocation, should it be quoted?
|
||||
;; it's quite common for 'now()' to be the default for a date, time or timestamp field.
|
||||
default)))
|
||||
(if
|
||||
key?
|
||||
"NOT NULL PRIMARY KEY"
|
||||
(if (= (:required (:attrs property)) "true") "NOT NULL"))))))))))
|
||||
|
||||
|
||||
(defn compose-convenience-entity-field
|
||||
[field entity application]
|
||||
(let [farside (child
|
||||
application
|
||||
#(and
|
||||
(entity? %)
|
||||
(= (:name (:attrs %)) (:entity (:attrs field)))))]
|
||||
application
|
||||
#(and
|
||||
(entity? %)
|
||||
(= (:name (:attrs %)) (:entity (:attrs field)))))]
|
||||
(flatten
|
||||
(map
|
||||
(fn [f]
|
||||
(if
|
||||
(= (:type (:attrs f)) "entity")
|
||||
(compose-convenience-entity-field f farside application)
|
||||
(str (safe-name (:table (:attrs farside))) "." (field-name f))))
|
||||
(user-distinct-properties farside)))))
|
||||
(map
|
||||
(fn [f]
|
||||
(if
|
||||
(= (:type (:attrs f)) "entity")
|
||||
(compose-convenience-entity-field f farside application)
|
||||
(str (safe-name (:table (:attrs farside))) "." (field-name f))))
|
||||
(user-distinct-properties farside)))))
|
||||
|
||||
|
||||
(defn compose-convenience-view-select-list
|
||||
[entity application top-level?]
|
||||
(remove
|
||||
nil?
|
||||
(flatten
|
||||
(cons
|
||||
(safe-name (:table (:attrs entity)) :sql)
|
||||
(map
|
||||
(fn [f]
|
||||
(if
|
||||
(= (:type (:attrs f)) "entity")
|
||||
(compose-convenience-view-select-list
|
||||
(child application #(and (entity? %) (= (:name (:attrs %))(:entity (:attrs f)))))
|
||||
application
|
||||
false)))
|
||||
(if
|
||||
top-level?
|
||||
(all-properties entity)
|
||||
(user-distinct-properties entity)))))))
|
||||
nil?
|
||||
(flatten
|
||||
(cons
|
||||
(safe-name (:table (:attrs entity)) :sql)
|
||||
(map
|
||||
(fn [f]
|
||||
(if
|
||||
(= (:type (:attrs f)) "entity")
|
||||
(compose-convenience-view-select-list
|
||||
(child application #(and (entity? %) (= (:name (:attrs %))(:entity (:attrs f)))))
|
||||
application
|
||||
false)))
|
||||
(if
|
||||
top-level?
|
||||
(all-properties entity)
|
||||
(user-distinct-properties entity)))))))
|
||||
|
||||
|
||||
(defn compose-convenience-where-clause
|
||||
|
|
@ -251,37 +251,37 @@
|
|||
;; See lv_electors, lv_followuprequests for examples of the problem.
|
||||
[entity application top-level?]
|
||||
(remove
|
||||
nil?
|
||||
(flatten
|
||||
(map
|
||||
(fn [f]
|
||||
(if
|
||||
(= (:type (:attrs f)) "entity")
|
||||
(let [farside (entity-for-property f application)]
|
||||
(cons
|
||||
(str
|
||||
(safe-name (:table (:attrs entity)) :sql)
|
||||
"."
|
||||
(field-name f)
|
||||
" = "
|
||||
(safe-name (:table (:attrs farside)) :sql)
|
||||
"."
|
||||
(safe-name (first (key-names farside)) :sql))
|
||||
#(compose-convenience-where-clause farside application false)))))
|
||||
(if
|
||||
top-level?
|
||||
(all-properties entity)
|
||||
(user-distinct-properties entity))))))
|
||||
nil?
|
||||
(flatten
|
||||
(map
|
||||
(fn [f]
|
||||
(if
|
||||
(= (:type (:attrs f)) "entity")
|
||||
(let [farside (entity-for-property f application)]
|
||||
(cons
|
||||
(str
|
||||
(safe-name (:table (:attrs entity)) :sql)
|
||||
"."
|
||||
(field-name f)
|
||||
" = "
|
||||
(safe-name (:table (:attrs farside)) :sql)
|
||||
"."
|
||||
(safe-name (first (key-names farside)) :sql))
|
||||
#(compose-convenience-where-clause farside application false)))))
|
||||
(if
|
||||
top-level?
|
||||
(all-properties entity)
|
||||
(user-distinct-properties entity))))))
|
||||
|
||||
|
||||
(defn emit-convenience-entity-field
|
||||
[field entity application]
|
||||
(str
|
||||
(s/join
|
||||
" ||', '|| "
|
||||
(compose-convenience-entity-field field entity application))
|
||||
" AS "
|
||||
(field-name field)
|
||||
(s/join
|
||||
" ||', '|| "
|
||||
(compose-convenience-entity-field field entity application))
|
||||
" AS "
|
||||
(field-name field)
|
||||
"_expanded"))
|
||||
|
||||
|
||||
|
|
@ -346,7 +346,7 @@
|
|||
(safe-name (first (key-names farside)) :sql))))
|
||||
entity-fields))))
|
||||
";"
|
||||
(emit-permissions-grant view-name :SELECT (permissions entity application))))))))
|
||||
(emit-permissions-grant view-name :SELECT (find-permissions entity application))))))))
|
||||
|
||||
|
||||
(defn emit-referential-integrity-link
|
||||
|
|
@ -354,45 +354,45 @@
|
|||
(let
|
||||
[farside (entity-for-property property application)]
|
||||
(s/join
|
||||
" "
|
||||
(list
|
||||
"ALTER TABLE"
|
||||
(safe-name (:name (:attrs nearside)) :sql)
|
||||
"ADD CONSTRAINT"
|
||||
(safe-name (str "ri_" (:name (:attrs nearside)) "_" (:name (:attrs farside)) "_" (:name (:attrs property))) :sql)
|
||||
"\n\tFOREIGN KEY("
|
||||
(field-name property)
|
||||
") \n\tREFERENCES"
|
||||
(str
|
||||
(safe-name (:table (:attrs farside)) :sql)
|
||||
"(" (field-name (first (key-properties farside))) ")")
|
||||
;; TODO: ought to handle the `cascade` attribute, even though it's rarely used
|
||||
"\n\tON DELETE"
|
||||
(case
|
||||
(:cascade (:attrs property))
|
||||
"orphan" "SET NULL"
|
||||
"delete" "CASCADE"
|
||||
"NO ACTION")
|
||||
";"))))
|
||||
" "
|
||||
(list
|
||||
"ALTER TABLE"
|
||||
(safe-name (:name (:attrs nearside)) :sql)
|
||||
"ADD CONSTRAINT"
|
||||
(safe-name (str "ri_" (:name (:attrs nearside)) "_" (:name (:attrs farside)) "_" (:name (:attrs property))) :sql)
|
||||
"\n\tFOREIGN KEY("
|
||||
(field-name property)
|
||||
") \n\tREFERENCES"
|
||||
(str
|
||||
(safe-name (:table (:attrs farside)) :sql)
|
||||
"(" (field-name (first (key-properties farside))) ")")
|
||||
;; TODO: ought to handle the `cascade` attribute, even though it's rarely used
|
||||
"\n\tON DELETE"
|
||||
(case
|
||||
(:cascade (:attrs property))
|
||||
"orphan" "SET NULL"
|
||||
"delete" "CASCADE"
|
||||
"NO ACTION")
|
||||
";"))))
|
||||
|
||||
|
||||
(defn emit-referential-integrity-links
|
||||
([entity application]
|
||||
(map
|
||||
#(emit-referential-integrity-link % entity application)
|
||||
(sort-by-name
|
||||
(filter
|
||||
#(= (:type (:attrs %)) "entity")
|
||||
(properties entity)))))
|
||||
#(emit-referential-integrity-link % entity application)
|
||||
(sort-by-name
|
||||
(filter
|
||||
#(= (:type (:attrs %)) "entity")
|
||||
(properties entity)))))
|
||||
([application]
|
||||
(flatten
|
||||
(list
|
||||
(emit-header
|
||||
"--"
|
||||
"referential integrity links for primary tables")
|
||||
(map
|
||||
#(emit-referential-integrity-links % application)
|
||||
(sort-by-name (children-with-tag application :entity)))))))
|
||||
(list
|
||||
(emit-header
|
||||
"--"
|
||||
"referential integrity links for primary tables")
|
||||
(map
|
||||
#(emit-referential-integrity-links % application)
|
||||
(sort-by-name (children-with-tag application :entity)))))))
|
||||
|
||||
|
||||
(defn emit-table
|
||||
|
|
@ -400,48 +400,48 @@
|
|||
(let [table-name (safe-name (:table (:attrs entity)) :sql)
|
||||
permissions (children-with-tag entity :permission)]
|
||||
(s/join
|
||||
"\n"
|
||||
(flatten
|
||||
(list
|
||||
(emit-header
|
||||
"--"
|
||||
"\n"
|
||||
(flatten
|
||||
(list
|
||||
doc-comment
|
||||
(map
|
||||
#(:content %)
|
||||
(children-with-tag entity :documentation))))
|
||||
(s/join
|
||||
" "
|
||||
(list "CREATE TABLE" table-name))
|
||||
"("
|
||||
(str
|
||||
(s/join
|
||||
",\n"
|
||||
(flatten
|
||||
(remove
|
||||
nil?
|
||||
(list
|
||||
(map
|
||||
#(emit-property % entity application true)
|
||||
(children-with-tag (child-with-tag entity :key) :property))
|
||||
(map
|
||||
#(emit-property % entity application false)
|
||||
(filter
|
||||
#(not (= (:type (:attrs %)) "link"))
|
||||
(children-with-tag entity :property)))))))
|
||||
"\n);")
|
||||
(map
|
||||
#(emit-permissions-grant table-name % permissions)
|
||||
'(:SELECT :INSERT :UPDATE :DELETE)))))))
|
||||
(emit-header
|
||||
"--"
|
||||
(list
|
||||
doc-comment
|
||||
(map
|
||||
#(:content %)
|
||||
(children-with-tag entity :documentation))))
|
||||
(s/join
|
||||
" "
|
||||
(list "CREATE TABLE" table-name))
|
||||
"("
|
||||
(str
|
||||
(s/join
|
||||
",\n"
|
||||
(flatten
|
||||
(remove
|
||||
nil?
|
||||
(list
|
||||
(map
|
||||
#(emit-property % entity application true)
|
||||
(children-with-tag (child-with-tag entity :key) :property))
|
||||
(map
|
||||
#(emit-property % entity application false)
|
||||
(filter
|
||||
#(not (= (:type (:attrs %)) "link"))
|
||||
(children-with-tag entity :property)))))))
|
||||
"\n);")
|
||||
(map
|
||||
#(emit-permissions-grant table-name % permissions)
|
||||
'(:SELECT :INSERT :UPDATE :DELETE)))))))
|
||||
([entity application]
|
||||
(emit-table
|
||||
entity
|
||||
application
|
||||
(str
|
||||
"primary table "
|
||||
(:table (:attrs entity))
|
||||
" for entity "
|
||||
(:name (:attrs entity))))))
|
||||
entity
|
||||
application
|
||||
(str
|
||||
"primary table "
|
||||
(:table (:attrs entity))
|
||||
" for entity "
|
||||
(:name (:attrs entity))))))
|
||||
|
||||
|
||||
(defn construct-link-property
|
||||
|
|
@ -457,117 +457,129 @@
|
|||
(defn emit-link-table
|
||||
[property e1 application emitted-link-tables]
|
||||
(let [e2 (child
|
||||
application
|
||||
#(and
|
||||
(entity? %)
|
||||
(= (:name (:attrs %)) (:entity (:attrs property)))))
|
||||
application
|
||||
#(and
|
||||
(entity? %)
|
||||
(= (:name (:attrs %)) (:entity (:attrs property)))))
|
||||
link-table-name (link-table-name e1 e2)]
|
||||
(if
|
||||
;; we haven't already emitted this one...
|
||||
(not (@emitted-link-tables link-table-name))
|
||||
(let [permissions (flatten
|
||||
(list
|
||||
(children-with-tag e1 :permission)
|
||||
(children-with-tag e1 :permission)))
|
||||
(list
|
||||
(children-with-tag e1 :permission)
|
||||
(children-with-tag e1 :permission)))
|
||||
;; construct a dummy entity
|
||||
link-entity {:tag :entity
|
||||
:attrs {:name link-table-name
|
||||
:table link-table-name}
|
||||
:content
|
||||
(apply vector
|
||||
(flatten
|
||||
(list
|
||||
[(construct-link-property e1)
|
||||
(construct-link-property e2)]
|
||||
permissions)))}]
|
||||
(apply vector
|
||||
(flatten
|
||||
(list
|
||||
[(construct-link-property e1)
|
||||
(construct-link-property e2)]
|
||||
permissions)))}]
|
||||
;; mark it as emitted
|
||||
(swap! emitted-link-tables conj link-table-name)
|
||||
;; emit it
|
||||
(flatten
|
||||
(list
|
||||
(emit-table
|
||||
link-entity
|
||||
application
|
||||
(str
|
||||
"link table joining "
|
||||
(:name (:attrs e1))
|
||||
" with "
|
||||
(:name (:attrs e2))))
|
||||
;; and immediately emit its referential integrity links
|
||||
(emit-referential-integrity-links link-entity application)))))))
|
||||
(list
|
||||
(emit-table
|
||||
link-entity
|
||||
application
|
||||
(str
|
||||
"link table joining "
|
||||
(:name (:attrs e1))
|
||||
" with "
|
||||
(:name (:attrs e2))))
|
||||
;; and immediately emit its referential integrity links
|
||||
(emit-referential-integrity-links link-entity application)))))))
|
||||
|
||||
|
||||
(defn emit-link-tables
|
||||
([entity application emitted-link-tables]
|
||||
(map
|
||||
#(emit-link-table % entity application emitted-link-tables)
|
||||
(sort-by-name
|
||||
(filter
|
||||
#(= (:type (:attrs %)) "link")
|
||||
(properties entity)))))
|
||||
(map
|
||||
#(emit-link-table % entity application emitted-link-tables)
|
||||
(sort-by-name
|
||||
(filter
|
||||
#(= (:type (:attrs %)) "link")
|
||||
(properties entity)))))
|
||||
([application emitted-link-tables]
|
||||
(map
|
||||
#(emit-link-tables % application emitted-link-tables)
|
||||
(sort-by-name (children-with-tag application :entity)))))
|
||||
#(emit-link-tables % application emitted-link-tables)
|
||||
(sort-by-name (children-with-tag application :entity)))))
|
||||
|
||||
|
||||
(defn emit-group-declaration
|
||||
[group application]
|
||||
(list
|
||||
(emit-header
|
||||
"--"
|
||||
(str "security group " (:name (:attrs group))))
|
||||
(str "CREATE GROUP " (safe-name (:name (:attrs group)) :sql) ";")))
|
||||
(emit-header
|
||||
"--"
|
||||
(str "security group " (:name (:attrs group))))
|
||||
(str "CREATE GROUP " (safe-name (:name (:attrs group)) :sql) ";")))
|
||||
|
||||
|
||||
(defn emit-file-header
|
||||
[application]
|
||||
(emit-header
|
||||
"--"
|
||||
"Database definition for application "
|
||||
(str (:name (:attrs application))
|
||||
" version "
|
||||
(:version (:attrs application)))
|
||||
"auto-generated by [Application Description Language framework]"
|
||||
(str "(https://github.com/simon-brooke/adl) at "
|
||||
(f/unparse (f/formatters :basic-date-time) (t/now)))
|
||||
(map
|
||||
#(:content %)
|
||||
(children-with-tag application :documentation))))
|
||||
"--"
|
||||
"Database definition for application "
|
||||
(str (:name (:attrs application))
|
||||
" version "
|
||||
(:version (:attrs application)))
|
||||
"auto-generated by [Application Description Language framework]"
|
||||
(str "(https://github.com/simon-brooke/adl) at "
|
||||
(f/unparse (f/formatters :basic-date-time) (t/now)))
|
||||
(map
|
||||
#(:content %)
|
||||
(children-with-tag application :documentation))))
|
||||
|
||||
|
||||
(defn emit-application
|
||||
[application]
|
||||
(let [emitted-link-tables (atom #{})]
|
||||
(s/join
|
||||
"\n\n"
|
||||
(flatten
|
||||
(list
|
||||
(emit-file-header application)
|
||||
(map
|
||||
#(emit-group-declaration % application)
|
||||
(sort-by-name
|
||||
(children-with-tag application :group)))
|
||||
(map
|
||||
#(emit-table % application)
|
||||
(sort-by-name
|
||||
(children-with-tag application :entity)))
|
||||
(map
|
||||
#(emit-convenience-view % application)
|
||||
(sort-by-name
|
||||
(children-with-tag application :entity)))
|
||||
(emit-referential-integrity-links application)
|
||||
(emit-link-tables application emitted-link-tables))))))
|
||||
"\n\n"
|
||||
(flatten
|
||||
(list
|
||||
(emit-file-header application)
|
||||
(map
|
||||
#(emit-group-declaration % application)
|
||||
(sort-by-name
|
||||
(children-with-tag application :group)))
|
||||
(map
|
||||
#(emit-table % application)
|
||||
(sort-by-name
|
||||
(children-with-tag application :entity)))
|
||||
(map
|
||||
#(emit-convenience-view % application)
|
||||
(sort-by-name
|
||||
(children-with-tag application :entity)))
|
||||
(emit-referential-integrity-links application)
|
||||
(emit-link-tables application emitted-link-tables))))))
|
||||
|
||||
|
||||
(defn to-psql
|
||||
[application]
|
||||
(let [filepath (str
|
||||
*output-path*
|
||||
"/resources/sql/"
|
||||
(:name (:attrs application))
|
||||
".postgres.sql")]
|
||||
*output-path*
|
||||
"resources/sql/"
|
||||
(:name (:attrs application))
|
||||
".postgres.sql")]
|
||||
(make-parents filepath)
|
||||
(spit filepath (emit-application application))))
|
||||
(try
|
||||
(spit filepath (emit-application application))
|
||||
(if (> *verbosity* 0)
|
||||
(println (str "\tGenerated " filepath)))
|
||||
(catch
|
||||
Exception any
|
||||
(println
|
||||
(str
|
||||
"ERROR: Exception "
|
||||
(.getName (.getClass any))
|
||||
(.getMessage any)
|
||||
" while printing "
|
||||
filepath))))))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
(ns adl.to-reframe
|
||||
(:require [adl.utils :refer :all]
|
||||
(:require [adl-support.utils :refer :all]
|
||||
[clojure.string :as s]
|
||||
[clj-time.core :as t]
|
||||
[clj-time.format :as f]))
|
||||
|
|
@ -27,6 +27,9 @@
|
|||
;;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;; TODO: not anywhere near finished.
|
||||
|
||||
|
||||
(defn file-header
|
||||
([parent-name this-name extra-requires]
|
||||
(list 'ns (symbol (str parent-name ".views." this-name))
|
||||
|
|
|
|||
|
|
@ -1,13 +1,14 @@
|
|||
(ns ^{:doc "Application Description Language: generate routes for user interface requests."
|
||||
:author "Simon Brooke"}
|
||||
adl.to-selmer-routes
|
||||
(:require [clojure.java.io :refer [file make-parents writer]]
|
||||
(:require [adl-support.utils :refer :all]
|
||||
[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]
|
||||
[adl.utils :refer :all]))
|
||||
))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;;;
|
||||
|
|
@ -32,7 +33,11 @@
|
|||
;;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;; Generally. there's one route in the generated file for each Selmer template which has been generated.
|
||||
;;; 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.
|
||||
|
||||
(defn file-header
|
||||
[application]
|
||||
|
|
@ -44,6 +49,7 @@
|
|||
(f/unparse (f/formatters :basic-date-time) (t/now)))
|
||||
(list
|
||||
:require
|
||||
'[adl-support.core :as support]
|
||||
'[clojure.java.io :as io]
|
||||
'[compojure.core :refer [defroutes GET POST]]
|
||||
'[hugsql.core :as hugsql]
|
||||
|
|
@ -61,25 +67,39 @@
|
|||
'defn
|
||||
(symbol n)
|
||||
(vector 'r)
|
||||
(list 'let (vector 'p (list :params 'r)) ;; TODO: we must take key params out of just params,
|
||||
(list 'let (vector
|
||||
'p
|
||||
(list
|
||||
'merge
|
||||
(list 'support/query-string-to-map (list :query-string 'r))
|
||||
(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 'resolve-template (str n ".html"))
|
||||
(list 'support/resolve-template (str n ".html"))
|
||||
(merge
|
||||
{:title (capitalise (:name (:attrs f)))
|
||||
:params 'p}
|
||||
(case (:tag f)
|
||||
(:form :page)
|
||||
{:record
|
||||
(list 'if (list 'empty? (list 'remove 'nil? (list 'vals 'p))) []
|
||||
(list
|
||||
(symbol
|
||||
(str "db/get-" (singularise (:name (:attrs e)))))
|
||||
(symbol "db/*db*")
|
||||
'p))}
|
||||
(reduce
|
||||
merge
|
||||
{:record
|
||||
(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 #(= (:type (:attrs %)) "entity") (descendants-with-tag e :property))))
|
||||
:list
|
||||
{:records
|
||||
(list
|
||||
|
|
@ -167,43 +187,49 @@
|
|||
|
||||
(defn to-selmer-routes
|
||||
[application]
|
||||
(let [filename (str *output-path* (:name (:attrs application)) "/routes/auto.clj")]
|
||||
(make-parents filename)
|
||||
(with-open [output (writer filename)]
|
||||
(binding [*out* output]
|
||||
(pprint (file-header application))
|
||||
(println)
|
||||
(pprint '(defn raw-resolve-template [n]
|
||||
(if
|
||||
(.exists (io/as-file (str "resources/templates/" n)))
|
||||
n
|
||||
(str "auto/" n))))
|
||||
(println)
|
||||
(pprint '(def resolve-template (memoize raw-resolve-template)))
|
||||
(println)
|
||||
(pprint '(defn index
|
||||
[r]
|
||||
(l/render
|
||||
(resolve-template
|
||||
"application-index.html")
|
||||
{: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)))))
|
||||
(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)))))
|
||||
(let [filepath (str *output-path* "src/clj/" (:name (:attrs application)) "/routes/auto.clj")]
|
||||
(make-parents filepath)
|
||||
(try
|
||||
(with-open [output (writer filepath)]
|
||||
(binding [*out* output]
|
||||
(pprint (file-header application))
|
||||
(println)
|
||||
(pprint '(defn admin
|
||||
[r]
|
||||
(l/render
|
||||
(support/resolve-template
|
||||
"application-index.html")
|
||||
{: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))))
|
||||
(pprint
|
||||
(generate-handler-resolver application))
|
||||
(println)
|
||||
(pprint '(def resolve-handler
|
||||
(memoize raw-resolve-handler)))
|
||||
(println)
|
||||
(pprint (make-defroutes application))
|
||||
(println)))
|
||||
(if (> *verbosity* 0)
|
||||
(println (str "\tGenerated " filepath)))
|
||||
(catch
|
||||
Exception any
|
||||
(println
|
||||
(str
|
||||
"ERROR: Exception "
|
||||
(.getName (.getClass any))
|
||||
(.getMessage any)
|
||||
" while printing "
|
||||
filepath))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
(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.utils :refer :all]
|
||||
[clojure.java.io :refer [file]]
|
||||
(:require [adl-support.utils :refer :all]
|
||||
[clojure.java.io :refer [file make-parents]]
|
||||
[clojure.pprint :as p]
|
||||
[clojure.string :as s]
|
||||
[clojure.xml :as x]
|
||||
|
|
@ -145,7 +145,8 @@
|
|||
|
||||
(defn save-widget
|
||||
"Return an appropriate 'save' widget for this `form` operating on this `entity` taken
|
||||
from this `application`."
|
||||
from this `application`.
|
||||
TODO: should be suppressed unless a member of a group which can insert or edit."
|
||||
[form entity application]
|
||||
{:tag :p
|
||||
:attrs {:class "widget action-safe"}
|
||||
|
|
@ -156,13 +157,14 @@
|
|||
:attrs {:id "save-button"
|
||||
:name "save-button"
|
||||
:class "action-safe"
|
||||
:type :submit
|
||||
:type "submit"
|
||||
:value (str "Save!")}}]})
|
||||
|
||||
|
||||
(defn delete-widget
|
||||
"Return an appropriate 'save' widget for this `form` operating on this `entity` taken
|
||||
from this `application`."
|
||||
from this `application`.
|
||||
TODO: should be suppressed unless member of a group which can delete."
|
||||
[form entity application]
|
||||
{:tag :p
|
||||
:attrs {:class "widget action-dangerous"}
|
||||
|
|
@ -173,7 +175,7 @@
|
|||
:attrs {:id "delete-button"
|
||||
:name "delete-button"
|
||||
:class "action-dangerous"
|
||||
:type :submit
|
||||
:type "submit"
|
||||
:value (str "Delete!")}}]})
|
||||
|
||||
|
||||
|
|
@ -259,21 +261,10 @@
|
|||
:content (apply vector (get-options property form entity application))})))}))
|
||||
|
||||
|
||||
(defn permissions-for
|
||||
[property entity application]
|
||||
(first
|
||||
(remove
|
||||
empty?
|
||||
(list
|
||||
(children-with-tag property :permission)
|
||||
(children-with-tag entity :permission)
|
||||
(children-with-tag application :permission)))))
|
||||
|
||||
|
||||
(defn compose-if-member-of-tag
|
||||
[property entity application writable?]
|
||||
(let
|
||||
[all-permissions (permissions-for property entity application)
|
||||
[all-permissions (find-permissions property entity application)
|
||||
permissions (if writable? (writable-by all-permissions) (visible-to all-permissions))]
|
||||
(s/join
|
||||
" "
|
||||
|
|
@ -295,20 +286,18 @@
|
|||
property (if
|
||||
(= (:tag field-or-property) :property)
|
||||
field-or-property
|
||||
(first
|
||||
(children
|
||||
entity
|
||||
#(and
|
||||
(= (:tag %) :property)
|
||||
(= (:name (:attrs %)) (:property (:attrs field-or-property)))))))
|
||||
permissions (permissions property form entity application)
|
||||
(child-with-tag entity
|
||||
:property
|
||||
#(= (:name (:attrs %))
|
||||
(:property (:attrs field-or-property)))))
|
||||
permissions (find-permissions field-or-property property form entity application)
|
||||
typedef (typedef property application)
|
||||
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
|
||||
(formal-primary-key? property entity)
|
||||
(= (:distinct (:attrs property)) "system")
|
||||
{:tag :input
|
||||
:attrs {:id widget-name
|
||||
:name widget-name
|
||||
|
|
@ -343,45 +332,44 @@
|
|||
: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 fields
|
||||
[form]
|
||||
(descendants-with-tag form :field))
|
||||
|
||||
|
||||
|
||||
(defn form-to-template
|
||||
"Generate a template as specified by this `form` element for this `entity`,
|
||||
taken from this `application`. If `form` is nill, generate a default form
|
||||
template for the entity."
|
||||
[form entity application]
|
||||
(let
|
||||
[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
|
||||
{: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)
|
||||
#(widget % form entity application)
|
||||
(children-with-tag (child-with-tag entity :key) :properties))
|
||||
(map
|
||||
#(widget % form entity application)
|
||||
(remove
|
||||
#(= (:distict (:attrs %)) :system)
|
||||
(fields entity)))
|
||||
#(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)))}]}))
|
||||
|
||||
(delete-widget form entity application)))}]})
|
||||
|
||||
|
||||
(defn page-to-template
|
||||
|
|
@ -434,7 +422,7 @@
|
|||
#(hash-map
|
||||
:content [(prompt %)]
|
||||
:tag :th)
|
||||
(fields list-spec)))}
|
||||
(children-with-tag list-spec :field)))}
|
||||
{:tag :tr
|
||||
:content
|
||||
(apply
|
||||
|
|
@ -442,7 +430,7 @@
|
|||
(concat
|
||||
(map
|
||||
#(compose-list-search-widget % entity)
|
||||
(fields list-spec))
|
||||
(children-with-tag list-spec :field))
|
||||
'({:tag :th
|
||||
:content
|
||||
[{:tag :input
|
||||
|
|
@ -492,7 +480,7 @@
|
|||
:attrs {:href (edit-link e application (list (:name (:attrs p))))}
|
||||
:content [(str "{{ record." (:property (:attrs field)) "_expanded }}")]}]
|
||||
[c]))})
|
||||
(fields list-spec))
|
||||
(children-with-tag list-spec :field))
|
||||
[{:tag :td
|
||||
:content
|
||||
[{:tag :a
|
||||
|
|
@ -623,31 +611,35 @@
|
|||
|
||||
(defn write-template-file
|
||||
[filename template application]
|
||||
(if
|
||||
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))))
|
||||
(catch Exception any
|
||||
(let [filepath (str *output-path* "resources/templates/auto/" filename)]
|
||||
(make-parents filepath)
|
||||
(if
|
||||
template
|
||||
(try
|
||||
(spit
|
||||
(str *output-path* filename)
|
||||
(with-out-str
|
||||
(println
|
||||
(str
|
||||
"<!-- Exception "
|
||||
(.getName (.getClass any))
|
||||
(.getMessage any)
|
||||
" while printing "
|
||||
filename "-->"))
|
||||
(p/pprint template))))))
|
||||
filename)
|
||||
filepath
|
||||
(s/join
|
||||
"\n"
|
||||
(list
|
||||
(file-header filename application)
|
||||
(with-out-str
|
||||
(x/emit-element 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 "<!-- " report "-->"))
|
||||
(p/pprint template)))
|
||||
(println report)))))
|
||||
(str filepath)))
|
||||
|
||||
|
||||
(defn to-selmer-templates
|
||||
|
|
@ -668,12 +660,13 @@
|
|||
(try
|
||||
(write-template-file filename (templates-map %) application)
|
||||
(catch Exception any
|
||||
(str
|
||||
"Exception "
|
||||
(.getName (.getClass any))
|
||||
(.getMessage any)
|
||||
" while writing "
|
||||
filename)))))
|
||||
(println
|
||||
(str
|
||||
"ERROR: Exception "
|
||||
(.getName (.getClass any))
|
||||
(.getMessage any)
|
||||
" while writing "
|
||||
filename))))))
|
||||
(keys templates-map)))))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,457 +0,0 @@
|
|||
(ns ^{:doc "Application Description Language - utility functions."
|
||||
:author "Simon Brooke"}
|
||||
adl.utils
|
||||
(:require [clojure.string :as s]
|
||||
[clojure.pprint :as p]
|
||||
[clojure.xml :as x]
|
||||
[adl.validator :refer [valid-adl? validate-adl]]))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;;;
|
||||
;;;; adl.utils: utility functions.
|
||||
;;;;
|
||||
;;;; This program is free software; you can redistribute it and/or
|
||||
;;;; modify it under the terms of the GNU General Public License
|
||||
;;;; as published by the Free Software Foundation; either version 2
|
||||
;;;; of the License, or (at your option) any later version.
|
||||
;;;;
|
||||
;;;; This program is distributed in the hope that it will be useful,
|
||||
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;;;; GNU General Public License for more details.
|
||||
;;;;
|
||||
;;;; You should have received a copy of the GNU General Public License
|
||||
;;;; along with this program; if not, write to the Free Software
|
||||
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
|
||||
;;;; USA.
|
||||
;;;;
|
||||
;;;; Copyright (C) 2018 Simon Brooke
|
||||
;;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
||||
(def ^:dynamic *locale*
|
||||
"The locale for which files will be generated."
|
||||
"en-GB")
|
||||
|
||||
(def ^:dynamic *output-path*
|
||||
"The path to which generated files will be written."
|
||||
"resources/auto/")
|
||||
|
||||
|
||||
(defn element?
|
||||
"True if `o` is a Clojure representation of an XML element."
|
||||
[o]
|
||||
(and (map? o) (:tag o) (:attrs o)))
|
||||
|
||||
|
||||
(defn wrap-lines
|
||||
"Wrap lines in this `text` to this `width`; return a list of lines."
|
||||
;; Shamelessly adapted from https://www.rosettacode.org/wiki/Word_wrap#Clojure
|
||||
[width text]
|
||||
(s/split-lines
|
||||
(p/cl-format
|
||||
nil
|
||||
(str "~{~<~%~1," width ":;~A~> ~}")
|
||||
(clojure.string/split text #" "))))
|
||||
|
||||
|
||||
(defn emit-header
|
||||
"Emit this `content` as a sequence of wrapped lines each prefixed with
|
||||
`prefix`, and the whole delimited by rules."
|
||||
[prefix & content]
|
||||
(let [comment-rule (apply str (repeat 70 (last prefix)))
|
||||
p (str "\n" prefix "\t") ]
|
||||
(str
|
||||
prefix
|
||||
comment-rule
|
||||
p
|
||||
(s/join
|
||||
p
|
||||
(flatten
|
||||
(interpose
|
||||
""
|
||||
(map
|
||||
#(wrap-lines 70 (str %))
|
||||
(flatten content)))))
|
||||
"\n"
|
||||
prefix
|
||||
comment-rule)))
|
||||
|
||||
|
||||
(defn sort-by-name
|
||||
[elements]
|
||||
(sort #(compare (:name (:attrs %1)) (:name (:attrs %2))) elements))
|
||||
|
||||
|
||||
(defn link-table-name
|
||||
"Canonical name of a link table between entity `e1` and entity `e2`."
|
||||
[e1 e2]
|
||||
(s/join
|
||||
"_"
|
||||
(cons
|
||||
"ln"
|
||||
(sort
|
||||
(list
|
||||
(:name (:attrs e1)) (:name (:attrs e2)))))))
|
||||
|
||||
|
||||
(defn children
|
||||
"Return the children of this `element`; if `predicate` is passed, return only those
|
||||
children satisfying the predicate."
|
||||
([element]
|
||||
(if
|
||||
(keyword? (:tag element)) ;; it has a tag; it seems to be an XML element
|
||||
(:content element)))
|
||||
([element predicate]
|
||||
(filter
|
||||
predicate
|
||||
(children element))))
|
||||
|
||||
|
||||
(defn child
|
||||
"Return the first child of this `element` satisfying this `predicate`."
|
||||
[element predicate]
|
||||
(first (children element predicate)))
|
||||
|
||||
|
||||
(defn attributes
|
||||
"Return the attributes of this `element`; if `predicate` is passed, return only those
|
||||
attributes satisfying the predicate."
|
||||
([element]
|
||||
(if
|
||||
(keyword? (:tag element)) ;; it has a tag; it seems to be an XML element
|
||||
(:attrs element)))
|
||||
([element predicate]
|
||||
(filter
|
||||
predicate
|
||||
(attributes element))))
|
||||
|
||||
|
||||
(defn typedef
|
||||
"If this `property` is of type `defined`, return its type definition from
|
||||
this `application`, else nil."
|
||||
[property application]
|
||||
(if
|
||||
(= (:type (:attrs property)) "defined")
|
||||
(child
|
||||
application
|
||||
#(and
|
||||
(= (:tag %) :typedef)
|
||||
(= (:name (:attrs %)) (:typedef (:attrs property)))))))
|
||||
|
||||
|
||||
(defn permissions
|
||||
"Return appropriate permissions of this `property`, taken from this `entity` of this
|
||||
`application`, in the context of this `page`."
|
||||
([property page entity application]
|
||||
(first
|
||||
(remove
|
||||
empty?
|
||||
(list
|
||||
(children page #(= (:tag %) :permission))
|
||||
(children property #(= (:tag %) :permission))
|
||||
(children entity #(= (:tag %) :permission))
|
||||
(children application #(= (:tag %) :permission))))))
|
||||
([property entity application]
|
||||
(permissions property nil entity application))
|
||||
([entity application]
|
||||
(permissions nil nil entity application)))
|
||||
|
||||
|
||||
(defn permission-groups
|
||||
"Return a list of names of groups to which this `predicate` is true of
|
||||
some permission taken from these `permissions`, else nil."
|
||||
[permissions predicate]
|
||||
(let [groups (remove
|
||||
nil?
|
||||
(map
|
||||
#(if
|
||||
(apply predicate (list %))
|
||||
(:group (:attrs %)))
|
||||
permissions))]
|
||||
(if groups groups)))
|
||||
|
||||
|
||||
(defn formal-primary-key?
|
||||
"Does this `prop-or-name` appear to be a property (or the name of a property)
|
||||
which is a formal primary key of this entity?"
|
||||
[prop-or-name entity]
|
||||
(if
|
||||
(map? prop-or-name)
|
||||
(formal-primary-key? (:name (:attrs prop-or-name)) entity)
|
||||
(let [primary-key (first (children entity #(= (:tag %) :key)))
|
||||
property (first
|
||||
(children
|
||||
primary-key
|
||||
#(and
|
||||
(= (:tag %) :property)
|
||||
(= (:name (:attrs %)) prop-or-name))))]
|
||||
(= (:distinct (:attrs property)) "system"))))
|
||||
|
||||
|
||||
(defn entity?
|
||||
"Return true if `x` is an ADL entity."
|
||||
[x]
|
||||
(= (:tag x) :entity))
|
||||
|
||||
|
||||
(defn property?
|
||||
"True if `o` is a property."
|
||||
[o]
|
||||
(= (:tag o) :property))
|
||||
|
||||
|
||||
(defn entity-for-property
|
||||
"If this `property` references an entity, return that entity from this `application`"
|
||||
[property application]
|
||||
(if
|
||||
(and (property? property) (:entity (:attrs property)))
|
||||
(child
|
||||
application
|
||||
#(and
|
||||
(entity? %)
|
||||
(= (:name (:attrs %))(:entity (:attrs property)))))))
|
||||
|
||||
|
||||
(defn visible-to
|
||||
"Return a list of names of groups to which are granted read access,
|
||||
given these `permissions`, else nil."
|
||||
[permissions]
|
||||
(permission-groups permissions #(#{"read" "insert" "noedit" "edit" "all"} (:permission (:attrs %)))))
|
||||
|
||||
|
||||
(defn writable-by
|
||||
"Return a list of names of groups to which are granted write access,
|
||||
given these `permissions`, else nil.
|
||||
TODO: TOTHINKABOUT: properties are also writable by `insert` and `noedit`, but only if the
|
||||
current value is nil."
|
||||
[permissions]
|
||||
(permission-groups permissions #(#{"edit" "all"} (:permission (:attrs %)))))
|
||||
|
||||
|
||||
(defn singularise
|
||||
"Attempt to construct an idiomatic English-language singular of this string."
|
||||
[string]
|
||||
(cond
|
||||
(.endsWith string "ss") string
|
||||
(.endsWith string "ise") string
|
||||
true
|
||||
(s/replace
|
||||
(s/replace
|
||||
(s/replace
|
||||
(s/replace string #"_" "-")
|
||||
#"s$" "")
|
||||
#"se$" "s")
|
||||
#"ie$" "y")))
|
||||
|
||||
|
||||
(defn capitalise
|
||||
"Return a string like `s` but with each token capitalised."
|
||||
[s]
|
||||
(s/join
|
||||
" "
|
||||
(map
|
||||
#(apply str (cons (Character/toUpperCase (first %)) (rest %)))
|
||||
(s/split s #"[ \t\r\n]+"))))
|
||||
|
||||
|
||||
(defn pretty-name
|
||||
[entity]
|
||||
(capitalise (singularise (:name (:attrs entity)))))
|
||||
|
||||
|
||||
(defn safe-name
|
||||
"Return a safe name for the object `o`, given the specified `convention`.
|
||||
`o` is expected to be either a string or an entity."
|
||||
([o]
|
||||
(if
|
||||
(element? o)
|
||||
(safe-name (:name (:attrs o)))
|
||||
(s/replace (str o) #"[^a-zA-Z0-9-]" "")))
|
||||
([o convention]
|
||||
(if
|
||||
(element? o)
|
||||
(safe-name (:name (:attrs o)) convention)
|
||||
(let [string (str o)]
|
||||
(case convention
|
||||
(:sql :c) (s/replace string #"[^a-zA-Z0-9_]" "_")
|
||||
:c-sharp (s/replace (capitalise string) #"[^a-zA-Z0-9]" "")
|
||||
:java (let
|
||||
[camel (s/replace (capitalise string) #"[^a-zA-Z0-9]" "")]
|
||||
(apply str (cons (Character/toLowerCase (first camel)) (rest camel))))
|
||||
(safe-name string))))))
|
||||
|
||||
|
||||
(defn read-adl [url]
|
||||
(let [adl (x/parse url)
|
||||
valid? (valid-adl? adl)]
|
||||
(if valid? adl
|
||||
(throw (Exception. (str (validate-adl adl)))))))
|
||||
|
||||
|
||||
(defn children-with-tag
|
||||
"Return all children of this `element` which have this `tag`;
|
||||
if `element` is `nil`, return `nil`."
|
||||
[element tag]
|
||||
(if
|
||||
element
|
||||
(children element #(= (:tag %) tag))))
|
||||
|
||||
|
||||
(defn child-with-tag
|
||||
"Return the first child of this `element` which has this `tag`;
|
||||
if `element` is `nil`, return `nil`."
|
||||
[element tag]
|
||||
(first (children-with-tag element tag)))
|
||||
|
||||
|
||||
(defmacro properties
|
||||
"Return all the properties of this `entity`."
|
||||
[entity]
|
||||
`(children-with-tag ~entity :property))
|
||||
|
||||
|
||||
(defn descendants-with-tag
|
||||
"Return all descendants of this `element`, recursively, which have this `tag`."
|
||||
[element tag]
|
||||
(flatten
|
||||
(remove
|
||||
empty?
|
||||
(cons
|
||||
(children element #(= (:tag %) tag))
|
||||
(map
|
||||
#(descendants-with-tag % tag)
|
||||
(children element))))))
|
||||
|
||||
|
||||
(defn insertable?
|
||||
"Return `true` it the value of this `property` may be set from user-supplied data."
|
||||
[property]
|
||||
(and
|
||||
(= (:tag property) :property)
|
||||
(not (#{"link"} (:type (:attrs property))))
|
||||
(not (= (:distinct (:attrs property)) "system"))))
|
||||
|
||||
|
||||
(defmacro all-properties
|
||||
"Return all properties of this `entity` (including key properties)."
|
||||
[entity]
|
||||
`(descendants-with-tag ~entity :property))
|
||||
|
||||
|
||||
(defn user-distinct-properties
|
||||
"Return the properties of this `entity` which are user distinct"
|
||||
[entity]
|
||||
(filter #(#{"user" "all"} (:distinct (:attrs %))) (all-properties entity)))
|
||||
|
||||
|
||||
(defmacro insertable-properties
|
||||
"Return all the properties of this `entity` (including key properties) into
|
||||
which user-supplied data can be inserted"
|
||||
[entity]
|
||||
`(filter
|
||||
insertable?
|
||||
(all-properties ~entity)))
|
||||
|
||||
|
||||
(defmacro key-properties
|
||||
[entity]
|
||||
`(children-with-tag (first (children-with-tag ~entity :key)) :property))
|
||||
|
||||
|
||||
(defmacro insertable-key-properties
|
||||
[entity]
|
||||
`(filter insertable? (key-properties entity)))
|
||||
|
||||
|
||||
(defn link-table?
|
||||
"Return true if this `entity` represents a link table."
|
||||
[entity]
|
||||
(let [properties (all-properties entity)
|
||||
links (filter #(-> % :attrs :entity) properties)]
|
||||
(= (count properties) (count links))))
|
||||
|
||||
|
||||
(defn key-names [entity]
|
||||
(remove
|
||||
nil?
|
||||
(map
|
||||
#(:name (:attrs %))
|
||||
(key-properties entity))))
|
||||
|
||||
|
||||
(defn base-type
|
||||
[property application]
|
||||
(cond
|
||||
(:typedef (:attrs property))
|
||||
(:type
|
||||
(:attrs
|
||||
(child
|
||||
application
|
||||
#(and
|
||||
(= (:tag %) :typedef)
|
||||
(= (:name (:attrs %)) (:typedef (:attrs property)))))))
|
||||
(:entity (:attrs property))
|
||||
(:type
|
||||
(:attrs
|
||||
(first
|
||||
(key-properties
|
||||
(child
|
||||
application
|
||||
#(and
|
||||
(= (:tag %) :entity)
|
||||
(= (:name (:attrs %)) (:entity (:attrs property)))))))))
|
||||
true
|
||||
(:type (:attrs property))))
|
||||
|
||||
|
||||
(defn is-quotable-type?
|
||||
"True if the value for this field should be quoted."
|
||||
[property application]
|
||||
(#{"date" "image" "string" "text" "time" "timestamp" "uploadable"} (base-type property application)))
|
||||
|
||||
|
||||
(defn has-primary-key? [entity]
|
||||
(> (count (key-names entity)) 0))
|
||||
|
||||
|
||||
(defn has-non-key-properties? [entity]
|
||||
(>
|
||||
(count (all-properties entity))
|
||||
(count (key-properties entity))))
|
||||
|
||||
|
||||
(defn distinct-properties
|
||||
[entity]
|
||||
(filter
|
||||
#(#{"system" "all"} (:distinct (:attrs %)))
|
||||
(properties entity)))
|
||||
|
||||
(defn path-part
|
||||
"Return the URL path part for this `form` of this `entity` within this `application`.
|
||||
Note that `form` may be a Clojure XML representation of a `form`, `list` or `page`
|
||||
ADL element, or may be one of the keywords `:form`, `:list`, `:page` in which case the
|
||||
first child of the `entity` of the specified type will be used."
|
||||
[form entity application]
|
||||
(cond
|
||||
(and (map? form) (#{:list :form :page} (:tag form)))
|
||||
(s/join
|
||||
"-"
|
||||
(flatten
|
||||
(list
|
||||
(name (:tag form)) (:name (:attrs entity)) (s/split (:name (:attrs form)) #"[ \n\r\t]+"))))
|
||||
(keyword? form)
|
||||
(path-part (first (children-with-tag entity form)) entity application)))
|
||||
|
||||
|
||||
(defn editor-name
|
||||
"Return the path-part of the editor form for this `entity`. Note:
|
||||
assumes the editor form is the first form listed for the entity."
|
||||
[entity application]
|
||||
(path-part :form entity application))
|
||||
|
||||
|
||||
(defn type-for-defined
|
||||
[property application]
|
||||
(:type (:attrs (typedef property application))))
|
||||
|
|
@ -1,7 +1,9 @@
|
|||
(ns ^{:doc "Application Description Language: validator for ADL structure."
|
||||
:author "Simon Brooke"}
|
||||
adl.validator
|
||||
(:require [clojure.set :refer [union]]
|
||||
(:require [adl-support.utils :refer :all]
|
||||
[clojure.set :refer [union]]
|
||||
[clojure.xml :refer [parse]]
|
||||
[bouncer.core :as b]
|
||||
[bouncer.validators :as v]))
|
||||
|
||||
|
|
@ -28,44 +30,55 @@
|
|||
;;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;; TODO: more work needed; I *think* this is finding spurious errors, and in any
|
||||
;;; case it is failing to usefully locate the errors it is finding, so its
|
||||
;;; diagnostic usefulness is small.
|
||||
|
||||
(defn disjunct-valid?
|
||||
|
||||
(defn try-validate
|
||||
[o validation]
|
||||
(if
|
||||
(symbol? validation)
|
||||
(try
|
||||
(b/validate o validation)
|
||||
(catch java.lang.ClassCastException c
|
||||
;; The validator regularly barfs on strings, which are perfectly
|
||||
;; valid content of some elements. I need a way to validate
|
||||
;; elements where they're not tolerated!
|
||||
(if (string? o) [nil o]))
|
||||
(catch Exception e
|
||||
[{:error (.getName (.getClass e))
|
||||
:message (.getMessage e)
|
||||
:validation validation
|
||||
:context o} o]))
|
||||
[(str "Error: not a symbol" validation) o]))
|
||||
|
||||
(defmacro disjunct-valid?
|
||||
;; Yes, this is a horrible hack. I should be returning the error structure
|
||||
;; not printing it. But I can't see how to make that work with `bouncer`.
|
||||
;; OK, so: most of the validators will (usually) fail, and that's OK. How
|
||||
;; do we identify the one which ought not to have failed?
|
||||
[o & validations]
|
||||
(println
|
||||
`(println
|
||||
(str
|
||||
(if (:tag o) (str "Tag: " (:tag o) "; "))
|
||||
(if (:name (:attrs o)) (str "Name: " (:name (:attrs o)) ";"))
|
||||
(if-not (or (:tag o) (:name (:attrs o))) (str "Context: " o))))
|
||||
(if (:tag ~o) (str "Tag: " (:tag ~o) "; "))
|
||||
(if (:name (:attrs ~o)) (str "Name: " (:name (:attrs ~o)) ";"))
|
||||
(if-not (or (:tag ~o) (:name (:attrs ~o))) (str "Context: " ~o))))
|
||||
|
||||
(let
|
||||
[rs (map
|
||||
#(try
|
||||
(b/validate o %)
|
||||
(catch java.lang.ClassCastException c
|
||||
;; The validator regularly barfs on strings, which are perfectly
|
||||
;; valid content of some elements. I need a way to validate
|
||||
;; elements where they're not tolerated!
|
||||
[nil o])
|
||||
(catch Exception e
|
||||
[{:exception (.getMessage e)
|
||||
:class (type e)
|
||||
:context o} o]))
|
||||
validations)
|
||||
all-candidates (remove nil? (map first rs))
|
||||
suspicious (remove :tag all-candidates)]
|
||||
;; if *any* succeeded, we succeeded
|
||||
;; otherwise, one of these is the valid error - but which? The answer, in my case
|
||||
;; is that if there is any which did not fail on the :tag check, then that is the
|
||||
;; interesting one. But generally?
|
||||
(try
|
||||
(doall (map #(println (str "\tError: " %)) suspicious))
|
||||
(empty? suspicious)
|
||||
(catch Exception _ (println "Error while trying to print errors")
|
||||
true))))
|
||||
`(empty?
|
||||
(remove :tag (remove nil? (map first (map
|
||||
#(try-validate ~o '%)
|
||||
~validations))))))
|
||||
;; ]
|
||||
;; ;; if *any* succeeded, we succeeded
|
||||
;; ;; otherwise, one of these is the valid error - but which? The answer, in my case
|
||||
;; ;; is that if there is any which did not fail on the :tag check, then that is the
|
||||
;; ;; interesting one. But generally?
|
||||
;; (try
|
||||
;; (doall (map #(println (str "ERROR: " %)) suspicious))
|
||||
;; (empty? suspicious)
|
||||
;; (catch Exception _ (println "ERROR while trying to print errors")
|
||||
;; true))))
|
||||
|
||||
|
||||
;;; the remainder of this file is a fairly straight translation of the ADL 1.4 DTD into Clojure
|
||||
|
|
@ -440,14 +453,15 @@
|
|||
[:attrs :column] v/string
|
||||
[:attrs :concrete] [[v/member #{"true", "false"}]]
|
||||
[:attrs :cascade] [[v/member cascade-actions]]
|
||||
:content [[v/every #(disjunct-valid? %
|
||||
documentation-validations
|
||||
generator-validations
|
||||
permission-validations
|
||||
option-validations
|
||||
prompt-validations
|
||||
help-validations
|
||||
ifmissing-validations)]]})
|
||||
;; :content [[v/every #(disjunct-valid? %
|
||||
;; documentation-validations
|
||||
;; generator-validations
|
||||
;; permission-validations
|
||||
;; option-validations
|
||||
;; prompt-validations
|
||||
;; help-validations
|
||||
;; ifmissing-validations)]]
|
||||
})
|
||||
|
||||
|
||||
(def permission-validations
|
||||
|
|
@ -657,3 +671,8 @@
|
|||
|
||||
(defn validate-adl [src]
|
||||
(b/validate src application-validations))
|
||||
|
||||
(defn validate-adl-file [filepath]
|
||||
(validate-adl (parse filepath)))
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue