X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FPostprocess.hs;h=7157b7d56e9dd14c4dcaa635ce47be599d2d15f6;hp=6735652d6a5656410c6cc5ebfcdc922c11184761;hb=246d66d6d3130e03834a6c3badc38711a1879aae;hpb=f402841101b4b84f263eea1a43c848f81c48ff93

diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs
index 6735652..7157b7d 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 ∧
+               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 ∧
+               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
@@ -108,7 +102,7 @@ writeDefaultPageIfNeeded ni@(NI {..})
              $ do writeHeader ni "Content-Type" $ Just defaultPageContentType
                   writeHeader ni "Content-Encoding" Nothing
                   res ← readTVar niResponse
-                  let body = getDefaultPage niConfig (Just niRequest) res
+                  let body = defaultPageForResponse niConfig (Just niRequest) res
                   putTMVar niBodyToSend body
 
 completeUnconditionalHeaders ∷ NormalInteraction → STM ()