X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FPreprocess.hs;h=9f9fa0d68c3b83f187c6316213cc100f39cdc5cf;hb=8bdd1da1ee1f3e453dbe2bce246618e12e26d30c;hp=e8fdfc630b20bf4dea3de677f6daeb392d7fd852;hpb=3c7a58ab749a55a30466a033b170536bcdf18b98;p=Lucu.git diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs index e8fdfc6..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,80 +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 - writeTVar (itrWillClose itr) True + do setStatus HttpVersionNotSupported + writeItr itr itrWillClose True else - do if reqVer == HttpVersion 1 0 then - -- HTTP/1.0 では Keep-Alive できない - writeTVar (itrWillClose itr) True - else - -- URI または Host: ヘッダのどちらかにホストが無ければ - -- ならない。 - when (uriAuthority (reqURI req) == Nothing && - getHeader req "Host" == 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 -> writeTVar (itrWillDiscardBody itr) True - POST -> ensureHavingBody itr - PUT -> ensureHavingBody itr - _ -> 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 - ensureHavingBody itr - = let req = fromJust $ itrRequest itr - in - if getHeader req "Content-Length" == Nothing && - getHeader req "Transfer-Encoding" == Nothing then - - setStatus itr LengthRequired + 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 - writeTVar (itrRequestHasBody itr) True - - setStatus itr status - = writeTVar (itrResponse itr) (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 - writeTVar (itrExpectedContinue itr) True - else - setStatus itr ExpectationFailed - - "transfer-encoding" - -> case map toLower value of - "identity" -> return () - "chunked" -> writeTVar (itrRequestIsChunked itr) True - _ -> setStatus itr NotImplemented - - "content-length" - -> if all isDigit value then - writeTVar (itrRequestBodyLength itr) (Just $ read value) - else - setStatus itr BadRequest - - "connection" - -> case map toLower value of - "close" -> writeTVar (itrWillClose itr) True - _ -> return () - - _ -> return () \ No newline at end of file + 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