diff --git a/src/adl/main.clj b/src/adl/main.clj index c82f1e2..8d2e0d9 100644 --- a/src/adl/main.clj +++ b/src/adl/main.clj @@ -1,7 +1,8 @@ (ns ^{:doc "Application Description Language - command line invocation." :author "Simon Brooke"} 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-psql :as p] [adl.to-selmer-routes :as s] @@ -52,8 +53,7 @@ :default "generated"] ["-v" "--verbosity [LEVEL]" nil "Verbosity level - integer value required" :parse-fn #(Integer/parseInt %) - :default 0] - ]) + :default 0]]) (defn usage @@ -105,6 +105,7 @@ #(if (.exists (java.io.File. %)) (let [application (x/parse (canonicalise %))] + (c/to-cache application) (h/to-hugsql-queries application) (j/to-json-routes application) (p/to-psql application) diff --git a/src/adl/to_cache.clj b/src/adl/to_cache.clj new file mode 100644 index 0000000..c77d85f --- /dev/null +++ b/src/adl/to_cache.clj @@ -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))))) + diff --git a/src/adl/to_hugsql_queries.clj b/src/adl/to_hugsql_queries.clj index a6c9c96..9b86ce8 100644 --- a/src/adl/to_hugsql_queries.clj +++ b/src/adl/to_hugsql_queries.clj @@ -48,12 +48,12 @@ property-names (map #(:name (:attrs %)) properties)] (if-not (empty? property-names) (str - "WHERE " - (s/join - "\n\tAND " - (map - #(str entity-name "." (safe-name % :sql) " = :" %) - property-names))))))) + "WHERE " + (s/join + "\n\tAND " + (map + #(str entity-name "." (safe-name % :sql) " = :" %) + property-names))))))) (defn order-by-clause @@ -63,26 +63,26 @@ ([entity prefix] (order-by-clause entity prefix false)) ([entity prefix expanded?] - (let - [entity-name (safe-name entity :sql) - preferred (filter #(#{"user" "all"} (-> % :attrs :distinct)) - (descendants-with-tag entity :property))] - (if - (empty? preferred) - "" - (str - "ORDER BY " prefix entity-name "." - (s/join - (str ",\n\t" prefix entity-name ".") - (map - #(if - (and expanded? (= "entity" (-> % :attrs :type))) - (str (safe-name % :sql) expanded-token) - (safe-name % :sql)) - (order-preserving-set - (concat - preferred - (key-properties entity)))))))))) + (let + [entity-name (safe-name entity :sql) + preferred (filter #(#{"user" "all"} (-> % :attrs :distinct)) + (descendants-with-tag entity :property))] + (if + (empty? preferred) + "" + (str + "ORDER BY " prefix entity-name "." + (s/join + (str ",\n\t" prefix entity-name ".") + (map + #(if + (and expanded? (= "entity" (-> % :attrs :type))) + (str (safe-name % :sql) expanded-token) + (safe-name % :sql)) + (order-preserving-set + (concat + preferred + (key-properties entity)))))))))) ;; (def a (x/parse "../youyesyet/youyesyet.adl.xml")) ;; (def e (child-with-tag a :entity #(= "dwellings" (-> % :attrs :name)))) @@ -131,31 +131,31 @@ (defn update-query "Generate an appropriate `update` query for this `entity`" [entity] - (let [entity-name (safe-name entity :sql) - pretty-name (singularise entity-name) - property-names (map - #(-> % :attrs :name) - (insertable-properties entity)) - query-name (str "update-" pretty-name "!") - signature ":! :n"] - (hash-map - (keyword query-name) - {:name query-name - :signature signature - :entity entity - :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 + (let [entity-name (safe-name entity :sql) + pretty-name (singularise entity-name) + property-names (map + #(-> % :attrs :name) + (insertable-properties entity)) + query-name (str "update-" pretty-name "!") + signature ":! :n"] + (hash-map + (keyword query-name) + {:name query-name + :signature signature + :entity entity + :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 (safe-name % :sql) " = " (keyword %)) property-names)) - "\n" - (where-clause entity))}))) + "\n" + (where-clause entity))}))) (defn search-query [entity application] @@ -193,29 +193,29 @@ #(let [sn (safe-name % :sql)] (str - "(if (:" (-> % :attrs :name) " params) (str \"AND " - (case (-> % :attrs :type) - ("string" "text") - (str - sn - " LIKE '%\" (:" (-> % :attrs :name) " params) \"%' ") - ("date" "time" "timestamp") - (str - sn - " = ':" (-> % :attrs :name) "'") - "entity" - (str - sn - "_expanded LIKE '%\" (:" (-> % :attrs :name) " params) \"%'") - (str - sn - " = :" - (-> % :attrs :name))) - "\"))")) + "(if (:" (-> % :attrs :name) " params) (str \"AND " + (case (-> % :attrs :type) + ("string" "text") + (str + sn + " LIKE '%\" (:" (-> % :attrs :name) " params) \"%' ") + ("date" "time" "timestamp") + (str + sn + " = ':" (-> % :attrs :name) "'") + "entity" + (str + sn + "_expanded LIKE '%\" (:" (-> % :attrs :name) " params) \"%'") + (str + sn + " = :" + (-> % :attrs :name))) + "\"))")) properties)))) - (order-by-clause entity "lv_" true) - "--~ (if (:offset params) \"OFFSET :offset \")" - "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))}))) + (order-by-clause entity "lv_" true) + "--~ (if (:offset params) \"OFFSET :offset \")" + "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))}))) ;; (search-query e a) @@ -345,11 +345,11 @@ (str "\tAND " link-table-name "." (singularise entity-safe) "_id = :id") (order-by-clause far-entity "lv_" false))) "list" (list - (str "-- :name " query-name " " signature) - (str "-- :doc lists all existing " pretty-far " records related to a given " pretty-name) - (str "SELECT lv_" safe-far ".* \nFROM lv_" safe-far) - (str "WHERE lv_" safe-far "." (safe-name (first (key-names far-entity)) :sql) " = :id") - (order-by-clause far-entity "lv_" false)) + (str "-- :name " query-name " " signature) + (str "-- :doc lists all existing " pretty-far " records related to a given " pretty-name) + (str "SELECT lv_" safe-far ".* \nFROM lv_" safe-far) + (str "WHERE lv_" safe-far "." (safe-name (first (key-names far-entity)) :sql) " = :id") + (order-by-clause far-entity "lv_" false)) (list (str "ERROR: unexpected type " link-type " of property " %))))) })) links)))) @@ -403,23 +403,94 @@ (let [filepath (str *output-path* "resources/sql/queries.auto.sql")] (make-parents filepath) (do-or-warn - (do - (spit - filepath - (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))))))) - (if (pos? *verbosity*) - (*warn* (str "\tGenerated " filepath))))))) + (do + (spit + filepath + (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))))))) + (if (pos? *verbosity*) + (*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.")))))) diff --git a/src/adl/to_json_routes.clj b/src/adl/to_json_routes.clj index 9b0b3d1..4713678 100644 --- a/src/adl/to_json_routes.clj +++ b/src/adl/to_json_routes.clj @@ -3,7 +3,7 @@ adl.to-json-routes (:require [adl-support.core :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.format :as f] [clojure.java.io :refer [file make-parents writer]] @@ -65,6 +65,7 @@ '[noir.response :as nresponse] '[noir.util.route :as route] '[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)))) @@ -79,79 +80,82 @@ "Generate and return the function body for the handler for this `query`." [query] (list - ['request] - (list - 'let - ['params (list - 'merge - (apply hash-map - (interleave - (map - #(keyword (column-name %)) - (descendants-with-tag - (:entity query) - :property - #(not (= (-> % :attrs :required) "true")))) - (repeat nil))) - '(massage-params request))] - (list - 'valid-user-or-forbid - (list - 'with-params-or-error + ['request] + (let + [v (volatility (:entity query)) + function (symbol (str + (if + (and + (number? v) + (> v 0) + (#{:select-1 :select-many :text-search} (:type query))) + "cache" + "db") + "/" + (:name query)))] + (list - 'do-or-server-fail - (list - (symbol (str "db/" (:name query))) - 'db/*db* 'params) - (case (:type query) - :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)))) + 'let + ['params (list + 'merge + (apply hash-map + (interleave + (map + #(keyword (column-name %)) + (descendants-with-tag + (:entity query) + :property + #(not (= (-> % :attrs :required) "true")))) + (repeat nil))) + '(massage-params request))] + (list + 'valid-user-or-forbid + (list + 'with-params-or-error + (list + 'do-or-server-fail + (list + function + 'db/*db* 'params) + (case (:type query) + :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 "Generate and return the handler for this `query`." - [handler-name query-map method doc] - (hash-map - :method method - :src (remove - nil? - (if - (or - (zero? (volatility (:entity query-map))) - (#{:delete-1 :insert-1 :update-1} (:type query-map))) + [handler-name query-map method] + (let [doc (str + "Auto-generated function to " + (generate-documentation query-map)) + v (volatility (:entity query-map))] + (hash-map + :method method + :src (remove + nil? (concat (list 'defn handler-name - (str "Auto-generated method to " doc)) - (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)))))))) + doc + (generate-handler-body query-map))))))) (defn handler @@ -168,78 +172,14 @@ :route (str "/json/" handler-name)} (case (:type query) - :delete-1 + (:delete-1 :insert-1 :update-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`: `" - (-> query :entity key-names) - "`.")) - :insert-1 + handler-name query :post) + (:select-1 :select-many :text-search) (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 - (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))) - "`.")) + handler-name query :get) (:select-many-to-many - :select-one-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)))) @@ -249,26 +189,6 @@ (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 "Analyse this `application` and generate from it a map of the handlers to be output." [application] @@ -288,6 +208,26 @@ (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 "Generate a `/routes/auto-json.clj` file for this `application`." [application] @@ -306,8 +246,8 @@ (println) h) (sort (keys handlers-map)))) - (pprint (defroutes handlers-map)))) - (if (pos? *verbosity*) - (*warn* (str "\tGenerated " filepath)))))) + (pprint (defroutes handlers-map))))) + (if (pos? *verbosity*) + (*warn* (str "\tGenerated " filepath)))))