X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FPostprocess.hs;h=062a3bf6203c303195684999a4198cb510338700;hb=d05d8c883eaca12ee621975a2b95c5ebdc2357d2;hp=124b66bd2ba3e4c4a4ac9aef92c4f9c76e0957ef;hpb=34b0ad7f2ffc5e7ca67fa3468d01c5551edc8a8b;p=Lucu.git diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs index 124b66b..062a3bf 100644 --- a/Network/HTTP/Lucu/Postprocess.hs +++ b/Network/HTTP/Lucu/Postprocess.hs @@ -1,4 +1,3 @@ --- #hide module Network.HTTP.Lucu.Postprocess ( postprocess , completeUnconditionalHeaders @@ -18,7 +17,6 @@ import Network.HTTP.Lucu.Interaction import Network.HTTP.Lucu.RFC1123DateTime import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response -import Network.HTTP.Lucu.Utils import System.Time {- @@ -32,14 +30,11 @@ import System.Time * 304 Not Modified 以外の 3xx なのに Location ヘッダが無ければ 500 に する。 - * Content-Length があれば、それを削除する。 + * Content-Length があれば、それを削除する。Transfer-Encoding があって + も削除する。 - * HTTP/1.1 であり、且つ body を持つ事が出來る時、Transfer-Encoding の - 最後の要素が chunked でなければ 500 Internal Error にする。 - Transfer-Encoding が未設定であれば、chunked に設定する。 - - * HTTP/1.0 なのに Transfer-Encoding が設定濟なら 500 Internal Server - Error にする。但し identity だけは許す。 + * HTTP/1.1 であり、body を持つ事が出來る時、Transfer-Encoding を + chunked に設定する。 * body を持つ事が出來る時、Content-Type が無ければデフォルト値にする。 出來ない時、HEAD でなければContent-Type, Etag, Last-Modified を削除 @@ -59,7 +54,9 @@ import System.Time postprocess :: Interaction -> STM () postprocess itr - = do res <- readItr itr itrResponse id + = itr `seq` + do reqM <- readItr itr itrRequest id + res <- readItr itr itrResponse id let sc = resStatus res when (not $ any (\ p -> p sc) [isSuccessful, isRedirection, isError]) @@ -75,19 +72,23 @@ postprocess itr $ abortSTM InternalServerError [] $ Just ("The status code was " ++ show sc ++ " but no Location header.") - when (itrRequest itr /= Nothing) + when (reqM /= Nothing) $ relyOnRequest itr - do newRes <- unsafeIOToSTM - $ completeUnconditionalHeaders (itrConfig itr) res + -- itrResponse の内容は relyOnRequest によって變へられてゐる可 + -- 能性が高い。 + do oldRes <- readItr itr itrResponse id + newRes <- unsafeIOToSTM + $ completeUnconditionalHeaders (itrConfig itr) oldRes writeItr itr itrResponse newRes where relyOnRequest :: Interaction -> STM () relyOnRequest itr - = do status <- readItr itr itrResponse resStatus + = itr `seq` + do status <- readItr itr itrResponse resStatus + req <- readItr itr itrRequest fromJust - let req = fromJust $ itrRequest itr - reqVer = reqVersion req + let reqVer = reqVersion req canHaveBody = if reqMethod req == HEAD then False else @@ -96,43 +97,23 @@ postprocess itr status == ResetContent || status == NotModified ) - updateRes itr $ deleteHeader "Content-Length" + updateRes itr $! deleteHeader "Content-Length" + updateRes itr $! deleteHeader "Transfer-Encoding" cType <- readHeader itr "Content-Type" when (cType == Nothing) $ updateRes itr $ setHeader "Content-Type" defaultPageContentType if canHaveBody then - do teM <- readHeader itr "Transfer-Encoding" - if reqVer == HttpVersion 1 1 then - - do case teM of - Nothing -> updateRes itr $ setHeader "Transfer-Encoding" "chunked" - Just te -> let teList = [trim isWhiteSpace x - | x <- splitBy (== ',') (map toLower te)] - in - when (teList == [] || last teList /= "chunked") - $ abortSTM InternalServerError [] - $ Just ("Transfer-Encoding must end with `chunked' " - ++ "because this is an HTTP/1.1 request: " - ++ te) - - writeItr itr itrWillChunkBody True - else - case fmap (map toLower) teM of - Nothing -> return () - Just "identity" -> return () - Just te -> abortSTM InternalServerError [] - $ Just ("Transfer-Encoding must be `identity' because " - ++ "this is an HTTP/1.0 request: " - ++ te) + when (reqVer == HttpVersion 1 1) + $ do updateRes itr $! setHeader "Transfer-Encoding" "chunked" + writeItr itr itrWillChunkBody True else -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す - do updateRes itr $ deleteHeader "Transfer-Encoding" - when (reqMethod req /= HEAD) - $ do updateRes itr $ deleteHeader "Content-Type" - updateRes itr $ deleteHeader "Etag" - updateRes itr $ deleteHeader "Last-Modified" + when (reqMethod req /= HEAD) + $ do updateRes itr $! deleteHeader "Content-Type" + updateRes itr $! deleteHeader "Etag" + updateRes itr $! deleteHeader "Last-Modified" conn <- readHeader itr "Connection" case fmap (map toLower) conn of @@ -141,23 +122,26 @@ postprocess itr willClose <- readItr itr itrWillClose id when willClose - $ updateRes itr $ setHeader "Connection" "close" + $ updateRes itr $! setHeader "Connection" "close" when (reqMethod req == HEAD || not canHaveBody) $ writeTVar (itrWillDiscardBody itr) True readHeader :: Interaction -> String -> STM (Maybe String) readHeader itr name - = readItr itr itrResponse $ getHeader name + = itr `seq` name `seq` + readItr itr itrResponse $ getHeader name updateRes :: Interaction -> (Response -> Response) -> STM () updateRes itr updator - = updateItr itr itrResponse updator + = itr `seq` updator `seq` + updateItr itr itrResponse updator completeUnconditionalHeaders :: Config -> Response -> IO Response completeUnconditionalHeaders conf res - = return res >>= compServer >>= compDate >>= return + = conf `seq` res `seq` + return res >>= compServer >>= compDate >>= return where compServer res = case getHeader "Server" res of