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 b4809eaa52e4d975b4afc16b8300a396ed85fe70..0af4a69df02f1a78604b0bc46d3b71077a545768 100644 (file)
--- a/Network/HTTP/Lucu/ResponseWriter.hs
+++ b/Network/HTTP/Lucu/ResponseWriter.hs
@@ -14,8 +14,9 @@ import Control.Concurrent
 import Control.Concurrent.STM
 import Control.Exception
 import Control.Monad
+import Data.Ascii (AsciiBuilder)
+import Data.Convertible.Utils
 import GHC.IO.Exception (IOException(..), IOErrorType(..))
-import qualified Data.Ascii as A
 import Data.Monoid.Unicode
 import qualified Data.Sequence as S
 import Data.Sequence (ViewR(..))
@@ -23,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)
@@ -102,7 +104,7 @@ writeContinueIfNeeded ctx@(Context {..}) ni@(NI {..})
                              , resStatus  = fromStatusCode Continue
                              , resHeaders = (∅)
                              }
-                  hPutBuilder cHandle $ A.toBuilder $ printResponse cont
+                  hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) cont
                   hFlush cHandle
          writeHeader ctx ni
 
@@ -117,7 +119,7 @@ writeHeader ctx@(Context {..}) ni@(NI {..})
                       readTVar niResponse
                   else
                       retry -- Too early to write header fields.
-         hPutBuilder cHandle $ A.toBuilder $ printResponse res
+         hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) res
          hFlush cHandle
          writeBodyIfNeeded ctx ni
 
@@ -128,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
@@ -231,8 +233,8 @@ writeResponseForSEI ∷ HandleLike h
                     → SemanticallyInvalidInteraction
                     → IO ()
 writeResponseForSEI ctx@(Context {..}) (SEI {..})
-    = do hPutBuilder cHandle $ A.toBuilder $ printResponse seiResponse
-         unless seiWillDiscardBody $
+    = do hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) seiResponse
+         when (reqMethod seiRequest ≢ HEAD) $
              if seiWillChunkBody then
                  do hPutBuilder cHandle $ BB.chunkedTransferEncoding seiBodyToSend
                     hPutBuilder cHandle BB.chunkedTransferTerminator
@@ -249,7 +251,7 @@ writeResponseForSYI ∷ HandleLike h
                     → SyntacticallyInvalidInteraction
                     → IO ()
 writeResponseForSYI (Context {..}) (SYI {..})
-    = do hPutBuilder cHandle $ A.toBuilder $ printResponse syiResponse
+    = do hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) syiResponse
          hPutBuilder cHandle syiBodyToSend
          hFlush cHandle
          return ()