Merge branch 'feature/3' into develop

src/adl/to_hugsql_queries.clj

@@ -44,14 +44,16 @@
    (where-clause entity (key-properties entity)))
   ([entity properties]
    (let
-     [entity-name (:name (:attrs entity))
+     [entity-name (safe-name entity :sql)
       property-names (map #(:name (:attrs %)) properties)]
      (if-not (empty? property-names)
        (str
         "WHERE "
         (s/join
          "\n\tAND"
-         (map #(str entity-name "." % " = :" %) property-names)))))))
+         (map
+          #(str entity-name "." (safe-name % :sql) " = :" %)
+          property-names)))))))
 
 
 (defn order-by-clause
@@ -62,7 +64,7 @@
    (order-by-clause entity prefix false))
   ([entity prefix expanded?]
   (let
-    [entity-name (safe-name (:name (:attrs entity)) :sql)
+    [entity-name (safe-name entity :sql)
      preferred (filter #(#{"user" "all"} (-> % :attrs :distinct))
                          (children entity #(= (:tag %) :property)))]
     (if
@@ -89,10 +91,10 @@
   TODO: this depends on the idea that system-unique properties
   are not insertable, which is... dodgy."
   [entity]
-  (let [entity-name (safe-name (:name (:attrs entity)) :sql)
+  (let [entity-name (safe-name entity :sql)
         pretty-name (singularise entity-name)
         insertable-property-names (map
-                                    #(safe-name (:name (:attrs %)) :sql)
+                                    #(safe-name % :sql)
                                     (insertable-properties entity))
         query-name (str "create-" pretty-name "!")
         signature (if (has-primary-key? entity)
@@ -126,9 +128,11 @@
 (defn update-query
   "Generate an appropriate `update` query for this `entity`"
   [entity]
-    (let [entity-name (safe-name (:name (:attrs entity)) :sql)
+    (let [entity-name (safe-name entity :sql)
           pretty-name (singularise entity-name)
-          property-names (map #(:name (:attrs %)) (insertable-properties entity))
+          property-names (map
+                          #(-> % :attrs :name)
+                          (insertable-properties entity))
           query-name (str "update-" pretty-name "!")
           signature ":! :n"]
       (hash-map
@@ -142,18 +146,22 @@
               "-- :doc updates an existing " pretty-name " record\n"
               "UPDATE " entity-name "\n"
               "SET "
-              (s/join ",\n\t" (map #(str (safe-name % :sql) " = " (keyword %)) property-names))
+              (s/join
+               ",\n\t"
+               (map
+                #(str (safe-name % :sql) " = " (keyword %))
+                property-names))
               "\n"
               (where-clause entity))})))
 
 
 (defn search-query [entity application]
   "Generate an appropriate search query for string fields of this `entity`"
-  (let [entity-name (safe-name (:name (:attrs entity)) :sql)
+  (let [entity-name (safe-name entity :sql)
         pretty-name (singularise entity-name)
         query-name (str "search-strings-" entity-name)
         signature ":? :*"
-        properties (remove #(#{"link"}(:type (:attrs %))) (all-properties entity))]
+        properties (remove #(#{"(safe-name entity :sql)"}(:type (:attrs %))) (all-properties entity))]
     (hash-map
       (keyword query-name)
       {:name query-name
@@ -180,7 +188,7 @@
                    string?
                    (map
                      #(let
-                        [sn (safe-name (-> % :attrs :name) :sql)]
+                        [sn (safe-name % :sql)]
                         (str
                         "(if (:" (-> % :attrs :name) " params) (str \"AND "
                         (case (-> % :attrs :type)
@@ -214,7 +222,7 @@
   ([entity properties]
    (if-not
      (empty? properties)
-     (let [entity-name (safe-name (:name (:attrs entity)) :sql)
+     (let [entity-name (safe-name entity :sql)
            pretty-name (singularise entity-name)
            query-name (if (= properties (key-properties entity))
                         (str "get-" pretty-name)
@@ -254,7 +262,7 @@
   Parameters `:limit` and `:offset` may be supplied. If not present limit defaults
   to 100 and offset to 0."
   [entity]
-  (let [entity-name (safe-name (:name (:attrs entity)) :sql)
+  (let [entity-name (safe-name entity :sql)
         pretty-name (singularise entity-name)
         query-name (str "list-" entity-name)
         signature ":? :*"]
@@ -282,7 +290,8 @@
   [entity application]
   (let [entity-name (:name (:attrs entity))
         pretty-name (singularise entity-name)
-        links (filter #(#{"link" "entity"} (:type (:attrs %))) (children-with-tag entity :property))]
+        entity-safe (safe-name entity :sql)
+        links (filter #(#{"list" "link" "entity"} (:type (:attrs %))) (children-with-tag entity :property))]
     (apply
       merge
       (map
@@ -295,10 +304,11 @@
                                   (= (:tag x) :entity)
                                   (= (:name (:attrs x)) far-name)))))
                pretty-far (singularise far-name)
+               safe-far (safe-name far-entity :sql)
                farkey (-> % :attrs :farkey)
                link-type (-> % :attrs :type)
                link-field (-> % :attrs :name)
-               query-name (str "list-" entity-name "-by-" pretty-far)
+               query-name (list-related-query-name % entity far-entity)
                signature ":? :*"]
            (hash-map
              (keyword query-name)
@@ -315,23 +325,27 @@
                   (case link-type
                     "entity" (list
                                (str "-- :name " query-name " " signature)
-                               (str "-- :doc lists all existing " pretty-name " records related to a given " pretty-far)
+                               (str "-- :doc lists all existing " pretty-far " records related to a given " pretty-name)
-                               (str "SELECT lv_" entity-name ".* \nFROM lv_" entity-name ", " entity-name)
+                               (str "SELECT lv_" entity-safe ".* \nFROM lv_" entity-safe)
-                               (str "WHERE lv_" entity-name "." (first (key-names entity)) " = "
+                               (str "WHERE lv_" entity-safe "." (safe-name % :sql) " = :id")
-                                    entity-name "." (first (key-names entity))
-                                    "\n\tAND " entity-name "." link-field " = :id")
                                (order-by-clause entity "lv_" false))
                     "link" (let [link-table-name
                                  (link-table-name % entity far-entity)]
                              (list
                                (str "-- :name " query-name " " signature)
-                               (str "-- :doc links all existing " pretty-name " records related to a given " pretty-far)
+                               (str "-- :doc links all existing " pretty-far " records related to a given " pretty-name)
-                               (str "SELECT * \nFROM " entity-name ", " link-table-name)
+                               (str "SELECT lv_" safe-far ".* \nFROM lv_" safe-far ", " link-table-name)
-                               (str "WHERE " entity-name "."
+                               (str "WHERE lv_" safe-far "."
-                                    (first (key-names entity))
+                                    (safe-name (first (key-names far-entity)) :sql)
-                                    " = " link-table-name "." (singularise entity-name) "_id")
+                                    " = " link-table-name "." (singularise safe-far) "_id")
-                               (str "\tAND " link-table-name "." (singularise far-name) "_id = :id")
+                               (str "\tAND " link-table-name "." (singularise entity-safe) "_id = :id")
-                               (order-by-clause entity)))
+                               (order-by-clause far-entity "lv_" false)))
+                    "list" (list
+                               (str "-- :name " query-name " " signature)
+                               (str "-- :doc lists all existing " pretty-far " records related to a given " pretty-name)
+                               (str "SELECT lv_" safe-far ".* \nFROM lv_" safe-far)
+                               (str "WHERE lv_" safe-far "." (safe-name (first (key-names far-entity)) :sql) " = :id")
+                               (order-by-clause far-entity "lv_" false))
                     (list (str "ERROR: unexpected type " link-type " of property " %)))))
               }))
         links))))
@@ -341,7 +355,7 @@
   "Generate an appropriate `delete` query for this `entity`"
   (if
     (has-primary-key? entity)
-    (let [entity-name (:name (:attrs entity))
+    (let [entity-name (safe-name entity :sql)
           pretty-name (singularise entity-name)
           query-name (str "delete-" pretty-name "!")
           signature ":! :n"]

src/adl/to_psql.clj

@@ -466,6 +466,7 @@
              #(and
                 (entity? %)
                 (= (:name (:attrs %)) (:entity (:attrs property)))))
+        unique? (unique-link? e1 e2)
         link-table-name (link-table-name property e1 e2)]
     (if
       ;; we haven't already emitted this one...
@@ -485,6 +486,13 @@
                                     [(construct-link-property e1)
                                      (construct-link-property e2)]
                                     permissions)))}]
+        (if-not unique?
+          (*warn*
+           (str "WARNING: Manually check link tables between "
+                (-> e1 :attrs :name)
+                " and "
+                (-> e2 :attrs :name)
+                " for redundancy")))
         ;; mark it as emitted
         (swap! emitted-link-tables conj link-table-name)
         ;; emit it

src/adl/to_selmer_routes.clj

@@ -65,58 +65,146 @@
     (vector (symbol (str (:name (:attrs application)) ".routes.manual")) :as 'm))))
 
 
-(defn make-form-get-handler-content
+(defn compose-fetch-record
-  [f e a n]
+  [e]
-  (let [entity-name (singularise (:name (:attrs e)))]
+  (let
-    ;; TODO: as yet makes no attempt to save the record
+    [entity-name (singularise (:name (:attrs e)))
-    (list 'let
+     warning (str
-          (vector
+              "Error while fetching "
-           'record (list
+              entity-name
-                    'get-current-value
+              " record")]
-                    (symbol (str "db/get-" entity-name))
+    (list
-                    'params
+     'if
-                    entity-name))
+     (list
-          (reduce
+      'all-keys-present?
-           merge
+      'params (key-names e true))
-           {:error (list :warnings 'record)
+     (list
-            :record (list 'dissoc 'record :warnings)}
+      'support/do-or-log-error
-           (map
+      (list
-            (fn [property]
+       (query-name e :get)
+       (symbol "db/*db*")
+       'params)
+      :message warning
+      :error-return {:warnings [warning]}))))
+
+
+(defn compose-get-menu-options
+  [property application]
+  ;; TODO: doesn't handle the case of type="link"
+  (case (-> property :attrs :type)
+    "entity" (if-let [e (child-with-tag
+                        application
+                        :entity
+                        #(= (-> % :attrs :name)
+                            (-> property :attrs :entity)))]
               (hash-map
                (keyword (-> property :attrs :name))
                (list
-                'flatten
+                'get-menu-options
+                (singularise (-> e :attrs :name))
+                (query-name e :search-strings)
+                (query-name e :search-strings)
+                (keyword (-> property :attrs :farkey))
+                (list (keyword (-> property :attrs :name)) 'params)))
+              {})
+    "link" (list
+           'do
            (list
-                 'remove
+            'comment
-                 'nil?
+            "Can't yet handle link properties")
+           {})
+    "list" (list
+           'do
            (list
+            'comment
+            "Can't yet handle link properties")
+           {})
+    (list
+     'do
+     (list
+      'comment
+      (str "Unexpected type " (-> property :atts :type)))
+     {})))
+
+
+(defn compose-fetch-auxlist-data
+  [auxlist entity application]
+  (let [p-name (-> auxlist :attrs :property)
+        property (child-with-tag entity
+                                 :property
+                                 #(= (-> % :attrs :name) p-name))
+        f-name (-> property :attrs :entity)
+        farside (child-with-tag application
+                                :entity
+                                #(= (-> % :attrs :name) f-name))]
+    (if (and (entity? entity) (entity? farside))
+      (list 'if (list 'all-keys-present? 'params  (key-names entity true))
+            (hash-map
+             (keyword (auxlist-data-name auxlist))
+             (list
+              (symbol (str "db/" (list-related-query-name property entity farside)))
+              'db/*db*
+              {:id
+               (list
+                (case (-> property :attrs :type)
+                  "link" :id
+                  "list" (keyword (-> property :attrs :name)))
+                'params)})))
+      (do
+        (if-not
+          (entity? entity)
+          (*warn*
+           (str
+            "Entity '"
+            (-> entity :attrs :name)
+            "' passed to compose-fetch-auxlist-data is a non-entity")))
+        (if-not
+          (entity? farside)
+          (*warn*
+           (str
+            "Entity '"
+            f-name
+            "' (" farside ")
+            found in compose-fetch-auxlist-data is a non-entity")))
+        nil))))
+
+
+(defn make-form-get-handler-content
+  [f e a n]
+  (list
+   'let
+   (vector
+    'record (compose-fetch-record e))
+   (list
+    'reduce
+    'merge
+    {:error (list :warnings 'record)
+     :record (list 'dissoc 'record :warnings)}
+    (cons
      'list
-                  ;; Get the current value of the property, if it's an entity
+     (concat
-                  (if (= (-> property :attrs :type) "entity")
+      (map
-                    (list 'get-menu-options
+       #(compose-get-menu-options % a)
-                          (-> e :attrs :name)
-                          (-> property :attrs :farkey)
-                          (list (keyword (-> property :attrs :name)) 'params))))))))
        (filter #(:entity (:attrs %))
-                    (descendants-with-tag e :property)))))))
+               (descendants-with-tag e :property)))
+      (map
+       #(compose-fetch-auxlist-data % e a)
+       (descendants-with-tag f :auxlist))
+       (list
+         (list 'if (list :error 'request)
+               {:error (list :error 'request)})
+         (list 'if (list :message 'request)
+               {:message (list :message 'request)})))))))
 
 
 (defn make-page-get-handler-content
   [f e a n]
-  (let [warning (str "Error while fetching " (singularise (:name (:attrs e))) " record")]
-    (list 'let
-          (vector 'record (list
-                           'support/handler-content-log-error
-                           (list 'if (list 'subset? (list 'keys 'p) (key-names e)) []
   (list
-                                  (symbol
+   'let
-                                   (str "db/get-" (singularise (:name (:attrs e)))))
+   (vector
-                                  (symbol "db/*db*")
+    'record (compose-fetch-record e))
-                                  'params))
-                           :message warning
-                           :error-return {:warnings [warning]}))
    {:warnings (list :warnings 'record)
-           :record (list 'assoc 'record :warnings nil)})))
+    :record (list 'assoc 'record :warnings nil)}))
 
 
 (defn make-list-get-handler-content
@@ -130,9 +218,15 @@
      (list
       'some
       (set (map #(keyword (-> % :attrs :name)) (all-properties e)))
-      (list 'keys 'params))
+      (list
-     (list 'do
+       'keys 'params))
-           (list (symbol "log/debug") (list (symbol (str "db/search-strings-" (:name (:attrs e)) "-sqlvec")) 'params))
+     (list
+      'do
+      (list
+       (symbol "log/debug")
+       (list
+        (symbol
+         (str "db/search-strings-" (:name (:attrs e)) "-sqlvec")) 'params))
       (list
        'support/do-or-log-error
        (list
@@ -147,8 +241,11 @@
                                   "Error while searching "
                                   (singularise (:name (:attrs e)))
                                   " records")]}))
-     (list 'do
+     (list
-           (list (symbol "log/debug") (list (symbol (str "db/list-" (:name (:attrs e)) "-sqlvec")) 'params))
+      'do
+      (list
+       (symbol "log/debug")
+       (list (symbol (str "db/list-" (:name (:attrs e)) "-sqlvec")) 'params))
       (list
        'support/do-or-log-error
        (list
@@ -156,7 +253,7 @@
          (str
           "db/list-"
           (:name (:attrs e))))
-             (symbol "db/*db*") {})
+        (symbol "db/*db*") 'params)
        :message (str
                  "Error while fetching "
                  (singularise (:name (:attrs e)))
@@ -165,7 +262,8 @@
                                   "Error while fetching "
                                   (singularise (:name (:attrs e)))
                                   " records")]}))))
-   (list 'if
+   (list
+    'if
     (list :warnings 'records)
     'records
     {:records 'records})))
@@ -213,38 +311,44 @@
     (list
       'let
       (vector
+        'insert-params (list
+                         'prepare-insertion-params
+                         'params
+                         (set
+                           (map
+                             #(-> % :attrs :name)
+                             (insertable-properties e))))
         'result
         (list
           'valid-user-or-forbid
           (list
             'with-params-or-error
-        (list
-         'do-or-server-fail
             (list
               'if
               (list 'all-keys-present? 'params (key-names e true))
+              (list
+                'do-or-server-fail
                 (list
                   update-name
                   'db/*db*
-           'params)
+                  'insert-params)
+                200)
+              (list
+                'do-or-server-fail
                 (list
                   create-name
                   'db/*db*
-           'params))
+                  'insert-params)
-         200) ;; OK
+                201))
             'params
             (set
               (map
                 #(keyword (:name (:attrs %)))
-          (insertable-properties e))))
+                (required-properties e))))
           'request))
-     (list
-      'if
-      (list
-       (set [200 400])
-       (list :status 'result))
       (list
         (symbol (handler-name f e a :get))
+        (list 'merge
               (list
                 'assoc
                 'request
@@ -252,8 +356,11 @@
                 (list
                   'merge
                   'params
-        'result)))
+                  'result))
-      'result))))
+              (list 'case (:status 'result)
+                    200 {:message "Record stored"}
+                    201 (str "Record created: " (list :body 'result))
+                    {:error (list :body 'result)}))))))
 
 
 (defn make-post-handler

src/adl/to_selmer_templates.clj

@@ -3,6 +3,7 @@
       :author "Simon Brooke"}
   adl.to-selmer-templates
   (:require [adl-support.core :refer :all]
+            [adl-support.forms-support :refer :all]
             [adl.to-hugsql-queries :refer [expanded-token]]
             [adl-support.utils :refer :all]
             [clojure.java.io :refer [file make-parents resource]]
@@ -65,7 +66,6 @@
 
 (defn emit-content
   ([content]
-   (do-or-warn
      (cond
        (nil? content)
        nil
@@ -77,8 +77,7 @@
        (seq? content)
        (map emit-content (remove nil? content))
        true
-       (str "<!-- don't know what to do with '" content "' -->"))
+       (str "<!-- don't know what to do with '" content "' -->")))
-    (str "Failed while writing " content)))
   ([filename application k]
    (emit-content filename nil nil application k))
   ([filename spec entity application k]
@@ -374,6 +373,20 @@
                   "{% endif %}")))})
 
 
+(defn get-size-for-widget
+  "Return, as an integer, the fieldwidth for the input widget for this
+  `property`."
+  [property]
+  (let [s (try
+            (read-string
+             (:size (:attrs property)))
+            (catch Exception _ 16))]
+  (if
+   (not (integer? s))
+   16
+   s)))
+
+
 (defn compose-input-widget-para
   "Generate an input widget for this `field-or-property` of this `form` for
   this `entity` taken from within this `application`, in context of a para
@@ -390,17 +403,14 @@
                :name widget-name
                :type w-type
                :value (str "{{record." widget-name "}}")
-               :maxlength (:size (:attrs property))
+               :maxlength (str (max (get-size-for-widget property) 16))
-               :size (cond
+               :size (str (min (get-size-for-widget property) 60))}
-                      (nil? (:size (:attrs property)))
+              (case (-> property :attrs :type)
-                      "16"
+                "real"
-                      (try
+                {:step 0.000001} ;; this is a bit arbitrary!
-                        (> (read-string
+                "integer"
-                            (:size (:attrs property))) 60)
+                {:step 1}
-                        (catch Exception _ false))
+                nil)
-                      "60"
-                      true
-                      (:size (:attrs property)))}
               ;; TODO: should match pattern from typedef
               (if
                 (:minimum (:attrs typedef))
@@ -479,10 +489,12 @@
 
 
 (defn edit-link
-  [entity application parameters]
+  [source entity application parameters]
   (str
     "{{servlet-context}}/"
-    (editor-name entity application)
+    (or
+     (-> source :attrs :onselect)
+     (editor-name entity application))
     "?"
     (s/join
       "&amp;"
@@ -494,7 +506,7 @@
 
 (defn list-tbody
   "Return a table body element for the list view for this `list-spec` of
-  this `entity` within this `application`, using data from this source."
+  this `entity` within this `application`, using data from this `source`."
   [source list-spec entity application]
   {:tag :tbody
    :content
@@ -503,6 +515,8 @@
      :content
      (apply
       vector
+      (remove
+       nil?
        (concat
         (map
          (fn [field]
@@ -524,7 +538,11 @@
                 (= (:type (:attrs p)) "entity")
                 [{:tag :a
                   :attrs {:href (edit-link
-                                  e
+                                 source
+                                 (child-with-tag
+                                  application
+                                  :entity
+                                  #(= (-> % :attrs :name)(-> p :attrs :entity)))
                                  application
                                  (list (:name (:attrs p))))}
                   :content [(str "{{ record." s "_expanded }}")]}]
@@ -532,10 +550,14 @@
          (children-with-tag list-spec :field))
         [{:tag :td
           :content
-          [{:tag :a
+          [(if
+             (or (= (:tag list-spec) :list)
+                 (-> list-spec :attrs :onselect))
+             {:tag :a
               :attrs
-     {:href (edit-link entity application (key-names entity))}
+              {:href (edit-link source entity application (key-names entity))}
-     :content ["View"]}]}]))}
+              :content ["View"]}
+             "&nbsp;")]}])))}
     "{% endfor %}"]})
 
 
@@ -558,7 +580,20 @@
       {:tag :div
        :attrs {:class "auxlist"}
        :content
-       [{:tag :h2
+       (apply
+         vector
+         (remove
+           nil?
+           (flatten
+             (list
+               ;; only show auxlists if we've got keys
+               (str "{% if all "
+                    (s/join " " (map #(str "params." %) (key-names entity)))
+                    " %}")
+               ;; only show the body of auxlists if the list is non-empty
+               (str "{% if " (auxlist-data-name auxlist) "|not-empty %}")
+
+               {:tag :h2
                 :content [(prompt auxlist form entity application)]}
                {:tag :table
                 :content
@@ -568,6 +603,8 @@
                     :content
                     (apply
                       vector
+                      (remove
+                        nil?
                         (flatten
                           (list
                             (map
@@ -575,12 +612,25 @@
                                  :tag :th
                                  :content [(prompt % form entity application)])
                               (children-with-tag auxlist :field))
-                   {:tag :th :content ["&nbsp;"]})))}]}
+                            {:tag :th :content ["&nbsp;"]}))))}]}
                  (list-tbody
-           (-> property :attrs :name)
+                   (auxlist-data-name auxlist)
                    auxlist
                    farside
-           application)]}]})))
+                   application)]}
+               "{% endif %}"
+               (if
+                 (= (-> auxlist :attrs :canadd) "true")
+                 (wrap-in-if-member-of
+                   (big-link (str
+                               "Add a new "
+                               (pretty-name property))
+                             (editor-name farside application))
+                   :writeable
+                   farside
+                   application)
+                 )
+               "{% endif %}"))))})))
 
 
 (defn compose-form-auxlists
@@ -1030,11 +1080,12 @@
          (if
            (pos? *verbosity*)
            (*warn* "\tGenerated " filepath))
-         (str filepath))))))
+         (str filepath))
+       (str "While generating " filepath)))))
 
 
 ;; (def a (x/parse "../youyesyet/youyesyet.canonical.adl.xml"))
-;; (def e (child-with-tag a :entity))
+;; (def e (child-with-tag a :entity #(= (-> % :attrs :name) "teams")))
 ;; (def f (child-with-tag e :form))
 ;; (write-template-file "froboz" (form-to-template f e a) a)
 ;; (def t (form-to-template f e a))