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

Merge mess...

Browse source
This commit is contained in:
Simon Brooke 2018-06-30 20:17:53 +01:00
parent 16f953741b a4e0fd1c9a
commit 48c8b6445b
13 changed files with 848 additions and 1134 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

21
README.md
View file

@ -2,6 +2,21 @@
A language for describing applications, from which code can be automatically generated.
## Usage
A document describing the proposed application should be written in XML using the DTD `resources/schemas/adl-1.4.1.dtd`. It may then be transformed into a C# or Java application using the XSL transforms, see **History** below, but this code is very out of date and the resulting application is unlikely to be very usable. Alternatively, it can be transformed into a Clojure [Luminus](http://www.luminusweb.net/) application using the Clojure transformation, as follows:
simon@fletcher:~/workspace/adl$ java -jar target/adl-1.4.1-SNAPSHOT-standalone.jar --help
Usage: java -jar adl-[VERSION]-SNAPSHOT-standalone.jar -options [adl-file]
where options include:
-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
-l, --locale [LOCALE]: set the locale to generate; (default: en_GB.UTF-8)
-p, --path [PATH]: The path under which generated files should be written; (default: generated)
-v, --verbosity [LEVEL], : Verbosity level - integer value required; (default: 0)
This is not yet complete but it is at an advanced stage and already produces code which is useful.
## History
This idea started back in 2007, when I felt that web development in Java had really reached the end of the road - one spent all one's time writing boilerplate, and the amount of time taken to achieve anything useful had expanded far beyond common sense. So I thought: write one high level document describing an application; write a series of transforms from that document to the different files required to build the application; and a great deal of time would be saved.
@ -26,6 +41,10 @@ The idea is that the ADL framework should autogenerate 95% of your application.
A Document Type Definition is the core of this; the current version is `adl-1.4.dtd`.
### The Clojure transformer application
This is the future direction of the project. Currently it converts a valid ADL XML document into most of the files required for a Clojure web-app. Shortly it will produce a complete Clojure [Luminus](http://www.luminusweb.net/) web-app. In future it may produce web-apps in other languages and frameworks.
### XSL transforms
XSL transforms exist which transform conforming documents as follows:
@ -54,6 +73,6 @@ I will happily accept pull requests for new XSL transforms (although I'd like so
## License
Copyright © Simon Brooke 2007-2018
Copyright © Simon Brooke 2007-2018; some work was done under contract to [Cygnet Solutions Ltd](http://cygnets.co.uk/), but they have kindly transferred the copyright back to me.
Distributed under the Gnu GPL version 2 or any later version; I am open to licensing this project under additional licences if required.

5
project.clj
View file

@ -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

22
resources/schemas/adl-1.4.1.dtd
View file

@ -246,7 +246,7 @@ that we can allow HTML block level entities within content elements -->
an entity which has properties and relationships; maps onto a database
table or a Java serialisable class - or, of course, various other things
name: obviously, the name of this entity
name: obviously, the name of this entity.
natural-key: if present, the name of a property of this entity which forms
a natural primary key [NOTE: Only partly implemented. NOTE: much of
the present implementation assumes all primary keys will be
@ -254,21 +254,27 @@ that we can allow HTML block level entities within content elements -->
'key' element, below.
table: the name of the table in which this entity is stored. Defaults to same
as name of entity. Strongly recommend this is not used unless it needs
to be different from the name of the entity
to be different from the name of the entity.
foreign: this entity is part of some other system; no code will be generated
for it, although code which links to it will be generated
for it, although code which links to it will be generated.
magnitude: The power of ten which approximates the expected number of records; thus
if ten records are expected, the magnitude is 1; if a million, the
magnitude is 6
magnitude is 6.
volatility: Number representing the anticipated rate of change of records in this
entity; if 0, results should never be cached; otherwise, a power of
10 representing the number of seconds the data may safely be cached.
thus 5 represents a cach time to live of 100,000 seconds, or slightly
more than one day.
-->
<!ELEMENT entity ( documentation?, prompt*, content?, key?,
property*, permission*, (form | page | list)*)>
<!ATTLIST entity
name CDATA #REQUIRED
name CDATA #REQUIRED
natural-key CDATA #IMPLIED
table CDATA #IMPLIED
foreign %Boolean; #IMPLIED
magnitude CDATA #IMPLIED>
table CDATA #IMPLIED
foreign %Boolean; #IMPLIED
magnitude CDATA #IMPLIED
volatility CDATA #IMPLIED>
<!--
contains documentation on the element which immediately contains it. TODO:

19
resources/transforms/adl2canonical.xslt
View file

@ -82,22 +82,25 @@
</xsl:template>
<!-- an entity which already has a key tag - just copy it through -->
<xsl:template match="adl:entity[adl:key]">
<xsl:comment>
entity <xsl:value-of select="@name"/> already has a key - not generating one
</xsl:comment>
<entity>
<xsl:template match="adl:entity[adl:key]">
<xsl:comment>
entity <xsl:value-of select="@name"/> already has a key - not generating one
</xsl:comment>
<entity>
<xsl:if test="not(@magnitude)">
<xsl:attribute name="magnitude">6</xsl:attribute>
</xsl:if>
<xsl:if test="not(@volatility)">
<xsl:attribute name="volatility">0</xsl:attribute>
</xsl:if>
<xsl:if test="not( @table)">
<xsl:attribute name="table">
<xsl:value-of select="concat( $tablename-prefix, @name)"/>
</xsl:attribute>
</xsl:if>
<xsl:apply-templates select="@* | node()"/>
</entity>
</xsl:template>
<xsl:apply-templates select="@* | node()"/>
</entity>
</xsl:template>
<!-- an entity which has a '@natural-key' attribute.
Since we've got the key tag, I think this should be disallowed -->

106
src/adl/main.clj
View file

@ -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)))))))))

201
src/adl/to_hugsql_queries.clj
View file

@ -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,15 +134,15 @@
"-- :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))}))
{}))
(defn search-query [entity]
(defn search-query [entity application]
"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"
@ -155,20 +164,34 @@
"-- :doc selects existing "
pretty-name
" records having any string field matching the parameter of the same name by substring match")
(str "SELECT * FROM lv_" entity-name)
"WHERE "
(str "SELECT DISTINCT * FROM lv_" entity-name)
(s/join
"\n\tOR "
(filter
string?
(map
#(if
(#{"string" "date" "text"} (:type (:attrs %)))
(str (-> % :attrs :name) " LIKE '%params." (-> % :attrs :name) "%'"))
properties)))
(order-by-clause entity "lv_")
"--~ (if (:offset params) \"OFFSET :offset \")"
"--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))})))
"\n\t--~ "
(cons
"WHERE false"
(filter
string?
(map
#(str
"(if (:" (-> % :attrs :name) " params) \"OR "
(case (base-type % application)
("string" "text")
(str
(safe-name (-> % :attrs :name) :sql)
" LIKE '%:" (-> % :attrs :name) "%'")
("date" "time" "timestamp")
(str
(safe-name (-> % :attrs :name) :sql)
" = ':" (-> % :attrs :name) "'")
(str
(safe-name (-> % :attrs :name) :sql)
" = :"
(-> % :attrs :name)))
"\")")
properties))))
(order-by-clause entity "lv_")
"--~ (if (:offset params) \"OFFSET :offset \")"
"--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))})))
(defn select-query
@ -176,7 +199,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 +239,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 ":? :*"]
@ -234,7 +257,7 @@
(list
(str "-- :name " query-name " " signature)
(str "-- :doc lists all existing " pretty-name " records")
(str "SELECT * FROM lv_" entity-name)
(str "SELECT DISTINCT * FROM lv_" entity-name)
(order-by-clause entity "lv_")
"--~ (if (:offset params) \"OFFSET :offset \")"
"--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))})))
@ -298,80 +321,6 @@
}))
links))))
(defn link-table-query
"Generate a query which links across the entity passed as `link`
from the entity passed as `near` to the entity passed as `far`.
TODO: not working?"
[near link far]
(if
(and
(entity? near)
(entity? link)
(entity? far))
(let [properties (-> link :content :properties vals)
links (apply
merge
(map
#(hash-map (keyword (-> % :attrs :entity)) %)
(filter #(-> % :attrs :entity) properties)))
near-name (-> near :attrs :name)
link-name (-> link :attrs :name)
far-name (-> far :attrs :name)
pretty-far (singularise far-name)
query-name (str "list-" link-name "-" near-name "-by-" pretty-far)
signature ":? :*"]
(hash-map
(keyword query-name)
{:name query-name
:signature signature
:entity link
:type :select-many-to-many
:near-entity near
:far-entity far
:query
(s/join
"\n"
(remove
empty?
(list
(str "-- :name " query-name " " signature)
(str "-- :doc lists all existing " near-name " records related through " link-name " to a given " pretty-far )
(str "SELECT "near-name ".*")
(str "FROM " near-name ", " link-name )
(str "WHERE " near-name "." (first (key-names near)) " = " link-name "." (singularise near-name) "_id" )
("\tAND " link-name "." (singularise far-name) "_id = :id")
(order-by-clause near))))}))))
(defn link-table-queries [entity application]
"Generate all the link queries in this `application` which link via this `entity`."
(let
[entities (map
;; find the far-side entities
(fn
[far-name]
(children
application
(fn [x]
(and
(= (:tag x) :entity)
(= (:name (:attrs x)) far-name)))))
;; of those properties of this `entity` which are of type `entity`
(remove
nil?
(map
#(-> % :attrs :entity)
(children entity #(= (:tag %) :property)))))
pairs (combinations entities 2)]
(apply
merge
(map
#(merge
(link-table-query (nth % 0) entity (nth % 1))
(link-table-query (nth % 1) entity (nth % 0)))
pairs))))
(defn delete-query [entity]
"Generate an appropriate `delete` query for this `entity`"
@ -405,7 +354,7 @@
(delete-query entity)
(select-query entity)
(list-query entity)
(search-query entity)
(search-query entity application)
(foreign-queries entity application)))
([application]
(apply
@ -417,22 +366,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))))))

146
src/adl/to_json_routes.clj
View file

@ -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,7 +46,9 @@
(f/unparse (f/formatters :basic-date-time) (t/now)))
(list
:require
'[adl-support.core :as support]
'[clojure.java.io :as io]
'[clojure.core.memoize :as memo]
'[compojure.core :refer [defroutes GET POST]]
'[hugsql.core :as hugsql]
'[noir.response :as nresponse]
@ -60,24 +61,45 @@
(cons 'declare (sort (map #(symbol (name %)) (keys handlers-map)))))
(defn generate-handler-body
"Generate and return the function body for the handler for this `query`."
[query]
(list
[{:keys ['params]}]
(list 'do (list (symbol (str "db/" (:name query))) 'params))
(case
(:type query)
(:delete-1 :update-1)
'(response/found "/")
nil)))
(defn generate-handler-src
"Generate and return the handler for this `query`."
[handler-name query-map method doc]
(hash-map
:method method
:src
(remove
nil?
(list
'defn
handler-name
(str "Auto-generated method to " doc)
[{:keys ['params]}]
(list 'do (list (symbol (str "db/" (:name query-map))) 'params))
(case
(:type query-map)
(:delete-1 :update-1)
'(response/found "/")
nil)))))
:src (remove
nil?
(if
(or
(zero? (volatility (:entity query-map)))
(#{:delete-1 :insert-1 :update-1} (:type query-map)))
(concat
(list
'defn
handler-name
(str "Auto-generated method to " doc))
(generate-handler-body query-map))
(concat
(list
'def
handler-name
(list
'memo/ttl
(cons 'fn (generate-handler-body query-map))
:ttl/threshold
(* (volatility (:entity query-map)) 1000))))))))
(defn handler
@ -100,7 +122,7 @@
(str "delete one record from the `"
(-> query :entity :attrs :name)
"` table. Expects the following key(s) to be present in `params`: `"
(doall (-> query :entity :content :key :content keys))
(-> query :entity key-names)
"`."))
:insert-1
(generate-handler-src
@ -108,9 +130,12 @@
(str "insert one record to the `"
(-> query :entity :attrs :name)
"` table. Expects the following key(s) to be present in `params`: `"
(pr-str (-> query :entity :content :properties keys))
(pr-str
(map
#(keyword (:name (:attrs %)))
(-> query :entity insertable-properties )))
"`. Returns a map containing the keys `"
(pr-str (-> query :entity :content :key :content keys))
(-> query :entity key-names)
"` identifying the record created."))
:update-1
(generate-handler-src
@ -121,10 +146,12 @@
(pr-str
(distinct
(sort
(flatten
(cons
(-> query :entity :content :properties keys)
(-> query :entity :content :key :content keys))))))
(map
#(keyword (:name (:attrs %)))
(flatten
(cons
(-> query :entity key-properties)
(-> query :entity insertable-properties)))))))
"`."))
:select-1
(generate-handler-src
@ -132,15 +159,9 @@
(str "select one record from the `"
(-> query :entity :attrs :name)
"` table. Expects the following key(s) to be present in `params`: `"
(pr-str (-> query :entity :content :key :content keys))
(-> query :entity key-names)
"`. Returns a map containing the following keys: `"
(pr-str
(distinct
(sort
(flatten
(cons
(-> query :entity :content :properties keys)
(-> query :entity :content :key :content keys))))))
(map #(keyword (:name (:attrs %))) (-> query :entity all-properties))
"`."))
:select-many
(generate-handler-src
@ -149,26 +170,21 @@
(-> query :entity :attrs :name)
"` table. If the keys `(:limit :offset)` are present in the request then they will be used to page through the data. Returns a sequence of maps each containing the following keys: `"
(pr-str
(distinct
(sort
(flatten
(cons
(-> query :entity :content :properties keys)
(-> query :entity :content :key :content keys))))))
(map
#(keyword (:name (:attrs %)))
(-> query :entity all-properties)))
"`."))
:text-search
(generate-handler-src
handler-name query :get
(str "select all records from the `"
(-> query :entity :attrs :name)
;; TODO: this doc-string is out of date
"` table with any text field matching the value of the key `:pattern` which should be in the request. If the keys `(:limit :offset)` are present in the request then they will be used to page through the data. Returns a sequence of maps each containing the following keys: `"
(pr-str
(distinct
(sort
(flatten
(cons
(-> query :entity :content :properties keys)
(-> query :entity :content :key :content keys))))))
(map
#(keyword (:name (:attrs %)))
(-> query :entity all-properties)))
"`."))
(:select-many-to-many
:select-one-to-many)
@ -221,25 +237,31 @@
(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]
(pprint (file-header application))
(println)
(doall
(map
(fn [h]
(pprint (:src (handlers-map h)))
(println)
h)
(sort (keys handlers-map))))
(pprint (defroutes handlers-map))))
(if (> *verbosity* 0)
(println (str "\tGenerated " filepath)))
(catch
Exception any
(println
(str
"ERROR: Exception "
(.getName (.getClass any))
(.getMessage any)
" while printing "
filepath))))))

562
src/adl/to_psql.clj
View file

@ -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,55 +400,55 @@
(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
[entity]
{:tag :property
:attrs {:name (safe-name (str (:name (:attrs entity)) "_id") :sql)
:column (safe-name (str (:name (:attrs entity)) "_id") :sql)
:attrs {:name (safe-name (str (singularise (:name (:attrs entity))) "_id") :sql)
:column (safe-name (str (singularise (:name (:attrs entity))) "_id") :sql)
:type "entity"
:entity (:name (:attrs entity))
:farkey (safe-name (first (key-names entity)) :sql)}})
@ -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))))))

5
src/adl/to_reframe.clj
View file

@ -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))

130
src/adl/to_selmer_routes.clj
View file

@ -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,38 @@
'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 'support/massage-params (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"))
'(:session r)
(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 #(#{"entity" "link"} (:type (:attrs %)))
(descendants-with-tag e :property))))
:list
{:records
(list
@ -133,7 +152,7 @@
'auto-selmer-routes
(cons
'(GET
"/index"
"/admin"
request
(route/restricted
(apply (resolve-handler "index") (list request))))
@ -167,43 +186,50 @@
(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 index
[r]
(l/render
(support/resolve-template
"application-index.html")
(:session r)
{: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))))))

211
src/adl/to_selmer_templates.clj
View file

@ -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]
@ -127,7 +127,6 @@
#(and
(= (:tag %) :prompt)
(= (:locale :attrs %) *locale*))))
(:name (:attrs field-or-property))
(:property (:attrs field-or-property)))))
@ -140,7 +139,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"}
@ -151,13 +151,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"}
@ -168,7 +169,7 @@
:attrs {:id "delete-button"
:name "delete-button"
:class "action-dangerous"
:type :submit
:type "submit"
:value (str "Delete!")}}]})
@ -254,22 +255,16 @@
: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)
permissions (if writable? (writable-by all-permissions) (visible-to all-permissions))]
[all-permissions (find-permissions property entity application)
permissions (map
s/lower-case
(if
writable?
(writable-by all-permissions)
(visible-to all-permissions)))]
(s/join
" "
(flatten
@ -290,20 +285,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
@ -324,7 +317,18 @@
{:id widget-name
:name widget-name
:type (widget-type property application typedef)
:value (str "{{record." widget-name "}}")}
:value (str "{{record." widget-name "}}")
:maxlength (:size (:attrs property))
:size (cond
(nil? (:size (:attrs property)))
"16"
(try
(> (read-string
(:size (:attrs property))) 60)
(catch Exception _ false))
"60"
true
(:size (:attrs property)))}
(if
(:minimum (:attrs typedef))
{:min (:minimum (:attrs typedef))})
@ -338,46 +342,45 @@
: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))))]
{:content
{:tag :div
:attrs {:id "content" :class "edit"}
:content
[{:tag :form
:attrs {:action (str "{{servlet-context}}/" (editor-name entity application))
:method "POST"}
:content (flatten
(list
(csrf-widget)
(map
#(widget % form entity application)
keyfields)
(map
#(widget % form entity application)
(remove
#(= (:distict (:attrs %)) :system)
(fields entity)))
(save-widget form entity application)
(delete-widget form entity application)))}]}}))
{:content
{:tag :div
:attrs {:id "content" :class "edit"}
:content
[{:tag :form
:attrs {:action (str "{{servlet-context}}/" (editor-name entity application))
:method "POST"}
:content (flatten
(list
(csrf-widget)
(map
#(widget % form entity application)
(children-with-tag (child-with-tag entity :key) :properties))
(map
#(widget % form entity application)
(remove
#(let
[property (filter
(fn [p] (= (:name (:attrs p)) (:property (:attrs %))))
(descendants-with-tag entity :property))]
(= (:distict (:attrs property)) :system))
(children-with-tag form :field)))
(save-widget form entity application)
(delete-widget form entity application)))}]}})
(defn page-to-template
@ -402,9 +405,11 @@
"time" "time"
"text")
base-name (:property (:attrs field))
search-name (if
(= (:type (:attrs property)) "entity")
(str base-name "_expanded") base-name)]
search-name (safe-name
(if
(= (:type (:attrs property)) "entity")
(str base-name "_expanded") base-name)
:sql)]
(hash-map
:tag :th
:content
@ -430,7 +435,7 @@
#(hash-map
:content [(prompt %)]
:tag :th)
(fields list-spec)))}
(children-with-tag list-spec :field)))}
{:tag :tr
:content
(apply
@ -438,7 +443,7 @@
(concat
(map
#(compose-list-search-widget % entity)
(fields list-spec))
(children-with-tag list-spec :field))
'({:tag :th
:content
[{:tag :input
@ -477,18 +482,19 @@
{:tag :td :content
(let
[p (first (filter #(= (:name (:attrs %)) (:property (:attrs field))) (all-properties entity)))
s (safe-name (:name (:attrs p)) :sql)
e (first
(filter
#(= (:name (:attrs %)) (:entity (:attrs p)))
(children-with-tag application :entity)))
c (str "{{ record." (:property (:attrs field)) " }}")]
c (str "{{ record." s " }}")]
(if
(= (:type (:attrs p)) "entity")
[{:tag :a
:attrs {:href (edit-link e application (list (:name (:attrs p))))}
:content [(str "{{ record." (:property (:attrs field)) "_expanded }}")]}]
:content [(str "{{ record." s "_expanded }}")]}]
[c]))})
(fields list-spec))
(children-with-tag list-spec :field))
[{:tag :td
:content
[{:tag :a
@ -610,19 +616,20 @@
(form-to-template nil entity application)})))))
(defn application-to-template
[application]
(let
[first-class-entities (filter
#(children-with-tag % :list)
(children-with-tag application :entity))]
[first-class-entities
(sort-by
#(:name (:attrs %))
(filter
#(children-with-tag % :list)
(children-with-tag application :entity)))]
{:content
{:application-index
{:tag :dl
:attrs {:class "index"}
:content
(apply
{:tag :dl
:attrs {:class "index"}
:content
(apply
vector
(interleave
(map
@ -644,8 +651,7 @@
:tag :p
:content (:content d)))
(children-with-tag % :documentation))))
first-class-entities)))}}}))
first-class-entities)))}}))
(defn write-template-file
@ -677,17 +683,29 @@
(file-footer filename application)))))
(catch Exception any
(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
@ -708,12 +726,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)))))

457
src/adl/utils.clj
View file

@ -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))))

97
src/adl/validator.clj
View file

@ -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)))