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

83
src/adl/to_psql.clj
View file

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

21
test/adl/to_psql_test.clj
View file

@ -1,8 +1,9 @@
(ns adl.to-psql-test (ns adl.to-psql-test
(:require [clojure.string :as s] (:require
[clojure.test :refer :all] [adl-support.utils :refer [child child-with-tag]]
[adl.to-psql :refer :all] [adl.to-psql :refer [emit-convenience-entity-field emit-convenience-view
[adl-support.utils :refer :all])) emit-property emit-table]]
[clojure.test :refer [deftest is testing]]))
;; (deftest link-property-test ;; (deftest link-property-test
;; (testing "No field generated for link property" ;; (testing "No field generated for link property"
@ -12,9 +13,9 @@
(let [application {:tag :application, (let [application {:tag :application,
:attrs {:version "0.1.1", :attrs {:version "0.1.1",
:name "youyesyet", :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: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 :content
[{:tag :typedef, [{:tag :typedef,
:attrs :attrs
@ -443,9 +444,9 @@
{:tag :application, {:tag :application,
:attrs {:version "0.0.1", :attrs {:version "0.0.1",
:name "pastoralist", :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: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, :content [{:tag :documentation,
:attrs nil, :attrs nil,
:content ["A web-app intended to be used by pastoralists in managing :content ["A web-app intended to be used by pastoralists in managing
@ -502,9 +503,9 @@
{:tag :application, {:tag :application,
:attrs {:version "0.0.1", :attrs {:version "0.0.1",
:name "pastoralist", :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: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, :content [{:tag :documentation,
:attrs nil, :attrs nil,
:content ["A web-app intended to be used by pastoralists in managing :content ["A web-app intended to be used by pastoralists in managing