diff --git a/.gitignore b/.gitignore index 96ff9d7..43b9a5b 100644 --- a/.gitignore +++ b/.gitignore @@ -27,3 +27,7 @@ node_modules/ generated/ + +*.orig + +*.out diff --git a/project.clj b/project.clj index f07537d..d306ce5 100644 --- a/project.clj +++ b/project.clj @@ -8,7 +8,7 @@ :dependencies [[adl-support "0.1.8-SNAPSHOT"] [bouncer "1.0.1"] [clojure-saxon "0.9.4"] - [environ "1.2.0"] + [environ "1.1.0"] [hiccup "1.0.5"] [org.clojure/clojure "1.12.0"] [org.clojure/math.combinatorics "0.3.0"] diff --git a/src/adl/to_hugsql_queries.clj b/src/adl/to_hugsql_queries.clj index 1d5a160..9104710 100644 --- a/src/adl/to_hugsql_queries.clj +++ b/src/adl/to_hugsql_queries.clj @@ -31,78 +31,78 @@ ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (def expanded-token "_expanded") +(def expanded-token "_expanded") - (defn where-clause - "Generate an appropriate `where` clause for queries on this `entity`; +(defn where-clause + "Generate an appropriate `where` clause for queries on this `entity`; if `properties` are passed, filter on those properties, otherwise the key properties." - ([entity] - (where-clause entity (key-properties entity))) - ([entity properties] - (let + ([entity] + (where-clause entity (key-properties entity))) + ([entity properties] + (let [entity-name (safe-name entity :sql) property-names (map #(:name (:attrs %)) properties)] (when-not (empty? property-names) (str "WHERE " (s/join - "\n\tAND " - (map - #(str entity-name "." (safe-name % :sql) " = :" %) - property-names))))))) + "\n\tAND " + (map + #(str entity-name "." (safe-name % :sql) " = :" %) + property-names))))))) - (defn order-by-clause - "Generate an appropriate `order by` clause for queries on this `entity`" - ([entity] - (order-by-clause entity "" false)) - ([entity prefix] - (order-by-clause entity prefix false)) - ([entity prefix expanded?] - (let +(defn order-by-clause + "Generate an appropriate `order by` clause for queries on this `entity`" + ([entity] + (order-by-clause entity "" false)) + ([entity prefix] + (order-by-clause entity prefix false)) + ([entity prefix expanded?] + (let [entity-name (safe-name entity :sql) preferred (filter #(#{"user" "all"} (-> % :attrs :distinct)) (descendants-with-tag entity :property))] - (if + (if (empty? preferred) - "" - (str + "" + (str "ORDER BY " prefix entity-name "." (s/join - (str ",\n\t" prefix entity-name ".") - (map - #(if - (and expanded? (= "entity" (-> % :attrs :type))) - (str (safe-name % :sql) expanded-token) - (safe-name % :sql)) - (order-preserving-set - (concat - preferred - (key-properties entity)))))))))) + (str ",\n\t" prefix entity-name ".") + (map + #(if + (and expanded? (= "entity" (-> % :attrs :type))) + (str (safe-name % :sql) expanded-token) + (safe-name % :sql)) + (order-preserving-set + (concat + preferred + (key-properties entity)))))))))) ;; (def a (x/parse "../youyesyet/youyesyet.adl.xml")) ;; (def e (child-with-tag a :entity #(= "dwellings" (-> % :attrs :name)))) ;; (order-by-clause e "" true) - (defn insert-query - "Generate an appropriate `insert` query for this `entity`. +(defn insert-query + "Generate an appropriate `insert` query for this `entity`. TODO: this depends on the idea that system-unique properties are not insertable, which is... dodgy." - [entity] - (let [entity-name (safe-name entity :sql) - pretty-name (singularise entity-name) - insertable-property-names (map + [entity] + (let [entity-name (safe-name entity :sql) + pretty-name (singularise entity-name) + insertable-property-names (map #(safe-name % :sql) (insertable-properties entity)) query-name (str "create-" pretty-name "!") signature (if (has-primary-key? entity) ":? :1" ;; bizarrely, if you want to return the keys, ;; you have to use a query signature. - ":! :n")] - (hash-map + ":! :n")] + (hash-map (keyword query-name) {:name query-name :signature signature @@ -117,26 +117,26 @@ (s/join ",\n\t" (map keyword insertable-property-names)) ")" (if - (has-primary-key? entity) + (has-primary-key? entity) (str "\nreturning " (s/join - ",\n\t" - (map - #(safe-name % :sql) - (key-names entity))))))}))) + ",\n\t" + (map + #(safe-name % :sql) + (key-names entity))))))}))) - (defn update-query - "Generate an appropriate `update` query for this `entity`" - [entity] - (let [entity-name (safe-name entity :sql) - pretty-name (singularise entity-name) - property-names (map +(defn update-query + "Generate an appropriate `update` query for this `entity`" + [entity] + (let [entity-name (safe-name entity :sql) + pretty-name (singularise entity-name) + property-names (map #(-> % :attrs :name) (insertable-properties entity)) - query-name (str "update-" pretty-name "!") - signature ":! :n"] - (hash-map + query-name (str "update-" pretty-name "!") + signature ":! :n"] + (hash-map (keyword query-name) {:name query-name :signature signature @@ -148,10 +148,10 @@ "UPDATE " entity-name "\n" "SET " (s/join - ",\n\t" - (map - #(str (safe-name % :sql) " = " (keyword %)) - property-names)) + ",\n\t" + (map + #(str (safe-name % :sql) " = " (keyword %)) + property-names)) "\n" (where-clause entity))}))) @@ -168,66 +168,67 @@ pretty-name (singularise entity-name) query-name (str "search-strings-" entity-name) signature ":? :*" - properties (remove #(#{"(safe-name entity :sql)"} (:type (:attrs %))) (all-properties entity))] + properties (remove #(#{"(safe-name entity :sql)"}(:type (:attrs %))) (all-properties entity))] (hash-map - (keyword query-name) - {:name query-name - :signature signature - :entity entity - :type :text-search - :query - (s/join - "\n" - (remove - empty? - (list - (str "-- :name " query-name " " signature) - (str - "-- :doc selects existing " - pretty-name - " records having any string field matching the parameter of the same name by substring match") - (str "SELECT DISTINCT * FROM lv_" entity-name) - (s/join - "\n\t--~ " - (cons - "WHERE true" - (filter - string? - (map - #(let - [sn (safe-name % :sql)] - (str - "(if (:" (-> % :attrs :name) " params) (str \"AND " - (case (-> % :attrs :type) - ("string" "text") - (str - sn - " LIKE '%\" (:" (-> % :attrs :name) " params) \"%' ") - ("date" "time" "timestamp") - (str - sn - " = ':" (-> % :attrs :name) "'") - "entity" - (str - sn - "_expanded LIKE '%\" (:" (-> % :attrs :name) " params) \"%'") - (str - sn - " = :" - (-> % :attrs :name))) - "\"))")) - properties)))) - (order-by-clause entity "lv_" true) - "--~ (if (:offset params) \"OFFSET :offset \")" - "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))})))) + (keyword query-name) + {:name query-name + :signature signature + :entity entity + :type :text-search + :query + (s/join + "\n" + (remove + empty? + (list + (str "-- :name " query-name " " signature) + (str + "-- :doc selects existing " + pretty-name + " records having any string field matching the parameter of the same name by substring match") + (str "SELECT DISTINCT * FROM lv_" entity-name) + (s/join + "\n\t--~ " + (cons + "WHERE true" + (filter + string? + (map + #(let + [sn (safe-name % :sql)] + (str + "(if (:" (-> % :attrs :name) " params) (str \"AND " + (case (-> % :attrs :type) + ("string" "text") + (str + sn + " LIKE '%\" (:" (-> % :attrs :name) " params) \"%' ") + ("date" "time" "timestamp") + (str + sn + " = ':" (-> % :attrs :name) "'") + "entity" + (str + sn + "_expanded LIKE '%\" (:" (-> % :attrs :name) " params) \"%'") + (str + sn + " = :" + (-> % :attrs :name))) + "\"))")) + properties)))) + (order-by-clause entity "lv_" true) + "--~ (if (:offset params) \"OFFSET :offset \")" + "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))})))) ;; (search-query e a) + (defn select-query "Generate an appropriate `select` query for this `entity`" ([entity properties] (if-not - (empty? properties) + (empty? properties) (let [entity-name (safe-name entity :sql) pretty-name (singularise entity-name) query-name (if (= properties (key-properties entity)) @@ -237,32 +238,32 @@ (map #(:name (:attrs %)) properties)))) signature ":? :1"] (hash-map - (keyword query-name) - {:name query-name - :signature signature - :entity entity - :type :select-1 - :query - (s/join - "\n" - (remove - empty? - (list - (str "-- :name " query-name " " signature) - (str "-- :doc selects an existing " pretty-name " record") - (str "SELECT * FROM " entity-name) - (where-clause entity properties) - (order-by-clause entity))))})) + (keyword query-name) + {:name query-name + :signature signature + :entity entity + :type :select-1 + :query + (s/join + "\n" + (remove + empty? + (list + (str "-- :name " query-name " " signature) + (str "-- :doc selects an existing " pretty-name " record") + (str "SELECT * FROM " entity-name) + (where-clause entity properties) + (order-by-clause entity))))})) {})) ([entity] (let [distinct-fields (distinct-properties entity)] (apply - merge - (cons - (select-query entity (key-properties entity)) - (map - #(select-query entity %) - (combinations distinct-fields (count distinct-fields)))))))) + merge + (cons + (select-query entity (key-properties entity)) + (map + #(select-query entity %) + (combinations distinct-fields (count distinct-fields)))))))) (defn list-query @@ -275,23 +276,23 @@ query-name (str "list-" entity-name) signature ":? :*"] (hash-map - (keyword query-name) - {:name query-name - :signature signature - :entity entity - :type :select-many - :query - (s/join - "\n" - (remove - empty? - (list - (str "-- :name " query-name " " signature) - (str "-- :doc lists all existing " pretty-name " records") - (str "SELECT DISTINCT lv_" entity-name ".* FROM lv_" entity-name) - (order-by-clause entity "lv_" false) - "--~ (if (:offset params) \"OFFSET :offset \")" - "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))}))) + (keyword query-name) + {:name query-name + :signature signature + :entity entity + :type :select-many + :query + (s/join + "\n" + (remove + empty? + (list + (str "-- :name " query-name " " signature) + (str "-- :doc lists all existing " pretty-name " records") + (str "SELECT DISTINCT lv_" entity-name ".* FROM lv_" entity-name) + (order-by-clause entity "lv_" false) + "--~ (if (:offset params) \"OFFSET :offset \")" + "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))}))) (defn foreign-queries @@ -363,22 +364,22 @@ "Generate an appropriate `delete` query for this `entity`" [entity] (if - (has-primary-key? entity) + (has-primary-key? entity) (let [entity-name (safe-name entity :sql) pretty-name (singularise entity-name) query-name (str "delete-" pretty-name "!") signature ":! :n"] (hash-map - (keyword query-name) - {:name query-name - :signature signature - :entity entity - :type :delete-1 - :query - (str "-- :name " query-name " " signature "\n" - "-- :doc deletes an existing " pretty-name " record\n" - "DELETE FROM " entity-name "\n" - (where-clause entity))})))) + (keyword query-name) + {:name query-name + :signature signature + :entity entity + :type :delete-1 + :query + (str "-- :name " query-name " " signature "\n" + "-- :doc deletes an existing " pretty-name " record\n" + "DELETE FROM " entity-name "\n" + (where-clause entity))})))) (defn queries @@ -387,18 +388,18 @@ ([application entity] (merge ;; TODO: queries that look through link tables - (insert-query entity) - (update-query entity) - (delete-query entity) - (select-query entity) - (list-query entity) - (search-query entity application) - (foreign-queries entity application))) + (insert-query entity) + (update-query entity) + (delete-query entity) + (select-query entity) + (list-query entity) + (search-query entity application) + (foreign-queries entity application))) ([application] (apply - merge - (map #(queries application %) - (children-with-tag application :entity))))) + merge + (map #(queries application %) + (children-with-tag application :entity))))) (defn to-hugsql-queries @@ -407,25 +408,25 @@ (let [filepath (str *output-path* "resources/sql/queries.auto.sql")] (make-parents filepath) (do-or-warn - (do - (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 (pos? *verbosity*) - (*warn* (str "\tGenerated " filepath))))))) + (do + (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 (pos? *verbosity*) + (*warn* (str "\tGenerated " filepath))))))) (defn generate-documentation @@ -433,68 +434,68 @@ [query] (let [v (volatility (:entity query))] (s/join - " " - (list - (case - (:type query) - :delete-1 - (str "delete one record from the `" - (-> query :entity :attrs :name) - "` table. Expects the following key(s) to be present in `params`: `" - (-> query :entity key-names) - "`.") - :insert-1 - (str "insert one record to the `" - (-> query :entity :attrs :name) - "` table. Expects the following key(s) to be present in `params`: `" - (pr-str - (map - #(keyword (:name (:attrs %))) - (-> query :entity insertable-properties))) - "`. Returns a map containing the keys `" - (-> query :entity key-names) - "` identifying the record created.") - :select-1 - (str "select one record from the `" - (-> query :entity :attrs :name) - "` table. Expects the following key(s) to be present in `params`: `" - (-> query :entity key-names) - "`. Returns a map containing the following keys: `" - (map #(keyword (:name (:attrs %))) (-> query :entity all-properties)) - "`.") - :select-many - (str "select all records from the `" - (-> 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 - (map - #(keyword (:name (:attrs %))) - (-> query :entity all-properties))) - "`.") - :text-search - (str "select all records from the `" - (-> query :entity :attrs :name) + " " + (list + (case + (:type query) + :delete-1 + (str "delete one record from the `" + (-> query :entity :attrs :name) + "` table. Expects the following key(s) to be present in `params`: `" + (-> query :entity key-names) + "`.") + :insert-1 + (str "insert one record to the `" + (-> query :entity :attrs :name) + "` table. Expects the following key(s) to be present in `params`: `" + (pr-str + (map + #(keyword (:name (:attrs %))) + (-> query :entity insertable-properties ))) + "`. Returns a map containing the keys `" + (-> query :entity key-names) + "` identifying the record created.") + :select-1 + (str "select one record from the `" + (-> query :entity :attrs :name) + "` table. Expects the following key(s) to be present in `params`: `" + (-> query :entity key-names) + "`. Returns a map containing the following keys: `" + (map #(keyword (:name (:attrs %))) (-> query :entity all-properties)) + "`.") + :select-many + (str "select all records from the `" + (-> 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 + (map + #(keyword (:name (:attrs %))) + (-> query :entity all-properties))) + "`.") + :text-search + (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 - (map - #(keyword (:name (:attrs %))) - (-> query :entity all-properties))) - "`.") - :update-1 - (str "update one record in the `" - (-> query :entity :attrs :name) - "` table. Expects the following key(s) to be present in `params`: `" - (pr-str - (distinct - (sort - (map - #(keyword (:name (:attrs %))) - (flatten - (cons - (-> query :entity key-properties) - (-> query :entity insertable-properties))))))) - "`.")) - (if-not - (zero? v) - (str "Results will be held in cache for " v " seconds.")))))) + "` 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 + (map + #(keyword (:name (:attrs %))) + (-> query :entity all-properties))) + "`.") + :update-1 + (str "update one record in the `" + (-> query :entity :attrs :name) + "` table. Expects the following key(s) to be present in `params`: `" + (pr-str + (distinct + (sort + (map + #(keyword (:name (:attrs %))) + (flatten + (cons + (-> query :entity key-properties) + (-> query :entity insertable-properties))))))) + "`.")) + (if-not + (zero? v) + (str "Results will be held in cache for " v " seconds.")))))) diff --git a/src/adl/to_psql.clj b/src/adl/to_psql.clj index 8109b94..64d6826 100644 --- a/src/adl/to_psql.clj +++ b/src/adl/to_psql.clj @@ -1,13 +1,20 @@ (ns ^{:doc "Application Description Language: generate Postgres database definition." :author "Simon Brooke"} adl.to-psql - (:require [adl-support.core :refer :all] - [adl-support.utils :refer :all] - ;; [adl.to-hugsql-queries :refer [queries]] - [clojure.java.io :refer [make-parents]] - [clojure.string :as s] - [clj-time.core :as t] - [clj-time.format :as f])) + (:require + [adl-support.core :refer [*warn* do-or-warn]] + [adl-support.utils :refer [*output-path* *verbosity* all-properties child + child-with-tag children-with-tag emit-header + entity-for-property entity? find-permissions + is-quotable-type? key-names key-properties + link-table-name properties property-for-field + safe-name singularise sort-by-name + system-generated? typedef unique-link? + user-distinct-properties]] ;; [adl.to-hugsql-queries :refer [queries]] + [clj-time.core :as t] + [clj-time.format :as f] + [clojure.java.io :refer [make-parents]] + [clojure.string :as s])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; @@ -161,7 +168,7 @@ #(if (selector (:permission (:attrs %))) (safe-name (:group (:attrs %)) :sql)) permissions)))] - (if-not + (when-not (empty? group-names) (s/join " " @@ -193,11 +200,12 @@ ([property entity application] (emit-property property entity application false)) ([property entity application key?] - (let [default (:default (:attrs property))] - (if + (let [default (:default (:attrs property)) + type (-> property :attrs :type)] + (when (and (= (:tag property) :property) - (not (#{"link"} (:type (:attrs property))))) + (not (#{"link" "list"} type))) (s/join " " (remove @@ -207,14 +215,14 @@ "\t" (field-name property) (emit-field-type property entity application key?) - (if + (when 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. + ;; it's quite common for `now()` to be the default for a date, time or timestamp field. default))) (if key? @@ -223,20 +231,25 @@ (defn compose-convenience-entity-field - [field entity application] - (let [farside (entity-for-property (property-for-field field entity) application)] + ([field entity application] + (compose-convenience-entity-field field entity application nil)) + ([field entity application table-alias] + (let [property (case (:tag field) + :field (property-for-field field entity) + :property field) + farside (entity-for-property property application)] (flatten (map - (fn [f] + (fn [p] (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))))) + (= (:type (:attrs p)) "entity") + (compose-convenience-entity-field p farside application (field-name property)) + (str (or table-alias (safe-name farside :sql)) "." (field-name p)))) + (user-distinct-properties farside)))))) -(defn compose-convenience-view-select-list - "Compose the body of an SQL `SELECT` statement for a convenience view of this +(defn compose-convenience-view-from-list + "Compose the FROM list of an SQL `SELECT` statement for a convenience view of this `entity` within this `application`, recursively. `top-level?` should be set only on first invocation." [entity application top-level?] @@ -244,15 +257,17 @@ nil? (flatten (cons - (safe-name (:table (:attrs entity)) :sql) + (safe-name entity :sql) (map (fn [f] - (if + (when (= (:type (:attrs f)) "entity") - (compose-convenience-view-select-list - (child application #(and (entity? %) (= (:name (:attrs %))(:entity (:attrs f))))) - application - false))) + (let [farside (child application #(and (entity? %) (= (:name (:attrs %))(:entity (:attrs f))))) + tablename (safe-name farside :sql) + fieldname (field-name f)] + (if (= tablename fieldname) + tablename + (str tablename " AS " fieldname))))) (if top-level? (all-properties entity) @@ -271,19 +286,19 @@ (flatten (map (fn [f] - (if + (when (= (:type (:attrs f)) "entity") (let [farside (entity-for-property f application)] (cons (str - (safe-name (:table (:attrs entity)) :sql) + (safe-name entity :sql) "." (field-name f) " = " - (safe-name (:table (:attrs farside)) :sql) + (safe-name farside :sql) "." (safe-name (first (key-names farside)) :sql)) - #(compose-convenience-where-clause farside application false))))) + (compose-convenience-where-clause farside application false))))) (if top-level? (all-properties entity) @@ -291,24 +306,29 @@ (defn emit-convenience-entity-field - [field entity application] - (str - (s/join - " ||', '|| " - (compose-convenience-entity-field field entity application)) - " AS " - (field-name field) - "_expanded")) + ([property entity application] + (emit-convenience-entity-field property entity application (field-name property))) + ([property entity application table-alias] + (when + (= "entity" (-> property :attrs :type)) + (str + (s/join + " ||', '|| " + (compose-convenience-entity-field property entity application table-alias)) + " AS " + (field-name property) + "_expanded")))) (defn emit-convenience-view "Emit a convenience view of this `entity` of this `application` for use in generating lists, menus, et cetera." [entity application] - (let [view-name (safe-name (str "lv_" (:table (:attrs entity))) :sql) - entity-fields (filter - #(= (:type (:attrs %)) "entity") - (properties entity))] + (let [table-name (safe-name entity :sql) + view-name (safe-name (str "lv_" table-name) :sql) + entity-properties (filter + #(= (:type (:attrs %)) "entity") + (properties entity))] (s/join "\n" (remove @@ -325,21 +345,23 @@ "SELECT " (s/join ",\n\t" - (flatten - (map - #(if - (= (:type (:attrs %)) "entity") - (list - (emit-convenience-entity-field % entity application) - (str (safe-name entity) "." (field-name %))) - (str (safe-name entity) "." (field-name %))) - (filter - #(not= (:type (:attrs %)) "link") - (all-properties entity) ))))) + (remove + nil? + (flatten + (map + #(if + (= (:type (:attrs %)) "entity") + (list + (emit-convenience-entity-field % entity application (field-name %)) + (str table-name "." (field-name %))) + (str table-name "." (field-name %))) + (remove + #(#{"link" "list"} (:type (:attrs %))) + (all-properties entity) )))))) (str - "FROM " (s/join ", " (set (compose-convenience-view-select-list entity application true)))) - (if-not - (empty? entity-fields) + "FROM " (s/join ", " (set (compose-convenience-view-from-list entity application true)))) + (when-not + (empty? entity-properties) (str "WHERE " (s/join @@ -349,14 +371,14 @@ (let [farside (entity-for-property f application)] (str - (safe-name (:table (:attrs entity)) :sql) + (safe-name entity :sql) "." (field-name f) " = " - (safe-name (:table (:attrs farside)) :sql) + (safe-name farside :sql) "." (safe-name (first (key-names farside)) :sql)))) - entity-fields)))) + entity-properties)))) ";" (emit-permissions-grant view-name :SELECT (find-permissions entity application)))))))) @@ -378,8 +400,8 @@ (field-name property) ") \n\tREFERENCES" (str - (safe-name (:table (:attrs farside)) :sql) - "(" (field-name (first (key-properties farside))) ")") + (safe-name 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 @@ -415,7 +437,7 @@ "Emit a table declaration for this `entity` of this `application`, documented with this `doc-comment` if specified." ([entity application doc-comment] - (let [table-name (safe-name (:table (:attrs entity)) :sql) + (let [table-name (safe-name entity :sql) permissions (children-with-tag entity :permission)] (s/join "\n" @@ -435,9 +457,9 @@ (str (s/join ",\n" - (flatten - (remove - nil? + (remove + nil? + (flatten (list (map #(emit-property % entity application true) @@ -457,7 +479,7 @@ application (str "primary table " - (:table (:attrs entity)) + (safe-name entity :sql) " for entity " (:name (:attrs entity)))))) @@ -488,7 +510,7 @@ (= (:name (:attrs %)) (:entity (:attrs property))))) unique? (unique-link? e1 e2) link-table-name (link-table-name property e1 e2)] - (if + (when ;; we haven't already emitted this one... (not (@emitted-link-tables link-table-name)) (let [permissions (flatten @@ -506,7 +528,7 @@ [(construct-link-property e1) (construct-link-property e2)] permissions)))}] - (if-not unique? + (when-not unique? (*warn* (str "WARNING: Manually check link tables between " (-> e1 :attrs :name) @@ -547,8 +569,8 @@ (defn emit-group-declaration - "Emit a declaration for this authorisation `group` within this `application`." - [group application] + "Emit a declaration for this authorisation `group`." + [group] (list (emit-header "--" @@ -585,7 +607,7 @@ (list (emit-file-header application) (map - #(emit-group-declaration % application) + #(emit-group-declaration %) (sort-by-name (children-with-tag application :group))) (map @@ -611,7 +633,7 @@ (make-parents filepath) (do-or-warn (spit filepath (emit-application application)) - (if + (when (pos? *verbosity*) (*warn* (str "\tGenerated " filepath)))))) diff --git a/src/adl/to_selmer_routes.clj b/src/adl/to_selmer_routes.clj index a6d9bc6..760e22a 100644 --- a/src/adl/to_selmer_routes.clj +++ b/src/adl/to_selmer_routes.clj @@ -176,7 +176,7 @@ (*warn* (str "Entity '" - (-> entity :attrs :name) + (or (-> entity :attrs :name) entity) "' passed to compose-fetch-auxlist-data is a non-entity"))) (if-not (entity? farside) diff --git a/src/adl/to_swagger.clj b/src/adl/to_swagger.clj index 3ce11ca..521b385 100644 --- a/src/adl/to_swagger.clj +++ b/src/adl/to_swagger.clj @@ -2,7 +2,7 @@ :author "Simon Brooke"} adl.to-swagger (:require [adl-support.utils :refer :all] - [adl.to-hugsql-queries :refer [queries]] + [adl.to-hugsql-queries :refer [generate-documentation queries]] [clj-time.core :as t] [clj-time.format :as f] [clojure.java.io :refer [file make-parents writer]] @@ -43,21 +43,98 @@ (list 'ns (symbol (str (safe-name (:name (:attrs application))) ".routes.auto-api")) - (str "API routes for " (:name (:attrs application)) + (str "Swagger routes for " (:name (:attrs application)) " auto-generated by [Application Description Language framework](https://github.com/simon-brooke/adl) at " (f/unparse (f/formatters :basic-date-time) (t/now))) (list :require - '[adl-support.core :as support] - '[clj-http.client :as client] - '[clojure.tools.logging :as log] - '[compojure.api.sweet :refer :all] - '[hugsql.core :as hugsql] + '[reitit.swagger :as swagger] + '[reitit.swagger-ui :as swagger-ui] + '[reitit.ring.coercion :as coercion] + '[reitit.coercion.spec :as spec-coercion] + '[reitit.ring.middleware.muuntaja :as muuntaja] + '[reitit.ring.middleware.multipart :as multipart] + '[reitit.ring.middleware.parameters :as parameters] + '[placenames.middleware.formats :as formats] + '[placenames.middleware.exception :as exception] + '[placenames.routes.auto-jason :as aj] '[ring.util.http-response :refer :all] - '[noir.response :as nresponse] - '[noir.util.route :as route] - '[ring.util.http-response :as response] - '[schema.core :as s] - (vector (symbol (str (safe-name (:name (:attrs application))) ".db.core")) :as 'db)))) + '[clojure.java.io :as io]))) + +(defn def-routes + "Generate Swagger routes for all queries implied by this ADL `application` spec." + ;; THIS ISN'T NEARLY FINISHED! + ([application] + (list 'defn 'auto-api-routes [] + ["/api" + {:coercion spec-coercion/coercion + :muuntaja formats/instance + :swagger {:id ::api} + :middleware [;; query-params & form-params + parameters/parameters-middleware + ;; content-negotiation + muuntaja/format-negotiate-middleware + ;; encoding response body + muuntaja/format-response-middleware + ;; exception handling + exception/exception-middleware + ;; decoding request body + muuntaja/format-request-middleware + ;; coercing response bodys + coercion/coerce-response-middleware + ;; coercing request parameters + coercion/coerce-request-middleware + ;; multipart + multipart/multipart-middleware]}] + (map #(def-routes application %) + (children-with-tag application :entity))) + ([application entity] + [(str "/" (safe-name entity)) + {:get (make-get-route entity) + (cons + 'defroutes + (cons + 'auto-rest-routes + (map + #(let [handler (handlers-map %)] + (list + (symbol (s/upper-case (name (:method handler)))) + (str "/json/auto/" (safe-name (:name handler))) + 'request + (list + 'route/restricted + (list (:name handler) 'request)))) + (sort + (keys handlers-map)))))}]))) + + +(defn to-swagger + "Generate a Swagger API for all queries implied by this ADL `application` spec." + [application] + (let [filepath (str + *output-path* + "src/" + (safe-name (:name (:attrs application))) + "/routes/auto_api.clj")] + (make-parents filepath) + (do-or-warn + (do + (spit + filepath + (s/join + "\n\n" + (cons + (file-header application) + (map + (fn [q] + (str + ;; THIS ISN'T NEARLY FINISHED! + )) + (sort + #(compare (:name %1) (:name %2)) + (vals + (queries application))))))) + (if (pos? *verbosity*) + (*warn* (str "\tGenerated " filepath))))))) diff --git a/src/adl/validator.clj b/src/adl/validator.clj index 8103851..fa5919f 100644 --- a/src/adl/validator.clj +++ b/src/adl/validator.clj @@ -43,7 +43,7 @@ (symbol? validation) (try (b/validate o validation) - (catch java.lang.ClassCastException _ + (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! @@ -227,10 +227,10 @@ Markdown (which may include a string representation of HTML markup) should be." {:tag [v/required [#(= % :documentation)]] - :content [[v/every #(disjunct-valid? - % - v/string - reference-validations)]]}) + :content [[v/every #(disjunct-valid? + % + v/string + reference-validations)]]}) ;; (def sample-documentation {:tag :documentation ;; :content ["Every animal should have a breed." @@ -328,6 +328,8 @@ [:attrs :name] [v/string v/required] [:attrs :value] [v/string v/required]}) + + (def generator-validations "marks a property which is auto-generated by some part of the system. This is based on the Hibernate construct, except that the Hibernate @@ -469,14 +471,13 @@ [:attrs :column] v/string [:attrs :concrete] [[v/member #{"true", "false"}]] :content [[v/every #(disjunct-valid? % - documentation-validations - generator-validations - permission-validations - option-validations - prompt-validations - help-validations - ifmissing-validations)]] - }) + documentation-validations + generator-validations + permission-validations + option-validations + prompt-validations + help-validations + ifmissing-validations)]]}) ;; (disjunct-valid? sample-option documentation-validations ;; generator-validations diff --git a/test/adl/to_hugsql_queries_test.clj b/test/adl/to_hugsql_queries_test.clj index 4bccbea..761208e 100644 --- a/test/adl/to_hugsql_queries_test.clj +++ b/test/adl/to_hugsql_queries_test.clj @@ -62,6 +62,7 @@ actual (order-by-clause entity)] (is (string-equal-ignore-whitespace? actual expected)))))) + (deftest keys-name-extraction-tests (let [application {:tag :application, :attrs {:version "0.1.1", :name "test-app"}, @@ -241,7 +242,9 @@ (testing "delete query signature" (let [expected ":! :n" actual (:signature (first (vals (delete-query entity))))] - (is (string-equal-ignore-whitespace? actual expected)))))) + (is (string-equal-ignore-whitespace? actual expected)))) + + )) (deftest complex-key-tests (let [application {:tag :application, diff --git a/test/adl/to_psql_test.clj b/test/adl/to_psql_test.clj new file mode 100644 index 0000000..dd705df --- /dev/null +++ b/test/adl/to_psql_test.clj @@ -0,0 +1,549 @@ +(ns adl.to-psql-test + (:require + [adl-support.utils :refer [child child-with-tag]] + [adl.to-psql :refer [emit-convenience-entity-field emit-convenience-view + emit-property emit-table]] + [clojure.test :refer [deftest is testing]])) + +;; (deftest link-property-test +;; (testing "No field generated for link property" + + +(deftest to-psql-tests + (let [application {:tag :application, + :attrs {:version "0.1.1", + :name "youyesyet", + :xmlns:adl "http://www.journeyman.cc/adl/1.4.7/", + :xmlns:html "http://www.w3.org/1999/xhtml", + :xmlns "http://www.journeyman.cc/adl/1.4.7/"} + :content + [{:tag :typedef, + :attrs + {:size "16", + :pattern + "^([Gg][Ii][Rr] 0[Aa]{2})|((([A-Za-z][0-9]{1,2})|(([A-Za-z][A-Ha-hJ-Yj-y][0-9]{1,2})|(([AZa-z][0-9][A-Za-z])|([A-Za-z][A-Ha-hJ-Yj-y][0-9]?[A-Za-z]))))[0-9][A-Za-z]{2})$", + :type "string", + :name "postcode"}, + :content + [{:tag :documentation, + :attrs nil, + :content + ["See\n https://assets.publishing.service.gov.uk/government/uploads/system/uploads/attachment_data/file/488478/Bulk_Data_Transfer_-_additional_validation_valid_from_12_November_2015.pdf,\n section 3"]} + {:tag :help, + :attrs {:locale "en_GB.UTF-8"}, + :content ["A valid postcode."]}]} + {:tag :entity, + :attrs + {:volatility "6", + :magnitude "6", + :name "addresses", + :table "addresses"}, + :content + [{:tag :documentation, + :attrs nil, + :content + ["Addresses of all buildings which contain\n dwellings."]} + {:tag :key, + :attrs nil, + :content + [{:tag :property, + :attrs + {:distinct "system", + :immutable "true", + :column "id", + :name "id", + :type "integer", + :required "true"}, + :content + [{:tag :generator, :attrs {:action "native"}, :content nil}]}]} + {:tag :property, + :attrs + {:distinct "user", + :size "256", + :column "address", + :name "address", + :type "string", + :required "true"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "Address"}, + :content nil}]} + {:tag :property, + :attrs + {:distinct "user", + :size "16", + :column "postcode", + :name "postcode", + :typedef "postcode", + :type "defined"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "Postcode"}, + :content nil}]} + {:tag :property, + :attrs + {:farkey "id", + :entity "districts", + :column "district_id", + :name "district_id", + :type "entity"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "District"}, + :content nil}]} + {:tag :property, + :attrs {:column "latitude", :name "latitude", :type "real"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "Latitude"}, + :content nil}]} + {:tag :property, + :attrs {:column "longitude", :name "longitude", :type "real"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "Longitude"}, + :content nil}]} + {:tag :property, + :attrs + {:farkey "address_id", + :entity "dwellings", + :name "dwellings", + :type "list"}, + :content nil} + {:tag :property, + :attrs {:column "locality", :name "locality", :type "integer"}, + :content + [{:tag :documentation, + :attrs nil, + :content + ["Locality indexing; see issue #44. Note that\n this property should be generated automatically from the\n latitude and longitude: (+ (* 10000 ;; left-shift the\n latitude component four digits (integer (* latitude 1000)))\n (- ;; invert the sign of the longitude component, since ;;\n we're interested in localities West of Greenwich. (integer (*\n longitude 1000)))) We'll use a trigger to insert this. I\n don't think it will ever appear in the user interface; it's\n an implementation detail, not of interest to\n users."]} + {:tag :generator, :attrs {:action "native"}, :content nil}]} + {:tag :list, + :attrs {:name "Addresses", :properties "listed"}, + :content + [{:tag :field, + :attrs {:property "address"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "Address"}, + :content nil}]} + {:tag :field, + :attrs {:property "postcode"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "Postcode"}, + :content nil}]} + {:tag :field, + :attrs {:property "district_id"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "District"}, + :content nil}]}]} + {:tag :form, + :attrs {:name "Address", :properties "listed"}, + :content + [{:tag :field, + :attrs {:property "address"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "Address"}, + :content nil}]} + {:tag :field, + :attrs {:property "postcode"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "Postcode"}, + :content nil}]} + {:tag :field, + :attrs {:property "district_id"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "District"}, + :content nil}]} + {:tag :field, + :attrs {:property "latitude"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "Latitude"}, + :content nil}]} + {:tag :field, + :attrs {:property "longitude"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "Longitude"}, + :content nil}]} + {:tag :auxlist, + :attrs + {:canadd "true", + :onselect "form-dwellings-Dwelling", + :property "dwellings"}, + :content + [{:tag :field, + :attrs {:property "sub-address"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "Sub-address"}, + :content nil}]}]}]} + {:tag :permission, + :attrs {:permission "read", :group "canvassers"}, + :content nil} + {:tag :permission, + :attrs {:permission "read", :group "teamorganisers"}, + :content nil} + {:tag :permission, + :attrs {:permission "read", :group "issueexperts"}, + :content nil} + {:tag :permission, + :attrs {:permission "read", :group "analysts"}, + :content nil} + {:tag :permission, + :attrs {:permission "read", :group "issueeditors"}, + :content nil} + {:tag :permission, + :attrs {:permission "all", :group "admin"}, + :content nil}]} + + {:tag :entity, + :attrs + {:volatility "6", + :magnitude "6", + :name "dwellings", + :table "dwellings"}, + :content + [{:tag :documentation, + :attrs nil, + :content + ["All dwellings within addresses in the system; a\n dwelling is a house, flat or appartment in which electors live.\n Every address should have at least one dwelling; essentially,\n an address maps onto a street door and dwellings map onto\n what's behind that door. So a tenement or a block of flats\n would be one address with many dwellings."]} + {:tag :key, + :attrs nil, + :content + [{:tag :property, + :attrs + {:distinct "system", + :immutable "true", + :column "id", + :name "id", + :type "integer", + :required "true"}, + :content + [{:tag :generator, :attrs {:action "native"}, :content nil}]}]} + {:tag :property, + :attrs + {:distinct "user", + :farkey "id", + :entity "addresses", + :column "address_id", + :name "address_id", + :type "entity", + :required "true"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "Building Address"}, + :content nil}]} + {:tag :property, + :attrs + {:distinct "user", + :name "sub-address", + :size "32", + :type "string", + :required "false"}, + :content + [{:tag :documentation, + :attrs nil, + :content + ["\n The part of the address which identifies the flat or\n apartment within the building, if in a multiple occupancy\n building.\n "]}]} + {:tag :property, + :attrs {:entity "electors", :name "electors", :type "list"}, + :content nil} + {:tag :list, + :attrs {:name "Dwellings", :properties "listed"}, + :content + [{:tag :field, + :attrs {:property "address_id"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "Building Address"}, + :content nil}]} + {:tag :field, + :attrs {:property "sub-address"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "Sub address"}, + :content nil}]}]} + {:tag :form, + :attrs {:name "Dwelling", :properties "listed"}, + :content + [{:tag :field, + :attrs {:property "address_id"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "Building Address"}, + :content nil}]} + {:tag :field, + :attrs {:property "sub-address"}, + :content + [{:tag :prompt, + :attrs + {:locale "en_GB.UTF-8", + :prompt "Sub address (e.g. flat number)"}, + :content nil}]}]} + {:tag :permission, + :attrs {:permission "read", :group "canvassers"}, + :content nil} + {:tag :permission, + :attrs {:permission "read", :group "teamorganisers"}, + :content nil} + {:tag :permission, + :attrs {:permission "read", :group "issueexperts"}, + :content nil} + {:tag :permission, + :attrs {:permission "read", :group "analysts"}, + :content nil} + {:tag :permission, + :attrs {:permission "read", :group "issueeditors"}, + :content nil} + {:tag :permission, + :attrs {:permission "all", :group "admin"}, + :content nil}]} + {:tag :entity, + :attrs + {:volatility "7", + :magnitude "4", + :name "districts", + :table "districts"}, + :content + [{:tag :documentation, + :attrs nil, + :content + ["Electoral districts: TODO: Shape (polygon)\n information will need to be added, for use in\n maps."]} + {:tag :key, + :attrs nil, + :content + [{:tag :property, + :attrs + {:distinct "system", + :immutable "true", + :column "id", + :name "id", + :type "integer", + :required "true"}, + :content + [{:tag :generator, :attrs {:action "native"}, :content nil}]}]} + {:tag :property, + :attrs + {:distinct "user", + :size "64", + :column "name", + :name "name", + :type "string", + :required "true"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "name"}, + :content nil}]} + {:tag :permission, + :attrs {:permission "read", :group "public"}, + :content nil} + {:tag :permission, + :attrs {:permission "all", :group "admin"}, + :content nil} + {:tag :list, + :attrs {:name "Districts", :properties "listed"}, + :content + [{:tag :field, + :attrs {:property "name"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "name"}, + :content nil}]}]} + {:tag :form, + :attrs {:name "District", :properties "listed"}, + :content + [{:tag :field, + :attrs {:property "name"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "name"}, + :content nil}]}]} + {:tag :permission, + :attrs {:permission "read", :group "canvassers"}, + :content nil} + {:tag :permission, + :attrs {:permission "read", :group "teamorganisers"}, + :content nil} + {:tag :permission, + :attrs {:permission "read", :group "issueexperts"}, + :content nil} + {:tag :permission, + :attrs {:permission "read", :group "analysts"}, + :content nil} + {:tag :permission, + :attrs {:permission "read", :group "issueeditors"}, + :content nil} + {:tag :permission, + :attrs {:permission "all", :group "admin"}, + :content nil}]} + ]} + address-entity (child-with-tag application :entity #(= (-> % :attrs :name) "addresses")) + dwelling-entity (child-with-tag application :entity #(= (-> % :attrs :name) "dwellings"))] + (testing "varchar field" + (let [property (child-with-tag address-entity :property #(= (-> % :attrs :name) "address")) + expected "\t address VARCHAR(256) NOT NULL" + actual (emit-property property address-entity application false)] + (is (= actual expected)))) + (testing "integer field" + (let [property (child-with-tag address-entity :property #(= (-> % :attrs :name) "locality")) + expected "\t locality INTEGER" + actual (emit-property property address-entity application false)] + (is (= actual expected)))) + (testing "real field" + (let [property (child-with-tag address-entity :property #(= (-> % :attrs :name) "longitude")) + expected "\t longitude DOUBLE PRECISION" + actual (emit-property property address-entity application false)] + (is (= actual expected)))) + (testing "list field" + (let [property (child-with-tag address-entity :property #(= (-> % :attrs :name) "dwellings")) + actual (emit-property property address-entity application false)] + (is (nil? actual)))) + (testing "entity field" + (let [property (child-with-tag address-entity :property #(= (-> % :attrs :name) "district_id")) + expected "\t district_id INTEGER" + actual (emit-property property address-entity application false)] + (is (= actual expected)))) + + ;; (testing "pattern field" + ;; (let [property (child-with-tag address-entity :property #(= (-> % :attrs :name) "postcode")) + ;; expected #"\t postcode VARCHAR(16) CONSTRAINT pattern_\d+ CHECK (postcode ~* '^([Gg][Ii][Rr] 0[Aa]{2})|((([A-Za-z][0-9]{1,2})|(([A-Za-z][A-Ha-hJ-Yj-y][0-9]{1,2})|(([AZa-z][0-9][A-Za-z])|([A-Za-z][A-Ha-hJ-Yj-y][0-9]?[A-Za-z]))))[0-9][A-Za-z]{2})$')" + ;; actual (emit-property property address-entity application false)] + ;; ;; slightly tricky because the pattern name is gensymed. + ;; (is (= actual expected)) + ;; (is (string? (re-find expected actual))))) + (testing "Table creation" + (let [expected "------------------------------------------------------------------------\n--\tTest doc \n--\t\n--\tAll dwellings within addresses in the system; a\n--\t dwelling is a house, flat or appartment in which electors live.\n--\t Every address should have at least one dwelling; essentially,\n--\t an address maps onto a street door and dwellings map onto\n--\t what's behind that door. So a tenement or a block of flats\n--\t would be one address with many dwellings. \n------------------------------------------------------------------------\nCREATE TABLE dwellings\n(\n\t id SERIAL NOT NULL PRIMARY KEY,\n\t address_id INTEGER NOT NULL,\n\t sub_address VARCHAR(32)\n);\nGRANT SELECT ON dwellings TO admin,\n\tanalysts,\n\tcanvassers,\n\tissueeditors,\n\tissueexperts,\n\tteamorganisers ;\nGRANT INSERT ON dwellings TO admin ;\nGRANT UPDATE ON dwellings TO admin ;\nGRANT DELETE ON dwellings TO admin ;" + actual (emit-table dwelling-entity application "Test doc")] + (is (= actual expected)))) + (testing "Convenience entity field - is an entity field, should emit" + (let [property (child-with-tag address-entity :property #(= (-> % :attrs :name) "district_id")) + expected "district_id.name AS district_id_expanded" + actual (emit-convenience-entity-field property address-entity application)] + (is (= actual expected)))) + + (testing "Convenience entity field - is not an entity field, should not emit" + (let [farside dwelling-entity + property (child-with-tag address-entity :property #(= (-> % :attrs :name) "dwellings")) + expected nil + actual (emit-convenience-entity-field property address-entity application)] + (is (= actual expected)))) + + )) + +(deftest bug-9-test + (testing "Correct reference to aliased tables in convenience view select queries + see [bug 9](https://github.com/simon-brooke/adl/issues/9)" + (let [app + {:tag :application, + :attrs {:version "0.0.1", + :name "pastoralist", + :xmlns:adl "http://www.journeyman.cc/adl/1.4.7/", + :xmlns:html "http://www.w3.org/1999/xhtml", + :xmlns "http://www.journeyman.cc/adl/1.4.7/"}, + :content [{:tag :documentation, + :attrs nil, + :content ["A web-app intended to be used by pastoralists in managing + pastures, grazing, and animals."]} + {:tag :entity, + :attrs {:volatility "5", :magnitude "9", :name "animal" :table "animal"}, + :content + [{:tag :key, + :attrs nil, + :content + [{:tag :property, + :attrs + {:distinct "system", + :immutable "true", + :column "id", + :name "id", + :type "integer", + :required "true"}, + :content + [{:tag :generator, :attrs {:action "native"}, :content nil}]}]} + {:tag :property, + :attrs {:entity "animal", :type "entity", :name "dam"}, + :content nil} + {:tag :property, + :attrs {:entity "animal", :type "entity", :name "sire"}, + :content nil} + {:tag :property, + :attrs + {:required "true", + :distinct "user", + :size "64", + :type "string", + :name "animal-identifier"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "Ear-tag Number"}, + :content nil}]} + {:tag :property, + :attrs {:distinct "user", :size "64", :type "string", :name "name"}, + :content nil}]}]} + animal (child app #(= (-> % :attrs :name) "animal")) + dam (child animal #(= (-> % :attrs :name) "dam"))] + (let [actual (emit-convenience-view animal app) + should-find #"dam.animal_identifier" + should-not-find #"animal.name AS dam_expanded"] + ;; (print actual) ;; see what we've got + (is (re-find should-find actual)) + (is (nil? (re-find should-not-find actual))))))) + +(deftest bug-10-test + (testing "Correct table names in convenience view select queries + see [bug 10](https://github.com/simon-brooke/adl/issues/10)" + (let [app + {:tag :application, + :attrs {:version "0.0.1", + :name "pastoralist", + :xmlns:adl "http://www.journeyman.cc/adl/1.4.7/", + :xmlns:html "http://www.w3.org/1999/xhtml", + :xmlns "http://www.journeyman.cc/adl/1.4.7/"}, + :content [{:tag :documentation, + :attrs nil, + :content ["A web-app intended to be used by pastoralists in managing + pastures, grazing, and animals."]} + {:tag :entity, + :attrs + {:volatility "5", + :magnitude "3", + :name "event-type", + :table "event-type"}, + :content + [{:tag :key, + :attrs nil, + :content + [{:tag :property, + :attrs + {:distinct "system", + :immutable "true", + :column "id", + :name "id", + :type "integer", + :required "true"}, + :content + [{:tag :generator, :attrs {:action "native"}, :content nil}]}]} + {:tag :property, + :attrs {:size "80", :type "string", :name "summary"}, + :content nil} + {:tag :property, + :attrs {:type "text", :name "description"}, + :content nil} + {:tag :property, + :attrs {:default "1", :type "integer", :name "n-holdings"},} + {:tag :property, + :attrs {:default "1", :type "integer", :name "n-pastures"}} + {:tag :property, + :attrs {:default "1", :type "integer", :name "n-animals"}}]}]} + should-find #"event_type.description" + should-not-find #"event-type.description" + actual (emit-convenience-view (child app #(= (-> % :attrs :name) "event-type")) app)] + (is (re-find should-find actual)) + (is (nil? (re-find should-not-find actual)))))) diff --git a/test/adl/validator_test.clj b/test/adl/validator_test.clj index bf53c6c..162bb93 100644 --- a/test/adl/validator_test.clj +++ b/test/adl/validator_test.clj @@ -125,10 +125,10 @@ (let [xml {:tag :group, :attrs {:name "public"}, :content - [{:tag :documentation, :attrs nil, :content ["All users"]}]} - expected true + [{:tag :documentation, :content ["All users"]}]} + expected nil actual (binding [*out* (writer "/dev/null")] - (valid? xml group-validations))] + (first (validate xml group-validations)))] (is (= actual expected))))) (deftest validator-entity @@ -334,7 +334,7 @@ :content nil}]}]} expected true actual (binding [*out* (writer "/dev/null")] - (valid? xml entity-validations))] + (valid? xml property-validations))] (is (= actual expected)))))