From e2aa97945801a7dd1580212c8a4dd89a39848b83 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Tue, 12 Nov 2019 15:10:26 +0000 Subject: [PATCH 1/9] All unit tests passing. --- src/adl/to_hugsql_queries.clj | 5 +- src/adl/validator.clj | 25 +++--- test/adl/to_hugsql_queries_test.clj | 117 +++++++++++++++------------- test/adl/validator_test.clj | 4 +- 4 files changed, 82 insertions(+), 69 deletions(-) diff --git a/src/adl/to_hugsql_queries.clj b/src/adl/to_hugsql_queries.clj index b10b2bd..6f2b1b9 100644 --- a/src/adl/to_hugsql_queries.clj +++ b/src/adl/to_hugsql_queries.clj @@ -101,8 +101,7 @@ (insertable-properties entity)) query-name (str "create-" pretty-name "!") signature (if (has-primary-key? entity) - ":? :1" ;; bizarrely, if you want to return the keys, - ;; you have to use a query signature. + ": Date: Tue, 12 Nov 2019 15:13:30 +0000 Subject: [PATCH 2/9] Ignore .orig files. --- .gitignore | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.gitignore b/.gitignore index 96ff9d7..243eef8 100644 --- a/.gitignore +++ b/.gitignore @@ -27,3 +27,5 @@ node_modules/ generated/ + +*.orig From dd4120bb91ecf53f32f164a6e9b79ddce1adb42e Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Tue, 12 Nov 2019 16:19:01 +0000 Subject: [PATCH 3/9] Run `lein ancient` and updated dependencies. to_psql_tests do NOT yet pass (new file, never has passed) --- project.clj | 4 +-- src/adl/to_psql.clj | 2 +- test/adl/to_psql_test.clj | 73 +++++++++++++++++++++++++++++++++++++++ 3 files changed, 76 insertions(+), 3 deletions(-) create mode 100644 test/adl/to_psql_test.clj diff --git a/project.clj b/project.clj index c20cfb3..e212a47 100644 --- a/project.clj +++ b/project.clj @@ -11,8 +11,8 @@ [environ "1.1.0"] [hiccup "1.0.5"] [org.clojure/clojure "1.8.0"] - [org.clojure/math.combinatorics "0.1.4"] - [org.clojure/tools.cli "0.3.7"]] + [org.clojure/math.combinatorics "0.1.6"] + [org.clojure/tools.cli "0.4.2"]] :aot [adl.main] diff --git a/src/adl/to_psql.clj b/src/adl/to_psql.clj index b3dd1f8..f913692 100644 --- a/src/adl/to_psql.clj +++ b/src/adl/to_psql.clj @@ -198,7 +198,7 @@ (if (and (= (:tag property) :property) - (not (#{"link"} (:type (:attrs property))))) + (not (#{"link" "list£"} (:type (:attrs property))))) (s/join " " (remove diff --git a/test/adl/to_psql_test.clj b/test/adl/to_psql_test.clj new file mode 100644 index 0000000..418d688 --- /dev/null +++ b/test/adl/to_psql_test.clj @@ -0,0 +1,73 @@ +(ns adl.to-psql-test + (:require [clojure.string :as s] + [clojure.test :refer :all] + [adl.to-psql :refer :all] + [adl-support.utils :refer :all])) + +(deftest create-table-test + (testing "Generation of table creation" + (let [application {:tag :application, + :attrs {:version "0.1.1", :name "test-app"}, + :content + [{: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 + {:immutable "true", + :required "true", + :distinct "all", + :generator "assigned" + :type "string", + :size "12" + :name "postcode"}} + ]} + {: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 {:name "dwellings" :type "list" :entity "dwellings" :farkey "address_id"}} + ]} + {:tag :entity, + :attrs {:name "dwelling"}, + :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 + {:name "address_id" :required "true" :type "entity" :entity "address" :farkey "id"}} + {:tag :property + :attrs + {:name "sub_address" :type "string" :size "32"}}]}]} + address-entity (child-with-tag application :entity #(= (:name %) "address")) + dwelling-entity (child-with-tag application :entity #(= (:name %) "dwelling")) + expected "" + actual (emit-table address-entity application "Test doc") + ] + (is (= actual expected))))) From c2d006ac3bf38731fa5712038e4af9e72be3ad1c Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 15 Nov 2019 15:27:24 +0000 Subject: [PATCH 4/9] A number of improvements, but still not generating clean PSQL. --- project.clj | 2 +- src/adl/to_psql.clj | 16 +- test/adl/to_psql_test.clj | 467 +++++++++++++++++++++++++++++++++----- 3 files changed, 420 insertions(+), 65 deletions(-) diff --git a/project.clj b/project.clj index e212a47..c2e3c69 100644 --- a/project.clj +++ b/project.clj @@ -5,7 +5,7 @@ :license {:name "GNU Lesser General Public License, version 3.0 or (at your option) any later version" :url "https://www.gnu.org/licenses/lgpl-3.0.en.html"} - :dependencies [[adl-support "0.1.6"] + :dependencies [[adl-support "0.1.7-SNAPSHOT"] [bouncer "1.0.1"] [clojure-saxon "0.9.4"] [environ "1.1.0"] diff --git a/src/adl/to_psql.clj b/src/adl/to_psql.clj index f913692..74cf5c6 100644 --- a/src/adl/to_psql.clj +++ b/src/adl/to_psql.clj @@ -194,11 +194,12 @@ ([property entity application] (emit-property property entity application false)) ([property entity application key?] - (let [default (:default (:attrs property))] + (let [default (:default (:attrs property)) + type (-> property :attrs :type)] (if (and (= (:tag property) :property) - (not (#{"link" "list£"} (:type (:attrs property))))) + (not (#{"link" "list"} (:type (:attrs property))))) (s/join " " (remove @@ -225,7 +226,10 @@ (defn compose-convenience-entity-field [field entity application] - (let [farside (entity-for-property (property-for-field field entity) application)] + (let [property (case (:tag field) + :field (property-for-field field entity) + :property field) + farside (entity-for-property property application)] (flatten (map (fn [f] @@ -435,9 +439,9 @@ (str (s/join ",\n" - (flatten - (remove - nil? + (remove + nil? + (flatten (list (map #(emit-property % entity application true) diff --git a/test/adl/to_psql_test.clj b/test/adl/to_psql_test.clj index 418d688..3339fc0 100644 --- a/test/adl/to_psql_test.clj +++ b/test/adl/to_psql_test.clj @@ -4,70 +4,421 @@ [adl.to-psql :refer :all] [adl-support.utils :refer :all])) -(deftest create-table-test - (testing "Generation of table creation" - (let [application {:tag :application, - :attrs {:version "0.1.1", :name "test-app"}, +;; (deftest link-property-test +;; (testing "No field generated for link property" + + +(deftest to-psql-tests + (let [application {:tag :application, + :attrs {:version "0.1.1", + :name "youyesyet", + :xmlns:adl "http://bowyer.journeyman.cc/adl/1.4.1/", + :xmlns:html "http://www.w3.org/1999/xhtml", + :xmlns "http://bowyer.journeyman.cc/adl/1.4.1/"} + :content + [{:tag :typedef, + :attrs + {:size "16", + :pattern + "^([Gg][Ii][Rr] 0[Aa]{2})|((([A-Za-z][0-9]{1,2})|(([A-Za-z][A-Ha-hJ-Yj-y][0-9]{1,2})|(([AZa-z][0-9][A-Za-z])|([A-Za-z][A-Ha-hJ-Yj-y][0-9]?[A-Za-z]))))[0-9][A-Za-z]{2})$", + :type "string", + :name "postcode"}, :content - [{:tag :entity, - :attrs {:name "address"}, + [{:tag :documentation, + :attrs nil, :content - [{:tag :key, + ["See\n https://assets.publishing.service.gov.uk/government/uploads/system/uploads/attachment_data/file/488478/Bulk_Data_Transfer_-_additional_validation_valid_from_12_November_2015.pdf,\n section 3"]} + {:tag :help, + :attrs {:locale "en_GB.UTF-8"}, + :content ["A valid postcode."]}]} + {:tag :entity, + :attrs + {:volatility "6", + :magnitude "6", + :name "addresses", + :table "addresses"}, + :content + [{:tag :documentation, + :attrs nil, + :content + ["Addresses of all buildings which contain\n dwellings."]} + {:tag :key, + :attrs nil, + :content + [{:tag :property, + :attrs + {:distinct "system", + :immutable "true", + :column "id", + :name "id", + :type "integer", + :required "true"}, + :content + [{:tag :generator, :attrs {:action "native"}, :content nil}]}]} + {:tag :property, + :attrs + {:distinct "user", + :size "256", + :column "address", + :name "address", + :type "string", + :required "true"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "Address"}, + :content nil}]} + {:tag :property, + :attrs + {:distinct "user", + :size "16", + :column "postcode", + :name "postcode", + :typedef "postcode", + :type "defined"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "Postcode"}, + :content nil}]} + {:tag :property, + :attrs + {:farkey "id", + :entity "districts", + :column "district_id", + :name "district_id", + :type "entity"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "District"}, + :content nil}]} + {:tag :property, + :attrs {:column "latitude", :name "latitude", :type "real"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "Latitude"}, + :content nil}]} + {:tag :property, + :attrs {:column "longitude", :name "longitude", :type "real"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "Longitude"}, + :content nil}]} + {:tag :property, + :attrs + {:farkey "address_id", + :entity "dwellings", + :name "dwellings", + :type "list"}, + :content nil} + {:tag :property, + :attrs {:column "locality", :name "locality", :type "integer"}, + :content + [{:tag :documentation, :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 - {:immutable "true", - :required "true", - :distinct "all", - :generator "assigned" - :type "string", - :size "12" - :name "postcode"}} - ]} - {: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 {:name "dwellings" :type "list" :entity "dwellings" :farkey "address_id"}} - ]} - {:tag :entity, - :attrs {:name "dwelling"}, + ["Locality indexing; see issue #44. Note that\n this property should be generated automatically from the\n latitude and longitude: (+ (* 10000 ;; left-shift the\n latitude component four digits (integer (* latitude 1000)))\n (- ;; invert the sign of the longitude component, since ;;\n we're interested in localities West of Greenwich. (integer (*\n longitude 1000)))) We'll use a trigger to insert this. I\n don't think it will ever appear in the user interface; it's\n an implementation detail, not of interest to\n users."]} + {:tag :generator, :attrs {:action "native"}, :content nil}]} + {:tag :list, + :attrs {:name "Addresses", :properties "listed"}, :content - [{:tag :key, + [{:tag :field, + :attrs {:property "address"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "Address"}, + :content nil}]} + {:tag :field, + :attrs {:property "postcode"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "Postcode"}, + :content nil}]} + {:tag :field, + :attrs {:property "district_id"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "District"}, + :content nil}]}]} + {:tag :form, + :attrs {:name "Address", :properties "listed"}, + :content + [{:tag :field, + :attrs {:property "address"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "Address"}, + :content nil}]} + {:tag :field, + :attrs {:property "postcode"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "Postcode"}, + :content nil}]} + {:tag :field, + :attrs {:property "district_id"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "District"}, + :content nil}]} + {:tag :field, + :attrs {:property "latitude"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "Latitude"}, + :content nil}]} + {:tag :field, + :attrs {:property "longitude"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "Longitude"}, + :content nil}]} + {:tag :auxlist, + :attrs + {:canadd "true", + :onselect "form-dwellings-Dwelling", + :property "dwellings"}, + :content + [{:tag :field, + :attrs {:property "sub-address"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "Sub-address"}, + :content nil}]}]}]} + {:tag :permission, + :attrs {:permission "read", :group "canvassers"}, + :content nil} + {:tag :permission, + :attrs {:permission "read", :group "teamorganisers"}, + :content nil} + {:tag :permission, + :attrs {:permission "read", :group "issueexperts"}, + :content nil} + {:tag :permission, + :attrs {:permission "read", :group "analysts"}, + :content nil} + {:tag :permission, + :attrs {:permission "read", :group "issueeditors"}, + :content nil} + {:tag :permission, + :attrs {:permission "all", :group "admin"}, + :content nil}]} + + {:tag :entity, + :attrs + {:volatility "6", + :magnitude "6", + :name "dwellings", + :table "dwellings"}, + :content + [{:tag :documentation, + :attrs nil, + :content + ["All dwellings within addresses in the system; a\n dwelling is a house, flat or appartment in which electors live.\n Every address should have at least one dwelling; essentially,\n an address maps onto a street door and dwellings map onto\n what's behind that door. So a tenement or a block of flats\n would be one address with many dwellings."]} + {:tag :key, + :attrs nil, + :content + [{:tag :property, + :attrs + {:distinct "system", + :immutable "true", + :column "id", + :name "id", + :type "integer", + :required "true"}, + :content + [{:tag :generator, :attrs {:action "native"}, :content nil}]}]} + {:tag :property, + :attrs + {:distinct "user", + :farkey "id", + :entity "addresses", + :column "address_id", + :name "address_id", + :type "entity", + :required "true"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "Building Address"}, + :content nil}]} + {:tag :property, + :attrs + {:distinct "user", + :name "sub-address", + :size "32", + :type "string", + :required "false"}, + :content + [{:tag :documentation, :attrs nil, :content - [{:tag :property, + ["\n The part of the address which identifies the flat or\n apartment within the building, if in a multiple occupancy\n building.\n "]}]} + {:tag :property, + :attrs {:entity "electors", :name "electors", :type "list"}, + :content nil} + {:tag :list, + :attrs {:name "Dwellings", :properties "listed"}, + :content + [{:tag :field, + :attrs {:property "address_id"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "Building Address"}, + :content nil}]} + {:tag :field, + :attrs {:property "sub-address"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "Sub address"}, + :content nil}]}]} + {:tag :form, + :attrs {:name "Dwelling", :properties "listed"}, + :content + [{:tag :field, + :attrs {:property "address_id"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "Building Address"}, + :content nil}]} + {:tag :field, + :attrs {:property "sub-address"}, + :content + [{:tag :prompt, :attrs - {:immutable "true", - :required "true", - :distinct "system", - :type "integer", - :name "id"}, - :content - [{:tag :generator, :attrs {:action "native"}, :content nil}]}]} - {:tag :property + {:locale "en_GB.UTF-8", + :prompt "Sub address (e.g. flat number)"}, + :content nil}]}]} + {:tag :permission, + :attrs {:permission "read", :group "canvassers"}, + :content nil} + {:tag :permission, + :attrs {:permission "read", :group "teamorganisers"}, + :content nil} + {:tag :permission, + :attrs {:permission "read", :group "issueexperts"}, + :content nil} + {:tag :permission, + :attrs {:permission "read", :group "analysts"}, + :content nil} + {:tag :permission, + :attrs {:permission "read", :group "issueeditors"}, + :content nil} + {:tag :permission, + :attrs {:permission "all", :group "admin"}, + :content nil}]} + {:tag :entity, + :attrs + {:volatility "7", + :magnitude "4", + :name "districts", + :table "districts"}, + :content + [{:tag :documentation, + :attrs nil, + :content + ["Electoral districts: TODO: Shape (polygon)\n information will need to be added, for use in\n maps."]} + {:tag :key, + :attrs nil, + :content + [{:tag :property, :attrs - {:name "address_id" :required "true" :type "entity" :entity "address" :farkey "id"}} - {:tag :property - :attrs - {:name "sub_address" :type "string" :size "32"}}]}]} - address-entity (child-with-tag application :entity #(= (:name %) "address")) - dwelling-entity (child-with-tag application :entity #(= (:name %) "dwelling")) - expected "" - actual (emit-table address-entity application "Test doc") - ] - (is (= actual expected))))) + {:distinct "system", + :immutable "true", + :column "id", + :name "id", + :type "integer", + :required "true"}, + :content + [{:tag :generator, :attrs {:action "native"}, :content nil}]}]} + {:tag :property, + :attrs + {:distinct "user", + :size "64", + :column "name", + :name "name", + :type "string", + :required "true"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "name"}, + :content nil}]} + {:tag :permission, + :attrs {:permission "read", :group "public"}, + :content nil} + {:tag :permission, + :attrs {:permission "all", :group "admin"}, + :content nil} + {:tag :list, + :attrs {:name "Districts", :properties "listed"}, + :content + [{:tag :field, + :attrs {:property "name"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "name"}, + :content nil}]}]} + {:tag :form, + :attrs {:name "District", :properties "listed"}, + :content + [{:tag :field, + :attrs {:property "name"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "name"}, + :content nil}]}]} + {:tag :permission, + :attrs {:permission "read", :group "canvassers"}, + :content nil} + {:tag :permission, + :attrs {:permission "read", :group "teamorganisers"}, + :content nil} + {:tag :permission, + :attrs {:permission "read", :group "issueexperts"}, + :content nil} + {:tag :permission, + :attrs {:permission "read", :group "analysts"}, + :content nil} + {:tag :permission, + :attrs {:permission "read", :group "issueeditors"}, + :content nil} + {:tag :permission, + :attrs {:permission "all", :group "admin"}, + :content nil}]} + ]} + address-entity (child-with-tag application :entity #(= (-> % :attrs :name) "addresses")) + dwelling-entity (child-with-tag application :entity #(= (-> % :attrs :name) "dwellings"))] + (testing "varchar field" + (let [property (child-with-tag address-entity :property #(= (-> % :attrs :name) "address")) + expected "\t address VARCHAR(256) NOT NULL" + actual (emit-property property address-entity application false)] + (is (= actual expected)))) + (testing "integer field" + (let [property (child-with-tag address-entity :property #(= (-> % :attrs :name) "locality")) + expected "\t locality INTEGER" + actual (emit-property property address-entity application false)] + (is (= actual expected)))) + (testing "real field" + (let [property (child-with-tag address-entity :property #(= (-> % :attrs :name) "longitude")) + expected "\t longitude DOUBLE PRECISION" + actual (emit-property property address-entity application false)] + (is (= actual expected)))) + (testing "list field" + (let [property (child-with-tag address-entity :property #(= (-> % :attrs :name) "dwellings")) + actual (emit-property property address-entity application false)] + (is (nil? actual)))) + (testing "entity field" + (let [property (child-with-tag address-entity :property #(= (-> % :attrs :name) "district_id")) + expected "\t district_id INTEGER" + actual (emit-property property address-entity application false)] + (is (= actual expected)))) + + ;; (testing "pattern field" + ;; (let [property (child-with-tag address-entity :property #(= (-> % :attrs :name) "postcode")) + ;; expected #"\t postcode VARCHAR(16) CONSTRAINT pattern_\d+ CHECK (postcode ~* '^([Gg][Ii][Rr] 0[Aa]{2})|((([A-Za-z][0-9]{1,2})|(([A-Za-z][A-Ha-hJ-Yj-y][0-9]{1,2})|(([AZa-z][0-9][A-Za-z])|([A-Za-z][A-Ha-hJ-Yj-y][0-9]?[A-Za-z]))))[0-9][A-Za-z]{2})$')" + ;; actual (emit-property property address-entity application false)] + ;; ;; slightly tricky because the pattern name is gensymed. + ;; (is (= actual expected)) + ;; (is (string? (re-find expected actual))))) + (testing "Table creation" + (let [expected "------------------------------------------------------------------------\n--\tTest doc \n--\t\n--\tAll dwellings within addresses in the system; a\n--\t dwelling is a house, flat or appartment in which electors live.\n--\t Every address should have at least one dwelling; essentially,\n--\t an address maps onto a street door and dwellings map onto\n--\t what's behind that door. So a tenement or a block of flats\n--\t would be one address with many dwellings. \n------------------------------------------------------------------------\nCREATE TABLE dwellings\n(\n\t id SERIAL NOT NULL PRIMARY KEY,\n\t address_id INTEGER NOT NULL,\n\t sub_address VARCHAR(32)\n);\nGRANT SELECT ON dwellings TO admin,\n\tanalysts,\n\tcanvassers,\n\tissueeditors,\n\tissueexperts,\n\tteamorganisers ;\nGRANT INSERT ON dwellings TO admin ;\nGRANT UPDATE ON dwellings TO admin ;\nGRANT DELETE ON dwellings TO admin ;" + actual (emit-table dwelling-entity application "Test doc")] + (is (= actual expected)))) + )) From 8f24c314a16b9e912352ea3803823873d300347f Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 16 Nov 2019 13:15:27 +0000 Subject: [PATCH 5/9] Now creating a complete database initialisation script that runs. --- src/adl/to_psql.clj | 58 +++++++++++++++++++++------------------ test/adl/to_psql_test.clj | 13 +++++++++ 2 files changed, 44 insertions(+), 27 deletions(-) diff --git a/src/adl/to_psql.clj b/src/adl/to_psql.clj index 74cf5c6..73a0842 100644 --- a/src/adl/to_psql.clj +++ b/src/adl/to_psql.clj @@ -232,11 +232,11 @@ farside (entity-for-property property application)] (flatten (map - (fn [f] + (fn [p] (if - (= (:type (:attrs f)) "entity") - (compose-convenience-entity-field f farside application) - (str (safe-name (:table (:attrs farside))) "." (field-name f)))) + (= (:type (:attrs p)) "entity") + (compose-convenience-entity-field p farside application) + (str (safe-name (:table (:attrs farside))) "." (field-name p)))) (user-distinct-properties farside))))) @@ -295,14 +295,16 @@ (defn emit-convenience-entity-field - [field entity application] - (str - (s/join - " ||', '|| " - (compose-convenience-entity-field field entity application)) - " AS " - (field-name field) - "_expanded")) + [property entity application] + (if + (= "entity" (-> property :attrs :type)) + (str + (s/join + " ||', '|| " + (compose-convenience-entity-field property entity application)) + " AS " + (field-name property) + "_expanded"))) (defn emit-convenience-view @@ -310,9 +312,9 @@ menus, et cetera." [entity application] (let [view-name (safe-name (str "lv_" (:table (:attrs entity))) :sql) - entity-fields (filter - #(= (:type (:attrs %)) "entity") - (properties entity))] + entity-properties (filter + #(= (:type (:attrs %)) "entity") + (properties entity))] (s/join "\n" (remove @@ -329,21 +331,23 @@ "SELECT " (s/join ",\n\t" - (flatten - (map - #(if - (= (:type (:attrs %)) "entity") - (list - (emit-convenience-entity-field % entity application) + (remove + nil? + (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 %))) - (str (safe-name entity) "." (field-name %))) - (filter - #(not= (:type (:attrs %)) "link") - (all-properties entity) ))))) + (remove + #(#{"link" "list"} (:type (:attrs %))) + (all-properties entity) )))))) (str "FROM " (s/join ", " (set (compose-convenience-view-select-list entity application true)))) (if-not - (empty? entity-fields) + (empty? entity-properties) (str "WHERE " (s/join @@ -360,7 +364,7 @@ (safe-name (:table (:attrs farside)) :sql) "." (safe-name (first (key-names farside)) :sql)))) - entity-fields)))) + entity-properties)))) ";" (emit-permissions-grant view-name :SELECT (find-permissions entity application)))))))) diff --git a/test/adl/to_psql_test.clj b/test/adl/to_psql_test.clj index 3339fc0..597bb13 100644 --- a/test/adl/to_psql_test.clj +++ b/test/adl/to_psql_test.clj @@ -421,4 +421,17 @@ (let [expected "------------------------------------------------------------------------\n--\tTest doc \n--\t\n--\tAll dwellings within addresses in the system; a\n--\t dwelling is a house, flat or appartment in which electors live.\n--\t Every address should have at least one dwelling; essentially,\n--\t an address maps onto a street door and dwellings map onto\n--\t what's behind that door. So a tenement or a block of flats\n--\t would be one address with many dwellings. \n------------------------------------------------------------------------\nCREATE TABLE dwellings\n(\n\t id SERIAL NOT NULL PRIMARY KEY,\n\t address_id INTEGER NOT NULL,\n\t sub_address VARCHAR(32)\n);\nGRANT SELECT ON dwellings TO admin,\n\tanalysts,\n\tcanvassers,\n\tissueeditors,\n\tissueexperts,\n\tteamorganisers ;\nGRANT INSERT ON dwellings TO admin ;\nGRANT UPDATE ON dwellings TO admin ;\nGRANT DELETE ON dwellings TO admin ;" actual (emit-table dwelling-entity application "Test doc")] (is (= actual expected)))) + (testing "Convenience entity field - is an entity field, should emit" + (let [property (child-with-tag address-entity :property #(= (-> % :attrs :name) "district_id")) + expected "districts.name AS district_id_expanded" + actual (emit-convenience-entity-field property address-entity application)] + (is (= actual expected)))) + + (testing "Convenience entity field - is not an entity field, should not emit" + (let [farside dwelling-entity + property (child-with-tag address-entity :property #(= (-> % :attrs :name) "dwellings")) + expected nil + actual (emit-convenience-entity-field property address-entity application)] + (is (= actual expected)))) + )) From b472bd4950fa61226ed0ee1d18f856605378a37d Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 28 Dec 2019 12:01:35 +0000 Subject: [PATCH 6/9] #9: Fixes bug 9, all tests pass... But I'm not utterly confident there won't be regressions. --- src/adl/to_hugsql_queries.clj | 2 +- src/adl/to_psql.clj | 50 +++++++++++++++------------ src/adl/to_selmer_routes.clj | 2 +- test/adl/to_psql_test.clj | 63 ++++++++++++++++++++++++++++++++++- 4 files changed, 92 insertions(+), 25 deletions(-) diff --git a/src/adl/to_hugsql_queries.clj b/src/adl/to_hugsql_queries.clj index 6f2b1b9..9e13053 100644 --- a/src/adl/to_hugsql_queries.clj +++ b/src/adl/to_hugsql_queries.clj @@ -311,7 +311,7 @@ farkey (-> % :attrs :farkey) link-type (-> % :attrs :type) link-field (-> % :attrs :name) - query-name (list-related-query-name % entity far-entity false) + query-name (list-related-query-name % entity (or far-entity far-name) false) signature ":? :*"] (hash-map (keyword query-name) diff --git a/src/adl/to_psql.clj b/src/adl/to_psql.clj index 73a0842..8f9c0e4 100644 --- a/src/adl/to_psql.clj +++ b/src/adl/to_psql.clj @@ -225,7 +225,9 @@ (defn compose-convenience-entity-field - [field entity application] + ([field entity application] + (compose-convenience-entity-field field entity application nil)) + ([field entity application table-alias] (let [property (case (:tag field) :field (property-for-field field entity) :property field) @@ -235,13 +237,13 @@ (fn [p] (if (= (:type (:attrs p)) "entity") - (compose-convenience-entity-field p farside application) - (str (safe-name (:table (:attrs farside))) "." (field-name p)))) - (user-distinct-properties farside))))) + (compose-convenience-entity-field p farside application (field-name property)) + (str (or table-alias (safe-name (:table (:attrs farside)))) "." (field-name p)))) + (user-distinct-properties farside)))))) -(defn compose-convenience-view-select-list - "Compose the body of an SQL `SELECT` statement for a convenience view of this +(defn compose-convenience-view-from-list + "Compose the FROM list of an SQL `SELECT` statement for a convenience view of this `entity` within this `application`, recursively. `top-level?` should be set only on first invocation." [entity application top-level?] @@ -254,10 +256,12 @@ (fn [f] (if (= (:type (:attrs f)) "entity") - (compose-convenience-view-select-list - (child application #(and (entity? %) (= (:name (:attrs %))(:entity (:attrs f))))) - application - false))) + (let [farside (child application #(and (entity? %) (= (:name (:attrs %))(:entity (:attrs f))))) + tablename (safe-name (-> farside :attrs :table) :sql) + fieldname (field-name f)] + (if (= tablename fieldname) + tablename + (str tablename " AS " fieldname))))) (if top-level? (all-properties entity) @@ -295,16 +299,18 @@ (defn emit-convenience-entity-field - [property entity application] - (if - (= "entity" (-> property :attrs :type)) - (str - (s/join - " ||', '|| " - (compose-convenience-entity-field property entity application)) - " AS " - (field-name property) - "_expanded"))) + ([property entity application] + (emit-convenience-entity-field property entity application (field-name property))) + ([property entity application table-alias] + (if + (= "entity" (-> property :attrs :type)) + (str + (s/join + " ||', '|| " + (compose-convenience-entity-field property entity application table-alias)) + " AS " + (field-name property) + "_expanded")))) (defn emit-convenience-view @@ -338,14 +344,14 @@ #(if (= (:type (:attrs %)) "entity") (list - (emit-convenience-entity-field % entity application) + (emit-convenience-entity-field % entity application (field-name %)) (str (safe-name entity) "." (field-name %))) (str (safe-name entity) "." (field-name %))) (remove #(#{"link" "list"} (:type (:attrs %))) (all-properties entity) )))))) (str - "FROM " (s/join ", " (set (compose-convenience-view-select-list entity application true)))) + "FROM " (s/join ", " (set (compose-convenience-view-from-list entity application true)))) (if-not (empty? entity-properties) (str diff --git a/src/adl/to_selmer_routes.clj b/src/adl/to_selmer_routes.clj index a6d9bc6..760e22a 100644 --- a/src/adl/to_selmer_routes.clj +++ b/src/adl/to_selmer_routes.clj @@ -176,7 +176,7 @@ (*warn* (str "Entity '" - (-> entity :attrs :name) + (or (-> entity :attrs :name) entity) "' passed to compose-fetch-auxlist-data is a non-entity"))) (if-not (entity? farside) diff --git a/test/adl/to_psql_test.clj b/test/adl/to_psql_test.clj index 597bb13..f01ad0d 100644 --- a/test/adl/to_psql_test.clj +++ b/test/adl/to_psql_test.clj @@ -423,7 +423,7 @@ (is (= actual expected)))) (testing "Convenience entity field - is an entity field, should emit" (let [property (child-with-tag address-entity :property #(= (-> % :attrs :name) "district_id")) - expected "districts.name AS district_id_expanded" + expected "district_id.name AS district_id_expanded" actual (emit-convenience-entity-field property address-entity application)] (is (= actual expected)))) @@ -435,3 +435,64 @@ (is (= actual expected)))) )) + +(deftest bug-9-test + (testing "Correct reference to aliased tables in convenience view select queries + see [bug 9](https://github.com/simon-brooke/adl/issues/9)" + (let [app + {:tag :application, + :attrs {:version "0.0.1", + :name "pastoralist", + :xmlns:adl "http://bowyer.journeyman.cc/adl/1.4.1/", + :xmlns:html "http://www.w3.org/1999/xhtml", + :xmlns "http://bowyer.journeyman.cc/adl/1.4.1/"}, + :content [{:tag :documentation, + :attrs nil, + :content ["A web-app intended to be used by pastoralists in managing + pastures, grazing, and animals."]} + {:tag :entity, + :attrs {:volatility "5", :magnitude "9", :name "animal" :table "animal"}, + :content + [{:tag :key, + :attrs nil, + :content + [{:tag :property, + :attrs + {:distinct "system", + :immutable "true", + :column "id", + :name "id", + :type "integer", + :required "true"}, + :content + [{:tag :generator, :attrs {:action "native"}, :content nil}]}]} + {:tag :property, + :attrs {:entity "animal", :type "entity", :name "dam"}, + :content nil} + {:tag :property, + :attrs {:entity "animal", :type "entity", :name "sire"}, + :content nil} + {:tag :property, + :attrs + {:required "true", + :distinct "user", + :size "64", + :type "string", + :name "animal-identifier"}, + :content + [{:tag :prompt, + :attrs {:locale "en_GB.UTF-8", :prompt "Ear-tag Number"}, + :content nil}]} + {:tag :property, + :attrs {:distinct "user", :size "64", :type "string", :name "name"}, + :content nil}]}]} + animal (child app #(= (-> % :attrs :name) "animal")) + dam (child animal #(= (-> % :attrs :name) "dam"))] + (let [actual (emit-convenience-view animal app) + should-find #"dam.animal_identifier" + should-not-find #"animal.name AS dam_expanded"] + ;; (print actual) ;; see what we've got + (is (re-find should-find actual)) + (is (nil? (re-find should-not-find actual)))) + + ))) From 69ead0f5ebc293b9ebd508e6dc7e112062f28e67 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 28 Dec 2019 14:20:50 +0000 Subject: [PATCH 7/9] #10: fixes bug 10, all tests pass, no regression expected. --- src/adl/to_psql.clj | 7 ++--- test/adl/to_psql_test.clj | 54 +++++++++++++++++++++++++++++++++++++-- 2 files changed, 56 insertions(+), 5 deletions(-) diff --git a/src/adl/to_psql.clj b/src/adl/to_psql.clj index 8f9c0e4..f08b80e 100644 --- a/src/adl/to_psql.clj +++ b/src/adl/to_psql.clj @@ -320,7 +320,8 @@ (let [view-name (safe-name (str "lv_" (:table (:attrs entity))) :sql) entity-properties (filter #(= (:type (:attrs %)) "entity") - (properties entity))] + (properties entity)) + tn (safe-name (-> entity :attrs :table) :sql)] (s/join "\n" (remove @@ -345,8 +346,8 @@ (= (:type (:attrs %)) "entity") (list (emit-convenience-entity-field % entity application (field-name %)) - (str (safe-name entity) "." (field-name %))) - (str (safe-name entity) "." (field-name %))) + (str tn "." (field-name %))) + (str tn "." (field-name %))) (remove #(#{"link" "list"} (:type (:attrs %))) (all-properties entity) )))))) diff --git a/test/adl/to_psql_test.clj b/test/adl/to_psql_test.clj index f01ad0d..1f41c81 100644 --- a/test/adl/to_psql_test.clj +++ b/test/adl/to_psql_test.clj @@ -493,6 +493,56 @@ should-not-find #"animal.name AS dam_expanded"] ;; (print actual) ;; see what we've got (is (re-find should-find actual)) - (is (nil? (re-find should-not-find actual)))) + (is (nil? (re-find should-not-find actual))))))) - ))) +(deftest bug-10-test + (testing "Correct table names in convenience view select queries + see [bug 10](https://github.com/simon-brooke/adl/issues/10)" + (let [app + {:tag :application, + :attrs {:version "0.0.1", + :name "pastoralist", + :xmlns:adl "http://bowyer.journeyman.cc/adl/1.4.1/", + :xmlns:html "http://www.w3.org/1999/xhtml", + :xmlns "http://bowyer.journeyman.cc/adl/1.4.1/"}, + :content [{:tag :documentation, + :attrs nil, + :content ["A web-app intended to be used by pastoralists in managing + pastures, grazing, and animals."]} + {:tag :entity, + :attrs + {:volatility "5", + :magnitude "3", + :name "event-type", + :table "event-type"}, + :content + [{:tag :key, + :attrs nil, + :content + [{:tag :property, + :attrs + {:distinct "system", + :immutable "true", + :column "id", + :name "id", + :type "integer", + :required "true"}, + :content + [{:tag :generator, :attrs {:action "native"}, :content nil}]}]} + {:tag :property, + :attrs {:size "80", :type "string", :name "summary"}, + :content nil} + {:tag :property, + :attrs {:type "text", :name "description"}, + :content nil} + {:tag :property, + :attrs {:default "1", :type "integer", :name "n-holdings"},} + {:tag :property, + :attrs {:default "1", :type "integer", :name "n-pastures"}} + {:tag :property, + :attrs {:default "1", :type "integer", :name "n-animals"}}]}]} + should-find #"event_type.description" + should-not-find #"event-type.description" + actual (emit-convenience-view (child app #(= (-> % :attrs :name) "event-type")) app)] + (is (re-find should-find actual)) + (is (nil? (re-find should-not-find actual)))))) From b4b20d1d7a1526472cf07a9b2b919a4c35d8cdcf Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 18 May 2025 12:46:15 +0100 Subject: [PATCH 8/9] Added `todo` element (child of `documentation`) to DTD. Upversioned to 1.4.2 --- resources/schemas/adl-1.4.2.dtd | 628 ++++++++++++++++++++++++++++++++ resources/schemas/adl-1.4.2.xsd | 559 ++++++++++++++++++++++++++++ src/adl/to_swagger.clj | 101 ++++- 3 files changed, 1276 insertions(+), 12 deletions(-) create mode 100644 resources/schemas/adl-1.4.2.dtd create mode 100644 resources/schemas/adl-1.4.2.xsd diff --git a/resources/schemas/adl-1.4.2.dtd b/resources/schemas/adl-1.4.2.dtd new file mode 100644 index 0000000..d2f63d8 --- /dev/null +++ b/resources/schemas/adl-1.4.2.dtd @@ -0,0 +1,628 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/resources/schemas/adl-1.4.2.xsd b/resources/schemas/adl-1.4.2.xsd new file mode 100644 index 0000000..225477a --- /dev/null +++ b/resources/schemas/adl-1.4.2.xsd @@ -0,0 +1,559 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/src/adl/to_swagger.clj b/src/adl/to_swagger.clj index 3ce11ca..521b385 100644 --- a/src/adl/to_swagger.clj +++ b/src/adl/to_swagger.clj @@ -2,7 +2,7 @@ :author "Simon Brooke"} adl.to-swagger (:require [adl-support.utils :refer :all] - [adl.to-hugsql-queries :refer [queries]] + [adl.to-hugsql-queries :refer [generate-documentation queries]] [clj-time.core :as t] [clj-time.format :as f] [clojure.java.io :refer [file make-parents writer]] @@ -43,21 +43,98 @@ (list 'ns (symbol (str (safe-name (:name (:attrs application))) ".routes.auto-api")) - (str "API routes for " (:name (:attrs application)) + (str "Swagger 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] + '[reitit.swagger :as swagger] + '[reitit.swagger-ui :as swagger-ui] + '[reitit.ring.coercion :as coercion] + '[reitit.coercion.spec :as spec-coercion] + '[reitit.ring.middleware.muuntaja :as muuntaja] + '[reitit.ring.middleware.multipart :as multipart] + '[reitit.ring.middleware.parameters :as parameters] + '[placenames.middleware.formats :as formats] + '[placenames.middleware.exception :as exception] + '[placenames.routes.auto-jason :as aj] '[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)))) + '[clojure.java.io :as io]))) + +(defn def-routes + "Generate Swagger routes for all queries implied by this ADL `application` spec." + ;; THIS ISN'T NEARLY FINISHED! + ([application] + (list 'defn 'auto-api-routes [] + ["/api" + {:coercion spec-coercion/coercion + :muuntaja formats/instance + :swagger {:id ::api} + :middleware [;; query-params & form-params + parameters/parameters-middleware + ;; content-negotiation + muuntaja/format-negotiate-middleware + ;; encoding response body + muuntaja/format-response-middleware + ;; exception handling + exception/exception-middleware + ;; decoding request body + muuntaja/format-request-middleware + ;; coercing response bodys + coercion/coerce-response-middleware + ;; coercing request parameters + coercion/coerce-request-middleware + ;; multipart + multipart/multipart-middleware]}] + (map #(def-routes application %) + (children-with-tag application :entity))) + ([application entity] + [(str "/" (safe-name entity)) + {:get (make-get-route entity) + (cons + 'defroutes + (cons + 'auto-rest-routes + (map + #(let [handler (handlers-map %)] + (list + (symbol (s/upper-case (name (:method handler)))) + (str "/json/auto/" (safe-name (:name handler))) + 'request + (list + 'route/restricted + (list (:name handler) 'request)))) + (sort + (keys handlers-map)))))}]))) + + +(defn to-swagger + "Generate a Swagger API for all queries implied by this ADL `application` spec." + [application] + (let [filepath (str + *output-path* + "src/" + (safe-name (:name (:attrs application))) + "/routes/auto_api.clj")] + (make-parents filepath) + (do-or-warn + (do + (spit + filepath + (s/join + "\n\n" + (cons + (file-header application) + (map + (fn [q] + (str + ;; THIS ISN'T NEARLY FINISHED! + )) + (sort + #(compare (:name %1) (:name %2)) + (vals + (queries application))))))) + (if (pos? *verbosity*) + (*warn* (str "\tGenerated " filepath))))))) From 0a23cacd048508e3addccc3574ddc87194e9f2fd Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 23 May 2025 17:56:00 +0100 Subject: [PATCH 9/9] Further work on Postgres transform, still not perfect. Current unit tests are almost worthless; need new tests. --- src/adl/to_psql.clj | 85 +++++++++++++++++++++------------------ test/adl/to_psql_test.clj | 21 +++++----- 2 files changed, 57 insertions(+), 49 deletions(-) diff --git a/src/adl/to_psql.clj b/src/adl/to_psql.clj index f12eda1..64d6826 100644 --- a/src/adl/to_psql.clj +++ b/src/adl/to_psql.clj @@ -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] - [clj-time.core :as t] - [clj-time.format :as f])) + (: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] + [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,8 +400,8 @@ (field-name property) ") \n\tREFERENCES" (str - (safe-name (:table (:attrs farside)) :sql) - "(" (field-name (first (key-properties farside))) ")") + (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" (case @@ -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)))))) diff --git a/test/adl/to_psql_test.clj b/test/adl/to_psql_test.clj index 1f41c81..dd705df 100644 --- a/test/adl/to_psql_test.clj +++ b/test/adl/to_psql_test.clj @@ -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