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"
|
:url "http://example.com/FIXME"
|
||||||
:license {:name "GNU General Public License,version 2.0 or (at your option) any later version"
|
: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"}
|
: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/math.combinatorics "0.1.4"]
|
||||||
|
[org.clojure/tools.cli "0.3.7"]
|
||||||
[bouncer "1.0.1"]
|
[bouncer "1.0.1"]
|
||||||
|
[environ "1.1.0"]
|
||||||
[hiccup "1.0.5"]]
|
[hiccup "1.0.5"]]
|
||||||
:aot [adl.main]
|
:aot [adl.main]
|
||||||
:main adl.main
|
:main adl.main
|
||||||
|
|
|
||||||
|
|
@ -1,13 +1,17 @@
|
||||||
(ns ^{:doc "Application Description Language - command line invocation."
|
(ns ^{:doc "Application Description Language - command line invocation."
|
||||||
:author "Simon Brooke"}
|
:author "Simon Brooke"}
|
||||||
adl.main
|
adl.main
|
||||||
(:require [adl.utils :refer :all]
|
(:require [adl-support.utils :refer :all]
|
||||||
[adl.to-hugsql-queries :as h]
|
[adl.to-hugsql-queries :as h]
|
||||||
[adl.to-json-routes :as j]
|
[adl.to-json-routes :as j]
|
||||||
[adl.to-psql :as p]
|
[adl.to-psql :as p]
|
||||||
[adl.to-selmer-routes :as s]
|
[adl.to-selmer-routes :as s]
|
||||||
[adl.to-selmer-templates :as t]
|
[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))
|
(:gen-class))
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
@ -33,22 +37,96 @@
|
||||||
;;;;
|
;;;;
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
(defn print-usage [_]
|
(def cli-options
|
||||||
(println "Argument should be a pathname to an ADL file"))
|
[["-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
|
(defn -main
|
||||||
"Expects as arg the path-name of an ADL file."
|
"Expects as arg the path-name of an ADL file."
|
||||||
[& args]
|
[& args]
|
||||||
|
(let [options (parse-opts args cli-options)]
|
||||||
(cond
|
(cond
|
||||||
(empty? args)
|
(empty? args)
|
||||||
(print-usage args)
|
(print-usage)
|
||||||
(.exists (java.io.File. (first args)))
|
(not (empty? (:errors options)))
|
||||||
(let [application (x/parse (first args))]
|
(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)
|
(h/to-hugsql-queries application)
|
||||||
(j/to-json-routes application)
|
(j/to-json-routes application)
|
||||||
(p/to-psql application)
|
(p/to-psql application)
|
||||||
(s/to-selmer-routes application)
|
(s/to-selmer-routes application)
|
||||||
(t/to-selmer-templates application))))
|
(t/to-selmer-templates application))
|
||||||
|
(println (str "ERROR: File not found: " %)))
|
||||||
|
(-> options :arguments)))))))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -7,7 +7,7 @@
|
||||||
[clojure.xml :as x]
|
[clojure.xml :as x]
|
||||||
[clj-time.core :as t]
|
[clj-time.core :as t]
|
||||||
[clj-time.format :as f]
|
[clj-time.format :as f]
|
||||||
[adl.utils :refer :all]))
|
[adl-support.utils :refer :all]))
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;;;;
|
;;;;
|
||||||
|
|
@ -58,9 +58,9 @@
|
||||||
(order-by-clause entity ""))
|
(order-by-clause entity ""))
|
||||||
([entity prefix]
|
([entity prefix]
|
||||||
(let
|
(let
|
||||||
[entity-name (:name (:attrs entity))
|
[entity-name (safe-name (:name (:attrs entity)) :sql)
|
||||||
preferred (map
|
preferred (map
|
||||||
#(:name (:attrs %))
|
#(safe-name (:name (:attrs %)) :sql)
|
||||||
(filter #(#{"user" "all"} (-> % :attrs :distinct))
|
(filter #(#{"user" "all"} (-> % :attrs :distinct))
|
||||||
(children entity #(= (:tag %) :property))))]
|
(children entity #(= (:tag %) :property))))]
|
||||||
(if
|
(if
|
||||||
|
|
@ -70,7 +70,9 @@
|
||||||
"ORDER BY " prefix entity-name "."
|
"ORDER BY " prefix entity-name "."
|
||||||
(s/join
|
(s/join
|
||||||
(str ",\n\t" prefix entity-name ".")
|
(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
|
(defn insert-query
|
||||||
|
|
@ -78,9 +80,11 @@
|
||||||
TODO: this depends on the idea that system-unique properties
|
TODO: this depends on the idea that system-unique properties
|
||||||
are not insertable, which is... dodgy."
|
are not insertable, which is... dodgy."
|
||||||
[entity]
|
[entity]
|
||||||
(let [entity-name (:name (:attrs entity))
|
(let [entity-name (safe-name (:name (:attrs entity)) :sql)
|
||||||
pretty-name (singularise entity-name)
|
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 "!")
|
query-name (str "create-" pretty-name "!")
|
||||||
signature ":! :n"]
|
signature ":! :n"]
|
||||||
(hash-map
|
(hash-map
|
||||||
|
|
@ -99,7 +103,12 @@
|
||||||
")"
|
")"
|
||||||
(if
|
(if
|
||||||
(has-primary-key? entity)
|
(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
|
(defn update-query
|
||||||
|
|
@ -109,7 +118,7 @@
|
||||||
(and
|
(and
|
||||||
(has-primary-key? entity)
|
(has-primary-key? entity)
|
||||||
(has-non-key-properties? 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)
|
pretty-name (singularise entity-name)
|
||||||
property-names (map #(:name (:attrs %)) (insertable-properties entity))
|
property-names (map #(:name (:attrs %)) (insertable-properties entity))
|
||||||
query-name (str "update-" pretty-name "!")
|
query-name (str "update-" pretty-name "!")
|
||||||
|
|
@ -125,7 +134,7 @@
|
||||||
"-- :doc updates an existing " pretty-name " record\n"
|
"-- :doc updates an existing " pretty-name " record\n"
|
||||||
"UPDATE " entity-name "\n"
|
"UPDATE " entity-name "\n"
|
||||||
"SET "
|
"SET "
|
||||||
(s/join ",\n\t" (map #(str % " = " (keyword %)) property-names))
|
(s/join ",\n\t" (map #(str (safe-name % :sql) " = " (keyword %)) property-names))
|
||||||
"\n"
|
"\n"
|
||||||
(where-clause entity))}))
|
(where-clause entity))}))
|
||||||
{}))
|
{}))
|
||||||
|
|
@ -133,7 +142,7 @@
|
||||||
|
|
||||||
(defn search-query [entity]
|
(defn search-query [entity]
|
||||||
"Generate an appropriate search query for string fields of this `entity`"
|
"Generate an appropriate search query for string fields of this `entity`"
|
||||||
(let [entity-name (:name (:attrs entity))
|
(let [entity-name (safe-name (:name (:attrs entity)) :sql)
|
||||||
pretty-name (singularise entity-name)
|
pretty-name (singularise entity-name)
|
||||||
query-name (str "search-strings-" pretty-name)
|
query-name (str "search-strings-" pretty-name)
|
||||||
signature ":? :1"
|
signature ":? :1"
|
||||||
|
|
@ -162,9 +171,21 @@
|
||||||
(filter
|
(filter
|
||||||
string?
|
string?
|
||||||
(map
|
(map
|
||||||
#(if
|
#(case (:type (:attrs %))
|
||||||
(#{"string" "date" "text"} (:type (:attrs %)))
|
("string" "text")
|
||||||
(str (-> % :attrs :name) " LIKE '%params." (-> % :attrs :name) "%'"))
|
(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)))
|
properties)))
|
||||||
(order-by-clause entity "lv_")
|
(order-by-clause entity "lv_")
|
||||||
"--~ (if (:offset params) \"OFFSET :offset \")"
|
"--~ (if (:offset params) \"OFFSET :offset \")"
|
||||||
|
|
@ -176,7 +197,7 @@
|
||||||
([entity properties]
|
([entity properties]
|
||||||
(if
|
(if
|
||||||
(not (empty? properties))
|
(not (empty? properties))
|
||||||
(let [entity-name (:name (:attrs entity))
|
(let [entity-name (safe-name (:name (:attrs entity)) :sql)
|
||||||
pretty-name (singularise entity-name)
|
pretty-name (singularise entity-name)
|
||||||
query-name (if (= properties (key-properties entity))
|
query-name (if (= properties (key-properties entity))
|
||||||
(str "get-" pretty-name)
|
(str "get-" pretty-name)
|
||||||
|
|
@ -216,7 +237,7 @@
|
||||||
Parameters `:limit` and `:offset` may be supplied. If not present limit defaults
|
Parameters `:limit` and `:offset` may be supplied. If not present limit defaults
|
||||||
to 100 and offset to 0."
|
to 100 and offset to 0."
|
||||||
[entity]
|
[entity]
|
||||||
(let [entity-name (:name (:attrs entity))
|
(let [entity-name (safe-name (:name (:attrs entity)) :sql)
|
||||||
pretty-name (singularise entity-name)
|
pretty-name (singularise entity-name)
|
||||||
query-name (str "list-" entity-name)
|
query-name (str "list-" entity-name)
|
||||||
signature ":? :*"]
|
signature ":? :*"]
|
||||||
|
|
@ -417,10 +438,11 @@
|
||||||
(defn to-hugsql-queries
|
(defn to-hugsql-queries
|
||||||
"Generate all [HugSQL](https://www.hugsql.org/) queries implied by this ADL `application` spec."
|
"Generate all [HugSQL](https://www.hugsql.org/) queries implied by this ADL `application` spec."
|
||||||
[application]
|
[application]
|
||||||
(let [file-path (str *output-path* "resources/sql/queries.sql")]
|
(let [filepath (str *output-path* "resources/sql/queries.auto.sql")]
|
||||||
(make-parents file-path)
|
(make-parents filepath)
|
||||||
|
(try
|
||||||
(spit
|
(spit
|
||||||
file-path
|
filepath
|
||||||
(s/join
|
(s/join
|
||||||
"\n\n"
|
"\n\n"
|
||||||
(cons
|
(cons
|
||||||
|
|
@ -434,5 +456,16 @@
|
||||||
(sort
|
(sort
|
||||||
#(compare (:name %1) (:name %2))
|
#(compare (:name %1) (:name %2))
|
||||||
(vals
|
(vals
|
||||||
(queries application)))))))))
|
(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]
|
[clojure.xml :as x]
|
||||||
[clj-time.core :as t]
|
[clj-time.core :as t]
|
||||||
[clj-time.format :as f]
|
[clj-time.format :as f]
|
||||||
[adl.utils :refer :all]
|
[adl-support.utils :refer :all]
|
||||||
[adl.to-hugsql-queries :refer [queries]]))
|
[adl.to-hugsql-queries :refer [queries]]))
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
@ -37,7 +37,6 @@
|
||||||
;;; to-hugsql-queries, because essentially we need one JSON entry point to wrap
|
;;; to-hugsql-queries, because essentially we need one JSON entry point to wrap
|
||||||
;;; each query.
|
;;; each query.
|
||||||
|
|
||||||
|
|
||||||
(defn file-header [application]
|
(defn file-header [application]
|
||||||
(list
|
(list
|
||||||
'ns
|
'ns
|
||||||
|
|
@ -47,6 +46,7 @@
|
||||||
(f/unparse (f/formatters :basic-date-time) (t/now)))
|
(f/unparse (f/formatters :basic-date-time) (t/now)))
|
||||||
(list
|
(list
|
||||||
:require
|
:require
|
||||||
|
'[adl-support.core :as support]
|
||||||
'[clojure.java.io :as io]
|
'[clojure.java.io :as io]
|
||||||
'[compojure.core :refer [defroutes GET POST]]
|
'[compojure.core :refer [defroutes GET POST]]
|
||||||
'[hugsql.core :as hugsql]
|
'[hugsql.core :as hugsql]
|
||||||
|
|
@ -221,8 +221,9 @@
|
||||||
(defn to-json-routes
|
(defn to-json-routes
|
||||||
[application]
|
[application]
|
||||||
(let [handlers-map (make-handlers-map 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)
|
(make-parents filepath)
|
||||||
|
(try
|
||||||
(with-open [output (writer filepath)]
|
(with-open [output (writer filepath)]
|
||||||
(binding [*out* output]
|
(binding [*out* output]
|
||||||
(doall
|
(doall
|
||||||
|
|
@ -240,6 +241,17 @@
|
||||||
(pprint (:src (handlers-map h)))
|
(pprint (:src (handlers-map h)))
|
||||||
(println)
|
(println)
|
||||||
h)
|
h)
|
||||||
(sort (keys handlers-map))))))))
|
(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]
|
[clojure.xml :as x]
|
||||||
[clj-time.core :as t]
|
[clj-time.core :as t]
|
||||||
[clj-time.format :as f]
|
[clj-time.format :as f]
|
||||||
[adl.utils :refer :all]
|
[adl-support.utils :refer :all]
|
||||||
[adl.to-hugsql-queries :refer [queries]]))
|
[adl.to-hugsql-queries :refer [queries]]))
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
@ -346,7 +346,7 @@
|
||||||
(safe-name (first (key-names farside)) :sql))))
|
(safe-name (first (key-names farside)) :sql))))
|
||||||
entity-fields))))
|
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
|
(defn emit-referential-integrity-link
|
||||||
|
|
@ -564,10 +564,22 @@
|
||||||
[application]
|
[application]
|
||||||
(let [filepath (str
|
(let [filepath (str
|
||||||
*output-path*
|
*output-path*
|
||||||
"/resources/sql/"
|
"resources/sql/"
|
||||||
(:name (:attrs application))
|
(:name (:attrs application))
|
||||||
".postgres.sql")]
|
".postgres.sql")]
|
||||||
(make-parents filepath)
|
(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
|
(ns adl.to-reframe
|
||||||
(:require [adl.utils :refer :all]
|
(:require [adl-support.utils :refer :all]
|
||||||
[clojure.string :as s]
|
[clojure.string :as s]
|
||||||
[clj-time.core :as t]
|
[clj-time.core :as t]
|
||||||
[clj-time.format :as f]))
|
[clj-time.format :as f]))
|
||||||
|
|
@ -27,6 +27,9 @@
|
||||||
;;;;
|
;;;;
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
;;; TODO: not anywhere near finished.
|
||||||
|
|
||||||
|
|
||||||
(defn file-header
|
(defn file-header
|
||||||
([parent-name this-name extra-requires]
|
([parent-name this-name extra-requires]
|
||||||
(list 'ns (symbol (str parent-name ".views." this-name))
|
(list 'ns (symbol (str parent-name ".views." this-name))
|
||||||
|
|
|
||||||
|
|
@ -1,13 +1,14 @@
|
||||||
(ns ^{:doc "Application Description Language: generate routes for user interface requests."
|
(ns ^{:doc "Application Description Language: generate routes for user interface requests."
|
||||||
:author "Simon Brooke"}
|
:author "Simon Brooke"}
|
||||||
adl.to-selmer-routes
|
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.pprint :refer [pprint]]
|
||||||
[clojure.string :as s]
|
[clojure.string :as s]
|
||||||
[clojure.xml :as x]
|
[clojure.xml :as x]
|
||||||
[clj-time.core :as t]
|
[clj-time.core :as t]
|
||||||
[clj-time.format :as f]
|
[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
|
(defn file-header
|
||||||
[application]
|
[application]
|
||||||
|
|
@ -44,6 +49,7 @@
|
||||||
(f/unparse (f/formatters :basic-date-time) (t/now)))
|
(f/unparse (f/formatters :basic-date-time) (t/now)))
|
||||||
(list
|
(list
|
||||||
:require
|
:require
|
||||||
|
'[adl-support.core :as support]
|
||||||
'[clojure.java.io :as io]
|
'[clojure.java.io :as io]
|
||||||
'[compojure.core :refer [defroutes GET POST]]
|
'[compojure.core :refer [defroutes GET POST]]
|
||||||
'[hugsql.core :as hugsql]
|
'[hugsql.core :as hugsql]
|
||||||
|
|
@ -61,18 +67,26 @@
|
||||||
'defn
|
'defn
|
||||||
(symbol n)
|
(symbol n)
|
||||||
(vector 'r)
|
(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
|
;; but we should take all other params out of form-params - because we need the key to
|
||||||
;; load the form in the first place, but just accepting values of other params would
|
;; load the form in the first place, but just accepting values of other params would
|
||||||
;; allow spoofing.
|
;; allow spoofing.
|
||||||
(list
|
(list
|
||||||
'l/render
|
'l/render
|
||||||
(list 'resolve-template (str n ".html"))
|
(list 'support/resolve-template (str n ".html"))
|
||||||
(merge
|
(merge
|
||||||
{:title (capitalise (:name (:attrs f)))
|
{:title (capitalise (:name (:attrs f)))
|
||||||
:params 'p}
|
:params 'p}
|
||||||
(case (:tag f)
|
(case (:tag f)
|
||||||
(:form :page)
|
(:form :page)
|
||||||
|
(reduce
|
||||||
|
merge
|
||||||
{:record
|
{:record
|
||||||
(list 'if (list 'empty? (list 'remove 'nil? (list 'vals 'p))) []
|
(list 'if (list 'empty? (list 'remove 'nil? (list 'vals 'p))) []
|
||||||
(list
|
(list
|
||||||
|
|
@ -80,6 +94,12 @@
|
||||||
(str "db/get-" (singularise (:name (:attrs e)))))
|
(str "db/get-" (singularise (:name (:attrs e)))))
|
||||||
(symbol "db/*db*")
|
(symbol "db/*db*")
|
||||||
'p))}
|
'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
|
:list
|
||||||
{:records
|
{:records
|
||||||
(list
|
(list
|
||||||
|
|
@ -167,24 +187,17 @@
|
||||||
|
|
||||||
(defn to-selmer-routes
|
(defn to-selmer-routes
|
||||||
[application]
|
[application]
|
||||||
(let [filename (str *output-path* (:name (:attrs application)) "/routes/auto.clj")]
|
(let [filepath (str *output-path* "src/clj/" (:name (:attrs application)) "/routes/auto.clj")]
|
||||||
(make-parents filename)
|
(make-parents filepath)
|
||||||
(with-open [output (writer filename)]
|
(try
|
||||||
|
(with-open [output (writer filepath)]
|
||||||
(binding [*out* output]
|
(binding [*out* output]
|
||||||
(pprint (file-header application))
|
(pprint (file-header application))
|
||||||
(println)
|
(println)
|
||||||
(pprint '(defn raw-resolve-template [n]
|
(pprint '(defn admin
|
||||||
(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]
|
[r]
|
||||||
(l/render
|
(l/render
|
||||||
(resolve-template
|
(support/resolve-template
|
||||||
"application-index.html")
|
"application-index.html")
|
||||||
{:title "Administrative menu"})))
|
{:title "Administrative menu"})))
|
||||||
(println)
|
(println)
|
||||||
|
|
@ -197,7 +210,9 @@
|
||||||
(pprint (make-handler c e application))
|
(pprint (make-handler c e application))
|
||||||
(println))
|
(println))
|
||||||
(filter (fn [c] (#{:form :list :page} (:tag c))) (children e)))))
|
(filter (fn [c] (#{:form :list :page} (:tag c))) (children e)))))
|
||||||
(children-with-tag application :entity)))
|
(sort
|
||||||
|
#(compare (:name (:attrs %1))(:name (:attrs %2)))
|
||||||
|
(children-with-tag application :entity))))
|
||||||
(pprint
|
(pprint
|
||||||
(generate-handler-resolver application))
|
(generate-handler-resolver application))
|
||||||
(println)
|
(println)
|
||||||
|
|
@ -205,5 +220,16 @@
|
||||||
(memoize raw-resolve-handler)))
|
(memoize raw-resolve-handler)))
|
||||||
(println)
|
(println)
|
||||||
(pprint (make-defroutes application))
|
(pprint (make-defroutes application))
|
||||||
(println)))))
|
(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."
|
(ns ^{:doc "Application Description Language - generate Selmer templates for the HTML pages implied by an ADL file."
|
||||||
:author "Simon Brooke"}
|
:author "Simon Brooke"}
|
||||||
adl.to-selmer-templates
|
adl.to-selmer-templates
|
||||||
(:require [adl.utils :refer :all]
|
(:require [adl-support.utils :refer :all]
|
||||||
[clojure.java.io :refer [file]]
|
[clojure.java.io :refer [file make-parents]]
|
||||||
[clojure.pprint :as p]
|
[clojure.pprint :as p]
|
||||||
[clojure.string :as s]
|
[clojure.string :as s]
|
||||||
[clojure.xml :as x]
|
[clojure.xml :as x]
|
||||||
|
|
@ -145,7 +145,8 @@
|
||||||
|
|
||||||
(defn save-widget
|
(defn save-widget
|
||||||
"Return an appropriate 'save' widget for this `form` operating on this `entity` taken
|
"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]
|
[form entity application]
|
||||||
{:tag :p
|
{:tag :p
|
||||||
:attrs {:class "widget action-safe"}
|
:attrs {:class "widget action-safe"}
|
||||||
|
|
@ -156,13 +157,14 @@
|
||||||
:attrs {:id "save-button"
|
:attrs {:id "save-button"
|
||||||
:name "save-button"
|
:name "save-button"
|
||||||
:class "action-safe"
|
:class "action-safe"
|
||||||
:type :submit
|
:type "submit"
|
||||||
:value (str "Save!")}}]})
|
:value (str "Save!")}}]})
|
||||||
|
|
||||||
|
|
||||||
(defn delete-widget
|
(defn delete-widget
|
||||||
"Return an appropriate 'save' widget for this `form` operating on this `entity` taken
|
"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]
|
[form entity application]
|
||||||
{:tag :p
|
{:tag :p
|
||||||
:attrs {:class "widget action-dangerous"}
|
:attrs {:class "widget action-dangerous"}
|
||||||
|
|
@ -173,7 +175,7 @@
|
||||||
:attrs {:id "delete-button"
|
:attrs {:id "delete-button"
|
||||||
:name "delete-button"
|
:name "delete-button"
|
||||||
:class "action-dangerous"
|
:class "action-dangerous"
|
||||||
:type :submit
|
:type "submit"
|
||||||
:value (str "Delete!")}}]})
|
:value (str "Delete!")}}]})
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -259,21 +261,10 @@
|
||||||
:content (apply vector (get-options property form entity application))})))}))
|
: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
|
(defn compose-if-member-of-tag
|
||||||
[property entity application writable?]
|
[property entity application writable?]
|
||||||
(let
|
(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))]
|
permissions (if writable? (writable-by all-permissions) (visible-to all-permissions))]
|
||||||
(s/join
|
(s/join
|
||||||
" "
|
" "
|
||||||
|
|
@ -295,20 +286,18 @@
|
||||||
property (if
|
property (if
|
||||||
(= (:tag field-or-property) :property)
|
(= (:tag field-or-property) :property)
|
||||||
field-or-property
|
field-or-property
|
||||||
(first
|
(child-with-tag entity
|
||||||
(children
|
:property
|
||||||
entity
|
#(= (:name (:attrs %))
|
||||||
#(and
|
(:property (:attrs field-or-property)))))
|
||||||
(= (:tag %) :property)
|
permissions (find-permissions field-or-property property form entity application)
|
||||||
(= (:name (:attrs %)) (:property (:attrs field-or-property)))))))
|
|
||||||
permissions (permissions property form entity application)
|
|
||||||
typedef (typedef property application)
|
typedef (typedef property application)
|
||||||
visible-to (visible-to permissions)
|
visible-to (visible-to permissions)
|
||||||
;; if the form isn't actually a form, no widget is writable.
|
;; if the form isn't actually a form, no widget is writable.
|
||||||
writable-by (if (= (:tag form) :form) (writable-by permissions))
|
writable-by (if (= (:tag form) :form) (writable-by permissions))
|
||||||
select? (#{"entity" "list" "link"} (:type (:attrs property)))]
|
select? (#{"entity" "list" "link"} (:type (:attrs property)))]
|
||||||
(if
|
(if
|
||||||
(formal-primary-key? property entity)
|
(= (:distinct (:attrs property)) "system")
|
||||||
{:tag :input
|
{:tag :input
|
||||||
:attrs {:id widget-name
|
:attrs {:id widget-name
|
||||||
:name widget-name
|
:name widget-name
|
||||||
|
|
@ -343,25 +332,21 @@
|
||||||
:name widget-name
|
:name widget-name
|
||||||
:class "pseudo-widget disabled"}
|
:class "pseudo-widget disabled"}
|
||||||
:content [(str "{{record." widget-name "}}")]}
|
: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 %}"
|
||||||
"{% endifmemberof %}"]})))
|
"{% endifmemberof %}"]})))
|
||||||
|
|
||||||
|
|
||||||
(defn fields
|
|
||||||
[form]
|
|
||||||
(descendants-with-tag form :field))
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
(defn form-to-template
|
(defn form-to-template
|
||||||
"Generate a template as specified by this `form` element for this `entity`,
|
"Generate a template as specified by this `form` element for this `entity`,
|
||||||
taken from this `application`. If `form` is nill, generate a default form
|
taken from this `application`. If `form` is nill, generate a default form
|
||||||
template for the entity."
|
template for the entity."
|
||||||
[form entity application]
|
[form entity application]
|
||||||
(let
|
|
||||||
[keyfields (children
|
|
||||||
;; there should only be one key; its keys are properties
|
|
||||||
(first (children entity #(= (:tag %) :key))))]
|
|
||||||
{:tag :div
|
{:tag :div
|
||||||
:attrs {:id "content" :class "edit"}
|
:attrs {:id "content" :class "edit"}
|
||||||
:content
|
:content
|
||||||
|
|
@ -373,15 +358,18 @@
|
||||||
(csrf-widget)
|
(csrf-widget)
|
||||||
(map
|
(map
|
||||||
#(widget % form entity application)
|
#(widget % form entity application)
|
||||||
keyfields)
|
(children-with-tag (child-with-tag entity :key) :properties))
|
||||||
(map
|
(map
|
||||||
#(widget % form entity application)
|
#(widget % form entity application)
|
||||||
(remove
|
(remove
|
||||||
#(= (:distict (:attrs %)) :system)
|
#(let
|
||||||
(fields entity)))
|
[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)
|
(save-widget form entity application)
|
||||||
(delete-widget form entity application)))}]}))
|
(delete-widget form entity application)))}]})
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
(defn page-to-template
|
(defn page-to-template
|
||||||
|
|
@ -434,7 +422,7 @@
|
||||||
#(hash-map
|
#(hash-map
|
||||||
:content [(prompt %)]
|
:content [(prompt %)]
|
||||||
:tag :th)
|
:tag :th)
|
||||||
(fields list-spec)))}
|
(children-with-tag list-spec :field)))}
|
||||||
{:tag :tr
|
{:tag :tr
|
||||||
:content
|
:content
|
||||||
(apply
|
(apply
|
||||||
|
|
@ -442,7 +430,7 @@
|
||||||
(concat
|
(concat
|
||||||
(map
|
(map
|
||||||
#(compose-list-search-widget % entity)
|
#(compose-list-search-widget % entity)
|
||||||
(fields list-spec))
|
(children-with-tag list-spec :field))
|
||||||
'({:tag :th
|
'({:tag :th
|
||||||
:content
|
:content
|
||||||
[{:tag :input
|
[{:tag :input
|
||||||
|
|
@ -492,7 +480,7 @@
|
||||||
:attrs {:href (edit-link e application (list (:name (:attrs p))))}
|
:attrs {:href (edit-link e application (list (:name (:attrs p))))}
|
||||||
:content [(str "{{ record." (:property (:attrs field)) "_expanded }}")]}]
|
:content [(str "{{ record." (:property (:attrs field)) "_expanded }}")]}]
|
||||||
[c]))})
|
[c]))})
|
||||||
(fields list-spec))
|
(children-with-tag list-spec :field))
|
||||||
[{:tag :td
|
[{:tag :td
|
||||||
:content
|
:content
|
||||||
[{:tag :a
|
[{:tag :a
|
||||||
|
|
@ -623,11 +611,13 @@
|
||||||
|
|
||||||
(defn write-template-file
|
(defn write-template-file
|
||||||
[filename template application]
|
[filename template application]
|
||||||
|
(let [filepath (str *output-path* "resources/templates/auto/" filename)]
|
||||||
|
(make-parents filepath)
|
||||||
(if
|
(if
|
||||||
template
|
template
|
||||||
(try
|
(try
|
||||||
(spit
|
(spit
|
||||||
(str *output-path* filename)
|
filepath
|
||||||
(s/join
|
(s/join
|
||||||
"\n"
|
"\n"
|
||||||
(list
|
(list
|
||||||
|
|
@ -635,19 +625,21 @@
|
||||||
(with-out-str
|
(with-out-str
|
||||||
(x/emit-element template))
|
(x/emit-element template))
|
||||||
(file-footer filename application))))
|
(file-footer filename application))))
|
||||||
|
(if (> *verbosity* 0) (println "\tGenerated " filepath))
|
||||||
(catch Exception any
|
(catch Exception any
|
||||||
(spit
|
(let [report (str
|
||||||
(str *output-path* filename)
|
"ERROR: Exception "
|
||||||
(with-out-str
|
|
||||||
(println
|
|
||||||
(str
|
|
||||||
"<!-- Exception "
|
|
||||||
(.getName (.getClass any))
|
(.getName (.getClass any))
|
||||||
(.getMessage any)
|
(.getMessage any)
|
||||||
" while printing "
|
" while printing "
|
||||||
filename "-->"))
|
filename)]
|
||||||
(p/pprint template))))))
|
(spit
|
||||||
filename)
|
filepath
|
||||||
|
(with-out-str
|
||||||
|
(println (str "<!-- " report "-->"))
|
||||||
|
(p/pprint template)))
|
||||||
|
(println report)))))
|
||||||
|
(str filepath)))
|
||||||
|
|
||||||
|
|
||||||
(defn to-selmer-templates
|
(defn to-selmer-templates
|
||||||
|
|
@ -668,12 +660,13 @@
|
||||||
(try
|
(try
|
||||||
(write-template-file filename (templates-map %) application)
|
(write-template-file filename (templates-map %) application)
|
||||||
(catch Exception any
|
(catch Exception any
|
||||||
|
(println
|
||||||
(str
|
(str
|
||||||
"Exception "
|
"ERROR: Exception "
|
||||||
(.getName (.getClass any))
|
(.getName (.getClass any))
|
||||||
(.getMessage any)
|
(.getMessage any)
|
||||||
" while writing "
|
" while writing "
|
||||||
filename)))))
|
filename))))))
|
||||||
(keys templates-map)))))
|
(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."
|
(ns ^{:doc "Application Description Language: validator for ADL structure."
|
||||||
:author "Simon Brooke"}
|
:author "Simon Brooke"}
|
||||||
adl.validator
|
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.core :as b]
|
||||||
[bouncer.validators :as v]))
|
[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
|
;; 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`.
|
;; 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
|
;; 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?
|
;; do we identify the one which ought not to have failed?
|
||||||
[o & validations]
|
[o & validations]
|
||||||
(println
|
`(println
|
||||||
(str
|
(str
|
||||||
(if (:tag o) (str "Tag: " (:tag o) "; "))
|
(if (:tag ~o) (str "Tag: " (:tag ~o) "; "))
|
||||||
(if (:name (:attrs o)) (str "Name: " (:name (:attrs o)) ";"))
|
(if (:name (:attrs ~o)) (str "Name: " (:name (:attrs ~o)) ";"))
|
||||||
(if-not (or (:tag o) (:name (:attrs o))) (str "Context: " o))))
|
(if-not (or (:tag ~o) (:name (:attrs ~o))) (str "Context: " ~o))))
|
||||||
|
|
||||||
(let
|
`(empty?
|
||||||
[rs (map
|
(remove :tag (remove nil? (map first (map
|
||||||
#(try
|
#(try-validate ~o '%)
|
||||||
(b/validate o %)
|
~validations))))))
|
||||||
(catch java.lang.ClassCastException c
|
;; ]
|
||||||
;; The validator regularly barfs on strings, which are perfectly
|
;; ;; if *any* succeeded, we succeeded
|
||||||
;; valid content of some elements. I need a way to validate
|
;; ;; otherwise, one of these is the valid error - but which? The answer, in my case
|
||||||
;; elements where they're not tolerated!
|
;; ;; is that if there is any which did not fail on the :tag check, then that is the
|
||||||
[nil o])
|
;; ;; interesting one. But generally?
|
||||||
(catch Exception e
|
;; (try
|
||||||
[{:exception (.getMessage e)
|
;; (doall (map #(println (str "ERROR: " %)) suspicious))
|
||||||
:class (type e)
|
;; (empty? suspicious)
|
||||||
:context o} o]))
|
;; (catch Exception _ (println "ERROR while trying to print errors")
|
||||||
validations)
|
;; true))))
|
||||||
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))))
|
|
||||||
|
|
||||||
|
|
||||||
;;; the remainder of this file is a fairly straight translation of the ADL 1.4 DTD into Clojure
|
;;; 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 :column] v/string
|
||||||
[:attrs :concrete] [[v/member #{"true", "false"}]]
|
[:attrs :concrete] [[v/member #{"true", "false"}]]
|
||||||
[:attrs :cascade] [[v/member cascade-actions]]
|
[:attrs :cascade] [[v/member cascade-actions]]
|
||||||
:content [[v/every #(disjunct-valid? %
|
;; :content [[v/every #(disjunct-valid? %
|
||||||
documentation-validations
|
;; documentation-validations
|
||||||
generator-validations
|
;; generator-validations
|
||||||
permission-validations
|
;; permission-validations
|
||||||
option-validations
|
;; option-validations
|
||||||
prompt-validations
|
;; prompt-validations
|
||||||
help-validations
|
;; help-validations
|
||||||
ifmissing-validations)]]})
|
;; ifmissing-validations)]]
|
||||||
|
})
|
||||||
|
|
||||||
|
|
||||||
(def permission-validations
|
(def permission-validations
|
||||||
|
|
@ -657,3 +671,8 @@
|
||||||
|
|
||||||
(defn validate-adl [src]
|
(defn validate-adl [src]
|
||||||
(b/validate src application-validations))
|
(b/validate src application-validations))
|
||||||
|
|
||||||
|
(defn validate-adl-file [filepath]
|
||||||
|
(validate-adl (parse filepath)))
|
||||||
|
|
||||||
|
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue