Prefer safe-name

src/adl/to_hugsql_queries.clj

@@ -1,7 +1,7 @@
 (ns ^{:doc "Application Description Language - generate HUGSQL queries file."
       :author "Simon Brooke"}
   adl.to-hugsql-queries
-  (:require [clojure.java.io :refer [file]]
+  (:require [clojure.java.io :refer [file make-parents]]
             [clojure.math.combinatorics :refer [combinations]]
             [clojure.string :as s]
             [clojure.xml :as x]
@@ -54,7 +54,9 @@
 
 (defn order-by-clause
   "Generate an appropriate `order by` clause for queries on this `entity`"
-  [entity]
+  ([entity]
+   (order-by-clause entity ""))
+  ([entity prefix]
   (let
     [entity-name (:name (:attrs entity))
      preferred (map
@@ -65,10 +67,10 @@
       (empty? preferred)
       ""
       (str
-        "ORDER BY " entity-name "."
+        "ORDER BY " prefix entity-name "."
         (s/join
-          (str ",\n\t" entity-name ".")
+          (str ",\n\t" prefix entity-name ".")
-          (flatten (cons preferred (key-names entity))))))))
+          (flatten (cons preferred (key-names entity)))))))))
 
 
 (defn insert-query
@@ -152,8 +154,8 @@
              (str
                "-- :doc selects existing "
                pretty-name
-               " records having any string field matching `:pattern` by substring match")
+               " records having any string field matching the parameter of the same name by substring match")
-             (str "SELECT * FROM " entity-name)
+             (str "SELECT * FROM lv_" entity-name)
              "WHERE "
              (s/join
                "\n\tOR "
@@ -162,9 +164,9 @@
                  (map
                    #(if
                       (#{"string" "date" "text"} (:type (:attrs %)))
-                      (str (-> % :attrs :name) " LIKE '%:pattern%'"))
+                      (str (-> % :attrs :name) " LIKE '%params." (-> % :attrs :name) "%'"))
                    properties)))
-             (order-by-clause entity)
+             (order-by-clause entity "lv_")
              "--~ (if (:offset params) \"OFFSET :offset \")"
              "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))})))
 
@@ -232,8 +234,8 @@
            (list
              (str "-- :name " query-name " " signature)
              (str "-- :doc lists all existing " pretty-name " records")
-             (str "SELECT * FROM " entity-name)
+             (str "SELECT * FROM lv_" entity-name)
-             (order-by-clause entity)
+             (order-by-clause entity "lv_")
              "--~ (if (:offset params) \"OFFSET :offset \")"
              "--~ (if (:limit params) \"LIMIT :limit\" \"LIMIT 100\")")))})))
 
@@ -276,9 +278,11 @@
                     "entity" (list
                                (str "-- :name " query-name " " signature)
                                (str "-- :doc lists all existing " pretty-name " records related to a given " pretty-far)
-                               (str "SELECT * \nFROM " entity-name)
+                               (str "SELECT * \nFROM lv_" entity-name ", " entity-name)
-                               (str "WHERE " entity-name "." link-field " = :id")
+                               (str "WHERE lv_" entity-name "." (first (key-names entity)) " = "
-                               (order-by-clause entity))
+                                    entity-name "." (first (key-names entity))
+                                    "\n\tAND " entity-name "." link-field " = :id")
+                               (order-by-clause entity "lv_"))
                     "link" (let [link-table-name
                                  (link-table-name entity far-entity)]
                              (list
@@ -392,13 +396,10 @@
 
 (defn queries
   "Generate all standard queries for this `entity` in this `application`; if
-  no entity is specified, generate all queris for the application."
+  no entity is specified, generate all queries for the application."
   ([application entity]
    (merge
-     (if
+     ;; TODO: queries that look through link tables
-       (link-table? entity)
-       (link-table-queries entity application)
-       {})
      (insert-query entity)
      (update-query entity)
      (delete-query entity)
@@ -416,22 +417,22 @@
 (defn to-hugsql-queries
   "Generate all [HugSQL](https://www.hugsql.org/) queries implied by this ADL `application` spec."
   [application]
+  (let [file-path (str *output-path* "resources/sql/queries.sql")]
+    (make-parents file-path)
     (spit
-    (str *output-path* "queries.sql")
+      file-path
       (s/join
         "\n\n"
         (cons
-        (s/join
+          (emit-header
-          "\n-- "
+            "--"
-          (list
+            "File queries.sql"
-            "-- File queries.sql"
+            (str "autogenerated by adl.to-hugsql-queries at " (t/now))
-            "autogenerated by adl.to-hugsql-queries at"
+            "See [Application Description Language](https://github.com/simon-brooke/adl).")
-            (t/now)
-            "See [Application Description Language](https://github.com/simon-brooke/adl).\n\n"))
           (map
             #(:query %)
             (sort
               #(compare (:name %1) (:name %2))
               (vals
-                (queries application))))))))
+                (queries application)))))))))
 

src/adl/to_json_routes.clj

@@ -47,12 +47,12 @@
          (f/unparse (f/formatters :basic-date-time) (t/now)))
     (list
       :require
+      '[clojure.java.io :as io]
+      '[compojure.core :refer [defroutes GET POST]]
+      '[hugsql.core :as hugsql]
       '[noir.response :as nresponse]
       '[noir.util.route :as route]
-      '[compojure.core :refer [defroutes GET POST]]
       '[ring.util.http-response :as response]
-      '[clojure.java.io :as io]
-      '[hugsql.core :as hugsql]
       (vector (symbol (str (safe-name (:name (:attrs application))) ".db.core")) :as 'db))))
 
 

src/adl/to_psql.clj

@@ -37,16 +37,6 @@
 ;;; this is a pretty straight translation of adl2psql.xslt, and was written because
 ;;; Clojure is easier to debug.
 
-;;; TODO: the order in which we generate tables is critical, because tables
-;;; can only reference other tables which already exist. We could get around
-;;; this by generating referential integrity constraints post-hoc, which is
-;;; what the xslt version did.
-
-(defn sort-by-name
-  [elements]
-  (sort #(.compareTo (:name (:attrs %1)) (:name (:attrs %2))) elements))
-
-
 (declare emit-field-type emit-property)
 
 
@@ -60,7 +50,7 @@
           (:pattern (:attrs typedef))
           (str
            " CONSTRAINT "
-           (gensym "c-")
+           (gensym "pattern_")
            " CHECK ("
            (:name (:attrs property))
            " ~* '"
@@ -70,7 +60,7 @@
           ;; TODO: if base type is date, time or timestamp, values should be quoted.
           (str
            " CONSTRAINT "
-           (gensym "c-")
+           (gensym "minmax_")
            " CHECK ("
            (:minimum (:attrs typedef))
            " < "
@@ -83,7 +73,7 @@
           (:maximum (:attrs typedef))
           (str
            " CONSTRAINT "
-           (gensym "c-")
+           (gensym "max_")
            " CHECK ("
            (:name (:attrs property))
            " < "
@@ -92,7 +82,7 @@
           (:minimum (:attrs typedef))
           (str
            " CONSTRAINT "
-           (gensym "c-")
+           (gensym "min_")
            " CHECK ("
            (:minimum (:attrs typedef))
            " < "
@@ -158,11 +148,31 @@
             nil?
             (map
               #(if (selector (:permission (:attrs %)))
-              (:group (:attrs %)))
+                 (safe-name (:group (:attrs %)) :sql))
               permissions)))]
     (if
       (not (empty? group-names))
-      (s/join " " (list "GRANT" (name privilege) "ON"  table-name "TO" (s/join ",\n\t" (sort group-names)) ";")))))
+      (s/join
+        " "
+        (list
+          "GRANT"
+          (name privilege)
+          "ON"
+          (safe-name table-name :sql)
+          "TO"
+          (s/join
+            ",\n\t"
+            (sort group-names))
+          ";")))))
+
+
+(defn field-name
+  [property]
+  (safe-name
+    (or
+      (:column (:attrs property))
+      (:name (:attrs property)))
+    :sql))
 
 
 (defn emit-property
@@ -181,9 +191,17 @@
          (flatten
           (list
            "\t"
-           (:name (:attrs property))
+           (field-name property)
            (emit-field-type property entity application key?)
-           (if default (list "DEFAULT" default))
+           (if
+             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.
+                 default)))
            (if
              key?
              "NOT NULL PRIMARY KEY"
@@ -203,7 +221,7 @@
         (if
           (= (:type (:attrs f)) "entity")
           (compose-convenience-entity-field f farside application)
-          (str (:table (:attrs farside)) "." (:name (:attrs f)))))
+          (str (safe-name (:table (:attrs farside))) "." (field-name f))))
       (user-distinct-properties farside)))))
 
 
@@ -213,7 +231,7 @@
    nil?
    (flatten
     (cons
-     (:name (:attrs entity))
+     (safe-name (:table (:attrs entity)) :sql)
      (map
       (fn [f]
         (if
@@ -242,13 +260,13 @@
          (let [farside (entity-for-property f application)]
            (cons
             (str
-             (:table (:attrs entity))
+             (safe-name (:table (:attrs entity)) :sql)
              "."
-             (:name (:attrs f))
+             (field-name f)
              " = "
-             (:table (:attrs farside))
+             (safe-name (:table (:attrs farside)) :sql)
              "."
-             (first (key-names farside)))
+             (safe-name (first (key-names farside)) :sql))
             #(compose-convenience-where-clause farside application false)))))
      (if
        top-level?
@@ -260,17 +278,17 @@
   [field entity application]
   (str
    (s/join
-    " |', '| "
+    " ||', '|| "
     (compose-convenience-entity-field field entity application))
    " AS "
-   (:name (:attrs field))))
+   (field-name 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)))
+  (let [view-name (safe-name (str "lv_" (:table (:attrs entity))) :sql)
         entity-fields (filter
                        #(= (:type (:attrs %)) "entity")
                        (properties entity))]
@@ -294,12 +312,12 @@
            #(if
               (= (:type (:attrs %)) "entity")
               (emit-convenience-entity-field % entity application)
-              (:name (:attrs %)))
+              (str (safe-name entity) "." (field-name %)))
            (filter
-            #(and (= (:tag %) :property) (not (= (:type (:attrs %)) "link")))
+            #(not (= (:type (:attrs %)) "link"))
             (all-properties entity) ))))
         (str
-         "FROM " (s/join ", " (compose-convenience-view-select-list entity application true)))
+         "FROM " (s/join ", " (set (compose-convenience-view-select-list entity application true))))
         (if
           (not (empty? entity-fields))
           (str
@@ -315,13 +333,13 @@
                              (entity? %)
                              (= (:name (:attrs %)) (:entity (:attrs f)))))]
                  (str
-                  (:table (:attrs entity))
+                  (safe-name (:table (:attrs entity)) :sql)
                   "."
-                  (:name (:attrs f))
+                  (field-name f)
                   " = "
-                  (:table (:attrs farside))
+                  (safe-name (:table (:attrs farside)) :sql)
                   "."
-                  (first (key-names farside)))))
+                  (safe-name (first (key-names farside)) :sql))))
              entity-fields))))
         ";"
         (emit-permissions-grant view-name :SELECT (permissions entity application))))))))
@@ -335,14 +353,15 @@
      " "
      (list
       "ALTER TABLE"
-      (:name (:attrs nearside))
+      (safe-name (:name (:attrs nearside)) :sql)
       "ADD CONSTRAINT"
-      (str "ri_" (:name (:attrs nearside)) "_" (:name (:attrs property)))
+      (safe-name (str "ri_" (:name (:attrs nearside)) "_" (:name (:attrs farside)) "_" (:name (:attrs property))) :sql)
       "\n\tFOREIGN KEY("
-      (:name (:attrs property))
+      (field-name property)
       ") \n\tREFERENCES"
       (str
-       (:table (:attrs farside)) "(" (:name (:attrs (first (key-properties farside)))) ")")
+       (safe-name (:table (:attrs 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
@@ -366,7 +385,7 @@
     (list
      (emit-header
       "--"
-      (str "--\treferential integrity links for first-class tables"))
+      "referential integrity links for primary tables")
      (map
       #(emit-referential-integrity-links % application)
       (sort-by-name (children-with-tag application :entity)))))))
@@ -374,7 +393,7 @@
 
 (defn emit-table
   ([entity application doc-comment]
-   (let [table-name (:table (:attrs entity))
+   (let [table-name (safe-name (:table (:attrs entity)) :sql)
          permissions (children-with-tag entity :permission)]
      (s/join
       "\n"
@@ -424,12 +443,11 @@
 (defn construct-link-property
   [entity]
   {:tag :property
-   :attrs {:name (str (:name (:attrs entity)) "_id")
+   :attrs {:name (safe-name (str (:name (:attrs entity)) "_id") :sql)
-           :column (str (:name (:attrs entity)) "_id")
+           :column (safe-name (str (:name (:attrs entity)) "_id") :sql)
            :type "entity"
            :entity (:name (:attrs entity))
-           :farkey (first (key-names entity))}
+           :farkey (safe-name (first (key-names entity)) :sql)}})
-   :content nil})
 
 
 (defn emit-link-table
@@ -489,21 +507,13 @@
     (sort-by-name (children-with-tag application :entity)))))
 
 
-(defn emit-entity
-  [entity application]
-  (doall
-   (list
-    (emit-table entity application)
-    (emit-convenience-view entity application))))
-
-
 (defn emit-group-declaration
   [group application]
   (list
    (emit-header
     "--"
     (str "security group " (:name (:attrs group))))
-   (str "CREATE GROUP " (:name (:attrs group)) ";")))
+   (str "CREATE GROUP " (safe-name (:name (:attrs group)) :sql) ";")))
 
 
 (defn emit-file-header
@@ -535,7 +545,11 @@
         (sort-by-name
          (children-with-tag application :group)))
        (map
-        #(emit-entity % application)
+        #(emit-table % application)
+        (sort-by-name
+         (children-with-tag application :entity)))
+       (map
+        #(emit-convenience-view % application)
         (sort-by-name
          (children-with-tag application :entity)))
        (emit-referential-integrity-links application)

src/adl/to_selmer_routes.clj

@@ -44,12 +44,12 @@
          (f/unparse (f/formatters :basic-date-time) (t/now)))
     (list
       :require
+      '[clojure.java.io :as io]
+      '[compojure.core :refer [defroutes GET POST]]
+      '[hugsql.core :as hugsql]
       '[noir.response :as nresponse]
       '[noir.util.route :as route]
-      '[compojure.core :refer [defroutes GET POST]]
       '[ring.util.http-response :as response]
-      '[clojure.java.io :as io]
-      '[hugsql.core :as hugsql]
       (vector (symbol (str (:name (:attrs application)) ".layout")) :as 'l)
       (vector (symbol (str (:name (:attrs application)) ".db.core")) :as 'db)
       (vector (symbol (str (:name (:attrs application)) ".routes.manual")) :as 'm))))
@@ -77,12 +77,26 @@
                      'p)}
                   :list
                   {:records
+                   (list
+                     'if
+                     (list
+                       'not
+                       (list
+                         'empty?
+                         (list 'remove 'nil? (list 'vals 'p))))
                      (list
                        (symbol
                          (str
                            "db/search-strings-"
                            (singularise (:name (:attrs e)))))
-                     'p)})))))))
+                       (symbol "db/*db*")
+                       'p)
+                     (list
+                       (symbol
+                         (str
+                           "db/list-"
+                           (:name (:attrs e))))
+                       (symbol "db/*db*") {}))})))))))
 
 (defn make-route
   "Make a route for method `m` to request the resource with name `n`."

src/adl/to_selmer_templates.clj

@@ -422,7 +422,7 @@
   [list-spec entity application]
   {:tag :tbody
    :content
-   ["{% for record in %records% %}"
+   ["{% for record in records %}"
     {:tag :tr
      :content
      (apply
@@ -438,7 +438,6 @@
      :attrs
      {:href
       (str
-        "{{servlet-context}}/"
         (editor-name entity application)
         "?"
         (s/join
@@ -480,7 +479,7 @@
     (list-page-control true)]})
 
 
-(defn- list-to-template
+(defn list-to-template
   "Generate a template as specified by this `list` element for this `entity`,
   taken from this `application`. If `list` is nill, generate a default list
   template for the entity."
@@ -502,9 +501,9 @@
   `entity` in this `application`"
   [entity application]
   (let
-    [forms (children entity #(= (:tag %) :form))
+    [forms (children-with-tag entity :form)
-     pages (children entity #(= (:tag %) :page))
+     pages (children-with-tag entity :page)
-     lists (children entity #(= (:tag %) :list))]
+     lists (children-with-tag entity :list)]
     (if
       (and
         (= (:tag entity) :entity) ;; it seems to be an ADL entity

src/adl/utils.clj

@@ -39,6 +39,12 @@
   "resources/auto/")
 
 
+(defn element?
+  "True if `o` is a Clojure representation of an XML element."
+  [o]
+  (and (map? o) (:tag o) (:attrs o)))
+
+
 (defn wrap-lines
   "Wrap lines in this `text` to this `width`; return a list of lines."
   ;; Shamelessly adapted from https://www.rosettacode.org/wiki/Word_wrap#Clojure
@@ -73,6 +79,11 @@
      comment-rule)))
 
 
+(defn sort-by-name
+  [elements]
+  (sort #(compare (:name (:attrs %1)) (:name (:attrs %2))) elements))
+
+
 (defn link-table-name
   "Canonical name of a link table between entity `e1` and entity `e2`."
   [e1 e2]
@@ -249,24 +260,25 @@
 
 
 (defn safe-name
-  ([string]
+  "Return a safe name for the object `o`, given the specified `convention`.
-    (s/replace string #"[^a-zA-Z0-9-]" ""))
+  `o` is expected to be either a string or an entity."
-  ([string convention]
+  ([o]
+   (if
+     (element? o)
+     (safe-name (:name (:attrs o)))
+     (s/replace (str o) #"[^a-zA-Z0-9-]" "")))
+  ([o convention]
+   (if
+     (element? o)
+     (safe-name (:name (:attrs o)) convention)
+     (let [string (str o)]
        (case convention
          (:sql :c) (s/replace string #"[^a-zA-Z0-9_]" "_")
          :c-sharp (s/replace (capitalise string) #"[^a-zA-Z0-9]" "")
          :java (let
                  [camel (s/replace (capitalise string) #"[^a-zA-Z0-9]" "")]
-             (apply str (cons (Character/toUpperCase (first camel)) (rest camel))))
+                 (apply str (cons (Character/toLowerCase (first camel)) (rest camel))))
-     (safe-name string))))
+         (safe-name string))))))
-
-
-(defn link-table?
-  "Return true if this `entity` represents a link table."
-  [entity]
-  (let [properties (children entity #(= (:tag %) :property))
-        links (filter #(-> % :attrs :entity) properties)]
-    (= (count properties) (count links))))
 
 
 (defn read-adl [url]
@@ -351,6 +363,14 @@
   `(filter insertable? (key-properties entity)))
 
 
+(defn link-table?
+  "Return true if this `entity` represents a link table."
+  [entity]
+  (let [properties (all-properties entity)
+        links (filter #(-> % :attrs :entity) properties)]
+    (= (count properties) (count links))))
+
+
 (defn key-names [entity]
   (remove
     nil?
@@ -359,6 +379,37 @@
       (key-properties entity))))
 
 
+(defn base-type
+  [property application]
+  (cond
+    (:typedef (:attrs property))
+    (:type
+      (:attrs
+        (child
+          application
+          #(and
+             (= (:tag %) :typedef)
+             (= (:name (:attrs %)) (:typedef (:attrs property)))))))
+    (:entity (:attrs property))
+    (:type
+      (:attrs
+        (first
+          (key-properties
+            (child
+              application
+              #(and
+                 (= (:tag %) :entity)
+                 (= (:name (:attrs %)) (:entity (:attrs property)))))))))
+    true
+    (:type (:attrs property))))
+
+
+(defn is-quotable-type?
+  "True if the value for this field should be quoted."
+  [property application]
+  (#{"date" "image" "string" "text" "time" "timestamp" "uploadable"} (base-type property application)))
+
+
 (defn has-primary-key? [entity]
   (> (count (key-names entity)) 0))