X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FRouter.hs;h=8624f53aa8312d514f5ca9af0e2fe70366c85f89;hb=af68f61;hp=f04441baf0b8fbdf9b40b0f69d87bbc3c25dd0d4;hpb=1a8b40bc467928dc018f00a3899cbc39398b213e;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Router.hs b/Network/HTTP/Lucu/Router.hs
index f04441b..8624f53 100644
--- a/Network/HTTP/Lucu/Router.hs
+++ b/Network/HTTP/Lucu/Router.hs
@@ -1,32 +1,44 @@
 {-# 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
 import Control.Category
 import Control.Arrow
-import Control.Arrow.ArrowList
 import Control.Arrow.ArrowKleisli
 import Control.Arrow.List
 import Control.Monad.IO.Class
-import Control.Monad.Unicode
+import Data.Ascii (CIAscii)
+import Data.Maybe
+import Network.URI hiding (scheme)
+import Network.HTTP.Lucu.Utils
 import Prelude.Unicode
 
 -- |FIXME: doc
-newtype MonadIO m ⇒ Router m α β
+newtype Router m α β
     = Router {
         unRouter ∷ ListTArrow m α β
       }
     deriving ( Arrow
              , ArrowKleisli m
              , ArrowZero
-             , ArrowList
              , ArrowPlus
              , ArrowChoice
              , ArrowApply
@@ -35,10 +47,33 @@ newtype MonadIO m ⇒ Router m α β
 
 -- |FIXME: doc
 runRouter ∷ (Applicative m, MonadIO m) ⇒ Router m α β → α → m (Maybe β)
-{-# INLINEABLE runRouter #-}
-runRouter = ((optional' =≪) ∘) ∘ runListTArrow ∘ unRouter
-    where
-      optional' ∷ Applicative f ⇒ [β] → f (Maybe β)
-      {-# INLINE optional' #-}
-      optional' []    = pure Nothing
-      optional' (x:_) = pure (Just x)
+{-# 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"