3 , ExistentialQuantification
6 , MultiParamTypeClasses
12 module Network.HTTP.Lucu.Dispatcher.Internal
25 import Control.Applicative hiding (empty)
26 import Control.Monad.Trans.Maybe
27 import Control.Monad.Unicode
28 import Data.Collections
29 import qualified Data.Map as M
31 import Data.Monoid.Unicode
32 import Network.HTTP.Lucu.Resource.Internal
33 import Network.HTTP.Lucu.Utils
34 import Network.URI hiding (path)
35 import Prelude hiding (filter, lookup, null)
36 import Prelude.Unicode
40 -- Minimal complete definition: 'findHostMap'
41 class SchemeMapper α where
42 findHostMap ∷ Scheme → α → MaybeT IO HostMap
43 schemeMap ∷ α → SchemeMap
44 {-# INLINE schemeMap #-}
47 -- |Container type for the 'SchemeMapper' type class.
48 data SchemeMap = ∀α. SchemeMapper α ⇒ SMap α
52 -- Minimal complete definition: 'findResourceMap'
53 class HostMapper α where
54 findResourceMap ∷ Host → α → MaybeT IO ResourceMap
56 {-# INLINE hostMap #-}
59 -- |Container type for the 'HostMapper' type class.
60 data HostMap = ∀α. HostMapper α ⇒ HMap α
64 -- Minimal complete definition: 'findResource'
65 class ResourceMapper α where
66 findResource ∷ PathSegments → α → MaybeT IO (PathSegments, Resource)
67 resourceMap ∷ α → ResourceMap
68 {-# INLINE resourceMap #-}
71 -- |Container type for the 'ResourceMapper' type class.
72 data ResourceMap = ∀α. ResourceMapper α ⇒ RMap α
75 newtype ResourceTree = Root ResourceNode
80 | NonGreedy !Resource !ResourceTree
81 | Branch !ResourceTree
83 -- Instances of SchemeMapper --------------------------------------------------
84 instance SchemeMapper SchemeMap where
85 {-# INLINE findHostMap #-}
86 findHostMap s (SMap α) = findHostMap s α
87 {-# INLINE schemeMap #-}
90 -- |'HostMap's are also 'SchemeMapper's too, which matches to any
92 instance SchemeMapper HostMap where
93 {-# INLINE findHostMap #-}
94 findHostMap = const return
96 -- |'ResourceMap's are also 'SchemeMapper's too, which matches to any
98 instance SchemeMapper ResourceMap where
99 {-# INLINE findHostMap #-}
100 findHostMap _ r = return $ hostMap f
102 f ∷ Host → Maybe ResourceMap
106 -- |@'insert' a b@ first tries @a@, and if it fails, tries @b@ next.
107 instance SchemeMapper α ⇒ Unfoldable SchemeMap α where
108 {-# INLINE insert #-}
109 insert a (SMap b) = schemeMap c
111 c ∷ Scheme → MaybeT IO HostMap
113 c s = findHostMap s a <|> findHostMap s b
116 {-# INLINE singleton #-}
117 singleton = schemeMap
119 -- |@a `'mappend'` b@ first tries @a@, and if it fails, tries @b@ next.
120 instance Monoid SchemeMap where
121 {-# INLINE mempty #-}
124 e ∷ Scheme → MaybeT IO HostMap
127 {-# INLINE mappend #-}
130 instance Map α Scheme HostMap ⇒ SchemeMapper α where
131 {-# INLINE findHostMap #-}
132 findHostMap = (maybe (fail (⊥)) return ∘) ∘ lookup
134 -- |An IO-based scheme mapper.
135 instance SchemeMapper (Scheme → MaybeT IO HostMap) where
136 {-# INLINE findHostMap #-}
137 findHostMap = flip id
139 -- |A pure scheme mapper.
140 instance SchemeMapper (Scheme → Maybe HostMap) where
141 {-# INLINE findHostMap #-}
142 findHostMap = (maybe (fail (⊥)) return ∘) ∘ flip id
145 -- Instances of HostMapper ----------------------------------------------------
146 instance HostMapper HostMap where
147 {-# INLINE findResourceMap #-}
148 findResourceMap h (HMap α) = findResourceMap h α
149 {-# INLINE hostMap #-}
152 -- |'ResourceMap's are also 'HostMapper's too, which matches to any
154 instance HostMapper ResourceMap where
155 {-# INLINE findResourceMap #-}
156 findResourceMap = const return
158 -- |@'insert' a b@ first tries @a@, and if it fails, tries @b@ next.
159 instance HostMapper α ⇒ Unfoldable HostMap α where
160 {-# INLINE insert #-}
161 insert a (HMap b) = hostMap c
163 c ∷ Host → MaybeT IO ResourceMap
165 c h = findResourceMap h a <|> findResourceMap h b
168 {-# INLINE singleton #-}
171 -- |@a `'mappend'` b@ first tries @a@, and if it fails, tries @b@ next.
172 instance Monoid HostMap where
173 {-# INLINE mempty #-}
176 e ∷ Host → MaybeT IO ResourceMap
179 {-# INLINE mappend #-}
182 instance Map α Host ResourceMap ⇒ HostMapper α where
183 {-# INLINE findResourceMap #-}
184 findResourceMap = (maybe (fail (⊥)) return ∘) ∘ lookup
186 -- |An IO-based host mapper.
187 instance HostMapper (Host → MaybeT IO ResourceMap) where
188 {-# INLINE findResourceMap #-}
189 findResourceMap = flip id
191 -- |A pure host mapper.
192 instance HostMapper (Host → Maybe ResourceMap) where
193 {-# INLINE findResourceMap #-}
194 findResourceMap = (maybe (fail (⊥)) return ∘) ∘ flip id
196 -- Instances of ResourceMapper ------------------------------------------------
197 instance ResourceMapper ResourceMap where
198 {-# INLINE findResource #-}
199 findResource s (RMap α) = findResource s α
200 {-# INLINE resourceMap #-}
203 -- |@'insert' a b@ first tries @a@, and if it fails, tries @b@ next.
204 instance ResourceMapper α ⇒ Unfoldable ResourceMap α where
205 {-# INLINE insert #-}
206 insert a (RMap b) = resourceMap c
208 c ∷ PathSegments → MaybeT IO (PathSegments, Resource)
210 c s = findResource s a <|> findResource s b
213 {-# INLINE singleton #-}
214 singleton = resourceMap
216 -- |@a `'mappend'` b@ first tries @a@, and if it fails, tries @b@ next.
217 instance Monoid ResourceMap where
218 {-# INLINE mempty #-}
219 mempty = resourceMap e
221 e ∷ PathSegments → MaybeT IO (PathSegments, Resource)
224 {-# INLINE mappend #-}
227 instance Map α PathSegments (PathSegments, Resource) ⇒ ResourceMapper α where
228 {-# INLINE findResource #-}
229 findResource = (maybe (fail (⊥)) return ∘) ∘ lookup
231 -- |An IO-based resource mapper.
232 instance ResourceMapper (PathSegments → MaybeT IO (PathSegments, Resource)) where
233 {-# INLINE findResource #-}
234 findResource = flip id
236 -- |A pure resource mapper.
237 instance ResourceMapper (PathSegments → Maybe (PathSegments, Resource)) where
238 {-# INLINE findResource #-}
239 findResource = (maybe (fail (⊥)) return ∘) ∘ flip id
241 -- Instances of ResourceTree --------------------------------------------------
243 instance (Functor m, MonadIO m)
244 ⇒ Unfoldable (ResourceTree m) ([PathSegment], ResourceNode m) where
245 {-# INLINE insert #-}
246 insert e (Root root) = Root $ insert e root
250 instance (Functor m, MonadIO m) ⇒ Monoid (ResourceTree m) where
251 {-# INLINE mempty #-}
253 {-# INLINE mappend #-}
254 mappend (Root a) (Root b)
258 -- Instances of ResourceNode --------------------------------------------------
260 instance (Functor m, MonadIO m)
261 ⇒ Unfoldable (ResourceNode m) ([PathSegment], ResourceNode m) where
262 {-# INLINEABLE insert #-}
263 insert (p, a) b = insertNodeAt (canonPath p) a b
267 canonPath ∷ (Collection c f, Foldable f e) ⇒ c → c
268 {-# INLINEABLE canonPath #-}
269 canonPath = filter ((¬) ∘ null)
271 insertNodeAt ∷ (Functor m, MonadIO m)
276 {-# INLINEABLE insertNodeAt #-}
277 insertNodeAt [] a b = a ⊕ b
278 insertNodeAt (x:[]) a b = Branch (singleton (x, a)) ⊕ b
279 insertNodeAt (x:xs) a b = insertNodeAt xs a (∅) ⊕ b
281 instance (Functor m, MonadIO m) ⇒ Monoid (ResourceNode m) where
282 {-# INLINE mempty #-}
284 {-# INLINEABLE mappend #-}
285 mappend _ (Greedy r ) = Greedy r
286 mappend (Greedy _ ) (NonGreedy r n) = NonGreedy r n
287 mappend (NonGreedy _ m) (NonGreedy r n) = NonGreedy r (m ⊕ n)
288 mappend (Branch m) (NonGreedy r n) = NonGreedy r (m ⊕ n)
289 mappend (Greedy r ) (Branch _) = Greedy r
290 mappend (NonGreedy r m) (Branch n) = NonGreedy r (m ⊕ n)
291 mappend (Branch m) (Branch n) = Branch (m ⊕ n)
294 -- dispatch -------------------------------------------------------------------
295 dispatch ∷ SchemeMapper α ⇒ URI → α → MaybeT IO (PathSegments, Resource)
297 = (findResource (uriPathSegments uri) =≪)
298 ∘ (findResourceMap (uriHost uri) =≪)
299 ∘ findHostMap (uriCIScheme uri)
302 -- |'ResTree' is an opaque structure which is a map from resource path
304 newtype ResTree = ResTree ResNode -- root だから Map ではない
305 type ResSubtree = Map ByteString ResNode
306 data ResNode = ResNode (Maybe Resource) ResSubtree
308 -- |'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g.
311 -- mkResTree [ ([] , 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/
312 -- , ([\"unistd\"], 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd
316 -- Note that path components are always represented as octet streams
317 -- in this system. Lucu automatically decodes percent-encoded URIs but
318 -- has no involvement in character encodings such as UTF-8, since RFC
319 -- 2616 (HTTP/1.1) says nothing about character encodings to be used
320 -- in \"http\" and \"https\" URI schemas.
321 mkResTree ∷ [ ([ByteString], Resource) ] → ResTree
322 mkResTree = processRoot ∘ map (first canonicalisePath)
324 canonicalisePath ∷ [ByteString] → [ByteString]
325 canonicalisePath = filter ((¬) ∘ BS.null)
327 processRoot ∷ [ ([ByteString], Resource) ] → ResTree
329 = let (roots, nonRoots) = partition (\(path, _) → null path) list
330 children = processNonRoot nonRoots
333 -- The root has no resources. Maybe there's one at
334 -- somewhere like "/foo".
335 ResTree (ResNode Nothing children)
337 -- There is a root resource.
338 let (_, def) = last roots
340 ResTree (ResNode (Just def) children)
342 processNonRoot ∷ [ ([ByteString], Resource) ] → ResSubtree
344 = let subtree = M.fromList [(name, node name)
346 childNames = [name | (name:_, _) ← list]
347 node name = let defs = [def | (path, def) ← list, path ≡ [name]]
350 -- No resources are defined
351 -- here. Maybe there's one at
352 -- somewhere below this node.
353 ResNode Nothing children
355 -- There is a resource here.
356 ResNode (Just $ last defs) children
357 children = processNonRoot [(path, def)
358 | (_:path, def) ← list]