X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FPreprocess.hs;h=9321b6bc78e4570b0745334e9994866fcf0185f2;hp=9f9fa0d68c3b83f187c6316213cc100f39cdc5cf;hb=2bb7a0baa35dadb5d36d3f9fa98bd242baabc6d1;hpb=cc55fb9a095c9c583ed6fe2ded3eaf6401fb760f diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs index 9f9fa0d..9321b6b 100644 --- a/Network/HTTP/Lucu/Preprocess.hs +++ b/Network/HTTP/Lucu/Preprocess.hs @@ -1,26 +1,36 @@ {-# LANGUAGE - BangPatterns + DoAndIfThenElse + , OverloadedStrings + , RecordWildCards + , UnicodeSyntax #-} module Network.HTTP.Lucu.Preprocess ( preprocess ) where - -import Control.Concurrent.STM -import Control.Monad -import qualified Data.ByteString as Strict (ByteString) -import qualified Data.ByteString.Char8 as C8 hiding (ByteString) -import Data.Char -import Data.Maybe -import Network.HTTP.Lucu.Config -import Network.HTTP.Lucu.Headers -import Network.HTTP.Lucu.HttpVersion -import Network.HTTP.Lucu.Interaction -import Network.HTTP.Lucu.Request -import Network.HTTP.Lucu.Response -import Network.URI +import Control.Applicative +import Control.Concurrent.STM +import Control.Monad +import Data.Ascii (Ascii) +import qualified Data.Ascii as A +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as C8 +import Data.Char +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.Headers +import Network.HTTP.Lucu.HttpVersion +import Network.HTTP.Lucu.Interaction +import Network.HTTP.Lucu.Request +import Network.HTTP.Lucu.Response +import Network.URI +import Prelude.Unicode {- + TODO: Tanslate this memo into English. It doesn't make sense to + non-Japanese speakers. * URI にホスト名が存在しない時、 [1] HTTP/1.0 ならば Config を使って補完 @@ -46,112 +56,107 @@ import Network.URI Request にする。 * willDiscardBody その他の變數を設定する。 - -} -preprocess :: Interaction -> STM () -preprocess !itr - = do req <- readItr itr itrRequest fromJust +preprocess ∷ Interaction → STM () +preprocess itr@(Interaction {..}) + = do req ← fromJust <$> readTVar itrRequest let reqVer = reqVersion req - if reqVer /= HttpVersion 1 0 && - reqVer /= HttpVersion 1 1 then + if reqVer ≢ HttpVersion 1 0 ∧ + reqVer ≢ HttpVersion 1 1 then - do setStatus HttpVersionNotSupported - writeItr itr itrWillClose True + do setStatus itr HttpVersionNotSupported + writeTVar itrWillClose True - else + else -- HTTP/1.0 では Keep-Alive できない - do when (reqVer == HttpVersion 1 0) - $ writeItr itr itrWillClose True + do when (reqVer ≡ HttpVersion 1 0) + $ writeTVar itrWillClose True -- ホスト部の補完 - completeAuthority req + completeAuthority itr req case reqMethod req of - GET -> return () - HEAD -> writeItr itr itrWillDiscardBody True - POST -> writeItr itr itrRequestHasBody True - PUT -> writeItr itr itrRequestHasBody True - DELETE -> return () - _ -> setStatus NotImplemented + GET → return () + HEAD → writeTVar itrWillDiscardBody True + POST → writeTVar itrRequestHasBody True + PUT → writeTVar itrRequestHasBody True + DELETE → return () + _ → setStatus itr NotImplemented - preprocessHeader req - where - setStatus :: StatusCode -> STM () - setStatus !status - = updateItr itr itrResponse - $! \ res -> res { - resStatus = status - } - - completeAuthority :: Request -> STM () - completeAuthority !req - = when (uriAuthority (reqURI req) == Nothing) - $ if reqVersion req == HttpVersion 1 0 then - -- HTTP/1.0 なので Config から補完 - do let conf = itrConfig itr - host = cnfServerHost conf - port = itrLocalPort itr - portStr - = case port of - 80 -> "" - n -> ':' : show n - updateAuthority host (C8.pack portStr) - else - case getHeader (C8.pack "Host") req of - Just str -> let (host, portStr) = parseHost str - in updateAuthority host portStr - Nothing -> setStatus BadRequest - - - parseHost :: Strict.ByteString -> (Strict.ByteString, Strict.ByteString) - parseHost = C8.break (== ':') - - - updateAuthority :: Strict.ByteString -> Strict.ByteString -> STM () - updateAuthority !host !portStr - = updateItr itr itrRequest - $! \ (Just req) -> Just req { - reqURI = let uri = reqURI req - in uri { - uriAuthority = Just URIAuth { - uriUserInfo = "" - , uriRegName = C8.unpack host - , uriPort = C8.unpack portStr - } - } - } - - - preprocessHeader :: Request -> STM () - preprocessHeader !req - = do case getHeader (C8.pack "Expect") req of - Nothing -> return () - Just value -> if value `noCaseEq` C8.pack "100-continue" then - writeItr itr itrExpectedContinue True - else - setStatus ExpectationFailed - - case getHeader (C8.pack "Transfer-Encoding") req of - Nothing -> return () - Just value -> unless (value `noCaseEq` C8.pack "identity") - $ if value `noCaseEq` C8.pack "chunked" then - writeItr itr itrRequestIsChunked True - else - setStatus NotImplemented - - case getHeader (C8.pack "Content-Length") req of - Nothing -> return () - Just value -> if C8.all isDigit value then - do let Just (len, _) = C8.readInt value - writeItr itr itrReqChunkLength $ Just len - writeItr itr itrReqChunkRemaining $ Just len - else - setStatus BadRequest - - case getHeader (C8.pack "Connection") req of - Nothing -> return () - Just value -> when (value `noCaseEq` C8.pack "close") - $ writeItr itr itrWillClose True + preprocessHeader itr req + +setStatus ∷ Interaction → StatusCode → STM () +setStatus (Interaction {..}) sc + = do res ← readTVar itrResponse + let res' = res { + resStatus = sc + } + writeTVar itrResponse res' + +completeAuthority ∷ Interaction → Request → STM () +completeAuthority itr@(Interaction {..}) req + = when (isNothing $ uriAuthority $ reqURI req) + $ if reqVersion req == HttpVersion 1 0 then + -- HTTP/1.0 なので Config から補完 + do let host = cnfServerHost itrConfig + portStr = case itrLocalPort of + 80 → "" + n → ':' : show n + updateAuthority host $ A.unsafeFromString portStr + else + case getHeader "Host" req of + Just str → let (host, portStr) = parseHost str + in + updateAuthority host portStr + Nothing → setStatus itr BadRequest + +parseHost ∷ Ascii → (Text, Ascii) +parseHost = C8.break (≡ ':') + +updateAuthority ∷ Text → Ascii → STM () +updateAuthority host portStr + = do Just req ← readTVar itrRequest + let uri = reqURI req + uri' = uri { + uriAuthority = Just URIAuth { + uriUserInfo = "" + , uriRegName = T.unpack host + , uriPort = A.toString portStr + } + } + req' = req { reqURI = uri' } + writeTVar itrRequest $ Just req' + +preprocessHeader ∷ Interaction → Request → STM () +preprocessHeader (Interaction {..}) req + = do case getCIHeader "Expect" req of + Nothing → return () + Just value → if value ≡ "100-continue" then + writeTVar itrExpectedContinue True + else + setStatus ExpectationFailed + + case getCIHeader "Transfer-Encoding" req of + Nothing → return () + Just value → unless (value ≡ "identity") + $ if value ≡ "chunked" then + writeTVar itrRequestIsChunked True + else + setStatus NotImplemented + + case getHeader "Content-Length" req of + Nothing → return () + Just value → if C8.all isDigit value then + do let Just (len, _) = C8.readInt value + writeTVar itrReqChunkLength $ Just len + writeTVar itrReqChunkRemaining $ Just len + else + setStatus BadRequest + + case getCIHeader "Connection" req of + Nothing → return () + Just value → when (value ≡ "close") + $ writeTVar itrWillClose True