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

diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs
index 4ba7865..ddda849 100644
--- a/Network/HTTP/Lucu/Postprocess.hs
+++ b/Network/HTTP/Lucu/Postprocess.hs
@@ -24,6 +24,7 @@ import Network.HTTP.Lucu.Headers
 import Network.HTTP.Lucu.Interaction
 import Network.HTTP.Lucu.Request
 import Network.HTTP.Lucu.Response
+import Network.HTTP.Lucu.Response.StatusCode
 import Prelude.Unicode
 
 postprocess ∷ NormalInteraction → STM ()
@@ -47,16 +48,16 @@ abortOnCertainConditions (NI {..})
                    $ cs ("Inappropriate status code for a response: " ∷ Ascii)
                    ⊕ cs resStatus
 
-               when ( resStatus ≈ MethodNotAllowed ∧
-                      hasHeader "Allow" res        )
+               when ( resStatus ≡ cs 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 ≢ cs 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