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]
[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))))

136
src/adl/to_psql.clj
View file

@ -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,7 +55,49 @@
(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]
@ -68,7 +119,7 @@
(emit-field-type (first key-properties) farside application false)
"REFERENCES"
(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
))))
@ -76,12 +127,14 @@
(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)))
))
@ -112,11 +165,11 @@
nil?
(map
#(if (selector (:permission (:attrs %)))
(:name (: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
@ -132,16 +185,16 @@
(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))
(s/join " " (list "CREATE TABLE IF NOT EXISTS" link-table-name))
"("
(emit-link-field property e1 application)
(emit-link-field property e2 application)
@ -154,7 +207,10 @@
[entity application emitted-link-tables]
(map
#(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
@ -168,6 +224,8 @@
(not (#{"link"} (:type (:attrs property)))))
(s/join
" "
(remove
nil?
(flatten
(list
"\t"
@ -177,11 +235,10 @@
(if
key?
"NOT NULL PRIMARY KEY"
(if (= (:required (:attrs property)) "true") "NOT NULL")))))))))
(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
@ -220,6 +277,8 @@
(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?
@ -245,7 +304,6 @@
(user-distinct-properties entity))))))
(defn emit-convenience-entity-field
[field entity application]
(str
@ -318,7 +376,7 @@
(defn emit-table
[entity application emitted-link-tables]
[entity application]
(let [table-name (:table (:attrs entity))
permissions (children-with-tag entity :permission)]
(s/join
@ -330,24 +388,35 @@
comment-rule
(s/join
" "
(list "CREATE TABLE " table-name))
(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)
(children-with-tag entity :property))
");"
(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
@ -358,7 +427,7 @@
comment-rule
(str "--\tsecurity group " (:name (:attrs group)))
comment-rule
(str "CREATE GROUP IF NOT EXISTS " (:name (:attrs group))))))
(str "CREATE GROUP " (:name (:attrs group)) ";"))))
(defn emit-file-header
@ -386,14 +455,27 @@
(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)))))))
(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))))

14
src/adl/utils.clj
View file

@ -88,12 +88,11 @@
[property application]
(if
(= (:type (:attrs property)) "defined")
(first
(children
(child
application
#(and
(= (:tag %) :typedef)
(= (:name (:attrs %)) (:typedef (:attrs property))))))))
(= (: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]