2 ExistentialQuantification
5 , GeneralizedNewtypeDeriving
7 , 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.Collections.Newtype.TH as C
30 import qualified Data.Map as M
32 import Data.Monoid.Unicode
33 import Network.HTTP.Lucu.Resource.Internal
34 import Network.HTTP.Lucu.Utils
35 import Network.URI hiding (path)
36 import Prelude hiding (filter, foldr, lookup, null)
37 import Prelude.Unicode
39 -- |Class of maps from 'Host' to 'ResourceMap' to provide name-based
42 -- Note that Lucu currently does not implement neither RFC 2817
43 -- connection upgrading (<http://tools.ietf.org/html/rfc2817>) nor RFC
44 -- 3546 server name indication
45 -- (<http://tools.ietf.org/html/rfc3546#section-3.1>) so you won't be
46 -- able to host more than one SSL virtual host on the same port
47 -- without using wildcard certificates
48 -- (<http://tools.ietf.org/html/rfc2818#section-3.1>).
50 -- Minimal complete definition: 'findResourceMap'
51 class HostMapper α where
52 -- |Find a repository of resources for the given host name if any.
53 findResourceMap ∷ Host → α → MaybeT IO ResourceMap
54 -- |Wrap an instance of 'HostMapper' in a monoidal, homogeneous
57 {-# INLINE hostMap #-}
60 -- |Container type for the 'HostMapper' type class.
61 data HostMap = ∀α. HostMapper α ⇒ HMap α
63 -- |Class of maps from resource 'Path' to 'Resource'.
65 -- Minimal complete definition: 'findResource'
66 class ResourceMapper α where
67 -- |Find a resource handler for the given resource path, along
68 -- with the path where the said handler was found. The found path
69 -- is usually the same as the queried path, but there are
70 -- situations where the found path is just a prefix of the queried
71 -- path. See 'greedy'.
72 findResource ∷ Path → α → MaybeT IO (Path, Resource)
73 -- |Wrap an instance of 'ResourceMapper' in a monoidal,
74 -- homogeneous container.
75 resourceMap ∷ α → ResourceMap
76 {-# INLINE resourceMap #-}
79 -- |Container type for the 'ResourceMapper' type class.
80 data ResourceMap = ∀α. ResourceMapper α ⇒ RMap α
82 -- |'ResourceTree' is an opaque structure which a map from resource
83 -- 'Path' to 'ResourceNode'.
86 -- 'fromList' [ ([] , 'nonGreedy' '$' 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/
87 -- , ([\"unistd\"], 'nonGreedy' '$' 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd
91 -- Note that path segments are always represented as octet streams in
92 -- this system. Lucu automatically decodes percent-encoded URIs but
93 -- has no involvement in character encodings such as UTF-8, since RFC
94 -- 2616 (HTTP/1.1) says nothing about character encodings to be used
95 -- in \"http\" and \"https\" URI schemas.
96 newtype ResourceTree = Tree (M.Map Path ResourceNode)
99 -- |A node of 'Resource' located somewhere in a 'ResourceTree'. Such
100 -- nodes are either 'greedy' or 'nonGreedy'.
102 = Greedy { nResource ∷ !Resource }
103 | NonGreedy { nResource ∷ !Resource }
105 -- |Make a greedy resource node.
107 -- Say a client is trying to access \"\/aaa\/bbb\/ccc\' while there is
108 -- no resource node at the path. If there are greedy resource nodes at
109 -- \"\/aaa\/bbb\", \"\/aaa\" or \"/\" they will be chosen instead as a
110 -- fallback. Greedy resource nodes are searched in depth-first
111 -- order, just like CGI scripts.
112 greedy ∷ Resource → ResourceNode
113 {-# INLINE CONLIKE greedy #-}
116 -- |Make a normal, non-greedy resource node.
117 nonGreedy ∷ Resource → ResourceNode
118 {-# INLINE CONLIKE nonGreedy #-}
119 nonGreedy = NonGreedy
122 -- Instances of HostMapper ----------------------------------------------------
123 instance HostMapper HostMap where
124 {-# INLINE findResourceMap #-}
125 findResourceMap h (HMap α) = findResourceMap h α
126 {-# INLINE hostMap #-}
129 -- |'ResourceMap's are also 'HostMapper's too, which matches to any
131 instance HostMapper ResourceMap where
132 {-# INLINE findResourceMap #-}
133 findResourceMap = const return
135 -- |@'insert' a b@ first tries @a@, and if it fails, tries @b@ next.
136 instance HostMapper α ⇒ Unfoldable HostMap α where
137 {-# INLINE insert #-}
138 insert a (HMap b) = hostMap c
140 c ∷ Host → MaybeT IO ResourceMap
142 c h = findResourceMap h a <|> findResourceMap h b
145 {-# INLINE singleton #-}
148 -- |@'mappend' a b@ first tries @a@, and if it fails, tries @b@ next.
149 instance Monoid HostMap where
150 {-# INLINE mempty #-}
153 e ∷ Host → MaybeT IO ResourceMap
156 {-# INLINE mappend #-}
159 -- |Any 'Map's from 'Host' to 'ResourceMap' are also 'HostMapper's.
160 instance Map α Host ResourceMap ⇒ HostMapper α where
161 {-# INLINE findResourceMap #-}
162 findResourceMap = (maybe (fail (⊥)) return ∘) ∘ lookup
164 -- |An IO-based host mapper.
165 instance HostMapper (Host → MaybeT IO ResourceMap) where
166 {-# INLINE findResourceMap #-}
167 findResourceMap = flip id
169 -- |A pure host mapper.
170 instance HostMapper (Host → Maybe ResourceMap) where
171 {-# INLINE findResourceMap #-}
172 findResourceMap = (maybe (fail (⊥)) return ∘) ∘ flip id
174 -- Instances of ResourceMapper ------------------------------------------------
175 instance ResourceMapper ResourceMap where
176 {-# INLINE findResource #-}
177 findResource s (RMap α) = findResource s α
178 {-# INLINE resourceMap #-}
181 -- |@'insert' a b@ first tries @a@, and if it fails, tries @b@ next.
182 instance ResourceMapper α ⇒ Unfoldable ResourceMap α where
183 {-# INLINE insert #-}
184 insert a (RMap b) = resourceMap c
186 c ∷ Path → MaybeT IO (Path, Resource)
188 c s = findResource s a <|> findResource s b
191 {-# INLINE singleton #-}
192 singleton = resourceMap
194 -- |@'mappend' a b@ first tries @a@, and if it fails, tries @b@ next.
195 instance Monoid ResourceMap where
196 {-# INLINE mempty #-}
197 mempty = resourceMap e
199 e ∷ Path → MaybeT IO (Path, Resource)
202 {-# INLINE mappend #-}
205 -- |Any 'Map's from 'Path' to @('Path', 'Resource')@ are also
206 -- 'ResourceMapper's.
207 instance Map α Path (Path, Resource) ⇒ ResourceMapper α where
208 {-# INLINE findResource #-}
209 findResource = (maybe (fail (⊥)) return ∘) ∘ lookup
211 -- |An IO-based resource mapper.
212 instance ResourceMapper (Path → MaybeT IO (Path, Resource)) where
213 {-# INLINE findResource #-}
214 findResource = flip id
216 -- |A pure resource mapper.
217 instance ResourceMapper (Path → Maybe (Path, Resource)) where
218 {-# INLINE findResource #-}
219 findResource = (maybe (fail (⊥)) return ∘) ∘ flip id
221 -- Instances of ResourceTree --------------------------------------------------
222 instance Unfoldable ResourceTree (Path, ResourceNode) where
223 {-# INLINEABLE insert #-}
224 insert (p, n) (Tree m) = Tree $ insert (canonPath p, n) m
227 {-# INLINE singleton #-}
228 singleton = Tree ∘ singleton
230 canonPath ∷ (Collection c f, Foldable f e) ⇒ c → c
231 {-# INLINEABLE canonPath #-}
232 canonPath = filter ((¬) ∘ null)
234 C.derive [d| instance Foldable ResourceTree (Path, ResourceNode)
237 instance Collection ResourceTree (Path, ResourceNode) where
238 {-# INLINE filter #-}
239 filter f (Tree m) = Tree $ filter f m
241 -- |'findResource' performs the longest prefix match on the tree,
242 -- finding the most specific one.
243 instance ResourceMapper ResourceTree where
244 {-# INLINEABLE findResource #-}
245 findResource p (Tree m)
247 Just n → return (p, nResource n)
248 Nothing → findGreedyResource p m
250 findGreedyResource ∷ (Monad m, Map α Path ResourceNode)
253 → MaybeT m (Path, Resource)
254 findGreedyResource p m
257 Just (p', _) → case lookup p' m of
260 _ → findGreedyResource p' m
262 -- dispatch -------------------------------------------------------------------
263 dispatch ∷ HostMapper α ⇒ URI → α → MaybeT IO (Path, Resource)
265 = (findResource (uriPathSegments uri) =≪)
266 ∘ findResourceMap (uriHost uri)