Now generating apparently-good but untested route handlers

src/squirrel_parse/to_hugsql_queries.clj

@@ -39,10 +39,10 @@
 (defn order-by-clause [entity-map]
   (let
     [entity-name (:name (:attrs entity-map))
-        preferred (map
+     preferred (map
-                  #(:name (:attrs %))
+                 #(:name (:attrs %))
-                  (filter #(= (-> % :attrs :distinct) "user")
+                 (filter #(= (-> % :attrs :distinct) "user")
-                          (-> entity-map :content :properties vals)))]
+                         (-> entity-map :content :properties vals)))]
     (str
       "ORDER BY " entity-name "."
       (s/join
@@ -52,20 +52,28 @@
 
 (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))))
-        ]
+        query-name (str "create-" pretty-name "!")
-    (str "-- :name create-" pretty-name "! :<!\n"
+        signature " :! :n"]
-         "-- :doc creates a new " pretty-name " record\n"
+    (hash-map
-         "INSERT INTO " entity-name " ("
+      (keyword query-name)
-         (s/join ",\n\t" all-property-names)
+      {:name query-name
-         ")\nVALUES ("
+       :signature signature
-         (s/join ",\n\t" (map keyword all-property-names))
+       :entity entity-map
-         ")"
+       :type :insert-1
-         (if
+       :query
-           (has-primary-key? entity-map)
+       (str "-- :name " query-name " " signature "\n"
-           (str "\nreturning " (s/join ",\n\t" (key-names entity-map))))
+            "-- :doc creates a new " pretty-name " record\n"
-         "\n\n")))
+            "INSERT INTO " entity-name " ("
+            (s/join ",\n\t" all-property-names)
+            ")\nVALUES ("
+            (s/join ",\n\t" (map keyword all-property-names))
+            ")"
+            (if
+              (has-primary-key? entity-map)
+              (str "\nreturning " (s/join ",\n\t" (key-names entity-map))))
+            "\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)))))]
+                             (vals (:properties (:content entity-map)))))
-      (str "-- :name update-" pretty-name "! :! :n\n"
+          query-name (str "update-" pretty-name "!")
-           "-- :doc updates an existing " pretty-name " record\n"
+          signature ":! :n"]
-           "UPDATE " entity-name "\n"
+      (hash-map
-           "SET "
+        (keyword query-name)
-           (s/join ",\n\t" (map #(str % " = " (keyword %)) property-names))
+        {:name query-name
-           "\n"
+         :signature signature
-           (where-clause entity-map)
+         :entity entity-map
-           "\n\n"))))
+         :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")}))
+    {}))
 
 
 (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$" "")]
+          pretty-name (singularise entity-name)
-      (str "-- :name get-" pretty-name " :? :1\n"
+          query-name (str "get-" pretty-name)
-           "-- :doc selects an existing " pretty-name " record\n"
+          signature ":? :1"]
-           "SELECT * FROM " entity-name "\n"
+      (hash-map
-           (where-clause entity-map)
+        (keyword query-name)
-           "\n"
+        {:name query-name
-           (order-by-clause entity-map)
+         :signature signature
-           "\n\n"))))
+         :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")}))
+    {}))
 
 
-(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$" "")]
+        pretty-name (singularise entity-name)
-    (str "-- :name list-" pretty-name " :? :*\n"
+        query-name (str "list-" entity-name)
-         "-- :doc lists all existing " pretty-name " records\n"
+        signature ":? :*"]
-         "SELECT * FROM " entity-name "\n"
+    (hash-map
-         (order-by-clause entity-map)
+      (keyword query-name)
-         "\n\n")))
+      {: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"
+            "--~ (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)]
+               link-field (-> % :attrs :name)
-           (str "-- :name list-" entity-name "-by-" pretty-far " :? :*\n"
+               query-name (str "list-" entity-name "-by-" pretty-far)
-                "-- :doc lists all existing " pretty-name " records related to a given " pretty-far "\n"
+               signature ":? :*"]
-                "SELECT * \nFROM " entity-name "\n"
+           (hash-map
-                "WHERE " entity-name "." link-field " = :id\n"
+             (keyword query-name)
-                (order-by-clause entity-map)
+             {:name query-name
-                "\n\n"))
+              :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")}))
         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)]
+        pretty-far (singularise far-name)
-    (println links)
+        query-name (str "list-" link-name "-" near-name "-by-" pretty-far)
-    (str "-- :name list-" link-name "-" near-name "-by-" pretty-far " :? :*\n"
+        signature ":? :*"]
-         "-- :doc lists all existing " near-name " records related through " link-name " to a given " pretty-far "\n"
+    (hash-map
-         "SELECT "near-name ".*\n"
+      (keyword query-name)
-         "FROM " near-name ", " link-name "\n"
+      {:name query-name
-         "WHERE " near-name "." (first (key-names near)) " = " link-name "." (-> (links (keyword near-name)) :attrs :name) "\n\t"
+       :signature signature
-         "AND " link-name "." (-> (links (keyword far-name)) :attrs :name) " = :id\n"
+       :entity link
-         (order-by-clause near)
+       :type :select-many-to-many
-         "\n\n")))
+       :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")})))
 
 
 (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$" "")]
+          pretty-name (singularise entity-name)
-      (str "-- :name delete-" pretty-name "! :! :n\n"
+          query-name (str "delete-" pretty-name "!")
-           "-- :doc updates an existing " pretty-name " record\n"
+          signature ":! :n"]
-           "DELETE FROM " entity-name "\n"
+      (hash-map
-           (where-clause entity-map)
+        (keyword query-name)
-           "\n\n"))))
+        {: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")}))))
 
 
 (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)))

src/squirrel_parse/to_json_routes.clj

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

src/squirrel_parse/utils.clj

@@ -213,5 +213,5 @@
 
 
 (defn singularise [string]
-  (s/replace (s/replace string #"_" "-") #"s$" ""))
+  (s/replace (s/replace (s/replace string #"_" "-") #"s$" "") #"ie$" "y"))