From 5ec60e524c7f60d5bdc3a56f987680c60590d41b Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 28 Jul 2018 16:27:46 +0100 Subject: [PATCH 1/2] Refactoring in progress... --- project.clj | 7 +- src/adl/main.clj | 39 +++--- src/adl/to_hugsql_queries.clj | 59 ++++----- src/adl/to_json_routes.clj | 68 +++++----- src/adl/to_psql.clj | 39 +++--- src/adl/to_selmer_routes.clj | 38 ++---- src/adl/to_selmer_templates.clj | 87 +++++++------ test/adl/to_hugsql_queries_test.clj | 187 +++++++++++++++------------- 8 files changed, 263 insertions(+), 261 deletions(-) diff --git a/project.clj b/project.clj index 84cee9c..7624344 100644 --- a/project.clj +++ b/project.clj @@ -5,7 +5,7 @@ :license {:name "GNU Lesser General Public License, version 3.0 or (at your option) any later version" :url "https://www.gnu.org/licenses/lgpl-3.0.en.html"} - :dependencies [[adl-support "0.1.3"] + :dependencies [[adl-support "0.1.4-SNAPSHOT"] [bouncer "1.0.1"] [clojure-saxon "0.9.4"] [environ "1.1.0"] @@ -19,7 +19,10 @@ :main adl.main :plugins [[lein-codox "0.10.3"] - [lein-release "1.0.5"]] + [lein-kibit "0.1.6"] + [lein-release "1.0.5"] + ;; [uncomplexor "0.1.0-SNAPSHOT"] + ] ;; :lein-release {:scm :git ;; :deploy-via :clojars} ;; :deploy-via :clojars fails - with an scp error. diff --git a/src/adl/main.clj b/src/adl/main.clj index c5ceba3..73bb40d 100644 --- a/src/adl/main.clj +++ b/src/adl/main.clj @@ -92,25 +92,24 @@ (defn process "Process these parsed `options`." [options] - (do - (let [p (:path (:options options)) - op (if (.endsWith p "/") p (str p "/"))] - (binding [*output-path* op - *locale* (-> options :options :locale) - *verbosity* (-> options :options :verbosity)] - (make-parents *output-path*) - (doall - (map - #(if - (.exists (java.io.File. %)) - (let [application (x/parse (canonicalise %))] - (h/to-hugsql-queries application) - (j/to-json-routes application) - (p/to-psql application) - (s/to-selmer-routes application) - (t/to-selmer-templates application)) - (*warn* (str "ERROR: File not found: " %))) - (-> options :arguments))))))) + (let [p (:path (:options options)) + op (if (.endsWith p "/") p (str p "/"))] + (binding [*output-path* op + *locale* (-> options :options :locale) + *verbosity* (-> options :options :verbosity)] + (make-parents *output-path*) + (doall + (map + #(if + (.exists (java.io.File. %)) + (let [application (x/parse (canonicalise %))] + (h/to-hugsql-queries application) + (j/to-json-routes application) + (p/to-psql application) + (s/to-selmer-routes application) + (t/to-selmer-templates application)) + (*warn* (str "ERROR: File not found: " %))) + (:arguments options)))))) (defn -main @@ -121,7 +120,7 @@ (cond (empty? args) (usage options) - (not (empty? (:errors options))) + (seq (:errors options)) (do (doall (map diff --git a/src/adl/to_hugsql_queries.clj b/src/adl/to_hugsql_queries.clj index c8fdd85..427bcfd 100644 --- a/src/adl/to_hugsql_queries.clj +++ b/src/adl/to_hugsql_queries.clj @@ -46,13 +46,12 @@ (let [entity-name (:name (:attrs entity)) property-names (map #(:name (:attrs %)) properties)] - (if - (not (empty? property-names)) + (if-not (empty? property-names) (str - "WHERE " - (s/join - "\n\tAND" - (map #(str entity-name "." % " = :" %) property-names))))))) + "WHERE " + (s/join + "\n\tAND" + (map #(str entity-name "." % " = :" %) property-names))))))) (defn order-by-clause @@ -213,8 +212,8 @@ (defn select-query "Generate an appropriate `select` query for this `entity`" ([entity properties] - (if - (not (empty? properties)) + (if-not + (empty? properties) (let [entity-name (safe-name (:name (:attrs entity)) :sql) pretty-name (singularise entity-name) query-name (if (= properties (key-properties entity)) @@ -384,32 +383,24 @@ [application] (let [filepath (str *output-path* "resources/sql/queries.auto.sql")] (make-parents filepath) - (try - (spit + (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 (> *verbosity* 0) - (*warn* (str "\tGenerated " filepath))) - (catch - Exception any - (*warn* - (str - "ERROR: Exception " - (.getName (.getClass any)) - (.getMessage any) - " while printing " - filepath)))))) + "\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))))))) diff --git a/src/adl/to_json_routes.clj b/src/adl/to_json_routes.clj index becad9e..0f872e6 100644 --- a/src/adl/to_json_routes.clj +++ b/src/adl/to_json_routes.clj @@ -53,7 +53,8 @@ (f/unparse (f/formatters :basic-date-time) (t/now))) (list :require - '[adl-support.core :as support] + '[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] @@ -72,28 +73,38 @@ (defn generate-handler-body "Generate and return the function body for the handler for this `query`." [query] - (let [action (list - (symbol (str "db/" (:name query))) - 'db/*db* - (list 'support/massage-params - 'params - 'form-params - (key-names (:entity query))))] + (list + ['request] + (list + 'let + ['params '(massage-params request)] (list - [{:keys ['params 'form-params]}] - (case - (:type query) - (:delete-1 :update-1) + 'valid-user-or-forbid + (list + 'with-params-or-error + (list + 'do-or-server-fail (list - action - `(log/debug (str ~(:name query) " called with params " ~'params ".")) - '(response/found "/")) - (list - 'let - (vector 'result action) - `(log/debug (~(symbol (str "db/" (:name query) "-sqlvec")) ~'params)) - `(log/debug (str ~(str "'" (:name query) "' with params ") ~'params " returned " (count ~'result) " records.")) - (list 'response/ok 'result)))))) + (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 (:name (:attrs %))) + (case (:type query) + (:insert-1 :update-1) + (-> query :entity insertable-properties) + (:select-1 :delete-1) + (-> query :entity key-properties) + ;; default + nil)))) + 'request)))) (defn generate-handler-src @@ -262,7 +273,7 @@ (let [handlers-map (make-handlers-map application) filepath (str *output-path* "src/clj/" (:name (:attrs application)) "/routes/auto_json.clj")] (make-parents filepath) - (try + (do-or-warn (with-open [output (writer filepath)] (binding [*out* output] (pprint (file-header application)) @@ -275,16 +286,7 @@ h) (sort (keys handlers-map)))) (pprint (defroutes handlers-map)))) - (if (> *verbosity* 0) - (*warn* (str "\tGenerated " filepath))) - (catch - Exception any - (*warn* - (str - "ERROR: Exception " - (.getName (.getClass any)) - (.getMessage any) - " while printing " - filepath)))))) + (if (pos? *verbosity*) + (*warn* (str "\tGenerated " filepath)))))) diff --git a/src/adl/to_psql.clj b/src/adl/to_psql.clj index c4a5c08..395b517 100644 --- a/src/adl/to_psql.clj +++ b/src/adl/to_psql.clj @@ -111,7 +111,12 @@ (defn emit-field-type [property entity application key?] (case (:type (:attrs property)) - "integer" (if key? "SERIAL" "INTEGER") + "integer" (if + (and + key? + (system-generated? property)) + "SERIAL" + "INTEGER") "real" "DOUBLE PRECISION" ("string" "image" "uploadable") (str "VARCHAR(" (:size (:attrs property)) ")") @@ -150,8 +155,8 @@ #(if (selector (:permission (:attrs %))) (safe-name (:group (:attrs %)) :sql)) permissions)))] - (if - (not (empty? group-names)) + (if-not + (empty? group-names) (s/join " " (list @@ -318,12 +323,12 @@ (str (safe-name entity) "." (field-name %))) (str (safe-name entity) "." (field-name %))) (filter - #(not (= (:type (:attrs %)) "link")) + #(not= (:type (:attrs %)) "link") (all-properties entity) ))))) (str "FROM " (s/join ", " (set (compose-convenience-view-select-list entity application true)))) - (if - (not (empty? entity-fields)) + (if-not + (empty? entity-fields) (str "WHERE " (s/join @@ -408,7 +413,7 @@ (list doc-comment (map - #(:content %) + :content (children-with-tag entity :documentation)))) (s/join " " @@ -427,7 +432,7 @@ (map #(emit-property % entity application false) (filter - #(not (= (:type (:attrs %)) "link")) + #(not= (:type (:attrs %)) "link") (children-with-tag entity :property))))))) "\n);") (map @@ -532,7 +537,7 @@ (str "(https://github.com/simon-brooke/adl) at " (f/unparse (f/formatters :basic-date-time) (t/now))) (map - #(:content %) + :content (children-with-tag application :documentation)))) @@ -568,18 +573,10 @@ (:name (:attrs application)) ".postgres.sql")] (make-parents filepath) - (try + (do-or-warn (spit filepath (emit-application application)) - (if (> *verbosity* 0) - (*warn* (str "\tGenerated " filepath))) - (catch - Exception any - (*warn* - (str - "ERROR: Exception " - (.getName (.getClass any)) - (.getMessage any) - " while printing " - filepath)))))) + (if + (pos? *verbosity*) + (*warn* (str "\tGenerated " filepath)))))) diff --git a/src/adl/to_selmer_routes.clj b/src/adl/to_selmer_routes.clj index a53440d..bd2e808 100644 --- a/src/adl/to_selmer_routes.clj +++ b/src/adl/to_selmer_routes.clj @@ -50,6 +50,7 @@ (f/unparse (f/formatters :basic-date-time) (t/now))) (list :require + '[adl-support.forms-support :refer :all] '[adl-support.core :as support] '[clojure.java.io :as io] '[clojure.set :refer [subset?]] @@ -67,21 +68,15 @@ (defn make-form-handler-content [f e a n] - (let [warning (list 'str (str "Error while fetching " (singularise (:name (:attrs e))) " record ") 'params)] + (let [entity-name (singularise (:name (:attrs e)))] ;; TODO: as yet makes no attempt to save the record (list 'let (vector 'record (list - 'support/do-or-log-error - ;;(list 'if (list 'subset? (key-names e) (list 'set (list 'keys 'params))) - (list - (symbol - (str "db/get-" (singularise (:name (:attrs e))))) - (symbol "db/*db*") - 'params) - ;;) - :message warning - :error-return {:warnings [warning]})) + 'get-current-value + (symbol (str "db/get-" entity-name)) + 'params + entity-name)) (reduce merge {:error (list :warnings 'record) @@ -199,10 +194,7 @@ (vector 'request) (list 'let (vector 'params - (list 'support/massage-params - (list 'keywordize-keys (list :params 'request)) - (list 'keywordize-keys (list :form-params 'request)) - (key-names e true))) + (list 'support/massage-params 'request)) (list 'l/render (list 'support/resolve-template (str n ".html")) @@ -303,7 +295,7 @@ [application] (let [filepath (str *output-path* "src/clj/" (:name (:attrs application)) "/routes/auto.clj")] (make-parents filepath) - (try + (do-or-warn (with-open [output (writer filepath)] (binding [*out* output] (pprint (file-header application)) @@ -330,15 +322,7 @@ (println) (pprint (make-defroutes application)) (println))) - (if (> *verbosity* 0) - (*warn* (str "\tGenerated " filepath))) - (catch - Exception any - (*warn* - (str - "ERROR: Exception " - (.getName (.getClass any)) - (.getMessage any) - " while printing " - filepath)))))) + (if + (pos? *verbosity*) + (*warn* (str "\tGenerated " filepath)))))) diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj index c4475f3..8e17824 100644 --- a/src/adl/to_selmer_templates.clj +++ b/src/adl/to_selmer_templates.clj @@ -62,7 +62,7 @@ (defn emit-content ([content] - (try + (do-or-warn (cond (nil? content) nil @@ -82,7 +82,7 @@ "';\n" (-> any .getClass .getName) ": " - (-> any .getMessage) + (.getMessage any) " -->")))) ([filename application k] (emit-content filename nil nil application k)) @@ -356,9 +356,46 @@ "{% endif %}")))}) +(defn compose-input-widget-para + "Generate an input widget for this `field-or-property` of this `form` for + this `entity` taken from within this `application`, in context of a para + also containing its label." + [property form entity application widget-name] + (let + [typedef (typedef property application) + w-type (widget-type property application typedef)] + (compose-widget-para + property form entity application widget-name + {:tag :input + :attrs (merge + {:id widget-name + :name widget-name + :type w-type + :value (str "{{record." widget-name "}}") + :maxlength (:size (:attrs property)) + :size (cond + (nil? (:size (:attrs property))) + "16" + (try + (> (read-string + (:size (:attrs property))) 60) + (catch Exception _ false)) + "60" + true + (:size (:attrs property)))} + ;; TODO: should match pattern from typedef + (if + (:minimum (:attrs typedef)) + {:min (:minimum (:attrs typedef))}) + (if + (:maximum (:attrs typedef)) + {:max (:maximum (:attrs typedef))}))}))) + + (defn widget "Generate a widget for this `field-or-property` of this `form` for this `entity` - taken from within this `application`." + taken from within this `application`, in context of a para also containing its + label." [field-or-property form entity application] (let [widget-name (safe-name @@ -370,13 +407,7 @@ :property field-or-property :field (property-for-field field-or-property entity) ;; default - nil) - permissions (find-permissions field-or-property property form entity application) - typedef (typedef property application) - w-type (widget-type property application typedef) - visible-to (visible-to permissions) - ;; if the form isn't actually a form, no widget is writeable. - writeable-by (if (= (:tag form) :form) (writeable-by permissions))] + nil)] (if property (case w-type @@ -396,31 +427,7 @@ :attrs {:rows "8" :cols "60" :id widget-name :name widget-name} :content [(str "{{record." widget-name "}}")]}) ;; all others - (compose-widget-para - property form entity application widget-name - {:tag :input - :attrs (merge - {:id widget-name - :name widget-name - :type w-type - :value (str "{{record." widget-name "}}") - :maxlength (:size (:attrs property)) - :size (cond - (nil? (:size (:attrs property))) - "16" - (try - (> (read-string - (:size (:attrs property))) 60) - (catch Exception _ false)) - "60" - true - (:size (:attrs property)))} - (if - (:minimum (:attrs typedef)) - {:min (:minimum (:attrs typedef))}) - (if - (:maximum (:attrs typedef)) - {:max (:maximum (:attrs typedef))}))}))))) + (compose-input-widget-para property form entity application widget-name))))) (defn embed-script-fragment @@ -898,7 +905,7 @@ (let [filepath (str *output-path* "resources/templates/auto/" filename)] (if template - (try + (do-or-warn (do (make-parents filepath) (spit @@ -917,7 +924,9 @@ "{% endblock %}")) (keys template))) (file-footer filename application))))) - (if (> *verbosity* 0) (*warn* "\tGenerated " filepath))) + (if + (pos? *verbosity*) + (*warn* "\tGenerated " filepath))) (catch Exception any (let [report (str "ERROR: Exception " @@ -925,7 +934,7 @@ (.getMessage any) " while printing " filepath)] - (try + (do-or-warn (spit filepath (with-out-str @@ -962,7 +971,7 @@ #(if (templates-map %) (let [filename (str (name %) ".html")] - (try + (do-or-warn (write-template-file filename (templates-map %) application) (catch Exception any (*warn* diff --git a/test/adl/to_hugsql_queries_test.clj b/test/adl/to_hugsql_queries_test.clj index ab4c257..6b4cff4 100644 --- a/test/adl/to_hugsql_queries_test.clj +++ b/test/adl/to_hugsql_queries_test.clj @@ -19,54 +19,67 @@ (= a b))) (deftest entity-tests - (let [xml {:tag :entity, - :attrs {:name "address"}, + (let [application {:tag :application, + :attrs {:version "0.1.1", :name "test-app"}, :content - [{:tag :key, - :attrs nil, + [{:tag :entity, + :attrs {:name "address"}, :content - [{:tag :property, - :attrs - {:immutable "true", - :required "true", - :distinct "system", - :type "integer", - :name "id"}, + [{:tag :key, + :attrs nil, :content - [{:tag :generator, :attrs {:action "native"}, :content nil}]}]} - {:tag :property, - :attrs - {:distinct "user", :size "128", :type "string", :name "street"}, - :content nil} - {:tag :property, - :attrs {:size "64", :type "string", :name "town"}, - :content nil} - {:tag :property, - :attrs - {:distinct "user", :size "12", :type "string", :name "postcode"}, - :content nil}]}] + [{:tag :property, + :attrs + {:immutable "true", + :required "true", + :distinct "system", + :type "integer", + :name "id"}, + :content + [{:tag :generator, :attrs {:action "native"}, :content nil}]} + {:tag :property, + :attrs + {:immutable "true", + :required "true", + :distinct "all", + :generator "assigned" + :type "string", + :size "12" + :name "postcode"}, + :content + [{:tag :generator, :attrs {:action "native"}, :content nil}]} + ]} + {:tag :property, + :attrs + {:distinct "user", :size "128", :type "string", :name "street"}, + :content nil} + {:tag :property, + :attrs {:size "64", :type "string", :name "town"}, + :content nil} + ]}]} + entity (child-with-tag application :entity)] (testing "user distinct properties should provide the default ordering" (let [expected "ORDER BY address.street, address.postcode, address.id" - actual (order-by-clause xml)] + actual (order-by-clause entity)] (is (string-equal-ignore-whitespace? actual expected)))) (testing "keys name extraction" - (let [expected '("id") - actual (key-names xml)] + (let [expected #{"id"} + actual (key-names entity)] (is (string-equal-ignore-whitespace? actual expected)))) (testing "primary key test" (let [expected true - actual (has-primary-key? xml)] + actual (has-primary-key? entity)] (is (string-equal-ignore-whitespace? actual expected)))) (testing "non-key properties test" (let [expected true - actual (has-non-key-properties? xml)] + actual (has-non-key-properties? entity)] (is (string-equal-ignore-whitespace? actual expected)))) (testing "insert query generation" - (let [expected "-- :name create-addres! :! :n - -- :doc creates a new addres record + (let [expected "-- :name create-address! :! :n + -- :doc creates a new address record INSERT INTO address (street, town, postcode) @@ -74,25 +87,25 @@ ':town', ':postcode') returning id\n\n" - actual (:query (first (vals (insert-query xml))))] + actual (:query (first (vals (insert-query entity))))] (is (string-equal-ignore-whitespace? actual expected)))) (testing "insert query signature" (let [expected ":! :n" - actual (:signature (first (vals (insert-query xml))))] + actual (:signature (first (vals (insert-query entity))))] (is (string-equal-ignore-whitespace? actual expected)))) (testing "update query generation" - (let [expected "-- :name update-addres! :! :n - -- :doc updates an existing addres record + (let [expected "-- :name update-address! :! :n + -- :doc updates an existing address record UPDATE address SET street = :street, town = :town, postcode = :postcode WHERE address.id = :id\n\n" - actual (:query (first (vals (update-query xml))))] + actual (:query (first (vals (update-query entity))))] (is (string-equal-ignore-whitespace? actual expected)))) (testing "update query signature" (let [expected ":! :n" - actual (:signature (first (vals (update-query xml))))] + actual (:signature (first (vals (update-query entity))))] (is (string-equal-ignore-whitespace? actual expected)))) (testing "search query generation" (let [expected "-- :name search-strings-addres :? :1 @@ -106,22 +119,22 @@ address.id --~ (if (:offset params) \"OFFSET :offset \") --~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")\n\n" - actual (:query (first (vals (search-query xml))))] + actual (:query (first (vals (search-query entity application))))] (is (string-equal-ignore-whitespace? actual expected)))) (testing "search query signature" (let [expected ":? :1" - actual (:signature (first (vals (search-query xml))))] + actual (:signature (first (vals (search-query entity))))] (is (string-equal-ignore-whitespace? actual expected)))) (testing "select query generation" (let [expected "-- :name get-addres :? :1 -- :doc selects an existing addres record SELECT * FROM address WHERE address.id = :id\n\n" - actual (:query (first (vals (select-query xml))))] + actual (:query (first (vals (select-query entity))))] (is (string-equal-ignore-whitespace? actual expected)))) (testing "select query signature" (let [expected ":? :1" - actual (:signature (first (vals (select-query xml))))] + actual (:signature (first (vals (select-query entity))))] (is (string-equal-ignore-whitespace? actual expected)))) (testing "list query generation" (let [expected "-- :name list-address :? :* @@ -132,75 +145,79 @@ address.id --~ (if (:offset params) \"OFFSET :offset \") --~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")\n\n" - actual (:query (first (vals (list-query xml))))] + actual (:query (first (vals (list-query entity))))] (is (string-equal-ignore-whitespace? actual expected)))) (testing "list query signature" (let [expected ":? :*" - actual (:signature (first (vals (list-query xml))))] + actual (:signature (first (vals (list-query entity))))] (is (string-equal-ignore-whitespace? actual expected)))) (testing "delete query generation" (let [expected "-- :name delete-addres! :! :n -- :doc updates an existing addres record DELETE FROM address WHERE address.id = :id\n\n" - actual (:query (first (vals (delete-query xml))))] + actual (:query (first (vals (delete-query entity))))] (is (string-equal-ignore-whitespace? actual expected)))) (testing "delete query signature" (let [expected ":! :n" - actual (:signature (first (vals (delete-query xml))))] + actual (:signature (first (vals (delete-query entity))))] (is (string-equal-ignore-whitespace? actual expected)))) )) (deftest complex-key-tests - (let [xml {:tag :entity, - :attrs {:name "address"}, + (let [application {:tag :application, + :attrs {:version "0.1.1", :name "test-app"}, :content - [{:tag :key, - :attrs nil, + [{:tag :entity, + :attrs {:name "address"}, :content - [{:tag :property, - :attrs - {:immutable "true", - :required "true", - :distinct "system", - :type "integer", - :name "id"}, + [{:tag :key, + :attrs nil, :content - [{:tag :generator, :attrs {:action "native"}, :content nil}]} + [{:tag :property, + :attrs + {:immutable "true", + :required "true", + :distinct "system", + :type "integer", + :name "id"}, + :content + [{:tag :generator, :attrs {:action "native"}, :content nil}]} + {:tag :property, + :attrs + {:immutable "true", + :required "true", + :distinct "all", + :generator "assigned" + :type "string", + :size "12" + :name "postcode"}, + :content + [{:tag :generator, :attrs {:action "native"}, :content nil}]} + ]} {:tag :property, :attrs - {:immutable "true", - :required "true", - :distinct "all", - :generator "assigned" - :type "string", - :size "12" - :name "postcode"}, - :content - [{:tag :generator, :attrs {:action "native"}, :content nil}]} - ]} - {:tag :property, - :attrs - {:distinct "user", :size "128", :type "string", :name "street"}, - :content nil} - {:tag :property, - :attrs {:size "64", :type "string", :name "town"}, - :content nil} - ]}] + {:distinct "user", :size "128", :type "string", :name "street"}, + :content nil} + {:tag :property, + :attrs {:size "64", :type "string", :name "town"}, + :content nil} + ]}]} + entity (child-with-tag application :entity)] (testing "user distinct properties should provide the default ordering" (let [expected "ORDER BY address.street, address.postcode, address.id" - actual (order-by-clause xml)] + actual (order-by-clause entity)] (is (string-equal-ignore-whitespace? actual expected)))) (testing "keys name extraction" - (let [expected '("id" "postcode") - actual (key-names xml)] + (let [expected #{"id" "postcode"} + actual (key-names entity)] (is (string-equal-ignore-whitespace? actual expected)))) (testing "insert query generation - compound key, non system generated field in key" - (let [expected "-- :name create-addres! :! :n - -- :doc creates a new addres record + (let [expected "-- :name create-address! :! :n + -- :doc creates a new address record INSERT INTO address (street, town, postcode) @@ -209,17 +226,17 @@ ':postcode') returning id, postcode\n\n" - actual (:query (first (vals (insert-query xml))))] + actual (:query (first (vals (insert-query entity))))] (is (string-equal-ignore-whitespace? actual expected)))) (testing "update query generation - compound key" - (let [expected "-- :name update-addres! :! :n - -- :doc updates an existing addres record + (let [expected "-- :name update-address! :! :n + -- :doc updates an existing address record UPDATE address SET street = :street, town = :town WHERE address.id = :id AND address.postcode = ':postcode'\n\n" - actual (:query (first (vals (update-query xml))))] + actual (:query (first (vals (update-query entity))))] (is (string-equal-ignore-whitespace? actual expected)))) (testing "search query generation - user-distinct field in key" (let [expected "-- :name search-strings-addres :? :1 @@ -233,7 +250,7 @@ address.id --~ (if (:offset params) \"OFFSET :offset \") --~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")\n\n" - actual (:query (first (vals (search-query xml))))] + actual (:query (first (vals (search-query entity application))))] (is (string-equal-ignore-whitespace? actual expected)))) (testing "delete query generation - compound key" (let [expected "-- :name delete-addres! :! :n @@ -241,6 +258,6 @@ DELETE FROM address WHERE address.id = :id AND address.postcode = ':postcode'\n\n" - actual (:query (first (vals (delete-query xml))))] + actual (:query (first (vals (delete-query entity))))] (is (string-equal-ignore-whitespace? actual expected)))))) From 7dc3f2dbb825655c0b0e48d6993906f2d48aca62 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 29 Jul 2018 00:37:18 +0100 Subject: [PATCH 2/2] Probably more to do before 1.4.4 release, but stonking progress. --- src/adl/to_hugsql_queries.clj | 2 +- src/adl/to_json_routes.clj | 2 +- src/adl/to_psql.clj | 2 +- src/adl/to_selmer_routes.clj | 394 +++++++++++++++----------- src/adl/to_selmer_templates.clj | 474 +++++++++++++++++++------------- 5 files changed, 517 insertions(+), 357 deletions(-) diff --git a/src/adl/to_hugsql_queries.clj b/src/adl/to_hugsql_queries.clj index 427bcfd..4b07240 100644 --- a/src/adl/to_hugsql_queries.clj +++ b/src/adl/to_hugsql_queries.clj @@ -1,7 +1,7 @@ (ns ^{:doc "Application Description Language - generate HUGSQL queries file." :author "Simon Brooke"} adl.to-hugsql-queries - (:require [adl-support.core :refer [*warn*]] + (:require [adl-support.core :refer :all] [adl-support.utils :refer :all] [clojure.java.io :refer [file make-parents]] [clojure.math.combinatorics :refer [combinations]] diff --git a/src/adl/to_json_routes.clj b/src/adl/to_json_routes.clj index 0f872e6..1918abc 100644 --- a/src/adl/to_json_routes.clj +++ b/src/adl/to_json_routes.clj @@ -1,7 +1,7 @@ (ns ^{:doc "Application Description Language: generate RING routes for REST requests." :author "Simon Brooke"} adl.to-json-routes - (:require [adl-support.core :refer [*warn*]] + (:require [adl-support.core :refer :all] [adl-support.utils :refer :all] [adl.to-hugsql-queries :refer [queries]] [clj-time.core :as t] diff --git a/src/adl/to_psql.clj b/src/adl/to_psql.clj index 395b517..898a9ea 100644 --- a/src/adl/to_psql.clj +++ b/src/adl/to_psql.clj @@ -1,7 +1,7 @@ (ns ^{:doc "Application Description Language: generate Postgres database definition." :author "Simon Brooke"} adl.to-psql - (:require [adl-support.core :refer [*warn*]] + (:require [adl-support.core :refer :all] [adl-support.utils :refer :all] [adl.to-hugsql-queries :refer [queries]] [clojure.java.io :refer [file make-parents writer]] diff --git a/src/adl/to_selmer_routes.clj b/src/adl/to_selmer_routes.clj index bd2e808..8bab130 100644 --- a/src/adl/to_selmer_routes.clj +++ b/src/adl/to_selmer_routes.clj @@ -1,8 +1,9 @@ (ns ^{:doc "Application Description Language: generate routes for user interface requests." :author "Simon Brooke"} adl.to-selmer-routes - (:require [adl-support.core :refer [*warn*]] + (:require [adl-support.core :refer :all] [adl-support.utils :refer :all] + [adl-support.forms-support :refer :all] [clj-time.core :as t] [clj-time.format :as f] [clojure.java.io :refer [file make-parents writer]] @@ -34,11 +35,8 @@ ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Generally. there's one route in the generated file for each Selmer -;;; template which has been generated. - -;;; TODO: there must be some more idiomatic way of generating all these -;;; functions. +;;; Generally. there are two routes - one for GET, one for POST - in the +;;; generated file for each Selmer template which has been generated. (defn file-header [application] @@ -50,8 +48,9 @@ (f/unparse (f/formatters :basic-date-time) (t/now))) (list :require - '[adl-support.forms-support :refer :all] '[adl-support.core :as support] + '[adl-support.forms-support :refer :all] + '[adl-support.rest-support :refer :all] '[clojure.java.io :as io] '[clojure.set :refer [subset?]] '[clojure.tools.logging :as log] @@ -66,56 +65,43 @@ (vector (symbol (str (:name (:attrs application)) ".routes.manual")) :as 'm)))) -(defn make-form-handler-content +(defn make-form-get-handler-content [f e a n] (let [entity-name (singularise (:name (:attrs e)))] ;; TODO: as yet makes no attempt to save the record (list 'let (vector - 'record (list - 'get-current-value - (symbol (str "db/get-" entity-name)) - 'params - entity-name)) + 'record (list + 'get-current-value + (symbol (str "db/get-" entity-name)) + 'params + entity-name)) (reduce - merge - {:error (list :warnings 'record) - :record (list 'dissoc 'record :warnings)} - (map - (fn [property] - (hash-map - (keyword (-> property :attrs :name)) - (list - 'flatten - (list - 'remove - 'nil? - (list - 'list - ;; Get the current value of the property, if it's an entity - (if (= (-> property :attrs :type) "entity") - (list 'support/do-or-log-error - (list - (symbol - (str "db/get-" (singularise (:entity (:attrs property))))) - (symbol "db/*db*") - (hash-map (keyword (-> property :attrs :farkey)) - (list (keyword (-> property :attrs :name)) 'record))) - :message (str "Error while fetching " - (singularise (:entity (:attrs property))) - " record " (hash-map (keyword (-> property :attrs :farkey)) - (list (keyword (-> property :attrs :name)) 'record))))) - ;;; and the potential values of the property - (list 'support/do-or-log-error - (list (symbol (str "db/list-" (:entity (:attrs property)))) (symbol "db/*db*")) - :message (str "Error while fetching " - (singularise (:entity (:attrs property))) - " list"))))))) - (filter #(:entity (:attrs %)) - (descendants-with-tag e :property))))))) + merge + {:error (list :warnings 'record) + :record (list 'dissoc 'record :warnings)} + (map + (fn [property] + (hash-map + (keyword (-> property :attrs :name)) + (list + 'flatten + (list + 'remove + 'nil? + (list + 'list + ;; Get the current value of the property, if it's an entity + (if (= (-> property :attrs :type) "entity") + (list 'get-menu-options + (-> e :attrs :name) + (-> property :attrs :farkey) + (list (keyword (-> property :attrs :name)) 'params)))))))) + (filter #(:entity (:attrs %)) + (descendants-with-tag e :property))))))) -(defn make-page-handler-content +(defn make-page-get-handler-content [f e a n] (let [warning (str "Error while fetching " (singularise (:name (:attrs e))) " record")] (list 'let @@ -129,110 +115,193 @@ 'params)) :message warning :error-return {:warnings [warning]})) - {:warnings (list :warnings 'record) - :record (list 'assoc 'record :warnings nil)}))) + {:warnings (list :warnings 'record) + :record (list 'assoc 'record :warnings nil)}))) -(defn make-list-handler-content +(defn make-list-get-handler-content [f e a n] (list - 'let - (vector - 'records - (list - 'if - (list - 'some - (set (map #(keyword (-> % :attrs :name)) (all-properties e))) - (list 'keys 'params)) - (list 'do - (list (symbol "log/debug") (list (symbol (str "db/search-strings-" (:name (:attrs e)) "-sqlvec")) 'params)) - (list - 'support/do-or-log-error - (list - (symbol (str "db/search-strings-" (:name (:attrs e)))) - (symbol "db/*db*") - 'params) - :message (str - "Error while searching " - (singularise (:name (:attrs e))) - " records") - :error-return {:warnings [(str - "Error while searching " - (singularise (:name (:attrs e))) - " records")]})) - (list 'do - (list (symbol "log/debug") (list (symbol (str "db/list-" (:name (:attrs e)) "-sqlvec")) 'params)) - (list - 'support/do-or-log-error - (list - (symbol - (str - "db/list-" - (:name (:attrs e)))) - (symbol "db/*db*") {}) - :message (str - "Error while fetching " - (singularise (:name (:attrs e))) - " records") - :error-return {:warnings [(str - "Error while fetching " - (singularise (:name (:attrs e))) - " records")]})))) - (list 'if - (list :warnings 'records) - 'records - {:records 'records}))) - - -(defn make-handler - [f e a] - (let [n (path-part f e a)] + 'let + (vector + 'records (list - 'defn - (symbol n) - (vector 'request) - (list 'let (vector - 'params - (list 'support/massage-params 'request)) + 'if + (list + 'some + (set (map #(keyword (-> % :attrs :name)) (all-properties e))) + (list 'keys 'params)) + (list 'do + (list (symbol "log/debug") (list (symbol (str "db/search-strings-" (:name (:attrs e)) "-sqlvec")) 'params)) + (list + 'support/do-or-log-error (list - 'l/render - (list 'support/resolve-template (str n ".html")) - (list 'merge - {:title (capitalise (:name (:attrs f))) - :params 'params} - (case (:tag f) - :form (make-form-handler-content f e a n) - :page (make-page-handler-content f e a n) - :list (make-list-handler-content f e a n)))))))) + (symbol (str "db/search-strings-" (:name (:attrs e)))) + (symbol "db/*db*") + 'params) + :message (str + "Error while searching " + (singularise (:name (:attrs e))) + " records") + :error-return {:warnings [(str + "Error while searching " + (singularise (:name (:attrs e))) + " records")]})) + (list 'do + (list (symbol "log/debug") (list (symbol (str "db/list-" (:name (:attrs e)) "-sqlvec")) 'params)) + (list + 'support/do-or-log-error + (list + (symbol + (str + "db/list-" + (:name (:attrs e)))) + (symbol "db/*db*") {}) + :message (str + "Error while fetching " + (singularise (:name (:attrs e))) + " records") + :error-return {:warnings [(str + "Error while fetching " + (singularise (:name (:attrs e))) + " records")]})))) + (list 'if + (list :warnings 'records) + 'records + {:records 'records}))) + + +(defn handler-name + "Generate the name of the appropriate handler function for form `f` of + entity `e` of application `a` for method `m`, where `f`, `e`, and `a` + are expected to be elements and `m` is expected to be one of the keywords + `:put` `:get`." + [f e a m] + (str (s/lower-case (name m)) "-" (path-part f e a))) + + +(defn make-get-handler + [f e a] + (let [n (handler-name f e a :get)] + (list + 'defn + (symbol n) + (vector 'request) + (list 'let (vector + 'params + (list 'support/massage-params 'request)) + (list + 'l/render + (list 'support/resolve-template (str (path-part f e a) ".html")) + (list 'merge + {:title (capitalise (:name (:attrs f))) + :params 'params} + (case (:tag f) + :form (make-form-get-handler-content f e a n) + :page (make-page-get-handler-content f e a n) + :list (make-list-get-handler-content f e a n)))))))) + + +(defn make-form-post-handler-content + ;; Literally the only thing the post handler has to do is to + ;; generate the database store operation. Then it can hand off + ;; to the get handler. + [f e a n] + (let + [create-name (query-name e :create) + update-name (query-name e :update)] + (list + 'let + (vector + 'result + (list + 'valid-user-or-forbid + (list + 'with-params-or-error + (list + 'do-or-server-fail + (list + 'if + (list 'all-keys-present? 'params (key-names e true)) + (list + update-name + 'db/*db* + 'params) + (list + create-name + 'db/*db* + 'params)) + 200) ;; OK + 'params + (set + (map + #(keyword (:name (:attrs %))) + (insertable-properties e)))) + 'request)) + (list + 'if + (list + (set [200 400]) + (list :status 'result)) + (list + (symbol (handler-name f e a :get)) + (list + 'assoc + 'request + :params + (list + 'merge + 'params + 'result))) + 'result)))) + + +(defn make-post-handler + [f e a] + (let [n (handler-name f e a :post)] + (list + 'defn + (symbol n) + (vector 'request) + (case + (:tag f) + (:page :list) (list (symbol (handler-name f e a :get)) 'request) + :form (list + 'let + (vector + 'params + (list 'support/massage-params 'request)) + (make-form-post-handler-content f e a n)))))) + ;; (def a (x/parse "../youyesyet/youyesyet.canonical.adl.xml")) ;; (def e (child-with-tag a :entity)) ;; (def f (child-with-tag e :form)) -;; (def n (path-part f e a)) -;; (make-handler f e a) +;; (def n (handler-name f e a :post)) +;; (make-post-handler f e a) ;; (vector ;; 'p ;; (list 'merge ;; {:offset 0 :limit 25} ;; (list 'support/massage-params (list :params 'r)))) -;; (make-handler f e a) +;; (make-get-handler f e a) (defn make-route "Make a route for method `m` to request the resource with name `n`." [m n] (list - m + (symbol (s/upper-case (name m))) (str "/" n) 'request (list 'route/restricted (list 'apply - (list 'resolve-handler n) + (list 'resolve-handler (str (s/lower-case (name m)) "-" n)) (list 'list 'request))))) + (defn make-defroutes [application] (let [routes (flatten @@ -255,10 +324,10 @@ (apply (resolve-handler "index") (list request)))) (interleave (map - (fn [r] (make-route 'GET r)) + (fn [r] (make-route :get r)) (sort routes)) (map - (fn [r] (make-route 'POST r)) + (fn [r] (make-route :post r)) (sort routes)))))))) @@ -286,43 +355,52 @@ (doall (map (fn [c] - (pprint (make-handler c e application)) - (println)) + ;; do all get handlers before post handlers, so that the post + ;; handlers can call the get handlers. + (pprint (make-get-handler c e application)) + (println "\n") + (pprint (make-post-handler c e application)) + (println "\n")) (filter (fn [c] (#{:form :list :page} (:tag c))) (children e))))) (defn to-selmer-routes [application] - (let [filepath (str *output-path* "src/clj/" (:name (:attrs application)) "/routes/auto.clj")] + (let [filepath (str + *output-path* + "src/clj/" + (:name (:attrs application)) + "/routes/auto.clj") + entities (sort + #(compare (:name (:attrs %1))(:name (:attrs %2))) + (children-with-tag application :entity))] (make-parents filepath) (do-or-warn - (with-open [output (writer filepath)] - (binding [*out* output] - (pprint (file-header application)) - (println) - (pprint '(defn index - [r] - (l/render - (support/resolve-template - "application-index.html") - (:session r) - {:title "Administrative menu"}))) - (println) - (doall - (map - #(make-handlers % application) - (sort - #(compare (:name (:attrs %1))(:name (:attrs %2))) - (children-with-tag application :entity)))) - (pprint - (generate-handler-resolver application)) - (println) - (pprint '(def resolve-handler - (memoize raw-resolve-handler))) - (println) - (pprint (make-defroutes application)) - (println))) - (if - (pos? *verbosity*) - (*warn* (str "\tGenerated " filepath)))))) + (with-open [output (writer filepath)] + (binding [*out* output] + (pprint (file-header application)) + (println) + (pprint '(defn index + [r] + (l/render + (support/resolve-template + "application-index.html") + (:session r) + {:title "Administrative menu"}))) + (println) + (doall + (map + #(make-handlers % application) + entities)) + (pprint + (generate-handler-resolver application)) + (println) + (pprint '(def resolve-handler + (memoize raw-resolve-handler))) + (println) + (pprint (make-defroutes application)) + (println))) + (if + (pos? *verbosity*) + (*warn* (str "\tGenerated " filepath)))))) diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj index 8e17824..595adf5 100644 --- a/src/adl/to_selmer_templates.clj +++ b/src/adl/to_selmer_templates.clj @@ -1,7 +1,8 @@ -(ns ^{:doc "Application Description Language - generate Selmer templates for the HTML pages implied by an ADL file." +(ns ^{:doc "Application Description Language - generate Selmer templates for + the HTML pages implied by an ADL file." :author "Simon Brooke"} adl.to-selmer-templates - (:require [adl-support.core :refer [*warn*]] + (:require [adl-support.core :refer :all] [adl.to-hugsql-queries :refer [expanded-token]] [adl-support.utils :refer :all] [clojure.java.io :refer [file make-parents resource]] @@ -41,7 +42,9 @@ {:tag :div :attrs {:class "big-link-container"} :content - [{:tag :a :attrs {:href (str "{{servlet-context}}/" url) :class "big-link"} + [{:tag :a + :attrs {:href (str "{{servlet-context}}/" url) + :class "big-link"} :content (if (vector? content) content @@ -75,15 +78,7 @@ (map emit-content (remove nil? content)) true (str "")) - (catch Exception any - (str - "")))) + (str "Failed while writing " content))) ([filename application k] (emit-content filename nil nil application k)) ([filename spec entity application k] @@ -143,7 +138,8 @@ (defn csrf-widget - "For the present, just return the standard cross site scripting protection field statement" + "For the present, just return the standard cross site scripting protection + field statement" [] "{% csrf-field %}") @@ -179,16 +175,20 @@ (defn save-widget - "Return an appropriate 'save' widget for this `form` operating on this `entity` taken - from this `application`. - TODO: should be suppressed unless a member of a group which can insert or edit." + "Return an appropriate 'save' widget for this `form` operating on this + `entity` taken from this `application`. + TODO: should be suppressed unless a member of a group which can insert + or edit." [form entity application] (wrap-in-if-member-of {:tag :p :attrs {:class "widget action-safe"} :content [{:tag :label :attrs {:for "save-button" :class "action-safe"} - :content [(str "To save this " (:name (:attrs entity)) " record")]} + :content [(str + "To save this " + (:name (:attrs entity)) + " record")]} {:tag :input :attrs {:id "save-button" :name "save-button" @@ -201,16 +201,20 @@ (defn delete-widget - "Return an appropriate 'save' widget for this `form` operating on this `entity` taken - from this `application`. + "Return an appropriate 'save' widget for this `form` operating on this + `entity` taken from this `application`. TODO: should be suppressed unless member of a group which can delete." [form entity application] (wrap-in-if-member-of {:tag :p :attrs {:class "widget action-dangerous"} :content [{:tag :label - :attrs {:for "delete-button" :class "action-dangerous"} - :content [(str "To delete this " (:name (:attrs entity)) " record")]} + :attrs {:for "delete-button" + :class "action-dangerous"} + :content [(str + "To delete this " + (:name (:attrs entity)) + " record")]} {:tag :input :attrs {:id "delete-button" :name "delete-button" @@ -223,7 +227,8 @@ (defn select-property - "Return the property on which we will by default do a user search on this `entity`." + "Return the property on which we will by default do a user search on this + `entity`." [entity] (descendant-with-tag entity @@ -241,8 +246,8 @@ (defn get-options - "Produce template code to get options for this `property` of this `entity` taken from - this `application`." + "Produce template code to get options for this `property` of this `entity` + taken from this `application`." [property form entity application] (let [type (:type (:attrs property)) @@ -258,9 +263,9 @@ (:farkey (:attrs property)) (first (key-names farside)) "id")] - ;; Yes, I know it looks BONKERS generating this as an HTML string. But there is a - ;; reason. We don't know whether the `selected` attribute should be present or - ;; absent until rendering. + ;; Yes, I know it looks BONKERS generating this as an HTML string. But + ;; there is a reason. We don't know whether the `selected` attribute + ;; should be present or absent until rendering. [(str "{% for option in " (-> property :attrs :name) " %}