X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FPostprocess.hs;h=c3aec8ec7fa2f54deea73257d63cc743c72497f2;hb=42aad5a1889cf99c7c26ae7573bcc888e840ae66;hp=4ba7865d466f499a11d6a5f86c133bfc34b705f4;hpb=5f2ef377345fc47aabc63c1325df82c1cd9da9ed;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs
index 4ba7865..c3aec8e 100644
--- a/Network/HTTP/Lucu/Postprocess.hs
+++ b/Network/HTTP/Lucu/Postprocess.hs
@@ -14,6 +14,7 @@ import Control.Monad
 import Control.Monad.Unicode
 import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
 import Data.Convertible.Base
+import Data.Eq.Indirect
 import Data.Maybe
 import Data.Monoid.Unicode
 import GHC.Conc (unsafeIOToSTM)
@@ -47,16 +48,16 @@ abortOnCertainConditions (NI {..})
                    $ cs ("Inappropriate status code for a response: " ∷ Ascii)
                    ⊕ cs resStatus
 
-               when ( resStatus ≈ MethodNotAllowed ∧
-                      hasHeader "Allow" res        )
+               when ( resStatus ≡: MethodNotAllowed ∧
+                      (¬) (hasHeader "Allow" res)   )
                    $ abort'
                    $ cs ("The status was " ∷ Ascii)
                    ⊕ cs resStatus
                    ⊕ cs (" but no \"Allow\" header." ∷ Ascii)
 
-               when ( resStatus ≉ NotModified  ∧
-                      isRedirection resStatus  ∧
-                      hasHeader "Location" res )
+               when ( resStatus ≢: NotModified       ∧
+                      isRedirection resStatus        ∧
+                      (¬) (hasHeader "Location" res) )
                    $ abort'
                    $ cs ("The status code was " ∷ Ascii)
                    ⊕ cs resStatus
@@ -69,29 +70,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