simon/adl
1
0
Fork 0
Code Issues Pull requests Actions Packages Projects Releases Wiki Activity

Separated caching into new namespace.

Browse source
This commit is contained in:
Simon Brooke 2018-09-30 14:33:51 +01:00
parent da5d884605
commit 2df3444090
4 changed files with 391 additions and 255 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

7
src/adl/main.clj
View file

@ -1,7 +1,8 @@
(ns ^{:doc "Application Description Language - command line invocation." (ns ^{:doc "Application Description Language - command line invocation."
:author "Simon Brooke"} :author "Simon Brooke"}
adl.main adl.main
(:require [adl.to-hugsql-queries :as h] (:require [adl.to-cache :as c]
[adl.to-hugsql-queries :as h]
[adl.to-json-routes :as j] [adl.to-json-routes :as j]
[adl.to-psql :as p] [adl.to-psql :as p]
[adl.to-selmer-routes :as s] [adl.to-selmer-routes :as s]
@ -52,8 +53,7 @@
:default "generated"] :default "generated"]
["-v" "--verbosity [LEVEL]" nil "Verbosity level - integer value required" ["-v" "--verbosity [LEVEL]" nil "Verbosity level - integer value required"
:parse-fn #(Integer/parseInt %) :parse-fn #(Integer/parseInt %)
:default 0] :default 0]])
])
(defn usage (defn usage
@ -105,6 +105,7 @@
#(if #(if
(.exists (java.io.File. %)) (.exists (java.io.File. %))
(let [application (x/parse (canonicalise %))] (let [application (x/parse (canonicalise %))]
(c/to-cache application)
(h/to-hugsql-queries application) (h/to-hugsql-queries application)
(j/to-json-routes application) (j/to-json-routes application)
(p/to-psql application) (p/to-psql application)

124
src/adl/to_cache.clj Normal file
View file

@ -0,0 +1,124 @@
(ns ^{:doc "Application Description Language: generate caching layer for database requests."
:author "Simon Brooke"}
adl.to-cache
(:require [adl-support.core :refer :all]
[adl-support.utils :refer :all]
[adl.to-hugsql-queries :refer [generate-documentation queries]]
[clj-time.core :as t]
[clj-time.format :as f]
[clojure.java.io :refer [file make-parents writer]]
[clojure.pprint :refer [pprint]]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; adl.to-cache: generate caching layer for database requests.
;;;;
;;;; 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
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; You can't cache the actual HugSQL functions (or at least, I don't know how
;;; you would); there's no point caching JSON requests because the request data
;;; will be different every time.
;;; 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.
;;; TODO: memoisation of handlers probably doesn't make sense, because every request
;;; will be different. I don't think we can memoise HugSQL, at least not without
;;; hacking the library (might be worth doing that and contributing a patch).
;;; So the solution may be to an intervening namespace 'cache', which has one
;;; memoised function for each hugsql query.
(defn file-header
"Generate an appropriate file header for JSON routes for this `application`."
[application]
(list
'ns
(symbol (str (safe-name (:name (:attrs application))) ".cache"))
(str "Caching wrappers for queries for " (:name (:attrs application))
" auto-generated by [Application Description Language framework](https://github.com/simon-brooke/adl) at "
(f/unparse (f/formatters :basic-date-time) (t/now)))
(list
:require
'[adl-support.core :refer :all]
'[adl-support.rest-support :refer :all]
'[clojure.core.memoize :as memo]
'[clojure.java.io :as io]
'[clojure.tools.logging :as log]
'[compojure.core :refer [defroutes GET POST]]
'[hugsql.core :as hugsql]
'[noir.response :as nresponse]
'[noir.util.route :as route]
'[ring.util.http-response :as response]
(vector (symbol (str (safe-name (:name (:attrs application))) ".db.core")) :as 'db))))
(defn handler
"Generate declarations for handlers for this `query`. Cache handlers are needed only for select queries."
[query]
(let [handler-name (symbol (:name query))
v (volatility (:entity query))]
(if (and
(number? v)
(> v 0)
(#{:select-1 :select-many :text-search}(:type query)))
(list
'def
handler-name
(str
"Auto-generated function to "
(generate-documentation query))
(list
'memo/ttl
(list
'fn
['connection 'params]
(list
(symbol (str "db/" (:name query)))
'connection 'params))
{}
:ttl/threshold
(* v 1000))))))
(defn to-cache
"Generate a `/cache.clj` file for this `application`."
[application]
(let [queries-map (queries application)
filepath (str *output-path* "src/clj/" (:name (:attrs application)) "/cache.clj")]
(make-parents filepath)
(do-or-warn
(with-open [output (writer filepath)]
(binding [*out* output]
(pprint (file-header application))
(println)
(doall
(map
(fn [k]
(let [k (handler (queries-map k))]
(if k
(do
(pprint k)
(println)))
k))
(sort (keys queries-map)))))))
(if (pos? *verbosity*)
(*warn* (str "\tGenerated " filepath)))))

261
src/adl/to_hugsql_queries.clj
View file

@ -48,12 +48,12 @@
property-names (map #(:name (:attrs %)) properties)] property-names (map #(:name (:attrs %)) properties)]
(if-not (empty? property-names) (if-not (empty? property-names)
(str (str
"WHERE " "WHERE "
(s/join (s/join
"\n\tAND " "\n\tAND "
(map (map
#(str entity-name "." (safe-name % :sql) " = :" %) #(str entity-name "." (safe-name % :sql) " = :" %)
property-names))))))) property-names)))))))
(defn order-by-clause (defn order-by-clause
@ -63,26 +63,26 @@
([entity prefix] ([entity prefix]
(order-by-clause entity prefix false)) (order-by-clause entity prefix false))
([entity prefix expanded?] ([entity prefix expanded?]
(let (let
[entity-name (safe-name entity :sql) [entity-name (safe-name entity :sql)
preferred (filter #(#{"user" "all"} (-> % :attrs :distinct)) preferred (filter #(#{"user" "all"} (-> % :attrs :distinct))
(descendants-with-tag entity :property))] (descendants-with-tag entity :property))]
(if (if
(empty? preferred) (empty? preferred)
"" ""
(str (str
"ORDER BY " prefix entity-name "." "ORDER BY " prefix entity-name "."
(s/join (s/join
(str ",\n\t" prefix entity-name ".") (str ",\n\t" prefix entity-name ".")
(map (map
#(if #(if
(and expanded? (= "entity" (-> % :attrs :type))) (and expanded? (= "entity" (-> % :attrs :type)))
(str (safe-name % :sql) expanded-token) (str (safe-name % :sql) expanded-token)
(safe-name % :sql)) (safe-name % :sql))
(order-preserving-set (order-preserving-set
(concat (concat
preferred preferred
(key-properties entity)))))))))) (key-properties entity))))))))))
;; (def a (x/parse "../youyesyet/youyesyet.adl.xml")) ;; (def a (x/parse "../youyesyet/youyesyet.adl.xml"))
;; (def e (child-with-tag a :entity #(= "dwellings" (-> % :attrs :name)))) ;; (def e (child-with-tag a :entity #(= "dwellings" (-> % :attrs :name))))
@ -131,31 +131,31 @@
(defn update-query (defn update-query
"Generate an appropriate `update` query for this `entity`" "Generate an appropriate `update` query for this `entity`"
[entity] [entity]
(let [entity-name (safe-name entity :sql) (let [entity-name (safe-name entity :sql)
pretty-name (singularise entity-name) pretty-name (singularise entity-name)
property-names (map property-names (map
#(-> % :attrs :name) #(-> % :attrs :name)
(insertable-properties entity)) (insertable-properties entity))
query-name (str "update-" pretty-name "!") query-name (str "update-" pretty-name "!")
signature ":! :n"] signature ":! :n"]
(hash-map (hash-map
(keyword query-name) (keyword query-name)
{:name query-name {:name query-name
:signature signature :signature signature
:entity entity :entity entity
:type :update-1 :type :update-1
:query :query
(str "-- :name " query-name " " signature "\n" (str "-- :name " query-name " " signature "\n"
"-- :doc updates an existing " pretty-name " record\n" "-- :doc updates an existing " pretty-name " record\n"
"UPDATE " entity-name "\n" "UPDATE " entity-name "\n"
"SET " "SET "
(s/join (s/join
",\n\t" ",\n\t"
(map (map
#(str (safe-name % :sql) " = " (keyword %)) #(str (safe-name % :sql) " = " (keyword %))
property-names)) property-names))
"\n" "\n"
(where-clause entity))}))) (where-clause entity))})))
(defn search-query [entity application] (defn search-query [entity application]
@ -193,29 +193,29 @@
#(let #(let
[sn (safe-name % :sql)] [sn (safe-name % :sql)]
(str (str
"(if (:" (-> % :attrs :name) " params) (str \"AND " "(if (:" (-> % :attrs :name) " params) (str \"AND "
(case (-> % :attrs :type) (case (-> % :attrs :type)
("string" "text") ("string" "text")
(str (str
sn sn
" LIKE '%\" (:" (-> % :attrs :name) " params) \"%' ") " LIKE '%\" (:" (-> % :attrs :name) " params) \"%' ")
("date" "time" "timestamp") ("date" "time" "timestamp")
(str (str
sn sn
" = ':" (-> % :attrs :name) "'") " = ':" (-> % :attrs :name) "'")
"entity" "entity"
(str (str
sn sn
"_expanded LIKE '%\" (:" (-> % :attrs :name) " params) \"%'") "_expanded LIKE '%\" (:" (-> % :attrs :name) " params) \"%'")
(str (str
sn sn
" = :" " = :"
(-> % :attrs :name))) (-> % :attrs :name)))
"\"))")) "\"))"))
properties)))) properties))))
(order-by-clause entity "lv_" true) (order-by-clause entity "lv_" true)
"--~ (if (:offset params) \"OFFSET :offset \")" "--~ (if (:offset params) \"OFFSET :offset \")"
"--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))}))) "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))})))
;; (search-query e a) ;; (search-query e a)
@ -345,11 +345,11 @@
(str "\tAND " link-table-name "." (singularise entity-safe) "_id = :id") (str "\tAND " link-table-name "." (singularise entity-safe) "_id = :id")
(order-by-clause far-entity "lv_" false))) (order-by-clause far-entity "lv_" false)))
"list" (list "list" (list
(str "-- :name " query-name " " signature) (str "-- :name " query-name " " signature)
(str "-- :doc lists all existing " pretty-far " records related to a given " pretty-name) (str "-- :doc lists all existing " pretty-far " records related to a given " pretty-name)
(str "SELECT lv_" safe-far ".* \nFROM lv_" safe-far) (str "SELECT lv_" safe-far ".* \nFROM lv_" safe-far)
(str "WHERE lv_" safe-far "." (safe-name (first (key-names far-entity)) :sql) " = :id") (str "WHERE lv_" safe-far "." (safe-name (first (key-names far-entity)) :sql) " = :id")
(order-by-clause far-entity "lv_" false)) (order-by-clause far-entity "lv_" false))
(list (str "ERROR: unexpected type " link-type " of property " %))))) (list (str "ERROR: unexpected type " link-type " of property " %)))))
})) }))
links)))) links))))
@ -403,23 +403,94 @@
(let [filepath (str *output-path* "resources/sql/queries.auto.sql")] (let [filepath (str *output-path* "resources/sql/queries.auto.sql")]
(make-parents filepath) (make-parents filepath)
(do-or-warn (do-or-warn
(do (do
(spit (spit
filepath filepath
(s/join (s/join
"\n\n" "\n\n"
(cons (cons
(emit-header (emit-header
"--" "--"
"File queries.sql" "File queries.sql"
(str "autogenerated by adl.to-hugsql-queries at " (t/now)) (str "autogenerated by adl.to-hugsql-queries at " (t/now))
"See [Application Description Language](https://github.com/simon-brooke/adl).") "See [Application Description Language](https://github.com/simon-brooke/adl).")
(map (map
:query :query
(sort (sort
#(compare (:name %1) (:name %2)) #(compare (:name %1) (:name %2))
(vals (vals
(queries application))))))) (queries application)))))))
(if (pos? *verbosity*) (if (pos? *verbosity*)
(*warn* (str "\tGenerated " filepath))))))) (*warn* (str "\tGenerated " filepath)))))))
(defn generate-documentation
"Generate, as a string, appropriate documentation for a function wrapping this `query` map."
[query]
(let [v (volatility (:entity query))]
(s/join
" "
(list
(case
(:type query)
:delete-1
(str "delete one record from the `"
(-> query :entity :attrs :name)
"` table. Expects the following key(s) to be present in `params`: `"
(-> query :entity key-names)
"`.")
:insert-1
(str "insert one record to the `"
(-> query :entity :attrs :name)
"` table. Expects the following key(s) to be present in `params`: `"
(pr-str
(map
#(keyword (:name (:attrs %)))
(-> query :entity insertable-properties )))
"`. Returns a map containing the keys `"
(-> query :entity key-names)
"` identifying the record created.")
:select-1
(str "select one record from the `"
(-> query :entity :attrs :name)
"` table. Expects the following key(s) to be present in `params`: `"
(-> query :entity key-names)
"`. Returns a map containing the following keys: `"
(map #(keyword (:name (:attrs %))) (-> query :entity all-properties))
"`.")
:select-many
(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
(map
#(keyword (:name (:attrs %)))
(-> query :entity all-properties)))
"`.")
:text-search
(str "select all records from the `"
(-> query :entity :attrs :name)
;; TODO: this doc-string is out of date
"` table with any text field matching the value of the key `:pattern` which should be in the request. 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
(map
#(keyword (:name (:attrs %)))
(-> query :entity all-properties)))
"`.")
:update-1
(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
(map
#(keyword (:name (:attrs %)))
(flatten
(cons
(-> query :entity key-properties)
(-> query :entity insertable-properties)))))))
"`."))
(if-not
(zero? v)
(str "Results will be held in cache for " v " seconds."))))))

254
src/adl/to_json_routes.clj
View file

@ -3,7 +3,7 @@
adl.to-json-routes adl.to-json-routes
(:require [adl-support.core :refer :all] (:require [adl-support.core :refer :all]
[adl-support.utils :refer :all] [adl-support.utils :refer :all]
[adl.to-hugsql-queries :refer [queries]] [adl.to-hugsql-queries :refer [generate-documentation queries]]
[clj-time.core :as t] [clj-time.core :as t]
[clj-time.format :as f] [clj-time.format :as f]
[clojure.java.io :refer [file make-parents writer]] [clojure.java.io :refer [file make-parents writer]]
@ -65,6 +65,7 @@
'[noir.response :as nresponse] '[noir.response :as nresponse]
'[noir.util.route :as route] '[noir.util.route :as route]
'[ring.util.http-response :as response] '[ring.util.http-response :as response]
(vector (symbol (str (safe-name (:name (:attrs application))) ".cache")) :as 'cache)
(vector (symbol (str (safe-name (:name (:attrs application))) ".db.core")) :as 'db)))) (vector (symbol (str (safe-name (:name (:attrs application))) ".db.core")) :as 'db))))
@ -79,79 +80,82 @@
"Generate and return the function body for the handler for this `query`." "Generate and return the function body for the handler for this `query`."
[query] [query]
(list (list
['request] ['request]
(list (let
'let [v (volatility (:entity query))
['params (list function (symbol (str
'merge (if
(apply hash-map (and
(interleave (number? v)
(map (> v 0)
#(keyword (column-name %)) (#{:select-1 :select-many :text-search} (:type query)))
(descendants-with-tag "cache"
(:entity query) "db")
:property "/"
#(not (= (-> % :attrs :required) "true")))) (:name query)))]
(repeat nil)))
'(massage-params request))]
(list
'valid-user-or-forbid
(list
'with-params-or-error
(list (list
'do-or-server-fail 'let
(list ['params (list
(symbol (str "db/" (:name query))) 'merge
'db/*db* 'params) (apply hash-map
(case (:type query) (interleave
:insert-1 201 ;; created (map
:delete-1 204 ;; no content #(keyword (column-name %))
;; default (descendants-with-tag
200)) ;; OK (:entity query)
'params :property
(set #(not (= (-> % :attrs :required) "true"))))
(map (repeat nil)))
#(keyword (column-name %)) '(massage-params request))]
(case (:type query) (list
:insert-1 'valid-user-or-forbid
(-> query :entity required-properties) (list
:update-1 (concat 'with-params-or-error
(-> query :entity key-properties) (list
(-> query :entity required-properties)) 'do-or-server-fail
(:select-1 :delete-1) (list
(-> query :entity key-properties) function
;; default 'db/*db* 'params)
nil)))) (case (:type query)
'request)))) :insert-1 201 ;; created
:delete-1 204 ;; no content
;; default
200)) ;; OK
'params
(set
(map
#(keyword (column-name %))
(case (:type query)
:insert-1
(-> query :entity required-properties)
:update-1 (concat
(-> query :entity key-properties)
(-> query :entity required-properties))
(:select-1 :delete-1)
(-> query :entity key-properties)
;; default
nil))))
'request)))))
(defn generate-handler-src (defn generate-handler-src
"Generate and return the handler for this `query`." "Generate and return the handler for this `query`."
[handler-name query-map method doc] [handler-name query-map method]
(hash-map (let [doc (str
:method method "Auto-generated function to "
:src (remove (generate-documentation query-map))
nil? v (volatility (:entity query-map))]
(if (hash-map
(or :method method
(zero? (volatility (:entity query-map))) :src (remove
(#{:delete-1 :insert-1 :update-1} (:type query-map))) nil?
(concat (concat
(list (list
'defn 'defn
handler-name handler-name
(str "Auto-generated method to " doc)) doc
(generate-handler-body query-map)) (generate-handler-body query-map)))))))
(concat
(list
'def
handler-name
(list
'memo/ttl
(cons 'fn (generate-handler-body query-map))
{}
:ttl/threshold
(* (volatility (:entity query-map)) 1000))))))))
(defn handler (defn handler
@ -168,78 +172,14 @@
:route (str "/json/" handler-name)} :route (str "/json/" handler-name)}
(case (case
(:type query) (:type query)
:delete-1 (:delete-1 :insert-1 :update-1)
(generate-handler-src (generate-handler-src
handler-name query :post handler-name query :post)
(str "delete one record from the `" (:select-1 :select-many :text-search)
(-> query :entity :attrs :name)
"` table. Expects the following key(s) to be present in `params`: `"
(-> query :entity key-names)
"`."))
:insert-1
(generate-handler-src (generate-handler-src
handler-name query :post handler-name query :get)
(str "insert one record to the `"
(-> query :entity :attrs :name)
"` table. Expects the following key(s) to be present in `params`: `"
(pr-str
(map
#(keyword (:name (:attrs %)))
(-> query :entity insertable-properties )))
"`. Returns a map containing the keys `"
(-> query :entity key-names)
"` 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
(map
#(keyword (:name (:attrs %)))
(flatten
(cons
(-> query :entity key-properties)
(-> query :entity insertable-properties)))))))
"`."))
:select-1
(generate-handler-src
handler-name query :get
(str "select one record from the `"
(-> query :entity :attrs :name)
"` table. Expects the following key(s) to be present in `params`: `"
(-> query :entity key-names)
"`. Returns a map containing the following keys: `"
(map #(keyword (:name (:attrs %))) (-> query :entity all-properties))
"`."))
:select-many
(generate-handler-src
handler-name query :get
(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
(map
#(keyword (:name (:attrs %)))
(-> query :entity all-properties)))
"`."))
:text-search
(generate-handler-src
handler-name query :get
(str "select all records from the `"
(-> query :entity :attrs :name)
;; TODO: this doc-string is out of date
"` table with any text field matching the value of the key `:pattern` which should be in the request. 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
(map
#(keyword (:name (:attrs %)))
(-> query :entity all-properties)))
"`."))
(:select-many-to-many (:select-many-to-many
:select-one-to-many) :select-one-to-many)
(hash-map :method :get (hash-map :method :get
:src (list 'defn handler-name [{:keys ['params]}] :src (list 'defn handler-name [{:keys ['params]}]
(list 'do (list (symbol (str "db/" (:name query))) 'params)))) (list 'do (list (symbol (str "db/" (:name query))) 'params))))
@ -249,26 +189,6 @@
(str ";; don't know what to do with query `" :key "` of type `" (:type query) "`."))))))) (str ";; don't know what to do with query `" :key "` of type `" (:type query) "`.")))))))
(defn defroutes
"Generate JSON routes for all queries implied by this ADL `application` spec."
[handlers-map]
(cons
'defroutes
(cons
'auto-rest-routes
(map
#(let [handler (handlers-map %)]
(list
(symbol (s/upper-case (name (:method handler))))
(str "/json/auto/" (safe-name (:name handler)))
'request
(list
'route/restricted
(list (:name handler) 'request))))
(sort
(keys handlers-map))))))
(defn make-handlers-map (defn make-handlers-map
"Analyse this `application` and generate from it a map of the handlers to be output." "Analyse this `application` and generate from it a map of the handlers to be output."
[application] [application]
@ -288,6 +208,26 @@
(children-with-tag application :entity)))) (children-with-tag application :entity))))
(defn defroutes
"Generate JSON routes for all queries implied by this ADL `application` spec."
[handlers-map]
(cons
'defroutes
(cons
'auto-rest-routes
(map
#(let [handler (handlers-map %)]
(list
(symbol (s/upper-case (name (:method handler))))
(str "/json/auto/" (safe-name (:name handler)))
'request
(list
'route/restricted
(list (:name handler) 'request))))
(sort
(keys handlers-map))))))
(defn to-json-routes (defn to-json-routes
"Generate a `/routes/auto-json.clj` file for this `application`." "Generate a `/routes/auto-json.clj` file for this `application`."
[application] [application]
@ -306,8 +246,8 @@
(println) (println)
h) h)
(sort (keys handlers-map)))) (sort (keys handlers-map))))
(pprint (defroutes handlers-map)))) (pprint (defroutes handlers-map)))))
(if (pos? *verbosity*) (if (pos? *verbosity*)
(*warn* (str "\tGenerated " filepath)))))) (*warn* (str "\tGenerated " filepath)))))