Still working on Router arrow

[Lucu.git] / Network / HTTP / Lucu / Router.hs

diff --git a/Network/HTTP/Lucu/Router.hs b/Network/HTTP/Lucu/Router.hs
index b643797ee960c17e14dab6c0ef2f8809685ea88f..7c9c8055e56c81b1dbb9a5f4ac8e36e591255a37 100644 (file)
--- a/Network/HTTP/Lucu/Router.hs
+++ b/Network/HTTP/Lucu/Router.hs
@@ -1,11 +1,22 @@
 {-# LANGUAGE
-    GeneralizedNewtypeDeriving
+    Arrows
+  , GeneralizedNewtypeDeriving
+  , OverloadedStrings
+  , TypeOperators
   , UnicodeSyntax
   #-}
 -- |FIXME: doc
 module Network.HTTP.Lucu.Router
-    ( Router
+    ( -- * The 'Router' arrow
+      Router
     , runRouter
+
+      -- * Testing for URI scheme
+    , schemeWith
+    , scheme
+    , http
+    , http'
+    , https
     )
     where
 import Control.Applicative
@@ -13,8 +24,11 @@ import Control.Category
 import Control.Arrow
 import Control.Arrow.ArrowKleisli
 import Control.Arrow.List
-import Data.Maybe
 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
@@ -35,3 +49,33 @@ newtype Router m α β
 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"