Codebase list comidi-clojure / bbe90d4b-61e1-4579-b4b6-360b6eadfdb7/main src / puppetlabs / comidi.clj
bbe90d4b-61e1-4579-b4b6-360b6eadfdb7/main

Tree @bbe90d4b-61e1-4579-b4b6-360b6eadfdb7/main (Download .tar.gz)

comidi.clj @bbe90d4b-61e1-4579-b4b6-360b6eadfdb7/mainraw · history · blame

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
(ns puppetlabs.comidi
  (:require [bidi.ring :as bidi-ring]
            [bidi.schema :as bidi-schema]
            [bidi.bidi :as bidi]
            [clojure.zip :as zip]
            [compojure.core :as compojure]
            [compojure.response :as compojure-response]
            [ring.util.mime-type :as mime]
            [ring.util.response :as ring-response]
            [schema.core :as schema]
            [puppetlabs.kitchensink.core :as ks]
            [clojure.string :as str])
  (:import (java.util.regex Pattern)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Schemas

(defn pattern?
  [x]
  (instance? Pattern x))

(def Zipper
  (schema/pred ks/zipper?))

(def RequestMethod
  (schema/enum :any :get :post :put :delete :head :options))

; Derived from bidi-schema PatternSegment
(def RegexPatternSegment
  (schema/pair schema/Regex "qual" schema/Keyword "id"))

(def RouteInfo
  {:path           [bidi-schema/PatternSegment]
   :request-method RequestMethod})

(def RouteInfoWithId
  (merge RouteInfo
         {:route-id schema/Str}))

(def Handler
  (schema/conditional
    keyword? schema/Keyword
    fn? (schema/pred fn?)
    map? {RequestMethod (schema/recursive #'Handler)}))

(def RouteMetadata
  {:routes [RouteInfoWithId]
   :handlers {Handler RouteInfoWithId}})

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Private - route id computation

(defn slashes->dashes
  "Convert all forward slashes to hyphens"
  [s]
  (str/replace s #"\/" "-"))

(defn remove-leading-and-trailing-dashes
  [s]
  (-> s
      (str/replace #"^-" "")
      (str/replace #"-$" "")))

(defn special-chars->underscores
  "Convert all non-alpha chars except ! * and - to underscores"
  [s]
  (str/replace s #"[^\w\!\*\-]" "_"))

(defn collapse-consecutive-underscores
  [s]
  (str/replace s #"_+" "_"))

(defn remove-leading-and-trailing-underscores
  [s]
  (-> s
      (str/replace #"^_" "")
      (str/replace #"_$" "")))

(defn add-regex-symbols
  "Wrap a regex pattern with forward slashes to make it easier to recognize as a regex"
  [s]
  (str "/" s "/"))

(schema/defn ^:always-validate
  path-element->route-id-element :- schema/Str
  "Given a String path element from comidi route metadata, convert it into a string
  suitable for use in building a route id string."
  [path-element :- schema/Str]
  (-> path-element
      slashes->dashes
      remove-leading-and-trailing-dashes
      special-chars->underscores
      collapse-consecutive-underscores
      remove-leading-and-trailing-underscores))

(schema/defn ^:always-validate
  regex-path-element->route-id-element :- schema/Str
  "Given a Regex path element from comidi route metadata, convert it into a string
  suitable for use in building a route id string."
  [path-element :- RegexPatternSegment]
  (-> path-element
      first
      str
      path-element->route-id-element
      add-regex-symbols))

(schema/defn ^:always-validate
  route-path-element->route-id-element :- schema/Str
  "Given a route path element from comidi route metadata, convert it into a string
  suitable for use in building a route id string.  This function is mostly
  responsible for determining the type of the path element and dispatching to
  the appropriate function."
  [path-element]
  (cond
    (string? path-element)
    (path-element->route-id-element path-element)

    (keyword? path-element)
    (pr-str path-element)

    (nil? (schema/check RegexPatternSegment path-element))
    (regex-path-element->route-id-element path-element)

    :else
    (throw (IllegalStateException. (str "Unrecognized path element: " path-element)))))

(schema/defn ^:always-validate
  route-path->route-id :- schema/Str
  "Given a route path (from comidi route-metadata), build a route-id string for
  the route.  This route-id can be used as a unique identifier for a route."
  [route-path :- [bidi-schema/PatternSegment]]
  (->> route-path
       (map route-path-element->route-id-element)
       (filter #(not (empty? %)))
       (str/join "-")))

(schema/defn ^:always-validate
  add-route-name :- RouteInfoWithId
  "Given a RouteInfo, compute a route-id and return a RouteInfoWithId."
  [route-info :- RouteInfo]
  (assoc route-info :route-id (route-path->route-id (:path route-info))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Private - route metadata computation

(def http-methods
  #{:any :get :post :put :delete :head :options})

(schema/defn ^:always-validate
  update-route-info* :- RouteInfo
  "Helper function, used to maintain a RouteInfo data structure that represents
  the current path elements of a route as we traverse the Bidi route tree via
  zipper."
  [route-info :- RouteInfo
   pattern :- bidi-schema/Pattern]
  (cond
    (contains? http-methods pattern)
    (assoc-in route-info [:request-method] pattern)

    (nil? (schema/check RegexPatternSegment pattern))
    (update-in route-info [:path] concat [pattern])

    (= true pattern)
    (update-in route-info [:path] conj "*")

    (= false pattern)
    (update-in route-info [:path] conj "!")

    (sequential? pattern)
    (update-in route-info [:path] into pattern)

    :else
    (update-in route-info [:path] conj pattern)))

(declare breadth-route-metadata*)

(schema/defn ^:always-validate
  depth-route-metadata* :- RouteMetadata
  "Helper function used to traverse branches of the Bidi route tree, depth-first."
  [route-meta :- RouteMetadata
   route-info :- RouteInfo
   loc :- Zipper]
  (let [[pattern matched] (zip/node loc)]
    (cond
      (map? matched)
      (depth-route-metadata*
        route-meta
        route-info
        (-> loc zip/down zip/right (zip/edit #(into [] %)) zip/up))

      (vector? matched)
      (breadth-route-metadata*
        route-meta
        (update-route-info* route-info pattern)
        (-> loc zip/down zip/right zip/down))

      :else
      (let [route-info (-> (update-route-info* route-info pattern)
                           add-route-name)]
        (-> route-meta
            (update-in [:routes] conj route-info)
            (assoc-in [:handlers matched] route-info))))))

(schema/defn ^:always-validate
  breadth-route-metadata* :- RouteMetadata
  "Helper function used to traverse branches of the Bidi route tree, breadth-first."
  [route-meta :- RouteMetadata
   route-info :- RouteInfo
   loc :- Zipper]
  (loop [route-meta route-meta
         loc    loc]
    (let [routes (depth-route-metadata* route-meta route-info loc)]
      (if-let [next (zip/right loc)]
        (recur routes next)
        routes))))

(schema/defn ^:always-validate
  route-metadata* :- RouteMetadata
  "Traverses a Bidi route tree and returns route metadata, which includes a list
  of RouteInfo objects (one per route), plus a mechanism to look up the
  RouteInfo for a given handler."
  [routes :- bidi-schema/RoutePair]
  (let [route-info {:path           []
                    :request-method :any}
        loc (-> [routes] zip/vector-zip zip/down)]
    (breadth-route-metadata* {:routes   []
                              :handlers {}} route-info loc)))

(def memoized-route-metadata*
  (memoize route-metadata*))

(defn make-handler
  "Create a Ring handler from the route definition data
  structure. Matches a handler from the uri in the request, and invokes
  it with the request as a parameter. (This code is largely copied from the
  bidi upstream, but we add support for inserting the match-context via
  middleware.)"
  [route]
  (fn [{:keys [uri path-info] :as req}]
    (let [path (or path-info uri)
          {:keys [handler route-params] :as match-context}
          (or (:match-context req)
              (apply bidi/match-route route path (apply concat (seq req))))]
      (when handler
        (bidi-ring/request
         handler
         (-> req
             (update-in [:params] merge route-params)
             (update-in [:route-params] merge route-params))
         (apply dissoc match-context :handler (keys req)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Private - helpers for compojure-like syntax

(defn- add-mime-type [response path options]
  (if-let [mime-type (mime/ext-mime-type path (:mime-types options {}))]
    (ring-response/content-type response mime-type)
    response))

(defmacro handler-fn*
  "Helper macro, used by the compojure-like macros (GET/POST/etc.) to generate
  a function that provides compojure's destructuring and rendering support."
  [bindings body]
  `(fn [request#]
     (compojure-response/render
       (compojure/let-request [~bindings request#] ~@body)
       request#)))

(defn route-with-method*
  "Helper function, used by the compojure-like macros (GET/POST/etc.) to generate
  a bidi route that includes a wrapped handler function."
  [method pattern bindings body]
  `[~pattern {~method (handler-fn* ~bindings ~body)}])

(defn route-tree-zip
  "Returns a zipper for a bidi route tree i.e. for an arbitrarily nested structure of
  `bidi.schema/RoutePair`s"
  [root]
  (zip/zipper
    (fn [[_ matched]]
      (or (vector? matched) (map? matched)))

    (fn [[_ matched]]
      (seq matched))

    (fn [[pattern matched :as node] children]
      (with-meta
        [pattern (into (if (vector? matched) [] {}) children)]
        (meta node)))

    root))

(defn wrap-routes*
  "Help function, used by compojure-like wrap-routes function to wrap leaf handlers
  in the bidi route with the middleware"
  [loc middleware]
  (if (zip/end? loc)
    loc
    (let [loc (if (zip/branch? loc)                         ; we only want modify the leaf nodes
                loc
                (let [[pattern matched] (zip/node loc)]
                  (if (fn? matched)
                    (zip/replace loc [pattern (middleware matched)])
                    loc)))]
      (recur (zip/next loc) middleware))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Public - core functions

(schema/defn ^:always-validate
  route-metadata :- RouteMetadata
  "Build up a map of metadata describing the routes.  This metadata map can be
  used for introspecting the routes after building the handler, and can also
  be used with the `wrap-with-route-metadata` middleware."
  [routes :- bidi-schema/RoutePair]
  (memoized-route-metadata* routes))

(schema/defn ^:always-validate
  wrap-with-route-metadata :- (schema/pred fn?)
  "Ring middleware; adds the comidi route-metadata to the request map, as well
  as a :route-info key that can be used to determine which route a given request
  matches."
  [app :- (schema/pred fn?)
   routes :- bidi-schema/RoutePair]
  (let [compiled-routes (bidi/compile-route routes)
        route-meta      (route-metadata routes)]
    (fn [{:keys [uri path-info] :as req}]
      (let [path (or path-info uri)
            {:keys [handler] :as match-context}
            (apply bidi/match-route compiled-routes path (apply concat (seq req)))
            route-info (get-in route-meta [:handlers handler])]
        (app (assoc req
               :route-metadata route-meta
               :route-info route-info
               :match-context match-context))))))

(schema/defn ^:always-validate
  wrap-routes :- bidi-schema/RoutePair
  "Wraps middleware around the handlers at every leaf in the route in a manner
  analagous to compojure's wrap-routes function"
  [routes :- bidi-schema/RoutePair
   middleware :- (schema/pred fn?)]
  (-> routes
      route-tree-zip
      (wrap-routes* middleware)
      zip/root))

(schema/defn ^:always-validate
  routes :- bidi-schema/RoutePair
  "Combines multiple bidi routes into a single data structure; this is largely
  just a convenience function for grouping several routes together as a single
  object that can be passed around."
  [& routes :- [bidi-schema/RoutePair]]
  ["" (vec routes)])

(schema/defn ^:always-validate
  context :- bidi-schema/RoutePair
  "Combines multiple bidi routes together into a single data structure, but nests
  them all under the given url-prefix.  This is similar to compojure's `context`
  macro, but does not accept a binding form.  You can still destructure variables
  by passing a bidi pattern for `url-prefix`, and the variables will be available
  to all nested routes."
  [url-prefix :- bidi-schema/Pattern
   & routes :- [bidi-schema/RoutePair]]
  [url-prefix (vec routes)])

(schema/defn ^:always-validate
  routes->handler :- (schema/pred fn?)
  "Given a bidi route tree, converts into a ring request handler function"
  [routes :- bidi-schema/RoutePair]
   (let [compiled-routes (bidi/compile-route routes)]
     (make-handler compiled-routes)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Public - compojure-like convenience macros

(defmacro ANY
  [pattern bindings & body]
  `[~pattern (handler-fn* ~bindings ~body)])

(defmacro GET
  [pattern bindings & body]
  (route-with-method* :get pattern bindings body))

(defmacro HEAD
  [pattern bindings & body]
  (route-with-method* :head pattern bindings body))

(defmacro PUT
  [pattern bindings & body]
  (route-with-method* :put pattern bindings body))

(defmacro POST
  [pattern bindings & body]
  (route-with-method* :post pattern bindings body))

(defmacro DELETE
  [pattern bindings & body]
  (route-with-method* :delete pattern bindings body))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Public - pre-built routes

(defn not-found
  [body]
  [[[#".*" :rest]] (fn [request]
                     (-> (compojure-response/render body request)
                         (ring-response/status 404)))])

(defn resources
  "A route for serving resources on the classpath. Accepts the following
  keys:
    :root       - the root prefix path of the resources, defaults to 'public'
    :mime-types - an optional map of file extensions to mime types"
  [path & [options]]
  (GET [path [#".*" :resource-path]] [resource-path]
    (let [root (:root options "public")]
      (some-> (ring-response/resource-response (str root "/" resource-path))
        (add-mime-type resource-path options)))))