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