working on Router

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

diff --git a/Network/HTTP/Lucu/Router.hs b/Network/HTTP/Lucu/Router.hs
index b643797ee960c17e14dab6c0ef2f8809685ea88f..8624f53aa8312d514f5ca9af0e2fe70366c85f89 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
+    , anyScheme
+    , 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,31 @@ newtype Router m α β
 runRouter ∷ (Applicative m, MonadIO m) ⇒ Router m α β → α → m (Maybe β)
 {-# INLINE runRouter #-}
 runRouter = ((listToMaybe <$>) ∘) ∘ runListTArrow ∘ unRouter
+
+-- |FIXME: doc
+anyScheme ∷ Arrow (⇝) ⇒ URI ⇝ (Host, Path)
+{-# INLINEABLE anyScheme #-}
+anyScheme = arr uriHost &&& arr uriPathSegments
+
+-- |FIXME: doc
+scheme ∷ (ArrowChoice (⇝), ArrowZero (⇝)) ⇒ CIAscii → URI ⇝ (Host, Path)
+{-# INLINEABLE scheme #-}
+scheme s
+    = proc uri →
+      if s ≡ uriCIScheme uri then
+          anyScheme ⤙ uri
+      else
+          zeroArrow ⤙ (⊥)
+
+-- |@'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"