X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FPreprocess.hs;h=37b1a75ad997dbc7cfe14cf5fca0b91c5b4b287b;hb=d05d8c883eaca12ee621975a2b95c5ebdc2357d2;hp=c1f1a8b8dacc9c8e91cc21907f3053c3a55a7cda;hpb=46f1b85674e45e823f5b6c7a1f87b1faf8172b85;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs
index c1f1a8b..37b1a75 100644
--- a/Network/HTTP/Lucu/Preprocess.hs
+++ b/Network/HTTP/Lucu/Preprocess.hs
@@ -1,4 +1,3 @@
--- #hide
 module Network.HTTP.Lucu.Preprocess
     ( preprocess
     )
@@ -47,11 +46,10 @@ import           Network.URI
 
 -}
 
-import GHC.Conc (unsafeIOToSTM)
-
 preprocess :: Interaction -> STM ()
 preprocess itr
-    = do req <- readItr itr itrRequest fromJust
+    = itr `seq`
+      do req <- readItr itr itrRequest fromJust
 
          let reqVer = reqVersion req
 
@@ -80,14 +78,16 @@ preprocess itr
     where
       setStatus :: StatusCode -> STM ()
       setStatus status
-          = updateItr itr itrResponse
-            $ \ res -> res {
-                         resStatus = status
-                       }
+          = status `seq`
+            updateItr itr itrResponse
+            $! \ res -> res {
+                          resStatus = status
+                        }
 
       completeAuthority :: Request -> STM ()
       completeAuthority req
-          = when (uriAuthority (reqURI req) == Nothing)
+          = req `seq`
+            when (uriAuthority (reqURI req) == Nothing)
             $ if reqVersion req == HttpVersion 1 0 then
                   -- HTTP/1.0 なので Config から補完
                   do let conf = itrConfig itr
@@ -120,24 +120,27 @@ preprocess itr
 
       updateAuthority :: String -> String -> STM ()
       updateAuthority host portStr
-          = updateItr itr itrRequest
-            $ \ (Just req) -> Just req {
-                                reqURI = let uri = reqURI req
-                                         in uri {
-                                              uriAuthority = Just URIAuth {
-                                                                  uriUserInfo = ""
-                                                                , uriRegName  = host
-                                                                , uriPort     = portStr
-                                                                }
-                                            }
-                              }
+          = host `seq` portStr `seq`
+            updateItr itr itrRequest
+            $! \ (Just req) -> Just req {
+                                 reqURI = let uri = reqURI req
+                                          in uri {
+                                               uriAuthority = Just URIAuth {
+                                                                   uriUserInfo = ""
+                                                                 , uriRegName  = host
+                                                                 , uriPort     = portStr
+                                                              }
+                                             }
+                               }
                 
 
+      preprocessHeader :: Interaction -> (String, String) -> STM ()
       preprocessHeader itr (name, value)
-          = case map toLower name of
+          = itr `seq` name `seq` value `seq`
+            case map toLower name of
 
               "expect"
-                  -> if value `noCaseEq` "100-continue" then
+                  -> if value `noCaseEq'` "100-continue" then
                          writeItr itr itrExpectedContinue True
                      else
                          setStatus ExpectationFailed