From 246d66d6d3130e03834a6c3badc38711a1879aae Mon Sep 17 00:00:00 2001 From: PHO Date: Tue, 20 Dec 2011 10:53:16 +0900 Subject: [PATCH] Bugfix regarding HEAD requests --- Network/HTTP/Lucu/Interaction.hs | 5 --- Network/HTTP/Lucu/Postprocess.hs | 31 ++++++++----------- Network/HTTP/Lucu/Preprocess.hs | 4 +-- Network/HTTP/Lucu/ResponseWriter.hs | 11 ++++--- ...c5a54d14cad8f79c456e23e92770fbbd3577e.yaml | 6 +++- 5 files changed, 25 insertions(+), 32 deletions(-) diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index d36c4d1..7c43f96 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -111,7 +111,6 @@ data SemanticallyInvalidInteraction , seiResponse ∷ !Response , seiWillChunkBody ∷ !Bool - , seiWillDiscardBody ∷ !Bool , seiWillClose ∷ !Bool , seiBodyToSend ∷ !Builder } @@ -143,7 +142,6 @@ mkSemanticallyInvalidInteraction config@(Config {..}) (AugmentedRequest {..}) , seiResponse = res , seiWillChunkBody = arWillChunkBody - , seiWillDiscardBody = arWillDiscardBody , seiWillClose = arWillClose , seiBodyToSend = body } @@ -168,7 +166,6 @@ data NormalInteraction , niResponse ∷ !(TVar Response) , niSendContinue ∷ !(TMVar Bool) , niWillChunkBody ∷ !Bool - , niWillDiscardBody ∷ !(TVar Bool) , niWillClose ∷ !(TVar Bool) , niResponseHasCType ∷ !(TVar Bool) -- FIXME: use TBChan Builder (in stm-chans package) @@ -212,7 +209,6 @@ mkNormalInteraction config remoteAddr (AugmentedRequest {..}) rsrcPath response ← newTVarIO $ emptyResponse arInitialStatus sendContinue ← newEmptyTMVarIO - willDiscardBody ← newTVarIO arWillDiscardBody willClose ← newTVarIO arWillClose responseHasCType ← newTVarIO False bodyToSend ← newEmptyTMVarIO @@ -236,7 +232,6 @@ mkNormalInteraction config remoteAddr (AugmentedRequest {..}) rsrcPath , niResponse = response , niSendContinue = sendContinue , niWillChunkBody = arWillChunkBody - , niWillDiscardBody = willDiscardBody , niWillClose = willClose , niResponseHasCType = responseHasCType , niBodyToSend = bodyToSend diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs index 4ba7865..7157b7d 100644 --- a/Network/HTTP/Lucu/Postprocess.hs +++ b/Network/HTTP/Lucu/Postprocess.hs @@ -69,29 +69,24 @@ abortOnCertainConditions (NI {..}) postprocessWithRequest ∷ NormalInteraction → STM () postprocessWithRequest ni@(NI {..}) - = do willDiscardBody ← readTVar niWillDiscardBody - canHaveBody ← if willDiscardBody then - return False - else - resCanHaveBody <$> readTVar niResponse - - updateRes ni + = do updateRes ni $ deleteHeader "Content-Length" ∘ deleteHeader "Transfer-Encoding" + canHaveBody ← resCanHaveBody <$> readTVar niResponse if canHaveBody then - do when niWillChunkBody $ - writeHeader ni "Transfer-Encoding" (Just "chunked") - writeDefaultPageIfNeeded ni - else - do writeTVar niWillDiscardBody True - -- These headers make sense for HEAD requests even - -- when there won't be a response entity body. + do when niWillChunkBody + $ writeHeader ni "Transfer-Encoding" (Just "chunked") when (reqMethod niRequest ≢ HEAD) - $ updateRes ni - $ deleteHeader "Content-Type" - ∘ deleteHeader "Etag" - ∘ deleteHeader "Last-Modified" + $ writeDefaultPageIfNeeded ni + else + -- These headers make sense for HEAD requests even when + -- there won't be a response entity body. + when (reqMethod niRequest ≢ HEAD) + $ updateRes ni + $ deleteHeader "Content-Type" + ∘ deleteHeader "Etag" + ∘ deleteHeader "Last-Modified" hasConnClose ← (≡ Just "close") <$> readCIHeader ni "Connection" willClose ← readTVar niWillClose diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs index de519da..1915b1b 100644 --- a/Network/HTTP/Lucu/Preprocess.hs +++ b/Network/HTTP/Lucu/Preprocess.hs @@ -36,7 +36,6 @@ data AugmentedRequest arRequest ∷ !Request , arInitialStatus ∷ !SomeStatusCode , arWillChunkBody ∷ !Bool - , arWillDiscardBody ∷ !Bool , arWillClose ∷ !Bool , arExpectedContinue ∷ !Bool , arReqBodyLength ∷ !(Maybe RequestBodyLength) @@ -56,7 +55,6 @@ preprocess localHost localPort req@(Request {..}) arRequest = req , arInitialStatus = fromStatusCode OK , arWillChunkBody = False - , arWillDiscardBody = False , arWillClose = False , arExpectedContinue = False , arReqBodyLength = Nothing @@ -101,7 +99,7 @@ examineMethod = do req ← gets arRequest case reqMethod req of GET → return () - HEAD → modify $ \ar → ar { arWillDiscardBody = True } + HEAD → return () POST → return () PUT → return () DELETE → return () diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs index 15f3d68..0af4a69 100644 --- a/Network/HTTP/Lucu/ResponseWriter.hs +++ b/Network/HTTP/Lucu/ResponseWriter.hs @@ -24,6 +24,7 @@ import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.HandleLike import Network.HTTP.Lucu.HttpVersion import Network.HTTP.Lucu.Interaction +import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response import Prelude.Unicode import System.IO (hPutStrLn, stderr) @@ -129,14 +130,14 @@ writeBodyIfNeeded ∷ HandleLike h writeBodyIfNeeded ctx ni@(NI {..}) = join $ atomically $ - do willDiscardBody ← readTVar niWillDiscardBody - if willDiscardBody then - return $ discardBody ctx ni - else + do canHaveBody ← resCanHaveBody <$> readTVar niResponse + if canHaveBody ∧ reqMethod niRequest ≢ HEAD then if niWillChunkBody then return $ writeChunkedBody ctx ni else return $ writeNonChunkedBody ctx ni + else + return $ discardBody ctx ni discardBody ∷ HandleLike h ⇒ Context h @@ -233,7 +234,7 @@ writeResponseForSEI ∷ HandleLike h → IO () writeResponseForSEI ctx@(Context {..}) (SEI {..}) = do hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) seiResponse - unless seiWillDiscardBody $ + when (reqMethod seiRequest ≢ HEAD) $ if seiWillChunkBody then do hPutBuilder cHandle $ BB.chunkedTransferEncoding seiBodyToSend hPutBuilder cHandle BB.chunkedTransferTerminator diff --git a/bugs/issue-e6ec5a54d14cad8f79c456e23e92770fbbd3577e.yaml b/bugs/issue-e6ec5a54d14cad8f79c456e23e92770fbbd3577e.yaml index 601c7f4..60ac6b0 100644 --- a/bugs/issue-e6ec5a54d14cad8f79c456e23e92770fbbd3577e.yaml +++ b/bugs/issue-e6ec5a54d14cad8f79c456e23e92770fbbd3577e.yaml @@ -5,7 +5,7 @@ type: :task component: Lucu release: Lucu-1.0 reporter: PHO -status: :unstarted +status: :in_progress disposition: creation_time: 2011-12-16 10:11:08.635552 Z references: [] @@ -16,4 +16,8 @@ log_events: - PHO - created - "" +- - 2011-12-20 01:22:49.383628 Z + - PHO + - changed status from unstarted to in_progress + - "" git_branch: -- 2.40.0