(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)
(if-let [next (first pattern)]
(update-route-info*
(update-in route-info [:path] conj next)
(rest pattern))
route-info)
: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)))))