X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FPostprocess.hs;h=5c4f5d01bb3bca73f92228e27833c4d489625017;hb=8e78bc83bfe67a376293c346ae0b30f1a684c787;hp=071ab56b1ea3f7e5f8770e803268f166c24c2c4d;hpb=46f1b85674e45e823f5b6c7a1f87b1faf8172b85;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs
index 071ab56..5c4f5d0 100644
--- a/Network/HTTP/Lucu/Postprocess.hs
+++ b/Network/HTTP/Lucu/Postprocess.hs
@@ -18,7 +18,6 @@ import           Network.HTTP.Lucu.Interaction
 import           Network.HTTP.Lucu.RFC1123DateTime
 import           Network.HTTP.Lucu.Request
 import           Network.HTTP.Lucu.Response
-import           Network.HTTP.Lucu.Utils
 import           System.Time
 
 {-
@@ -56,7 +55,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 +85,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 +98,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 +107,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 +123,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