diff --git a/resources/schemas/adl-1.4.1.dtd b/resources/schemas/adl-1.4.1.dtd index 3f02697..53a9402 100644 --- a/resources/schemas/adl-1.4.1.dtd +++ b/resources/schemas/adl-1.4.1.dtd @@ -246,7 +246,7 @@ that we can allow HTML block level entities within content elements --> an entity which has properties and relationships; maps onto a database table or a Java serialisable class - or, of course, various other things - name: obviously, the name of this entity + name: obviously, the name of this entity. natural-key: if present, the name of a property of this entity which forms a natural primary key [NOTE: Only partly implemented. NOTE: much of the present implementation assumes all primary keys will be @@ -254,21 +254,27 @@ that we can allow HTML block level entities within content elements --> 'key' element, below. table: the name of the table in which this entity is stored. Defaults to same as name of entity. Strongly recommend this is not used unless it needs - to be different from the name of the entity + to be different from the name of the entity. foreign: this entity is part of some other system; no code will be generated - for it, although code which links to it will be generated + for it, although code which links to it will be generated. magnitude: The power of ten which approximates the expected number of records; thus if ten records are expected, the magnitude is 1; if a million, the - magnitude is 6 + magnitude is 6. + volatility: Number representing the anticipated rate of change of records in this + entity; if 0, results should never be cached; otherwise, a power of + 10 representing the number of seconds the data may safely be cached. + thus 5 represents a cach time to live of 100,000 seconds, or slightly + more than one day. --> + table CDATA #IMPLIED + foreign %Boolean; #IMPLIED + magnitude CDATA #IMPLIED + volatility CDATA #IMPLIED> - - - entity already has a key - not generating one - - + + + entity already has a key - not generating one + + 6 + + 0 + - - - + + + diff --git a/src/adl/to_hugsql_queries.clj b/src/adl/to_hugsql_queries.clj index 673023d..6011417 100644 --- a/src/adl/to_hugsql_queries.clj +++ b/src/adl/to_hugsql_queries.clj @@ -321,80 +321,6 @@ })) links)))) -(defn link-table-query - "Generate a query which links across the entity passed as `link` - from the entity passed as `near` to the entity passed as `far`. - TODO: not working?" - [near link far] - (if - (and - (entity? near) - (entity? link) - (entity? far)) - (let [properties (-> link :content :properties vals) - links (apply - merge - (map - #(hash-map (keyword (-> % :attrs :entity)) %) - (filter #(-> % :attrs :entity) properties))) - near-name (-> near :attrs :name) - link-name (-> link :attrs :name) - far-name (-> far :attrs :name) - pretty-far (singularise far-name) - query-name (str "list-" link-name "-" near-name "-by-" pretty-far) - signature ":? :*"] - (hash-map - (keyword query-name) - {:name query-name - :signature signature - :entity link - :type :select-many-to-many - :near-entity near - :far-entity far - :query - (s/join - "\n" - (remove - empty? - (list - (str "-- :name " query-name " " signature) - (str "-- :doc lists all existing " near-name " records related through " link-name " to a given " pretty-far ) - (str "SELECT DISTINCT "near-name ".*") - (str "FROM " near-name ", " link-name ) - (str "WHERE " near-name "." (first (key-names near)) " = " link-name "." (singularise near-name) "_id" ) - ("\tAND " link-name "." (singularise far-name) "_id = :id") - (order-by-clause near))))})))) - - -(defn link-table-queries [entity application] - "Generate all the link queries in this `application` which link via this `entity`." - (let - [entities (map - ;; find the far-side entities - (fn - [far-name] - (children - application - (fn [x] - (and - (= (:tag x) :entity) - (= (:name (:attrs x)) far-name))))) - ;; of those properties of this `entity` which are of type `entity` - (remove - nil? - (map - #(-> % :attrs :entity) - (children entity #(= (:tag %) :property))))) - pairs (combinations entities 2)] - (apply - merge - (map - #(merge - (link-table-query (nth % 0) entity (nth % 1)) - (link-table-query (nth % 1) entity (nth % 0))) - pairs)))) - - (defn delete-query [entity] "Generate an appropriate `delete` query for this `entity`" diff --git a/src/adl/to_json_routes.clj b/src/adl/to_json_routes.clj index 5464313..7b192ed 100644 --- a/src/adl/to_json_routes.clj +++ b/src/adl/to_json_routes.clj @@ -48,6 +48,7 @@ :require '[adl-support.core :as support] '[clojure.java.io :as io] + '[clojure.core.memoize :as memo] '[compojure.core :refer [defroutes GET POST]] '[hugsql.core :as hugsql] '[noir.response :as nresponse] @@ -60,24 +61,45 @@ (cons 'declare (sort (map #(symbol (name %)) (keys handlers-map))))) +(defn generate-handler-body + "Generate and return the function body for the handler for this `query`." + [query] + (list + [{:keys ['params]}] + (list 'do (list (symbol (str "db/" (:name query))) 'params)) + (case + (:type query) + (:delete-1 :update-1) + '(response/found "/") + nil))) + + (defn generate-handler-src + "Generate and return the handler for this `query`." [handler-name query-map method doc] (hash-map :method method - :src - (remove - nil? - (list - 'defn - handler-name - (str "Auto-generated method to " doc) - [{:keys ['params]}] - (list 'do (list (symbol (str "db/" (:name query-map))) 'params)) - (case - (:type query-map) - (:delete-1 :update-1) - '(response/found "/") - nil))))) + :src (remove + nil? + (if + (or + (zero? (volatility (:entity query-map))) + (#{:delete-1 :insert-1 :update-1} (:type query-map))) + (concat + (list + 'defn + handler-name + (str "Auto-generated method to " doc)) + (generate-handler-body query-map)) + (concat + (list + 'def + handler-name + (list + 'memo/ttl + (cons 'fn (generate-handler-body query-map)) + :ttl/threshold + (* (volatility (:entity query-map)) 1000)))))))) (defn handler @@ -100,7 +122,7 @@ (str "delete one record from the `" (-> query :entity :attrs :name) "` table. Expects the following key(s) to be present in `params`: `" - (doall (-> query :entity :content :key :content keys)) + (-> query :entity key-names) "`.")) :insert-1 (generate-handler-src @@ -108,9 +130,12 @@ (str "insert one record to the `" (-> query :entity :attrs :name) "` table. Expects the following key(s) to be present in `params`: `" - (pr-str (-> query :entity :content :properties keys)) + (pr-str + (map + #(keyword (:name (:attrs %))) + (-> query :entity insertable-properties ))) "`. Returns a map containing the keys `" - (pr-str (-> query :entity :content :key :content keys)) + (-> query :entity key-names) "` identifying the record created.")) :update-1 (generate-handler-src @@ -121,10 +146,12 @@ (pr-str (distinct (sort - (flatten - (cons - (-> query :entity :content :properties keys) - (-> query :entity :content :key :content keys)))))) + (map + #(keyword (:name (:attrs %))) + (flatten + (cons + (-> query :entity key-properties) + (-> query :entity insertable-properties))))))) "`.")) :select-1 (generate-handler-src @@ -132,15 +159,9 @@ (str "select one record from the `" (-> query :entity :attrs :name) "` table. Expects the following key(s) to be present in `params`: `" - (pr-str (-> query :entity :content :key :content keys)) + (-> query :entity key-names) "`. Returns a map containing the following keys: `" - (pr-str - (distinct - (sort - (flatten - (cons - (-> query :entity :content :properties keys) - (-> query :entity :content :key :content keys)))))) + (map #(keyword (:name (:attrs %))) (-> query :entity all-properties)) "`.")) :select-many (generate-handler-src @@ -149,26 +170,21 @@ (-> query :entity :attrs :name) "` table. If the keys `(:limit :offset)` are present in the request then they will be used to page through the data. Returns a sequence of maps each containing the following keys: `" (pr-str - (distinct - (sort - (flatten - (cons - (-> query :entity :content :properties keys) - (-> query :entity :content :key :content keys)))))) + (map + #(keyword (:name (:attrs %))) + (-> query :entity all-properties))) "`.")) :text-search (generate-handler-src handler-name query :get (str "select all records from the `" (-> query :entity :attrs :name) + ;; TODO: this doc-string is out of date "` table with any text field matching the value of the key `:pattern` which should be in the request. If the keys `(:limit :offset)` are present in the request then they will be used to page through the data. Returns a sequence of maps each containing the following keys: `" (pr-str - (distinct - (sort - (flatten - (cons - (-> query :entity :content :properties keys) - (-> query :entity :content :key :content keys)))))) + (map + #(keyword (:name (:attrs %))) + (-> query :entity all-properties))) "`.")) (:select-many-to-many :select-one-to-many) @@ -226,22 +242,16 @@ (try (with-open [output (writer filepath)] (binding [*out* output] - (doall - (map - (fn [f] - (pprint f) - (println "\n")) - (list - (file-header application) - (declarations handlers-map) - (defroutes handlers-map)))) + (pprint (file-header application)) + (println) (doall (map (fn [h] (pprint (:src (handlers-map h))) (println) h) - (sort (keys handlers-map)))))) + (sort (keys handlers-map)))) + (pprint (defroutes handlers-map)))) (if (> *verbosity* 0) (println (str "\tGenerated " filepath))) (catch diff --git a/src/adl/to_selmer_routes.clj b/src/adl/to_selmer_routes.clj index 645a640..ea6f7ed 100644 --- a/src/adl/to_selmer_routes.clj +++ b/src/adl/to_selmer_routes.clj @@ -198,6 +198,7 @@ (l/render (support/resolve-template "application-index.html") + (:session r) {:title "Administrative menu"}))) (println) (doall