From 38bcacc376825ad3b9afd1b55318525b0cd65516 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Tue, 20 Mar 2018 16:21:43 +0000 Subject: [PATCH 01/52] Preparing for move to GitHub --- .cvsignore | 2 - .gitignore | 11 + LICENSE | 214 +++++ README.md | 62 ++ TestApp/Auto/1 | 2 - TestApp/Web/Controllers/Auto/1 | 1 - TestApp/Web/Views/Auto/test/1 | 17 - TestApp/testapp.adl.xml | 82 -- UnitTests/Program.cs | 11 - UnitTests/Properties/AssemblyInfo.cs | 36 - UnitTests/UnitTests.csproj | 59 -- .../UnitTests.csproj.FileListAbsolute.txt | 10 - doc/intro.md | 767 ++++++++++++++++++ project.clj | 6 + {schemas => resources/schemas}/adl-1.3.dtd | 0 {schemas => resources/schemas}/adl-1.4.dtd | 0 resources/schemas/adl-1.4.rnc | 545 +++++++++++++ {schemas => resources/schemas}/adl-1.4.rng | 0 resources/schemas/adl-1.4.xsd | 547 +++++++++++++ .../schemas}/permitted-html-head.rng | 0 .../schemas}/permitted-html.rng | 0 {schemas => resources/schemas}/strict.dtd | 0 .../transforms}/adl2activerecord.xslt | 0 .../transforms}/adl2canonical.xslt | 0 .../transforms}/adl2controllerclasses.xslt | 0 .../transforms}/adl2documentation.xslt | 0 .../transforms}/adl2entityclasses.xslt | 0 .../transforms}/adl2hibernate.xslt | 0 .../transforms}/adl2mssql.xslt | 0 .../transforms}/adl2psql.xslt | 0 .../transforms}/adl2views.xslt | 0 .../transforms}/base-type-include.xslt | 0 .../transforms}/csharp-type-include.xslt | 0 .../transforms}/i18n-en-GB-include.xslt | 0 .../transforms}/localise-transform.xslt | 0 .../transforms}/permissions-include.xslt | 0 src/adl/core.clj | 6 + src/adl/to_hugsql_queries.clj | 0 src/adl/to_json_routes.clj | 0 src/adl/validator.clj | 0 test/adl/core_test.clj | 7 + 41 files changed, 2165 insertions(+), 220 deletions(-) delete mode 100755 .cvsignore create mode 100644 .gitignore create mode 100644 LICENSE create mode 100644 README.md delete mode 100755 TestApp/Auto/1 delete mode 100755 TestApp/Web/Controllers/Auto/1 delete mode 100755 TestApp/Web/Views/Auto/test/1 delete mode 100755 TestApp/testapp.adl.xml delete mode 100755 UnitTests/Program.cs delete mode 100755 UnitTests/Properties/AssemblyInfo.cs delete mode 100755 UnitTests/UnitTests.csproj delete mode 100755 UnitTests/obj/Debug/UnitTests.csproj.FileListAbsolute.txt create mode 100644 doc/intro.md create mode 100644 project.clj rename {schemas => resources/schemas}/adl-1.3.dtd (100%) rename {schemas => resources/schemas}/adl-1.4.dtd (100%) create mode 100644 resources/schemas/adl-1.4.rnc rename {schemas => resources/schemas}/adl-1.4.rng (100%) create mode 100644 resources/schemas/adl-1.4.xsd rename {schemas => resources/schemas}/permitted-html-head.rng (100%) rename {schemas => resources/schemas}/permitted-html.rng (100%) rename {schemas => resources/schemas}/strict.dtd (100%) rename {transforms => resources/transforms}/adl2activerecord.xslt (100%) rename {transforms => resources/transforms}/adl2canonical.xslt (100%) rename {transforms => resources/transforms}/adl2controllerclasses.xslt (100%) rename {transforms => resources/transforms}/adl2documentation.xslt (100%) rename {transforms => resources/transforms}/adl2entityclasses.xslt (100%) rename {transforms => resources/transforms}/adl2hibernate.xslt (100%) rename {transforms => resources/transforms}/adl2mssql.xslt (100%) rename {transforms => resources/transforms}/adl2psql.xslt (100%) rename {transforms => resources/transforms}/adl2views.xslt (100%) rename {transforms => resources/transforms}/base-type-include.xslt (100%) rename {transforms => resources/transforms}/csharp-type-include.xslt (100%) rename {transforms => resources/transforms}/i18n-en-GB-include.xslt (100%) rename {transforms => resources/transforms}/localise-transform.xslt (100%) rename {transforms => resources/transforms}/permissions-include.xslt (100%) create mode 100644 src/adl/core.clj create mode 100644 src/adl/to_hugsql_queries.clj create mode 100644 src/adl/to_json_routes.clj create mode 100644 src/adl/validator.clj create mode 100644 test/adl/core_test.clj diff --git a/.cvsignore b/.cvsignore deleted file mode 100755 index 2e9693e..0000000 --- a/.cvsignore +++ /dev/null @@ -1,2 +0,0 @@ -obj -bin \ No newline at end of file diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..c53038e --- /dev/null +++ b/.gitignore @@ -0,0 +1,11 @@ +/target +/classes +/checkouts +pom.xml +pom.xml.asc +*.jar +*.class +/.lein-* +/.nrepl-port +.hgignore +.hg/ diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..d921d3d --- /dev/null +++ b/LICENSE @@ -0,0 +1,214 @@ +THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE PUBLIC +LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR DISTRIBUTION OF THE PROGRAM +CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS AGREEMENT. + +1. DEFINITIONS + +"Contribution" means: + +a) in the case of the initial Contributor, the initial code and +documentation distributed under this Agreement, and + +b) in the case of each subsequent Contributor: + +i) changes to the Program, and + +ii) additions to the Program; + +where such changes and/or additions to the Program originate from and are +distributed by that particular Contributor. A Contribution 'originates' from +a Contributor if it was added to the Program by such Contributor itself or +anyone acting on such Contributor's behalf. Contributions do not include +additions to the Program which: (i) are separate modules of software +distributed in conjunction with the Program under their own license +agreement, and (ii) are not derivative works of the Program. + +"Contributor" means any person or entity that distributes the Program. + +"Licensed Patents" mean patent claims licensable by a Contributor which are +necessarily infringed by the use or sale of its Contribution alone or when +combined with the Program. + +"Program" means the Contributions distributed in accordance with this +Agreement. + +"Recipient" means anyone who receives the Program under this Agreement, +including all Contributors. + +2. GRANT OF RIGHTS + +a) Subject to the terms of this Agreement, each Contributor hereby grants +Recipient a non-exclusive, worldwide, royalty-free copyright license to +reproduce, prepare derivative works of, publicly display, publicly perform, +distribute and sublicense the Contribution of such Contributor, if any, and +such derivative works, in source code and object code form. + +b) Subject to the terms of this Agreement, each Contributor hereby grants +Recipient a non-exclusive, worldwide, royalty-free patent license under +Licensed Patents to make, use, sell, offer to sell, import and otherwise +transfer the Contribution of such Contributor, if any, in source code and +object code form. This patent license shall apply to the combination of the +Contribution and the Program if, at the time the Contribution is added by the +Contributor, such addition of the Contribution causes such combination to be +covered by the Licensed Patents. The patent license shall not apply to any +other combinations which include the Contribution. No hardware per se is +licensed hereunder. + +c) Recipient understands that although each Contributor grants the licenses +to its Contributions set forth herein, no assurances are provided by any +Contributor that the Program does not infringe the patent or other +intellectual property rights of any other entity. Each Contributor disclaims +any liability to Recipient for claims brought by any other entity based on +infringement of intellectual property rights or otherwise. As a condition to +exercising the rights and licenses granted hereunder, each Recipient hereby +assumes sole responsibility to secure any other intellectual property rights +needed, if any. For example, if a third party patent license is required to +allow Recipient to distribute the Program, it is Recipient's responsibility +to acquire that license before distributing the Program. + +d) Each Contributor represents that to its knowledge it has sufficient +copyright rights in its Contribution, if any, to grant the copyright license +set forth in this Agreement. + +3. REQUIREMENTS + +A Contributor may choose to distribute the Program in object code form under +its own license agreement, provided that: + +a) it complies with the terms and conditions of this Agreement; and + +b) its license agreement: + +i) effectively disclaims on behalf of all Contributors all warranties and +conditions, express and implied, including warranties or conditions of title +and non-infringement, and implied warranties or conditions of merchantability +and fitness for a particular purpose; + +ii) effectively excludes on behalf of all Contributors all liability for +damages, including direct, indirect, special, incidental and consequential +damages, such as lost profits; + +iii) states that any provisions which differ from this Agreement are offered +by that Contributor alone and not by any other party; and + +iv) states that source code for the Program is available from such +Contributor, and informs licensees how to obtain it in a reasonable manner on +or through a medium customarily used for software exchange. + +When the Program is made available in source code form: + +a) it must be made available under this Agreement; and + +b) a copy of this Agreement must be included with each copy of the Program. + +Contributors may not remove or alter any copyright notices contained within +the Program. + +Each Contributor must identify itself as the originator of its Contribution, +if any, in a manner that reasonably allows subsequent Recipients to identify +the originator of the Contribution. + +4. COMMERCIAL DISTRIBUTION + +Commercial distributors of software may accept certain responsibilities with +respect to end users, business partners and the like. While this license is +intended to facilitate the commercial use of the Program, the Contributor who +includes the Program in a commercial product offering should do so in a +manner which does not create potential liability for other Contributors. +Therefore, if a Contributor includes the Program in a commercial product +offering, such Contributor ("Commercial Contributor") hereby agrees to defend +and indemnify every other Contributor ("Indemnified Contributor") against any +losses, damages and costs (collectively "Losses") arising from claims, +lawsuits and other legal actions brought by a third party against the +Indemnified Contributor to the extent caused by the acts or omissions of such +Commercial Contributor in connection with its distribution of the Program in +a commercial product offering. The obligations in this section do not apply +to any claims or Losses relating to any actual or alleged intellectual +property infringement. In order to qualify, an Indemnified Contributor must: +a) promptly notify the Commercial Contributor in writing of such claim, and +b) allow the Commercial Contributor to control, and cooperate with the +Commercial Contributor in, the defense and any related settlement +negotiations. The Indemnified Contributor may participate in any such claim +at its own expense. + +For example, a Contributor might include the Program in a commercial product +offering, Product X. That Contributor is then a Commercial Contributor. If +that Commercial Contributor then makes performance claims, or offers +warranties related to Product X, those performance claims and warranties are +such Commercial Contributor's responsibility alone. Under this section, the +Commercial Contributor would have to defend claims against the other +Contributors related to those performance claims and warranties, and if a +court requires any other Contributor to pay any damages as a result, the +Commercial Contributor must pay those damages. + +5. NO WARRANTY + +EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, THE PROGRAM IS PROVIDED ON +AN "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, EITHER +EXPRESS OR IMPLIED INCLUDING, WITHOUT LIMITATION, ANY WARRANTIES OR +CONDITIONS OF TITLE, NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A +PARTICULAR PURPOSE. Each Recipient is solely responsible for determining the +appropriateness of using and distributing the Program and assumes all risks +associated with its exercise of rights under this Agreement , including but +not limited to the risks and costs of program errors, compliance with +applicable laws, damage to or loss of data, programs or equipment, and +unavailability or interruption of operations. + +6. DISCLAIMER OF LIABILITY + +EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, NEITHER RECIPIENT NOR ANY +CONTRIBUTORS SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING WITHOUT LIMITATION +LOST PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OR DISTRIBUTION OF THE PROGRAM OR THE +EXERCISE OF ANY RIGHTS GRANTED HEREUNDER, EVEN IF ADVISED OF THE POSSIBILITY +OF SUCH DAMAGES. + +7. GENERAL + +If any provision of this Agreement is invalid or unenforceable under +applicable law, it shall not affect the validity or enforceability of the +remainder of the terms of this Agreement, and without further action by the +parties hereto, such provision shall be reformed to the minimum extent +necessary to make such provision valid and enforceable. + +If Recipient institutes patent litigation against any entity (including a +cross-claim or counterclaim in a lawsuit) alleging that the Program itself +(excluding combinations of the Program with other software or hardware) +infringes such Recipient's patent(s), then such Recipient's rights granted +under Section 2(b) shall terminate as of the date such litigation is filed. + +All Recipient's rights under this Agreement shall terminate if it fails to +comply with any of the material terms or conditions of this Agreement and +does not cure such failure in a reasonable period of time after becoming +aware of such noncompliance. If all Recipient's rights under this Agreement +terminate, Recipient agrees to cease use and distribution of the Program as +soon as reasonably practicable. However, Recipient's obligations under this +Agreement and any licenses granted by Recipient relating to the Program shall +continue and survive. + +Everyone is permitted to copy and distribute copies of this Agreement, but in +order to avoid inconsistency the Agreement is copyrighted and may only be +modified in the following manner. The Agreement Steward reserves the right to +publish new versions (including revisions) of this Agreement from time to +time. No one other than the Agreement Steward has the right to modify this +Agreement. The Eclipse Foundation is the initial Agreement Steward. The +Eclipse Foundation may assign the responsibility to serve as the Agreement +Steward to a suitable separate entity. Each new version of the Agreement will +be given a distinguishing version number. The Program (including +Contributions) may always be distributed subject to the version of the +Agreement under which it was received. In addition, after a new version of +the Agreement is published, Contributor may elect to distribute the Program +(including its Contributions) under the new version. Except as expressly +stated in Sections 2(a) and 2(b) above, Recipient receives no rights or +licenses to the intellectual property of any Contributor under this +Agreement, whether expressly, by implication, estoppel or otherwise. All +rights in the Program not expressly granted under this Agreement are +reserved. + +This Agreement is governed by the laws of the State of New York and the +intellectual property laws of the United States of America. No party to this +Agreement will bring a legal action under this Agreement more than one year +after the cause of action arose. Each party waives its rights to a jury trial +in any resulting litigation. diff --git a/README.md b/README.md new file mode 100644 index 0000000..b7b9833 --- /dev/null +++ b/README.md @@ -0,0 +1,62 @@ +# Application Description Language + +A language for describing applications, from which code can be automatically generated. + +## History + +This idea started back in 2007, when I felt that web development in Java had really reached the end of the road - one spent all one's time writing boilerplate, and the amount of time taken to achieve anything useful had expanded far beyond common sense. So I thought: write one high level document describing an application; write a series of transforms from that document to the different files required to build the application; and a great deal of time would be saved. + +And this worked. When it was used commercially, the target language was mostly C#, which I don't much like, but... + +Then, in 2010, I had one of my periodic spells of mental illness, and development stopped. Later, when my former employers ceased to develop software, copyright in the project was turned over to me. + +More recently, I've found myself in the same situation with Clojure that I was in 2007 with Java: I'm writing fairly large applications and the amount of mindless boilerplate that has to be written is a real problem. So I'm looking at reviving this old framework and bringing it up to date. + +## Why this is a good idea + +Web applications contain an awful lot of repetitive code. Not only does this take a lot of time to write; when you have an awful lot of repetitive code, if you find a bug in one place and fix it, it also probably has to be found and fixed in many other places. Also, underlying libraries, frameworks and (sometimes) even languages have breaking changes from one version to the next. Fixing the issue in the code generator, and then automatically regenerating the code for all of your applications, is enormously quicker than finding and fixing the issues in each file of each application separately. + +Also, you can port all your applications to new technologies simply by writing transforms for those new technologies and regenerating. + +The idea is that the ADL framework should autogenerate 95% of your application. This means human programmer effort can be concentrated on the 5% which is actually interesting. + +## What exists + +### The DTD + +A Document Type Definition is the core of this; the current version is `adl-1.4.dtd`. + +### XSL transforms + +XSL transforms exist which transform conforming documents as follows: + +* `adl2activerecord.xslt` - generate C# ActiveRecord classes +* `adl2canonical.xslt` - canonicalises ADL, adding useful defaults +* `adl2controllerclasses.xslt` - generates C# controller classes +* `adl2documentation.xslt` - generates documentation +* `adl2entityclasses.xslt` - generates C# entity classes +* `adl2hibernate.xslt` - generates [N]Hibernate mapping files +* `adl2mssql.xslt` - generates Microsoft SQL Server database initialisation scripts +* `adl2psql.xslt` - generates Postgres database initialisation scripts +* `adl2views.xslt` - generates Velocity templates + +All of this worked (well) back in 2010, but it relied on some proprietary libraries which are not my copyright. So you can't just pick it up and use it. But it provides a basis for writing new transforms in XSL, should you choose to do so. + +## Future direction + +Back in 2007, XSLT seemed a really good technology for doing this sort of thing. But it's prolix, and while back then I was expert in it, I don't really use it much now. So my plan is to write future transforms in Clojure, and, because these days I work mostly in Clojure, the transforms I shall write will mostly target the Clojure ecosystem. + +This doesn't mean you can't pick up the framework and write transforms in other languages and/or to other language ecosystems. In fact, I'd encourage you to do so. + +## Contributing + +I will happily accept pull requests for new XSL transforms (although I'd like some evidence they work). I'll also happily accept pull requests for new transforms written in Clojure. Changes to the DTD I shall be more conservative about, simply because there is a potential to break a lot of stuff and the DTD is fairly good. All schemas are generated off the DTD using `[trang](https://github.com/relaxng/jing-trang)`, so there is no point in sending pull requests on schema changes. + +## License + +Copyright © Simon Brooke 2007-2018 + +Distributed under the Eclipse Public License either version 1.0 or (at +your option) any later version. + +Note that you are also entitled to use this project under the terms of the Gnu GPL version 2 or any later version; I generally prefer GPL, but I know that if this project is to be useful to folk it has to be relatively uncomplicated to use in commercial projects. diff --git a/TestApp/Auto/1 b/TestApp/Auto/1 deleted file mode 100755 index 139597f..0000000 --- a/TestApp/Auto/1 +++ /dev/null @@ -1,2 +0,0 @@ - - diff --git a/TestApp/Web/Controllers/Auto/1 b/TestApp/Web/Controllers/Auto/1 deleted file mode 100755 index 8b13789..0000000 --- a/TestApp/Web/Controllers/Auto/1 +++ /dev/null @@ -1 +0,0 @@ - diff --git a/TestApp/Web/Views/Auto/test/1 b/TestApp/Web/Views/Auto/test/1 deleted file mode 100755 index 0aa8241..0000000 --- a/TestApp/Web/Views/Auto/test/1 +++ /dev/null @@ -1,17 +0,0 @@ - - - - - diff --git a/TestApp/testapp.adl.xml b/TestApp/testapp.adl.xml deleted file mode 100755 index 136379f..0000000 --- a/TestApp/testapp.adl.xml +++ /dev/null @@ -1,82 +0,0 @@ - - - - - - - - - - - - - - a postcode follows arcane rules. - - - - - We don't believe people who claim to be over 120. - - - - - - - - - - - - A real (administrative) user of this system with a first-class, database layer login, - as opposed to a Subscriber with a second-class, application layer login. - - - - - - - - - - - - - - - - - - - If the canonical name is a common one, or there are known to be two or more authors - with the same canonical name, some brief text about the author to disambiguate. - - - - - - - The name of the author as entered by the original user, prior to being resolved against known authors - - - - - - - - - diff --git a/UnitTests/Program.cs b/UnitTests/Program.cs deleted file mode 100755 index 1d1c7fb..0000000 --- a/UnitTests/Program.cs +++ /dev/null @@ -1,11 +0,0 @@ -using System; -using System.Collections.Generic; -using System.Linq; -using System.Text; - -namespace UnitTests { - class Program { - static void Main(string[] args) { - } - } -} diff --git a/UnitTests/Properties/AssemblyInfo.cs b/UnitTests/Properties/AssemblyInfo.cs deleted file mode 100755 index a468e4d..0000000 --- a/UnitTests/Properties/AssemblyInfo.cs +++ /dev/null @@ -1,36 +0,0 @@ -using System.Reflection; -using System.Runtime.CompilerServices; -using System.Runtime.InteropServices; - -// General Information about an assembly is controlled through the following -// set of attributes. Change these attribute values to modify the information -// associated with an assembly. -[assembly: AssemblyTitle("UnitTests")] -[assembly: AssemblyDescription("")] -[assembly: AssemblyConfiguration("")] -[assembly: AssemblyCompany("")] -[assembly: AssemblyProduct("UnitTests")] -[assembly: AssemblyCopyright("Copyright © 2008")] -[assembly: AssemblyTrademark("")] -[assembly: AssemblyCulture("")] - -// Setting ComVisible to false makes the types in this assembly not visible -// to COM components. If you need to access a type in this assembly from -// COM, set the ComVisible attribute to true on that type. -[assembly: ComVisible(false)] - -// The following GUID is for the ID of the typelib if this project is exposed to COM -[assembly: Guid("a5d9274a-d36f-45f3-a01a-b552e1a69a77")] - -// Version information for an assembly consists of the following four values: -// -// Major Version -// Minor Version -// Build Number -// Revision -// -// You can specify all the values or you can default the Build and Revision Numbers -// by using the '*' as shown below: -// [assembly: AssemblyVersion("1.0.*")] -[assembly: AssemblyVersion("1.0.0.0")] -[assembly: AssemblyFileVersion("1.0.0.0")] diff --git a/UnitTests/UnitTests.csproj b/UnitTests/UnitTests.csproj deleted file mode 100755 index 3d82050..0000000 --- a/UnitTests/UnitTests.csproj +++ /dev/null @@ -1,59 +0,0 @@ - - - - Debug - AnyCPU - 9.0.21022 - 2.0 - {D705F7CA-EB87-48EF-8F18-7D1AD90660BA} - Exe - Properties - UnitTests - UnitTests - v3.5 - 512 - - - true - full - false - bin\Debug\ - DEBUG;TRACE - prompt - 4 - - - pdbonly - true - bin\Release\ - TRACE - prompt - 4 - - - - - 3.5 - - - 3.5 - - - 3.5 - - - - - - - - - - - \ No newline at end of file diff --git a/UnitTests/obj/Debug/UnitTests.csproj.FileListAbsolute.txt b/UnitTests/obj/Debug/UnitTests.csproj.FileListAbsolute.txt deleted file mode 100755 index 4291642..0000000 --- a/UnitTests/obj/Debug/UnitTests.csproj.FileListAbsolute.txt +++ /dev/null @@ -1,10 +0,0 @@ -C:\Projects\UnitTests\bin\Debug\UnitTests.exe -C:\Projects\UnitTests\bin\Debug\UnitTests.pdb -C:\Projects\UnitTests\obj\Debug\ResolveAssemblyReference.cache -C:\Projects\UnitTests\obj\Debug\UnitTests.exe -C:\Projects\UnitTests\obj\Debug\UnitTests.pdb -C:\Projects\ADL\UnitTests\bin\Debug\UnitTests.exe -C:\Projects\ADL\UnitTests\bin\Debug\UnitTests.pdb -C:\Projects\ADL\UnitTests\obj\Debug\ResolveAssemblyReference.cache -C:\Projects\ADL\UnitTests\obj\Debug\UnitTests.exe -C:\Projects\ADL\UnitTests\obj\Debug\UnitTests.pdb diff --git a/doc/intro.md b/doc/intro.md new file mode 100644 index 0000000..90828b1 --- /dev/null +++ b/doc/intro.md @@ -0,0 +1,767 @@ + Application Description Language framework + +**NOTE**: *this markdown was automatically generated from `adl_user_doc.html`, which in turn was taken from the Wiki page on which this documentation was originally written.* + +Application Description Language framework +========================================== + +Contents +-------- + +* [1 What is Application Description Language?](#What_is_Application_Description_Language.3F) +* [2 Current versions](#Current_versions) +* [3 What is the Application Description Language Framework?](#What_is_the_Application_Description_Language_Framework.3F) +* [4 Why does it matter?](#Why_does_it_matter.3F) + * [4.1 Automated Application Generation](#Automated_Application_Generation) + * [4.2 Integration with hand-written code](#Integration_with_hand-written_code) + * [4.3 High quality auto-generated code](#High_quality_auto-generated_code) +* [5 What can the Application Description Language framework now do?](#What_can_the_Application_Description_Language_framework_now_do.3F) + * [5.1 adl2entityclass.xsl](#adl2entityclass.xsl) + * [5.2 adl2mssql.xsl](#adl2mssql.xsl) + * [5.3 adl2views.xsl](#adl2views.xsl) + * [5.4 adl2controllerclasses.xsl](#adl2controllerclasses.xsl) + * [5.5 adl2hibernate.xsl](#adl2hibernate.xsl) + * [5.6 adl2pgsql.xsl](#adl2pgsql.xsl) +* [6 So is ADL a quick way to build Monorail applications?](#So_is_ADL_a_quick_way_to_build_Monorail_applications.3F) +* [7 Limitations on ADL](#Limitations_on_ADL) + * [7.1 Current limitations](#Current_limitations) + * [7.1.1 Authentication model](#Authentication_model) + * [7.1.2 Alternative Verbs](#Alternative_Verbs) + * [7.2 Inherent limitations](#Inherent_limitations) +* [8 ADL Vocabulary](#ADL_Vocabulary) + * [8.1 Basic definitions](#Basic_definitions) + * [8.1.1 Permissions](#Permissions) + * [8.1.2 Data types](#Data_types) + * [8.1.3 Definable data types](#Definable_data_types) + * [8.1.4 Page content](#Page_content) + * [8.2 The Elements](#The_Elements) + * [8.2.1 Application](#Application) + * [8.2.2 Definition](#Definition) + * [8.2.3 Groups](#Groups) + * [8.2.4 Enities and Properties](#Enities_and_Properties) + * [8.2.5 Options](#Options) + * [8.2.6 Permissions](#Permissions_2) + * [8.2.7 Pragmas](#Pragmas) + * [8.2.8 Prompts, helptexts and error texts](#Prompts.2C_helptexts_and_error_texts) + * [8.2.9 Forms, Pages and Lists](#Forms.2C_Pages_and_Lists) +* [9 Using ADL in your project](#Using_ADL_in_your_project) + * [9.1 Selecting the version](#Selecting_the_version) + * [9.2 Integrating into your build](#Integrating_into_your_build) + * [9.2.1 Properties](#Properties) + * [9.2.2 Canonicalisation](#Canonicalisation) + * [9.2.3 Generate NHibernate mapping](#Generate_NHibernate_mapping) + * [9.2.4 Generate SQL](#Generate_SQL) + * [9.2.5 Generate C# entity classes ('POCOs')](#Generate_C.23_entity_classes_.28.27POCOs.27.29) + * [9.2.6 Generate Monorail controller classes](#Generate_Monorail_controller_classes) + * [9.2.7 Generate Velocity views for use with Monorail](#Generate_Velocity_views_for_use_with_Monorail) + +// + +\[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=1 "Edit section: What is Application Description Language?")\] What is Application Description Language? +-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- + +Application Description Language is an XML vocabulary, defined in a [Document Type Definition](http://en.wikipedia.org/wiki/Document_Type_Definition "http://en.wikipedia.org/wiki/Document_Type_Definition"), which declaratively describes the entities in an application domain, their relationships, and their properties. Because ADL is defined in a formal definition which can be parsed by XML editors, any DTD-aware XML editor (such as that built into Visual studio) can provide context-sensitive auto-completion for ADL, making the vocabulary easy to learn and to edit. It would perhaps be desirable to replace this DTD at some future stage with an XML Schema, since it is desirable to be able to mix HTML in with ADL in the same document. + +ADL is thus a '[Fourth Generation Language](http://en.wikipedia.org/wiki/Fourth-generation_programming_language "http://en.wikipedia.org/wiki/Fourth-generation_programming_language")' as understood in the 1980s - an ultra-high level language for a specific problem domain; but it is a purely declarative 4GL. + +\[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=2 "Edit section: Current versions")\] Current versions +------------------------------------------------------------------------------------------------------------------------------------------------------------------------ + +* The current STABLE version of ADL is 1.1. + * The namespace URL for ADL 1.1 is [http://libs.cygnets.co.uk/adl/1.1/](http://libs.cygnets.co.uk/adl/1.1/ "http://libs.cygnets.co.uk/adl/1.1/") + * Transforms for ADL 1.1 can be found at [http://libs.cygnets.co.uk/adl/1.1/ADL/transforms/](http://libs.cygnets.co.uk/adl/1.1/ADL/transforms/ "http://libs.cygnets.co.uk/adl/1.1/ADL/transforms/") + * The document type definition for ADL 1.1 can be found at [http://libs.cygnets.co.uk/adl/1.1/ADL/schemas/adl-1.1.dtd](http://libs.cygnets.co.uk/adl/1.1/ADL/schemas/adl-1.1.dtd "http://libs.cygnets.co.uk/adl/1.1/ADL/schemas/adl-1.1.dtd") +* the current UNSTABLE version of ADL is 1.2. The namespace URL for ADL 1.2 is [http://libs.cygnets.co.uk/adl/1.2/](http://libs.cygnets.co.uk/adl/1.2/ "http://libs.cygnets.co.uk/adl/1.2/") + * The namespace URL for ADL 1.2 is [http://libs.cygnets.co.uk/adl/1.2/](http://libs.cygnets.co.uk/adl/1.2/ "http://libs.cygnets.co.uk/adl/1.2/") + * Transforms for ADL 1.2 can be found at [http://libs.cygnets.co.uk/adl/1.2/ADL/transforms/](http://libs.cygnets.co.uk/adl/1.2/ADL/transforms/ "http://libs.cygnets.co.uk/adl/1.2/ADL/transforms/") + * The document type definition for ADL 1.2 can be found at [http://libs.cygnets.co.uk/adl/1.2/ADL/schemas/adl-1.2.dtd](http://libs.cygnets.co.uk/adl/1.2/ADL/schemas/adl-1.2.dtd "http://libs.cygnets.co.uk/adl/1.2/ADL/schemas/adl-1.2.dtd") + +\[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=3 "Edit section: What is the Application Description Language Framework?")\] What is the Application Description Language Framework? +------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------ + +The Application Description Language Framework is principally a set of XSL transforms which transform a single ADL file into all the various source files required to build an application. + +\[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=4 "Edit section: Why does it matter?")\] Why does it matter? +------------------------------------------------------------------------------------------------------------------------------------------------------------------------------ + +The average data driven web application comprises pages (lists) which show lists of entities, pages (forms) that edit instances of entities, and pages (inspectors) that show details of instances of entities. That comprises 100% of many applications and 90% of others; traditionally, even with modern tools like Monorail, coding these lists, forms and inspectors has taken 90% of the development effort. + +I realised about three years ago that I was doing essentially the same job over and over again, and I don't like doing that. I see my mission in life as being to automate people out of jobs, and that includes me. So the object of the Application Description Language is to raise the level of abstraction with which we define data driven applications one level higher, and automate the process we have thus far done as programmers. This isn't a new insight; it's fundamentally the same insight that led machine code programmers to develop the first macro assembler, and led assembly language programmers to write the first high level language compiler. Computers are tools which can be used to mung information from one representation to another, and all we need to do is to work out how to write a powerful enough representation, and how to transform it. + +The whole purpose of ADL is to increase productivity - mine, and that of anyone else who chooses to follow me down this path. It is pragmatic technology - it is designed to be an 80/20 or 90/10 solution, taking the repetitious grunt-work out of application development so that we can devote more time to the fun, interesting and novel bits. It is not intended to be an academic, perfect, 100% solution - although for many applications it may in practice be a 100% solution. + +### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=5 "Edit section: Automated Application Generation")\] Automated Application Generation + +Thus to create a new application, all that should be necessary is to create a new ADL file, and to compile it using a single, standardised \[[NAnt](http://nant.sourceforge.net/ "http://nant.sourceforge.net/")\] (or \[[Ant](http://ant.apache.org/ "http://ant.apache.org/")\]) build file using scripts already created as part of the framework. All these scripts (with the exception of the PSQL one, which was pre-existing) have been created as part of the [C1873 - SRU - Hospitality](http://wiki.cygnets.co.uk/index.php/C1873_-_SRU_-_Hospitality "C1873 - SRU - Hospitality") contract, but they contain almost no SRU specific material (and what does exist has been designed to be factored out). Prototype 1 of the SRU Hospitality Application contains no hand-written code whatever - all the application code is automatically generated from the single ADL file. The one exception to this rule is the CSS stylesheet which provides look-and-feel and branding. + +### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=6 "Edit section: Integration with hand-written code")\] Integration with hand-written code + +Application-specific procedural code, covering specific business procedures, may still need to be hand written; the code generated by the ADL framework is specifically designed to make it easy to integrate hand-written code. Thus for example the C# entity controller classes generated are intentionally generated as _partial_ classes, so that they may be complemented by other partial classes which may be manually maintained and held in a version control system. + +### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=7 "Edit section: High quality auto-generated code")\] High quality auto-generated code + +One key objective of the framework is that the code which is generated should be as clear and readable - and as well commented - as the best hand-written code. Consider this example: + + /// + /// Store the record represented by the parameters passed in an HTTP service + /// Without Id -> it's new, I create a new persistent object; + /// With Id -> it's existing, I update the existing persistent object + /// + \[AccessibleThrough( Verb.Post)\] + public void Store() + { + ISession hibernator = + NHibernateHelper.GetCurrentSession( Session\[ NHibernateHelper.USERTOKEN\], + Session\[NHibernateHelper.PASSTOKEN\]); + + SRU.Hospitality.Entities.Event record; + + + if ( Params\[ "instance.Date" \] == null) + { + AddError( "You must supply a value for Date"); + } + + + if ( Params\[ "instance.Description" \] == null) + { + AddError( "You must supply a value for Description"); + } + + + + string id = Params\["instance.EventId"\]; + + if ( String.IsNullOrEmpty( id)) + { + /\* it's new, create persistent object */ + record = new SRU.Hospitality.Entities.Event(); + + /\* perform any domain knowledge behaviour on the new record + \* after instantiation */ + record.AfterCreationHook(); + } + else + { + /\* it's existing, retrieve it */ + record = + hibernator.CreateCriteria(typeof(Event)) + .Add(Expression.Eq("EventId", Int32.Parse(id))) + .UniqueResult(); + } + + if ( record != null) + { + /\* perform any domain knowledge behaviour on the record prior to updating */ + record.BeforeUpdateHook(); + + /\* actually update the record */ + BindObjectInstance( record, ParamStore.Form, "instance"); + + + + /\* write the record to the database, in order to guarantee we have a valid key */ + hibernator.Save(record); + hibernator.Flush(); + + /\* perform any domain knowledge behaviour on the record after updating */ + record.AfterUpdateHook(); + + PropertyBag\["username"\] = Session\[ NHibernateHelper.USERTOKEN\]; + PropertyBag\["instance"\] = record; + + + RenderViewWithFailover("edit.vm", "edit.auto.vm"); + } + else + { + throw new Exception( String.Format( "No record of type Event with key value {0} found", id)); + } + } + +This means that it should be trivial to decide at some point in development of a project to manually modify and maintain auto-generated code. + +\[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=8 "Edit section: What can the Application Description Language framework now do?")\] What can the Application Description Language framework now do? +---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- + +Currently the framework includes: + +### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=9 "Edit section: adl2entityclass.xsl")\] adl2entityclass.xsl + +Transforms the ADL file into C# source files for classes which describe the entities in a manner acceptable to [NHibernate](http://www.hibernate.org/ "http://www.hibernate.org/"), a widely used Object/Relational mapping layer. + +### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=10 "Edit section: adl2mssql.xsl")\] adl2mssql.xsl + +Transforms the ADL file into an SQL script in Microsoft SQL Server 2000 syntax which initialises the database required by the application, with all relationships, permissions, referential integrity constraints and so on. + +### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=11 "Edit section: adl2views.xsl")\] adl2views.xsl + +Transforms the ADL file into [Velocity](http://velocity.apache.org/ "http://velocity.apache.org/") template files as used by the [Monorail](http://www.castleproject.org/monorail/index.html "http://www.castleproject.org/monorail/index.html") framework, one template each for all the lists, forms and inspectors described in the ADL. + +### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=12 "Edit section: adl2controllerclasses.xsl")\] adl2controllerclasses.xsl + +Transforms the ADL file into a series of C# source files for classes which are controllers as used by the Monorail framework. + +### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=13 "Edit section: adl2hibernate.xsl")\] adl2hibernate.xsl + +Transforms the ADL file into a Hibernate mapping file, used by the [Hibernate](http://www.hibernate.org/ "http://www.hibernate.org/") ([Java](http://java.sun.com/ "http://java.sun.com")) and [NHibernate](http://www.hibernate.org/ "http://www.hibernate.org/") (C#) Object/Relational mapping layers. This transform is relatively trivial, since ADL is not greatly different from being a superset of the Hibernate vocabulary - it describes the same sorts of things but in more detail. + +### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=14 "Edit section: adl2pgsql.xsl")\] adl2pgsql.xsl + +Transforms the ADL file into an SQL script in [Postgres](http://www.postgresql.org/ "http://www.postgresql.org/") 7 syntax which initialises the database required by the application, with all relationships, permissions, referential integrity constraints and so on. + +\[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=15 "Edit section: So is ADL a quick way to build Monorail applications?")\] So is ADL a quick way to build Monorail applications? +--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- + +Yes and no. + +ADL _is_ a quick way to build Monorail applications, because it seemed to me that as Monorail/NHibernate are technologies that the company is adopting and it would be better to work with technologies with which we already have expertise - it's no good doing these things if other people can't maintain them afterwards. + +However ADL wasn't originally conceived with Monorail in mind. It was originally intended to generated LISP for [CLHTTPD](http://www.cl-http.org:8001/cl-http/ "http://www.cl-http.org:8001/cl-http/"), and I have a half-finished set of scripts to generate Java as part of the Jacquard2 project which I never finished. Because ADL is at a level of abstraction considerably above any [3GL](http://en.wikipedia.org/wiki/Third-generation_programming_language "http://en.wikipedia.org/wiki/Third-generation_programming_language"), it is inherently agnostic to what 3GL it is compiled down to - so that it would be as easy to write transforms that compiled ADL to [Struts](http://struts.apache.org/ "http://struts.apache.org/") or [Ruby on Rails](http://www.rubyonrails.org/ "http://www.rubyonrails.org/") as to C#/Monorail. More importantly, ADL isn't inherently limited to Web applications - it doesn't actually know anything about the Web. It should be possible to write transforms which compile ADL down to Windows native applications or to native applications for mobile phones (and, indeed, if we did have those transforms then we could make all our applications platform agnostic). + +\[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=16 "Edit section: Limitations on ADL")\] Limitations on ADL +----------------------------------------------------------------------------------------------------------------------------------------------------------------------------- + +### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=17 "Edit section: Current limitations")\] Current limitations + +Although I've built experimental systems before using ADL, the SRU project is the first time I've really used it in anger. There are some features I need which it can't yet represent. + +#### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=18 "Edit section: Authentication model")\] Authentication model + +For SRU, I have implemented an authentication model which authenticates the user against real database user accounts. I've done this because I think, in general, this is the correct solution, and because without this sort of authentication you cannot implement table-layer security. However most web applications use application layer authentication rather than database layer authentication, and I have not yet written controller-layer code to deal with this. So unless you do so, ADL applications can currently only authenticate at database layer. + +ADL defines field-level permissions, but the current controller generator does not implement this. + +#### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=19 "Edit section: Alternative Verbs")\] Alternative Verbs + +Generically, with an entity form, one needs to be able to save the record being edited, and one (often) needs to be able to delete it. But sometimes one needs to be able to do other things. With SRU, for example, there is a need to be able to export event data to [Perfect Table Plan](http://www.perfecttableplan.com/ "http://www.perfecttableplan.com/"), and to reimport data from Perfect Table Plan. This will need custom buttons on the event entity form, and will also need hand-written code at the controller layer to respond to those buttons. + +Also, a person will have, over the course of their interaction with the SRU, potentially many invitations. In order to access those invitations it will be necessary to associate lists of dependent records with forms. Currently ADL cannot represent these. + +### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=20 "Edit section: Inherent limitations")\] Inherent limitations + +At this stage I doubt whether there is much point in extending ADL to include a vocabulary to describe business processes. It would make the language much more complicated, and would be unlikely to be able to offer a significantly higher level of abstraction than current 3GLs. If using ADL does not save work, it isn't worth doing it in ADL; remember this is conceived as an 80/20 solution, and you need to be prepared to write the 20 in something else. + +\[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=21 "Edit section: ADL Vocabulary")\] ADL Vocabulary +--------------------------------------------------------------------------------------------------------------------------------------------------------------------- + +This section of this document presents and comments on the existing ADL document type definition (DTD). + +### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=22 "Edit section: Basic definitions")\] Basic definitions + +The DTD starts with some basic definitions + + + + + + + + + + +--> + + +#### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=23 "Edit section: Permissions")\] Permissions + +Key to any data driven application is who has authority to do what to what: 'permissions'. + + + + +#### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=24 "Edit section: Data types")\] Data types + +ADL needs to know what type of data can be stored on different properties of different entities. The data types were originally based on JDBC data types: + + + +#### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=25 "Edit section: Definable data types")\] Definable data types + +However, in order to be able to do data validation, it's useful to associate rules with data types. ADL has the concept of definable data types, to allow data validation code to be generated from the declarative description. These definable data types are used in the ADL application, for example, to define derived types for phone numbers, email addresses, postcodes, and range types. + + + + + + + + + + + + +#### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=26 "Edit section: Page content")\] Page content + +Pages in applications typically have common, often largely static, sections above, below, to the left or right of the main content which incorporates things like branding, navigation, and so on. This can be defined globally or per page. The intention is that the `head`, `top` and `foot` elements in ADL should be allowed to contain arbitrary HTML, but currently I don't have enough skill with DTD design to know how to specify this. + + + + + + + + + + +### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=27 "Edit section: The Elements")\] The Elements + +#### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=28 "Edit section: Application")\] Application + +The top level element of an Application Description Language file is the application element: + + + + + +#### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=29 "Edit section: Definition")\] Definition + +In order to be able to use defined types, you need to be able to provide definitions of these types: + + + + + +#### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=30 "Edit section: Groups")\] Groups + +In order to be able to user permissions, we need to define who has those permissions. Groups in ADL map directly onto groups/roles at SQL level, but the intention with ADL is that groups should be defined hierarchically. + + + + + + + + +#### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=31 "Edit section: Enities and Properties")\] Enities and Properties + +A thing-in-the-domain has properties. Things in the domain fall into regularities, groups of things which share similar collections of properties, such that the values of these properties may have are constrained. This is a representation of the world which is not perfect, but which is sufficiently useful to be recognised by the software technologies which ADL abstracts, so we need to be able to define these. Hence we have entities and properties/ + + + + + + + + + + +#### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=32 "Edit section: Options")\] Options + +Sometimes a property has a constrained list of specific values; this is represented for example in the enumerated types supported by many programming languages. Again, we need to be able to represent this. + + + + + + +#### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=33 "Edit section: Permissions")\] Permissions + +Permissions define policies to allow groups of users to access forms, pages, fields (not yet implemented) or entities. Only entity permissions are enforced at database layer, and field protection is not yet implemented at controller layer. But the ADL allows it to be described, and future implementations of the controller generating transform will do this. + + + + + +#### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=34 "Edit section: Pragmas")\] Pragmas + +Pragmas are currently not used at all. They are there as a possible means to provide additional controls on forms, but may not be the correct solutions for that. + + + + + +#### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=35 "Edit section: Prompts, helptexts and error texts")\] Prompts, helptexts and error texts + +When soliciting a value for a property from the user, we need to be able to offer the user a prompt to describe what we're asking for, and we need to be able to offer that in the user's preferred natural language. Prompts are typically brief. Sometimes, however, we need to give the user a more extensive description of what is being solicited - 'help text'. Finally, if the data offered by the user isn't adequate for some reason, we need ways of feeding that back. Currently the only error text which is carried in the ADL is 'ifmissing', text to be shown if the value for a required property is missing. All prompts, helptexts and error texts have locale information, so that it should be possible to generate variants of all pages for different natural languages from the same ADL. + + + + + + + + + + + + + +#### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=36 "Edit section: Forms, Pages and Lists")\] Forms, Pages and Lists + +The basic pages of the user interface. Pages and Forms by default show fields for all the properties of the entity they describe, or they may show only a listed subset. Currently lists show fields for only those properties which are 'user distinct'. Forms, pages and lists may each have their own head, top and foot content, or they may inherit the content defined for the application. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +\[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=37 "Edit section: Using ADL in your project")\] Using ADL in your project +------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- + +### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=38 "Edit section: Selecting the version")\] Selecting the version + +Current versions of ADL are given at the top of this document. Historical versions are as follows: + +* **Version 0.1**: Used by the SRU Hospitality application only. The Hospitality Application will be upgraded to the current version whenever it has further work done on it. + * You cannot access Version 1.0 at all, as nothing in current development should be using it. It is in CVS as part of the SRU Hospitality application + * As soon as SRU Hospitality has been updated to **stable**, version 0.1 will be unmaintained. +* **Version 0.3**: Identical to Version 1.0, except that the obsolete _transforms01_ directory has not been removed. + * You can access 0.3, should you need to, here: [http://libs.cygnets.co.uk/adl/0.3/ADL/](http://libs.cygnets.co.uk/adl/0.3/ADL/ "http://libs.cygnets.co.uk/adl/0.3/ADL/") + * I do not plan to maintain 0.3 even for bugfixes; you should ensure your project builds with 1.0 +* **Version 1.0**: Identical to Version 3.0, except tidied up. + * * the obsolete _transforms01_ directory has been removed. + * _adl2entityclass.xslt_ has been renamed to _adl2entityclasses.xslt_, for consistency + * This is the current **stable** branch; it is the HEAD branch in CVS. + * If there are bugs, I (sb) will fix them. + * If you want new functionality, it belongs in 'unstable'. + * You can access 1.0 here: [http://libs.cygnets.co.uk/adl/1.0/ADL/](http://libs.cygnets.co.uk/adl/1.0/ADL/ "http://libs.cygnets.co.uk/adl/1.0/ADL/") + * Projects using ADL 1.0 should be built with the 1.0 version of CygnetToolkit +* **unstable**: this is the current development branch, the branch tagged **b_development** in CVS. + * It should be backwards compatible with 1.0 (i.e. anything which builds satisfactorily with 1.0 should also build with unstable) + * It may have additional features + * It is not guaranteed to work, and before a final release of a product to a customer we may wish to move changes into a new 'stable' branch. + * You can access the unstable branch here: [http://libs.cygnets.co.uk/adl/unstable/ADL/](http://libs.cygnets.co.uk/adl/unstable/ADL/ "http://libs.cygnets.co.uk/adl/unstable/ADL/") + * The version at that location is automatically updated from CVS every night + * Projects using the **b_development** branch of ADL should be built against the **b_development** branch of CygnetToolkit. + +### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=39 "Edit section: Integrating into your build")\] Integrating into your build + +To use ADL, it is currently most convenient to use NAnt. It is probably possible to do this with MSBuild, but as of yet I don't know how. + +#### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=40 "Edit section: Properties")\] Properties + +For the examples given here to work, you will need to set up at least the following properties in your NAnt `.build` file: + + + + + + + + + + + + + + + + +where, obviously, **YourProjectName**, **YourSourceDir** and **YourADL.adl.xml** stand in for the actual names of your project, your source directory (relative to your solution directory, where the .build file is) and your ADL file, respectively. Note that if it is to be used as an assembly name, the project name should include neither spaces, hyphens nor periods. If it must do so, you should give an assembly name which does not, explicitly. + +#### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=41 "Edit section: Canonicalisation")\] Canonicalisation + +The first thing you need to do with your ADL file is canonicalise it. You should generally not need to alter this, you should copy and paste it verbatim: + + + + + +#### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=42 "Edit section: Generate NHibernate mapping")\] Generate NHibernate mapping + +You should generally not need to alter this at all, just copy and paste it verbatim: + + + + + +#### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=43 "Edit section: Generate SQL")\] Generate SQL + + + + + +#### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=44 "Edit section: Generate C# entity classes ('POCOs')")\] Generate C# entity classes ('POCOs') + +Note that for this to work you must have the following: + +* '[Artistic Style](http://astyle.sourceforge.net/ "http://astyle.sourceforge.net/")' installed as `c:\Program Files\astyle\bin\astyle.exe` + + + + + + + + + + + + + +#### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=45 "Edit section: Generate Monorail controller classes")\] Generate Monorail controller classes + +Note that for this to work you must have + +* '[Artistic Style](http://astyle.sourceforge.net/ "http://astyle.sourceforge.net/")' installed as `c:\Program Files\astyle\bin\astyle.exe` +* The 'fetchtasks' target from the 'entity classes' stanza, above. + + + + + + + + + +#### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=46 "Edit section: Generate Velocity views for use with Monorail")\] Generate Velocity views for use with Monorail + +Note that for this to work you must have + +* The 'fetchtasks' target from the 'entity classes' stanza, above. + + + + + + + + + diff --git a/project.clj b/project.clj new file mode 100644 index 0000000..867903c --- /dev/null +++ b/project.clj @@ -0,0 +1,6 @@ +(defproject adl "0.1.0-SNAPSHOT" + :description "FIXME: write description" + :url "http://example.com/FIXME" + :license {:name "Eclipse Public License" + :url "http://www.eclipse.org/legal/epl-v10.html"} + :dependencies [[org.clojure/clojure "1.8.0"]]) diff --git a/schemas/adl-1.3.dtd b/resources/schemas/adl-1.3.dtd similarity index 100% rename from schemas/adl-1.3.dtd rename to resources/schemas/adl-1.3.dtd diff --git a/schemas/adl-1.4.dtd b/resources/schemas/adl-1.4.dtd similarity index 100% rename from schemas/adl-1.4.dtd rename to resources/schemas/adl-1.4.dtd diff --git a/resources/schemas/adl-1.4.rnc b/resources/schemas/adl-1.4.rnc new file mode 100644 index 0000000..a073ed5 --- /dev/null +++ b/resources/schemas/adl-1.4.rnc @@ -0,0 +1,545 @@ +# :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: + +# + +# adl-1.4.dtd + +# + +# Purpose: + +# Document Type Description for Application Description + +# Language. Normative for now; will be replaced by a schema. ` + +# + +# Author: Simon Brooke + +# Created: 24th January 2006 + +# Copyright: (c) 2007 Cygnet Solutions + +# + +# :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: + +# $Revision: 1.5 $ + +# :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: + +# 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 + +# boolean means true or false + +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: +# +# +Locale = string +# 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 +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. +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 +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 +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. +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 +SpecialDataTypes = "geopos" | "image" | "message" +# all data types +AllDataTypes = ComplexDataTypes | SimpleDataTypes | SpecialDataTypes +# content, for things like pages (i.e. forms, lists, pages) +Content = head | top | foot +FieldStuff = field | fieldgroup | auxlist | verb +PageContent = Content | FieldStuff +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 +PageAttrs = + attribute name { text }, + attribute properties { "all" | "user-distinct" | "listed" } +# 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 generatos 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! +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 +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 +application = + element application { + attlist.application, + specification*, + documentation?, + content?, + typedef*, + group*, + entity* + } +attlist.application &= + attribute name { text }, + attribute version { text }?, + attribute revision { text }?, + attribute currency { text }? +# 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) +typedef = + element typedef { + attlist.typedef, documentation?, in-implementation*, help* + } +attlist.typedef &= + attribute name { text }, + attribute type { DefinableDataTypes }?, + attribute size { text }?, + attribute pattern { text }?, + attribute minimum { text }?, + attribute maximum { text }? +# 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... +in-implementation = + element in-implementation { + attlist.in-implementation, documentation? + } +attlist.in-implementation &= + attribute target { text }, + attribute value { text }, + attribute kind { text }? +# 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 +group = element group { attlist.group, documentation? } +attlist.group &= + attribute name { text }, + attribute parent { text }? +# 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 +entity = + element entity { + attlist.entity, + documentation?, + prompt*, + content?, + key?, + property*, + permission*, + (form | page | \list)* + } +attlist.entity &= + attribute name { text }, + attribute natural-key { text }?, + attribute table { text }?, + attribute foreign { Boolean }? +# contains documentation on the element which immediately contains it. TODO: +# should HTML markup within a documentation element be allowed? If so, are +# there restrictions? +documentation = + element documentation { attlist.documentation, (text | reference)* } +attlist.documentation &= empty +# an explicit primary key, possibly compound +key = element key { attlist.key, property* } +attlist.key &= empty +# 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 +property = + element property { + attlist.property, + documentation?, + generator?, + (permission | option | prompt | help | ifmissing)* + } +attlist.property &= + attribute name { text }, + attribute type { AllDataTypes }, + attribute default { text }?, + attribute typedef { text }?, + attribute distinct { "none" | "all" | "user" | "system" }?, + attribute entity { text }?, + attribute farkey { text }?, + attribute required { Boolean }?, + attribute immutable { Boolean }?, + attribute size { text }?, + attribute column { text }?, + attribute concrete { Boolean }?, + attribute cascade { CascadeActions }? +# 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 +generator = + element generator { attlist.generator, documentation?, param* } +attlist.generator &= + attribute action { GeneratorActions }, + attribute class { text }? +# 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. +param = element param { attlist.param, text } +attlist.param &= attribute name { text } +# 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. +option = element option { attlist.option, documentation?, prompt* } +# if the value is different from the prompt the user sees, specify it +attlist.option &= attribute value { text }? +# 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 +permission = element permission { attlist.permission, documentation? } +attlist.permission &= + attribute group { text }, + attribute permission { Permissions } +# 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. +pragma = element pragma { attlist.pragma, documentation? } +attlist.pragma &= + attribute name { text }, + attribute value { text } +# 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 +prompt = element prompt { attlist.prompt, documentation? } +attlist.prompt &= + attribute prompt { text }, + attribute locale { Locale } +# 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 +help = element help { attlist.help, text } +attlist.help &= attribute locale { Locale } +# 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. +ifmissing = element ifmissing { attlist.ifmissing, text } +attlist.ifmissing &= attribute locale { Locale } +# 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. +form = element form { attlist.form, documentation?, PageStuff* } +attlist.form &= PageAttrs +# a page on which an entity may be displayed +page = element page { attlist.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 +order = element order { attlist.order, documentation? } +attlist.order &= + attribute property { text }, + attribute sequence { Sequences }? +# 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 +\list = + element list { attlist.list, documentation?, (PageStuff | order)* } +attlist.list &= + PageAttrs, + attribute onselect { text }? +# 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 +auxlist = + element auxlist { + attlist.auxlist, documentation?, (prompt | FieldStuff)* + } +attlist.auxlist &= + PageAttrs, + attribute property { text }, + attribute onselect { text }?, + attribute canadd { Boolean }? +# 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. +fieldgroup = + element fieldgroup { + attlist.fieldgroup, + documentation?, + (prompt | permission | FieldStuff)* + } +attlist.fieldgroup &= attribute name { text } +# a field in a form or page +# +# property: the property which this field displays/edits +field = + element field { + attlist.field, documentation?, (prompt | help | permission)* + } +attlist.field &= attribute property { text } +# 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 = + element verb { + attlist.verb, documentation?, (prompt | help | permission)* + } +attlist.verb &= + attribute verb { text }, + attribute dangerous { Boolean } +# a container for global content +content = element content { attlist.content, Content* } +attlist.content &= empty +# 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. +head = element head { attlist.head, text } +attlist.head &= empty +# 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. +top = element top { attlist.top, text } +attlist.top &= empty +# 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. +foot = element foot { attlist.foot, text } +attlist.foot &= empty +# 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 +specification = + element specification { + attlist.specification, documentation?, reference* + } +attlist.specification &= + attribute url { text }?, + attribute name { text }, + attribute abbr { text } +# 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 +reference = element reference { attlist.reference, documentation? } +attlist.reference &= + attribute abbr { text }?, + attribute section { text }?, + attribute entity { text }?, + attribute property { text }? +start = application diff --git a/schemas/adl-1.4.rng b/resources/schemas/adl-1.4.rng similarity index 100% rename from schemas/adl-1.4.rng rename to resources/schemas/adl-1.4.rng diff --git a/resources/schemas/adl-1.4.xsd b/resources/schemas/adl-1.4.xsd new file mode 100644 index 0000000..89f4c38 --- /dev/null +++ b/resources/schemas/adl-1.4.xsd @@ -0,0 +1,547 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/schemas/permitted-html-head.rng b/resources/schemas/permitted-html-head.rng similarity index 100% rename from schemas/permitted-html-head.rng rename to resources/schemas/permitted-html-head.rng diff --git a/schemas/permitted-html.rng b/resources/schemas/permitted-html.rng similarity index 100% rename from schemas/permitted-html.rng rename to resources/schemas/permitted-html.rng diff --git a/schemas/strict.dtd b/resources/schemas/strict.dtd similarity index 100% rename from schemas/strict.dtd rename to resources/schemas/strict.dtd diff --git a/transforms/adl2activerecord.xslt b/resources/transforms/adl2activerecord.xslt similarity index 100% rename from transforms/adl2activerecord.xslt rename to resources/transforms/adl2activerecord.xslt diff --git a/transforms/adl2canonical.xslt b/resources/transforms/adl2canonical.xslt similarity index 100% rename from transforms/adl2canonical.xslt rename to resources/transforms/adl2canonical.xslt diff --git a/transforms/adl2controllerclasses.xslt b/resources/transforms/adl2controllerclasses.xslt similarity index 100% rename from transforms/adl2controllerclasses.xslt rename to resources/transforms/adl2controllerclasses.xslt diff --git a/transforms/adl2documentation.xslt b/resources/transforms/adl2documentation.xslt similarity index 100% rename from transforms/adl2documentation.xslt rename to resources/transforms/adl2documentation.xslt diff --git a/transforms/adl2entityclasses.xslt b/resources/transforms/adl2entityclasses.xslt similarity index 100% rename from transforms/adl2entityclasses.xslt rename to resources/transforms/adl2entityclasses.xslt diff --git a/transforms/adl2hibernate.xslt b/resources/transforms/adl2hibernate.xslt similarity index 100% rename from transforms/adl2hibernate.xslt rename to resources/transforms/adl2hibernate.xslt diff --git a/transforms/adl2mssql.xslt b/resources/transforms/adl2mssql.xslt similarity index 100% rename from transforms/adl2mssql.xslt rename to resources/transforms/adl2mssql.xslt diff --git a/transforms/adl2psql.xslt b/resources/transforms/adl2psql.xslt similarity index 100% rename from transforms/adl2psql.xslt rename to resources/transforms/adl2psql.xslt diff --git a/transforms/adl2views.xslt b/resources/transforms/adl2views.xslt similarity index 100% rename from transforms/adl2views.xslt rename to resources/transforms/adl2views.xslt diff --git a/transforms/base-type-include.xslt b/resources/transforms/base-type-include.xslt similarity index 100% rename from transforms/base-type-include.xslt rename to resources/transforms/base-type-include.xslt diff --git a/transforms/csharp-type-include.xslt b/resources/transforms/csharp-type-include.xslt similarity index 100% rename from transforms/csharp-type-include.xslt rename to resources/transforms/csharp-type-include.xslt diff --git a/transforms/i18n-en-GB-include.xslt b/resources/transforms/i18n-en-GB-include.xslt similarity index 100% rename from transforms/i18n-en-GB-include.xslt rename to resources/transforms/i18n-en-GB-include.xslt diff --git a/transforms/localise-transform.xslt b/resources/transforms/localise-transform.xslt similarity index 100% rename from transforms/localise-transform.xslt rename to resources/transforms/localise-transform.xslt diff --git a/transforms/permissions-include.xslt b/resources/transforms/permissions-include.xslt similarity index 100% rename from transforms/permissions-include.xslt rename to resources/transforms/permissions-include.xslt diff --git a/src/adl/core.clj b/src/adl/core.clj new file mode 100644 index 0000000..4e6cdf1 --- /dev/null +++ b/src/adl/core.clj @@ -0,0 +1,6 @@ +(ns adl.core) + +(defn foo + "I don't do a whole lot." + [x] + (println x "Hello, World!")) diff --git a/src/adl/to_hugsql_queries.clj b/src/adl/to_hugsql_queries.clj new file mode 100644 index 0000000..e69de29 diff --git a/src/adl/to_json_routes.clj b/src/adl/to_json_routes.clj new file mode 100644 index 0000000..e69de29 diff --git a/src/adl/validator.clj b/src/adl/validator.clj new file mode 100644 index 0000000..e69de29 diff --git a/test/adl/core_test.clj b/test/adl/core_test.clj new file mode 100644 index 0000000..18a1a26 --- /dev/null +++ b/test/adl/core_test.clj @@ -0,0 +1,7 @@ +(ns adl.core-test + (:require [clojure.test :refer :all] + [adl.core :refer :all])) + +(deftest a-test + (testing "FIXME, I fail." + (is (= 0 1)))) From 4d6bad7c2a6854bded12bfa65da18889acf27796 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Tue, 20 Mar 2018 22:52:04 +0000 Subject: [PATCH 02/52] Making a commit now to mark a point in development. Many tests fail Failures are to do with XML elements with (legitimate) text content. My validator - specifically I think the function adl.validator/disjunct-valid? - is causing spurious validation fails. But just having a battery of unit tests is progress. --- LICENSE | 222 ++------ LICENSE.md | 340 +++++++++++ README.md | 5 +- RELEASENOTES.md | 4 + RELEASENOTES.txt | 2 - project.clj | 4 +- resources/test/documentation-only.adl.xml | 9 + resources/test/test1.adl.xml | 77 +++ src/adl/core.clj | 6 - src/adl/to_hugsql_queries.clj | 361 ++++++++++++ src/adl/to_json_routes.clj | 237 ++++++++ src/adl/utils.clj | 11 + src/adl/validator.clj | 654 ++++++++++++++++++++++ test/adl/core_test.clj | 7 - test/adl/validator_test.clj | 435 ++++++++++++++ 15 files changed, 2179 insertions(+), 195 deletions(-) create mode 100644 LICENSE.md create mode 100644 RELEASENOTES.md delete mode 100755 RELEASENOTES.txt create mode 100644 resources/test/documentation-only.adl.xml create mode 100644 resources/test/test1.adl.xml delete mode 100644 src/adl/core.clj create mode 100644 src/adl/utils.clj delete mode 100644 test/adl/core_test.clj create mode 100644 test/adl/validator_test.clj diff --git a/LICENSE b/LICENSE index d921d3d..10d59ec 100644 --- a/LICENSE +++ b/LICENSE @@ -1,214 +1,86 @@ -THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE PUBLIC -LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR DISTRIBUTION OF THE PROGRAM -CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS AGREEMENT. +GNU GENERAL PUBLIC LICENSE -1. DEFINITIONS +Version 2, June 1991 -"Contribution" means: +Copyright (C) 1989, 1991 Free Software Foundation, Inc. +51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA -a) in the case of the initial Contributor, the initial code and -documentation distributed under this Agreement, and +Everyone is permitted to copy and distribute verbatim copies +of this license document, but changing it is not allowed. +Preamble -b) in the case of each subsequent Contributor: +The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Lesser General Public License instead.) You can apply it to your programs, too. -i) changes to the Program, and +When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. -ii) additions to the Program; +To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. -where such changes and/or additions to the Program originate from and are -distributed by that particular Contributor. A Contribution 'originates' from -a Contributor if it was added to the Program by such Contributor itself or -anyone acting on such Contributor's behalf. Contributions do not include -additions to the Program which: (i) are separate modules of software -distributed in conjunction with the Program under their own license -agreement, and (ii) are not derivative works of the Program. +For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. -"Contributor" means any person or entity that distributes the Program. +We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. -"Licensed Patents" mean patent claims licensable by a Contributor which are -necessarily infringed by the use or sale of its Contribution alone or when -combined with the Program. +Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. -"Program" means the Contributions distributed in accordance with this -Agreement. +Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. -"Recipient" means anyone who receives the Program under this Agreement, -including all Contributors. +The precise terms and conditions for copying, distribution and modification follow. -2. GRANT OF RIGHTS +TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION -a) Subject to the terms of this Agreement, each Contributor hereby grants -Recipient a non-exclusive, worldwide, royalty-free copyright license to -reproduce, prepare derivative works of, publicly display, publicly perform, -distribute and sublicense the Contribution of such Contributor, if any, and -such derivative works, in source code and object code form. +0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". -b) Subject to the terms of this Agreement, each Contributor hereby grants -Recipient a non-exclusive, worldwide, royalty-free patent license under -Licensed Patents to make, use, sell, offer to sell, import and otherwise -transfer the Contribution of such Contributor, if any, in source code and -object code form. This patent license shall apply to the combination of the -Contribution and the Program if, at the time the Contribution is added by the -Contributor, such addition of the Contribution causes such combination to be -covered by the Licensed Patents. The patent license shall not apply to any -other combinations which include the Contribution. No hardware per se is -licensed hereunder. +Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. -c) Recipient understands that although each Contributor grants the licenses -to its Contributions set forth herein, no assurances are provided by any -Contributor that the Program does not infringe the patent or other -intellectual property rights of any other entity. Each Contributor disclaims -any liability to Recipient for claims brought by any other entity based on -infringement of intellectual property rights or otherwise. As a condition to -exercising the rights and licenses granted hereunder, each Recipient hereby -assumes sole responsibility to secure any other intellectual property rights -needed, if any. For example, if a third party patent license is required to -allow Recipient to distribute the Program, it is Recipient's responsibility -to acquire that license before distributing the Program. +1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. -d) Each Contributor represents that to its knowledge it has sufficient -copyright rights in its Contribution, if any, to grant the copyright license -set forth in this Agreement. +You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. -3. REQUIREMENTS +2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: -A Contributor may choose to distribute the Program in object code form under -its own license agreement, provided that: +a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. +b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. +c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) +These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. -a) it complies with the terms and conditions of this Agreement; and +Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. -b) its license agreement: +In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. -i) effectively disclaims on behalf of all Contributors all warranties and -conditions, express and implied, including warranties or conditions of title -and non-infringement, and implied warranties or conditions of merchantability -and fitness for a particular purpose; +3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: -ii) effectively excludes on behalf of all Contributors all liability for -damages, including direct, indirect, special, incidental and consequential -damages, such as lost profits; +a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, +b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, +c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) +The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. -iii) states that any provisions which differ from this Agreement are offered -by that Contributor alone and not by any other party; and +If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. -iv) states that source code for the Program is available from such -Contributor, and informs licensees how to obtain it in a reasonable manner on -or through a medium customarily used for software exchange. +4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. -When the Program is made available in source code form: +5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. -a) it must be made available under this Agreement; and +6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. -b) a copy of this Agreement must be included with each copy of the Program. +7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. -Contributors may not remove or alter any copyright notices contained within -the Program. +If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. -Each Contributor must identify itself as the originator of its Contribution, -if any, in a manner that reasonably allows subsequent Recipients to identify -the originator of the Contribution. +It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. -4. COMMERCIAL DISTRIBUTION +This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. -Commercial distributors of software may accept certain responsibilities with -respect to end users, business partners and the like. While this license is -intended to facilitate the commercial use of the Program, the Contributor who -includes the Program in a commercial product offering should do so in a -manner which does not create potential liability for other Contributors. -Therefore, if a Contributor includes the Program in a commercial product -offering, such Contributor ("Commercial Contributor") hereby agrees to defend -and indemnify every other Contributor ("Indemnified Contributor") against any -losses, damages and costs (collectively "Losses") arising from claims, -lawsuits and other legal actions brought by a third party against the -Indemnified Contributor to the extent caused by the acts or omissions of such -Commercial Contributor in connection with its distribution of the Program in -a commercial product offering. The obligations in this section do not apply -to any claims or Losses relating to any actual or alleged intellectual -property infringement. In order to qualify, an Indemnified Contributor must: -a) promptly notify the Commercial Contributor in writing of such claim, and -b) allow the Commercial Contributor to control, and cooperate with the -Commercial Contributor in, the defense and any related settlement -negotiations. The Indemnified Contributor may participate in any such claim -at its own expense. +8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. -For example, a Contributor might include the Program in a commercial product -offering, Product X. That Contributor is then a Commercial Contributor. If -that Commercial Contributor then makes performance claims, or offers -warranties related to Product X, those performance claims and warranties are -such Commercial Contributor's responsibility alone. Under this section, the -Commercial Contributor would have to defend claims against the other -Contributors related to those performance claims and warranties, and if a -court requires any other Contributor to pay any damages as a result, the -Commercial Contributor must pay those damages. +9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. -5. NO WARRANTY +Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. -EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, THE PROGRAM IS PROVIDED ON -AN "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, EITHER -EXPRESS OR IMPLIED INCLUDING, WITHOUT LIMITATION, ANY WARRANTIES OR -CONDITIONS OF TITLE, NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A -PARTICULAR PURPOSE. Each Recipient is solely responsible for determining the -appropriateness of using and distributing the Program and assumes all risks -associated with its exercise of rights under this Agreement , including but -not limited to the risks and costs of program errors, compliance with -applicable laws, damage to or loss of data, programs or equipment, and -unavailability or interruption of operations. +10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. -6. DISCLAIMER OF LIABILITY +NO WARRANTY -EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, NEITHER RECIPIENT NOR ANY -CONTRIBUTORS SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING WITHOUT LIMITATION -LOST PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -ARISING IN ANY WAY OUT OF THE USE OR DISTRIBUTION OF THE PROGRAM OR THE -EXERCISE OF ANY RIGHTS GRANTED HEREUNDER, EVEN IF ADVISED OF THE POSSIBILITY -OF SUCH DAMAGES. +11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. -7. GENERAL +12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. -If any provision of this Agreement is invalid or unenforceable under -applicable law, it shall not affect the validity or enforceability of the -remainder of the terms of this Agreement, and without further action by the -parties hereto, such provision shall be reformed to the minimum extent -necessary to make such provision valid and enforceable. -If Recipient institutes patent litigation against any entity (including a -cross-claim or counterclaim in a lawsuit) alleging that the Program itself -(excluding combinations of the Program with other software or hardware) -infringes such Recipient's patent(s), then such Recipient's rights granted -under Section 2(b) shall terminate as of the date such litigation is filed. - -All Recipient's rights under this Agreement shall terminate if it fails to -comply with any of the material terms or conditions of this Agreement and -does not cure such failure in a reasonable period of time after becoming -aware of such noncompliance. If all Recipient's rights under this Agreement -terminate, Recipient agrees to cease use and distribution of the Program as -soon as reasonably practicable. However, Recipient's obligations under this -Agreement and any licenses granted by Recipient relating to the Program shall -continue and survive. - -Everyone is permitted to copy and distribute copies of this Agreement, but in -order to avoid inconsistency the Agreement is copyrighted and may only be -modified in the following manner. The Agreement Steward reserves the right to -publish new versions (including revisions) of this Agreement from time to -time. No one other than the Agreement Steward has the right to modify this -Agreement. The Eclipse Foundation is the initial Agreement Steward. The -Eclipse Foundation may assign the responsibility to serve as the Agreement -Steward to a suitable separate entity. Each new version of the Agreement will -be given a distinguishing version number. The Program (including -Contributions) may always be distributed subject to the version of the -Agreement under which it was received. In addition, after a new version of -the Agreement is published, Contributor may elect to distribute the Program -(including its Contributions) under the new version. Except as expressly -stated in Sections 2(a) and 2(b) above, Recipient receives no rights or -licenses to the intellectual property of any Contributor under this -Agreement, whether expressly, by implication, estoppel or otherwise. All -rights in the Program not expressly granted under this Agreement are -reserved. - -This Agreement is governed by the laws of the State of New York and the -intellectual property laws of the United States of America. No party to this -Agreement will bring a legal action under this Agreement more than one year -after the cause of action arose. Each party waives its rights to a jury trial -in any resulting litigation. diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 index 0000000..aab650f --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,340 @@ + + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Lesser General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + 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. + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) year name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, the commands you use may +be called something other than `show w' and `show c'; they could even be +mouse-clicks or menu items--whatever suits your program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + {signature of Ty Coon}, 1 April 1989 + Ty Coon, President of Vice + +This General Public License does not permit incorporating your program into +proprietary programs. If your program is a subroutine library, you may +consider it more useful to permit linking proprietary applications with the +library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. diff --git a/README.md b/README.md index b7b9833..e35ec34 100644 --- a/README.md +++ b/README.md @@ -56,7 +56,4 @@ I will happily accept pull requests for new XSL transforms (although I'd like so Copyright © Simon Brooke 2007-2018 -Distributed under the Eclipse Public License either version 1.0 or (at -your option) any later version. - -Note that you are also entitled to use this project under the terms of the Gnu GPL version 2 or any later version; I generally prefer GPL, but I know that if this project is to be useful to folk it has to be relatively uncomplicated to use in commercial projects. +Distributed under the Gnu GPL version 2 or any later version; I am open to licensing this project under additional licences if required. diff --git a/RELEASENOTES.md b/RELEASENOTES.md new file mode 100644 index 0000000..7adf8c0 --- /dev/null +++ b/RELEASENOTES.md @@ -0,0 +1,4 @@ +# Release 1.4 + +Release 1.4 adds an 'order' element as a possible child of the 'list' element, in order to specify +the default order of lists. Otherwise unchanged from 1.3. diff --git a/RELEASENOTES.txt b/RELEASENOTES.txt deleted file mode 100755 index ea8aef6..0000000 --- a/RELEASENOTES.txt +++ /dev/null @@ -1,2 +0,0 @@ -Release 1.4 adds an 'order' element as a possible child of the 'list' element, in order to specify -the default order of lists. Otherwise unchanged from 1.3. \ No newline at end of file diff --git a/project.clj b/project.clj index 867903c..e4673d3 100644 --- a/project.clj +++ b/project.clj @@ -3,4 +3,6 @@ :url "http://example.com/FIXME" :license {:name "Eclipse Public License" :url "http://www.eclipse.org/legal/epl-v10.html"} - :dependencies [[org.clojure/clojure "1.8.0"]]) + :dependencies [[org.clojure/clojure "1.8.0"] + [org.clojure/math.combinatorics "0.1.4"] + [bouncer "1.0.1"]]) diff --git a/resources/test/documentation-only.adl.xml b/resources/test/documentation-only.adl.xml new file mode 100644 index 0000000..31af20d --- /dev/null +++ b/resources/test/documentation-only.adl.xml @@ -0,0 +1,9 @@ + + + + + Some test documentation + diff --git a/resources/test/test1.adl.xml b/resources/test/test1.adl.xml new file mode 100644 index 0000000..5dc4327 --- /dev/null +++ b/resources/test/test1.adl.xml @@ -0,0 +1,77 @@ + + + + This is a very simple test document just to exercise validator and generators. + + + + + + Test 1 + + + That's all folks! + + + + All users + + + Administrative users + + + A person + + + + + + + + + + + + + + + + + + + + +
+ + + + + + + + + +
+ + + + + + + + + + + diff --git a/src/adl/core.clj b/src/adl/core.clj deleted file mode 100644 index 4e6cdf1..0000000 --- a/src/adl/core.clj +++ /dev/null @@ -1,6 +0,0 @@ -(ns adl.core) - -(defn foo - "I don't do a whole lot." - [x] - (println x "Hello, World!")) diff --git a/src/adl/to_hugsql_queries.clj b/src/adl/to_hugsql_queries.clj index e69de29..50916b5 100644 --- a/src/adl/to_hugsql_queries.clj +++ b/src/adl/to_hugsql_queries.clj @@ -0,0 +1,361 @@ +(ns ^{:doc "Application Description Language: generate HUGSQL queries file." + :author "Simon Brooke"} + adl.to-hugsql-queries + (:require [clojure.java.io :refer [file]] + [clojure.math.combinatorics :refer [combinations]] + [clojure.string :as s] + [clj-time.core :as t] + [clj-time.format :as f] + [adl.utils :refer [singularise is-link-table?]])) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; adl.to-hugsql-queries: generate HUGSQL queries file. +;;;; +;;;; 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 key-names [entity-map] + (remove + nil? + (map + #(:name (:attrs %)) + (vals (:content (:key (:content entity-map))))))) + + +(defn has-primary-key? [entity-map] + (> (count (key-names entity-map)) 0)) + + +(defn has-non-key-properties? [entity-map] + (> + (count (vals (:properties (:content entity-map)))) + (count (key-names entity-map)))) + + +(defn where-clause [entity-map] + (let + [entity-name (:name (:attrs entity-map))] + (str + "WHERE " entity-name "." + (s/join + (str " AND\n\t" entity-name ".") + (map #(str % " = " (keyword %)) (key-names entity-map)))))) + + +(defn order-by-clause [entity-map] + (let + [entity-name (:name (:attrs entity-map)) + preferred (map + #(:name (:attrs %)) + (filter #(= (-> % :attrs :distinct) "user") + (-> entity-map :content :properties vals)))] + (str + "ORDER BY " entity-name "." + (s/join + (str ",\n\t" entity-name ".") + (doall (flatten (cons preferred (key-names entity-map)))))))) + + +(defn insert-query [entity-map] + (let [entity-name (:name (:attrs entity-map)) + pretty-name (singularise entity-name) + all-property-names (map #(:name (:attrs %)) (vals (:properties (:content entity-map)))) + query-name (str "create-" pretty-name "!") + signature " :! :n"] + (hash-map + (keyword query-name) + {:name query-name + :signature signature + :entity entity-map + :type :insert-1 + :query + (str "-- :name " query-name " " signature "\n" + "-- :doc creates a new " pretty-name " record\n" + "INSERT INTO " entity-name " (" + (s/join ",\n\t" all-property-names) + ")\nVALUES (" + (s/join ",\n\t" (map keyword all-property-names)) + ")" + (if + (has-primary-key? entity-map) + (str "\nreturning " (s/join ",\n\t" (key-names entity-map)))) + "\n\n")}))) + + +(defn update-query [entity-map] + (if + (and + (has-primary-key? entity-map) + (has-non-key-properties? entity-map)) + (let [entity-name (:name (:attrs entity-map)) + pretty-name (singularise entity-name) + property-names (remove + nil? + (map + #(if (= (:tag %) :property) (:name (:attrs %))) + (vals (:properties (:content entity-map))))) + query-name (str "update-" pretty-name "!") + signature ":! :n"] + (hash-map + (keyword query-name) + {:name query-name + :signature signature + :entity entity-map + :type :update-1 + :query + (str "-- :name " query-name " " signature "\n" + "-- :doc updates an existing " pretty-name " record\n" + "UPDATE " entity-name "\n" + "SET " + (s/join ",\n\t" (map #(str % " = " (keyword %)) property-names)) + "\n" + (where-clause entity-map) + "\n\n")})) + {})) + + +(defn search-query [entity-map] + (let [entity-name (:name (:attrs entity-map)) + pretty-name (singularise entity-name) + query-name (str "search-strings-" pretty-name) + signature ":? :1" + string-fields (filter + #(= (-> % :attrs :type) "string") + (-> entity-map :content :properties vals))] + (if + (empty? string-fields) + {} + (hash-map + (keyword query-name) + {:name query-name + :signature signature + :entity entity-map + :type :text-search + :query + (str "-- :name " query-name " " signature "\n" + "-- :doc selects existing " entity-name " records having any string field matching `:pattern` by substring match\n" + "SELECT * FROM " entity-name "\n" + "WHERE " + (s/join + "\n\tOR " + (map + #(str (-> % :attrs :name) " LIKE '%:pattern%'") + string-fields)) + "\n" + (order-by-clause entity-map) + "\n" + "--~ (if (:offset params) \"OFFSET :offset \") \n" + "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")" + "\n\n")})))) + + +(defn select-query [entity-map] + (if + (has-primary-key? entity-map) + (let [entity-name (:name (:attrs entity-map)) + pretty-name (singularise entity-name) + query-name (str "get-" pretty-name) + signature ":? :1"] + (hash-map + (keyword query-name) + {:name query-name + :signature signature + :entity entity-map + :type :select-1 + :query + (str "-- :name " query-name " " signature "\n" + "-- :doc selects an existing " pretty-name " record\n" + "SELECT * FROM " entity-name "\n" + (where-clause entity-map) + "\n" + (order-by-clause entity-map) + "\n\n")})) + {})) + + +(defn list-query + "Generate a query to list records in the table represented by this `entity-map`. + Parameters `:limit` and `:offset` may be supplied. If not present limit defaults + to 100 and offset to 0." + [entity-map] + (let [entity-name (:name (:attrs entity-map)) + pretty-name (singularise entity-name) + query-name (str "list-" entity-name) + signature ":? :*"] + (hash-map + (keyword query-name) + {:name query-name + :signature signature + :entity entity-map + :type :select-many + :query + (str "-- :name " query-name " " signature "\n" + "-- :doc lists all existing " pretty-name " records\n" + "SELECT * FROM " entity-name "\n" + (order-by-clause entity-map) "\n" + "--~ (if (:offset params) \"OFFSET :offset \") \n" + "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")" + "\n\n")}))) + + +(defn foreign-queries [entity-map entities-map] + (let [entity-name (:name (:attrs entity-map)) + pretty-name (singularise entity-name) + links (filter #(-> % :attrs :entity) (-> entity-map :content :properties vals))] + (apply + merge + (map + #(let [far-name (-> % :attrs :entity) + far-entity ((keyword far-name) entities-map) + pretty-far (s/replace (s/replace far-name #"_" "-") #"s$" "") + farkey (-> % :attrs :farkey) + link-field (-> % :attrs :name) + query-name (str "list-" entity-name "-by-" pretty-far) + signature ":? :*"] + (hash-map + (keyword query-name) + {:name query-name + :signature signature + :entity entity-map + :type :select-one-to-many + :far-entity far-entity + :query + (str "-- :name " query-name " " signature "\n" + "-- :doc lists all existing " pretty-name " records related to a given " pretty-far "\n" + "SELECT * \nFROM " entity-name "\n" + "WHERE " entity-name "." link-field " = :id\n" + (order-by-clause entity-map) + "\n\n")})) + links)))) + + +(defn link-table-query [near link far] + (let [properties (-> link :content :properties vals) + links (apply + merge + (map + #(hash-map (keyword (-> % :attrs :entity)) %) + (filter #(-> % :attrs :entity) properties))) + near-name (-> near :attrs :name) + link-name (-> link :attrs :name) + far-name (-> far :attrs :name) + pretty-far (singularise far-name) + query-name (str "list-" link-name "-" near-name "-by-" pretty-far) + signature ":? :*"] + (hash-map + (keyword query-name) + {:name query-name + :signature signature + :entity link + :type :select-many-to-many + :near-entity near + :far-entity far + :query + (str "-- :name " query-name " " signature " \n" + "-- :doc lists all existing " near-name " records related through " link-name " to a given " pretty-far "\n" + "SELECT "near-name ".*\n" + "FROM " near-name ", " link-name "\n" + "WHERE " near-name "." (first (key-names near)) " = " link-name "." (-> (links (keyword near-name)) :attrs :name) "\n\t" + "AND " link-name "." (-> (links (keyword far-name)) :attrs :name) " = :id\n" + (order-by-clause near) + "\n\n")}))) + + +(defn link-table-queries [entity-map entities-map] + (let + [entities (map + #((keyword %) entities-map) + (remove nil? (map #(-> % :attrs :entity) (-> entity-map :content :properties vals)))) + pairs (combinations entities 2)] + (apply + merge + (map + #(merge + (link-table-query (nth % 0) entity-map (nth % 1)) + (link-table-query (nth % 1) entity-map (nth % 0))) + pairs)))) + + + +(defn delete-query [entity-map] + (if + (has-primary-key? entity-map) + (let [entity-name (:name (:attrs entity-map)) + pretty-name (singularise entity-name) + query-name (str "delete-" pretty-name "!") + signature ":! :n"] + (hash-map + (keyword query-name) + {:name query-name + :signature signature + :entity entity-map + :type :delete-1 + :query + (str "-- :name " query-name " " signature "\n" + "-- :doc updates an existing " pretty-name " record\n" + "DELETE FROM " entity-name "\n" + (where-clause entity-map) + "\n\n")})))) + + +(defn queries + [entity-map entities-map] + (merge + {} + (insert-query entity-map) + (update-query entity-map) + (delete-query entity-map) + (if + (is-link-table? entity-map) + (link-table-queries entity-map entities-map) + (merge + (select-query entity-map) + (list-query entity-map) + (search-query entity-map) + (foreign-queries entity-map entities-map))))) + + +;; (defn migrations-to-queries-sql +;; ([migrations-path] +;; (migrations-to-queries-sql migrations-path "queries.auto.sql")) +;; ([migrations-path output] +;; (let +;; [adl-struct (migrations-to-xml migrations-path "Ignored") +;; file-content (apply +;; str +;; (cons +;; (str "-- " +;; output +;; " autogenerated by \n-- [squirrel-parse](https://github.com/simon-brooke/squirrel-parse)\n-- at " +;; (f/unparse (f/formatters :basic-date-time) (t/now)) +;; "\n\n") +;; (doall +;; (map +;; #(:query %) +;; (sort +;; #(compare (:name %1) (:name %2)) +;; (vals +;; (apply +;; merge +;; (map +;; #(queries % adl-struct) +;; (vals adl-struct)))))))))] +;; (spit output file-content) +;; file-content))) diff --git a/src/adl/to_json_routes.clj b/src/adl/to_json_routes.clj index e69de29..f6bac58 100644 --- a/src/adl/to_json_routes.clj +++ b/src/adl/to_json_routes.clj @@ -0,0 +1,237 @@ +(ns ^{:doc "Application Description Language: generate RING routes for REST requests." + :author "Simon Brooke"} + adl.to-json-routes + (:require [clojure.java.io :refer [file]] + [clojure.math.combinatorics :refer [combinations]] + [clojure.string :as s] + [clj-time.core :as t] + [clj-time.format :as f])) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; adl.to-json-routes: generate RING routes for REST requests. +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU General Public License +;;;; as published by the Free Software Foundation; either version 2 +;;;; of the License, or (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;;; USA. +;;;; +;;;; Copyright (C) 2018 Simon Brooke +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; The overall structure of this has quite closely to follow the structure of +;;; to-hugsql-queries, because essentially we need one JSON entry point to wrap +;;; each query. + +(defn file-header [parent-name this-name] + (list + 'ns + (symbol (str parent-name ".routes." this-name)) + (str "JSON routes for " parent-name + " auto-generated by [squirrel-parse](https://github.com/simon-brooke/squirrel-parse) at " + (f/unparse (f/formatters :basic-date-time) (t/now))) + (list + 'require + '[noir.response :as nresponse] + '[noir.util.route :as route] + '[compojure.core :refer [defroutes GET POST]] + '[ring.util.http-response :as response] + '[clojure.java.io :as io] + '[hugsql.core :as hugsql] + (vector (symbol (str parent-name ".db.core")) :as 'db)))) + + +(defn make-safe-name [string] + (s/replace string #"[^a-zA-Z0-9-]" "")) + + +(defn declarations [handlers-map] + (cons 'declare (sort (map #(symbol (make-safe-name (name %))) (keys handlers-map))))) + + +(defn generate-handler-src + [handler-name query-map method doc] + (hash-map + :method method + :src + (remove + nil? + (list + 'defn + handler-name + (str "Auto-generated method to " doc) + [{:keys ['params]}] + (list 'do (list (symbol (str "db/" (:name query-map))) 'params)) + (case + (:type query-map) + (:delete-1 :update-1) + '(response/found "/") + nil))))) + + +(defn handler + "Generate declarations for handlers from query with this `query-key` in this `queries-map` taken from within + this `entities-map`. This method must follow the structure of + `to-hugsql-queries/queries` quite closely, because we must generate the same names." + [query-key queries-map entities-map] + (let [query (query-key queries-map) + handler-name (symbol (make-safe-name (name query-key)))] + (hash-map + (keyword handler-name) + (merge + {:name handler-name + :route (str "/json/" handler-name)} + (case + (:type query) + :delete-1 + (generate-handler-src + handler-name query :post + (str "delete one record from the `" + (-> query :entity :attrs :name) + "` table. Expects the following key(s) to be present in `params`: `" + (doall (-> query :entity :content :key :content keys)) + "`.")) + :insert-1 + (generate-handler-src + handler-name query :post + (str "insert one record to the `" + (-> query :entity :attrs :name) + "` table. Expects the following key(s) to be present in `params`: `" + (pr-str (-> query :entity :content :properties keys)) + "`. Returns a map containing the keys `" + (pr-str (-> query :entity :content :key :content keys)) + "` identifying the record created.")) + :update-1 + (generate-handler-src + handler-name query :post + (str "update one record in the `" + (-> query :entity :attrs :name) + "` table. Expects the following key(s) to be present in `params`: `" + (pr-str + (distinct + (sort + (flatten + (cons + (-> query :entity :content :properties keys) + (-> query :entity :content :key :content keys)))))) + "`.")) + :select-1 + (generate-handler-src + handler-name query :post + (str "select one record from the `" + (-> query :entity :attrs :name) + "` table. Expects the following key(s) to be present in `params`: `" + (pr-str (-> query :entity :content :key :content keys)) + "`. Returns a map containing the following keys: `" + (pr-str + (distinct + (sort + (flatten + (cons + (-> query :entity :content :properties keys) + (-> query :entity :content :key :content keys)))))) + "`.")) + :select-many + (generate-handler-src + handler-name query :get + (str "select all records from the `" + (-> query :entity :attrs :name) + "` table. If the keys `(:limit :offset)` are present in the request then they will be used to page through the data. Returns a sequence of maps each containing the following keys: `" + (pr-str + (distinct + (sort + (flatten + (cons + (-> query :entity :content :properties keys) + (-> query :entity :content :key :content keys)))))) + "`.")) + :text-search + (generate-handler-src + handler-name query :get + (str "select all records from the `" + (-> query :entity :attrs :name) + "` table with any text field matching the value of the key `:pattern` which should be in the request. If the keys `(:limit :offset)` are present in the request then they will be used to page through the data. Returns a sequence of maps each containing the following keys: `" + (pr-str + (distinct + (sort + (flatten + (cons + (-> query :entity :content :properties keys) + (-> query :entity :content :key :content keys)))))) + "`.")) + (:select-many-to-many + :select-one-to-many) + (hash-map :method :get + :src (list 'defn handler-name [{:keys ['params]}] + (list 'do (list (symbol (str "db/" (:name query))) 'params)))) + ;; default + (hash-map + :src + (str ";; don't know what to do with query `" :key "` of type `" (:type query) "`."))))))) + + +(defn defroutes [handlers-map] + (cons + 'defroutes + (cons + 'auto-rest-routes + (map + #(let [handler (handlers-map %)] + (list + (symbol (s/upper-case (name (:method handler)))) + (str "/json/auto/" (:name handler)) + 'request + (list + 'route/restricted + (list (:name handler) 'request)))) + (sort + (keys handlers-map)))))) + + +;; (defn migrations-to-json-routes +;; ([migrations-path parent-namespace-name] +;; (migrations-to-json-routes migrations-path parent-namespace-name "auto-json-routes")) +;; ([migrations-path parent-namespace-name namespace-name] +;; (let [output (str (s/replace namespace-name #"-" "_") ".clj") +;; adl-struct (migrations-to-xml migrations-path "Ignored") +;; q (reduce +;; merge +;; {} +;; (map +;; #(queries % adl-struct) +;; (vals adl-struct))) +;; h (reduce +;; merge +;; {} +;; (map +;; #(handler % q adl-struct) +;; (keys q))) +;; f (cons +;; (file-header parent-namespace-name namespace-name) +;; ;; (pre-declare +;; (cons +;; (declarations h) +;; (cons +;; (defroutes h) +;; (map #(:src (h %)) (sort (keys h))))))] +;; (spit +;; output +;; (with-out-str +;; (doall +;; (for [expr f] +;; (do +;; (pprint expr) +;; (print "\n\n")))))) +;; f +;; ))) diff --git a/src/adl/utils.clj b/src/adl/utils.clj new file mode 100644 index 0000000..ed77ca5 --- /dev/null +++ b/src/adl/utils.clj @@ -0,0 +1,11 @@ +(ns adl.utils + (:require [clojure.string :as s])) + +(defn singularise [string] + (s/replace (s/replace (s/replace string #"_" "-") #"s$" "") #"ie$" "y")) + +(defn is-link-table? + [entity-map] + (let [properties (-> entity-map :content :properties vals) + links (filter #(-> % :attrs :entity) properties)] + (= (count properties) (count links)))) diff --git a/src/adl/validator.clj b/src/adl/validator.clj index e69de29..13a547f 100644 --- a/src/adl/validator.clj +++ b/src/adl/validator.clj @@ -0,0 +1,654 @@ +(ns ^{:doc "Application Description Language: validator for ADL structure." + :author "Simon Brooke"} + adl.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-valid? + ;; Yes, this is a horrible hack. I should be returning the error structure + ;; not printing it. But I can't see how to make that work with `bouncer`. + ;; OK, so: most of the validators will (usually) fail, and that's OK. How + ;; do we identify the one which ought not to have failed? + [o & validations] + (println + (str + (if (:tag o) (str "Tag: " (:tag o) "; ")) + (if (:name (:attrs o)) (str "Name: " (:name (:attrs o)) ";")) + (if-not (or (:tag o) (:name (:attrs o))) (str "Context: " o)))) + + (let + [rs (map + #(try + (b/validate o %) + (catch java.lang.ClassCastException c + ;; The validator regularly barfs on strings, which are perfectly + ;; valid content of some elements. I need a way to validate + ;; elements where they're not tolerated! + [nil o]) + (catch Exception e + [{:exception (.getMessage e) + :class (type e) + :context o} o])) + validations) + all-candidates (remove nil? (map first rs)) + suspicious (remove :tag all-candidates)] + ;; if *any* succeeded, we succeeded + ;; otherwise, one of these is the valid error - but which? The answer, in my case + ;; is that if there is any which did not fail on the :tag check, then that is the + ;; interesting one. But generally? + (try + (doall (map #(println (str "\tError: " %)) suspicious)) + (empty? suspicious) + (catch Exception _ (println "Error while trying to print errors") + true)))) + + +;;; the remainder of this file is a fairly straight translation of the ADL 1.4 DTD into Clojure + + +(declare documentation-validations 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 reference-validations +"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" + {:tag [v/required [#(= % :reference)]] + [:attrs :abbr] v/string + [:attrs :section] v/string + [:attrs :entity] v/string ;; and should be the name of an entity within this document + [:attrs :property] v/string ;; and should be the name of a property in that entity + :content [[v/every documentation-validations]]}) + + +(def specification-validations + "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." + {:tag [v/required [#(= % :specification)]] + [:attrs :url] v/string + [:attrs :name] [v/string v/required] + [:attrs :abbr] [v/string v/required] + :content [[v/every #(disjunct-valid? + documentation-validations + reference-validations)]]}) + + +(def documentation-validations + "contains documentation on the element which immediately contains it. TODO: + should HTML markup within a documentation element be allowed? If so, are + there restrictions?" + {:tag [v/required [#(= % :documentation)]] + :content [[v/every #(disjunct-valid? + % + v/string + reference-validations)]] + }) + +(def content-validations + {:tag [v/required [#(= % :content)]]}) + +(def help-validations + "helptext about a property of an entity, or a field of a page, form or + 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 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-valid? % + 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-valid? % + 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-valid? % + 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-valid? % + 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-valid? % + 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-valid? % + 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-valid? % + specification-validations + documentation-validations + content-validations + typedef-validations + group-validations + entity-validations)]]}) + + diff --git a/test/adl/core_test.clj b/test/adl/core_test.clj deleted file mode 100644 index 18a1a26..0000000 --- a/test/adl/core_test.clj +++ /dev/null @@ -1,7 +0,0 @@ -(ns adl.core-test - (:require [clojure.test :refer :all] - [adl.core :refer :all])) - -(deftest a-test - (testing "FIXME, I fail." - (is (= 0 1)))) diff --git a/test/adl/validator_test.clj b/test/adl/validator_test.clj new file mode 100644 index 0000000..cdb0fe0 --- /dev/null +++ b/test/adl/validator_test.clj @@ -0,0 +1,435 @@ +(ns adl.validator-test + (:require [clojure.java.io :refer [writer]] + [clojure.test :refer :all] + [clojure.xml :refer [parse]] + [adl.validator :refer :all] + [bouncer.core :refer [valid?]])) + +;; OK, so where we're up to: documentation breaks validation of the +;; element that contains it if the documentation is non-empty. + +(deftest validator-documentation-only + (testing "validation of a bare documentation element" + (let [xml {:tag :documentation, + :content ["This is a very simple test document just to exercise validator and generators."]} + expected true + actual (binding [*out* (writer "/dev/null")] + (valid? xml documentation-validations))] + (is (= actual expected)))) + (testing "validation of empty documentation within application element" + (let [xml {:tag + :application, + :attrs {:version "0.0.1", + :name "test1"}, + :content [{:tag :documentation, + :attrs nil, + :content []}]} + expected true + actual (binding [*out* (writer "/dev/null")] + (valid? xml application-validations))] + (is (= actual expected)))) + (testing "validation of non-empty documentation within application element" + (let [xml {:tag :application, + :attrs {:version "0.0.1", + :name "test1"}, + :content [{:tag :documentation, + :attrs nil, + :content ["This is a very simple test document just to exercise validator and generators."]}]} + expected true + actual (binding [*out* (writer "/dev/null")] + (valid? xml application-validations))] + (is (= actual expected)))) + (testing "validation of file `documentation-only.adl.xml`." + (let [xml (parse "resources/test/documentation-only.adl.xml") + expected true + actual (binding [*out* (writer "/dev/null")] + (valid? xml application-validations))] + (is (= actual expected))))) + +(deftest validator-content + (testing "Validation of content element (has text in PCDATA positions)" + (let [xml {:tag :content, + :attrs nil, + :content + [{:tag :head, + :attrs nil, + :content + [{:tag :h:meta, + :attrs + {:content "Application Description Language framework", + :name "generator", + :xmlns "http://www.w3.org/1999/xhtml"}, + :content nil}]} + {:tag :top, + :attrs nil, + :content + [{:tag :h:h1, + :attrs {:xmlns "http://www.w3.org/1999/xhtml"}, + :content ["Test 1"]}]} + {:tag :foot, + :attrs nil, + :content + [{:tag :h:p, + :attrs {:class "footer", :xmlns "http://www.w3.org/1999/xhtml"}, + :content ["That's all folks!"]}]}]} + expected true + actual (binding [*out* (writer "/dev/null")] + (valid? xml content-validations))] + (is (= actual expected))))) + +(deftest validator-head + (testing "Validation of head element" + (let [xml {:tag :head, + :attrs nil, + :content + [{:tag :h:meta, + :attrs + {:content "Application Description Language framework", + :name "generator", + :xmlns "http://www.w3.org/1999/xhtml"}, + :content nil}]} + expected true + actual (binding [*out* (writer "/dev/null")] + (valid? xml head-validations))] + (is (= actual expected))))) + +(deftest validator-top + (testing "Validation of top element (has markup in content)" + (let [xml {:tag :top, + :attrs nil, + :content + [{:tag :h:h1, + :attrs {:xmlns "http://www.w3.org/1999/xhtml"}, + :content ["Test 1"]}]} + expected true + actual (binding [*out* (writer "/dev/null")] + (valid? xml top-validations))] + (is (= actual expected))))) + +(deftest validator-foot + (testing "Validation of foot element (has text in content)" + (let [xml {:tag :foot, + :attrs nil, + :content + [{:tag :h:p, + :attrs {:class "footer", :xmlns "http://www.w3.org/1999/xhtml"}, + :content ["That's all folks!"]}]} + expected true + actual (binding [*out* (writer "/dev/null")] + (valid? xml foot-validations))] + (is (= actual expected))))) + +(deftest validator-group + (testing "Validation of group element (has documentation)" + (let [xml {:tag :group, + :attrs {:name "public"}, + :content + [{:tag :documentation, :attrs nil, :content ["All users"]}]} + expected true + actual (binding [*out* (writer "/dev/null")] + (valid? xml group-validations))] + (is (= actual expected))))) + +(deftest validator-entity + (testing "Validation of entity element" + (let [xml {:tag :entity, + :attrs {:name "person"}, + :content + [{:tag :documentation, :attrs nil, :content ["A person"]} + {:tag :prompt, + :attrs {:locale "en-GB", :prompt "Person"}, + :content nil} + {:tag :key, + :attrs nil, + :content + [{:tag :property, + :attrs + {:immutable "true", + :required "true", + :distinct "system", + :type "integer", + :name "id"}, + :content + [{:tag :generator, :attrs {:action "native"}, :content nil}]}]} + {:tag :property, + :attrs + {:required "true", + :distinct "user", + :size "32", + :type "string", + :name "name"}, + :content + [{:tag :prompt, + :attrs {:locale "en-GB", :prompt "Name"}, + :content nil} + {:tag :prompt, + :attrs {:locale "fr-FR", :prompt "Nomme"}, + :content nil}]} + {:tag :property, + :attrs + {:default "Unknown", :size "8", :type "string", :name "gender"}, + :content + [{: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}]} + {:tag :option, + :attrs {:value "Male"}, + :content + [{:tag :prompt, + :attrs {:locale "fr-FR", :prompt "Homme"}, + :content nil} + {:tag :prompt, + :attrs {:locale "en-GB", :prompt "Male"}, + :content nil}]} + {:tag :option, + :attrs {:value "Non-bin"}, + :content + [{:tag :prompt, + :attrs {:locale "fr-FR", :prompt "Non binaire"}, + :content nil} + {:tag :prompt, + :attrs {:locale "en-GB", :prompt "Non-binary"}, + :content nil}]} + {:tag :option, + :attrs {:value "Unknown"}, + :content + [{:tag :prompt, + :attrs {:locale "fr-FR", :prompt "Inconnu"}, + :content nil} + {:tag :prompt, + :attrs {:locale "en-GB", :prompt "Unknown"}, + :content nil}]}]} + {:tag :property, + :attrs {:type "integer", :name "age"}, + :content nil} + {:tag :property, + :attrs {:entity "address", :type "entity", :name "address"}, + :content nil} + {:tag :form, + :attrs {:properties "listed", :name "edit-person"}, + :content + [{:tag :field, :attrs {:property "name"}, :content nil} + {:tag :field, :attrs {:property "gender"}, :content nil} + {:tag :field, :attrs {:property "age"}, :content nil} + {:tag :field, :attrs {:property "address"}, :content nil} + {:tag :permission, + :attrs {:permission "all", :group "admin"}, + :content nil} + {:tag :permission, + :attrs {:permission "insert", :group "public"}, + :content nil}]} + {:tag :page, + :attrs {:properties "all", :name "inspect-person"}, + :content nil} + {:tag :list, + :attrs + {:on-select "edit-person", + :properties "all", + :name "list-people"}, + :content nil}]} + expected true + actual (binding [*out* (writer "/dev/null")] + (valid? xml entity-validations))] + (is (= actual expected))))) + +(deftest validator-prompt + (testing "Validation of prompt element" + (let [xml {:tag :prompt, + :attrs {:locale "en-GB", :prompt "Person"}, + :content nil} + expected true + actual (binding [*out* (writer "/dev/null")] + (valid? xml prompt-validations))] + (is (= actual expected))))) + +(deftest validator-key + (testing "Validation of key element" + (let [xml {:tag :key, + :attrs nil, + :content + [{:tag :property, + :attrs + {:immutable "true", + :required "true", + :distinct "system", + :type "integer", + :name "id"}, + :content + [{:tag :generator, :attrs {:action "native"}, :content nil}]}]} + expected true + actual (binding [*out* (writer "/dev/null")] + (valid? xml key-validations))] + (is (= actual expected))))) + +(deftest validator-property + (testing "Validation of property element" + (let [xml {:tag :property, + :attrs + {:required "true", + :distinct "user", + :size "32", + :type "string", + :name "name"}, + :content + [{:tag :prompt, + :attrs {:locale "en-GB", :prompt "Name"}, + :content nil} + {:tag :prompt, + :attrs {:locale "fr-FR", :prompt "Nomme"}, + :content nil}]} + + expected true + actual (binding [*out* (writer "/dev/null")] + (valid? xml property-validations))] + (is (= actual expected))))) + +(deftest validator-property-with-options + (testing "Validation of property element with options" + (let [xml {:tag :property, + :attrs + {:default "Unknown", :size "8", :type "string", :name "gender"}, + :content + [{: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}]} + {:tag :option, + :attrs {:value "Male"}, + :content + [{:tag :prompt, + :attrs {:locale "fr-FR", :prompt "Homme"}, + :content nil} + {:tag :prompt, + :attrs {:locale "en-GB", :prompt "Male"}, + :content nil}]} + {:tag :option, + :attrs {:value "Non-bin"}, + :content + [{:tag :prompt, + :attrs {:locale "fr-FR", :prompt "Non binaire"}, + :content nil} + {:tag :prompt, + :attrs {:locale "en-GB", :prompt "Non-binary"}, + :content nil}]} + {:tag :option, + :attrs {:value "Unknown"}, + :content + [{:tag :prompt, + :attrs {:locale "fr-FR", :prompt "Inconnu"}, + :content nil} + {:tag :prompt, + :attrs {:locale "en-GB", :prompt "Unknown"}, + :content nil}]}]} + expected true + actual (binding [*out* (writer "/dev/null")] + (valid? xml entity-validations))] + (is (= actual expected))))) + + +(deftest validator-option + (testing "Validation of option element" + (let [xml {:tag :option, + :attrs {:value "Female"}, + :content + [{:tag :prompt, + :attrs {:locale "fr-FR", :prompt "Femme"}, + :content nil} + {:tag :prompt, + :attrs {:locale "en-GB", :prompt "Female"}, + :content nil}]} + expected true + actual (binding [*out* (writer "/dev/null")] + (valid? xml option-validations))] + (is (= actual expected))))) + + +(deftest validator-form + (testing "Validation of form element" + (let [xml {:tag :form, + :attrs {:properties "listed", :name "edit-person"}, + :content + [{:tag :field, :attrs {:property "name"}, :content nil} + {:tag :field, :attrs {:property "gender"}, :content nil} + {:tag :field, :attrs {:property "age"}, :content nil} + {:tag :field, :attrs {:property "address"}, :content nil} + {:tag :permission, + :attrs {:permission "all", :group "admin"}, + :content nil} + {:tag :permission, + :attrs {:permission "insert", :group "public"}, + :content nil}]} + expected true + actual (binding [*out* (writer "/dev/null")] + (valid? xml form-validations))] + (is (= actual expected))))) + + +(deftest validator-page + (testing "Validation of page element" + (let [xml {:tag :page, + :attrs {:properties "all", :name "inspect-person"}, + :content nil} + expected true + actual (binding [*out* (writer "/dev/null")] + (valid? xml page-validations))] + (is (= actual expected))))) + + +(deftest validator-list + (testing "Validation of list element" + (let [xml {:tag :list, + :attrs + {:on-select "edit-person", + :properties "all", + :name "list-people"}, + :content nil} + expected true + actual (binding [*out* (writer "/dev/null")] + (valid? xml list-validations))] + (is (= actual expected))))) + + +;; (deftest validator-xxx +;; (testing "Validation of xxx element" +;; (let [xml +;; expected true +;; actual (binding [*out* (writer "/dev/null")] +;; (valid? xml xxx-validations))] +;; (is (= actual expected))))) + + +;; (deftest validator-xxx +;; (testing "Validation of xxx element" +;; (let [xml +;; expected true +;; actual (binding [*out* (writer "/dev/null")] +;; (valid? xml xxx-validations))] +;; (is (= actual expected))))) + + +;; (deftest validator-xxx +;; (testing "Validation of xxx element" +;; (let [xml +;; expected true +;; actual (binding [*out* (writer "/dev/null")] +;; (valid? xml xxx-validations))] +;; (is (= actual expected))))) + + +(deftest validator-test-1 + (testing "validation of `testl.adl.xml`." + (let [xml (parse "resources/test/test1.adl.xml") + expected true + actual (valid? xml application-validations)] + (is (= actual expected))))) From 5cf0a4cbed72d6dc0d9f6a21c8ebea946a553227 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 21 Mar 2018 01:55:08 +0000 Subject: [PATCH 03/52] More unit tests. --- src/adl/to_hugsql_queries.clj | 47 +++++++------- test/adl/to_hugsql_queries_test.clj | 98 +++++++++++++++++++++++++++++ 2 files changed, 122 insertions(+), 23 deletions(-) create mode 100644 test/adl/to_hugsql_queries_test.clj diff --git a/src/adl/to_hugsql_queries.clj b/src/adl/to_hugsql_queries.clj index 50916b5..ae5241a 100644 --- a/src/adl/to_hugsql_queries.clj +++ b/src/adl/to_hugsql_queries.clj @@ -31,22 +31,23 @@ ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (defn key-names [entity-map] + (let [k (first (filter #(= (:tag %) :key) (:content entity-map)))] (remove nil? (map #(:name (:attrs %)) - (vals (:content (:key (:content entity-map))))))) + (filter #(= (:tag %) :property) (:content k)))))) (defn has-primary-key? [entity-map] - (> (count (key-names entity-map)) 0)) + (not (empty? (key-names entity-map)))) (defn has-non-key-properties? [entity-map] - (> - (count (vals (:properties (:content entity-map)))) - (count (key-names entity-map)))) + (not + (empty? (filter #(= (:tag %) :property) (:content entity-map))))) (defn where-clause [entity-map] @@ -63,22 +64,26 @@ (let [entity-name (:name (:attrs entity-map)) preferred (map - #(:name (:attrs %)) - (filter #(= (-> % :attrs :distinct) "user") - (-> entity-map :content :properties vals)))] + #(:name (:attrs %)) + (filter #(and + (= (-> % :attrs :distinct) "user") + (= (-> % :tag) :property)) + (-> entity-map :content)))] (str - "ORDER BY " entity-name "." - (s/join - (str ",\n\t" entity-name ".") - (doall (flatten (cons preferred (key-names entity-map)))))))) + "ORDER BY " entity-name "." + (s/join + (str ",\n\t" entity-name ".") + (doall (flatten (cons preferred (key-names entity-map)))))))) +(defn property-names [entity-map] + (map #(:name (:attrs %)) (filter #(= (-> % :tag) :property) (:content entity-map)))) (defn insert-query [entity-map] (let [entity-name (:name (:attrs entity-map)) pretty-name (singularise entity-name) - all-property-names (map #(:name (:attrs %)) (vals (:properties (:content entity-map)))) + all-property-names (property-names entity-map) query-name (str "create-" pretty-name "!") - signature " :! :n"] + signature ":! :n"] (hash-map (keyword query-name) {:name query-name @@ -106,11 +111,7 @@ (has-non-key-properties? entity-map)) (let [entity-name (:name (:attrs entity-map)) pretty-name (singularise entity-name) - property-names (remove - nil? - (map - #(if (= (:tag %) :property) (:name (:attrs %))) - (vals (:properties (:content entity-map))))) + property-names (property-names entity-map) query-name (str "update-" pretty-name "!") signature ":! :n"] (hash-map @@ -137,8 +138,10 @@ query-name (str "search-strings-" pretty-name) signature ":? :1" string-fields (filter - #(= (-> % :attrs :type) "string") - (-> entity-map :content :properties vals))] + #(and + (= (-> % :attrs :type) "string") + (= (:tag %) :property)) + (-> entity-map :content))] (if (empty? string-fields) {} @@ -184,8 +187,6 @@ "-- :doc selects an existing " pretty-name " record\n" "SELECT * FROM " entity-name "\n" (where-clause entity-map) - "\n" - (order-by-clause entity-map) "\n\n")})) {})) diff --git a/test/adl/to_hugsql_queries_test.clj b/test/adl/to_hugsql_queries_test.clj new file mode 100644 index 0000000..e32828e --- /dev/null +++ b/test/adl/to_hugsql_queries_test.clj @@ -0,0 +1,98 @@ +(ns adl.to-hugsql-queries-test + (:require [clojure.test :refer :all] + [adl.to-hugsql-queries :refer :all])) + +(deftest entity-tests + (let [xml {:tag :entity, + :attrs {:name "address"}, + :content + [{:tag :key, + :attrs nil, + :content + [{:tag :property, + :attrs + {:immutable "true", + :required "true", + :distinct "system", + :type "integer", + :name "id"}, + :content + [{:tag :generator, :attrs {:action "native"}, :content nil}]}]} + {:tag :property, + :attrs + {:distinct "user", :size "128", :type "string", :name "street"}, + :content nil} + {:tag :property, + :attrs {:size "64", :type "string", :name "town"}, + :content nil} + {:tag :property, + :attrs + {:distinct "user", :size "12", :type "string", :name "postcode"}, + :content nil}]}] + (testing "user distinct properties should provide the default ordering" + (let [expected "ORDER BY address.street,\n\taddress.postcode,\n\taddress.id" + actual (order-by-clause xml)] + (is (= actual expected)))) + (testing "keys name extraction" + (let [expected '("id") + actual (key-names xml)] + (is (= actual expected)))) + (testing "primary key test" + (let [expected true + actual (has-primary-key? xml)] + (is (= actual expected)))) + (testing "non-key properties test" + (let [expected true + actual (has-non-key-properties? xml)] + (is (= actual expected)))) + (testing "insert query generation" + (let [expected "-- :name create-addres! :! :n\n-- :doc creates a new addres record\nINSERT INTO address (street,\n\ttown,\n\tpostcode)\nVALUES (:street,\n\t:town,\n\t:postcode)\nreturning id\n\n" + actual (:query (first (vals (insert-query xml))))] + (is (= actual expected)))) + (testing "insert query signature" + (let [expected ":! :n" + actual (:signature (first (vals (insert-query xml))))] + (is (= actual expected)))) + (testing "update query generation" + (let [expected "-- :name update-addres! :! :n\n-- :doc updates an existing addres record\nUPDATE address\nSET street = :street,\n\ttown = :town,\n\tpostcode = :postcode\nWHERE address.id = :id\n\n" + actual (:query (first (vals (update-query xml))))] + (is (= actual expected)))) + (testing "update query signature" + (let [expected ":! :n" + actual (:signature (first (vals (update-query xml))))] + (is (= actual expected)))) + (testing "search query generation" + (let [expected "-- :name search-strings-addres :? :1\n-- :doc selects existing address records having any string field matching `:pattern` by substring match\nSELECT * FROM address\nWHERE street LIKE '%:pattern%'\n\tOR town LIKE '%:pattern%'\n\tOR postcode LIKE '%:pattern%'\nORDER BY address.street,\n\taddress.postcode,\n\taddress.id\n--~ (if (:offset params) \"OFFSET :offset \") \n--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")\n\n" + actual (:query (first (vals (search-query xml))))] + (is (= actual expected)))) + (testing "search query signature" + (let [expected ":? :1" + actual (:signature (first (vals (search-query xml))))] + (is (= actual expected)))) + (testing "select query generation" + (let [expected "-- :name get-addres :? :1\n-- :doc selects an existing addres record\nSELECT * FROM address\nWHERE address.id = :id\n\n" + actual (:query (first (vals (select-query xml))))] + (is (= actual expected)))) + (testing "select query signature" + (let [expected ":? :1" + actual (:signature (first (vals (select-query xml))))] + (is (= actual expected)))) + (testing "list query generation" + (let [expected "-- :name list-address :? :*\n-- :doc lists all existing addres records\nSELECT * FROM address\nORDER BY address.street,\n\taddress.postcode,\n\taddress.id\n--~ (if (:offset params) \"OFFSET :offset \") \n--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")\n\n" + actual (:query (first (vals (list-query xml))))] + (is (= actual expected)))) + (testing "list query signature" + (let [expected ":? :*" + actual (:signature (first (vals (list-query xml))))] + (is (= actual expected)))) + (testing "delete query generation" + (let [expected "-- :name delete-addres! :! :n\n-- :doc updates an existing addres record\nDELETE FROM address\nWHERE address.id = :id\n\n" + actual (:query (first (vals (delete-query xml))))] + (is (= actual expected)))) + (testing "delete query signature" + (let [expected ":! :n" + actual (:signature (first (vals (delete-query xml))))] + (is (= actual expected)))) + + )) + From dcbe9ee01b838c395b38f832dc5d5751333342c3 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 21 Mar 2018 10:32:02 +0000 Subject: [PATCH 04/52] Queries improved, all tests in adl.to-hugsql-queries-test pass. --- resources/schemas/adl-1.4.dtd | 244 ++++++++++---------- src/adl/to_hugsql_queries.clj | 332 ++++++++++++++-------------- src/adl/utils.clj | 117 +++++++++- test/adl/to_hugsql_queries_test.clj | 107 +++++++-- 4 files changed, 491 insertions(+), 309 deletions(-) diff --git a/resources/schemas/adl-1.4.dtd b/resources/schemas/adl-1.4.dtd index d8286e3..96de80e 100755 --- a/resources/schemas/adl-1.4.dtd +++ b/resources/schemas/adl-1.4.dtd @@ -11,7 +11,7 @@ - + @@ -24,8 +24,8 @@ - @@ -35,7 +35,7 @@ that we can allow HTML block level entities within content elements --> - --> - --> - date: date java.sql.Types.DATE time: time java.sql.Types.TIME timestamp: timestamp java.sql.Types.TIMESTAMP - uploadable: varchar java.sql.Types.VARCHAR + 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 --> - - present) user-distinct: all properties which are user-distinct (NOTE: Not yet implemented) listed: only those properties for which fields are explicitly listed ---> - + 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 --> @@ -172,9 +172,9 @@ that we can allow HTML block level entities within content elements --> - xmlns: XML namespace, in case required --> - - --> - @@ -232,28 +232,28 @@ that we can allow HTML block level entities within content elements --> value CDATA #REQUIRED kind CDATA #IMPLIED> - - - --> - - - 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 + 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 --> - entity CDATA #IMPLIED farkey CDATA #IMPLIED required %Boolean; #IMPLIED - immutable %Boolean; #IMPLIED + immutable %Boolean; #IMPLIED size CDATA #IMPLIED column CDATA #IMPLIED concrete %Boolean; #IMPLIED cascade (%CascadeActions;) #IMPLIED> - @@ -360,15 +360,15 @@ that we can allow HTML block level entities within content elements --> class CDATA #IMPLIED> @@ -377,40 +377,40 @@ that we can allow HTML block level entities within content elements --> - - - - name CDATA #REQUIRED value CDATA #REQUIRED> - - xmlns CDATA #IMPLIED > @@ -472,7 +472,7 @@ that we can allow HTML block level entities within content elements --> - @@ -481,11 +481,11 @@ that we can allow HTML block level entities within content elements --> property CDATA #REQUIRED sequence (%Sequences;) #IMPLIED> - canadd %Boolean; #IMPLIED> @@ -523,10 +523,10 @@ that we can allow HTML block level entities within content elements --> property: the property which this field displays/edits --> - - @@ -539,14 +539,14 @@ that we can allow HTML block level entities within content elements --> - @@ -554,30 +554,30 @@ that we can allow HTML block level entities within content elements --> xmlns CDATA #IMPLIED> - - - abbr CDATA #REQUIRED > - -#### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=23 "Edit section: Permissions")\] Permissions +#### Permissions Key to any data driven application is who has authority to do what to what: 'permissions'. @@ -285,7 +283,7 @@ Key to any data driven application is who has authority to do what to what: 'per --> -#### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=24 "Edit section: Data types")\] Data types +#### Data types ADL needs to know what type of data can be stored on different properties of different entities. The data types were originally based on JDBC data types: @@ -302,7 +300,7 @@ ADL needs to know what type of data can be stored on different properties of dif timestamp: timestamp java.sql.Types.TIMESTAMP --> -#### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=25 "Edit section: Definable data types")\] Definable data types +#### Definable data types However, in order to be able to do data validation, it's useful to associate rules with data types. ADL has the concept of definable data types, to allow data validation code to be generated from the declarative description. These definable data types are used in the ADL application, for example, to define derived types for phone numbers, email addresses, postcodes, and range types. @@ -328,7 +326,7 @@ However, in order to be able to do data validation, it's useful to associate rul -#### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=26 "Edit section: Page content")\] Page content +#### Page content Pages in applications typically have common, often largely static, sections above, below, to the left or right of the main content which incorporates things like branding, navigation, and so on. This can be defined globally or per page. The intention is that the `head`, `top` and `foot` elements in ADL should be allowed to contain arbitrary HTML, but currently I don't have enough skill with DTD design to know how to specify this. @@ -343,9 +341,9 @@ Pages in applications typically have common, often largely static, sections abov "name CDATA #REQUIRED properties (all|listed) #REQUIRED" > -### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=27 "Edit section: The Elements")\] The Elements +### The Elements -#### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=28 "Edit section: Application")\] Application +#### Application The top level element of an Application Description Language file is the application element: @@ -355,7 +353,7 @@ The top level element of an Application Description Language file is the applica name CDATA #REQUIRED version CDATA #IMPLIED> -#### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=29 "Edit section: Definition")\] Definition +#### Definition In order to be able to use defined types, you need to be able to provide definitions of these types: @@ -377,7 +375,7 @@ In order to be able to use defined types, you need to be able to provide definit minimum CDATA #IMPLIED maximum CDATA #IMPLIED> -#### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=30 "Edit section: Groups")\] Groups +#### Groups In order to be able to user permissions, we need to define who has those permissions. Groups in ADL map directly onto groups/roles at SQL level, but the intention with ADL is that groups should be defined hierarchically. @@ -388,7 +386,7 @@ In order to be able to user permissions, we need to define who has those permiss -#### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=31 "Edit section: Enities and Properties")\] Enities and Properties +#### Enities and Properties A thing-in-the-domain has properties. Things in the domain fall into regularities, groups of things which share similar collections of properties, such that the values of these properties may have are constrained. This is a representation of the world which is not perfect, but which is sufficiently useful to be recognised by the software technologies which ADL abstracts, so we need to be able to define these. Hence we have entities and properties/ @@ -432,7 +430,7 @@ A thing-in-the-domain has properties. Things in the domain fall into regularitie required %Boolean; #IMPLIED size CDATA #IMPLIED> -#### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=32 "Edit section: Options")\] Options +#### Options Sometimes a property has a constrained list of specific values; this is represented for example in the enumerated types supported by many programming languages. Again, we need to be able to represent this. @@ -447,7 +445,7 @@ Sometimes a property has a constrained list of specific values; this is represen -#### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=33 "Edit section: Permissions")\] Permissions +#### Permissions Permissions define policies to allow groups of users to access forms, pages, fields (not yet implemented) or entities. Only entity permissions are enforced at database layer, and field protection is not yet implemented at controller layer. But the ADL allows it to be described, and future implementations of the controller generating transform will do this. @@ -462,7 +460,7 @@ Permissions define policies to allow groups of users to access forms, pages, fie group CDATA #REQUIRED permission (%Permissions;) #REQUIRED> -#### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=34 "Edit section: Pragmas")\] Pragmas +#### Pragmas Pragmas are currently not used at all. They are there as a possible means to provide additional controls on forms, but may not be the correct solutions for that. @@ -477,7 +475,7 @@ Pragmas are currently not used at all. They are there as a possible means to pro name CDATA #REQUIRED value CDATA #REQUIRED> -#### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=35 "Edit section: Prompts, helptexts and error texts")\] Prompts, helptexts and error texts +#### Prompts, helptexts and error texts When soliciting a value for a property from the user, we need to be able to offer the user a prompt to describe what we're asking for, and we need to be able to offer that in the user's preferred natural language. Prompts are typically brief. Sometimes, however, we need to give the user a more extensive description of what is being solicited - 'help text'. Finally, if the data offered by the user isn't adequate for some reason, we need ways of feeding that back. Currently the only error text which is carried in the ADL is 'ifmissing', text to be shown if the value for a required property is missing. All prompts, helptexts and error texts have locale information, so that it should be possible to generate variants of all pages for different natural languages from the same ADL. @@ -519,7 +517,7 @@ When soliciting a value for a property from the user, we need to be able to offe -#### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=36 "Edit section: Forms, Pages and Lists")\] Forms, Pages and Lists +#### Forms, Pages and Lists The basic pages of the user interface. Pages and Forms by default show fields for all the properties of the entity they describe, or they may show only a listed subset. Currently lists show fields for only those properties which are 'user distinct'. Forms, pages and lists may each have their own head, top and foot content, or they may inherit the content defined for the application. @@ -576,10 +574,10 @@ The basic pages of the user interface. Pages and Forms by default show fields fo --> -\[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=37 "Edit section: Using ADL in your project")\] Using ADL in your project +## Using ADL in your project ------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- -### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=38 "Edit section: Selecting the version")\] Selecting the version +### Selecting the version Current versions of ADL are given at the top of this document. Historical versions are as follows: @@ -605,11 +603,11 @@ Current versions of ADL are given at the top of this document. Historical versio * The version at that location is automatically updated from CVS every night * Projects using the **b_development** branch of ADL should be built against the **b_development** branch of CygnetToolkit. -### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=39 "Edit section: Integrating into your build")\] Integrating into your build +### Integrating into your build To use ADL, it is currently most convenient to use NAnt. It is probably possible to do this with MSBuild, but as of yet I don't know how. -#### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=40 "Edit section: Properties")\] Properties +#### Properties For the examples given here to work, you will need to set up at least the following properties in your NAnt `.build` file: @@ -630,7 +628,7 @@ For the examples given here to work, you will need to set up at least the follow where, obviously, **YourProjectName**, **YourSourceDir** and **YourADL.adl.xml** stand in for the actual names of your project, your source directory (relative to your solution directory, where the .build file is) and your ADL file, respectively. Note that if it is to be used as an assembly name, the project name should include neither spaces, hyphens nor periods. If it must do so, you should give an assembly name which does not, explicitly. -#### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=41 "Edit section: Canonicalisation")\] Canonicalisation +#### Canonicalisation The first thing you need to do with your ADL file is canonicalise it. You should generally not need to alter this, you should copy and paste it verbatim: @@ -644,7 +642,7 @@ The first thing you need to do with your ADL file is canonicalise it. You should -#### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=42 "Edit section: Generate NHibernate mapping")\] Generate NHibernate mapping +#### Generate NHibernate mapping You should generally not need to alter this at all, just copy and paste it verbatim: @@ -660,7 +658,7 @@ You should generally not need to alter this at all, just copy and paste it verba -#### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=43 "Edit section: Generate SQL")\] Generate SQL +#### Generate SQL @@ -674,7 +672,7 @@ You should generally not need to alter this at all, just copy and paste it verba -#### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=44 "Edit section: Generate C# entity classes ('POCOs')")\] Generate C# entity classes ('POCOs') +#### Generate C# entity classes ('POCOs') Note that for this to work you must have the following: @@ -707,7 +705,7 @@ Note that for this to work you must have the following: pattern="cut here: next file '(\[a-zA-Z0-9_.\]*)'"/> -#### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=45 "Edit section: Generate Monorail controller classes")\] Generate Monorail controller classes +#### Generate Monorail controller classes Note that for this to work you must have @@ -737,7 +735,7 @@ Note that for this to work you must have destdir="${controllers}/Auto" pattern="cut here: next file '(\[a-zA-Z0-9_.\]*)'"/> -#### \[[edit](http://wiki.cygnets.co.uk/index.php?title=Application_Description_Language_framework&action=edit§ion=46 "Edit section: Generate Velocity views for use with Monorail")\] Generate Velocity views for use with Monorail +#### Generate Velocity views for use with Monorail Note that for this to work you must have diff --git a/project.clj b/project.clj index 72439df..945cda4 100644 --- a/project.clj +++ b/project.clj @@ -6,4 +6,5 @@ :dependencies [[org.clojure/clojure "1.8.0"] [org.clojure/math.combinatorics "0.1.4"] [bouncer "1.0.1"] - [hiccup "1.0.5"]]) + [hiccup "1.0.5"]] + :plugins [[lein-codox "0.10.3"]]) diff --git a/resources/transforms/adl2canonical.xslt b/resources/transforms/adl2canonical.xslt index 1f381be..c157874 100755 --- a/resources/transforms/adl2canonical.xslt +++ b/resources/transforms/adl2canonical.xslt @@ -2,23 +2,23 @@ @@ -75,8 +75,8 @@ * BE MANUALLY EDITED. * * Generated using adl2canonical.xslt - * - *************************************************************************** + * + *************************************************************************** @@ -84,10 +84,10 @@ - + entity already has a key - not generating one @@ -97,7 +97,7 @@ - @@ -139,7 +139,7 @@ entity has no key - generating one - + @@ -214,8 +214,8 @@ -
@@ -231,8 +231,8 @@
- @@ -248,8 +248,8 @@ - @@ -265,7 +265,7 @@ -
@@ -281,7 +281,7 @@
- @@ -298,7 +298,7 @@ - @@ -399,7 +399,7 @@ - @@ -434,7 +434,7 @@ - @@ -450,4 +450,4 @@ - \ No newline at end of file + diff --git a/src/adl/to_hugsql_queries.clj b/src/adl/to_hugsql_queries.clj index f85f761..074978e 100644 --- a/src/adl/to_hugsql_queries.clj +++ b/src/adl/to_hugsql_queries.clj @@ -1,4 +1,4 @@ -(ns ^{:doc "Application Description Language: generate HUGSQL queries file." +(ns ^{:doc "Application Description Language - generate HUGSQL queries file." :author "Simon Brooke"} adl.to-hugsql-queries (:require [clojure.java.io :refer [file]] @@ -6,7 +6,7 @@ [clojure.string :as s] [clj-time.core :as t] [clj-time.format :as f] - [adl.utils :refer [has-non-key-properties? has-primary-key? is-link-table? key-names singularise]])) + [adl.utils :refer [has-non-key-properties? has-primary-key? link-table? key-names singularise]])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; @@ -306,7 +306,7 @@ (update-query entity-map) (delete-query entity-map) (if - (is-link-table? entity-map) + (link-table? entity-map) (link-table-queries entity-map entities-map) (merge (select-query entity-map) diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj index 332ac33..ad3e9c0 100644 --- a/src/adl/to_selmer_templates.clj +++ b/src/adl/to_selmer_templates.clj @@ -1,9 +1,10 @@ -(ns ^{:doc "Application Description Language: generate RING routes for REST requests." +(ns ^{;; :doc "Application Description Language - generate RING routes for REST requests." :author "Simon Brooke"} adl.to-selmer-templates (:require [adl.utils :refer :all] [clojure.java.io :refer [file]] [clojure.math.combinatorics :refer [combinations]] + [clojure.pprint :as p] [clojure.string :as s] [clojure.xml :as x] [clj-time.core :as t] @@ -34,13 +35,32 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(def ^:dynamic *locale* "en-GB") +(def ^:dynamic *locale* + "The locale for which files will be generated." + "en-GB") -(defn file-header [] - "{% extends \"templates/base.html\" %}\n{% block content %}") +(def ^:dynamic *output-path* + "The path to which generated files will be written." + "resources/auto/") -(defn file-footer [] - "{% endblock %}") +(defn file-header + "Generate a header for a template file." + [filename] + (str + "{% extends \"templates/base.html\" %}\n\n" + "\n\n" + "{% block content %}")) + +(defn file-footer + "Generate a header for a template file." + [filename] + "{% endblock %}\n") (defn prompt @@ -58,32 +78,6 @@ (:name (:attrs field-or-property)))) -(defn permission - [property form entity application] - (or - (children property #(= (:tag %) :permission)) - (children entity :permission))) - - -(defn visible? - "Return `true` if this property is not `system`-distinct, and is readable - to the `public` group; else return a list of groups to which it is readable, - given these `permissions`." - [property permissions] - (let [attributes (attributes property)] - (if - (not - (and - ;; if it's immutable and system distinct, the user should not need to see it. - (= (:immutable attributes) "true") - (= (:distinct attributes) "system"))) - (map - #(if - (some #{"read" "insert" "noedit" "edit" "all"} (:permission (:attrs %))) - (:group (:attrs %))) - permissions)))) - - (defn csrf-widget "For the present, just return the standard cross site scripting protection field statement" [] @@ -145,6 +139,20 @@ "%{ endfor %}")) +(defn typedef + "If this `property` is of type `defined`, return its type definition from + this `application`, else nil." + [property application] + (if + (= (:type (:attrs property)) "defined") + (first + (children + application + #(and + (= (:tag %) :typedef) + (= (:name (:attrs %)) (:typedef (:attrs property)))))))) + + (defn widget "Generate a widget for this `field-or-property` of this `form` for this `entity` taken from within this `application`." @@ -160,10 +168,13 @@ #(and (= (:tag %) :property) (= (:name (:attrs %)) (:property (:attrs field-or-property))))))) - permissions (permission property form entity application) - show? (visible? property permissions) - is-select? false] + permissions (permissions property entity application) + typedef + show? true ;;(visible? property permissions) + select? (some #{"entity" "list" "link"} (:type (:attrs property)))] ;; TODO: deal with disabling/hiding if no permission + (println "Property:") + (p/pprint property) (if show? {:tag :p @@ -172,7 +183,7 @@ :attrs {:for name} :content [(prompt field-or-property form entity application)]} (if - is-select? + select? {:tag :select :attrs {:id name :name name} @@ -180,7 +191,7 @@ {:tag :input :attrs {:id name :name name - :type :text ;; TODO - or other things + :type "text" ;; TODO - or other things :value (str "{{record." name "}}")}})]} {:tag :input :attrs {:id name @@ -205,7 +216,7 @@ (flatten (map #(if (some #{:field :fieldgroup :verb} (:tag %)) %) (children form))) - (children entity #(= (:key %) :property)))] + (children entity #(= (:tag %) :property)))] {:tag :div :attrs {:id "content" :class "edit"} :content @@ -217,8 +228,10 @@ (csrf-widget) (map #(widget % form entity application) - (flatten - (list keyfields fields))) + keyfields) + (map + #(widget % form entity application) + fields) (save-widget form entity application) (delete-widget form entity application)))}]})) @@ -278,16 +291,17 @@ (defn write-template-file [filename template] (spit - filename + (str *output-path* filename) (s/join "\n" (list - (file-header) + (file-header filename) (with-out-str (x/emit-element template)) - (file-footer))))) + (file-footer filename))))) (defn to-selmer-templates + "Generate all [Selmer](https://github.com/yogthos/Selmer) templates implied by this ADL `application` spec." [application] (let [templates-map (reduce @@ -300,7 +314,8 @@ (map #(if (templates-map %) - (write-template-file (str (name %) ".html") (templates-map %))) + (let [filename (str (name %) ".html")] + (write-template-file filename (templates-map %)))) (keys templates-map))) templates-map)) diff --git a/src/adl/utils.clj b/src/adl/utils.clj index 5fc77cf..198e345 100644 --- a/src/adl/utils.clj +++ b/src/adl/utils.clj @@ -1,8 +1,31 @@ -(ns adl.utils +(ns ^{:doc "Application Description Language - utility functions." + :author "Simon Brooke"} + adl.utils (:require [clojure.string :as s] [clojure.xml :as x] [adl.validator :refer [valid-adl? validate-adl]])) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; adl.utils: utility functions. +;;;; +;;;; 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 children @@ -20,6 +43,49 @@ (children element))))) +(defn attributes + "Return the attributes of this `element`; if `predicate` is passed, return only those + attributes satisfying the predicate." + ([element] + (if + (keyword? (:tag element)) ;; it has a tag; it seems to be an XML element + (:attrs element))) + ([element predicate] + (remove ;; there's a more idionatic way of doing remove-nil-map, but for the moment I can't recall it. + nil? + (map + #(if (predicate %) %) + (:attrs element))))) + + +(defn permissions + "Return appropriate permissions of this `property`, taken from this `entity` of this + `application`." + [property entity application] + (or + (children property #(= (:tag %) :permission)) + (children entity :permission))) + + +(defn visible? + "Return `true` if this property is not `system`-distinct, and is readable + to the `public` group; else return a list of groups to which it is readable, + given these `permissions`." + [property permissions] + (let [attributes (attributes property)] + (if + (not + (and + ;; if it's immutable and system distinct, the user should not need to see it. + (= (:immutable attributes) "true") + (= (:distinct attributes) "system"))) + (map + #(if + (some #{"read" "insert" "noedit" "edit" "all"} (:permission (:attrs %))) + (:group (:attrs %))) + permissions)))) + + (defn singularise [string] (s/replace (s/replace (s/replace string #"_" "-") #"s$" "") #"ie$" "y")) @@ -56,20 +122,6 @@ (count (key-names entity-map)))) -(defn attributes - "Return the attributes of this `element`; if `predicate` is passed, return only those - attributes satisfying the predicate." - ([element] - (if - (keyword? (:tag element)) ;; it has a tag; it seems to be an XML element - (:attrs element))) - ([element predicate] - (remove ;; there's a more idionatic way of doing remove-nil-map, but for the moment I can't recall it. - nil? - (map - #(if (predicate %) %) - (:attrs element))))) - ;; (read-adl "../youyesyet/stripped.adl.xml") From 8a7a80a461c76e0113ac139b104bf07695f9737a Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 13 May 2018 12:05:07 +0100 Subject: [PATCH 09/52] Very close to good on templates. --- src/adl/to_selmer_templates.clj | 113 ++++++++++++++++++++------------ src/adl/utils.clj | 93 +++++++++++++++++++------- 2 files changed, 141 insertions(+), 65 deletions(-) diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj index ad3e9c0..266589e 100644 --- a/src/adl/to_selmer_templates.clj +++ b/src/adl/to_selmer_templates.clj @@ -125,32 +125,45 @@ (let [type (:type (:attrs property)) farname (:entity (:attrs property)) - farside (application farname) + farside (first + (children + application + #(and + (= (:tag %) :entity) + (= (:name (:attrs %)) farname)))) + fs-distinct (flatten + (list + (children farside #(#{"user" "all"} (:distinct (:attrs %)))) + (children + (first + (children farside #(= (:tag %) :key))) + #(#{"user" "all"} (:distinct (:attrs %)))))) farkey (or (:farkey (:attrs property)) (:name (:attrs (first (children (children farside #(= (:tag %) :key)))))) "id")] - (str "{% for record in " farname " %}%{ endfor %}")) + [(str "{% for record in " farname " %}{% endfor %}")])) -(defn typedef - "If this `property` is of type `defined`, return its type definition from - this `application`, else nil." - [property application] - (if - (= (:type (:attrs property)) "defined") - (first - (children - application - #(and - (= (:tag %) :typedef) - (= (:name (:attrs %)) (:typedef (:attrs property)))))))) +(defn widget-type + "Return an appropriate HTML5 input type for this property." + ([property application] + (widget-type property application (typedef property application))) + ([property application typedef] + (let [t (if + typedef + (:type (:attrs typedef)) + (:type (:attrs property)))] + (case t + ("integer" "real" "money") "number" + ("uploadable" "image") "file" + "boolean" "checkbox" + "date" "date" + "time" "time" + "text" ;; default + )))) (defn widget @@ -158,7 +171,7 @@ taken from within this `application`." [field-or-property form entity application] (let - [name (:name (:attrs field-or-property)) + [widget-name (:name (:attrs field-or-property)) property (if (= (:tag field-or-property) :property) field-or-property @@ -168,36 +181,52 @@ #(and (= (:tag %) :property) (= (:name (:attrs %)) (:property (:attrs field-or-property))))))) - permissions (permissions property entity application) - typedef - show? true ;;(visible? property permissions) - select? (some #{"entity" "list" "link"} (:type (:attrs property)))] - ;; TODO: deal with disabling/hiding if no permission - (println "Property:") - (p/pprint property) + permissions (permissions property form entity application) + typedef (typedef property application) + visible-to (visible-to permissions) + ;; if the form isn't actually a form, no widget is writable. + writable-by (if (= (:tag form) :form) (writable-by permissions)) + select? (#{"entity" "list" "link"} (:type (:attrs property)))] (if - show? + (formal-primary-key? property entity) + {:tag :input + :attrs {:id widget-name + :name widget-name + :type "hidden" + :value (str "{{record." widget-name "}}")}} {:tag :p :attrs {:class "widget"} :content [{:tag :label - :attrs {:for name} + :attrs {:for widget-name} :content [(prompt field-or-property form entity application)]} + "TODO: selmer command to hide for all groups except for those for which it is writable" (if select? {:tag :select - :attrs {:id name - :name name} + :attrs {:id widget-name + :name widget-name} :content (get-options property form entity application)} {:tag :input - :attrs {:id name - :name name - :type "text" ;; TODO - or other things - :value (str "{{record." name "}}")}})]} - {:tag :input - :attrs {:id name - :name name - :type :hidden - :value (str "{{record." name "}}")}}))) + :attrs (merge + {:id widget-name + :name widget-name + :type (widget-type property application typedef) + :value (str "{{record." widget-name "}}")} + (if + (:minimum (:attrs typedef)) + {:min (:minimum (:attrs typedef))}) + (if + (:maximum (:attrs typedef)) + {:max (:maximum (:attrs typedef))}))}) + "{% else %}" + "TODO: selmer if command to hide for all groups except to those for which it is readable" + {:tag :span + :attrs {:id widget-name + :name widget-name + :class "pseudo-widget disabled"} + :content [(str "{{record." widget-name "}}")]} + "{% endif %}" + "{% endif %}"]}))) (defn form-to-template @@ -214,7 +243,7 @@ (and form (= "listed" (:properties (:attrs form)))) ;; if we've got a form, collect its fields, fieldgroups and verbs (flatten - (map #(if (some #{:field :fieldgroup :verb} (:tag %)) %) + (map #(if (#{:field :fieldgroup :verb} (:tag %)) %) (children form))) (children entity #(= (:tag %) :property)))] {:tag :div diff --git a/src/adl/utils.clj b/src/adl/utils.clj index 198e345..ca30560 100644 --- a/src/adl/utils.clj +++ b/src/adl/utils.clj @@ -58,35 +58,82 @@ (:attrs element))))) +(defn typedef + "If this `property` is of type `defined`, return its type definition from + this `application`, else nil." + [property application] + (if + (= (:type (:attrs property)) "defined") + (first + (children + application + #(and + (= (:tag %) :typedef) + (= (:name (:attrs %)) (:typedef (:attrs property)))))))) + + (defn permissions "Return appropriate permissions of this `property`, taken from this `entity` of this - `application`." - [property entity application] - (or - (children property #(= (:tag %) :permission)) - (children entity :permission))) + `application`, in the context of this `page`." + [property page entity application] + (first + (remove + empty? + (list + (children page #(= (:tag %) :permission)) + (children property #(= (:tag %) :permission)) + (children entity #(= (:tag %) :permission)) + (children application #(= (:tag %) :permission)))))) -(defn visible? - "Return `true` if this property is not `system`-distinct, and is readable - to the `public` group; else return a list of groups to which it is readable, - given these `permissions`." - [property permissions] - (let [attributes (attributes property)] - (if - (not - (and - ;; if it's immutable and system distinct, the user should not need to see it. - (= (:immutable attributes) "true") - (= (:distinct attributes) "system"))) - (map - #(if - (some #{"read" "insert" "noedit" "edit" "all"} (:permission (:attrs %))) - (:group (:attrs %))) - permissions)))) +(defn permission-groups + "Return a list of names of groups to which this `predicate` is true of + some permission taken from these `permissions`, else nil." + [permissions predicate] + (let [groups (remove + nil? + (map + #(if + (apply predicate (list %)) + (:group (:attrs %))) + permissions))] + (if groups groups))) -(defn singularise [string] +(defn formal-primary-key? + "Does this `prop-or-name` appear to be a property (or the name of a property) + which is a formal primary key of this entity?" + [prop-or-name entity] + (if + (map? prop-or-name) + (formal-primary-key? (:name (:attrs prop-or-name)) entity) + (let [primary-key (first (children entity #(= (:tag %) :key))) + property (first + (children + primary-key + #(and + (= (:tag %) :property) + (= (:name (:attrs %)) prop-or-name))))] + (= (:distinct (:attrs property)) "system")))) + + +(defn visible-to + "Return a list of names of groups to which are granted read access, + given these `permissions`, else nil." + [permissions] + (permission-groups permissions #(#{"read" "insert" "noedit" "edit" "all"} (:permission (:attrs %))))) + + +(defn writable-by + "Return a list of names of groups to which are granted read access, + given these `permissions`, else nil." + [permissions] + (permission-groups permissions #(#{"edit" "all"} (:permission (:attrs %))))) + + +(defn singularise + "Attempt to construct an idiomatic English-language singular of this string." + [string] (s/replace (s/replace (s/replace string #"_" "-") #"s$" "") #"ie$" "y")) From e3dfbb53436ca4ca188afb44990ac4cf3703fe60 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 13 May 2018 15:31:32 +0100 Subject: [PATCH 10/52] Documentation improvement --- doc/intro.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/intro.md b/doc/intro.md index 306718a..2e730b8 100644 --- a/doc/intro.md +++ b/doc/intro.md @@ -1,4 +1,4 @@ - Application Description Language framework +# Introduction **NOTE**: *this markdown was automatically generated from `adl_user_doc.html`, which in turn was taken from the Wiki page on which this documentation was originally written.* From 481743ff2dbd6918f69a15d67334a6fc8318e358 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 13 May 2018 17:49:15 +0100 Subject: [PATCH 11/52] Much improved query generation. --- src/adl/to_hugsql_queries.clj | 409 ++++++++++++++++++++-------------- src/adl/utils.clj | 36 ++- 2 files changed, 276 insertions(+), 169 deletions(-) diff --git a/src/adl/to_hugsql_queries.clj b/src/adl/to_hugsql_queries.clj index 074978e..de23de7 100644 --- a/src/adl/to_hugsql_queries.clj +++ b/src/adl/to_hugsql_queries.clj @@ -6,7 +6,7 @@ [clojure.string :as s] [clj-time.core :as t] [clj-time.format :as f] - [adl.utils :refer [has-non-key-properties? has-primary-key? link-table? key-names singularise]])) + [adl.utils :refer :all])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; @@ -32,75 +32,96 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defn where-clause [entity-map] +(def ^:dynamic *output-path* + "The path to which generated files will be written." + "resources/auto/") + + +(defn where-clause + "Generate an appropriate `where` clause for queries on this `entity`" + [entity] (let - [entity-name (:name (:attrs entity-map))] + [entity-name (:name (:attrs entity))] (str "WHERE " entity-name "." (s/join (str " AND\n\t" entity-name ".") - (map #(str % " = " (keyword %)) (key-names entity-map)))))) + (map #(str % " = " (keyword %)) (key-names entity)))))) -(defn order-by-clause [entity-map] +(defn order-by-clause + "Generate an appropriate `order by` clause for queries on this `entity`" + [entity] (let - [entity-name (:name (:attrs entity-map)) + [entity-name (:name (:attrs entity)) preferred (map #(:name (:attrs %)) - (filter #(= (-> % :attrs :distinct) "user") - (-> entity-map :content :properties vals)))] - (str - "ORDER BY " entity-name "." - (s/join - (str ",\n\t" entity-name ".") - (doall (flatten (cons preferred (key-names entity-map)))))))) + (filter #(#{"user" "all"} (-> % :attrs :distinct)) + (children entity #(= (:tag %) :property))))] + (if + (empty? preferred) + "" + (str + "ORDER BY " entity-name "." + (s/join + (str ",\n\t" entity-name ".") + (flatten (cons preferred (key-names entity)))))))) -(defn insert-query [entity-map] - (let [entity-name (:name (:attrs entity-map)) +(defn insert-query + "Generate an appropriate `insert` query for this `entity`. + TODO: this depends on the idea that system-unique properties + are not insertable, which is... dodgy." + [entity] + (let [entity-name (:name (:attrs entity)) pretty-name (singularise entity-name) - all-property-names (map #(:name (:attrs %)) (vals (:properties (:content entity-map)))) + insertable-property-names (map + #(:name (:attrs %)) + (filter + #(not (= (:distinct (:attrs %)) "system")) + (all-properties entity))) query-name (str "create-" pretty-name "!") signature " :! :n"] (hash-map (keyword query-name) {:name query-name :signature signature - :entity entity-map + :entity entity :type :insert-1 :query (str "-- :name " query-name " " signature "\n" "-- :doc creates a new " pretty-name " record\n" "INSERT INTO " entity-name " (" - (s/join ",\n\t" all-property-names) + (s/join ",\n\t" insertable-property-names) ")\nVALUES (" - (s/join ",\n\t" (map keyword all-property-names)) + (s/join ",\n\t" (map keyword insertable-property-names)) ")" (if - (has-primary-key? entity-map) - (str "\nreturning " (s/join ",\n\t" (key-names entity-map)))) - "\n\n")}))) + (has-primary-key? entity) + (str "\nreturning " (s/join ",\n\t" (key-names entity)))))}))) -(defn update-query [entity-map] +(defn update-query + "Generate an appropriate `update` query for this `entity`" + [entity] (if (and - (has-primary-key? entity-map) - (has-non-key-properties? entity-map)) - (let [entity-name (:name (:attrs entity-map)) + (has-primary-key? entity) + (has-non-key-properties? entity)) + (let [entity-name (:name (:attrs entity)) pretty-name (singularise entity-name) property-names (remove nil? (map #(if (= (:tag %) :property) (:name (:attrs %))) - (vals (:properties (:content entity-map))))) + (vals (:properties (:content entity))))) query-name (str "update-" pretty-name "!") signature ":! :n"] (hash-map (keyword query-name) {:name query-name :signature signature - :entity entity-map + :entity entity :type :update-1 :query (str "-- :name " query-name " " signature "\n" @@ -109,50 +130,56 @@ "SET " (s/join ",\n\t" (map #(str % " = " (keyword %)) property-names)) "\n" - (where-clause entity-map) - "\n\n")})) + (where-clause entity))})) {})) -(defn search-query [entity-map] - (let [entity-name (:name (:attrs entity-map)) +(defn search-query [entity] + "Generate an appropriate search query for this `entity`" + (let [entity-name (:name (:attrs entity)) pretty-name (singularise entity-name) query-name (str "search-strings-" pretty-name) signature ":? :1" string-fields (filter - #(= (-> % :attrs :type) "string") - (-> entity-map :content :properties vals))] + #(= (-> % :attrs :type) "string") + (children entity #(= (:tag %) :property)))] (if (empty? string-fields) {} (hash-map - (keyword query-name) - {:name query-name - :signature signature - :entity entity-map - :type :text-search - :query - (str "-- :name " query-name " " signature "\n" - "-- :doc selects existing " entity-name " records having any string field matching `:pattern` by substring match\n" - "SELECT * FROM " entity-name "\n" - "WHERE " - (s/join - "\n\tOR " - (map - #(str (-> % :attrs :name) " LIKE '%:pattern%'") - string-fields)) - "\n" - (order-by-clause entity-map) - "\n" - "--~ (if (:offset params) \"OFFSET :offset \") \n" - "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")" - "\n\n")})))) + (keyword query-name) + {:name query-name + :signature signature + :entity entity + :type :text-search + :query + (s/join + "\n" + (remove + empty? + (list + (str "-- :name " query-name " " signature) + (str + "-- :doc selects existing " + pretty-name + " records having any string field matching `:pattern` by substring match") + (str "SELECT * FROM " entity-name) + "WHERE " + (s/join + "\n\tOR " + (map + #(str (-> % :attrs :name) " LIKE '%:pattern%'") + string-fields)) + (order-by-clause entity) + "--~ (if (:offset params) \"OFFSET :offset \")" + "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))})))) -(defn select-query [entity-map] +(defn select-query [entity] + "Generate an appropriate `select` query for this `entity`" (if - (has-primary-key? entity-map) - (let [entity-name (:name (:attrs entity-map)) + (has-primary-key? entity) + (let [entity-name (:name (:attrs entity)) pretty-name (singularise entity-name) query-name (str "get-" pretty-name) signature ":? :1"] @@ -160,25 +187,28 @@ (keyword query-name) {:name query-name :signature signature - :entity entity-map + :entity entity :type :select-1 :query - (str "-- :name " query-name " " signature "\n" - "-- :doc selects an existing " pretty-name " record\n" - "SELECT * FROM " entity-name "\n" - (where-clause entity-map) - "\n" - (order-by-clause entity-map) - "\n\n")})) + (s/join + "\n" + (remove + empty? + (list + (str "-- :name " query-name " " signature) + (str "-- :doc selects an existing " pretty-name " record") + (str "SELECT * FROM " entity-name) + (where-clause entity) + (order-by-clause entity))))})) {})) (defn list-query - "Generate a query to list records in the table represented by this `entity-map`. + "Generate a query to list records in the table represented by this `entity`. Parameters `:limit` and `:offset` may be supplied. If not present limit defaults to 100 and offset to 0." - [entity-map] - (let [entity-name (:name (:attrs entity-map)) + [entity] + (let [entity-name (:name (:attrs entity)) pretty-name (singularise entity-name) query-name (str "list-" entity-name) signature ":? :*"] @@ -186,28 +216,40 @@ (keyword query-name) {:name query-name :signature signature - :entity entity-map + :entity entity :type :select-many :query - (str "-- :name " query-name " " signature "\n" - "-- :doc lists all existing " pretty-name " records\n" - "SELECT * FROM " entity-name "\n" - (order-by-clause entity-map) "\n" - "--~ (if (:offset params) \"OFFSET :offset \") \n" - "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")" - "\n\n")}))) + (s/join + "\n" + (remove + empty? + (list + (str "-- :name " query-name " " signature) + (str "-- :doc lists all existing " pretty-name " records") + (str "SELECT * FROM " entity-name) + (order-by-clause entity) + "--~ (if (:offset params) \"OFFSET :offset \")" + "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))}))) -(defn foreign-queries [entity-map entities-map] - (let [entity-name (:name (:attrs entity-map)) +(defn foreign-queries + + [entity application] + (let [entity-name (:name (:attrs entity)) pretty-name (singularise entity-name) - links (filter #(-> % :attrs :entity) (-> entity-map :content :properties vals))] + links (filter #(-> % :attrs :entity) (children entity #(= (:tag %) :property)))] (apply merge (map #(let [far-name (-> % :attrs :entity) - far-entity ((keyword far-name) entities-map) - pretty-far (s/replace (s/replace far-name #"_" "-") #"s$" "") + far-entity (first + (children + application + (fn [x] + (and + (= (:tag x) :entity) + (= (:name (:attrs x)) far-name))))) + pretty-far (singularise far-name) farkey (-> % :attrs :farkey) link-field (-> % :attrs :name) query-name (str "list-" entity-name "-by-" pretty-far) @@ -216,71 +258,103 @@ (keyword query-name) {:name query-name :signature signature - :entity entity-map + :entity entity :type :select-one-to-many :far-entity far-entity :query - (str "-- :name " query-name " " signature "\n" - "-- :doc lists all existing " pretty-name " records related to a given " pretty-far "\n" - "SELECT * \nFROM " entity-name "\n" - "WHERE " entity-name "." link-field " = :id\n" - (order-by-clause entity-map) - "\n\n")})) + (s/join + "\n" + (remove + empty? + (list + (str "-- :name " query-name " " signature) + (str "-- :doc lists all existing " pretty-name " records related to a given " pretty-far) + (str "SELECT * \nFROM " entity-name) + (str "WHERE " entity-name "." link-field " = :id") + (order-by-clause entity))))})) links)))) -(defn link-table-query [near link far] - (let [properties (-> link :content :properties vals) - links (apply - merge - (map - #(hash-map (keyword (-> % :attrs :entity)) %) - (filter #(-> % :attrs :entity) properties))) - near-name (-> near :attrs :name) - link-name (-> link :attrs :name) - far-name (-> far :attrs :name) - pretty-far (singularise far-name) - query-name (str "list-" link-name "-" near-name "-by-" pretty-far) - signature ":? :*"] - (hash-map - (keyword query-name) - {:name query-name - :signature signature - :entity link - :type :select-many-to-many - :near-entity near - :far-entity far - :query - (str "-- :name " query-name " " signature " \n" - "-- :doc lists all existing " near-name " records related through " link-name " to a given " pretty-far "\n" - "SELECT "near-name ".*\n" - "FROM " near-name ", " link-name "\n" - "WHERE " near-name "." (first (key-names near)) " = " link-name "." (-> (links (keyword near-name)) :attrs :name) "\n\t" - "AND " link-name "." (-> (links (keyword far-name)) :attrs :name) " = :id\n" - (order-by-clause near) - "\n\n")}))) +(defn link-table-query + "Generate a query which links across the entity passed as `link` + from the entity passed as `near` to the entity passed as `far`. + TODO: not working?" + [near link far] + (if + (and + (entity? near) + (entity? link) + (entity? far)) + (let [properties (-> link :content :properties vals) + links (apply + merge + (map + #(hash-map (keyword (-> % :attrs :entity)) %) + (filter #(-> % :attrs :entity) properties))) + near-name (-> near :attrs :name) + link-name (-> link :attrs :name) + far-name (-> far :attrs :name) + pretty-far (singularise far-name) + query-name (str "list-" link-name "-" near-name "-by-" pretty-far) + signature ":? :*"] + (hash-map + (keyword query-name) + {:name query-name + :signature signature + :entity link + :type :select-many-to-many + :near-entity near + :far-entity far + :query + (s/join + "\n" + (remove + empty? + (list + (str "-- :name " query-name " " signature) + (str "-- :doc lists all existing " near-name " records related through " link-name " to a given " pretty-far ) + (str "SELECT "near-name ".*") + (str "FROM " near-name ", " link-name ) + (str "WHERE " near-name "." (first (key-names near)) " = " link-name "." (-> (links (keyword near-name)) :attrs :name) ) + ("\tAND " link-name "." (-> (links (keyword far-name)) :attrs :name) " = :id") + (order-by-clause near))))})))) -(defn link-table-queries [entity-map entities-map] +(defn link-table-queries [entity application] + "Generate all the link queries in this `application` which link via this `entity`." (let [entities (map - #((keyword %) entities-map) - (remove nil? (map #(-> % :attrs :entity) (-> entity-map :content :properties vals)))) + ;; find the far-side entities + (fn + [far-name] + (children + application + (fn [x] + (and + (= (:tag x) :entity) + (= (:name (:attrs x)) far-name))))) + ;; of those properties of this `entity` which are of type `entity` + (remove + nil? + (map + #(-> % :attrs :entity) + (children entity #(= (:tag %) :property))))) pairs (combinations entities 2)] (apply merge (map #(merge - (link-table-query (nth % 0) entity-map (nth % 1)) - (link-table-query (nth % 1) entity-map (nth % 0))) + (link-table-query (nth % 0) entity (nth % 1)) + (link-table-query (nth % 1) entity (nth % 0))) pairs)))) -(defn delete-query [entity-map] +(defn delete-query [entity] + "Generate an appropriate `delete` query for this `entity`" (if - (has-primary-key? entity-map) - (let [entity-name (:name (:attrs entity-map)) + (has-primary-key? entity) + (let [entity-name (:name (:attrs entity)) pretty-name (singularise entity-name) query-name (str "delete-" pretty-name "!") signature ":! :n"] @@ -288,57 +362,58 @@ (keyword query-name) {:name query-name :signature signature - :entity entity-map + :entity entity :type :delete-1 :query (str "-- :name " query-name " " signature "\n" "-- :doc updates an existing " pretty-name " record\n" "DELETE FROM " entity-name "\n" - (where-clause entity-map) - "\n\n")})))) + (where-clause entity))})))) (defn queries - [entity-map entities-map] + "Generate all standard queries for this `entity` in this `application`." + [entity application] (merge {} - (insert-query entity-map) - (update-query entity-map) - (delete-query entity-map) + (insert-query entity) + (update-query entity) + (delete-query entity) (if - (link-table? entity-map) - (link-table-queries entity-map entities-map) + (link-table? entity) + (link-table-queries entity application) (merge - (select-query entity-map) - (list-query entity-map) - (search-query entity-map) - (foreign-queries entity-map entities-map))))) + (select-query entity) + (list-query entity) + (search-query entity) + (foreign-queries entity application))))) -;; (defn migrations-to-queries-sql -;; ([migrations-path] -;; (migrations-to-queries-sql migrations-path "queries.auto.sql")) -;; ([migrations-path output] -;; (let -;; [adl-struct (migrations-to-xml migrations-path "Ignored") -;; file-content (apply -;; str -;; (cons -;; (str "-- " -;; output -;; " autogenerated by \n-- [squirrel-parse](https://github.com/simon-brooke/squirrel-parse)\n-- at " -;; (f/unparse (f/formatters :basic-date-time) (t/now)) -;; "\n\n") -;; (doall -;; (map -;; #(:query %) -;; (sort -;; #(compare (:name %1) (:name %2)) -;; (vals -;; (apply -;; merge -;; (map -;; #(queries % adl-struct) -;; (vals adl-struct)))))))))] -;; (spit output file-content) -;; file-content))) +(defn to-hugsql-queries + "Generate all [HugSQL](https://www.hugsql.org/) queries implied by this ADL `application` spec." + [application] + (spit + (str *output-path* "queries.sql") + (s/join + "\n\n" + (cons + (s/join + "\n-- " + (list + "-- File queries.sql" + "autogenerated by adl.to-hugsql-queries at" + (t/now) + "See [Application Description Language](https://github.com/simon-brooke/adl).\n\n")) + (map + #(:query %) + (sort + #(compare (:name %1) (:name %2)) + (vals + (apply + merge + (map + #(queries % application) + (children + application + (fn [child] (= (:tag child) :entity)))))))))))) + diff --git a/src/adl/utils.clj b/src/adl/utils.clj index ca30560..de0cc44 100644 --- a/src/adl/utils.clj +++ b/src/adl/utils.clj @@ -117,6 +117,12 @@ (= (:distinct (:attrs property)) "system")))) +(defn entity? + "Return true if `x` is an ADL entity." + [x] + (= (:tag x) :entity)) + + (defn visible-to "Return a list of names of groups to which are granted read access, given these `permissions`, else nil." @@ -134,7 +140,13 @@ (defn singularise "Attempt to construct an idiomatic English-language singular of this string." [string] - (s/replace (s/replace (s/replace string #"_" "-") #"s$" "") #"ie$" "y")) + (s/replace + (s/replace + (s/replace + (s/replace string #"_" "-") + #"s$" "") + #"se$" "s") + #"ie$" "y")) (defn link-table? @@ -169,6 +181,26 @@ (count (key-names entity-map)))) +(defn children-with-tag + "Return all children of this `element` which have this `tag`." + [element tag] + (children element #(= (:tag %) tag))) + +(defn descendants-with-tag + "Return all descendants of this `element`, recursively, which have this `tag`." + [element tag] + (flatten + (remove + empty? + (cons + (children element #(= (:tag %) tag)) + (map + #(descendants-with-tag % tag) + (children element)))))) -;; (read-adl "../youyesyet/stripped.adl.xml") +(defn all-properties + "Return all properties of this entity (including key properties)." + [entity] + (descendants-with-tag entity :property)) + From 2764f7ec00fae30d1b5e6a1b14eae4eb763d0a7c Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 3 Jun 2018 08:53:23 +0100 Subject: [PATCH 12/52] Added magnitude attribute on entities --- resources/schemas/adl-1.4.1.dtd | 615 ++++++++++++++++++++++++ resources/transforms/adl2canonical.xslt | 44 +- 2 files changed, 641 insertions(+), 18 deletions(-) create mode 100644 resources/schemas/adl-1.4.1.dtd diff --git a/resources/schemas/adl-1.4.1.dtd b/resources/schemas/adl-1.4.1.dtd new file mode 100644 index 0000000..3f02697 --- /dev/null +++ b/resources/schemas/adl-1.4.1.dtd @@ -0,0 +1,615 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/resources/transforms/adl2canonical.xslt b/resources/transforms/adl2canonical.xslt index c157874..78f9f33 100755 --- a/resources/transforms/adl2canonical.xslt +++ b/resources/transforms/adl2canonical.xslt @@ -25,8 +25,8 @@ --> @@ -69,7 +69,6 @@ *************************************************************************** * * - * ©2007 Cygnet Solutions Ltd * * THIS FILE IS AUTOMATICALLY GENERATED AND SHOULD NOT * BE MANUALLY EDITED. @@ -84,15 +83,18 @@ - - entity already has a key - not generating one + + 6 + + + + + + @@ -100,15 +102,18 @@ - - - - - ADL WARNING: [In entity '']: '@natural-key' is deprecated - use the 'key' sub element instead + + 6 + + + + + + @@ -141,13 +146,16 @@ + + 6 + + + + + + - - - - - From 538406b4736aaf1645474517a7636af9d22c95e7 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Tue, 5 Jun 2018 09:28:18 +0100 Subject: [PATCH 13/52] Most of the way to working forms --- src/adl/to_selmer_templates.clj | 57 +++++++++++++++++++++++++++++++-- 1 file changed, 55 insertions(+), 2 deletions(-) diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj index 266589e..e976341 100644 --- a/src/adl/to_selmer_templates.clj +++ b/src/adl/to_selmer_templates.clj @@ -277,8 +277,61 @@ "Generate a template as specified by this `list` element for this `entity`, taken from this `application`. If `list` is nill, generate a default list template for the entity." - [list entity application] - ) + [list-spec entity application] + (let [user-distinct-fields] + [:tag :div + :attrs {:id "content" :class "edit"} + :content + [:table {:caption (:name (:attrs entity))} + [:thead + [:tr + (map + #(vector :th (prompt %)) + (:fields list-spec))] + [tr + (map + #(vector :th (prompt %)) + (:fields list-spec))] + ] + "{% for record in %records% %}" + [:tr + (map + (fn [field] + [:td (str "{% record." (:name (:attrs %)) " %}")]) + (:fields list-spec)) + [:td + [:a + {:href + (str + "view-or-edit-" + (:name (:attrs entity)) + "?" + (s/join + "&" + (map + #(let [n (:name (:attrs %))] + (str n "=record." n))) + (children (first (filter #(= (:tag %) :key) (children entity))))))} + View]]] + "{% endfor %}" + [:tfoot]] + "{% if offset > 0 %}" + [:div {:id "back-link-container"} + [:a {:href "FIXME"} + Previous]] + "{% endif %}" + [:div {:id "big-link-container"} + [:a {:href "FIXME"} + Next]] + ])) + + + + + + + ]})) + (defn entity-to-templates From 398e3c3a6cddbf68d924e8072a2023cf4f714835 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 10 Jun 2018 21:05:02 +0100 Subject: [PATCH 14/52] Much progress! Many working! --- resources/transforms/adl2canonical.xslt | 3 + src/adl/to_hugsql_queries.clj | 212 ++++++++------- src/adl/to_json_routes.clj | 1 - src/adl/to_selmer_routes.clj | 152 +++++++++++ src/adl/to_selmer_templates.clj | 347 +++++++++++++++++------- src/adl/utils.clj | 150 +++++++--- test/adl/utils_test.clj | 10 + 7 files changed, 634 insertions(+), 241 deletions(-) create mode 100644 src/adl/to_selmer_routes.clj create mode 100644 test/adl/utils_test.clj diff --git a/resources/transforms/adl2canonical.xslt b/resources/transforms/adl2canonical.xslt index 78f9f33..9c583db 100755 --- a/resources/transforms/adl2canonical.xslt +++ b/resources/transforms/adl2canonical.xslt @@ -418,6 +418,7 @@ + @@ -435,6 +436,7 @@ + @@ -454,6 +456,7 @@ + diff --git a/src/adl/to_hugsql_queries.clj b/src/adl/to_hugsql_queries.clj index 4317007..4700ae8 100644 --- a/src/adl/to_hugsql_queries.clj +++ b/src/adl/to_hugsql_queries.clj @@ -36,17 +36,25 @@ "The path to which generated files will be written." "resources/auto/") +(def electors {:tag :entity, :attrs {:magnitude "6", :name "electors", :table "electors"}, :content [{:tag :key, :attrs nil, :content [{:tag :property, :attrs {:distinct "system", :immutable "true", :column "id", :name "id", :type "integer", :required "true"}, :content [{:tag :prompt, :attrs {:locale "en-GB", :prompt "id"}, :content nil}]}]} {:tag :property, :attrs {:distinct "user", :column "name", :name "name", :type "string", :required "true", :size "64"}, :content [{:tag :prompt, :attrs {:locale "en-GB", :prompt "name"}, :content nil}]} {:tag :property, :attrs {:farkey "id", :entity "dwelling", :column "dwelling_id", :name "dwelling_id", :type "entity", :required "true"}, :content [{:tag :prompt, :attrs {:locale "en-GB", :prompt "Flat"}, :content nil}]} {:tag :property, :attrs {:distinct "user", :column "phone", :name "phone", :type "string", :size "16"}, :content [{:tag :prompt, :attrs {:locale "en-GB", :prompt "phone"}, :content nil}]} {:tag :property, :attrs {:distinct "user", :column "email", :name "email", :type "string", :size "128"}, :content [{:tag :prompt, :attrs {:locale "en-GB", :prompt "email"}, :content nil}]} {:tag :property, :attrs {:default "Unknown", :farkey "id", :entity "genders", :column "gender", :type "entity", :name "gender"}, :content [{:tag :prompt, :attrs {:locale "en-GB", :prompt "gender"}, :content nil}]} {:tag :list, :attrs {:name "Electors", :properties "listed"}, :content [{:tag :field, :attrs {:property "id"}, :content nil} {:tag :field, :attrs {:property "name"}, :content nil} {:tag :field, :attrs {:property "dwelling_id"}, :content nil} {:tag :field, :attrs {:property "phone"}, :content nil} {:tag :field, :attrs {:property "email"}, :content nil} {:tag :field, :attrs {:property "gender"}, :content nil}]} {:tag :form, :attrs {:name "Elector", :properties "listed"}, :content [{:tag :field, :attrs {:property "id"}, :content nil} {:tag :field, :attrs {:property "name"}, :content nil} {:tag :field, :attrs {:property "dwelling_id"}, :content nil} {:tag :field, :attrs {:property "phone"}, :content nil} {:tag :field, :attrs {:property "email"}, :content nil} {:tag :field, :attrs {:property "gender"}, :content nil}]}]}) (defn where-clause - "Generate an appropriate `where` clause for queries on this `entity`" - [entity] - (let - [entity-name (:name (:attrs entity))] - (str - "WHERE " entity-name "." - (s/join - (str " AND\n\t" entity-name ".") - (map #(str % " = " (keyword %)) (key-names entity)))))) + "Generate an appropriate `where` clause for queries on this `entity`; + if `properties` are passed, filter on those properties, otherwise the key + properties." + ([entity] + (where-clause entity (key-properties entity))) + ([entity properties] + (let + [entity-name (:name (:attrs entity)) + property-names (map #(:name (:attrs %)) properties)] + (if + (not (empty? property-names)) + (str + "WHERE " + (s/join + "\n\tAND" + (map #(str entity-name "." % " = :" %) property-names))))))) (defn order-by-clause @@ -75,11 +83,7 @@ [entity] (let [entity-name (:name (:attrs entity)) pretty-name (singularise entity-name) - insertable-property-names (map - #(:name (:attrs %)) - (filter - #(not (= (:distinct (:attrs %)) "system")) - (all-properties entity))) + insertable-property-names (map #(:name (:attrs %)) (insertable-properties entity)) query-name (str "create-" pretty-name "!") signature ":! :n"] (hash-map @@ -110,11 +114,7 @@ (has-non-key-properties? entity)) (let [entity-name (:name (:attrs entity)) pretty-name (singularise entity-name) - property-names (remove - nil? - (map - #(if (= (:tag %) :property) (:name (:attrs %))) - (vals (:properties (:content entity))))) + property-names (map #(:name (:attrs %)) (insertable-properties entity)) query-name (str "update-" pretty-name "!") signature ":! :n"] (hash-map @@ -135,73 +135,85 @@ (defn search-query [entity] - "Generate an appropriate search query for this `entity`" + "Generate an appropriate search query for string fields of this `entity`" (let [entity-name (:name (:attrs entity)) pretty-name (singularise entity-name) query-name (str "search-strings-" pretty-name) signature ":? :1" - props (concat (properties entity-map) (insertable-key-properties entity-map)) - string-fields (filter - #(= (-> % :attrs :type) "string") - (children entity #(= (:tag %) :property)))] - (if - (empty? string-fields) - {} - (hash-map - (keyword query-name) - {:name query-name - :signature signature - :entity entity - :type :text-search - :query - (s/join - "\n" - (remove - empty? - (list - (str "-- :name " query-name " " signature) - (str - "-- :doc selects existing " - pretty-name - " records having any string field matching `:pattern` by substring match") - (str "SELECT * FROM " entity-name) - "WHERE " - (s/join - "\n\tOR " + properties (all-properties entity)] + (hash-map + (keyword query-name) + {:name query-name + :signature signature + :entity entity + :type :text-search + :query + (s/join + "\n" + (remove + empty? + (list + (str "-- :name " query-name " " signature) + (str + "-- :doc selects existing " + pretty-name + " records having any string field matching `:pattern` by substring match") + (str "SELECT * FROM " entity-name) + "WHERE " + (s/join + "\n\tOR " + (filter + string? (map - #(str (-> % :attrs :name) " LIKE '%:pattern%'") - string-fields)) - (order-by-clause entity) - "--~ (if (:offset params) \"OFFSET :offset \")" - "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))})))) + #(if + (#{"string" "date" "text"} (:type (:attrs %))) + (str (-> % :attrs :name) " LIKE '%:pattern%'")) + properties))) + (order-by-clause entity) + "--~ (if (:offset params) \"OFFSET :offset \")" + "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))}))) -(defn select-query [entity] +(defn select-query "Generate an appropriate `select` query for this `entity`" - (if - (has-primary-key? entity) - (let [entity-name (:name (:attrs entity)) - pretty-name (singularise entity-name) - query-name (str "get-" pretty-name) - signature ":? :1"] - (hash-map - (keyword query-name) - {:name query-name - :signature signature - :entity entity - :type :select-1 - :query - (s/join - "\n" - (remove - empty? - (list - (str "-- :name " query-name " " signature) - (str "-- :doc selects an existing " pretty-name " record") - (str "SELECT * FROM " entity-name) - (where-clause entity) - (order-by-clause entity))))})) - {})) + ([entity properties] + (if + (not (empty? properties)) + (let [entity-name (:name (:attrs entity)) + pretty-name (singularise entity-name) + query-name (if (= properties (key-properties entity)) + (str "get-" pretty-name) + (str "get-" pretty-name "-by-" (s/join "=" (map #(:name (:attrs %)) properties)))) + signature ":? :1"] + (hash-map + (keyword query-name) + {:name query-name + :signature signature + :entity entity + :type :select-1 + :query + (s/join + "\n" + (remove + empty? + (list + (str "-- :name " query-name " " signature) + (str "-- :doc selects an existing " pretty-name " record") + (str "SELECT * FROM " entity-name) + (where-clause entity properties) + (order-by-clause entity))))})) + {})) + ([entity] + (let [distinct-fields (distinct-properties entity)] + (apply + merge + (cons + (select-query entity (key-properties entity)) + (map + #(select-query entity %) + (combinations distinct-fields (count distinct-fields)))))))) + +(select-query electors) (defn list-query @@ -373,21 +385,27 @@ (defn queries - "Generate all standard queries for this `entity` in this `application`." - [entity application] - (merge - {} - (insert-query entity) - (update-query entity) - (delete-query entity) - (if - (link-table? entity) - (link-table-queries entity application) - (merge - (select-query entity) - (list-query entity) - (search-query entity) - (foreign-queries entity application))))) + "Generate all standard queries for this `entity` in this `application`; if + no entity is specified, generate all queris for the application." + ([application entity] + (merge + {} + (insert-query entity) + (update-query entity) + (delete-query entity) + (if + (link-table? entity) + (link-table-queries entity application) + {}) + (select-query entity) + (list-query entity) + (search-query entity) + (foreign-queries entity application))) + ([application] + (apply + merge + (map #(queries application %) + (children-with-tag application :entity))))) (defn to-hugsql-queries @@ -410,11 +428,5 @@ (sort #(compare (:name %1) (:name %2)) (vals - (apply - merge - (map - #(queries % application) - (children - application - (fn [child] (= (:tag child) :entity)))))))))))) + (queries application)))))))) diff --git a/src/adl/to_json_routes.clj b/src/adl/to_json_routes.clj index 01a8ddc..97e015c 100644 --- a/src/adl/to_json_routes.clj +++ b/src/adl/to_json_routes.clj @@ -2,7 +2,6 @@ :author "Simon Brooke"} adl.to-json-routes (:require [clojure.java.io :refer [file]] - [clojure.math.combinatorics :refer [combinations]] [clojure.string :as s] [clj-time.core :as t] [clj-time.format :as f])) diff --git a/src/adl/to_selmer_routes.clj b/src/adl/to_selmer_routes.clj new file mode 100644 index 0000000..9386d13 --- /dev/null +++ b/src/adl/to_selmer_routes.clj @@ -0,0 +1,152 @@ +(ns ^{:doc "Application Description Language: generate routes for user interface requests." + :author "Simon Brooke"} + adl.to-selmer-routes + (:require [clojure.java.io :refer [file make-parents writer]] + [clojure.pprint :refer [pprint]] + [clojure.string :as s] + [clojure.xml :as x] + [clj-time.core :as t] + [clj-time.format :as f] + [adl.utils :refer :all])) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; adl.to-selmer-routes: generate RING routes for REST requests. +;;;; +;;;; 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 +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Generally. there's one route in the generated file for each Selmer template which has been generated. + +(def ^:dynamic *output-path* + "The path to which generated files will be written." + "resources/auto/") + + +(defn file-header + [application] + (list + 'ns + (symbol (str (:name (:attrs application)) ".routes.auto")) + (str "JSON routes for " (pretty-name application) + " auto-generated by [Application Description Language framework](https://github.com/simon-brooke/adl) at " + (f/unparse (f/formatters :basic-date-time) (t/now))) + (list + :require + '[noir.response :as nresponse] + '[noir.util.route :as route] + '[compojure.core :refer [defroutes GET POST]] + '[ring.util.http-response :as response] + '[clojure.java.io :as io] + '[hugsql.core :as hugsql] + (vector (symbol (str (:name (:attrs application)) ".routes.manual")) :as 'm)))) + +(defn make-handler + [f e a] + (let [n (path-part f e a)] + (list + 'defn + (symbol n) + (vector 'r) + (list + 'layout/render + (list 'resolve-template (str n ".html")) {:title (pretty-name e)})))) + +(defn make-route + "Make a route for method `m` to request the resource with name `n`." + [m n] + (list + m + (str "/" n) + 'request + (list + 'route/restricted + (list + 'apply + (list 'resolve-handler n) + (list 'list 'request))))) + +(defn make-defroutes + [application] + (let [routes (flatten + (map + (fn [e] + (map + (fn [c] + (path-part c e application)) + (filter (fn [c] (#{:form :list :page} (:tag c))) (children e)))) + (children-with-tag application :entity)))] + (cons + 'defroutes + (cons + 'auto-selmer-routes + (interleave + (map + (fn [r] (make-route 'GET r)) + (sort routes)) + (map + (fn [r] (make-route 'POST r)) + (sort routes))))))) + + +(defn to-selmer-routes + [application] + (let [filename (str *output-path* (:name (:attrs application)) "/routes/auto.clj")] + (make-parents filename) + (with-open [output (writer filename)] + (binding [*out* output] + (pprint (file-header application)) + (println) + (pprint '(defn raw-resolve-template [n] + (if + (.exists (io/as-file (str "resources/templates/" n))) + n + (str "auto/" n)))) + (println) + (pprint '(def resolve-template (memoise raw-resolve-template))) + (println) + (doall + (map + (fn [e] + (doall + (map + (fn [c] + (pprint (make-handler c e application)) + (println)) + (filter (fn [c] (#{:form :list :page} (:tag c))) (children e))))) + (children-with-tag application :entity))) + (pprint '(defn raw-resolve-handler + "Prefer the manually-written version of the handler with name `n`, if it exists, to the automatically generated one" + [n] + (let [s (symbol (str "m." n))] + (if + (bound? s) + (eval s) + (eval (symbol n)))))) + (println) + (pprint '(def resolve-handler + (memoize raw-resolve-handler))) + (println) + (pprint (make-defroutes application)) + (println))))) + +(def x (x/parse "../youyesyet/youyesyet.canonical.adl.xml")) + +(to-selmer-routes x) + diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj index e976341..7ad3beb 100644 --- a/src/adl/to_selmer_templates.clj +++ b/src/adl/to_selmer_templates.clj @@ -1,9 +1,8 @@ -(ns ^{;; :doc "Application Description Language - generate RING routes for REST requests." +(ns ^{;; :doc "Application Description Language - generate Selmer templates for the HTML pages implied by an ADL file." :author "Simon Brooke"} adl.to-selmer-templates (:require [adl.utils :refer :all] [clojure.java.io :refer [file]] - [clojure.math.combinatorics :refer [combinations]] [clojure.pprint :as p] [clojure.string :as s] [clojure.xml :as x] @@ -13,7 +12,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; -;;;; adl.to-json-routes: generate RING routes for REST requests. +;;;; adl.to-selmer-templates. ;;;; ;;;; This program is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU General Public License @@ -43,6 +42,31 @@ "The path to which generated files will be written." "resources/auto/") + +(defn big-link + [content url] + {:tag :div + :attrs {:class "big-link-container"} + :content + [{:tag :a :attrs {:href url} + :content (if + (vector? content) + content + [content])}]}) + + +(defn back-link + [content url] + {:tag :div + :attrs {:class "back-link-container"} + :content + [{:tag :a :attrs {:href url} + :content (if + (vector? content) + content + [content])}]}) + + (defn file-header "Generate a header for a template file." [filename] @@ -67,15 +91,19 @@ "Return an appropriate prompt for the given `field-or-property` taken from this `form` of this `entity` of this `application`, in the context of the current binding of `*locale*`. TODO: something more sophisticated about i18n" - [field-or-property form entity application] - (or - (first - (children - field-or-property - #(and - (= (:tag %) :prompt) - (= (:locale :attrs %) *locale*)))) - (:name (:attrs field-or-property)))) + ([field-or-property form entity application] + (prompt field-or-property)) + ([field-or-property] + (or + (first + (children + field-or-property + #(and + (= (:tag %) :prompt) + (= (:locale :attrs %) *locale*)))) + + (:name (:attrs field-or-property)) + (:property (:attrs field-or-property))))) (defn csrf-widget @@ -166,12 +194,48 @@ )))) +(defn select-widget + [property form entity application] + (let [farname (:entity (:attrs property)) + farside (first (children application #(= (:name (:attrs %)) farname))) + magnitude (try (read-string (:magnitude (:attrs farside))) (catch Exception _ 7)) + async? (and (number? magnitude) (> magnitude 1)) + widget-name (:name (:attrs property))] + {:tag :div + :attrs {:class "select-box" :farside farname :found (if farside "true" "false")} + :content + (apply + vector + (remove + nil? + (list + (if + async? + {:tag :input + :attrs + {:name (str widget-name "-search-box") + :onchange "/* javascript to repopulate the select widget */"}}) + {:tag :select + :attrs (merge + {:id widget-name + :name widget-name} + (if + (= (:type (:attrs property)) "link") + {:multiple "multiple"}) + (if + async? + {:comment "JavaScript stuff to fix up aynchronous loading"})) + :content (apply vector (get-options property form entity application))})))})) + + (defn widget "Generate a widget for this `field-or-property` of this `form` for this `entity` taken from within this `application`." [field-or-property form entity application] (let - [widget-name (:name (:attrs field-or-property)) + [widget-name (if (= (:tag field-or-property) :property) + (:name (:attrs field-or-property)) + (:property (:attrs field-or-property))) property (if (= (:tag field-or-property) :property) field-or-property @@ -199,13 +263,11 @@ :content [{:tag :label :attrs {:for widget-name} :content [(prompt field-or-property form entity application)]} - "TODO: selmer command to hide for all groups except for those for which it is writable" - (if + (str "{% ifwritable " (:name (:attrs entity)) " " (:name (:attrs property)) " %}") + (cond select? - {:tag :select - :attrs {:id widget-name - :name widget-name} - :content (get-options property form entity application)} + (select-widget property form entity application) + true {:tag :input :attrs (merge {:id widget-name @@ -219,14 +281,20 @@ (:maximum (:attrs typedef)) {:max (:maximum (:attrs typedef))}))}) "{% else %}" - "TODO: selmer if command to hide for all groups except to those for which it is readable" + (str "{% ifreadable " (:name (:attrs entity)) " " (:name (:attrs property)) "%}") {:tag :span :attrs {:id widget-name :name widget-name :class "pseudo-widget disabled"} :content [(str "{{record." widget-name "}}")]} - "{% endif %}" - "{% endif %}"]}))) + "{% endifreadable %}" + "{% endifwritable %}"]}))) + + +(defn fields + [form] + (descendants-with-tag form :field)) + (defn form-to-template @@ -235,22 +303,14 @@ template for the entity." [form entity application] (let - [name (str (if form (:name (:attrs form)) "edit") "-" (:name (:attrs entity))) - keyfields (children + [keyfields (children ;; there should only be one key; its keys are properties - (first (children entity #(= (:tag %) :key)))) - fields (if - (and form (= "listed" (:properties (:attrs form)))) - ;; if we've got a form, collect its fields, fieldgroups and verbs - (flatten - (map #(if (#{:field :fieldgroup :verb} (:tag %)) %) - (children form))) - (children entity #(= (:tag %) :property)))] + (first (children entity #(= (:tag %) :key))))] {:tag :div :attrs {:id "content" :class "edit"} :content [{:tag :form - :attrs {:action (str "{{servlet-context}}/" name) + :attrs {:action (str "{{servlet-context}}/" (editor-name entity application)) :method "POST"} :content (flatten (list @@ -260,7 +320,7 @@ keyfields) (map #(widget % form entity application) - fields) + (fields entity)) (save-widget form entity application) (delete-widget form entity application)))}]})) @@ -273,67 +333,91 @@ [page entity application] ) -(defn list-to-template + +(defn- list-thead + [list-spec] + {:tag :thead + :content + [{:tag :tr + :content + (apply + vector + (map + #(hash-map + :content [(prompt %)] + :tag :th) + (fields list-spec)))} + {:tag :tr + :content + (apply + vector + (map + #(hash-map + :tag :th + :content + [{:tag :input + :attrs {:id (:property (:attrs %)) + :name (:property (:attrs %))}}]) + (fields list-spec)))}]}) + + +(defn- list-tbody + [list-spec entity application] + {:tag :tbody + :content + ["{% for record in %records% %}" + {:tag :tr + :content + (apply + vector + (concat + (map + (fn [field] + {:tag :td :content [(str "{{ record." (:property (:attrs field)) " }}")]}) + (fields list-spec)) + [{:tag :td + :content + [{:tag :a + :attrs + {:href + (str + (editor-name entity application) + "?" + (s/join + "&" + (map + #(let [n (:name (:attrs %))] + (str n "={{ record." n "}}")) + (children (first (filter #(= (:tag %) :key) (children entity)))))))} + :content ["View"]}]}]))} + "{% endfor %}"]}) + + +(defn- list-to-template "Generate a template as specified by this `list` element for this `entity`, taken from this `application`. If `list` is nill, generate a default list template for the entity." [list-spec entity application] - (let [user-distinct-fields] - [:tag :div - :attrs {:id "content" :class "edit"} + {:tag :form + :attrs {:id "content" :class "list"} + :content + [(big-link (str "Add a new " (pretty-name entity)) (editor-name entity application)) + {:tag :table + :attrs {:caption (:name (:attrs entity))} :content - [:table {:caption (:name (:attrs entity))} - [:thead - [:tr - (map - #(vector :th (prompt %)) - (:fields list-spec))] - [tr - (map - #(vector :th (prompt %)) - (:fields list-spec))] - ] - "{% for record in %records% %}" - [:tr - (map - (fn [field] - [:td (str "{% record." (:name (:attrs %)) " %}")]) - (:fields list-spec)) - [:td - [:a - {:href - (str - "view-or-edit-" - (:name (:attrs entity)) - "?" - (s/join - "&" - (map - #(let [n (:name (:attrs %))] - (str n "=record." n))) - (children (first (filter #(= (:tag %) :key) (children entity))))))} - View]]] - "{% endfor %}" - [:tfoot]] - "{% if offset > 0 %}" - [:div {:id "back-link-container"} - [:a {:href "FIXME"} - Previous]] - "{% endif %}" - [:div {:id "big-link-container"} - [:a {:href "FIXME"} - Next]] - ])) + [ + (list-thead list-spec) + (list-tbody list-spec entity application) + {:tag :tfoot}]} + "{% if offset > 0 %}" + (back-link "Previous" "FIXME") + "{% endif %}" + (big-link "Next" "FIXME") + (big-link (str "Add a new " (pretty-name entity)) (editor-name entity application))]}) - - - ]})) - - - (defn entity-to-templates "Generate one or more templates for editing instances of this `entity` in this `application`" @@ -349,37 +433,91 @@ (merge (if forms - (apply merge (map #(assoc {} (keyword (str "form-" (:name (:attrs entity)) "-" (:name (:attrs %)))) + (apply merge (map #(assoc {} (keyword (path-part % entity application)) (form-to-template % entity application)) forms)) {(keyword (str "form-" (:name (:attrs entity)))) (form-to-template nil entity application)}) (if pages - (apply merge (map #(assoc {} (keyword (str "page-" (:name (:attrs entity)) "-" (:name (:attrs %)))) + (apply merge (map #(assoc {} (keyword (path-part % entity application)) (page-to-template % entity application)) pages)) {(keyword (str "page-" (:name (:attrs entity)))) (page-to-template nil entity application)}) (if lists - (apply merge (map #(assoc {} (keyword (str "list-" (:name (:attrs entity)) "-" (:name (:attrs %)))) + (apply merge (map #(assoc {} (keyword (path-part % entity application)) (list-to-template % entity application)) lists)) {(keyword (str "list-" (:name (:attrs entity)))) (form-to-template nil entity application)}))))) + +(defn application-to-template + [application] + (let + [first-class-entities (filter + #(children-with-tag % :list) + (children-with-tag application :entity))] + {:application-index + {:tag :dl + :attrs {:class "index"} + :content + (apply + vector + (interleave + (map + #(hash-map + :tag :dt + :content + [{:tag :a + :attrs {:href (path-part :list % application)} + :content [(pretty-name %)]}]) + first-class-entities) + (map + #(hash-map + :tag :dd + :content (apply + vector + (map + (fn [d] + (hash-map + :tag :p + :content (:content d))) + (children-with-tag % :documentation)))) + first-class-entities)))}})) + + + (defn write-template-file [filename template] - (spit - (str *output-path* filename) - (s/join - "\n" - (list - (file-header filename) - (with-out-str (x/emit-element template)) - (file-footer filename))))) + (if + template + (try + (spit + (str *output-path* filename) + (s/join + "\n" + (list + (file-header filename) + (with-out-str + (x/emit-element template)) + (file-footer filename)))) + (catch Exception any + (spit + (str *output-path* filename) + (with-out-str + (println + (str + "")) + (p/pprint template)))))) + filename) (defn to-selmer-templates @@ -388,7 +526,7 @@ (let [templates-map (reduce merge - {} + (application-to-template application) (map #(entity-to-templates % application) (children application #(= (:tag %) :entity))))] @@ -397,8 +535,15 @@ #(if (templates-map %) (let [filename (str (name %) ".html")] - (write-template-file filename (templates-map %)))) - (keys templates-map))) - templates-map)) + (try + (write-template-file filename (templates-map %)) + (catch Exception any + (str + "Exception " + (.getName (.getClass any)) + (.getMessage any) + " while writing " + filename))))) + (keys templates-map))))) diff --git a/src/adl/utils.clj b/src/adl/utils.clj index de0cc44..f39d540 100644 --- a/src/adl/utils.clj +++ b/src/adl/utils.clj @@ -36,11 +36,9 @@ (keyword? (:tag element)) ;; it has a tag; it seems to be an XML element (:content element))) ([element predicate] - (remove ;; there's a more idionatic way of doing remove-nil-map, but for the moment I can't recall it. - nil? - (map - #(if (predicate %) %) - (children element))))) + (filter + predicate + (children element)))) (defn attributes @@ -51,11 +49,9 @@ (keyword? (:tag element)) ;; it has a tag; it seems to be an XML element (:attrs element))) ([element predicate] - (remove ;; there's a more idionatic way of doing remove-nil-map, but for the moment I can't recall it. - nil? - (map - #(if (predicate %) %) - (:attrs element))))) + (filter + predicate + (attributes element)))) (defn typedef @@ -140,13 +136,33 @@ (defn singularise "Attempt to construct an idiomatic English-language singular of this string." [string] - (s/replace + (cond + (.endsWith string "ss") string + (.endsWith string "ise") string + true (s/replace (s/replace - (s/replace string #"_" "-") - #"s$" "") - #"se$" "s") - #"ie$" "y")) + (s/replace + (s/replace string #"_" "-") + #"s$" "") + #"se$" "s") + #"ie$" "y"))) + + +(defn capitalise + "Return a string like `s` but with each token capitalised." + [s] + (s/join + " " + (map + #(apply str (cons (Character/toUpperCase (first %)) (rest %))) + (s/split s #"[ \t\r\n]+")))) + + +(defn pretty-name + [entity] + (capitalise (singularise (:name (:attrs entity))))) + (defn link-table? @@ -159,26 +175,8 @@ (defn read-adl [url] (let [adl (x/parse url) valid? (valid-adl? adl)] - adl)) -;; (if valid? adl -;; (throw (Exception. (str (validate-adl adl))))))) - -(defn key-names [entity-map] - (remove - nil? - (map - #(:name (:attrs %)) - (vals (:content (:key (:content entity-map))))))) - - -(defn has-primary-key? [entity-map] - (> (count (key-names entity-map)) 0)) - - -(defn has-non-key-properties? [entity-map] - (> - (count (vals (:properties (:content entity-map)))) - (count (key-names entity-map)))) + (if valid? adl + (throw (Exception. (str (validate-adl adl))))))) (defn children-with-tag @@ -186,6 +184,11 @@ [element tag] (children element #(= (:tag %) tag))) +(defmacro properties + "Return all the properties of this `entity`." + [entity] + `(children-with-tag ~entity :property)) + (defn descendants-with-tag "Return all descendants of this `element`, recursively, which have this `tag`." [element tag] @@ -199,8 +202,77 @@ (children element)))))) -(defn all-properties - "Return all properties of this entity (including key properties)." - [entity] - (descendants-with-tag entity :property)) +(defn insertable? + "Return `true` it the value of this `property` may be set from user-supplied data." + [property] + (and + (= (:tag property) :property) + (not (= (:distinct (:attrs property)) "system")))) +(defmacro all-properties + "Return all properties of this `entity` (including key properties)." + [entity] + `(descendants-with-tag ~entity :property)) + +(defmacro insertable-properties + "Return all the properties of this `entity` (including key properties) into + which user-supplied data can be inserted" + [entity] + `(filter + insertable? + (all-properties ~entity))) + +(defmacro key-properties + [entity] + `(children-with-tag (first (children-with-tag ~entity :key)) :property)) + +(defmacro insertable-key-properties + [entity] + `(filter insertable? (key-properties entity))) + + +(defn key-names [entity] + (remove + nil? + (map + #(:name (:attrs %)) + (key-properties entity)))) + + +(defn has-primary-key? [entity] + (> (count (key-names entity)) 0)) + + +(defn has-non-key-properties? [entity] + (> + (count (all-properties entity)) + (count (key-properties entity)))) + + +(defn distinct-properties + [entity] + (filter + #(#{"system" "all"} (:distinct (:attrs %))) + (properties entity))) + +(defn path-part + "Return the URL path part for this `form` of this `entity` within this `application`. + Note that `form` may be a Clojure XML representation of a `form`, `list` or `page` + ADL element, or may be one of the keywords `:form`, `:list`, `:page` in which case the + first child of the `entity` of the specified type will be used." + [form entity application] + (cond + (and (map? form) (#{:list :form :page} (:tag form))) + (s/join + "-" + (flatten + (list + (name (:tag form)) (:name (:attrs entity)) (s/split (:name (:attrs form)) #"[ \n\r\t]+")))) + (keyword? form) + (path-part (first (children-with-tag entity form)) entity application))) + +(defn editor-name + "Return the path-part of the editor form for this `entity`. Note: + assumes the editor form is the first form listed for the entity." + [entity application] + (path-part :form entity application)) diff --git a/test/adl/utils_test.clj b/test/adl/utils_test.clj new file mode 100644 index 0000000..cd9c083 --- /dev/null +++ b/test/adl/utils_test.clj @@ -0,0 +1,10 @@ +(ns adl.utils-test + (:require [clojure.string :as s] + [clojure.test :refer :all] + [adl.utils :refer :all])) + +(deftest singularise-tests + (testing "Singularise" + (is (= "address" (singularise "addresses"))) + (is (= "address" (singularise "address"))) + (is (= "expertise" (singularise "expertise"))))) From e98906c85e45e1f63a0aa9805de24477cf136f37 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 10 Jun 2018 21:05:02 +0100 Subject: [PATCH 15/52] Much progress! Many working! --- resources/transforms/adl2canonical.xslt | 3 + src/adl/to_hugsql_queries.clj | 212 +++++++------- src/adl/to_json_routes.clj | 1 - src/adl/to_selmer_routes.clj | 179 ++++++++++++ src/adl/to_selmer_templates.clj | 368 +++++++++++++++++------- src/adl/utils.clj | 150 +++++++--- test/adl/utils_test.clj | 10 + 7 files changed, 679 insertions(+), 244 deletions(-) create mode 100644 src/adl/to_selmer_routes.clj create mode 100644 test/adl/utils_test.clj diff --git a/resources/transforms/adl2canonical.xslt b/resources/transforms/adl2canonical.xslt index 78f9f33..9c583db 100755 --- a/resources/transforms/adl2canonical.xslt +++ b/resources/transforms/adl2canonical.xslt @@ -418,6 +418,7 @@ + @@ -435,6 +436,7 @@ + @@ -454,6 +456,7 @@ + diff --git a/src/adl/to_hugsql_queries.clj b/src/adl/to_hugsql_queries.clj index 4317007..4700ae8 100644 --- a/src/adl/to_hugsql_queries.clj +++ b/src/adl/to_hugsql_queries.clj @@ -36,17 +36,25 @@ "The path to which generated files will be written." "resources/auto/") +(def electors {:tag :entity, :attrs {:magnitude "6", :name "electors", :table "electors"}, :content [{:tag :key, :attrs nil, :content [{:tag :property, :attrs {:distinct "system", :immutable "true", :column "id", :name "id", :type "integer", :required "true"}, :content [{:tag :prompt, :attrs {:locale "en-GB", :prompt "id"}, :content nil}]}]} {:tag :property, :attrs {:distinct "user", :column "name", :name "name", :type "string", :required "true", :size "64"}, :content [{:tag :prompt, :attrs {:locale "en-GB", :prompt "name"}, :content nil}]} {:tag :property, :attrs {:farkey "id", :entity "dwelling", :column "dwelling_id", :name "dwelling_id", :type "entity", :required "true"}, :content [{:tag :prompt, :attrs {:locale "en-GB", :prompt "Flat"}, :content nil}]} {:tag :property, :attrs {:distinct "user", :column "phone", :name "phone", :type "string", :size "16"}, :content [{:tag :prompt, :attrs {:locale "en-GB", :prompt "phone"}, :content nil}]} {:tag :property, :attrs {:distinct "user", :column "email", :name "email", :type "string", :size "128"}, :content [{:tag :prompt, :attrs {:locale "en-GB", :prompt "email"}, :content nil}]} {:tag :property, :attrs {:default "Unknown", :farkey "id", :entity "genders", :column "gender", :type "entity", :name "gender"}, :content [{:tag :prompt, :attrs {:locale "en-GB", :prompt "gender"}, :content nil}]} {:tag :list, :attrs {:name "Electors", :properties "listed"}, :content [{:tag :field, :attrs {:property "id"}, :content nil} {:tag :field, :attrs {:property "name"}, :content nil} {:tag :field, :attrs {:property "dwelling_id"}, :content nil} {:tag :field, :attrs {:property "phone"}, :content nil} {:tag :field, :attrs {:property "email"}, :content nil} {:tag :field, :attrs {:property "gender"}, :content nil}]} {:tag :form, :attrs {:name "Elector", :properties "listed"}, :content [{:tag :field, :attrs {:property "id"}, :content nil} {:tag :field, :attrs {:property "name"}, :content nil} {:tag :field, :attrs {:property "dwelling_id"}, :content nil} {:tag :field, :attrs {:property "phone"}, :content nil} {:tag :field, :attrs {:property "email"}, :content nil} {:tag :field, :attrs {:property "gender"}, :content nil}]}]}) (defn where-clause - "Generate an appropriate `where` clause for queries on this `entity`" - [entity] - (let - [entity-name (:name (:attrs entity))] - (str - "WHERE " entity-name "." - (s/join - (str " AND\n\t" entity-name ".") - (map #(str % " = " (keyword %)) (key-names entity)))))) + "Generate an appropriate `where` clause for queries on this `entity`; + if `properties` are passed, filter on those properties, otherwise the key + properties." + ([entity] + (where-clause entity (key-properties entity))) + ([entity properties] + (let + [entity-name (:name (:attrs entity)) + property-names (map #(:name (:attrs %)) properties)] + (if + (not (empty? property-names)) + (str + "WHERE " + (s/join + "\n\tAND" + (map #(str entity-name "." % " = :" %) property-names))))))) (defn order-by-clause @@ -75,11 +83,7 @@ [entity] (let [entity-name (:name (:attrs entity)) pretty-name (singularise entity-name) - insertable-property-names (map - #(:name (:attrs %)) - (filter - #(not (= (:distinct (:attrs %)) "system")) - (all-properties entity))) + insertable-property-names (map #(:name (:attrs %)) (insertable-properties entity)) query-name (str "create-" pretty-name "!") signature ":! :n"] (hash-map @@ -110,11 +114,7 @@ (has-non-key-properties? entity)) (let [entity-name (:name (:attrs entity)) pretty-name (singularise entity-name) - property-names (remove - nil? - (map - #(if (= (:tag %) :property) (:name (:attrs %))) - (vals (:properties (:content entity))))) + property-names (map #(:name (:attrs %)) (insertable-properties entity)) query-name (str "update-" pretty-name "!") signature ":! :n"] (hash-map @@ -135,73 +135,85 @@ (defn search-query [entity] - "Generate an appropriate search query for this `entity`" + "Generate an appropriate search query for string fields of this `entity`" (let [entity-name (:name (:attrs entity)) pretty-name (singularise entity-name) query-name (str "search-strings-" pretty-name) signature ":? :1" - props (concat (properties entity-map) (insertable-key-properties entity-map)) - string-fields (filter - #(= (-> % :attrs :type) "string") - (children entity #(= (:tag %) :property)))] - (if - (empty? string-fields) - {} - (hash-map - (keyword query-name) - {:name query-name - :signature signature - :entity entity - :type :text-search - :query - (s/join - "\n" - (remove - empty? - (list - (str "-- :name " query-name " " signature) - (str - "-- :doc selects existing " - pretty-name - " records having any string field matching `:pattern` by substring match") - (str "SELECT * FROM " entity-name) - "WHERE " - (s/join - "\n\tOR " + properties (all-properties entity)] + (hash-map + (keyword query-name) + {:name query-name + :signature signature + :entity entity + :type :text-search + :query + (s/join + "\n" + (remove + empty? + (list + (str "-- :name " query-name " " signature) + (str + "-- :doc selects existing " + pretty-name + " records having any string field matching `:pattern` by substring match") + (str "SELECT * FROM " entity-name) + "WHERE " + (s/join + "\n\tOR " + (filter + string? (map - #(str (-> % :attrs :name) " LIKE '%:pattern%'") - string-fields)) - (order-by-clause entity) - "--~ (if (:offset params) \"OFFSET :offset \")" - "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))})))) + #(if + (#{"string" "date" "text"} (:type (:attrs %))) + (str (-> % :attrs :name) " LIKE '%:pattern%'")) + properties))) + (order-by-clause entity) + "--~ (if (:offset params) \"OFFSET :offset \")" + "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))}))) -(defn select-query [entity] +(defn select-query "Generate an appropriate `select` query for this `entity`" - (if - (has-primary-key? entity) - (let [entity-name (:name (:attrs entity)) - pretty-name (singularise entity-name) - query-name (str "get-" pretty-name) - signature ":? :1"] - (hash-map - (keyword query-name) - {:name query-name - :signature signature - :entity entity - :type :select-1 - :query - (s/join - "\n" - (remove - empty? - (list - (str "-- :name " query-name " " signature) - (str "-- :doc selects an existing " pretty-name " record") - (str "SELECT * FROM " entity-name) - (where-clause entity) - (order-by-clause entity))))})) - {})) + ([entity properties] + (if + (not (empty? properties)) + (let [entity-name (:name (:attrs entity)) + pretty-name (singularise entity-name) + query-name (if (= properties (key-properties entity)) + (str "get-" pretty-name) + (str "get-" pretty-name "-by-" (s/join "=" (map #(:name (:attrs %)) properties)))) + signature ":? :1"] + (hash-map + (keyword query-name) + {:name query-name + :signature signature + :entity entity + :type :select-1 + :query + (s/join + "\n" + (remove + empty? + (list + (str "-- :name " query-name " " signature) + (str "-- :doc selects an existing " pretty-name " record") + (str "SELECT * FROM " entity-name) + (where-clause entity properties) + (order-by-clause entity))))})) + {})) + ([entity] + (let [distinct-fields (distinct-properties entity)] + (apply + merge + (cons + (select-query entity (key-properties entity)) + (map + #(select-query entity %) + (combinations distinct-fields (count distinct-fields)))))))) + +(select-query electors) (defn list-query @@ -373,21 +385,27 @@ (defn queries - "Generate all standard queries for this `entity` in this `application`." - [entity application] - (merge - {} - (insert-query entity) - (update-query entity) - (delete-query entity) - (if - (link-table? entity) - (link-table-queries entity application) - (merge - (select-query entity) - (list-query entity) - (search-query entity) - (foreign-queries entity application))))) + "Generate all standard queries for this `entity` in this `application`; if + no entity is specified, generate all queris for the application." + ([application entity] + (merge + {} + (insert-query entity) + (update-query entity) + (delete-query entity) + (if + (link-table? entity) + (link-table-queries entity application) + {}) + (select-query entity) + (list-query entity) + (search-query entity) + (foreign-queries entity application))) + ([application] + (apply + merge + (map #(queries application %) + (children-with-tag application :entity))))) (defn to-hugsql-queries @@ -410,11 +428,5 @@ (sort #(compare (:name %1) (:name %2)) (vals - (apply - merge - (map - #(queries % application) - (children - application - (fn [child] (= (:tag child) :entity)))))))))))) + (queries application)))))))) diff --git a/src/adl/to_json_routes.clj b/src/adl/to_json_routes.clj index 01a8ddc..97e015c 100644 --- a/src/adl/to_json_routes.clj +++ b/src/adl/to_json_routes.clj @@ -2,7 +2,6 @@ :author "Simon Brooke"} adl.to-json-routes (:require [clojure.java.io :refer [file]] - [clojure.math.combinatorics :refer [combinations]] [clojure.string :as s] [clj-time.core :as t] [clj-time.format :as f])) diff --git a/src/adl/to_selmer_routes.clj b/src/adl/to_selmer_routes.clj new file mode 100644 index 0000000..551596c --- /dev/null +++ b/src/adl/to_selmer_routes.clj @@ -0,0 +1,179 @@ +(ns ^{:doc "Application Description Language: generate routes for user interface requests." + :author "Simon Brooke"} + adl.to-selmer-routes + (:require [clojure.java.io :refer [file make-parents writer]] + [clojure.pprint :refer [pprint]] + [clojure.string :as s] + [clojure.xml :as x] + [clj-time.core :as t] + [clj-time.format :as f] + [adl.utils :refer :all])) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; adl.to-selmer-routes: generate routes for user interface requests. +;;;; +;;;; 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 +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Generally. there's one route in the generated file for each Selmer template which has been generated. + +(def ^:dynamic *output-path* + "The path to which generated files will be written." + "resources/auto/") + + +(defn file-header + [application] + (list + 'ns + (symbol (str (:name (:attrs application)) ".routes.auto")) + (str "JSON routes for " (pretty-name application) + " auto-generated by [Application Description Language framework](https://github.com/simon-brooke/adl) at " + (f/unparse (f/formatters :basic-date-time) (t/now))) + (list + :require + '[noir.response :as nresponse] + '[noir.util.route :as route] + '[compojure.core :refer [defroutes GET POST]] + '[ring.util.http-response :as response] + '[clojure.java.io :as io] + '[hugsql.core :as hugsql] + (vector (symbol (str parent-name ".db.core")) :as 'db) + (vector (symbol (str (:name (:attrs application)) ".routes.manual")) :as 'm)))) + +(defn make-handler + [f e a] + (let [n (path-part f e a)] + (list + 'defn + (symbol n) + (vector 'r) + (list 'let (vector 'p (list :form-params 'r)) + (list + 'layout/render + (list 'resolve-template (str n ".html")) + (merge + {:title (capitalise (:name (:attrs f))) + :params 'p} + (case (:tag f) + (:form :page) + {:record + (list + (symbol + (str "db/get-" (singularise (:name (:attrs e))))) + 'p)} + :list + {:records + (list + (symbol + (str + "db/search-" + (singularise (:name (:attrs e))))) + 'p)}))))))) + +(defn make-route + "Make a route for method `m` to request the resource with name `n`." + [m n] + (list + m + (str "/" n) + 'request + (list + 'route/restricted + (list + 'apply + (list 'resolve-handler n) + (list 'list 'request))))) + +(defn make-defroutes + [application] + (let [routes (flatten + (map + (fn [e] + (map + (fn [c] + (path-part c e application)) + (filter (fn [c] (#{:form :list :page} (:tag c))) (children e)))) + (children-with-tag application :entity)))] + (cons + 'defroutes + (cons + 'auto-selmer-routes + (interleave + (map + (fn [r] (make-route 'GET r)) + (sort routes)) + (map + (fn [r] (make-route 'POST r)) + (sort routes))))))) + + +(defn to-selmer-routes + [application] + (let [filename (str *output-path* (:name (:attrs application)) "/routes/auto.clj")] + (make-parents filename) + (with-open [output (writer filename)] + (binding [*out* output] + (pprint (file-header application)) + (println) + (pprint '(defn raw-resolve-template [n] + (if + (.exists (io/as-file (str "resources/templates/" n))) + n + (str "auto/" n)))) + (println) + (pprint '(def resolve-template (memoise raw-resolve-template))) + (println) + (pprint '(defn index + [r] + (layout/render + (resolve-template + "application-index") + {:title "Administrative menu"}))) + (println) + (doall + (map + (fn [e] + (doall + (map + (fn [c] + (pprint (make-handler c e application)) + (println)) + (filter (fn [c] (#{:form :list :page} (:tag c))) (children e))))) + (children-with-tag application :entity))) + (pprint '(defn raw-resolve-handler + "Prefer the manually-written version of the handler with name `n`, if it exists, to the automatically generated one" + [n] + (let [s (symbol (str "m." n))] + (if + (bound? s) + (eval s) + (eval (symbol n)))))) + (println) + (pprint '(def resolve-handler + (memoize raw-resolve-handler))) + (println) + (pprint (make-defroutes application)) + (println))))) + +(def x (x/parse "../youyesyet/youyesyet.canonical.adl.xml")) + +(to-selmer-routes x) + diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj index e976341..d69f9f6 100644 --- a/src/adl/to_selmer_templates.clj +++ b/src/adl/to_selmer_templates.clj @@ -1,9 +1,8 @@ -(ns ^{;; :doc "Application Description Language - generate RING routes for REST requests." +(ns ^{;; :doc "Application Description Language - generate Selmer templates for the HTML pages implied by an ADL file." :author "Simon Brooke"} adl.to-selmer-templates (:require [adl.utils :refer :all] [clojure.java.io :refer [file]] - [clojure.math.combinatorics :refer [combinations]] [clojure.pprint :as p] [clojure.string :as s] [clojure.xml :as x] @@ -13,7 +12,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; -;;;; adl.to-json-routes: generate RING routes for REST requests. +;;;; adl.to-selmer-templates. ;;;; ;;;; This program is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU General Public License @@ -43,6 +42,31 @@ "The path to which generated files will be written." "resources/auto/") + +(defn big-link + [content url] + {:tag :div + :attrs {:class "big-link-container"} + :content + [{:tag :a :attrs {:href url} + :content (if + (vector? content) + content + [content])}]}) + + +(defn back-link + [content url] + {:tag :div + :attrs {:class "back-link-container"} + :content + [{:tag :a :attrs {:href url} + :content (if + (vector? content) + content + [content])}]}) + + (defn file-header "Generate a header for a template file." [filename] @@ -67,15 +91,19 @@ "Return an appropriate prompt for the given `field-or-property` taken from this `form` of this `entity` of this `application`, in the context of the current binding of `*locale*`. TODO: something more sophisticated about i18n" - [field-or-property form entity application] - (or - (first - (children - field-or-property - #(and - (= (:tag %) :prompt) - (= (:locale :attrs %) *locale*)))) - (:name (:attrs field-or-property)))) + ([field-or-property form entity application] + (prompt field-or-property)) + ([field-or-property] + (or + (first + (children + field-or-property + #(and + (= (:tag %) :prompt) + (= (:locale :attrs %) *locale*)))) + + (:name (:attrs field-or-property)) + (:property (:attrs field-or-property))))) (defn csrf-widget @@ -166,12 +194,48 @@ )))) +(defn select-widget + [property form entity application] + (let [farname (:entity (:attrs property)) + farside (first (children application #(= (:name (:attrs %)) farname))) + magnitude (try (read-string (:magnitude (:attrs farside))) (catch Exception _ 7)) + async? (and (number? magnitude) (> magnitude 1)) + widget-name (:name (:attrs property))] + {:tag :div + :attrs {:class "select-box" :farside farname :found (if farside "true" "false")} + :content + (apply + vector + (remove + nil? + (list + (if + async? + {:tag :input + :attrs + {:name (str widget-name "-search-box") + :onchange "/* javascript to repopulate the select widget */"}}) + {:tag :select + :attrs (merge + {:id widget-name + :name widget-name} + (if + (= (:type (:attrs property)) "link") + {:multiple "multiple"}) + (if + async? + {:comment "JavaScript stuff to fix up aynchronous loading"})) + :content (apply vector (get-options property form entity application))})))})) + + (defn widget "Generate a widget for this `field-or-property` of this `form` for this `entity` taken from within this `application`." [field-or-property form entity application] (let - [widget-name (:name (:attrs field-or-property)) + [widget-name (if (= (:tag field-or-property) :property) + (:name (:attrs field-or-property)) + (:property (:attrs field-or-property))) property (if (= (:tag field-or-property) :property) field-or-property @@ -199,13 +263,11 @@ :content [{:tag :label :attrs {:for widget-name} :content [(prompt field-or-property form entity application)]} - "TODO: selmer command to hide for all groups except for those for which it is writable" - (if + (str "{% ifwritable " (:name (:attrs entity)) " " (:name (:attrs property)) " %}") + (cond select? - {:tag :select - :attrs {:id widget-name - :name widget-name} - :content (get-options property form entity application)} + (select-widget property form entity application) + true {:tag :input :attrs (merge {:id widget-name @@ -219,14 +281,20 @@ (:maximum (:attrs typedef)) {:max (:maximum (:attrs typedef))}))}) "{% else %}" - "TODO: selmer if command to hide for all groups except to those for which it is readable" + (str "{% ifreadable " (:name (:attrs entity)) " " (:name (:attrs property)) "%}") {:tag :span :attrs {:id widget-name :name widget-name :class "pseudo-widget disabled"} :content [(str "{{record." widget-name "}}")]} - "{% endif %}" - "{% endif %}"]}))) + "{% endifreadable %}" + "{% endifwritable %}"]}))) + + +(defn fields + [form] + (descendants-with-tag form :field)) + (defn form-to-template @@ -235,22 +303,14 @@ template for the entity." [form entity application] (let - [name (str (if form (:name (:attrs form)) "edit") "-" (:name (:attrs entity))) - keyfields (children + [keyfields (children ;; there should only be one key; its keys are properties - (first (children entity #(= (:tag %) :key)))) - fields (if - (and form (= "listed" (:properties (:attrs form)))) - ;; if we've got a form, collect its fields, fieldgroups and verbs - (flatten - (map #(if (#{:field :fieldgroup :verb} (:tag %)) %) - (children form))) - (children entity #(= (:tag %) :property)))] + (first (children entity #(= (:tag %) :key))))] {:tag :div :attrs {:id "content" :class "edit"} :content [{:tag :form - :attrs {:action (str "{{servlet-context}}/" name) + :attrs {:action (str "{{servlet-context}}/" (editor-name entity application)) :method "POST"} :content (flatten (list @@ -260,7 +320,7 @@ keyfields) (map #(widget % form entity application) - fields) + (fields entity)) (save-widget form entity application) (delete-widget form entity application)))}]})) @@ -268,70 +328,109 @@ (defn page-to-template "Generate a template as specified by this `page` element for this `entity`, - taken from this `application`. If `page` is nill, generate a default page + taken from this `application`. If `page` is nil, generate a default page template for the entity." [page entity application] ) -(defn list-to-template + +(defn- list-thead + "Return a table head element for the list view for this `list-spec` of this `entity` within + this `application`. + + TODO: where entity fields are being shown/searched on, we should be using the user-distinct + fields of the far side, rather than key values" + [list-spec entity application] + {:tag :thead + :content + [{:tag :tr + :content + (apply + vector + (map + #(hash-map + :content [(prompt %)] + :tag :th) + (fields list-spec)))} + {:tag :tr + :content + (apply + vector + + (map + (fn [f] + (let [property (first + (children + entity + (fn [p] (and (= (:tag p) :property) + (= (:name (:attrs p)) (:property (:attrs f)))))))] + (hash-map + :tag :th + :content + [{:tag :input + :type (case (:type (:attrs property)) + ("integer" "real" "money") "number" + ("date" "timestamp") "date" + "time" "time" + "text") + :attrs {:id (:property (:attrs f)) + :name (:property (:attrs f)) + :value (str "{{ params." (:property (:attrs f)) " }}")}}]))) + (fields list-spec)))}]}) + + +(defn- list-tbody + [list-spec entity application] + {:tag :tbody + :content + ["{% for record in %records% %}" + {:tag :tr + :content + (apply + vector + (concat + (map + (fn [field] + {:tag :td :content [(str "{{ record." (:property (:attrs field)) " }}")]}) + (fields list-spec)) + [{:tag :td + :content + [{:tag :a + :attrs + {:href + (str + (editor-name entity application) + "?" + (s/join + "&" + (map + #(let [n (:name (:attrs %))] + (str n "={{ record." n "}}")) + (children (first (filter #(= (:tag %) :key) (children entity)))))))} + :content ["View"]}]}]))} + "{% endfor %}"]}) + + +(defn- list-to-template "Generate a template as specified by this `list` element for this `entity`, taken from this `application`. If `list` is nill, generate a default list template for the entity." [list-spec entity application] - (let [user-distinct-fields] - [:tag :div - :attrs {:id "content" :class "edit"} + {:tag :form + :attrs {:id "content" :class "list"} + :content + [(big-link (str "Add a new " (pretty-name entity)) (editor-name entity application)) + {:tag :table + :attrs {:caption (:name (:attrs entity))} :content - [:table {:caption (:name (:attrs entity))} - [:thead - [:tr - (map - #(vector :th (prompt %)) - (:fields list-spec))] - [tr - (map - #(vector :th (prompt %)) - (:fields list-spec))] - ] - "{% for record in %records% %}" - [:tr - (map - (fn [field] - [:td (str "{% record." (:name (:attrs %)) " %}")]) - (:fields list-spec)) - [:td - [:a - {:href - (str - "view-or-edit-" - (:name (:attrs entity)) - "?" - (s/join - "&" - (map - #(let [n (:name (:attrs %))] - (str n "=record." n))) - (children (first (filter #(= (:tag %) :key) (children entity))))))} - View]]] - "{% endfor %}" - [:tfoot]] - "{% if offset > 0 %}" - [:div {:id "back-link-container"} - [:a {:href "FIXME"} - Previous]] - "{% endif %}" - [:div {:id "big-link-container"} - [:a {:href "FIXME"} - Next]] - ])) - - - - - - - ]})) - + [(list-thead list-spec entity application) + (list-tbody list-spec entity application) + {:tag :tfoot}]} + "{% if offset > 0 %}" + (back-link "Previous" "FIXME") + "{% endif %}" + (big-link "Next" "FIXME") + (big-link (str "Add a new " (pretty-name entity)) (editor-name entity application))]}) (defn entity-to-templates @@ -349,37 +448,91 @@ (merge (if forms - (apply merge (map #(assoc {} (keyword (str "form-" (:name (:attrs entity)) "-" (:name (:attrs %)))) + (apply merge (map #(assoc {} (keyword (path-part % entity application)) (form-to-template % entity application)) forms)) {(keyword (str "form-" (:name (:attrs entity)))) (form-to-template nil entity application)}) (if pages - (apply merge (map #(assoc {} (keyword (str "page-" (:name (:attrs entity)) "-" (:name (:attrs %)))) + (apply merge (map #(assoc {} (keyword (path-part % entity application)) (page-to-template % entity application)) pages)) {(keyword (str "page-" (:name (:attrs entity)))) (page-to-template nil entity application)}) (if lists - (apply merge (map #(assoc {} (keyword (str "list-" (:name (:attrs entity)) "-" (:name (:attrs %)))) + (apply merge (map #(assoc {} (keyword (path-part % entity application)) (list-to-template % entity application)) lists)) {(keyword (str "list-" (:name (:attrs entity)))) (form-to-template nil entity application)}))))) + +(defn application-to-template + [application] + (let + [first-class-entities (filter + #(children-with-tag % :list) + (children-with-tag application :entity))] + {:application-index + {:tag :dl + :attrs {:class "index"} + :content + (apply + vector + (interleave + (map + #(hash-map + :tag :dt + :content + [{:tag :a + :attrs {:href (path-part :list % application)} + :content [(pretty-name %)]}]) + first-class-entities) + (map + #(hash-map + :tag :dd + :content (apply + vector + (map + (fn [d] + (hash-map + :tag :p + :content (:content d))) + (children-with-tag % :documentation)))) + first-class-entities)))}})) + + + (defn write-template-file [filename template] - (spit - (str *output-path* filename) - (s/join - "\n" - (list - (file-header filename) - (with-out-str (x/emit-element template)) - (file-footer filename))))) + (if + template + (try + (spit + (str *output-path* filename) + (s/join + "\n" + (list + (file-header filename) + (with-out-str + (x/emit-element template)) + (file-footer filename)))) + (catch Exception any + (spit + (str *output-path* filename) + (with-out-str + (println + (str + "")) + (p/pprint template)))))) + filename) (defn to-selmer-templates @@ -388,7 +541,7 @@ (let [templates-map (reduce merge - {} + (application-to-template application) (map #(entity-to-templates % application) (children application #(= (:tag %) :entity))))] @@ -397,8 +550,15 @@ #(if (templates-map %) (let [filename (str (name %) ".html")] - (write-template-file filename (templates-map %)))) - (keys templates-map))) - templates-map)) + (try + (write-template-file filename (templates-map %)) + (catch Exception any + (str + "Exception " + (.getName (.getClass any)) + (.getMessage any) + " while writing " + filename))))) + (keys templates-map))))) diff --git a/src/adl/utils.clj b/src/adl/utils.clj index de0cc44..f39d540 100644 --- a/src/adl/utils.clj +++ b/src/adl/utils.clj @@ -36,11 +36,9 @@ (keyword? (:tag element)) ;; it has a tag; it seems to be an XML element (:content element))) ([element predicate] - (remove ;; there's a more idionatic way of doing remove-nil-map, but for the moment I can't recall it. - nil? - (map - #(if (predicate %) %) - (children element))))) + (filter + predicate + (children element)))) (defn attributes @@ -51,11 +49,9 @@ (keyword? (:tag element)) ;; it has a tag; it seems to be an XML element (:attrs element))) ([element predicate] - (remove ;; there's a more idionatic way of doing remove-nil-map, but for the moment I can't recall it. - nil? - (map - #(if (predicate %) %) - (:attrs element))))) + (filter + predicate + (attributes element)))) (defn typedef @@ -140,13 +136,33 @@ (defn singularise "Attempt to construct an idiomatic English-language singular of this string." [string] - (s/replace + (cond + (.endsWith string "ss") string + (.endsWith string "ise") string + true (s/replace (s/replace - (s/replace string #"_" "-") - #"s$" "") - #"se$" "s") - #"ie$" "y")) + (s/replace + (s/replace string #"_" "-") + #"s$" "") + #"se$" "s") + #"ie$" "y"))) + + +(defn capitalise + "Return a string like `s` but with each token capitalised." + [s] + (s/join + " " + (map + #(apply str (cons (Character/toUpperCase (first %)) (rest %))) + (s/split s #"[ \t\r\n]+")))) + + +(defn pretty-name + [entity] + (capitalise (singularise (:name (:attrs entity))))) + (defn link-table? @@ -159,26 +175,8 @@ (defn read-adl [url] (let [adl (x/parse url) valid? (valid-adl? adl)] - adl)) -;; (if valid? adl -;; (throw (Exception. (str (validate-adl adl))))))) - -(defn key-names [entity-map] - (remove - nil? - (map - #(:name (:attrs %)) - (vals (:content (:key (:content entity-map))))))) - - -(defn has-primary-key? [entity-map] - (> (count (key-names entity-map)) 0)) - - -(defn has-non-key-properties? [entity-map] - (> - (count (vals (:properties (:content entity-map)))) - (count (key-names entity-map)))) + (if valid? adl + (throw (Exception. (str (validate-adl adl))))))) (defn children-with-tag @@ -186,6 +184,11 @@ [element tag] (children element #(= (:tag %) tag))) +(defmacro properties + "Return all the properties of this `entity`." + [entity] + `(children-with-tag ~entity :property)) + (defn descendants-with-tag "Return all descendants of this `element`, recursively, which have this `tag`." [element tag] @@ -199,8 +202,77 @@ (children element)))))) -(defn all-properties - "Return all properties of this entity (including key properties)." - [entity] - (descendants-with-tag entity :property)) +(defn insertable? + "Return `true` it the value of this `property` may be set from user-supplied data." + [property] + (and + (= (:tag property) :property) + (not (= (:distinct (:attrs property)) "system")))) +(defmacro all-properties + "Return all properties of this `entity` (including key properties)." + [entity] + `(descendants-with-tag ~entity :property)) + +(defmacro insertable-properties + "Return all the properties of this `entity` (including key properties) into + which user-supplied data can be inserted" + [entity] + `(filter + insertable? + (all-properties ~entity))) + +(defmacro key-properties + [entity] + `(children-with-tag (first (children-with-tag ~entity :key)) :property)) + +(defmacro insertable-key-properties + [entity] + `(filter insertable? (key-properties entity))) + + +(defn key-names [entity] + (remove + nil? + (map + #(:name (:attrs %)) + (key-properties entity)))) + + +(defn has-primary-key? [entity] + (> (count (key-names entity)) 0)) + + +(defn has-non-key-properties? [entity] + (> + (count (all-properties entity)) + (count (key-properties entity)))) + + +(defn distinct-properties + [entity] + (filter + #(#{"system" "all"} (:distinct (:attrs %))) + (properties entity))) + +(defn path-part + "Return the URL path part for this `form` of this `entity` within this `application`. + Note that `form` may be a Clojure XML representation of a `form`, `list` or `page` + ADL element, or may be one of the keywords `:form`, `:list`, `:page` in which case the + first child of the `entity` of the specified type will be used." + [form entity application] + (cond + (and (map? form) (#{:list :form :page} (:tag form))) + (s/join + "-" + (flatten + (list + (name (:tag form)) (:name (:attrs entity)) (s/split (:name (:attrs form)) #"[ \n\r\t]+")))) + (keyword? form) + (path-part (first (children-with-tag entity form)) entity application))) + +(defn editor-name + "Return the path-part of the editor form for this `entity`. Note: + assumes the editor form is the first form listed for the entity." + [entity application] + (path-part :form entity application)) diff --git a/test/adl/utils_test.clj b/test/adl/utils_test.clj new file mode 100644 index 0000000..cd9c083 --- /dev/null +++ b/test/adl/utils_test.clj @@ -0,0 +1,10 @@ +(ns adl.utils-test + (:require [clojure.string :as s] + [clojure.test :refer :all] + [adl.utils :refer :all])) + +(deftest singularise-tests + (testing "Singularise" + (is (= "address" (singularise "addresses"))) + (is (= "address" (singularise "address"))) + (is (= "expertise" (singularise "expertise"))))) From f4330aad6b8ece4222ce2d11dde3f3982628a9df Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 11 Jun 2018 01:06:16 +0100 Subject: [PATCH 16/52] Small fixes --- src/adl/to_hugsql_queries.clj | 49 ++++++++++++++++++++--------------- src/adl/to_selmer_routes.clj | 8 ++---- src/adl/utils.clj | 5 ++++ 3 files changed, 35 insertions(+), 27 deletions(-) diff --git a/src/adl/to_hugsql_queries.clj b/src/adl/to_hugsql_queries.clj index 4700ae8..ee44fe1 100644 --- a/src/adl/to_hugsql_queries.clj +++ b/src/adl/to_hugsql_queries.clj @@ -4,6 +4,7 @@ (:require [clojure.java.io :refer [file]] [clojure.math.combinatorics :refer [combinations]] [clojure.string :as s] + [clojure.xml :as x] [clj-time.core :as t] [clj-time.format :as f] [adl.utils :refer :all])) @@ -36,8 +37,6 @@ "The path to which generated files will be written." "resources/auto/") -(def electors {:tag :entity, :attrs {:magnitude "6", :name "electors", :table "electors"}, :content [{:tag :key, :attrs nil, :content [{:tag :property, :attrs {:distinct "system", :immutable "true", :column "id", :name "id", :type "integer", :required "true"}, :content [{:tag :prompt, :attrs {:locale "en-GB", :prompt "id"}, :content nil}]}]} {:tag :property, :attrs {:distinct "user", :column "name", :name "name", :type "string", :required "true", :size "64"}, :content [{:tag :prompt, :attrs {:locale "en-GB", :prompt "name"}, :content nil}]} {:tag :property, :attrs {:farkey "id", :entity "dwelling", :column "dwelling_id", :name "dwelling_id", :type "entity", :required "true"}, :content [{:tag :prompt, :attrs {:locale "en-GB", :prompt "Flat"}, :content nil}]} {:tag :property, :attrs {:distinct "user", :column "phone", :name "phone", :type "string", :size "16"}, :content [{:tag :prompt, :attrs {:locale "en-GB", :prompt "phone"}, :content nil}]} {:tag :property, :attrs {:distinct "user", :column "email", :name "email", :type "string", :size "128"}, :content [{:tag :prompt, :attrs {:locale "en-GB", :prompt "email"}, :content nil}]} {:tag :property, :attrs {:default "Unknown", :farkey "id", :entity "genders", :column "gender", :type "entity", :name "gender"}, :content [{:tag :prompt, :attrs {:locale "en-GB", :prompt "gender"}, :content nil}]} {:tag :list, :attrs {:name "Electors", :properties "listed"}, :content [{:tag :field, :attrs {:property "id"}, :content nil} {:tag :field, :attrs {:property "name"}, :content nil} {:tag :field, :attrs {:property "dwelling_id"}, :content nil} {:tag :field, :attrs {:property "phone"}, :content nil} {:tag :field, :attrs {:property "email"}, :content nil} {:tag :field, :attrs {:property "gender"}, :content nil}]} {:tag :form, :attrs {:name "Elector", :properties "listed"}, :content [{:tag :field, :attrs {:property "id"}, :content nil} {:tag :field, :attrs {:property "name"}, :content nil} {:tag :field, :attrs {:property "dwelling_id"}, :content nil} {:tag :field, :attrs {:property "phone"}, :content nil} {:tag :field, :attrs {:property "email"}, :content nil} {:tag :field, :attrs {:property "gender"}, :content nil}]}]}) - (defn where-clause "Generate an appropriate `where` clause for queries on this `entity`; if `properties` are passed, filter on those properties, otherwise the key @@ -140,7 +139,7 @@ pretty-name (singularise entity-name) query-name (str "search-strings-" pretty-name) signature ":? :1" - properties (all-properties entity)] + properties (remove #(#{"link"}(:type (:attrs %))) (all-properties entity))] (hash-map (keyword query-name) {:name query-name @@ -213,8 +212,6 @@ #(select-query entity %) (combinations distinct-fields (count distinct-fields)))))))) -(select-query electors) - (defn list-query "Generate a query to list records in the table represented by this `entity`. @@ -246,15 +243,14 @@ (defn foreign-queries - [entity application] (let [entity-name (:name (:attrs entity)) pretty-name (singularise entity-name) - links (filter #(-> % :attrs :entity) (children entity #(= (:tag %) :property)))] + links (filter #(#{"link" "entity"} (:type (:attrs %))) (children-with-tag entity :property))] (apply merge (map - #(let [far-name (-> % :attrs :entity) + #(let [far-name (:entity (:attrs %)) far-entity (first (children application @@ -264,6 +260,7 @@ (= (:name (:attrs x)) far-name))))) pretty-far (singularise far-name) farkey (-> % :attrs :farkey) + link-type (-> % :attrs :type) link-field (-> % :attrs :name) query-name (str "list-" entity-name "-by-" pretty-far) signature ":? :*"] @@ -279,15 +276,26 @@ "\n" (remove empty? - (list - (str "-- :name " query-name " " signature) - (str "-- :doc lists all existing " pretty-name " records related to a given " pretty-far) - (str "SELECT * \nFROM " entity-name) - (str "WHERE " entity-name "." link-field " = :id") - (order-by-clause entity))))})) + (case link-type + "entity" (list + (str "-- :name " query-name " " signature) + (str "-- :doc lists all existing " pretty-name " records related to a given " pretty-far) + (str "SELECT * \nFROM " entity-name) + (str "WHERE " entity-name "." link-field " = :id") + (order-by-clause entity)) + "link" (let [link-table-name + (link-table-name entity far-entity)] + (list + (str "-- :name " query-name " " signature) + (str "-- :doc links all existing " pretty-name " records related to a given " pretty-far) + (str "SELECT * \nFROM " entity-name) + (str "WHERE " entity-name "." link-field " = " link-table-name "." (singularise entity-name) "_id") + (str "\tAND " link-table-name "." (singularise far-name) "_id = :id") + (order-by-clause entity))) + (list (str "ERROR: unexpected type " link-type " of property " %))))) + })) links)))) - (defn link-table-query "Generate a query which links across the entity passed as `link` from the entity passed as `near` to the entity passed as `far`. @@ -328,8 +336,8 @@ (str "-- :doc lists all existing " near-name " records related through " link-name " to a given " pretty-far ) (str "SELECT "near-name ".*") (str "FROM " near-name ", " link-name ) - (str "WHERE " near-name "." (first (key-names near)) " = " link-name "." (-> (links (keyword near-name)) :attrs :name) ) - ("\tAND " link-name "." (-> (links (keyword far-name)) :attrs :name) " = :id") + (str "WHERE " near-name "." (first (key-names near)) " = " link-name "." (singularise near-name) "_id" ) + ("\tAND " link-name "." (singularise far-name) "_id = :id") (order-by-clause near))))})))) @@ -389,14 +397,13 @@ no entity is specified, generate all queris for the application." ([application entity] (merge - {} - (insert-query entity) - (update-query entity) - (delete-query entity) (if (link-table? entity) (link-table-queries entity application) {}) + (insert-query entity) + (update-query entity) + (delete-query entity) (select-query entity) (list-query entity) (search-query entity) diff --git a/src/adl/to_selmer_routes.clj b/src/adl/to_selmer_routes.clj index 551596c..deae446 100644 --- a/src/adl/to_selmer_routes.clj +++ b/src/adl/to_selmer_routes.clj @@ -44,7 +44,7 @@ (list 'ns (symbol (str (:name (:attrs application)) ".routes.auto")) - (str "JSON routes for " (pretty-name application) + (str "User interface routes for " (pretty-name application) " auto-generated by [Application Description Language framework](https://github.com/simon-brooke/adl) at " (f/unparse (f/formatters :basic-date-time) (t/now))) (list @@ -55,7 +55,7 @@ '[ring.util.http-response :as response] '[clojure.java.io :as io] '[hugsql.core :as hugsql] - (vector (symbol (str parent-name ".db.core")) :as 'db) + (vector (symbol (str (:name (:attrs application)) ".db.core")) :as 'db) (vector (symbol (str (:name (:attrs application)) ".routes.manual")) :as 'm)))) (defn make-handler @@ -173,7 +173,3 @@ (pprint (make-defroutes application)) (println))))) -(def x (x/parse "../youyesyet/youyesyet.canonical.adl.xml")) - -(to-selmer-routes x) - diff --git a/src/adl/utils.clj b/src/adl/utils.clj index f39d540..4856a77 100644 --- a/src/adl/utils.clj +++ b/src/adl/utils.clj @@ -27,6 +27,11 @@ ;;;; Copyright (C) 2018 Simon Brooke ;;;; +(defn link-table-name + "Canonical name of a link table between entity `e1` and entity `e2`." + [e1 e2] + (s/join "_" (list "link" (:name (:attrs e1)) (:name (:attrs e2))))) + (defn children "Return the children of this `element`; if `predicate` is passed, return only those From 1338b548463e041fd2d5e47a19a8febbdcde2347 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 11 Jun 2018 01:34:03 +0100 Subject: [PATCH 17/52] Added a main class, to allow command line invocation. --- RELEASENOTES.md | 8 ++++++ project.clj | 10 ++++--- src/adl/main.clj | 50 +++++++++++++++++++++++++++++++++ src/adl/to_hugsql_queries.clj | 4 --- src/adl/to_json_routes.clj | 3 +- src/adl/to_selmer_routes.clj | 5 ---- src/adl/to_selmer_templates.clj | 11 +------- src/adl/utils.clj | 11 ++++++++ 8 files changed, 78 insertions(+), 24 deletions(-) create mode 100644 src/adl/main.clj diff --git a/RELEASENOTES.md b/RELEASENOTES.md index 7adf8c0..2cb9c4c 100644 --- a/RELEASENOTES.md +++ b/RELEASENOTES.md @@ -1,3 +1,11 @@ +# Release 1.4.1 + +Release 1.4.1 adds a 'magnitude' element to entities, in order to provide a pragma for when +to switch to asynchronous select widgets. + +It also provides a family of transforms, written in Clojure, to generate a skeleton Clojure +web app from an ADL specification. + # Release 1.4 Release 1.4 adds an 'order' element as a possible child of the 'list' element, in order to specify diff --git a/project.clj b/project.clj index 945cda4..131722c 100644 --- a/project.clj +++ b/project.clj @@ -1,10 +1,12 @@ -(defproject adl "0.1.0-SNAPSHOT" - :description "FIXME: write description" +(defproject adl "1.4.1-SNAPSHOT" + :description "An application to transform an ADL application specification document into skeleton code for a Clojure web-app" :url "http://example.com/FIXME" - :license {:name "Eclipse Public License" - :url "http://www.eclipse.org/legal/epl-v10.html"} + :license {:name "GNU General Public License,version 2.0 or (at your option) any later version" + :url "https://www.gnu.org/licenses/old-licenses/gpl-2.0.en.html"} :dependencies [[org.clojure/clojure "1.8.0"] [org.clojure/math.combinatorics "0.1.4"] [bouncer "1.0.1"] [hiccup "1.0.5"]] + :aot [adl.main] + :main adl.main :plugins [[lein-codox "0.10.3"]]) diff --git a/src/adl/main.clj b/src/adl/main.clj new file mode 100644 index 0000000..d56e945 --- /dev/null +++ b/src/adl/main.clj @@ -0,0 +1,50 @@ +(ns ^{:doc "Application Description Language - command line invocation." + :author "Simon Brooke"} + adl.main + (:require [adl.utils :refer :all] + [adl.to-hugsql-queries :as h] + [adl.to-json-routes :as j] + [adl.to-selmer-routes :as s] + [adl.to-selmer-templates :as t] + [clojure.xml :as x]) + (:gen-class)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; adl.main +;;;; +;;;; 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 print-usage [_] + (println "Argument should be a pathname to an ADL file")) + +(defn -main + "Expects as arg the name of the git hook to be handled, followed by the arguments to it" + [& args] + (cond + (empty? args) + (print-usage args) + (.exists (java.io.File. (first args))) + (let [application (x/parse (first args))] + (h/to-hugsql-queries application) + ;; (j/to-json-routes application) + (s/to-selmer-routes application) + (t/to-selmer-templates application)))) + diff --git a/src/adl/to_hugsql_queries.clj b/src/adl/to_hugsql_queries.clj index ee44fe1..c9633d7 100644 --- a/src/adl/to_hugsql_queries.clj +++ b/src/adl/to_hugsql_queries.clj @@ -33,10 +33,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(def ^:dynamic *output-path* - "The path to which generated files will be written." - "resources/auto/") - (defn where-clause "Generate an appropriate `where` clause for queries on this `entity`; if `properties` are passed, filter on those properties, otherwise the key diff --git a/src/adl/to_json_routes.clj b/src/adl/to_json_routes.clj index 97e015c..a6daf18 100644 --- a/src/adl/to_json_routes.clj +++ b/src/adl/to_json_routes.clj @@ -4,7 +4,8 @@ (:require [clojure.java.io :refer [file]] [clojure.string :as s] [clj-time.core :as t] - [clj-time.format :as f])) + [clj-time.format :as f] + [adl.utils :refer :all])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; diff --git a/src/adl/to_selmer_routes.clj b/src/adl/to_selmer_routes.clj index deae446..f30c20e 100644 --- a/src/adl/to_selmer_routes.clj +++ b/src/adl/to_selmer_routes.clj @@ -34,11 +34,6 @@ ;;; Generally. there's one route in the generated file for each Selmer template which has been generated. -(def ^:dynamic *output-path* - "The path to which generated files will be written." - "resources/auto/") - - (defn file-header [application] (list diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj index d69f9f6..874204f 100644 --- a/src/adl/to_selmer_templates.clj +++ b/src/adl/to_selmer_templates.clj @@ -1,4 +1,4 @@ -(ns ^{;; :doc "Application Description Language - generate Selmer templates for the HTML pages implied by an ADL file." +(ns ^{:doc "Application Description Language - generate Selmer templates for the HTML pages implied by an ADL file." :author "Simon Brooke"} adl.to-selmer-templates (:require [adl.utils :refer :all] @@ -34,15 +34,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(def ^:dynamic *locale* - "The locale for which files will be generated." - "en-GB") - -(def ^:dynamic *output-path* - "The path to which generated files will be written." - "resources/auto/") - - (defn big-link [content url] {:tag :div diff --git a/src/adl/utils.clj b/src/adl/utils.clj index 4856a77..ebd6af8 100644 --- a/src/adl/utils.clj +++ b/src/adl/utils.clj @@ -26,6 +26,17 @@ ;;;; ;;;; Copyright (C) 2018 Simon Brooke ;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +(def ^:dynamic *locale* + "The locale for which files will be generated." + "en-GB") + +(def ^:dynamic *output-path* + "The path to which generated files will be written." + "resources/auto/") + (defn link-table-name "Canonical name of a link table between entity `e1` and entity `e2`." From 7c9f7f91b413da16b46e76621bd4063198f8c5cb Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 11 Jun 2018 10:13:44 +0100 Subject: [PATCH 18/52] Improvements to page/form/list generation --- src/adl/to_selmer_templates.clj | 133 +++++++++++++++++++++++++------- src/adl/utils.clj | 8 +- 2 files changed, 109 insertions(+), 32 deletions(-) diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj index 874204f..22b6c7d 100644 --- a/src/adl/to_selmer_templates.clj +++ b/src/adl/to_selmer_templates.clj @@ -12,7 +12,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; -;;;; adl.to-selmer-templates. +;;;; adl.to-selmer-templates. Generate Web 1.0 style user interface. ;;;; ;;;; This program is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU General Public License @@ -58,24 +58,64 @@ [content])}]}) +(defn emit-content + ([filename application k] + (emit-content filename nil nil application k)) + ([filename spec entity application k] + (let [content (:content + (first + (or (children-with-tag spec k) + (children-with-tag entity k) + (children-with-tag + (first + (children-with-tag application :content)) + k))))] + (if + content + (list + (str "{% block " (name k) " %}") + (map + #(with-out-str (x/emit-element %)) + content) + "{% endblock %}"))))) + + (defn file-header - "Generate a header for a template file." - [filename] - (str - "{% extends \"templates/base.html\" %}\n\n" - "\n\n" - "{% block content %}")) + "Generate a header for a template file with this `filename` for this `spec` + of this `entity` within this `application`." + ([filename application] + (file-header filename nil nil application)) + ([filename spec entity application] + (s/join + "\n" + (flatten + (list + "{% extends \"templates/base.html\" %}" + (str "") + (emit-content filename spec entity application :head) + (emit-content filename spec entity application :top) + "{% block content %}"))))) + (defn file-footer - "Generate a header for a template file." - [filename] - "{% endblock %}\n") + "Generate a footer for a template file with this `filename` for this `spec` + of this `entity` within this `application`." + ([filename application] + (file-footer filename nil nil application)) + ([filename spec entity application] + (s/join + "\n" + (flatten + (list + "{% endblock %}" + (emit-content filename spec entity application :foot) + ))))) (defn prompt @@ -347,7 +387,7 @@ :content (apply vector - + (concat (map (fn [f] (let [property (first @@ -359,18 +399,26 @@ :tag :th :content [{:tag :input - :type (case (:type (:attrs property)) + :attrs {:id (:property (:attrs f)) + :type (case (:type (:attrs property)) ("integer" "real" "money") "number" ("date" "timestamp") "date" "time" "time" "text") - :attrs {:id (:property (:attrs f)) :name (:property (:attrs f)) :value (str "{{ params." (:property (:attrs f)) " }}")}}]))) - (fields list-spec)))}]}) + (fields list-spec)) + '({:tag :th + :content + [{:tag :input + :attrs {:type "submit" + :id "search" + :value "Search"}}]})))}]}) (defn- list-tbody + "Return a table body element for the list view for this `list-spec` of this `entity` within + this `application`." [list-spec entity application] {:tag :tbody :content @@ -390,6 +438,7 @@ :attrs {:href (str + "{{servlet-context}}/" (editor-name entity application) "?" (s/join @@ -402,6 +451,35 @@ "{% endfor %}"]}) +(defn- list-page-control + "What this needs to do is emit an HTML control which, when selected, requests the + next or previous page keeping the same search parameters; so it essentially needs + to be a submit button, not a link." + [forward?] + {:tag :div + :attrs {:class (if forward? "big-link-container" "back-link-container")} + :content + [{:tag :input + :attrs {:id "page" + :name "page" + :disabled (if + forward? + false + "{% ifequal offset 0 %} false {% else %} true {% endifequal %}") + ;; TODO: real thought needs to happen on doing i18n for this! + :value (if forward? "Next" "Previous")}}]}) + + +(defn- list-tfoot + "Return a table footer element for the list view for this `list-spec` of this `entity` within + this `application`." + [list-spec entity application] + {:tag :tfoot + :content + [(list-page-control false) + (list-page-control true)]}) + + (defn- list-to-template "Generate a template as specified by this `list` element for this `entity`, taken from this `application`. If `list` is nill, generate a default list @@ -416,12 +494,7 @@ :content [(list-thead list-spec entity application) (list-tbody list-spec entity application) - {:tag :tfoot}]} - "{% if offset > 0 %}" - (back-link "Previous" "FIXME") - "{% endif %}" - (big-link "Next" "FIXME") - (big-link (str "Add a new " (pretty-name entity)) (editor-name entity application))]}) + (list-tfoot list-spec entity application)]}]}) (defn entity-to-templates @@ -498,7 +571,7 @@ (defn write-template-file - [filename template] + [filename template application] (if template (try @@ -507,10 +580,10 @@ (s/join "\n" (list - (file-header filename) + (file-header filename application) (with-out-str (x/emit-element template)) - (file-footer filename)))) + (file-footer filename application)))) (catch Exception any (spit (str *output-path* filename) @@ -542,7 +615,7 @@ (templates-map %) (let [filename (str (name %) ".html")] (try - (write-template-file filename (templates-map %)) + (write-template-file filename (templates-map %) application) (catch Exception any (str "Exception " diff --git a/src/adl/utils.clj b/src/adl/utils.clj index ebd6af8..3a60447 100644 --- a/src/adl/utils.clj +++ b/src/adl/utils.clj @@ -196,9 +196,12 @@ (defn children-with-tag - "Return all children of this `element` which have this `tag`." + "Return all children of this `element` which have this `tag`; + if `element` is `nil`, return `nil`." [element tag] - (children element #(= (:tag %) tag))) + (if + element + (children element #(= (:tag %) tag)))) (defmacro properties "Return all the properties of this `entity`." @@ -223,6 +226,7 @@ [property] (and (= (:tag property) :property) + (not (#{"link"} (:type (:attrs property)))) (not (= (:distinct (:attrs property)) "system")))) (defmacro all-properties From b69bcaa020c57ee00dd2f2a8b09aa02715cd79d4 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 11 Jun 2018 19:08:08 +0100 Subject: [PATCH 19/52] MY MONSTER IT LIVES! --- src/adl/main.clj | 2 +- src/adl/to_json_routes.clj | 112 +++++++++++++++++--------------- src/adl/to_selmer_routes.clj | 60 +++++++++++------ src/adl/to_selmer_templates.clj | 2 +- src/adl/utils.clj | 13 ++++ 5 files changed, 115 insertions(+), 74 deletions(-) diff --git a/src/adl/main.clj b/src/adl/main.clj index d56e945..31c2efe 100644 --- a/src/adl/main.clj +++ b/src/adl/main.clj @@ -44,7 +44,7 @@ (.exists (java.io.File. (first args))) (let [application (x/parse (first args))] (h/to-hugsql-queries application) - ;; (j/to-json-routes application) + (j/to-json-routes application) (s/to-selmer-routes application) (t/to-selmer-templates application)))) diff --git a/src/adl/to_json_routes.clj b/src/adl/to_json_routes.clj index a6daf18..e6e9346 100644 --- a/src/adl/to_json_routes.clj +++ b/src/adl/to_json_routes.clj @@ -1,11 +1,14 @@ (ns ^{:doc "Application Description Language: generate RING routes for REST requests." :author "Simon Brooke"} adl.to-json-routes - (:require [clojure.java.io :refer [file]] + (:require [clojure.java.io :refer [file make-parents writer]] + [clojure.pprint :refer [pprint]] [clojure.string :as s] + [clojure.xml :as x] [clj-time.core :as t] [clj-time.format :as f] - [adl.utils :refer :all])) + [adl.utils :refer :all] + [adl.to-hugsql-queries :refer [queries]])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; @@ -34,11 +37,12 @@ ;;; to-hugsql-queries, because essentially we need one JSON entry point to wrap ;;; each query. -(defn file-header [parent-name this-name] + +(defn file-header [application] (list 'ns - (symbol (str parent-name ".routes." this-name)) - (str "JSON routes for " parent-name + (symbol (str (safe-name (:name (:attrs application))) ".routes.auto-json")) + (str "JSON routes for " (:name (:attrs application)) " auto-generated by [Application Description Language framework](https://github.com/simon-brooke/adl) at " (f/unparse (f/formatters :basic-date-time) (t/now))) (list @@ -49,15 +53,11 @@ '[ring.util.http-response :as response] '[clojure.java.io :as io] '[hugsql.core :as hugsql] - (vector (symbol (str parent-name ".db.core")) :as 'db)))) - - -(defn make-safe-name [string] - (s/replace string #"[^a-zA-Z0-9-]" "")) + (vector (symbol (str (safe-name (:name (:attrs application))) ".db.core")) :as 'db)))) (defn declarations [handlers-map] - (cons 'declare (sort (map #(symbol (make-safe-name (name %))) (keys handlers-map))))) + (cons 'declare (sort (map #(symbol (name %)) (keys handlers-map))))) (defn generate-handler-src @@ -81,12 +81,12 @@ (defn handler - "Generate declarations for handlers from query with this `query-key` in this `queries-map` taken from within - this `entities-map`. This method must follow the structure of + "Generate declarations for handlers from query with this `query-key` in this `queries-map` + taken from within this `application`. This method must follow the structure of `to-hugsql-queries/queries` quite closely, because we must generate the same names." - [query-key queries-map entities-map] + [query-key queries-map application] (let [query (query-key queries-map) - handler-name (symbol (make-safe-name (name query-key)))] + handler-name (symbol (name query-key))] (hash-map (keyword handler-name) (merge @@ -182,6 +182,7 @@ (defn defroutes [handlers-map] + "Generate JSON routes for all queries implied by this ADL `application` spec." (cons 'defroutes (cons @@ -190,7 +191,7 @@ #(let [handler (handlers-map %)] (list (symbol (s/upper-case (name (:method handler)))) - (str "/json/auto/" (:name handler)) + (str "/json/auto/" (safe-name (:name handler))) 'request (list 'route/restricted @@ -199,39 +200,46 @@ (keys handlers-map)))))) -;; (defn migrations-to-json-routes -;; ([migrations-path parent-namespace-name] -;; (migrations-to-json-routes migrations-path parent-namespace-name "auto-json-routes")) -;; ([migrations-path parent-namespace-name namespace-name] -;; (let [output (str (s/replace namespace-name #"-" "_") ".clj") -;; adl-struct (migrations-to-xml migrations-path "Ignored") -;; q (reduce -;; merge -;; {} -;; (map -;; #(queries % adl-struct) -;; (vals adl-struct))) -;; h (reduce -;; merge -;; {} -;; (map -;; #(handler % q adl-struct) -;; (keys q))) -;; f (cons -;; (file-header parent-namespace-name namespace-name) -;; ;; (pre-declare -;; (cons -;; (declarations h) -;; (cons -;; (defroutes h) -;; (map #(:src (h %)) (sort (keys h))))))] -;; (spit -;; output -;; (with-out-str -;; (doall -;; (for [expr f] -;; (do -;; (pprint expr) -;; (print "\n\n")))))) -;; f -;; ))) +(defn make-handlers-map + [application] + (reduce + merge + {} + (map + (fn [e] + (let [qmap (queries application e)] + (reduce + merge + {} + (map + (fn [k] + (handler k qmap application)) + (keys qmap))))) + (children-with-tag application :entity)))) + + +(defn to-json-routes + [application] + (let [handlers-map (make-handlers-map application) + filepath (str *output-path* (:name (:attrs application)) "/routes/auto_json.clj")] + (make-parents filepath) + (with-open [output (writer filepath)] + (binding [*out* output] + (doall + (map + (fn [f] + (pprint f) + (println "\n")) + (list + (file-header application) + (declarations handlers-map) + (defroutes handlers-map)))) + (doall + (map + (fn [h] + (pprint (:src (handlers-map h))) + (println) + h) + (sort (keys handlers-map)))))))) + + diff --git a/src/adl/to_selmer_routes.clj b/src/adl/to_selmer_routes.clj index f30c20e..37e5a71 100644 --- a/src/adl/to_selmer_routes.clj +++ b/src/adl/to_selmer_routes.clj @@ -50,6 +50,7 @@ '[ring.util.http-response :as response] '[clojure.java.io :as io] '[hugsql.core :as hugsql] + (vector (symbol (str (:name (:attrs application)) ".layout")) :as 'l) (vector (symbol (str (:name (:attrs application)) ".db.core")) :as 'db) (vector (symbol (str (:name (:attrs application)) ".routes.manual")) :as 'm)))) @@ -62,7 +63,7 @@ (vector 'r) (list 'let (vector 'p (list :form-params 'r)) (list - 'layout/render + 'l/render (list 'resolve-template (str n ".html")) (merge {:title (capitalise (:name (:attrs f))) @@ -79,7 +80,7 @@ (list (symbol (str - "db/search-" + "db/search-strings-" (singularise (:name (:attrs e))))) 'p)}))))))) @@ -111,13 +112,38 @@ 'defroutes (cons 'auto-selmer-routes - (interleave - (map - (fn [r] (make-route 'GET r)) - (sort routes)) - (map - (fn [r] (make-route 'POST r)) - (sort routes))))))) + (cons + '(GET + "/index" + request + (route/restricted + (apply (resolve-handler "index") (list request)))) + (interleave + (map + (fn [r] (make-route 'GET r)) + (sort routes)) + (map + (fn [r] (make-route 'POST r)) + (sort routes)))))))) + + +(defn generate-handler-resolver + "Dodgy, dodgy, dodgy. Generate code which will look up functions in the + manual and in this namespace. I'm sure someone who really knew what they + were doing could write this more elegantly." + [application] + (list + 'defn + 'raw-resolve-handler + "Prefer the manually-written version of the handler with name `n`, if it exists, to the automatically generated one" + (vector 'n) + (list 'try + (list 'eval (list 'symbol (list 'str (:name (:attrs application)) ".routes.manual/" 'n))) + (list 'catch + 'Exception '_ + (list 'eval + (list 'symbol + (list 'str (:name (:attrs application)) ".routes.auto/" 'n))))))) (defn to-selmer-routes @@ -134,13 +160,13 @@ n (str "auto/" n)))) (println) - (pprint '(def resolve-template (memoise raw-resolve-template))) + (pprint '(def resolve-template (memoize raw-resolve-template))) (println) (pprint '(defn index [r] - (layout/render + (l/render (resolve-template - "application-index") + "application-index.html") {:title "Administrative menu"}))) (println) (doall @@ -153,14 +179,8 @@ (println)) (filter (fn [c] (#{:form :list :page} (:tag c))) (children e))))) (children-with-tag application :entity))) - (pprint '(defn raw-resolve-handler - "Prefer the manually-written version of the handler with name `n`, if it exists, to the automatically generated one" - [n] - (let [s (symbol (str "m." n))] - (if - (bound? s) - (eval s) - (eval (symbol n)))))) + (pprint + (generate-handler-resolver application)) (println) (pprint '(def resolve-handler (memoize raw-resolve-handler))) diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj index 22b6c7d..a1616e1 100644 --- a/src/adl/to_selmer_templates.clj +++ b/src/adl/to_selmer_templates.clj @@ -90,7 +90,7 @@ "\n" (flatten (list - "{% extends \"templates/base.html\" %}" + "{% extends \"base.html\" %}" (str " @@ -17,35 +17,35 @@ - + - + - @@ -56,7 +56,7 @@ Name_Link - the name of the foreign key is the same as the name of the table linked to, followed by '_Link' --> - + @@ -128,7 +128,7 @@ - + ------------------------------------------------------------------------------------------------- -- -- @@ -156,7 +156,7 @@ -- tables, views and permissions ------------------------------------------------------------------------------------------------- - + ------------------------------------------------------------------------------------------------- -- referential integrity constraints ------------------------------------------------------------------------------------------------- @@ -166,24 +166,24 @@ - + - + ------------------------------------------------------------------------------------------------- -- end of file ------------------------------------------------------------------------------------------------- - + /* */ - + ------------------------------------------------------------------------------------------------- -- security group @@ -191,12 +191,12 @@ CREATE GROUP ; - - + + - ALTER TABLE ADD CONSTRAINT ri_ + ALTER TABLE ADD CONSTRAINT ri_ FOREIGN KEY ( ) REFERENCES ON DELETE NO ACTION; @@ -204,20 +204,20 @@ - ALTER TABLE ln__ - ADD CONSTRAINT ri____id + ALTER TABLE ln__ + ADD CONSTRAINT ri____id FOREIGN KEY ( _id) REFERENCES ON DELETE CASCADE; - ALTER TABLE ln__ - ADD CONSTRAINT ri____id + ALTER TABLE ln__ + ADD CONSTRAINT ri____id FOREIGN KEY ( _id) REFERENCES ON DELETE CASCADE; - + - - + + - + ------------------------------------------------------------------------------------------------- -- primary table ------------------------------------------------------------------------------------------------- @@ -231,7 +231,7 @@ ); - + ---- permissions ------------------------------------------------------------------------------ @@ -266,7 +266,7 @@ WHERE AND - .. = ._id ; @@ -276,7 +276,7 @@ - + @@ -290,74 +290,74 @@ - + - + - - - + Template distinctfield entered, table is . + + Entity detected. - . | ' ' | + . | ', ' | - + - - + - GRANT SELECT ON GRANT SELECT ON TO GROUP ; - GRANT INSERT ON GRANT INSERT ON TO GROUP ; - GRANT SELECT, INSERT ON GRANT SELECT, INSERT ON TO GROUP ; - GRANT SELECT, INSERT, UPDATE ON GRANT SELECT, INSERT, UPDATE ON TO GROUP ; - GRANT SELECT, INSERT, UPDATE, DELETE ON GRANT SELECT, INSERT, UPDATE, DELETE ON TO GROUP ; - REVOKE ALL ON REVOKE ALL ON FROM GROUP ; - + - + - REVOKE ALL ON lv_REVOKE ALL ON lv_ FROM GROUP ; - REVOKE ALL ON lv_REVOKE ALL ON lv_ FROM GROUP ; - GRANT SELECT ON lv_GRANT SELECT ON lv_ TO GROUP ; - + - - + + @@ -369,7 +369,7 @@ - + ------------------------------------------------------------------------------------------------- -- link table joining with ------------------------------------------------------------------------------------------------- @@ -379,15 +379,15 @@ _id INT NOT NULL, ); - + - + - + - INT DEFAULT INT DEFAULT NOT NULL @@ -395,46 +395,46 @@ - VARCHAR( VARCHAR( ) INT DOUBLE PRECISION - DEFAULT NOT NULL PRIMARY KEY NOT NULL - + - VARCHAR( ) VARCHAR( ) DEFAULT NOT NULL PRIMARY KEY NOT NULL - + - INT INT DEFAULT NOT NULL PRIMARY KEY NOT NULL - + - DOUBLE PRECISION DEFAULT DOUBLE PRECISION DEFAULT NOT NULL - + - DEFAULT NOT NULL PRIMARY KEY NOT NULL - + diff --git a/src/adl/to_hugsql_queries.clj b/src/adl/to_hugsql_queries.clj index c9633d7..be644f9 100644 --- a/src/adl/to_hugsql_queries.clj +++ b/src/adl/to_hugsql_queries.clj @@ -284,8 +284,10 @@ (list (str "-- :name " query-name " " signature) (str "-- :doc links all existing " pretty-name " records related to a given " pretty-far) - (str "SELECT * \nFROM " entity-name) - (str "WHERE " entity-name "." link-field " = " link-table-name "." (singularise entity-name) "_id") + (str "SELECT * \nFROM " entity-name ", " link-table-name) + (str "WHERE " entity-name "." + (first (key-names entity)) + " = " link-table-name "." (singularise entity-name) "_id") (str "\tAND " link-table-name "." (singularise far-name) "_id = :id") (order-by-clause entity))) (list (str "ERROR: unexpected type " link-type " of property " %))))) diff --git a/src/adl/to_psql.clj b/src/adl/to_psql.clj new file mode 100644 index 0000000..1a9472e --- /dev/null +++ b/src/adl/to_psql.clj @@ -0,0 +1,400 @@ +(ns ^{:doc "Application Description Language: generate Postgres database definition." + :author "Simon Brooke"} + adl.to-psql + (:require [clojure.java.io :refer [file make-parents writer]] + [clojure.pprint :refer [pprint]] + [clojure.string :as s] + [clojure.xml :as x] + [clj-time.core :as t] + [clj-time.format :as f] + [adl.utils :refer :all] + [adl.to-hugsql-queries :refer [queries]])) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; adl.to-psql: generate Postgres database definition. +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU General Public License +;;;; as published by the Free Software Foundation; either version 2 +;;;; of the License, or (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;;; USA. +;;;; +;;;; Copyright (C) 2018 Simon Brooke +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +;;; this is a pretty straight translation of adl2psql.xslt, and was written because +;;; Clojure is easier to debug + +(declare emit-field-type emit-property) + +(def comment-rule (apply str (repeat 79 "-"))) + +(defn emit-defined-field-type + [property application] + (let [typedef (typedef property application)] + ;; this is a hack based on the fact that emit-field-type doesn't check + ;; that the argument passed as `property` is indeed a property. + (emit-field-type typedef nil application false))) + +(defn emit-entity-field-type + [property application] + (let [farside (child + application + #(and + (entity? %) + (= (:name (:attrs %)) (:entity (:attrs property))))) + key-properties (children-with-tag + (first (children-with-tag farside :key)) + :property)] + (if + (> (count key-properties) 1) + (str + "-- ERROR: cannot generate link to entity " + (:name (:attrs farside)) + " with compound primary key\n") + (list + (emit-field-type (first key-properties) farside application false) + "REFERENCES" + (str + (:table (:attrs farside)) "(" (:name (:attrs (first key-properties))) ) ")" + ;; TODO: ought to handle the `cascade` attribute, even though it's rarely used + )))) + + +(defn emit-field-type + [property entity application key?] + (case (:type (:attrs property)) + "integer" (if key? "serial" "INTEGER") + "real" "DOUBLE PRECISION" + ("string" "image" "uploadable") (str "VARCHAR(" (:size (:attrs property)) ")") + "defined" (emit-defined-field-type property application) + "entity" (emit-entity-field-type property application) + ("date" "time" "timestamp" "boolean" "text" "money") (.toUpperCase (:type (:attrs property))) + (str "-- ERROR: unknown type " (:type (:attrs property))) + )) + + +(defn emit-link-field + [property entity application] + (emit-property + {:tag :property + :attrs {:name (str (:name (:attrs entity)) "_id") + :type "entity" + :entity (:name (:attrs entity)) + :cascade (:cascade (:attrs property))}} + entity + application)) + + +(defn emit-permissions-grant + [table-name privilege permissions] + (let [selector + (case privilege + :SELECT #{"read" "noedit" "edit" "all"} + :INSERT #{"insert" "noedit" "edit" "all"} + :UPDATE #{"edit" "all"} + (:DELETE :ALL) #{"all"}) + group-names + (set + (remove + nil? + (map + #(if (selector (:permission (:attrs %))) + (:name (:attrs %))) + permissions)))] + (if + (not (empty? group-names)) + (s/join " " (list "GRANT" (name privilege) "ON" table-name "TO" (s/join "," group-names) ";"))))) + + +(defn emit-link-table + [property e1 application emitted-link-tables] + (let [e2 (child + application + #(and + (entity? %) + (= (:name (:attrs %)) (:entity (:attrs property))))) + link-table-name (link-table-name e1 e2) + permissions (flatten + (list + (children-with-tag e1 :permission) + (children-with-tag e1 :permission)))] + (if + true ;;(not (@emitted-link-tables link-table-name)) + (do + ;; (swap! emitted-link-tables (conj @emitted-link-tables link-table-name)) + (s/join + "\n" + (list + comment-rule + (str "--\tlink table joining " (:name (:attrs e1)) " with " (:name (:attrs e2))) + comment-rule + (s/join " " (list "CREATE TABLE" link-table-name)) + "(" + (emit-link-field property e1 application) + (emit-link-field property e2 application) + ");" + (emit-permissions-grant link-table-name :SELECT permissions) + (emit-permissions-grant link-table-name :INSERT permissions))))))) + + +(defn emit-link-tables + [entity application emitted-link-tables] + (map + #(emit-link-table % entity application emitted-link-tables) + (children entity #(and (= (:tag %) :property) (= (:type (:attrs %)) "link"))))) + + +(defn emit-property + ([property entity application] + (emit-property property entity application false)) + ([property entity application key?] + (let [default (:default (:attrs property))] + (if + (and + (= (:tag property) :property) + (not (#{"link"} (:type (:attrs property))))) + (s/join + " " + (flatten + (list + "\t" + (:name (:attrs property)) + (emit-field-type property entity application key?) + (if default (list "DEFAULT" default)) + (if + key? + "NOT NULL PRIMARY KEY" + (if (= (:required (:attrs property)) "true") "NOT NULL"))))))))) + + +(defn compose-convenience-entity-field + ;; TODO: this is not recursing properly + [field entity application] + (let [farside (child + application + #(and + (entity? %) + (= (:name (:attrs %)) (:entity (:attrs field)))))] + (flatten + (map + (fn [f] + (if + (= (:type (:attrs f)) "entity") + (compose-convenience-entity-field f farside application) + (str (:table (:attrs farside)) "." (:name (:attrs f))))) + (user-distinct-properties farside))))) + + +(defn compose-convenience-view-select-list + [entity application top-level?] + (remove + nil? + (flatten + (cons + (:name (:attrs entity)) + (map + (fn [f] + (if + (= (:type (:attrs f)) "entity") + (compose-convenience-view-select-list + (child application #(and (entity? %) (= (:name (:attrs %))(:entity (:attrs f))))) + application + false))) + (if + top-level? + (all-properties entity) + (user-distinct-properties entity))))))) + + +(defn compose-convenience-where-clause + [entity application top-level?] + (remove + nil? + (flatten + (map + (fn [f] + (if + (= (:type (:attrs f)) "entity") + (let [farside (entity-for-property f application)] + (cons + (str + (:table (:attrs entity)) + "." + (:name (:attrs f)) + " = " + (:table (:attrs farside)) + "." + (first (key-names farside))) + #(compose-convenience-where-clause farside application false))))) + (if + top-level? + (all-properties entity) + (user-distinct-properties entity)))))) + + + +(defn emit-convenience-entity-field + [field entity application] + (str + (s/join + " |', '| " + (compose-convenience-entity-field field entity application)) + " AS " + (:name (:attrs field)))) + + +(defn emit-convenience-view + "Emit a convenience view of this `entity` of this `application` for use in generating lists, + menus, et cetera." + [entity application] + (let [view-name (str "lv_" (:table (:attrs entity))) + entity-fields (filter + #(= (:type (:attrs %)) "entity") + (properties entity))] + (s/join + "\n" + (remove + nil? + (flatten + (list + comment-rule + (str "--\tconvenience view " view-name " of entity " (:name (:attrs entity)) " for lists, et cetera") + comment-rule + (s/join + " " + (list "CREATE VIEW" view-name "AS")) + (str + "SELECT " + (s/join + ",\n\t" + (map + #(if + (= (:type (:attrs %)) "entity") + (emit-convenience-entity-field % entity application) + (:name (:attrs %))) + (filter + #(and (= (:tag %) :property) (not (= (:type (:attrs %)) "link"))) + (all-properties entity) )))) + (str + "FROM " (s/join ", " (compose-convenience-view-select-list entity application true))) + (if + (not (empty? entity-fields)) + (str + "WHERE " + (s/join + "\n\tAND " + (map + (fn [f] + (let + [farside (child + application + #(and + (entity? %) + (= (:name (:attrs %)) (:entity (:attrs f)))))] + (str + (:table (:attrs entity)) + "." + (:name (:attrs f)) + " = " + (:table (:attrs farside)) + "." + (first (key-names farside))))) + entity-fields)))) + ";" + (emit-permissions-grant view-name :SELECT (permissions entity application)))))))) + + +(defn emit-table + [entity application emitted-link-tables] + (let [table-name (:table (:attrs entity)) + permissions (children-with-tag entity :permission)] + (s/join + "\n" + (flatten + (list + comment-rule + (str "--\tprimary table " table-name " for entity " (:name (:attrs entity))) + comment-rule + (s/join + " " + (list "CREATE TABLE " table-name)) + "(" + (map + #(emit-property % entity application true) + (children-with-tag (child-with-tag entity :key) :property)) + (map + #(emit-property % entity application false) + (children-with-tag entity :property)) + ");" + (map + #(emit-permissions-grant table-name % permissions) + '(:SELECT :INSERT :UPDATE :DELETE))))))) + + +(defn emit-entity + [entity application emitted-link-tables] + (emit-table entity application emitted-link-tables) + (emit-convenience-view entity application)) + + +(defn emit-group-declaration + [group application] + (s/join + "\n" + (list + comment-rule + (str "--\tsecurity group " (:name (:attrs group))) + comment-rule + (str "CREATE GROUP IF NOT EXISTS " (:name (:attrs group)))))) + + +(defn emit-file-header + [application] + (s/join + "\n" + (list + comment-rule + (str + "--\tDatabase definition for application " + (:name (:attrs application)) + " version " + (:version (:attrs application))) + (str + "--\tauto-generated by [Application Description Language framework](https://github.com/simon-brooke/adl) at " + (f/unparse (f/formatters :basic-date-time) (t/now))) + comment-rule))) + + +(defn emit-application + [application] + (let [emitted-link-tables (atom #{})] + (s/join + "\n\n" + (flatten + (list + (emit-file-header application) + (map #(emit-group-declaration % application) (children-with-tag application :group)) + (map #(emit-entity % application emitted-link-tables) (children-with-tag application :entity)) + (map #(emit-link-tables % application emitted-link-tables) (children-with-tag application :entity))))))) + + +(defn to-psql + [application] + (let [filepath (str *output-path* "/resources/sql/" (:name (:attrs application)) ".postgres.sql")] + (make-parents filepath) + (spit filepath (emit-application application)))) + + diff --git a/src/adl/utils.clj b/src/adl/utils.clj index b4362c2..5f51ae2 100644 --- a/src/adl/utils.clj +++ b/src/adl/utils.clj @@ -41,7 +41,13 @@ (defn link-table-name "Canonical name of a link table between entity `e1` and entity `e2`." [e1 e2] - (s/join "_" (list "link" (:name (:attrs e1)) (:name (:attrs e2))))) + (s/join + "_" + (cons + "ln" + (sort + (list + (:name (:attrs e1)) (:name (:attrs e2))))))) (defn children @@ -57,6 +63,12 @@ (children element)))) +(defn child + "Return the first child of this `element` satisfying this `predicate`." + [element predicate] + (first (children element predicate))) + + (defn attributes "Return the attributes of this `element`; if `predicate` is passed, return only those attributes satisfying the predicate." @@ -87,7 +99,7 @@ (defn permissions "Return appropriate permissions of this `property`, taken from this `entity` of this `application`, in the context of this `page`." - [property page entity application] + ([property page entity application] (first (remove empty? @@ -96,6 +108,10 @@ (children property #(= (:tag %) :permission)) (children entity #(= (:tag %) :permission)) (children application #(= (:tag %) :permission)))))) + ([property entity application] + (permissions property nil entity application)) + ([entity application] + (permissions nil nil entity application))) (defn permission-groups @@ -135,6 +151,24 @@ (= (:tag x) :entity)) +(defn property? + "True if `o` is a property." + [o] + (= (:tag o) :property)) + + +(defn entity-for-property + "If this `property` references an entity, return that entity from this `application`" + [property application] + (if + (and (property? property) (:entity (:attrs property))) + (child + application + #(and + (entity? %) + (= (:name (:attrs %))(:entity (:attrs property))))))) + + (defn visible-to "Return a list of names of groups to which are granted read access, given these `permissions`, else nil." @@ -216,6 +250,12 @@ element (children element #(= (:tag %) tag)))) +(defn child-with-tag + "Return the first child of this `element` which has this `tag`; + if `element` is `nil`, return `nil`." + [element tag] + (first (children-with-tag element tag))) + (defmacro properties "Return all the properties of this `entity`." [entity] @@ -242,11 +282,19 @@ (not (#{"link"} (:type (:attrs property)))) (not (= (:distinct (:attrs property)) "system")))) + (defmacro all-properties "Return all properties of this `entity` (including key properties)." [entity] `(descendants-with-tag ~entity :property)) + +(defn user-distinct-properties + "Return the properties of this `entity` which are user distinct" + [entity] + (filter #(#{"user" "all"} (:distinct (:attrs %))) (all-properties entity))) + + (defmacro insertable-properties "Return all the properties of this `entity` (including key properties) into which user-supplied data can be inserted" @@ -309,3 +357,16 @@ assumes the editor form is the first form listed for the entity." [entity application] (path-part :form entity application)) + +(defn typedef + [property application] + (first + (children application + #(and + (= (:tag %) :typedef) + (= (:name (:attrs %)) + (:definition (:attrs property))))))) + +(defn type-for-defined + [property application] + (:type (:attrs (typedef property application)))) From 66ab4a2bc187364c5fa9ad40c76b5a327e37d39f Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 14 Jun 2018 00:25:11 +0100 Subject: [PATCH 21/52] Postgres generation is now very close to good. --- src/adl/main.clj | 6 +- src/adl/to_psql.clj | 534 +++++++++++++++++++++++++------------------- src/adl/utils.clj | 20 +- 3 files changed, 319 insertions(+), 241 deletions(-) diff --git a/src/adl/main.clj b/src/adl/main.clj index 31c2efe..ea955b1 100644 --- a/src/adl/main.clj +++ b/src/adl/main.clj @@ -4,6 +4,7 @@ (:require [adl.utils :refer :all] [adl.to-hugsql-queries :as h] [adl.to-json-routes :as j] + [adl.to-psql :as p] [adl.to-selmer-routes :as s] [adl.to-selmer-templates :as t] [clojure.xml :as x]) @@ -36,7 +37,7 @@ (println "Argument should be a pathname to an ADL file")) (defn -main - "Expects as arg the name of the git hook to be handled, followed by the arguments to it" + "Expects as arg the path-name of an ADL file." [& args] (cond (empty? args) @@ -45,6 +46,9 @@ (let [application (x/parse (first args))] (h/to-hugsql-queries application) (j/to-json-routes application) + (p/to-psql application) (s/to-selmer-routes application) (t/to-selmer-templates application)))) + + diff --git a/src/adl/to_psql.clj b/src/adl/to_psql.clj index 1a9472e..eba8b22 100644 --- a/src/adl/to_psql.clj +++ b/src/adl/to_psql.clj @@ -35,7 +35,16 @@ ;;; this is a pretty straight translation of adl2psql.xslt, and was written because -;;; Clojure is easier to debug +;;; Clojure is easier to debug. + +;;; TODO: the order in which we generate tables is critical, because tables +;;; can only reference other tables which already exist. We could get around +;;; this by generating referential integrity constraints post-hoc, which is +;;; what the xslt version did. + +(defn sort-by-name + [elements] + (sort #(.compareTo (:name (:attrs %1)) (:name (:attrs %2))) elements)) (declare emit-field-type emit-property) @@ -46,42 +55,86 @@ (let [typedef (typedef property application)] ;; this is a hack based on the fact that emit-field-type doesn't check ;; that the argument passed as `property` is indeed a property. - (emit-field-type typedef nil application false))) + (str (emit-field-type typedef nil application false) + (cond + (:pattern (:attrs typedef)) + (str + " CONSTRAINT " + (gensym "c-") + " CHECK (" + (:name (:attrs property)) + " ~* '" + (:pattern (:attrs typedef)) + "')") + (and (:maximum (:attrs typedef))(:minimum (:attrs typedef))) + ;; TODO: if base type is date, time or timestamp, values should be quoted. + (str + " CONSTRAINT " + (gensym "c-") + " CHECK (" + (:minimum (:attrs typedef)) + " < " + (:name (:attrs property)) + " AND " + (:name (:attrs property)) + " < " + (:maximum (:attrs typedef)) + ")") + (:maximum (:attrs typedef)) + (str + " CONSTRAINT " + (gensym "c-") + " CHECK (" + (:name (:attrs property)) + " < " + (:maximum (:attrs typedef)) + ")") + (:minimum (:attrs typedef)) + (str + " CONSTRAINT " + (gensym "c-") + " CHECK (" + (:minimum (:attrs typedef)) + " < " + (:name (:attrs property))))))) + (defn emit-entity-field-type [property application] (let [farside (child - application - #(and - (entity? %) - (= (:name (:attrs %)) (:entity (:attrs property))))) + application + #(and + (entity? %) + (= (:name (:attrs %)) (:entity (:attrs property))))) key-properties (children-with-tag - (first (children-with-tag farside :key)) - :property)] + (first (children-with-tag farside :key)) + :property)] (if (> (count key-properties) 1) (str - "-- ERROR: cannot generate link to entity " - (:name (:attrs farside)) - " with compound primary key\n") + "-- ERROR: cannot generate link to entity " + (:name (:attrs farside)) + " with compound primary key\n") (list - (emit-field-type (first key-properties) farside application false) - "REFERENCES" - (str - (:table (:attrs farside)) "(" (:name (:attrs (first key-properties))) ) ")" - ;; TODO: ought to handle the `cascade` attribute, even though it's rarely used - )))) + (emit-field-type (first key-properties) farside application false) + "REFERENCES" + (str + (:table (:attrs farside)) "(" (:name (:attrs (first key-properties)))) ")" + ;; TODO: ought to handle the `cascade` attribute, even though it's rarely used + )))) (defn emit-field-type [property entity application key?] (case (:type (:attrs property)) - "integer" (if key? "serial" "INTEGER") + "integer" (if key? "SERIAL" "INTEGER") "real" "DOUBLE PRECISION" - ("string" "image" "uploadable") (str "VARCHAR(" (:size (:attrs property)) ")") + ("string" "image" "uploadable") + (str "VARCHAR(" (:size (:attrs property)) ")") "defined" (emit-defined-field-type property application) "entity" (emit-entity-field-type property application) - ("date" "time" "timestamp" "boolean" "text" "money") (.toUpperCase (:type (:attrs property))) + ("date" "time" "timestamp" "boolean" "text" "money") + (.toUpperCase (:type (:attrs property))) (str "-- ERROR: unknown type " (:type (:attrs property))) )) @@ -89,13 +142,13 @@ (defn emit-link-field [property entity application] (emit-property - {:tag :property - :attrs {:name (str (:name (:attrs entity)) "_id") - :type "entity" - :entity (:name (:attrs entity)) - :cascade (:cascade (:attrs property))}} - entity - application)) + {:tag :property + :attrs {:name (str (:name (:attrs entity)) "_id") + :type "entity" + :entity (:name (:attrs entity)) + :cascade (:cascade (:attrs property))}} + entity + application)) (defn emit-permissions-grant @@ -108,53 +161,56 @@ (:DELETE :ALL) #{"all"}) group-names (set - (remove - nil? - (map - #(if (selector (:permission (:attrs %))) - (:name (:attrs %))) - permissions)))] + (remove + nil? + (map + #(if (selector (:permission (:attrs %))) + (:group (:attrs %))) + permissions)))] (if (not (empty? group-names)) - (s/join " " (list "GRANT" (name privilege) "ON" table-name "TO" (s/join "," group-names) ";"))))) + (s/join " " (list "GRANT" (name privilege) "ON" table-name "TO" (s/join ",\n\t" (sort group-names)) ";"))))) (defn emit-link-table [property e1 application emitted-link-tables] (let [e2 (child - application - #(and - (entity? %) - (= (:name (:attrs %)) (:entity (:attrs property))))) + application + #(and + (entity? %) + (= (:name (:attrs %)) (:entity (:attrs property))))) link-table-name (link-table-name e1 e2) permissions (flatten - (list - (children-with-tag e1 :permission) - (children-with-tag e1 :permission)))] + (list + (children-with-tag e1 :permission) + (children-with-tag e1 :permission)))] (if - true ;;(not (@emitted-link-tables link-table-name)) + (not (@emitted-link-tables link-table-name)) (do - ;; (swap! emitted-link-tables (conj @emitted-link-tables link-table-name)) + (swap! emitted-link-tables conj link-table-name) (s/join - "\n" - (list - comment-rule - (str "--\tlink table joining " (:name (:attrs e1)) " with " (:name (:attrs e2))) - comment-rule - (s/join " " (list "CREATE TABLE" link-table-name)) - "(" - (emit-link-field property e1 application) - (emit-link-field property e2 application) - ");" - (emit-permissions-grant link-table-name :SELECT permissions) - (emit-permissions-grant link-table-name :INSERT permissions))))))) + "\n" + (list + comment-rule + (str "--\tlink table joining " (:name (:attrs e1)) " with " (:name (:attrs e2))) + comment-rule + (s/join " " (list "CREATE TABLE IF NOT EXISTS" link-table-name)) + "(" + (emit-link-field property e1 application) + (emit-link-field property e2 application) + ");" + (emit-permissions-grant link-table-name :SELECT permissions) + (emit-permissions-grant link-table-name :INSERT permissions))))))) (defn emit-link-tables [entity application emitted-link-tables] (map - #(emit-link-table % entity application emitted-link-tables) - (children entity #(and (= (:tag %) :property) (= (:type (:attrs %)) "link"))))) + #(emit-link-table % entity application emitted-link-tables) + (sort-by-name + (filter + #(= (:type (:attrs %)) "link") + (properties entity))))) (defn emit-property @@ -164,96 +220,98 @@ (let [default (:default (:attrs property))] (if (and - (= (:tag property) :property) - (not (#{"link"} (:type (:attrs property))))) + (= (:tag property) :property) + (not (#{"link"} (:type (:attrs property))))) (s/join - " " + " " + (remove + nil? (flatten - (list - "\t" - (:name (:attrs property)) - (emit-field-type property entity application key?) - (if default (list "DEFAULT" default)) - (if - key? - "NOT NULL PRIMARY KEY" - (if (= (:required (:attrs property)) "true") "NOT NULL"))))))))) + (list + "\t" + (:name (:attrs property)) + (emit-field-type property entity application key?) + (if default (list "DEFAULT" default)) + (if + key? + "NOT NULL PRIMARY KEY" + (if (= (:required (:attrs property)) "true") "NOT NULL")))))))))) (defn compose-convenience-entity-field - ;; TODO: this is not recursing properly [field entity application] (let [farside (child - application - #(and - (entity? %) - (= (:name (:attrs %)) (:entity (:attrs field)))))] + application + #(and + (entity? %) + (= (:name (:attrs %)) (:entity (:attrs field)))))] (flatten - (map - (fn [f] - (if - (= (:type (:attrs f)) "entity") - (compose-convenience-entity-field f farside application) - (str (:table (:attrs farside)) "." (:name (:attrs f))))) - (user-distinct-properties farside))))) + (map + (fn [f] + (if + (= (:type (:attrs f)) "entity") + (compose-convenience-entity-field f farside application) + (str (:table (:attrs farside)) "." (:name (:attrs f))))) + (user-distinct-properties farside))))) (defn compose-convenience-view-select-list [entity application top-level?] (remove - nil? - (flatten - (cons - (:name (:attrs entity)) - (map - (fn [f] - (if - (= (:type (:attrs f)) "entity") - (compose-convenience-view-select-list - (child application #(and (entity? %) (= (:name (:attrs %))(:entity (:attrs f))))) - application - false))) - (if - top-level? - (all-properties entity) - (user-distinct-properties entity))))))) + nil? + (flatten + (cons + (:name (:attrs entity)) + (map + (fn [f] + (if + (= (:type (:attrs f)) "entity") + (compose-convenience-view-select-list + (child application #(and (entity? %) (= (:name (:attrs %))(:entity (:attrs f))))) + application + false))) + (if + top-level? + (all-properties entity) + (user-distinct-properties entity))))))) (defn compose-convenience-where-clause + ;; TODO: does not correctly compose links at one stage down the tree. + ;; See lv_electors, lv_followuprequests for examples of the problem. [entity application top-level?] (remove - nil? - (flatten - (map - (fn [f] - (if - (= (:type (:attrs f)) "entity") - (let [farside (entity-for-property f application)] - (cons - (str - (:table (:attrs entity)) - "." - (:name (:attrs f)) - " = " - (:table (:attrs farside)) - "." - (first (key-names farside))) - #(compose-convenience-where-clause farside application false))))) - (if - top-level? - (all-properties entity) - (user-distinct-properties entity)))))) - + nil? + (flatten + (map + (fn [f] + (if + (= (:type (:attrs f)) "entity") + (let [farside (entity-for-property f application)] + (cons + (str + (:table (:attrs entity)) + "." + (:name (:attrs f)) + " = " + (:table (:attrs farside)) + "." + (first (key-names farside))) + #(compose-convenience-where-clause farside application false))))) + (if + top-level? + (all-properties entity) + (user-distinct-properties entity)))))) (defn emit-convenience-entity-field [field entity application] (str - (s/join - " |', '| " - (compose-convenience-entity-field field entity application)) - " AS " - (:name (:attrs field)))) + (s/join + " |', '| " + (compose-convenience-entity-field field entity application)) + " AS " + (:name (:attrs field)))) (defn emit-convenience-view @@ -262,138 +320,162 @@ [entity application] (let [view-name (str "lv_" (:table (:attrs entity))) entity-fields (filter - #(= (:type (:attrs %)) "entity") - (properties entity))] + #(= (:type (:attrs %)) "entity") + (properties entity))] (s/join - "\n" - (remove - nil? - (flatten - (list - comment-rule - (str "--\tconvenience view " view-name " of entity " (:name (:attrs entity)) " for lists, et cetera") - comment-rule - (s/join - " " - (list "CREATE VIEW" view-name "AS")) - (str - "SELECT " - (s/join - ",\n\t" - (map - #(if - (= (:type (:attrs %)) "entity") - (emit-convenience-entity-field % entity application) - (:name (:attrs %))) - (filter - #(and (= (:tag %) :property) (not (= (:type (:attrs %)) "link"))) - (all-properties entity) )))) - (str - "FROM " (s/join ", " (compose-convenience-view-select-list entity application true))) - (if - (not (empty? entity-fields)) - (str - "WHERE " - (s/join - "\n\tAND " - (map - (fn [f] - (let - [farside (child - application - #(and - (entity? %) - (= (:name (:attrs %)) (:entity (:attrs f)))))] - (str - (:table (:attrs entity)) - "." - (:name (:attrs f)) - " = " - (:table (:attrs farside)) - "." - (first (key-names farside))))) - entity-fields)))) - ";" - (emit-permissions-grant view-name :SELECT (permissions entity application)))))))) + "\n" + (remove + nil? + (flatten + (list + comment-rule + (str "--\tconvenience view " view-name " of entity " (:name (:attrs entity)) " for lists, et cetera") + comment-rule + (s/join + " " + (list "CREATE VIEW" view-name "AS")) + (str + "SELECT " + (s/join + ",\n\t" + (map + #(if + (= (:type (:attrs %)) "entity") + (emit-convenience-entity-field % entity application) + (:name (:attrs %))) + (filter + #(and (= (:tag %) :property) (not (= (:type (:attrs %)) "link"))) + (all-properties entity) )))) + (str + "FROM " (s/join ", " (compose-convenience-view-select-list entity application true))) + (if + (not (empty? entity-fields)) + (str + "WHERE " + (s/join + "\n\tAND " + (map + (fn [f] + (let + [farside (child + application + #(and + (entity? %) + (= (:name (:attrs %)) (:entity (:attrs f)))))] + (str + (:table (:attrs entity)) + "." + (:name (:attrs f)) + " = " + (:table (:attrs farside)) + "." + (first (key-names farside))))) + entity-fields)))) + ";" + (emit-permissions-grant view-name :SELECT (permissions entity application)))))))) (defn emit-table - [entity application emitted-link-tables] + [entity application] (let [table-name (:table (:attrs entity)) permissions (children-with-tag entity :permission)] (s/join - "\n" - (flatten - (list - comment-rule - (str "--\tprimary table " table-name " for entity " (:name (:attrs entity))) - comment-rule - (s/join - " " - (list "CREATE TABLE " table-name)) - "(" - (map - #(emit-property % entity application true) - (children-with-tag (child-with-tag entity :key) :property)) - (map - #(emit-property % entity application false) - (children-with-tag entity :property)) - ");" - (map - #(emit-permissions-grant table-name % permissions) - '(:SELECT :INSERT :UPDATE :DELETE))))))) + "\n" + (flatten + (list + comment-rule + (str "--\tprimary table " table-name " for entity " (:name (:attrs entity))) + comment-rule + (s/join + " " + (list "CREATE TABLE" table-name)) + "(" + (str + (s/join + ",\n" + (flatten + (remove + nil? + (list + (map + #(emit-property % entity application true) + (children-with-tag (child-with-tag entity :key) :property)) + (map + #(emit-property % entity application false) + (filter + #(not (= (:type (:attrs %)) "link")) + (children-with-tag entity :property))))))) + "\n);") + (map + #(emit-permissions-grant table-name % permissions) + '(:SELECT :INSERT :UPDATE :DELETE))))))) (defn emit-entity - [entity application emitted-link-tables] - (emit-table entity application emitted-link-tables) - (emit-convenience-view entity application)) + [entity application] + (doall + (list + (emit-table entity application) + (emit-convenience-view entity application)))) (defn emit-group-declaration [group application] (s/join - "\n" - (list - comment-rule - (str "--\tsecurity group " (:name (:attrs group))) - comment-rule - (str "CREATE GROUP IF NOT EXISTS " (:name (:attrs group)))))) + "\n" + (list + comment-rule + (str "--\tsecurity group " (:name (:attrs group))) + comment-rule + (str "CREATE GROUP " (:name (:attrs group)) ";")))) (defn emit-file-header [application] (s/join - "\n" - (list - comment-rule - (str - "--\tDatabase definition for application " - (:name (:attrs application)) - " version " - (:version (:attrs application))) - (str - "--\tauto-generated by [Application Description Language framework](https://github.com/simon-brooke/adl) at " - (f/unparse (f/formatters :basic-date-time) (t/now))) - comment-rule))) + "\n" + (list + comment-rule + (str + "--\tDatabase definition for application " + (:name (:attrs application)) + " version " + (:version (:attrs application))) + (str + "--\tauto-generated by [Application Description Language framework](https://github.com/simon-brooke/adl) at " + (f/unparse (f/formatters :basic-date-time) (t/now))) + comment-rule))) (defn emit-application [application] (let [emitted-link-tables (atom #{})] (s/join - "\n\n" - (flatten - (list - (emit-file-header application) - (map #(emit-group-declaration % application) (children-with-tag application :group)) - (map #(emit-entity % application emitted-link-tables) (children-with-tag application :entity)) - (map #(emit-link-tables % application emitted-link-tables) (children-with-tag application :entity))))))) + "\n\n" + (flatten + (list + (emit-file-header application) + (map + #(emit-group-declaration % application) + (sort-by-name + (children-with-tag application :group))) + (map + #(emit-entity % application) + (sort-by-name + (children-with-tag application :entity))) + (map + #(emit-link-tables % application emitted-link-tables) + (sort-by-name + (children-with-tag application :entity)))))))) (defn to-psql [application] - (let [filepath (str *output-path* "/resources/sql/" (:name (:attrs application)) ".postgres.sql")] + (let [filepath (str + *output-path* + "/resources/sql/" + (:name (:attrs application)) + ".postgres.sql")] (make-parents filepath) (spit filepath (emit-application application)))) diff --git a/src/adl/utils.clj b/src/adl/utils.clj index 5f51ae2..fbb921c 100644 --- a/src/adl/utils.clj +++ b/src/adl/utils.clj @@ -88,12 +88,11 @@ [property application] (if (= (:type (:attrs property)) "defined") - (first - (children - application - #(and - (= (:tag %) :typedef) - (= (:name (:attrs %)) (:typedef (:attrs property)))))))) + (child + application + #(and + (= (:tag %) :typedef) + (= (:name (:attrs %)) (:typedef (:attrs property))))))) (defn permissions @@ -352,20 +351,13 @@ (keyword? form) (path-part (first (children-with-tag entity form)) entity application))) + (defn editor-name "Return the path-part of the editor form for this `entity`. Note: assumes the editor form is the first form listed for the entity." [entity application] (path-part :form entity application)) -(defn typedef - [property application] - (first - (children application - #(and - (= (:tag %) :typedef) - (= (:name (:attrs %)) - (:definition (:attrs property))))))) (defn type-for-defined [property application] From 055eac80926a7c160840a27d4a9e452a06deca34 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 14 Jun 2018 09:52:18 +0100 Subject: [PATCH 22/52] Much improved --- src/adl/to_psql.clj | 271 +++++++++++++++++++++++++++----------------- src/adl/utils.clj | 42 ++++++- 2 files changed, 210 insertions(+), 103 deletions(-) diff --git a/src/adl/to_psql.clj b/src/adl/to_psql.clj index eba8b22..ed93635 100644 --- a/src/adl/to_psql.clj +++ b/src/adl/to_psql.clj @@ -46,9 +46,9 @@ [elements] (sort #(.compareTo (:name (:attrs %1)) (:name (:attrs %2))) elements)) + (declare emit-field-type emit-property) -(def comment-rule (apply str (repeat 79 "-"))) (defn emit-defined-field-type [property application] @@ -115,13 +115,7 @@ "-- ERROR: cannot generate link to entity " (:name (:attrs farside)) " with compound primary key\n") - (list - (emit-field-type (first key-properties) farside application false) - "REFERENCES" - (str - (:table (:attrs farside)) "(" (:name (:attrs (first key-properties)))) ")" - ;; TODO: ought to handle the `cascade` attribute, even though it's rarely used - )))) + (emit-field-type (first key-properties) farside application false)))) (defn emit-field-type @@ -135,8 +129,7 @@ "entity" (emit-entity-field-type property application) ("date" "time" "timestamp" "boolean" "text" "money") (.toUpperCase (:type (:attrs property))) - (str "-- ERROR: unknown type " (:type (:attrs property))) - )) + (str "-- ERROR: unknown type " (:type (:attrs property))))) (defn emit-link-field @@ -172,47 +165,6 @@ (s/join " " (list "GRANT" (name privilege) "ON" table-name "TO" (s/join ",\n\t" (sort group-names)) ";"))))) -(defn emit-link-table - [property e1 application emitted-link-tables] - (let [e2 (child - application - #(and - (entity? %) - (= (:name (:attrs %)) (:entity (:attrs property))))) - link-table-name (link-table-name e1 e2) - permissions (flatten - (list - (children-with-tag e1 :permission) - (children-with-tag e1 :permission)))] - (if - (not (@emitted-link-tables link-table-name)) - (do - (swap! emitted-link-tables conj link-table-name) - (s/join - "\n" - (list - comment-rule - (str "--\tlink table joining " (:name (:attrs e1)) " with " (:name (:attrs e2))) - comment-rule - (s/join " " (list "CREATE TABLE IF NOT EXISTS" link-table-name)) - "(" - (emit-link-field property e1 application) - (emit-link-field property e2 application) - ");" - (emit-permissions-grant link-table-name :SELECT permissions) - (emit-permissions-grant link-table-name :INSERT permissions))))))) - - -(defn emit-link-tables - [entity application emitted-link-tables] - (map - #(emit-link-table % entity application emitted-link-tables) - (sort-by-name - (filter - #(= (:type (:attrs %)) "link") - (properties entity))))) - - (defn emit-property ([property entity application] (emit-property property entity application false)) @@ -328,9 +280,9 @@ nil? (flatten (list - comment-rule - (str "--\tconvenience view " view-name " of entity " (:name (:attrs entity)) " for lists, et cetera") - comment-rule + (emit-header + "--" + (str "convenience view " view-name " of entity " (:name (:attrs entity)) " for lists, et cetera")) (s/join " " (list "CREATE VIEW" view-name "AS")) @@ -375,40 +327,157 @@ (emit-permissions-grant view-name :SELECT (permissions entity application)))))))) -(defn emit-table - [entity application] - (let [table-name (:table (:attrs entity)) - permissions (children-with-tag entity :permission)] +(defn emit-referential-integrity-link + [property nearside application] + (let + [farside (entity-for-property property application)] (s/join - "\n" - (flatten - (list - comment-rule - (str "--\tprimary table " table-name " for entity " (:name (:attrs entity))) - comment-rule - (s/join - " " - (list "CREATE TABLE" table-name)) - "(" - (str + " " + (list + "ALTER TABLE" + (:name (:attrs nearside)) + "ADD CONSTRINT" + (str "ri_" (:name (:attrs nearside)) "_" (:name (:attrs farside)) "_" (:name (:attrs property))) + "\n\tFOREIGN KEY(" + (:name (:attrs property)) + ") \n\tREFERENCES" + (str + (:table (:attrs farside)) "(" (:name (:attrs (first (key-properties farside)))) ")") + ;; TODO: ought to handle the `cascade` attribute, even though it's rarely used + "\n\tON DELETE" + (case + (:cascade (:attrs property)) + "orphan" "SET NULL" + "delete" "CASCADE" + "NO ACTION") + ";")))) + + +(defn emit-referential-integrity-links + ([entity application] + (map + #(emit-referential-integrity-link % entity application) + (filter + #(= (:type (:attrs %)) "entity") + (properties entity)))) + ([application] + (flatten + (list + (emit-header + "--" + (str "--\treferential integrity links for first-class tables")) + (map + #(emit-referential-integrity-links % application) + (children-with-tag application :entity)))))) + + +(defn emit-table + ([entity application doc-comment] + (let [table-name (:table (:attrs entity)) + permissions (children-with-tag entity :permission)] + (s/join + "\n" + (flatten + (list + (emit-header + "--" + (list + doc-comment + (map + #(:content %) + (children-with-tag entity :documentation)))) (s/join - ",\n" - (flatten - (remove - nil? - (list - (map - #(emit-property % entity application true) - (children-with-tag (child-with-tag entity :key) :property)) - (map - #(emit-property % entity application false) - (filter - #(not (= (:type (:attrs %)) "link")) - (children-with-tag entity :property))))))) + " " + (list "CREATE TABLE" table-name)) + "(" + (str + (s/join + ",\n" + (flatten + (remove + nil? + (list + (map + #(emit-property % entity application true) + (children-with-tag (child-with-tag entity :key) :property)) + (map + #(emit-property % entity application false) + (filter + #(not (= (:type (:attrs %)) "link")) + (children-with-tag entity :property))))))) "\n);") (map #(emit-permissions-grant table-name % permissions) '(:SELECT :INSERT :UPDATE :DELETE))))))) + ([entity application] + (emit-table + entity + application + (str + "primary table " + (:table (:attrs entity)) + " for entity " + (:name (:attrs entity)))))) + + +(defn construct-link-property + [entity] + {:tag :property + :attrs {:name (str (:name (:attrs entity)) "_id") + :column (str (:name (:attrs entity)) "_id") + :type "entity" + :entity (:name (:attrs entity)) + :farkey (first (key-names entity))}}) + + +(defn emit-link-table + [property e1 application emitted-link-tables] + (let [e2 (child + application + #(and + (entity? %) + (= (:name (:attrs %)) (:entity (:attrs property))))) + link-table-name (link-table-name e1 e2)] + (if + ;; we haven't already emitted this one... + (not (@emitted-link-tables link-table-name)) + (let [permissions (flatten + (list + (children-with-tag e1 :permission) + (children-with-tag e1 :permission))) + ;; construct a dummy entity + link-entity {:tag :entity + :attrs {:name link-table-name + :table link-table-name} + :content + (vector + (concat + [(construct-link-property e1) + (construct-link-property e2)] + permissions))}] + ;; mark it as emitted + (swap! emitted-link-tables conj link-table-name) + ;; emit it + (emit-table + link-entity + application + (str + "link table joining " + (:name (:attrs e1)) + " with " + (:name (:attrs e2)))) + ;; and immediately emit its referential integrity links + (emit-referential-integrity-links link-entity application))))) + + +(defn emit-link-tables + [entity application emitted-link-tables] + (map + #(emit-link-table % entity application emitted-link-tables) + (sort-by-name + (filter + #(= (:type (:attrs %)) "link") + (properties entity))))) (defn emit-entity @@ -421,30 +490,27 @@ (defn emit-group-declaration [group application] - (s/join - "\n" - (list - comment-rule - (str "--\tsecurity group " (:name (:attrs group))) - comment-rule - (str "CREATE GROUP " (:name (:attrs group)) ";")))) + (list + (emit-header + "--" + (str "security group " (:name (:attrs group)))) + (str "CREATE GROUP " (:name (:attrs group)) ";"))) (defn emit-file-header [application] - (s/join - "\n" - (list - comment-rule - (str - "--\tDatabase definition for application " - (:name (:attrs application)) - " version " - (:version (:attrs application))) - (str - "--\tauto-generated by [Application Description Language framework](https://github.com/simon-brooke/adl) at " - (f/unparse (f/formatters :basic-date-time) (t/now))) - comment-rule))) + (emit-header + "--" + "Database definition for application " + (str (:name (:attrs application)) + " version " + (:version (:attrs application))) + "auto-generated by [Application Description Language framework]" + (str "(https://github.com/simon-brooke/adl) at " + (f/unparse (f/formatters :basic-date-time) (t/now))) + (map + #(:content %) + (children-with-tag application :documentation)))) (defn emit-application @@ -463,6 +529,7 @@ #(emit-entity % application) (sort-by-name (children-with-tag application :entity))) + (emit-referential-integrity-links application) (map #(emit-link-tables % application emitted-link-tables) (sort-by-name diff --git a/src/adl/utils.clj b/src/adl/utils.clj index fbb921c..13b43e7 100644 --- a/src/adl/utils.clj +++ b/src/adl/utils.clj @@ -2,6 +2,7 @@ :author "Simon Brooke"} adl.utils (:require [clojure.string :as s] + [clojure.pprint :as p] [clojure.xml :as x] [adl.validator :refer [valid-adl? validate-adl]])) @@ -38,6 +39,40 @@ "resources/auto/") +(defn wrap-lines + "Wrap lines in this `text` to this `width`; return a list of lines." + ;; Shamelessly adapted from https://www.rosettacode.org/wiki/Word_wrap#Clojure + [width text] + (s/split-lines + (p/cl-format + nil + (str "~{~<~%~1," width ":;~A~> ~}") + (clojure.string/split text #" ")))) + + +(defn emit-header + "Emit this `content` as a sequence of wrapped lines each prefixed with + `prefix`, and the whole delimited by rules." + [prefix & content] + (let [comment-rule (apply str (repeat 70 (last prefix))) + p (str "\n" prefix "\t") ] + (str + prefix + comment-rule + p + (s/join + p + (flatten + (interpose + "" + (map + #(wrap-lines 70 (str %)) + (flatten content))))) + "\n" + prefix + comment-rule))) + + (defn link-table-name "Canonical name of a link table between entity `e1` and entity `e2`." [e1 e2] @@ -213,7 +248,6 @@ (capitalise (singularise (:name (:attrs entity))))) - (defn safe-name ([string] (s/replace string #"[^a-zA-Z0-9-]" "")) @@ -234,6 +268,7 @@ links (filter #(-> % :attrs :entity) properties)] (= (count properties) (count links)))) + (defn read-adl [url] (let [adl (x/parse url) valid? (valid-adl? adl)] @@ -249,17 +284,20 @@ element (children element #(= (:tag %) tag)))) + (defn child-with-tag "Return the first child of this `element` which has this `tag`; if `element` is `nil`, return `nil`." [element tag] (first (children-with-tag element tag))) + (defmacro properties "Return all the properties of this `entity`." [entity] `(children-with-tag ~entity :property)) + (defn descendants-with-tag "Return all descendants of this `element`, recursively, which have this `tag`." [element tag] @@ -302,10 +340,12 @@ insertable? (all-properties ~entity))) + (defmacro key-properties [entity] `(children-with-tag (first (children-with-tag ~entity :key)) :property)) + (defmacro insertable-key-properties [entity] `(filter insertable? (key-properties entity))) From f0ddceb19ca9ee260a9087041c7ae80917f9714f Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 14 Jun 2018 11:56:47 +0100 Subject: [PATCH 23/52] Link tables working; a few other minor fixes. --- src/adl/to_psql.clj | 56 +++++++++++++++++++++++++-------------------- 1 file changed, 31 insertions(+), 25 deletions(-) diff --git a/src/adl/to_psql.clj b/src/adl/to_psql.clj index ed93635..8737290 100644 --- a/src/adl/to_psql.clj +++ b/src/adl/to_psql.clj @@ -336,8 +336,8 @@ (list "ALTER TABLE" (:name (:attrs nearside)) - "ADD CONSTRINT" - (str "ri_" (:name (:attrs nearside)) "_" (:name (:attrs farside)) "_" (:name (:attrs property))) + "ADD CONSTRAINT" + (str "ri_" (:name (:attrs nearside)) "_" (:name (:attrs property))) "\n\tFOREIGN KEY(" (:name (:attrs property)) ") \n\tREFERENCES" @@ -357,9 +357,10 @@ ([entity application] (map #(emit-referential-integrity-link % entity application) - (filter + (sort-by-name + (filter #(= (:type (:attrs %)) "entity") - (properties entity)))) + (properties entity))))) ([application] (flatten (list @@ -368,7 +369,7 @@ (str "--\treferential integrity links for first-class tables")) (map #(emit-referential-integrity-links % application) - (children-with-tag application :entity)))))) + (sort-by-name (children-with-tag application :entity))))))) (defn emit-table @@ -427,7 +428,8 @@ :column (str (:name (:attrs entity)) "_id") :type "entity" :entity (:name (:attrs entity)) - :farkey (first (key-names entity))}}) + :farkey (first (key-names entity))} + :content nil}) (defn emit-link-table @@ -450,34 +452,41 @@ :attrs {:name link-table-name :table link-table-name} :content - (vector - (concat - [(construct-link-property e1) + (apply vector + (flatten + (list + [(construct-link-property e1) (construct-link-property e2)] - permissions))}] + permissions)))}] ;; mark it as emitted (swap! emitted-link-tables conj link-table-name) ;; emit it - (emit-table - link-entity - application - (str - "link table joining " - (:name (:attrs e1)) - " with " - (:name (:attrs e2)))) - ;; and immediately emit its referential integrity links - (emit-referential-integrity-links link-entity application))))) + (flatten + (list + (emit-table + link-entity + application + (str + "link table joining " + (:name (:attrs e1)) + " with " + (:name (:attrs e2)))) + ;; and immediately emit its referential integrity links + (emit-referential-integrity-links link-entity application))))))) (defn emit-link-tables - [entity application emitted-link-tables] + ([entity application emitted-link-tables] (map #(emit-link-table % entity application emitted-link-tables) (sort-by-name (filter #(= (:type (:attrs %)) "link") (properties entity))))) + ([application emitted-link-tables] + (map + #(emit-link-tables % application emitted-link-tables) + (sort-by-name (children-with-tag application :entity))))) (defn emit-entity @@ -530,10 +539,7 @@ (sort-by-name (children-with-tag application :entity))) (emit-referential-integrity-links application) - (map - #(emit-link-tables % application emitted-link-tables) - (sort-by-name - (children-with-tag application :entity)))))))) + (emit-link-tables application emitted-link-tables)))))) (defn to-psql From e67142db471b3b0a134ff1ab378d041294ac4f88 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 14 Jun 2018 18:58:45 +0100 Subject: [PATCH 24/52] ADL now successfully generates the whole db definition for YouYesYet --- src/adl/to_hugsql_queries.clj | 52 ++++++------- src/adl/to_psql.clj | 133 +++++++++++++++++++--------------- src/adl/utils.clj | 71 +++++++++++++++--- 3 files changed, 161 insertions(+), 95 deletions(-) diff --git a/src/adl/to_hugsql_queries.clj b/src/adl/to_hugsql_queries.clj index be644f9..578f4ee 100644 --- a/src/adl/to_hugsql_queries.clj +++ b/src/adl/to_hugsql_queries.clj @@ -1,7 +1,7 @@ (ns ^{:doc "Application Description Language - generate HUGSQL queries file." :author "Simon Brooke"} adl.to-hugsql-queries - (:require [clojure.java.io :refer [file]] + (:require [clojure.java.io :refer [file make-parents]] [clojure.math.combinatorics :refer [combinations]] [clojure.string :as s] [clojure.xml :as x] @@ -325,18 +325,18 @@ :near-entity near :far-entity far :query - (s/join - "\n" - (remove - empty? - (list - (str "-- :name " query-name " " signature) - (str "-- :doc lists all existing " near-name " records related through " link-name " to a given " pretty-far ) - (str "SELECT "near-name ".*") - (str "FROM " near-name ", " link-name ) - (str "WHERE " near-name "." (first (key-names near)) " = " link-name "." (singularise near-name) "_id" ) - ("\tAND " link-name "." (singularise far-name) "_id = :id") - (order-by-clause near))))})))) + (s/join + "\n" + (remove + empty? + (list + (str "-- :name " query-name " " signature) + (str "-- :doc lists all existing " near-name " records related through " link-name " to a given " pretty-far ) + (str "SELECT "near-name ".*") + (str "FROM " near-name ", " link-name ) + (str "WHERE " near-name "." (first (key-names near)) " = " link-name "." (singularise near-name) "_id" ) + ("\tAND " link-name "." (singularise far-name) "_id = :id") + (order-by-clause near))))})))) (defn link-table-queries [entity application] @@ -416,22 +416,22 @@ (defn to-hugsql-queries "Generate all [HugSQL](https://www.hugsql.org/) queries implied by this ADL `application` spec." [application] - (spit - (str *output-path* "queries.sql") - (s/join - "\n\n" - (cons - (s/join - "\n-- " - (list - "-- File queries.sql" - "autogenerated by adl.to-hugsql-queries at" - (t/now) - "See [Application Description Language](https://github.com/simon-brooke/adl).\n\n")) + (let [file-path (str *output-path* "resources/sql/queries.sql")] + (make-parents file-path) + (spit + file-path + (s/join + "\n\n" + (cons + (emit-header + "--" + "File queries.sql" + (str "autogenerated by adl.to-hugsql-queries at " (t/now)) + "See [Application Description Language](https://github.com/simon-brooke/adl).") (map #(:query %) (sort #(compare (:name %1) (:name %2)) (vals - (queries application)))))))) + (queries application))))))))) diff --git a/src/adl/to_psql.clj b/src/adl/to_psql.clj index ed93635..dd4dcf1 100644 --- a/src/adl/to_psql.clj +++ b/src/adl/to_psql.clj @@ -37,16 +37,6 @@ ;;; this is a pretty straight translation of adl2psql.xslt, and was written because ;;; Clojure is easier to debug. -;;; TODO: the order in which we generate tables is critical, because tables -;;; can only reference other tables which already exist. We could get around -;;; this by generating referential integrity constraints post-hoc, which is -;;; what the xslt version did. - -(defn sort-by-name - [elements] - (sort #(.compareTo (:name (:attrs %1)) (:name (:attrs %2))) elements)) - - (declare emit-field-type emit-property) @@ -60,7 +50,7 @@ (:pattern (:attrs typedef)) (str " CONSTRAINT " - (gensym "c-") + (gensym "pattern_") " CHECK (" (:name (:attrs property)) " ~* '" @@ -70,7 +60,7 @@ ;; TODO: if base type is date, time or timestamp, values should be quoted. (str " CONSTRAINT " - (gensym "c-") + (gensym "minmax_") " CHECK (" (:minimum (:attrs typedef)) " < " @@ -83,7 +73,7 @@ (:maximum (:attrs typedef)) (str " CONSTRAINT " - (gensym "c-") + (gensym "max_") " CHECK (" (:name (:attrs property)) " < " @@ -92,7 +82,7 @@ (:minimum (:attrs typedef)) (str " CONSTRAINT " - (gensym "c-") + (gensym "min_") " CHECK (" (:minimum (:attrs typedef)) " < " @@ -154,15 +144,35 @@ (:DELETE :ALL) #{"all"}) group-names (set - (remove - nil? - (map - #(if (selector (:permission (:attrs %))) - (:group (:attrs %))) - permissions)))] + (remove + nil? + (map + #(if (selector (:permission (:attrs %))) + (safe-name (:group (:attrs %)) :sql)) + permissions)))] (if (not (empty? group-names)) - (s/join " " (list "GRANT" (name privilege) "ON" table-name "TO" (s/join ",\n\t" (sort group-names)) ";"))))) + (s/join + " " + (list + "GRANT" + (name privilege) + "ON" + (safe-name table-name :sql) + "TO" + (s/join + ",\n\t" + (sort group-names)) + ";"))))) + + +(defn field-name + [property] + (safe-name + (or + (:column (:attrs property)) + (:name (:attrs property))) + :sql)) (defn emit-property @@ -181,9 +191,17 @@ (flatten (list "\t" - (:name (:attrs property)) + (field-name property) (emit-field-type property entity application key?) - (if default (list "DEFAULT" default)) + (if + default + (list + "DEFAULT" + (if + (is-quotable-type? property application) + (str "'" default "'") ;; TODO: but if the default value seems to be a function invocation, should it be quoted? + ;; it's quite common for 'now()' to be the default for a date, time or timestamp field. + default))) (if key? "NOT NULL PRIMARY KEY" @@ -203,7 +221,7 @@ (if (= (:type (:attrs f)) "entity") (compose-convenience-entity-field f farside application) - (str (:table (:attrs farside)) "." (:name (:attrs f))))) + (str (safe-name (:table (:attrs farside))) "." (field-name f)))) (user-distinct-properties farside))))) @@ -213,7 +231,7 @@ nil? (flatten (cons - (:name (:attrs entity)) + (safe-name (:table (:attrs entity)) :sql) (map (fn [f] (if @@ -242,13 +260,13 @@ (let [farside (entity-for-property f application)] (cons (str - (:table (:attrs entity)) + (safe-name (:table (:attrs entity)) :sql) "." - (:name (:attrs f)) + (field-name f) " = " - (:table (:attrs farside)) + (safe-name (:table (:attrs farside)) :sql) "." - (first (key-names farside))) + (safe-name (first (key-names farside)) :sql)) #(compose-convenience-where-clause farside application false))))) (if top-level? @@ -260,17 +278,17 @@ [field entity application] (str (s/join - " |', '| " + " ||', '|| " (compose-convenience-entity-field field entity application)) " AS " - (:name (:attrs field)))) + (field-name field))) (defn emit-convenience-view "Emit a convenience view of this `entity` of this `application` for use in generating lists, menus, et cetera." [entity application] - (let [view-name (str "lv_" (:table (:attrs entity))) + (let [view-name (safe-name (str "lv_" (:table (:attrs entity))) :sql) entity-fields (filter #(= (:type (:attrs %)) "entity") (properties entity))] @@ -294,12 +312,12 @@ #(if (= (:type (:attrs %)) "entity") (emit-convenience-entity-field % entity application) - (:name (:attrs %))) + (str (safe-name entity) "." (field-name %))) (filter - #(and (= (:tag %) :property) (not (= (:type (:attrs %)) "link"))) + #(not (= (:type (:attrs %)) "link")) (all-properties entity) )))) (str - "FROM " (s/join ", " (compose-convenience-view-select-list entity application true))) + "FROM " (s/join ", " (set (compose-convenience-view-select-list entity application true)))) (if (not (empty? entity-fields)) (str @@ -315,13 +333,13 @@ (entity? %) (= (:name (:attrs %)) (:entity (:attrs f)))))] (str - (:table (:attrs entity)) + (safe-name (:table (:attrs entity)) :sql) "." - (:name (:attrs f)) + (field-name f) " = " - (:table (:attrs farside)) + (safe-name (:table (:attrs farside)) :sql) "." - (first (key-names farside))))) + (safe-name (first (key-names farside)) :sql)))) entity-fields)))) ";" (emit-permissions-grant view-name :SELECT (permissions entity application)))))))) @@ -335,14 +353,15 @@ " " (list "ALTER TABLE" - (:name (:attrs nearside)) - "ADD CONSTRINT" - (str "ri_" (:name (:attrs nearside)) "_" (:name (:attrs farside)) "_" (:name (:attrs property))) + (safe-name (:name (:attrs nearside)) :sql) + "ADD CONSTRAINT" + (safe-name (str "ri_" (:name (:attrs nearside)) "_" (:name (:attrs farside)) "_" (:name (:attrs property))) :sql) "\n\tFOREIGN KEY(" - (:name (:attrs property)) + (field-name property) ") \n\tREFERENCES" (str - (:table (:attrs farside)) "(" (:name (:attrs (first (key-properties farside)))) ")") + (safe-name (:table (:attrs farside)) :sql) + "(" (field-name (first (key-properties farside))) ")") ;; TODO: ought to handle the `cascade` attribute, even though it's rarely used "\n\tON DELETE" (case @@ -365,7 +384,7 @@ (list (emit-header "--" - (str "--\treferential integrity links for first-class tables")) + "referential integrity links for primary tables") (map #(emit-referential-integrity-links % application) (children-with-tag application :entity)))))) @@ -373,7 +392,7 @@ (defn emit-table ([entity application doc-comment] - (let [table-name (:table (:attrs entity)) + (let [table-name (safe-name (:table (:attrs entity)) :sql) permissions (children-with-tag entity :permission)] (s/join "\n" @@ -423,11 +442,11 @@ (defn construct-link-property [entity] {:tag :property - :attrs {:name (str (:name (:attrs entity)) "_id") - :column (str (:name (:attrs entity)) "_id") + :attrs {:name (safe-name (str (:name (:attrs entity)) "_id") :sql) + :column (safe-name (str (:name (:attrs entity)) "_id") :sql) :type "entity" :entity (:name (:attrs entity)) - :farkey (first (key-names entity))}}) + :farkey (safe-name (first (key-names entity)) :sql)}}) (defn emit-link-table @@ -480,21 +499,13 @@ (properties entity))))) -(defn emit-entity - [entity application] - (doall - (list - (emit-table entity application) - (emit-convenience-view entity application)))) - - (defn emit-group-declaration [group application] (list (emit-header "--" (str "security group " (:name (:attrs group)))) - (str "CREATE GROUP " (:name (:attrs group)) ";"))) + (str "CREATE GROUP " (safe-name (:name (:attrs group)) :sql) ";"))) (defn emit-file-header @@ -526,7 +537,11 @@ (sort-by-name (children-with-tag application :group))) (map - #(emit-entity % application) + #(emit-table % application) + (sort-by-name + (children-with-tag application :entity))) + (map + #(emit-convenience-view % application) (sort-by-name (children-with-tag application :entity))) (emit-referential-integrity-links application) diff --git a/src/adl/utils.clj b/src/adl/utils.clj index 13b43e7..fb9c5f2 100644 --- a/src/adl/utils.clj +++ b/src/adl/utils.clj @@ -39,6 +39,12 @@ "resources/auto/") +(defn element? + "True if `o` is a Clojure representation of an XML element." + [o] + (and (map? o) (:tag o) (:attrs o))) + + (defn wrap-lines "Wrap lines in this `text` to this `width`; return a list of lines." ;; Shamelessly adapted from https://www.rosettacode.org/wiki/Word_wrap#Clojure @@ -73,6 +79,11 @@ comment-rule))) +(defn sort-by-name + [elements] + (sort #(compare (:name (:attrs %1)) (:name (:attrs %2))) elements)) + + (defn link-table-name "Canonical name of a link table between entity `e1` and entity `e2`." [e1 e2] @@ -249,16 +260,25 @@ (defn safe-name - ([string] - (s/replace string #"[^a-zA-Z0-9-]" "")) - ([string convention] - (case convention - (:sql :c) (s/replace string #"[^a-zA-Z0-9_]" "_") - :c-sharp (s/replace (capitalise string) #"[^a-zA-Z0-9]" "") - :java (let - [camel (s/replace (capitalise string) #"[^a-zA-Z0-9]" "")] - (apply str (cons (Character/toUpperCase (first camel)) (rest camel)))) - (safe-name string)))) + "Return a safe name for the object `o`, given the specified `convention`. + `o` is expected to be either a string or an entity." + ([o] + (if + (element? o) + (safe-name (:name (:attrs o))) + (s/replace (str o) #"[^a-zA-Z0-9-]" ""))) + ([o convention] + (if + (element? o) + (safe-name (:name (:attrs o)) convention) + (let [string (str o)] + (case convention + (:sql :c) (s/replace string #"[^a-zA-Z0-9_]" "_") + :c-sharp (s/replace (capitalise string) #"[^a-zA-Z0-9]" "") + :java (let + [camel (s/replace (capitalise string) #"[^a-zA-Z0-9]" "")] + (apply str (cons (Character/toLowerCase (first camel)) (rest camel)))) + (safe-name string)))))) (defn link-table? @@ -359,6 +379,37 @@ (key-properties entity)))) +(defn base-type + [property application] + (cond + (:typedef (:attrs property)) + (:type + (:attrs + (child + application + #(and + (= (:tag %) :typedef) + (= (:name (:attrs %)) (:typedef (:attrs property))))))) + (:entity (:attrs property)) + (:type + (:attrs + (first + (key-properties + (child + application + #(and + (= (:tag %) :entity) + (= (:name (:attrs %)) (:entity (:attrs property))))))))) + true + (:type (:attrs property)))) + + +(defn is-quotable-type? + "True if the value for this field should be quoted." + [property application] + (#{"date" "image" "string" "text" "time" "timestamp" "uploadable"} (base-type property application))) + + (defn has-primary-key? [entity] (> (count (key-names entity)) 0)) From 8ee91b537286e176c133871a66efc700fe0597f0 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 14 Jun 2018 21:26:23 +0100 Subject: [PATCH 25/52] Generated HugSQL queries now (all?) working. --- src/adl/to_hugsql_queries.clj | 7 ++----- src/adl/to_json_routes.clj | 6 +++--- src/adl/to_selmer_routes.clj | 6 +++--- src/adl/to_selmer_templates.clj | 8 ++++---- src/adl/utils.clj | 16 ++++++++-------- 5 files changed, 20 insertions(+), 23 deletions(-) diff --git a/src/adl/to_hugsql_queries.clj b/src/adl/to_hugsql_queries.clj index 578f4ee..dbb0508 100644 --- a/src/adl/to_hugsql_queries.clj +++ b/src/adl/to_hugsql_queries.clj @@ -392,13 +392,10 @@ (defn queries "Generate all standard queries for this `entity` in this `application`; if - no entity is specified, generate all queris for the application." + no entity is specified, generate all queries for the application." ([application entity] (merge - (if - (link-table? entity) - (link-table-queries entity application) - {}) + ;; TODO: queries that look through link tables (insert-query entity) (update-query entity) (delete-query entity) diff --git a/src/adl/to_json_routes.clj b/src/adl/to_json_routes.clj index e6e9346..afb0426 100644 --- a/src/adl/to_json_routes.clj +++ b/src/adl/to_json_routes.clj @@ -47,12 +47,12 @@ (f/unparse (f/formatters :basic-date-time) (t/now))) (list :require + '[clojure.java.io :as io] + '[compojure.core :refer [defroutes GET POST]] + '[hugsql.core :as hugsql] '[noir.response :as nresponse] '[noir.util.route :as route] - '[compojure.core :refer [defroutes GET POST]] '[ring.util.http-response :as response] - '[clojure.java.io :as io] - '[hugsql.core :as hugsql] (vector (symbol (str (safe-name (:name (:attrs application))) ".db.core")) :as 'db)))) diff --git a/src/adl/to_selmer_routes.clj b/src/adl/to_selmer_routes.clj index 37e5a71..f58c00d 100644 --- a/src/adl/to_selmer_routes.clj +++ b/src/adl/to_selmer_routes.clj @@ -44,12 +44,12 @@ (f/unparse (f/formatters :basic-date-time) (t/now))) (list :require + '[clojure.java.io :as io] + '[compojure.core :refer [defroutes GET POST]] + '[hugsql.core :as hugsql] '[noir.response :as nresponse] '[noir.util.route :as route] - '[compojure.core :refer [defroutes GET POST]] '[ring.util.http-response :as response] - '[clojure.java.io :as io] - '[hugsql.core :as hugsql] (vector (symbol (str (:name (:attrs application)) ".layout")) :as 'l) (vector (symbol (str (:name (:attrs application)) ".db.core")) :as 'db) (vector (symbol (str (:name (:attrs application)) ".routes.manual")) :as 'm)))) diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj index a1616e1..05673e0 100644 --- a/src/adl/to_selmer_templates.clj +++ b/src/adl/to_selmer_templates.clj @@ -480,7 +480,7 @@ (list-page-control true)]}) -(defn- list-to-template +(defn list-to-template "Generate a template as specified by this `list` element for this `entity`, taken from this `application`. If `list` is nill, generate a default list template for the entity." @@ -502,9 +502,9 @@ `entity` in this `application`" [entity application] (let - [forms (children entity #(= (:tag %) :form)) - pages (children entity #(= (:tag %) :page)) - lists (children entity #(= (:tag %) :list))] + [forms (children-with-tag entity :form) + pages (children-with-tag entity :page) + lists (children-with-tag entity :list)] (if (and (= (:tag entity) :entity) ;; it seems to be an ADL entity diff --git a/src/adl/utils.clj b/src/adl/utils.clj index fb9c5f2..8767c47 100644 --- a/src/adl/utils.clj +++ b/src/adl/utils.clj @@ -281,14 +281,6 @@ (safe-name string)))))) -(defn link-table? - "Return true if this `entity` represents a link table." - [entity] - (let [properties (children entity #(= (:tag %) :property)) - links (filter #(-> % :attrs :entity) properties)] - (= (count properties) (count links)))) - - (defn read-adl [url] (let [adl (x/parse url) valid? (valid-adl? adl)] @@ -371,6 +363,14 @@ `(filter insertable? (key-properties entity))) +(defn link-table? + "Return true if this `entity` represents a link table." + [entity] + (let [properties (all-properties entity) + links (filter #(-> % :attrs :entity) properties)] + (= (count properties) (count links)))) + + (defn key-names [entity] (remove nil? From e879b8b6282000c309454c21df6e975b45fe1926 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 15 Jun 2018 10:51:31 +0100 Subject: [PATCH 26/52] Fixes to generated routes, views and queries List views now work; edit views don't yet. --- src/adl/to_hugsql_queries.clj | 30 +++++++++++++++++------------- src/adl/to_selmer_routes.clj | 24 +++++++++++++++++++----- src/adl/to_selmer_templates.clj | 3 +-- 3 files changed, 37 insertions(+), 20 deletions(-) diff --git a/src/adl/to_hugsql_queries.clj b/src/adl/to_hugsql_queries.clj index dbb0508..bc480e8 100644 --- a/src/adl/to_hugsql_queries.clj +++ b/src/adl/to_hugsql_queries.clj @@ -54,7 +54,9 @@ (defn order-by-clause "Generate an appropriate `order by` clause for queries on this `entity`" - [entity] + ([entity] + (order-by-clause entity "")) + ([entity prefix] (let [entity-name (:name (:attrs entity)) preferred (map @@ -65,10 +67,10 @@ (empty? preferred) "" (str - "ORDER BY " entity-name "." + "ORDER BY " prefix entity-name "." (s/join - (str ",\n\t" entity-name ".") - (flatten (cons preferred (key-names entity)))))))) + (str ",\n\t" prefix entity-name ".") + (flatten (cons preferred (key-names entity))))))))) (defn insert-query @@ -152,8 +154,8 @@ (str "-- :doc selects existing " pretty-name - " records having any string field matching `:pattern` by substring match") - (str "SELECT * FROM " entity-name) + " records having any string field matching the parameter of the same name by substring match") + (str "SELECT * FROM lv_" entity-name) "WHERE " (s/join "\n\tOR " @@ -162,9 +164,9 @@ (map #(if (#{"string" "date" "text"} (:type (:attrs %))) - (str (-> % :attrs :name) " LIKE '%:pattern%'")) + (str (-> % :attrs :name) " LIKE '%params." (-> % :attrs :name) "%'")) properties))) - (order-by-clause entity) + (order-by-clause entity "lv_") "--~ (if (:offset params) \"OFFSET :offset \")" "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))}))) @@ -232,8 +234,8 @@ (list (str "-- :name " query-name " " signature) (str "-- :doc lists all existing " pretty-name " records") - (str "SELECT * FROM " entity-name) - (order-by-clause entity) + (str "SELECT * FROM lv_" entity-name) + (order-by-clause entity "lv_") "--~ (if (:offset params) \"OFFSET :offset \")" "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))}))) @@ -276,9 +278,11 @@ "entity" (list (str "-- :name " query-name " " signature) (str "-- :doc lists all existing " pretty-name " records related to a given " pretty-far) - (str "SELECT * \nFROM " entity-name) - (str "WHERE " entity-name "." link-field " = :id") - (order-by-clause entity)) + (str "SELECT * \nFROM lv_" entity-name ", " entity-name) + (str "WHERE lv_" entity-name "." (first (key-names entity)) " = " + entity-name "." (first (key-names entity)) + "\n\tAND " entity-name "." link-field " = :id") + (order-by-clause entity "lv_")) "link" (let [link-table-name (link-table-name entity far-entity)] (list diff --git a/src/adl/to_selmer_routes.clj b/src/adl/to_selmer_routes.clj index f58c00d..597797a 100644 --- a/src/adl/to_selmer_routes.clj +++ b/src/adl/to_selmer_routes.clj @@ -78,11 +78,25 @@ :list {:records (list - (symbol - (str - "db/search-strings-" - (singularise (:name (:attrs e))))) - 'p)}))))))) + 'if + (list + 'not + (list + 'empty? + (list 'remove 'nil? (list 'vals 'p)))) + (list + (symbol + (str + "db/search-strings-" + (singularise (:name (:attrs e))))) + (symbol "db/*db*") + 'p) + (list + (symbol + (str + "db/list-" + (:name (:attrs e)))) + (symbol "db/*db*") {}))}))))))) (defn make-route "Make a route for method `m` to request the resource with name `n`." diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj index 05673e0..69faf38 100644 --- a/src/adl/to_selmer_templates.clj +++ b/src/adl/to_selmer_templates.clj @@ -422,7 +422,7 @@ [list-spec entity application] {:tag :tbody :content - ["{% for record in %records% %}" + ["{% for record in records %}" {:tag :tr :content (apply @@ -438,7 +438,6 @@ :attrs {:href (str - "{{servlet-context}}/" (editor-name entity application) "?" (s/join From 40fc3a99cc653c855331c3fe3f0b46d5dff2c296 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 16 Jun 2018 10:34:05 +0100 Subject: [PATCH 27/52] Added drill-down in lists. --- src/adl/to_psql.clj | 110 +++++++++++++++++--------------- src/adl/to_selmer_templates.clj | 43 +++++++++---- 2 files changed, 88 insertions(+), 65 deletions(-) diff --git a/src/adl/to_psql.clj b/src/adl/to_psql.clj index dd4dcf1..faf2b21 100644 --- a/src/adl/to_psql.clj +++ b/src/adl/to_psql.clj @@ -281,7 +281,8 @@ " ||', '|| " (compose-convenience-entity-field field entity application)) " AS " - (field-name field))) + (field-name field) + "_expanded")) (defn emit-convenience-view @@ -290,59 +291,62 @@ [entity application] (let [view-name (safe-name (str "lv_" (:table (:attrs entity))) :sql) entity-fields (filter - #(= (:type (:attrs %)) "entity") - (properties entity))] + #(= (:type (:attrs %)) "entity") + (properties entity))] (s/join - "\n" - (remove - nil? - (flatten - (list - (emit-header - "--" - (str "convenience view " view-name " of entity " (:name (:attrs entity)) " for lists, et cetera")) - (s/join - " " - (list "CREATE VIEW" view-name "AS")) - (str - "SELECT " - (s/join - ",\n\t" - (map - #(if - (= (:type (:attrs %)) "entity") - (emit-convenience-entity-field % entity application) - (str (safe-name entity) "." (field-name %))) - (filter - #(not (= (:type (:attrs %)) "link")) - (all-properties entity) )))) - (str - "FROM " (s/join ", " (set (compose-convenience-view-select-list entity application true)))) - (if - (not (empty? entity-fields)) - (str - "WHERE " - (s/join - "\n\tAND " - (map - (fn [f] - (let - [farside (child - application - #(and - (entity? %) - (= (:name (:attrs %)) (:entity (:attrs f)))))] - (str - (safe-name (:table (:attrs entity)) :sql) - "." - (field-name f) - " = " - (safe-name (:table (:attrs farside)) :sql) - "." - (safe-name (first (key-names farside)) :sql)))) - entity-fields)))) - ";" - (emit-permissions-grant view-name :SELECT (permissions entity application)))))))) + "\n" + (remove + nil? + (flatten + (list + (emit-header + "--" + (str "convenience view " view-name " of entity " (:name (:attrs entity)) " for lists, et cetera")) + (s/join + " " + (list "CREATE VIEW" view-name "AS")) + (str + "SELECT " + (s/join + ",\n\t" + (flatten + (map + #(if + (= (:type (:attrs %)) "entity") + (list + (emit-convenience-entity-field % entity application) + (str (safe-name entity) "." (field-name %))) + (str (safe-name entity) "." (field-name %))) + (filter + #(not (= (:type (:attrs %)) "link")) + (all-properties entity) ))))) + (str + "FROM " (s/join ", " (set (compose-convenience-view-select-list entity application true)))) + (if + (not (empty? entity-fields)) + (str + "WHERE " + (s/join + "\n\tAND " + (map + (fn [f] + (let + [farside (child + application + #(and + (entity? %) + (= (:name (:attrs %)) (:entity (:attrs f)))))] + (str + (safe-name (:table (:attrs entity)) :sql) + "." + (field-name f) + " = " + (safe-name (:table (:attrs farside)) :sql) + "." + (safe-name (first (key-names farside)) :sql)))) + entity-fields)))) + ";" + (emit-permissions-grant view-name :SELECT (permissions entity application)))))))) (defn emit-referential-integrity-link diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj index 69faf38..a813092 100644 --- a/src/adl/to_selmer_templates.clj +++ b/src/adl/to_selmer_templates.clj @@ -362,6 +362,7 @@ taken from this `application`. If `page` is nil, generate a default page template for the entity." [page entity application] + ;; TODO ) @@ -416,7 +417,21 @@ :value "Search"}}]})))}]}) -(defn- list-tbody +(defn edit-link + [entity application parameters] + (str + (editor-name entity application) + "?" + (s/join + "&" + (map + #(let [n (:name (:attrs %1))] + (str n "={{ record." %2 " }}")) + (key-names entity) + parameters)))) + + +(defn list-tbody "Return a table body element for the list view for this `list-spec` of this `entity` within this `application`." [list-spec entity application] @@ -430,22 +445,26 @@ (concat (map (fn [field] - {:tag :td :content [(str "{{ record." (:property (:attrs field)) " }}")]}) + {:tag :td :content + (let + [p (first (filter #(= (:name (:attrs %)) (:property (:attrs field))) (all-properties entity))) + e (first + (filter + #(= (:name (:attrs %)) (:entity (:attrs p))) + (children-with-tag application :entity))) + c (str "{{ record." (:property (:attrs field)) " }}")] + (if + (= (:type (:attrs p)) "entity") + [{:tag :a + :attrs {:href (edit-link e application (list (:name (:attrs p))))} + :content [(str "{{ record." (:property (:attrs field)) "_expanded }}")]}] + [c]))}) (fields list-spec)) [{:tag :td :content [{:tag :a :attrs - {:href - (str - (editor-name entity application) - "?" - (s/join - "&" - (map - #(let [n (:name (:attrs %))] - (str n "={{ record." n "}}")) - (children (first (filter #(= (:tag %) :key) (children entity)))))))} + {:href (edit-link entity application (key-names entity))} :content ["View"]}]}]))} "{% endfor %}"]}) From adca71875cd639dec6edbc13516af4cefd43e147 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 16 Jun 2018 11:29:21 +0100 Subject: [PATCH 28/52] Work on getting forms working. Not complete but a considerable advance. --- src/adl/to_selmer_routes.clj | 9 ++++- src/adl/to_selmer_templates.clj | 72 ++++++++++++++++++--------------- 2 files changed, 46 insertions(+), 35 deletions(-) diff --git a/src/adl/to_selmer_routes.clj b/src/adl/to_selmer_routes.clj index 597797a..62170c1 100644 --- a/src/adl/to_selmer_routes.clj +++ b/src/adl/to_selmer_routes.clj @@ -61,7 +61,10 @@ 'defn (symbol n) (vector 'r) - (list 'let (vector 'p (list :form-params 'r)) + (list 'let (vector 'p (list :params 'r)) ;; TODO: we must take key params out of just params, + ;; but we should take all other params out of form-params - because we need the key to + ;; load the form in the first place, but just accepting values of other params would + ;; allow spoofing. (list 'l/render (list 'resolve-template (str n ".html")) @@ -71,10 +74,12 @@ (case (:tag f) (:form :page) {:record + (list 'if (list 'empty? (list 'remove 'nil? (list 'vals 'p))) [] (list (symbol (str "db/get-" (singularise (:name (:attrs e))))) - 'p)} + (symbol "db/*db*") + 'p))} :list {:records (list diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj index a813092..b784f9b 100644 --- a/src/adl/to_selmer_templates.clj +++ b/src/adl/to_selmer_templates.clj @@ -366,12 +366,36 @@ ) +(defn compose-list-search-widget + [field entity] + (let [property (first + (children + entity + (fn [p] (and (= (:tag p) :property) + (= (:name (:attrs p)) (:property (:attrs field))))))) + input-type (case (:type (:attrs property)) + ("integer" "real" "money") "number" + ("date" "timestamp") "date" + "time" "time" + "text") + base-name (:property (:attrs field)) + search-name (if + (= (:type (:attrs property)) "entity") + (str base-name "_expanded") base-name)] + (hash-map + :tag :th + :content + [{:tag :input + :attrs {:id search-name + :type input-type + :name search-name + :value (str "{{ params." search-name " }}")}}]))) + + + (defn- list-thead "Return a table head element for the list view for this `list-spec` of this `entity` within - this `application`. - - TODO: where entity fields are being shown/searched on, we should be using the user-distinct - fields of the far side, rather than key values" + this `application`." [list-spec entity application] {:tag :thead :content @@ -388,33 +412,16 @@ :content (apply vector - (concat - (map - (fn [f] - (let [property (first - (children - entity - (fn [p] (and (= (:tag p) :property) - (= (:name (:attrs p)) (:property (:attrs f)))))))] - (hash-map - :tag :th - :content - [{:tag :input - :attrs {:id (:property (:attrs f)) - :type (case (:type (:attrs property)) - ("integer" "real" "money") "number" - ("date" "timestamp") "date" - "time" "time" - "text") - :name (:property (:attrs f)) - :value (str "{{ params." (:property (:attrs f)) " }}")}}]))) - (fields list-spec)) - '({:tag :th - :content - [{:tag :input - :attrs {:type "submit" - :id "search" - :value "Search"}}]})))}]}) + (concat + (map + #(compose-list-search-widget % entity) + (fields list-spec)) + '({:tag :th + :content + [{:tag :input + :attrs {:type "submit" + :id "search" + :value "Search"}}]})))}]}) (defn edit-link @@ -425,8 +432,7 @@ (s/join "&" (map - #(let [n (:name (:attrs %1))] - (str n "={{ record." %2 " }}")) + #(str %1 "={{ record." %2 " }}") (key-names entity) parameters)))) From 2d7e39ca2904fb7c26f4685924e1cc91307d786c Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Tue, 19 Jun 2018 08:24:43 +0100 Subject: [PATCH 29/52] Work on getting forms to work - almost, but not quite, complete --- src/adl/to_selmer_templates.clj | 59 ++++++++++++++++++++++++--------- src/adl/utils.clj | 6 ++-- 2 files changed, 47 insertions(+), 18 deletions(-) diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj index b784f9b..17aa062 100644 --- a/src/adl/to_selmer_templates.clj +++ b/src/adl/to_selmer_templates.clj @@ -259,6 +259,31 @@ :content (apply vector (get-options property form entity application))})))})) +(defn permissions-for + [property entity application] + (first + (remove + empty? + (list + (children-with-tag property :permission) + (children-with-tag entity :permission) + (children-with-tag application :permission))))) + + +(defn compose-if-member-of-tag + [property entity application writable?] + (let + [all-permissions (permissions-for property entity application) + permissions (if writable? (writable-by all-permissions) (visible-to all-permissions))] + (s/join + " " + (flatten + (list + "{% ifmemberof" + permissions + "%}"))))) + + (defn widget "Generate a widget for this `field-or-property` of this `form` for this `entity` taken from within this `application`." @@ -294,7 +319,7 @@ :content [{:tag :label :attrs {:for widget-name} :content [(prompt field-or-property form entity application)]} - (str "{% ifwritable " (:name (:attrs entity)) " " (:name (:attrs property)) " %}") + (compose-if-member-of-tag property entity application true) (cond select? (select-widget property form entity application) @@ -312,14 +337,14 @@ (:maximum (:attrs typedef)) {:max (:maximum (:attrs typedef))}))}) "{% else %}" - (str "{% ifreadable " (:name (:attrs entity)) " " (:name (:attrs property)) "%}") + (compose-if-member-of-tag property entity application false) {:tag :span :attrs {:id widget-name :name widget-name :class "pseudo-widget disabled"} :content [(str "{{record." widget-name "}}")]} - "{% endifreadable %}" - "{% endifwritable %}"]}))) + "{% endifmemberof %}" + "{% endifmemberof %}"]}))) (defn fields @@ -335,8 +360,8 @@ [form entity application] (let [keyfields (children - ;; there should only be one key; its keys are properties - (first (children entity #(= (:tag %) :key))))] + ;; there should only be one key; its keys are properties + (first (children entity #(= (:tag %) :key))))] {:tag :div :attrs {:id "content" :class "edit"} :content @@ -344,16 +369,18 @@ :attrs {:action (str "{{servlet-context}}/" (editor-name entity application)) :method "POST"} :content (flatten - (list - (csrf-widget) - (map - #(widget % form entity application) - keyfields) - (map - #(widget % form entity application) - (fields entity)) - (save-widget form entity application) - (delete-widget form entity application)))}]})) + (list + (csrf-widget) + (map + #(widget % form entity application) + keyfields) + (map + #(widget % form entity application) + (remove + #(= (:distict (:attrs %)) :system) + (fields entity))) + (save-widget form entity application) + (delete-widget form entity application)))}]})) diff --git a/src/adl/utils.clj b/src/adl/utils.clj index 8767c47..09888cc 100644 --- a/src/adl/utils.clj +++ b/src/adl/utils.clj @@ -222,8 +222,10 @@ (defn writable-by - "Return a list of names of groups to which are granted read access, - given these `permissions`, else nil." + "Return a list of names of groups to which are granted write access, + given these `permissions`, else nil. + TODO: TOTHINKABOUT: properties are also writable by `insert` and `noedit`, but only if the + current value is nil." [permissions] (permission-groups permissions #(#{"edit" "all"} (:permission (:attrs %))))) From fc79e74fb88eef61a8c10f6b946f827fb591d7d5 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 20 Jun 2018 09:26:08 +0100 Subject: [PATCH 30/52] Moved utils into the support project. Also greatly improved CLI. --- project.clj | 5 +- src/adl/main.clj | 106 +++++- src/adl/to_hugsql_queries.clj | 99 ++++-- src/adl/to_json_routes.clj | 54 ++-- src/adl/to_psql.clj | 558 ++++++++++++++++---------------- src/adl/to_reframe.clj | 5 +- src/adl/to_selmer_routes.clj | 128 +++++--- src/adl/to_selmer_templates.clj | 163 +++++----- src/adl/utils.clj | 457 -------------------------- src/adl/validator.clj | 97 +++--- 10 files changed, 697 insertions(+), 975 deletions(-) delete mode 100644 src/adl/utils.clj diff --git a/project.clj b/project.clj index 131722c..f2c7d3f 100644 --- a/project.clj +++ b/project.clj @@ -3,9 +3,12 @@ :url "http://example.com/FIXME" :license {:name "GNU General Public License,version 2.0 or (at your option) any later version" :url "https://www.gnu.org/licenses/old-licenses/gpl-2.0.en.html"} - :dependencies [[org.clojure/clojure "1.8.0"] + :dependencies [[adl-support "0.1.0-SNAPSHOT"] + [org.clojure/clojure "1.8.0"] [org.clojure/math.combinatorics "0.1.4"] + [org.clojure/tools.cli "0.3.7"] [bouncer "1.0.1"] + [environ "1.1.0"] [hiccup "1.0.5"]] :aot [adl.main] :main adl.main diff --git a/src/adl/main.clj b/src/adl/main.clj index ea955b1..066a864 100644 --- a/src/adl/main.clj +++ b/src/adl/main.clj @@ -1,13 +1,17 @@ (ns ^{:doc "Application Description Language - command line invocation." :author "Simon Brooke"} adl.main - (:require [adl.utils :refer :all] + (:require [adl-support.utils :refer :all] [adl.to-hugsql-queries :as h] [adl.to-json-routes :as j] [adl.to-psql :as p] [adl.to-selmer-routes :as s] [adl.to-selmer-templates :as t] - [clojure.xml :as x]) + [clojure.java.io :refer [make-parents]] + [clojure.string :refer [join]] + [clojure.tools.cli :refer [parse-opts]] + [clojure.xml :as x] + [environ.core :refer [env]]) (:gen-class)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -33,22 +37,96 @@ ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defn print-usage [_] - (println "Argument should be a pathname to an ADL file")) +(def cli-options + [["-a" "--abstract-key-name-convention [string]" "the abstract key name convention to use for generated key fields (TODO: not yet implemented)" + :default "id"] + ["-h" "--help" "Show this message" + :default false] + ["-l" "--locale [LOCALE]" "set the locale to generate" + :default (env :lang)] + ["-p" "--path [PATH]" "The path under which generated files should be written" + :default "generated"] + ["-v" "--verbosity [LEVEL]" nil "Verbosity level - integer value required" + :parse-fn #(Integer/parseInt %) + :default 0] + ]) + + +(defn- doc-part + "An `option` in cli-options comprises a sequence of strings followed by + keyword/value pairs. Return all the strings before the first keyword." + [option] + (if + (keyword? (first option)) nil + (cons (first option) (doc-part (rest option))))) + +(defn map-part + "An `option` in cli-options comprises a sequence of strings followed by + keyword/value pairs. Return the keyword/value pairs as a map." + [option] + (cond + (empty? option) nil + (keyword? (first option)) (apply hash-map option) + true + (map-part (rest option)))) + +(defn print-usage [] + (println + (join + "\n" + (flatten + (list + (join + (list + "Usage: java -jar adl-" + (or (System/getProperty "adl.version") "[VERSION]") + "-SNAPSHOT-standalone.jar -options [adl-file]")) + "where options include:" + (map + #(let + [doc-part (doc-part %) + default (:default (map-part %)) + default-string (if default (str "; (default: " default ")"))] + (str "\t" (join ", " (butlast doc-part)) ": " (last doc-part) default-string)) + cli-options)))))) + (defn -main "Expects as arg the path-name of an ADL file." [& args] - (cond - (empty? args) - (print-usage args) - (.exists (java.io.File. (first args))) - (let [application (x/parse (first args))] - (h/to-hugsql-queries application) - (j/to-json-routes application) - (p/to-psql application) - (s/to-selmer-routes application) - (t/to-selmer-templates application)))) + (let [options (parse-opts args cli-options)] + (cond + (empty? args) + (print-usage) + (not (empty? (:errors options))) + (do + (doall + (map + println + (:errors options))) + (print-usage)) + (-> options :options :help) + (print-usage) + true + (do + (let [p (:path (:options options)) + op (if (.endsWith p "/") p (str p "/"))] + (binding [*output-path* op + *locale* (-> options :options :locale) + *verbosity* (-> options :options :verbosity)] + (make-parents *output-path*) + (doall + (map + #(if + (.exists (java.io.File. %)) + (let [application (x/parse %)] + (h/to-hugsql-queries application) + (j/to-json-routes application) + (p/to-psql application) + (s/to-selmer-routes application) + (t/to-selmer-templates application)) + (println (str "ERROR: File not found: " %))) + (-> options :arguments))))))))) diff --git a/src/adl/to_hugsql_queries.clj b/src/adl/to_hugsql_queries.clj index bc480e8..4a983ab 100644 --- a/src/adl/to_hugsql_queries.clj +++ b/src/adl/to_hugsql_queries.clj @@ -7,7 +7,7 @@ [clojure.xml :as x] [clj-time.core :as t] [clj-time.format :as f] - [adl.utils :refer :all])) + [adl-support.utils :refer :all])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; @@ -58,9 +58,9 @@ (order-by-clause entity "")) ([entity prefix] (let - [entity-name (:name (:attrs entity)) + [entity-name (safe-name (:name (:attrs entity)) :sql) preferred (map - #(:name (:attrs %)) + #(safe-name (:name (:attrs %)) :sql) (filter #(#{"user" "all"} (-> % :attrs :distinct)) (children entity #(= (:tag %) :property))))] (if @@ -70,7 +70,9 @@ "ORDER BY " prefix entity-name "." (s/join (str ",\n\t" prefix entity-name ".") - (flatten (cons preferred (key-names entity))))))))) + (map + #(safe-name % :sql) + (flatten (cons preferred (key-names entity)))))))))) (defn insert-query @@ -78,9 +80,11 @@ TODO: this depends on the idea that system-unique properties are not insertable, which is... dodgy." [entity] - (let [entity-name (:name (:attrs entity)) + (let [entity-name (safe-name (:name (:attrs entity)) :sql) pretty-name (singularise entity-name) - insertable-property-names (map #(:name (:attrs %)) (insertable-properties entity)) + insertable-property-names (map + #(safe-name (:name (:attrs %)) :sql) + (insertable-properties entity)) query-name (str "create-" pretty-name "!") signature ":! :n"] (hash-map @@ -99,7 +103,12 @@ ")" (if (has-primary-key? entity) - (str "\nreturning " (s/join ",\n\t" (key-names entity)))))}))) + (str "\nreturning " + (s/join + ",\n\t" + (map + #(safe-name % :sql) + (key-names entity))))))}))) (defn update-query @@ -109,7 +118,7 @@ (and (has-primary-key? entity) (has-non-key-properties? entity)) - (let [entity-name (:name (:attrs entity)) + (let [entity-name (safe-name (:name (:attrs entity)) :sql) pretty-name (singularise entity-name) property-names (map #(:name (:attrs %)) (insertable-properties entity)) query-name (str "update-" pretty-name "!") @@ -125,7 +134,7 @@ "-- :doc updates an existing " pretty-name " record\n" "UPDATE " entity-name "\n" "SET " - (s/join ",\n\t" (map #(str % " = " (keyword %)) property-names)) + (s/join ",\n\t" (map #(str (safe-name % :sql) " = " (keyword %)) property-names)) "\n" (where-clause entity))})) {})) @@ -133,7 +142,7 @@ (defn search-query [entity] "Generate an appropriate search query for string fields of this `entity`" - (let [entity-name (:name (:attrs entity)) + (let [entity-name (safe-name (:name (:attrs entity)) :sql) pretty-name (singularise entity-name) query-name (str "search-strings-" pretty-name) signature ":? :1" @@ -162,9 +171,21 @@ (filter string? (map - #(if - (#{"string" "date" "text"} (:type (:attrs %))) - (str (-> % :attrs :name) " LIKE '%params." (-> % :attrs :name) "%'")) + #(case (:type (:attrs %)) + ("string" "text") + (str + (safe-name (-> % :attrs :name) :sql) + " LIKE '%params." + (-> % :attrs :name) "%'") + ("date" "time" "timestamp") + (str + (safe-name (-> % :attrs :name) :sql) + " = 'params." + (-> % :attrs :name) "'") + (str + (safe-name (-> % :attrs :name) :sql) + " = params." + (-> % :attrs :name))) properties))) (order-by-clause entity "lv_") "--~ (if (:offset params) \"OFFSET :offset \")" @@ -176,7 +197,7 @@ ([entity properties] (if (not (empty? properties)) - (let [entity-name (:name (:attrs entity)) + (let [entity-name (safe-name (:name (:attrs entity)) :sql) pretty-name (singularise entity-name) query-name (if (= properties (key-properties entity)) (str "get-" pretty-name) @@ -216,7 +237,7 @@ Parameters `:limit` and `:offset` may be supplied. If not present limit defaults to 100 and offset to 0." [entity] - (let [entity-name (:name (:attrs entity)) + (let [entity-name (safe-name (:name (:attrs entity)) :sql) pretty-name (singularise entity-name) query-name (str "list-" entity-name) signature ":? :*"] @@ -417,22 +438,34 @@ (defn to-hugsql-queries "Generate all [HugSQL](https://www.hugsql.org/) queries implied by this ADL `application` spec." [application] - (let [file-path (str *output-path* "resources/sql/queries.sql")] - (make-parents file-path) - (spit - file-path - (s/join - "\n\n" - (cons - (emit-header - "--" - "File queries.sql" - (str "autogenerated by adl.to-hugsql-queries at " (t/now)) - "See [Application Description Language](https://github.com/simon-brooke/adl).") - (map - #(:query %) - (sort - #(compare (:name %1) (:name %2)) - (vals - (queries application))))))))) + (let [filepath (str *output-path* "resources/sql/queries.auto.sql")] + (make-parents filepath) + (try + (spit + filepath + (s/join + "\n\n" + (cons + (emit-header + "--" + "File queries.sql" + (str "autogenerated by adl.to-hugsql-queries at " (t/now)) + "See [Application Description Language](https://github.com/simon-brooke/adl).") + (map + #(:query %) + (sort + #(compare (:name %1) (:name %2)) + (vals + (queries application))))))) + (if (> *verbosity* 0) + (println (str "\tGenerated " filepath))) + (catch + Exception any + (println + (str + "ERROR: Exception " + (.getName (.getClass any)) + (.getMessage any) + " while printing " + filepath)))))) diff --git a/src/adl/to_json_routes.clj b/src/adl/to_json_routes.clj index afb0426..5464313 100644 --- a/src/adl/to_json_routes.clj +++ b/src/adl/to_json_routes.clj @@ -7,7 +7,7 @@ [clojure.xml :as x] [clj-time.core :as t] [clj-time.format :as f] - [adl.utils :refer :all] + [adl-support.utils :refer :all] [adl.to-hugsql-queries :refer [queries]])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -37,7 +37,6 @@ ;;; to-hugsql-queries, because essentially we need one JSON entry point to wrap ;;; each query. - (defn file-header [application] (list 'ns @@ -47,6 +46,7 @@ (f/unparse (f/formatters :basic-date-time) (t/now))) (list :require + '[adl-support.core :as support] '[clojure.java.io :as io] '[compojure.core :refer [defroutes GET POST]] '[hugsql.core :as hugsql] @@ -221,25 +221,37 @@ (defn to-json-routes [application] (let [handlers-map (make-handlers-map application) - filepath (str *output-path* (:name (:attrs application)) "/routes/auto_json.clj")] + filepath (str *output-path* "src/clj/" (:name (:attrs application)) "/routes/auto_json.clj")] (make-parents filepath) - (with-open [output (writer filepath)] - (binding [*out* output] - (doall - (map - (fn [f] - (pprint f) - (println "\n")) - (list - (file-header application) - (declarations handlers-map) - (defroutes handlers-map)))) - (doall - (map - (fn [h] - (pprint (:src (handlers-map h))) - (println) - h) - (sort (keys handlers-map)))))))) + (try + (with-open [output (writer filepath)] + (binding [*out* output] + (doall + (map + (fn [f] + (pprint f) + (println "\n")) + (list + (file-header application) + (declarations handlers-map) + (defroutes handlers-map)))) + (doall + (map + (fn [h] + (pprint (:src (handlers-map h))) + (println) + h) + (sort (keys handlers-map)))))) + (if (> *verbosity* 0) + (println (str "\tGenerated " filepath))) + (catch + Exception any + (println + (str + "ERROR: Exception " + (.getName (.getClass any)) + (.getMessage any) + " while printing " + filepath)))))) diff --git a/src/adl/to_psql.clj b/src/adl/to_psql.clj index 21156d8..ee7f549 100644 --- a/src/adl/to_psql.clj +++ b/src/adl/to_psql.clj @@ -7,7 +7,7 @@ [clojure.xml :as x] [clj-time.core :as t] [clj-time.format :as f] - [adl.utils :refer :all] + [adl-support.utils :refer :all] [adl.to-hugsql-queries :refer [queries]])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -47,65 +47,65 @@ ;; that the argument passed as `property` is indeed a property. (str (emit-field-type typedef nil application false) (cond - (:pattern (:attrs typedef)) - (str - " CONSTRAINT " - (gensym "pattern_") - " CHECK (" - (:name (:attrs property)) - " ~* '" (:pattern (:attrs typedef)) - "')") - (and (:maximum (:attrs typedef))(:minimum (:attrs typedef))) - ;; TODO: if base type is date, time or timestamp, values should be quoted. - (str - " CONSTRAINT " - (gensym "minmax_") - " CHECK (" - (:minimum (:attrs typedef)) - " < " - (:name (:attrs property)) - " AND " - (:name (:attrs property)) - " < " + (str + " CONSTRAINT " + (gensym "pattern_") + " CHECK (" + (:name (:attrs property)) + " ~* '" + (:pattern (:attrs typedef)) + "')") + (and (:maximum (:attrs typedef))(:minimum (:attrs typedef))) + ;; TODO: if base type is date, time or timestamp, values should be quoted. + (str + " CONSTRAINT " + (gensym "minmax_") + " CHECK (" + (:minimum (:attrs typedef)) + " < " + (:name (:attrs property)) + " AND " + (:name (:attrs property)) + " < " + (:maximum (:attrs typedef)) + ")") (:maximum (:attrs typedef)) - ")") - (:maximum (:attrs typedef)) - (str - " CONSTRAINT " - (gensym "max_") - " CHECK (" - (:name (:attrs property)) - " < " - (:maximum (:attrs typedef)) - ")") - (:minimum (:attrs typedef)) - (str - " CONSTRAINT " - (gensym "min_") - " CHECK (" + (str + " CONSTRAINT " + (gensym "max_") + " CHECK (" + (:name (:attrs property)) + " < " + (:maximum (:attrs typedef)) + ")") (:minimum (:attrs typedef)) - " < " - (:name (:attrs property))))))) + (str + " CONSTRAINT " + (gensym "min_") + " CHECK (" + (:minimum (:attrs typedef)) + " < " + (:name (:attrs property))))))) (defn emit-entity-field-type [property application] (let [farside (child - application - #(and - (entity? %) - (= (:name (:attrs %)) (:entity (:attrs property))))) + application + #(and + (entity? %) + (= (:name (:attrs %)) (:entity (:attrs property))))) key-properties (children-with-tag - (first (children-with-tag farside :key)) - :property)] + (first (children-with-tag farside :key)) + :property)] (if (> (count key-properties) 1) (str - "-- ERROR: cannot generate link to entity " - (:name (:attrs farside)) - " with compound primary key\n") - (emit-field-type (first key-properties) farside application false)))) + "-- ERROR: cannot generate link to entity " + (:name (:attrs farside)) + " with compound primary key\n") + (emit-field-type (first key-properties) farside application false)))) (defn emit-field-type @@ -114,24 +114,24 @@ "integer" (if key? "SERIAL" "INTEGER") "real" "DOUBLE PRECISION" ("string" "image" "uploadable") - (str "VARCHAR(" (:size (:attrs property)) ")") + (str "VARCHAR(" (:size (:attrs property)) ")") "defined" (emit-defined-field-type property application) "entity" (emit-entity-field-type property application) ("date" "time" "timestamp" "boolean" "text" "money") - (.toUpperCase (:type (:attrs property))) + (.toUpperCase (:type (:attrs property))) (str "-- ERROR: unknown type " (:type (:attrs property))))) (defn emit-link-field [property entity application] (emit-property - {:tag :property - :attrs {:name (str (:name (:attrs entity)) "_id") - :type "entity" - :entity (:name (:attrs entity)) - :cascade (:cascade (:attrs property))}} - entity - application)) + {:tag :property + :attrs {:name (str (:name (:attrs entity)) "_id") + :type "entity" + :entity (:name (:attrs entity)) + :cascade (:cascade (:attrs property))}} + entity + application)) (defn emit-permissions-grant @@ -182,68 +182,68 @@ (let [default (:default (:attrs property))] (if (and - (= (:tag property) :property) - (not (#{"link"} (:type (:attrs property))))) + (= (:tag property) :property) + (not (#{"link"} (:type (:attrs property))))) (s/join - " " - (remove - nil? - (flatten - (list - "\t" - (field-name property) - (emit-field-type property entity application key?) - (if - default + " " + (remove + nil? + (flatten (list - "DEFAULT" + "\t" + (field-name property) + (emit-field-type property entity application key?) (if - (is-quotable-type? property application) - (str "'" default "'") ;; TODO: but if the default value seems to be a function invocation, should it be quoted? - ;; it's quite common for 'now()' to be the default for a date, time or timestamp field. - default))) - (if - key? - "NOT NULL PRIMARY KEY" - (if (= (:required (:attrs property)) "true") "NOT NULL")))))))))) + default + (list + "DEFAULT" + (if + (is-quotable-type? property application) + (str "'" default "'") ;; TODO: but if the default value seems to be a function invocation, should it be quoted? + ;; it's quite common for 'now()' to be the default for a date, time or timestamp field. + default))) + (if + key? + "NOT NULL PRIMARY KEY" + (if (= (:required (:attrs property)) "true") "NOT NULL")))))))))) (defn compose-convenience-entity-field [field entity application] (let [farside (child - application - #(and - (entity? %) - (= (:name (:attrs %)) (:entity (:attrs field)))))] + application + #(and + (entity? %) + (= (:name (:attrs %)) (:entity (:attrs field)))))] (flatten - (map - (fn [f] - (if - (= (:type (:attrs f)) "entity") - (compose-convenience-entity-field f farside application) - (str (safe-name (:table (:attrs farside))) "." (field-name f)))) - (user-distinct-properties farside))))) + (map + (fn [f] + (if + (= (:type (:attrs f)) "entity") + (compose-convenience-entity-field f farside application) + (str (safe-name (:table (:attrs farside))) "." (field-name f)))) + (user-distinct-properties farside))))) (defn compose-convenience-view-select-list [entity application top-level?] (remove - nil? - (flatten - (cons - (safe-name (:table (:attrs entity)) :sql) - (map - (fn [f] - (if - (= (:type (:attrs f)) "entity") - (compose-convenience-view-select-list - (child application #(and (entity? %) (= (:name (:attrs %))(:entity (:attrs f))))) - application - false))) - (if - top-level? - (all-properties entity) - (user-distinct-properties entity))))))) + nil? + (flatten + (cons + (safe-name (:table (:attrs entity)) :sql) + (map + (fn [f] + (if + (= (:type (:attrs f)) "entity") + (compose-convenience-view-select-list + (child application #(and (entity? %) (= (:name (:attrs %))(:entity (:attrs f))))) + application + false))) + (if + top-level? + (all-properties entity) + (user-distinct-properties entity))))))) (defn compose-convenience-where-clause @@ -251,37 +251,37 @@ ;; See lv_electors, lv_followuprequests for examples of the problem. [entity application top-level?] (remove - nil? - (flatten - (map - (fn [f] - (if - (= (:type (:attrs f)) "entity") - (let [farside (entity-for-property f application)] - (cons - (str - (safe-name (:table (:attrs entity)) :sql) - "." - (field-name f) - " = " - (safe-name (:table (:attrs farside)) :sql) - "." - (safe-name (first (key-names farside)) :sql)) - #(compose-convenience-where-clause farside application false))))) - (if - top-level? - (all-properties entity) - (user-distinct-properties entity)))))) + nil? + (flatten + (map + (fn [f] + (if + (= (:type (:attrs f)) "entity") + (let [farside (entity-for-property f application)] + (cons + (str + (safe-name (:table (:attrs entity)) :sql) + "." + (field-name f) + " = " + (safe-name (:table (:attrs farside)) :sql) + "." + (safe-name (first (key-names farside)) :sql)) + #(compose-convenience-where-clause farside application false))))) + (if + top-level? + (all-properties entity) + (user-distinct-properties entity)))))) (defn emit-convenience-entity-field [field entity application] (str - (s/join - " ||', '|| " - (compose-convenience-entity-field field entity application)) - " AS " - (field-name field) + (s/join + " ||', '|| " + (compose-convenience-entity-field field entity application)) + " AS " + (field-name field) "_expanded")) @@ -346,7 +346,7 @@ (safe-name (first (key-names farside)) :sql)))) entity-fields)))) ";" - (emit-permissions-grant view-name :SELECT (permissions entity application)))))))) + (emit-permissions-grant view-name :SELECT (find-permissions entity application)))))))) (defn emit-referential-integrity-link @@ -354,45 +354,45 @@ (let [farside (entity-for-property property application)] (s/join - " " - (list - "ALTER TABLE" - (safe-name (:name (:attrs nearside)) :sql) - "ADD CONSTRAINT" - (safe-name (str "ri_" (:name (:attrs nearside)) "_" (:name (:attrs farside)) "_" (:name (:attrs property))) :sql) - "\n\tFOREIGN KEY(" - (field-name property) - ") \n\tREFERENCES" - (str - (safe-name (:table (:attrs farside)) :sql) - "(" (field-name (first (key-properties farside))) ")") - ;; TODO: ought to handle the `cascade` attribute, even though it's rarely used - "\n\tON DELETE" - (case - (:cascade (:attrs property)) - "orphan" "SET NULL" - "delete" "CASCADE" - "NO ACTION") - ";")))) + " " + (list + "ALTER TABLE" + (safe-name (:name (:attrs nearside)) :sql) + "ADD CONSTRAINT" + (safe-name (str "ri_" (:name (:attrs nearside)) "_" (:name (:attrs farside)) "_" (:name (:attrs property))) :sql) + "\n\tFOREIGN KEY(" + (field-name property) + ") \n\tREFERENCES" + (str + (safe-name (:table (:attrs farside)) :sql) + "(" (field-name (first (key-properties farside))) ")") + ;; TODO: ought to handle the `cascade` attribute, even though it's rarely used + "\n\tON DELETE" + (case + (:cascade (:attrs property)) + "orphan" "SET NULL" + "delete" "CASCADE" + "NO ACTION") + ";")))) (defn emit-referential-integrity-links ([entity application] (map - #(emit-referential-integrity-link % entity application) - (sort-by-name - (filter - #(= (:type (:attrs %)) "entity") - (properties entity))))) + #(emit-referential-integrity-link % entity application) + (sort-by-name + (filter + #(= (:type (:attrs %)) "entity") + (properties entity))))) ([application] (flatten - (list - (emit-header - "--" - "referential integrity links for primary tables") - (map - #(emit-referential-integrity-links % application) - (sort-by-name (children-with-tag application :entity))))))) + (list + (emit-header + "--" + "referential integrity links for primary tables") + (map + #(emit-referential-integrity-links % application) + (sort-by-name (children-with-tag application :entity))))))) (defn emit-table @@ -400,48 +400,48 @@ (let [table-name (safe-name (:table (:attrs entity)) :sql) permissions (children-with-tag entity :permission)] (s/join - "\n" - (flatten - (list - (emit-header - "--" + "\n" + (flatten (list - doc-comment - (map - #(:content %) - (children-with-tag entity :documentation)))) - (s/join - " " - (list "CREATE TABLE" table-name)) - "(" - (str - (s/join - ",\n" - (flatten - (remove - nil? - (list - (map - #(emit-property % entity application true) - (children-with-tag (child-with-tag entity :key) :property)) - (map - #(emit-property % entity application false) - (filter - #(not (= (:type (:attrs %)) "link")) - (children-with-tag entity :property))))))) - "\n);") - (map - #(emit-permissions-grant table-name % permissions) - '(:SELECT :INSERT :UPDATE :DELETE))))))) + (emit-header + "--" + (list + doc-comment + (map + #(:content %) + (children-with-tag entity :documentation)))) + (s/join + " " + (list "CREATE TABLE" table-name)) + "(" + (str + (s/join + ",\n" + (flatten + (remove + nil? + (list + (map + #(emit-property % entity application true) + (children-with-tag (child-with-tag entity :key) :property)) + (map + #(emit-property % entity application false) + (filter + #(not (= (:type (:attrs %)) "link")) + (children-with-tag entity :property))))))) + "\n);") + (map + #(emit-permissions-grant table-name % permissions) + '(:SELECT :INSERT :UPDATE :DELETE))))))) ([entity application] (emit-table - entity - application - (str - "primary table " - (:table (:attrs entity)) - " for entity " - (:name (:attrs entity)))))) + entity + application + (str + "primary table " + (:table (:attrs entity)) + " for entity " + (:name (:attrs entity)))))) (defn construct-link-property @@ -457,117 +457,129 @@ (defn emit-link-table [property e1 application emitted-link-tables] (let [e2 (child - application - #(and - (entity? %) - (= (:name (:attrs %)) (:entity (:attrs property))))) + application + #(and + (entity? %) + (= (:name (:attrs %)) (:entity (:attrs property))))) link-table-name (link-table-name e1 e2)] (if ;; we haven't already emitted this one... (not (@emitted-link-tables link-table-name)) (let [permissions (flatten - (list - (children-with-tag e1 :permission) - (children-with-tag e1 :permission))) + (list + (children-with-tag e1 :permission) + (children-with-tag e1 :permission))) ;; construct a dummy entity link-entity {:tag :entity :attrs {:name link-table-name :table link-table-name} :content - (apply vector - (flatten - (list - [(construct-link-property e1) - (construct-link-property e2)] - permissions)))}] + (apply vector + (flatten + (list + [(construct-link-property e1) + (construct-link-property e2)] + permissions)))}] ;; mark it as emitted (swap! emitted-link-tables conj link-table-name) ;; emit it (flatten - (list - (emit-table - link-entity - application - (str - "link table joining " - (:name (:attrs e1)) - " with " - (:name (:attrs e2)))) - ;; and immediately emit its referential integrity links - (emit-referential-integrity-links link-entity application))))))) + (list + (emit-table + link-entity + application + (str + "link table joining " + (:name (:attrs e1)) + " with " + (:name (:attrs e2)))) + ;; and immediately emit its referential integrity links + (emit-referential-integrity-links link-entity application))))))) (defn emit-link-tables ([entity application emitted-link-tables] - (map - #(emit-link-table % entity application emitted-link-tables) - (sort-by-name - (filter - #(= (:type (:attrs %)) "link") - (properties entity))))) + (map + #(emit-link-table % entity application emitted-link-tables) + (sort-by-name + (filter + #(= (:type (:attrs %)) "link") + (properties entity))))) ([application emitted-link-tables] (map - #(emit-link-tables % application emitted-link-tables) - (sort-by-name (children-with-tag application :entity))))) + #(emit-link-tables % application emitted-link-tables) + (sort-by-name (children-with-tag application :entity))))) (defn emit-group-declaration [group application] (list - (emit-header - "--" - (str "security group " (:name (:attrs group)))) - (str "CREATE GROUP " (safe-name (:name (:attrs group)) :sql) ";"))) + (emit-header + "--" + (str "security group " (:name (:attrs group)))) + (str "CREATE GROUP " (safe-name (:name (:attrs group)) :sql) ";"))) (defn emit-file-header [application] (emit-header - "--" - "Database definition for application " - (str (:name (:attrs application)) - " version " - (:version (:attrs application))) - "auto-generated by [Application Description Language framework]" - (str "(https://github.com/simon-brooke/adl) at " - (f/unparse (f/formatters :basic-date-time) (t/now))) - (map - #(:content %) - (children-with-tag application :documentation)))) + "--" + "Database definition for application " + (str (:name (:attrs application)) + " version " + (:version (:attrs application))) + "auto-generated by [Application Description Language framework]" + (str "(https://github.com/simon-brooke/adl) at " + (f/unparse (f/formatters :basic-date-time) (t/now))) + (map + #(:content %) + (children-with-tag application :documentation)))) (defn emit-application [application] (let [emitted-link-tables (atom #{})] (s/join - "\n\n" - (flatten - (list - (emit-file-header application) - (map - #(emit-group-declaration % application) - (sort-by-name - (children-with-tag application :group))) - (map - #(emit-table % application) - (sort-by-name - (children-with-tag application :entity))) - (map - #(emit-convenience-view % application) - (sort-by-name - (children-with-tag application :entity))) - (emit-referential-integrity-links application) - (emit-link-tables application emitted-link-tables)))))) + "\n\n" + (flatten + (list + (emit-file-header application) + (map + #(emit-group-declaration % application) + (sort-by-name + (children-with-tag application :group))) + (map + #(emit-table % application) + (sort-by-name + (children-with-tag application :entity))) + (map + #(emit-convenience-view % application) + (sort-by-name + (children-with-tag application :entity))) + (emit-referential-integrity-links application) + (emit-link-tables application emitted-link-tables)))))) (defn to-psql [application] (let [filepath (str - *output-path* - "/resources/sql/" - (:name (:attrs application)) - ".postgres.sql")] + *output-path* + "resources/sql/" + (:name (:attrs application)) + ".postgres.sql")] (make-parents filepath) - (spit filepath (emit-application application)))) + (try + (spit filepath (emit-application application)) + (if (> *verbosity* 0) + (println (str "\tGenerated " filepath))) + (catch + Exception any + (println + (str + "ERROR: Exception " + (.getName (.getClass any)) + (.getMessage any) + " while printing " + filepath)))))) diff --git a/src/adl/to_reframe.clj b/src/adl/to_reframe.clj index c23536e..84a5c52 100644 --- a/src/adl/to_reframe.clj +++ b/src/adl/to_reframe.clj @@ -1,5 +1,5 @@ (ns adl.to-reframe - (:require [adl.utils :refer :all] + (:require [adl-support.utils :refer :all] [clojure.string :as s] [clj-time.core :as t] [clj-time.format :as f])) @@ -27,6 +27,9 @@ ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; TODO: not anywhere near finished. + + (defn file-header ([parent-name this-name extra-requires] (list 'ns (symbol (str parent-name ".views." this-name)) diff --git a/src/adl/to_selmer_routes.clj b/src/adl/to_selmer_routes.clj index 62170c1..fa2158d 100644 --- a/src/adl/to_selmer_routes.clj +++ b/src/adl/to_selmer_routes.clj @@ -1,13 +1,14 @@ (ns ^{:doc "Application Description Language: generate routes for user interface requests." :author "Simon Brooke"} adl.to-selmer-routes - (:require [clojure.java.io :refer [file make-parents writer]] + (:require [adl-support.utils :refer :all] + [clojure.java.io :refer [file make-parents writer]] [clojure.pprint :refer [pprint]] [clojure.string :as s] [clojure.xml :as x] [clj-time.core :as t] [clj-time.format :as f] - [adl.utils :refer :all])) + )) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; @@ -32,7 +33,11 @@ ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Generally. there's one route in the generated file for each Selmer template which has been generated. +;;; Generally. there's one route in the generated file for each Selmer +;;; template which has been generated. + +;;; TODO: there must be some more idiomatic way of generating all these +;;; functions. (defn file-header [application] @@ -44,6 +49,7 @@ (f/unparse (f/formatters :basic-date-time) (t/now))) (list :require + '[adl-support.core :as support] '[clojure.java.io :as io] '[compojure.core :refer [defroutes GET POST]] '[hugsql.core :as hugsql] @@ -61,25 +67,39 @@ 'defn (symbol n) (vector 'r) - (list 'let (vector 'p (list :params 'r)) ;; TODO: we must take key params out of just params, + (list 'let (vector + 'p + (list + 'merge + (list 'support/query-string-to-map (list :query-string 'r)) + (list :params 'r))) + ;; TODO: we must take key params out of just params, ;; but we should take all other params out of form-params - because we need the key to ;; load the form in the first place, but just accepting values of other params would ;; allow spoofing. (list 'l/render - (list 'resolve-template (str n ".html")) + (list 'support/resolve-template (str n ".html")) (merge {:title (capitalise (:name (:attrs f))) :params 'p} (case (:tag f) (:form :page) - {:record - (list 'if (list 'empty? (list 'remove 'nil? (list 'vals 'p))) [] - (list - (symbol - (str "db/get-" (singularise (:name (:attrs e))))) - (symbol "db/*db*") - 'p))} + (reduce + merge + {:record + (list 'if (list 'empty? (list 'remove 'nil? (list 'vals 'p))) [] + (list + (symbol + (str "db/get-" (singularise (:name (:attrs e))))) + (symbol "db/*db*") + 'p))} + (map + (fn [p] + (hash-map + (keyword (-> p :attrs :entity)) + (list (symbol (str "db/list-" (:entity (:attrs p)))) (symbol "db/*db*")))) + (filter #(= (:type (:attrs %)) "entity") (descendants-with-tag e :property)))) :list {:records (list @@ -167,43 +187,49 @@ (defn to-selmer-routes [application] - (let [filename (str *output-path* (:name (:attrs application)) "/routes/auto.clj")] - (make-parents filename) - (with-open [output (writer filename)] - (binding [*out* output] - (pprint (file-header application)) - (println) - (pprint '(defn raw-resolve-template [n] - (if - (.exists (io/as-file (str "resources/templates/" n))) - n - (str "auto/" n)))) - (println) - (pprint '(def resolve-template (memoize raw-resolve-template))) - (println) - (pprint '(defn index - [r] - (l/render - (resolve-template - "application-index.html") - {:title "Administrative menu"}))) - (println) - (doall - (map - (fn [e] - (doall - (map - (fn [c] - (pprint (make-handler c e application)) - (println)) - (filter (fn [c] (#{:form :list :page} (:tag c))) (children e))))) - (children-with-tag application :entity))) - (pprint - (generate-handler-resolver application)) - (println) - (pprint '(def resolve-handler - (memoize raw-resolve-handler))) - (println) - (pprint (make-defroutes application)) - (println))))) + (let [filepath (str *output-path* "src/clj/" (:name (:attrs application)) "/routes/auto.clj")] + (make-parents filepath) + (try + (with-open [output (writer filepath)] + (binding [*out* output] + (pprint (file-header application)) + (println) + (pprint '(defn admin + [r] + (l/render + (support/resolve-template + "application-index.html") + {:title "Administrative menu"}))) + (println) + (doall + (map + (fn [e] + (doall + (map + (fn [c] + (pprint (make-handler c e application)) + (println)) + (filter (fn [c] (#{:form :list :page} (:tag c))) (children e))))) + (sort + #(compare (:name (:attrs %1))(:name (:attrs %2))) + (children-with-tag application :entity)))) + (pprint + (generate-handler-resolver application)) + (println) + (pprint '(def resolve-handler + (memoize raw-resolve-handler))) + (println) + (pprint (make-defroutes application)) + (println))) + (if (> *verbosity* 0) + (println (str "\tGenerated " filepath))) + (catch + Exception any + (println + (str + "ERROR: Exception " + (.getName (.getClass any)) + (.getMessage any) + " while printing " + filepath)))))) diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj index 17aa062..9c8a8df 100644 --- a/src/adl/to_selmer_templates.clj +++ b/src/adl/to_selmer_templates.clj @@ -1,8 +1,8 @@ (ns ^{:doc "Application Description Language - generate Selmer templates for the HTML pages implied by an ADL file." :author "Simon Brooke"} adl.to-selmer-templates - (:require [adl.utils :refer :all] - [clojure.java.io :refer [file]] + (:require [adl-support.utils :refer :all] + [clojure.java.io :refer [file make-parents]] [clojure.pprint :as p] [clojure.string :as s] [clojure.xml :as x] @@ -145,7 +145,8 @@ (defn save-widget "Return an appropriate 'save' widget for this `form` operating on this `entity` taken - from this `application`." + from this `application`. + TODO: should be suppressed unless a member of a group which can insert or edit." [form entity application] {:tag :p :attrs {:class "widget action-safe"} @@ -156,13 +157,14 @@ :attrs {:id "save-button" :name "save-button" :class "action-safe" - :type :submit + :type "submit" :value (str "Save!")}}]}) (defn delete-widget "Return an appropriate 'save' widget for this `form` operating on this `entity` taken - from this `application`." + from this `application`. + TODO: should be suppressed unless member of a group which can delete." [form entity application] {:tag :p :attrs {:class "widget action-dangerous"} @@ -173,7 +175,7 @@ :attrs {:id "delete-button" :name "delete-button" :class "action-dangerous" - :type :submit + :type "submit" :value (str "Delete!")}}]}) @@ -259,21 +261,10 @@ :content (apply vector (get-options property form entity application))})))})) -(defn permissions-for - [property entity application] - (first - (remove - empty? - (list - (children-with-tag property :permission) - (children-with-tag entity :permission) - (children-with-tag application :permission))))) - - (defn compose-if-member-of-tag [property entity application writable?] (let - [all-permissions (permissions-for property entity application) + [all-permissions (find-permissions property entity application) permissions (if writable? (writable-by all-permissions) (visible-to all-permissions))] (s/join " " @@ -295,20 +286,18 @@ property (if (= (:tag field-or-property) :property) field-or-property - (first - (children - entity - #(and - (= (:tag %) :property) - (= (:name (:attrs %)) (:property (:attrs field-or-property))))))) - permissions (permissions property form entity application) + (child-with-tag entity + :property + #(= (:name (:attrs %)) + (:property (:attrs field-or-property))))) + permissions (find-permissions field-or-property property form entity application) typedef (typedef property application) visible-to (visible-to permissions) ;; if the form isn't actually a form, no widget is writable. writable-by (if (= (:tag form) :form) (writable-by permissions)) select? (#{"entity" "list" "link"} (:type (:attrs property)))] (if - (formal-primary-key? property entity) + (= (:distinct (:attrs property)) "system") {:tag :input :attrs {:id widget-name :name widget-name @@ -343,45 +332,44 @@ :name widget-name :class "pseudo-widget disabled"} :content [(str "{{record." widget-name "}}")]} + "{% else %}" + {:tag :span + :attrs {:id widget-name + :name widget-name + :class "pseudo-widget not-authorised"} + :content [(str "You are not permitted to view " widget-name " of " (:name (:attrs entity)))]} "{% endifmemberof %}" "{% endifmemberof %}"]}))) -(defn fields - [form] - (descendants-with-tag form :field)) - - - (defn form-to-template "Generate a template as specified by this `form` element for this `entity`, taken from this `application`. If `form` is nill, generate a default form template for the entity." [form entity application] - (let - [keyfields (children - ;; there should only be one key; its keys are properties - (first (children entity #(= (:tag %) :key))))] - {:tag :div - :attrs {:id "content" :class "edit"} - :content - [{:tag :form - :attrs {:action (str "{{servlet-context}}/" (editor-name entity application)) - :method "POST"} - :content (flatten - (list + {:tag :div + :attrs {:id "content" :class "edit"} + :content + [{:tag :form + :attrs {:action (str "{{servlet-context}}/" (editor-name entity application)) + :method "POST"} + :content (flatten + (list (csrf-widget) (map - #(widget % form entity application) - keyfields) + #(widget % form entity application) + (children-with-tag (child-with-tag entity :key) :properties)) (map - #(widget % form entity application) - (remove - #(= (:distict (:attrs %)) :system) - (fields entity))) + #(widget % form entity application) + (remove + #(let + [property (filter + (fn [p] (= (:name (:attrs p)) (:property (:attrs %)))) + (descendants-with-tag entity :property))] + (= (:distict (:attrs property)) :system)) + (children-with-tag form :field))) (save-widget form entity application) - (delete-widget form entity application)))}]})) - + (delete-widget form entity application)))}]}) (defn page-to-template @@ -434,7 +422,7 @@ #(hash-map :content [(prompt %)] :tag :th) - (fields list-spec)))} + (children-with-tag list-spec :field)))} {:tag :tr :content (apply @@ -442,7 +430,7 @@ (concat (map #(compose-list-search-widget % entity) - (fields list-spec)) + (children-with-tag list-spec :field)) '({:tag :th :content [{:tag :input @@ -492,7 +480,7 @@ :attrs {:href (edit-link e application (list (:name (:attrs p))))} :content [(str "{{ record." (:property (:attrs field)) "_expanded }}")]}] [c]))}) - (fields list-spec)) + (children-with-tag list-spec :field)) [{:tag :td :content [{:tag :a @@ -623,31 +611,35 @@ (defn write-template-file [filename template application] - (if - template - (try - (spit - (str *output-path* filename) - (s/join - "\n" - (list - (file-header filename application) - (with-out-str - (x/emit-element template)) - (file-footer filename application)))) - (catch Exception any + (let [filepath (str *output-path* "resources/templates/auto/" filename)] + (make-parents filepath) + (if + template + (try (spit - (str *output-path* filename) - (with-out-str - (println - (str - "")) - (p/pprint template)))))) - filename) + filepath + (s/join + "\n" + (list + (file-header filename application) + (with-out-str + (x/emit-element template)) + (file-footer filename application)))) + (if (> *verbosity* 0) (println "\tGenerated " filepath)) + (catch Exception any + (let [report (str + "ERROR: Exception " + (.getName (.getClass any)) + (.getMessage any) + " while printing " + filename)] + (spit + filepath + (with-out-str + (println (str "")) + (p/pprint template))) + (println report))))) + (str filepath))) (defn to-selmer-templates @@ -668,12 +660,13 @@ (try (write-template-file filename (templates-map %) application) (catch Exception any - (str - "Exception " - (.getName (.getClass any)) - (.getMessage any) - " while writing " - filename))))) + (println + (str + "ERROR: Exception " + (.getName (.getClass any)) + (.getMessage any) + " while writing " + filename)))))) (keys templates-map))))) diff --git a/src/adl/utils.clj b/src/adl/utils.clj deleted file mode 100644 index 09888cc..0000000 --- a/src/adl/utils.clj +++ /dev/null @@ -1,457 +0,0 @@ -(ns ^{:doc "Application Description Language - utility functions." - :author "Simon Brooke"} - adl.utils - (:require [clojure.string :as s] - [clojure.pprint :as p] - [clojure.xml :as x] - [adl.validator :refer [valid-adl? validate-adl]])) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; -;;;; adl.utils: utility functions. -;;;; -;;;; 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 -;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -(def ^:dynamic *locale* - "The locale for which files will be generated." - "en-GB") - -(def ^:dynamic *output-path* - "The path to which generated files will be written." - "resources/auto/") - - -(defn element? - "True if `o` is a Clojure representation of an XML element." - [o] - (and (map? o) (:tag o) (:attrs o))) - - -(defn wrap-lines - "Wrap lines in this `text` to this `width`; return a list of lines." - ;; Shamelessly adapted from https://www.rosettacode.org/wiki/Word_wrap#Clojure - [width text] - (s/split-lines - (p/cl-format - nil - (str "~{~<~%~1," width ":;~A~> ~}") - (clojure.string/split text #" ")))) - - -(defn emit-header - "Emit this `content` as a sequence of wrapped lines each prefixed with - `prefix`, and the whole delimited by rules." - [prefix & content] - (let [comment-rule (apply str (repeat 70 (last prefix))) - p (str "\n" prefix "\t") ] - (str - prefix - comment-rule - p - (s/join - p - (flatten - (interpose - "" - (map - #(wrap-lines 70 (str %)) - (flatten content))))) - "\n" - prefix - comment-rule))) - - -(defn sort-by-name - [elements] - (sort #(compare (:name (:attrs %1)) (:name (:attrs %2))) elements)) - - -(defn link-table-name - "Canonical name of a link table between entity `e1` and entity `e2`." - [e1 e2] - (s/join - "_" - (cons - "ln" - (sort - (list - (:name (:attrs e1)) (:name (:attrs e2))))))) - - -(defn children - "Return the children of this `element`; if `predicate` is passed, return only those - children satisfying the predicate." - ([element] - (if - (keyword? (:tag element)) ;; it has a tag; it seems to be an XML element - (:content element))) - ([element predicate] - (filter - predicate - (children element)))) - - -(defn child - "Return the first child of this `element` satisfying this `predicate`." - [element predicate] - (first (children element predicate))) - - -(defn attributes - "Return the attributes of this `element`; if `predicate` is passed, return only those - attributes satisfying the predicate." - ([element] - (if - (keyword? (:tag element)) ;; it has a tag; it seems to be an XML element - (:attrs element))) - ([element predicate] - (filter - predicate - (attributes element)))) - - -(defn typedef - "If this `property` is of type `defined`, return its type definition from - this `application`, else nil." - [property application] - (if - (= (:type (:attrs property)) "defined") - (child - application - #(and - (= (:tag %) :typedef) - (= (:name (:attrs %)) (:typedef (:attrs property))))))) - - -(defn permissions - "Return appropriate permissions of this `property`, taken from this `entity` of this - `application`, in the context of this `page`." - ([property page entity application] - (first - (remove - empty? - (list - (children page #(= (:tag %) :permission)) - (children property #(= (:tag %) :permission)) - (children entity #(= (:tag %) :permission)) - (children application #(= (:tag %) :permission)))))) - ([property entity application] - (permissions property nil entity application)) - ([entity application] - (permissions nil nil entity application))) - - -(defn permission-groups - "Return a list of names of groups to which this `predicate` is true of - some permission taken from these `permissions`, else nil." - [permissions predicate] - (let [groups (remove - nil? - (map - #(if - (apply predicate (list %)) - (:group (:attrs %))) - permissions))] - (if groups groups))) - - -(defn formal-primary-key? - "Does this `prop-or-name` appear to be a property (or the name of a property) - which is a formal primary key of this entity?" - [prop-or-name entity] - (if - (map? prop-or-name) - (formal-primary-key? (:name (:attrs prop-or-name)) entity) - (let [primary-key (first (children entity #(= (:tag %) :key))) - property (first - (children - primary-key - #(and - (= (:tag %) :property) - (= (:name (:attrs %)) prop-or-name))))] - (= (:distinct (:attrs property)) "system")))) - - -(defn entity? - "Return true if `x` is an ADL entity." - [x] - (= (:tag x) :entity)) - - -(defn property? - "True if `o` is a property." - [o] - (= (:tag o) :property)) - - -(defn entity-for-property - "If this `property` references an entity, return that entity from this `application`" - [property application] - (if - (and (property? property) (:entity (:attrs property))) - (child - application - #(and - (entity? %) - (= (:name (:attrs %))(:entity (:attrs property))))))) - - -(defn visible-to - "Return a list of names of groups to which are granted read access, - given these `permissions`, else nil." - [permissions] - (permission-groups permissions #(#{"read" "insert" "noedit" "edit" "all"} (:permission (:attrs %))))) - - -(defn writable-by - "Return a list of names of groups to which are granted write access, - given these `permissions`, else nil. - TODO: TOTHINKABOUT: properties are also writable by `insert` and `noedit`, but only if the - current value is nil." - [permissions] - (permission-groups permissions #(#{"edit" "all"} (:permission (:attrs %))))) - - -(defn singularise - "Attempt to construct an idiomatic English-language singular of this string." - [string] - (cond - (.endsWith string "ss") string - (.endsWith string "ise") string - true - (s/replace - (s/replace - (s/replace - (s/replace string #"_" "-") - #"s$" "") - #"se$" "s") - #"ie$" "y"))) - - -(defn capitalise - "Return a string like `s` but with each token capitalised." - [s] - (s/join - " " - (map - #(apply str (cons (Character/toUpperCase (first %)) (rest %))) - (s/split s #"[ \t\r\n]+")))) - - -(defn pretty-name - [entity] - (capitalise (singularise (:name (:attrs entity))))) - - -(defn safe-name - "Return a safe name for the object `o`, given the specified `convention`. - `o` is expected to be either a string or an entity." - ([o] - (if - (element? o) - (safe-name (:name (:attrs o))) - (s/replace (str o) #"[^a-zA-Z0-9-]" ""))) - ([o convention] - (if - (element? o) - (safe-name (:name (:attrs o)) convention) - (let [string (str o)] - (case convention - (:sql :c) (s/replace string #"[^a-zA-Z0-9_]" "_") - :c-sharp (s/replace (capitalise string) #"[^a-zA-Z0-9]" "") - :java (let - [camel (s/replace (capitalise string) #"[^a-zA-Z0-9]" "")] - (apply str (cons (Character/toLowerCase (first camel)) (rest camel)))) - (safe-name string)))))) - - -(defn read-adl [url] - (let [adl (x/parse url) - valid? (valid-adl? adl)] - (if valid? adl - (throw (Exception. (str (validate-adl adl))))))) - - -(defn children-with-tag - "Return all children of this `element` which have this `tag`; - if `element` is `nil`, return `nil`." - [element tag] - (if - element - (children element #(= (:tag %) tag)))) - - -(defn child-with-tag - "Return the first child of this `element` which has this `tag`; - if `element` is `nil`, return `nil`." - [element tag] - (first (children-with-tag element tag))) - - -(defmacro properties - "Return all the properties of this `entity`." - [entity] - `(children-with-tag ~entity :property)) - - -(defn descendants-with-tag - "Return all descendants of this `element`, recursively, which have this `tag`." - [element tag] - (flatten - (remove - empty? - (cons - (children element #(= (:tag %) tag)) - (map - #(descendants-with-tag % tag) - (children element)))))) - - -(defn insertable? - "Return `true` it the value of this `property` may be set from user-supplied data." - [property] - (and - (= (:tag property) :property) - (not (#{"link"} (:type (:attrs property)))) - (not (= (:distinct (:attrs property)) "system")))) - - -(defmacro all-properties - "Return all properties of this `entity` (including key properties)." - [entity] - `(descendants-with-tag ~entity :property)) - - -(defn user-distinct-properties - "Return the properties of this `entity` which are user distinct" - [entity] - (filter #(#{"user" "all"} (:distinct (:attrs %))) (all-properties entity))) - - -(defmacro insertable-properties - "Return all the properties of this `entity` (including key properties) into - which user-supplied data can be inserted" - [entity] - `(filter - insertable? - (all-properties ~entity))) - - -(defmacro key-properties - [entity] - `(children-with-tag (first (children-with-tag ~entity :key)) :property)) - - -(defmacro insertable-key-properties - [entity] - `(filter insertable? (key-properties entity))) - - -(defn link-table? - "Return true if this `entity` represents a link table." - [entity] - (let [properties (all-properties entity) - links (filter #(-> % :attrs :entity) properties)] - (= (count properties) (count links)))) - - -(defn key-names [entity] - (remove - nil? - (map - #(:name (:attrs %)) - (key-properties entity)))) - - -(defn base-type - [property application] - (cond - (:typedef (:attrs property)) - (:type - (:attrs - (child - application - #(and - (= (:tag %) :typedef) - (= (:name (:attrs %)) (:typedef (:attrs property))))))) - (:entity (:attrs property)) - (:type - (:attrs - (first - (key-properties - (child - application - #(and - (= (:tag %) :entity) - (= (:name (:attrs %)) (:entity (:attrs property))))))))) - true - (:type (:attrs property)))) - - -(defn is-quotable-type? - "True if the value for this field should be quoted." - [property application] - (#{"date" "image" "string" "text" "time" "timestamp" "uploadable"} (base-type property application))) - - -(defn has-primary-key? [entity] - (> (count (key-names entity)) 0)) - - -(defn has-non-key-properties? [entity] - (> - (count (all-properties entity)) - (count (key-properties entity)))) - - -(defn distinct-properties - [entity] - (filter - #(#{"system" "all"} (:distinct (:attrs %))) - (properties entity))) - -(defn path-part - "Return the URL path part for this `form` of this `entity` within this `application`. - Note that `form` may be a Clojure XML representation of a `form`, `list` or `page` - ADL element, or may be one of the keywords `:form`, `:list`, `:page` in which case the - first child of the `entity` of the specified type will be used." - [form entity application] - (cond - (and (map? form) (#{:list :form :page} (:tag form))) - (s/join - "-" - (flatten - (list - (name (:tag form)) (:name (:attrs entity)) (s/split (:name (:attrs form)) #"[ \n\r\t]+")))) - (keyword? form) - (path-part (first (children-with-tag entity form)) entity application))) - - -(defn editor-name - "Return the path-part of the editor form for this `entity`. Note: - assumes the editor form is the first form listed for the entity." - [entity application] - (path-part :form entity application)) - - -(defn type-for-defined - [property application] - (:type (:attrs (typedef property application)))) diff --git a/src/adl/validator.clj b/src/adl/validator.clj index 9513542..8602f90 100644 --- a/src/adl/validator.clj +++ b/src/adl/validator.clj @@ -1,7 +1,9 @@ (ns ^{:doc "Application Description Language: validator for ADL structure." :author "Simon Brooke"} adl.validator - (:require [clojure.set :refer [union]] + (:require [adl-support.utils :refer :all] + [clojure.set :refer [union]] + [clojure.xml :refer [parse]] [bouncer.core :as b] [bouncer.validators :as v])) @@ -28,44 +30,55 @@ ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; TODO: more work needed; I *think* this is finding spurious errors, and in any +;;; case it is failing to usefully locate the errors it is finding, so its +;;; diagnostic usefulness is small. -(defn disjunct-valid? + +(defn try-validate + [o validation] + (if + (symbol? validation) + (try + (b/validate o validation) + (catch java.lang.ClassCastException c + ;; The validator regularly barfs on strings, which are perfectly + ;; valid content of some elements. I need a way to validate + ;; elements where they're not tolerated! + (if (string? o) [nil o])) + (catch Exception e + [{:error (.getName (.getClass e)) + :message (.getMessage e) + :validation validation + :context o} o])) + [(str "Error: not a symbol" validation) o])) + +(defmacro disjunct-valid? ;; Yes, this is a horrible hack. I should be returning the error structure ;; not printing it. But I can't see how to make that work with `bouncer`. ;; OK, so: most of the validators will (usually) fail, and that's OK. How ;; do we identify the one which ought not to have failed? [o & validations] - (println + `(println (str - (if (:tag o) (str "Tag: " (:tag o) "; ")) - (if (:name (:attrs o)) (str "Name: " (:name (:attrs o)) ";")) - (if-not (or (:tag o) (:name (:attrs o))) (str "Context: " o)))) + (if (:tag ~o) (str "Tag: " (:tag ~o) "; ")) + (if (:name (:attrs ~o)) (str "Name: " (:name (:attrs ~o)) ";")) + (if-not (or (:tag ~o) (:name (:attrs ~o))) (str "Context: " ~o)))) - (let - [rs (map - #(try - (b/validate o %) - (catch java.lang.ClassCastException c - ;; The validator regularly barfs on strings, which are perfectly - ;; valid content of some elements. I need a way to validate - ;; elements where they're not tolerated! - [nil o]) - (catch Exception e - [{:exception (.getMessage e) - :class (type e) - :context o} o])) - validations) - all-candidates (remove nil? (map first rs)) - suspicious (remove :tag all-candidates)] - ;; if *any* succeeded, we succeeded - ;; otherwise, one of these is the valid error - but which? The answer, in my case - ;; is that if there is any which did not fail on the :tag check, then that is the - ;; interesting one. But generally? - (try - (doall (map #(println (str "\tError: " %)) suspicious)) - (empty? suspicious) - (catch Exception _ (println "Error while trying to print errors") - true)))) + `(empty? + (remove :tag (remove nil? (map first (map + #(try-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? +;; (try +;; (doall (map #(println (str "ERROR: " %)) suspicious)) +;; (empty? suspicious) +;; (catch Exception _ (println "ERROR while trying to print errors") +;; true)))) ;;; the remainder of this file is a fairly straight translation of the ADL 1.4 DTD into Clojure @@ -440,14 +453,15 @@ [:attrs :column] v/string [:attrs :concrete] [[v/member #{"true", "false"}]] [:attrs :cascade] [[v/member cascade-actions]] - :content [[v/every #(disjunct-valid? % - documentation-validations - generator-validations - permission-validations - option-validations - prompt-validations - help-validations - ifmissing-validations)]]}) +;; :content [[v/every #(disjunct-valid? % +;; documentation-validations +;; generator-validations +;; permission-validations +;; option-validations +;; prompt-validations +;; help-validations +;; ifmissing-validations)]] + }) (def permission-validations @@ -657,3 +671,8 @@ (defn validate-adl [src] (b/validate src application-validations)) + +(defn validate-adl-file [filepath] + (validate-adl (parse filepath))) + + From 9bf773a978c4719b0aaf3becb1b2e5f9c0d0d9f5 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 20 Jun 2018 10:12:47 +0100 Subject: [PATCH 31/52] Updated README to take account of the fact this is beginning to work. --- README.md | 21 ++++++++++++++++++++- 1 file changed, 20 insertions(+), 1 deletion(-) diff --git a/README.md b/README.md index e35ec34..a0e8527 100644 --- a/README.md +++ b/README.md @@ -2,6 +2,21 @@ A language for describing applications, from which code can be automatically generated. +## Usage + +A document describing the proposed application should be written in XML using the DTD `resources/schemas/adl-1.4.1.dtd`. It may then be transformed into a C# or Java application using the XSL transforms, see **History** below, but this code is very out of date and the resulting application is unlikely to be very usable. Alternatively, it can be transformed into a Clojure [Luminus](http://www.luminusweb.net/) application using the Clojure transformation, as follows: + + simon@fletcher:~/workspace/adl$ java -jar target/adl-1.4.1-SNAPSHOT-standalone.jar --help + Usage: java -jar adl-[VERSION]-SNAPSHOT-standalone.jar -options [adl-file] + where options include: + -a, --abstract-key-name-convention [string]: the abstract key name convention to use for generated key fields (TODO: not yet implemented); (default: id) + -h, --help: Show this message + -l, --locale [LOCALE]: set the locale to generate; (default: en_GB.UTF-8) + -p, --path [PATH]: The path under which generated files should be written; (default: generated) + -v, --verbosity [LEVEL], : Verbosity level - integer value required; (default: 0) + +This is not yet complete but it is at an advanced stage and already produces code which is useful. + ## History This idea started back in 2007, when I felt that web development in Java had really reached the end of the road - one spent all one's time writing boilerplate, and the amount of time taken to achieve anything useful had expanded far beyond common sense. So I thought: write one high level document describing an application; write a series of transforms from that document to the different files required to build the application; and a great deal of time would be saved. @@ -26,6 +41,10 @@ The idea is that the ADL framework should autogenerate 95% of your application. A Document Type Definition is the core of this; the current version is `adl-1.4.dtd`. +### The Clojure transformer application + +This is the future direction of the project. Currently it converts a valid ADL XML document into most of the files required for a Clojure web-app. Shortly it will produce a complete Clojure [Luminus](http://www.luminusweb.net/) web-app. In future it may produce web-apps in other languages and frameworks. + ### XSL transforms XSL transforms exist which transform conforming documents as follows: @@ -54,6 +73,6 @@ I will happily accept pull requests for new XSL transforms (although I'd like so ## License -Copyright © Simon Brooke 2007-2018 +Copyright © Simon Brooke 2007-2018; some work was done under contract to Cygnet Solutions Ltd, but they have kindly transferred the copyright back to me. Distributed under the Gnu GPL version 2 or any later version; I am open to licensing this project under additional licences if required. From ea9341145eb188df2ddf36759899ae80502ebb5c Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 20 Jun 2018 10:12:47 +0100 Subject: [PATCH 32/52] Updated README to take account of the fact this is beginning to work. --- README.md | 21 ++++++++++++++++++++- 1 file changed, 20 insertions(+), 1 deletion(-) diff --git a/README.md b/README.md index e35ec34..ad18847 100644 --- a/README.md +++ b/README.md @@ -2,6 +2,21 @@ A language for describing applications, from which code can be automatically generated. +## Usage + +A document describing the proposed application should be written in XML using the DTD `resources/schemas/adl-1.4.1.dtd`. It may then be transformed into a C# or Java application using the XSL transforms, see **History** below, but this code is very out of date and the resulting application is unlikely to be very usable. Alternatively, it can be transformed into a Clojure [Luminus](http://www.luminusweb.net/) application using the Clojure transformation, as follows: + + simon@fletcher:~/workspace/adl$ java -jar target/adl-1.4.1-SNAPSHOT-standalone.jar --help + Usage: java -jar adl-[VERSION]-SNAPSHOT-standalone.jar -options [adl-file] + where options include: + -a, --abstract-key-name-convention [string]: the abstract key name convention to use for generated key fields (TODO: not yet implemented); (default: id) + -h, --help: Show this message + -l, --locale [LOCALE]: set the locale to generate; (default: en_GB.UTF-8) + -p, --path [PATH]: The path under which generated files should be written; (default: generated) + -v, --verbosity [LEVEL], : Verbosity level - integer value required; (default: 0) + +This is not yet complete but it is at an advanced stage and already produces code which is useful. + ## History This idea started back in 2007, when I felt that web development in Java had really reached the end of the road - one spent all one's time writing boilerplate, and the amount of time taken to achieve anything useful had expanded far beyond common sense. So I thought: write one high level document describing an application; write a series of transforms from that document to the different files required to build the application; and a great deal of time would be saved. @@ -26,6 +41,10 @@ The idea is that the ADL framework should autogenerate 95% of your application. A Document Type Definition is the core of this; the current version is `adl-1.4.dtd`. +### The Clojure transformer application + +This is the future direction of the project. Currently it converts a valid ADL XML document into most of the files required for a Clojure web-app. Shortly it will produce a complete Clojure [Luminus](http://www.luminusweb.net/) web-app. In future it may produce web-apps in other languages and frameworks. + ### XSL transforms XSL transforms exist which transform conforming documents as follows: @@ -54,6 +73,6 @@ I will happily accept pull requests for new XSL transforms (although I'd like so ## License -Copyright © Simon Brooke 2007-2018 +Copyright © Simon Brooke 2007-2018; some work was done under contract to [Cygnet Solutions Ltd](http://cygnets.co.uk/), but they have kindly transferred the copyright back to me. Distributed under the Gnu GPL version 2 or any later version; I am open to licensing this project under additional licences if required. From 3320cff4b5332c310221300dc1e3efb5e2342ab4 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 29 Jun 2018 11:14:42 +0100 Subject: [PATCH 33/52] Substantial improvements --- src/adl/to_hugsql_queries.clj | 50 +++++++++++++++++---------------- src/adl/to_selmer_routes.clj | 7 ++--- src/adl/to_selmer_templates.clj | 13 ++++++++- 3 files changed, 40 insertions(+), 30 deletions(-) diff --git a/src/adl/to_hugsql_queries.clj b/src/adl/to_hugsql_queries.clj index 4a983ab..a79f174 100644 --- a/src/adl/to_hugsql_queries.clj +++ b/src/adl/to_hugsql_queries.clj @@ -165,31 +165,33 @@ pretty-name " records having any string field matching the parameter of the same name by substring match") (str "SELECT * FROM lv_" entity-name) - "WHERE " (s/join - "\n\tOR " - (filter - string? - (map - #(case (:type (:attrs %)) - ("string" "text") - (str - (safe-name (-> % :attrs :name) :sql) - " LIKE '%params." - (-> % :attrs :name) "%'") - ("date" "time" "timestamp") - (str - (safe-name (-> % :attrs :name) :sql) - " = 'params." - (-> % :attrs :name) "'") - (str - (safe-name (-> % :attrs :name) :sql) - " = params." - (-> % :attrs :name))) - properties))) - (order-by-clause entity "lv_") - "--~ (if (:offset params) \"OFFSET :offset \")" - "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))}))) + "\n\t--~ " + (cons + "WHERE false" + (filter + string? + (map + #(str + "(if (:" (-> % :attrs :name) " params) \"OR " + (case (:type (:attrs %)) + ("string" "text" "defined") ;; TODO: 'defined' types may be string or number - more work here + (str + (safe-name (-> % :attrs :name) :sql) + " LIKE '%:" (-> % :attrs :name) "%'") + ("date" "time" "timestamp") + (str + (safe-name (-> % :attrs :name) :sql) + " = ':" (-> % :attrs :name) "'") + (str + (safe-name (-> % :attrs :name) :sql) + " = :" + (-> % :attrs :name))) + "\")") + properties)))) + (order-by-clause entity "lv_") + "--~ (if (:offset params) \"OFFSET :offset \")" + "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))}))) (defn select-query diff --git a/src/adl/to_selmer_routes.clj b/src/adl/to_selmer_routes.clj index fa2158d..acaa24f 100644 --- a/src/adl/to_selmer_routes.clj +++ b/src/adl/to_selmer_routes.clj @@ -69,10 +69,7 @@ (vector 'r) (list 'let (vector 'p - (list - 'merge - (list 'support/query-string-to-map (list :query-string 'r)) - (list :params 'r))) + (list 'support/massage-params (list :params 'r))) ;; TODO: we must take key params out of just params, ;; but we should take all other params out of form-params - because we need the key to ;; load the form in the first place, but just accepting values of other params would @@ -194,7 +191,7 @@ (binding [*out* output] (pprint (file-header application)) (println) - (pprint '(defn admin + (pprint '(defn index [r] (l/render (support/resolve-template diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj index 9c8a8df..c8d6d3e 100644 --- a/src/adl/to_selmer_templates.clj +++ b/src/adl/to_selmer_templates.clj @@ -318,7 +318,18 @@ {:id widget-name :name widget-name :type (widget-type property application typedef) - :value (str "{{record." widget-name "}}")} + :value (str "{{record." widget-name "}}") + :maxlength (:size (:attrs property)) + :size (cond + (nil? (:size (:attrs property))) + "16" + (try + (> (read-string + (:size (:attrs property))) 60) + (catch Exception _ false)) + "60" + true + (:size (:attrs property)))} (if (:minimum (:attrs typedef)) {:min (:minimum (:attrs typedef))}) From 9d086f7028064cb77c741c0ba13cae5537f59e3b Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 29 Jun 2018 18:40:29 +0100 Subject: [PATCH 34/52] Minor fixes and tidyings --- src/adl/to_psql.clj | 4 ++-- src/adl/to_selmer_routes.clj | 2 +- src/adl/to_selmer_templates.clj | 13 ++++++++----- 3 files changed, 11 insertions(+), 8 deletions(-) diff --git a/src/adl/to_psql.clj b/src/adl/to_psql.clj index ee7f549..f7aea86 100644 --- a/src/adl/to_psql.clj +++ b/src/adl/to_psql.clj @@ -447,8 +447,8 @@ (defn construct-link-property [entity] {:tag :property - :attrs {:name (safe-name (str (:name (:attrs entity)) "_id") :sql) - :column (safe-name (str (:name (:attrs entity)) "_id") :sql) + :attrs {:name (safe-name (str (singularise (:name (:attrs entity))) "_id") :sql) + :column (safe-name (str (singularise (:name (:attrs entity))) "_id") :sql) :type "entity" :entity (:name (:attrs entity)) :farkey (safe-name (first (key-names entity)) :sql)}}) diff --git a/src/adl/to_selmer_routes.clj b/src/adl/to_selmer_routes.clj index acaa24f..50a1585 100644 --- a/src/adl/to_selmer_routes.clj +++ b/src/adl/to_selmer_routes.clj @@ -150,7 +150,7 @@ 'auto-selmer-routes (cons '(GET - "/index" + "/admin" request (route/restricted (apply (resolve-handler "index") (list request)))) diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj index c8d6d3e..b4feb07 100644 --- a/src/adl/to_selmer_templates.clj +++ b/src/adl/to_selmer_templates.clj @@ -405,9 +405,11 @@ "time" "time" "text") base-name (:property (:attrs field)) - search-name (if - (= (:type (:attrs property)) "entity") - (str base-name "_expanded") base-name)] + search-name (safe-name + (if + (= (:type (:attrs property)) "entity") + (str base-name "_expanded") base-name) + :sql)] (hash-map :tag :th :content @@ -480,16 +482,17 @@ {:tag :td :content (let [p (first (filter #(= (:name (:attrs %)) (:property (:attrs field))) (all-properties entity))) + s (safe-name (:name (:attrs p)) :sql) e (first (filter #(= (:name (:attrs %)) (:entity (:attrs p))) (children-with-tag application :entity))) - c (str "{{ record." (:property (:attrs field)) " }}")] + c (str "{{ record." s " }}")] (if (= (:type (:attrs p)) "entity") [{:tag :a :attrs {:href (edit-link e application (list (:name (:attrs p))))} - :content [(str "{{ record." (:property (:attrs field)) "_expanded }}")]}] + :content [(str "{{ record." s "_expanded }}")]}] [c]))}) (children-with-tag list-spec :field)) [{:tag :td From 7ea6b5f29990fda39caec87f9c47c31a174e1eae Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 29 Jun 2018 23:37:55 +0100 Subject: [PATCH 35/52] Detail work, improving robustness and presentation. --- src/adl/to_hugsql_queries.clj | 14 +++++++------- src/adl/to_selmer_routes.clj | 4 +++- src/adl/to_selmer_templates.clj | 17 ++++++++++++----- 3 files changed, 22 insertions(+), 13 deletions(-) diff --git a/src/adl/to_hugsql_queries.clj b/src/adl/to_hugsql_queries.clj index a79f174..673023d 100644 --- a/src/adl/to_hugsql_queries.clj +++ b/src/adl/to_hugsql_queries.clj @@ -140,7 +140,7 @@ {})) -(defn search-query [entity] +(defn search-query [entity application] "Generate an appropriate search query for string fields of this `entity`" (let [entity-name (safe-name (:name (:attrs entity)) :sql) pretty-name (singularise entity-name) @@ -164,7 +164,7 @@ "-- :doc selects existing " pretty-name " records having any string field matching the parameter of the same name by substring match") - (str "SELECT * FROM lv_" entity-name) + (str "SELECT DISTINCT * FROM lv_" entity-name) (s/join "\n\t--~ " (cons @@ -174,8 +174,8 @@ (map #(str "(if (:" (-> % :attrs :name) " params) \"OR " - (case (:type (:attrs %)) - ("string" "text" "defined") ;; TODO: 'defined' types may be string or number - more work here + (case (base-type % application) + ("string" "text") (str (safe-name (-> % :attrs :name) :sql) " LIKE '%:" (-> % :attrs :name) "%'") @@ -257,7 +257,7 @@ (list (str "-- :name " query-name " " signature) (str "-- :doc lists all existing " pretty-name " records") - (str "SELECT * FROM lv_" entity-name) + (str "SELECT DISTINCT * FROM lv_" entity-name) (order-by-clause entity "lv_") "--~ (if (:offset params) \"OFFSET :offset \")" "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))}))) @@ -359,7 +359,7 @@ (list (str "-- :name " query-name " " signature) (str "-- :doc lists all existing " near-name " records related through " link-name " to a given " pretty-far ) - (str "SELECT "near-name ".*") + (str "SELECT DISTINCT "near-name ".*") (str "FROM " near-name ", " link-name ) (str "WHERE " near-name "." (first (key-names near)) " = " link-name "." (singularise near-name) "_id" ) ("\tAND " link-name "." (singularise far-name) "_id = :id") @@ -428,7 +428,7 @@ (delete-query entity) (select-query entity) (list-query entity) - (search-query entity) + (search-query entity application) (foreign-queries entity application))) ([application] (apply diff --git a/src/adl/to_selmer_routes.clj b/src/adl/to_selmer_routes.clj index 50a1585..645a640 100644 --- a/src/adl/to_selmer_routes.clj +++ b/src/adl/to_selmer_routes.clj @@ -77,6 +77,7 @@ (list 'l/render (list 'support/resolve-template (str n ".html")) + '(:session r) (merge {:title (capitalise (:name (:attrs f))) :params 'p} @@ -96,7 +97,8 @@ (hash-map (keyword (-> p :attrs :entity)) (list (symbol (str "db/list-" (:entity (:attrs p)))) (symbol "db/*db*")))) - (filter #(= (:type (:attrs %)) "entity") (descendants-with-tag e :property)))) + (filter #(#{"entity" "link"} (:type (:attrs %))) + (descendants-with-tag e :property)))) :list {:records (list diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj index b4feb07..640af91 100644 --- a/src/adl/to_selmer_templates.clj +++ b/src/adl/to_selmer_templates.clj @@ -132,7 +132,6 @@ #(and (= (:tag %) :prompt) (= (:locale :attrs %) *locale*)))) - (:name (:attrs field-or-property)) (:property (:attrs field-or-property))))) @@ -265,7 +264,12 @@ [property entity application writable?] (let [all-permissions (find-permissions property entity application) - permissions (if writable? (writable-by all-permissions) (visible-to all-permissions))] + permissions (map + s/lower-case + (if + writable? + (writable-by all-permissions) + (visible-to all-permissions)))] (s/join " " (flatten @@ -590,9 +594,12 @@ (defn application-to-template [application] (let - [first-class-entities (filter - #(children-with-tag % :list) - (children-with-tag application :entity))] + [first-class-entities + (sort-by + #(:name (:attrs %)) + (filter + #(children-with-tag % :list) + (children-with-tag application :entity)))] {:application-index {:tag :dl :attrs {:class "index"} From a4e0fd1c9a32408bda86b9677c1a00b4f9267c30 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 30 Jun 2018 12:53:08 +0100 Subject: [PATCH 36/52] Added volatility to entities, to enable cacheing. --- resources/schemas/adl-1.4.1.dtd | 22 +++-- resources/transforms/adl2canonical.xslt | 19 ++-- src/adl/to_hugsql_queries.clj | 74 ---------------- src/adl/to_json_routes.clj | 112 +++++++++++++----------- src/adl/to_selmer_routes.clj | 1 + 5 files changed, 87 insertions(+), 141 deletions(-) diff --git a/resources/schemas/adl-1.4.1.dtd b/resources/schemas/adl-1.4.1.dtd index 3f02697..53a9402 100644 --- a/resources/schemas/adl-1.4.1.dtd +++ b/resources/schemas/adl-1.4.1.dtd @@ -246,7 +246,7 @@ that we can allow HTML block level entities within content elements --> 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 + 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 @@ -254,21 +254,27 @@ that we can allow HTML block level entities within content elements --> '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 + 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 + 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 + 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. --> + table CDATA #IMPLIED + foreign %Boolean; #IMPLIED + magnitude CDATA #IMPLIED + volatility CDATA #IMPLIED> - - - entity already has a key - not generating one - - + + + entity already has a key - not generating one + + 6 + + 0 + - - - + + + diff --git a/src/adl/to_hugsql_queries.clj b/src/adl/to_hugsql_queries.clj index 673023d..6011417 100644 --- a/src/adl/to_hugsql_queries.clj +++ b/src/adl/to_hugsql_queries.clj @@ -321,80 +321,6 @@ })) links)))) -(defn link-table-query - "Generate a query which links across the entity passed as `link` - from the entity passed as `near` to the entity passed as `far`. - TODO: not working?" - [near link far] - (if - (and - (entity? near) - (entity? link) - (entity? far)) - (let [properties (-> link :content :properties vals) - links (apply - merge - (map - #(hash-map (keyword (-> % :attrs :entity)) %) - (filter #(-> % :attrs :entity) properties))) - near-name (-> near :attrs :name) - link-name (-> link :attrs :name) - far-name (-> far :attrs :name) - pretty-far (singularise far-name) - query-name (str "list-" link-name "-" near-name "-by-" pretty-far) - signature ":? :*"] - (hash-map - (keyword query-name) - {:name query-name - :signature signature - :entity link - :type :select-many-to-many - :near-entity near - :far-entity far - :query - (s/join - "\n" - (remove - empty? - (list - (str "-- :name " query-name " " signature) - (str "-- :doc lists all existing " near-name " records related through " link-name " to a given " pretty-far ) - (str "SELECT DISTINCT "near-name ".*") - (str "FROM " near-name ", " link-name ) - (str "WHERE " near-name "." (first (key-names near)) " = " link-name "." (singularise near-name) "_id" ) - ("\tAND " link-name "." (singularise far-name) "_id = :id") - (order-by-clause near))))})))) - - -(defn link-table-queries [entity application] - "Generate all the link queries in this `application` which link via this `entity`." - (let - [entities (map - ;; find the far-side entities - (fn - [far-name] - (children - application - (fn [x] - (and - (= (:tag x) :entity) - (= (:name (:attrs x)) far-name))))) - ;; of those properties of this `entity` which are of type `entity` - (remove - nil? - (map - #(-> % :attrs :entity) - (children entity #(= (:tag %) :property))))) - pairs (combinations entities 2)] - (apply - merge - (map - #(merge - (link-table-query (nth % 0) entity (nth % 1)) - (link-table-query (nth % 1) entity (nth % 0))) - pairs)))) - - (defn delete-query [entity] "Generate an appropriate `delete` query for this `entity`" diff --git a/src/adl/to_json_routes.clj b/src/adl/to_json_routes.clj index 5464313..7b192ed 100644 --- a/src/adl/to_json_routes.clj +++ b/src/adl/to_json_routes.clj @@ -48,6 +48,7 @@ :require '[adl-support.core :as support] '[clojure.java.io :as io] + '[clojure.core.memoize :as memo] '[compojure.core :refer [defroutes GET POST]] '[hugsql.core :as hugsql] '[noir.response :as nresponse] @@ -60,24 +61,45 @@ (cons 'declare (sort (map #(symbol (name %)) (keys handlers-map))))) +(defn generate-handler-body + "Generate and return the function body for the handler for this `query`." + [query] + (list + [{:keys ['params]}] + (list 'do (list (symbol (str "db/" (:name query))) 'params)) + (case + (:type query) + (:delete-1 :update-1) + '(response/found "/") + nil))) + + (defn generate-handler-src + "Generate and return the handler for this `query`." [handler-name query-map method doc] (hash-map :method method - :src - (remove - nil? - (list - 'defn - handler-name - (str "Auto-generated method to " doc) - [{:keys ['params]}] - (list 'do (list (symbol (str "db/" (:name query-map))) 'params)) - (case - (:type query-map) - (:delete-1 :update-1) - '(response/found "/") - nil))))) + :src (remove + nil? + (if + (or + (zero? (volatility (:entity query-map))) + (#{:delete-1 :insert-1 :update-1} (:type query-map))) + (concat + (list + 'defn + handler-name + (str "Auto-generated method to " doc)) + (generate-handler-body query-map)) + (concat + (list + 'def + handler-name + (list + 'memo/ttl + (cons 'fn (generate-handler-body query-map)) + :ttl/threshold + (* (volatility (:entity query-map)) 1000)))))))) (defn handler @@ -100,7 +122,7 @@ (str "delete one record from the `" (-> query :entity :attrs :name) "` table. Expects the following key(s) to be present in `params`: `" - (doall (-> query :entity :content :key :content keys)) + (-> query :entity key-names) "`.")) :insert-1 (generate-handler-src @@ -108,9 +130,12 @@ (str "insert one record to the `" (-> query :entity :attrs :name) "` table. Expects the following key(s) to be present in `params`: `" - (pr-str (-> query :entity :content :properties keys)) + (pr-str + (map + #(keyword (:name (:attrs %))) + (-> query :entity insertable-properties ))) "`. Returns a map containing the keys `" - (pr-str (-> query :entity :content :key :content keys)) + (-> query :entity key-names) "` identifying the record created.")) :update-1 (generate-handler-src @@ -121,10 +146,12 @@ (pr-str (distinct (sort - (flatten - (cons - (-> query :entity :content :properties keys) - (-> query :entity :content :key :content keys)))))) + (map + #(keyword (:name (:attrs %))) + (flatten + (cons + (-> query :entity key-properties) + (-> query :entity insertable-properties))))))) "`.")) :select-1 (generate-handler-src @@ -132,15 +159,9 @@ (str "select one record from the `" (-> query :entity :attrs :name) "` table. Expects the following key(s) to be present in `params`: `" - (pr-str (-> query :entity :content :key :content keys)) + (-> query :entity key-names) "`. Returns a map containing the following keys: `" - (pr-str - (distinct - (sort - (flatten - (cons - (-> query :entity :content :properties keys) - (-> query :entity :content :key :content keys)))))) + (map #(keyword (:name (:attrs %))) (-> query :entity all-properties)) "`.")) :select-many (generate-handler-src @@ -149,26 +170,21 @@ (-> query :entity :attrs :name) "` table. If the keys `(:limit :offset)` are present in the request then they will be used to page through the data. Returns a sequence of maps each containing the following keys: `" (pr-str - (distinct - (sort - (flatten - (cons - (-> query :entity :content :properties keys) - (-> query :entity :content :key :content keys)))))) + (map + #(keyword (:name (:attrs %))) + (-> query :entity all-properties))) "`.")) :text-search (generate-handler-src handler-name query :get (str "select all records from the `" (-> query :entity :attrs :name) + ;; TODO: this doc-string is out of date "` table with any text field matching the value of the key `:pattern` which should be in the request. If the keys `(:limit :offset)` are present in the request then they will be used to page through the data. Returns a sequence of maps each containing the following keys: `" (pr-str - (distinct - (sort - (flatten - (cons - (-> query :entity :content :properties keys) - (-> query :entity :content :key :content keys)))))) + (map + #(keyword (:name (:attrs %))) + (-> query :entity all-properties))) "`.")) (:select-many-to-many :select-one-to-many) @@ -226,22 +242,16 @@ (try (with-open [output (writer filepath)] (binding [*out* output] - (doall - (map - (fn [f] - (pprint f) - (println "\n")) - (list - (file-header application) - (declarations handlers-map) - (defroutes handlers-map)))) + (pprint (file-header application)) + (println) (doall (map (fn [h] (pprint (:src (handlers-map h))) (println) h) - (sort (keys handlers-map)))))) + (sort (keys handlers-map)))) + (pprint (defroutes handlers-map)))) (if (> *verbosity* 0) (println (str "\tGenerated " filepath))) (catch diff --git a/src/adl/to_selmer_routes.clj b/src/adl/to_selmer_routes.clj index 645a640..ea6f7ed 100644 --- a/src/adl/to_selmer_routes.clj +++ b/src/adl/to_selmer_routes.clj @@ -198,6 +198,7 @@ (l/render (support/resolve-template "application-index.html") + (:session r) {:title "Administrative menu"}))) (println) (doall From 16f953741b4ad56d20dec773d890a72ccae1d87d Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 30 Jun 2018 20:05:55 +0100 Subject: [PATCH 37/52] Tactical commit --- src/adl/to_selmer_templates.clj | 202 +++++++++++++++++++------------- 1 file changed, 121 insertions(+), 81 deletions(-) diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj index 17aa062..f0e4ee7 100644 --- a/src/adl/to_selmer_templates.clj +++ b/src/adl/to_selmer_templates.clj @@ -99,8 +99,7 @@ "See [Application Description Language](https://github.com/simon-brooke/adl)." "-->") (emit-content filename spec entity application :head) - (emit-content filename spec entity application :top) - "{% block content %}"))))) + (emit-content filename spec entity application :top)))))) (defn file-footer @@ -110,12 +109,8 @@ (file-footer filename nil nil application)) ([filename spec entity application] (s/join - "\n" - (flatten - (list - "{% endblock %}" - (emit-content filename spec entity application :foot) - ))))) + "\n" + (emit-content filename spec entity application :foot)))) (defn prompt @@ -362,25 +357,26 @@ [keyfields (children ;; there should only be one key; its keys are properties (first (children entity #(= (:tag %) :key))))] - {:tag :div - :attrs {:id "content" :class "edit"} - :content - [{:tag :form - :attrs {:action (str "{{servlet-context}}/" (editor-name entity application)) - :method "POST"} - :content (flatten - (list - (csrf-widget) - (map - #(widget % form entity application) - keyfields) - (map - #(widget % form entity application) - (remove - #(= (:distict (:attrs %)) :system) - (fields entity))) - (save-widget form entity application) - (delete-widget form entity application)))}]})) + {:content + {:tag :div + :attrs {:id "content" :class "edit"} + :content + [{:tag :form + :attrs {:action (str "{{servlet-context}}/" (editor-name entity application)) + :method "POST"} + :content (flatten + (list + (csrf-widget) + (map + #(widget % form entity application) + keyfields) + (map + #(widget % form entity application) + (remove + #(= (:distict (:attrs %)) :system) + (fields entity))) + (save-widget form entity application) + (delete-widget form entity application)))}]}})) @@ -536,16 +532,46 @@ taken from this `application`. If `list` is nill, generate a default list template for the entity." [list-spec entity application] - {:tag :form - :attrs {:id "content" :class "list"} - :content - [(big-link (str "Add a new " (pretty-name entity)) (editor-name entity application)) - {:tag :table - :attrs {:caption (:name (:attrs entity))} + (let [form-name + (str + "list-" + (:name (:attrs entity)) + "-" + (:name (:attrs list-spec)))] + {:big-links + {:tag :div + :content + [{:tag :div :attrs {:class "big-link-container"} + :content + [{:tag :a :attrs {:id "next-selector" :role "button" :class "big-link"} + :content ["Next"]}]} + (big-link (str "Add a new " (pretty-name entity)) (editor-name entity application))]} :content - [(list-thead list-spec entity application) - (list-tbody list-spec entity application) - (list-tfoot list-spec entity application)]}]}) + {:tag :form + :attrs {:id form-name :class "list" + :action (str "{{servlet-context}}/" form-name) + :method "POST"} + :content + [ + (csrf-widget) + {:tag :input :attrs {:id "offset" :type "hidden" :value "{{offset|0}}"}} + {:tag :input :attrs {:id "limit" :type "hidden" :value "{{limit|50}}"}} + (big-link (str "Add a new " (pretty-name entity)) (editor-name entity application)) + {:tag :table + :attrs {:caption (:name (:attrs entity))} + :content + [(list-thead list-spec entity application) + (list-tbody list-spec entity application) + (list-tfoot list-spec entity application)]}]} + :extra-script + (str "var form = document.getElementById('" form-name "'); + var ow = document.getElementById('offset'); + var lw = document.getElementById('limit'); + + document.getElementById('next-selector').addEventListener('click', function () { + ow.text=(parseInt(ow.text)+parseInt(lw.text)); + //form.submit(); + });")})) (defn entity-to-templates @@ -589,35 +615,36 @@ [application] (let [first-class-entities (filter - #(children-with-tag % :list) - (children-with-tag application :entity))] - {:application-index - {:tag :dl - :attrs {:class "index"} - :content - (apply + #(children-with-tag % :list) + (children-with-tag application :entity))] + {:content + {:application-index + {:tag :dl + :attrs {:class "index"} + :content + (apply vector (interleave - (map - #(hash-map - :tag :dt - :content - [{:tag :a - :attrs {:href (path-part :list % application)} - :content [(pretty-name %)]}]) - first-class-entities) - (map - #(hash-map - :tag :dd - :content (apply - vector - (map - (fn [d] - (hash-map - :tag :p - :content (:content d))) - (children-with-tag % :documentation)))) - first-class-entities)))}})) + (map + #(hash-map + :tag :dt + :content + [{:tag :a + :attrs {:href (path-part :list % application)} + :content [(pretty-name %)]}]) + first-class-entities) + (map + #(hash-map + :tag :dd + :content (apply + vector + (map + (fn [d] + (hash-map + :tag :p + :content (:content d))) + (children-with-tag % :documentation)))) + first-class-entities)))}}})) @@ -627,26 +654,39 @@ template (try (spit - (str *output-path* filename) - (s/join - "\n" - (list - (file-header filename application) - (with-out-str - (x/emit-element template)) - (file-footer filename application)))) + (str *output-path* filename) + (s/join + "\n" + (flatten + (list + (file-header filename application) + (doall + (map + #(let [content (template %)] + (list + (str "{% block " (name %) " %}") + (cond (string? content) + content + (map? content) + (with-out-str + (x/emit-element content)) + true + (str "")) + "{% endblock %}") + (keys template)))) + (file-footer filename application))))) (catch Exception any (spit - (str *output-path* filename) - (with-out-str - (println - (str - "")) - (p/pprint template)))))) + (str *output-path* filename) + (with-out-str + (println + (str + "")) + (p/pprint template)))))) filename) From 96c273ee063d737e02f866cb285afab622144201 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 1 Jul 2018 01:36:49 +0100 Subject: [PATCH 38/52] Work on list paging - not complete, but promising --- .gitignore | 4 + src/adl/to_selmer_routes.clj | 6 +- src/adl/to_selmer_templates.clj | 215 ++++++++++++++++---------------- 3 files changed, 114 insertions(+), 111 deletions(-) diff --git a/.gitignore b/.gitignore index 0c08a8a..b7b0702 100644 --- a/.gitignore +++ b/.gitignore @@ -11,3 +11,7 @@ pom.xml.asc .hg/ resources/auto/ + +generated/resources/sql/ + +generated/src/clj/youyesyet/routes/ diff --git a/src/adl/to_selmer_routes.clj b/src/adl/to_selmer_routes.clj index ea6f7ed..5958082 100644 --- a/src/adl/to_selmer_routes.clj +++ b/src/adl/to_selmer_routes.clj @@ -69,7 +69,9 @@ (vector 'r) (list 'let (vector 'p - (list 'support/massage-params (list :params 'r))) + (list 'merge + {:offset 0 :limit 25} + (list 'support/massage-params (list :params 'r)))) ;; TODO: we must take key params out of just params, ;; but we should take all other params out of form-params - because we need the key to ;; load the form in the first place, but just accepting values of other params would @@ -86,6 +88,8 @@ (reduce merge {:record + ;; TODO: this breaks. We need to check for the presence of the + ;; actual key in the params. (list 'if (list 'empty? (list 'remove 'nil? (list 'vals 'p))) [] (list (symbol diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj index a701a74..606c4da 100644 --- a/src/adl/to_selmer_templates.clj +++ b/src/adl/to_selmer_templates.clj @@ -39,7 +39,7 @@ {:tag :div :attrs {:class "big-link-container"} :content - [{:tag :a :attrs {:href url} + [{:tag :a :attrs {:href url :class "big-link"} :content (if (vector? content) content @@ -62,22 +62,24 @@ ([filename application k] (emit-content filename nil nil application k)) ([filename spec entity application k] - (let [content (:content - (first - (or (children-with-tag spec k) - (children-with-tag entity k) - (children-with-tag - (first - (children-with-tag application :content)) - k))))] + (let [content + (:content + (first + (or (children-with-tag spec k) + (children-with-tag entity k) + (children-with-tag + (child-with-tag application :content) + k))))] (if content - (list + (flatten + (list (str "{% block " (name k) " %}") - (map + (doall + (map #(with-out-str (x/emit-element %)) - content) - "{% endblock %}"))))) + content)) + "{% endblock %}")))))) (defn file-header @@ -448,7 +450,7 @@ :content [{:tag :input :attrs {:type "submit" - :id "search" + :id "search-widget" :value "Search"}}]})))}]}) @@ -504,35 +506,6 @@ "{% endfor %}"]}) -(defn- list-page-control - "What this needs to do is emit an HTML control which, when selected, requests the - next or previous page keeping the same search parameters; so it essentially needs - to be a submit button, not a link." - [forward?] - {:tag :div - :attrs {:class (if forward? "big-link-container" "back-link-container")} - :content - [{:tag :input - :attrs {:id "page" - :name "page" - :disabled (if - forward? - false - "{% ifequal offset 0 %} false {% else %} true {% endifequal %}") - ;; TODO: real thought needs to happen on doing i18n for this! - :value (if forward? "Next" "Previous")}}]}) - - -(defn- list-tfoot - "Return a table footer element for the list view for this `list-spec` of this `entity` within - this `application`." - [list-spec entity application] - {:tag :tfoot - :content - [(list-page-control false) - (list-page-control true)]}) - - (defn list-to-template "Generate a template as specified by this `list` element for this `entity`, taken from this `application`. If `list` is nill, generate a default list @@ -544,7 +517,22 @@ (:name (:attrs entity)) "-" (:name (:attrs list-spec)))] - {:big-links + {:back-links + {:tag :div + :content + [ + {:tag :div :attrs {:class "back-link-container"} + :content + ["{% ifunequal offset 0 %}" + {:tag :a :attrs {:id "prev-selector" :class "back-link"} + :content ["Previous"]} + "{% else %}" + {:tag :a + :attrs {:id "back-link" :class "back-link" :href "{{servlet-context}}/admin"} + :content ["Back"]} + "{% endifunequal %}"]} + ]} + :big-links {:tag :div :content [{:tag :div :attrs {:class "big-link-container"} @@ -558,25 +546,36 @@ :action (str "{{servlet-context}}/" form-name) :method "POST"} :content - [ - (csrf-widget) - {:tag :input :attrs {:id "offset" :type "hidden" :value "{{offset|0}}"}} - {:tag :input :attrs {:id "limit" :type "hidden" :value "{{limit|50}}"}} - (big-link (str "Add a new " (pretty-name entity)) (editor-name entity application)) + [(csrf-widget) + {:tag :input :attrs {:id "offset" :type "hidden" :value "{{params.offset|default:0}}"}} + {:tag :input :attrs {:id "limit" :type "hidden" :value "{{params.limit|default:50}}"}} {:tag :table :attrs {:caption (:name (:attrs entity))} :content - [(list-thead list-spec entity application) - (list-tbody list-spec entity application) - (list-tfoot list-spec entity application)]}]} + [(list-thead list-spec entity application) + (list-tbody list-spec entity application) + ]}]} :extra-script - (str "var form = document.getElementById('" form-name "'); + (str " + var form = document.getElementById('" form-name "'); var ow = document.getElementById('offset'); var lw = document.getElementById('limit'); + form.addEventListener('submit', function() { + ow.value='0'; + }); + + {% ifunequal offset 0 %} + document.getElementById('prev-selector').addEventListener('click', function () { + ow.value=(parseInt(ow.value)-parseInt(lw.value)); + console.log('Updated offset to ' + ow.value); + form.submit(); + }); + {% endifunequal %} document.getElementById('next-selector').addEventListener('click', function () { - ow.text=(parseInt(ow.text)+parseInt(lw.text)); - //form.submit(); + ow.value=(parseInt(ow.value)+parseInt(lw.value)); + console.log('Updated offset to ' + ow.value); + form.submit(); });")})) @@ -621,15 +620,16 @@ (let [first-class-entities (sort-by - #(:name (:attrs %)) - (filter - #(children-with-tag % :list) - (children-with-tag application :entity)))] - {:content - {:tag :dl - :attrs {:class "index"} - :content - (apply + #(:name (:attrs %)) + (filter + #(children-with-tag % :list) + (children-with-tag application :entity)))] + {:application-index + {:content + {:tag :dl + :attrs {:class "index"} + :content + (apply vector (interleave (map @@ -651,60 +651,55 @@ :tag :p :content (:content d))) (children-with-tag % :documentation)))) - first-class-entities)))}})) + first-class-entities)))}}})) (defn write-template-file [filename template application] - (if - template - (try - (spit - (str *output-path* filename) - (s/join - "\n" - (flatten - (list - (file-header filename application) - (doall - (map - #(let [content (template %)] - (list - (str "{% block " (name %) " %}") - (cond (string? content) - content - (map? content) - (with-out-str - (x/emit-element content)) - true - (str "")) - "{% endblock %}") - (keys template)))) - (file-footer filename application))))) - (catch Exception any - (spit - filepath - (s/join + (let [filepath (str *output-path* "resources/templates/auto/" filename)] + (if + template + (try + (do + (spit + filepath + (s/join "\n" - (list + (flatten + (list (file-header filename application) - (with-out-str - (x/emit-element template)) - (file-footer filename application)))) - (if (> *verbosity* 0) (println "\tGenerated " filepath)) + (doall + (map + #(let [content (template %)] + (list + (str "{% block " (name %) " %}") + (cond (string? content) + content + (map? content) + (with-out-str + (x/emit-element content)) + true + (str "")) + "{% endblock %}")) + (keys template))) + (file-footer filename application))))) + (if (> *verbosity* 0) (println "\tGenerated " filepath))) (catch Exception any (let [report (str - "ERROR: Exception " - (.getName (.getClass any)) - (.getMessage any) - " while printing " - filename)] - (spit - filepath - (with-out-str - (println (str "")) - (p/pprint template))) - (println report))))) + "ERROR: Exception " + (.getName (.getClass any)) + (.getMessage any) + " while printing " + filepath)] + (try + (spit + filepath + (with-out-str + (println (str "")) + (p/pprint template))) + (catch Exception _ nil)) + (println report) + (throw any))))) (str filepath))) From 40fa2aacb9030a6d803f091a07137116576225e6 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 2 Jul 2018 10:54:57 +0100 Subject: [PATCH 39/52] A lot of UI work. --- src/adl/to_hugsql_queries.clj | 4 + src/adl/to_json_routes.clj | 34 ++- src/adl/to_selmer_routes.clj | 366 +++++++++++++++++++------------- src/adl/to_selmer_templates.clj | 12 +- 4 files changed, 260 insertions(+), 156 deletions(-) diff --git a/src/adl/to_hugsql_queries.clj b/src/adl/to_hugsql_queries.clj index 6011417..6bcaa68 100644 --- a/src/adl/to_hugsql_queries.clj +++ b/src/adl/to_hugsql_queries.clj @@ -183,6 +183,10 @@ (str (safe-name (-> % :attrs :name) :sql) " = ':" (-> % :attrs :name) "'") + "entity" + (str + (safe-name (-> % :attrs :name) :sql) + "_expanded LIKE '%:" (-> % :attrs :name) "%'") (str (safe-name (-> % :attrs :name) :sql) " = :" diff --git a/src/adl/to_json_routes.clj b/src/adl/to_json_routes.clj index 7b192ed..76e3cfb 100644 --- a/src/adl/to_json_routes.clj +++ b/src/adl/to_json_routes.clj @@ -1,14 +1,14 @@ (ns ^{:doc "Application Description Language: generate RING routes for REST requests." :author "Simon Brooke"} adl.to-json-routes - (:require [clojure.java.io :refer [file make-parents writer]] - [clojure.pprint :refer [pprint]] - [clojure.string :as s] - [clojure.xml :as x] + (:require [adl-support.utils :refer :all] + [adl.to-hugsql-queries :refer [queries]] [clj-time.core :as t] [clj-time.format :as f] - [adl-support.utils :refer :all] - [adl.to-hugsql-queries :refer [queries]])) + [clojure.java.io :refer [file make-parents writer]] + [clojure.pprint :refer [pprint]] + [clojure.string :as s] + [clojure.xml :as x])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; @@ -47,8 +47,9 @@ (list :require '[adl-support.core :as support] - '[clojure.java.io :as io] '[clojure.core.memoize :as memo] + '[clojure.java.io :as io] + '[clojure.tools.logging :as log] '[compojure.core :refer [defroutes GET POST]] '[hugsql.core :as hugsql] '[noir.response :as nresponse] @@ -66,7 +67,24 @@ [query] (list [{:keys ['params]}] - (list 'do (list (symbol (str "db/" (:name query))) 'params)) + (list 'do + (list + 'log/debug + (list 'str + "Calling query '" + (:name query) + "' with params " + (list 'map + (list 'fn ['p] + ;; user-distinct is a reasonable proxy for 'not-too-secret' - + ;; this will only appear in debug logs. + (list 'if + (list (user-distinct-property-names (:entity query)) + (list 'str (list 'name 'p))) + (list 'params 'p) + "[ELIDED]")) + '(keys params)))) + (list (symbol (str "db/" (:name query))) 'params)) (case (:type query) (:delete-1 :update-1) diff --git a/src/adl/to_selmer_routes.clj b/src/adl/to_selmer_routes.clj index 5958082..bcd985c 100644 --- a/src/adl/to_selmer_routes.clj +++ b/src/adl/to_selmer_routes.clj @@ -2,12 +2,12 @@ :author "Simon Brooke"} adl.to-selmer-routes (:require [adl-support.utils :refer :all] + [clj-time.core :as t] + [clj-time.format :as f] [clojure.java.io :refer [file make-parents writer]] [clojure.pprint :refer [pprint]] [clojure.string :as s] [clojure.xml :as x] - [clj-time.core :as t] - [clj-time.format :as f] )) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -42,131 +42,209 @@ (defn file-header [application] (list - 'ns - (symbol (str (:name (:attrs application)) ".routes.auto")) - (str "User interface routes for " (pretty-name application) - " auto-generated by [Application Description Language framework](https://github.com/simon-brooke/adl) at " - (f/unparse (f/formatters :basic-date-time) (t/now))) + 'ns + (symbol (str (:name (:attrs application)) ".routes.auto")) + (str "User interface routes for " (pretty-name application) + " auto-generated by [Application Description Language framework](https://github.com/simon-brooke/adl) at " + (f/unparse (f/formatters :basic-date-time) (t/now))) + (list + :require + '[adl-support.core :as support] + '[clojure.java.io :as io] + '[clojure.set :refer [subset?]] + '[clojure.tools.logging :as log] + '[compojure.core :refer [defroutes GET POST]] + '[hugsql.core :as hugsql] + '[noir.response :as nresponse] + '[noir.util.route :as route] + '[ring.util.http-response :as response] + (vector (symbol (str (:name (:attrs application)) ".layout")) :as 'l) + (vector (symbol (str (:name (:attrs application)) ".db.core")) :as 'db) + (vector (symbol (str (:name (:attrs application)) ".routes.manual")) :as 'm)))) + + +(defn make-form-handler-content + [f e a n] + (let [warning (str "Error while fetching " (singularise (:name (:attrs e))) " record")] + ;; TODO: as yet makes no attempt to save the record + (list 'let + (vector + 'record (list + 'support/do-or-log-error + (list 'if (list 'subset? (key-names e) (set (list 'keys 'p))) + (list + (symbol + (str "db/get-" (singularise (:name (:attrs e))))) + (symbol "db/*db*") + 'p)) + :message warning + :error-return {:warnings [warning]})) + (reduce + merge + {:warnings (list :warnings 'record) + :record (list 'assoc 'record :warnings nil)} + (map + (fn [p] + (hash-map + (keyword (-> p :attrs :entity)) + (list 'support/do-or-log-error + (list (symbol (str "db/list-" (:entity (:attrs p)))) (symbol "db/*db*")) + :message (str "Error while fetching " + (singularise (:entity (:attrs p))) + " record")))) + (filter #(#{"entity" "link"} (:type (:attrs %))) + (descendants-with-tag e :property))))))) + + +(defn make-page-handler-content + [f e a n] + (let [warning (str "Error while fetching " (singularise (:name (:attrs e))) " record")] + (list 'let + (vector 'record (list + 'support/handler-content-log-error + (list 'if (list 'subset? (list 'keys 'p) (key-names e)) [] + (list + (symbol + (str "db/get-" (singularise (:name (:attrs e))))) + (symbol "db/*db*") + 'p)) + :message warning + :error-return {:warnings [warning]})) + {:warnings (list :warnings 'record) + :record (list 'assoc 'record :warnings nil)}))) + + +(defn make-list-handler-content + [f e a n] + (list + 'let + (vector + 'records (list - :require - '[adl-support.core :as support] - '[clojure.java.io :as io] - '[compojure.core :refer [defroutes GET POST]] - '[hugsql.core :as hugsql] - '[noir.response :as nresponse] - '[noir.util.route :as route] - '[ring.util.http-response :as response] - (vector (symbol (str (:name (:attrs application)) ".layout")) :as 'l) - (vector (symbol (str (:name (:attrs application)) ".db.core")) :as 'db) - (vector (symbol (str (:name (:attrs application)) ".routes.manual")) :as 'm)))) + 'if + (list + 'some + (set (map #(-> % :attrs :name) (all-properties e))) + (list 'keys 'p)) + (list + 'support/do-or-log-error + (list + (symbol + (str + "db/search-strings-" + (singularise (:name (:attrs e))))) + (symbol "db/*db*") + 'p) + :message (str + "Error while searching " + (singularise (:name (:attrs e))) + " records") + :error-return {:warnings [(str + "Error while searching " + (singularise (:name (:attrs e))) + " records")]}) + (list + 'support/do-or-log-error + (list + (symbol + (str + "db/list-" + (:name (:attrs e)))) + (symbol "db/*db*") {}) + :message (str + "Error while fetching " + (singularise (:name (:attrs e))) + " records") + :error-return {:warnings [(str + "Error while fetching " + (singularise (:name (:attrs e))) + " records")]}))) + (list 'if + (list :warnings 'records) + 'records + {:records 'records}))) + (defn make-handler [f e a] (let [n (path-part f e a)] (list - 'defn - (symbol n) - (vector 'r) - (list 'let (vector - 'p - (list 'merge - {:offset 0 :limit 25} - (list 'support/massage-params (list :params 'r)))) - ;; TODO: we must take key params out of just params, - ;; but we should take all other params out of form-params - because we need the key to - ;; load the form in the first place, but just accepting values of other params would - ;; allow spoofing. - (list - 'l/render - (list 'support/resolve-template (str n ".html")) - '(:session r) - (merge - {:title (capitalise (:name (:attrs f))) - :params 'p} - (case (:tag f) - (:form :page) - (reduce - merge - {:record - ;; TODO: this breaks. We need to check for the presence of the - ;; actual key in the params. - (list 'if (list 'empty? (list 'remove 'nil? (list 'vals 'p))) [] - (list - (symbol - (str "db/get-" (singularise (:name (:attrs e))))) - (symbol "db/*db*") - 'p))} - (map - (fn [p] - (hash-map - (keyword (-> p :attrs :entity)) - (list (symbol (str "db/list-" (:entity (:attrs p)))) (symbol "db/*db*")))) - (filter #(#{"entity" "link"} (:type (:attrs %))) - (descendants-with-tag e :property)))) - :list - {:records - (list - 'if - (list - 'not - (list - 'empty? - (list 'remove 'nil? (list 'vals 'p)))) - (list - (symbol - (str - "db/search-strings-" - (singularise (:name (:attrs e))))) - (symbol "db/*db*") - 'p) - (list - (symbol - (str - "db/list-" - (:name (:attrs e)))) - (symbol "db/*db*") {}))}))))))) + 'defn + (symbol n) + (vector 'r) + (list + 'let + (vector + 'p + (list 'merge + {:offset 0 :limit 25} + (list 'support/massage-params (list :params 'r) (list :form-params 'r) (key-names e))) + 'c (case (:tag f) + :form (make-form-handler-content f e a n) + :page (make-page-handler-content f e a n) + :list (make-list-handler-content f e a n))) + (list + 'l/render + (list 'support/resolve-template (str n ".html")) + '(:session 'r) + (list 'merge + {:title (capitalise (:name (:attrs f))) + :params 'p} + 'c)))))) + +;; (def a (x/parse "../youyesyet/youyesyet.canonical.adl.xml")) +;; (def e (child-with-tag a :entity)) +;; (def f (child-with-tag e :form)) +;; (def n (path-part f e a)) +;; (vector +;; 'p +;; (list 'merge +;; {:offset 0 :limit 25} +;; (list 'support/massage-params (list :params 'r)))) +;; (make-handler f e a) + (defn make-route "Make a route for method `m` to request the resource with name `n`." [m n] (list - m - (str "/" n) - 'request + m + (str "/" n) + 'request + (list + 'route/restricted (list - 'route/restricted - (list - 'apply - (list 'resolve-handler n) - (list 'list 'request))))) + 'apply + (list 'resolve-handler n) + (list 'list 'request))))) (defn make-defroutes [application] (let [routes (flatten - (map - (fn [e] - (map - (fn [c] - (path-part c e application)) - (filter (fn [c] (#{:form :list :page} (:tag c))) (children e)))) - (children-with-tag application :entity)))] + (map + (fn [e] + (map + (fn [c] + (path-part c e application)) + (filter (fn [c] (#{:form :list :page} (:tag c))) (children e)))) + (children-with-tag application :entity)))] (cons - 'defroutes + 'defroutes + (cons + 'auto-selmer-routes (cons - 'auto-selmer-routes - (cons - '(GET - "/admin" - request - (route/restricted - (apply (resolve-handler "index") (list request)))) - (interleave - (map - (fn [r] (make-route 'GET r)) - (sort routes)) - (map - (fn [r] (make-route 'POST r)) - (sort routes)))))))) + '(GET + "/admin" + request + (route/restricted + (apply (resolve-handler "index") (list request)))) + (interleave + (map + (fn [r] (make-route 'GET r)) + (sort routes)) + (map + (fn [r] (make-route 'POST r)) + (sort routes)))))))) (defn generate-handler-resolver @@ -175,17 +253,27 @@ were doing could write this more elegantly." [application] (list - 'defn - 'raw-resolve-handler - "Prefer the manually-written version of the handler with name `n`, if it exists, to the automatically generated one" - (vector 'n) - (list 'try - (list 'eval (list 'symbol (list 'str (:name (:attrs application)) ".routes.manual/" 'n))) - (list 'catch - 'Exception '_ - (list 'eval - (list 'symbol - (list 'str (:name (:attrs application)) ".routes.auto/" 'n))))))) + 'defn + 'raw-resolve-handler + "Prefer the manually-written version of the handler with name `n`, if it exists, to the automatically generated one" + (vector 'n) + (list 'try + (list 'eval (list 'symbol (list 'str (:name (:attrs application)) ".routes.manual/" 'n))) + (list 'catch + 'Exception '_ + (list 'eval + (list 'symbol + (list 'str (:name (:attrs application)) ".routes.auto/" 'n))))))) + + +(defn make-handlers + [e application] + (doall + (map + (fn [c] + (pprint (make-handler c e application)) + (println)) + (filter (fn [c] (#{:form :list :page} (:tag c))) (children e))))) (defn to-selmer-routes @@ -200,25 +288,19 @@ (pprint '(defn index [r] (l/render - (support/resolve-template - "application-index.html") - (:session r) - {:title "Administrative menu"}))) + (support/resolve-template + "application-index.html") + (:session r) + {:title "Administrative menu"}))) (println) (doall - (map - (fn [e] - (doall - (map - (fn [c] - (pprint (make-handler c e application)) - (println)) - (filter (fn [c] (#{:form :list :page} (:tag c))) (children e))))) - (sort - #(compare (:name (:attrs %1))(:name (:attrs %2))) - (children-with-tag application :entity)))) + (map + #(make-handlers % application) + (sort + #(compare (:name (:attrs %1))(:name (:attrs %2))) + (children-with-tag application :entity)))) (pprint - (generate-handler-resolver application)) + (generate-handler-resolver application)) (println) (pprint '(def resolve-handler (memoize raw-resolve-handler))) @@ -230,10 +312,10 @@ (catch Exception any (println - (str - "ERROR: Exception " - (.getName (.getClass any)) - (.getMessage any) - " while printing " - filepath)))))) + (str + "ERROR: Exception " + (.getName (.getClass any)) + (.getMessage any) + " while printing " + filepath)))))) diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj index 606c4da..47ca965 100644 --- a/src/adl/to_selmer_templates.clj +++ b/src/adl/to_selmer_templates.clj @@ -523,13 +523,13 @@ [ {:tag :div :attrs {:class "back-link-container"} :content - ["{% ifunequal offset 0 %}" - {:tag :a :attrs {:id "prev-selector" :class "back-link"} - :content ["Previous"]} - "{% else %}" - {:tag :a + ["{% ifequal params.offset \"0\" %}" + {:tag :a :attrs {:id "back-link" :class "back-link" :href "{{servlet-context}}/admin"} :content ["Back"]} + "{% else %}" + {:tag :a :attrs {:id "prev-selector" :class "back-link"} + :content ["Previous"]} "{% endifunequal %}"]} ]} :big-links @@ -564,7 +564,7 @@ ow.value='0'; }); - {% ifunequal offset 0 %} + {% ifunequal params.offset \"0\" %} document.getElementById('prev-selector').addEventListener('click', function () { ow.value=(parseInt(ow.value)-parseInt(lw.value)); console.log('Updated offset to ' + ow.value); From 83f23dd05584ebbebdf10fa09b6f74b72174c2b0 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 4 Jul 2018 19:01:18 +0100 Subject: [PATCH 40/52] Work on asynchronous select widget loading. Not working yet, but significant progress. --- .gitignore | 6 + resources/js/select-widget-support.js | 14 ++ src/adl/to_hugsql_queries.clj | 2 +- src/adl/to_json_routes.clj | 23 +- src/adl/to_selmer_routes.clj | 4 +- src/adl/to_selmer_templates.clj | 290 +++++++++++++++----------- 6 files changed, 210 insertions(+), 129 deletions(-) create mode 100644 resources/js/select-widget-support.js diff --git a/.gitignore b/.gitignore index 0c08a8a..7f97479 100644 --- a/.gitignore +++ b/.gitignore @@ -11,3 +11,9 @@ pom.xml.asc .hg/ resources/auto/ + +generated/resources/sql/ + +generated/resources/templates/auto/ + +generated/src/clj/youyesyet/routes/ diff --git a/resources/js/select-widget-support.js b/resources/js/select-widget-support.js new file mode 100644 index 0000000..4d75ab0 --- /dev/null +++ b/resources/js/select-widget-support.js @@ -0,0 +1,14 @@ + /** + * update the select menu with id `wid` from this `data` whose fields include + * this `entity_key` and these `fields` + */ + function updateMenuOptions(wid, entity_key, fields, data){ + $('#' + wid).children().filter(function(){ + return $(this).attr('selected') === undefined; + }).remove().end(); + + $.each(data, function(key, entry){ + $('#' + wid).append( + $('').attr('value', key).text(entry)); + }); + } diff --git a/src/adl/to_hugsql_queries.clj b/src/adl/to_hugsql_queries.clj index 6011417..3bb67e3 100644 --- a/src/adl/to_hugsql_queries.clj +++ b/src/adl/to_hugsql_queries.clj @@ -144,7 +144,7 @@ "Generate an appropriate search query for string fields of this `entity`" (let [entity-name (safe-name (:name (:attrs entity)) :sql) pretty-name (singularise entity-name) - query-name (str "search-strings-" pretty-name) + query-name (str "search-strings-" entity-name) signature ":? :1" properties (remove #(#{"link"}(:type (:attrs %))) (all-properties entity))] (hash-map diff --git a/src/adl/to_json_routes.clj b/src/adl/to_json_routes.clj index 7b192ed..ac7c5e9 100644 --- a/src/adl/to_json_routes.clj +++ b/src/adl/to_json_routes.clj @@ -65,13 +65,20 @@ "Generate and return the function body for the handler for this `query`." [query] (list - [{:keys ['params]}] - (list 'do (list (symbol (str "db/" (:name query))) 'params)) - (case - (:type query) - (:delete-1 :update-1) - '(response/found "/") - nil))) + [{:keys ['params 'form-params]}] + (list 'let + (vector + 'result + (list + (symbol (str "db/" (:name query))) + 'db/*db* + (list 'support/massage-params + 'params 'form-params (key-names (:entity query))))) + (case + (:type query) + (:delete-1 :update-1) + '(response/found "/") + (list 'response/ok 'result))))) (defn generate-handler-src @@ -155,7 +162,7 @@ "`.")) :select-1 (generate-handler-src - handler-name query :post + handler-name query :get (str "select one record from the `" (-> query :entity :attrs :name) "` table. Expects the following key(s) to be present in `params`: `" diff --git a/src/adl/to_selmer_routes.clj b/src/adl/to_selmer_routes.clj index ea6f7ed..411327b 100644 --- a/src/adl/to_selmer_routes.clj +++ b/src/adl/to_selmer_routes.clj @@ -69,7 +69,7 @@ (vector 'r) (list 'let (vector 'p - (list 'support/massage-params (list :params 'r))) + (list 'support/massage-params (list :params 'r) (list :form-params 'r) (key-names e))) ;; TODO: we must take key params out of just params, ;; but we should take all other params out of form-params - because we need the key to ;; load the form in the first place, but just accepting values of other params would @@ -112,7 +112,7 @@ (symbol (str "db/search-strings-" - (singularise (:name (:attrs e))))) + (:name (:attrs e)))) (symbol "db/*db*") 'p) (list diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj index 640af91..f3ea3d2 100644 --- a/src/adl/to_selmer_templates.clj +++ b/src/adl/to_selmer_templates.clj @@ -99,8 +99,7 @@ "See [Application Description Language](https://github.com/simon-brooke/adl)." "-->") (emit-content filename spec entity application :head) - (emit-content filename spec entity application :top) - "{% block content %}"))))) + (emit-content filename spec entity application :top)))))) (defn file-footer @@ -114,8 +113,7 @@ (flatten (list "{% endblock %}" - (emit-content filename spec entity application :foot) - ))))) + (emit-content filename spec entity application :foot)))))) (defn prompt @@ -191,20 +189,18 @@ #(and (= (:tag %) :entity) (= (:name (:attrs %)) farname)))) - fs-distinct (flatten - (list - (children farside #(#{"user" "all"} (:distinct (:attrs %)))) - (children - (first - (children farside #(= (:tag %) :key))) - #(#{"user" "all"} (:distinct (:attrs %)))))) + fs-distinct (user-distinct-properties farside) farkey (or (:farkey (:attrs property)) - (:name (:attrs (first (children (children farside #(= (:tag %) :key)))))) + (first (key-names farside)) "id")] - [(str "{% for record in " farname " %}{% endfor %}")])) + [(str "{% for r in " farname " %}{% endfor %}")])) (defn widget-type @@ -216,23 +212,30 @@ typedef (:type (:attrs typedef)) (:type (:attrs property)))] - (case t - ("integer" "real" "money") "number" - ("uploadable" "image") "file" - "boolean" "checkbox" - "date" "date" - "time" "time" - "text" ;; default - )))) + (if + (= (-> property :attrs :distinct) "system") + "hidden" ;; <- this is slightly wrong. There are some circumstances in which + ;; system-distinct properties might be user-editable + (case t + ("integer" "real" "money") "number" + ("uploadable" "image") "file" + ("entity" "link") "select" + "boolean" "checkbox" + "date" "date" + "time" "time" + "text" ;; default + ))))) (defn select-widget + ;; TODO: rewrite for selectize https://github.com/selectize/selectize.js/blob/master/docs/usage.md + ;; https://gist.github.com/zabolotnov87/11142887 [property form entity application] (let [farname (:entity (:attrs property)) farside (first (children application #(= (:name (:attrs %)) farname))) magnitude (try (read-string (:magnitude (:attrs farside))) (catch Exception _ 7)) async? (and (number? magnitude) (> magnitude 1)) - widget-name (:name (:attrs property))] + widget-name (safe-name (:name (:attrs property)) :sql)] {:tag :div :attrs {:class "select-box" :farside farname :found (if farside "true" "false")} :content @@ -245,18 +248,25 @@ async? {:tag :input :attrs - {:name (str widget-name "-search-box") - :onchange "/* javascript to repopulate the select widget */"}}) + {:name (str widget-name "_search_box") + :onchange (str "$.getJSON(\"/auto/json/seach-strings-" (-> farside :attrs :name) + "?" + (s/join (str "=\" + " widget-name "_search_box.text + \"&") + (user-distinct-property-names farside)) + (str "=\" + " widget-name "_search_box.text") + ", null, function (data) {updateMenuOptions(\"" + widget-name "\", \"" + (first (key-names farside)) + "\", [\"" + (s/join "\", \"" (user-distinct-property-names farside)) + "\"], data);})")}}) {:tag :select :attrs (merge {:id widget-name :name widget-name} (if (= (:type (:attrs property)) "link") - {:multiple "multiple"}) - (if - async? - {:comment "JavaScript stuff to fix up aynchronous loading"})) + {:multiple "multiple"})) :content (apply vector (get-options property form entity application))})))})) @@ -279,14 +289,41 @@ "%}"))))) +(defn compose-widget-para + [p f e a w content] + {:tag :p + :attrs {:class "widget"} + :content [{:tag :label + :attrs {:for w} + :content [(prompt p f e a)]} + (compose-if-member-of-tag p e a true) + content + "{% else %}" + (compose-if-member-of-tag p e a false) + {:tag :span + :attrs {:id w + :name w + :class "pseudo-widget disabled"} + :content [(str "{{record." w "}}")]} + "{% else %}" + {:tag :span + :attrs {:id w + :name w + :class "pseudo-widget not-authorised"} + :content [(str "You are not permitted to view " w " of " (:name (:attrs e)))]} + "{% endifmemberof %}" + "{% endifmemberof %}"]}) + + (defn widget "Generate a widget for this `field-or-property` of this `form` for this `entity` taken from within this `application`." [field-or-property form entity application] (let - [widget-name (if (= (:tag field-or-property) :property) - (:name (:attrs field-or-property)) - (:property (:attrs field-or-property))) + [widget-name (safe-name + (if (= (:tag field-or-property) :property) + (:name (:attrs field-or-property)) + (:property (:attrs field-or-property))) :sql) property (if (= (:tag field-or-property) :property) field-or-property @@ -296,65 +333,54 @@ (:property (:attrs field-or-property))))) permissions (find-permissions field-or-property property form entity application) typedef (typedef property application) + w-type (widget-type property application typedef) visible-to (visible-to permissions) ;; if the form isn't actually a form, no widget is writable. - writable-by (if (= (:tag form) :form) (writable-by permissions)) - select? (#{"entity" "list" "link"} (:type (:attrs property)))] - (if - (= (:distinct (:attrs property)) "system") + writable-by (if (= (:tag form) :form) (writable-by permissions))] + (case w-type + "hidden" {:tag :input :attrs {:id widget-name :name widget-name :type "hidden" :value (str "{{record." widget-name "}}")}} - {:tag :p - :attrs {:class "widget"} - :content [{:tag :label - :attrs {:for widget-name} - :content [(prompt field-or-property form entity application)]} - (compose-if-member-of-tag property entity application true) - (cond - select? - (select-widget property form entity application) - true - {:tag :input - :attrs (merge - {:id widget-name - :name widget-name - :type (widget-type property application typedef) - :value (str "{{record." widget-name "}}") - :maxlength (:size (:attrs property)) - :size (cond - (nil? (:size (:attrs property))) - "16" - (try - (> (read-string - (:size (:attrs property))) 60) - (catch Exception _ false)) - "60" - true - (:size (:attrs property)))} - (if - (:minimum (:attrs typedef)) - {:min (:minimum (:attrs typedef))}) - (if - (:maximum (:attrs typedef)) - {:max (:maximum (:attrs typedef))}))}) - "{% else %}" - (compose-if-member-of-tag property entity application false) - {:tag :span - :attrs {:id widget-name - :name widget-name - :class "pseudo-widget disabled"} - :content [(str "{{record." widget-name "}}")]} - "{% else %}" - {:tag :span - :attrs {:id widget-name - :name widget-name - :class "pseudo-widget not-authorised"} - :content [(str "You are not permitted to view " widget-name " of " (:name (:attrs entity)))]} - "{% endifmemberof %}" - "{% endifmemberof %}"]}))) + "select" + (compose-widget-para field-or-property form entity application widget-name + (select-widget property form entity application)) + ;; all others + (compose-widget-para + field-or-property form entity application widget-name + {:tag :input + :attrs (merge + {:id widget-name + :name widget-name + :type w-type + :value (str "{{record." widget-name "}}") + :maxlength (:size (:attrs property)) + :size (cond + (nil? (:size (:attrs property))) + "16" + (try + (> (read-string + (:size (:attrs property))) 60) + (catch Exception _ false)) + "60" + true + (:size (:attrs property)))} + (if + (:minimum (:attrs typedef)) + {:min (:minimum (:attrs typedef))}) + (if + (:maximum (:attrs typedef)) + {:max (:maximum (:attrs typedef))}))})))) + + +(defn compose-select-script-header [entity application] + ["{% block extra-head %}" + {:tag :script :attrs {:type "text/javascript"} + :content + [(slurp "resources/js/select-widget-support.js")]} + "{% endblock %}"]) (defn form-to-template @@ -362,29 +388,35 @@ taken from this `application`. If `form` is nill, generate a default form template for the entity." [form entity application] - {:tag :div - :attrs {:id "content" :class "edit"} - :content - [{:tag :form - :attrs {:action (str "{{servlet-context}}/" (editor-name entity application)) - :method "POST"} - :content (flatten - (list - (csrf-widget) - (map - #(widget % form entity application) - (children-with-tag (child-with-tag entity :key) :properties)) - (map - #(widget % form entity application) - (remove - #(let - [property (filter - (fn [p] (= (:name (:attrs p)) (:property (:attrs %)))) - (descendants-with-tag entity :property))] - (= (:distict (:attrs property)) :system)) - (children-with-tag form :field))) - (save-widget form entity application) - (delete-widget form entity application)))}]}) + (merge + {:content + {:tag :div + :attrs {:id "content" :class "edit"} + :content + [{:tag :form + :attrs {:action (str "{{servlet-context}}/" (editor-name entity application)) + :method "POST"} + :content (flatten + (list + (csrf-widget) + (map + #(widget % form entity application) + (children-with-tag (child-with-tag entity :key) :properties)) + (map + #(widget % form entity application) + (remove + #(let + [property (filter + (fn [p] (= (:name (:attrs p)) (:property (:attrs %)))) + (descendants-with-tag entity :property))] + (= (:distict (:attrs property)) :system)) + (children-with-tag form :field))) + (save-widget form entity application) + (delete-widget form entity application)))}]}} + (if + (some #(= "select" (widget-type % application)) (properties entity)) + {:header (compose-select-script-header entity application)} + {}))) (defn page-to-template @@ -542,7 +574,8 @@ taken from this `application`. If `list` is nill, generate a default list template for the entity." [list-spec entity application] - {:tag :form + {:content + {:tag :form :attrs {:id "content" :class "list"} :content [(big-link (str "Add a new " (pretty-name entity)) (editor-name entity application)) @@ -551,7 +584,7 @@ :content [(list-thead list-spec entity application) (list-tbody list-spec entity application) - (list-tfoot list-spec entity application)]}]}) + (list-tfoot list-spec entity application)]}]}}) (defn entity-to-templates @@ -590,7 +623,6 @@ (form-to-template nil entity application)}))))) - (defn application-to-template [application] (let @@ -629,7 +661,6 @@ first-class-entities)))}})) - (defn write-template-file [filename template application] (let [filepath (str *output-path* "resources/templates/auto/" filename)] @@ -641,11 +672,23 @@ filepath (s/join "\n" - (list - (file-header filename application) - (with-out-str - (x/emit-element template)) - (file-footer filename application)))) + (flatten + (list + (file-header filename application) + (map + #(cond + (:tag %) + (with-out-str + (x/emit-element %)) + (string? %) + % + true + (str ";; WTF? " %)) + (:header template)) + "{% block content %}" + (with-out-str + (x/emit-element (:content template))) + (file-footer filename application))))) (if (> *verbosity* 0) (println "\tGenerated " filepath)) (catch Exception any (let [report (str @@ -659,10 +702,21 @@ (with-out-str (println (str "")) (p/pprint template))) - (println report))))) + (println report) + (throw any))))) (str filepath))) +;; (def a (x/parse "../youyesyet/youyesyet.canonical.adl.xml")) +;; (def e (child-with-tag a :entity)) +;; (def f (child-with-tag e :form)) +;; (write-template-file "froboz" (form-to-template f e a) a) +;; (def t (form-to-template f e a)) +;; (map type t) +;; t + + + (defn to-selmer-templates "Generate all [Selmer](https://github.com/yogthos/Selmer) templates implied by this ADL `application` spec." [application] From ac070b537fba30f68fa835897bda8eb18913150e Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 4 Jul 2018 22:29:33 +0100 Subject: [PATCH 41/52] Small improvements. More and more works. --- src/adl/to_hugsql_queries.clj | 7 +-- src/adl/to_selmer_routes.clj | 66 ++++++++++++++++++--------- src/adl/to_selmer_templates.clj | 81 +++++++++++++++++---------------- 3 files changed, 87 insertions(+), 67 deletions(-) diff --git a/src/adl/to_hugsql_queries.clj b/src/adl/to_hugsql_queries.clj index 3da9fd6..0dabffd 100644 --- a/src/adl/to_hugsql_queries.clj +++ b/src/adl/to_hugsql_queries.clj @@ -114,10 +114,6 @@ (defn update-query "Generate an appropriate `update` query for this `entity`" [entity] - (if - (and - (has-primary-key? entity) - (has-non-key-properties? entity)) (let [entity-name (safe-name (:name (:attrs entity)) :sql) pretty-name (singularise entity-name) property-names (map #(:name (:attrs %)) (insertable-properties entity)) @@ -136,8 +132,7 @@ "SET " (s/join ",\n\t" (map #(str (safe-name % :sql) " = " (keyword %)) property-names)) "\n" - (where-clause entity))})) - {})) + (where-clause entity))}))) (defn search-query [entity application] diff --git a/src/adl/to_selmer_routes.clj b/src/adl/to_selmer_routes.clj index ed4fe70..e016a3f 100644 --- a/src/adl/to_selmer_routes.clj +++ b/src/adl/to_selmer_routes.clj @@ -182,28 +182,49 @@ (list 'l/render (list 'support/resolve-template (str n ".html")) - '(:session r) - (merge - {:title (capitalise (:name (:attrs f))) - :params 'p} - (case (:tag f) - (:form :page) - (reduce - merge - {:record - (list 'if (list 'empty? (list 'remove 'nil? (list 'vals 'p))) [] - (list - (symbol - (str "db/get-" (singularise (:name (:attrs e))))) - (symbol "db/*db*") - 'p))} - (map - (fn [p] - (hash-map - (keyword (-> p :attrs :entity)) - (list (symbol (str "db/list-" (:entity (:attrs p)))) (symbol "db/*db*")))) - (filter #(#{"entity" "link"} (:type (:attrs %))) - (descendants-with-tag e :property)))) + (list :session 'r) + (list 'merge + {:title (capitalise (:name (:attrs f))) + :params 'p} + (case (:tag f) + (:form :page) + (list + 'reduce + 'merge + (list 'merge + (list 'cond (list :save-button 'p) + (list 'try + (list 'if + (list 'some (key-names e) (list 'map 'name (list 'keys 'p))) + (list 'do + (list (symbol + (str "db/update-" (singularise (-> e :attrs :name)) "!")) + 'db/*db* + 'p) + {:message "Updated record"}) + (list 'do + (list (symbol + (str "db/create-" (singularise (-> e :attrs :name)) "!")) + 'db/*db* + 'p) + {:message "Saved record"})) + `(catch Exception any# + {:error (.getMessage any#)}))) + {:record + (list 'if (list 'empty? (list 'remove 'nil? (list 'vals 'p))) [] + (list + (symbol + (str "db/get-" (singularise (:name (:attrs e))))) + (symbol "db/*db*") + 'p))}) + (cons 'list + (map + (fn [p] + (hash-map + (keyword (-> p :attrs :entity)) + (list (symbol (str "db/list-" (:entity (:attrs p)))) (symbol "db/*db*")))) + (filter #(#{"entity" "link"} (:type (:attrs %))) + (descendants-with-tag e :property))))) :list {:records (list @@ -231,6 +252,7 @@ ;; (def e (child-with-tag a :entity)) ;; (def f (child-with-tag e :form)) ;; (def n (path-part f e a)) +;; (make-handler f e a) ;; (vector ;; 'p ;; (list 'merge diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj index 011aad2..bd2b89d 100644 --- a/src/adl/to_selmer_templates.clj +++ b/src/adl/to_selmer_templates.clj @@ -114,7 +114,6 @@ "\n" (flatten (list - "{% endblock %}" (emit-content filename spec entity application :foot)))))) @@ -238,38 +237,42 @@ magnitude (try (read-string (:magnitude (:attrs farside))) (catch Exception _ 7)) async? (and (number? magnitude) (> magnitude 1)) widget-name (safe-name (:name (:attrs property)) :sql)] - {:tag :div + {:tag :span :attrs {:class "select-box" :farside farname :found (if farside "true" "false")} :content (apply vector (remove nil? - (list - (if - async? - {:tag :input - :attrs - {:name (str widget-name "_search_box") - :onchange (str "$.getJSON(\"/auto/json/seach-strings-" (-> farside :attrs :name) - "?" - (s/join (str "=\" + " widget-name "_search_box.text + \"&") - (user-distinct-property-names farside)) - (str "=\" + " widget-name "_search_box.text") - ", null, function (data) {updateMenuOptions(\"" - widget-name "\", \"" - (first (key-names farside)) - "\", [\"" - (s/join "\", \"" (user-distinct-property-names farside)) - "\"], data);})")}}) - {:tag :select - :attrs (merge - {:id widget-name - :name widget-name} - (if - (= (:type (:attrs property)) "link") - {:multiple "multiple"})) - :content (apply vector (get-options property form entity application))})))})) + (flatten + (list + (if + async? + (list + {:tag :input + :attrs + {:name (str widget-name "_search_box") + :onchange (str "$.getJSON(\"/auto/json/seach-strings-" + (-> farside :attrs :name) + "?" + (s/join (str "=\" + " widget-name "_search_box.text + \"&") + (user-distinct-property-names farside)) + (str "=\" + " widget-name "_search_box.text") + ", null, function (data) {updateMenuOptions(\"" + widget-name "\", \"" + (first (key-names farside)) + "\", [\"" + (s/join "\", \"" (user-distinct-property-names farside)) + "\"], data);})")}} + {:tag :br})) + {:tag :select + :attrs (merge + {:id widget-name + :name widget-name} + (if + (= (:type (:attrs property)) "link") + {:multiple "multiple"})) + :content (apply vector (get-options property form entity application))}))))})) (defn compose-if-member-of-tag @@ -378,11 +381,9 @@ (defn compose-select-script-header [entity application] - ["{% block extra-head %}" - {:tag :script :attrs {:type "text/javascript"} + {:tag :script :attrs {:type "text/javascript"} :content - [(slurp "resources/js/select-widget-support.js")]} - "{% endblock %}"]) + [(slurp "resources/js/select-widget-support.js")]}) (defn form-to-template @@ -417,7 +418,7 @@ (delete-widget form entity application)))}]}} (if (some #(= "select" (widget-type % application)) (properties entity)) - {:header (compose-select-script-header entity application)} + {:extra-head (compose-select-script-header entity application)} {}))) @@ -467,13 +468,15 @@ :content [{:tag :tr :content - (apply - vector - (map - #(hash-map - :content [(prompt %)] - :tag :th) - (children-with-tag list-spec :field)))} + (conj + (apply + vector + (map + #(hash-map + :content [(prompt %)] + :tag :th) + (children-with-tag list-spec :field))) + {:tag :th :content [" "]})} {:tag :tr :content (apply From 66d4b2af4db2b3b8bd2895602c1342c3a5596a78 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 5 Jul 2018 11:15:25 +0100 Subject: [PATCH 42/52] Added more if-member-of checks; added simplemde support. --- resources/js/text-area-md-support.js | 17 ++ src/adl/to_selmer_templates.clj | 400 +++++++++++++++++---------- 2 files changed, 274 insertions(+), 143 deletions(-) create mode 100644 resources/js/text-area-md-support.js diff --git a/resources/js/text-area-md-support.js b/resources/js/text-area-md-support.js new file mode 100644 index 0000000..d7fb7aa --- /dev/null +++ b/resources/js/text-area-md-support.js @@ -0,0 +1,17 @@ + var simplemde = new SimpleMDE({ + autosave: { + enabled: true, + uniqueId: "Smeagol-{{page}}", + delay: 1000, + }, + indentWithTabs: true, + insertTexts: { + horizontalRule: ["", "\n\n-----\n\n"], + image: ["![](http://", ")"], + link: ["[", "](http://)"], + table: ["", "\n\n| Column 1 | Column 2 | Column 3 |\n| -------- | -------- | -------- |\n| Text | Text | Text |\n\n"], + }, + showIcons: ["code"], //, "table"], - sadly, markdown-clj does not support tables + spellChecker: true, + status: ["autosave", "lines", "words", "cursor"] + }); diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj index bd2b89d..77460f1 100644 --- a/src/adl/to_selmer_templates.clj +++ b/src/adl/to_selmer_templates.clj @@ -59,27 +59,49 @@ (defn emit-content + ([content] + (cond + (nil? content) + nil + (string? content) + content + (and (map? content) (:tag content)) + (with-out-str + (x/emit-element content)) + (seq? content) + (map emit-content content) + true + (str ""))) ([filename application k] (emit-content filename nil nil application k)) ([filename spec entity application k] (let [content (:content - (first - (or (children-with-tag spec k) - (children-with-tag entity k) - (children-with-tag - (child-with-tag application :content) - k))))] + (first + (or (children-with-tag spec k) + (children-with-tag entity k) + (children-with-tag + (child-with-tag application :content) + k))))] (if content (flatten - (list - (str "{% block " (name k) " %}") - (doall - (map - #(with-out-str (x/emit-element %)) - content)) - "{% endblock %}")))))) + (list + (str "{% block " (name k) " %}") + (doall + (map + emit-content + content)) + "{% endblock %}")))))) + +;; {:tag :div, :content +;; [{:tag :div, :attrs {:class big-link-container}, :content +;; [{:tag :a, :attrs {:id next-selector, :role button, :class big-link}, +;; :content [Next]}]} +;; [{% ifmemberof admin %} +;; {:tag :div, :attrs {:class big-link-container}, :content +;; [{:tag :a, :attrs {:href form-electors-Elector, :class big-link}, :content [Add a new Elector]}]} +;; {% endifmemberof %}]]} (defn file-header @@ -141,22 +163,56 @@ "{% csrf-field %}") +(defn compose-if-member-of-tag + [writable? & elts] + (let + [all-permissions (distinct (apply find-permissions elts)) + permissions (map + s/lower-case + (if + writable? + (writable-by all-permissions) + (visible-to all-permissions)))] + (s/join + " " + (flatten + (list + "{% ifmemberof" + permissions + "%}"))))) + + +(defn wrap-in-if-member-of + "Wrap this `content` in an if-member-of tag; if `writable?` is true, + allow those groups by whom it is writable, else those by whom it is + readable. `context` should be a sequence of adl elements from which + permissions may be obtained." + [content writable? & context] + [(apply compose-if-member-of-tag (cons writable? context)) + content + "{% endifmemberof %}"]) + + (defn save-widget "Return an appropriate 'save' widget for this `form` operating on this `entity` taken from this `application`. TODO: should be suppressed unless a member of a group which can insert or edit." [form entity application] - {:tag :p - :attrs {:class "widget action-safe"} - :content [{:tag :label - :attrs {:for "save-button" :class "action-safe"} - :content [(str "To save this " (:name (:attrs entity)) " record")]} - {:tag :input - :attrs {:id "save-button" - :name "save-button" - :class "action-safe" - :type "submit" - :value (str "Save!")}}]}) + (wrap-in-if-member-of + {:tag :p + :attrs {:class "widget action-safe"} + :content [{:tag :label + :attrs {:for "save-button" :class "action-safe"} + :content [(str "To save this " (:name (:attrs entity)) " record")]} + {:tag :input + :attrs {:id "save-button" + :name "save-button" + :class "action-safe" + :type "submit" + :value (str "Save!")}}]} + true + entity + application)) (defn delete-widget @@ -164,17 +220,21 @@ from this `application`. TODO: should be suppressed unless member of a group which can delete." [form entity application] - {:tag :p - :attrs {:class "widget action-dangerous"} - :content [{:tag :label - :attrs {:for "delete-button" :class "action-dangerous"} - :content [(str "To delete this " (:name (:attrs entity)) " record")]} - {:tag :input - :attrs {:id "delete-button" - :name "delete-button" - :class "action-dangerous" - :type "submit" - :value (str "Delete!")}}]}) + (wrap-in-if-member-of + {:tag :p + :attrs {:class "widget action-dangerous"} + :content [{:tag :label + :attrs {:for "delete-button" :class "action-dangerous"} + :content [(str "To delete this " (:name (:attrs entity)) " record")]} + {:tag :input + :attrs {:id "delete-button" + :name "delete-button" + :class "action-dangerous" + :type "submit" + :value (str "Delete!")}}]} + true + entity + application)) (defn get-options @@ -224,7 +284,8 @@ "boolean" "checkbox" "date" "date" "time" "time" - "text" ;; default + "text" "text-area" + "string" ;; default ))))) @@ -275,25 +336,6 @@ :content (apply vector (get-options property form entity application))}))))})) -(defn compose-if-member-of-tag - [property entity application writable?] - (let - [all-permissions (find-permissions property entity application) - permissions (map - s/lower-case - (if - writable? - (writable-by all-permissions) - (visible-to all-permissions)))] - (s/join - " " - (flatten - (list - "{% ifmemberof" - permissions - "%}"))))) - - (defn compose-widget-para [p f e a w content] {:tag :p @@ -301,10 +343,10 @@ :content [{:tag :label :attrs {:for w} :content [(prompt p f e a)]} - (compose-if-member-of-tag p e a true) + (compose-if-member-of-tag true p e a) content "{% else %}" - (compose-if-member-of-tag p e a false) + (compose-if-member-of-tag false p e a) {:tag :span :attrs {:id w :name w @@ -352,6 +394,12 @@ "select" (compose-widget-para field-or-property form entity application widget-name (select-widget property form entity application)) + "text-area" + (compose-widget-para + field-or-property form entity application widget-name + {:tag :textarea + :attrs {:rows "8" :cols "60" :id widget-name :name widget-name} + :content [(str "{{record." widget-name "}}")]}) ;; all others (compose-widget-para field-or-property form entity application widget-name @@ -380,18 +428,23 @@ {:max (:maximum (:attrs typedef))}))})))) -(defn compose-select-script-header [entity application] - {:tag :script :attrs {:type "text/javascript"} - :content - [(slurp "resources/js/select-widget-support.js")]}) +(defn embed-script-fragment + "Return the content of the file at `fielpath`, with these `substitutions` + made into it in order. Substitutions should be pairss [`pattern` `value`], + where `pattern` is a string, a char, or a regular expression." + ([filepath substitutions] + (let [v (slurp filepath)] + (reduce + (fn [s [pattern value]] + (s/replace s pattern value)) + v + substitutions))) + ([filepath] + (embed-script-fragment filepath []))) -(defn form-to-template - "Generate a template as specified by this `form` element for this `entity`, - taken from this `application`. If `form` is nill, generate a default form - template for the entity." +(defn compose-form-content [form entity application] - (merge {:content {:tag :div :attrs {:id "content" :class "edit"} @@ -415,11 +468,48 @@ (= (:distict (:attrs property)) :system)) (children-with-tag form :field))) (save-widget form entity application) - (delete-widget form entity application)))}]}} - (if - (some #(= "select" (widget-type % application)) (properties entity)) - {:extra-head (compose-select-script-header entity application)} - {}))) + (delete-widget form entity application)))}]}}) + + +(defn compose-form-extra-head + [form entity application] + {:extra-head + (if + (some + #(= "text-area" (widget-type % application)) (properties entity)) + "{% script \"js/lib/node_modules/simplemde/dist/simplemde.min.js\" %} + {% style \"js/lib/node_modules/simplemde/dist/simplemde.min.css\" %}")}) + + + (defn compose-form-extra-tail + [form entity application] + {:extra-tail + {:tag :script :attrs {:type "text/javascript"} + :content + (apply + vector + (remove + nil? + (list + (if + (some + #(= "select" (widget-type % application)) (properties entity)) + (embed-script-fragment "resources/js/select-widget-support.js")) + (if + (some + #(= "text-area" (widget-type % application)) (properties entity)) + (embed-script-fragment "resources/js/text-area-md-support.js")))))}}) + + +(defn form-to-template + "Generate a template as specified by this `form` element for this `entity`, + taken from this `application`. If `form` is nill, generate a default form + template for the entity." + [form entity application] + (merge + (compose-form-extra-head form entity application) + (compose-form-content form entity application) + (compose-form-extra-tail form entity application))) (defn page-to-template @@ -552,33 +642,43 @@ [list-spec entity application] (let [form-name (str - "list-" - (:name (:attrs entity)) - "-" - (:name (:attrs list-spec)))] + "list-" + (:name (:attrs entity)) + "-" + (:name (:attrs list-spec)))] {:back-links {:tag :div :content [ - {:tag :div :attrs {:class "back-link-container"} - :content - ["{% ifequal params.offset \"0\" %}" + {:tag :div :attrs {:class "back-link-container"} + :content + ["{% ifequal params.offset \"0\" %}" {:tag :a - :attrs {:id "back-link" :class "back-link" :href "{{servlet-context}}/admin"} - :content ["Back"]} - "{% else %}" + :attrs {:id "back-link" :class "back-link" :href "{{servlet-context}}/admin"} + :content ["Back"]} + "{% else %}" {:tag :a :attrs {:id "prev-selector" :class "back-link"} - :content ["Previous"]} - "{% endifunequal %}"]} - ]} + :content ["Previous"]} + "{% endifunequal %}"]} + ]} :big-links {:tag :div :content - [{:tag :div :attrs {:class "big-link-container"} - :content - [{:tag :a :attrs {:id "next-selector" :role "button" :class "big-link"} - :content ["Next"]}]} - (big-link (str "Add a new " (pretty-name entity)) (editor-name entity application))]} + (apply + vector + (remove + nil? + (flatten + (list + {:tag :div :attrs {:class "big-link-container"} + :content + [{:tag :a :attrs {:id "next-selector" :role "button" :class "big-link"} + :content ["Next"]}]} + (wrap-in-if-member-of + (big-link (str "Add a new " (pretty-name entity)) (editor-name entity application)) + true + entity + application)))))} :content {:tag :form :attrs {:id form-name :class "list" @@ -591,30 +691,30 @@ {:tag :table :attrs {:caption (:name (:attrs entity))} :content - [(list-thead list-spec entity application) - (list-tbody list-spec entity application) - ]}]} + [(list-thead list-spec entity application) + (list-tbody list-spec entity application) + ]}]} :extra-script (str " var form = document.getElementById('" form-name "'); var ow = document.getElementById('offset'); var lw = document.getElementById('limit'); form.addEventListener('submit', function() { - ow.value='0'; + ow.value='0'; }); {% ifunequal params.offset \"0\" %} document.getElementById('prev-selector').addEventListener('click', function () { - ow.value=(parseInt(ow.value)-parseInt(lw.value)); - console.log('Updated offset to ' + ow.value); - form.submit(); + ow.value=(parseInt(ow.value)-parseInt(lw.value)); + console.log('Updated offset to ' + ow.value); + form.submit(); }); {% endifunequal %} document.getElementById('next-selector').addEventListener('click', function () { - ow.value=(parseInt(ow.value)+parseInt(lw.value)); - console.log('Updated offset to ' + ow.value); - form.submit(); + ow.value=(parseInt(ow.value)+parseInt(lw.value)); + console.log('Updated offset to ' + ow.value); + form.submit(); });")})) @@ -654,43 +754,63 @@ (form-to-template nil entity application)}))))) -(defn application-to-template - [application] - (let - [first-class-entities - (sort-by - #(:name (:attrs %)) - (filter - #(children-with-tag % :list) - (children-with-tag application :entity)))] - {:application-index - {:content - {:tag :dl - :attrs {:class "index"} - :content - (apply - vector - (interleave - (map - #(hash-map - :tag :dt - :content - [{:tag :a - :attrs {:href (path-part :list % application)} - :content [(pretty-name %)]}]) - first-class-entities) - (map - #(hash-map - :tag :dd - :content (apply - vector - (map - (fn [d] - (hash-map - :tag :p - :content (:content d))) - (children-with-tag % :documentation)))) - first-class-entities)))}}})) +(defn emit-entity-dt + [entity application] + (wrap-in-if-member-of + {:tag :dt + :content + [{:tag :a + :attrs {:href (path-part :list entity application)} + :content [(pretty-name entity)]}]} + false + entity + application)) + + +(defn emit-entity-dd + [entity application] + (wrap-in-if-member-of + {:tag :dd + :content + (apply + vector + (map + (fn [d] + (hash-map + :tag :p + :content (:content d))) + (children-with-tag entity :documentation)))} + false + entity + application)) + + + (defn application-to-template + [application] + (let + [first-class-entities + (sort-by + #(:name (:attrs %)) + (filter + #(children-with-tag % :list) + (children-with-tag application :entity)))] + {:application-index + {:content + {:tag :dl + :attrs {:class "index"} + :content + (apply + vector + (remove + nil? + (flatten + (interleave + (map + #(emit-entity-dt % application) + first-class-entities) + (map + #(emit-entity-dd % application) + first-class-entities)))))}}})) (defn write-template-file @@ -712,13 +832,7 @@ #(let [content (template %)] (list (str "{% block " (name %) " %}") - (cond (string? content) - content - (map? content) - (with-out-str - (x/emit-element content)) - true - (str "")) + (emit-content content) "{% endblock %}")) (keys template))) (file-footer filename application))))) From 7d629768808903be45c426af9114e97e0c7e0201 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 7 Jul 2018 09:06:13 +0100 Subject: [PATCH 43/52] Allow for multiple distinct links between the same two entities. --- src/adl/to_hugsql_queries.clj | 2 +- src/adl/to_json_routes.clj | 40 ++++++++++++++++++++------------- src/adl/to_psql.clj | 2 +- src/adl/to_selmer_templates.clj | 19 ++++++++-------- 4 files changed, 37 insertions(+), 26 deletions(-) diff --git a/src/adl/to_hugsql_queries.clj b/src/adl/to_hugsql_queries.clj index 0dabffd..2387610 100644 --- a/src/adl/to_hugsql_queries.clj +++ b/src/adl/to_hugsql_queries.clj @@ -306,7 +306,7 @@ "\n\tAND " entity-name "." link-field " = :id") (order-by-clause entity "lv_")) "link" (let [link-table-name - (link-table-name entity far-entity)] + (link-table-name % entity far-entity)] (list (str "-- :name " query-name " " signature) (str "-- :doc links all existing " pretty-name " records related to a given " pretty-far) diff --git a/src/adl/to_json_routes.clj b/src/adl/to_json_routes.clj index 87f8677..5d59257 100644 --- a/src/adl/to_json_routes.clj +++ b/src/adl/to_json_routes.clj @@ -37,6 +37,12 @@ ;;; to-hugsql-queries, because essentially we need one JSON entry point to wrap ;;; each query. +;;; TODO: memoisation of handlers probably doesn't make sense, because every request +;;; will be different. I don't think we can memoise HugSQL, at least not without +;;; hacking the library (might be worth doing that and contributing a patch). +;;; So the solution may be to an intervening namespace 'cache', which has one +;;; memoised function for each hugsql query. + (defn file-header [application] (list 'ns @@ -65,21 +71,25 @@ (defn generate-handler-body "Generate and return the function body for the handler for this `query`." [query] - (list - [{:keys ['params 'form-params]}] - (list 'let - (vector - 'result - (list - (symbol (str "db/" (:name query))) - 'db/*db* - (list 'support/massage-params - 'params 'form-params (key-names (:entity query))))) - (case - (:type query) - (:delete-1 :update-1) - '(response/found "/") - (list 'response/ok 'result))))) + (let [action (list + (symbol (str "db/" (:name query))) + 'db/*db* + (list 'support/massage-params + 'params + 'form-params + (key-names (:entity query))))] + (list + [{:keys ['params 'form-params]}] + (case + (:type query) + (:delete-1 :update-1) + (list + action + '(response/found "/")) + (list + 'let + (vector 'result action) + (list 'response/ok 'result)))))) (defn generate-handler-src diff --git a/src/adl/to_psql.clj b/src/adl/to_psql.clj index f7aea86..2734198 100644 --- a/src/adl/to_psql.clj +++ b/src/adl/to_psql.clj @@ -461,7 +461,7 @@ #(and (entity? %) (= (:name (:attrs %)) (:entity (:attrs property))))) - link-table-name (link-table-name e1 e2)] + link-table-name (link-table-name property e1 e2)] (if ;; we haven't already emitted this one... (not (@emitted-link-tables link-table-name)) diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj index 77460f1..3e6767c 100644 --- a/src/adl/to_selmer_templates.clj +++ b/src/adl/to_selmer_templates.clj @@ -146,15 +146,16 @@ ([field-or-property form entity application] (prompt field-or-property)) ([field-or-property] - (or - (first - (children - field-or-property - #(and - (= (:tag %) :prompt) - (= (:locale :attrs %) *locale*)))) - (:name (:attrs field-or-property)) - (:property (:attrs field-or-property))))) + (capitalise + (or + (first + (children + field-or-property + #(and + (= (:tag %) :prompt) + (= (:locale :attrs %) *locale*)))) + (:name (:attrs field-or-property)) + (:property (:attrs field-or-property)))))) (defn csrf-widget From 238bbf1187db11d1f8b4f7c7e478f9a0f8fb81c9 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 9 Jul 2018 21:57:56 +0100 Subject: [PATCH 44/52] #4: fixed --- .gitignore | 3 + src/adl/to_selmer_templates.clj | 311 +++++++++++++++++--------------- src/adl/to_swagger.clj | 61 +++++++ 3 files changed, 229 insertions(+), 146 deletions(-) create mode 100644 src/adl/to_swagger.clj diff --git a/.gitignore b/.gitignore index 7f97479..faf3ae7 100644 --- a/.gitignore +++ b/.gitignore @@ -9,6 +9,7 @@ pom.xml.asc /.nrepl-port .hgignore .hg/ +.idea resources/auto/ @@ -17,3 +18,5 @@ generated/resources/sql/ generated/resources/templates/auto/ generated/src/clj/youyesyet/routes/ + +*.iml diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj index 3e6767c..4aa5eb9 100644 --- a/src/adl/to_selmer_templates.clj +++ b/src/adl/to_selmer_templates.clj @@ -39,7 +39,7 @@ {:tag :div :attrs {:class "big-link-container"} :content - [{:tag :a :attrs {:href url :class "big-link"} + [{:tag :a :attrs {:href (str "{{servlet-context}}/" url) :class "big-link"} :content (if (vector? content) content @@ -51,7 +51,7 @@ {:tag :div :attrs {:class "back-link-container"} :content - [{:tag :a :attrs {:href url} + [{:tag :a :attrs {:href (str "{{servlet-context}}/" url)} :content (if (vector? content) content @@ -60,18 +60,20 @@ (defn emit-content ([content] - (cond - (nil? content) - nil - (string? content) - content - (and (map? content) (:tag content)) - (with-out-str - (x/emit-element content)) - (seq? content) - (map emit-content content) - true - (str ""))) + (try + (cond + (nil? content) + nil + (string? content) + content + (and (map? content) (:tag content)) + (with-out-str + (x/emit-element content)) + (seq? content) + (map emit-content content) + true + (str "")) + (catch Exception _ (str "")))) ([filename application k] (emit-content filename nil nil application k)) ([filename spec entity application k] @@ -94,15 +96,6 @@ content)) "{% endblock %}")))))) -;; {:tag :div, :content -;; [{:tag :div, :attrs {:class big-link-container}, :content -;; [{:tag :a, :attrs {:id next-selector, :role button, :class big-link}, -;; :content [Next]}]} -;; [{% ifmemberof admin %} -;; {:tag :div, :attrs {:class big-link-container}, :content -;; [{:tag :a, :attrs {:href form-electors-Elector, :class big-link}, :content [Add a new Elector]}]} -;; {% endifmemberof %}]]} - (defn file-header "Generate a header for a template file with this `filename` for this `spec` @@ -155,7 +148,8 @@ (= (:tag %) :prompt) (= (:locale :attrs %) *locale*)))) (:name (:attrs field-or-property)) - (:property (:attrs field-or-property)))))) + (:property (:attrs field-or-property)) + "Missing prompt")))) (defn csrf-widget @@ -165,15 +159,15 @@ (defn compose-if-member-of-tag - [writable? & elts] + [privilege & elts] (let [all-permissions (distinct (apply find-permissions elts)) permissions (map s/lower-case - (if - writable? - (writable-by all-permissions) - (visible-to all-permissions)))] + (case privilege + :writeable (writeable-by all-permissions) + :editable (writeable-by all-permissions true) + :readable (visible-to all-permissions)))] (s/join " " (flatten @@ -184,12 +178,12 @@ (defn wrap-in-if-member-of - "Wrap this `content` in an if-member-of tag; if `writable?` is true, - allow those groups by whom it is writable, else those by whom it is + "Wrap this `content` in an if-member-of tag; if `writeable?` is true, + allow those groups by whom it is writeable, else those by whom it is readable. `context` should be a sequence of adl elements from which permissions may be obtained." - [content writable? & context] - [(apply compose-if-member-of-tag (cons writable? context)) + [content privilege & context] + [(apply compose-if-member-of-tag (cons privilege context)) content "{% endifmemberof %}"]) @@ -211,7 +205,7 @@ :class "action-safe" :type "submit" :value (str "Save!")}}]} - true + :editable entity application)) @@ -233,7 +227,7 @@ :class "action-dangerous" :type "submit" :value (str "Delete!")}}]} - true + :editable entity application)) @@ -275,9 +269,8 @@ (:type (:attrs typedef)) (:type (:attrs property)))] (if - (= (-> property :attrs :distinct) "system") - "hidden" ;; <- this is slightly wrong. There are some circumstances in which - ;; system-distinct properties might be user-editable + (and (= (-> property :attrs :distinct) "system") (= (-> property :attrs :immutable) "true")) + "hidden" (case t ("integer" "real" "money") "number" ("uploadable" "image") "file" @@ -286,8 +279,8 @@ "date" "date" "time" "time" "text" "text-area" - "string" ;; default - ))))) + ;; default + "string"))))) (defn select-widget @@ -337,30 +330,49 @@ :content (apply vector (get-options property form entity application))}))))})) +(defn compose-readable-or-not-authorised + [p f e a w] + (list + (compose-if-member-of-tag :readable p e a) + {:tag :span + :attrs {:id w + :name w + :class "pseudo-widget disabled"} + :content [(str "{{record." w "}}")]} + "{% else %}" + {:tag :span + :attrs {:id w + :name w + :class "pseudo-widget not-authorised"} + :content [(str "You are not permitted to view " w " of " (:name (:attrs e)))]} + "{% endifmemberof %}" + )) + + (defn compose-widget-para [p f e a w content] {:tag :p :attrs {:class "widget"} - :content [{:tag :label - :attrs {:for w} - :content [(prompt p f e a)]} - (compose-if-member-of-tag true p e a) - content - "{% else %}" - (compose-if-member-of-tag false p e a) - {:tag :span - :attrs {:id w - :name w - :class "pseudo-widget disabled"} - :content [(str "{{record." w "}}")]} - "{% else %}" - {:tag :span - :attrs {:id w - :name w - :class "pseudo-widget not-authorised"} - :content [(str "You are not permitted to view " w " of " (:name (:attrs e)))]} - "{% endifmemberof %}" - "{% endifmemberof %}"]}) + :content (apply + vector + (flatten + (list + {:tag :label + :attrs {:for w} + :content [(prompt p f e a)]} + (str "{% if {{record." (-> p :attrs :name) "}} %}") + (compose-if-member-of-tag :editable p e a) + content + "{% else %}" + (compose-readable-or-not-authorised p f e a w) + "{% endifmemberof %}" + "{% else %}" + (compose-if-member-of-tag :writeable p e a) + content + "{% else %}" + (compose-readable-or-not-authorised p f e a w) + "{% endifmemberof %}" + "{% endif %}")))}) (defn widget @@ -375,58 +387,62 @@ property (if (= (:tag field-or-property) :property) field-or-property - (child-with-tag entity - :property - #(= (:name (:attrs %)) - (:property (:attrs field-or-property))))) + (first + (filter + #(= (:name (:attrs %)) + (:property (:attrs field-or-property))) + (descendants-with-tag entity + :property)))) permissions (find-permissions field-or-property property form entity application) typedef (typedef property application) w-type (widget-type property application typedef) visible-to (visible-to permissions) - ;; if the form isn't actually a form, no widget is writable. - writable-by (if (= (:tag form) :form) (writable-by permissions))] - (case w-type - "hidden" - {:tag :input - :attrs {:id widget-name - :name widget-name - :type "hidden" - :value (str "{{record." widget-name "}}")}} - "select" - (compose-widget-para field-or-property form entity application widget-name - (select-widget property form entity application)) - "text-area" - (compose-widget-para - field-or-property form entity application widget-name - {:tag :textarea - :attrs {:rows "8" :cols "60" :id widget-name :name widget-name} - :content [(str "{{record." widget-name "}}")]}) - ;; all others - (compose-widget-para - field-or-property form entity application widget-name + ;; if the form isn't actually a form, no widget is writeable. + writeable-by (if (= (:tag form) :form) (writeable-by permissions))] + (if + property + (case w-type + "hidden" {:tag :input - :attrs (merge - {:id widget-name - :name widget-name - :type w-type - :value (str "{{record." widget-name "}}") - :maxlength (:size (:attrs property)) - :size (cond - (nil? (:size (:attrs property))) - "16" - (try - (> (read-string - (:size (:attrs property))) 60) - (catch Exception _ false)) - "60" - true - (:size (:attrs property)))} - (if - (:minimum (:attrs typedef)) - {:min (:minimum (:attrs typedef))}) - (if - (:maximum (:attrs typedef)) - {:max (:maximum (:attrs typedef))}))})))) + :attrs {:id widget-name + :name widget-name + :type "hidden" + :value (str "{{record." widget-name "}}")}} + "select" + (compose-widget-para property form entity application widget-name + (select-widget property form entity application)) + "text-area" + (compose-widget-para + property form entity application widget-name + {:tag :textarea + :attrs {:rows "8" :cols "60" :id widget-name :name widget-name} + :content [(str "{{record." widget-name "}}")]}) + ;; all others + (compose-widget-para + property form entity application widget-name + {:tag :input + :attrs (merge + {:id widget-name + :name widget-name + :type w-type + :value (str "{{record." widget-name "}}") + :maxlength (:size (:attrs property)) + :size (cond + (nil? (:size (:attrs property))) + "16" + (try + (> (read-string + (:size (:attrs property))) 60) + (catch Exception _ false)) + "60" + true + (:size (:attrs property)))} + (if + (:minimum (:attrs typedef)) + {:min (:minimum (:attrs typedef))}) + (if + (:maximum (:attrs typedef)) + {:max (:maximum (:attrs typedef))}))}))))) (defn embed-script-fragment @@ -446,14 +462,16 @@ (defn compose-form-content [form entity application] - {:content - {:tag :div - :attrs {:id "content" :class "edit"} - :content - [{:tag :form - :attrs {:action (str "{{servlet-context}}/" (editor-name entity application)) - :method "POST"} - :content (flatten + {:content + {:tag :div + :attrs {:id "content" :class "edit"} + :content + [{:tag :form + :attrs {:action (str "{{servlet-context}}/" (editor-name entity application)) + :method "POST"} + :content (apply + vector + (flatten (list (csrf-widget) (map @@ -469,7 +487,7 @@ (= (:distict (:attrs property)) :system)) (children-with-tag form :field))) (save-widget form entity application) - (delete-widget form entity application)))}]}}) + (delete-widget form entity application))))}]}}) (defn compose-form-extra-head @@ -587,6 +605,7 @@ (defn edit-link [entity application parameters] (str + "{{servlet-context}}/" (editor-name entity application) "?" (s/join @@ -677,7 +696,7 @@ :content ["Next"]}]} (wrap-in-if-member-of (big-link (str "Add a new " (pretty-name entity)) (editor-name entity application)) - true + :writeable entity application)))))} :content @@ -761,9 +780,9 @@ {:tag :dt :content [{:tag :a - :attrs {:href (path-part :list entity application)} + :attrs {:href (str "{{servlet-context}}/" (path-part :list entity application))} :content [(pretty-name entity)]}]} - false + :readable entity application)) @@ -781,37 +800,37 @@ :tag :p :content (:content d))) (children-with-tag entity :documentation)))} - false + :readable entity application)) - (defn application-to-template - [application] - (let - [first-class-entities - (sort-by - #(:name (:attrs %)) - (filter - #(children-with-tag % :list) - (children-with-tag application :entity)))] - {:application-index - {:content - {:tag :dl - :attrs {:class "index"} - :content - (apply - vector - (remove - nil? - (flatten - (interleave - (map - #(emit-entity-dt % application) - first-class-entities) - (map - #(emit-entity-dd % application) - first-class-entities)))))}}})) +(defn application-to-template + [application] + (let + [first-class-entities + (sort-by + #(:name (:attrs %)) + (filter + #(children-with-tag % :list) + (children-with-tag application :entity)))] + {:application-index + {:content + {:tag :dl + :attrs {:class "index"} + :content + (apply + vector + (remove + nil? + (flatten + (interleave + (map + #(emit-entity-dt % application) + first-class-entities) + (map + #(emit-entity-dd % application) + first-class-entities)))))}}})) (defn write-template-file diff --git a/src/adl/to_swagger.clj b/src/adl/to_swagger.clj new file mode 100644 index 0000000..b069d80 --- /dev/null +++ b/src/adl/to_swagger.clj @@ -0,0 +1,61 @@ +(ns ^{:doc "Application Description Language: generate swagger routes." + :author "Simon Brooke"} + adl.to-swagger + (:require [adl-support.utils :refer :all] + [adl.to-hugsql-queries :refer [queries]] + [clj-time.core :as t] + [clj-time.format :as f] + [clojure.java.io :refer [file make-parents writer]] + [clojure.pprint :refer [pprint]] + [clojure.string :as s] + [clojure.xml :as x])) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; adl.to-swagger: generate swagger routes. +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU General Public License +;;;; as published by the Free Software Foundation; either version 2 +;;;; of the License, or (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;;; USA. +;;;; +;;;; Copyright (C) 2018 Simon Brooke +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; The overall structure of this has quite closely to follow the structure of +;;; to-hugsql-queries, because essentially we need one JSON entry point to wrap +;;; each query. + +(defn file-header [application] + (list + 'ns + (symbol (str (safe-name (:name (:attrs application))) ".routes.auto-api")) + (str "API routes for " (:name (:attrs application)) + " auto-generated by [Application Description Language framework](https://github.com/simon-brooke/adl) at " + (f/unparse (f/formatters :basic-date-time) (t/now))) + (list + :require + '[adl-support.core :as support] + '[clj-http.client :as client] + '[clojure.tools.logging :as log] + '[compojure.api.sweet :refer :all] + '[hugsql.core :as hugsql] + '[ring.util.http-response :refer :all] + '[noir.response :as nresponse] + '[noir.util.route :as route] + '[ring.util.http-response :as response] + '[schema.core :as s] + (vector (symbol (str (safe-name (:name (:attrs application))) ".db.core")) :as 'db)))) + + From b5f1190c13d49c7e07bbe1cf18adab1b96802249 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Tue, 10 Jul 2018 08:52:20 +0100 Subject: [PATCH 45/52] #3: Now generating selmer skeleton for auxlists, not yet the data. --- src/adl/to_selmer_templates.clj | 171 +++++++++++++++++++++----------- 1 file changed, 114 insertions(+), 57 deletions(-) diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj index 4aa5eb9..027d367 100644 --- a/src/adl/to_selmer_templates.clj +++ b/src/adl/to_selmer_templates.clj @@ -73,7 +73,15 @@ (map emit-content content) true (str "")) - (catch Exception _ (str "")))) + (catch Exception any + (str + ""))))) ([filename application k] (emit-content filename nil nil application k)) ([filename spec entity application k] @@ -460,13 +468,114 @@ (embed-script-fragment filepath []))) +(defn edit-link + [entity application parameters] + (str + "{{servlet-context}}/" + (editor-name entity application) + "?" + (s/join + "&" + (map + #(str %1 "={{ record." %2 " }}") + (key-names entity) + parameters)))) + + +(defn list-tbody + "Return a table body element for the list view for this `list-spec` of this `entity` within + this `application`, using data from this source." + [source list-spec entity application] + {:tag :tbody + :content + [(str "{% for record in " source " %}") + {:tag :tr + :content + (apply + vector + (concat + (map + (fn [field] + {:tag :td :content + (let + [p (first (filter #(= (:name (:attrs %)) (:property (:attrs field))) (all-properties entity))) + s (safe-name (:name (:attrs p)) :sql) + e (first + (filter + #(= (:name (:attrs %)) (:entity (:attrs p))) + (children-with-tag application :entity))) + c (str "{{ record." s " }}")] + (if + (= (:type (:attrs p)) "entity") + [{:tag :a + :attrs {:href (edit-link e application (list (:name (:attrs p))))} + :content [(str "{{ record." s "_expanded }}")]}] + [c]))}) + (children-with-tag list-spec :field)) + [{:tag :td + :content + [{:tag :a + :attrs + {:href (edit-link entity application (key-names entity))} + :content ["View"]}]}]))} + "{% endfor %}"]}) + + +(defn compose-form-auxlist + [auxlist form entity application] + (let [property (child-with-tag + entity + :property + #(= (-> % :attrs :name) (-> auxlist :attrs :property))) + farside (child-with-tag + application + :entity + #(= (-> % :attrs :name)(-> property :attrs :entity)))] + (if + (and property farside) + {:tag :div + :attrs {:class "auxlist"} + :content + [{:tag :h2 + :content [(prompt auxlist form entity application)]} + {:tag :table + :content + [{:tag :thead + :content + [{:tag :tr + :content + (apply + vector + (flatten + (list + (map + #(hash-map + :tag :th + :content [(prompt % form entity application)]) + (children-with-tag auxlist :field)) + {:tag :th :content [" "]})))}]} + (list-tbody (-> property :attrs :name) auxlist farside application)]}]}))) + + +(defn compose-form-auxlists + [form entity application] + (remove + nil? + (map + #(compose-form-auxlist % form entity application) + (children-with-tag form :auxlist)))) + + (defn compose-form-content [form entity application] {:content {:tag :div :attrs {:id "content" :class "edit"} :content - [{:tag :form + (apply + vector + (cons + {:tag :form :attrs {:action (str "{{servlet-context}}/" (editor-name entity application)) :method "POST"} :content (apply @@ -487,7 +596,8 @@ (= (:distict (:attrs property)) :system)) (children-with-tag form :field))) (save-widget form entity application) - (delete-widget form entity application))))}]}}) + (delete-widget form entity application))))} + (compose-form-auxlists form entity application)))}}) (defn compose-form-extra-head @@ -602,59 +712,6 @@ :value "Search"}}]})))}]}) -(defn edit-link - [entity application parameters] - (str - "{{servlet-context}}/" - (editor-name entity application) - "?" - (s/join - "&" - (map - #(str %1 "={{ record." %2 " }}") - (key-names entity) - parameters)))) - - -(defn list-tbody - "Return a table body element for the list view for this `list-spec` of this `entity` within - this `application`." - [list-spec entity application] - {:tag :tbody - :content - ["{% for record in records %}" - {:tag :tr - :content - (apply - vector - (concat - (map - (fn [field] - {:tag :td :content - (let - [p (first (filter #(= (:name (:attrs %)) (:property (:attrs field))) (all-properties entity))) - s (safe-name (:name (:attrs p)) :sql) - e (first - (filter - #(= (:name (:attrs %)) (:entity (:attrs p))) - (children-with-tag application :entity))) - c (str "{{ record." s " }}")] - (if - (= (:type (:attrs p)) "entity") - [{:tag :a - :attrs {:href (edit-link e application (list (:name (:attrs p))))} - :content [(str "{{ record." s "_expanded }}")]}] - [c]))}) - (children-with-tag list-spec :field)) - [{:tag :td - :content - [{:tag :a - :attrs - {:href (edit-link entity application (key-names entity))} - :content ["View"]}]}]))} - "{% endfor %}"]}) - - (defn list-to-template "Generate a template as specified by this `list` element for this `entity`, taken from this `application`. If `list` is nill, generate a default list @@ -712,7 +769,7 @@ :attrs {:caption (:name (:attrs entity))} :content [(list-thead list-spec entity application) - (list-tbody list-spec entity application) + (list-tbody "records" list-spec entity application) ]}]} :extra-script (str " From 54029c29417378f77290700a1936c529e154ca64 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Tue, 10 Jul 2018 15:46:59 +0100 Subject: [PATCH 46/52] Selectize working. --- resources/js/selectize-one.js | 28 ++++ src/adl/to_selmer_routes.clj | 222 ++++++++++++++++++-------------- src/adl/to_selmer_templates.clj | 129 +++++++++---------- 3 files changed, 214 insertions(+), 165 deletions(-) create mode 100644 resources/js/selectize-one.js diff --git a/resources/js/selectize-one.js b/resources/js/selectize-one.js new file mode 100644 index 0000000..a45d578 --- /dev/null +++ b/resources/js/selectize-one.js @@ -0,0 +1,28 @@ +/** + * selectize one select widget. Substitute the actual id of the widget for `{{widget_id}}`. + */ +$('#{{widget_id}}').selectize({ + valueField: 'id', + labelField: 'name', + searchField: 'name', + options: [], + create: false, + + load: function(query, callback) { + console.log('Desperately seeking ' + query); + if (query === null || !query.length) return callback(); + $.ajax({ + url: '/json/auto/search-strings-electors?name=' + query, + type: 'GET', + dataType: 'jsonp', + error: function() { + console.log( 'Query ' + query + ' failed.'); + callback(); + }, + success: function(res) { + console.log('Received ' + res + ' records for ' + query); + callback(res); + } + }); + } +}); diff --git a/src/adl/to_selmer_routes.clj b/src/adl/to_selmer_routes.clj index e016a3f..272c007 100644 --- a/src/adl/to_selmer_routes.clj +++ b/src/adl/to_selmer_routes.clj @@ -53,6 +53,7 @@ '[clojure.java.io :as io] '[clojure.set :refer [subset?]] '[clojure.tools.logging :as log] + '[clojure.walk :refer [keywordize-keys]] '[compojure.core :refer [defroutes GET POST]] '[hugsql.core :as hugsql] '[noir.response :as nresponse] @@ -65,35 +66,57 @@ (defn make-form-handler-content [f e a n] - (let [warning (str "Error while fetching " (singularise (:name (:attrs e))) " record")] + (let [warning (list 'str (str "Error while fetching " (singularise (:name (:attrs e))) " record ") 'params)] ;; TODO: as yet makes no attempt to save the record (list 'let (vector - 'record (list - 'support/do-or-log-error - (list 'if (list 'subset? (key-names e) (set (list 'keys 'p))) - (list - (symbol - (str "db/get-" (singularise (:name (:attrs e))))) - (symbol "db/*db*") - 'p)) - :message warning - :error-return {:warnings [warning]})) + 'record (list + 'support/do-or-log-error + ;;(list 'if (list 'subset? (key-names e) (list 'set (list 'keys 'params))) + (list + (symbol + (str "db/get-" (singularise (:name (:attrs e))))) + (symbol "db/*db*") + 'params) + ;;) + :message warning + :error-return {:warnings [warning]})) (reduce - merge - {:warnings (list :warnings 'record) - :record (list 'assoc 'record :warnings nil)} - (map - (fn [p] - (hash-map - (keyword (-> p :attrs :entity)) - (list 'support/do-or-log-error - (list (symbol (str "db/list-" (:entity (:attrs p)))) (symbol "db/*db*")) - :message (str "Error while fetching " - (singularise (:entity (:attrs p))) - " record")))) - (filter #(#{"entity" "link"} (:type (:attrs %))) - (descendants-with-tag e :property))))))) + merge + {:error (list :warnings 'record) + :record (list 'dissoc 'record :warnings)} + (map + (fn [property] + (hash-map + (keyword (-> property :attrs :name)) + (list + 'flatten + (list + 'remove + 'nil? + (list + 'list + ;; Get the current value of the property, if it's an entity + (if (= (-> property :attrs :type) "entity") + (list 'support/do-or-log-error + (list + (symbol + (str "db/get-" (singularise (:entity (:attrs property))))) + (symbol "db/*db*") + (hash-map (keyword (-> property :attrs :farkey)) + (list (keyword (-> property :attrs :name)) 'record))) + :message (str "Error while fetching " + (singularise (:entity (:attrs property))) + " record " (hash-map (keyword (-> property :attrs :farkey)) + (list (keyword (-> property :attrs :name)) 'record))))) + ;;; and the potential values of the property + (list 'support/do-or-log-error + (list (symbol (str "db/list-" (:entity (:attrs property)))) (symbol "db/*db*")) + :message (str "Error while fetching " + (singularise (:entity (:attrs property))) + " list"))))))) + (filter #(:entity (:attrs %)) + (descendants-with-tag e :property))))))) (defn make-page-handler-content @@ -107,7 +130,7 @@ (symbol (str "db/get-" (singularise (:name (:attrs e))))) (symbol "db/*db*") - 'p)) + 'params)) :message warning :error-return {:warnings [warning]})) {:warnings (list :warnings 'record) @@ -124,17 +147,14 @@ 'if (list 'some - (set (map #(-> % :attrs :name) (all-properties e))) - (list 'keys 'p)) + (set (map #(keyword (-> % :attrs :name)) (all-properties e))) + (list 'keys 'params)) (list 'support/do-or-log-error (list - (symbol - (str - "db/search-strings-" - (singularise (:name (:attrs e))))) + (symbol (str "db/search-strings-" (:name (:attrs e)))) (symbol "db/*db*") - 'p) + 'params) :message (str "Error while searching " (singularise (:name (:attrs e))) @@ -171,10 +191,13 @@ (list 'defn (symbol n) - (vector 'r) + (vector 'request) (list 'let (vector - 'p - (list 'support/massage-params (list :params 'r) (list :form-params 'r) (key-names e))) + 'params + (list 'support/massage-params + (list 'keywordize-keys (list :params 'request)) + (list 'keywordize-keys (list :form-params 'request)) + (key-names e true))) ;; TODO: we must take key params out of just params, ;; but we should take all other params out of form-params - because we need the key to ;; load the form in the first place, but just accepting values of other params would @@ -182,71 +205,74 @@ (list 'l/render (list 'support/resolve-template (str n ".html")) - (list :session 'r) + (list :session 'request) (list 'merge {:title (capitalise (:name (:attrs f))) - :params 'p} + :params 'params} (case (:tag f) - (:form :page) - (list - 'reduce - 'merge - (list 'merge - (list 'cond (list :save-button 'p) - (list 'try - (list 'if - (list 'some (key-names e) (list 'map 'name (list 'keys 'p))) - (list 'do - (list (symbol - (str "db/update-" (singularise (-> e :attrs :name)) "!")) - 'db/*db* - 'p) - {:message "Updated record"}) - (list 'do - (list (symbol - (str "db/create-" (singularise (-> e :attrs :name)) "!")) - 'db/*db* - 'p) - {:message "Saved record"})) - `(catch Exception any# - {:error (.getMessage any#)}))) - {:record - (list 'if (list 'empty? (list 'remove 'nil? (list 'vals 'p))) [] - (list - (symbol - (str "db/get-" (singularise (:name (:attrs e))))) - (symbol "db/*db*") - 'p))}) - (cons 'list - (map - (fn [p] - (hash-map - (keyword (-> p :attrs :entity)) - (list (symbol (str "db/list-" (:entity (:attrs p)))) (symbol "db/*db*")))) - (filter #(#{"entity" "link"} (:type (:attrs %))) - (descendants-with-tag e :property))))) - :list - {:records - (list - 'if - (list - 'not - (list - 'empty? - (list 'remove 'nil? (list 'vals 'p)))) - (list - (symbol - (str - "db/search-strings-" - (:name (:attrs e)))) - (symbol "db/*db*") - 'p) - (list - (symbol - (str - "db/list-" - (:name (:attrs e)))) - (symbol "db/*db*") {}))}))))))) + :form (make-form-handler-content f e a n) + :page (make-page-handler-content f e a n) + :list (make-list-handler-content f e a n)))))))) +;; (:form :page) +;; (list +;; 'reduce +;; 'merge +;; (list 'merge +;; (list 'cond (list :save-button 'p) +;; (list 'try +;; (list 'if +;; (list 'some (key-names e) (list 'map 'name (list 'keys 'p))) +;; (list 'do +;; (list (symbol +;; (str "db/update-" (singularise (-> e :attrs :name)) "!")) +;; 'db/*db* +;; 'p) +;; {:message "Updated record"}) +;; (list 'do +;; (list (symbol +;; (str "db/create-" (singularise (-> e :attrs :name)) "!")) +;; 'db/*db* +;; 'p) +;; {:message "Saved record"})) +;; `(catch Exception any# +;; {:error (.getMessage any#)}))) +;; {:record +;; (list 'if (list 'empty? (list 'remove 'nil? (list 'vals 'p))) [] +;; (list +;; (symbol +;; (str "db/get-" (singularise (:name (:attrs e))))) +;; (symbol "db/*db*") +;; 'p))}) +;; (cons 'list +;; (map +;; (fn [p] +;; (hash-map +;; (keyword (-> p :attrs :entity)) +;; (list (symbol (str "db/list-" (:entity (:attrs p)))) (symbol "db/*db*")))) +;; (filter #(#{"entity" "link"} (:type (:attrs %))) +;; (descendants-with-tag e :property))))) +;; :list +;; {:records +;; (list +;; 'if +;; (list +;; 'not +;; (list +;; 'empty? +;; (list 'remove 'nil? (list 'vals 'p)))) +;; (list +;; (symbol +;; (str +;; "db/search-strings-" +;; (:name (:attrs e)))) +;; (symbol "db/*db*") +;; 'p) +;; (list +;; (symbol +;; (str +;; "db/list-" +;; (:name (:attrs e)))) +;; (symbol "db/*db*") {}))}))))))) ;; (def a (x/parse "../youyesyet/youyesyet.canonical.adl.xml")) ;; (def e (child-with-tag a :entity)) diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj index 027d367..ff1b30e 100644 --- a/src/adl/to_selmer_templates.clj +++ b/src/adl/to_selmer_templates.clj @@ -258,12 +258,16 @@ (:farkey (:attrs property)) (first (key-names farside)) "id")] - [(str "{% for r in " farname " %}{% endfor %}")])) @@ -292,50 +296,20 @@ (defn select-widget - ;; TODO: rewrite for selectize https://github.com/selectize/selectize.js/blob/master/docs/usage.md - ;; https://gist.github.com/zabolotnov87/11142887 [property form entity application] (let [farname (:entity (:attrs property)) farside (first (children application #(= (:name (:attrs %)) farname))) magnitude (try (read-string (:magnitude (:attrs farside))) (catch Exception _ 7)) async? (and (number? magnitude) (> magnitude 1)) widget-name (safe-name (:name (:attrs property)) :sql)] - {:tag :span - :attrs {:class "select-box" :farside farname :found (if farside "true" "false")} - :content - (apply - vector - (remove - nil? - (flatten - (list - (if - async? - (list - {:tag :input - :attrs - {:name (str widget-name "_search_box") - :onchange (str "$.getJSON(\"/auto/json/seach-strings-" - (-> farside :attrs :name) - "?" - (s/join (str "=\" + " widget-name "_search_box.text + \"&") - (user-distinct-property-names farside)) - (str "=\" + " widget-name "_search_box.text") - ", null, function (data) {updateMenuOptions(\"" - widget-name "\", \"" - (first (key-names farside)) - "\", [\"" - (s/join "\", \"" (user-distinct-property-names farside)) - "\"], data);})")}} - {:tag :br})) - {:tag :select - :attrs (merge - {:id widget-name - :name widget-name} - (if - (= (:type (:attrs property)) "link") - {:multiple "multiple"})) - :content (apply vector (get-options property form entity application))}))))})) + {:tag :select + :attrs (merge + {:id widget-name + :name widget-name} + (if + (= (:type (:attrs property)) "link") + {:multiple "multiple"})) + :content (apply vector (get-options property form entity application))})) (defn compose-readable-or-not-authorised @@ -353,8 +327,7 @@ :name w :class "pseudo-widget not-authorised"} :content [(str "You are not permitted to view " w " of " (:name (:attrs e)))]} - "{% endifmemberof %}" - )) + "{% endifmemberof %}")) (defn compose-widget-para @@ -454,7 +427,7 @@ (defn embed-script-fragment - "Return the content of the file at `fielpath`, with these `substitutions` + "Return the content of the file at `filepath`, with these `substitutions` made into it in order. Substitutions should be pairss [`pattern` `value`], where `pattern` is a string, a char, or a regular expression." ([filepath substitutions] @@ -603,31 +576,53 @@ (defn compose-form-extra-head [form entity application] {:extra-head - (if - (some - #(= "text-area" (widget-type % application)) (properties entity)) - "{% script \"js/lib/node_modules/simplemde/dist/simplemde.min.js\" %} - {% style \"js/lib/node_modules/simplemde/dist/simplemde.min.css\" %}")}) + (apply + str + (remove + nil? + (list + (if + (some + #(= "text-area" (widget-type % application)) (properties entity)) + " + {% script \"js/lib/node_modules/simplemde/dist/simplemde.min.js\" %} + {% style \"js/lib/node_modules/simplemde/dist/simplemde.min.css\" %}") + (if + (some + #(= "select" (widget-type % application)) (properties entity)) + " + {% script \"/js/lib/node_modules/selectize/dist/js/standalone/selectize.min.js\" %} + {% style \"/js/lib/node_modules/selectize/dist/css/selectize.css\" %}"))))}) - (defn compose-form-extra-tail - [form entity application] - {:extra-tail - {:tag :script :attrs {:type "text/javascript"} - :content - (apply - vector - (remove - nil? - (list - (if - (some - #(= "select" (widget-type % application)) (properties entity)) - (embed-script-fragment "resources/js/select-widget-support.js")) - (if - (some - #(= "text-area" (widget-type % application)) (properties entity)) - (embed-script-fragment "resources/js/text-area-md-support.js")))))}}) +(defn compose-form-extra-tail + [form entity application] + {:extra-tail + {:tag :script :attrs {:type "text/javascript"} + :content + (apply + vector + (remove + nil? + (flatten + (list + (map + (fn [property] + (let + [farname (:entity (:attrs property)) + farside (first (children application #(= (:name (:attrs %)) farname))) + magnitude (try (read-string (:magnitude (:attrs farside))) (catch Exception _ 7))] + (if + (> magnitude 2) + (embed-script-fragment + "resources/js/selectize-one.js" + [["{{widget_id}}" (-> property :attrs :name)]] + )))) + (children-with-tag entity :property #(= (-> % :attrs :type) "entity"))) + (if + (some + #(= "text-area" (widget-type % application)) (properties entity)) + (embed-script-fragment "resources/js/text-area-md-support.js"))))))}}) (defn form-to-template From 7dfff9f9eea8c719a420eb0516c8a64a7cfaef13 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 15 Jul 2018 12:41:07 +0100 Subject: [PATCH 47/52] Improvements to selectization --- resources/js/selectize-one.js | 7 ++++--- src/adl/to_selmer_templates.clj | 13 ++++++++++--- 2 files changed, 14 insertions(+), 6 deletions(-) diff --git a/resources/js/selectize-one.js b/resources/js/selectize-one.js index a45d578..7deb265 100644 --- a/resources/js/selectize-one.js +++ b/resources/js/selectize-one.js @@ -1,11 +1,12 @@ /** - * selectize one select widget. Substitute the actual id of the widget for `{{widget_id}}`. + * selectize one select widget. Substitute the actual id of the widget for `{{widget_id}}`, + * and the current value for {{widget_value}}. */ $('#{{widget_id}}').selectize({ valueField: 'id', labelField: 'name', searchField: 'name', - options: [], + hideSelected: false, create: false, load: function(query, callback) { @@ -25,4 +26,4 @@ $('#{{widget_id}}').selectize({ } }); } -}); +})[0].selectize.setValue({{widget_value}}, true); diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj index ff1b30e..443b3a0 100644 --- a/src/adl/to_selmer_templates.clj +++ b/src/adl/to_selmer_templates.clj @@ -266,8 +266,14 @@ farkey "}}' {% ifequal record." (-> property :attrs :name) - " option." farkey "%}selected{% endifequal %}>" - (s/join " " (map #(str "{{option." (:name (:attrs %)) "}}") fs-distinct)) + " option." farkey "%}selected='selected'{% endifequal %}>" + (s/join " " (map + #(str + "{{option." + (:name (:attrs %)) + (if (= (-> % :attrs :type) "entity") "_expanded") + "}}") + fs-distinct)) "{% endfor %}")])) @@ -616,7 +622,8 @@ (> magnitude 2) (embed-script-fragment "resources/js/selectize-one.js" - [["{{widget_id}}" (-> property :attrs :name)]] + [["{{widget_id}}" (-> property :attrs :name)] + ["{{widget_value}}" (str "{{record." (-> property :attrs :name) "}}")]] )))) (children-with-tag entity :property #(= (-> % :attrs :type) "entity"))) (if From 8d32850b8fb30ad633f70bc17b2cd63930c9f1ee Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 15 Jul 2018 21:03:13 +0100 Subject: [PATCH 48/52] Searching lists works; paging lists still doesn't, but is closer. --- src/adl/to_hugsql_queries.clj | 12 ++--- src/adl/to_selmer_routes.clj | 88 +++++++++++++++++---------------- src/adl/to_selmer_templates.clj | 51 +++++++++---------- 3 files changed, 74 insertions(+), 77 deletions(-) diff --git a/src/adl/to_hugsql_queries.clj b/src/adl/to_hugsql_queries.clj index 2387610..f45dcc2 100644 --- a/src/adl/to_hugsql_queries.clj +++ b/src/adl/to_hugsql_queries.clj @@ -140,7 +140,7 @@ (let [entity-name (safe-name (:name (:attrs entity)) :sql) pretty-name (singularise entity-name) query-name (str "search-strings-" entity-name) - signature ":? :1" + signature ":? :*" properties (remove #(#{"link"}(:type (:attrs %))) (all-properties entity))] (hash-map (keyword query-name) @@ -168,12 +168,12 @@ string? (map #(str - "(if (:" (-> % :attrs :name) " params) \"OR " - (case (base-type % application) + "(if (:" (-> % :attrs :name) " params) (str \"OR " + (case (-> % :attrs :type) ("string" "text") (str (safe-name (-> % :attrs :name) :sql) - " LIKE '%:" (-> % :attrs :name) "%'") + " LIKE '%\" (:" (-> % :attrs :name) " params) \"%'") ("date" "time" "timestamp") (str (safe-name (-> % :attrs :name) :sql) @@ -181,12 +181,12 @@ "entity" (str (safe-name (-> % :attrs :name) :sql) - "_expanded LIKE '%:" (-> % :attrs :name) "%'") + "_expanded LIKE '%\" (:" (-> % :attrs :name) " params) \"%'") (str (safe-name (-> % :attrs :name) :sql) " = :" (-> % :attrs :name))) - "\")") + "\"))") properties)))) (order-by-clause entity "lv_") "--~ (if (:offset params) \"OFFSET :offset \")" diff --git a/src/adl/to_selmer_routes.clj b/src/adl/to_selmer_routes.clj index 272c007..6f7b5e7 100644 --- a/src/adl/to_selmer_routes.clj +++ b/src/adl/to_selmer_routes.clj @@ -140,49 +140,53 @@ (defn make-list-handler-content [f e a n] (list - 'let - (vector - 'records - (list - 'if - (list - 'some - (set (map #(keyword (-> % :attrs :name)) (all-properties e))) - (list 'keys 'params)) - (list - 'support/do-or-log-error + 'let + (vector + 'records (list - (symbol (str "db/search-strings-" (:name (:attrs e)))) - (symbol "db/*db*") - 'params) - :message (str - "Error while searching " - (singularise (:name (:attrs e))) - " records") - :error-return {:warnings [(str - "Error while searching " - (singularise (:name (:attrs e))) - " records")]}) - (list - 'support/do-or-log-error - (list - (symbol - (str - "db/list-" - (:name (:attrs e)))) - (symbol "db/*db*") {}) - :message (str - "Error while fetching " - (singularise (:name (:attrs e))) - " records") - :error-return {:warnings [(str - "Error while fetching " - (singularise (:name (:attrs e))) - " records")]}))) - (list 'if - (list :warnings 'records) - 'records - {:records 'records}))) + 'if + (list + 'some + (set (map #(keyword (-> % :attrs :name)) (all-properties e))) + (list 'keys 'params)) + (list 'do + (list (symbol "log/debug") (list (symbol (str "db/search-strings-" (:name (:attrs e)) "-sqlvec")) 'params)) + (list + 'support/do-or-log-error + (list + (symbol (str "db/search-strings-" (:name (:attrs e)))) + (symbol "db/*db*") + 'params) + :message (str + "Error while searching " + (singularise (:name (:attrs e))) + " records") + :error-return {:warnings [(str + "Error while searching " + (singularise (:name (:attrs e))) + " records")]})) + (list 'do + (list (symbol "log/debug") (list (symbol (str "db/list-" (:name (:attrs e)) "-sqlvec")) 'params)) + (list + 'support/do-or-log-error + (list + (symbol + (str + "db/list-" + (:name (:attrs e)))) + (symbol "db/*db*") {}) + :message (str + "Error while fetching " + (singularise (:name (:attrs e))) + " records") + :error-return {:warnings [(str + "Error while fetching " + (singularise (:name (:attrs e))) + " records")]})))) + (list 'if + (list :warnings 'records) + 'records + {:records 'records}))) (defn make-handler diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj index 443b3a0..76cb484 100644 --- a/src/adl/to_selmer_templates.clj +++ b/src/adl/to_selmer_templates.clj @@ -665,11 +665,7 @@ "time" "time" "text") base-name (:property (:attrs field)) - search-name (safe-name - (if - (= (:type (:attrs property)) "entity") - (str base-name "_expanded") base-name) - :sql)] + search-name (safe-name base-name :sql)] (hash-map :tag :th :content @@ -728,18 +724,10 @@ {:back-links {:tag :div :content - [ - {:tag :div :attrs {:class "back-link-container"} + [{:tag :div :attrs {:class "back-link-container"} :content - ["{% ifequal params.offset \"0\" %}" - {:tag :a - :attrs {:id "back-link" :class "back-link" :href "{{servlet-context}}/admin"} - :content ["Back"]} - "{% else %}" - {:tag :a :attrs {:id "prev-selector" :class "back-link"} - :content ["Previous"]} - "{% endifunequal %}"]} - ]} + [{:tag :a :attrs {:id "prev-selector" :class "back-link"} + :content ["Previous"]}]}]} :big-links {:tag :div :content @@ -765,8 +753,8 @@ :method "POST"} :content [(csrf-widget) - {:tag :input :attrs {:id "offset" :type "hidden" :value "{{params.offset|default:0}}"}} - {:tag :input :attrs {:id "limit" :type "hidden" :value "{{params.limit|default:50}}"}} + {:tag :input :attrs {:id "offset" :name "offset" :type "hidden" :value "{{params.offset|default:0}}"}} + {:tag :input :attrs {:id "limit" :name "limit" :type "hidden" :value "{{params.limit|default:50}}"}} {:tag :table :attrs {:caption (:name (:attrs entity))} :content @@ -779,21 +767,26 @@ var ow = document.getElementById('offset'); var lw = document.getElementById('limit'); form.addEventListener('submit', function() { - ow.value='0'; + ow.value='0'; }); - {% ifunequal params.offset \"0\" %} - document.getElementById('prev-selector').addEventListener('click', function () { - ow.value=(parseInt(ow.value)-parseInt(lw.value)); - console.log('Updated offset to ' + ow.value); - form.submit(); - }); - {% endifunequal %} + var prevSelector = document.getElementById('prev-selector'); + if (prevSelector != null) { + prevSelector.addEventListener('click', function () { + if (parseInt(ow.value)===0) { + window.location = '{{servlet-context}}/admin'; + } else { + ow.value=(parseInt(ow.value)-parseInt(lw.value)); + console.log('Updated offset to ' + ow.value); + form.submit(); + } + }); + } document.getElementById('next-selector').addEventListener('click', function () { - ow.value=(parseInt(ow.value)+parseInt(lw.value)); - console.log('Updated offset to ' + ow.value); - form.submit(); + ow.value=(parseInt(ow.value)+parseInt(lw.value)); + console.log('Updated offset to ' + ow.value); + form.submit(); });")})) From 2ec8f4a928e197a18db5e0c48968f455cdd14807 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Tue, 17 Jul 2018 09:01:27 +0100 Subject: [PATCH 49/52] Improvements to menus and lists. --- .gitignore | 3 + resources/js/selectize-one.js | 10 +- resources/js/text-area-md-support.js | 2 +- src/adl/to_hugsql_queries.clj | 51 +++++---- src/adl/to_json_routes.clj | 3 + src/adl/to_selmer_templates.clj | 158 ++++++++++++++------------- 6 files changed, 126 insertions(+), 101 deletions(-) diff --git a/.gitignore b/.gitignore index faf3ae7..d388cc3 100644 --- a/.gitignore +++ b/.gitignore @@ -20,3 +20,6 @@ generated/resources/templates/auto/ generated/src/clj/youyesyet/routes/ *.iml + +node_modules/ + diff --git a/resources/js/selectize-one.js b/resources/js/selectize-one.js index 7deb265..f248b6f 100644 --- a/resources/js/selectize-one.js +++ b/resources/js/selectize-one.js @@ -3,9 +3,9 @@ * and the current value for {{widget_value}}. */ $('#{{widget_id}}').selectize({ - valueField: 'id', - labelField: 'name', - searchField: 'name', + valueField: '{{key}}', + labelField: '{{field}}', + searchField: '{{field}}', hideSelected: false, create: false, @@ -13,7 +13,7 @@ $('#{{widget_id}}').selectize({ console.log('Desperately seeking ' + query); if (query === null || !query.length) return callback(); $.ajax({ - url: '/json/auto/search-strings-electors?name=' + query, + url: '/json/auto/search-strings-{{entity}}?{{field}}=' + query, type: 'GET', dataType: 'jsonp', error: function() { @@ -26,4 +26,4 @@ $('#{{widget_id}}').selectize({ } }); } -})[0].selectize.setValue({{widget_value}}, true); +})[0].selectize.setValue('{{widget_value}}', true); diff --git a/resources/js/text-area-md-support.js b/resources/js/text-area-md-support.js index d7fb7aa..6923b42 100644 --- a/resources/js/text-area-md-support.js +++ b/resources/js/text-area-md-support.js @@ -1,7 +1,7 @@ var simplemde = new SimpleMDE({ autosave: { enabled: true, - uniqueId: "Smeagol-{{page}}", + uniqueId: "adl-generated-{{page}}", delay: 1000, }, indentWithTabs: true, diff --git a/src/adl/to_hugsql_queries.clj b/src/adl/to_hugsql_queries.clj index f45dcc2..fe9e6d8 100644 --- a/src/adl/to_hugsql_queries.clj +++ b/src/adl/to_hugsql_queries.clj @@ -32,6 +32,8 @@ ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(def expanded-token "_expanded") + (defn where-clause "Generate an appropriate `where` clause for queries on this `entity`; @@ -55,14 +57,14 @@ (defn order-by-clause "Generate an appropriate `order by` clause for queries on this `entity`" ([entity] - (order-by-clause entity "")) + (order-by-clause entity "" false)) ([entity prefix] + (order-by-clause entity prefix false)) + ([entity prefix expanded?] (let [entity-name (safe-name (:name (:attrs entity)) :sql) - preferred (map - #(safe-name (:name (:attrs %)) :sql) - (filter #(#{"user" "all"} (-> % :attrs :distinct)) - (children entity #(= (:tag %) :property))))] + preferred (filter #(#{"user" "all"} (-> % :attrs :distinct)) + (children entity #(= (:tag %) :property)))] (if (empty? preferred) "" @@ -71,8 +73,15 @@ (s/join (str ",\n\t" prefix entity-name ".") (map - #(safe-name % :sql) - (flatten (cons preferred (key-names entity)))))))))) + #(if + (and expanded? (= "entity" (-> % :attrs :type))) + (str (safe-name % :sql) expanded-token) + (safe-name % :sql)) + (flatten (cons preferred (key-properties entity)))))))))) + +;; (def a (x/parse "../youyesyet/youyesyet.adl.xml")) +;; (def e (child-with-tag a :entity #(= "dwellings" (-> % :attrs :name)))) +;; (order-by-clause e "" true) (defn insert-query @@ -163,35 +172,39 @@ (s/join "\n\t--~ " (cons - "WHERE false" + "WHERE true" (filter string? (map - #(str - "(if (:" (-> % :attrs :name) " params) (str \"OR " + #(let + [sn (safe-name (-> % :attrs :name) :sql)] + (str + "(if (:" (-> % :attrs :name) " params) (str \"AND " (case (-> % :attrs :type) ("string" "text") (str - (safe-name (-> % :attrs :name) :sql) - " LIKE '%\" (:" (-> % :attrs :name) " params) \"%'") + sn + " LIKE '%\" (:" (-> % :attrs :name) " params) \"%' ") ("date" "time" "timestamp") (str - (safe-name (-> % :attrs :name) :sql) + sn " = ':" (-> % :attrs :name) "'") "entity" (str - (safe-name (-> % :attrs :name) :sql) + sn "_expanded LIKE '%\" (:" (-> % :attrs :name) " params) \"%'") (str - (safe-name (-> % :attrs :name) :sql) + sn " = :" (-> % :attrs :name))) - "\"))") + "\"))")) properties)))) - (order-by-clause entity "lv_") + (order-by-clause entity "lv_" true) "--~ (if (:offset params) \"OFFSET :offset \")" "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))}))) +;; (search-query e a) + (defn select-query "Generate an appropriate `select` query for this `entity`" @@ -257,7 +270,7 @@ (str "-- :name " query-name " " signature) (str "-- :doc lists all existing " pretty-name " records") (str "SELECT DISTINCT * FROM lv_" entity-name) - (order-by-clause entity "lv_") + (order-by-clause entity "lv_" false) "--~ (if (:offset params) \"OFFSET :offset \")" "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))}))) @@ -304,7 +317,7 @@ (str "WHERE lv_" entity-name "." (first (key-names entity)) " = " entity-name "." (first (key-names entity)) "\n\tAND " entity-name "." link-field " = :id") - (order-by-clause entity "lv_")) + (order-by-clause entity "lv_" false)) "link" (let [link-table-name (link-table-name % entity far-entity)] (list diff --git a/src/adl/to_json_routes.clj b/src/adl/to_json_routes.clj index 5d59257..0c3dee8 100644 --- a/src/adl/to_json_routes.clj +++ b/src/adl/to_json_routes.clj @@ -85,10 +85,13 @@ (:delete-1 :update-1) (list action + `(log/debug (str ~(:name query) " called with params " ~'params ".")) '(response/found "/")) (list 'let (vector 'result action) + `(log/debug (~(symbol (str "db/" (:name query) "-sqlvec")) ~'params)) + `(log/debug (str ~(str "'" (:name query) "' with params ") ~'params " returned " (count ~'result) " records.")) (list 'response/ok 'result)))))) diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj index 76cb484..5d93c85 100644 --- a/src/adl/to_selmer_templates.clj +++ b/src/adl/to_selmer_templates.clj @@ -1,7 +1,8 @@ (ns ^{:doc "Application Description Language - generate Selmer templates for the HTML pages implied by an ADL file." :author "Simon Brooke"} adl.to-selmer-templates - (:require [adl-support.utils :refer :all] + (:require [adl.to-hugsql-queries :refer [expanded-token]] + [adl-support.utils :refer :all] [clojure.java.io :refer [file make-parents]] [clojure.pprint :as p] [clojure.string :as s] @@ -70,7 +71,7 @@ (with-out-str (x/emit-element content)) (seq? content) - (map emit-content content) + (map emit-content (remove nil? content)) true (str "")) (catch Exception any @@ -80,8 +81,8 @@ "';\n" (-> any .getClass .getName) ": " - (-> any .getMessage - " -->"))))) + (-> any .getMessage) + " -->")))) ([filename application k] (emit-content filename nil nil application k)) ([filename spec entity application k] @@ -140,26 +141,6 @@ (emit-content filename spec entity application :foot)))))) -(defn prompt - "Return an appropriate prompt for the given `field-or-property` taken from this - `form` of this `entity` of this `application`, in the context of the current - binding of `*locale*`. TODO: something more sophisticated about i18n" - ([field-or-property form entity application] - (prompt field-or-property)) - ([field-or-property] - (capitalise - (or - (first - (children - field-or-property - #(and - (= (:tag %) :prompt) - (= (:locale :attrs %) *locale*)))) - (:name (:attrs field-or-property)) - (:property (:attrs field-or-property)) - "Missing prompt")))) - - (defn csrf-widget "For the present, just return the standard cross site scripting protection field statement" [] @@ -240,6 +221,24 @@ application)) +(defn select-property + "Return the property on which we will by default do a user search on this `entity`." + [entity] + (descendant-with-tag + entity + :property + #(#{"user" "all"} (-> % :attrs :distinct)))) + + +(defn select-field-name + [entity] + (let [p (select-property entity)] + (if + (-> p :attrs :entity) + (str (safe-name p :sql) expanded-token) + (-> p :attrs :name)))) + + (defn get-options "Produce template code to get options for this `property` of this `entity` taken from this `application`." @@ -267,14 +266,8 @@ "}}' {% ifequal record." (-> property :attrs :name) " option." farkey "%}selected='selected'{% endifequal %}>" - (s/join " " (map - #(str - "{{option." - (:name (:attrs %)) - (if (= (-> % :attrs :type) "entity") "_expanded") - "}}") - fs-distinct)) - "{% endfor %}")])) + "{{option." (select-field-name farside) + "}}{% endfor %}")])) (defn widget-type @@ -371,15 +364,12 @@ (if (= (:tag field-or-property) :property) (:name (:attrs field-or-property)) (:property (:attrs field-or-property))) :sql) - property (if - (= (:tag field-or-property) :property) - field-or-property - (first - (filter - #(= (:name (:attrs %)) - (:property (:attrs field-or-property))) - (descendants-with-tag entity - :property)))) + property (case + (:tag field-or-property) + :property field-or-property + :field (property-for-field field-or-property entity) + ;; default + nil) permissions (find-permissions field-or-property property form entity application) typedef (typedef property application) w-type (widget-type property application typedef) @@ -440,7 +430,9 @@ (let [v (slurp filepath)] (reduce (fn [s [pattern value]] - (s/replace s pattern value)) + (if (and pattern value) + (s/replace s pattern value) + s)) v substitutions))) ([filepath] @@ -555,28 +547,30 @@ vector (cons {:tag :form - :attrs {:action (str "{{servlet-context}}/" (editor-name entity application)) - :method "POST"} - :content (apply - vector - (flatten - (list - (csrf-widget) - (map - #(widget % form entity application) - (children-with-tag (child-with-tag entity :key) :properties)) - (map - #(widget % form entity application) - (remove - #(let - [property (filter - (fn [p] (= (:name (:attrs p)) (:property (:attrs %)))) - (descendants-with-tag entity :property))] - (= (:distict (:attrs property)) :system)) - (children-with-tag form :field))) - (save-widget form entity application) - (delete-widget form entity application))))} - (compose-form-auxlists form entity application)))}}) + :attrs {:action (str "{{servlet-context}}/" (editor-name entity application)) + :method "POST"} + :content (apply + vector + (remove + nil? + (flatten + (list + (csrf-widget) + (map + #(widget % form entity application) + (children-with-tag (child-with-tag entity :key) :property)) + (map + #(widget % form entity application) + (remove + #(let + [property (filter + (fn [p] (= (:name (:attrs p)) (:property (:attrs %)))) + (descendants-with-tag entity :property))] + (= (:distict (:attrs property)) :system)) + (children-with-tag form :field))) + (save-widget form entity application) + (delete-widget form entity application)))))} + (compose-form-auxlists form entity application)))}}) (defn compose-form-extra-head @@ -588,14 +582,18 @@ nil? (list (if - (some - #(= "text-area" (widget-type % application)) (properties entity)) + (child-with-tag + form + :field + #(= "text-area" (widget-type (property-for-field % entity) application))) " {% script \"js/lib/node_modules/simplemde/dist/simplemde.min.js\" %} {% style \"js/lib/node_modules/simplemde/dist/simplemde.min.css\" %}") (if - (some - #(= "select" (widget-type % application)) (properties entity)) + (child-with-tag + form + :field + #(= "select" (widget-type (property-for-field % entity) application))) " {% script \"/js/lib/node_modules/selectize/dist/js/standalone/selectize.min.js\" %} {% style \"/js/lib/node_modules/selectize/dist/css/selectize.css\" %}"))))}) @@ -613,9 +611,12 @@ (flatten (list (map - (fn [property] + (fn [field] (let - [farname (:entity (:attrs property)) + [property (child-with-tag entity :property #(= + (-> field :attrs :property) + (-> % :attrs :name))) + farname (:entity (:attrs property)) farside (first (children application #(= (:name (:attrs %)) farname))) magnitude (try (read-string (:magnitude (:attrs farside))) (catch Exception _ 7))] (if @@ -623,12 +624,17 @@ (embed-script-fragment "resources/js/selectize-one.js" [["{{widget_id}}" (-> property :attrs :name)] - ["{{widget_value}}" (str "{{record." (-> property :attrs :name) "}}")]] - )))) - (children-with-tag entity :property #(= (-> % :attrs :type) "entity"))) + ["{{widget_value}}" (str "{{record." (-> property :attrs :name) "}}")] + ["{{entity}}" farname] + ["{{field}}" (select-field-name farside)] + ["{{key}}" (first (key-names farside))]])))) + (children-with-tag + form :field + #(= "select" (widget-type (property-for-field % entity) application)))) (if - (some - #(= "text-area" (widget-type % application)) (properties entity)) + (child-with-tag + form :field + #(= "text-area" (widget-type (property-for-field % entity) application))) (embed-script-fragment "resources/js/text-area-md-support.js"))))))}}) @@ -690,7 +696,7 @@ vector (map #(hash-map - :content [(prompt %)] + :content [(prompt % list-spec entity application)] :tag :th) (children-with-tag list-spec :field))) {:tag :th :content [" "]})} From 80860a264e9b3fae8775da855e770df8a9ce7481 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 18 Jul 2018 15:17:55 +0100 Subject: [PATCH 50/52] Moved print-usage out into support. --- src/adl/main.clj | 51 +++++++-------------------------- src/adl/to_selmer_templates.clj | 4 +-- 2 files changed, 13 insertions(+), 42 deletions(-) diff --git a/src/adl/main.clj b/src/adl/main.clj index 066a864..6423236 100644 --- a/src/adl/main.clj +++ b/src/adl/main.clj @@ -2,6 +2,7 @@ :author "Simon Brooke"} adl.main (:require [adl-support.utils :refer :all] + [adl-support.print-usage :refer [print-usage]] [adl.to-hugsql-queries :as h] [adl.to-json-routes :as j] [adl.to-psql :as p] @@ -52,43 +53,13 @@ ]) -(defn- doc-part - "An `option` in cli-options comprises a sequence of strings followed by - keyword/value pairs. Return all the strings before the first keyword." - [option] - (if - (keyword? (first option)) nil - (cons (first option) (doc-part (rest option))))) - -(defn map-part - "An `option` in cli-options comprises a sequence of strings followed by - keyword/value pairs. Return the keyword/value pairs as a map." - [option] - (cond - (empty? option) nil - (keyword? (first option)) (apply hash-map option) - true - (map-part (rest option)))) - -(defn print-usage [] - (println - (join - "\n" - (flatten - (list - (join - (list - "Usage: java -jar adl-" - (or (System/getProperty "adl.version") "[VERSION]") - "-SNAPSHOT-standalone.jar -options [adl-file]")) - "where options include:" - (map - #(let - [doc-part (doc-part %) - default (:default (map-part %)) - default-string (if default (str "; (default: " default ")"))] - (str "\t" (join ", " (butlast doc-part)) ": " (last doc-part) default-string)) - cli-options)))))) +(defn usage [parsed-options] + "Show a usage message. `parsed-options` should be options as + parsed by [clojure.tools.cli](https://github.com/clojure/tools.cli)" + (print-usage + "adl" + parsed-options + {"adl-file" "An XML file conforming to the ADL DTD"})) (defn -main @@ -97,16 +68,16 @@ (let [options (parse-opts args cli-options)] (cond (empty? args) - (print-usage) + (usage options) (not (empty? (:errors options))) (do (doall (map println (:errors options))) - (print-usage)) + (usage options)) (-> options :options :help) - (print-usage) + (usage options) true (do (let [p (:path (:options options)) diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj index 5d93c85..0cafd0a 100644 --- a/src/adl/to_selmer_templates.clj +++ b/src/adl/to_selmer_templates.clj @@ -587,8 +587,8 @@ :field #(= "text-area" (widget-type (property-for-field % entity) application))) " - {% script \"js/lib/node_modules/simplemde/dist/simplemde.min.js\" %} - {% style \"js/lib/node_modules/simplemde/dist/simplemde.min.css\" %}") + {% script \"/js/lib/node_modules/simplemde/dist/simplemde.min.js\" %} + {% style \"/js/lib/node_modules/simplemde/dist/simplemde.min.css\" %}") (if (child-with-tag form From 1be3db1453efacb9c6b484d2bcaaf36e5c0e492a Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 18 Jul 2018 23:01:14 +0100 Subject: [PATCH 51/52] Prevent cross-contamination of SimpleMDE auto-saves --- resources/js/text-area-md-support.js | 39 ++++++++++++++++------------ src/adl/to_selmer_templates.clj | 3 ++- 2 files changed, 24 insertions(+), 18 deletions(-) diff --git a/resources/js/text-area-md-support.js b/resources/js/text-area-md-support.js index 6923b42..f05e241 100644 --- a/resources/js/text-area-md-support.js +++ b/resources/js/text-area-md-support.js @@ -1,17 +1,22 @@ - var simplemde = new SimpleMDE({ - autosave: { - enabled: true, - uniqueId: "adl-generated-{{page}}", - delay: 1000, - }, - indentWithTabs: true, - insertTexts: { - horizontalRule: ["", "\n\n-----\n\n"], - image: ["![](http://", ")"], - link: ["[", "](http://)"], - table: ["", "\n\n| Column 1 | Column 2 | Column 3 |\n| -------- | -------- | -------- |\n| Text | Text | Text |\n\n"], - }, - showIcons: ["code"], //, "table"], - sadly, markdown-clj does not support tables - spellChecker: true, - status: ["autosave", "lines", "words", "cursor"] - }); +/** + * Provide SimpleMDE support for textareas on this page. TODO: this is + * slightly problematic since it assumes (and saves autosave data for) + * only one text area on the page. Perhaps we should disable autosave? + */ +var simplemde = new SimpleMDE({ + autosave: { + enabled: true, + uniqueId: "{{page}}-{{record.id}}", + delay: 1000, + }, + indentWithTabs: true, + insertTexts: { + horizontalRule: ["", "\n\n-----\n\n"], + image: ["![](http://", ")"], + link: ["[", "](http://)"], + table: ["", "\n\n| Column 1 | Column 2 | Column 3 |\n| -------- | -------- | -------- |\n| Text | Text | Text |\n\n"], + }, + showIcons: ["code"], //, "table"], - sadly, markdown-clj does not support tables + spellChecker: true, + status: ["autosave", "lines", "words", "cursor"] +}); diff --git a/src/adl/to_selmer_templates.clj b/src/adl/to_selmer_templates.clj index 0cafd0a..548ddf5 100644 --- a/src/adl/to_selmer_templates.clj +++ b/src/adl/to_selmer_templates.clj @@ -635,7 +635,8 @@ (child-with-tag form :field #(= "text-area" (widget-type (property-for-field % entity) application))) - (embed-script-fragment "resources/js/text-area-md-support.js"))))))}}) + (embed-script-fragment "resources/js/text-area-md-support.js" + [["{{page}}" (-> form :attrs :name)]]))))))}}) (defn form-to-template From 549d4ad2beed4387433dcacaa5737288d9dfda22 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 18 Jul 2018 23:17:21 +0100 Subject: [PATCH 52/52] Removed 'SNAPSHOT' from version number --- project.clj | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/project.clj b/project.clj index f2c7d3f..aa1d9d2 100644 --- a/project.clj +++ b/project.clj @@ -1,4 +1,4 @@ -(defproject adl "1.4.1-SNAPSHOT" +(defproject adl "1.4.1" :description "An application to transform an ADL application specification document into skeleton code for a Clojure web-app" :url "http://example.com/FIXME" :license {:name "GNU General Public License,version 2.0 or (at your option) any later version"