]> gitweb @ CieloNegro.org - Lucu.git/blob - Network/HTTP/Lucu/Resource/Dispatcher.hs
Rename: Resource --> Rsrc; ResourceDef --> Resource
[Lucu.git] / Network / HTTP / Lucu / Resource / Dispatcher.hs
1 {-# LANGUAGE
2     ExistentialQuantification
3   , FlexibleInstances
4   , UnicodeSyntax
5   #-}
6 -- |FIXME: doc
7 module Network.HTTP.Lucu.Resource.Dispatcher
8     ( Dispatchable(..)
9     , Dispatcher
10     )
11     where
12 import Control.Applicative
13 import Data.ByteString (ByteString)
14 import Data.CaseInsensitive (CI)
15 import Data.Monoid
16 import Data.Text (Text)
17 import Network.HTTP.Lucu.Resource.Internal
18 import Prelude.Unicode
19
20 -- |FIXME: docs
21 class Dispatchable α where
22     dispatch ∷ α
23              → CI Text
24              → [ByteString]
25              → IO (Maybe ([ByteString], Resource))
26
27     dispatcher ∷ α → Dispatcher
28     {-# INLINE dispatcher #-}
29     dispatcher = Dispatcher
30
31 -- |Container type for 'Dispatchable' type class.
32 data Dispatcher = ∀α. Dispatchable α ⇒ Dispatcher α
33
34 instance Dispatchable Dispatcher where
35     dispatch (Dispatcher α) = dispatch α
36     dispatcher = id
37
38 -- |@a `'mappend'` b@ first tries to find a resource with @a@, and if
39 -- it returns 'Nothing', tries @b@ next.
40 instance Monoid Dispatcher where
41     {-# INLINE mempty #-}
42     mempty = dispatcher ()
43
44     {-# INLINEABLE mappend #-}
45     mappend (Dispatcher α) (Dispatcher β)
46         = dispatcher
47           $ \host path → do r ← dispatch α host path
48                             case r of
49                               Just _  → return r
50                               Nothing → dispatch β host path
51
52 -- |An IO-based dispatcher returning resource paths as well as
53 -- 'Resource's.
54 instance Dispatchable (CI Text
55                        → [ByteString]
56                        → IO (Maybe ([ByteString], Resource))) where
57     dispatch = id
58
59 -- |An IO-based dispatcher.
60 instance Dispatchable (CI Text → [ByteString] → IO (Maybe Resource)) where
61     dispatch = ((((<$>) ∘ (<$>)) ((,) []) ∘) ∘)
62
63 -- |A pure dispatcher.
64 instance Dispatchable (CI Text → [ByteString] → Maybe Resource) where
65     dispatch = (((return ∘ ((,) [] <$>)) ∘) ∘)
66
67 -- |An IO-based dispatcher ignoring host names.
68 instance Dispatchable ([ByteString] → IO (Maybe Resource)) where
69     dispatch = const ∘ (((<$>) ∘ (<$>)) ((,) []) ∘)
70
71 -- |A pure dispatcher ignoring host names.
72 instance Dispatchable ([ByteString] → Maybe Resource) where
73     dispatch = const ∘ ((return ∘ ((,) [] <$>)) ∘)
74
75 -- |The constant dispatcher returning always the same 'Resource'.
76 instance Dispatchable Resource where
77     dispatch = const ∘ const ∘ return ∘ Just ∘ (,) []
78
79 -- |The empty dispatcher returning always 'Nothing'.
80 instance Dispatchable () where
81     dispatch _ _ _ = return Nothing