Bugfix regarding HEAD requests

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

diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs
index a8359758f9d90eaf107f58fc2bb4cf008b611cac..7157b7d56e9dd14c4dcaa635ce47be599d2d15f6 100644 (file)
--- a/Network/HTTP/Lucu/Postprocess.hs
+++ b/Network/HTTP/Lucu/Postprocess.hs
@@ -13,7 +13,7 @@ import Control.Concurrent.STM
 import Control.Monad
 import Control.Monad.Unicode
 import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
-import qualified Data.Ascii as A
+import Data.Convertible.Base
 import Data.Maybe
 import Data.Monoid.Unicode
 import GHC.Conc (unsafeIOToSTM)
@@ -44,55 +44,49 @@ abortOnCertainConditions (NI {..})
                                                , isError
                                                ])
                    $ abort'
-                   $ A.toAsciiBuilder "Inappropriate status code for a response: "
-                   ⊕ printStatusCode resStatus
+                   $ cs ("Inappropriate status code for a response: " ∷ Ascii)
+                   ⊕ cs resStatus
 
                when ( resStatus ≈ MethodNotAllowed ∧
                       hasHeader "Allow" res        )
                    $ abort'
-                   $ A.toAsciiBuilder "The status was "
-                   ⊕ printStatusCode resStatus
-                   ⊕ A.toAsciiBuilder " but no \"Allow\" header."
+                   $ cs ("The status was " ∷ Ascii)
+                   ⊕ cs resStatus
+                   ⊕ cs (" but no \"Allow\" header." ∷ Ascii)
 
                when ( resStatus ≉ NotModified  ∧
                       isRedirection resStatus  ∧
                       hasHeader "Location" res )
                    $ abort'
-                   $ A.toAsciiBuilder "The status code was "
-                   ⊕ printStatusCode resStatus
-                   ⊕ A.toAsciiBuilder " but no Location header."
+                   $ cs ("The status code was " ∷ Ascii)
+                   ⊕ cs resStatus
+                   ⊕ cs (" but no Location header." ∷ Ascii)
 
       abort' ∷ AsciiBuilder → STM ()
       abort' = throwSTM
                ∘ mkAbortion' InternalServerError
-               ∘ A.toText
-               ∘ A.fromAsciiBuilder
+               ∘ cs
 
 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