From b944aa6bf16f462868eecbecca4fba58bc64167e Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 22 May 2025 11:43:48 +0100 Subject: [PATCH] Lots of work on trying to get all validator tests to pass. Three still fail, but substantial progress. The to-husql-queries tests are failing much worse, but are not a current target (nor is the validator, frankly, but it irks me that it is so broken) --- project.clj | 10 +- src/adl/to_hugsql_queries.clj | 658 ++++++++++++++-------------- src/adl/to_psql.clj | 8 +- src/adl/validator.clj | 290 ++++++------ test/adl/to_hugsql_queries_test.clj | 313 +++++++------ test/adl/validator_test.clj | 37 +- 6 files changed, 677 insertions(+), 639 deletions(-) diff --git a/project.clj b/project.clj index c20cfb3..f07537d 100644 --- a/project.clj +++ b/project.clj @@ -5,14 +5,14 @@ :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.6"] + :dependencies [[adl-support "0.1.8-SNAPSHOT"] [bouncer "1.0.1"] [clojure-saxon "0.9.4"] - [environ "1.1.0"] + [environ "1.2.0"] [hiccup "1.0.5"] - [org.clojure/clojure "1.8.0"] - [org.clojure/math.combinatorics "0.1.4"] - [org.clojure/tools.cli "0.3.7"]] + [org.clojure/clojure "1.12.0"] + [org.clojure/math.combinatorics "0.3.0"] + [org.clojure/tools.cli "1.1.230"]] :aot [adl.main] diff --git a/src/adl/to_hugsql_queries.clj b/src/adl/to_hugsql_queries.clj index b10b2bd..1d5a160 100644 --- a/src/adl/to_hugsql_queries.clj +++ b/src/adl/to_hugsql_queries.clj @@ -1,14 +1,12 @@ (ns ^{:doc "Application Description Language - generate HUGSQL queries file." - :author "Simon Brooke"} + :author "Simon Brooke"} adl.to-hugsql-queries - (:require [adl-support.core :refer :all] - [adl-support.utils :refer :all] - [clojure.java.io :refer [file make-parents]] - [clojure.math.combinatorics :refer [combinations]] - [clojure.string :as s] - [clojure.xml :as x] - [clj-time.core :as t] - [clj-time.format :as f])) + (:require [adl-support.core :refer :all] + [adl-support.utils :refer :all] + [clojure.java.io :refer [make-parents]] + [clojure.math.combinatorics :refer [combinations]] + [clojure.string :as s] + [clj-time.core :as t])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; @@ -33,78 +31,78 @@ ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(def expanded-token "_expanded") + (def expanded-token "_expanded") -(defn where-clause - "Generate an appropriate `where` clause for queries on this `entity`; + (defn where-clause + "Generate an appropriate `where` clause for queries on this `entity`; if `properties` are passed, filter on those properties, otherwise the key properties." - ([entity] - (where-clause entity (key-properties entity))) - ([entity properties] - (let + ([entity] + (where-clause entity (key-properties entity))) + ([entity properties] + (let [entity-name (safe-name entity :sql) property-names (map #(:name (:attrs %)) properties)] - (if-not (empty? property-names) - (str + (when-not (empty? property-names) + (str "WHERE " (s/join - "\n\tAND " - (map - #(str entity-name "." (safe-name % :sql) " = :" %) - property-names))))))) + "\n\tAND " + (map + #(str entity-name "." (safe-name % :sql) " = :" %) + property-names))))))) -(defn order-by-clause - "Generate an appropriate `order by` clause for queries on this `entity`" - ([entity] - (order-by-clause entity "" false)) - ([entity prefix] - (order-by-clause entity prefix false)) - ([entity prefix expanded?] - (let + (defn order-by-clause + "Generate an appropriate `order by` clause for queries on this `entity`" + ([entity] + (order-by-clause entity "" false)) + ([entity prefix] + (order-by-clause entity prefix false)) + ([entity prefix expanded?] + (let [entity-name (safe-name entity :sql) preferred (filter #(#{"user" "all"} (-> % :attrs :distinct)) (descendants-with-tag entity :property))] - (if + (if (empty? preferred) - "" - (str + "" + (str "ORDER BY " prefix entity-name "." (s/join - (str ",\n\t" prefix entity-name ".") - (map - #(if - (and expanded? (= "entity" (-> % :attrs :type))) - (str (safe-name % :sql) expanded-token) - (safe-name % :sql)) - (order-preserving-set - (concat - preferred - (key-properties entity)))))))))) + (str ",\n\t" prefix entity-name ".") + (map + #(if + (and expanded? (= "entity" (-> % :attrs :type))) + (str (safe-name % :sql) expanded-token) + (safe-name % :sql)) + (order-preserving-set + (concat + preferred + (key-properties entity)))))))))) ;; (def a (x/parse "../youyesyet/youyesyet.adl.xml")) ;; (def e (child-with-tag a :entity #(= "dwellings" (-> % :attrs :name)))) ;; (order-by-clause e "" true) -(defn insert-query - "Generate an appropriate `insert` query for this `entity`. + (defn insert-query + "Generate an appropriate `insert` query for this `entity`. TODO: this depends on the idea that system-unique properties are not insertable, which is... dodgy." - [entity] - (let [entity-name (safe-name entity :sql) - pretty-name (singularise entity-name) - insertable-property-names (map + [entity] + (let [entity-name (safe-name entity :sql) + pretty-name (singularise entity-name) + insertable-property-names (map #(safe-name % :sql) (insertable-properties entity)) - query-name (str "create-" pretty-name "!") - signature (if (has-primary-key? entity) - ":? :1" ;; bizarrely, if you want to return the keys, + query-name (str "create-" pretty-name "!") + signature (if (has-primary-key? entity) + ":? :1" ;; bizarrely, if you want to return the keys, ;; you have to use a query signature. - ":! :n")] - (hash-map + ":! :n")] + (hash-map (keyword query-name) {:name query-name :signature signature @@ -119,26 +117,26 @@ (s/join ",\n\t" (map keyword insertable-property-names)) ")" (if - (has-primary-key? entity) + (has-primary-key? entity) (str "\nreturning " (s/join - ",\n\t" - (map - #(safe-name % :sql) - (key-names entity))))))}))) + ",\n\t" + (map + #(safe-name % :sql) + (key-names entity))))))}))) -(defn update-query - "Generate an appropriate `update` query for this `entity`" - [entity] - (let [entity-name (safe-name entity :sql) - pretty-name (singularise entity-name) - property-names (map + (defn update-query + "Generate an appropriate `update` query for this `entity`" + [entity] + (let [entity-name (safe-name entity :sql) + pretty-name (singularise entity-name) + property-names (map #(-> % :attrs :name) (insertable-properties entity)) - query-name (str "update-" pretty-name "!") - signature ":! :n"] - (hash-map + query-name (str "update-" pretty-name "!") + signature ":! :n"] + (hash-map (keyword query-name) {:name query-name :signature signature @@ -150,114 +148,121 @@ "UPDATE " entity-name "\n" "SET " (s/join - ",\n\t" - (map - #(str (safe-name % :sql) " = " (keyword %)) - property-names)) + ",\n\t" + (map + #(str (safe-name % :sql) " = " (keyword %)) + property-names)) "\n" (where-clause entity))}))) -(defn search-query [entity application] - "Generate an appropriate search query for string fields of this `entity`" + (defn search-query + "Generate an appropriate search query for string fields of this `entity`. + + Unused second argument was `application`, and is retained for backward + compatibility." + ([entity _] + (search-query entity)) + ([entity] (let [entity-name (safe-name entity :sql) pretty-name (singularise entity-name) query-name (str "search-strings-" entity-name) signature ":? :*" - properties (remove #(#{"(safe-name entity :sql)"}(:type (:attrs %))) (all-properties entity))] + properties (remove #(#{"(safe-name entity :sql)"} (:type (:attrs %))) (all-properties entity))] (hash-map - (keyword query-name) - {:name query-name - :signature signature - :entity entity - :type :text-search - :query - (s/join - "\n" - (remove - empty? - (list - (str "-- :name " query-name " " signature) - (str - "-- :doc selects existing " - pretty-name - " records having any string field matching the parameter of the same name by substring match") - (str "SELECT DISTINCT * FROM lv_" entity-name) - (s/join - "\n\t--~ " - (cons - "WHERE true" - (filter - string? - (map - #(let - [sn (safe-name % :sql)] - (str - "(if (:" (-> % :attrs :name) " params) (str \"AND " - (case (-> % :attrs :type) - ("string" "text") - (str - sn - " LIKE '%\" (:" (-> % :attrs :name) " params) \"%' ") - ("date" "time" "timestamp") - (str - sn - " = ':" (-> % :attrs :name) "'") - "entity" - (str - sn - "_expanded LIKE '%\" (:" (-> % :attrs :name) " params) \"%'") - (str - sn - " = :" - (-> % :attrs :name))) - "\"))")) - properties)))) - (order-by-clause entity "lv_" true) - "--~ (if (:offset params) \"OFFSET :offset \")" - "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))}))) + (keyword query-name) + {:name query-name + :signature signature + :entity entity + :type :text-search + :query + (s/join + "\n" + (remove + empty? + (list + (str "-- :name " query-name " " signature) + (str + "-- :doc selects existing " + pretty-name + " records having any string field matching the parameter of the same name by substring match") + (str "SELECT DISTINCT * FROM lv_" entity-name) + (s/join + "\n\t--~ " + (cons + "WHERE true" + (filter + string? + (map + #(let + [sn (safe-name % :sql)] + (str + "(if (:" (-> % :attrs :name) " params) (str \"AND " + (case (-> % :attrs :type) + ("string" "text") + (str + sn + " LIKE '%\" (:" (-> % :attrs :name) " params) \"%' ") + ("date" "time" "timestamp") + (str + sn + " = ':" (-> % :attrs :name) "'") + "entity" + (str + sn + "_expanded LIKE '%\" (:" (-> % :attrs :name) " params) \"%'") + (str + sn + " = :" + (-> % :attrs :name))) + "\"))")) + properties)))) + (order-by-clause entity "lv_" true) + "--~ (if (:offset params) \"OFFSET :offset \")" + "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))})))) ;; (search-query e a) - (defn select-query "Generate an appropriate `select` query for this `entity`" ([entity properties] (if-not - (empty? properties) + (empty? properties) (let [entity-name (safe-name entity :sql) pretty-name (singularise entity-name) query-name (if (= properties (key-properties entity)) (str "get-" pretty-name) - (str "get-" pretty-name "-by-" (s/join "=" (map #(:name (:attrs %)) properties)))) + (str "get-" pretty-name "-by-" + (s/join "=" + (map #(:name (:attrs %)) properties)))) signature ":? :1"] (hash-map - (keyword query-name) - {:name query-name - :signature signature - :entity entity - :type :select-1 - :query - (s/join - "\n" - (remove - empty? - (list - (str "-- :name " query-name " " signature) - (str "-- :doc selects an existing " pretty-name " record") - (str "SELECT * FROM " entity-name) - (where-clause entity properties) - (order-by-clause entity))))})) + (keyword query-name) + {:name query-name + :signature signature + :entity entity + :type :select-1 + :query + (s/join + "\n" + (remove + empty? + (list + (str "-- :name " query-name " " signature) + (str "-- :doc selects an existing " pretty-name " record") + (str "SELECT * FROM " entity-name) + (where-clause entity properties) + (order-by-clause entity))))})) {})) ([entity] (let [distinct-fields (distinct-properties entity)] (apply - merge - (cons - (select-query entity (key-properties entity)) - (map - #(select-query entity %) - (combinations distinct-fields (count distinct-fields)))))))) + merge + (cons + (select-query entity (key-properties entity)) + (map + #(select-query entity %) + (combinations distinct-fields (count distinct-fields)))))))) (defn list-query @@ -270,23 +275,23 @@ query-name (str "list-" entity-name) signature ":? :*"] (hash-map - (keyword query-name) - {:name query-name - :signature signature - :entity entity - :type :select-many - :query - (s/join - "\n" - (remove - empty? - (list - (str "-- :name " query-name " " signature) - (str "-- :doc lists all existing " pretty-name " records") - (str "SELECT DISTINCT lv_" entity-name ".* FROM lv_" entity-name) - (order-by-clause entity "lv_" false) - "--~ (if (:offset params) \"OFFSET :offset \")" - "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))}))) + (keyword query-name) + {:name query-name + :signature signature + :entity entity + :type :select-many + :query + (s/join + "\n" + (remove + empty? + (list + (str "-- :name " query-name " " signature) + (str "-- :doc lists all existing " pretty-name " records") + (str "SELECT DISTINCT lv_" entity-name ".* FROM lv_" entity-name) + (order-by-clause entity "lv_" false) + "--~ (if (:offset params) \"OFFSET :offset \")" + "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))}))) (defn foreign-queries @@ -297,84 +302,83 @@ entity-safe (safe-name entity :sql) links (filter #(:entity (:attrs %)) (children-with-tag entity :property))] (apply - merge - (map - #(let [far-name (:entity (:attrs %)) - far-entity (first - (children - application - (fn [x] - (and - (= (:tag x) :entity) - (= (:name (:attrs x)) far-name))))) - pretty-far (singularise far-name) - safe-far (safe-name far-entity :sql) - farkey (-> % :attrs :farkey) - link-type (-> % :attrs :type) - link-field (-> % :attrs :name) - query-name (list-related-query-name % entity far-entity false) - signature ":? :*"] - (hash-map - (keyword query-name) - {:name query-name - :signature signature - :entity entity - :type :select-one-to-many - :far-entity far-entity - :query - (s/join - "\n" - (remove - empty? - (case link-type - "entity" (list - (str "-- :name " query-name " " signature) - (str "-- :doc lists all existing " pretty-far " records related to a given " pretty-name) - (str "SELECT DISTINCT lv_" entity-safe ".* \nFROM lv_" entity-safe) - (str "WHERE lv_" entity-safe "." (safe-name % :sql) " = :id") - (order-by-clause entity "lv_" false)) - "link" (let [ltn - (link-table-name % entity far-entity)] - (list - (str "-- :name " query-name " " signature) - (str "-- :doc links all existing " pretty-far " records related to a given " pretty-name) - (str "SELECT DISTINCT lv_" safe-far ".* \nFROM lv_" safe-far ", " ltn) - (str "WHERE lv_" safe-far "." - (safe-name (first (key-names far-entity)) :sql) - " = " ltn "." (singularise safe-far) "_id") - (str "\tAND " ltn "." (singularise entity-safe) "_id = :id") - (order-by-clause far-entity "lv_" false))) - "list" (list - (str "-- :name " query-name " " signature) - (str "-- :doc lists all existing " pretty-far " records related to a given " pretty-name) - (str "SELECT DISTINCT lv_" safe-far ".* \nFROM lv_" safe-far) - (str "WHERE lv_" safe-far "." (safe-name (first (key-names far-entity)) :sql) " = :id") - (order-by-clause far-entity "lv_" false)) - (list (str "ERROR: unexpected type " link-type " of property " %))))) - })) - links)))) + merge + (map + #(let [far-name (:entity (:attrs %)) + far-entity (first + (children + application + (fn [x] + (and + (= (:tag x) :entity) + (= (:name (:attrs x)) far-name))))) + pretty-far (singularise far-name) + safe-far (safe-name far-entity :sql) + farkey (-> % :attrs :farkey) + link-type (-> % :attrs :type) + link-field (-> % :attrs :name) + query-name (list-related-query-name % entity far-entity false) + signature ":? :*"] + (hash-map + (keyword query-name) + {:name query-name + :signature signature + :entity entity + :type :select-one-to-many + :far-entity far-entity + :query + (s/join + "\n" + (remove + empty? + (case link-type + "entity" (list + (str "-- :name " query-name " " signature) + (str "-- :doc lists all existing " pretty-far " records related to a given " pretty-name) + (str "SELECT DISTINCT lv_" entity-safe ".* \nFROM lv_" entity-safe) + (str "WHERE lv_" entity-safe "." (safe-name % :sql) " = :id") + (order-by-clause entity "lv_" false)) + "link" (let [ltn + (link-table-name % entity far-entity)] + (list + (str "-- :name " query-name " " signature) + (str "-- :doc links all existing " pretty-far " records related to a given " pretty-name) + (str "SELECT DISTINCT lv_" safe-far ".* \nFROM lv_" safe-far ", " ltn) + (str "WHERE lv_" safe-far "." + (safe-name (first (key-names far-entity)) :sql) + " = " ltn "." (singularise safe-far) "_id") + (str "\tAND " ltn "." (singularise entity-safe) "_id = :id") + (order-by-clause far-entity "lv_" false))) + "list" (list + (str "-- :name " query-name " " signature) + (str "-- :doc lists all existing " pretty-far " records related to a given " pretty-name) + (str "SELECT DISTINCT lv_" safe-far ".* \nFROM lv_" safe-far) + (str "WHERE lv_" safe-far "." (safe-name (first (key-names far-entity)) :sql) " = :id") + (order-by-clause far-entity "lv_" false)) + (list (str "ERROR: unexpected type " link-type " of property " %)))))})) + links)))) (defn delete-query "Generate an appropriate `delete` query for this `entity`" [entity] (if - (has-primary-key? entity) + (has-primary-key? entity) (let [entity-name (safe-name entity :sql) 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 - :type :delete-1 - :query - (str "-- :name " query-name " " signature "\n" - "-- :doc deletes an existing " pretty-name " record\n" - "DELETE FROM " entity-name "\n" - (where-clause entity))})))) + (keyword query-name) + {:name query-name + :signature signature + :entity entity + :type :delete-1 + :query + (str "-- :name " query-name " " signature "\n" + "-- :doc deletes an existing " pretty-name " record\n" + "DELETE FROM " entity-name "\n" + (where-clause entity))})))) (defn queries @@ -383,18 +387,18 @@ ([application entity] (merge ;; TODO: queries that look through link tables - (insert-query entity) - (update-query entity) - (delete-query entity) - (select-query entity) - (list-query entity) - (search-query entity application) - (foreign-queries entity application))) + (insert-query entity) + (update-query entity) + (delete-query entity) + (select-query entity) + (list-query entity) + (search-query entity application) + (foreign-queries entity application))) ([application] (apply - merge - (map #(queries application %) - (children-with-tag application :entity))))) + merge + (map #(queries application %) + (children-with-tag application :entity))))) (defn to-hugsql-queries @@ -403,25 +407,25 @@ (let [filepath (str *output-path* "resources/sql/queries.auto.sql")] (make-parents filepath) (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 (pos? *verbosity*) - (*warn* (str "\tGenerated " filepath))))))) + (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 (pos? *verbosity*) + (*warn* (str "\tGenerated " filepath))))))) (defn generate-documentation @@ -429,68 +433,68 @@ [query] (let [v (volatility (:entity query))] (s/join - " " - (list - (case - (:type query) - :delete-1 - (str "delete one record from the `" - (-> query :entity :attrs :name) - "` table. Expects the following key(s) to be present in `params`: `" - (-> query :entity key-names) - "`.") - :insert-1 - (str "insert one record to the `" - (-> query :entity :attrs :name) - "` table. Expects the following key(s) to be present in `params`: `" - (pr-str - (map - #(keyword (:name (:attrs %))) - (-> query :entity insertable-properties ))) - "`. Returns a map containing the keys `" - (-> query :entity key-names) - "` identifying the record created.") - :select-1 - (str "select one record from the `" - (-> query :entity :attrs :name) - "` table. Expects the following key(s) to be present in `params`: `" - (-> query :entity key-names) - "`. Returns a map containing the following keys: `" - (map #(keyword (:name (:attrs %))) (-> query :entity all-properties)) - "`.") - :select-many - (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 - (map - #(keyword (:name (:attrs %))) - (-> query :entity all-properties))) - "`.") - :text-search - (str "select all records from the `" - (-> query :entity :attrs :name) + " " + (list + (case + (:type query) + :delete-1 + (str "delete one record from the `" + (-> query :entity :attrs :name) + "` table. Expects the following key(s) to be present in `params`: `" + (-> query :entity key-names) + "`.") + :insert-1 + (str "insert one record to the `" + (-> query :entity :attrs :name) + "` table. Expects the following key(s) to be present in `params`: `" + (pr-str + (map + #(keyword (:name (:attrs %))) + (-> query :entity insertable-properties))) + "`. Returns a map containing the keys `" + (-> query :entity key-names) + "` identifying the record created.") + :select-1 + (str "select one record from the `" + (-> query :entity :attrs :name) + "` table. Expects the following key(s) to be present in `params`: `" + (-> query :entity key-names) + "`. Returns a map containing the following keys: `" + (map #(keyword (:name (:attrs %))) (-> query :entity all-properties)) + "`.") + :select-many + (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 + (map + #(keyword (:name (:attrs %))) + (-> query :entity all-properties))) + "`.") + :text-search + (str "select all records from the `" + (-> query :entity :attrs :name) ;; TODO: this doc-string is out of date - "` 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 - (map - #(keyword (:name (:attrs %))) - (-> query :entity all-properties))) - "`.") - :update-1 - (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 - (map - #(keyword (:name (:attrs %))) - (flatten - (cons - (-> query :entity key-properties) - (-> query :entity insertable-properties))))))) - "`.")) - (if-not - (zero? v) - (str "Results will be held in cache for " v " seconds.")))))) + "` 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 + (map + #(keyword (:name (:attrs %))) + (-> query :entity all-properties))) + "`.") + :update-1 + (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 + (map + #(keyword (:name (:attrs %))) + (flatten + (cons + (-> query :entity key-properties) + (-> query :entity insertable-properties))))))) + "`.")) + (if-not + (zero? v) + (str "Results will be held in cache for " v " seconds.")))))) diff --git a/src/adl/to_psql.clj b/src/adl/to_psql.clj index b3dd1f8..8109b94 100644 --- a/src/adl/to_psql.clj +++ b/src/adl/to_psql.clj @@ -3,10 +3,9 @@ adl.to-psql (: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]] + ;; [adl.to-hugsql-queries :refer [queries]] + [clojure.java.io :refer [make-parents]] [clojure.string :as s] - [clojure.xml :as x] [clj-time.core :as t] [clj-time.format :as f])) @@ -220,7 +219,7 @@ (if key? "NOT NULL PRIMARY KEY" - (if (= (:required (:attrs property)) "true") "NOT NULL")))))))))) + (when (= (:required (:attrs property)) "true") "NOT NULL")))))))))) (defn compose-convenience-entity-field @@ -259,6 +258,7 @@ (all-properties entity) (user-distinct-properties entity))))))) +(declare compose-convenience-where-clause) (defn compose-convenience-where-clause "Compose an SQL `WHERE` clause for a convenience view of this diff --git a/src/adl/validator.clj b/src/adl/validator.clj index 6bb57dc..8103851 100644 --- a/src/adl/validator.clj +++ b/src/adl/validator.clj @@ -1,12 +1,12 @@ (ns ^{:doc "Application Description Language: validator for ADL structure. TODO: this is at present largely a failed experiment." :author "Simon Brooke"} - adl.validator - (:require [adl-support.utils :refer :all] + adl.validator + (:require [adl-support.utils :refer []] [clojure.set :refer [union]] [clojure.xml :refer [parse]] [bouncer.core :as b] - [bouncer.validators :as v])) + [bouncer.validators :as v :refer [every member required string]])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; @@ -40,14 +40,14 @@ "Pass this `validation` and the object `o` to bouncer" [o validation] (if - (symbol? validation) + (symbol? validation) (try (b/validate o validation) - (catch java.lang.ClassCastException c + (catch java.lang.ClassCastException _ ;; The validator regularly barfs on strings, which are perfectly ;; valid content of some elements. I need a way to validate ;; elements where they're not tolerated! - (if (string? o) [nil o])) + (when (string? o) [nil o])) (catch Exception e [{:error (.getName (.getClass e)) :message (.getMessage e) @@ -55,27 +55,26 @@ :context o} o])) [(str "Error: not a symbol" validation) o])) -(defmacro disjunct-valid? +(defn disjunct-valid? "Yes, this is a horrible hack. I should be returning the error structure not printing it. But I can't see how to make that work with `bouncer`. 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 + (println (str - (if (:tag ~o) (str "Tag: " (:tag ~o) "; ")) - (if (:name (:attrs ~o)) (str "Name: " (:name (:attrs ~o)) ";")) - (if-not (or (:tag ~o) (:name (:attrs ~o))) (str "Context: " ~o)))) + (when (:tag o) (str "Tag: " (:tag o) "; ")) + (when (:name (:attrs o)) (str "Name: " (:name (:attrs o)) ";")) + (when-not (or (:tag o) (:name (:attrs o))) (str "Context: " o)))) - `(empty? - (remove :tag (remove nil? (map first (map - #(try-validate ~o '%) - ~validations)))))) + (empty? + (remove :tag (remove nil? (map first (map + #(try-validate o '%) + validations)))))) ;;; the remainder of this file is a fairly straight translation of the ADL 1.4 DTD into Clojure - -(declare documentation-validations fieldgroup-validations ) +(declare documentation-validations fieldgroup-validations) (def permissions "permissions a group may have on an entity, list, page, form or field @@ -106,7 +105,7 @@ #{"all", "all-delete-orphan", "delete", "manual", "save-update"}) (def defineable-data-types - "data types which can be used in a typedef to provide validation - + "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 @@ -129,8 +128,8 @@ * `text`: text or java.sql.Types.LONGVARCHAR memo java.sql.Types.CLOB" (union - defineable-data-types - #{"boolean" "text"})) + defineable-data-types + #{"boolean" "text"})) (def complex-data-types "data types which are more complex than SimpleDataTypes... @@ -170,7 +169,7 @@ (def sequences #{"canonical", "reverse-canonical"}) (def reference-validations -"The 'specification' and 'reference' elements are for documentation only, + "The 'specification' and 'reference' elements are for documentation only, and do not contribute to the engineering of the application described. A reference element is a reference to a specifying document. @@ -191,9 +190,18 @@ [:attrs :property] v/string ;; and should be the name of a property in that entity :content [[v/every documentation-validations]]}) +;; (def sample-reference {:tag :reference +;; :attrs {:abbr "foo" +;; :section "bar" +;; :entity "animal" +;; :property "breed"} +;; :content [{:tag :documentation +;; :content ["Every animal should have a breed."]}]}) + +;; (b/validate sample-reference reference-validations) (def specification-validations - "The 'specification' and 'reference' elements are for documentation only, + "The 'specification' and 'reference' elements are for documentation only, and do not contribute to the engineering of the application described. A specification element is intended chiefly to declare the reference @@ -208,26 +216,33 @@ [:attrs :name] [v/string v/required] [:attrs :abbr] [v/string v/required] :content [[v/every #(disjunct-valid? + % documentation-validations reference-validations)]]}) (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?" + "contains documentation on the element which immediately contains it. For + the time being, HTML markup is not permitted within documentation, but + Markdown (which may include a string representation of HTML markup) should + be." {:tag [v/required [#(= % :documentation)]] - :content [[v/every #(disjunct-valid? - % + :content [[v/every #(disjunct-valid? + % v/string - reference-validations)]] - }) + reference-validations)]]}) + +;; (def sample-documentation {:tag :documentation +;; :content ["Every animal should have a breed." +;; sample-reference]}) +;; (b/validate sample-documentation documentation-validations) +;; (b/valid? sample-documentation documentation-validations) (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 + "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. @@ -267,7 +282,7 @@ (def prompt-validations - "a prompt for a property or field; used as the prompt text for a widget + "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. @@ -293,6 +308,17 @@ (b/valid? % documentation-validations) (b/valid? % prompt-validations))]]}) +(def sample-option {:tag :option, + :attrs {:value "Female"}, + :content + [{:tag :prompt, + :attrs {:locale "fr-FR", :prompt "Femme"}, + :content nil} + {:tag :prompt, + :attrs {:locale "en-GB", :prompt "Female"}, + :content nil}]}) +(b/validate sample-option option-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 @@ -302,8 +328,6 @@ [: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 @@ -320,8 +344,8 @@ [:attrs :action] [v/string v/required [v/member generator-actions]] [:attrs :class] v/string :content [[v/every #(disjunct-valid? % - documentation-validations - param-validations)]]}) + documentation-validations + param-validations)]]}) (def in-implementation-validations @@ -359,22 +383,22 @@ [:attrs :name] [v/required v/string] [:attrs :type] [[v/member defineable-data-types]] [:attrs :size] [[#(if - (string? %) + (string? %) (integer? (read-string %)) (integer? %))]] [:attrs :pattern] v/string [:attrs :minimum] [[#(if - (string? %) + (string? %) (integer? (read-string %)) (integer? %))]] [:attrs :maximum] [[#(if - (string? %) + (string? %) (integer? (read-string %)) (integer? %))]] :content [[v/every #(or - (b/valid? % documentation-validations) - (b/valid? % in-implementation-validations) - (b/valid? % 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 @@ -387,7 +411,7 @@ :content [[v/every documentation-validations]]}) (def property-validations - "a property (field) of an entity (table) + "a property (field) of an entity (table) * `name`: the name of this property. * `type`: the type of this property. @@ -425,35 +449,55 @@ 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] [] ;; 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/member #{"true", "false"}]] [:attrs :immutable] [[v/member #{"true", "false"}]] + [:attrs :name] [v/required v/string] + [:attrs :required] [[v/member #{"true", "false"}]] [:attrs :size] [[#(cond - (empty? %) ;; it's allowed to be missing - true + (empty? %) ;; it's allowed to be missing + true (string? %) (integer? (read-string %)) - true + :else (integer? %))]] + [:attrs :type] [v/required [v/member all-data-types]] + ;; [:attrs :default] [] ;; it's allowed, but I don't have anything particular to say about it + [:attrs :typedef] v/string + [:attrs :cascade] [[v/member cascade-actions]] [:attrs :column] v/string [:attrs :concrete] [[v/member #{"true", "false"}]] - [:attrs :cascade] [[v/member cascade-actions]] -;; :content [[v/every #(disjunct-valid? % -;; documentation-validations -;; generator-validations -;; permission-validations -;; option-validations -;; prompt-validations -;; help-validations -;; ifmissing-validations)]] + :content [[v/every #(disjunct-valid? % + documentation-validations + generator-validations + permission-validations + option-validations + prompt-validations + help-validations + ifmissing-validations)]] }) +;; (disjunct-valid? sample-option documentation-validations +;; generator-validations +;; permission-validations +;; option-validations +;; prompt-validations +;; help-validations +;; ifmissing-validations) + +;; (def sample-property {:tag :property, +;; :attrs +;; {:immutable "true", +;; :required "true", +;; :distinct "system", +;; :type "integer", +;; :name "id"}, +;; :content +;; [{:tag :generator, :attrs {:action "native"}, :content nil}]}) + +;; (b/validate sample-property property-validations) + (def permission-validations "permissions policy on an entity, a page, form, list or field @@ -486,10 +530,10 @@ {: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))]]}) + (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' @@ -526,12 +570,12 @@ [: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))]]}) + (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 @@ -539,14 +583,14 @@ {: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))]]}) + (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 @@ -556,16 +600,16 @@ [:attrs :properties] [v/required [v/member #{"all", "user-distinct", "listed"}]] [:attrs :canadd] [[v/member #{"true", "false"}]] :content [[v/every #(disjunct-valid? % - documentation-validations - head-validations - top-validations - foot-validations - field-validations - fieldgroup-validations - auxlist-validations - verb-validations - permission-validations - pragma-validations)]]}) + 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" @@ -573,16 +617,16 @@ [:attrs :name] [v/required v/string] [:attrs :properties] [v/required [v/member #{"all", "user-distinct", "listed"}]] :content [[v/every #(disjunct-valid? % - documentation-validations - head-validations - top-validations - foot-validations - field-validations - fieldgroup-validations - auxlist-validations - verb-validations - permission-validations - pragma-validations)]]}) + 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 @@ -594,17 +638,17 @@ [:attrs :properties] [v/required [v/member #{"all", "user-distinct", "listed"}]] [:attrs :onselect] v/string :content [[v/every #(disjunct-valid? % - documentation-validations - head-validations - top-validations - foot-validations - field-validations - fieldgroup-validations - auxlist-validations - verb-validations - permission-validations - pragma-validations - order-validations)]]}) + 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)]] @@ -632,15 +676,15 @@ [:attrs :table] v/string [:attrs :foreign] [[v/member #{"true", "false"}]] :content [[v/every #(disjunct-valid? % - documentation-validations - prompt-validations - content-validations - key-validations - property-validations - permission-validations - form-validations - page-validations - list-validations)]]}) + 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)]] @@ -649,12 +693,12 @@ [:attrs :revision] v/string [:attrs :currency] v/string :content [[v/every #(disjunct-valid? % - specification-validations - documentation-validations - content-validations - typedef-validations - group-validations - entity-validations)]]}) + specification-validations + documentation-validations + content-validations + typedef-validations + group-validations + entity-validations)]]}) (defn valid-adl? diff --git a/test/adl/to_hugsql_queries_test.clj b/test/adl/to_hugsql_queries_test.clj index 513a57e..4bccbea 100644 --- a/test/adl/to_hugsql_queries_test.clj +++ b/test/adl/to_hugsql_queries_test.clj @@ -1,109 +1,104 @@ (ns adl.to-hugsql-queries-test (:require [clojure.string :as s] - [clojure.test :refer :all] - [adl.to-hugsql-queries :refer :all] - [adl-support.utils :refer :all])) + [clojure.test :refer [deftest is testing]] + [adl.to-hugsql-queries :refer [delete-query insert-query list-query order-by-clause search-query select-query update-query]] + [adl-support.utils :refer [child-with-tag has-non-key-properties? has-primary-key? key-names]])) (defn string-equal-ignore-whitespace? "I don't want unit tests to fail just because emitted whitespace changes." [a b] (if - (and - (string? a) - (string? b)) - (let + (and + (string? a) + (string? b)) + (let [pattern #"[\s]+" aa (s/replace a pattern " ") bb (s/replace b pattern " ")] - (= aa bb)) + (= aa bb)) (= a b))) (deftest order-by-tests (let [application {:tag :application, - :attrs {:version "0.1.1", :name "test-app"}, - :content - [{:tag :entity, - :attrs {:name "address"}, - :content - [{:tag :key, - :attrs nil, - :content - [{: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} - ]}]} + :attrs {:version "0.1.1", :name "test-app"}, + :content + [{:tag :entity, + :attrs {:name "address"}, + :content + [{:tag :key, + :attrs nil, + :content + [{: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" + (testing "user distinct properties should provide the default ordering" (let [expected "ORDER BY address.street, address.postcode, address.id" actual (order-by-clause entity)] (is (string-equal-ignore-whitespace? actual expected)))))) - (deftest keys-name-extraction-tests - (let [application {:tag :application, - :attrs {:version "0.1.1", :name "test-app"}, - :content - [{:tag :entity, - :attrs {:name "address"}, - :content - [{:tag :key, - :attrs nil, - :content - [{: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} - ]}]} + (let [application {:tag :application, + :attrs {:version "0.1.1", :name "test-app"}, + :content + [{:tag :entity, + :attrs {:name "address"}, + :content + [{:tag :key, + :attrs nil, + :content + [{: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 "keys name extraction" (let [expected #{"id" "postcode"} @@ -113,43 +108,41 @@ (deftest entity-tests (let [application {:tag :application, - :attrs {:version "0.1.1", :name "test-app"}, - :content - [{:tag :entity, - :attrs {:name "address"}, - :content - [{:tag :key, - :attrs nil, - :content - [{: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} - ]}]} + :attrs {:version "0.1.1", :name "test-app"}, + :content + [{:tag :entity, + :attrs {:name "address"}, + :content + [{:tag :key, + :attrs nil, + :content + [{: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 "keys name extraction" (let [expected #{"id"} @@ -248,49 +241,45 @@ (testing "delete query signature" (let [expected ":! :n" actual (:signature (first (vals (delete-query entity))))] - (is (string-equal-ignore-whitespace? actual expected)))) - - )) + (is (string-equal-ignore-whitespace? actual expected)))))) (deftest complex-key-tests (let [application {:tag :application, - :attrs {:version "0.1.1", :name "test-app"}, - :content - [{:tag :entity, - :attrs {:name "address"}, - :content - [{:tag :key, - :attrs nil, - :content - [{: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} - ]}]} + :attrs {:version "0.1.1", :name "test-app"}, + :content + [{:tag :entity, + :attrs {:name "address"}, + :content + [{:tag :key, + :attrs nil, + :content + [{: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, diff --git a/test/adl/validator_test.clj b/test/adl/validator_test.clj index cdb0fe0..bf53c6c 100644 --- a/test/adl/validator_test.clj +++ b/test/adl/validator_test.clj @@ -1,9 +1,10 @@ (ns adl.validator-test - (:require [clojure.java.io :refer [writer]] - [clojure.test :refer :all] - [clojure.xml :refer [parse]] - [adl.validator :refer :all] - [bouncer.core :refer [valid?]])) + (:require + [adl.validator :refer :all] + [bouncer.core :refer [valid? validate]] + [clojure.java.io :refer [writer]] + [clojure.test :refer :all] + [clojure.xml :refer [parse]])) ;; OK, so where we're up to: documentation breaks validation of the ;; element that contains it if the documentation is non-empty. @@ -262,9 +263,9 @@ :name "id"}, :content [{:tag :generator, :attrs {:action "native"}, :content nil}]}]} - expected true - actual (binding [*out* (writer "/dev/null")] - (valid? xml key-validations))] + expected nil + actual (first (binding [*out* (writer "/dev/null")] + (validate xml key-validations)))] (is (= actual expected))))) (deftest validator-property @@ -340,14 +341,14 @@ (deftest validator-option (testing "Validation of option element" (let [xml {:tag :option, - :attrs {:value "Female"}, - :content - [{:tag :prompt, - :attrs {:locale "fr-FR", :prompt "Femme"}, - :content nil} - {:tag :prompt, - :attrs {:locale "en-GB", :prompt "Female"}, - :content nil}]} + :attrs {:value "Female"}, + :content + [{:tag :prompt, + :attrs {:locale "fr-FR", :prompt "Femme"}, + :content nil} + {:tag :prompt, + :attrs {:locale "en-GB", :prompt "Female"}, + :content nil}]} expected true actual (binding [*out* (writer "/dev/null")] (valid? xml option-validations))] @@ -378,8 +379,8 @@ (deftest validator-page (testing "Validation of page element" (let [xml {:tag :page, - :attrs {:properties "all", :name "inspect-person"}, - :content nil} + :attrs {:properties "all", :name "inspect-person"}, + :content nil} expected true actual (binding [*out* (writer "/dev/null")] (valid? xml page-validations))]