From 896da36ec761ae1c66a12350a91ca7c399ab6262 Mon Sep 17 00:00:00 2001
From: PHO <pho@cielonegro.org>
Date: Fri, 6 Jan 2012 22:27:33 +0900
Subject: [PATCH] working on Router arrow

Ditz-issue: c80e79a2585ac20cc5ed677d70b6983a2842a81d
---
 Network/HTTP/Lucu/Httpd.hs  |  1 +
 Network/HTTP/Lucu/Router.hs | 12 +++++++++---
 2 files changed, 10 insertions(+), 3 deletions(-)

diff --git a/Network/HTTP/Lucu/Httpd.hs b/Network/HTTP/Lucu/Httpd.hs
index a5f9749..6f4b34d 100644
--- a/Network/HTTP/Lucu/Httpd.hs
+++ b/Network/HTTP/Lucu/Httpd.hs
@@ -50,6 +50,7 @@ import Prelude.Unicode
 --                       'Network.HTTP.Lucu.putChunk' \"Hello, world!\"
 --                }
 -- @
+-- FIXME: use monad-parallel's MonadFork instead of IO.
 runHttpd ∷ HostMapper α ⇒ Config → α → IO ()
 runHttpd cnf hm
     = do let launchers
diff --git a/Network/HTTP/Lucu/Router.hs b/Network/HTTP/Lucu/Router.hs
index 7c9c805..657df3b 100644
--- a/Network/HTTP/Lucu/Router.hs
+++ b/Network/HTTP/Lucu/Router.hs
@@ -12,6 +12,7 @@ module Network.HTTP.Lucu.Router
     , runRouter
 
       -- * Testing for URI scheme
+    , anyScheme
     , schemeWith
     , scheme
     , http
@@ -50,6 +51,11 @@ 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
 schemeWith ∷ (ArrowChoice (⇝), ArrowZero (⇝))
            ⇒ (CIAscii → Bool)
@@ -58,7 +64,7 @@ schemeWith ∷ (ArrowChoice (⇝), ArrowZero (⇝))
 schemeWith f
     = proc uri →
       if f (uriCIScheme uri) then
-          arr uriHost &&& arr uriPathSegments ⤙ uri
+          anyScheme ⤙ uri
       else
           zeroArrow ⤙ (⊥)
 
@@ -72,10 +78,10 @@ http ∷ (ArrowChoice (⇝), ArrowPlus (⇝), ArrowZero (⇝)) ⇒ URI ⇝ (Host
 {-# INLINE http #-}
 http = scheme "http" <+> scheme "https"
 
--- |@'http'' = 'scheme' \"http\"
+-- |@'http'' = 'scheme' \"http\"@
 http' ∷ (ArrowChoice (⇝), ArrowZero (⇝)) ⇒ URI ⇝ (Host, Path)
 http' = scheme "http"
 
--- |@'https' = 'scheme' \"https\"
+-- |@'https' = 'scheme' \"https\"@
 https ∷ (ArrowChoice (⇝), ArrowZero (⇝)) ⇒ URI ⇝ (Host, Path)
 https = scheme "https"
-- 
2.40.0