Now generating credible-seeming (but untested) routes file
This commit is contained in:
parent
a43e10c49b
commit
4193d5700b
|
|
@ -52,10 +52,18 @@
|
|||
|
||||
(defn insert-query [entity-map]
|
||||
(let [entity-name (:name (:attrs entity-map))
|
||||
pretty-name (s/replace (s/replace entity-name #"_" "-") #"s$" "")
|
||||
pretty-name (singularise entity-name)
|
||||
all-property-names (map #(:name (:attrs %)) (vals (:properties (:content entity-map))))
|
||||
]
|
||||
(str "-- :name create-" pretty-name "! :<!\n"
|
||||
query-name (str "create-" pretty-name "!")
|
||||
signature " :! :n"]
|
||||
(hash-map
|
||||
(keyword query-name)
|
||||
{:name query-name
|
||||
:signature signature
|
||||
:entity entity-map
|
||||
: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)
|
||||
|
|
@ -65,7 +73,7 @@
|
|||
(if
|
||||
(has-primary-key? entity-map)
|
||||
(str "\nreturning " (s/join ",\n\t" (key-names entity-map))))
|
||||
"\n\n")))
|
||||
"\n\n")})))
|
||||
|
||||
|
||||
(defn update-query [entity-map]
|
||||
|
|
@ -74,64 +82,109 @@
|
|||
(has-primary-key? entity-map)
|
||||
(has-non-key-properties? entity-map))
|
||||
(let [entity-name (:name (:attrs entity-map))
|
||||
pretty-name (s/replace (s/replace entity-name #"_" "-") #"s$" "")
|
||||
pretty-name (singularise entity-name)
|
||||
property-names (remove
|
||||
nil?
|
||||
(map
|
||||
#(if (= (:tag %) :property) (:name (:attrs %)))
|
||||
(vals (:properties (:content entity-map)))))]
|
||||
(str "-- :name update-" pretty-name "! :! :n\n"
|
||||
(vals (:properties (:content entity-map)))))
|
||||
query-name (str "update-" pretty-name "!")
|
||||
signature ":! :n"]
|
||||
(hash-map
|
||||
(keyword query-name)
|
||||
{:name query-name
|
||||
:signature signature
|
||||
:entity entity-map
|
||||
:type :update-1
|
||||
:query
|
||||
(str "-- :name " query-name " " signature "\n"
|
||||
"-- :doc updates an existing " pretty-name " record\n"
|
||||
"UPDATE " entity-name "\n"
|
||||
"SET "
|
||||
(s/join ",\n\t" (map #(str % " = " (keyword %)) property-names))
|
||||
"\n"
|
||||
(where-clause entity-map)
|
||||
"\n\n"))))
|
||||
"\n\n")}))
|
||||
{}))
|
||||
|
||||
|
||||
(defn select-query [entity-map]
|
||||
(if
|
||||
(has-primary-key? entity-map)
|
||||
(let [entity-name (:name (:attrs entity-map))
|
||||
pretty-name (s/replace (s/replace entity-name #"_" "-") #"s$" "")]
|
||||
(str "-- :name get-" pretty-name " :? :1\n"
|
||||
pretty-name (singularise entity-name)
|
||||
query-name (str "get-" pretty-name)
|
||||
signature ":? :1"]
|
||||
(hash-map
|
||||
(keyword query-name)
|
||||
{:name query-name
|
||||
:signature signature
|
||||
:entity entity-map
|
||||
: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)
|
||||
"\n"
|
||||
(order-by-clause entity-map)
|
||||
"\n\n"))))
|
||||
"\n\n")}))
|
||||
{}))
|
||||
|
||||
|
||||
(defn list-query [entity-map]
|
||||
(defn list-query
|
||||
"Generate a query to list records in the table represented by this `entity-map`.
|
||||
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))
|
||||
pretty-name (s/replace (s/replace entity-name #"_" "-") #"s$" "")]
|
||||
(str "-- :name list-" pretty-name " :? :*\n"
|
||||
pretty-name (singularise entity-name)
|
||||
query-name (str "list-" entity-name)
|
||||
signature ":? :*"]
|
||||
(hash-map
|
||||
(keyword query-name)
|
||||
{:name query-name
|
||||
:signature signature
|
||||
:entity entity-map
|
||||
: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\n")))
|
||||
(order-by-clause entity-map) "\n"
|
||||
"--~ (if (:offset params) \"OFFSET :offset \") \n"
|
||||
"--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")"
|
||||
"\n\n")})))
|
||||
|
||||
|
||||
(defn foreign-queries [entity-map entities-map]
|
||||
(let [entity-name (:name (:attrs entity-map))
|
||||
pretty-name (s/replace (s/replace entity-name #"_" "-") #"s$" "")
|
||||
pretty-name (singularise entity-name)
|
||||
links (filter #(-> % :attrs :entity) (-> entity-map :content :properties vals))]
|
||||
(apply
|
||||
str
|
||||
merge
|
||||
(map
|
||||
#(let [far-name (-> % :attrs :entity)
|
||||
far-entity ((keyword far-name) entities-map)
|
||||
pretty-far (s/replace (s/replace far-name #"_" "-") #"s$" "")
|
||||
farkey (-> % :attrs :farkey)
|
||||
link-field (-> % :attrs :name)]
|
||||
(str "-- :name list-" entity-name "-by-" pretty-far " :? :*\n"
|
||||
link-field (-> % :attrs :name)
|
||||
query-name (str "list-" entity-name "-by-" pretty-far)
|
||||
signature ":? :*"]
|
||||
(hash-map
|
||||
(keyword query-name)
|
||||
{:name query-name
|
||||
:signature signature
|
||||
:entity entity-map
|
||||
: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"))
|
||||
"\n\n")}))
|
||||
links))))
|
||||
|
||||
|
||||
|
|
@ -145,16 +198,26 @@
|
|||
near-name (-> near :attrs :name)
|
||||
link-name (-> link :attrs :name)
|
||||
far-name (-> far :attrs :name)
|
||||
pretty-far (singularise far-name)]
|
||||
(println links)
|
||||
(str "-- :name list-" link-name "-" near-name "-by-" pretty-far " :? :*\n"
|
||||
pretty-far (singularise far-name)
|
||||
query-name (str "list-" link-name "-" near-name "-by-" pretty-far)
|
||||
signature ":? :*"]
|
||||
(hash-map
|
||||
(keyword query-name)
|
||||
{:name query-name
|
||||
:signature signature
|
||||
:entity link
|
||||
:type :select-many-to-many
|
||||
: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")))
|
||||
"\n\n")})))
|
||||
|
||||
|
||||
(defn link-table-queries [entity-map entities-map]
|
||||
|
|
@ -164,9 +227,9 @@
|
|||
(remove nil? (map #(-> % :attrs :entity) (-> entity-map :content :properties vals))))
|
||||
pairs (combinations entities 2)]
|
||||
(apply
|
||||
str
|
||||
merge
|
||||
(map
|
||||
#(str
|
||||
#(merge
|
||||
(link-table-query (nth % 0) entity-map (nth % 1))
|
||||
(link-table-query (nth % 1) entity-map (nth % 0)))
|
||||
pairs))))
|
||||
|
|
@ -177,24 +240,34 @@
|
|||
(if
|
||||
(has-primary-key? entity-map)
|
||||
(let [entity-name (:name (:attrs entity-map))
|
||||
pretty-name (s/replace (s/replace entity-name #"_" "-") #"s$" "")]
|
||||
(str "-- :name delete-" pretty-name "! :! :n\n"
|
||||
pretty-name (singularise entity-name)
|
||||
query-name (str "delete-" pretty-name "!")
|
||||
signature ":! :n"]
|
||||
(hash-map
|
||||
(keyword query-name)
|
||||
{:name query-name
|
||||
:signature signature
|
||||
:entity entity-map
|
||||
: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"))))
|
||||
"\n\n")}))))
|
||||
|
||||
|
||||
(defn queries
|
||||
[entity-map entities-map]
|
||||
(str
|
||||
(merge
|
||||
{}
|
||||
(insert-query entity-map)
|
||||
(update-query entity-map)
|
||||
(delete-query entity-map)
|
||||
(if
|
||||
(is-link-table? entity-map)
|
||||
(link-table-queries entity-map entities-map)
|
||||
(str
|
||||
(merge
|
||||
(select-query entity-map)
|
||||
(list-query entity-map)
|
||||
(foreign-queries entity-map entities-map)))))
|
||||
|
|
@ -206,6 +279,15 @@
|
|||
([migrations-path output]
|
||||
(let
|
||||
[adl-struct (migrations-to-xml migrations-path "Ignored")
|
||||
file-content (apply str (map #(queries % adl-struct) (vals adl-struct)))]
|
||||
file-content (apply
|
||||
str
|
||||
(doall (map
|
||||
#(:query %)
|
||||
(vals
|
||||
(apply
|
||||
merge
|
||||
(map
|
||||
#(queries % adl-struct)
|
||||
(vals adl-struct)))))))]
|
||||
(spit output file-content)
|
||||
file-content)))
|
||||
|
|
|
|||
225
src/squirrel_parse/to_json_routes.clj
Normal file
225
src/squirrel_parse/to_json_routes.clj
Normal file
|
|
@ -0,0 +1,225 @@
|
|||
(ns ^{:doc "A parser for SQL: generate JSON routes."
|
||||
:author "Simon Brooke"}
|
||||
squirrel-parse.to-json-routes
|
||||
(:require [clojure.java.io :refer [file]]
|
||||
[clojure.math.combinatorics :refer [combinations]]
|
||||
[clojure.pprint :refer [pprint write]]
|
||||
[clojure.string :as s]
|
||||
[squirrel-parse.to-adl :refer [migrations-to-xml]]
|
||||
[squirrel-parse.to-hugsql-queries :refer [queries]]
|
||||
[squirrel-parse.utils :refer [is-link-table? singularise]]))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;;;
|
||||
;;;; squirrel-parse.to-json-routes: generate JSON routes.
|
||||
;;;;
|
||||
;;;; This program is free software; you can redistribute it and/or
|
||||
;;;; modify it under the terms of the GNU General Public License
|
||||
;;;; as published by the Free Software Foundation; either version 2
|
||||
;;;; of the License, or (at your option) any later version.
|
||||
;;;;
|
||||
;;;; This program is distributed in the hope that it will be useful,
|
||||
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;;;; GNU General Public License for more details.
|
||||
;;;;
|
||||
;;;; You should have received a copy of the GNU General Public License
|
||||
;;;; along with this program; if not, write to the Free Software
|
||||
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
|
||||
;;;; USA.
|
||||
;;;;
|
||||
;;;; Copyright (C) 2018 Simon Brooke
|
||||
;;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;; The overall structure of this has quite closely to follow the structure of
|
||||
;;; to-hugsql-queries, because essentially we need one JSON entry point to wrap
|
||||
;;; each query.
|
||||
|
||||
(defn file-header [parent-name this-name]
|
||||
(list
|
||||
'ns
|
||||
^{:doc "JSON routes auto-generated by squirrel-parse"}
|
||||
(symbol (str parent-name "." this-name))
|
||||
(list
|
||||
'require
|
||||
'[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 parent-name ".db.core")) :as 'db))))
|
||||
|
||||
|
||||
(defn make-safe-name [string]
|
||||
(s/replace string #"[^a-zA-Z0-9-]" ""))
|
||||
|
||||
|
||||
(defn declarations [handlers-map]
|
||||
(cons 'declare (sort (map #(symbol (make-safe-name (name %))) (keys handlers-map)))))
|
||||
|
||||
|
||||
(defn generate-handler-src
|
||||
[handler-name query-map method doc]
|
||||
(hash-map
|
||||
:method method
|
||||
:src
|
||||
(remove
|
||||
nil?
|
||||
(list
|
||||
'defn
|
||||
handler-name
|
||||
(str "Auto-generated method to " doc)
|
||||
[{:keys ['params]}]
|
||||
(list 'do (list (symbol (str "db/" (:name query-map))) 'params))
|
||||
(case
|
||||
(:type query-map)
|
||||
(:delete-1 :update-1)
|
||||
'(response/found "/")
|
||||
nil)))))
|
||||
|
||||
|
||||
(defn handler
|
||||
"Generate declarations for handlers from query with this `query-key` in this `queries-map` taken from within
|
||||
this `entities-map`. This method must follow the structure of
|
||||
`to-hugsql-queries/queries` quite closely, because we must generate the same names."
|
||||
[query-key queries-map entities-map]
|
||||
(let [query (query-key queries-map)
|
||||
handler-name (symbol (make-safe-name (name query-key)))]
|
||||
(hash-map
|
||||
(keyword handler-name)
|
||||
(merge
|
||||
{:name handler-name
|
||||
:route (str "/json/" handler-name)}
|
||||
(case
|
||||
(:type query)
|
||||
:delete-1
|
||||
(generate-handler-src
|
||||
handler-name query :post
|
||||
(str "delete one record from the "
|
||||
(-> query :entity :attrs :name)
|
||||
" table. Expects the following key(s) to be present in `params`: "
|
||||
(doall (-> query :entity :content :key :content keys))
|
||||
"."))
|
||||
:insert-1
|
||||
(generate-handler-src
|
||||
handler-name query :post
|
||||
(str "insert one record to the "
|
||||
(-> query :entity :attrs :name)
|
||||
" table. Expects the following key(s) to be present in `params`: "
|
||||
(pr-str (-> query :entity :content :properties keys))
|
||||
". Returns a map containing the keys "
|
||||
(pr-str (-> query :entity :content :key :content keys))
|
||||
" identifying the record created."))
|
||||
:update-1
|
||||
(generate-handler-src
|
||||
handler-name query :post
|
||||
(str "update one record in the "
|
||||
(-> query :entity :attrs :name)
|
||||
" table. Expects the following key(s) to be present in `params`: "
|
||||
(pr-str
|
||||
(distinct
|
||||
(sort
|
||||
(flatten
|
||||
(cons
|
||||
(-> query :entity :content :properties keys)
|
||||
(-> query :entity :content :key :content keys))))))
|
||||
"."))
|
||||
:select-1
|
||||
(generate-handler-src
|
||||
handler-name query :post
|
||||
(str "select one record from the "
|
||||
(-> query :entity :attrs :name)
|
||||
" table. Expects the following key(s) to be present in `params`: "
|
||||
(pr-str (-> query :entity :content :key :content keys))
|
||||
". Returns a map containing the following keys: "
|
||||
(pr-str
|
||||
(distinct
|
||||
(sort
|
||||
(flatten
|
||||
(cons
|
||||
(-> query :entity :content :properties keys)
|
||||
(-> query :entity :content :key :content keys))))))
|
||||
"."))
|
||||
:select-many
|
||||
(generate-handler-src
|
||||
handler-name query :post
|
||||
(str "select all records from the "
|
||||
(-> query :entity :attrs :name)
|
||||
" table. If the keys (:limit :offset) are present in the request then they will be used to page through the data. Returns a sequence of maps each containing the following keys: "
|
||||
(pr-str
|
||||
(distinct
|
||||
(sort
|
||||
(flatten
|
||||
(cons
|
||||
(-> query :entity :content :properties keys)
|
||||
(-> query :entity :content :key :content keys))))))
|
||||
"."))
|
||||
|
||||
(:select-many-to-many
|
||||
:select-one-to-many)
|
||||
(hash-map :method :get
|
||||
:src (list 'defn handler-name [{:keys ['params]}]
|
||||
(list 'do (list (symbol (str "db/" (:name query))) 'params))))
|
||||
;; default
|
||||
(hash-map
|
||||
:src
|
||||
(str ";; don't know what to do with query " :key " of type " (:type query))))))))
|
||||
|
||||
|
||||
(defn defroutes [handlers-map]
|
||||
(cons
|
||||
'defroutes
|
||||
(cons
|
||||
'auto-rest-routes
|
||||
(map
|
||||
#(let [handler (handlers-map %)]
|
||||
(list
|
||||
(s/upper-case (name (:method handler)))
|
||||
(str "/json/auto/" (:name handler))
|
||||
'request
|
||||
(list
|
||||
'route/restricted
|
||||
(list (:name handler) 'request))))
|
||||
(sort
|
||||
(keys handlers-map))))))
|
||||
|
||||
|
||||
(defn migrations-to-json-routes
|
||||
([migrations-path parent-namespace-name]
|
||||
(migrations-to-json-routes migrations-path parent-namespace-name "auto-json-routes"))
|
||||
([migrations-path parent-namespace-name namespace-name]
|
||||
(let [output (str (s/replace namespace-name #"-" "_") ".clj")
|
||||
adl-struct (migrations-to-xml migrations-path "Ignored")
|
||||
q (reduce
|
||||
merge
|
||||
{}
|
||||
(map
|
||||
#(queries % adl-struct)
|
||||
(vals adl-struct)))
|
||||
h (reduce
|
||||
merge
|
||||
{}
|
||||
(map
|
||||
#(handler % q adl-struct)
|
||||
(keys q)))
|
||||
f (cons
|
||||
(file-header parent-namespace-name namespace-name)
|
||||
;; (pre-declare
|
||||
(cons
|
||||
(declarations h)
|
||||
(cons
|
||||
(defroutes h)
|
||||
(map #(:src (h %)) (sort (keys h))))))]
|
||||
(spit
|
||||
output
|
||||
(with-out-str
|
||||
(doall
|
||||
(for [expr f]
|
||||
(do
|
||||
(pprint expr)
|
||||
(print "\n\n"))))))
|
||||
f
|
||||
)))
|
||||
|
|
@ -213,5 +213,5 @@
|
|||
|
||||
|
||||
(defn singularise [string]
|
||||
(s/replace (s/replace string #"_" "-") #"s$" ""))
|
||||
(s/replace (s/replace (s/replace string #"_" "-") #"s$" "") #"ie$" "y"))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue