From 7bb9f322d85c1d7d8f23044a1be3b7e3b0ebe5b7 Mon Sep 17 00:00:00 2001 From: PHO Date: Fri, 6 Jan 2012 22:09:56 +0900 Subject: [PATCH] Still working on Router arrow Ditz-issue: c80e79a2585ac20cc5ed677d70b6983a2842a81d --- Network/HTTP/Lucu/HandleLike.hs | 3 ++ Network/HTTP/Lucu/Preprocess.hs | 33 +++++++++++++++++--- Network/HTTP/Lucu/RequestReader.hs | 2 +- Network/HTTP/Lucu/Router.hs | 50 ++++++++++++++++++++++++++++-- Network/HTTP/Lucu/Utils.hs | 15 +++++++-- 5 files changed, 93 insertions(+), 10 deletions(-) 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 -- 2.40.0