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

Further work on Postgres transform, still not perfect.

Browse source 
Current unit tests are almost worthless; need new tests.
This commit is contained in:
Simon Brooke 2025-05-23 17:56:00 +01:00
parent 38f9c0f0e4
commit 0a23cacd04
2 changed files with 57 additions and 49 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

81
src/adl/to_psql.clj
View file

@ -1,13 +1,20 @@
(ns ^{:doc "Application Description Language: generate Postgres database definition."
:author "Simon Brooke"}
adl.to-psql
(:require [adl-support.core :refer :all]
[adl-support.utils :refer :all]
;; [adl.to-hugsql-queries :refer [queries]]
[clojure.java.io :refer [make-parents]]
[clojure.string :as s]
(:require
[adl-support.core :refer [*warn* do-or-warn]]
[adl-support.utils :refer [*output-path* *verbosity* all-properties child
child-with-tag children-with-tag emit-header
entity-for-property entity? find-permissions
is-quotable-type? key-names key-properties
link-table-name properties property-for-field
safe-name singularise sort-by-name
system-generated? typedef unique-link?
user-distinct-properties]] ;; [adl.to-hugsql-queries :refer [queries]]
[clj-time.core :as t]
[clj-time.format :as f]))
[clj-time.format :as f]
[clojure.java.io :refer [make-parents]]
[clojure.string :as s]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
@ -161,7 +168,7 @@
#(if (selector (:permission (:attrs %)))
(safe-name (:group (:attrs %)) :sql))
permissions)))]
(if-not
(when-not
(empty? group-names)
(s/join
" "
@ -195,10 +202,10 @@
([property entity application key?]
(let [default (:default (:attrs property))
type (-> property :attrs :type)]
(if
(when
(and
(= (:tag property) :property)
(not (#{"link" "list"} (:type (:attrs property)))))
(not (#{"link" "list"} type)))
(s/join
" "
(remove
@ -208,14 +215,14 @@
"\t"
(field-name property)
(emit-field-type property entity application key?)
(if
(when
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.
;; it's quite common for `now()` to be the default for a date, time or timestamp field.
default)))
(if
key?
@ -237,7 +244,7 @@
(if
(= (:type (:attrs p)) "entity")
(compose-convenience-entity-field p farside application (field-name property))
(str (or table-alias (safe-name (:table (:attrs farside)))) "." (field-name p))))
(str (or table-alias (safe-name farside :sql)) "." (field-name p))))
(user-distinct-properties farside))))))
@ -250,13 +257,13 @@
nil?
(flatten
(cons
(safe-name (:table (:attrs entity)) :sql)
(safe-name entity :sql)
(map
(fn [f]
(if
(when
(= (:type (:attrs f)) "entity")
(let [farside (child application #(and (entity? %) (= (:name (:attrs %))(:entity (:attrs f)))))
tablename (safe-name (-> farside :attrs :table) :sql)
tablename (safe-name farside :sql)
fieldname (field-name f)]
(if (= tablename fieldname)
tablename
@ -279,19 +286,19 @@
(flatten
(map
(fn [f]
(if
(when
(= (:type (:attrs f)) "entity")
(let [farside (entity-for-property f application)]
(cons
(str
(safe-name (:table (:attrs entity)) :sql)
(safe-name entity :sql)
"."
(field-name f)
" = "
(safe-name (:table (:attrs farside)) :sql)
(safe-name farside :sql)
"."
(safe-name (first (key-names farside)) :sql))
#(compose-convenience-where-clause farside application false)))))
(compose-convenience-where-clause farside application false)))))
(if
top-level?
(all-properties entity)
@ -302,7 +309,7 @@
([property entity application]
(emit-convenience-entity-field property entity application (field-name property)))
([property entity application table-alias]
(if
(when
(= "entity" (-> property :attrs :type))
(str
(s/join
@ -317,11 +324,11 @@
"Emit a convenience view of this `entity` of this `application` for use in generating lists,
menus, et cetera."
[entity application]
(let [view-name (safe-name (str "lv_" (:table (:attrs entity))) :sql)
(let [table-name (safe-name entity :sql)
view-name (safe-name (str "lv_" table-name) :sql)
entity-properties (filter
#(= (:type (:attrs %)) "entity")
(properties entity))
tn (safe-name (-> entity :attrs :table) :sql)]
(properties entity))]
(s/join
"\n"
(remove
@ -346,14 +353,14 @@
(= (:type (:attrs %)) "entity")
(list
(emit-convenience-entity-field % entity application (field-name %))
(str tn "." (field-name %)))
(str tn "." (field-name %)))
(str table-name "." (field-name %)))
(str table-name "." (field-name %)))
(remove
#(#{"link" "list"} (:type (:attrs %)))
(all-properties entity) ))))))
(str
"FROM " (s/join ", " (set (compose-convenience-view-from-list entity application true))))
(if-not
(when-not
(empty? entity-properties)
(str
"WHERE "
@ -364,11 +371,11 @@
(let
[farside (entity-for-property f application)]
(str
(safe-name (:table (:attrs entity)) :sql)
(safe-name entity :sql)
"."
(field-name f)
" = "
(safe-name (:table (:attrs farside)) :sql)
(safe-name farside :sql)
"."
(safe-name (first (key-names farside)) :sql))))
entity-properties))))
@ -393,7 +400,7 @@
(field-name property)
") \n\tREFERENCES"
(str
(safe-name (:table (:attrs farside)) :sql)
(safe-name farside :sql)
"( " (field-name (first (key-properties farside))) " )")
;; TODO: ought to handle the `cascade` attribute, even though it's rarely used
"\n\tON DELETE"
@ -430,7 +437,7 @@
"Emit a table declaration for this `entity` of this `application`,
documented with this `doc-comment` if specified."
([entity application doc-comment]
(let [table-name (safe-name (:table (:attrs entity)) :sql)
(let [table-name (safe-name entity :sql)
permissions (children-with-tag entity :permission)]
(s/join
"\n"
@ -472,7 +479,7 @@
application
(str
"primary table "
(:table (:attrs entity))
(safe-name entity :sql)
" for entity "
(:name (:attrs entity))))))
@ -503,7 +510,7 @@
(= (:name (:attrs %)) (:entity (:attrs property)))))
unique? (unique-link? e1 e2)
link-table-name (link-table-name property e1 e2)]
(if
(when
;; we haven't already emitted this one...
(not (@emitted-link-tables link-table-name))
(let [permissions (flatten
@ -521,7 +528,7 @@
[(construct-link-property e1)
(construct-link-property e2)]
permissions)))}]
(if-not unique?
(when-not unique?
(*warn*
(str "WARNING: Manually check link tables between "
(-> e1 :attrs :name)
@ -562,8 +569,8 @@
(defn emit-group-declaration
"Emit a declaration for this authorisation `group` within this `application`."
[group application]
"Emit a declaration for this authorisation `group`."
[group]
(list
(emit-header
"--"
@ -600,7 +607,7 @@
(list
(emit-file-header application)
(map
#(emit-group-declaration % application)
#(emit-group-declaration %)
(sort-by-name
(children-with-tag application :group)))
(map
@ -626,7 +633,7 @@
(make-parents filepath)
(do-or-warn
(spit filepath (emit-application application))
(if
(when
(pos? *verbosity*)
(*warn* (str "\tGenerated " filepath))))))

21
test/adl/to_psql_test.clj
View file

@ -1,8 +1,9 @@
(ns adl.to-psql-test
(:require [clojure.string :as s]
[clojure.test :refer :all]
[adl.to-psql :refer :all]
[adl-support.utils :refer :all]))
(:require
[adl-support.utils :refer [child child-with-tag]]
[adl.to-psql :refer [emit-convenience-entity-field emit-convenience-view
emit-property emit-table]]
[clojure.test :refer [deftest is testing]]))
;; (deftest link-property-test
;; (testing "No field generated for link property"
@ -12,9 +13,9 @@
(let [application {:tag :application,
:attrs {:version "0.1.1",
:name "youyesyet",
:xmlns:adl "http://bowyer.journeyman.cc/adl/1.4.1/",
:xmlns:adl "http://www.journeyman.cc/adl/1.4.7/",
:xmlns:html "http://www.w3.org/1999/xhtml",
:xmlns "http://bowyer.journeyman.cc/adl/1.4.1/"}
:xmlns "http://www.journeyman.cc/adl/1.4.7/"}
:content
[{:tag :typedef,
:attrs
@ -443,9 +444,9 @@
{:tag :application,
:attrs {:version "0.0.1",
:name "pastoralist",
:xmlns:adl "http://bowyer.journeyman.cc/adl/1.4.1/",
:xmlns:adl "http://www.journeyman.cc/adl/1.4.7/",
:xmlns:html "http://www.w3.org/1999/xhtml",
:xmlns "http://bowyer.journeyman.cc/adl/1.4.1/"},
:xmlns "http://www.journeyman.cc/adl/1.4.7/"},
:content [{:tag :documentation,
:attrs nil,
:content ["A web-app intended to be used by pastoralists in managing
@ -502,9 +503,9 @@
{:tag :application,
:attrs {:version "0.0.1",
:name "pastoralist",
:xmlns:adl "http://bowyer.journeyman.cc/adl/1.4.1/",
:xmlns:adl "http://www.journeyman.cc/adl/1.4.7/",
:xmlns:html "http://www.w3.org/1999/xhtml",
:xmlns "http://bowyer.journeyman.cc/adl/1.4.1/"},
:xmlns "http://www.journeyman.cc/adl/1.4.7/"},
:content [{:tag :documentation,
:attrs nil,
:content ["A web-app intended to be used by pastoralists in managing