Network/HTTP/Lucu/Router.hs

   1 {-# LANGUAGE
   2     Arrows
   3   , GeneralizedNewtypeDeriving
   4   , OverloadedStrings
   5   , TypeOperators
   6   , UnicodeSyntax
   7   #-}
   8 -- |FIXME: doc
   9 module Network.HTTP.Lucu.Router
  10     ( -- * The 'Router' arrow
  11       Router
  12     , runRouter
  13
  14       -- * Testing for URI scheme
  15     , anyScheme
  16     , scheme
  17     , http
  18     , http'
  19     , https
  20     )
  21     where
  22 import Control.Applicative
  23 import Control.Category
  24 import Control.Arrow
  25 import Control.Arrow.ArrowKleisli
  26 import Control.Arrow.List
  27 import Control.Monad.IO.Class
  28 import Data.Ascii (CIAscii)
  29 import Data.Maybe
  30 import Network.URI hiding (scheme)
  31 import Network.HTTP.Lucu.Utils
  32 import Prelude.Unicode
  33
  34 -- |FIXME: doc
  35 newtype Router m α β
  36     = Router {
  37         unRouter ∷ ListTArrow m α β
  38       }
  39     deriving ( Arrow
  40              , ArrowKleisli m
  41              , ArrowZero
  42              , ArrowPlus
  43              , ArrowChoice
  44              , ArrowApply
  45              , Category
  46              )
  47
  48 -- |FIXME: doc
  49 runRouter ∷ (Applicative m, MonadIO m) ⇒ Router m α β → α → m (Maybe β)
  50 {-# INLINE runRouter #-}
  51 runRouter = ((listToMaybe <$>) ∘) ∘ runListTArrow ∘ unRouter
  52
  53 -- |FIXME: doc
  54 anyScheme ∷ Arrow (⇝) ⇒ URI ⇝ (Host, Path)
  55 {-# INLINEABLE anyScheme #-}
  56 anyScheme = arr uriHost &&& arr uriPathSegments
  57
  58 -- |FIXME: doc
  59 scheme ∷ (ArrowChoice (⇝), ArrowZero (⇝)) ⇒ CIAscii → URI ⇝ (Host, Path)
  60 {-# INLINEABLE scheme #-}
  61 scheme s
  62     = proc uri →
  63       if s ≡ uriCIScheme uri then
  64           anyScheme ⤙ uri
  65       else
  66           zeroArrow ⤙ (⊥)
  67
  68 -- |@'http' = 'scheme' \"http\" '<+>' 'scheme' \"https\"@
  69 http ∷ (ArrowChoice (⇝), ArrowPlus (⇝), ArrowZero (⇝)) ⇒ URI ⇝ (Host, Path)
  70 {-# INLINE http #-}
  71 http = scheme "http" <+> scheme "https"
  72
  73 -- |@'http'' = 'scheme' \"http\"@
  74 http' ∷ (ArrowChoice (⇝), ArrowZero (⇝)) ⇒ URI ⇝ (Host, Path)
  75 http' = scheme "http"
  76
  77 -- |@'https' = 'scheme' \"https\"@
  78 https ∷ (ArrowChoice (⇝), ArrowZero (⇝)) ⇒ URI ⇝ (Host, Path)
  79 https = scheme "https"