Merge mess...

README.md

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

project.clj

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

resources/schemas/adl-1.4.1.dtd

@@ -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,12 +254,17 @@ 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)*)>
@@ -268,7 +273,8 @@ that we can allow HTML block level entities within content elements -->
     natural-key CDATA         #IMPLIED
     table       CDATA         #IMPLIED
     foreign     %Boolean;     #IMPLIED
-    magnitude CDATA           #IMPLIED>
+    magnitude   CDATA         #IMPLIED
+    volatility  CDATA         #IMPLIED>
 
 <!--
   contains documentation on the element which immediately contains it. TODO:

resources/transforms/adl2canonical.xslt

@@ -90,6 +90,9 @@
       <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)"/>

src/adl/main.clj

@@ -1,13 +1,17 @@
 (ns ^{:doc "Application Description Language - command line invocation."
       :author "Simon Brooke"}
   adl.main
-  (:require [adl.utils :refer :all]
+  (:require [adl-support.utils :refer :all]
             [adl.to-hugsql-queries :as h]
             [adl.to-json-routes :as j]
             [adl.to-psql :as p]
             [adl.to-selmer-routes :as s]
             [adl.to-selmer-templates :as t]
-            [clojure.xml :as x])
+            [clojure.java.io :refer [make-parents]]
+            [clojure.string :refer [join]]
+            [clojure.tools.cli :refer [parse-opts]]
+            [clojure.xml :as x]
+            [environ.core :refer [env]])
   (:gen-class))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -33,22 +37,96 @@
 ;;;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(defn print-usage [_]
+(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
   "Expects as arg the path-name of an ADL file."
   [& args]
+  (let [options (parse-opts args cli-options)]
     (cond
       (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)
                      (j/to-json-routes application)
                      (p/to-psql application)
                      (s/to-selmer-routes application)
-      (t/to-selmer-templates application))))
+                     (t/to-selmer-templates application))
+                   (println (str "ERROR: File not found: " %)))
+                (-> options :arguments)))))))))
 
 
 

src/adl/to_hugsql_queries.clj

@@ -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,17 +164,31 @@
                "-- :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)
+             (str "SELECT DISTINCT * FROM lv_" entity-name)
-             "WHERE "
              (s/join
-               "\n\tOR "
+               "\n\t--~ "
+               (cons
+                 "WHERE false"
                  (filter
                    string?
                    (map
-                   #(if
+                     #(str
-                      (#{"string" "date" "text"} (:type (:attrs %)))
+                        "(if (:" (-> % :attrs :name) " params) \"OR "
-                      (str (-> % :attrs :name) " LIKE '%params." (-> % :attrs :name) "%'"))
+                        (case (base-type % application)
-                   properties)))
+                          ("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\")")))})))
@@ -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,10 +366,11 @@
 (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")]
+  (let [filepath (str *output-path* "resources/sql/queries.auto.sql")]
-    (make-parents file-path)
+    (make-parents filepath)
+    (try
       (spit
-      file-path
+        filepath
         (s/join
           "\n\n"
           (cons
@@ -434,5 +384,16 @@
               (sort
                 #(compare (:name %1) (:name %2))
                 (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))))))
 

src/adl/to_json_routes.clj

@@ -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
+    :src (remove
-    (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)
+                 (str "Auto-generated method to " doc))
-      [{:keys ['params]}]
+               (generate-handler-body query-map))
-      (list 'do (list (symbol (str "db/" (:name query-map))) 'params))
+             (concat
-      (case
+               (list
-        (:type query-map)
+                 'def
-        (:delete-1 :update-1)
+                 handler-name
-        '(response/found "/")
+                 (list
-        nil)))))
+                   '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
+                       (map
+                         #(keyword (:name (:attrs %)))
                          (flatten
                            (cons
-                           (-> query :entity :content :properties keys)
+                             (-> query :entity key-properties)
-                           (-> query :entity :content :key :content keys))))))
+                             (-> 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
+                 (map #(keyword (:name (:attrs %))) (-> query :entity all-properties))
-                   (distinct
-                     (sort
-                       (flatten
-                         (cons
-                           (-> query :entity :content :properties keys)
-                           (-> query :entity :content :key :content keys))))))
                  "`."))
           :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
+                   (map
-                     (sort
+                     #(keyword (:name (:attrs %)))
-                       (flatten
+                     (-> query :entity all-properties)))
-                         (cons
-                           (-> query :entity :content :properties keys)
-                           (-> query :entity :content :key :content keys))))))
                  "`."))
           :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
+                   (map
-                     (sort
+                     #(keyword (:name (:attrs %)))
-                       (flatten
+                     (-> query :entity all-properties)))
-                         (cons
-                           (-> query :entity :content :properties keys)
-                           (-> query :entity :content :key :content keys))))))
                  "`."))
           (: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)
+    (try
       (with-open [output (writer filepath)]
         (binding [*out* output]
-        (doall
+          (pprint (file-header application))
-          (map
+          (println)
-            (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))))))))
+              (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))))))
 
 

src/adl/to_psql.clj

@@ -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]]))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -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
@@ -447,8 +447,8 @@
 (defn construct-link-property
   [entity]
   {:tag :property
-   :attrs {:name (safe-name (str (:name (:attrs entity)) "_id") :sql)
+   :attrs {:name (safe-name (str (singularise (:name (:attrs entity))) "_id") :sql)
-           :column (safe-name (str (: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)}})
@@ -564,10 +564,22 @@
   [application]
   (let [filepath (str
                    *output-path*
-                  "/resources/sql/"
+                   "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))))))
 
 

src/adl/to_reframe.clj

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

src/adl/to_selmer_routes.clj

@@ -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,18 +67,24 @@
       '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)
+                  (reduce
+                    merge
                     {:record
                      (list 'if (list 'empty? (list 'remove 'nil? (list 'vals 'p))) []
                            (list
@@ -80,6 +92,13 @@
                                (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,25 +186,19 @@
 
 (defn to-selmer-routes
   [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]
           (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
+                       (support/resolve-template
                          "application-index.html")
+                       (:session r)
                        {:title "Administrative menu"})))
           (println)
           (doall
@@ -197,7 +210,9 @@
                       (pprint (make-handler c e application))
                       (println))
                     (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
             (generate-handler-resolver application))
           (println)
@@ -205,5 +220,16 @@
                      (memoize raw-resolve-handler)))
           (println)
           (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))))))
 

src/adl/to_selmer_templates.clj

@@ -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]
+  (:require [adl-support.utils :refer :all]
-            [clojure.java.io :refer [file]]
+            [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)
+    [all-permissions (find-permissions property entity application)
-     permissions (if writable? (writable-by all-permissions) (visible-to all-permissions))]
+     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
+                (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)
      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,25 +342,21 @@
                           :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"}
@@ -369,15 +369,18 @@
                  (csrf-widget)
                  (map
                   #(widget % form entity application)
-                    keyfields)
+                  (children-with-tag (child-with-tag entity :key) :properties))
                  (map
                   #(widget % form entity application)
                   (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)
-                   (delete-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
+        search-name (safe-name
+                      (if
                         (= (:type (:attrs property)) "entity")
-                      (str base-name "_expanded") base-name)]
+                        (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,15 +616,16 @@
            (form-to-template nil entity application)})))))
 
 
-
 (defn application-to-template
   [application]
   (let
-    [first-class-entities (filter
+    [first-class-entities
+     (sort-by
+       #(:name (:attrs %))
+       (filter
          #(children-with-tag % :list)
-                           (children-with-tag application :entity))]
+         (children-with-tag application :entity)))]
     {:content
-     {:application-index
      {:tag :dl
       :attrs {:class "index"}
       :content
@@ -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)
+          filepath
+          (s/join
+            "\n"
+            (list
+              (file-header filename application)
               (with-out-str
-           (println
+                (x/emit-element template))
-            (str
+              (file-footer filename application))))
-             "<!-- Exception "
+        (if (> *verbosity* 0) (println "\tGenerated " filepath))
+        (catch Exception any
+          (let [report (str
+                         "ERROR: Exception "
                          (.getName (.getClass any))
                          (.getMessage any)
                          " 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
@@ -708,12 +726,13 @@
              (try
                (write-template-file filename (templates-map %) application)
                (catch Exception any
+                 (println
                    (str
-                   "Exception "
+                     "ERROR: Exception "
                      (.getName (.getClass any))
                      (.getMessage any)
                      " while writing "
-                   filename)))))
+                     filename))))))
         (keys templates-map)))))
 
 

src/adl/utils.clj

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

src/adl/validator.clj

@@ -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 (: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
@@ -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? %
+;;    :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
@@ -657,3 +671,8 @@
 
 (defn validate-adl [src]
   (b/validate src application-validations))
+
+(defn validate-adl-file [filepath]
+  (validate-adl (parse filepath)))
+
+