From fc79e74fb88eef61a8c10f6b946f827fb591d7d5 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 20 Jun 2018 09:26:08 +0100 Subject: [PATCH 1/7] Moved utils into the support project. Also greatly improved CLI. --- project.clj | 5 +- src/adl/main.clj | 106 +++++- src/adl/to_hugsql_queries.clj | 99 ++++-- src/adl/to_json_routes.clj | 54 ++-- src/adl/to_psql.clj | 558 ++++++++++++++++---------------- src/adl/to_reframe.clj | 5 +- src/adl/to_selmer_routes.clj | 128 +++++--- src/adl/to_selmer_templates.clj | 163 +++++----- src/adl/utils.clj | 457 -------------------------- src/adl/validator.clj | 97 +++--- 10 files changed, 697 insertions(+), 975 deletions(-) delete mode 100644 src/adl/utils.clj diff --git a/project.clj b/project.clj index 131722c..f2c7d3f 100644 --- a/project.clj +++ b/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 diff --git a/src/adl/main.clj b/src/adl/main.clj index ea955b1..066a864 100644 --- a/src/adl/main.clj +++ b/src/adl/main.clj @@ -1,13 +1,17 @@ (ns ^{:doc "Application Description Language - command line invocation." :author "Simon Brooke"} adl.main - (:require [adl.utils :refer :all] + (:require [adl-support.utils :refer :all] [adl.to-hugsql-queries :as h] [adl.to-json-routes :as j] [adl.to-psql :as p] [adl.to-selmer-routes :as s] [adl.to-selmer-templates :as t] - [clojure.xml :as x]) + [clojure.java.io :refer [make-parents]] + [clojure.string :refer [join]] + [clojure.tools.cli :refer [parse-opts]] + [clojure.xml :as x] + [environ.core :refer [env]]) (:gen-class)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -33,22 +37,96 @@ ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defn print-usage [_] - (println "Argument should be a pathname to an ADL file")) +(def cli-options + [["-a" "--abstract-key-name-convention [string]" "the abstract key name convention to use for generated key fields (TODO: not yet implemented)" + :default "id"] + ["-h" "--help" "Show this message" + :default false] + ["-l" "--locale [LOCALE]" "set the locale to generate" + :default (env :lang)] + ["-p" "--path [PATH]" "The path under which generated files should be written" + :default "generated"] + ["-v" "--verbosity [LEVEL]" nil "Verbosity level - integer value required" + :parse-fn #(Integer/parseInt %) + :default 0] + ]) + + +(defn- doc-part + "An `option` in cli-options comprises a sequence of strings followed by + keyword/value pairs. Return all the strings before the first keyword." + [option] + (if + (keyword? (first option)) nil + (cons (first option) (doc-part (rest option))))) + +(defn map-part + "An `option` in cli-options comprises a sequence of strings followed by + keyword/value pairs. Return the keyword/value pairs as a map." + [option] + (cond + (empty? option) nil + (keyword? (first option)) (apply hash-map option) + true + (map-part (rest option)))) + +(defn print-usage [] + (println + (join + "\n" + (flatten + (list + (join + (list + "Usage: java -jar adl-" + (or (System/getProperty "adl.version") "[VERSION]") + "-SNAPSHOT-standalone.jar -options [adl-file]")) + "where options include:" + (map + #(let + [doc-part (doc-part %) + default (:default (map-part %)) + default-string (if default (str "; (default: " default ")"))] + (str "\t" (join ", " (butlast doc-part)) ": " (last doc-part) default-string)) + cli-options)))))) + (defn -main "Expects as arg the path-name of an ADL file." [& args] - (cond - (empty? args) - (print-usage args) - (.exists (java.io.File. (first args))) - (let [application (x/parse (first args))] - (h/to-hugsql-queries application) - (j/to-json-routes application) - (p/to-psql application) - (s/to-selmer-routes application) - (t/to-selmer-templates application)))) + (let [options (parse-opts args cli-options)] + (cond + (empty? args) + (print-usage) + (not (empty? (:errors options))) + (do + (doall + (map + println + (:errors options))) + (print-usage)) + (-> options :options :help) + (print-usage) + true + (do + (let [p (:path (:options options)) + op (if (.endsWith p "/") p (str p "/"))] + (binding [*output-path* op + *locale* (-> options :options :locale) + *verbosity* (-> options :options :verbosity)] + (make-parents *output-path*) + (doall + (map + #(if + (.exists (java.io.File. %)) + (let [application (x/parse %)] + (h/to-hugsql-queries application) + (j/to-json-routes application) + (p/to-psql application) + (s/to-selmer-routes application) + (t/to-selmer-templates application)) + (println (str "ERROR: File not found: " %))) + (-> options :arguments))))))))) diff --git a/src/adl/to_hugsql_queries.clj b/src/adl/to_hugsql_queries.clj index bc480e8..4a983ab 100644 --- a/src/adl/to_hugsql_queries.clj +++ b/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,7 +134,7 @@ "-- :doc updates an existing " pretty-name " record\n" "UPDATE " entity-name "\n" "SET " - (s/join ",\n\t" (map #(str % " = " (keyword %)) property-names)) + (s/join ",\n\t" (map #(str (safe-name % :sql) " = " (keyword %)) property-names)) "\n" (where-clause entity))})) {})) @@ -133,7 +142,7 @@ (defn search-query [entity] "Generate an appropriate search query for string fields of this `entity`" - (let [entity-name (:name (:attrs entity)) + (let [entity-name (safe-name (:name (:attrs entity)) :sql) pretty-name (singularise entity-name) query-name (str "search-strings-" pretty-name) signature ":? :1" @@ -162,9 +171,21 @@ (filter string? (map - #(if - (#{"string" "date" "text"} (:type (:attrs %))) - (str (-> % :attrs :name) " LIKE '%params." (-> % :attrs :name) "%'")) + #(case (:type (:attrs %)) + ("string" "text") + (str + (safe-name (-> % :attrs :name) :sql) + " LIKE '%params." + (-> % :attrs :name) "%'") + ("date" "time" "timestamp") + (str + (safe-name (-> % :attrs :name) :sql) + " = 'params." + (-> % :attrs :name) "'") + (str + (safe-name (-> % :attrs :name) :sql) + " = params." + (-> % :attrs :name))) properties))) (order-by-clause entity "lv_") "--~ (if (:offset params) \"OFFSET :offset \")" @@ -176,7 +197,7 @@ ([entity properties] (if (not (empty? properties)) - (let [entity-name (:name (:attrs entity)) + (let [entity-name (safe-name (:name (:attrs entity)) :sql) pretty-name (singularise entity-name) query-name (if (= properties (key-properties entity)) (str "get-" pretty-name) @@ -216,7 +237,7 @@ Parameters `:limit` and `:offset` may be supplied. If not present limit defaults to 100 and offset to 0." [entity] - (let [entity-name (:name (:attrs entity)) + (let [entity-name (safe-name (:name (:attrs entity)) :sql) pretty-name (singularise entity-name) query-name (str "list-" entity-name) signature ":? :*"] @@ -417,22 +438,34 @@ (defn to-hugsql-queries "Generate all [HugSQL](https://www.hugsql.org/) queries implied by this ADL `application` spec." [application] - (let [file-path (str *output-path* "resources/sql/queries.sql")] - (make-parents file-path) - (spit - file-path - (s/join - "\n\n" - (cons - (emit-header - "--" - "File queries.sql" - (str "autogenerated by adl.to-hugsql-queries at " (t/now)) - "See [Application Description Language](https://github.com/simon-brooke/adl).") - (map - #(:query %) - (sort - #(compare (:name %1) (:name %2)) - (vals - (queries application))))))))) + (let [filepath (str *output-path* "resources/sql/queries.auto.sql")] + (make-parents filepath) + (try + (spit + filepath + (s/join + "\n\n" + (cons + (emit-header + "--" + "File queries.sql" + (str "autogenerated by adl.to-hugsql-queries at " (t/now)) + "See [Application Description Language](https://github.com/simon-brooke/adl).") + (map + #(:query %) + (sort + #(compare (:name %1) (:name %2)) + (vals + (queries application))))))) + (if (> *verbosity* 0) + (println (str "\tGenerated " filepath))) + (catch + Exception any + (println + (str + "ERROR: Exception " + (.getName (.getClass any)) + (.getMessage any) + " while printing " + filepath)))))) diff --git a/src/adl/to_json_routes.clj b/src/adl/to_json_routes.clj index afb0426..5464313 100644 --- a/src/adl/to_json_routes.clj +++ b/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,6 +46,7 @@ (f/unparse (f/formatters :basic-date-time) (t/now))) (list :require + '[adl-support.core :as support] '[clojure.java.io :as io] '[compojure.core :refer [defroutes GET POST]] '[hugsql.core :as hugsql] @@ -221,25 +221,37 @@ (defn to-json-routes [application] (let [handlers-map (make-handlers-map application) - filepath (str *output-path* (:name (:attrs application)) "/routes/auto_json.clj")] + filepath (str *output-path* "src/clj/" (:name (:attrs application)) "/routes/auto_json.clj")] (make-parents filepath) - (with-open [output (writer filepath)] - (binding [*out* output] - (doall - (map - (fn [f] - (pprint f) - (println "\n")) - (list - (file-header application) - (declarations handlers-map) - (defroutes handlers-map)))) - (doall - (map - (fn [h] - (pprint (:src (handlers-map h))) - (println) - h) - (sort (keys handlers-map)))))))) + (try + (with-open [output (writer filepath)] + (binding [*out* output] + (doall + (map + (fn [f] + (pprint f) + (println "\n")) + (list + (file-header application) + (declarations handlers-map) + (defroutes handlers-map)))) + (doall + (map + (fn [h] + (pprint (:src (handlers-map h))) + (println) + h) + (sort (keys handlers-map)))))) + (if (> *verbosity* 0) + (println (str "\tGenerated " filepath))) + (catch + Exception any + (println + (str + "ERROR: Exception " + (.getName (.getClass any)) + (.getMessage any) + " while printing " + filepath)))))) diff --git a/src/adl/to_psql.clj b/src/adl/to_psql.clj index 21156d8..ee7f549 100644 --- a/src/adl/to_psql.clj +++ b/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]])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -47,65 +47,65 @@ ;; that the argument passed as `property` is indeed a property. (str (emit-field-type typedef nil application false) (cond - (:pattern (:attrs typedef)) - (str - " CONSTRAINT " - (gensym "pattern_") - " CHECK (" - (:name (:attrs property)) - " ~* '" (:pattern (:attrs typedef)) - "')") - (and (:maximum (:attrs typedef))(:minimum (:attrs typedef))) - ;; TODO: if base type is date, time or timestamp, values should be quoted. - (str - " CONSTRAINT " - (gensym "minmax_") - " CHECK (" - (:minimum (:attrs typedef)) - " < " - (:name (:attrs property)) - " AND " - (:name (:attrs property)) - " < " + (str + " CONSTRAINT " + (gensym "pattern_") + " CHECK (" + (:name (:attrs property)) + " ~* '" + (:pattern (:attrs typedef)) + "')") + (and (:maximum (:attrs typedef))(:minimum (:attrs typedef))) + ;; TODO: if base type is date, time or timestamp, values should be quoted. + (str + " CONSTRAINT " + (gensym "minmax_") + " CHECK (" + (:minimum (:attrs typedef)) + " < " + (:name (:attrs property)) + " AND " + (:name (:attrs property)) + " < " + (:maximum (:attrs typedef)) + ")") (:maximum (:attrs typedef)) - ")") - (:maximum (:attrs typedef)) - (str - " CONSTRAINT " - (gensym "max_") - " CHECK (" - (:name (:attrs property)) - " < " - (:maximum (:attrs typedef)) - ")") - (:minimum (:attrs typedef)) - (str - " CONSTRAINT " - (gensym "min_") - " CHECK (" + (str + " CONSTRAINT " + (gensym "max_") + " CHECK (" + (:name (:attrs property)) + " < " + (:maximum (:attrs typedef)) + ")") (:minimum (:attrs typedef)) - " < " - (:name (:attrs property))))))) + (str + " CONSTRAINT " + (gensym "min_") + " CHECK (" + (:minimum (:attrs typedef)) + " < " + (:name (:attrs property))))))) (defn emit-entity-field-type [property application] (let [farside (child - application - #(and - (entity? %) - (= (:name (:attrs %)) (:entity (:attrs property))))) + application + #(and + (entity? %) + (= (:name (:attrs %)) (:entity (:attrs property))))) key-properties (children-with-tag - (first (children-with-tag farside :key)) - :property)] + (first (children-with-tag farside :key)) + :property)] (if (> (count key-properties) 1) (str - "-- ERROR: cannot generate link to entity " - (:name (:attrs farside)) - " with compound primary key\n") - (emit-field-type (first key-properties) farside application false)))) + "-- ERROR: cannot generate link to entity " + (:name (:attrs farside)) + " with compound primary key\n") + (emit-field-type (first key-properties) farside application false)))) (defn emit-field-type @@ -114,24 +114,24 @@ "integer" (if key? "SERIAL" "INTEGER") "real" "DOUBLE PRECISION" ("string" "image" "uploadable") - (str "VARCHAR(" (:size (:attrs property)) ")") + (str "VARCHAR(" (:size (:attrs property)) ")") "defined" (emit-defined-field-type property application) "entity" (emit-entity-field-type property application) ("date" "time" "timestamp" "boolean" "text" "money") - (.toUpperCase (:type (:attrs property))) + (.toUpperCase (:type (:attrs property))) (str "-- ERROR: unknown type " (:type (:attrs property))))) (defn emit-link-field [property entity application] (emit-property - {:tag :property - :attrs {:name (str (:name (:attrs entity)) "_id") - :type "entity" - :entity (:name (:attrs entity)) - :cascade (:cascade (:attrs property))}} - entity - application)) + {:tag :property + :attrs {:name (str (:name (:attrs entity)) "_id") + :type "entity" + :entity (:name (:attrs entity)) + :cascade (:cascade (:attrs property))}} + entity + application)) (defn emit-permissions-grant @@ -182,68 +182,68 @@ (let [default (:default (:attrs property))] (if (and - (= (:tag property) :property) - (not (#{"link"} (:type (:attrs property))))) + (= (:tag property) :property) + (not (#{"link"} (:type (:attrs property))))) (s/join - " " - (remove - nil? - (flatten - (list - "\t" - (field-name property) - (emit-field-type property entity application key?) - (if - default + " " + (remove + nil? + (flatten (list - "DEFAULT" + "\t" + (field-name property) + (emit-field-type property entity application key?) (if - (is-quotable-type? property application) - (str "'" default "'") ;; TODO: but if the default value seems to be a function invocation, should it be quoted? - ;; it's quite common for 'now()' to be the default for a date, time or timestamp field. - default))) - (if - key? - "NOT NULL PRIMARY KEY" - (if (= (:required (:attrs property)) "true") "NOT NULL")))))))))) + default + (list + "DEFAULT" + (if + (is-quotable-type? property application) + (str "'" default "'") ;; TODO: but if the default value seems to be a function invocation, should it be quoted? + ;; it's quite common for 'now()' to be the default for a date, time or timestamp field. + default))) + (if + key? + "NOT NULL PRIMARY KEY" + (if (= (:required (:attrs property)) "true") "NOT NULL")))))))))) (defn compose-convenience-entity-field [field entity application] (let [farside (child - application - #(and - (entity? %) - (= (:name (:attrs %)) (:entity (:attrs field)))))] + application + #(and + (entity? %) + (= (:name (:attrs %)) (:entity (:attrs field)))))] (flatten - (map - (fn [f] - (if - (= (:type (:attrs f)) "entity") - (compose-convenience-entity-field f farside application) - (str (safe-name (:table (:attrs farside))) "." (field-name f)))) - (user-distinct-properties farside))))) + (map + (fn [f] + (if + (= (:type (:attrs f)) "entity") + (compose-convenience-entity-field f farside application) + (str (safe-name (:table (:attrs farside))) "." (field-name f)))) + (user-distinct-properties farside))))) (defn compose-convenience-view-select-list [entity application top-level?] (remove - nil? - (flatten - (cons - (safe-name (:table (:attrs entity)) :sql) - (map - (fn [f] - (if - (= (:type (:attrs f)) "entity") - (compose-convenience-view-select-list - (child application #(and (entity? %) (= (:name (:attrs %))(:entity (:attrs f))))) - application - false))) - (if - top-level? - (all-properties entity) - (user-distinct-properties entity))))))) + nil? + (flatten + (cons + (safe-name (:table (:attrs entity)) :sql) + (map + (fn [f] + (if + (= (:type (:attrs f)) "entity") + (compose-convenience-view-select-list + (child application #(and (entity? %) (= (:name (:attrs %))(:entity (:attrs f))))) + application + false))) + (if + top-level? + (all-properties entity) + (user-distinct-properties entity))))))) (defn compose-convenience-where-clause @@ -251,37 +251,37 @@ ;; See lv_electors, lv_followuprequests for examples of the problem. [entity application top-level?] (remove - nil? - (flatten - (map - (fn [f] - (if - (= (:type (:attrs f)) "entity") - (let [farside (entity-for-property f application)] - (cons - (str - (safe-name (:table (:attrs entity)) :sql) - "." - (field-name f) - " = " - (safe-name (:table (:attrs farside)) :sql) - "." - (safe-name (first (key-names farside)) :sql)) - #(compose-convenience-where-clause farside application false))))) - (if - top-level? - (all-properties entity) - (user-distinct-properties entity)))))) + nil? + (flatten + (map + (fn [f] + (if + (= (:type (:attrs f)) "entity") + (let [farside (entity-for-property f application)] + (cons + (str + (safe-name (:table (:attrs entity)) :sql) + "." + (field-name f) + " = " + (safe-name (:table (:attrs farside)) :sql) + "." + (safe-name (first (key-names farside)) :sql)) + #(compose-convenience-where-clause farside application false))))) + (if + top-level? + (all-properties entity) + (user-distinct-properties entity)))))) (defn emit-convenience-entity-field [field entity application] (str - (s/join - " ||', '|| " - (compose-convenience-entity-field field entity application)) - " AS " - (field-name field) + (s/join + " ||', '|| " + (compose-convenience-entity-field field entity application)) + " AS " + (field-name field) "_expanded")) @@ -346,7 +346,7 @@ (safe-name (first (key-names farside)) :sql)))) entity-fields)))) ";" - (emit-permissions-grant view-name :SELECT (permissions entity application)))))))) + (emit-permissions-grant view-name :SELECT (find-permissions entity application)))))))) (defn emit-referential-integrity-link @@ -354,45 +354,45 @@ (let [farside (entity-for-property property application)] (s/join - " " - (list - "ALTER TABLE" - (safe-name (:name (:attrs nearside)) :sql) - "ADD CONSTRAINT" - (safe-name (str "ri_" (:name (:attrs nearside)) "_" (:name (:attrs farside)) "_" (:name (:attrs property))) :sql) - "\n\tFOREIGN KEY(" - (field-name property) - ") \n\tREFERENCES" - (str - (safe-name (:table (:attrs farside)) :sql) - "(" (field-name (first (key-properties farside))) ")") - ;; TODO: ought to handle the `cascade` attribute, even though it's rarely used - "\n\tON DELETE" - (case - (:cascade (:attrs property)) - "orphan" "SET NULL" - "delete" "CASCADE" - "NO ACTION") - ";")))) + " " + (list + "ALTER TABLE" + (safe-name (:name (:attrs nearside)) :sql) + "ADD CONSTRAINT" + (safe-name (str "ri_" (:name (:attrs nearside)) "_" (:name (:attrs farside)) "_" (:name (:attrs property))) :sql) + "\n\tFOREIGN KEY(" + (field-name property) + ") \n\tREFERENCES" + (str + (safe-name (:table (:attrs farside)) :sql) + "(" (field-name (first (key-properties farside))) ")") + ;; TODO: ought to handle the `cascade` attribute, even though it's rarely used + "\n\tON DELETE" + (case + (:cascade (:attrs property)) + "orphan" "SET NULL" + "delete" "CASCADE" + "NO ACTION") + ";")))) (defn emit-referential-integrity-links ([entity application] (map - #(emit-referential-integrity-link % entity application) - (sort-by-name - (filter - #(= (:type (:attrs %)) "entity") - (properties entity))))) + #(emit-referential-integrity-link % entity application) + (sort-by-name + (filter + #(= (:type (:attrs %)) "entity") + (properties entity))))) ([application] (flatten - (list - (emit-header - "--" - "referential integrity links for primary tables") - (map - #(emit-referential-integrity-links % application) - (sort-by-name (children-with-tag application :entity))))))) + (list + (emit-header + "--" + "referential integrity links for primary tables") + (map + #(emit-referential-integrity-links % application) + (sort-by-name (children-with-tag application :entity))))))) (defn emit-table @@ -400,48 +400,48 @@ (let [table-name (safe-name (:table (:attrs entity)) :sql) permissions (children-with-tag entity :permission)] (s/join - "\n" - (flatten - (list - (emit-header - "--" + "\n" + (flatten (list - doc-comment - (map - #(:content %) - (children-with-tag entity :documentation)))) - (s/join - " " - (list "CREATE TABLE" table-name)) - "(" - (str - (s/join - ",\n" - (flatten - (remove - nil? - (list - (map - #(emit-property % entity application true) - (children-with-tag (child-with-tag entity :key) :property)) - (map - #(emit-property % entity application false) - (filter - #(not (= (:type (:attrs %)) "link")) - (children-with-tag entity :property))))))) - "\n);") - (map - #(emit-permissions-grant table-name % permissions) - '(:SELECT :INSERT :UPDATE :DELETE))))))) + (emit-header + "--" + (list + doc-comment + (map + #(:content %) + (children-with-tag entity :documentation)))) + (s/join + " " + (list "CREATE TABLE" table-name)) + "(" + (str + (s/join + ",\n" + (flatten + (remove + nil? + (list + (map + #(emit-property % entity application true) + (children-with-tag (child-with-tag entity :key) :property)) + (map + #(emit-property % entity application false) + (filter + #(not (= (:type (:attrs %)) "link")) + (children-with-tag entity :property))))))) + "\n);") + (map + #(emit-permissions-grant table-name % permissions) + '(:SELECT :INSERT :UPDATE :DELETE))))))) ([entity application] (emit-table - entity - application - (str - "primary table " - (:table (:attrs entity)) - " for entity " - (:name (:attrs entity)))))) + entity + application + (str + "primary table " + (:table (:attrs entity)) + " for entity " + (:name (:attrs entity)))))) (defn construct-link-property @@ -457,117 +457,129 @@ (defn emit-link-table [property e1 application emitted-link-tables] (let [e2 (child - application - #(and - (entity? %) - (= (:name (:attrs %)) (:entity (:attrs property))))) + application + #(and + (entity? %) + (= (:name (:attrs %)) (:entity (:attrs property))))) link-table-name (link-table-name e1 e2)] (if ;; we haven't already emitted this one... (not (@emitted-link-tables link-table-name)) (let [permissions (flatten - (list - (children-with-tag e1 :permission) - (children-with-tag e1 :permission))) + (list + (children-with-tag e1 :permission) + (children-with-tag e1 :permission))) ;; construct a dummy entity link-entity {:tag :entity :attrs {:name link-table-name :table link-table-name} :content - (apply vector - (flatten - (list - [(construct-link-property e1) - (construct-link-property e2)] - permissions)))}] + (apply vector + (flatten + (list + [(construct-link-property e1) + (construct-link-property e2)] + permissions)))}] ;; mark it as emitted (swap! emitted-link-tables conj link-table-name) ;; emit it (flatten - (list - (emit-table - link-entity - application - (str - "link table joining " - (:name (:attrs e1)) - " with " - (:name (:attrs e2)))) - ;; and immediately emit its referential integrity links - (emit-referential-integrity-links link-entity application))))))) + (list + (emit-table + link-entity + application + (str + "link table joining " + (:name (:attrs e1)) + " with " + (:name (:attrs e2)))) + ;; and immediately emit its referential integrity links + (emit-referential-integrity-links link-entity application))))))) (defn emit-link-tables ([entity application emitted-link-tables] - (map - #(emit-link-table % entity application emitted-link-tables) - (sort-by-name - (filter - #(= (:type (:attrs %)) "link") - (properties entity))))) + (map + #(emit-link-table % entity application emitted-link-tables) + (sort-by-name + (filter + #(= (:type (:attrs %)) "link") + (properties entity))))) ([application emitted-link-tables] (map - #(emit-link-tables % application emitted-link-tables) - (sort-by-name (children-with-tag application :entity))))) + #(emit-link-tables % application emitted-link-tables) + (sort-by-name (children-with-tag application :entity))))) (defn emit-group-declaration [group application] (list - (emit-header - "--" - (str "security group " (:name (:attrs group)))) - (str "CREATE GROUP " (safe-name (:name (:attrs group)) :sql) ";"))) + (emit-header + "--" + (str "security group " (:name (:attrs group)))) + (str "CREATE GROUP " (safe-name (:name (:attrs group)) :sql) ";"))) (defn emit-file-header [application] (emit-header - "--" - "Database definition for application " - (str (:name (:attrs application)) - " version " - (:version (:attrs application))) - "auto-generated by [Application Description Language framework]" - (str "(https://github.com/simon-brooke/adl) at " - (f/unparse (f/formatters :basic-date-time) (t/now))) - (map - #(:content %) - (children-with-tag application :documentation)))) + "--" + "Database definition for application " + (str (:name (:attrs application)) + " version " + (:version (:attrs application))) + "auto-generated by [Application Description Language framework]" + (str "(https://github.com/simon-brooke/adl) at " + (f/unparse (f/formatters :basic-date-time) (t/now))) + (map + #(:content %) + (children-with-tag application :documentation)))) (defn emit-application [application] (let [emitted-link-tables (atom #{})] (s/join - "\n\n" - (flatten - (list - (emit-file-header application) - (map - #(emit-group-declaration % application) - (sort-by-name - (children-with-tag application :group))) - (map - #(emit-table % application) - (sort-by-name - (children-with-tag application :entity))) - (map - #(emit-convenience-view % application) - (sort-by-name - (children-with-tag application :entity))) - (emit-referential-integrity-links application) - (emit-link-tables application emitted-link-tables)))))) + "\n\n" + (flatten + (list + (emit-file-header application) + (map + #(emit-group-declaration % application) + (sort-by-name + (children-with-tag application :group))) + (map + #(emit-table % application) + (sort-by-name + (children-with-tag application :entity))) + (map + #(emit-convenience-view % application) + (sort-by-name + (children-with-tag application :entity))) + (emit-referential-integrity-links application) + (emit-link-tables application emitted-link-tables)))))) (defn to-psql [application] (let [filepath (str - *output-path* - "/resources/sql/" - (:name (:attrs application)) - ".postgres.sql")] + *output-path* + "resources/sql/" + (:name (:attrs application)) + ".postgres.sql")] (make-parents filepath) - (spit filepath (emit-application application)))) + (try + (spit filepath (emit-application application)) + (if (> *verbosity* 0) + (println (str "\tGenerated " filepath))) + (catch + Exception any + (println + (str + "ERROR: Exception " + (.getName (.getClass any)) + (.getMessage any) + " while printing " + filepath)))))) diff --git a/src/adl/to_reframe.clj b/src/adl/to_reframe.clj index c23536e..84a5c52 100644 --- a/src/adl/to_reframe.clj +++ b/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)) diff --git a/src/adl/to_selmer_routes.clj b/src/adl/to_selmer_routes.clj index 62170c1..fa2158d 100644 --- a/src/adl/to_selmer_routes.clj +++ b/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,25 +67,39 @@ 'defn (symbol n) (vector 'r) - (list 'let (vector 'p (list :params 'r)) ;; TODO: we must take key params out of just params, + (list 'let (vector + 'p + (list + 'merge + (list 'support/query-string-to-map (list :query-string 'r)) + (list :params 'r))) + ;; TODO: we must take key params out of just params, ;; but we should take all other params out of form-params - because we need the key to ;; load the form in the first place, but just accepting values of other params would ;; allow spoofing. (list 'l/render - (list 'resolve-template (str n ".html")) + (list 'support/resolve-template (str n ".html")) (merge {:title (capitalise (:name (:attrs f))) :params 'p} (case (:tag f) (:form :page) - {:record - (list 'if (list 'empty? (list 'remove 'nil? (list 'vals 'p))) [] - (list - (symbol - (str "db/get-" (singularise (:name (:attrs e))))) - (symbol "db/*db*") - 'p))} + (reduce + merge + {:record + (list 'if (list 'empty? (list 'remove 'nil? (list 'vals 'p))) [] + (list + (symbol + (str "db/get-" (singularise (:name (:attrs e))))) + (symbol "db/*db*") + 'p))} + (map + (fn [p] + (hash-map + (keyword (-> p :attrs :entity)) + (list (symbol (str "db/list-" (:entity (:attrs p)))) (symbol "db/*db*")))) + (filter #(= (:type (:attrs %)) "entity") (descendants-with-tag e :property)))) :list {:records (list @@ -167,43 +187,49 @@ (defn to-selmer-routes [application] - (let [filename (str *output-path* (:name (:attrs application)) "/routes/auto.clj")] - (make-parents filename) - (with-open [output (writer filename)] - (binding [*out* output] - (pprint (file-header application)) - (println) - (pprint '(defn raw-resolve-template [n] - (if - (.exists (io/as-file (str "resources/templates/" n))) - n - (str "auto/" n)))) - (println) - (pprint '(def resolve-template (memoize raw-resolve-template))) - (println) - (pprint '(defn index - [r] - (l/render - (resolve-template - "application-index.html") - {:title "Administrative menu"}))) - (println) - (doall - (map - (fn [e] - (doall - (map - (fn [c] - (pprint (make-handler c e application)) - (println)) - (filter (fn [c] (#{:form :list :page} (:tag c))) (children e))))) - (children-with-tag application :entity))) - (pprint - (generate-handler-resolver application)) - (println) - (pprint '(def resolve-handler - (memoize raw-resolve-handler))) - (println) - (pprint (make-defroutes application)) - (println))))) + (let [filepath (str *output-path* "src/clj/" (:name (:attrs application)) "/routes/auto.clj")] + (make-parents filepath) + (try + (with-open [output (writer filepath)] + (binding [*out* output] + (pprint (file-header application)) + (println) + (pprint '(defn admin + [r] + (l/render + (support/resolve-template + "application-index.html") + {:title "Administrative menu"}))) + (println) + (doall + (map + (fn [e] + (doall + (map + (fn [c] + (pprint (make-handler c e application)) + (println)) + (filter (fn [c] (#{:form :list :page} (:tag c))) (children e))))) + (sort + #(compare (:name (:attrs %1))(:name (:attrs %2))) + (children-with-tag application :entity)))) + (pprint + (generate-handler-resolver application)) + (println) + (pprint '(def resolve-handler + (memoize raw-resolve-handler))) + (println) + (pprint (make-defroutes application)) + (println))) + (if (> *verbosity* 0) + (println (str "\tGenerated " filepath))) + (catch + Exception any + (println + (str + "ERROR: Exception " + (.getName (.getClass any)) + (.getMessage any) + " while printing " + filepath)))))) diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj index 17aa062..9c8a8df 100644 --- a/src/adl/to_selmer_templates.clj +++ b/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] - [clojure.java.io :refer [file]] + (:require [adl-support.utils :refer :all] + [clojure.java.io :refer [file make-parents]] [clojure.pprint :as p] [clojure.string :as s] [clojure.xml :as x] @@ -145,7 +145,8 @@ (defn save-widget "Return an appropriate 'save' widget for this `form` operating on this `entity` taken - from this `application`." + from this `application`. + TODO: should be suppressed unless a member of a group which can insert or edit." [form entity application] {:tag :p :attrs {:class "widget action-safe"} @@ -156,13 +157,14 @@ :attrs {:id "save-button" :name "save-button" :class "action-safe" - :type :submit + :type "submit" :value (str "Save!")}}]}) (defn delete-widget "Return an appropriate 'save' widget for this `form` operating on this `entity` taken - from this `application`." + from this `application`. + TODO: should be suppressed unless member of a group which can delete." [form entity application] {:tag :p :attrs {:class "widget action-dangerous"} @@ -173,7 +175,7 @@ :attrs {:id "delete-button" :name "delete-button" :class "action-dangerous" - :type :submit + :type "submit" :value (str "Delete!")}}]}) @@ -259,21 +261,10 @@ :content (apply vector (get-options property form entity application))})))})) -(defn permissions-for - [property entity application] - (first - (remove - empty? - (list - (children-with-tag property :permission) - (children-with-tag entity :permission) - (children-with-tag application :permission))))) - - (defn compose-if-member-of-tag [property entity application writable?] (let - [all-permissions (permissions-for property entity application) + [all-permissions (find-permissions property entity application) permissions (if writable? (writable-by all-permissions) (visible-to all-permissions))] (s/join " " @@ -295,20 +286,18 @@ property (if (= (:tag field-or-property) :property) field-or-property - (first - (children - entity - #(and - (= (:tag %) :property) - (= (:name (:attrs %)) (:property (:attrs field-or-property))))))) - permissions (permissions property form entity application) + (child-with-tag entity + :property + #(= (:name (:attrs %)) + (:property (:attrs field-or-property))))) + permissions (find-permissions field-or-property property form entity application) typedef (typedef property application) visible-to (visible-to permissions) ;; if the form isn't actually a form, no widget is writable. writable-by (if (= (:tag form) :form) (writable-by permissions)) select? (#{"entity" "list" "link"} (:type (:attrs property)))] (if - (formal-primary-key? property entity) + (= (:distinct (:attrs property)) "system") {:tag :input :attrs {:id widget-name :name widget-name @@ -343,45 +332,44 @@ :name widget-name :class "pseudo-widget disabled"} :content [(str "{{record." widget-name "}}")]} + "{% else %}" + {:tag :span + :attrs {:id widget-name + :name widget-name + :class "pseudo-widget not-authorised"} + :content [(str "You are not permitted to view " widget-name " of " (:name (:attrs entity)))]} "{% endifmemberof %}" "{% endifmemberof %}"]}))) -(defn fields - [form] - (descendants-with-tag form :field)) - - - (defn form-to-template "Generate a template as specified by this `form` element for this `entity`, taken from this `application`. If `form` is nill, generate a default form template for the entity." [form entity application] - (let - [keyfields (children - ;; there should only be one key; its keys are properties - (first (children entity #(= (:tag %) :key))))] - {:tag :div - :attrs {:id "content" :class "edit"} - :content - [{:tag :form - :attrs {:action (str "{{servlet-context}}/" (editor-name entity application)) - :method "POST"} - :content (flatten - (list + {:tag :div + :attrs {:id "content" :class "edit"} + :content + [{:tag :form + :attrs {:action (str "{{servlet-context}}/" (editor-name entity application)) + :method "POST"} + :content (flatten + (list (csrf-widget) (map - #(widget % form entity application) - keyfields) + #(widget % form entity application) + (children-with-tag (child-with-tag entity :key) :properties)) (map - #(widget % form entity application) - (remove - #(= (:distict (:attrs %)) :system) - (fields entity))) + #(widget % form entity application) + (remove + #(let + [property (filter + (fn [p] (= (:name (:attrs p)) (:property (:attrs %)))) + (descendants-with-tag entity :property))] + (= (:distict (:attrs property)) :system)) + (children-with-tag form :field))) (save-widget form entity application) - (delete-widget form entity application)))}]})) - + (delete-widget form entity application)))}]}) (defn page-to-template @@ -434,7 +422,7 @@ #(hash-map :content [(prompt %)] :tag :th) - (fields list-spec)))} + (children-with-tag list-spec :field)))} {:tag :tr :content (apply @@ -442,7 +430,7 @@ (concat (map #(compose-list-search-widget % entity) - (fields list-spec)) + (children-with-tag list-spec :field)) '({:tag :th :content [{:tag :input @@ -492,7 +480,7 @@ :attrs {:href (edit-link e application (list (:name (:attrs p))))} :content [(str "{{ record." (:property (:attrs field)) "_expanded }}")]}] [c]))}) - (fields list-spec)) + (children-with-tag list-spec :field)) [{:tag :td :content [{:tag :a @@ -623,31 +611,35 @@ (defn write-template-file [filename template application] - (if - template - (try - (spit - (str *output-path* filename) - (s/join - "\n" - (list - (file-header filename application) - (with-out-str - (x/emit-element template)) - (file-footer filename application)))) - (catch Exception any + (let [filepath (str *output-path* "resources/templates/auto/" filename)] + (make-parents filepath) + (if + template + (try (spit - (str *output-path* filename) - (with-out-str - (println - (str - "")) - (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 "")) + (p/pprint template))) + (println report))))) + (str filepath))) (defn to-selmer-templates @@ -668,12 +660,13 @@ (try (write-template-file filename (templates-map %) application) (catch Exception any - (str - "Exception " - (.getName (.getClass any)) - (.getMessage any) - " while writing " - filename))))) + (println + (str + "ERROR: Exception " + (.getName (.getClass any)) + (.getMessage any) + " while writing " + filename)))))) (keys templates-map))))) diff --git a/src/adl/utils.clj b/src/adl/utils.clj deleted file mode 100644 index 09888cc..0000000 --- a/src/adl/utils.clj +++ /dev/null @@ -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)))) diff --git a/src/adl/validator.clj b/src/adl/validator.clj index 9513542..8602f90 100644 --- a/src/adl/validator.clj +++ b/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 (: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))) + + From 9bf773a978c4719b0aaf3becb1b2e5f9c0d0d9f5 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 20 Jun 2018 10:12:47 +0100 Subject: [PATCH 2/7] Updated README to take account of the fact this is beginning to work. --- README.md | 21 ++++++++++++++++++++- 1 file changed, 20 insertions(+), 1 deletion(-) diff --git a/README.md b/README.md index e35ec34..a0e8527 100644 --- a/README.md +++ b/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, 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. From ea9341145eb188df2ddf36759899ae80502ebb5c Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 20 Jun 2018 10:12:47 +0100 Subject: [PATCH 3/7] Updated README to take account of the fact this is beginning to work. --- README.md | 21 ++++++++++++++++++++- 1 file changed, 20 insertions(+), 1 deletion(-) diff --git a/README.md b/README.md index e35ec34..ad18847 100644 --- a/README.md +++ b/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. From 3320cff4b5332c310221300dc1e3efb5e2342ab4 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 29 Jun 2018 11:14:42 +0100 Subject: [PATCH 4/7] Substantial improvements --- src/adl/to_hugsql_queries.clj | 50 +++++++++++++++++---------------- src/adl/to_selmer_routes.clj | 7 ++--- src/adl/to_selmer_templates.clj | 13 ++++++++- 3 files changed, 40 insertions(+), 30 deletions(-) diff --git a/src/adl/to_hugsql_queries.clj b/src/adl/to_hugsql_queries.clj index 4a983ab..a79f174 100644 --- a/src/adl/to_hugsql_queries.clj +++ b/src/adl/to_hugsql_queries.clj @@ -165,31 +165,33 @@ pretty-name " records having any string field matching the parameter of the same name by substring match") (str "SELECT * FROM lv_" entity-name) - "WHERE " (s/join - "\n\tOR " - (filter - string? - (map - #(case (:type (:attrs %)) - ("string" "text") - (str - (safe-name (-> % :attrs :name) :sql) - " LIKE '%params." - (-> % :attrs :name) "%'") - ("date" "time" "timestamp") - (str - (safe-name (-> % :attrs :name) :sql) - " = 'params." - (-> % :attrs :name) "'") - (str - (safe-name (-> % :attrs :name) :sql) - " = params." - (-> % :attrs :name))) - properties))) - (order-by-clause entity "lv_") - "--~ (if (:offset params) \"OFFSET :offset \")" - "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))}))) + "\n\t--~ " + (cons + "WHERE false" + (filter + string? + (map + #(str + "(if (:" (-> % :attrs :name) " params) \"OR " + (case (:type (:attrs %)) + ("string" "text" "defined") ;; TODO: 'defined' types may be string or number - more work here + (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 diff --git a/src/adl/to_selmer_routes.clj b/src/adl/to_selmer_routes.clj index fa2158d..acaa24f 100644 --- a/src/adl/to_selmer_routes.clj +++ b/src/adl/to_selmer_routes.clj @@ -69,10 +69,7 @@ (vector 'r) (list 'let (vector 'p - (list - 'merge - (list 'support/query-string-to-map (list :query-string 'r)) - (list :params 'r))) + (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 @@ -194,7 +191,7 @@ (binding [*out* output] (pprint (file-header application)) (println) - (pprint '(defn admin + (pprint '(defn index [r] (l/render (support/resolve-template diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj index 9c8a8df..c8d6d3e 100644 --- a/src/adl/to_selmer_templates.clj +++ b/src/adl/to_selmer_templates.clj @@ -318,7 +318,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))}) From 9d086f7028064cb77c741c0ba13cae5537f59e3b Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 29 Jun 2018 18:40:29 +0100 Subject: [PATCH 5/7] Minor fixes and tidyings --- src/adl/to_psql.clj | 4 ++-- src/adl/to_selmer_routes.clj | 2 +- src/adl/to_selmer_templates.clj | 13 ++++++++----- 3 files changed, 11 insertions(+), 8 deletions(-) diff --git a/src/adl/to_psql.clj b/src/adl/to_psql.clj index ee7f549..f7aea86 100644 --- a/src/adl/to_psql.clj +++ b/src/adl/to_psql.clj @@ -447,8 +447,8 @@ (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)}}) diff --git a/src/adl/to_selmer_routes.clj b/src/adl/to_selmer_routes.clj index acaa24f..50a1585 100644 --- a/src/adl/to_selmer_routes.clj +++ b/src/adl/to_selmer_routes.clj @@ -150,7 +150,7 @@ 'auto-selmer-routes (cons '(GET - "/index" + "/admin" request (route/restricted (apply (resolve-handler "index") (list request)))) diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj index c8d6d3e..b4feb07 100644 --- a/src/adl/to_selmer_templates.clj +++ b/src/adl/to_selmer_templates.clj @@ -405,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 @@ -480,16 +482,17 @@ {: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]))}) (children-with-tag list-spec :field)) [{:tag :td From 7ea6b5f29990fda39caec87f9c47c31a174e1eae Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 29 Jun 2018 23:37:55 +0100 Subject: [PATCH 6/7] Detail work, improving robustness and presentation. --- src/adl/to_hugsql_queries.clj | 14 +++++++------- src/adl/to_selmer_routes.clj | 4 +++- src/adl/to_selmer_templates.clj | 17 ++++++++++++----- 3 files changed, 22 insertions(+), 13 deletions(-) diff --git a/src/adl/to_hugsql_queries.clj b/src/adl/to_hugsql_queries.clj index a79f174..673023d 100644 --- a/src/adl/to_hugsql_queries.clj +++ b/src/adl/to_hugsql_queries.clj @@ -140,7 +140,7 @@ {})) -(defn search-query [entity] +(defn search-query [entity application] "Generate an appropriate search query for string fields of this `entity`" (let [entity-name (safe-name (:name (:attrs entity)) :sql) pretty-name (singularise entity-name) @@ -164,7 +164,7 @@ "-- :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) (s/join "\n\t--~ " (cons @@ -174,8 +174,8 @@ (map #(str "(if (:" (-> % :attrs :name) " params) \"OR " - (case (:type (:attrs %)) - ("string" "text" "defined") ;; TODO: 'defined' types may be string or number - more work here + (case (base-type % application) + ("string" "text") (str (safe-name (-> % :attrs :name) :sql) " LIKE '%:" (-> % :attrs :name) "%'") @@ -257,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\")")))}))) @@ -359,7 +359,7 @@ (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 "SELECT DISTINCT "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") @@ -428,7 +428,7 @@ (delete-query entity) (select-query entity) (list-query entity) - (search-query entity) + (search-query entity application) (foreign-queries entity application))) ([application] (apply diff --git a/src/adl/to_selmer_routes.clj b/src/adl/to_selmer_routes.clj index 50a1585..645a640 100644 --- a/src/adl/to_selmer_routes.clj +++ b/src/adl/to_selmer_routes.clj @@ -77,6 +77,7 @@ (list 'l/render (list 'support/resolve-template (str n ".html")) + '(:session r) (merge {:title (capitalise (:name (:attrs f))) :params 'p} @@ -96,7 +97,8 @@ (hash-map (keyword (-> p :attrs :entity)) (list (symbol (str "db/list-" (:entity (:attrs p)))) (symbol "db/*db*")))) - (filter #(= (:type (:attrs %)) "entity") (descendants-with-tag e :property)))) + (filter #(#{"entity" "link"} (:type (:attrs %))) + (descendants-with-tag e :property)))) :list {:records (list diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj index b4feb07..640af91 100644 --- a/src/adl/to_selmer_templates.clj +++ b/src/adl/to_selmer_templates.clj @@ -132,7 +132,6 @@ #(and (= (:tag %) :prompt) (= (:locale :attrs %) *locale*)))) - (:name (:attrs field-or-property)) (:property (:attrs field-or-property))))) @@ -265,7 +264,12 @@ [property entity application writable?] (let [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 @@ -590,9 +594,12 @@ (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)))] {:application-index {:tag :dl :attrs {:class "index"} From a4e0fd1c9a32408bda86b9677c1a00b4f9267c30 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 30 Jun 2018 12:53:08 +0100 Subject: [PATCH 7/7] Added volatility to entities, to enable cacheing. --- resources/schemas/adl-1.4.1.dtd | 22 +++-- resources/transforms/adl2canonical.xslt | 19 ++-- src/adl/to_hugsql_queries.clj | 74 ---------------- src/adl/to_json_routes.clj | 112 +++++++++++++----------- src/adl/to_selmer_routes.clj | 1 + 5 files changed, 87 insertions(+), 141 deletions(-) diff --git a/resources/schemas/adl-1.4.1.dtd b/resources/schemas/adl-1.4.1.dtd index 3f02697..53a9402 100644 --- a/resources/schemas/adl-1.4.1.dtd +++ b/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,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. --> + table CDATA #IMPLIED + foreign %Boolean; #IMPLIED + magnitude CDATA #IMPLIED + volatility CDATA #IMPLIED> - - - entity already has a key - not generating one - - + + + entity already has a key - not generating one + + 6 + + 0 + - - - + + + diff --git a/src/adl/to_hugsql_queries.clj b/src/adl/to_hugsql_queries.clj index 673023d..6011417 100644 --- a/src/adl/to_hugsql_queries.clj +++ b/src/adl/to_hugsql_queries.clj @@ -321,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 DISTINCT "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`" diff --git a/src/adl/to_json_routes.clj b/src/adl/to_json_routes.clj index 5464313..7b192ed 100644 --- a/src/adl/to_json_routes.clj +++ b/src/adl/to_json_routes.clj @@ -48,6 +48,7 @@ :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) @@ -226,22 +242,16 @@ (try (with-open [output (writer filepath)] (binding [*out* output] - (doall - (map - (fn [f] - (pprint f) - (println "\n")) - (list - (file-header application) - (declarations handlers-map) - (defroutes handlers-map)))) + (pprint (file-header application)) + (println) (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 diff --git a/src/adl/to_selmer_routes.clj b/src/adl/to_selmer_routes.clj index 645a640..ea6f7ed 100644 --- a/src/adl/to_selmer_routes.clj +++ b/src/adl/to_selmer_routes.clj @@ -198,6 +198,7 @@ (l/render (support/resolve-template "application-index.html") + (:session r) {:title "Administrative menu"}))) (println) (doall