diff --git a/src/adl/to_hugsql_queries.clj b/src/adl/to_hugsql_queries.clj index be644f9..bc480e8 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] @@ -54,7 +54,9 @@ (defn order-by-clause "Generate an appropriate `order by` clause for queries on this `entity`" - [entity] + ([entity] + (order-by-clause entity "")) + ([entity prefix] (let [entity-name (:name (:attrs entity)) preferred (map @@ -65,10 +67,10 @@ (empty? preferred) "" (str - "ORDER BY " entity-name "." + "ORDER BY " prefix entity-name "." (s/join - (str ",\n\t" entity-name ".") - (flatten (cons preferred (key-names entity)))))))) + (str ",\n\t" prefix entity-name ".") + (flatten (cons preferred (key-names entity))))))))) (defn insert-query @@ -152,8 +154,8 @@ (str "-- :doc selects existing " pretty-name - " records having any string field matching `:pattern` by substring match") - (str "SELECT * FROM " entity-name) + " records having any string field matching the parameter of the same name by substring match") + (str "SELECT * FROM lv_" entity-name) "WHERE " (s/join "\n\tOR " @@ -162,9 +164,9 @@ (map #(if (#{"string" "date" "text"} (:type (:attrs %))) - (str (-> % :attrs :name) " LIKE '%:pattern%'")) + (str (-> % :attrs :name) " LIKE '%params." (-> % :attrs :name) "%'")) properties))) - (order-by-clause entity) + (order-by-clause entity "lv_") "--~ (if (:offset params) \"OFFSET :offset \")" "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))}))) @@ -232,8 +234,8 @@ (list (str "-- :name " query-name " " signature) (str "-- :doc lists all existing " pretty-name " records") - (str "SELECT * FROM " entity-name) - (order-by-clause entity) + (str "SELECT * FROM lv_" entity-name) + (order-by-clause entity "lv_") "--~ (if (:offset params) \"OFFSET :offset \")" "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))}))) @@ -276,9 +278,11 @@ "entity" (list (str "-- :name " query-name " " signature) (str "-- :doc lists all existing " pretty-name " records related to a given " pretty-far) - (str "SELECT * \nFROM " entity-name) - (str "WHERE " entity-name "." link-field " = :id") - (order-by-clause entity)) + (str "SELECT * \nFROM lv_" entity-name ", " entity-name) + (str "WHERE lv_" entity-name "." (first (key-names entity)) " = " + entity-name "." (first (key-names entity)) + "\n\tAND " entity-name "." link-field " = :id") + (order-by-clause entity "lv_")) "link" (let [link-table-name (link-table-name entity far-entity)] (list @@ -325,18 +329,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] @@ -392,13 +396,10 @@ (defn queries "Generate all standard queries for this `entity` in this `application`; if - no entity is specified, generate all queris for the application." + no entity is specified, generate all queries for the application." ([application entity] (merge - (if - (link-table? entity) - (link-table-queries entity application) - {}) + ;; TODO: queries that look through link tables (insert-query entity) (update-query entity) (delete-query entity) @@ -416,22 +417,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_json_routes.clj b/src/adl/to_json_routes.clj index e6e9346..afb0426 100644 --- a/src/adl/to_json_routes.clj +++ b/src/adl/to_json_routes.clj @@ -47,12 +47,12 @@ (f/unparse (f/formatters :basic-date-time) (t/now))) (list :require + '[clojure.java.io :as io] + '[compojure.core :refer [defroutes GET POST]] + '[hugsql.core :as hugsql] '[noir.response :as nresponse] '[noir.util.route :as route] - '[compojure.core :refer [defroutes GET POST]] '[ring.util.http-response :as response] - '[clojure.java.io :as io] - '[hugsql.core :as hugsql] (vector (symbol (str (safe-name (:name (:attrs application))) ".db.core")) :as 'db)))) diff --git a/src/adl/to_psql.clj b/src/adl/to_psql.clj index 8737290..623c912 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)) + (safe-name (:name (:attrs nearside)) :sql) "ADD CONSTRAINT" - (str "ri_" (:name (:attrs nearside)) "_" (:name (:attrs property))) + (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 @@ -366,7 +385,7 @@ (list (emit-header "--" - (str "--\treferential integrity links for first-class tables")) + "referential integrity links for primary tables") (map #(emit-referential-integrity-links % application) (sort-by-name (children-with-tag application :entity))))))) @@ -374,7 +393,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" @@ -424,12 +443,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))} - :content nil}) + :farkey (safe-name (first (key-names entity)) :sql)}}) (defn emit-link-table @@ -489,21 +507,13 @@ (sort-by-name (children-with-tag application :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 @@ -535,7 +545,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/to_selmer_routes.clj b/src/adl/to_selmer_routes.clj index 37e5a71..597797a 100644 --- a/src/adl/to_selmer_routes.clj +++ b/src/adl/to_selmer_routes.clj @@ -44,12 +44,12 @@ (f/unparse (f/formatters :basic-date-time) (t/now))) (list :require + '[clojure.java.io :as io] + '[compojure.core :refer [defroutes GET POST]] + '[hugsql.core :as hugsql] '[noir.response :as nresponse] '[noir.util.route :as route] - '[compojure.core :refer [defroutes GET POST]] '[ring.util.http-response :as response] - '[clojure.java.io :as io] - '[hugsql.core :as hugsql] (vector (symbol (str (:name (:attrs application)) ".layout")) :as 'l) (vector (symbol (str (:name (:attrs application)) ".db.core")) :as 'db) (vector (symbol (str (:name (:attrs application)) ".routes.manual")) :as 'm)))) @@ -78,11 +78,25 @@ :list {:records (list - (symbol - (str - "db/search-strings-" - (singularise (:name (:attrs e))))) - 'p)}))))))) + 'if + (list + 'not + (list + 'empty? + (list 'remove 'nil? (list 'vals 'p)))) + (list + (symbol + (str + "db/search-strings-" + (singularise (:name (:attrs e))))) + (symbol "db/*db*") + 'p) + (list + (symbol + (str + "db/list-" + (:name (:attrs e)))) + (symbol "db/*db*") {}))}))))))) (defn make-route "Make a route for method `m` to request the resource with name `n`." diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj index a1616e1..69faf38 100644 --- a/src/adl/to_selmer_templates.clj +++ b/src/adl/to_selmer_templates.clj @@ -422,7 +422,7 @@ [list-spec entity application] {:tag :tbody :content - ["{% for record in %records% %}" + ["{% for record in records %}" {:tag :tr :content (apply @@ -438,7 +438,6 @@ :attrs {:href (str - "{{servlet-context}}/" (editor-name entity application) "?" (s/join @@ -480,7 +479,7 @@ (list-page-control true)]}) -(defn- list-to-template +(defn list-to-template "Generate a template as specified by this `list` element for this `entity`, taken from this `application`. If `list` is nill, generate a default list template for the entity." @@ -502,9 +501,9 @@ `entity` in this `application`" [entity application] (let - [forms (children entity #(= (:tag %) :form)) - pages (children entity #(= (:tag %) :page)) - lists (children entity #(= (:tag %) :list))] + [forms (children-with-tag entity :form) + pages (children-with-tag entity :page) + lists (children-with-tag entity :list)] (if (and (= (:tag entity) :entity) ;; it seems to be an ADL entity diff --git a/src/adl/utils.clj b/src/adl/utils.clj index 13b43e7..8767c47 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,24 +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)))) - - -(defn link-table? - "Return true if this `entity` represents a link table." - [entity] - (let [properties (children entity #(= (:tag %) :property)) - links (filter #(-> % :attrs :entity) properties)] - (= (count properties) (count links)))) + "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 read-adl [url] @@ -351,6 +363,14 @@ `(filter insertable? (key-properties entity))) +(defn link-table? + "Return true if this `entity` represents a link table." + [entity] + (let [properties (all-properties entity) + links (filter #(-> % :attrs :entity) properties)] + (= (count properties) (count links)))) + + (defn key-names [entity] (remove nil? @@ -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))