X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FPostprocess.hs;h=cce46cdd89ddaadff56557c1b1bfd8d7c8b1d54f;hp=071ab56b1ea3f7e5f8770e803268f166c24c2c4d;hb=858129cb755aa09da2b7bd758efb8519f2c89103;hpb=5b255535f2c7d2a6d4622ad164b31e63746b906e

diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs
index 071ab56..cce46cd 100644
--- a/Network/HTTP/Lucu/Postprocess.hs
+++ b/Network/HTTP/Lucu/Postprocess.hs
@@ -56,7 +56,8 @@ import           System.Time
 
 postprocess :: Interaction -> STM ()
 postprocess itr
-    = do reqM <- readItr itr itrRequest id
+    = itr `seq`
+      do reqM <- readItr itr itrRequest id
          res  <- readItr itr itrResponse id
          let sc = resStatus res
 
@@ -85,7 +86,8 @@ postprocess itr
     where
       relyOnRequest :: Interaction -> STM ()
       relyOnRequest itr
-          = do status <- readItr itr itrResponse resStatus
+          = itr `seq`
+            do status <- readItr itr itrResponse resStatus
                req    <- readItr itr itrRequest fromJust
 
                let reqVer      = reqVersion req
@@ -97,8 +99,8 @@ postprocess itr
                                           status == ResetContent ||
                                           status == NotModified    )
 
-               updateRes itr $ deleteHeader "Content-Length"
-               updateRes itr $ deleteHeader "Transfer-Encoding"
+               updateRes itr $! deleteHeader "Content-Length"
+               updateRes itr $! deleteHeader "Transfer-Encoding"
 
                cType <- readHeader itr "Content-Type"
                when (cType == Nothing)
@@ -106,14 +108,14 @@ postprocess itr
 
                if canHaveBody then
                    when (reqVer == HttpVersion 1 1)
-                            $ do updateRes itr $ setHeader "Transfer-Encoding" "chunked"
+                            $ do updateRes itr $! setHeader "Transfer-Encoding" "chunked"
                                  writeItr itr itrWillChunkBody True
                  else
                    -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す
                    when (reqMethod req /= HEAD)
-                            $ do updateRes itr $ deleteHeader "Content-Type"
-                                 updateRes itr $ deleteHeader "Etag"
-                                 updateRes itr $ deleteHeader "Last-Modified"
+                            $ do updateRes itr $! deleteHeader "Content-Type"
+                                 updateRes itr $! deleteHeader "Etag"
+                                 updateRes itr $! deleteHeader "Last-Modified"
 
                conn <- readHeader itr "Connection"
                case fmap (map toLower) conn of
@@ -122,23 +124,26 @@ postprocess itr
 
                willClose <- readItr itr itrWillClose id
                when willClose
-                        $ updateRes itr $ setHeader "Connection" "close"
+                        $ updateRes itr $! setHeader "Connection" "close"
 
                when (reqMethod req == HEAD || not canHaveBody)
                         $ writeTVar (itrWillDiscardBody itr) True
 
       readHeader :: Interaction -> String -> STM (Maybe String)
       readHeader itr name
-          = readItr itr itrResponse $ getHeader name
+          = itr `seq` name `seq`
+            readItr itr itrResponse $ getHeader name
 
       updateRes :: Interaction -> (Response -> Response) -> STM ()
       updateRes itr updator 
-          = updateItr itr itrResponse updator
+          = itr `seq` updator `seq`
+            updateItr itr itrResponse updator
 
 
 completeUnconditionalHeaders :: Config -> Response -> IO Response
 completeUnconditionalHeaders conf res
-    = return res >>= compServer >>= compDate >>= return
+    = conf `seq` res `seq`
+      return res >>= compServer >>= compDate >>= return
       where
         compServer res
             = case getHeader "Server" res of