X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FPostprocess.hs;h=b31c0ee5ef6bd819498584ed89bc7d036a34b90c;hb=eb77281b24b8d7218e1fd80164f941836cef1d5a;hp=a8359758f9d90eaf107f58fc2bb4cf008b611cac;hpb=c060bff37e29f06e105c0ec2b1f844f55b48906c;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs
index a835975..b31c0ee 100644
--- 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        )
+               when ( resStatus ≡ cs 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 )
+               when ( resStatus ≢ cs 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