Much improved query generation.
This commit is contained in:
parent
e3dfbb5343
commit
481743ff2d
|
|
@ -6,7 +6,7 @@
|
|||
[clojure.string :as s]
|
||||
[clj-time.core :as t]
|
||||
[clj-time.format :as f]
|
||||
[adl.utils :refer [has-non-key-properties? has-primary-key? link-table? key-names singularise]]))
|
||||
[adl.utils :refer :all]))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;;;
|
||||
|
|
@ -32,75 +32,96 @@
|
|||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
||||
(defn where-clause [entity-map]
|
||||
(def ^:dynamic *output-path*
|
||||
"The path to which generated files will be written."
|
||||
"resources/auto/")
|
||||
|
||||
|
||||
(defn where-clause
|
||||
"Generate an appropriate `where` clause for queries on this `entity`"
|
||||
[entity]
|
||||
(let
|
||||
[entity-name (:name (:attrs entity-map))]
|
||||
[entity-name (:name (:attrs entity))]
|
||||
(str
|
||||
"WHERE " entity-name "."
|
||||
(s/join
|
||||
(str " AND\n\t" entity-name ".")
|
||||
(map #(str % " = " (keyword %)) (key-names entity-map))))))
|
||||
(map #(str % " = " (keyword %)) (key-names entity))))))
|
||||
|
||||
|
||||
(defn order-by-clause [entity-map]
|
||||
(defn order-by-clause
|
||||
"Generate an appropriate `order by` clause for queries on this `entity`"
|
||||
[entity]
|
||||
(let
|
||||
[entity-name (:name (:attrs entity-map))
|
||||
[entity-name (:name (:attrs entity))
|
||||
preferred (map
|
||||
#(:name (:attrs %))
|
||||
(filter #(= (-> % :attrs :distinct) "user")
|
||||
(-> entity-map :content :properties vals)))]
|
||||
(filter #(#{"user" "all"} (-> % :attrs :distinct))
|
||||
(children entity #(= (:tag %) :property))))]
|
||||
(if
|
||||
(empty? preferred)
|
||||
""
|
||||
(str
|
||||
"ORDER BY " entity-name "."
|
||||
(s/join
|
||||
(str ",\n\t" entity-name ".")
|
||||
(doall (flatten (cons preferred (key-names entity-map))))))))
|
||||
(flatten (cons preferred (key-names entity))))))))
|
||||
|
||||
|
||||
(defn insert-query [entity-map]
|
||||
(let [entity-name (:name (:attrs entity-map))
|
||||
(defn insert-query
|
||||
"Generate an appropriate `insert` query for this `entity`.
|
||||
TODO: this depends on the idea that system-unique properties
|
||||
are not insertable, which is... dodgy."
|
||||
[entity]
|
||||
(let [entity-name (:name (:attrs entity))
|
||||
pretty-name (singularise entity-name)
|
||||
all-property-names (map #(:name (:attrs %)) (vals (:properties (:content entity-map))))
|
||||
insertable-property-names (map
|
||||
#(:name (:attrs %))
|
||||
(filter
|
||||
#(not (= (:distinct (:attrs %)) "system"))
|
||||
(all-properties entity)))
|
||||
query-name (str "create-" pretty-name "!")
|
||||
signature " :! :n"]
|
||||
(hash-map
|
||||
(keyword query-name)
|
||||
{:name query-name
|
||||
:signature signature
|
||||
:entity entity-map
|
||||
:entity entity
|
||||
:type :insert-1
|
||||
:query
|
||||
(str "-- :name " query-name " " signature "\n"
|
||||
"-- :doc creates a new " pretty-name " record\n"
|
||||
"INSERT INTO " entity-name " ("
|
||||
(s/join ",\n\t" all-property-names)
|
||||
(s/join ",\n\t" insertable-property-names)
|
||||
")\nVALUES ("
|
||||
(s/join ",\n\t" (map keyword all-property-names))
|
||||
(s/join ",\n\t" (map keyword insertable-property-names))
|
||||
")"
|
||||
(if
|
||||
(has-primary-key? entity-map)
|
||||
(str "\nreturning " (s/join ",\n\t" (key-names entity-map))))
|
||||
"\n\n")})))
|
||||
(has-primary-key? entity)
|
||||
(str "\nreturning " (s/join ",\n\t" (key-names entity)))))})))
|
||||
|
||||
|
||||
(defn update-query [entity-map]
|
||||
(defn update-query
|
||||
"Generate an appropriate `update` query for this `entity`"
|
||||
[entity]
|
||||
(if
|
||||
(and
|
||||
(has-primary-key? entity-map)
|
||||
(has-non-key-properties? entity-map))
|
||||
(let [entity-name (:name (:attrs entity-map))
|
||||
(has-primary-key? entity)
|
||||
(has-non-key-properties? entity))
|
||||
(let [entity-name (:name (:attrs entity))
|
||||
pretty-name (singularise entity-name)
|
||||
property-names (remove
|
||||
nil?
|
||||
(map
|
||||
#(if (= (:tag %) :property) (:name (:attrs %)))
|
||||
(vals (:properties (:content entity-map)))))
|
||||
(vals (:properties (:content entity)))))
|
||||
query-name (str "update-" pretty-name "!")
|
||||
signature ":! :n"]
|
||||
(hash-map
|
||||
(keyword query-name)
|
||||
{:name query-name
|
||||
:signature signature
|
||||
:entity entity-map
|
||||
:entity entity
|
||||
:type :update-1
|
||||
:query
|
||||
(str "-- :name " query-name " " signature "\n"
|
||||
|
|
@ -109,19 +130,19 @@
|
|||
"SET "
|
||||
(s/join ",\n\t" (map #(str % " = " (keyword %)) property-names))
|
||||
"\n"
|
||||
(where-clause entity-map)
|
||||
"\n\n")}))
|
||||
(where-clause entity))}))
|
||||
{}))
|
||||
|
||||
|
||||
(defn search-query [entity-map]
|
||||
(let [entity-name (:name (:attrs entity-map))
|
||||
(defn search-query [entity]
|
||||
"Generate an appropriate search query for this `entity`"
|
||||
(let [entity-name (:name (:attrs entity))
|
||||
pretty-name (singularise entity-name)
|
||||
query-name (str "search-strings-" pretty-name)
|
||||
signature ":? :1"
|
||||
string-fields (filter
|
||||
#(= (-> % :attrs :type) "string")
|
||||
(-> entity-map :content :properties vals))]
|
||||
(children entity #(= (:tag %) :property)))]
|
||||
(if
|
||||
(empty? string-fields)
|
||||
{}
|
||||
|
|
@ -129,30 +150,36 @@
|
|||
(keyword query-name)
|
||||
{:name query-name
|
||||
:signature signature
|
||||
:entity entity-map
|
||||
:entity entity
|
||||
:type :text-search
|
||||
:query
|
||||
(str "-- :name " query-name " " signature "\n"
|
||||
"-- :doc selects existing " entity-name " records having any string field matching `:pattern` by substring match\n"
|
||||
"SELECT * FROM " entity-name "\n"
|
||||
(s/join
|
||||
"\n"
|
||||
(remove
|
||||
empty?
|
||||
(list
|
||||
(str "-- :name " query-name " " signature)
|
||||
(str
|
||||
"-- :doc selects existing "
|
||||
pretty-name
|
||||
" records having any string field matching `:pattern` by substring match")
|
||||
(str "SELECT * FROM " entity-name)
|
||||
"WHERE "
|
||||
(s/join
|
||||
"\n\tOR "
|
||||
(map
|
||||
#(str (-> % :attrs :name) " LIKE '%:pattern%'")
|
||||
string-fields))
|
||||
"\n"
|
||||
(order-by-clause entity-map)
|
||||
"\n"
|
||||
"--~ (if (:offset params) \"OFFSET :offset \") \n"
|
||||
"--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")"
|
||||
"\n\n")}))))
|
||||
(order-by-clause entity)
|
||||
"--~ (if (:offset params) \"OFFSET :offset \")"
|
||||
"--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))}))))
|
||||
|
||||
|
||||
(defn select-query [entity-map]
|
||||
(defn select-query [entity]
|
||||
"Generate an appropriate `select` query for this `entity`"
|
||||
(if
|
||||
(has-primary-key? entity-map)
|
||||
(let [entity-name (:name (:attrs entity-map))
|
||||
(has-primary-key? entity)
|
||||
(let [entity-name (:name (:attrs entity))
|
||||
pretty-name (singularise entity-name)
|
||||
query-name (str "get-" pretty-name)
|
||||
signature ":? :1"]
|
||||
|
|
@ -160,25 +187,28 @@
|
|||
(keyword query-name)
|
||||
{:name query-name
|
||||
:signature signature
|
||||
:entity entity-map
|
||||
:entity entity
|
||||
:type :select-1
|
||||
:query
|
||||
(str "-- :name " query-name " " signature "\n"
|
||||
"-- :doc selects an existing " pretty-name " record\n"
|
||||
"SELECT * FROM " entity-name "\n"
|
||||
(where-clause entity-map)
|
||||
(s/join
|
||||
"\n"
|
||||
(order-by-clause entity-map)
|
||||
"\n\n")}))
|
||||
(remove
|
||||
empty?
|
||||
(list
|
||||
(str "-- :name " query-name " " signature)
|
||||
(str "-- :doc selects an existing " pretty-name " record")
|
||||
(str "SELECT * FROM " entity-name)
|
||||
(where-clause entity)
|
||||
(order-by-clause entity))))}))
|
||||
{}))
|
||||
|
||||
|
||||
(defn list-query
|
||||
"Generate a query to list records in the table represented by this `entity-map`.
|
||||
"Generate a query to list records in the table represented by this `entity`.
|
||||
Parameters `:limit` and `:offset` may be supplied. If not present limit defaults
|
||||
to 100 and offset to 0."
|
||||
[entity-map]
|
||||
(let [entity-name (:name (:attrs entity-map))
|
||||
[entity]
|
||||
(let [entity-name (:name (:attrs entity))
|
||||
pretty-name (singularise entity-name)
|
||||
query-name (str "list-" entity-name)
|
||||
signature ":? :*"]
|
||||
|
|
@ -186,28 +216,40 @@
|
|||
(keyword query-name)
|
||||
{:name query-name
|
||||
:signature signature
|
||||
:entity entity-map
|
||||
:entity entity
|
||||
:type :select-many
|
||||
:query
|
||||
(str "-- :name " query-name " " signature "\n"
|
||||
"-- :doc lists all existing " pretty-name " records\n"
|
||||
"SELECT * FROM " entity-name "\n"
|
||||
(order-by-clause entity-map) "\n"
|
||||
"--~ (if (:offset params) \"OFFSET :offset \") \n"
|
||||
"--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")"
|
||||
"\n\n")})))
|
||||
(s/join
|
||||
"\n"
|
||||
(remove
|
||||
empty?
|
||||
(list
|
||||
(str "-- :name " query-name " " signature)
|
||||
(str "-- :doc lists all existing " pretty-name " records")
|
||||
(str "SELECT * FROM " entity-name)
|
||||
(order-by-clause entity)
|
||||
"--~ (if (:offset params) \"OFFSET :offset \")"
|
||||
"--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))})))
|
||||
|
||||
|
||||
(defn foreign-queries [entity-map entities-map]
|
||||
(let [entity-name (:name (:attrs entity-map))
|
||||
(defn foreign-queries
|
||||
|
||||
[entity application]
|
||||
(let [entity-name (:name (:attrs entity))
|
||||
pretty-name (singularise entity-name)
|
||||
links (filter #(-> % :attrs :entity) (-> entity-map :content :properties vals))]
|
||||
links (filter #(-> % :attrs :entity) (children entity #(= (:tag %) :property)))]
|
||||
(apply
|
||||
merge
|
||||
(map
|
||||
#(let [far-name (-> % :attrs :entity)
|
||||
far-entity ((keyword far-name) entities-map)
|
||||
pretty-far (s/replace (s/replace far-name #"_" "-") #"s$" "")
|
||||
far-entity (first
|
||||
(children
|
||||
application
|
||||
(fn [x]
|
||||
(and
|
||||
(= (:tag x) :entity)
|
||||
(= (:name (:attrs x)) far-name)))))
|
||||
pretty-far (singularise far-name)
|
||||
farkey (-> % :attrs :farkey)
|
||||
link-field (-> % :attrs :name)
|
||||
query-name (str "list-" entity-name "-by-" pretty-far)
|
||||
|
|
@ -216,20 +258,33 @@
|
|||
(keyword query-name)
|
||||
{:name query-name
|
||||
:signature signature
|
||||
:entity entity-map
|
||||
:entity entity
|
||||
:type :select-one-to-many
|
||||
:far-entity far-entity
|
||||
:query
|
||||
(str "-- :name " query-name " " signature "\n"
|
||||
"-- :doc lists all existing " pretty-name " records related to a given " pretty-far "\n"
|
||||
"SELECT * \nFROM " entity-name "\n"
|
||||
"WHERE " entity-name "." link-field " = :id\n"
|
||||
(order-by-clause entity-map)
|
||||
"\n\n")}))
|
||||
(s/join
|
||||
"\n"
|
||||
(remove
|
||||
empty?
|
||||
(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))))}))
|
||||
links))))
|
||||
|
||||
|
||||
(defn link-table-query [near link far]
|
||||
(defn link-table-query
|
||||
"Generate a query which links across the entity passed as `link`
|
||||
from the entity passed as `near` to the entity passed as `far`.
|
||||
TODO: not working?"
|
||||
[near link far]
|
||||
(if
|
||||
(and
|
||||
(entity? near)
|
||||
(entity? link)
|
||||
(entity? far))
|
||||
(let [properties (-> link :content :properties vals)
|
||||
links (apply
|
||||
merge
|
||||
|
|
@ -251,36 +306,55 @@
|
|||
:near-entity near
|
||||
:far-entity far
|
||||
:query
|
||||
(str "-- :name " query-name " " signature " \n"
|
||||
"-- :doc lists all existing " near-name " records related through " link-name " to a given " pretty-far "\n"
|
||||
"SELECT "near-name ".*\n"
|
||||
"FROM " near-name ", " link-name "\n"
|
||||
"WHERE " near-name "." (first (key-names near)) " = " link-name "." (-> (links (keyword near-name)) :attrs :name) "\n\t"
|
||||
"AND " link-name "." (-> (links (keyword far-name)) :attrs :name) " = :id\n"
|
||||
(order-by-clause near)
|
||||
"\n\n")})))
|
||||
(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 "." (-> (links (keyword near-name)) :attrs :name) )
|
||||
("\tAND " link-name "." (-> (links (keyword far-name)) :attrs :name) " = :id")
|
||||
(order-by-clause near))))}))))
|
||||
|
||||
|
||||
(defn link-table-queries [entity-map entities-map]
|
||||
(defn link-table-queries [entity application]
|
||||
"Generate all the link queries in this `application` which link via this `entity`."
|
||||
(let
|
||||
[entities (map
|
||||
#((keyword %) entities-map)
|
||||
(remove nil? (map #(-> % :attrs :entity) (-> entity-map :content :properties vals))))
|
||||
;; find the far-side entities
|
||||
(fn
|
||||
[far-name]
|
||||
(children
|
||||
application
|
||||
(fn [x]
|
||||
(and
|
||||
(= (:tag x) :entity)
|
||||
(= (:name (:attrs x)) far-name)))))
|
||||
;; of those properties of this `entity` which are of type `entity`
|
||||
(remove
|
||||
nil?
|
||||
(map
|
||||
#(-> % :attrs :entity)
|
||||
(children entity #(= (:tag %) :property)))))
|
||||
pairs (combinations entities 2)]
|
||||
(apply
|
||||
merge
|
||||
(map
|
||||
#(merge
|
||||
(link-table-query (nth % 0) entity-map (nth % 1))
|
||||
(link-table-query (nth % 1) entity-map (nth % 0)))
|
||||
(link-table-query (nth % 0) entity (nth % 1))
|
||||
(link-table-query (nth % 1) entity (nth % 0)))
|
||||
pairs))))
|
||||
|
||||
|
||||
|
||||
(defn delete-query [entity-map]
|
||||
(defn delete-query [entity]
|
||||
"Generate an appropriate `delete` query for this `entity`"
|
||||
(if
|
||||
(has-primary-key? entity-map)
|
||||
(let [entity-name (:name (:attrs entity-map))
|
||||
(has-primary-key? entity)
|
||||
(let [entity-name (:name (:attrs entity))
|
||||
pretty-name (singularise entity-name)
|
||||
query-name (str "delete-" pretty-name "!")
|
||||
signature ":! :n"]
|
||||
|
|
@ -288,57 +362,58 @@
|
|||
(keyword query-name)
|
||||
{:name query-name
|
||||
:signature signature
|
||||
:entity entity-map
|
||||
:entity entity
|
||||
:type :delete-1
|
||||
:query
|
||||
(str "-- :name " query-name " " signature "\n"
|
||||
"-- :doc updates an existing " pretty-name " record\n"
|
||||
"DELETE FROM " entity-name "\n"
|
||||
(where-clause entity-map)
|
||||
"\n\n")}))))
|
||||
(where-clause entity))}))))
|
||||
|
||||
|
||||
(defn queries
|
||||
[entity-map entities-map]
|
||||
"Generate all standard queries for this `entity` in this `application`."
|
||||
[entity application]
|
||||
(merge
|
||||
{}
|
||||
(insert-query entity-map)
|
||||
(update-query entity-map)
|
||||
(delete-query entity-map)
|
||||
(insert-query entity)
|
||||
(update-query entity)
|
||||
(delete-query entity)
|
||||
(if
|
||||
(link-table? entity-map)
|
||||
(link-table-queries entity-map entities-map)
|
||||
(link-table? entity)
|
||||
(link-table-queries entity application)
|
||||
(merge
|
||||
(select-query entity-map)
|
||||
(list-query entity-map)
|
||||
(search-query entity-map)
|
||||
(foreign-queries entity-map entities-map)))))
|
||||
(select-query entity)
|
||||
(list-query entity)
|
||||
(search-query entity)
|
||||
(foreign-queries entity application)))))
|
||||
|
||||
|
||||
;; (defn migrations-to-queries-sql
|
||||
;; ([migrations-path]
|
||||
;; (migrations-to-queries-sql migrations-path "queries.auto.sql"))
|
||||
;; ([migrations-path output]
|
||||
;; (let
|
||||
;; [adl-struct (migrations-to-xml migrations-path "Ignored")
|
||||
;; file-content (apply
|
||||
;; str
|
||||
;; (cons
|
||||
;; (str "-- "
|
||||
;; output
|
||||
;; " autogenerated by \n-- [squirrel-parse](https://github.com/simon-brooke/squirrel-parse)\n-- at "
|
||||
;; (f/unparse (f/formatters :basic-date-time) (t/now))
|
||||
;; "\n\n")
|
||||
;; (doall
|
||||
;; (map
|
||||
;; #(:query %)
|
||||
;; (sort
|
||||
;; #(compare (:name %1) (:name %2))
|
||||
;; (vals
|
||||
;; (apply
|
||||
;; merge
|
||||
;; (map
|
||||
;; #(queries % adl-struct)
|
||||
;; (vals adl-struct)))))))))]
|
||||
;; (spit output file-content)
|
||||
;; file-content)))
|
||||
(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"))
|
||||
(map
|
||||
#(:query %)
|
||||
(sort
|
||||
#(compare (:name %1) (:name %2))
|
||||
(vals
|
||||
(apply
|
||||
merge
|
||||
(map
|
||||
#(queries % application)
|
||||
(children
|
||||
application
|
||||
(fn [child] (= (:tag child) :entity))))))))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -117,6 +117,12 @@
|
|||
(= (:distinct (:attrs property)) "system"))))
|
||||
|
||||
|
||||
(defn entity?
|
||||
"Return true if `x` is an ADL entity."
|
||||
[x]
|
||||
(= (:tag x) :entity))
|
||||
|
||||
|
||||
(defn visible-to
|
||||
"Return a list of names of groups to which are granted read access,
|
||||
given these `permissions`, else nil."
|
||||
|
|
@ -134,7 +140,13 @@
|
|||
(defn singularise
|
||||
"Attempt to construct an idiomatic English-language singular of this string."
|
||||
[string]
|
||||
(s/replace (s/replace (s/replace string #"_" "-") #"s$" "") #"ie$" "y"))
|
||||
(s/replace
|
||||
(s/replace
|
||||
(s/replace
|
||||
(s/replace string #"_" "-")
|
||||
#"s$" "")
|
||||
#"se$" "s")
|
||||
#"ie$" "y"))
|
||||
|
||||
|
||||
(defn link-table?
|
||||
|
|
@ -169,6 +181,26 @@
|
|||
(count (key-names entity-map))))
|
||||
|
||||
|
||||
(defn children-with-tag
|
||||
"Return all children of this `element` which have this `tag`."
|
||||
[element tag]
|
||||
(children element #(= (:tag %) tag)))
|
||||
|
||||
(defn descendants-with-tag
|
||||
"Return all descendants of this `element`, recursively, which have this `tag`."
|
||||
[element tag]
|
||||
(flatten
|
||||
(remove
|
||||
empty?
|
||||
(cons
|
||||
(children element #(= (:tag %) tag))
|
||||
(map
|
||||
#(descendants-with-tag % tag)
|
||||
(children element))))))
|
||||
|
||||
|
||||
;; (read-adl "../youyesyet/stripped.adl.xml")
|
||||
(defn all-properties
|
||||
"Return all properties of this entity (including key properties)."
|
||||
[entity]
|
||||
(descendants-with-tag entity :property))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue