From 66ab4a2bc187364c5fa9ad40c76b5a327e37d39f Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 14 Jun 2018 00:25:11 +0100 Subject: [PATCH] Postgres generation is now very close to good. --- src/adl/main.clj | 6 +- src/adl/to_psql.clj | 534 +++++++++++++++++++++++++------------------- src/adl/utils.clj | 20 +- 3 files changed, 319 insertions(+), 241 deletions(-) diff --git a/src/adl/main.clj b/src/adl/main.clj index 31c2efe..ea955b1 100644 --- a/src/adl/main.clj +++ b/src/adl/main.clj @@ -4,6 +4,7 @@ (:require [adl.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]) @@ -36,7 +37,7 @@ (println "Argument should be a pathname to an ADL file")) (defn -main - "Expects as arg the name of the git hook to be handled, followed by the arguments to it" + "Expects as arg the path-name of an ADL file." [& args] (cond (empty? args) @@ -45,6 +46,9 @@ (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)))) + + diff --git a/src/adl/to_psql.clj b/src/adl/to_psql.clj index 1a9472e..eba8b22 100644 --- a/src/adl/to_psql.clj +++ b/src/adl/to_psql.clj @@ -35,7 +35,16 @@ ;;; this is a pretty straight translation of adl2psql.xslt, and was written because -;;; Clojure is easier to debug +;;; Clojure is easier to debug. + +;;; TODO: the order in which we generate tables is critical, because tables +;;; can only reference other tables which already exist. We could get around +;;; this by generating referential integrity constraints post-hoc, which is +;;; what the xslt version did. + +(defn sort-by-name + [elements] + (sort #(.compareTo (:name (:attrs %1)) (:name (:attrs %2))) elements)) (declare emit-field-type emit-property) @@ -46,42 +55,86 @@ (let [typedef (typedef property application)] ;; this is a hack based on the fact that emit-field-type doesn't check ;; that the argument passed as `property` is indeed a property. - (emit-field-type typedef nil application false))) + (str (emit-field-type typedef nil application false) + (cond + (:pattern (:attrs typedef)) + (str + " CONSTRAINT " + (gensym "c-") + " 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 "c-") + " CHECK (" + (:minimum (:attrs typedef)) + " < " + (:name (:attrs property)) + " AND " + (:name (:attrs property)) + " < " + (:maximum (:attrs typedef)) + ")") + (:maximum (:attrs typedef)) + (str + " CONSTRAINT " + (gensym "c-") + " CHECK (" + (:name (:attrs property)) + " < " + (:maximum (:attrs typedef)) + ")") + (:minimum (:attrs typedef)) + (str + " CONSTRAINT " + (gensym "c-") + " 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") + "-- ERROR: cannot generate link to entity " + (:name (:attrs farside)) + " with compound primary key\n") (list - (emit-field-type (first key-properties) farside application false) - "REFERENCES" - (str - (:table (:attrs farside)) "(" (:name (:attrs (first key-properties))) ) ")" - ;; TODO: ought to handle the `cascade` attribute, even though it's rarely used - )))) + (emit-field-type (first key-properties) farside application false) + "REFERENCES" + (str + (:table (:attrs farside)) "(" (:name (:attrs (first key-properties)))) ")" + ;; TODO: ought to handle the `cascade` attribute, even though it's rarely used + )))) (defn emit-field-type [property entity application key?] (case (:type (:attrs property)) - "integer" (if key? "serial" "INTEGER") + "integer" (if key? "SERIAL" "INTEGER") "real" "DOUBLE PRECISION" - ("string" "image" "uploadable") (str "VARCHAR(" (:size (:attrs property)) ")") + ("string" "image" "uploadable") + (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))) + ("date" "time" "timestamp" "boolean" "text" "money") + (.toUpperCase (:type (:attrs property))) (str "-- ERROR: unknown type " (:type (:attrs property))) )) @@ -89,13 +142,13 @@ (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 @@ -108,53 +161,56 @@ (:DELETE :ALL) #{"all"}) group-names (set - (remove - nil? - (map - #(if (selector (:permission (:attrs %))) - (:name (:attrs %))) - permissions)))] + (remove + nil? + (map + #(if (selector (:permission (:attrs %))) + (:group (:attrs %))) + permissions)))] (if (not (empty? group-names)) - (s/join " " (list "GRANT" (name privilege) "ON" table-name "TO" (s/join "," group-names) ";"))))) + (s/join " " (list "GRANT" (name privilege) "ON" table-name "TO" (s/join ",\n\t" (sort group-names)) ";"))))) (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) permissions (flatten - (list - (children-with-tag e1 :permission) - (children-with-tag e1 :permission)))] + (list + (children-with-tag e1 :permission) + (children-with-tag e1 :permission)))] (if - true ;;(not (@emitted-link-tables link-table-name)) + (not (@emitted-link-tables link-table-name)) (do - ;; (swap! emitted-link-tables (conj @emitted-link-tables link-table-name)) + (swap! emitted-link-tables conj link-table-name) (s/join - "\n" - (list - comment-rule - (str "--\tlink table joining " (:name (:attrs e1)) " with " (:name (:attrs e2))) - comment-rule - (s/join " " (list "CREATE TABLE" link-table-name)) - "(" - (emit-link-field property e1 application) - (emit-link-field property e2 application) - ");" - (emit-permissions-grant link-table-name :SELECT permissions) - (emit-permissions-grant link-table-name :INSERT permissions))))))) + "\n" + (list + comment-rule + (str "--\tlink table joining " (:name (:attrs e1)) " with " (:name (:attrs e2))) + comment-rule + (s/join " " (list "CREATE TABLE IF NOT EXISTS" link-table-name)) + "(" + (emit-link-field property e1 application) + (emit-link-field property e2 application) + ");" + (emit-permissions-grant link-table-name :SELECT permissions) + (emit-permissions-grant link-table-name :INSERT permissions))))))) (defn emit-link-tables [entity application emitted-link-tables] (map - #(emit-link-table % entity application emitted-link-tables) - (children entity #(and (= (:tag %) :property) (= (:type (:attrs %)) "link"))))) + #(emit-link-table % entity application emitted-link-tables) + (sort-by-name + (filter + #(= (:type (:attrs %)) "link") + (properties entity))))) (defn emit-property @@ -164,96 +220,98 @@ (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" - (:name (:attrs property)) - (emit-field-type property entity application key?) - (if default (list "DEFAULT" default)) - (if - key? - "NOT NULL PRIMARY KEY" - (if (= (:required (:attrs property)) "true") "NOT NULL"))))))))) + (list + "\t" + (:name (:attrs property)) + (emit-field-type property entity application key?) + (if default (list "DEFAULT" default)) + (if + key? + "NOT NULL PRIMARY KEY" + (if (= (:required (:attrs property)) "true") "NOT NULL")))))))))) (defn compose-convenience-entity-field - ;; TODO: this is not recursing properly [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 (:table (:attrs farside)) "." (:name (:attrs f))))) - (user-distinct-properties farside))))) + (map + (fn [f] + (if + (= (:type (:attrs f)) "entity") + (compose-convenience-entity-field f farside application) + (str (:table (:attrs farside)) "." (:name (:attrs f))))) + (user-distinct-properties farside))))) (defn compose-convenience-view-select-list [entity application top-level?] (remove - nil? - (flatten - (cons - (:name (:attrs entity)) - (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 + (:name (:attrs entity)) + (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 + ;; TODO: does not correctly compose links at one stage down the tree. + ;; 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 - (:table (:attrs entity)) - "." - (:name (:attrs f)) - " = " - (:table (:attrs farside)) - "." - (first (key-names farside))) - #(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 + (:table (:attrs entity)) + "." + (:name (:attrs f)) + " = " + (:table (:attrs farside)) + "." + (first (key-names farside))) + #(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 " - (:name (:attrs field)))) + (s/join + " |', '| " + (compose-convenience-entity-field field entity application)) + " AS " + (:name (:attrs field)))) (defn emit-convenience-view @@ -262,138 +320,162 @@ [entity application] (let [view-name (str "lv_" (:table (:attrs entity))) entity-fields (filter - #(= (:type (:attrs %)) "entity") - (properties entity))] + #(= (:type (:attrs %)) "entity") + (properties entity))] (s/join - "\n" - (remove - nil? - (flatten - (list - comment-rule - (str "--\tconvenience view " view-name " of entity " (:name (:attrs entity)) " for lists, et cetera") - comment-rule - (s/join - " " - (list "CREATE VIEW" view-name "AS")) - (str - "SELECT " - (s/join - ",\n\t" - (map - #(if - (= (:type (:attrs %)) "entity") - (emit-convenience-entity-field % entity application) - (:name (:attrs %))) - (filter - #(and (= (:tag %) :property) (not (= (:type (:attrs %)) "link"))) - (all-properties entity) )))) - (str - "FROM " (s/join ", " (compose-convenience-view-select-list entity application true))) - (if - (not (empty? entity-fields)) - (str - "WHERE " - (s/join - "\n\tAND " - (map - (fn [f] - (let - [farside (child - application - #(and - (entity? %) - (= (:name (:attrs %)) (:entity (:attrs f)))))] - (str - (:table (:attrs entity)) - "." - (:name (:attrs f)) - " = " - (:table (:attrs farside)) - "." - (first (key-names farside))))) - entity-fields)))) - ";" - (emit-permissions-grant view-name :SELECT (permissions entity application)))))))) + "\n" + (remove + nil? + (flatten + (list + comment-rule + (str "--\tconvenience view " view-name " of entity " (:name (:attrs entity)) " for lists, et cetera") + comment-rule + (s/join + " " + (list "CREATE VIEW" view-name "AS")) + (str + "SELECT " + (s/join + ",\n\t" + (map + #(if + (= (:type (:attrs %)) "entity") + (emit-convenience-entity-field % entity application) + (:name (:attrs %))) + (filter + #(and (= (:tag %) :property) (not (= (:type (:attrs %)) "link"))) + (all-properties entity) )))) + (str + "FROM " (s/join ", " (compose-convenience-view-select-list entity application true))) + (if + (not (empty? entity-fields)) + (str + "WHERE " + (s/join + "\n\tAND " + (map + (fn [f] + (let + [farside (child + application + #(and + (entity? %) + (= (:name (:attrs %)) (:entity (:attrs f)))))] + (str + (:table (:attrs entity)) + "." + (:name (:attrs f)) + " = " + (:table (:attrs farside)) + "." + (first (key-names farside))))) + entity-fields)))) + ";" + (emit-permissions-grant view-name :SELECT (permissions entity application)))))))) (defn emit-table - [entity application emitted-link-tables] + [entity application] (let [table-name (:table (:attrs entity)) permissions (children-with-tag entity :permission)] (s/join - "\n" - (flatten - (list - comment-rule - (str "--\tprimary table " table-name " for entity " (:name (:attrs entity))) - comment-rule - (s/join - " " - (list "CREATE TABLE " table-name)) - "(" - (map - #(emit-property % entity application true) - (children-with-tag (child-with-tag entity :key) :property)) - (map - #(emit-property % entity application false) - (children-with-tag entity :property)) - ");" - (map - #(emit-permissions-grant table-name % permissions) - '(:SELECT :INSERT :UPDATE :DELETE))))))) + "\n" + (flatten + (list + comment-rule + (str "--\tprimary table " table-name " for entity " (:name (:attrs entity))) + comment-rule + (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))))))) (defn emit-entity - [entity application emitted-link-tables] - (emit-table entity application emitted-link-tables) - (emit-convenience-view entity application)) + [entity application] + (doall + (list + (emit-table entity application) + (emit-convenience-view entity application)))) (defn emit-group-declaration [group application] (s/join - "\n" - (list - comment-rule - (str "--\tsecurity group " (:name (:attrs group))) - comment-rule - (str "CREATE GROUP IF NOT EXISTS " (:name (:attrs group)))))) + "\n" + (list + comment-rule + (str "--\tsecurity group " (:name (:attrs group))) + comment-rule + (str "CREATE GROUP " (:name (:attrs group)) ";")))) (defn emit-file-header [application] (s/join - "\n" - (list - comment-rule - (str - "--\tDatabase definition for application " - (:name (:attrs application)) - " version " - (:version (:attrs application))) - (str - "--\tauto-generated by [Application Description Language framework](https://github.com/simon-brooke/adl) at " - (f/unparse (f/formatters :basic-date-time) (t/now))) - comment-rule))) + "\n" + (list + comment-rule + (str + "--\tDatabase definition for application " + (:name (:attrs application)) + " version " + (:version (:attrs application))) + (str + "--\tauto-generated by [Application Description Language framework](https://github.com/simon-brooke/adl) at " + (f/unparse (f/formatters :basic-date-time) (t/now))) + comment-rule))) (defn emit-application [application] (let [emitted-link-tables (atom #{})] (s/join - "\n\n" - (flatten - (list - (emit-file-header application) - (map #(emit-group-declaration % application) (children-with-tag application :group)) - (map #(emit-entity % application emitted-link-tables) (children-with-tag application :entity)) - (map #(emit-link-tables % application emitted-link-tables) (children-with-tag application :entity))))))) + "\n\n" + (flatten + (list + (emit-file-header application) + (map + #(emit-group-declaration % application) + (sort-by-name + (children-with-tag application :group))) + (map + #(emit-entity % application) + (sort-by-name + (children-with-tag application :entity))) + (map + #(emit-link-tables % application emitted-link-tables) + (sort-by-name + (children-with-tag application :entity)))))))) (defn to-psql [application] - (let [filepath (str *output-path* "/resources/sql/" (:name (:attrs application)) ".postgres.sql")] + (let [filepath (str + *output-path* + "/resources/sql/" + (:name (:attrs application)) + ".postgres.sql")] (make-parents filepath) (spit filepath (emit-application application)))) diff --git a/src/adl/utils.clj b/src/adl/utils.clj index 5f51ae2..fbb921c 100644 --- a/src/adl/utils.clj +++ b/src/adl/utils.clj @@ -88,12 +88,11 @@ [property application] (if (= (:type (:attrs property)) "defined") - (first - (children - application - #(and - (= (:tag %) :typedef) - (= (:name (:attrs %)) (:typedef (:attrs property)))))))) + (child + application + #(and + (= (:tag %) :typedef) + (= (:name (:attrs %)) (:typedef (:attrs property))))))) (defn permissions @@ -352,20 +351,13 @@ (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 typedef - [property application] - (first - (children application - #(and - (= (:tag %) :typedef) - (= (:name (:attrs %)) - (:definition (:attrs property))))))) (defn type-for-defined [property application]