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

Rewrote adl2psql into Clojure, because these days it's more comfortable.

Browse source
This commit is contained in:
Simon Brooke 2018-06-13 19:43:50 +01:00
parent b69bcaa020
commit e9ed2d0573
4 changed files with 548 additions and 85 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
resources/transforms/adl2psql.xslt
View file

@ -1,7 +1,7 @@
<?xml version="1.0"?>
<xsl:stylesheet version="1.0"
xmlns="http://bowyer.journeyman.cc/adl/1.4/"
xmlns:adl="http://bowyer.journeyman.cc/adl/1.4/"
xmlns="http://bowyer.journeyman.cc/adl/1.4.1/"
xmlns:adl="http://bowyer.journeyman.cc/adl/1.4.1/"
xmlns:xsl="http://www.w3.org/1999/XSL/Transform">
<!-- :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -->
<!-- -->
@ -300,10 +300,11 @@
print the names of the distinguishing fields in this table,
concatenating into a single string.
-->
<xsl:for-each select="/application/entity[@name=$table]">
<xsl:for-each select="property[@distinct='user' or @distinct='all']">
Template distinctfield entered, table is <xsl:value-of select="$table"/>.
<xsl:for-each select="//entity[@name=$table]/property[@distinct='user' or @distinct='all']">
<xsl:choose>
<xsl:when test="@type='entity'">
Entity <xsl:value-of select="@name"/> detected.
<xsl:call-template name="distinctfield">
<xsl:with-param name="table" select="@entity"/>
<xsl:with-param name="alias" select="concat( $alias, '_', @name)"></xsl:with-param>
@ -311,12 +312,11 @@
</xsl:when>
<xsl:otherwise>
<xsl:value-of select="$alias"/>.<xsl:value-of
select="@name"/><xsl:if test="position() != last()"> | ' ' | </xsl:if>
select="@name"/><xsl:if test="position() != last()"> | ', ' | </xsl:if>
</xsl:otherwise>
</xsl:choose>
</xsl:for-each>
</xsl:for-each>
</xsl:template>
<xsl:template name="permission">

6
src/adl/to_hugsql_queries.clj
View file

@ -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 " %)))))

400
src/adl/to_psql.clj Normal file
View file

@ -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))))

65
src/adl/utils.clj
View file

@ -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))))