MY MONSTER IT LIVES!

2018-06-11 19:08:08 +01:00 · 2018-06-11 19:08:08 +01:00 · b69bcaa020
parent 7c9f7f91b4
commit b69bcaa020
5 changed files with 115 additions and 74 deletions
--- a/src/adl/main.clj
+++ b/src/adl/main.clj
@ -44,7 +44,7 @@
    (.exists (java.io.File. (first args)))
    (let [application (x/parse (first args))]
      (h/to-hugsql-queries application)
-      ;; (j/to-json-routes application)
+      (j/to-json-routes application)
      (s/to-selmer-routes application)
      (t/to-selmer-templates application))))

--- a/src/adl/to_json_routes.clj
+++ b/src/adl/to_json_routes.clj
@ -1,11 +1,14 @@
 (ns ^{:doc "Application Description Language: generate RING routes for REST requests."
      :author "Simon Brooke"}
  adl.to-json-routes
-  (:require [clojure.java.io :refer [file]]
+  (:require [clojure.java.io :refer [file make-parents writer]]
+            [clojure.pprint :refer [pprint]]
            [clojure.string :as s]
+            [clojure.xml :as x]
            [clj-time.core :as t]
            [clj-time.format :as f]
-            [adl.utils :refer :all]))
+            [adl.utils :refer :all]
+            [adl.to-hugsql-queries :refer [queries]]))

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;;
@ -34,11 +37,12 @@
 ;;; to-hugsql-queries, because essentially we need one JSON entry point to wrap
 ;;; each query.

-(defn file-header [parent-name this-name]
+
+(defn file-header [application]
  (list
    'ns
-    (symbol (str parent-name ".routes." this-name))
-    (str "JSON routes for " parent-name
+    (symbol (str (safe-name (:name (:attrs application))) ".routes.auto-json"))
+    (str "JSON routes 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
@ -49,15 +53,11 @@
      '[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-]" ""))
+      (vector (symbol (str (safe-name (:name (:attrs application))) ".db.core")) :as 'db))))


 (defn declarations [handlers-map]
-  (cons 'declare (sort (map #(symbol (make-safe-name (name %))) (keys handlers-map)))))
+  (cons 'declare (sort (map #(symbol (name %)) (keys handlers-map)))))


 (defn generate-handler-src
@ -81,12 +81,12 @@


 (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
+  "Generate declarations for handlers from query with this `query-key` in this `queries-map`
+  taken from within this `application`. 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]
+  [query-key queries-map application]
  (let [query (query-key queries-map)
-        handler-name (symbol (make-safe-name (name query-key)))]
+        handler-name (symbol (name query-key))]
    (hash-map
      (keyword handler-name)
      (merge
@ -182,6 +182,7 @@


 (defn defroutes [handlers-map]
+  "Generate JSON routes for all queries implied by this ADL `application` spec."
  (cons
    'defroutes
    (cons
@ -190,7 +191,7 @@
        #(let [handler (handlers-map %)]
           (list
             (symbol (s/upper-case (name (:method handler))))
-             (str "/json/auto/" (:name handler))
+             (str "/json/auto/" (safe-name (:name handler)))
             'request
              (list
                'route/restricted
@ -199,39 +200,46 @@
          (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
-;;      )))
+(defn make-handlers-map
+  [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
+  [application]
+  (let [handlers-map (make-handlers-map application)
+        filepath (str *output-path* (:name (:attrs application)) "/routes/auto_json.clj")]
+    (make-parents filepath)
+    (with-open [output (writer filepath)]
+      (binding [*out* output]
+        (doall
+          (map
+            (fn [f]
+              (pprint f)
+              (println "\n"))
+            (list
+              (file-header application)
+              (declarations handlers-map)
+              (defroutes handlers-map))))
+        (doall
+          (map
+            (fn [h]
+              (pprint (:src (handlers-map h)))
+              (println)
+              h)
+            (sort (keys handlers-map))))))))
+
+
--- a/src/adl/to_selmer_routes.clj
+++ b/src/adl/to_selmer_routes.clj
@ -50,6 +50,7 @@
      '[ring.util.http-response :as response]
      '[clojure.java.io :as io]
      '[hugsql.core :as hugsql]
+      (vector (symbol (str (:name (:attrs application)) ".layout")) :as 'l)
      (vector (symbol (str (:name (:attrs application)) ".db.core")) :as 'db)
      (vector (symbol (str (:name (:attrs application)) ".routes.manual")) :as 'm))))

@ -62,7 +63,7 @@
      (vector 'r)
      (list 'let (vector 'p (list :form-params 'r))
            (list
-              'layout/render
+              'l/render
              (list 'resolve-template (str n ".html"))
              (merge
                {:title (capitalise (:name (:attrs f)))
@ -79,7 +80,7 @@
                   (list
                     (symbol
                       (str
-                         "db/search-"
+                         "db/search-strings-"
                         (singularise (:name (:attrs e)))))
                     'p)})))))))

@ -111,13 +112,38 @@
      'defroutes
      (cons
        'auto-selmer-routes
-        (interleave
-          (map
-            (fn [r] (make-route 'GET r))
-            (sort routes))
-        (map
-          (fn [r] (make-route 'POST r))
-          (sort routes)))))))
+        (cons
+          '(GET
+             "/index"
+             request
+             (route/restricted
+               (apply (resolve-handler "index") (list request))))
+          (interleave
+            (map
+              (fn [r] (make-route 'GET r))
+              (sort routes))
+            (map
+              (fn [r] (make-route 'POST r))
+              (sort routes))))))))
+
+
+(defn generate-handler-resolver
+  "Dodgy, dodgy, dodgy. Generate code which will look up functions in the
+  manual and in this namespace. I'm sure someone who really knew what they
+  were doing could write this more elegantly."
+  [application]
+  (list
+    'defn
+    'raw-resolve-handler
+    "Prefer the manually-written version of the handler with name `n`, if it exists, to the automatically generated one"
+    (vector 'n)
+    (list 'try
+          (list 'eval (list 'symbol (list 'str (:name (:attrs application)) ".routes.manual/" 'n)))
+          (list 'catch
+                'Exception '_
+                (list 'eval
+                      (list 'symbol
+                            (list 'str (:name (:attrs application)) ".routes.auto/" 'n)))))))


 (defn to-selmer-routes
@ -134,13 +160,13 @@
                     n
                     (str "auto/" n))))
        (println)
-        (pprint '(def resolve-template (memoise raw-resolve-template)))
+        (pprint '(def resolve-template (memoize raw-resolve-template)))
        (println)
        (pprint '(defn index
                   [r]
-                   (layout/render
+                   (l/render
                     (resolve-template
-                       "application-index")
+                       "application-index.html")
                     {:title "Administrative menu"})))
        (println)
        (doall
@ -153,14 +179,8 @@
                    (println))
                  (filter (fn [c] (#{:form :list :page} (:tag c))) (children e)))))
            (children-with-tag application :entity)))
-        (pprint '(defn raw-resolve-handler
-                   "Prefer the manually-written version of the handler with name `n`, if it exists, to the automatically generated one"
-                   [n]
-                   (let [s (symbol (str "m." n))]
-                     (if
-                       (bound? s)
-                       (eval s)
-                       (eval (symbol n))))))
+        (pprint
+          (generate-handler-resolver application))
        (println)
        (pprint '(def resolve-handler
                   (memoize raw-resolve-handler)))
--- a/src/adl/to_selmer_templates.clj
+++ b/src/adl/to_selmer_templates.clj
@ -90,7 +90,7 @@
     "\n"
     (flatten
       (list
-         "{% extends \"templates/base.html\" %}"
+         "{% extends \"base.html\" %}"
         (str "<!-- File "
              filename
              " generated "
--- a/src/adl/utils.clj
+++ b/src/adl/utils.clj
@ -181,6 +181,19 @@



+(defn safe-name
+  ([string]
+    (s/replace string #"[^a-zA-Z0-9-]" ""))
+  ([string convention]
+   (case convention
+     (:sql :c) (s/replace string #"[^a-zA-Z0-9_]" "_")
+     :c-sharp (s/replace (capitalise string) #"[^a-zA-Z0-9]" "")
+     :java (let
+             [camel (s/replace (capitalise string) #"[^a-zA-Z0-9]" "")]
+             (apply str (cons (Character/toUpperCase (first camel)) (rest camel))))
+     (safe-name string))))
+
+
 (defn link-table?
  "Return true if this `entity` represents a link table."
  [entity]