From: PHO <pho@cielonegro.org>
Date: Fri, 6 Jan 2012 13:09:56 +0000 (+0900)
Subject: Still working on Router arrow
X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=7bb9f322d85c1d7d8f23044a1be3b7e3b0ebe5b7;p=Lucu.git
Still working on Router arrow
Ditz-issue: c80e79a2585ac20cc5ed677d70b6983a2842a81d
---
diff --git a/Network/HTTP/Lucu/HandleLike.hs b/Network/HTTP/Lucu/HandleLike.hs
index cc90cd6..65d99f4 100644
--- 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 ca29c9a..17a23b2 100644
--- 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 edd3fa2..497db93 100644
--- 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 b643797..7c9c805 100644
--- 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 7537eaf..f8fd589 100644
--- 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