X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FPreprocess.hs;h=1397950212abd91ced41b1a7b4d9293f61146a2e;hb=8e78bc83bfe67a376293c346ae0b30f1a684c787;hp=e8fdfc630b20bf4dea3de677f6daeb392d7fd852;hpb=3c7a58ab749a55a30466a033b170536bcdf18b98;p=Lucu.git diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs index e8fdfc6..1397950 100644 --- a/Network/HTTP/Lucu/Preprocess.hs +++ b/Network/HTTP/Lucu/Preprocess.hs @@ -1,5 +1,6 @@ +-- #hide module Network.HTTP.Lucu.Preprocess - ( preprocess -- Interaction -> STM () + ( preprocess ) where @@ -7,16 +8,22 @@ import Control.Concurrent.STM import Control.Monad 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 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 +31,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 +47,122 @@ import Network.URI -} -import GHC.Conc (unsafeIOToSTM) - preprocess :: Interaction -> STM () preprocess itr - = do let req = fromJust $ itrRequest itr - reqVer = reqVersion req + = itr `seq` + 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 + HEAD -> writeItr itr itrWillDiscardBody True + POST -> writeItr itr itrRequestHasBody True + PUT -> writeItr itr itrRequestHasBody True + _ -> setStatus NotImplemented mapM_ (preprocessHeader itr) (reqHeaders 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 + = status `seq` + updateItr itr itrResponse + $! \ res -> res { + resStatus = status + } + + completeAuthority :: Request -> STM () + completeAuthority req + = req `seq` + 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 = case cnfServerPort conf of + PortNumber n -> Just $ fromIntegral n + _ -> Nothing + portStr + = case port of + Just 80 -> Just "" + Just n -> Just $ ":" ++ show n + Nothing -> Nothing + case portStr of + Just str -> updateAuthority host str + -- FIXME: このエラーの原因は、listen してゐるソ + -- ケットが INET でない故にポート番號が分からな + -- い事だが、その事をどうにかして通知した方が良 + -- いと思ふ。stderr？ + Nothing -> setStatus InternalServerError else - writeTVar (itrRequestHasBody itr) True - - setStatus itr status - = writeTVar (itrResponse itr) (Just $ Response { - resVersion = HttpVersion 1 1 - , resStatus = status - , resHeaders = [] - }) - + do case getHeader "Host" req of + Just str -> let (host, portStr) = parseHost str + in updateAuthority host portStr + Nothing -> setStatus BadRequest + + + parseHost :: String -> (String, String) + parseHost = break (== ':') + + + updateAuthority :: String -> String -> STM () + updateAuthority host portStr + = host `seq` portStr `seq` + updateItr itr itrRequest + $! \ (Just req) -> Just req { + reqURI = let uri = reqURI req + in uri { + uriAuthority = Just URIAuth { + uriUserInfo = "" + , uriRegName = host + , uriPort = portStr + } + } + } + + + preprocessHeader :: Interaction -> (String, String) -> STM () preprocessHeader itr (name, value) - = case map toLower name of + = itr `seq` name `seq` value `seq` + case map toLower name of "expect" - -> if value `noCaseEq` "100-continue" then - writeTVar (itrExpectedContinue itr) True + -> if value `noCaseEq'` "100-continue" then + writeItr itr itrExpectedContinue True else - setStatus itr ExpectationFailed + setStatus ExpectationFailed "transfer-encoding" -> case map toLower value of "identity" -> return () - "chunked" -> writeTVar (itrRequestIsChunked itr) True - _ -> setStatus itr NotImplemented + "chunked" -> writeItr itr itrRequestIsChunked True + _ -> setStatus NotImplemented "content-length" -> if all isDigit value then - writeTVar (itrRequestBodyLength itr) (Just $ read value) + do let len = read value + writeItr itr itrReqChunkLength $ Just len + writeItr itr itrReqChunkRemaining $ Just len else - setStatus itr BadRequest + setStatus BadRequest "connection" -> case map toLower value of - "close" -> writeTVar (itrWillClose itr) True + "close" -> writeItr itr itrWillClose True _ -> return () _ -> return () \ No newline at end of file