Separated caching into new namespace.

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)

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)))))
+

src/adl/to_hugsql_queries.clj

@@ -423,3 +423,74 @@
         (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."))))))

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))))
 
 
@@ -80,6 +81,19 @@
   [query]
   (list
     ['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
         'let
         ['params (list
@@ -101,7 +115,7 @@
             (list
               'do-or-server-fail
               (list
-        (symbol (str "db/" (:name query)))
+                function
                 'db/*db* 'params)
               (case (:type query)
                 :insert-1 201 ;; created
@@ -122,36 +136,26 @@
                   (-> query :entity key-properties)
                   ;; default
                   nil))))
-     'request))))
+          'request)))))
 
 
 (defn generate-handler-src
   "Generate and return the handler for this `query`."
-  [handler-name query-map method doc]
+  [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?
-           (if
-             (or
-               (zero? (volatility (:entity query-map)))
-               (#{:delete-1 :insert-1 :update-1} (:type query-map)))
              (concat
                (list
                  'defn
                  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
@@ -168,76 +172,12 @@
          :route (str "/json/" handler-name)}
         (case
           (:type query)
-          :delete-1
+          (:delete-1 :insert-1 :update-1)
           (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
-            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-one-to-many)
           (hash-map :method :get
@@ -249,6 +189,25 @@
             (str ";; don't know what to do with query `" :key "` of type `" (:type query) "`.")))))))
 
 
+(defn make-handlers-map
+  "Analyse this `application` and generate from it a map of the handlers to be output."
+  [application]
+  (reduce
+    merge
+    {}
+    (map
+      (fn [e]
+        (let [qmap (queries application e)]
+          (reduce
+            merge
+            {}
+            (map
+              (fn [k]
+                (handler k qmap application))
+              (keys qmap)))))
+      (children-with-tag application :entity))))
+
+
 (defn defroutes
   "Generate JSON routes for all queries implied by this ADL `application` spec."
   [handlers-map]
@@ -269,25 +228,6 @@
           (keys handlers-map))))))
 
 
-(defn make-handlers-map
-  "Analyse this `application` and generate from it a map of the handlers to be output."
-  [application]
-  (reduce
-    merge
-    {}
-    (map
-      (fn [e]
-        (let [qmap (queries application e)]
-          (reduce
-            merge
-            {}
-            (map
-              (fn [k]
-                (handler k qmap application))
-              (keys qmap)))))
-      (children-with-tag application :entity))))
-
-
 (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))))
+          (pprint (defroutes handlers-map)))))
     (if (pos? *verbosity*)
-        (*warn* (str "\tGenerated " filepath))))))
+      (*warn* (str "\tGenerated " filepath)))))