{-# LANGUAGE
    Arrows
  , GeneralizedNewtypeDeriving
  , OverloadedStrings
  , TypeOperators
  , UnicodeSyntax
  #-}
-- |FIXME: doc
module Network.HTTP.Lucu.Router
    ( -- * The 'Router' arrow
      Router
    , runRouter

      -- * Testing for URI scheme
    , schemeWith
    , scheme
    , http
    , http'
    , https
    )
    where
import Control.Applicative
import Control.Category
import Control.Arrow
import Control.Arrow.ArrowKleisli
import Control.Arrow.List
import Control.Monad.IO.Class
import Data.Ascii (CIAscii)
import Data.Maybe
import Network.URI hiding (scheme)
import Network.HTTP.Lucu.Utils
import Prelude.Unicode

-- |FIXME: doc
newtype Router m α β
    = Router {
        unRouter ∷ ListTArrow m α β
      }
    deriving ( Arrow
             , ArrowKleisli m
             , ArrowZero
             , ArrowPlus
             , ArrowChoice
             , ArrowApply
             , Category
             )

-- |FIXME: doc
runRouter ∷ (Applicative m, MonadIO m) ⇒ Router m α β → α → m (Maybe β)
{-# INLINE runRouter #-}
runRouter = ((listToMaybe <$>) ∘) ∘ runListTArrow ∘ unRouter

-- |FIXME: doc
schemeWith ∷ (ArrowChoice (⇝), ArrowZero (⇝))
           ⇒ (CIAscii → Bool)
           → URI ⇝ (Host, Path)
{-# INLINEABLE schemeWith #-}
schemeWith f
    = proc uri →
      if f (uriCIScheme uri) then
          arr uriHost &&& arr uriPathSegments ⤙ uri
      else
          zeroArrow ⤙ (⊥)

-- |@'scheme' s@ = @'schemeWith' ('==' s)@
scheme ∷ (ArrowChoice (⇝), ArrowZero (⇝)) ⇒ CIAscii → URI ⇝ (Host, Path)
{-# INLINE scheme #-}
scheme = schemeWith ∘ (≡)

-- |@'http' = 'scheme' \"http\" '<+>' 'scheme' \"https\"@
http ∷ (ArrowChoice (⇝), ArrowPlus (⇝), ArrowZero (⇝)) ⇒ URI ⇝ (Host, Path)
{-# INLINE http #-}
http = scheme "http" <+> scheme "https"

-- |@'http'' = 'scheme' \"http\"
http' ∷ (ArrowChoice (⇝), ArrowZero (⇝)) ⇒ URI ⇝ (Host, Path)
http' = scheme "http"

-- |@'https' = 'scheme' \"https\"
https ∷ (ArrowChoice (⇝), ArrowZero (⇝)) ⇒ URI ⇝ (Host, Path)
https = scheme "https"