]> gitweb @ CieloNegro.org - Lucu.git/blob - Network/HTTP/Lucu/Dispatcher/Internal.hs
docs
[Lucu.git] / Network / HTTP / Lucu / Dispatcher / Internal.hs
1 {-# LANGUAGE
2     ExistentialQuantification
3   , FlexibleContexts
4   , FlexibleInstances
5   , GeneralizedNewtypeDeriving
6   , OverlappingInstances
7   , MultiParamTypeClasses
8   , TemplateHaskell
9   , UndecidableInstances
10   , UnicodeSyntax
11   #-}
12 module Network.HTTP.Lucu.Dispatcher.Internal
13     ( HostMapper(..)
14     , HostMap
15     , ResourceMapper(..)
16     , ResourceMap
17     , ResourceTree
18     , ResourceNode
19     , greedy
20     , nonGreedy
21
22     , dispatch
23     )
24     where
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
31 import Data.Monoid
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
38
39 -- |Class of maps from 'Host' to 'ResourceMap' to provide name-based
40 -- virtual hosts.
41 --
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>).
49 --
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
55     -- container.
56     hostMap ∷ α → HostMap
57     {-# INLINE hostMap #-}
58     hostMap = HMap
59
60 -- |Container type for the 'HostMapper' type class.
61 data HostMap = ∀α. HostMapper α ⇒ HMap α
62
63 -- |Class of maps from resource 'Path' to 'Resource'.
64 --
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 #-}
77     resourceMap = RMap
78
79 -- |Container type for the 'ResourceMapper' type class.
80 data ResourceMap = ∀α. ResourceMapper α ⇒ RMap α
81
82 -- |'ResourceTree' is an opaque structure which is a map from resource
83 -- path to 'Resource'.
84 --
85 -- @
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
88 --            ]
89 -- @
90 --
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)
97     deriving Monoid
98
99 -- |FIXME: doc
100 data ResourceNode
101     = Greedy    { nResource ∷ !Resource }
102     | NonGreedy { nResource ∷ !Resource }
103
104 -- |Make a greedy resource node.
105 --
106 -- Say a client is trying to access \"\/aaa\/bbb\/ccc\' while there is
107 -- no resource node at the path. If there are greedy resource nodes at
108 -- \"\/aaa\/bbb\", \"\/aaa\" or \"/\" they will be chosen instead as a
109 -- fallback. Greedy resource nodes are searched in depth-first order.
110 greedy ∷ Resource → ResourceNode
111 {-# INLINE CONLIKE greedy #-}
112 greedy = Greedy
113
114 -- |FIXME: doc
115 nonGreedy ∷ Resource → ResourceNode
116 {-# INLINE CONLIKE nonGreedy #-}
117 nonGreedy = NonGreedy
118
119
120 -- Instances of HostMapper ----------------------------------------------------
121 instance HostMapper HostMap where
122     {-# INLINE findResourceMap #-}
123     findResourceMap h (HMap α) = findResourceMap h α
124     {-# INLINE hostMap #-}
125     hostMap = id
126
127 -- |'ResourceMap's are also 'HostMapper's too, which matches to any
128 -- hosts.
129 instance HostMapper ResourceMap where
130     {-# INLINE findResourceMap #-}
131     findResourceMap = const return
132
133 -- |@'insert' a b@ first tries @a@, and if it fails, tries @b@ next.
134 instance HostMapper α ⇒ Unfoldable HostMap α where
135     {-# INLINE insert #-}
136     insert a (HMap b) = hostMap c
137         where
138           c ∷ Host → MaybeT IO ResourceMap
139           {-# INLINEABLE c #-}
140           c h = findResourceMap h a <|> findResourceMap h b
141     {-# INLINE empty #-}
142     empty = (∅)
143     {-# INLINE singleton #-}
144     singleton = hostMap
145
146 -- |@'mappend' a b@ first tries @a@, and if it fails, tries @b@ next.
147 instance Monoid HostMap where
148     {-# INLINE mempty #-}
149     mempty = hostMap e
150         where
151           e ∷ Host → MaybeT IO ResourceMap
152           {-# INLINE e #-}
153           e = const (fail (⊥))
154     {-# INLINE mappend #-}
155     mappend = insert
156
157 -- |Any 'Map's from 'Host' to 'ResourceMap' are also 'HostMapper's.
158 instance Map α Host ResourceMap ⇒ HostMapper α where
159     {-# INLINE findResourceMap #-}
160     findResourceMap = (maybe (fail (⊥)) return ∘) ∘ lookup
161
162 -- |An IO-based host mapper.
163 instance HostMapper (Host → MaybeT IO ResourceMap) where
164     {-# INLINE findResourceMap #-}
165     findResourceMap = flip id
166
167 -- |A pure host mapper.
168 instance HostMapper (Host → Maybe ResourceMap) where
169     {-# INLINE findResourceMap #-}
170     findResourceMap = (maybe (fail (⊥)) return ∘) ∘ flip id
171
172 -- Instances of ResourceMapper ------------------------------------------------
173 instance ResourceMapper ResourceMap where
174     {-# INLINE findResource #-}
175     findResource s (RMap α) = findResource s α
176     {-# INLINE resourceMap #-}
177     resourceMap = id
178
179 -- |@'insert' a b@ first tries @a@, and if it fails, tries @b@ next.
180 instance ResourceMapper α ⇒ Unfoldable ResourceMap α where
181     {-# INLINE insert #-}
182     insert a (RMap b) = resourceMap c
183         where
184           c ∷ Path → MaybeT IO (Path, Resource)
185           {-# INLINEABLE c #-}
186           c s = findResource s a <|> findResource s b
187     {-# INLINE empty #-}
188     empty = (∅)
189     {-# INLINE singleton #-}
190     singleton = resourceMap
191
192 -- |@'mappend' a b@ first tries @a@, and if it fails, tries @b@ next.
193 instance Monoid ResourceMap where
194     {-# INLINE mempty #-}
195     mempty = resourceMap e
196         where
197           e ∷ Path → MaybeT IO (Path, Resource)
198           {-# INLINE e #-}
199           e = const (fail (⊥))
200     {-# INLINE mappend #-}
201     mappend = insert
202
203 -- |Any 'Map's from 'Path' to @('Path', 'Resource')@ are also
204 -- 'ResourceMapper's.
205 instance Map α Path (Path, Resource) ⇒ ResourceMapper α where
206     {-# INLINE findResource #-}
207     findResource = (maybe (fail (⊥)) return ∘) ∘ lookup
208
209 -- |An IO-based resource mapper.
210 instance ResourceMapper (Path → MaybeT IO (Path, Resource)) where
211     {-# INLINE findResource #-}
212     findResource = flip id
213
214 -- |A pure resource mapper.
215 instance ResourceMapper (Path → Maybe (Path, Resource)) where
216     {-# INLINE findResource #-}
217     findResource = (maybe (fail (⊥)) return ∘) ∘ flip id
218
219 -- Instances of ResourceTree --------------------------------------------------
220 instance Unfoldable ResourceTree (Path, ResourceNode) where
221     {-# INLINEABLE insert #-}
222     insert (p, n) (Tree m) = Tree $ insert (canonPath p, n) m
223     {-# INLINE empty #-}
224     empty = Tree (∅)
225     {-# INLINE singleton #-}
226     singleton = Tree ∘ singleton
227
228 canonPath ∷ (Collection c f, Foldable f e) ⇒ c → c
229 {-# INLINEABLE canonPath #-}
230 canonPath = filter ((¬) ∘ null)
231
232 C.derive [d| instance Foldable ResourceTree (Path, ResourceNode)
233            |]
234
235 instance Collection ResourceTree (Path, ResourceNode) where
236     {-# INLINE filter #-}
237     filter f (Tree m) = Tree $ filter f m
238
239 -- |'findResource' performs the longest prefix match on the tree,
240 -- finding the most specific one.
241 instance ResourceMapper ResourceTree where
242     {-# INLINEABLE findResource #-}
243     findResource p (Tree m)
244         = case lookup p m of
245             Just n  → return (p, nResource n)
246             Nothing → findGreedyResource p m
247
248 findGreedyResource ∷ (Monad m, Map α Path ResourceNode)
249                    ⇒ Path
250                    → α
251                    → MaybeT m (Path, Resource)
252 findGreedyResource p m
253     = case back p of
254         Nothing      → fail (⊥)
255         Just (p', _) → case lookup p' m of
256                           Just (Greedy r)
257                               → return (p', r)
258                           _   → findGreedyResource p' m
259
260 -- dispatch -------------------------------------------------------------------
261 dispatch ∷ HostMapper α ⇒ URI → α → MaybeT IO (Path, Resource)
262 dispatch uri
263     = (findResource (uriPathSegments uri) =≪)
264       ∘ findResourceMap (uriHost uri)