Bugfix regarding HEAD requests

diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs
index d36c4d1773d4ebcaad2cf2937d5ce0fcddf716b0..7c43f96c5e7a12bcf3145771a7ea6b4976fed17e 100644 (file)
--- 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 4ba7865d466f499a11d6a5f86c133bfc34b705f4..7157b7d56e9dd14c4dcaa635ce47be599d2d15f6 100644 (file)
--- 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 de519da58ea013412f8862889c8e2556d7eacd6b..1915b1bd44e3a93f95ffba41f922d3f2bea0bc94 100644 (file)
--- 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 15f3d6884064715c1281f9f0c42fe12bdca6bc78..0af4a69df02f1a78604b0bc46d3b71077a545768 100644 (file)
--- 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 601c7f4e92460d837c39255621afa0e888509ea9..60ac6b016628ef6e8595023498957d101c0e1579 100644 (file)
--- a/bugs/issue-e6ec5a54d14cad8f79c456e23e92770fbbd3577e.yaml
+++ b/bugs/issue-e6ec5a54d14cad8f79c456e23e92770fbbd3577e.yaml
@@ -5,7 +5,7 @@ type: :task
 component: Lucu
 release: Lucu-1.0
 reporter: PHO <pho@cielonegro.org>
-status: :unstarted
+status: :in_progress
 disposition: 
 creation_time: 2011-12-16 10:11:08.635552 Z
 references: []
@@ -16,4 +16,8 @@ log_events:
   - PHO <pho@cielonegro.org>
   - created
   - ""
+- - 2011-12-20 01:22:49.383628 Z
+  - PHO <pho@cielonegro.org>
+  - changed status from unstarted to in_progress
+  - ""
 git_branch: