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)
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 ) = f (p, Greedy r)
276 go p (NonGreedy r m) = f (p, NonGreedy r (∅)) ⊕ go' p m
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
286 -- Instances of ResourceNode --------------------------------------------------
287 instance Show ResourceNode where
288 show (Greedy _ ) = "Greedy _"
289 show (NonGreedy _ m) = "NonGreedy _ " ⊕ show m
290 show (Branch m) = "Branch " ⊕ show m
292 instance Monoid ResourceNode where
293 {-# INLINE mempty #-}
295 {-# INLINEABLE mappend #-}
296 mappend (Greedy r ) _ = Greedy r
297 mappend (NonGreedy r m) (Greedy _ ) = NonGreedy r m
298 mappend (NonGreedy r m) (NonGreedy _ n) = NonGreedy r (m ⊕ n)
299 mappend (NonGreedy r m) (Branch n) = NonGreedy r (m ⊕ n)
300 mappend (Branch _) (Greedy r ) = Greedy r
301 mappend (Branch m) (NonGreedy r n) = NonGreedy r (m ⊕ n)
302 mappend (Branch m) (Branch n) = Branch (m ⊕ n)
304 -- dispatch -------------------------------------------------------------------
305 dispatch ∷ SchemeMapper α ⇒ URI → α → MaybeT IO (PathSegments, Resource)
307 = (findResource (uriPathSegments uri) =≪)
308 ∘ (findResourceMap (uriHost uri) =≪)
309 ∘ findHostMap (uriCIScheme uri)
312 -- |'ResTree' is an opaque structure which is a map from resource path
314 newtype ResTree = ResTree ResNode -- root だから Map ではない
315 type ResSubtree = Map ByteString ResNode
316 data ResNode = ResNode (Maybe Resource) ResSubtree
318 -- |'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g.
321 -- mkResTree [ ([] , 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/
322 -- , ([\"unistd\"], 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd
326 -- Note that path components are always represented as octet streams
327 -- in this system. Lucu automatically decodes percent-encoded URIs but
328 -- has no involvement in character encodings such as UTF-8, since RFC
329 -- 2616 (HTTP/1.1) says nothing about character encodings to be used
330 -- in \"http\" and \"https\" URI schemas.
331 mkResTree ∷ [ ([ByteString], Resource) ] → ResTree
332 mkResTree = processRoot ∘ map (first canonicalisePath)
334 canonicalisePath ∷ [ByteString] → [ByteString]
335 canonicalisePath = filter ((¬) ∘ BS.null)
337 processRoot ∷ [ ([ByteString], Resource) ] → ResTree
339 = let (roots, nonRoots) = partition (\(path, _) → null path) list
340 children = processNonRoot nonRoots
343 -- The root has no resources. Maybe there's one at
344 -- somewhere like "/foo".
345 ResTree (ResNode Nothing children)
347 -- There is a root resource.
348 let (_, def) = last roots
350 ResTree (ResNode (Just def) children)
352 processNonRoot ∷ [ ([ByteString], Resource) ] → ResSubtree
354 = let subtree = M.fromList [(name, node name)
356 childNames = [name | (name:_, _) ← list]
357 node name = let defs = [def | (path, def) ← list, path ≡ [name]]
360 -- No resources are defined
361 -- here. Maybe there's one at
362 -- somewhere below this node.
363 ResNode Nothing children
365 -- There is a resource here.
366 ResNode (Just $ last defs) children
367 children = processNonRoot [(path, def)
368 | (_:path, def) ← list]