]> gitweb @ CieloNegro.org - Lucu.git/blob - Network/HTTP/Lucu/Dispatcher/Internal.hs
Simplify the implementation of ResourceTree
[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     ( SchemeMapper(..)
14     , SchemeMap
15     , HostMapper(..)
16     , HostMap
17     , ResourceMapper(..)
18     , ResourceMap
19     , ResourceTree
20     , ResourceNode
21     , greedy
22     , nonGreedy
23
24     , dispatch
25     )
26     where
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
32 import Data.Monoid
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
39
40 -- |FIXME: docs
41 --
42 -- Minimal complete definition: 'findHostMap'
43 class SchemeMapper α where
44     findHostMap ∷ Scheme → α → MaybeT IO HostMap
45     schemeMap   ∷ α → SchemeMap
46     {-# INLINE schemeMap #-}
47     schemeMap   = SMap
48
49 -- |Container type for the 'SchemeMapper' type class.
50 data SchemeMap = ∀α. SchemeMapper α ⇒ SMap α
51
52 -- |FIXME: docs
53 --
54 -- Minimal complete definition: 'findResourceMap'
55 class HostMapper α where
56     findResourceMap ∷ Host → α → MaybeT IO ResourceMap
57     hostMap ∷ α → HostMap
58     {-# INLINE hostMap #-}
59     hostMap = HMap
60
61 -- |Container type for the 'HostMapper' type class.
62 data HostMap = ∀α. HostMapper α ⇒ HMap α
63
64 -- |FIXME: docs
65 --
66 -- Minimal complete definition: 'findResource'
67 class ResourceMapper α where
68     findResource ∷ PathSegments → α → MaybeT IO (PathSegments, Resource)
69     resourceMap  ∷ α → ResourceMap
70     {-# INLINE resourceMap #-}
71     resourceMap = RMap
72
73 -- |Container type for the 'ResourceMapper' type class.
74 data ResourceMap = ∀α. ResourceMapper α ⇒ RMap α
75
76 -- |FIXME: doc
77 newtype ResourceTree = Tree (M.Map PathSegments ResourceNode)
78     deriving Monoid
79
80 -- |FIXME: doc
81 data ResourceNode
82     = Greedy    { nResource ∷ !Resource }
83     | NonGreedy { nResource ∷ !Resource }
84
85 -- |FIXME: doc
86 greedy ∷ Resource → ResourceNode
87 {-# INLINE CONLIKE greedy #-}
88 greedy = Greedy
89
90 -- |FIXME: doc
91 nonGreedy ∷ Resource → ResourceNode
92 {-# INLINE CONLIKE nonGreedy #-}
93 nonGreedy = NonGreedy
94
95 -- Instances of SchemeMapper --------------------------------------------------
96 instance SchemeMapper SchemeMap where
97     {-# INLINE findHostMap #-}
98     findHostMap s (SMap α) = findHostMap s α
99     {-# INLINE schemeMap #-}
100     schemeMap = id
101
102 -- |'HostMap's are also 'SchemeMapper's too, which matches to any
103 -- schemes.
104 instance SchemeMapper HostMap where
105     {-# INLINE findHostMap #-}
106     findHostMap = const return
107
108 -- |'ResourceMap's are also 'SchemeMapper's too, which matches to any
109 -- schemes and hosts.
110 instance SchemeMapper ResourceMap where
111     {-# INLINE findHostMap #-}
112     findHostMap _ r = return $ hostMap f
113         where
114           f ∷ Host → Maybe ResourceMap
115           {-# INLINE f #-}
116           f = const $ Just r
117
118 -- |@'insert' a b@ first tries @a@, and if it fails, tries @b@ next.
119 instance SchemeMapper α ⇒ Unfoldable SchemeMap α where
120     {-# INLINE insert #-}
121     insert a (SMap b) = schemeMap c
122         where
123           c ∷ Scheme → MaybeT IO HostMap
124           {-# INLINEABLE c #-}
125           c s = findHostMap s a <|> findHostMap s b
126     {-# INLINE empty #-}
127     empty = (∅)
128     {-# INLINE singleton #-}
129     singleton = schemeMap
130
131 -- |@'mappend' a b@ first tries @a@, and if it fails, tries @b@ next.
132 instance Monoid SchemeMap where
133     {-# INLINE mempty #-}
134     mempty = schemeMap e
135         where
136           e ∷ Scheme → MaybeT IO HostMap
137           {-# INLINE e #-}
138           e = const (fail (⊥))
139     {-# INLINE mappend #-}
140     mappend = insert
141
142 -- |Any 'Map's from 'Scheme' to 'HostMap' are also 'SchemeMapper's.
143 instance Map α Scheme HostMap ⇒ SchemeMapper α where
144     {-# INLINE findHostMap #-}
145     findHostMap = (maybe (fail (⊥)) return ∘) ∘ lookup
146
147 -- |An IO-based scheme mapper.
148 instance SchemeMapper (Scheme → MaybeT IO HostMap) where
149     {-# INLINE findHostMap #-}
150     findHostMap = flip id
151
152 -- |A pure scheme mapper.
153 instance SchemeMapper (Scheme → Maybe HostMap) where
154     {-# INLINE findHostMap #-}
155     findHostMap = (maybe (fail (⊥)) return ∘) ∘ flip id
156
157
158 -- Instances of HostMapper ----------------------------------------------------
159 instance HostMapper HostMap where
160     {-# INLINE findResourceMap #-}
161     findResourceMap h (HMap α) = findResourceMap h α
162     {-# INLINE hostMap #-}
163     hostMap = id
164
165 -- |'ResourceMap's are also 'HostMapper's too, which matches to any
166 -- hosts.
167 instance HostMapper ResourceMap where
168     {-# INLINE findResourceMap #-}
169     findResourceMap = const return
170
171 -- |@'insert' a b@ first tries @a@, and if it fails, tries @b@ next.
172 instance HostMapper α ⇒ Unfoldable HostMap α where
173     {-# INLINE insert #-}
174     insert a (HMap b) = hostMap c
175         where
176           c ∷ Host → MaybeT IO ResourceMap
177           {-# INLINEABLE c #-}
178           c h = findResourceMap h a <|> findResourceMap h b
179     {-# INLINE empty #-}
180     empty = (∅)
181     {-# INLINE singleton #-}
182     singleton = hostMap
183
184 -- |@'mappend' a b@ first tries @a@, and if it fails, tries @b@ next.
185 instance Monoid HostMap where
186     {-# INLINE mempty #-}
187     mempty = hostMap e
188         where
189           e ∷ Host → MaybeT IO ResourceMap
190           {-# INLINE e #-}
191           e = const (fail (⊥))
192     {-# INLINE mappend #-}
193     mappend = insert
194
195 -- |Any 'Map's from 'Host' to 'ResourceMap' are also 'HostMapper's.
196 instance Map α Host ResourceMap ⇒ HostMapper α where
197     {-# INLINE findResourceMap #-}
198     findResourceMap = (maybe (fail (⊥)) return ∘) ∘ lookup
199
200 -- |An IO-based host mapper.
201 instance HostMapper (Host → MaybeT IO ResourceMap) where
202     {-# INLINE findResourceMap #-}
203     findResourceMap = flip id
204
205 -- |A pure host mapper.
206 instance HostMapper (Host → Maybe ResourceMap) where
207     {-# INLINE findResourceMap #-}
208     findResourceMap = (maybe (fail (⊥)) return ∘) ∘ flip id
209
210 -- Instances of ResourceMapper ------------------------------------------------
211 instance ResourceMapper ResourceMap where
212     {-# INLINE findResource #-}
213     findResource s (RMap α) = findResource s α
214     {-# INLINE resourceMap #-}
215     resourceMap = id
216
217 -- |@'insert' a b@ first tries @a@, and if it fails, tries @b@ next.
218 instance ResourceMapper α ⇒ Unfoldable ResourceMap α where
219     {-# INLINE insert #-}
220     insert a (RMap b) = resourceMap c
221         where
222           c ∷ PathSegments → MaybeT IO (PathSegments, Resource)
223           {-# INLINEABLE c #-}
224           c s = findResource s a <|> findResource s b
225     {-# INLINE empty #-}
226     empty = (∅)
227     {-# INLINE singleton #-}
228     singleton = resourceMap
229
230 -- |@'mappend' a b@ first tries @a@, and if it fails, tries @b@ next.
231 instance Monoid ResourceMap where
232     {-# INLINE mempty #-}
233     mempty = resourceMap e
234         where
235           e ∷ PathSegments → MaybeT IO (PathSegments, Resource)
236           {-# INLINE e #-}
237           e = const (fail (⊥))
238     {-# INLINE mappend #-}
239     mappend = insert
240
241 -- |Any 'Map's from 'PathSegments' to @('PathSegments', 'Resource')@
242 -- are also 'ResourceMapper's.
243 instance Map α PathSegments (PathSegments, Resource) ⇒ ResourceMapper α where
244     {-# INLINE findResource #-}
245     findResource = (maybe (fail (⊥)) return ∘) ∘ lookup
246
247 -- |An IO-based resource mapper.
248 instance ResourceMapper (PathSegments → MaybeT IO (PathSegments, Resource)) where
249     {-# INLINE findResource #-}
250     findResource = flip id
251
252 -- |A pure resource mapper.
253 instance ResourceMapper (PathSegments → Maybe (PathSegments, Resource)) where
254     {-# INLINE findResource #-}
255     findResource = (maybe (fail (⊥)) return ∘) ∘ flip id
256
257 -- Instances of ResourceTree --------------------------------------------------
258 instance Unfoldable ResourceTree (PathSegments, ResourceNode) where
259     {-# INLINEABLE insert #-}
260     insert (p, n) (Tree m) = Tree $ insert (canonPath p, n) m
261     {-# INLINE empty #-}
262     empty = Tree (∅)
263     {-# INLINE singleton #-}
264     singleton = Tree ∘ singleton
265
266 canonPath ∷ (Collection c f, Foldable f e) ⇒ c → c
267 {-# INLINEABLE canonPath #-}
268 canonPath = filter ((¬) ∘ null)
269
270 -- |'findResource' performs the longest prefix match on the tree,
271 -- finding the most specific one.
272 instance ResourceMapper ResourceTree where
273     {-# INLINEABLE findResource #-}
274     findResource p (Tree m)
275         = case lookup p m of
276             Just n  → return (p, nResource n)
277             Nothing → findGreedyResource p m
278
279 findGreedyResource ∷ (Monad m, Map α PathSegments ResourceNode)
280                    ⇒ PathSegments
281                    → α
282                    → MaybeT m (PathSegments, Resource)
283 findGreedyResource p m
284     = case back p of
285         Nothing      → fail (⊥)
286         Just (p', _) → case lookup p' m of
287                           Just (Greedy r)
288                               → return (p', r)
289                           _   → findGreedyResource p' m
290
291 -- dispatch -------------------------------------------------------------------
292 dispatch ∷ SchemeMapper α ⇒ URI → α → MaybeT IO (PathSegments, Resource)
293 dispatch uri
294     = (findResource (uriPathSegments uri) =≪)
295       ∘ (findResourceMap (uriHost uri) =≪)
296       ∘ findHostMap (uriCIScheme uri)
297
298 {-
299 -- |'ResTree' is an opaque structure which is a map from resource path
300 -- to 'Resource'.
301 newtype ResTree = ResTree ResNode -- root だから Map ではない
302 type ResSubtree = Map ByteString ResNode
303 data ResNode    = ResNode (Maybe Resource) ResSubtree
304
305 -- |'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g.
306 --
307 -- @
308 --   mkResTree [ ([]        , 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/
309 --             , ([\"unistd\"], 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd
310 --             ]
311 -- @
312 --
313 -- Note that path components are always represented as octet streams
314 -- in this system. Lucu automatically decodes percent-encoded URIs but
315 -- has no involvement in character encodings such as UTF-8, since RFC
316 -- 2616 (HTTP/1.1) says nothing about character encodings to be used
317 -- in \"http\" and \"https\" URI schemas.
318 mkResTree ∷ [ ([ByteString], Resource) ] → ResTree
319 mkResTree = processRoot ∘ map (first canonicalisePath)
320     where
321       canonicalisePath ∷ [ByteString] → [ByteString]
322       canonicalisePath = filter ((¬) ∘ BS.null)
323
324       processRoot ∷ [ ([ByteString], Resource) ] → ResTree
325       processRoot list
326           = let (roots, nonRoots) = partition (\(path, _) → null path) list
327                 children = processNonRoot nonRoots
328             in
329               if null roots then
330                   -- The root has no resources. Maybe there's one at
331                   -- somewhere like "/foo".
332                   ResTree (ResNode Nothing children)
333               else
334                   -- There is a root resource.
335                   let (_, def) = last roots
336                   in 
337                     ResTree (ResNode (Just def) children)
338
339       processNonRoot ∷ [ ([ByteString], Resource) ] → ResSubtree
340       processNonRoot list
341           = let subtree    = M.fromList [(name, node name)
342                                              | name ← childNames]
343                 childNames = [name | (name:_, _) ← list]
344                 node name  = let defs = [def | (path, def) ← list, path ≡ [name]]
345                              in
346                                if null defs then
347                                    -- No resources are defined
348                                    -- here. Maybe there's one at
349                                    -- somewhere below this node.
350                                    ResNode Nothing children
351                                else
352                                    -- There is a resource here.
353                                    ResNode (Just $ last defs) children
354                 children   = processNonRoot [(path, def)
355                                                  | (_:path, def) ← list]
356             in
357               subtree
358 -}