From e67142db471b3b0a134ff1ab378d041294ac4f88 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 14 Jun 2018 18:58:45 +0100 Subject: [PATCH] ADL now successfully generates the whole db definition for YouYesYet --- src/adl/to_hugsql_queries.clj | 52 ++++++------- src/adl/to_psql.clj | 133 +++++++++++++++++++--------------- src/adl/utils.clj | 71 +++++++++++++++--- 3 files changed, 161 insertions(+), 95 deletions(-) diff --git a/src/adl/to_hugsql_queries.clj b/src/adl/to_hugsql_queries.clj index be644f9..578f4ee 100644 --- a/src/adl/to_hugsql_queries.clj +++ b/src/adl/to_hugsql_queries.clj @@ -1,7 +1,7 @@ (ns ^{:doc "Application Description Language - generate HUGSQL queries file." :author "Simon Brooke"} adl.to-hugsql-queries - (:require [clojure.java.io :refer [file]] + (:require [clojure.java.io :refer [file make-parents]] [clojure.math.combinatorics :refer [combinations]] [clojure.string :as s] [clojure.xml :as x] @@ -325,18 +325,18 @@ :near-entity near :far-entity far :query - (s/join - "\n" - (remove - empty? - (list - (str "-- :name " query-name " " signature) - (str "-- :doc lists all existing " near-name " records related through " link-name " to a given " pretty-far ) - (str "SELECT "near-name ".*") - (str "FROM " near-name ", " link-name ) - (str "WHERE " near-name "." (first (key-names near)) " = " link-name "." (singularise near-name) "_id" ) - ("\tAND " link-name "." (singularise far-name) "_id = :id") - (order-by-clause near))))})))) + (s/join + "\n" + (remove + empty? + (list + (str "-- :name " query-name " " signature) + (str "-- :doc lists all existing " near-name " records related through " link-name " to a given " pretty-far ) + (str "SELECT "near-name ".*") + (str "FROM " near-name ", " link-name ) + (str "WHERE " near-name "." (first (key-names near)) " = " link-name "." (singularise near-name) "_id" ) + ("\tAND " link-name "." (singularise far-name) "_id = :id") + (order-by-clause near))))})))) (defn link-table-queries [entity application] @@ -416,22 +416,22 @@ (defn to-hugsql-queries "Generate all [HugSQL](https://www.hugsql.org/) queries implied by this ADL `application` spec." [application] - (spit - (str *output-path* "queries.sql") - (s/join - "\n\n" - (cons - (s/join - "\n-- " - (list - "-- File queries.sql" - "autogenerated by adl.to-hugsql-queries at" - (t/now) - "See [Application Description Language](https://github.com/simon-brooke/adl).\n\n")) + (let [file-path (str *output-path* "resources/sql/queries.sql")] + (make-parents file-path) + (spit + file-path + (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)))))))) + (queries application))))))))) diff --git a/src/adl/to_psql.clj b/src/adl/to_psql.clj index ed93635..dd4dcf1 100644 --- a/src/adl/to_psql.clj +++ b/src/adl/to_psql.clj @@ -37,16 +37,6 @@ ;;; this is a pretty straight translation of adl2psql.xslt, and was written because ;;; 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) @@ -60,7 +50,7 @@ (:pattern (:attrs typedef)) (str " CONSTRAINT " - (gensym "c-") + (gensym "pattern_") " CHECK (" (:name (:attrs property)) " ~* '" @@ -70,7 +60,7 @@ ;; TODO: if base type is date, time or timestamp, values should be quoted. (str " CONSTRAINT " - (gensym "c-") + (gensym "minmax_") " CHECK (" (:minimum (:attrs typedef)) " < " @@ -83,7 +73,7 @@ (:maximum (:attrs typedef)) (str " CONSTRAINT " - (gensym "c-") + (gensym "max_") " CHECK (" (:name (:attrs property)) " < " @@ -92,7 +82,7 @@ (:minimum (:attrs typedef)) (str " CONSTRAINT " - (gensym "c-") + (gensym "min_") " CHECK (" (:minimum (:attrs typedef)) " < " @@ -154,15 +144,35 @@ (:DELETE :ALL) #{"all"}) group-names (set - (remove - nil? - (map - #(if (selector (:permission (:attrs %))) - (:group (:attrs %))) - permissions)))] + (remove + nil? + (map + #(if (selector (:permission (:attrs %))) + (safe-name (:group (:attrs %)) :sql)) + permissions)))] (if (not (empty? group-names)) - (s/join " " (list "GRANT" (name privilege) "ON" table-name "TO" (s/join ",\n\t" (sort group-names)) ";"))))) + (s/join + " " + (list + "GRANT" + (name privilege) + "ON" + (safe-name table-name :sql) + "TO" + (s/join + ",\n\t" + (sort group-names)) + ";"))))) + + +(defn field-name + [property] + (safe-name + (or + (:column (:attrs property)) + (:name (:attrs property))) + :sql)) (defn emit-property @@ -181,9 +191,17 @@ (flatten (list "\t" - (:name (:attrs property)) + (field-name property) (emit-field-type property entity application key?) - (if default (list "DEFAULT" default)) + (if + 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. + default))) (if key? "NOT NULL PRIMARY KEY" @@ -203,7 +221,7 @@ (if (= (:type (:attrs f)) "entity") (compose-convenience-entity-field f farside application) - (str (:table (:attrs farside)) "." (:name (:attrs f))))) + (str (safe-name (:table (:attrs farside))) "." (field-name f)))) (user-distinct-properties farside))))) @@ -213,7 +231,7 @@ nil? (flatten (cons - (:name (:attrs entity)) + (safe-name (:table (:attrs entity)) :sql) (map (fn [f] (if @@ -242,13 +260,13 @@ (let [farside (entity-for-property f application)] (cons (str - (:table (:attrs entity)) + (safe-name (:table (:attrs entity)) :sql) "." - (:name (:attrs f)) + (field-name f) " = " - (:table (:attrs farside)) + (safe-name (:table (:attrs farside)) :sql) "." - (first (key-names farside))) + (safe-name (first (key-names farside)) :sql)) #(compose-convenience-where-clause farside application false))))) (if top-level? @@ -260,17 +278,17 @@ [field entity application] (str (s/join - " |', '| " + " ||', '|| " (compose-convenience-entity-field field entity application)) " AS " - (:name (:attrs field)))) + (field-name 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))) + (let [view-name (safe-name (str "lv_" (:table (:attrs entity))) :sql) entity-fields (filter #(= (:type (:attrs %)) "entity") (properties entity))] @@ -294,12 +312,12 @@ #(if (= (:type (:attrs %)) "entity") (emit-convenience-entity-field % entity application) - (:name (:attrs %))) + (str (safe-name entity) "." (field-name %))) (filter - #(and (= (:tag %) :property) (not (= (:type (:attrs %)) "link"))) + #(not (= (:type (:attrs %)) "link")) (all-properties entity) )))) (str - "FROM " (s/join ", " (compose-convenience-view-select-list entity application true))) + "FROM " (s/join ", " (set (compose-convenience-view-select-list entity application true)))) (if (not (empty? entity-fields)) (str @@ -315,13 +333,13 @@ (entity? %) (= (:name (:attrs %)) (:entity (:attrs f)))))] (str - (:table (:attrs entity)) + (safe-name (:table (:attrs entity)) :sql) "." - (:name (:attrs f)) + (field-name f) " = " - (:table (:attrs farside)) + (safe-name (:table (:attrs farside)) :sql) "." - (first (key-names farside))))) + (safe-name (first (key-names farside)) :sql)))) entity-fields)))) ";" (emit-permissions-grant view-name :SELECT (permissions entity application)))))))) @@ -335,14 +353,15 @@ " " (list "ALTER TABLE" - (:name (:attrs nearside)) - "ADD CONSTRINT" - (str "ri_" (:name (:attrs nearside)) "_" (:name (:attrs farside)) "_" (:name (:attrs property))) + (safe-name (:name (:attrs nearside)) :sql) + "ADD CONSTRAINT" + (safe-name (str "ri_" (:name (:attrs nearside)) "_" (:name (:attrs farside)) "_" (:name (:attrs property))) :sql) "\n\tFOREIGN KEY(" - (:name (:attrs property)) + (field-name property) ") \n\tREFERENCES" (str - (:table (:attrs farside)) "(" (:name (:attrs (first (key-properties farside)))) ")") + (safe-name (:table (:attrs 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 @@ -365,7 +384,7 @@ (list (emit-header "--" - (str "--\treferential integrity links for first-class tables")) + "referential integrity links for primary tables") (map #(emit-referential-integrity-links % application) (children-with-tag application :entity)))))) @@ -373,7 +392,7 @@ (defn emit-table ([entity application doc-comment] - (let [table-name (:table (:attrs entity)) + (let [table-name (safe-name (:table (:attrs entity)) :sql) permissions (children-with-tag entity :permission)] (s/join "\n" @@ -423,11 +442,11 @@ (defn construct-link-property [entity] {:tag :property - :attrs {:name (str (:name (:attrs entity)) "_id") - :column (str (:name (:attrs entity)) "_id") + :attrs {:name (safe-name (str (:name (:attrs entity)) "_id") :sql) + :column (safe-name (str (:name (:attrs entity)) "_id") :sql) :type "entity" :entity (:name (:attrs entity)) - :farkey (first (key-names entity))}}) + :farkey (safe-name (first (key-names entity)) :sql)}}) (defn emit-link-table @@ -480,21 +499,13 @@ (properties entity))))) -(defn emit-entity - [entity application] - (doall - (list - (emit-table entity application) - (emit-convenience-view entity application)))) - - (defn emit-group-declaration [group application] (list (emit-header "--" (str "security group " (:name (:attrs group)))) - (str "CREATE GROUP " (:name (:attrs group)) ";"))) + (str "CREATE GROUP " (safe-name (:name (:attrs group)) :sql) ";"))) (defn emit-file-header @@ -526,7 +537,11 @@ (sort-by-name (children-with-tag application :group))) (map - #(emit-entity % application) + #(emit-table % application) + (sort-by-name + (children-with-tag application :entity))) + (map + #(emit-convenience-view % application) (sort-by-name (children-with-tag application :entity))) (emit-referential-integrity-links application) diff --git a/src/adl/utils.clj b/src/adl/utils.clj index 13b43e7..fb9c5f2 100644 --- a/src/adl/utils.clj +++ b/src/adl/utils.clj @@ -39,6 +39,12 @@ "resources/auto/") +(defn element? + "True if `o` is a Clojure representation of an XML element." + [o] + (and (map? o) (:tag o) (:attrs o))) + + (defn wrap-lines "Wrap lines in this `text` to this `width`; return a list of lines." ;; Shamelessly adapted from https://www.rosettacode.org/wiki/Word_wrap#Clojure @@ -73,6 +79,11 @@ comment-rule))) +(defn sort-by-name + [elements] + (sort #(compare (:name (:attrs %1)) (:name (:attrs %2))) elements)) + + (defn link-table-name "Canonical name of a link table between entity `e1` and entity `e2`." [e1 e2] @@ -249,16 +260,25 @@ (defn safe-name - ([string] - (s/replace string #"[^a-zA-Z0-9-]" "")) - ([string convention] - (case convention - (:sql :c) (s/replace string #"[^a-zA-Z0-9_]" "_") - :c-sharp (s/replace (capitalise string) #"[^a-zA-Z0-9]" "") - :java (let - [camel (s/replace (capitalise string) #"[^a-zA-Z0-9]" "")] - (apply str (cons (Character/toUpperCase (first camel)) (rest camel)))) - (safe-name string)))) + "Return a safe name for the object `o`, given the specified `convention`. + `o` is expected to be either a string or an entity." + ([o] + (if + (element? o) + (safe-name (:name (:attrs o))) + (s/replace (str o) #"[^a-zA-Z0-9-]" ""))) + ([o convention] + (if + (element? o) + (safe-name (:name (:attrs o)) convention) + (let [string (str o)] + (case convention + (:sql :c) (s/replace string #"[^a-zA-Z0-9_]" "_") + :c-sharp (s/replace (capitalise string) #"[^a-zA-Z0-9]" "") + :java (let + [camel (s/replace (capitalise string) #"[^a-zA-Z0-9]" "")] + (apply str (cons (Character/toLowerCase (first camel)) (rest camel)))) + (safe-name string)))))) (defn link-table? @@ -359,6 +379,37 @@ (key-properties entity)))) +(defn base-type + [property application] + (cond + (:typedef (:attrs property)) + (:type + (:attrs + (child + application + #(and + (= (:tag %) :typedef) + (= (:name (:attrs %)) (:typedef (:attrs property))))))) + (:entity (:attrs property)) + (:type + (:attrs + (first + (key-properties + (child + application + #(and + (= (:tag %) :entity) + (= (:name (:attrs %)) (:entity (:attrs property))))))))) + true + (:type (:attrs property)))) + + +(defn is-quotable-type? + "True if the value for this field should be quoted." + [property application] + (#{"date" "image" "string" "text" "time" "timestamp" "uploadable"} (base-type property application))) + + (defn has-primary-key? [entity] (> (count (key-names entity)) 0))