From b69bcaa020c57ee00dd2f2a8b09aa02715cd79d4 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 11 Jun 2018 19:08:08 +0100 Subject: [PATCH] MY MONSTER IT LIVES! --- src/adl/main.clj | 2 +- src/adl/to_json_routes.clj | 112 +++++++++++++++++--------------- src/adl/to_selmer_routes.clj | 60 +++++++++++------ src/adl/to_selmer_templates.clj | 2 +- src/adl/utils.clj | 13 ++++ 5 files changed, 115 insertions(+), 74 deletions(-) diff --git a/src/adl/main.clj b/src/adl/main.clj index d56e945..31c2efe 100644 --- 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)))) diff --git a/src/adl/to_json_routes.clj b/src/adl/to_json_routes.clj index a6daf18..e6e9346 100644 --- 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)))))))) + + diff --git a/src/adl/to_selmer_routes.clj b/src/adl/to_selmer_routes.clj index f30c20e..37e5a71 100644 --- 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))) diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj index 22b6c7d..a1616e1 100644 --- 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 "