simon/adl
1
0
Fork 0
Code Issues Pull requests Actions Packages Projects Releases Wiki Activity

Merge branch 'develop' of ssh://git.journeyman.cc:4022/simon/adl into develop;

Browse source 
Fixed yet another validator test.
This commit is contained in:
Simon Brooke 2025-05-23 10:17:04 +01:00
parent b4b20d1d7a b944aa6bf1
commit 38f9c0f0e4
9 changed files with 471 additions and 1626 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
.gitignore vendored
View file

@ -29,3 +29,5 @@ generated/
*.orig *.orig
*.out

8
project.clj
View file

@ -5,14 +5,14 @@
:license {:name "GNU Lesser General Public License, version 3.0 or (at your option) any later version" :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"} :url "https://www.gnu.org/licenses/lgpl-3.0.en.html"}
:dependencies [[adl-support "0.1.7-SNAPSHOT"] :dependencies [[adl-support "0.1.8-SNAPSHOT"]
[bouncer "1.0.1"] [bouncer "1.0.1"]
[clojure-saxon "0.9.4"] [clojure-saxon "0.9.4"]
[environ "1.1.0"] [environ "1.1.0"]
[hiccup "1.0.5"] [hiccup "1.0.5"]
[org.clojure/clojure "1.8.0"] [org.clojure/clojure "1.12.0"]
[org.clojure/math.combinatorics "0.1.6"] [org.clojure/math.combinatorics "0.3.0"]
[org.clojure/tools.cli "0.4.2"]] [org.clojure/tools.cli "1.1.230"]]
:aot [adl.main] :aot [adl.main]

628
resources/schemas/adl-1.4.2.dtd
View file

@ -1,628 +0,0 @@
<!-- :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -->
<!-- -->
<!-- adl-1.4.2.dtd -->
<!-- -->
<!-- Purpose: -->
<!-- Document Type Description for Application Description -->
<!-- Language. Normative for now; will be replaced by a schema. ` -->
<!-- -->
<!-- Author: Simon Brooke <simon@journeyman.cc> -->
<!-- Created: 3rd June 2018 -->
<!-- Copyright: (c) 2018 Simon Brooke -->
<!-- -->
<!-- :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -->
<!-- :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -->
<!-- Before we start: import XHTML for use in documentation sections -->
<!-- :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -->
<!-- :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -->
<!-- Before we start: some useful definitions -->
<!-- :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -->
<!-- some basic character entities inherited from HTML. Actually we probably ought to
import all the HTML4 character entity files, and possibly the HTML4 Strict DTD (so
that we can allow HTML block level entities within content elements -->
<!ENTITY nbsp "&#160;">
<!ENTITY pound "&#163;">
<!ENTITY copy "&#169;">
<!-- boolean means true or false -->
<!ENTITY % Boolean "(true|false)" >
<!--
Locale is a string comprising an ISO 639 language code followed by a space
followed by an ISO 3166 country code, or else the string 'default'. See:
<URL:http://www.ics.uci.edu/pub/ietf/http/related/iso639.txt>
<URL:http://www.chemie.fu-berlin.de/diverse/doc/ISO_3166.html>
-->
<!ENTITY % Locale "CDATA" >
<!--
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
-->
<!ENTITY % Permissions "none|read|insert|noedit|edit|all" >
<!--
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.
-->
<!ENTITY % CascadeActions "all|all-delete-orphan|delete|manual|save-update">
<!--
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
-->
<!ENTITY % DefinableDataTypes "string|integer|real|money|date|time|timestamp|uploadable" >
<!--
data types which are fairly straightforward translations of JDBC data types
boolean: boolean or java.sql.Types.BIT
char(1) java.sql.Types.CHAR
text: text or java.sql.Types.LONGVARCHAR
memo java.sql.Types.CLOB
-->
<!ENTITY % SimpleDataTypes "%DefinableDataTypes;|boolean|text" >
<!--
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 % ComplexDataTypes "entity|link|list|defined" >
<!--
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|png format (experimental, not yet implemented)
message : an internationalised message, having different translations for different locales
-->
<!ENTITY % SpecialDataTypes "geopos|image|message" >
<!-- all data types -->
<!ENTITY % AllDataTypes "%ComplexDataTypes;|%SimpleDataTypes;|%SpecialDataTypes;" >
<!-- content, for things like pages (i.e. forms, lists, pages) -->
<!ENTITY % Content "head|top|foot" >
<!ENTITY % FieldStuff "field|fieldgroup|auxlist|verb">
<!ENTITY % PageContent "%Content;|%FieldStuff;" >
<!ENTITY % PageStuff "%PageContent;|permission|pragma" >
<!-- Properties for pages:
name: obviously, the name (URL stub) of the page
properties: the properties of the entity the page describes to be shown
as fields on the page
all: obviously, all properties (except the abstract primary key, if
present)
user-distinct: all properties which are user-distinct (NOTE: Not yet implemented)
listed: only those properties for which fields are explicitly listed
-->
<!ENTITY % PageAttrs
"name CDATA #REQUIRED
properties (all|user-distinct|listed) #REQUIRED" >
<!-- Actions for generators (mainly for keyfields - see entity 'generator', below
assigned: In manually-maintained code, you contract to assign a value
to this property before it is persisted.
guid: The system will supply a unique GUid value to this field
before it is persisted.
mannual: You contract to supply a generator class in manually maintained
code.
native: The database will supply a unique value to this field when it
is persisted; the value will be an integer. RECOMMENDED!
-->
<!ENTITY % GeneratorActions "assigned|guid|manual|native">
<!-- sequences for orderings of lists - see entity 'order'
canonical: Whatever the normal canonical ordering for this datatype is -
typically alpha-numeric, except for dates, etc.
reverse-canonical: The reverse of the above
possibly there should be some further values but I have no idea what these are
-->
<!ENTITY % Sequences "canonical|reverse-canonical">
<!-- :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -->
<!-- Elements -->
<!-- :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -->
<!--
the application that the document describes: required top level element
name: the name of this application
version: the version number of this application
revision: the revision of the ADL document
currency: the base monetary currency, in the form of an ISO 4217 three-letter code
xmlns: XML namespace, in case required
-->
<!ELEMENT application ( specification*, documentation?, content?, typedef*, group*, entity*)>
<!ATTLIST application
name CDATA #REQUIRED
version CDATA #IMPLIED
revision CDATA #IMPLIED
currency CDATA #IMPLIED
xmlns CDATA #IMPLIED>
<!--
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)
-->
<!ELEMENT typedef (documentation?, in-implementation*, help*) >
<!ATTLIST typedef
name CDATA #REQUIRED
type (%DefinableDataTypes;) #IMPLIED
size CDATA #IMPLIED
pattern CDATA #IMPLIED
minimum CDATA #IMPLIED
maximum CDATA #IMPLIED>
<!--
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...
-->
<!ELEMENT in-implementation (documentation?)>
<!ATTLIST in-implementation
target CDATA #REQUIRED
value CDATA #REQUIRED
kind CDATA #IMPLIED>
<!--
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
-->
<!ELEMENT group (documentation?)>
<!ATTLIST group
name CDATA #REQUIRED
parent CDATA #IMPLIED>
<!--
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.
magnitude: The power of ten which approximates the expected number of records; thus
if ten records are expected, the magnitude is 1; if a million, the
magnitude is 6.
volatility: Number representing the anticipated rate of change of records in this
entity; if 0, results should never be cached; otherwise, a power of
10 representing the number of seconds the data may safely be cached.
thus 5 represents a cach time to live of 100,000 seconds, or slightly
more than one day.
-->
<!ELEMENT entity ( documentation?, prompt*, content?, key?,
property*, permission*, (form | page | list)*)>
<!ATTLIST entity
name CDATA #REQUIRED
natural-key CDATA #IMPLIED
table CDATA #IMPLIED
foreign %Boolean; #IMPLIED
magnitude CDATA #IMPLIED
volatility CDATA #IMPLIED>
<!--
contains documentation on the element which immediately contains it. TODO:
should HTML markup within a documentation element be allowed? If so, are
there restrictions? For now, no: instead I shall aim to support MarkDown
within documentation.
-->
<!ELEMENT documentation ( #PCDATA|reference|todo)*>
<!ATTLIST documentation
xmlns CDATA #IMPLIED>
<!-- a child of documentation, q.v., which allows TODO items to be identified.
-->
<!ELEMENT todo ( #PCDATA|reference)*>
<!ATTLIST todo
xmlns CDATA #IMPLIED>
<!-- an explicit primary key, possibly compound -->
<!ELEMENT key (property*)>
<!--
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
-->
<!ELEMENT property ( documentation?, generator?, (permission|option|prompt|help|ifmissing)*)>
<!ATTLIST property
name CDATA #REQUIRED
type (%AllDataTypes;) #REQUIRED
default CDATA #IMPLIED
typedef CDATA #IMPLIED
distinct (none|all|user|system) #IMPLIED
entity CDATA #IMPLIED
farkey CDATA #IMPLIED
required %Boolean; #IMPLIED
immutable %Boolean; #IMPLIED
size CDATA #IMPLIED
column CDATA #IMPLIED
concrete %Boolean; #IMPLIED
cascade (%CascadeActions;) #IMPLIED>
<!--
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
-->
<!ELEMENT generator (documentation?, param*)>
<!ATTLIST generator
action (%GeneratorActions;) #REQUIRED
class CDATA #IMPLIED>
<!--
A parameter passed to the generator. Again, based on the Hibernate
implementation. TODO: #PCDATA is wrong as the content model, as embedded
markup is definitely not allowed!
name: the name of this parameter
TODO: This needs to be renamed or removed because it conflicts with the
XHTML element of the same name. In fact it could be simply removed since
our usage is compatible with the XHTML usage, but it might be less
ambiguous to rename it.
-->
<!ELEMENT param (#PCDATA)>
<!ATTLIST param
name CDATA #REQUIRED>
<!--
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
TODO: This needs to be renamed or removed because it conflicts with the
XHTML element of the same name. In fact it could be simply removed since
our usage is compatible with the XHTML usage, but it might be less
ambiguous to rename it.
-->
<!ELEMENT option (documentation?, prompt*)>
<!-- if the value is different from the prompt the user sees, specify it -->
<!ATTLIST option
value CDATA #IMPLIED>
<!--
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
-->
<!ELEMENT permission (documentation?)>
<!ATTLIST permission
group CDATA #REQUIRED
permission (%Permissions;) #REQUIRED>
<!--
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.
-->
<!ELEMENT pragma (documentation?)>
<!ATTLIST pragma
name CDATA #REQUIRED
value CDATA #REQUIRED>
<!--
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
-->
<!ELEMENT prompt (documentation?)>
<!ATTLIST prompt
prompt CDATA #REQUIRED
locale %Locale; #REQUIRED >
<!--
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
-->
<!ELEMENT help (#PCDATA)>
<!ATTLIST help
locale %Locale; #REQUIRED
xmlns CDATA #IMPLIED >
<!--
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.
-->
<!ELEMENT ifmissing (#PCDATA)>
<!ATTLIST ifmissing
locale %Locale; #REQUIRED
xmlns CDATA #IMPLIED>
<!-- a form through which an entity may be added or edited
TODO: This needs to be renamed because it conflicts with the
XHTML element of the same name.
-->
<!ELEMENT form (documentation?, ( %PageStuff;)*)>
<!ATTLIST form %PageAttrs;>
<!-- a page on which an entity may be displayed -->
<!ELEMENT page (documentation?, ( %PageStuff;)*)>
<!ATTLIST page %PageAttrs;>
<!-- an ordering or records in a list
property: the property on which to order
sequence: the sequence in which to order
-->
<!ELEMENT order (documentation?)>
<!ATTLIST order
property CDATA #REQUIRED
sequence (%Sequences;) #IMPLIED>
<!--
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
-->
<!ELEMENT list (documentation?, ( %PageStuff;|order)*)>
<!ATTLIST list %PageAttrs;
onselect CDATA #IMPLIED >
<!--
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
-->
<!ELEMENT auxlist (documentation?, (prompt|%FieldStuff;)*)>
<!ATTLIST auxlist %PageAttrs;
property CDATA #REQUIRED
onselect CDATA #IMPLIED
canadd %Boolean; #IMPLIED>
<!--
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.
-->
<!ELEMENT fieldgroup (documentation?, (prompt|permission|%FieldStuff;)*)>
<!ATTLIST fieldgroup
name CDATA #REQUIRED>
<!-- a field in a form or page
property: the property which this field displays/edits
-->
<!ELEMENT field (documentation?, (prompt|help|permission)*) >
<!ATTLIST field
property CDATA #REQUIRED >
<!-- 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 -->
<!ELEMENT verb (documentation?, (prompt|help|permission)*) >
<!ATTLIST verb
verb CDATA #REQUIRED
dangerous %Boolean; #REQUIRED>
<!-- a container for global content -->
<!ELEMENT content (%Content;)*>
<!--
content to place in the head of the generated document; this is #PCDATA
because it will almost certainly belong to a different namespace
(usually HTML)
TODO: This needs to be renamed or removed because it conflicts with the
XHTML element of the same name. In fact it could be simply removed since
our usage is compatible with the XHTML usage, but it might be less
ambiguous to rename it.
-->
<!ELEMENT head (#PCDATA) >
<!ATTLIST head
xmlns CDATA #IMPLIED>
<!--
content to place in the top of the body of the generated document;
this is %Flow; which is any HTML block or inline level element.
-->
<!ELEMENT top (#PCDATA) >
<!ATTLIST top
xmlns CDATA #IMPLIED>
<!--
content to place at the foot of the body of the generated document;
this is %Flow; which is any HTML block or inline level element.
-->
<!ELEMENT foot (#PCDATA) >
<!ATTLIST foot
xmlns CDATA #IMPLIED>
<!--
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
documents which may be used in documentation elements later in the
document.
url: The URL from which the document referenced can be retrieved
name: The full name (title) given to this document
abbr: A convenient abbreviated name
-->
<!ELEMENT specification (documentation?, reference*)>
<!ATTLIST specification
url CDATA #IMPLIED
name CDATA #REQUIRED
abbr CDATA #REQUIRED
>
<!--
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.
abbr: The abbreviated name of the specification to which this
reference refers
section: The 'anchor part' (part following a hash character) which,
when appended to the URL, will locate the exact section
referenced.
entity: A reference to another entity within this ADL document
property: A reference to another property within this ADL document;
if entity is also specified then of that entity, else of
the ancestor entity if any
-->
<!ELEMENT reference (documentation?)>
<!ATTLIST reference
abbr CDATA #IMPLIED
section CDATA #IMPLIED
entity CDATA #IMPLIED
property CDATA #IMPLIED
>

559
resources/schemas/adl-1.4.2.xsd
View file

@ -1,559 +0,0 @@
<schema
xmlns='http://www.w3.org/2001/XMLSchema'
targetNamespace='http://www.w3.org/namespace/'
xmlns:t='http://www.w3.org/namespace/'>
<element name='application'>
<complexType>
<sequence>
<element ref='t:specification' minOccurs='0' maxOccurs='unbounded'/>
<element ref='t:documentation' minOccurs='0' maxOccurs='1'/>
<element ref='t:content' minOccurs='0' maxOccurs='1'/>
<element ref='t:typedef' minOccurs='0' maxOccurs='unbounded'/>
<element ref='t:group' minOccurs='0' maxOccurs='unbounded'/>
<element ref='t:entity' minOccurs='0' maxOccurs='unbounded'/>
</sequence>
<attribute name='name' type='string' use='required'/>
<attribute name='version' type='string' use='optional'/>
<attribute name='revision' type='string' use='optional'/>
<attribute name='currency' type='string' use='optional'/>
<attribute name='xmlns' type='string' use='optional'/>
</complexType>
</element>
<element name='typedef'>
<complexType>
<sequence>
<element ref='t:documentation' minOccurs='0' maxOccurs='1'/>
<element ref='t:in-implementation' minOccurs='0' maxOccurs='unbounded'/>
<element ref='t:help' minOccurs='0' maxOccurs='unbounded'/>
</sequence>
<attribute name='name' type='string' use='required'/>
<attribute name='type' use='optional'>
<simpleType>
<restriction base='string'>
<enumeration value='string'/>
<enumeration value='integer'/>
<enumeration value='real'/>
<enumeration value='money'/>
<enumeration value='date'/>
<enumeration value='time'/>
<enumeration value='timestamp'/>
<enumeration value='uploadable'/>
</restriction>
</simpleType>
</attribute>
<attribute name='size' type='string' use='optional'/>
<attribute name='pattern' type='string' use='optional'/>
<attribute name='minimum' type='string' use='optional'/>
<attribute name='maximum' type='string' use='optional'/>
</complexType>
</element>
<element name='in-implementation'>
<complexType>
<sequence>
<element ref='t:documentation' minOccurs='0' maxOccurs='1'/>
</sequence>
<attribute name='target' type='string' use='required'/>
<attribute name='value' type='string' use='required'/>
<attribute name='kind' type='string' use='optional'/>
</complexType>
</element>
<element name='group'>
<complexType>
<sequence>
<element ref='t:documentation' minOccurs='0' maxOccurs='1'/>
</sequence>
<attribute name='name' type='string' use='required'/>
<attribute name='parent' type='string' use='optional'/>
</complexType>
</element>
<element name='entity'>
<complexType>
<sequence>
<element ref='t:documentation' minOccurs='0' maxOccurs='1'/>
<element ref='t:prompt' minOccurs='0' maxOccurs='unbounded'/>
<element ref='t:content' minOccurs='0' maxOccurs='1'/>
<element ref='t:key' minOccurs='0' maxOccurs='1'/>
<element ref='t:property' minOccurs='0' maxOccurs='unbounded'/>
<element ref='t:permission' minOccurs='0' maxOccurs='unbounded'/>
<choice minOccurs='0' maxOccurs='unbounded'>
<element ref='t:form'/>
<element ref='t:page'/>
<element ref='t:list'/>
</choice>
</sequence>
<attribute name='name' type='string' use='required'/>
<attribute name='natural-key' type='string' use='optional'/>
<attribute name='table' type='string' use='optional'/>
<attribute name='foreign' use='optional'>
<simpleType>
<restriction base='string'>
<enumeration value='true'/>
<enumeration value='false'/>
</restriction>
</simpleType>
</attribute>
<attribute name='magnitude' type='string' use='optional'/>
<attribute name='volatility' type='string' use='optional'/>
</complexType>
</element>
<element name='documentation'>
<complexType mixed='true'>
<choice minOccurs='0' maxOccurs='unbounded'>
<element ref='t:reference'/>
<element ref='t:todo'/>
</choice>
<attribute name='xmlns' type='string' use='optional'/>
</complexType>
</element>
<element name='todo'>
<complexType mixed='true'>
<sequence minOccurs='0' maxOccurs='unbounded'>
<element ref='t:reference'/>
</sequence>
<attribute name='xmlns' type='string' use='optional'/>
</complexType>
</element>
<element name='key'>
<complexType>
<sequence>
<element ref='t:property' minOccurs='0' maxOccurs='unbounded'/>
</sequence>
</complexType>
</element>
<element name='property'>
<complexType>
<sequence>
<element ref='t:documentation' minOccurs='0' maxOccurs='1'/>
<element ref='t:generator' minOccurs='0' maxOccurs='1'/>
<choice minOccurs='0' maxOccurs='unbounded'>
<element ref='t:permission'/>
<element ref='t:option'/>
<element ref='t:prompt'/>
<element ref='t:help'/>
<element ref='t:ifmissing'/>
</choice>
</sequence>
<attribute name='name' type='string' use='required'/>
<attribute name='type' use='required'>
<simpleType>
<restriction base='string'>
<enumeration value='entity'/>
<enumeration value='link'/>
<enumeration value='list'/>
<enumeration value='defined'/>
<enumeration value='string'/>
<enumeration value='integer'/>
<enumeration value='real'/>
<enumeration value='money'/>
<enumeration value='date'/>
<enumeration value='time'/>
<enumeration value='timestamp'/>
<enumeration value='uploadable'/>
<enumeration value='boolean'/>
<enumeration value='text'/>
<enumeration value='geopos'/>
<enumeration value='image'/>
<enumeration value='message'/>
</restriction>
</simpleType>
</attribute>
<attribute name='default' type='string' use='optional'/>
<attribute name='typedef' type='string' use='optional'/>
<attribute name='distinct' use='optional'>
<simpleType>
<restriction base='string'>
<enumeration value='none'/>
<enumeration value='all'/>
<enumeration value='user'/>
<enumeration value='system'/>
</restriction>
</simpleType>
</attribute>
<attribute name='entity' type='string' use='optional'/>
<attribute name='farkey' type='string' use='optional'/>
<attribute name='required' use='optional'>
<simpleType>
<restriction base='string'>
<enumeration value='true'/>
<enumeration value='false'/>
</restriction>
</simpleType>
</attribute>
<attribute name='immutable' use='optional'>
<simpleType>
<restriction base='string'>
<enumeration value='true'/>
<enumeration value='false'/>
</restriction>
</simpleType>
</attribute>
<attribute name='size' type='string' use='optional'/>
<attribute name='column' type='string' use='optional'/>
<attribute name='concrete' use='optional'>
<simpleType>
<restriction base='string'>
<enumeration value='true'/>
<enumeration value='false'/>
</restriction>
</simpleType>
</attribute>
<attribute name='cascade' use='optional'>
<simpleType>
<restriction base='string'>
<enumeration value='all'/>
<enumeration value='all-delete-orphan'/>
<enumeration value='delete'/>
<enumeration value='manual'/>
<enumeration value='save-update'/>
</restriction>
</simpleType>
</attribute>
</complexType>
</element>
<element name='generator'>
<complexType>
<sequence>
<element ref='t:documentation' minOccurs='0' maxOccurs='1'/>
<element ref='t:param' minOccurs='0' maxOccurs='unbounded'/>
</sequence>
<attribute name='action' use='required'>
<simpleType>
<restriction base='string'>
<enumeration value='assigned'/>
<enumeration value='guid'/>
<enumeration value='manual'/>
<enumeration value='native'/>
</restriction>
</simpleType>
</attribute>
<attribute name='class' type='string' use='optional'/>
</complexType>
</element>
<element name='param'>
<complexType mixed='true'>
<attribute name='name' type='string' use='required'/>
</complexType>
</element>
<element name='option'>
<complexType>
<sequence>
<element ref='t:documentation' minOccurs='0' maxOccurs='1'/>
<element ref='t:prompt' minOccurs='0' maxOccurs='unbounded'/>
</sequence>
<attribute name='value' type='string' use='optional'/>
</complexType>
</element>
<element name='permission'>
<complexType>
<sequence>
<element ref='t:documentation' minOccurs='0' maxOccurs='1'/>
</sequence>
<attribute name='group' type='string' use='required'/>
<attribute name='permission' use='required'>
<simpleType>
<restriction base='string'>
<enumeration value='none'/>
<enumeration value='read'/>
<enumeration value='insert'/>
<enumeration value='noedit'/>
<enumeration value='edit'/>
<enumeration value='all'/>
</restriction>
</simpleType>
</attribute>
</complexType>
</element>
<element name='pragma'>
<complexType>
<sequence>
<element ref='t:documentation' minOccurs='0' maxOccurs='1'/>
</sequence>
<attribute name='name' type='string' use='required'/>
<attribute name='value' type='string' use='required'/>
</complexType>
</element>
<element name='prompt'>
<complexType>
<sequence>
<element ref='t:documentation' minOccurs='0' maxOccurs='1'/>
</sequence>
<attribute name='prompt' type='string' use='required'/>
<attribute name='locale' type='string' use='required'/>
</complexType>
</element>
<element name='help'>
<complexType mixed='true'>
<attribute name='locale' type='string' use='required'/>
<attribute name='xmlns' type='string' use='optional'/>
</complexType>
</element>
<element name='ifmissing'>
<complexType mixed='true'>
<attribute name='locale' type='string' use='required'/>
<attribute name='xmlns' type='string' use='optional'/>
</complexType>
</element>
<element name='form'>
<complexType>
<sequence>
<element ref='t:documentation' minOccurs='0' maxOccurs='1'/>
<choice minOccurs='0' maxOccurs='unbounded'>
<element ref='t:head'/>
<element ref='t:top'/>
<element ref='t:foot'/>
<element ref='t:field'/>
<element ref='t:fieldgroup'/>
<element ref='t:auxlist'/>
<element ref='t:verb'/>
<element ref='t:permission'/>
<element ref='t:pragma'/>
</choice>
</sequence>
<attribute name='name' type='string' use='required'/>
<attribute name='properties' use='required'>
<simpleType>
<restriction base='string'>
<enumeration value='all'/>
<enumeration value='user-distinct'/>
<enumeration value='listed'/>
</restriction>
</simpleType>
</attribute>
</complexType>
</element>
<element name='page'>
<complexType>
<sequence>
<element ref='t:documentation' minOccurs='0' maxOccurs='1'/>
<choice minOccurs='0' maxOccurs='unbounded'>
<element ref='t:head'/>
<element ref='t:top'/>
<element ref='t:foot'/>
<element ref='t:field'/>
<element ref='t:fieldgroup'/>
<element ref='t:auxlist'/>
<element ref='t:verb'/>
<element ref='t:permission'/>
<element ref='t:pragma'/>
</choice>
</sequence>
<attribute name='name' type='string' use='required'/>
<attribute name='properties' use='required'>
<simpleType>
<restriction base='string'>
<enumeration value='all'/>
<enumeration value='user-distinct'/>
<enumeration value='listed'/>
</restriction>
</simpleType>
</attribute>
</complexType>
</element>
<element name='order'>
<complexType>
<sequence>
<element ref='t:documentation' minOccurs='0' maxOccurs='1'/>
</sequence>
<attribute name='property' type='string' use='required'/>
<attribute name='sequence' use='optional'>
<simpleType>
<restriction base='string'>
<enumeration value='canonical'/>
<enumeration value='reverse-canonical'/>
</restriction>
</simpleType>
</attribute>
</complexType>
</element>
<element name='list'>
<complexType>
<sequence>
<element ref='t:documentation' minOccurs='0' maxOccurs='1'/>
<choice minOccurs='0' maxOccurs='unbounded'>
<element ref='t:head'/>
<element ref='t:top'/>
<element ref='t:foot'/>
<element ref='t:field'/>
<element ref='t:fieldgroup'/>
<element ref='t:auxlist'/>
<element ref='t:verb'/>
<element ref='t:permission'/>
<element ref='t:pragma'/>
<element ref='t:order'/>
</choice>
</sequence>
<attribute name='name' type='string' use='required'/>
<attribute name='properties' use='required'>
<simpleType>
<restriction base='string'>
<enumeration value='all'/>
<enumeration value='user-distinct'/>
<enumeration value='listed'/>
</restriction>
</simpleType>
</attribute>
<attribute name='onselect' type='string' use='optional'/>
</complexType>
</element>
<element name='auxlist'>
<complexType>
<sequence>
<element ref='t:documentation' minOccurs='0' maxOccurs='1'/>
<choice minOccurs='0' maxOccurs='unbounded'>
<element ref='t:prompt'/>
<element ref='t:field'/>
<element ref='t:fieldgroup'/>
<element ref='t:auxlist'/>
<element ref='t:verb'/>
</choice>
</sequence>
<attribute name='name' type='string' use='required'/>
<attribute name='properties' use='required'>
<simpleType>
<restriction base='string'>
<enumeration value='all'/>
<enumeration value='user-distinct'/>
<enumeration value='listed'/>
</restriction>
</simpleType>
</attribute>
<attribute name='property' type='string' use='required'/>
<attribute name='onselect' type='string' use='optional'/>
<attribute name='canadd' use='optional'>
<simpleType>
<restriction base='string'>
<enumeration value='true'/>
<enumeration value='false'/>
</restriction>
</simpleType>
</attribute>
</complexType>
</element>
<element name='fieldgroup'>
<complexType>
<sequence>
<element ref='t:documentation' minOccurs='0' maxOccurs='1'/>
<choice minOccurs='0' maxOccurs='unbounded'>
<element ref='t:prompt'/>
<element ref='t:permission'/>
<element ref='t:field'/>
<element ref='t:fieldgroup'/>
<element ref='t:auxlist'/>
<element ref='t:verb'/>
</choice>
</sequence>
<attribute name='name' type='string' use='required'/>
</complexType>
</element>
<element name='field'>
<complexType>
<sequence>
<element ref='t:documentation' minOccurs='0' maxOccurs='1'/>
<choice minOccurs='0' maxOccurs='unbounded'>
<element ref='t:prompt'/>
<element ref='t:help'/>
<element ref='t:permission'/>
</choice>
</sequence>
<attribute name='property' type='string' use='required'/>
</complexType>
</element>
<element name='verb'>
<complexType>
<sequence>
<element ref='t:documentation' minOccurs='0' maxOccurs='1'/>
<choice minOccurs='0' maxOccurs='unbounded'>
<element ref='t:prompt'/>
<element ref='t:help'/>
<element ref='t:permission'/>
</choice>
</sequence>
<attribute name='verb' type='string' use='required'/>
<attribute name='dangerous' use='required'>
<simpleType>
<restriction base='string'>
<enumeration value='true'/>
<enumeration value='false'/>
</restriction>
</simpleType>
</attribute>
</complexType>
</element>
<element name='content'>
<complexType>
<choice minOccurs='0' maxOccurs='unbounded'>
<element ref='t:head'/>
<element ref='t:top'/>
<element ref='t:foot'/>
</choice>
</complexType>
</element>
<element name='head'>
<complexType mixed='true'>
<attribute name='xmlns' type='string' use='optional'/>
</complexType>
</element>
<element name='top'>
<complexType mixed='true'>
<attribute name='xmlns' type='string' use='optional'/>
</complexType>
</element>
<element name='foot'>
<complexType mixed='true'>
<attribute name='xmlns' type='string' use='optional'/>
</complexType>
</element>
<element name='specification'>
<complexType>
<sequence>
<element ref='t:documentation' minOccurs='0' maxOccurs='1'/>
<element ref='t:reference' minOccurs='0' maxOccurs='unbounded'/>
</sequence>
<attribute name='url' type='string' use='optional'/>
<attribute name='name' type='string' use='required'/>
<attribute name='abbr' type='string' use='required'/>
</complexType>
</element>
<element name='reference'>
<complexType>
<sequence>
<element ref='t:documentation' minOccurs='0' maxOccurs='1'/>
</sequence>
<attribute name='abbr' type='string' use='optional'/>
<attribute name='section' type='string' use='optional'/>
<attribute name='entity' type='string' use='optional'/>
<attribute name='property' type='string' use='optional'/>
</complexType>
</element>
</schema>

154
src/adl/to_hugsql_queries.clj
View file

@ -1,14 +1,12 @@
(ns ^{:doc "Application Description Language - generate HUGSQL queries file." (ns ^{:doc "Application Description Language - generate HUGSQL queries file."
:author "Simon Brooke"} :author "Simon Brooke"}
adl.to-hugsql-queries adl.to-hugsql-queries
(:require [adl-support.core :refer :all] (:require [adl-support.core :refer :all]
[adl-support.utils :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.math.combinatorics :refer [combinations]]
[clojure.string :as s] [clojure.string :as s]
[clojure.xml :as x] [clj-time.core :as t]))
[clj-time.core :as t]
[clj-time.format :as f]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; ;;;;
@ -46,8 +44,8 @@
(let (let
[entity-name (safe-name entity :sql) [entity-name (safe-name entity :sql)
property-names (map #(:name (:attrs %)) properties)] property-names (map #(:name (:attrs %)) properties)]
(if-not (empty? property-names) (when-not (empty? property-names)
(str (str
"WHERE " "WHERE "
(s/join (s/join
"\n\tAND " "\n\tAND "
@ -99,9 +97,10 @@
insertable-property-names (map insertable-property-names (map
#(safe-name % :sql) #(safe-name % :sql)
(insertable-properties entity)) (insertable-properties entity))
query-name (str "create-" pretty-name "!") query-name (str "create-" pretty-name "!")
signature (if (has-primary-key? entity) signature (if (has-primary-key? entity)
":<!" ":? :1" ;; bizarrely, if you want to return the keys,
;; you have to use a query signature.
":! :n")] ":! :n")]
(hash-map (hash-map
(keyword query-name) (keyword query-name)
@ -157,8 +156,14 @@
(where-clause entity))}))) (where-clause entity))})))
(defn search-query [entity application] (defn search-query
"Generate an appropriate search query for string fields of this `entity` within this `application`" "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) (let [entity-name (safe-name entity :sql)
pretty-name (singularise entity-name) pretty-name (singularise entity-name)
query-name (str "search-strings-" entity-name) query-name (str "search-strings-" entity-name)
@ -214,7 +219,7 @@
properties)))) properties))))
(order-by-clause entity "lv_" true) (order-by-clause entity "lv_" true)
"--~ (if (:offset params) \"OFFSET :offset \")" "--~ (if (:offset params) \"OFFSET :offset \")"
"--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))}))) "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))}))))
;; (search-query e a) ;; (search-query e a)
@ -228,7 +233,9 @@
pretty-name (singularise entity-name) pretty-name (singularise entity-name)
query-name (if (= properties (key-properties entity)) query-name (if (= properties (key-properties entity))
(str "get-" pretty-name) (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"] signature ":? :1"]
(hash-map (hash-map
(keyword query-name) (keyword query-name)
@ -296,62 +303,61 @@
entity-safe (safe-name entity :sql) entity-safe (safe-name entity :sql)
links (filter #(:entity (:attrs %)) (children-with-tag entity :property))] links (filter #(:entity (:attrs %)) (children-with-tag entity :property))]
(apply (apply
merge merge
(map (map
#(let [far-name (:entity (:attrs %)) #(let [far-name (:entity (:attrs %))
far-entity (first far-entity (first
(children (children
application application
(fn [x] (fn [x]
(and (and
(= (:tag x) :entity) (= (:tag x) :entity)
(= (:name (:attrs x)) far-name))))) (= (:name (:attrs x)) far-name)))))
pretty-far (singularise far-name) pretty-far (singularise far-name)
safe-far (safe-name far-entity :sql) safe-far (safe-name far-entity :sql)
farkey (-> % :attrs :farkey) farkey (-> % :attrs :farkey)
link-type (-> % :attrs :type) link-type (-> % :attrs :type)
link-field (-> % :attrs :name) link-field (-> % :attrs :name)
query-name (list-related-query-name % entity (or far-entity far-name) false) query-name (list-related-query-name % entity far-entity false)
signature ":? :*"] signature ":? :*"]
(hash-map (hash-map
(keyword query-name) (keyword query-name)
{:name query-name {:name query-name
:signature signature :signature signature
:entity entity :entity entity
:type :select-one-to-many :type :select-one-to-many
:far-entity far-entity :far-entity far-entity
:query :query
(s/join (s/join
"\n" "\n"
(remove (remove
empty? empty?
(case link-type (case link-type
"entity" (list "entity" (list
(str "-- :name " query-name " " signature) (str "-- :name " query-name " " signature)
(str "-- :doc lists all existing " pretty-far " records related to a given " pretty-name) (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 "SELECT DISTINCT lv_" entity-safe ".* \nFROM lv_" entity-safe)
(str "WHERE lv_" entity-safe "." (safe-name % :sql) " = :id") (str "WHERE lv_" entity-safe "." (safe-name % :sql) " = :id")
(order-by-clause entity "lv_" false)) (order-by-clause entity "lv_" false))
"link" (let [ltn "link" (let [ltn
(link-table-name % entity far-entity)] (link-table-name % entity far-entity)]
(list (list
(str "-- :name " query-name " " signature) (str "-- :name " query-name " " signature)
(str "-- :doc links all existing " pretty-far " records related to a given " pretty-name) (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 "SELECT DISTINCT lv_" safe-far ".* \nFROM lv_" safe-far ", " ltn)
(str "WHERE lv_" safe-far "." (str "WHERE lv_" safe-far "."
(safe-name (first (key-names far-entity)) :sql) (safe-name (first (key-names far-entity)) :sql)
" = " ltn "." (singularise safe-far) "_id") " = " ltn "." (singularise safe-far) "_id")
(str "\tAND " ltn "." (singularise entity-safe) "_id = :id") (str "\tAND " ltn "." (singularise entity-safe) "_id = :id")
(order-by-clause far-entity "lv_" false))) (order-by-clause far-entity "lv_" false)))
"list" (list "list" (list
(str "-- :name " query-name " " signature) (str "-- :name " query-name " " signature)
(str "-- :doc lists all existing " pretty-far " records related to a given " pretty-name) (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 "SELECT DISTINCT lv_" safe-far ".* \nFROM lv_" safe-far)
(str "WHERE lv_" safe-far "." (safe-name (first (key-names far-entity)) :sql) " = :id") (str "WHERE lv_" safe-far "." (safe-name (first (key-names far-entity)) :sql) " = :id")
(order-by-clause far-entity "lv_" false)) (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))))
links))))
(defn delete-query (defn delete-query

8
src/adl/to_psql.clj
View file

@ -3,10 +3,9 @@
adl.to-psql adl.to-psql
(:require [adl-support.core :refer :all] (:require [adl-support.core :refer :all]
[adl-support.utils :refer :all] [adl-support.utils :refer :all]
[adl.to-hugsql-queries :refer [queries]] ;; [adl.to-hugsql-queries :refer [queries]]
[clojure.java.io :refer [file make-parents writer]] [clojure.java.io :refer [make-parents]]
[clojure.string :as s] [clojure.string :as s]
[clojure.xml :as x]
[clj-time.core :as t] [clj-time.core :as t]
[clj-time.format :as f])) [clj-time.format :as f]))
@ -221,7 +220,7 @@
(if (if
key? key?
"NOT NULL PRIMARY KEY" "NOT NULL PRIMARY KEY"
(if (= (:required (:attrs property)) "true") "NOT NULL")))))))))) (when (= (:required (:attrs property)) "true") "NOT NULL"))))))))))
(defn compose-convenience-entity-field (defn compose-convenience-entity-field
@ -267,6 +266,7 @@
(all-properties entity) (all-properties entity)
(user-distinct-properties entity))))))) (user-distinct-properties entity)))))))
(declare compose-convenience-where-clause)
(defn compose-convenience-where-clause (defn compose-convenience-where-clause
"Compose an SQL `WHERE` clause for a convenience view of this "Compose an SQL `WHERE` clause for a convenience view of this

300
src/adl/validator.clj
View file

@ -1,16 +1,16 @@
(ns ^{:doc "Application Description Language: validator for ADL structure. (ns ^{:doc "Application Description Language: validator for ADL structure.
TODO: this is at present largely a failed experiment." TODO: this is at present largely a failed experiment."
:author "Simon Brooke"} :author "Simon Brooke"}
adl.validator adl.validator
(:require [adl-support.utils :refer :all] (:require [adl-support.utils :refer []]
[clojure.set :refer [union]] [clojure.set :refer [union]]
[clojure.xml :refer [parse]] [clojure.xml :refer [parse]]
[bouncer.core :as b] [bouncer.core :as b]
[bouncer.validators :as v])) [bouncer.validators :as v :refer [every member required string]]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; ;;;;
;;;; Application Description Language: validator for ADL structure ;;;; squirrel-parse.to-adl: validate Application Description Language.
;;;; ;;;;
;;;; This program is free software; you can redistribute it and/or ;;;; This program is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU General Public License ;;;; modify it under the terms of the GNU General Public License
@ -40,14 +40,14 @@
"Pass this `validation` and the object `o` to bouncer" "Pass this `validation` and the object `o` to bouncer"
[o validation] [o validation]
(if (if
(symbol? validation) (symbol? validation)
(try (try
(b/validate o validation) (b/validate o validation)
(catch java.lang.ClassCastException c (catch java.lang.ClassCastException c
;; The validator regularly barfs on strings, which are perfectly ;; The validator regularly barfs on strings, which are perfectly
;; valid content of some elements. I need a way to validate ;; valid content of some elements. I need a way to validate
;; elements where they're not tolerated! ;; elements where they're not tolerated!
(if (string? o) [nil o])) (when (string? o) [nil o]))
(catch Exception e (catch Exception e
[{:error (.getName (.getClass e)) [{:error (.getName (.getClass e))
:message (.getMessage e) :message (.getMessage e)
@ -61,20 +61,20 @@
OK, so: most of the validators will (usually) fail, and that's OK. How 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?" do we identify the one which ought not to have failed?"
[o & validations] [o & validations]
`(println (println
(str (str
(if (:tag ~o) (str "Tag: " (:tag ~o) "; ")) (when (:tag o) (str "Tag: " (:tag o) "; "))
(if (:name (:attrs ~o)) (str "Name: " (:name (:attrs ~o)) ";")) (when (:name (:attrs o)) (str "Name: " (:name (:attrs o)) ";"))
(if-not (or (:tag ~o) (:name (:attrs ~o))) (str "Context: " ~o)))) (when-not (or (:tag o) (:name (:attrs o))) (str "Context: " o))))
`(empty?
(remove :tag (remove nil? (map first (map (empty?
#(try-validate ~o '%) (remove :tag (remove nil? (map first (map
~validations)))))) #(try-validate o '%)
validations))))))
;;; the remainder of this file is a fairly straight translation of the ADL 1.4 DTD into Clojure ;;; 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 (def permissions
"permissions a group may have on an entity, list, page, form or field "permissions a group may have on an entity, list, page, form or field
@ -105,7 +105,7 @@
#{"all", "all-delete-orphan", "delete", "manual", "save-update"}) #{"all", "all-delete-orphan", "delete", "manual", "save-update"})
(def defineable-data-types (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 e.g. a string can be used with a regexp or a scalar can be used with
min and max values min and max values
* `string`: varchar java.sql.Types.VARCHAR * `string`: varchar java.sql.Types.VARCHAR
@ -128,8 +128,8 @@
* `text`: text or java.sql.Types.LONGVARCHAR * `text`: text or java.sql.Types.LONGVARCHAR
memo java.sql.Types.CLOB" memo java.sql.Types.CLOB"
(union (union
defineable-data-types defineable-data-types
#{"boolean" "text"})) #{"boolean" "text"}))
(def complex-data-types (def complex-data-types
"data types which are more complex than SimpleDataTypes... "data types which are more complex than SimpleDataTypes...
@ -169,7 +169,7 @@
(def sequences #{"canonical", "reverse-canonical"}) (def sequences #{"canonical", "reverse-canonical"})
(def reference-validations (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. and do not contribute to the engineering of the application described.
A reference element is a reference to a specifying document. A reference element is a reference to a specifying document.
@ -190,9 +190,18 @@
[:attrs :property] v/string ;; and should be the name of a property in that entity [:attrs :property] v/string ;; and should be the name of a property in that entity
:content [[v/every documentation-validations]]}) :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 (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. and do not contribute to the engineering of the application described.
A specification element is intended chiefly to declare the reference A specification element is intended chiefly to declare the reference
@ -207,30 +216,33 @@
[:attrs :name] [v/string v/required] [:attrs :name] [v/string v/required]
[:attrs :abbr] [v/string v/required] [:attrs :abbr] [v/string v/required]
:content [[v/every #(disjunct-valid? :content [[v/every #(disjunct-valid?
%
documentation-validations documentation-validations
reference-validations)]]}) reference-validations)]]})
(v/defvalidator documentation-content-validator
{:default-message-format "%s must be a sequence containing only strings and references"}
[value]
(let
[no-strings (remove string? value)]
(and
(every? map? no-strings)
(map #(b/valid? % reference-validations) no-strings))))
(def documentation-validations (def documentation-validations
"contains documentation on the element which immediately contains it. TODO: "contains documentation on the element which immediately contains it. For
should HTML markup within a documentation element be allowed? If so, are the time being, HTML markup is not permitted within documentation, but
there restrictions?" Markdown (which may include a string representation of HTML markup) should
be."
{:tag [v/required [#(= % :documentation)]] {:tag [v/required [#(= % :documentation)]]
:content documentation-content-validator}) :content [[v/every #(disjunct-valid?
%
v/string
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 (def content-validations
{:tag [v/required [#(= % :content)]]}) {:tag [v/required [#(= % :content)]]})
(def help-validations (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 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 per locale; if there are more than one all those matching the locale may
be concatenated, or just one may be used. be concatenated, or just one may be used.
@ -270,7 +282,7 @@
(def prompt-validations (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 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 per locale; if there are more than one all those matching the locale may
be concatenated, or just one may be used. be concatenated, or just one may be used.
@ -296,6 +308,17 @@
(b/valid? % documentation-validations) (b/valid? % documentation-validations)
(b/valid? % prompt-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 (def pragma-validations
"pragmatic advice to generators of lists and forms, in the form of "pragmatic advice to generators of lists and forms, in the form of
name/value pairs which may contain anything. Over time some pragmas name/value pairs which may contain anything. Over time some pragmas
@ -323,8 +346,8 @@
[:attrs :action] [v/string v/required [v/member generator-actions]] [:attrs :action] [v/string v/required [v/member generator-actions]]
[:attrs :class] v/string [:attrs :class] v/string
:content [[v/every #(disjunct-valid? % :content [[v/every #(disjunct-valid? %
documentation-validations documentation-validations
param-validations)]]}) param-validations)]]})
(def in-implementation-validations (def in-implementation-validations
@ -340,7 +363,7 @@
[:attrs :target] [v/string v/required] [:attrs :target] [v/string v/required]
[:attrs :value] [v/string v/required] [:attrs :value] [v/string v/required]
[:attrs :kind] v/string [:attrs :kind] v/string
:content [[v/every #(b/valid? % documentation-validations)]]}) :content [[v/every documentation-validations]]})
(def typedef-validations (def typedef-validations
"the definition of a defined type. At this stage a defined type is either "the definition of a defined type. At this stage a defined type is either
@ -362,22 +385,22 @@
[:attrs :name] [v/required v/string] [:attrs :name] [v/required v/string]
[:attrs :type] [[v/member defineable-data-types]] [:attrs :type] [[v/member defineable-data-types]]
[:attrs :size] [[#(if [:attrs :size] [[#(if
(string? %) (string? %)
(integer? (read-string %)) (integer? (read-string %))
(integer? %))]] (integer? %))]]
[:attrs :pattern] v/string [:attrs :pattern] v/string
[:attrs :minimum] [[#(if [:attrs :minimum] [[#(if
(string? %) (string? %)
(integer? (read-string %)) (integer? (read-string %))
(integer? %))]] (integer? %))]]
[:attrs :maximum] [[#(if [:attrs :maximum] [[#(if
(string? %) (string? %)
(integer? (read-string %)) (integer? (read-string %))
(integer? %))]] (integer? %))]]
:content [[v/every #(or :content [[v/every #(or
(b/valid? % documentation-validations) (b/valid? % documentation-validations)
(b/valid? % in-implementation-validations) (b/valid? % in-implementation-validations)
(b/valid? % help-validations))]]}) (b/valid? % help-validations))]]})
(def group-validations (def group-validations
"a group of people with similar permissions to one another "a group of people with similar permissions to one another
@ -387,10 +410,10 @@
{:tag [v/required [#(= % :group)]] {:tag [v/required [#(= % :group)]]
[:attrs :name] [v/string v/required] [:attrs :name] [v/string v/required]
[:attrs :parent] v/string [:attrs :parent] v/string
:content [[v/every #(b/valid? % documentation-validations)]]}) :content [[v/every documentation-validations]]})
(def property-validations (def property-validations
"a property (field) of an entity (table) "a property (field) of an entity (table)
* `name`: the name of this property. * `name`: the name of this property.
* `type`: the type of this property. * `type`: the type of this property.
@ -428,34 +451,53 @@
committed to persistent store, the value which it holds before committed to persistent store, the value which it holds before
it has been committed" it has been committed"
{:tag [v/required [#(= % :property)]] {: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 :distinct] [v/string [v/member #{"none", "all", "user", "system"}]]
[:attrs :entity] v/string [:attrs :entity] v/string
[:attrs :farkey] v/string [:attrs :farkey] v/string
[:attrs :required] [[v/member #{"true", "false"}]]
[:attrs :immutable] [[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 [:attrs :size] [[#(cond
(empty? %) ;; it's allowed to be missing (empty? %) ;; it's allowed to be missing
true true
(string? %) (string? %)
(integer? (read-string %)) (integer? (read-string %))
true :else
(integer? %))]] (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 :column] v/string
[:attrs :concrete] [[v/member #{"true", "false"}]] [:attrs :concrete] [[v/member #{"true", "false"}]]
[:attrs :cascade] [[v/member cascade-actions]] :content [[v/every #(disjunct-valid? %
;; :content [[v/every #(disjunct-valid? % documentation-validations
;; documentation-validations generator-validations
;; generator-validations permission-validations
;; permission-validations option-validations
;; option-validations prompt-validations
;; prompt-validations help-validations
;; help-validations ifmissing-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 (def permission-validations
@ -489,10 +531,10 @@
{:tag [v/required [#(= % :field)]] {:tag [v/required [#(= % :field)]]
[:attrs :property] [v/string v/required] ;; and it must also be the name of a property in the current entity [:attrs :property] [v/string v/required] ;; and it must also be the name of a property in the current entity
:content [[v/every #(or :content [[v/every #(or
(b/valid? % documentation-validations) (b/valid? % documentation-validations)
(b/valid? % prompt-validations) (b/valid? % prompt-validations)
(b/valid? % permission-validations) (b/valid? % permission-validations)
(b/valid? % help-validations))]]}) (b/valid? % help-validations))]]})
(def verb-validations (def verb-validations
"a verb is something that may be done through a form. Probably the verbs 'store' "a verb is something that may be done through a form. Probably the verbs 'store'
@ -529,12 +571,12 @@
[:attrs :onselect] v/string [:attrs :onselect] v/string
[:attrs :canadd] v/boolean [:attrs :canadd] v/boolean
:content [[v/every #(or :content [[v/every #(or
(b/valid? % documentation-validations) (b/valid? % documentation-validations)
(b/valid? % prompt-validations) (b/valid? % prompt-validations)
(b/valid? % field-validations) (b/valid? % field-validations)
(b/valid? % fieldgroup-validations) (b/valid? % fieldgroup-validations)
(b/valid? % auxlist-validations) (b/valid? % auxlist-validations)
(b/valid? % verb-validations))]]}) (b/valid? % verb-validations))]]})
(def fieldgroup-validations (def fieldgroup-validations
"a group of fields and other controls within a form or list, which the "a group of fields and other controls within a form or list, which the
@ -542,14 +584,14 @@
{:tag [v/required [#(= % :fieldgroup)]] {:tag [v/required [#(= % :fieldgroup)]]
[:attrs :name] [v/string v/required] [:attrs :name] [v/string v/required]
:content [[v/every #(or :content [[v/every #(or
(b/valid? % documentation-validations) (b/valid? % documentation-validations)
(b/valid? % prompt-validations) (b/valid? % prompt-validations)
(b/valid? % permission-validations) (b/valid? % permission-validations)
(b/valid? % help-validations) (b/valid? % help-validations)
(b/valid? % field-validations) (b/valid? % field-validations)
(b/valid? % fieldgroup-validations) (b/valid? % fieldgroup-validations)
(b/valid? % auxlist-validations) (b/valid? % auxlist-validations)
(b/valid? % verb-validations))]]}) (b/valid? % verb-validations))]]})
(def form-validations (def form-validations
@ -559,16 +601,16 @@
[:attrs :properties] [v/required [v/member #{"all", "user-distinct", "listed"}]] [:attrs :properties] [v/required [v/member #{"all", "user-distinct", "listed"}]]
[:attrs :canadd] [[v/member #{"true", "false"}]] [:attrs :canadd] [[v/member #{"true", "false"}]]
:content [[v/every #(disjunct-valid? % :content [[v/every #(disjunct-valid? %
documentation-validations documentation-validations
head-validations head-validations
top-validations top-validations
foot-validations foot-validations
field-validations field-validations
fieldgroup-validations fieldgroup-validations
auxlist-validations auxlist-validations
verb-validations verb-validations
permission-validations permission-validations
pragma-validations)]]}) pragma-validations)]]})
(def page-validations (def page-validations
"a page on which an entity may be displayed" "a page on which an entity may be displayed"
@ -576,16 +618,16 @@
[:attrs :name] [v/required v/string] [:attrs :name] [v/required v/string]
[:attrs :properties] [v/required [v/member #{"all", "user-distinct", "listed"}]] [:attrs :properties] [v/required [v/member #{"all", "user-distinct", "listed"}]]
:content [[v/every #(disjunct-valid? % :content [[v/every #(disjunct-valid? %
documentation-validations documentation-validations
head-validations head-validations
top-validations top-validations
foot-validations foot-validations
field-validations field-validations
fieldgroup-validations fieldgroup-validations
auxlist-validations auxlist-validations
verb-validations verb-validations
permission-validations permission-validations
pragma-validations)]]}) pragma-validations)]]})
(def list-validations (def list-validations
"a list on which entities of a given type are listed "a list on which entities of a given type are listed
@ -597,21 +639,21 @@
[:attrs :properties] [v/required [v/member #{"all", "user-distinct", "listed"}]] [:attrs :properties] [v/required [v/member #{"all", "user-distinct", "listed"}]]
[:attrs :onselect] v/string [:attrs :onselect] v/string
:content [[v/every #(disjunct-valid? % :content [[v/every #(disjunct-valid? %
documentation-validations documentation-validations
head-validations head-validations
top-validations top-validations
foot-validations foot-validations
field-validations field-validations
fieldgroup-validations fieldgroup-validations
auxlist-validations auxlist-validations
verb-validations verb-validations
permission-validations permission-validations
pragma-validations pragma-validations
order-validations)]]}) order-validations)]]})
(def key-validations (def key-validations
{:tag [v/required [#(= % :key)]] {:tag [v/required [#(= % :key)]]
:content [[v/every #(b/validate % property-validations)]]}) :content [[v/every property-validations]]})
(def entity-validations (def entity-validations
@ -635,15 +677,15 @@
[:attrs :table] v/string [:attrs :table] v/string
[:attrs :foreign] [[v/member #{"true", "false"}]] [:attrs :foreign] [[v/member #{"true", "false"}]]
:content [[v/every #(disjunct-valid? % :content [[v/every #(disjunct-valid? %
documentation-validations documentation-validations
prompt-validations prompt-validations
content-validations content-validations
key-validations key-validations
property-validations property-validations
permission-validations permission-validations
form-validations form-validations
page-validations page-validations
list-validations)]]}) list-validations)]]})
(def application-validations (def application-validations
{:tag [v/required [#(= % :application)]] {:tag [v/required [#(= % :application)]]
@ -652,12 +694,12 @@
[:attrs :revision] v/string [:attrs :revision] v/string
[:attrs :currency] v/string [:attrs :currency] v/string
:content [[v/every #(disjunct-valid? % :content [[v/every #(disjunct-valid? %
specification-validations specification-validations
documentation-validations documentation-validations
content-validations content-validations
typedef-validations typedef-validations
group-validations group-validations
entity-validations)]]}) entity-validations)]]})
(defn valid-adl? (defn valid-adl?

397
test/adl/to_hugsql_queries_test.clj
View file

@ -1,76 +1,62 @@
(ns adl.to-hugsql-queries-test (ns adl.to-hugsql-queries-test
(:require [clojure.string :as s] (:require [clojure.string :as s]
[clojure.test :refer :all] [clojure.test :refer [deftest is testing]]
[adl.to-hugsql-queries :refer :all] [adl.to-hugsql-queries :refer [delete-query insert-query list-query order-by-clause search-query select-query update-query]]
[adl-support.utils :refer :all])) [adl-support.utils :refer [child-with-tag has-non-key-properties? has-primary-key? key-names]]))
(defn string-equal-ignore-whitespace? (defn string-equal-ignore-whitespace?
"I don't want unit tests to fail just because emitted whitespace changes." "I don't want unit tests to fail just because emitted whitespace changes."
[a b] [a b]
(if (if
(and (and
(string? a) (string? a)
(string? b)) (string? b))
(let (let
[pattern #"[\s]+" [pattern #"[\s]+"
aa (s/replace (s/trim a) pattern " ") aa (s/replace a pattern " ")
bb (s/replace (s/trim b) pattern " ")] bb (s/replace b pattern " ")]
(= aa bb)) (= aa bb))
(= a b))) (= a b)))
(string-equal-ignore-whitespace?
"-- :name create-address! :<!\n-- :doc creates a new address record\nINSERT INTO address (street,\n\ttown,\n\tpostcode)\nVALUES (:street,\n\t:town,\n\t:postcode)\nreturning postcode,\n\tid" "-- :name create-address! :<!\n -- :doc creates a new address record\n INSERT INTO address (street,\n town,\n postcode)\n VALUES (':street',\n ':town',\n ':postcode')\n returning\n postcode,\n id")
(s/replace
"-- :name create-address! :<!\n-- :doc creates a new address record\nINSERT INTO address (street,\n\ttown,\n\tpostcode)\nVALUES (:street,\n\t:town,\n\t:postcode)\nreturning postcode,\n\tid"
#"[\s]+"
" ")
(s/replace
(s/trim "-- :name update-address! :! :n\n -- :doc updates an existing address record\n UPDATE address\n SET street = :street,\n town = :town,\n postcode = :postcode\n WHERE address.id = :id\n AND address.postcode = :postcode\n\n")
#"[\s]+"
" ")
(deftest order-by-tests (deftest order-by-tests
(let [application {:tag :application, (let [application {:tag :application,
:attrs {:version "0.1.1", :name "test-app"}, :attrs {:version "0.1.1", :name "test-app"},
:content :content
[{:tag :entity, [{:tag :entity,
:attrs {:name "address"}, :attrs {:name "address"},
:content :content
[{:tag :key, [{:tag :key,
:attrs nil, :attrs nil,
:content :content
[{:tag :property, [{:tag :property,
:attrs :attrs
{:immutable "true", {:immutable "true",
:required "true", :required "true",
:distinct "system", :distinct "system",
:type "integer", :type "integer",
:name "id"}, :name "id"},
:content :content
[{:tag :generator, :attrs {:action "native"}, :content nil}]} [{:tag :generator, :attrs {:action "native"}, :content nil}]}
{:tag :property, {:tag :property,
:attrs :attrs
{:immutable "true", {:immutable "true",
:required "true", :required "true",
:distinct "all", :distinct "all",
:generator "assigned" :generator "assigned"
:type "string", :type "string",
:size "12" :size "12"
:name "postcode"}, :name "postcode"},
:content :content
[{:tag :generator, :attrs {:action "native"}, :content nil}]} [{:tag :generator, :attrs {:action "native"}, :content nil}]}]}
]} {:tag :property,
{:tag :property, :attrs
:attrs {:distinct "user", :size "128", :type "string", :name "street"},
{:distinct "user", :size "128", :type "string", :name "street"}, :content nil}
:content nil} {:tag :property,
{:tag :property, :attrs {:size "64", :type "string", :name "town"},
:attrs {:size "64", :type "string", :name "town"}, :content nil}]}]}
:content nil}
]}]}
entity (child-with-tag application :entity)] 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 (let [expected
"ORDER BY address.street, address.postcode, address.id" "ORDER BY address.street, address.postcode, address.id"
actual (order-by-clause entity)] actual (order-by-clause entity)]
@ -78,44 +64,42 @@
(deftest keys-name-extraction-tests (deftest keys-name-extraction-tests
(let [application {:tag :application, (let [application {:tag :application,
:attrs {:version "0.1.1", :name "test-app"}, :attrs {:version "0.1.1", :name "test-app"},
:content :content
[{:tag :entity, [{:tag :entity,
:attrs {:name "address"}, :attrs {:name "address"},
:content :content
[{:tag :key, [{:tag :key,
:attrs nil, :attrs nil,
:content :content
[{:tag :property, [{:tag :property,
:attrs :attrs
{:immutable "true", {:immutable "true",
:required "true", :required "true",
:distinct "system", :distinct "system",
:type "integer", :type "integer",
:name "id"}, :name "id"},
:content :content
[{:tag :generator, :attrs {:action "native"}, :content nil}]} [{:tag :generator, :attrs {:action "native"}, :content nil}]}
{:tag :property, {:tag :property,
:attrs :attrs
{:immutable "true", {:immutable "true",
:required "true", :required "true",
:distinct "all", :distinct "all",
:generator "assigned" :generator "assigned"
:type "string", :type "string",
:size "12" :size "12"
:name "postcode"}, :name "postcode"},
:content :content
[{:tag :generator, :attrs {:action "native"}, :content nil}]} [{:tag :generator, :attrs {:action "native"}, :content nil}]}]}
]} {:tag :property,
{:tag :property, :attrs
:attrs {:distinct "user", :size "128", :type "string", :name "street"},
{:distinct "user", :size "128", :type "string", :name "street"}, :content nil}
:content nil} {:tag :property,
{:tag :property, :attrs {:size "64", :type "string", :name "town"},
:attrs {:size "64", :type "string", :name "town"}, :content nil}]}]}
:content nil}
]}]}
entity (child-with-tag application :entity)] entity (child-with-tag application :entity)]
(testing "keys name extraction" (testing "keys name extraction"
(let [expected #{"id" "postcode"} (let [expected #{"id" "postcode"}
@ -124,41 +108,42 @@
(deftest entity-tests (deftest entity-tests
;; NOTE: generally identical to `complex-key-tests`, below, except that the key is not complex
(let [application {:tag :application, (let [application {:tag :application,
:attrs {:version "0.1.1", :name "test-app"}, :attrs {:version "0.1.1", :name "test-app"},
:content :content
[{:tag :entity, [{:tag :entity,
:attrs {:name "address"}, :attrs {:name "address"},
:content :content
[{:tag :key, [{:tag :key,
:attrs nil, :attrs nil,
:content :content
[{:tag :property, [{:tag :property,
:attrs :attrs
{:immutable "true", {:immutable "true",
:required "true", :required "true",
:distinct "system", :distinct "system",
:type "integer", :type "integer",
:name "id"}, :name "id"},
:content :content
[{:tag :generator, :attrs {:action "native"}, :content nil}]} [{:tag :generator, :attrs {:action "native"}, :content nil}]}
]} {:tag :property,
{:tag :property, :attrs
:attrs {:immutable "true",
{:distinct "user", :size "128", :type "string", :name "street"}, :required "true",
:content nil} :distinct "all",
{:tag :property, :generator "assigned"
:attrs {:size "64", :type "string", :name "town"}, :type "string",
:content nil} :size "12"
{:tag :property, :name "postcode"},
:attrs :content
{:required "true", [{:tag :generator, :attrs {:action "native"}, :content nil}]}]}
:distinct "user", {:tag :property,
:type "string", :attrs
:size "12" {:distinct "user", :size "128", :type "string", :name "street"},
:name "postcode"}} :content nil}
]}]} {:tag :property,
:attrs {:size "64", :type "string", :name "town"},
:content nil}]}]}
entity (child-with-tag application :entity)] entity (child-with-tag application :entity)]
(testing "keys name extraction" (testing "keys name extraction"
(let [expected #{"id"} (let [expected #{"id"}
@ -173,19 +158,19 @@
actual (has-non-key-properties? entity)] actual (has-non-key-properties? entity)]
(is (string-equal-ignore-whitespace? actual expected)))) (is (string-equal-ignore-whitespace? actual expected))))
(testing "insert query generation" (testing "insert query generation"
(let [expected "-- :name create-address! :<! (let [expected "-- :name create-address! :! :n
-- :doc creates a new address record -- :doc creates a new address record
INSERT INTO address (street, INSERT INTO address (street,
town, town,
postcode) postcode)
VALUES (:street, VALUES (':street',
:town, ':town',
:postcode) ':postcode')
returning id" returning id\n\n"
actual (:query (first (vals (insert-query entity))))] actual (:query (first (vals (insert-query entity))))]
(is (string-equal-ignore-whitespace? actual expected)))) (is (string-equal-ignore-whitespace? actual expected))))
(testing "insert query signature" (testing "insert query signature"
(let [expected ":<!" (let [expected ":! :n"
actual (:signature (first (vals (insert-query entity))))] actual (:signature (first (vals (insert-query entity))))]
(is (string-equal-ignore-whitespace? actual expected)))) (is (string-equal-ignore-whitespace? actual expected))))
(testing "update query generation" (testing "update query generation"
@ -195,7 +180,7 @@
SET street = :street, SET street = :street,
town = :town, town = :town,
postcode = :postcode postcode = :postcode
WHERE address.id = :id" WHERE address.id = :id\n\n"
actual (:query (first (vals (update-query entity))))] actual (:query (first (vals (update-query entity))))]
(is (string-equal-ignore-whitespace? actual expected)))) (is (string-equal-ignore-whitespace? actual expected))))
(testing "update query signature" (testing "update query signature"
@ -203,32 +188,28 @@
actual (:signature (first (vals (update-query entity))))] actual (:signature (first (vals (update-query entity))))]
(is (string-equal-ignore-whitespace? actual expected)))) (is (string-equal-ignore-whitespace? actual expected))))
(testing "search query generation" (testing "search query generation"
(let [expected "-- :name search-strings-address :? :* (let [expected "-- :name search-strings-addres :? :1
-- :doc selects existing address records having any string field matching the parameter of the same name by substring match -- :doc selects existing address records having any string field matching `:pattern` by substring match
SELECT DISTINCT * FROM lv_address SELECT * FROM address
WHERE true WHERE street LIKE '%:pattern%'
--~ (if (:street params) (str \"AND street LIKE '%\" (:street params) \"%' \")) OR town LIKE '%:pattern%'
--~ (if (:town params) (str \"AND town LIKE '%\" (:town params) \"%' \")) OR postcode LIKE '%:pattern%'
--~ (if (:postcode params) (str \"AND postcode LIKE '%\" (:postcode params) \"%' \")) ORDER BY address.street,
--~ (if (:id params) (str \"AND id = :id\")) address.postcode,
ORDER BY lv_address.street, address.id
lv_address.postcode,
lv_address.id
--~ (if (:offset params) \"OFFSET :offset \") --~ (if (:offset params) \"OFFSET :offset \")
--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")" --~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")\n\n"
actual (:query (first (vals (search-query entity application))))] actual (:query (first (vals (search-query entity application))))]
(is (string-equal-ignore-whitespace? actual expected)))) (is (string-equal-ignore-whitespace? actual expected))))
(testing "search query signature" (testing "search query signature"
(let [expected ":? :*" (let [expected ":? :1"
actual (:signature (first (vals (search-query entity application))))] actual (:signature (first (vals (search-query entity))))]
(is (string-equal-ignore-whitespace? actual expected)))) (is (string-equal-ignore-whitespace? actual expected))))
(testing "select query generation" (testing "select query generation"
(let [expected "-- :name get-address :? :1 (let [expected "-- :name get-addres :? :1
-- :doc selects an existing address record -- :doc selects an existing addres record
SELECT * FROM address\nWHERE address.id = :id SELECT * FROM address
ORDER BY address.street, WHERE address.id = :id\n\n"
address.postcode,
address.id"
actual (:query (first (vals (select-query entity))))] actual (:query (first (vals (select-query entity))))]
(is (string-equal-ignore-whitespace? actual expected)))) (is (string-equal-ignore-whitespace? actual expected))))
(testing "select query signature" (testing "select query signature"
@ -237,13 +218,13 @@
(is (string-equal-ignore-whitespace? actual expected)))) (is (string-equal-ignore-whitespace? actual expected))))
(testing "list query generation" (testing "list query generation"
(let [expected "-- :name list-address :? :* (let [expected "-- :name list-address :? :*
-- :doc lists all existing address records -- :doc lists all existing addres records
SELECT DISTINCT lv_address.* FROM lv_address SELECT * FROM address
ORDER BY lv_address.street, ORDER BY address.street,
lv_address.postcode, address.postcode,
lv_address.id address.id
--~ (if (:offset params) \"OFFSET :offset \") --~ (if (:offset params) \"OFFSET :offset \")
--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")" --~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")\n\n"
actual (:query (first (vals (list-query entity))))] actual (:query (first (vals (list-query entity))))]
(is (string-equal-ignore-whitespace? actual expected)))) (is (string-equal-ignore-whitespace? actual expected))))
(testing "list query signature" (testing "list query signature"
@ -254,7 +235,8 @@
(let [expected "-- :name delete-address! :! :n (let [expected "-- :name delete-address! :! :n
-- :doc deletes an existing address record -- :doc deletes an existing address record
DELETE FROM address DELETE FROM address
WHERE address.id = :id" WHERE address.id = :id
ANDaddress.postcode = :postcode"
actual (:query (first (vals (delete-query entity))))] actual (:query (first (vals (delete-query entity))))]
(is (string-equal-ignore-whitespace? actual expected)))) (is (string-equal-ignore-whitespace? actual expected))))
(testing "delete query signature" (testing "delete query signature"
@ -266,41 +248,41 @@
(deftest complex-key-tests (deftest complex-key-tests
(let [application {:tag :application, (let [application {:tag :application,
:attrs {:version "0.1.1", :name "test-app"}, :attrs {:version "0.1.1", :name "test-app"},
:content :content
[{:tag :entity, [{:tag :entity,
:attrs {:name "address"}, :attrs {:name "address"},
:content :content
[{:tag :key, [{:tag :key,
:attrs nil, :attrs nil,
:content :content
[{:tag :property, [{:tag :property,
:attrs :attrs
{:immutable "true", {:immutable "true",
:required "true", :required "true",
:distinct "system", :distinct "system",
:type "integer", :type "integer",
:name "id"}, :name "id"},
:content :content
[{:tag :generator, :attrs {:action "native"}, :content nil}]} [{:tag :generator, :attrs {:action "native"}, :content nil}]}
{:tag :property, {:tag :property,
:attrs :attrs
{:immutable "true", {:immutable "true",
:required "true", :required "true",
:distinct "all", :distinct "all",
:generator "assigned" :generator "assigned"
:type "string", :type "string",
:size "12" :size "12"
:name "postcode"}} :name "postcode"},
]} :content
{:tag :property, [{:tag :generator, :attrs {:action "native"}, :content nil}]}]}
:attrs {:tag :property,
{:distinct "user", :size "128", :type "string", :name "street"}, :attrs
:content nil} {:distinct "user", :size "128", :type "string", :name "street"},
{:tag :property, :content nil}
:attrs {:size "64", :type "string", :name "town"}, {:tag :property,
:content nil} :attrs {:size "64", :type "string", :name "town"},
]}]} :content nil}]}]}
entity (child-with-tag application :entity)] 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, (let [expected "ORDER BY address.street,
@ -313,14 +295,14 @@
actual (key-names entity)] actual (key-names entity)]
(is (string-equal-ignore-whitespace? actual expected)))) (is (string-equal-ignore-whitespace? actual expected))))
(testing "insert query generation - compound key, non system generated field in key" (testing "insert query generation - compound key, non system generated field in key"
(let [expected "-- :name create-address! :<! (let [expected "-- :name create-address! :! :n
-- :doc creates a new address record -- :doc creates a new address record
INSERT INTO address (street, INSERT INTO address (street,
town, town,
postcode) postcode)
VALUES (:street, VALUES (':street',
:town, ':town',
:postcode) ':postcode')
returning returning
postcode, postcode,
id" id"
@ -331,10 +313,9 @@
-- :doc updates an existing address record -- :doc updates an existing address record
UPDATE address UPDATE address
SET street = :street, SET street = :street,
town = :town, town = :town
postcode = :postcode
WHERE address.id = :id WHERE address.id = :id
AND address.postcode = :postcode\n\n" AND address.postcode = ':postcode'\n\n"
actual (:query (first (vals (update-query entity))))] actual (:query (first (vals (update-query entity))))]
(is (string-equal-ignore-whitespace? actual expected)))) (is (string-equal-ignore-whitespace? actual expected))))
(testing "search query generation - user-distinct field in key" (testing "search query generation - user-distinct field in key"

41
test/adl/validator_test.clj
View file

@ -1,9 +1,10 @@
(ns adl.validator-test (ns adl.validator-test
(:require [clojure.java.io :refer [writer]] (:require
[clojure.test :refer :all] [adl.validator :refer :all]
[clojure.xml :refer [parse]] [bouncer.core :refer [valid? validate]]
[adl.validator :refer :all] [clojure.java.io :refer [writer]]
[bouncer.core :refer [valid?]])) [clojure.test :refer :all]
[clojure.xml :refer [parse]]))
;; OK, so where we're up to: documentation breaks validation of the ;; OK, so where we're up to: documentation breaks validation of the
;; element that contains it if the documentation is non-empty. ;; element that contains it if the documentation is non-empty.
@ -125,9 +126,9 @@
:attrs {:name "public"}, :attrs {:name "public"},
:content :content
[{:tag :documentation, :content ["All users"]}]} [{:tag :documentation, :content ["All users"]}]}
expected true expected nil
actual (binding [*out* (writer "/dev/null")] actual (binding [*out* (writer "/dev/null")]
(valid? xml group-validations))] (first (validate xml group-validations)))]
(is (= actual expected))))) (is (= actual expected)))))
(deftest validator-entity (deftest validator-entity
@ -262,9 +263,9 @@
:name "id"}, :name "id"},
:content :content
[{:tag :generator, :attrs {:action "native"}, :content nil}]}]} [{:tag :generator, :attrs {:action "native"}, :content nil}]}]}
expected true expected nil
actual (binding [*out* (writer "/dev/null")] actual (first (binding [*out* (writer "/dev/null")]
(valid? xml key-validations))] (validate xml key-validations)))]
(is (= actual expected))))) (is (= actual expected)))))
(deftest validator-property (deftest validator-property
@ -340,14 +341,14 @@
(deftest validator-option (deftest validator-option
(testing "Validation of option element" (testing "Validation of option element"
(let [xml {:tag :option, (let [xml {:tag :option,
:attrs {:value "Female"}, :attrs {:value "Female"},
:content :content
[{:tag :prompt, [{:tag :prompt,
:attrs {:locale "fr-FR", :prompt "Femme"}, :attrs {:locale "fr-FR", :prompt "Femme"},
:content nil} :content nil}
{:tag :prompt, {:tag :prompt,
:attrs {:locale "en-GB", :prompt "Female"}, :attrs {:locale "en-GB", :prompt "Female"},
:content nil}]} :content nil}]}
expected true expected true
actual (binding [*out* (writer "/dev/null")] actual (binding [*out* (writer "/dev/null")]
(valid? xml option-validations))] (valid? xml option-validations))]
@ -378,8 +379,8 @@
(deftest validator-page (deftest validator-page
(testing "Validation of page element" (testing "Validation of page element"
(let [xml {:tag :page, (let [xml {:tag :page,
:attrs {:properties "all", :name "inspect-person"}, :attrs {:properties "all", :name "inspect-person"},
:content nil} :content nil}
expected true expected true
actual (binding [*out* (writer "/dev/null")] actual (binding [*out* (writer "/dev/null")]
(valid? xml page-validations))] (valid? xml page-validations))]