simon/squirrel-parse
1
0
Fork 0
Code Issues Pull requests Actions Packages Projects Releases Wiki Activity
squirrel-parse/src/squirrel_parse/validator.clj
Simon Brooke 8e63f4b6c9 #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.
2018-03-20 13:22:08 +00:00

660 lines
27 KiB
Clojure
Raw Blame History

(ns ^{:doc "A parser for SQL: validator for ADL structure."
:author "Simon Brooke"}
squirrel-parse.validator
(:require [clojure.set :refer [union]]
[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
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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)
(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
"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
"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
"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
"content, for things like pages (i.e. forms, lists, pages)"
#{"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/valid? % documentation-validations)
(b/valid? % 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 #(disjunct-validate %
documentation-validations
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] [[#(if
(string? %)
(integer? (read-string %))
(integer? %))]]
[:attrs :pattern] v/string
[:attrs :minimum] [[#(if
(string? %)
(integer? (read-string %))
(integer? %))]]
[:attrs :maximum] [[#(if
(string? %)
(integer? (read-string %))
(integer? %))]]
:content [[v/every #(or
(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
* `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] [] ;; 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 :size] [[#(cond
(empty? %) ;; it's allowed to be missing
true
(string? %)
(integer? (read-string %))
true
(integer? %))]]
[:attrs :column] v/string
[:attrs :concrete] [[v/member #{"true", "false"}]]
[:attrs :cascade] [[v/member cascade-actions]]
:content [[v/every #(disjunct-validate %
documentation-validations
generator-validations
permission-validations
option-validations
prompt-validations
help-validations
ifmissing-validations)]]})
(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/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/member #{"true", "false"}] 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
"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/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 #(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
* `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 #(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)]]
: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/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)]]
[:attrs :name] [v/required v/string]
[:attrs :version] v/string
[:attrs :revision] v/string
[:attrs :currency] v/string
: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))
Reference in a new issue View git blame Copy permalink