From b486ac49e53eaedea101f63a5c418dbd62668913 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 2 Mar 2018 15:37:55 +0000 Subject: [PATCH] No longer actually generates XML, but structure is more usable --- src/squirrel_parse/parser.clj | 3 +- src/squirrel_parse/simplify.clj | 9 +- src/squirrel_parse/to_adl.clj | 190 ++++++++++++++++++++++++++++---- src/squirrel_parse/utils.clj | 16 +++ 4 files changed, 193 insertions(+), 25 deletions(-) diff --git a/src/squirrel_parse/parser.clj b/src/squirrel_parse/parser.clj index 707631f..54fa36b 100644 --- a/src/squirrel_parse/parser.clj +++ b/src/squirrel_parse/parser.clj @@ -244,7 +244,8 @@ "PERMISSIONS-STMT := REVOKE-STMT | GRANT-STMT;" "REVOKE-STMT := KW-REVOKE PERMISSIONS KW-ON OPT-KW-SCHEMA QUAL-NAME KW-FROM NAMES TERMINATOR;" - "GRANT-STMT := KW-GRANT PERMISSIONS KW-ON OPT-KW-SCHEMA QUAL-NAME KW-TO NAMES TERMINATOR;" + "GRANT-STMT := KW-GRANT PERMISSIONS KW-ON OPT-KW-SCHEMA QUAL-NAME KW-TO OPT-ROLE NAMES TERMINATOR;" + "OPT-ROLE := ROLE | '';" "PERMISSIONS := PERMISSION-COMMA * PERMISSION ;" "PERMISSION-COMMA := PERMISSION COMMA ;" diff --git a/src/squirrel_parse/simplify.clj b/src/squirrel_parse/simplify.clj index 49d5021..bc54100 100644 --- a/src/squirrel_parse/simplify.clj +++ b/src/squirrel_parse/simplify.clj @@ -36,10 +36,12 @@ [x] (and (coll? x)(contains? #{:COMMENT - :SPACE + :LPAR :OPT-KW-DATA :OPT-SPACE :QUOTE-MK + :RPAR + :SPACE :TERMINATOR} (first x)))) @@ -88,6 +90,8 @@ :ALTER-SEQ-ELEMENT :ALTER-STMT :ALTER-TABLE-ELEMENT + :CREATE-STMT + :EXPRESSION :MATCH-TYPE :ONLY :OPT-KW-SCHEMA @@ -107,7 +111,8 @@ :TABLE-SPEC-ELEMENT :TC-ELEMENT :VALUE) (simplify-second-of-two tree) - (:PERMISSION-COMMA) (in-simplify (nth tree 1)) + (:PERMISSION-COMMA + :TABLE-SPEC-ELT-COMMA) (in-simplify (nth tree 1)) (:ROLE) (first tree) (remove nil? (map in-simplify tree))) tree)) diff --git a/src/squirrel_parse/to_adl.clj b/src/squirrel_parse/to_adl.clj index bb0be02..7b9b320 100644 --- a/src/squirrel_parse/to_adl.clj +++ b/src/squirrel_parse/to_adl.clj @@ -5,7 +5,8 @@ [clj-time.core :refer [now]] [clj-time.format :refer [formatters unparse]] [squirrel-parse.parser :refer [parse]] - [squirrel-parse.simplify :refer [simplify]])) + [squirrel-parse.simplify :refer [simplify]] + [squirrel-parse.utils :refer [deep-merge]])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -68,10 +69,43 @@ [subtree type] (and (coll? subtree) (= (first subtree) type))) + +(defn subtree? + "Does this `subtree` appear to be a subtree of a parse tree?" + [subtree] + (and (seq? subtree) (keyword? (first subtree)))) + + +(defn subtree-to-map + "Converts `subtree` to a map. **Note** that this will return unexpected + results if the subtree contains repeating entries of the same type + (i.e. having the same initial keyword), as only the last of such + a sequence will be retained. Use with care." + [subtree] + (if + (subtree? subtree) + (if + (and + (> (count subtree) 1) + (reduce #(and %1 %2) (map seq? (rest subtree)))) + {(first subtree) (reduce merge {} (map subtree-to-map (rest subtree)))} + {(first subtree) (first (rest subtree))}) + subtree)) + + +(defn map-to-xml + [m] + (if + (map? m) + (interleave (keys m) (map map-to-xml (vals m))) + m)) + + + (defn is-create-table-statement? "Is this statement a create table statement?" [statement] - (is-subtree-of-type? statement :TABLE-DECL)) + (is-subtree-of-type? statement :CREATE-TABLE-STMT)) (defn get-children-of-type [subtree type] (if @@ -84,15 +118,18 @@ %) subtree)))) + (defn get-first-child-of-type [subtree type] (first (get-children-of-type subtree type))) + (defn get-name "Return the value the first top-level :NAME element of this `subtree`." [subtree] (let [name-elt (get-first-child-of-type subtree :NAME)] (if name-elt (second name-elt)))) + (defn get-column-datatype "Get the datatype of this column specification." [column-spec] @@ -100,27 +137,32 @@ sql-datatype (first (second datatype-spec))] (sql-datatype-to-adl-datatype sql-datatype))) + (defn make-property "Make an ADL property representing this column specification." [column-spec] (if (is-subtree-of-type? (second column-spec) :COLUMN-SPEC) (make-property (second column-spec)) - {:tag :property - :attrs - { - :name (get-name column-spec) - :type (get-column-datatype column-spec) - }} - )) + (let [name (get-name column-spec)] + {(keyword name) + {:tag :property + :attrs + { + :name (get-name column-spec) + :type (get-column-datatype column-spec) + }}} + ))) + (defn make-entity [table-decl] "Make an ADL entity representing this table declaration" {:tag :entity - :name (get-name table-decl) - :content + :name (get-name table-decl) + :content + {:properties (apply - vector + merge (map make-property (remove @@ -129,10 +171,11 @@ #(if (is-subtree-of-type? % :COLUMN-SPEC) %) - (get-first-child-of-type table-decl :TABLE-SPEC-ELEMENTS)))))}) + (get-first-child-of-type table-decl + :TABLE-SPEC-ELEMENTS)))))}}) -(defn table-definition-to-entity +(defn table-definition-to-map "Return a map like this `map` with, if this `statement` is a table declaration, an ADL entity representing that table added to it." [entity-map statement] @@ -142,15 +185,119 @@ (merge entity-map {table-name (make-entity statement)})) entity-map)) + +(defn is-column-constraint-statement-of-type? + [statement key] + (and + (is-subtree-of-type? statement :ALTER-TABLE) + (let [sm (subtree-to-map statement)] + (or + (key + (:COLUMN-CONSTRAINT + (:ADD-CONSTRAINT + (:ALTER-TABLE-ELEMENTS + (:ALTER-TABLE sm))))) + (key + (:COLUMN-CONSTRAINT + (:COLUMN-CONSTRAINT + (:ADD-CONSTRAINT + (:ALTER-TABLE-ELEMENTS + (:ALTER-TABLE sm)))))) + )))) + + +(defn is-foreign-key-statement? + "Returns non-nil (actually the relevant fragment) if `statement` is an + 'alter table... add foreign key' statement" + [statement] + (is-column-constraint-statement-of-type? statement :REFERENCES-CC)) + + +(defn is-primary-key-statement? + [statement] + (is-column-constraint-statement-of-type? statement :PRIMARY-CC)) + + +(defn decorate-with-relationship + [entity-map statement] + (if + (is-foreign-key-statement? statement) + (let [sm (subtree-to-map (is-foreign-key-statement? statement)) + table (:name entity-map) + ns-table (:NAME (:QUAL-NAME (:ALTER-TABLE (subtree-to-map statement)))) + ns-cols (:NAME (:NAMES sm)) + fs-table (:NAME (:REFERENCES-CC sm)) + fs-cols (:NAME (:NAMES (:REFERENCES-CC sm)))] + (println (str + "table: " table + "\n\tns-table: " ns-table + "\n\tns-cols: " ns-cols + "\n\tfs-table: " fs-table + "\n\tfs-cols: " fs-cols)) + (cond + (not + (= table ns-table)) + ;; this statement doesn't refer to us... + entity-map + true + (deep-merge + entity-map + {:content + {:properties + {(keyword ns-cols) + {:attrs + {:type "entity" :entity fs-table :farkey fs-cols}}}}}))))) + + +(defn decorate-with-primary-key + [entity-map statement] + (if + (is-primary-key-statement? statement) + (let [sm (subtree-to-map (is-primary-key-statement? statement)) + table (:name entity-map) + st-table (:NAME (:QUAL-NAME (:ALTER-TABLE (subtree-to-map statement)))) + col (keyword (:NAME (:NAMES (:INDEX-PARAMS sm)))) + properties (:properties (:content entity-map))] + (if + (= table st-table) + (merge + entity-map + {:content + (merge + (:content entity-map) + {:key {col (properties col)} + :properties (dissoc properties col)})}) + entity-map)) + entity-map)) + + +(defn decorate-with-all + [entity-map statements function] + (reduce + deep-merge + entity-map + (remove + nil? + (map function statements)))) + + (defn table-definitions-to-entities "Extract table definitions from these `statements` as a map of ADL - entities indexed by name." - ([statements] - (reduce table-definition-to-entity {} statements))) - -(defn extract-security-groups-from-statements + entities indexed by name." [statements] - nil) + (let + [base-map (reduce table-definition-to-map {} statements)] + (apply + merge + (map + (fn [x] + (let [entity-map (base-map x)] + {x + (decorate-with-all + (decorate-with-all entity-map statements #(decorate-with-relationship entity-map %)) + statements + #(decorate-with-primary-key entity-map %))})) + (keys base-map))))) (defn to-adl @@ -165,8 +312,7 @@ {:tag :application :attrs {:name application-name :version version } - :content (vals entities)} - )) + :content (vals entities)})) ([input application-name version output] (let [adl (to-adl input application-name version)] (spit output (str xml-header "\n" (with-out-str (emit-element adl)))) diff --git a/src/squirrel_parse/utils.clj b/src/squirrel_parse/utils.clj index c1e2324..edd4688 100644 --- a/src/squirrel_parse/utils.clj +++ b/src/squirrel_parse/utils.clj @@ -28,6 +28,22 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defn deep-merge [v & vs] + "Filched from https://gist.github.com/danielpcox/c70a8aa2c36766200a95" + (letfn [(rec-merge [v1 v2] + (if (and (map? v1) (map? v2)) + (merge-with deep-merge v1 v2) + v2))] + (when (some identity vs) + (reduce #(rec-merge %1 %2) v vs)))) +;; (letfn [(rec-merge [v1 v2] +;; (if (and (map? v1) (map? v2)) +;; (merge-with deep-merge v1 v2) +;; v2))] +;; (if (some identity vs) +;; (reduce #(rec-merge %1 %2) v vs) +;; v))) + (defn- make-unterminated-case-insensitive-match-rule "Make a grammar rule which matches this `token` case-insensitively, without the terminal semi-colon. Keywords may always optionally be preceded