diff --git a/resources/transforms/adl2psql.xslt b/resources/transforms/adl2psql.xslt index 7850ad9..8fe1a65 100755 --- a/resources/transforms/adl2psql.xslt +++ b/resources/transforms/adl2psql.xslt @@ -1,7 +1,7 @@ - @@ -17,35 +17,35 @@ - + - + - @@ -56,7 +56,7 @@ Name_Link - the name of the foreign key is the same as the name of the table linked to, followed by '_Link' --> - + @@ -128,7 +128,7 @@ - + ------------------------------------------------------------------------------------------------- -- -- @@ -156,7 +156,7 @@ -- tables, views and permissions ------------------------------------------------------------------------------------------------- - + ------------------------------------------------------------------------------------------------- -- referential integrity constraints ------------------------------------------------------------------------------------------------- @@ -166,24 +166,24 @@ - + - + ------------------------------------------------------------------------------------------------- -- end of file ------------------------------------------------------------------------------------------------- - + /* */ - + ------------------------------------------------------------------------------------------------- -- security group @@ -191,12 +191,12 @@ CREATE GROUP ; - - + + - ALTER TABLE ADD CONSTRAINT ri_ + ALTER TABLE ADD CONSTRAINT ri_ FOREIGN KEY ( ) REFERENCES ON DELETE NO ACTION; @@ -204,20 +204,20 @@ - ALTER TABLE ln__ - ADD CONSTRAINT ri____id + ALTER TABLE ln__ + ADD CONSTRAINT ri____id FOREIGN KEY ( _id) REFERENCES ON DELETE CASCADE; - ALTER TABLE ln__ - ADD CONSTRAINT ri____id + ALTER TABLE ln__ + ADD CONSTRAINT ri____id FOREIGN KEY ( _id) REFERENCES ON DELETE CASCADE; - + - - + + - + ------------------------------------------------------------------------------------------------- -- primary table ------------------------------------------------------------------------------------------------- @@ -231,7 +231,7 @@ ); - + ---- permissions ------------------------------------------------------------------------------ @@ -266,7 +266,7 @@ WHERE AND - .. = ._id ; @@ -276,7 +276,7 @@ - + @@ -290,74 +290,74 @@ - + - + - - - + Template distinctfield entered, table is . + + Entity detected. - . | ' ' | + . | ', ' | - + - - + - GRANT SELECT ON GRANT SELECT ON TO GROUP ; - GRANT INSERT ON GRANT INSERT ON TO GROUP ; - GRANT SELECT, INSERT ON GRANT SELECT, INSERT ON TO GROUP ; - GRANT SELECT, INSERT, UPDATE ON GRANT SELECT, INSERT, UPDATE ON TO GROUP ; - GRANT SELECT, INSERT, UPDATE, DELETE ON GRANT SELECT, INSERT, UPDATE, DELETE ON TO GROUP ; - REVOKE ALL ON REVOKE ALL ON FROM GROUP ; - + - + - REVOKE ALL ON lv_REVOKE ALL ON lv_ FROM GROUP ; - REVOKE ALL ON lv_REVOKE ALL ON lv_ FROM GROUP ; - GRANT SELECT ON lv_GRANT SELECT ON lv_ TO GROUP ; - + - - + + @@ -369,7 +369,7 @@ - + ------------------------------------------------------------------------------------------------- -- link table joining with ------------------------------------------------------------------------------------------------- @@ -379,15 +379,15 @@ _id INT NOT NULL, ); - + - + - + - INT DEFAULT INT DEFAULT NOT NULL @@ -395,46 +395,46 @@ - VARCHAR( VARCHAR( ) INT DOUBLE PRECISION - DEFAULT NOT NULL PRIMARY KEY NOT NULL - + - VARCHAR( ) VARCHAR( ) DEFAULT NOT NULL PRIMARY KEY NOT NULL - + - INT INT DEFAULT NOT NULL PRIMARY KEY NOT NULL - + - DOUBLE PRECISION DEFAULT DOUBLE PRECISION DEFAULT NOT NULL - + - DEFAULT NOT NULL PRIMARY KEY NOT NULL - + diff --git a/src/adl/to_hugsql_queries.clj b/src/adl/to_hugsql_queries.clj index c9633d7..be644f9 100644 --- a/src/adl/to_hugsql_queries.clj +++ b/src/adl/to_hugsql_queries.clj @@ -284,8 +284,10 @@ (list (str "-- :name " query-name " " signature) (str "-- :doc links all existing " pretty-name " records related to a given " pretty-far) - (str "SELECT * \nFROM " entity-name) - (str "WHERE " entity-name "." link-field " = " link-table-name "." (singularise entity-name) "_id") + (str "SELECT * \nFROM " entity-name ", " link-table-name) + (str "WHERE " entity-name "." + (first (key-names entity)) + " = " link-table-name "." (singularise entity-name) "_id") (str "\tAND " link-table-name "." (singularise far-name) "_id = :id") (order-by-clause entity))) (list (str "ERROR: unexpected type " link-type " of property " %))))) diff --git a/src/adl/to_psql.clj b/src/adl/to_psql.clj new file mode 100644 index 0000000..1a9472e --- /dev/null +++ b/src/adl/to_psql.clj @@ -0,0 +1,400 @@ +(ns ^{:doc "Application Description Language: generate Postgres database definition." + :author "Simon Brooke"} + adl.to-psql + (:require [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] + [adl.to-hugsql-queries :refer [queries]])) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; adl.to-psql: generate Postgres database definition. +;;;; +;;;; 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 +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +;;; this is a pretty straight translation of adl2psql.xslt, and was written because +;;; Clojure is easier to debug + +(declare emit-field-type emit-property) + +(def comment-rule (apply str (repeat 79 "-"))) + +(defn emit-defined-field-type + [property application] + (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))) + +(defn emit-entity-field-type + [property application] + (let [farside (child + application + #(and + (entity? %) + (= (:name (:attrs %)) (:entity (:attrs property))))) + key-properties (children-with-tag + (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") + (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 + )))) + + +(defn emit-field-type + [property entity application key?] + (case (:type (:attrs property)) + "integer" (if key? "serial" "INTEGER") + "real" "DOUBLE PRECISION" + ("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))) + (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)) + + +(defn emit-permissions-grant + [table-name privilege permissions] + (let [selector + (case privilege + :SELECT #{"read" "noedit" "edit" "all"} + :INSERT #{"insert" "noedit" "edit" "all"} + :UPDATE #{"edit" "all"} + (:DELETE :ALL) #{"all"}) + group-names + (set + (remove + nil? + (map + #(if (selector (:permission (:attrs %))) + (:name (:attrs %))) + permissions)))] + (if + (not (empty? group-names)) + (s/join " " (list "GRANT" (name privilege) "ON" table-name "TO" (s/join "," group-names) ";"))))) + + +(defn emit-link-table + [property e1 application emitted-link-tables] + (let [e2 (child + 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)))] + (if + true ;;(not (@emitted-link-tables link-table-name)) + (do + ;; (swap! emitted-link-tables (conj @emitted-link-tables 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))))))) + + +(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"))))) + + +(defn emit-property + ([property entity application] + (emit-property property entity application false)) + ([property entity application key?] + (let [default (:default (:attrs property))] + (if + (and + (= (:tag property) :property) + (not (#{"link"} (:type (:attrs property))))) + (s/join + " " + (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"))))))))) + + +(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)))))] + (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))))) + + +(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))))))) + + +(defn compose-convenience-where-clause + [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)))))) + + + +(defn emit-convenience-entity-field + [field entity application] + (str + (s/join + " |', '| " + (compose-convenience-entity-field field entity application)) + " AS " + (:name (:attrs field)))) + + +(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 (str "lv_" (:table (:attrs entity))) + entity-fields (filter + #(= (: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)))))))) + + +(defn emit-table + [entity application emitted-link-tables] + (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))))))) + + +(defn emit-entity + [entity application emitted-link-tables] + (emit-table entity application emitted-link-tables) + (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)))))) + + +(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))) + + +(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))))))) + + +(defn to-psql + [application] + (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 b4362c2..5f51ae2 100644 --- a/src/adl/utils.clj +++ b/src/adl/utils.clj @@ -41,7 +41,13 @@ (defn link-table-name "Canonical name of a link table between entity `e1` and entity `e2`." [e1 e2] - (s/join "_" (list "link" (:name (:attrs e1)) (:name (:attrs e2))))) + (s/join + "_" + (cons + "ln" + (sort + (list + (:name (:attrs e1)) (:name (:attrs e2))))))) (defn children @@ -57,6 +63,12 @@ (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." @@ -87,7 +99,7 @@ (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] + ([property page entity application] (first (remove empty? @@ -96,6 +108,10 @@ (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 @@ -135,6 +151,24 @@ (= (: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." @@ -216,6 +250,12 @@ 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] @@ -242,11 +282,19 @@ (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" @@ -309,3 +357,16 @@ 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] + (:type (:attrs (typedef property application))))