3 , ExistentialQuantification
5 , GeneralizedNewtypeDeriving
7 , MultiParamTypeClasses
11 , UndecidableInstances
14 {-# OPTIONS_GHC -fno-warn-missing-methods #-}
15 module Network.HTTP.Lucu.Dispatcher.Internal
28 import Control.Applicative hiding (empty)
29 import Control.Monad.Trans.Maybe
30 import Control.Monad.Unicode
31 import Data.Collections
32 import qualified Data.Map as M
34 import Data.Monoid.Unicode
35 import Network.HTTP.Lucu.Resource.Internal
36 import Network.HTTP.Lucu.Utils
37 import Network.URI hiding (path)
38 import Prelude hiding (filter, lookup, null)
39 import Prelude.Unicode
43 -- Minimal complete definition: 'findHostMap'
44 class SchemeMapper α where
45 findHostMap ∷ Scheme → α → MaybeT IO HostMap
46 schemeMap ∷ α → SchemeMap
47 {-# INLINE schemeMap #-}
50 -- |Container type for the 'SchemeMapper' type class.
51 data SchemeMap = ∀α. SchemeMapper α ⇒ SMap α
55 -- Minimal complete definition: 'findResourceMap'
56 class HostMapper α where
57 findResourceMap ∷ Host → α → MaybeT IO ResourceMap
59 {-# INLINE hostMap #-}
62 -- |Container type for the 'HostMapper' type class.
63 data HostMap = ∀α. HostMapper α ⇒ HMap α
67 -- Minimal complete definition: 'findResource'
68 class ResourceMapper α where
69 findResource ∷ PathSegments → α → MaybeT IO (PathSegments, Resource)
70 resourceMap ∷ α → ResourceMap
71 {-# INLINE resourceMap #-}
74 -- |Container type for the 'ResourceMapper' type class.
75 data ResourceMap = ∀α. ResourceMapper α ⇒ RMap α
78 newtype ResourceTree = Root ResourceNode
79 deriving (Monoid, Show)
83 = Greedy !Resource !SubTree
84 | NonGreedy !Resource !SubTree
88 = M.Map PathSegment ResourceNode
90 -- Instances of SchemeMapper --------------------------------------------------
91 instance SchemeMapper SchemeMap where
92 {-# INLINE findHostMap #-}
93 findHostMap s (SMap α) = findHostMap s α
94 {-# INLINE schemeMap #-}
97 -- |'HostMap's are also 'SchemeMapper's too, which matches to any
99 instance SchemeMapper HostMap where
100 {-# INLINE findHostMap #-}
101 findHostMap = const return
103 -- |'ResourceMap's are also 'SchemeMapper's too, which matches to any
104 -- schemes and hosts.
105 instance SchemeMapper ResourceMap where
106 {-# INLINE findHostMap #-}
107 findHostMap _ r = return $ hostMap f
109 f ∷ Host → Maybe ResourceMap
113 -- |@'insert' a b@ first tries @a@, and if it fails, tries @b@ next.
114 instance SchemeMapper α ⇒ Unfoldable SchemeMap α where
115 {-# INLINE insert #-}
116 insert a (SMap b) = schemeMap c
118 c ∷ Scheme → MaybeT IO HostMap
120 c s = findHostMap s a <|> findHostMap s b
123 {-# INLINE singleton #-}
124 singleton = schemeMap
126 -- |@'mappend' a b@ first tries @a@, and if it fails, tries @b@ next.
127 instance Monoid SchemeMap where
128 {-# INLINE mempty #-}
131 e ∷ Scheme → MaybeT IO HostMap
134 {-# INLINE mappend #-}
137 -- |Any 'Map's from 'Scheme' to 'HostMap' are also 'SchemeMapper's.
138 instance Map α Scheme HostMap ⇒ SchemeMapper α where
139 {-# INLINE findHostMap #-}
140 findHostMap = (maybe (fail (⊥)) return ∘) ∘ lookup
142 -- |An IO-based scheme mapper.
143 instance SchemeMapper (Scheme → MaybeT IO HostMap) where
144 {-# INLINE findHostMap #-}
145 findHostMap = flip id
147 -- |A pure scheme mapper.
148 instance SchemeMapper (Scheme → Maybe HostMap) where
149 {-# INLINE findHostMap #-}
150 findHostMap = (maybe (fail (⊥)) return ∘) ∘ flip id
153 -- Instances of HostMapper ----------------------------------------------------
154 instance HostMapper HostMap where
155 {-# INLINE findResourceMap #-}
156 findResourceMap h (HMap α) = findResourceMap h α
157 {-# INLINE hostMap #-}
160 -- |'ResourceMap's are also 'HostMapper's too, which matches to any
162 instance HostMapper ResourceMap where
163 {-# INLINE findResourceMap #-}
164 findResourceMap = const return
166 -- |@'insert' a b@ first tries @a@, and if it fails, tries @b@ next.
167 instance HostMapper α ⇒ Unfoldable HostMap α where
168 {-# INLINE insert #-}
169 insert a (HMap b) = hostMap c
171 c ∷ Host → MaybeT IO ResourceMap
173 c h = findResourceMap h a <|> findResourceMap h b
176 {-# INLINE singleton #-}
179 -- |@'mappend' a b@ first tries @a@, and if it fails, tries @b@ next.
180 instance Monoid HostMap where
181 {-# INLINE mempty #-}
184 e ∷ Host → MaybeT IO ResourceMap
187 {-# INLINE mappend #-}
190 -- |Any 'Map's from 'Host' to 'ResourceMap' are also 'HostMapper's.
191 instance Map α Host ResourceMap ⇒ HostMapper α where
192 {-# INLINE findResourceMap #-}
193 findResourceMap = (maybe (fail (⊥)) return ∘) ∘ lookup
195 -- |An IO-based host mapper.
196 instance HostMapper (Host → MaybeT IO ResourceMap) where
197 {-# INLINE findResourceMap #-}
198 findResourceMap = flip id
200 -- |A pure host mapper.
201 instance HostMapper (Host → Maybe ResourceMap) where
202 {-# INLINE findResourceMap #-}
203 findResourceMap = (maybe (fail (⊥)) return ∘) ∘ flip id
205 -- Instances of ResourceMapper ------------------------------------------------
206 instance ResourceMapper ResourceMap where
207 {-# INLINE findResource #-}
208 findResource s (RMap α) = findResource s α
209 {-# INLINE resourceMap #-}
212 -- |@'insert' a b@ first tries @a@, and if it fails, tries @b@ next.
213 instance ResourceMapper α ⇒ Unfoldable ResourceMap α where
214 {-# INLINE insert #-}
215 insert a (RMap b) = resourceMap c
217 c ∷ PathSegments → MaybeT IO (PathSegments, Resource)
219 c s = findResource s a <|> findResource s b
222 {-# INLINE singleton #-}
223 singleton = resourceMap
225 -- |@'mappend' a b@ first tries @a@, and if it fails, tries @b@ next.
226 instance Monoid ResourceMap where
227 {-# INLINE mempty #-}
228 mempty = resourceMap e
230 e ∷ PathSegments → MaybeT IO (PathSegments, Resource)
233 {-# INLINE mappend #-}
236 -- |Any 'Map's from 'PathSegments' to @('PathSegments', 'Resource')@
237 -- are also 'ResourceMapper's.
238 instance Map α PathSegments (PathSegments, Resource) ⇒ ResourceMapper α where
239 {-# INLINE findResource #-}
240 findResource = (maybe (fail (⊥)) return ∘) ∘ lookup
242 -- |An IO-based resource mapper.
243 instance ResourceMapper (PathSegments → MaybeT IO (PathSegments, Resource)) where
244 {-# INLINE findResource #-}
245 findResource = flip id
247 -- |A pure resource mapper.
248 instance ResourceMapper (PathSegments → Maybe (PathSegments, Resource)) where
249 {-# INLINE findResource #-}
250 findResource = (maybe (fail (⊥)) return ∘) ∘ flip id
252 -- Instances of ResourceTree --------------------------------------------------
253 instance Unfoldable ResourceTree (PathSegments, ResourceNode) where
254 {-# INLINEABLE insert #-}
255 insert (p, a) (Root b) = Root $ insertNodeAt (canonPath p) a b
257 empty = Root $ Branch (∅)
259 canonPath ∷ (Collection c f, Foldable f e) ⇒ c → c
260 {-# INLINEABLE canonPath #-}
261 canonPath = filter ((¬) ∘ null)
263 insertNodeAt ∷ PathSegments → ResourceNode → ResourceNode → ResourceNode
264 {-# INLINEABLE insertNodeAt #-}
269 | null xs → Branch (singleton (x, a)) ⊕ b
270 | otherwise → insertNodeAt xs a (∅) ⊕ b
272 instance Foldable ResourceTree (PathSegments, ResourceNode) where
273 foldMap f (Root n) = go (∅) n
275 go p (Greedy r m) = go' p m ⊕ f (p, Greedy r (∅))
276 go p (NonGreedy r m) = go' p m ⊕ f (p, NonGreedy r (∅))
277 go p (Branch m) = go' p m
279 go' p = foldMap $ \(s, n') → go (p `snoc` s) n'
281 null (Root (Greedy _ _)) = False
282 null (Root (NonGreedy _ _)) = False
283 null (Root (Branch m)) = null m
285 instance Collection ResourceTree (PathSegments, ResourceNode) where
286 {-# INLINE filter #-}
287 filter f = fromList ∘ filter f ∘ fromFoldable
290 -- Instances of ResourceNode --------------------------------------------------
291 instance Show ResourceNode where
292 show (Greedy _ m) = "Greedy _ " ⊕ show m
293 show (NonGreedy _ m) = "NonGreedy _ " ⊕ show m
294 show (Branch m) = "Branch " ⊕ show m
296 instance Monoid ResourceNode where
297 {-# INLINE mempty #-}
299 {-# INLINEABLE mappend #-}
300 mappend (Greedy r m) _ = Greedy r m
301 mappend (NonGreedy r m) (Greedy _ n) = NonGreedy r (m ⊕ n)
302 mappend (NonGreedy r m) (NonGreedy _ n) = NonGreedy r (m ⊕ n)
303 mappend (NonGreedy r m) (Branch n) = NonGreedy r (m ⊕ n)
304 mappend (Branch m) (Greedy r n) = Greedy r (m ⊕ n)
305 mappend (Branch m) (NonGreedy r n) = NonGreedy r (m ⊕ n)
306 mappend (Branch m) (Branch n) = Branch (m ⊕ n)
308 -- dispatch -------------------------------------------------------------------
309 dispatch ∷ SchemeMapper α ⇒ URI → α → MaybeT IO (PathSegments, Resource)
311 = (findResource (uriPathSegments uri) =≪)
312 ∘ (findResourceMap (uriHost uri) =≪)
313 ∘ findHostMap (uriCIScheme uri)
316 -- |'ResTree' is an opaque structure which is a map from resource path
318 newtype ResTree = ResTree ResNode -- root だから Map ではない
319 type ResSubtree = Map ByteString ResNode
320 data ResNode = ResNode (Maybe Resource) ResSubtree
322 -- |'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g.
325 -- mkResTree [ ([] , 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/
326 -- , ([\"unistd\"], 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd
330 -- Note that path components are always represented as octet streams
331 -- in this system. Lucu automatically decodes percent-encoded URIs but
332 -- has no involvement in character encodings such as UTF-8, since RFC
333 -- 2616 (HTTP/1.1) says nothing about character encodings to be used
334 -- in \"http\" and \"https\" URI schemas.
335 mkResTree ∷ [ ([ByteString], Resource) ] → ResTree
336 mkResTree = processRoot ∘ map (first canonicalisePath)
338 canonicalisePath ∷ [ByteString] → [ByteString]
339 canonicalisePath = filter ((¬) ∘ BS.null)
341 processRoot ∷ [ ([ByteString], Resource) ] → ResTree
343 = let (roots, nonRoots) = partition (\(path, _) → null path) list
344 children = processNonRoot nonRoots
347 -- The root has no resources. Maybe there's one at
348 -- somewhere like "/foo".
349 ResTree (ResNode Nothing children)
351 -- There is a root resource.
352 let (_, def) = last roots
354 ResTree (ResNode (Just def) children)
356 processNonRoot ∷ [ ([ByteString], Resource) ] → ResSubtree
358 = let subtree = M.fromList [(name, node name)
360 childNames = [name | (name:_, _) ← list]
361 node name = let defs = [def | (path, def) ← list, path ≡ [name]]
364 -- No resources are defined
365 -- here. Maybe there's one at
366 -- somewhere below this node.
367 ResNode Nothing children
369 -- There is a resource here.
370 ResNode (Just $ last defs) children
371 children = processNonRoot [(path, def)
372 | (_:path, def) ← list]