simon/adl
1
0
Fork 0
Code Issues Pull requests Actions Packages Projects Releases Wiki Activity

Postgres generation is now very close to good.

Browse source
This commit is contained in:
Simon Brooke 2018-06-14 00:25:11 +01:00
parent e9ed2d0573
commit 66ab4a2bc1
3 changed files with 319 additions and 241 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
src/adl/main.clj
View file

@ -4,6 +4,7 @@
(:require [adl.utils :refer :all] (:require [adl.utils :refer :all]
[adl.to-hugsql-queries :as h] [adl.to-hugsql-queries :as h]
[adl.to-json-routes :as j] [adl.to-json-routes :as j]
[adl.to-psql :as p]
[adl.to-selmer-routes :as s] [adl.to-selmer-routes :as s]
[adl.to-selmer-templates :as t] [adl.to-selmer-templates :as t]
[clojure.xml :as x]) [clojure.xml :as x])
@ -36,7 +37,7 @@
(println "Argument should be a pathname to an ADL file")) (println "Argument should be a pathname to an ADL file"))
(defn -main (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] [& args]
(cond (cond
(empty? args) (empty? args)
@ -45,6 +46,9 @@
(let [application (x/parse (first args))] (let [application (x/parse (first args))]
(h/to-hugsql-queries application) (h/to-hugsql-queries application)
(j/to-json-routes application) (j/to-json-routes application)
(p/to-psql application)
(s/to-selmer-routes application) (s/to-selmer-routes application)
(t/to-selmer-templates application)))) (t/to-selmer-templates application))))

534
src/adl/to_psql.clj
View file

@ -35,7 +35,16 @@
;;; this is a pretty straight translation of adl2psql.xslt, and was written because ;;; 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) (declare emit-field-type emit-property)
@ -46,42 +55,86 @@
(let [typedef (typedef property application)] (let [typedef (typedef property application)]
;; this is a hack based on the fact that emit-field-type doesn't check ;; 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. ;; 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 (defn emit-entity-field-type
[property application] [property application]
(let [farside (child (let [farside (child
application application
#(and #(and
(entity? %) (entity? %)
(= (:name (:attrs %)) (:entity (:attrs property))))) (= (:name (:attrs %)) (:entity (:attrs property)))))
key-properties (children-with-tag key-properties (children-with-tag
(first (children-with-tag farside :key)) (first (children-with-tag farside :key))
:property)] :property)]
(if (if
(> (count key-properties) 1) (> (count key-properties) 1)
(str (str
"-- ERROR: cannot generate link to entity " "-- ERROR: cannot generate link to entity "
(:name (:attrs farside)) (:name (:attrs farside))
" with compound primary key\n") " with compound primary key\n")
(list (list
(emit-field-type (first key-properties) farside application false) (emit-field-type (first key-properties) farside application false)
"REFERENCES" "REFERENCES"
(str (str
(:table (:attrs farside)) "(" (:name (:attrs (first key-properties))) ) ")" (:table (:attrs farside)) "(" (:name (:attrs (first key-properties)))) ")"
;; TODO: ought to handle the `cascade` attribute, even though it's rarely used ;; TODO: ought to handle the `cascade` attribute, even though it's rarely used
)))) ))))
(defn emit-field-type (defn emit-field-type
[property entity application key?] [property entity application key?]
(case (:type (:attrs property)) (case (:type (:attrs property))
"integer" (if key? "serial" "INTEGER") "integer" (if key? "SERIAL" "INTEGER")
"real" "DOUBLE PRECISION" "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) "defined" (emit-defined-field-type property application)
"entity" (emit-entity-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))) (str "-- ERROR: unknown type " (:type (:attrs property)))
)) ))
@ -89,13 +142,13 @@
(defn emit-link-field (defn emit-link-field
[property entity application] [property entity application]
(emit-property (emit-property
{:tag :property {:tag :property
:attrs {:name (str (:name (:attrs entity)) "_id") :attrs {:name (str (:name (:attrs entity)) "_id")
:type "entity" :type "entity"
:entity (:name (:attrs entity)) :entity (:name (:attrs entity))
:cascade (:cascade (:attrs property))}} :cascade (:cascade (:attrs property))}}
entity entity
application)) application))
(defn emit-permissions-grant (defn emit-permissions-grant
@ -108,53 +161,56 @@
(:DELETE :ALL) #{"all"}) (:DELETE :ALL) #{"all"})
group-names group-names
(set (set
(remove (remove
nil? nil?
(map (map
#(if (selector (:permission (:attrs %))) #(if (selector (:permission (:attrs %)))
(:name (:attrs %))) (:group (:attrs %)))
permissions)))] permissions)))]
(if (if
(not (empty? group-names)) (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 (defn emit-link-table
[property e1 application emitted-link-tables] [property e1 application emitted-link-tables]
(let [e2 (child (let [e2 (child
application application
#(and #(and
(entity? %) (entity? %)
(= (:name (:attrs %)) (:entity (:attrs property))))) (= (:name (:attrs %)) (:entity (:attrs property)))))
link-table-name (link-table-name e1 e2) link-table-name (link-table-name e1 e2)
permissions (flatten permissions (flatten
(list (list
(children-with-tag e1 :permission) (children-with-tag e1 :permission)
(children-with-tag e1 :permission)))] (children-with-tag e1 :permission)))]
(if (if
true ;;(not (@emitted-link-tables link-table-name)) (not (@emitted-link-tables link-table-name))
(do (do
;; (swap! emitted-link-tables (conj @emitted-link-tables link-table-name)) (swap! emitted-link-tables conj link-table-name)
(s/join (s/join
"\n" "\n"
(list (list
comment-rule comment-rule
(str "--\tlink table joining " (:name (:attrs e1)) " with " (:name (:attrs e2))) (str "--\tlink table joining " (:name (:attrs e1)) " with " (:name (:attrs e2)))
comment-rule comment-rule
(s/join " " (list "CREATE TABLE" link-table-name)) (s/join " " (list "CREATE TABLE IF NOT EXISTS" link-table-name))
"(" "("
(emit-link-field property e1 application) (emit-link-field property e1 application)
(emit-link-field property e2 application) (emit-link-field property e2 application)
");" ");"
(emit-permissions-grant link-table-name :SELECT permissions) (emit-permissions-grant link-table-name :SELECT permissions)
(emit-permissions-grant link-table-name :INSERT permissions))))))) (emit-permissions-grant link-table-name :INSERT permissions)))))))
(defn emit-link-tables (defn emit-link-tables
[entity application emitted-link-tables] [entity application emitted-link-tables]
(map (map
#(emit-link-table % entity application emitted-link-tables) #(emit-link-table % entity application emitted-link-tables)
(children entity #(and (= (:tag %) :property) (= (:type (:attrs %)) "link"))))) (sort-by-name
(filter
#(= (:type (:attrs %)) "link")
(properties entity)))))
(defn emit-property (defn emit-property
@ -164,96 +220,98 @@
(let [default (:default (:attrs property))] (let [default (:default (:attrs property))]
(if (if
(and (and
(= (:tag property) :property) (= (:tag property) :property)
(not (#{"link"} (:type (:attrs property))))) (not (#{"link"} (:type (:attrs property)))))
(s/join (s/join
" " " "
(remove
nil?
(flatten (flatten
(list (list
"\t" "\t"
(:name (:attrs property)) (:name (:attrs property))
(emit-field-type property entity application key?) (emit-field-type property entity application key?)
(if default (list "DEFAULT" default)) (if default (list "DEFAULT" default))
(if (if
key? key?
"NOT NULL PRIMARY KEY" "NOT NULL PRIMARY KEY"
(if (= (:required (:attrs property)) "true") "NOT NULL"))))))))) (if (= (:required (:attrs property)) "true") "NOT NULL"))))))))))
(defn compose-convenience-entity-field (defn compose-convenience-entity-field
;; TODO: this is not recursing properly
[field entity application] [field entity application]
(let [farside (child (let [farside (child
application application
#(and #(and
(entity? %) (entity? %)
(= (:name (:attrs %)) (:entity (:attrs field)))))] (= (:name (:attrs %)) (:entity (:attrs field)))))]
(flatten (flatten
(map (map
(fn [f] (fn [f]
(if (if
(= (:type (:attrs f)) "entity") (= (:type (:attrs f)) "entity")
(compose-convenience-entity-field f farside application) (compose-convenience-entity-field f farside application)
(str (:table (:attrs farside)) "." (:name (:attrs f))))) (str (:table (:attrs farside)) "." (:name (:attrs f)))))
(user-distinct-properties farside))))) (user-distinct-properties farside)))))
(defn compose-convenience-view-select-list (defn compose-convenience-view-select-list
[entity application top-level?] [entity application top-level?]
(remove (remove
nil? nil?
(flatten (flatten
(cons (cons
(:name (:attrs entity)) (:name (:attrs entity))
(map (map
(fn [f] (fn [f]
(if (if
(= (:type (:attrs f)) "entity") (= (:type (:attrs f)) "entity")
(compose-convenience-view-select-list (compose-convenience-view-select-list
(child application #(and (entity? %) (= (:name (:attrs %))(:entity (:attrs f))))) (child application #(and (entity? %) (= (:name (:attrs %))(:entity (:attrs f)))))
application application
false))) false)))
(if (if
top-level? top-level?
(all-properties entity) (all-properties entity)
(user-distinct-properties entity))))))) (user-distinct-properties entity)))))))
(defn compose-convenience-where-clause (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?] [entity application top-level?]
(remove (remove
nil? nil?
(flatten (flatten
(map (map
(fn [f] (fn [f]
(if (if
(= (:type (:attrs f)) "entity") (= (:type (:attrs f)) "entity")
(let [farside (entity-for-property f application)] (let [farside (entity-for-property f application)]
(cons (cons
(str (str
(:table (:attrs entity)) (:table (:attrs entity))
"." "."
(:name (:attrs f)) (:name (:attrs f))
" = " " = "
(:table (:attrs farside)) (:table (:attrs farside))
"." "."
(first (key-names farside))) (first (key-names farside)))
#(compose-convenience-where-clause farside application false))))) #(compose-convenience-where-clause farside application false)))))
(if (if
top-level? top-level?
(all-properties entity) (all-properties entity)
(user-distinct-properties entity)))))) (user-distinct-properties entity))))))
(defn emit-convenience-entity-field (defn emit-convenience-entity-field
[field entity application] [field entity application]
(str (str
(s/join (s/join
" |', '| " " |', '| "
(compose-convenience-entity-field field entity application)) (compose-convenience-entity-field field entity application))
" AS " " AS "
(:name (:attrs field)))) (:name (:attrs field))))
(defn emit-convenience-view (defn emit-convenience-view
@ -262,138 +320,162 @@
[entity application] [entity application]
(let [view-name (str "lv_" (:table (:attrs entity))) (let [view-name (str "lv_" (:table (:attrs entity)))
entity-fields (filter entity-fields (filter
#(= (:type (:attrs %)) "entity") #(= (:type (:attrs %)) "entity")
(properties entity))] (properties entity))]
(s/join (s/join
"\n" "\n"
(remove (remove
nil? nil?
(flatten (flatten
(list (list
comment-rule comment-rule
(str "--\tconvenience view " view-name " of entity " (:name (:attrs entity)) " for lists, et cetera") (str "--\tconvenience view " view-name " of entity " (:name (:attrs entity)) " for lists, et cetera")
comment-rule comment-rule
(s/join (s/join
" " " "
(list "CREATE VIEW" view-name "AS")) (list "CREATE VIEW" view-name "AS"))
(str (str
"SELECT " "SELECT "
(s/join (s/join
",\n\t" ",\n\t"
(map (map
#(if #(if
(= (:type (:attrs %)) "entity") (= (:type (:attrs %)) "entity")
(emit-convenience-entity-field % entity application) (emit-convenience-entity-field % entity application)
(:name (:attrs %))) (:name (:attrs %)))
(filter (filter
#(and (= (:tag %) :property) (not (= (:type (:attrs %)) "link"))) #(and (= (:tag %) :property) (not (= (:type (:attrs %)) "link")))
(all-properties entity) )))) (all-properties entity) ))))
(str (str
"FROM " (s/join ", " (compose-convenience-view-select-list entity application true))) "FROM " (s/join ", " (compose-convenience-view-select-list entity application true)))
(if (if
(not (empty? entity-fields)) (not (empty? entity-fields))
(str (str
"WHERE " "WHERE "
(s/join (s/join
"\n\tAND " "\n\tAND "
(map (map
(fn [f] (fn [f]
(let (let
[farside (child [farside (child
application application
#(and #(and
(entity? %) (entity? %)
(= (:name (:attrs %)) (:entity (:attrs f)))))] (= (:name (:attrs %)) (:entity (:attrs f)))))]
(str (str
(:table (:attrs entity)) (:table (:attrs entity))
"." "."
(:name (:attrs f)) (:name (:attrs f))
" = " " = "
(:table (:attrs farside)) (:table (:attrs farside))
"." "."
(first (key-names farside))))) (first (key-names farside)))))
entity-fields)))) entity-fields))))
";" ";"
(emit-permissions-grant view-name :SELECT (permissions entity application)))))))) (emit-permissions-grant view-name :SELECT (permissions entity application))))))))
(defn emit-table (defn emit-table
[entity application emitted-link-tables] [entity application]
(let [table-name (:table (:attrs entity)) (let [table-name (:table (:attrs entity))
permissions (children-with-tag entity :permission)] permissions (children-with-tag entity :permission)]
(s/join (s/join
"\n" "\n"
(flatten (flatten
(list (list
comment-rule comment-rule
(str "--\tprimary table " table-name " for entity " (:name (:attrs entity))) (str "--\tprimary table " table-name " for entity " (:name (:attrs entity)))
comment-rule comment-rule
(s/join (s/join
" " " "
(list "CREATE TABLE " table-name)) (list "CREATE TABLE" table-name))
"(" "("
(map (str
#(emit-property % entity application true) (s/join
(children-with-tag (child-with-tag entity :key) :property)) ",\n"
(map (flatten
#(emit-property % entity application false) (remove
(children-with-tag entity :property)) nil?
");" (list
(map (map
#(emit-permissions-grant table-name % permissions) #(emit-property % entity application true)
'(:SELECT :INSERT :UPDATE :DELETE))))))) (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 (defn emit-entity
[entity application emitted-link-tables] [entity application]
(emit-table entity application emitted-link-tables) (doall
(emit-convenience-view entity application)) (list
(emit-table entity application)
(emit-convenience-view entity application))))
(defn emit-group-declaration (defn emit-group-declaration
[group application] [group application]
(s/join (s/join
"\n" "\n"
(list (list
comment-rule comment-rule
(str "--\tsecurity group " (:name (:attrs group))) (str "--\tsecurity group " (:name (:attrs group)))
comment-rule comment-rule
(str "CREATE GROUP IF NOT EXISTS " (:name (:attrs group)))))) (str "CREATE GROUP " (:name (:attrs group)) ";"))))
(defn emit-file-header (defn emit-file-header
[application] [application]
(s/join (s/join
"\n" "\n"
(list (list
comment-rule comment-rule
(str (str
"--\tDatabase definition for application " "--\tDatabase definition for application "
(:name (:attrs application)) (:name (:attrs application))
" version " " version "
(:version (:attrs application))) (:version (:attrs application)))
(str (str
"--\tauto-generated by [Application Description Language framework](https://github.com/simon-brooke/adl) at " "--\tauto-generated by [Application Description Language framework](https://github.com/simon-brooke/adl) at "
(f/unparse (f/formatters :basic-date-time) (t/now))) (f/unparse (f/formatters :basic-date-time) (t/now)))
comment-rule))) comment-rule)))
(defn emit-application (defn emit-application
[application] [application]
(let [emitted-link-tables (atom #{})] (let [emitted-link-tables (atom #{})]
(s/join (s/join
"\n\n" "\n\n"
(flatten (flatten
(list (list
(emit-file-header application) (emit-file-header application)
(map #(emit-group-declaration % application) (children-with-tag application :group)) (map
(map #(emit-entity % application emitted-link-tables) (children-with-tag application :entity)) #(emit-group-declaration % application)
(map #(emit-link-tables % application emitted-link-tables) (children-with-tag application :entity))))))) (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 (defn to-psql
[application] [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) (make-parents filepath)
(spit filepath (emit-application application)))) (spit filepath (emit-application application))))

20
src/adl/utils.clj
View file

@ -88,12 +88,11 @@
[property application] [property application]
(if (if
(= (:type (:attrs property)) "defined") (= (:type (:attrs property)) "defined")
(first (child
(children application
application #(and
#(and (= (:tag %) :typedef)
(= (:tag %) :typedef) (= (:name (:attrs %)) (:typedef (:attrs property)))))))
(= (:name (:attrs %)) (:typedef (:attrs property))))))))
(defn permissions (defn permissions
@ -352,20 +351,13 @@
(keyword? form) (keyword? form)
(path-part (first (children-with-tag entity form)) entity application))) (path-part (first (children-with-tag entity form)) entity application)))
(defn editor-name (defn editor-name
"Return the path-part of the editor form for this `entity`. Note: "Return the path-part of the editor form for this `entity`. Note:
assumes the editor form is the first form listed for the entity." assumes the editor form is the first form listed for the entity."
[entity application] [entity application]
(path-part :form 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 (defn type-for-defined
[property application] [property application]