-
Notifications
You must be signed in to change notification settings - Fork 2
/
route.cljc
286 lines (259 loc) · 12.5 KB
/
route.cljc
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
(ns janus.route
"Construct routing tree, identify route from URIs and generate route from parameters"
(:import #?@(:cljs (goog.Uri)
:clj ([java.net URI])))
(:require [clojure.string :as string]
[clojure.zip :as z]
[clojure.spec.alpha :as s]
[clojure.core.match :as m]
[clojure.pprint]
#?@(:cljs ([goog.string :as gstring]
goog.string.format)
:clj ([ring.util.codec]))))
(defprotocol Identifiable
(ident [this] "Identify this logical route segment"))
(defprotocol AsSegment
"An abstraction for concisely representing the construction and identification of route segments"
(match [this segment] "If the given segment matches this, return the match context (if any), otherwise falsey")
(build [this options] "Build the segment represented by this with the given options"))
(defprotocol Dispatchable
(dispatch* [this args]))
(extend-protocol AsSegment
nil ; implicitly matched and generated placeholder -used by the root route.
(match [this segment])
(build [this _])
#?(:cljs string :clj String) ; constant, invertible
(match [this segment] (when (= this segment) segment))
(build [this args] (if (sequential? args)
(apply #?(:cljs gstring/format :clj format) this args) ; potential inverse of regex
this))
#?(:cljs cljs.core/Keyword :clj clojure.lang.Keyword) ; constant, invertible
(match [this segment] (when (= (name this) segment) segment))
(build [this _] (name this))
#?(:cljs boolean :clj java.lang.Boolean) ; invertible
(match [this segment] (when this segment))
(build [this arg] arg)
#?(:cljs js/RegExp :clj java.util.regex.Pattern) ; invertible when used cautiously
(match [this segment] (when-let [m (re-matches this segment)]
(cond (string? m) m
(vector? m) (rest m))))
(build [this args] (if (sequential? args) (apply str args) args))
#?(:cljs cljs.core/PersistentVector :clj clojure.lang.PersistentVector) ; invertible when elements are inverses of each other
(match [this segment] (match (first this) segment))
(build [this args] (build (second this) args))
#?(:cljs function :clj clojure.lang.Fn) ; potentially invertible
(match [this segment] (this segment))
(build [this args] (this args)))
(defprotocol Zippable
(branch? [route] "Is it possible for this node to have children?")
(children [route] "Return children of this node.")
(make-node [route children] "Makes new node from existing node and new children."))
(defprotocol ConformableRoute
(conform [route] "Return the conformed form of this route"))
(defn- equivalent-routes [r0 r1] (and (= (type r0) (type r1))
(= (.-identifiable r0) (.-identifiable r1))
(= (.-as-segment r0) (.-as-segment r1))
(= (.-dispatchable r0) (.-dispatchable r1))
(= (.-children r0) (.-children r1))))
(deftype Route [identifiable as-segment dispatchable children]
Zippable
(branch? [this] (seq children))
(children [this] children)
(make-node [this children] (Route. identifiable as-segment dispatchable children))
ConformableRoute
(conform [this] this)
AsSegment
(match [this segment] (match as-segment segment))
(build [this options] (build as-segment options))
Identifiable
(ident [this] identifiable)
Dispatchable
(dispatch* [this args] (dispatch* dispatchable args))
#?@(:cljs (IEquiv
(-equiv [this other] (equivalent-routes this other)))
:clj (java.lang.Object
(hashCode [this] (.hashCode [identifiable as-segment dispatchable children]))
(equals [this other] (equivalent-routes this other)))))
(defn- equivalent-recursive-routes [r0 r1] (and (= (type r0) (type r1))
(= (.-identifiable r0) (.-identifiable r1))
(= (.-as-segment r0) (.-as-segment r1))
(= (.-dispatchable r0) (.-dispatchable r1))))
(deftype RecursiveRoute [identifiable as-segment dispatchable]
Zippable
(branch? [this] true)
(children [this] [this])
(make-node [this children] this)
ConformableRoute
(conform [this] this)
AsSegment
(match [this segment] (match as-segment segment))
(build [this options] (build as-segment options))
Identifiable
(ident [this] identifiable)
Dispatchable
(dispatch* [this args] (dispatch* dispatchable args))
#?@(:cljs (IEquiv
(-equiv [this other] (equivalent-recursive-routes this other)))
:clj (java.lang.Object
(hashCode [this] (.hashCode [identifiable as-segment dispatchable]))
(equals [this other] (equivalent-recursive-routes this other)))))
(s/def ::segment #(satisfies? AsSegment %))
(s/def ::dispatchable #(satisfies? Dispatchable %))
(defn- conform-ipersistentvector
[ipv]
(let [[identifiable v] ipv
s (name identifiable)
as-segment? (partial s/valid? ::segment)
dispatchable? (partial s/valid? ::dispatchable)]
(cond
(vector? v) (m/match [(count v) v]
[0 []]
, (conform [identifiable [s identifiable ()]])
[1 [(a :guard seqable?)]]
, (conform [identifiable [s identifiable a]])
[1 [(a :guard as-segment?)]]
, (conform [identifiable [a identifiable ()]])
[1 [a]]
, (conform [identifiable [s a ()]])
[2 [(a :guard as-segment?) (b :guard seqable?)]]
, (conform [identifiable [a identifiable b]])
[2 [(a :guard dispatchable?) (b :guard seqable?)]]
, (conform [identifiable [s a b]])
[2 [(a :guard as-segment?) b]]
, (conform [identifiable [a b ()]])
[3 [(a :guard as-segment?) b (c :guard seqable?)]]
, (->Route identifiable a b (map conform c)) ; terminus
:else (throw (ex-info "Unrecognized route format" {::route ipv})))
(string? v) (conform [identifiable [v identifiable ()]])
(seqable? v) (conform [identifiable [s identifiable v]])
(or (var? v) (fn? v)) (conform [identifiable [s v ()]])
:else (conform [identifiable [v identifiable ()]]))))
(extend-protocol ConformableRoute
#?(:cljs cljs.core/PersistentVector :clj clojure.lang.PersistentVector)
(conform [this] (conform-ipersistentvector this))
#?(:cljs cljs.core/MapEntry :clj clojure.lang.MapEntry)
(conform [this] (conform-ipersistentvector this))
#?(:cljs cljs.core/Keyword :clj clojure.lang.Keyword)
(conform [this] (conform [::root [nil this ()]])))
(defn- r-zip
"Return a zipper for a normalized route data structure"
[route]
(z/zipper branch? children make-node route))
(s/def ::conformable-route #(satisfies? ConformableRoute %))
(s/def ::zippable #(satisfies? Zippable %))
(defn- conform*
"Yields `route => [identifiable [as-segment dispatchable routes]]`"
([identifiable dispatchable route] (conform* [identifiable [true dispatchable route]]))
([dispatchable route] (conform* [::root [nil dispatchable route]]))
([] (conform* [::root [nil ::root ()]])) ; degenerate route table
([route]
{:pre [(s/valid? ::conformable-route route)] :post [(s/valid? ::zippable %)]}
(conform route)))
(defprotocol Routable
"An abstraction for an entity located in the route tree that can process move instructions by
returning a new instance"
(root [this] "Return a new routable located at the root")
(parent [this] "Return a new routable located at the parent of this")
(identify [this path] "Return a new routable based on the given path (URI)")
(generate [this params] "Return a new routable based on the given path parameters"))
(defprotocol Routed
"An abstraction for an entity located in the route tree that can describe its position"
(path [this] [this generalized?] "Return the path of the route as a string, optionally generalized")
(identifiers [this] "Return the route as a sequence of segment identifiers")
(parameters [this] "Return map of segment identifiers to route parameters"))
(defn- normalize-target [target] (if (vector? target) target [target nil]))
(defn- normalize-uri
[uri]
#?(:clj (.getRawPath (.normalize (URI. uri)))
:cljs (.getPath (goog.Uri. uri))))
(def url-encode #?(:clj ring.util.codec/url-encode :cljs js/encodeURIComponent))
(def url-decode #?(:clj ring.util.codec/url-decode :cljs js/decodeURIComponent))
(defrecord Router [zipper params]
Routable
(root [this] (Router. (r-zip (z/root zipper)) []))
(parent [this] (when-let [z (z/up zipper)] (Router. z (vec (butlast params)))))
(identify [this uri]
(if-let [segments (seq (map url-decode (rest (string/split (normalize-uri uri) #"/"))))]
(loop [rz (z/down zipper) segments segments params params]
(when rz
(let [route (z/node rz)]
(if-let [p (match route (first segments))]
(if-let [remaining-segments (seq (rest segments))]
(recur (z/down rz) remaining-segments (conj params p))
(Router. rz (conj params p)))
(recur (z/right rz) segments params)))))
this))
(generate [this targets]
(if-let [ps (seq (map normalize-target targets))]
(loop [rz (z/down zipper) [[i p] & remaining-ps :as ps] ps params params]
(when rz
(let [route (z/node rz)]
(if-let [p' (when (= (ident route) i) (build route p))]
(if (seq remaining-ps)
(recur (z/down rz) remaining-ps (conj params p))
(Router. rz (conj params p)))
(recur (z/right rz) ps params)))))
this))
Routed
(path [this] (path this false))
(path [this generalized?]
(let [nodes (rest (concat (z/path zipper) (list (z/node zipper))))
f (fn [route p] (if generalized? (ident route) (url-encode (build route p))))
segments (map f nodes params)]
(str "/" (string/join "/" segments))))
(identifiers [this] (map ident (concat (z/path zipper) (list (z/node zipper)))))
(parameters [this] (map vector (rest (identifiers this)) params))
Dispatchable
(dispatch* [this args] (dispatch* (z/node zipper) args)))
#?(:clj
(do (defmethod clojure.core/print-method Router
[router ^java.io.Writer writer]
(.write writer (format "#<Router \"%s\">" (path router))))
(defmethod clojure.core/print-method Route
[route ^java.io.Writer writer]
(.write writer "#janus.route/Route ")
(print-method [(.identifiable route)
(.as-segment route)
(.dispatchable route)
(.children route)] writer))
(defmethod clojure.pprint/simple-dispatch Router
[router]
(print-method router *out*))
(defmethod clojure.core/print-method RecursiveRoute
[route ^java.io.Writer writer]
(.write writer "#janus.route/RecursiveRoute ")
(print-method [(.identifiable route)
(.as-segment route)
(.dispatchable route)] writer))
(defmethod clojure.pprint/simple-dispatch Router
[router]
(print-method router *out*)))
:cljs
(extend-protocol IPrintWithWriter
Router
(-pr-writer [this writer opts]
(-write writer (goog.string/format "#<Router %s>" (path this))))
Route
(-pr-writer [this writer opts]
(-write writer "#janus.route/Route ")
(-pr-writer [(.-identifiable this)
(.-as-segment this)
(.-dispatchable this)
(.-children this)] writer opts))
RecursiveRoute
(-pr-writer [this writer opts]
(-write writer "#janus.route/RecursiveRoute ")
(-pr-writer [(.-identifiable this)
(.-as-segment this)
(.-dispatchable this)] writer opts))))
(def read-route (partial apply ->Route))
(def read-recursive-route (partial apply ->RecursiveRoute))
(defn router
[route]
(->Router (-> route conform* r-zip) []))
(defn recursive-route [name as-segment dispatch]
(->RecursiveRoute name as-segment dispatch))
(defn dispatch
"Dispatch to the Dispatchable.dispatch method while collecting varargs"
[dispatchable & args]
(dispatch* dispatchable args))