ResponseWriter now compiles.

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

diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs
index a7c2e070843c45b4f357687c81cebb083a9d02e7..1a00b00b0eab578bca9db5d52e3e6bf4003abf46 100644 (file)
--- a/Network/HTTP/Lucu/Postprocess.hs
+++ b/Network/HTTP/Lucu/Postprocess.hs
@@ -1,6 +1,5 @@
 {-# LANGUAGE
-    BangPatterns
-  , DoAndIfThenElse
+    DoAndIfThenElse
   , OverloadedStrings
   , UnicodeSyntax
   #-}
@@ -63,44 +62,50 @@ import Prelude.Unicode
 -}
 
 postprocess ∷ Interaction → STM ()
-postprocess !itr
-    = do reqM ← readItr itrRequest  id itr
-         res  ← readItr itrResponse id itr
+postprocess itr
+    = do reqM ← readItr itrRequest  itr
+         res  ← readItr itrResponse itr
          let sc = resStatus res
 
          unless (any (\ p → p sc) [isSuccessful, isRedirection, isError])
              $ abortSTM InternalServerError []
              $ Just
-             $ A.toText ( "The status code is not good for a final status of a response: "
-                          ⊕ printStatusCode sc )
+             $ A.toText
+             $ A.fromAsciiBuilder
+             $ A.toAsciiBuilder "The status code is not good for a final status of a response: "
+             ⊕ printStatusCode sc
 
          when (sc ≡ MethodNotAllowed ∧ getHeader "Allow" res ≡ Nothing)
              $ abortSTM InternalServerError []
              $ Just
-             $ A.toText ( "The status was "
-                          ⊕ printStatusCode sc
-                          ⊕ " but no Allow header." )
+             $ A.toText
+             $ A.fromAsciiBuilder
+             $ A.toAsciiBuilder "The status was "
+             ⊕ printStatusCode sc
+             ⊕ A.toAsciiBuilder " but no Allow header."
 
          when (sc ≢ NotModified ∧ isRedirection sc ∧ getHeader "Location" res ≡ Nothing)
              $ abortSTM InternalServerError []
              $ Just
-             $ A.toText ( "The status code was "
-                          ⊕ printStatusCode sc
-                          ⊕ " but no Location header." )
+             $ A.toText
+             $ A.fromAsciiBuilder
+             $ A.toAsciiBuilder "The status code was "
+             ⊕ printStatusCode sc
+             ⊕ A.toAsciiBuilder " but no Location header."
 
          when (reqM ≢ Nothing) relyOnRequest
 
          -- itrResponse の内容は relyOnRequest によって變へられてゐる可
          -- 能性が高い。
-         do oldRes ← readItr itrResponse id itr
+         do oldRes ← readItr itrResponse itr
             newRes ← unsafeIOToSTM
                      $ completeUnconditionalHeaders (itrConfig itr) oldRes
             writeItr itrResponse newRes itr
     where
       relyOnRequest ∷ STM ()
       relyOnRequest
-          = do status ← readItr itrResponse resStatus itr
-               req    ← readItr itrRequest  fromJust  itr
+          = do status ← resStatus <$> readItr itrResponse itr
+               req    ← fromJust  <$> readItr itrRequest  itr
 
                let reqVer      = reqVersion req
                    canHaveBody = if reqMethod req ≡ HEAD then
@@ -135,7 +140,7 @@ postprocess !itr
                  Just value → when (A.toCIAscii value ≡ "close")
                                   $ writeItr itrWillClose True itr
 
-               willClose ← readItr itrWillClose id itr
+               willClose ← readItr itrWillClose itr
                when willClose
                    $ updateRes $ setHeader "Connection" "close"
 
@@ -144,7 +149,7 @@ postprocess !itr
 
       readHeader ∷ CIAscii → STM (Maybe Ascii)
       {-# INLINE readHeader #-}
-      readHeader k = readItr itrResponse (getHeader k) itr
+      readHeader k = getHeader k <$> readItr itrResponse itr
 
       updateRes ∷ (Response → Response) → STM ()
       {-# INLINE updateRes #-}