2 ExistentialQuantification
5 , GeneralizedNewtypeDeriving
7 , MultiParamTypeClasses
12 module Network.HTTP.Lucu.Dispatcher.Internal
27 import Control.Applicative hiding (empty)
28 import Control.Monad.Trans.Maybe
29 import Control.Monad.Unicode
30 import Data.Collections
31 import qualified Data.Map as M
33 import Data.Monoid.Unicode
34 import Network.HTTP.Lucu.Resource.Internal
35 import Network.HTTP.Lucu.Utils
36 import Network.URI hiding (path)
37 import Prelude hiding (filter, lookup, null)
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 α
76 -- |'ResourceTree' is an opaque structure which is a map from resource
77 -- path to 'Resource'.
80 -- 'fromList' [ ([] , 'nonGreedy' '$' 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/
81 -- , ([\"unistd\"], 'nonGreedy' '$' 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd
85 -- Note that path segments are always represented as octet streams in
86 -- this system. Lucu automatically decodes percent-encoded URIs but
87 -- has no involvement in character encodings such as UTF-8, since RFC
88 -- 2616 (HTTP/1.1) says nothing about character encodings to be used
89 -- in \"http\" and \"https\" URI schemas.
90 newtype ResourceTree = Tree (M.Map PathSegments ResourceNode)
95 = Greedy { nResource ∷ !Resource }
96 | NonGreedy { nResource ∷ !Resource }
99 greedy ∷ Resource → ResourceNode
100 {-# INLINE CONLIKE greedy #-}
104 nonGreedy ∷ Resource → ResourceNode
105 {-# INLINE CONLIKE nonGreedy #-}
106 nonGreedy = NonGreedy
108 -- Instances of SchemeMapper --------------------------------------------------
109 instance SchemeMapper SchemeMap where
110 {-# INLINE findHostMap #-}
111 findHostMap s (SMap α) = findHostMap s α
112 {-# INLINE schemeMap #-}
115 -- |'HostMap's are also 'SchemeMapper's too, which matches to any
117 instance SchemeMapper HostMap where
118 {-# INLINE findHostMap #-}
119 findHostMap = const return
121 -- |'ResourceMap's are also 'SchemeMapper's too, which matches to any
122 -- schemes and hosts.
123 instance SchemeMapper ResourceMap where
124 {-# INLINE findHostMap #-}
125 findHostMap _ r = return $ hostMap f
127 f ∷ Host → Maybe ResourceMap
131 -- |@'insert' a b@ first tries @a@, and if it fails, tries @b@ next.
132 instance SchemeMapper α ⇒ Unfoldable SchemeMap α where
133 {-# INLINE insert #-}
134 insert a (SMap b) = schemeMap c
136 c ∷ Scheme → MaybeT IO HostMap
138 c s = findHostMap s a <|> findHostMap s b
141 {-# INLINE singleton #-}
142 singleton = schemeMap
144 -- |@'mappend' a b@ first tries @a@, and if it fails, tries @b@ next.
145 instance Monoid SchemeMap where
146 {-# INLINE mempty #-}
149 e ∷ Scheme → MaybeT IO HostMap
152 {-# INLINE mappend #-}
155 -- |Any 'Map's from 'Scheme' to 'HostMap' are also 'SchemeMapper's.
156 instance Map α Scheme HostMap ⇒ SchemeMapper α where
157 {-# INLINE findHostMap #-}
158 findHostMap = (maybe (fail (⊥)) return ∘) ∘ lookup
160 -- |An IO-based scheme mapper.
161 instance SchemeMapper (Scheme → MaybeT IO HostMap) where
162 {-# INLINE findHostMap #-}
163 findHostMap = flip id
165 -- |A pure scheme mapper.
166 instance SchemeMapper (Scheme → Maybe HostMap) where
167 {-# INLINE findHostMap #-}
168 findHostMap = (maybe (fail (⊥)) return ∘) ∘ flip id
171 -- Instances of HostMapper ----------------------------------------------------
172 instance HostMapper HostMap where
173 {-# INLINE findResourceMap #-}
174 findResourceMap h (HMap α) = findResourceMap h α
175 {-# INLINE hostMap #-}
178 -- |'ResourceMap's are also 'HostMapper's too, which matches to any
180 instance HostMapper ResourceMap where
181 {-# INLINE findResourceMap #-}
182 findResourceMap = const return
184 -- |@'insert' a b@ first tries @a@, and if it fails, tries @b@ next.
185 instance HostMapper α ⇒ Unfoldable HostMap α where
186 {-# INLINE insert #-}
187 insert a (HMap b) = hostMap c
189 c ∷ Host → MaybeT IO ResourceMap
191 c h = findResourceMap h a <|> findResourceMap h b
194 {-# INLINE singleton #-}
197 -- |@'mappend' a b@ first tries @a@, and if it fails, tries @b@ next.
198 instance Monoid HostMap where
199 {-# INLINE mempty #-}
202 e ∷ Host → MaybeT IO ResourceMap
205 {-# INLINE mappend #-}
208 -- |Any 'Map's from 'Host' to 'ResourceMap' are also 'HostMapper's.
209 instance Map α Host ResourceMap ⇒ HostMapper α where
210 {-# INLINE findResourceMap #-}
211 findResourceMap = (maybe (fail (⊥)) return ∘) ∘ lookup
213 -- |An IO-based host mapper.
214 instance HostMapper (Host → MaybeT IO ResourceMap) where
215 {-# INLINE findResourceMap #-}
216 findResourceMap = flip id
218 -- |A pure host mapper.
219 instance HostMapper (Host → Maybe ResourceMap) where
220 {-# INLINE findResourceMap #-}
221 findResourceMap = (maybe (fail (⊥)) return ∘) ∘ flip id
223 -- Instances of ResourceMapper ------------------------------------------------
224 instance ResourceMapper ResourceMap where
225 {-# INLINE findResource #-}
226 findResource s (RMap α) = findResource s α
227 {-# INLINE resourceMap #-}
230 -- |@'insert' a b@ first tries @a@, and if it fails, tries @b@ next.
231 instance ResourceMapper α ⇒ Unfoldable ResourceMap α where
232 {-# INLINE insert #-}
233 insert a (RMap b) = resourceMap c
235 c ∷ PathSegments → MaybeT IO (PathSegments, Resource)
237 c s = findResource s a <|> findResource s b
240 {-# INLINE singleton #-}
241 singleton = resourceMap
243 -- |@'mappend' a b@ first tries @a@, and if it fails, tries @b@ next.
244 instance Monoid ResourceMap where
245 {-# INLINE mempty #-}
246 mempty = resourceMap e
248 e ∷ PathSegments → MaybeT IO (PathSegments, Resource)
251 {-# INLINE mappend #-}
254 -- |Any 'Map's from 'PathSegments' to @('PathSegments', 'Resource')@
255 -- are also 'ResourceMapper's.
256 instance Map α PathSegments (PathSegments, Resource) ⇒ ResourceMapper α where
257 {-# INLINE findResource #-}
258 findResource = (maybe (fail (⊥)) return ∘) ∘ lookup
260 -- |An IO-based resource mapper.
261 instance ResourceMapper (PathSegments → MaybeT IO (PathSegments, Resource)) where
262 {-# INLINE findResource #-}
263 findResource = flip id
265 -- |A pure resource mapper.
266 instance ResourceMapper (PathSegments → Maybe (PathSegments, Resource)) where
267 {-# INLINE findResource #-}
268 findResource = (maybe (fail (⊥)) return ∘) ∘ flip id
270 -- Instances of ResourceTree --------------------------------------------------
271 instance Unfoldable ResourceTree (PathSegments, ResourceNode) where
272 {-# INLINEABLE insert #-}
273 insert (p, n) (Tree m) = Tree $ insert (canonPath p, n) m
276 {-# INLINE singleton #-}
277 singleton = Tree ∘ singleton
279 canonPath ∷ (Collection c f, Foldable f e) ⇒ c → c
280 {-# INLINEABLE canonPath #-}
281 canonPath = filter ((¬) ∘ null)
283 -- |'findResource' performs the longest prefix match on the tree,
284 -- finding the most specific one.
285 instance ResourceMapper ResourceTree where
286 {-# INLINEABLE findResource #-}
287 findResource p (Tree m)
289 Just n → return (p, nResource n)
290 Nothing → findGreedyResource p m
292 findGreedyResource ∷ (Monad m, Map α PathSegments ResourceNode)
295 → MaybeT m (PathSegments, Resource)
296 findGreedyResource p m
299 Just (p', _) → case lookup p' m of
302 _ → findGreedyResource p' m
304 -- dispatch -------------------------------------------------------------------
305 dispatch ∷ SchemeMapper α ⇒ URI → α → MaybeT IO (PathSegments, Resource)
307 = (findResource (uriPathSegments uri) =≪)
308 ∘ (findResourceMap (uriHost uri) =≪)
309 ∘ findHostMap (uriCIScheme uri)