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     , schemeWith
  17     , scheme
  18     , http
  19     , http'
  20     , https
  21     )
  22     where
  23 import Control.Applicative
  24 import Control.Category
  25 import Control.Arrow
  26 import Control.Arrow.ArrowKleisli
  27 import Control.Arrow.List
  28 import Control.Monad.IO.Class
  29 import Data.Ascii (CIAscii)
  30 import Data.Maybe
  31 import Network.URI hiding (scheme)
  32 import Network.HTTP.Lucu.Utils
  33 import Prelude.Unicode
  34
  35 -- |FIXME: doc
  36 newtype Router m α β
  37     = Router {
  38         unRouter ∷ ListTArrow m α β
  39       }
  40     deriving ( Arrow
  41              , ArrowKleisli m
  42              , ArrowZero
  43              , ArrowPlus
  44              , ArrowChoice
  45              , ArrowApply
  46              , Category
  47              )
  48
  49 -- |FIXME: doc
  50 runRouter ∷ (Applicative m, MonadIO m) ⇒ Router m α β → α → m (Maybe β)
  51 {-# INLINE runRouter #-}
  52 runRouter = ((listToMaybe <$>) ∘) ∘ runListTArrow ∘ unRouter
  53
  54 -- |FIXME: doc
  55 anyScheme ∷ Arrow (⇝) ⇒ URI ⇝ (Host, Path)
  56 {-# INLINEABLE anyScheme #-}
  57 anyScheme = arr uriHost &&& arr uriPathSegments
  58
  59 -- |FIXME: doc
  60 schemeWith ∷ (ArrowChoice (⇝), ArrowZero (⇝))
  61            ⇒ (CIAscii → Bool)
  62            → URI ⇝ (Host, Path)
  63 {-# INLINEABLE schemeWith #-}
  64 schemeWith f
  65     = proc uri →
  66       if f (uriCIScheme uri) then
  67           anyScheme ⤙ uri
  68       else
  69           zeroArrow ⤙ (⊥)
  70
  71 -- |@'scheme' s@ = @'schemeWith' ('==' s)@
  72 scheme ∷ (ArrowChoice (⇝), ArrowZero (⇝)) ⇒ CIAscii → URI ⇝ (Host, Path)
  73 {-# INLINE scheme #-}
  74 scheme = schemeWith ∘ (≡)
  75
  76 -- |@'http' = 'scheme' \"http\" '<+>' 'scheme' \"https\"@
  77 http ∷ (ArrowChoice (⇝), ArrowPlus (⇝), ArrowZero (⇝)) ⇒ URI ⇝ (Host, Path)
  78 {-# INLINE http #-}
  79 http = scheme "http" <+> scheme "https"
  80
  81 -- |@'http'' = 'scheme' \"http\"@
  82 http' ∷ (ArrowChoice (⇝), ArrowZero (⇝)) ⇒ URI ⇝ (Host, Path)
  83 http' = scheme "http"
  84
  85 -- |@'https' = 'scheme' \"https\"@
  86 https ∷ (ArrowChoice (⇝), ArrowZero (⇝)) ⇒ URI ⇝ (Host, Path)
  87 https = scheme "https"