Bugfix regarding HEAD requests

[Lucu.git] / Network / HTTP / Lucu / ResponseWriter.hs

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