From c6c7b1c6ea4a1d67bae79dce03f7069fc51da795 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 16 Mar 2018 16:39:11 +0000 Subject: [PATCH 01/10] Upversion to 0.1.1-SNAPSHOT --- project.clj | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/project.clj b/project.clj index 5efe509..275cd80 100644 --- a/project.clj +++ b/project.clj @@ -1,4 +1,4 @@ -(defproject squirrel-parse "0.1.1" +(defproject squirrel-parse "0.1.1-SNAPSHOT" :description "A library for parsing SQL" ;; :url "http://example.com/FIXME" :license {:name "GNU General Public License,version 2.0 or (at your option) any later version" From 4193d5700bd51112e0a761be21f841be9c0a8c15 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 17 Mar 2018 15:30:46 +0000 Subject: [PATCH 02/10] Now generating credible-seeming (but untested) routes file --- src/squirrel_parse/to_hugsql_queries.clj | 226 +++++++++++++++-------- src/squirrel_parse/to_json_routes.clj | 225 ++++++++++++++++++++++ src/squirrel_parse/utils.clj | 2 +- 3 files changed, 380 insertions(+), 73 deletions(-) create mode 100644 src/squirrel_parse/to_json_routes.clj diff --git a/src/squirrel_parse/to_hugsql_queries.clj b/src/squirrel_parse/to_hugsql_queries.clj index 9518016..dacd1f8 100644 --- a/src/squirrel_parse/to_hugsql_queries.clj +++ b/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 - #(:name (:attrs %)) - (filter #(= (-> % :attrs :distinct) "user") - (-> entity-map :content :properties vals)))] + preferred (map + #(:name (:attrs %)) + (filter #(= (-> % :attrs :distinct) "user") + (-> 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)))) - ] - (str "-- :name create-" pretty-name "! : % :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)] - (str "-- :name list-" entity-name "-by-" pretty-far " :? :*\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")) + link-field (-> % :attrs :name) + query-name (str "list-" entity-name "-by-" pretty-far) + signature ":? :*"] + (hash-map + (keyword query-name) + {:name query-name + :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)] - (println links) - (str "-- :name list-" link-name "-" near-name "-by-" pretty-far " :? :*\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"))) + pretty-far (singularise far-name) + query-name (str "list-" link-name "-" near-name "-by-" pretty-far) + signature ":? :*"] + (hash-map + (keyword query-name) + {:name query-name + :signature signature + :entity link + :type :select-many-to-many + :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$" "")] - (str "-- :name delete-" pretty-name "! :! :n\n" - "-- :doc updates an existing " pretty-name " record\n" - "DELETE FROM " entity-name "\n" - (where-clause entity-map) - "\n\n")))) + pretty-name (singularise entity-name) + query-name (str "delete-" pretty-name "!") + signature ":! :n"] + (hash-map + (keyword query-name) + {: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))) diff --git a/src/squirrel_parse/to_json_routes.clj b/src/squirrel_parse/to_json_routes.clj new file mode 100644 index 0000000..fe74533 --- /dev/null +++ b/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 + ))) diff --git a/src/squirrel_parse/utils.clj b/src/squirrel_parse/utils.clj index a23d2a9..7298858 100644 --- a/src/squirrel_parse/utils.clj +++ b/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")) From df9d12e572879c6f617d883f493c3ad471628776 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 17 Mar 2018 15:38:18 +0000 Subject: [PATCH 03/10] Added auto-generated files to .gitignore --- .gitignore | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/.gitignore b/.gitignore index 5acfe7c..1f254c0 100644 --- a/.gitignore +++ b/.gitignore @@ -10,3 +10,7 @@ target/ \.lein-failures *.dump + +queries\.auto\.sql + +auto_json_routes\.clj From 080075628804c90f08f0c2cdc9fa3ef2b06faa10 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 17 Mar 2018 18:26:00 +0000 Subject: [PATCH 04/10] Now actually working! --- src/squirrel_parse/to_hugsql_queries.clj | 2 +- src/squirrel_parse/to_json_routes.clj | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/squirrel_parse/to_hugsql_queries.clj b/src/squirrel_parse/to_hugsql_queries.clj index dacd1f8..ec50e70 100644 --- a/src/squirrel_parse/to_hugsql_queries.clj +++ b/src/squirrel_parse/to_hugsql_queries.clj @@ -250,7 +250,7 @@ :entity entity-map :type :delete-1 :query - (str "-- :name " query-name ":! " signature "\n" + (str "-- :name " query-name " " signature "\n" "-- :doc updates an existing " pretty-name " record\n" "DELETE FROM " entity-name "\n" (where-clause entity-map) diff --git a/src/squirrel_parse/to_json_routes.clj b/src/squirrel_parse/to_json_routes.clj index fe74533..a4eca3a 100644 --- a/src/squirrel_parse/to_json_routes.clj +++ b/src/squirrel_parse/to_json_routes.clj @@ -145,7 +145,7 @@ ".")) :select-many (generate-handler-src - handler-name query :post + 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: " @@ -177,11 +177,11 @@ (map #(let [handler (handlers-map %)] (list - (s/upper-case (name (:method handler))) + (symbol (s/upper-case (name (:method handler)))) (str "/json/auto/" (:name handler)) 'request - (list - 'route/restricted + (list + 'route/restricted (list (:name handler) 'request)))) (sort (keys handlers-map)))))) From 05623f0168909fea700f0c490ff320e79b031ec5 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 17 Mar 2018 19:06:02 +0000 Subject: [PATCH 05/10] Identifying headers added to generated files. --- src/squirrel_parse/to_hugsql_queries.clj | 13 +++++++++++-- src/squirrel_parse/to_json_routes.clj | 6 +++++- 2 files changed, 16 insertions(+), 3 deletions(-) diff --git a/src/squirrel_parse/to_hugsql_queries.clj b/src/squirrel_parse/to_hugsql_queries.clj index ec50e70..cd67655 100644 --- a/src/squirrel_parse/to_hugsql_queries.clj +++ b/src/squirrel_parse/to_hugsql_queries.clj @@ -4,6 +4,8 @@ (:require [clojure.java.io :refer [file]] [clojure.math.combinatorics :refer [combinations]] [clojure.string :as s] + [clj-time.core :as t] + [clj-time.format :as f] [squirrel-parse.to-adl :refer [migrations-to-xml]] [squirrel-parse.utils :refer [is-link-table? singularise]])) @@ -281,13 +283,20 @@ [adl-struct (migrations-to-xml migrations-path "Ignored") file-content (apply str - (doall (map + (cons + (str "-- " + output + " autogenerated by \n-- [squirrel-parse](https://github.com/simon-brooke/squirrel-parse)\n-- at " + (f/unparse (f/formatters :basic-date-time) (t/now)) + "\n\n") + (doall + (map #(:query %) (vals (apply merge (map #(queries % adl-struct) - (vals adl-struct)))))))] + (vals adl-struct))))))))] (spit output file-content) file-content))) diff --git a/src/squirrel_parse/to_json_routes.clj b/src/squirrel_parse/to_json_routes.clj index a4eca3a..2f9efe4 100644 --- a/src/squirrel_parse/to_json_routes.clj +++ b/src/squirrel_parse/to_json_routes.clj @@ -5,6 +5,8 @@ [clojure.math.combinatorics :refer [combinations]] [clojure.pprint :refer [pprint write]] [clojure.string :as s] + [clj-time.core :as t] + [clj-time.format :as f] [squirrel-parse.to-adl :refer [migrations-to-xml]] [squirrel-parse.to-hugsql-queries :refer [queries]] [squirrel-parse.utils :refer [is-link-table? singularise]])) @@ -40,8 +42,10 @@ (defn file-header [parent-name this-name] (list 'ns - ^{:doc "JSON routes auto-generated by squirrel-parse"} (symbol (str parent-name "." this-name)) + (str "JSON routes for " parent-name + " auto-generated by [squirrel-parse](https://github.com/simon-brooke/squirrel-parse) at " + (f/unparse (f/formatters :basic-date-time) (t/now))) (list 'require '[noir.response :as nresponse] From 955fb20acc75db1822a634209e180c2e05d3fa2e Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 17 Mar 2018 23:59:09 +0000 Subject: [PATCH 06/10] Added a first stab at a general text search query --- src/squirrel_parse/to_hugsql_queries.clj | 70 ++++++++++++++++++------ src/squirrel_parse/to_json_routes.clj | 57 +++++++++++-------- 2 files changed, 89 insertions(+), 38 deletions(-) diff --git a/src/squirrel_parse/to_hugsql_queries.clj b/src/squirrel_parse/to_hugsql_queries.clj index cd67655..cfb8c87 100644 --- a/src/squirrel_parse/to_hugsql_queries.clj +++ b/src/squirrel_parse/to_hugsql_queries.clj @@ -110,6 +110,41 @@ {})) +(defn search-query [entity-map] + (let [entity-name (:name (:attrs entity-map)) + pretty-name (singularise entity-name) + query-name (str "search-strings-" pretty-name) + signature ":? :1" + string-fields (filter + #(= (-> % :attrs :type) "string") + (-> entity-map :content :properties vals))] + (if + (empty? string-fields) + {} + (hash-map + (keyword query-name) + {:name query-name + :signature signature + :entity entity-map + :type :text-search + :query + (str "-- :name " query-name " " signature "\n" + "-- :doc selects existing " entity-name " records having any string field matching `:pattern` by substring match\n" + "SELECT * FROM " entity-name "\n" + "WHERE " + (s/join + "\n\tOR " + (map + #(str (-> % :attrs :name) " LIKE '%:pattern%'") + string-fields)) + "\n" + (order-by-clause entity-map) + "\n" + "--~ (if (:offset params) \"OFFSET :offset \") \n" + "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")" + "\n\n")})))) + + (defn select-query [entity-map] (if (has-primary-key? entity-map) @@ -272,6 +307,7 @@ (merge (select-query entity-map) (list-query entity-map) + (search-query entity-map) (foreign-queries entity-map entities-map))))) @@ -282,21 +318,23 @@ (let [adl-struct (migrations-to-xml migrations-path "Ignored") file-content (apply - str - (cons - (str "-- " - output - " autogenerated by \n-- [squirrel-parse](https://github.com/simon-brooke/squirrel-parse)\n-- at " - (f/unparse (f/formatters :basic-date-time) (t/now)) - "\n\n") - (doall - (map - #(:query %) - (vals - (apply - merge - (map - #(queries % adl-struct) - (vals adl-struct))))))))] + str + (cons + (str "-- " + output + " autogenerated by \n-- [squirrel-parse](https://github.com/simon-brooke/squirrel-parse)\n-- at " + (f/unparse (f/formatters :basic-date-time) (t/now)) + "\n\n") + (doall + (map + #(:query %) + (sort + #(compare (:name %1) (:name %2)) + (vals + (apply + merge + (map + #(queries % adl-struct) + (vals adl-struct)))))))))] (spit output file-content) file-content))) diff --git a/src/squirrel_parse/to_json_routes.clj b/src/squirrel_parse/to_json_routes.clj index 2f9efe4..ed3d9ad 100644 --- a/src/squirrel_parse/to_json_routes.clj +++ b/src/squirrel_parse/to_json_routes.clj @@ -42,7 +42,7 @@ (defn file-header [parent-name this-name] (list 'ns - (symbol (str parent-name "." this-name)) + (symbol (str parent-name ".routes." this-name)) (str "JSON routes for " parent-name " auto-generated by [squirrel-parse](https://github.com/simon-brooke/squirrel-parse) at " (f/unparse (f/formatters :basic-date-time) (t/now))) @@ -102,27 +102,27 @@ :delete-1 (generate-handler-src handler-name query :post - (str "delete one record from the " + (str "delete one record from the `" (-> query :entity :attrs :name) - " table. Expects the following key(s) to be present in `params`: " + "` 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 " + (str "insert one record to the `" (-> query :entity :attrs :name) - " table. Expects the following key(s) to be present in `params`: " + "` table. Expects the following key(s) to be present in `params`: `" (pr-str (-> query :entity :content :properties keys)) - ". Returns a map containing the keys " + "`. Returns a map containing the keys `" (pr-str (-> query :entity :content :key :content keys)) - " identifying the record created.")) + "` identifying the record created.")) :update-1 (generate-handler-src handler-name query :post - (str "update one record in the " + (str "update one record in the `" (-> query :entity :attrs :name) - " table. Expects the following key(s) to be present in `params`: " + "` table. Expects the following key(s) to be present in `params`: `" (pr-str (distinct (sort @@ -130,15 +130,15 @@ (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 " + (str "select one record from the `" (-> query :entity :attrs :name) - " table. Expects the following key(s) to be present in `params`: " + "` 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: " + "`. Returns a map containing the following keys: `" (pr-str (distinct (sort @@ -146,13 +146,13 @@ (cons (-> query :entity :content :properties keys) (-> query :entity :content :key :content keys)))))) - ".")) - :select-many + "`.")) + :select-many (generate-handler-src handler-name query :get - (str "select all records from the " + (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: " + "` 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 @@ -160,17 +160,30 @@ (cons (-> query :entity :content :properties keys) (-> query :entity :content :key :content keys)))))) - ".")) - + "`.")) + :text-search + (generate-handler-src + handler-name query :get + (str "select all records from the `" + (-> query :entity :attrs :name) + "` 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 + (distinct + (sort + (flatten + (cons + (-> query :entity :content :properties keys) + (-> query :entity :content :key :content keys)))))) + "`.")) (:select-many-to-many - :select-one-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)))))))) + (str ";; don't know what to do with query `" :key "` of type `" (:type query) "`."))))))) (defn defroutes [handlers-map] From db71251a530b178259ae96be4fdc2e0501ff6673 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 19 Mar 2018 14:36:05 +0000 Subject: [PATCH 07/10] #7 Added ADL validator Doesn't belong here in the long term, see epic #5. --- .gitignore | 4 + project.clj | 1 + src/squirrel_parse/validator.clj | 414 +++++++++++++++++++++++++++++++ 3 files changed, 419 insertions(+) create mode 100644 src/squirrel_parse/validator.clj diff --git a/.gitignore b/.gitignore index 1f254c0..4aa7593 100644 --- a/.gitignore +++ b/.gitignore @@ -14,3 +14,7 @@ target/ queries\.auto\.sql auto_json_routes\.clj + +\.idea/ + +*.iml diff --git a/project.clj b/project.clj index 275cd80..518f510 100644 --- a/project.clj +++ b/project.clj @@ -5,5 +5,6 @@ :url "https://www.gnu.org/licenses/old-licenses/gpl-2.0.en.html"} :dependencies [[org.clojure/clojure "1.8.0"] [org.clojure/math.combinatorics "0.1.4"] + [bouncer "1.0.1"] [clj-time "0.14.2"] [instaparse "1.4.8"]]) diff --git a/src/squirrel_parse/validator.clj b/src/squirrel_parse/validator.clj new file mode 100644 index 0000000..c593bf6 --- /dev/null +++ b/src/squirrel_parse/validator.clj @@ -0,0 +1,414 @@ +(ns ^{:doc "A parser for SQL: validator for ADL structure." + :author "Simon Brooke"} + squirrel-parse.validator + (:require [clojure.set :refer [union]] + [clojure.string :as s] + [bouncer.core :as b] + [bouncer.validators :as v])) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; squirrel-parse.to-adl: validate Application Description Language. +;;;; +;;;; 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 +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +;;; this is a fairly straight translation of the ADL 1.4 DTD into Clojure + +(def permissions + "permissions a group may have on an entity, list, page, form or field + permissions are deemed to increase as you go right. A group cannot + have greater permission on a field than on the form it is in, or + greater permission on form than the entity it belongs to + + * `none`: none + * `read`: select + * `insert`: insert + * `noedit`: select, insert + * `edit`: select, insert, update + * `all`: select, insert, update, delete" + #{"none", "read", "insert", "noedit", "edit", "all"}) + +(def cascade-actions + "actions which should be cascaded to dependent objects. All these values except + 'manual' are taken from Hibernate and should be passed through the adl2hibernate + mapping transparently. Relevent only for properties with type='entity', type='link' + and type='list' + + * `all`: cascade delete, save and update + * `all-delete-orphan`: see hibernate documentation; relates to transient objects only + * `delete`: cascade delete actions, but not save and update + * `manual`: cascading will be handled in manually managed code, code to + handle cascading should not be generated + * `save-update`: cascade save and update actions, but not delete." + #{"all", "all-delete-orphan", "delete", "manual", "save-update"}) + +(def defineable-data-types + "data types which can be used in a typedef to provide validation - + e.g. a string can be used with a regexp or a scalar can be used with + min and max values + * `string`: varchar java.sql.Types.VARCHAR + * `integer`: int java.sql.Types.INTEGER + * `real`: double java.sql.Types.DOUBLE + * `money`: money java.sql.Types.INTEGER + * `date`: date java.sql.Types.DATE + * `time`: time java.sql.Types.TIME + * `timestamp`: timestamp java.sql.Types.TIMESTAMP + * `uploadable`: varchar java.sql.Types.VARCHAR + * `image`: varchar java.sql.Types.VARCHAR + + uploadable is as string but points to an uploaded file; image is as + uploadable but points to an uploadable graphical image file." + #{"string", "integer", "real", "money", "date", "time", "timestamp", "uploadable"}) + +(def simple-data-types (union + defineable-data-types + #{"boolean" "text"})) + +(def complex-data-types #{"entity", "link", "list", "defined"}) + +(def special-data-types #{"geopos", "image", "message"}) + +(def all-data-types (union + simple-data-types + complex-data-types + special-data-types)) + +(def content #{"head", "top", "foot"}) + +(def field-stuff #{"field", "fieldgroup", "auxlist", "verb"}) + +(def page-content (union content field-stuff)) + +(def page-stuff (union page-content #{"permission", "pragma"})) + +(def generator-actions #{"assigned", "guid", "manual", "native"}) + +(def sequences #{"canonical", "reverse-canonical"}) + +(def specification-validations + {:tag [v/required [#(= % :specification)]]}) + +(def documentation-validations + "contains documentation on the element which immediately contains it. TODO: + should HTML markup within a documentation element be allowed? If so, are + there restrictions?" + {:tag [v/required [#(= % :documentation)]]}) + +(def content-validations + {:tag [v/required [#(= % :content)]]}) + +(def help-validations + "helptext about a property of an entity, or a field of a page, form or + list, or a typedef. Typically there will be only one of these per property + per locale; if there are more than one all those matching the locale may + be concatenated, or just one may be used. + + * `locale`: the locale in which to prefer this prompt" + {:tag [v/required [#(= % :help)]] + [:attrs :locale] [v/string v/required [v/matches #"[a-z]{2}-[A-Z]{2}"]]}) + +(def ifmissing-validations + "helpful text to be shown if a property value is missing, typically when + a form is submitted. Typically there will be only one of these per property + per locale; if there are more than one all those matching the locale may + be concatenated, or just one may be used. Later there may be more sophisticated + behaviour here. + + * `locale`: the locale in which to prefer this prompt" + {:tag [v/required [#(= % :if-missing)]] + [:attrs :locale] [v/string v/required [v/matches #"[a-z]{2}-[A-Z]{2}"]]}) + +(def param-validations + "A parameter passed to the generator. Again, based on the Hibernate + implementation. + + * `name`: the name of this parameter." + {:tag [v/required [#(= % :param)]] + [:attrs :name] [v/string v/required]}) + + +(def permission-validations + "permissions policy on an entity, a page, form, list or field + + * `group`: the group to which permission is granted + * `permission`: the permission which is granted to that group." + {:tag [v/required [#(= % :permission)]] + [:attrs :group] [v/string v/required] ;; TODO: and it must be the name of a group that has already been defined. + [:attrs :permission] [v/required [v/matches permissions]]}) + + +(def prompt-validations + "a prompt for a property or field; used as the prompt text for a widget + which edits it. Typically there will be only one of these per property + per locale; if there are more than one all those matching the locale may + be concatenated, or just one may be used. + + * `prompt`: the prompt to use + * `locale`: the locale in which to prefer this prompt." + {:tag [v/required [#(= % :prompt)]] + [:attrs :prompt] [v/string v/required] + [:attrs :locale] [v/string v/required [v/matches #"[a-z]{2}-[A-Z]{2}"]]}) + +(def ifmissing-validations + "helpful text to be shown if a property value is missing, typically when + a form is submitted. Typically there will be only one of these per property + per locale; if there are more than one all those matching the locale may + be concatenated, or just one may be used. Later there may be more sophisticated + behaviour here. + + * `locale`: the locale in which to prefer this prompt." + {:tag [v/required [#(= % :ifmissing)]] + [:attrs :locale] [v/string v/required [v/matches #"[a-z]{2}-[A-Z]{2}"]]}) + +(def option-validations + "one of an explicit list of optional values a property may have + NOTE: whether options get encoded at application layer or at database layer + is UNDEFINED; either behaviour is correct. If at database layer it's also + UNDEFINED whether they're encoded as a single reference data table or as + separate reference data tables for each property. + + * `value`: the value of this option." + {:tag [v/required [#(= % :option)]] + [:attrs :value] [v/required] + :content [[v/every #(or + (b/validate % documentation-validations) + (b/validate % prompt-validations))]]}) + +(def pragma-validations + "pragmatic advice to generators of lists and forms, in the form of + name/value pairs which may contain anything. Over time some pragmas + will become 'well known', but the whole point of having a pragma + architecture is that it is extensible." + {:tag [v/required [#(= % :pragma)]] + [:attrs :name] [v/string v/required] + [:attrs :value] [v/string v/required]}) + + + +(def generator-validations + "marks a property which is auto-generated by some part of the system. + This is based on the Hibernate construct, except that the Hibernate + implementation folds both its internal generators and custom generators + onto the same attribute. This separates them onto two attributes so we + can police values for Hibernate's 'builtin' generators. + + * `action`: one of the supported Hibernate builtin generators, or + 'manual'. 'native' is strongly recommended in most instances + * `class`: if action is 'manual', the name of a manually maintained + class conforming to the Hibernate IdentifierGenerator + interface, or its equivalent in other languages." + {:tag [v/required [#(= % :generator)]] + [:attrs :action] [v/string v/required [v/member generator-actions]] + [:attrs :class] v/string + :content [[v/every #(or + (b/validate % documentation-validations) + (b/validate % param-validations))]]}) + + +(def in-implementation-validations + "information about how to translate a type into types known to different target + languages. TODO: Once again I'm not wholly comfortable with the name; I'm not + really comfortable that this belongs in ADL at all. + + * `target`: the target language + * `value`: the type to use in that target language + * `kind`: OK, I confess I don't understand this, but Andrew needs it... " + + {:tag [v/required [#(= % :in-implementation)]] + [:attrs :target] [v/string v/required] + [:attrs :value] [v/string v/required] + [:attrs :kind] v/string + :content [[v/every documentation-validations]]}) + +(def typedef-validations + "the definition of a defined type. At this stage a defined type is either + * a string in which case it must have size and pattern, or + * a scalar in which case it must have minimum and/or maximum + pattern must be a regular expression as interpreted by org.apache.regexp.RE + minimum and maximum must be of appropriate format for the datatype specified. + Validation may be done client-side and/or server-side at application layer + and/or server side at database layer. + + * `name`: the name of this typedef + * `type`: the simple type on which this defined type is based; must be + present unless in-implementation children are supplied + * `size`: the data size of this defined type + * `pattern`: a regular expression which values for this type must match + * `minimum`: the minimum value for this type (if base type is scalar) + * `maximum`: the maximum value for this type (if base type is scalar)" + {:tag [v/required [#(= % :typedef)]] + [:attrs :name] [v/required v/string] + [:attrs :type] [[v/member defineable-data-types]] + [:attrs :size] [[#(or + (integer? %) + (integer? (read-string %)))]] + [:attrs :pattern] v/string + [:attrs :minimum] [[#(or + (integer? %) + (integer? (read-string %)))]] + [:attrs :maximum] [[#(or + (integer? %) + (integer? (read-string %)))]] + :content [[v/every #(or + (b/validate % documentation-validations) + (b/validate % in-implementation-validations) + (b/validate % help-validations))]]}) + +(def group-validations + "a group of people with similar permissions to one another + + * `name`: the name of this group + * `parent`: the name of a group of which this group is subset" + {:tag [v/required [#(= % :group)]] + [:attrs :name] [v/string v/required] + [:attrs :parent] v/string + :content [[v/every documentation-validations]]}) + +(def property-validations + "a property (field) of an entity (table) + + * `name`: the name of this property. + * `type`: the type of this property. + * `default`: the default value of this property. There will probably be + magic values of this! + * `typedef`: name of the typedef to use, it type = 'defined'. + * `distinct`: distinct='system' required that every value in the system + will be distinct (i.e. natural primary key); + distinct='user' implies that the value may be used by users + in distinguishing entities even if values are not formally + unique; + distinct='all' implies that the values are formally unique + /and/ are user friendly (NOTE: not implemented). + * `entity`: if type='entity', the name of the entity this property is + a foreign key link to. + if type='list', the name of the entity that has a foreign + key link to this entity + * `farkey`: if type='list', the name of farside key in the listed + entity; if type='entity' and the farside field to join to + is not the farside primary key, then the name of that + farside field + * `required`: whether this propery is required (i.e. 'not null'). + * `immutable`: if true, once a value has been set it cannot be changed. + * `size`: fieldwidth of the property if specified. + * `concrete`: if set to 'false', this property is not stored in the + database but must be computed (manually written code must + be provided to support this) + * `cascade`: what action(s) on the parent entity should be cascaded to + entitie(s) linked on this property. Valid only if type='entity', + type='link' or type='list'. + * `column`: name of the column in a SQL database table in which this property + is stored. TODO: Think about this. + * `unsaved-value`: + of a property whose persistent value is set on first being + committed to persistent store, the value which it holds before + it has been committed" + {:tag [v/required [#(= % :property)]] + [:attrs :name] [v/required v/string] + [:attrs :type] [v/required [v/member all-data-types]] + ;; [:attrs :default] [] + [:attrs :typedef] v/string + [:attrs :distinct] [v/string [v/member #{"none", "all", "user", "system"}]] + [:attrs :entity] v/string + [:attrs :farkey] v/string + [:attrs :required] v/boolean + [:attrs :immutable] v/boolean + [:attrs :size] [[#(or (integer? %)(integer? (read-string %)))]] + [:attrs :column] v/string + [:attrs :concrete] v/boolean + [:attrs :cascade] [[v/member cascade-actions]] + :content [[v/every #(or + (b/validate % documentation-validations) + (b/validate % generator-validations) + (b/validate % permission-validations) + (b/validate % option-validations) + (b/validate % prompt-validations) + (b/validate % help-validations) + (b/validate % ifmissing-validations))]]}) + + +(def permission-validations + {:tag [v/required [#(= % :permission)]]}) + +(def form-validations + {:tag [v/required [#(= % :form)]]}) + +(def page-validations + {:tag [v/required [#(= % :page)]]}) + +(def list-validations + {:tag [v/required [#(= % :list)]]}) + +;; (def prompt-validations +;; {:tag [v/required [#(= % :prompt)]]}) + +(def key-validations + {:tag [v/required [#(= % :key)]] + :content [[v/every property-validations]]}) + + +(def entity-validations + "an entity which has properties and relationships; maps onto a database + table or a Java serialisable class - or, of course, various other things + + * `name`: obviously, the name of this entity + * `natural-key`: if present, the name of a property of this entity which forms + a natural primary key [NOTE: Only partly implemented. NOTE: much of + the present implementation assumes all primary keys will be + integers. This needs to be fixed!] DEPRECATED: remove; replace with the + 'key' element, below. + * `table`: the name of the table in which this entity is stored. Defaults to same + as name of entity. Strongly recommend this is not used unless it needs + to be different from the name of the entity + * `foreign`: this entity is part of some other system; no code will be generated + for it, although code which links to it will be generated" + {:tag [v/required [#(= % :entity)]] + [:attrs :name] [v/required v/string] + [:attrs :natural-key] v/string + [:attrs :table] v/string + [:attrs :foreign] v/boolean + :content [[v/every #(or + (b/validate % documentation-validations) + (b/validate % prompt-validations) + (b/validate % content-validations) + (b/validate % key-validations) + (b/validate % property-validations) + (b/validate % permission-validations) + (b/validate % form-validations) + (b/validate % page-validations) + (b/validate % list-validations) + )]]}) + +(def application-validations + {:tag [v/required [#(= % :application)]] + [:attrs :name] [v/required v/string] + [:attrs :version] v/string + [:attrs :revision] v/string + [:attrs :currency] v/string + :content [[v/every #(or + (b/validate % specification-validations) + (b/validate % documentation-validations) + (b/validate % content-validations) + (b/validate % typedef-validations) + (b/validate % group-validations) + (b/validate % entity-validations))]]}) + + + From d5d26db0370c2600e7734579d2ae52b7bd71e707 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 19 Mar 2018 18:17:50 +0000 Subject: [PATCH 08/10] #7 The good news: it's complete. The bad news: it doesn't yet work. --- src/squirrel_parse/validator.clj | 277 +++++++++++++++++++++++++------ 1 file changed, 223 insertions(+), 54 deletions(-) diff --git a/src/squirrel_parse/validator.clj b/src/squirrel_parse/validator.clj index c593bf6..1f1a12d 100644 --- a/src/squirrel_parse/validator.clj +++ b/src/squirrel_parse/validator.clj @@ -32,6 +32,8 @@ ;;; this is a fairly straight translation of the ADL 1.4 DTD into Clojure +(declare fieldgroup-validations) + (def permissions "permissions a group may have on an entity, list, page, form or field permissions are deemed to increase as you go right. A group cannot @@ -78,20 +80,41 @@ uploadable but points to an uploadable graphical image file." #{"string", "integer", "real", "money", "date", "time", "timestamp", "uploadable"}) -(def simple-data-types (union - defineable-data-types - #{"boolean" "text"})) +(def simple-data-types + "data types which are fairly straightforward translations of JDBC data types + * `boolean`: boolean java.sql.Types.BIT or char(1) java.sql.Types.CHAR + * `text`: text or java.sql.Types.LONGVARCHAR + memo java.sql.Types.CLOB" + (union + defineable-data-types + #{"boolean" "text"})) -(def complex-data-types #{"entity", "link", "list", "defined"}) +(def complex-data-types + "data types which are more complex than SimpleDataTypes... + * `entity` : a foreign key link to another entity (i.e. the 'many' end of a + one-to-many link); + * `list` : a list of some other entity that links to me (i.e. the 'one' end of + a one-to-many link); + * `link` : a many to many link (via a link table); + * `defined` : a type defined by a typedef." + #{"entity", "link", "list", "defined"}) -(def special-data-types #{"geopos", "image", "message"}) +(def special-data-types + "data types which require special handling - which don't simply map onto + common SQL data types + * `geopos` : a latitude/longitude pair (experimental and not yet implemented) + * `image` : a raster image file, in jpeg, gif, or png format (experimental, not yet implemented) + * `message` : an internationalised message, having different translations for different locales" + #{"geopos", "image", "message"}) (def all-data-types (union simple-data-types complex-data-types special-data-types)) -(def content #{"head", "top", "foot"}) +(def content + "content, for things like pages (i.e. forms, lists, pages)" + #{"head", "top", "foot"}) (def field-stuff #{"field", "fieldgroup", "auxlist", "verb"}) @@ -189,8 +212,8 @@ {:tag [v/required [#(= % :option)]] [:attrs :value] [v/required] :content [[v/every #(or - (b/validate % documentation-validations) - (b/validate % prompt-validations))]]}) + (b/valid? % documentation-validations) + (b/valid? % prompt-validations))]]}) (def pragma-validations "pragmatic advice to generators of lists and forms, in the form of @@ -219,8 +242,8 @@ [:attrs :action] [v/string v/required [v/member generator-actions]] [:attrs :class] v/string :content [[v/every #(or - (b/validate % documentation-validations) - (b/validate % param-validations))]]}) + (b/valid? % documentation-validations) + (b/valid? % param-validations))]]}) (def in-implementation-validations @@ -257,20 +280,23 @@ {:tag [v/required [#(= % :typedef)]] [:attrs :name] [v/required v/string] [:attrs :type] [[v/member defineable-data-types]] - [:attrs :size] [[#(or - (integer? %) - (integer? (read-string %)))]] + [:attrs :size] [[#(if + (string? %) + (integer? (read-string %)) + (integer? %))]] [:attrs :pattern] v/string - [:attrs :minimum] [[#(or - (integer? %) - (integer? (read-string %)))]] - [:attrs :maximum] [[#(or - (integer? %) - (integer? (read-string %)))]] + [:attrs :minimum] [[#(if + (string? %) + (integer? (read-string %)) + (integer? %))]] + [:attrs :maximum] [[#(if + (string? %) + (integer? (read-string %)) + (integer? %))]] :content [[v/every #(or - (b/validate % documentation-validations) - (b/validate % in-implementation-validations) - (b/validate % help-validations))]]}) + (b/valid? % documentation-validations) + (b/valid? % in-implementation-validations) + (b/valid? % help-validations))]]}) (def group-validations "a group of people with similar permissions to one another @@ -321,43 +347,184 @@ committed to persistent store, the value which it holds before it has been committed" {:tag [v/required [#(= % :property)]] - [:attrs :name] [v/required v/string] + [:attrs :name] [v/required v/string] [:attrs :type] [v/required [v/member all-data-types]] - ;; [:attrs :default] [] + ;; [:attrs :default] [] ;; it's allowed, but I don't have anything particular to say about it [:attrs :typedef] v/string [:attrs :distinct] [v/string [v/member #{"none", "all", "user", "system"}]] [:attrs :entity] v/string [:attrs :farkey] v/string [:attrs :required] v/boolean [:attrs :immutable] v/boolean - [:attrs :size] [[#(or (integer? %)(integer? (read-string %)))]] + [:attrs :size] [[#(if + (string? %) + (integer? (read-string %)) + (integer? %))]] [:attrs :column] v/string [:attrs :concrete] v/boolean [:attrs :cascade] [[v/member cascade-actions]] :content [[v/every #(or - (b/validate % documentation-validations) - (b/validate % generator-validations) - (b/validate % permission-validations) - (b/validate % option-validations) - (b/validate % prompt-validations) - (b/validate % help-validations) - (b/validate % ifmissing-validations))]]}) + (b/valid? % documentation-validations) + (b/valid? % generator-validations) + (b/valid? % permission-validations) + (b/valid? % option-validations) + (b/valid? % prompt-validations) + (b/valid? % help-validations) + (b/valid? % ifmissing-validations))]]}) (def permission-validations - {:tag [v/required [#(= % :permission)]]}) + "permissions policy on an entity, a page, form, list or field + + * `group`: the group to which permission is granted + * `permission`: the permission which is granted to that group" + {:tag [v/required [#(= % :permission)]] + [:attrs :group] [v/required v/string] ;; and it also needs to be the name of a pre-declared group + [:attrs :permission] [[v/member permissions]] + :content [[v/every documentation-validations]]}) + +(def head-validations + "content to place in the head of the generated document; normally HTML." + {:tag [v/required [#(= % :head)]]}) + +(def top-validations + "content to place in the top of the body of the generated document; + this is any HTML block or inline level element." + {:tag [v/required [#(= % :top)]]}) + +(def foot-validations + "content to place in the bottom of the body of the generated document; + this is any HTML block or inline level element." + {:tag [v/required [#(= % :foot)]]}) + +(def field-validations + "a field in a form or page + + * `property`: the property which this field displays/edits." + {:tag [v/required [#(= % :field)]] + [:attrs :property] [v/string v/required] ;; and it must also be the name of a property in the current entity + :content [[v/every #(or + (b/valid? % documentation-validations) + (b/valid? % prompt-validations) + (b/valid? % permission-validations) + (b/valid? % help-validations))]]}) + +(def verb-validations + "a verb is something that may be done through a form. Probably the verbs 'store' + and 'delete' are implied, but maybe they need to be explicitly declared. The 'verb' + attribute of the verb is what gets returned to the controller + + * `verb` what gets returned to the controller when this verb is selected + * `dangerous` true if this verb causes a destructive change." + {:tag [v/required [#(= % :verb)]] + [:attrs :verb] [v/string v/required] + [:attrs :dangerous] [v/boolean v/required]}) + +(def order-validations + "an ordering or records in a list + * `property`: the property on which to order + * `sequence`: the sequence in which to order" + {:tag [v/required [#(= % :order)]] + [:attrs :property] [v/string v/required] ;; and it must also be the name of a property in the current entity + [:attrs :sequence] [[v/member sequences]] + :content [[v/every documentation-validations]]}) + +(def auxlist-validations + "a subsidiary list, on which entities related to primary + entities in the enclosing page or list are listed + + * `property`: the property of the enclosing entity that this + list displays (obviously, must be of type='list') + * `onselect`: the form or page of the listed entity to call + when an item from the list is selected + * `canadd`: true if the user should be able to add records + to this list" + {:tag [v/required [#(= % :auxlist)]] + [:attrs :property] [v/string v/required] ;; and it must also be the name of a property of type `list` in the current entity + [:attrs :onselect] v/string + [:attrs :canadd] v/boolean + :content [[v/every #(or + (b/valid? % documentation-validations) + (b/valid? % prompt-validations) + (b/valid? % field-validations) + (b/valid? % fieldgroup-validations) + (b/valid? % auxlist-validations) + (b/valid? % verb-validations))]]}) + +(def fieldgroup-validations + "a group of fields and other controls within a form or list, which the + renderer might render as a single pane in a tabbed display, for example." + {:tag [v/required [#(= % :fieldgroup)]] + [:attrs :name] [v/string v/required] + :content [[v/every #(or + (b/valid? % documentation-validations) + (b/valid? % prompt-validations) + (b/valid? % permission-validations) + (b/valid? % help-validations) + (b/valid? % field-validations) + (b/valid? % fieldgroup-validations) + (b/valid? % auxlist-validations) + (b/valid? % verb-validations))]]}) + (def form-validations - {:tag [v/required [#(= % :form)]]}) + "a form through which an entity may be added or edited" + {:tag [v/required [#(= % :form)]] + [:attrs :name] [v/required v/string] + [:attrs :properties] [v/required [v/member #{"all", "user-distinct", "listed"}]] + [:attrs :canadd] v/boolean + :content [[v/every #(or + (b/valid? % documentation-validations) + (b/valid? % head-validations) + (b/valid? % top-validations) + (b/valid? % foot-validations) + (b/valid? % field-validations) + (b/valid? % fieldgroup-validations) + (b/valid? % auxlist-validations) + (b/valid? % verb-validations) + (b/valid? % permission-validations) + (b/valid? % pragma-validations))]]}) (def page-validations - {:tag [v/required [#(= % :page)]]}) + "a page on which an entity may be displayed" + {:tag [v/required [#(= % :page)]] + [:attrs :name] [v/required v/string] + [:attrs :properties] [v/required [v/member #{"all", "user-distinct", "listed"}]] + :content [[v/every #(or + (b/valid? % documentation-validations) + (b/valid? % head-validations) + (b/valid? % top-validations) + (b/valid? % foot-validations) + (b/valid? % field-validations) + (b/valid? % fieldgroup-validations) + (b/valid? % auxlist-validations) + (b/valid? % verb-validations) + (b/valid? % permission-validations) + (b/valid? % pragma-validations) + )]]}) (def list-validations - {:tag [v/required [#(= % :list)]]}) + "a list on which entities of a given type are listed -;; (def prompt-validations -;; {:tag [v/required [#(= % :prompt)]]}) + * `onselect`: name of form/page/list to go to when + a selection is made from the list" + {:tag [v/required [#(= % :list)]] + [:attrs :name] [v/required v/string] + [:attrs :properties] [v/required [v/member #{"all", "user-distinct", "listed"}]] + [:attrs :onselect] v/string + :content [[v/every #(or + (b/valid? % documentation-validations) + (b/valid? % head-validations) + (b/valid? % top-validations) + (b/valid? % foot-validations) + (b/valid? % field-validations) + (b/valid? % fieldgroup-validations) + (b/valid? % auxlist-validations) + (b/valid? % verb-validations) + (b/valid? % permission-validations) + (b/valid? % pragma-validations) + (b/valid? % order-validations) + )]]}) (def key-validations {:tag [v/required [#(= % :key)]] @@ -385,15 +552,15 @@ [:attrs :table] v/string [:attrs :foreign] v/boolean :content [[v/every #(or - (b/validate % documentation-validations) - (b/validate % prompt-validations) - (b/validate % content-validations) - (b/validate % key-validations) - (b/validate % property-validations) - (b/validate % permission-validations) - (b/validate % form-validations) - (b/validate % page-validations) - (b/validate % list-validations) + (b/valid? % documentation-validations) + (b/valid? % prompt-validations) + (b/valid? % content-validations) + (b/valid? % key-validations) + (b/valid? % property-validations) + (b/valid? % permission-validations) + (b/valid? % form-validations) + (b/valid? % page-validations) + (b/valid? % list-validations) )]]}) (def application-validations @@ -403,12 +570,14 @@ [:attrs :revision] v/string [:attrs :currency] v/string :content [[v/every #(or - (b/validate % specification-validations) - (b/validate % documentation-validations) - (b/validate % content-validations) - (b/validate % typedef-validations) - (b/validate % group-validations) - (b/validate % entity-validations))]]}) - + (b/valid? % specification-validations) + (b/valid? % documentation-validations) + (b/valid? % content-validations) + (b/valid? % typedef-validations) + (b/valid? % group-validations) + (b/valid? % entity-validations))]]}) +;; the good news: it's complete. +;; the bad news: it doesn't yet work. +;; TODO: write a function which takes the output of bouncer.core.validate and filters out the paths to those bits which failed. From 8e63f4b6c9134c77c008e9ab2df2ba9e9bcd2fc2 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Tue, 20 Mar 2018 13:22:08 +0000 Subject: [PATCH 09/10] #7 It works, but it isn't actually useful The problem is that bouncer doesn't seem really to support the idea that an object may satisfy one of a set of validations, and that's OK; and it doesn't seem to support collecting nested errors through custom validators. So although this will now tell you *that* an adl structure is invalid, it won't tell you *where* the document is invalid. --- src/squirrel_parse/to_adl.clj | 2 +- src/squirrel_parse/validator.clj | 224 +++++++++++++++++++++---------- 2 files changed, 151 insertions(+), 75 deletions(-) diff --git a/src/squirrel_parse/to_adl.clj b/src/squirrel_parse/to_adl.clj index 937cc91..e274bbc 100644 --- a/src/squirrel_parse/to_adl.clj +++ b/src/squirrel_parse/to_adl.clj @@ -115,7 +115,7 @@ {:tag :prompt :attrs {:prompt name - :local "en-GB"}}}}}}))) + :locale "en-GB"}}}}}}))) (defn make-entity-map [table-decl] diff --git a/src/squirrel_parse/validator.clj b/src/squirrel_parse/validator.clj index 1f1a12d..cc8b9f6 100644 --- a/src/squirrel_parse/validator.clj +++ b/src/squirrel_parse/validator.clj @@ -2,7 +2,6 @@ :author "Simon Brooke"} squirrel-parse.validator (:require [clojure.set :refer [union]] - [clojure.string :as s] [bouncer.core :as b] [bouncer.validators :as v])) @@ -30,7 +29,37 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; this is a fairly straight translation of the ADL 1.4 DTD into Clojure +(defn disjunct-validate + ;; OK, so: most of the validators will (usually) fail, and that's OK. How + ;; do we identify the one which ought not to have failed? + [o & validations] + (let + [rs (map + #(b/validate o %) + validations)] + ;; if *any* succeeded, we succeeded + ;; otherwise, one of these is the valid error - but which? The answer, in my case + ;; is that if there is any which did not fail on the :tag check, then that is the + ;; interesting one. But generally? + (empty? (remove :tag (map first rs))))) + +(v/defvalidator disjunct-validator + ;; OK, so: most of the validators will (usually) fail, and that's OK. How + ;; do we identify the one which ought not to have failed? + {:optional false} + [value & validations] + (let + [rs (map + #(b/validate value %) + validations)] + ;; if *any* succeeded, we succeeded + ;; otherwise, one of these is the valid error - but which? The answer, in my case + ;; is that if there is any which did not fail on the :tag check, then that is the + ;; interesting one. But generally? + (empty? (remove :tag (map first rs))))) + +;;; the remainder of this file is a fairly straight translation of the ADL 1.4 DTD into Clojure + (declare fieldgroup-validations) @@ -241,9 +270,9 @@ {:tag [v/required [#(= % :generator)]] [:attrs :action] [v/string v/required [v/member generator-actions]] [:attrs :class] v/string - :content [[v/every #(or - (b/valid? % documentation-validations) - (b/valid? % param-validations))]]}) + :content [[v/every #(disjunct-validate % + documentation-validations + param-validations)]]}) (def in-implementation-validations @@ -354,23 +383,26 @@ [:attrs :distinct] [v/string [v/member #{"none", "all", "user", "system"}]] [:attrs :entity] v/string [:attrs :farkey] v/string - [:attrs :required] v/boolean - [:attrs :immutable] v/boolean - [:attrs :size] [[#(if + [:attrs :required] [[v/member #{"true", "false"}]] + [:attrs :immutable] [[v/member #{"true", "false"}]] + [:attrs :size] [[#(cond + (empty? %) ;; it's allowed to be missing + true (string? %) (integer? (read-string %)) + true (integer? %))]] [:attrs :column] v/string - [:attrs :concrete] v/boolean + [:attrs :concrete] [[v/member #{"true", "false"}]] [:attrs :cascade] [[v/member cascade-actions]] - :content [[v/every #(or - (b/valid? % documentation-validations) - (b/valid? % generator-validations) - (b/valid? % permission-validations) - (b/valid? % option-validations) - (b/valid? % prompt-validations) - (b/valid? % help-validations) - (b/valid? % ifmissing-validations))]]}) + :content [[v/every #(disjunct-validate % + documentation-validations + generator-validations + permission-validations + option-validations + prompt-validations + help-validations + ifmissing-validations)]]}) (def permission-validations @@ -418,7 +450,7 @@ * `dangerous` true if this verb causes a destructive change." {:tag [v/required [#(= % :verb)]] [:attrs :verb] [v/string v/required] - [:attrs :dangerous] [v/boolean v/required]}) + [:attrs :dangerous] [[v/member #{"true", "false"}] v/required]}) (def order-validations "an ordering or records in a list @@ -472,36 +504,35 @@ {:tag [v/required [#(= % :form)]] [:attrs :name] [v/required v/string] [:attrs :properties] [v/required [v/member #{"all", "user-distinct", "listed"}]] - [:attrs :canadd] v/boolean - :content [[v/every #(or - (b/valid? % documentation-validations) - (b/valid? % head-validations) - (b/valid? % top-validations) - (b/valid? % foot-validations) - (b/valid? % field-validations) - (b/valid? % fieldgroup-validations) - (b/valid? % auxlist-validations) - (b/valid? % verb-validations) - (b/valid? % permission-validations) - (b/valid? % pragma-validations))]]}) + [:attrs :canadd] [[v/member #{"true", "false"}]] + :content [[v/every #(disjunct-validate % + documentation-validations + head-validations + top-validations + foot-validations + field-validations + fieldgroup-validations + auxlist-validations + verb-validations + permission-validations + pragma-validations)]]}) (def page-validations "a page on which an entity may be displayed" {:tag [v/required [#(= % :page)]] [:attrs :name] [v/required v/string] [:attrs :properties] [v/required [v/member #{"all", "user-distinct", "listed"}]] - :content [[v/every #(or - (b/valid? % documentation-validations) - (b/valid? % head-validations) - (b/valid? % top-validations) - (b/valid? % foot-validations) - (b/valid? % field-validations) - (b/valid? % fieldgroup-validations) - (b/valid? % auxlist-validations) - (b/valid? % verb-validations) - (b/valid? % permission-validations) - (b/valid? % pragma-validations) - )]]}) + :content [[v/every #(disjunct-validate % + documentation-validations + head-validations + top-validations + foot-validations + field-validations + fieldgroup-validations + auxlist-validations + verb-validations + permission-validations + pragma-validations)]]}) (def list-validations "a list on which entities of a given type are listed @@ -512,19 +543,18 @@ [:attrs :name] [v/required v/string] [:attrs :properties] [v/required [v/member #{"all", "user-distinct", "listed"}]] [:attrs :onselect] v/string - :content [[v/every #(or - (b/valid? % documentation-validations) - (b/valid? % head-validations) - (b/valid? % top-validations) - (b/valid? % foot-validations) - (b/valid? % field-validations) - (b/valid? % fieldgroup-validations) - (b/valid? % auxlist-validations) - (b/valid? % verb-validations) - (b/valid? % permission-validations) - (b/valid? % pragma-validations) - (b/valid? % order-validations) - )]]}) + :content [[v/every #(disjunct-validate % + documentation-validations + head-validations + top-validations + foot-validations + field-validations + fieldgroup-validations + auxlist-validations + verb-validations + permission-validations + pragma-validations + order-validations)]]}) (def key-validations {:tag [v/required [#(= % :key)]] @@ -550,18 +580,17 @@ [:attrs :name] [v/required v/string] [:attrs :natural-key] v/string [:attrs :table] v/string - [:attrs :foreign] v/boolean - :content [[v/every #(or - (b/valid? % documentation-validations) - (b/valid? % prompt-validations) - (b/valid? % content-validations) - (b/valid? % key-validations) - (b/valid? % property-validations) - (b/valid? % permission-validations) - (b/valid? % form-validations) - (b/valid? % page-validations) - (b/valid? % list-validations) - )]]}) + [:attrs :foreign] [[v/member #{"true", "false"}]] + :content [[v/every #(disjunct-validate % + documentation-validations + prompt-validations + content-validations + key-validations + property-validations + permission-validations + form-validations + page-validations + list-validations)]]}) (def application-validations {:tag [v/required [#(= % :application)]] @@ -569,15 +598,62 @@ [:attrs :version] v/string [:attrs :revision] v/string [:attrs :currency] v/string - :content [[v/every #(or - (b/valid? % specification-validations) - (b/valid? % documentation-validations) - (b/valid? % content-validations) - (b/valid? % typedef-validations) - (b/valid? % group-validations) - (b/valid? % entity-validations))]]}) + :content [[v/every #(disjunct-validate % + specification-validations + documentation-validations + content-validations + typedef-validations + group-validations + entity-validations)]]}) ;; the good news: it's complete. ;; the bad news: it doesn't yet work. ;; TODO: write a function which takes the output of bouncer.core.validate and filters out the paths to those bits which failed. +(defn find-keys + [o p] + (cond + (map? o) + (reduce + merge + {} + (map + (fn [k] + (let [tail (find-keys (o k) p)] ;; error is here + (cond + (not (empty? tail)) + {k tail} + (p k) + {k (o k)} + true + {}))) + (keys o))) + (coll? o) + (remove empty? (map #(find-keys % p) o)))) + +(defn walk-find-keys + [o p] + (walk + #(do %) + #(cond + (map? %) + (reduce + {} + (remove + empty? + (map + (fn [k] + (cond + (p k) + {k (% k)} + (walk-find-keys (% k) p) + {k (walk-find-keys (% k) p)})) + (keys %)))) + (coll? %) + (remove + empty? + (map + (fn [e] + (walk-find-keys e p)) + %))) + o)) From 12424d70997e9e196ae0e3747f6a763bd5b8bf4d Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Tue, 20 Mar 2018 13:40:04 +0000 Subject: [PATCH 10/10] #7: Sort of done. Not proud of this. It prints errors to STDOUT, but does not return a sensible value. However, it will do for now. --- src/squirrel_parse/validator.clj | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/squirrel_parse/validator.clj b/src/squirrel_parse/validator.clj index cc8b9f6..1e8e194 100644 --- a/src/squirrel_parse/validator.clj +++ b/src/squirrel_parse/validator.clj @@ -33,15 +33,19 @@ ;; OK, so: most of the validators will (usually) fail, and that's OK. How ;; do we identify the one which ought not to have failed? [o & validations] + (println (str "Tag: " (:tag o) "; name: " (:name (:attrs o)))) (let [rs (map #(b/validate o %) - validations)] + validations) + all-candidates (remove nil? (map first rs)) + suspicious (remove :tag all-candidates)] ;; if *any* succeeded, we succeeded ;; otherwise, one of these is the valid error - but which? The answer, in my case ;; is that if there is any which did not fail on the :tag check, then that is the ;; interesting one. But generally? - (empty? (remove :tag (map first rs))))) + (doall (map #(println (str "\tError: " %)) suspicious)) + (empty? suspicious))) (v/defvalidator disjunct-validator ;; OK, so: most of the validators will (usually) fail, and that's OK. How