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)
This commit is contained in:
parent
5af9a7349c
commit
b944aa6bf1
10
project.clj
10
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]
|
||||
|
||||
|
|
|
|||
|
|
@ -3,12 +3,10 @@
|
|||
adl.to-hugsql-queries
|
||||
(:require [adl-support.core :refer :all]
|
||||
[adl-support.utils :refer :all]
|
||||
[clojure.java.io :refer [file make-parents]]
|
||||
[clojure.java.io :refer [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]))
|
||||
[clj-time.core :as t]))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;;;
|
||||
|
|
@ -33,10 +31,10 @@
|
|||
;;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(def expanded-token "_expanded")
|
||||
(def expanded-token "_expanded")
|
||||
|
||||
|
||||
(defn where-clause
|
||||
(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."
|
||||
|
|
@ -46,7 +44,7 @@
|
|||
(let
|
||||
[entity-name (safe-name entity :sql)
|
||||
property-names (map #(:name (:attrs %)) properties)]
|
||||
(if-not (empty? property-names)
|
||||
(when-not (empty? property-names)
|
||||
(str
|
||||
"WHERE "
|
||||
(s/join
|
||||
|
|
@ -56,7 +54,7 @@
|
|||
property-names)))))))
|
||||
|
||||
|
||||
(defn order-by-clause
|
||||
(defn order-by-clause
|
||||
"Generate an appropriate `order by` clause for queries on this `entity`"
|
||||
([entity]
|
||||
(order-by-clause entity "" false))
|
||||
|
|
@ -89,7 +87,7 @@
|
|||
;; (order-by-clause e "" true)
|
||||
|
||||
|
||||
(defn insert-query
|
||||
(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."
|
||||
|
|
@ -128,7 +126,7 @@
|
|||
(key-names entity))))))})))
|
||||
|
||||
|
||||
(defn update-query
|
||||
(defn update-query
|
||||
"Generate an appropriate `update` query for this `entity`"
|
||||
[entity]
|
||||
(let [entity-name (safe-name entity :sql)
|
||||
|
|
@ -158,13 +156,19 @@
|
|||
(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
|
||||
|
|
@ -215,11 +219,10 @@
|
|||
properties))))
|
||||
(order-by-clause entity "lv_" true)
|
||||
"--~ (if (:offset params) \"OFFSET :offset \")"
|
||||
"--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))})))
|
||||
"--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))}))))
|
||||
|
||||
;; (search-query e a)
|
||||
|
||||
|
||||
(defn select-query
|
||||
"Generate an appropriate `select` query for this `entity`"
|
||||
([entity properties]
|
||||
|
|
@ -229,7 +232,9 @@
|
|||
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)
|
||||
|
|
@ -350,8 +355,7 @@
|
|||
(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 " %)))))
|
||||
}))
|
||||
(list (str "ERROR: unexpected type " link-type " of property " %)))))}))
|
||||
links))))
|
||||
|
||||
|
||||
|
|
@ -446,7 +450,7 @@
|
|||
(pr-str
|
||||
(map
|
||||
#(keyword (:name (:attrs %)))
|
||||
(-> query :entity insertable-properties )))
|
||||
(-> query :entity insertable-properties)))
|
||||
"`. Returns a map containing the keys `"
|
||||
(-> query :entity key-names)
|
||||
"` identifying the record created.")
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -2,11 +2,11 @@
|
|||
TODO: this is at present largely a failed experiment."
|
||||
:author "Simon Brooke"}
|
||||
adl.validator
|
||||
(:require [adl-support.utils :refer :all]
|
||||
(: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]]))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;;;
|
||||
|
|
@ -43,11 +43,11 @@
|
|||
(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?
|
||||
(empty?
|
||||
(remove :tag (remove nil? (map first (map
|
||||
#(try-validate ~o '%)
|
||||
~validations))))))
|
||||
#(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
|
||||
|
|
@ -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,6 +190,15 @@
|
|||
[: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,
|
||||
|
|
@ -208,20 +216,27 @@
|
|||
[: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?
|
||||
%
|
||||
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)]]})
|
||||
|
|
@ -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
|
||||
|
|
@ -425,34 +449,54 @@
|
|||
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
|
||||
(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
|
||||
: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)]]
|
||||
})
|
||||
;; 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
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
(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."
|
||||
|
|
@ -47,16 +47,14 @@
|
|||
:size "12"
|
||||
:name "postcode"},
|
||||
:content
|
||||
[{:tag :generator, :attrs {:action "native"}, :content nil}]}
|
||||
]}
|
||||
[{: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}
|
||||
]}]}
|
||||
:content nil}]}]}
|
||||
entity (child-with-tag application :entity)]
|
||||
(testing "user distinct properties should provide the default ordering"
|
||||
(let [expected
|
||||
|
|
@ -64,7 +62,6 @@
|
|||
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"},
|
||||
|
|
@ -94,16 +91,14 @@
|
|||
:size "12"
|
||||
:name "postcode"},
|
||||
:content
|
||||
[{:tag :generator, :attrs {:action "native"}, :content nil}]}
|
||||
]}
|
||||
[{: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}
|
||||
]}]}
|
||||
:content nil}]}]}
|
||||
entity (child-with-tag application :entity)]
|
||||
(testing "keys name extraction"
|
||||
(let [expected #{"id" "postcode"}
|
||||
|
|
@ -140,16 +135,14 @@
|
|||
:size "12"
|
||||
:name "postcode"},
|
||||
:content
|
||||
[{:tag :generator, :attrs {:action "native"}, :content nil}]}
|
||||
]}
|
||||
[{: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}
|
||||
]}]}
|
||||
:content nil}]}]}
|
||||
entity (child-with-tag application :entity)]
|
||||
(testing "keys name extraction"
|
||||
(let [expected #{"id"}
|
||||
|
|
@ -248,9 +241,7 @@
|
|||
(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,
|
||||
|
|
@ -281,16 +272,14 @@
|
|||
:size "12"
|
||||
:name "postcode"},
|
||||
:content
|
||||
[{:tag :generator, :attrs {:action "native"}, :content nil}]}
|
||||
]}
|
||||
[{: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}
|
||||
]}]}
|
||||
:content nil}]}]}
|
||||
entity (child-with-tag application :entity)]
|
||||
(testing "user distinct properties should provide the default ordering"
|
||||
(let [expected "ORDER BY address.street,
|
||||
|
|
|
|||
|
|
@ -1,9 +1,10 @@
|
|||
(ns adl.validator-test
|
||||
(:require [clojure.java.io :refer [writer]]
|
||||
[clojure.test :refer :all]
|
||||
[clojure.xml :refer [parse]]
|
||||
(:require
|
||||
[adl.validator :refer :all]
|
||||
[bouncer.core :refer [valid?]]))
|
||||
[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
|
||||
|
|
|
|||
Loading…
Reference in a new issue