initial commit
This commit is contained in:
Executable
+403
@@ -0,0 +1,403 @@
|
||||
(ns secretary.core
|
||||
(:require [clojure.string :as string]
|
||||
[clojure.walk :refer [keywordize-keys]])
|
||||
(:require-macros [secretary.core :refer [defroute]]))
|
||||
|
||||
;;----------------------------------------------------------------------
|
||||
;; Protocols
|
||||
|
||||
(defprotocol IRouteMatches
|
||||
(route-matches [this route]))
|
||||
|
||||
(defprotocol IRouteValue
|
||||
(route-value [this]))
|
||||
|
||||
(defprotocol IRenderRoute
|
||||
(render-route
|
||||
[this]
|
||||
[this params]))
|
||||
|
||||
;;----------------------------------------------------------------------
|
||||
;; Configuration
|
||||
|
||||
(def ^:dynamic *config*
|
||||
(atom {:prefix ""}))
|
||||
|
||||
(defn get-config
|
||||
"Gets a value for *config* at path."
|
||||
[path]
|
||||
(let [path (if (sequential? path) path [path])]
|
||||
(get-in @*config* path)))
|
||||
|
||||
(defn set-config!
|
||||
"Associates a value val for *config* at path."
|
||||
[path val]
|
||||
(let [path (if (sequential? path) path [path])]
|
||||
(swap! *config* assoc-in path val)))
|
||||
|
||||
;;----------------------------------------------------------------------
|
||||
;; Parameter encoding
|
||||
|
||||
(def encode js/encodeURIComponent)
|
||||
|
||||
(defmulti
|
||||
^{:private true
|
||||
:doc "Given a key and a value return and encoded key-value pair."}
|
||||
encode-pair
|
||||
(fn [[k v]]
|
||||
(cond
|
||||
(or (sequential? v) (set? v))
|
||||
::sequential
|
||||
(or (map? v) (satisfies? IRecord v))
|
||||
::map)))
|
||||
|
||||
(defn- key-index
|
||||
([k] (str (name k) "[]"))
|
||||
([k index]
|
||||
(str (name k) "[" index "]")))
|
||||
|
||||
(defmethod encode-pair ::sequential [[k v]]
|
||||
(let [encoded (map-indexed
|
||||
(fn [i x]
|
||||
(let [pair (if (coll? x)
|
||||
[(key-index k i) x]
|
||||
[(key-index k) x])]
|
||||
(encode-pair pair)))
|
||||
v)]
|
||||
(string/join \& encoded)))
|
||||
|
||||
(defmethod encode-pair ::map [[k v]]
|
||||
(let [encoded (map
|
||||
(fn [[ik iv]]
|
||||
(encode-pair [(key-index k (name ik)) iv]))
|
||||
v)]
|
||||
(string/join \& encoded)))
|
||||
|
||||
(defmethod encode-pair :default [[k v]]
|
||||
(str (name k) \= (encode (str v))))
|
||||
|
||||
(defn encode-query-params
|
||||
"Convert a map of query parameters into url encoded string."
|
||||
[query-params]
|
||||
(string/join \& (map encode-pair query-params)))
|
||||
|
||||
(defn encode-uri
|
||||
"Like js/encodeURIComponent excepts ignore slashes."
|
||||
[uri]
|
||||
(->> (string/split uri #"/")
|
||||
(map encode)
|
||||
(string/join "/")))
|
||||
|
||||
;;----------------------------------------------------------------------
|
||||
;; Parameter decoding
|
||||
|
||||
(def decode js/decodeURIComponent)
|
||||
|
||||
(defn- parse-path
|
||||
"Parse a value from a serialized query-string key index. If the
|
||||
index value is empty 0 is returned, if it's a digit it returns the
|
||||
js/parseInt value, otherwise it returns the extracted index."
|
||||
[path]
|
||||
(let [index-re #"\[([^\]]*)\]*" ;; Capture the index value.
|
||||
parts (re-seq index-re path)]
|
||||
(map
|
||||
(fn [[_ part]]
|
||||
(cond
|
||||
(empty? part) 0
|
||||
(re-matches #"\d+" part) (js/parseInt part)
|
||||
:else part))
|
||||
parts)))
|
||||
|
||||
(defn- key-parse
|
||||
"Return a key path for a serialized query-string entry.
|
||||
|
||||
Ex.
|
||||
|
||||
(key-parse \"foo[][a][][b]\")
|
||||
;; => (\"foo\" 0 \"a\" 0 \"b\")
|
||||
"
|
||||
[k]
|
||||
(let [re #"([^\[\]]+)((?:\[[^\]]*\])*)?"
|
||||
[_ key path] (re-matches re k)
|
||||
parsed-path (when path (parse-path path))]
|
||||
(cons key parsed-path)))
|
||||
|
||||
(defn- assoc-in-query-params
|
||||
"Like assoc-in but numbers in path create vectors instead of maps.
|
||||
|
||||
Ex.
|
||||
|
||||
(assoc-in-query-params {} [\"foo\" 0] 1)
|
||||
;; => {\"foo\" [1]}
|
||||
|
||||
(assoc-in-query-params {} [\"foo\" 0 \"a\"] 1)
|
||||
;; => {\"foo\" [{\"a\" 1}]}
|
||||
"
|
||||
[m path v]
|
||||
(let [heads (fn [xs]
|
||||
(map-indexed
|
||||
(fn [i _]
|
||||
(take (inc i) xs))
|
||||
xs))
|
||||
hs (heads path)
|
||||
m (reduce
|
||||
(fn [m h]
|
||||
(if (and (or (number? (last h)))
|
||||
(not (vector? (get-in m (butlast h)))))
|
||||
(assoc-in m (butlast h) [])
|
||||
m))
|
||||
m
|
||||
hs)]
|
||||
(if (zero? (last path))
|
||||
(update-in m (butlast path) conj v)
|
||||
(assoc-in m path v))))
|
||||
|
||||
(defn decode-query-params
|
||||
"Extract a map of query parameters from a query string."
|
||||
[query-string]
|
||||
(let [parts (string/split query-string #"&")
|
||||
params (reduce
|
||||
(fn [m part]
|
||||
;; We only want two parts since the part on the right hand side
|
||||
;; could potentially contain an =.
|
||||
(let [[k v] (string/split part #"=" 2)]
|
||||
(assoc-in-query-params m (key-parse (decode k)) (decode v))))
|
||||
{}
|
||||
parts)
|
||||
params (keywordize-keys params)]
|
||||
params))
|
||||
|
||||
;;----------------------------------------------------------------------
|
||||
;; Route compilation
|
||||
|
||||
;; The implementation for route compilation was inspired by Clout and
|
||||
;; modified to suit JavaScript and Secretary.
|
||||
;; SEE: https://github.com/weavejester/clout
|
||||
|
||||
(defn- re-matches*
|
||||
"Like re-matches but result is a always vector. If re does not
|
||||
capture matches then it will return a vector of [m m] as if it had a
|
||||
single capture. Other wise it maintains consistent behavior with
|
||||
re-matches. "
|
||||
[re s]
|
||||
(let [ms (clojure.core/re-matches re s)]
|
||||
(when ms
|
||||
(if (sequential? ms) ms [ms ms]))))
|
||||
|
||||
(def ^:private re-escape-chars
|
||||
(set "\\.*+|?()[]{}$^"))
|
||||
|
||||
(defn- re-escape [s]
|
||||
(reduce
|
||||
(fn [s c]
|
||||
(if (re-escape-chars c)
|
||||
(str s \\ c)
|
||||
(str s c)))
|
||||
""
|
||||
s))
|
||||
|
||||
(defn- lex*
|
||||
"Attempt to lex a single token from s with clauses. Each clause is a
|
||||
pair of [regexp action] where action is a function. regexp is
|
||||
expected to begin with ^ and contain a single capture. If the
|
||||
attempt is successful a vector of [s-without-token (action capture)]
|
||||
is returned. Otherwise the result is nil."
|
||||
[s clauses]
|
||||
(some
|
||||
(fn [[re action]]
|
||||
(when-let [[m c] (re-find re s)]
|
||||
[(subs s (count m)) (action c)]))
|
||||
clauses))
|
||||
|
||||
(defn- lex-route
|
||||
"Return a pair of [regex params]. regex is a compiled regular
|
||||
expression for matching routes. params is a list of route param
|
||||
names (:*, :id, etc.). "
|
||||
[s clauses]
|
||||
(loop [s s pattern "" params []]
|
||||
(if (seq s)
|
||||
(let [[s [r p]] (lex* s clauses)]
|
||||
(recur s (str pattern r) (conj params p)))
|
||||
[(re-pattern (str \^ pattern \$)) (remove nil? params)])))
|
||||
|
||||
(defn- compile-route
|
||||
"Given a route return an instance of IRouteMatches."
|
||||
[orig-route]
|
||||
(let [clauses [[#"^\*([^\s.:*/]*)" ;; Splats, named splates
|
||||
(fn [v]
|
||||
(let [r "(.*?)"
|
||||
p (if (seq v)
|
||||
(keyword v)
|
||||
:*)]
|
||||
[r p]))]
|
||||
[#"^\:([^\s.:*/]+)" ;; Params
|
||||
(fn [v]
|
||||
(let [r "([^,;?/]+)"
|
||||
p (keyword v)]
|
||||
[r p]))]
|
||||
[#"^([^:*]+)" ;; Literals
|
||||
(fn [v]
|
||||
(let [r (re-escape v)]
|
||||
[r]))]]
|
||||
[re params] (lex-route orig-route clauses)]
|
||||
(reify
|
||||
IRouteValue
|
||||
(route-value [this] orig-route)
|
||||
|
||||
IRouteMatches
|
||||
(route-matches [_ route]
|
||||
(when-let [[_ & ms] (re-matches* re route)]
|
||||
(->> (interleave params (map decode ms))
|
||||
(partition 2)
|
||||
(map (fn [[k v]] (MapEntry. k v nil)))
|
||||
(merge-with vector {})))))))
|
||||
|
||||
;;----------------------------------------------------------------------
|
||||
;; Route rendering
|
||||
|
||||
(defn ^:internal render-route* [obj & args]
|
||||
(when (satisfies? IRenderRoute obj)
|
||||
(apply render-route obj args)))
|
||||
|
||||
;;----------------------------------------------------------------------
|
||||
;; Routes adding/removing
|
||||
|
||||
(def ^:dynamic *routes*
|
||||
(atom []))
|
||||
|
||||
(defn add-route! [obj action]
|
||||
(let [obj (if (string? obj)
|
||||
(compile-route obj)
|
||||
obj)]
|
||||
(swap! *routes* conj [obj action])))
|
||||
|
||||
(defn remove-route! [obj]
|
||||
(swap! *routes*
|
||||
(fn [rs]
|
||||
(filterv
|
||||
(fn [[x _]]
|
||||
(not= x obj))
|
||||
rs))))
|
||||
|
||||
(defn reset-routes! []
|
||||
(reset! *routes* []))
|
||||
|
||||
;;----------------------------------------------------------------------
|
||||
;; Route lookup and dispatch
|
||||
|
||||
(defn locate-route [route]
|
||||
(some
|
||||
(fn [[compiled-route action]]
|
||||
(when-let [params (route-matches compiled-route route)]
|
||||
{:action action :params params :route compiled-route}))
|
||||
@*routes*))
|
||||
|
||||
(defn locate-route-value
|
||||
"Returns original route value as set in defroute when passed a URI path."
|
||||
[uri]
|
||||
(-> uri locate-route :route route-value))
|
||||
|
||||
(defn- prefix
|
||||
[]
|
||||
(str (get-config [:prefix])))
|
||||
|
||||
(defn- uri-without-prefix
|
||||
[uri]
|
||||
(string/replace uri (re-pattern (str "^" (prefix))) ""))
|
||||
|
||||
(defn- uri-with-leading-slash
|
||||
"Ensures that the uri has a leading slash"
|
||||
[uri]
|
||||
(if (= "/" (first uri))
|
||||
uri
|
||||
(str "/" uri)))
|
||||
|
||||
(defn dispatch!
|
||||
"Dispatch an action for a given route if it matches the URI path."
|
||||
[uri]
|
||||
(let [[uri-path query-string] (string/split (uri-without-prefix uri) #"\?")
|
||||
uri-path (uri-with-leading-slash uri-path)
|
||||
query-params (when query-string
|
||||
{:query-params (decode-query-params query-string)})
|
||||
{:keys [action params]} (locate-route uri-path)
|
||||
action (or action identity)
|
||||
params (merge params query-params)]
|
||||
(action params)))
|
||||
|
||||
(defn invalid-params [params validations]
|
||||
(reduce (fn [m [key validation]]
|
||||
(let [value (get params key)]
|
||||
(if (re-matches validation value)
|
||||
m
|
||||
(assoc m key [value validation]))))
|
||||
{} (partition 2 validations)))
|
||||
|
||||
(defn- params-valid? [params validations]
|
||||
(empty? (invalid-params params validations)))
|
||||
|
||||
;;----------------------------------------------------------------------
|
||||
;; Protocol implementations
|
||||
|
||||
(extend-protocol IRouteMatches
|
||||
string
|
||||
(route-matches [this route]
|
||||
(route-matches (compile-route this) route))
|
||||
|
||||
js/RegExp
|
||||
(route-matches [this route]
|
||||
(when-let [[_ & ms] (re-matches* this route)]
|
||||
(vec ms)))
|
||||
|
||||
cljs.core/PersistentVector
|
||||
(route-matches [[route-string & validations] route]
|
||||
(let [params (route-matches (compile-route route-string) route)]
|
||||
(when (params-valid? params validations)
|
||||
params))))
|
||||
|
||||
(extend-protocol IRouteValue
|
||||
string
|
||||
(route-value [this]
|
||||
(route-value (compile-route this)))
|
||||
|
||||
js/RegExp
|
||||
(route-value [this] this)
|
||||
|
||||
cljs.core/PersistentVector
|
||||
(route-value [[route-string & validations]]
|
||||
(vec (cons (route-value route-string) validations))))
|
||||
|
||||
(extend-protocol IRenderRoute
|
||||
string
|
||||
(render-route
|
||||
([this]
|
||||
(render-route this {}))
|
||||
([this params]
|
||||
(let [{:keys [query-params] :as m} params
|
||||
a (atom m)
|
||||
path (.replace this (js/RegExp. ":[^\\s.:*/]+|\\*[^\\s.:*/]*" "g")
|
||||
(fn [$1]
|
||||
(let [lookup (keyword (if (= $1 "*")
|
||||
$1
|
||||
(subs $1 1)))
|
||||
v (get @a lookup)
|
||||
replacement (if (sequential? v)
|
||||
(do
|
||||
(swap! a assoc lookup (next v))
|
||||
(encode-uri (first v)))
|
||||
(if v (encode-uri v) $1))]
|
||||
replacement)))
|
||||
path (str (get-config [:prefix]) path)]
|
||||
(if-let [query-string (and query-params
|
||||
(encode-query-params query-params))]
|
||||
(str path "?" query-string)
|
||||
path))))
|
||||
|
||||
cljs.core/PersistentVector
|
||||
(render-route
|
||||
([this]
|
||||
(render-route this {}))
|
||||
([[route-string & validations] params]
|
||||
(let [invalid (invalid-params params validations)]
|
||||
(if (empty? invalid)
|
||||
(render-route route-string params)
|
||||
(throw (ex-info "Could not build route: invalid params" invalid)))))))
|
||||
Reference in New Issue
Block a user