X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FPreprocess.hs;h=9f9fa0d68c3b83f187c6316213cc100f39cdc5cf;hp=1c11f89784cb622ec6ee5fae0e67c7acd666c9c1;hb=8bdd1da1ee1f3e453dbe2bce246618e12e26d30c;hpb=2d25d34513dc4f6bf62e53e2af2f4a4ef39cc6dc diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs index 1c11f89..9f9fa0d 100644 --- a/Network/HTTP/Lucu/Preprocess.hs +++ b/Network/HTTP/Lucu/Preprocess.hs @@ -1,22 +1,31 @@ +{-# LANGUAGE + BangPatterns + #-} module Network.HTTP.Lucu.Preprocess - ( preprocess -- Interaction -> STM () + ( 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.HTTP.Lucu.Utils import Network.URI {- + * URI にホスト名が存在しない時、 + [1] HTTP/1.0 ならば Config を使って補完 + [2] HTTP/1.1 ならば Host ヘッダで補完。Host が無ければ 400。 + * Expect: に問題があった場合は 417 Expectation Failed に設定。 100-continue 以外のものは全部 417 に。 @@ -24,9 +33,6 @@ import Network.URI 体的には、identity でも chunked でもなければ 501 Not Implemented に する。 - * HTTP/1.1 リクエストであり、URI にホスト名が無く、Host: ヘッダも無い - 場合には 400 Bad Request にする。 - * メソッドが GET, HEAD, POST, PUT, DELETE の何れでもない場合は 501 Not Implemented にする。 @@ -43,72 +49,109 @@ import Network.URI -} -import GHC.Conc (unsafeIOToSTM) - preprocess :: Interaction -> STM () -preprocess itr - = do let req = fromJust $ itrRequest itr - reqVer = reqVersion req +preprocess !itr + = do req <- readItr itr itrRequest fromJust + + let reqVer = reqVersion req if reqVer /= HttpVersion 1 0 && reqVer /= HttpVersion 1 1 then - do setStatus itr HttpVersionNotSupported + do setStatus HttpVersionNotSupported writeItr itr itrWillClose True else - do if reqVer == HttpVersion 1 0 then - -- HTTP/1.0 では Keep-Alive できない - writeItr itr itrWillClose True - else - -- URI または Host: ヘッダのどちらかにホストが無ければ - -- ならない。 - when (uriAuthority (reqURI req) == Nothing && - getHeader "Host" req == Nothing) - $ setStatus itr BadRequest + -- HTTP/1.0 では Keep-Alive できない + do when (reqVer == HttpVersion 1 0) + $ writeItr itr itrWillClose True + + -- ホスト部の補完 + completeAuthority req case reqMethod req of - GET -> return () - HEAD -> writeItr itr itrWillDiscardBody True - POST -> writeItr itr itrRequestHasBody True - PUT -> writeItr itr itrRequestHasBody True - _ -> setStatus itr NotImplemented + GET -> return () + HEAD -> writeItr itr itrWillDiscardBody True + POST -> writeItr itr itrRequestHasBody True + PUT -> writeItr itr itrRequestHasBody True + DELETE -> return () + _ -> setStatus NotImplemented - mapM_ (preprocessHeader itr) (reqHeaders req) + preprocessHeader req where - setStatus itr status - = writeItr itr itrResponse $ Just (Response { - resVersion = HttpVersion 1 1 - , resStatus = status - , resHeaders = [] - }) - - preprocessHeader itr (name, value) - = case map toLower name of - - "expect" - -> if value `noCaseEq` "100-continue" then - writeItr itr itrExpectedContinue True - else - setStatus itr ExpectationFailed - - "transfer-encoding" - -> case map toLower value of - "identity" -> return () - "chunked" -> writeItr itr itrRequestIsChunked True - _ -> setStatus itr NotImplemented - - "content-length" - -> if all isDigit value then - do let len = read value - writeItr itr itrReqChunkLength $ Just len - writeItr itr itrReqChunkRemaining $ Just len - else - setStatus itr BadRequest - - "connection" - -> case map toLower value of - "close" -> writeItr itr itrWillClose True - _ -> return () - - _ -> return () \ No newline at end of file + 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