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

diff --git a/Network/HTTP/Lucu/Router.hs b/Network/HTTP/Lucu/Router.hs
index f04441b..7c9c805 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
+    , schemeWith
+    , 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,35 @@ 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
+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"