Network/HTTP/Lucu/Resource/Dispatcher.hs

   1 {-# LANGUAGE
   2     ExistentialQuantification
   3   , FlexibleInstances
   4   , MultiParamTypeClasses
   5   , UndecidableInstances
   6   , UnicodeSyntax
   7   #-}
   8 -- |FIXME: doc
   9 module Network.HTTP.Lucu.Resource.Dispatcher
  10     ( Dispatchable(..)
  11     , Dispatcher
  12     , uriHost
  13     , uriPathSegments
  14     )
  15     where
  16 import Data.CaseInsensitive (CI)
  17 import Data.Collections
  18 import Data.Monoid
  19 import Data.Text (Text)
  20 import Network.HTTP.Lucu.Resource.Internal
  21 import Network.HTTP.Lucu.Utils
  22 import Network.URI
  23 import Prelude.Unicode
  24
  25 -- |FIXME: docs
  26 --
  27 -- Minimal complete definition: 'dispatch'
  28 class Dispatchable α where
  29     dispatch ∷ α → URI → IO (Maybe Resource)
  30
  31     dispatcher ∷ α → Dispatcher
  32     {-# INLINE dispatcher #-}
  33     dispatcher = Dispatcher
  34
  35 -- |Container type for 'Dispatchable' type class.
  36 data Dispatcher = ∀α. Dispatchable α ⇒ Dispatcher α
  37
  38 instance Dispatchable Dispatcher where
  39     dispatch (Dispatcher α) = dispatch α
  40     dispatcher = id
  41
  42 -- |@insert a b@ first tries @a@, and then tries @b@. @insertMany bs
  43 -- a@ first tries @a@, and then tries each one in @bs@ from head to
  44 -- tail.
  45 instance Dispatchable α ⇒ Unfoldable Dispatcher α where
  46     {-# INLINEABLE insert #-}
  47     insert a (Dispatcher b)
  48         = dispatcher
  49           $ \uri → do r ← dispatch a uri
  50                       case r of
  51                         Just _  → return r
  52                         Nothing → dispatch b uri
  53     {-# INLINE empty #-}
  54     empty = dispatcher e
  55         where
  56           e ∷ URI → IO (Maybe Resource)
  57           {-# INLINE e #-}
  58           e = return ∘ const Nothing
  59     {-# INLINE singleton #-}
  60     singleton = dispatcher
  61
  62 -- |@a `'mappend'` b@ first tries @a@, and then tries @b@.
  63 instance Monoid Dispatcher where
  64     {-# INLINE mempty #-}
  65     mempty = empty
  66     {-# INLINE mappend #-}
  67     mappend = insert
  68
  69 -- |An IO-based dispatcher.
  70 instance Dispatchable (URI → IO (Maybe Resource)) where
  71     dispatch = id
  72
  73 -- |A pure dispatcher.
  74 instance Dispatchable (URI → Maybe Resource) where
  75     dispatch = (return ∘)
  76
  77 -- |The constant dispatcher returning always the same 'Resource'.
  78 instance Dispatchable Resource where
  79     dispatch = const ∘ return ∘ Just
  80
  81 -- |FIXME: doc
  82 uriHost ∷ URI → CI Text
  83 uriHost = error "FIXME"