3 , ExistentialQuantification
5 , GeneralizedNewtypeDeriving
7 , MultiParamTypeClasses
11 , UndecidableInstances
14 module Network.HTTP.Lucu.Dispatcher.Internal
26 import Control.Applicative hiding (empty)
27 import Control.Monad.Trans.Maybe
28 import Control.Monad.Unicode
29 import Data.Collections
30 import qualified Data.Collections.Newtype.TH as C
32 import Data.Monoid.Unicode
33 import Network.HTTP.Lucu.Dispatcher.Node
34 import Network.HTTP.Lucu.Resource.Internal
35 import Network.HTTP.Lucu.Utils
36 import Network.URI hiding (path)
37 import Prelude hiding (lookup)
38 import Prelude.Unicode
42 -- Minimal complete definition: 'findHostMap'
43 class SchemeMapper α where
44 findHostMap ∷ Scheme → α → MaybeT IO HostMap
45 schemeMap ∷ α → SchemeMap
46 {-# INLINE schemeMap #-}
49 -- |Container type for the 'SchemeMapper' type class.
50 data SchemeMap = ∀α. SchemeMapper α ⇒ SMap α
54 -- Minimal complete definition: 'findResourceMap'
55 class HostMapper α where
56 findResourceMap ∷ Host → α → MaybeT IO ResourceMap
58 {-# INLINE hostMap #-}
61 -- |Container type for the 'HostMapper' type class.
62 data HostMap = ∀α. HostMapper α ⇒ HMap α
66 -- Minimal complete definition: 'findResource'
67 class ResourceMapper α where
68 findResource ∷ PathSegments → α → MaybeT IO (PathSegments, Resource)
69 resourceMap ∷ α → ResourceMap
70 {-# INLINE resourceMap #-}
73 -- |Container type for the 'ResourceMapper' type class.
74 data ResourceMap = ∀α. ResourceMapper α ⇒ RMap α
77 newtype ResourceTree = Root ResourceNode
78 deriving (Monoid, Show)
80 -- Instances of SchemeMapper --------------------------------------------------
81 instance SchemeMapper SchemeMap where
82 {-# INLINE findHostMap #-}
83 findHostMap s (SMap α) = findHostMap s α
84 {-# INLINE schemeMap #-}
87 -- |'HostMap's are also 'SchemeMapper's too, which matches to any
89 instance SchemeMapper HostMap where
90 {-# INLINE findHostMap #-}
91 findHostMap = const return
93 -- |'ResourceMap's are also 'SchemeMapper's too, which matches to any
95 instance SchemeMapper ResourceMap where
96 {-# INLINE findHostMap #-}
97 findHostMap _ r = return $ hostMap f
99 f ∷ Host → Maybe ResourceMap
103 -- |@'insert' a b@ first tries @a@, and if it fails, tries @b@ next.
104 instance SchemeMapper α ⇒ Unfoldable SchemeMap α where
105 {-# INLINE insert #-}
106 insert a (SMap b) = schemeMap c
108 c ∷ Scheme → MaybeT IO HostMap
110 c s = findHostMap s a <|> findHostMap s b
113 {-# INLINE singleton #-}
114 singleton = schemeMap
116 -- |@'mappend' a b@ first tries @a@, and if it fails, tries @b@ next.
117 instance Monoid SchemeMap where
118 {-# INLINE mempty #-}
121 e ∷ Scheme → MaybeT IO HostMap
124 {-# INLINE mappend #-}
127 instance Map α Scheme HostMap ⇒ SchemeMapper α where
128 {-# INLINE findHostMap #-}
129 findHostMap = (maybe (fail (⊥)) return ∘) ∘ lookup
131 -- |An IO-based scheme mapper.
132 instance SchemeMapper (Scheme → MaybeT IO HostMap) where
133 {-# INLINE findHostMap #-}
134 findHostMap = flip id
136 -- |A pure scheme mapper.
137 instance SchemeMapper (Scheme → Maybe HostMap) where
138 {-# INLINE findHostMap #-}
139 findHostMap = (maybe (fail (⊥)) return ∘) ∘ flip id
142 -- Instances of HostMapper ----------------------------------------------------
143 instance HostMapper HostMap where
144 {-# INLINE findResourceMap #-}
145 findResourceMap h (HMap α) = findResourceMap h α
146 {-# INLINE hostMap #-}
149 -- |'ResourceMap's are also 'HostMapper's too, which matches to any
151 instance HostMapper ResourceMap where
152 {-# INLINE findResourceMap #-}
153 findResourceMap = const return
155 -- |@'insert' a b@ first tries @a@, and if it fails, tries @b@ next.
156 instance HostMapper α ⇒ Unfoldable HostMap α where
157 {-# INLINE insert #-}
158 insert a (HMap b) = hostMap c
160 c ∷ Host → MaybeT IO ResourceMap
162 c h = findResourceMap h a <|> findResourceMap h b
165 {-# INLINE singleton #-}
168 -- |@'mappend' a b@ first tries @a@, and if it fails, tries @b@ next.
169 instance Monoid HostMap where
170 {-# INLINE mempty #-}
173 e ∷ Host → MaybeT IO ResourceMap
176 {-# INLINE mappend #-}
179 instance Map α Host ResourceMap ⇒ HostMapper α where
180 {-# INLINE findResourceMap #-}
181 findResourceMap = (maybe (fail (⊥)) return ∘) ∘ lookup
183 -- |An IO-based host mapper.
184 instance HostMapper (Host → MaybeT IO ResourceMap) where
185 {-# INLINE findResourceMap #-}
186 findResourceMap = flip id
188 -- |A pure host mapper.
189 instance HostMapper (Host → Maybe ResourceMap) where
190 {-# INLINE findResourceMap #-}
191 findResourceMap = (maybe (fail (⊥)) return ∘) ∘ flip id
193 -- Instances of ResourceMapper ------------------------------------------------
194 instance ResourceMapper ResourceMap where
195 {-# INLINE findResource #-}
196 findResource s (RMap α) = findResource s α
197 {-# INLINE resourceMap #-}
200 -- |@'insert' a b@ first tries @a@, and if it fails, tries @b@ next.
201 instance ResourceMapper α ⇒ Unfoldable ResourceMap α where
202 {-# INLINE insert #-}
203 insert a (RMap b) = resourceMap c
205 c ∷ PathSegments → MaybeT IO (PathSegments, Resource)
207 c s = findResource s a <|> findResource s b
210 {-# INLINE singleton #-}
211 singleton = resourceMap
213 -- |@'mappend' a b@ first tries @a@, and if it fails, tries @b@ next.
214 instance Monoid ResourceMap where
215 {-# INLINE mempty #-}
216 mempty = resourceMap e
218 e ∷ PathSegments → MaybeT IO (PathSegments, Resource)
221 {-# INLINE mappend #-}
224 instance Map α PathSegments (PathSegments, Resource) ⇒ ResourceMapper α where
225 {-# INLINE findResource #-}
226 findResource = (maybe (fail (⊥)) return ∘) ∘ lookup
228 -- |An IO-based resource mapper.
229 instance ResourceMapper (PathSegments → MaybeT IO (PathSegments, Resource)) where
230 {-# INLINE findResource #-}
231 findResource = flip id
233 -- |A pure resource mapper.
234 instance ResourceMapper (PathSegments → Maybe (PathSegments, Resource)) where
235 {-# INLINE findResource #-}
236 findResource = (maybe (fail (⊥)) return ∘) ∘ flip id
238 -- Instances of ResourceTree --------------------------------------------------
239 C.derive [d| instance Foldable ResourceTree (PathSegments, ResourceNode)
242 -- dispatch -------------------------------------------------------------------
243 dispatch ∷ SchemeMapper α ⇒ URI → α → MaybeT IO (PathSegments, Resource)
245 = (findResource (uriPathSegments uri) =≪)
246 ∘ (findResourceMap (uriHost uri) =≪)
247 ∘ findHostMap (uriCIScheme uri)
250 -- |'ResTree' is an opaque structure which is a map from resource path
252 newtype ResTree = ResTree ResNode -- root だから Map ではない
253 type ResSubtree = Map ByteString ResNode
254 data ResNode = ResNode (Maybe Resource) ResSubtree
256 -- |'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g.
259 -- mkResTree [ ([] , 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/
260 -- , ([\"unistd\"], 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd
264 -- Note that path components are always represented as octet streams
265 -- in this system. Lucu automatically decodes percent-encoded URIs but
266 -- has no involvement in character encodings such as UTF-8, since RFC
267 -- 2616 (HTTP/1.1) says nothing about character encodings to be used
268 -- in \"http\" and \"https\" URI schemas.
269 mkResTree ∷ [ ([ByteString], Resource) ] → ResTree
270 mkResTree = processRoot ∘ map (first canonicalisePath)
272 canonicalisePath ∷ [ByteString] → [ByteString]
273 canonicalisePath = filter ((¬) ∘ BS.null)
275 processRoot ∷ [ ([ByteString], Resource) ] → ResTree
277 = let (roots, nonRoots) = partition (\(path, _) → null path) list
278 children = processNonRoot nonRoots
281 -- The root has no resources. Maybe there's one at
282 -- somewhere like "/foo".
283 ResTree (ResNode Nothing children)
285 -- There is a root resource.
286 let (_, def) = last roots
288 ResTree (ResNode (Just def) children)
290 processNonRoot ∷ [ ([ByteString], Resource) ] → ResSubtree
292 = let subtree = M.fromList [(name, node name)
294 childNames = [name | (name:_, _) ← list]
295 node name = let defs = [def | (path, def) ← list, path ≡ [name]]
298 -- No resources are defined
299 -- here. Maybe there's one at
300 -- somewhere below this node.
301 ResNode Nothing children
303 -- There is a resource here.
304 ResNode (Just $ last defs) children
305 children = processNonRoot [(path, def)
306 | (_:path, def) ← list]