Still working on Router arrow

Ditz-issue: c80e79a2585ac20cc5ed677d70b6983a2842a81d

diff --git a/Network/HTTP/Lucu/HandleLike.hs b/Network/HTTP/Lucu/HandleLike.hs
index cc90cd6746ed7a74e8a1ed979e4f343423585863..65d99f40c60aa42f4be092527914e5f6d8d64bed 100644 (file)
--- a/Network/HTTP/Lucu/HandleLike.hs
+++ b/Network/HTTP/Lucu/HandleLike.hs
@@ -30,6 +30,8 @@ class HandleLike h where
     hGetPeerCert ∷ h → IO (Maybe X509)
     hGetPeerCert = const $ return Nothing
 #endif
+    hIsSSL ∷ h → Bool
+    hIsSSL _ = False
 
     hFlush  ∷ h → IO ()
     hClose  ∷ h → IO ()
@@ -56,6 +58,7 @@ instance HandleLike SSL.SSL where
                  SSL.getPeerCertificate s
              else
                  return Nothing
+    hIsSSL _ = True
 
     hFlush _ = return () -- No need to do anything.
     hClose s = SSL.shutdown s SSL.Bidirectional

diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs
index ca29c9a12e531432c66fcc9deced4be509820352..17a23b2435e50527674f3d51f75fb214d3dbad6b 100644 (file)
--- a/Network/HTTP/Lucu/Preprocess.hs
+++ b/Network/HTTP/Lucu/Preprocess.hs
@@ -3,6 +3,7 @@
   , OverloadedStrings
   , RecordWildCards
   , UnicodeSyntax
+  , ViewPatterns
   #-}
 module Network.HTTP.Lucu.Preprocess
     ( AugmentedRequest(..)
@@ -11,6 +12,7 @@ module Network.HTTP.Lucu.Preprocess
     )
     where
 import Control.Applicative
+import Control.Applicative.Unicode
 import Control.Monad
 import Control.Monad.State.Strict
 import Data.Ascii (Ascii)
@@ -46,8 +48,8 @@ data RequestBodyLength
     | Chunked
     deriving (Eq, Show)
 
-preprocess ∷ CI Text → PortNumber → Request → AugmentedRequest
-preprocess localHost localPort req@(Request {..})
+preprocess ∷ CI Text → PortNumber → Bool → Request → AugmentedRequest
+preprocess localHost localPort isSSL req@(Request {..})
     = execState go initialAR
     where
       initialAR ∷ AugmentedRequest
@@ -62,6 +64,7 @@ preprocess localHost localPort req@(Request {..})
       go ∷ State AugmentedRequest ()
       go = do examineHttpVersion
               examineMethod
+              examineScheme isSSL
               examineAuthority localHost localPort
               examineHeaders
               examineBodyLength
@@ -105,6 +108,20 @@ examineMethod
            DELETE → return ()
            _      → setStatus NotImplemented
 
+examineScheme ∷ Bool → State AugmentedRequest ()
+examineScheme isSSL
+    = do req ← gets arRequest
+         when (null ∘ uriScheme $ reqURI req) $
+             let uri' = (reqURI req) {
+                          uriScheme = if isSSL then
+                                          "https:"
+                                      else
+                                          "http:"
+                        }
+                 req' = req { reqURI = uri' }
+             in
+               setRequest req'
+
 examineAuthority ∷ CI Text → PortNumber → State AugmentedRequest ()
 examineAuthority localHost localPort
     = do req ← gets arRequest
@@ -115,8 +132,9 @@ examineAuthority localHost localPort
                HttpVersion 1 0
                    → let host = localHost
                          port = case localPort of
-                                  80 → ""
-                                  n  → A.unsafeFromString $ ':':show n
+                                  n | Just n ≡ defaultPort (reqURI req)
+                                        → ""
+                                  n     → A.unsafeFromString $ ':':show n
                          req' = updateAuthority host port req
                      in
                        setRequest req'
@@ -140,6 +158,13 @@ examineAuthority localHost localPort
                -- Should never reach here...
                ver → fail ("internal error: unknown version: " ⧺ show ver)
 
+defaultPort ∷ Alternative f ⇒ URI → f PortNumber
+{-# INLINEABLE defaultPort #-}
+defaultPort (uriScheme → s)
+    | s ≡ "http:"  = pure 80
+    | s ≡ "https:" = pure 443
+    | otherwise    = (∅)
+
 parseHost ∷ Ascii → (CI Text, Ascii)
 parseHost hp
     = let (h, p) = C8.break (≡ ':') $ cs hp

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index edd3fa2fedf899243d22840769aa2ccbd653a828..497db9320a0d2e87b6dc23d903bc24b213eb6246 100644 (file)
--- a/Network/HTTP/Lucu/RequestReader.hs
+++ b/Network/HTTP/Lucu/RequestReader.hs
@@ -111,7 +111,7 @@ acceptParsableRequest ∷ HandleLike h
                       → Lazy.ByteString
                       → IO ()
 acceptParsableRequest ctx@(Context {..}) req input
-    = do let ar = preprocess (cnfServerHost cConfig) cPort req
+    = do let ar = preprocess (cnfServerHost cConfig) cPort (hIsSSL cHandle) req
          if isError $ arInitialStatus ar then
              acceptSemanticallyInvalidRequest ctx ar input
          else

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"

diff --git a/Network/HTTP/Lucu/Utils.hs b/Network/HTTP/Lucu/Utils.hs
index 7537eafcffacf7d8edf755e2bb8fea30cd636547..f8fd589b74bbd5c170f2a98aa0afd28aee91f33c 100644 (file)
--- a/Network/HTTP/Lucu/Utils.hs
+++ b/Network/HTTP/Lucu/Utils.hs
@@ -5,13 +5,15 @@
   #-}
 -- |Utility functions used internally in this package.
 module Network.HTTP.Lucu.Utils
-    ( Host
+    ( Scheme
+    , Host
     , PathSegment
     , Path
 
     , splitBy
     , quoteStr
     , parseWWWFormURLEncoded
+    , uriCIScheme
     , uriHost
     , uriPathSegments
     , trim
@@ -26,7 +28,7 @@ module Network.HTTP.Lucu.Utils
     where
 import Control.Applicative hiding (empty)
 import Control.Monad hiding (mapM)
-import Data.Ascii (Ascii, AsciiBuilder)
+import Data.Ascii (Ascii, AsciiBuilder, CIAscii)
 import qualified Data.Ascii as A
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Char8 as BS
@@ -48,6 +50,9 @@ import Prelude hiding (last, mapM, null, reverse)
 import Prelude.Unicode
 import System.Directory
 
+-- |'Scheme' represents an URI scheme.
+type Scheme = CIAscii
+
 -- |'Host' represents an IP address or a host name in an URI
 -- authority.
 type Host = CI Text
@@ -113,6 +118,12 @@ parseWWWFormURLEncoded src
       plusToSpace '+' = ' '
       plusToSpace c   = c
 
+-- |>>> uriCIScheme "http://example.com/foo/bar"
+-- "http"
+uriCIScheme ∷ URI → CIAscii
+{-# INLINE uriCIScheme #-}
+uriCIScheme = convertUnsafe ∘ fst ∘ fromJust ∘ back ∘ uriScheme
+
 -- |>>> uriHost "http://example.com/foo/bar"
 -- "example.com"
 uriHost ∷ URI → Host