X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FInteraction.hs;h=91979c9d5449e7a1b2ee7811a0c8294a9d381fc7;hb=d05d8c883eaca12ee621975a2b95c5ebdc2357d2;hp=29c944e573bf8c41c1fbb2ca2cb00ba500181eab;hpb=5b255535f2c7d2a6d4622ad164b31e63746b906e;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs
index 29c944e..91979c9 100644
--- a/Network/HTTP/Lucu/Interaction.hs
+++ b/Network/HTTP/Lucu/Interaction.hs
@@ -1,4 +1,3 @@
--- #hide
 module Network.HTTP.Lucu.Interaction
     ( Interaction(..)
     , InteractionState(..)
@@ -27,39 +26,37 @@ import           Network.HTTP.Lucu.Request
 import           Network.HTTP.Lucu.Response
 
 data Interaction = Interaction {
-      itrConfig       :: Config
-    , itrRemoteAddr   :: SockAddr
-    , itrResourcePath :: Maybe [String]
-    , itrRequest      :: TVar (Maybe Request)
-    , itrResponse     :: TVar Response
+      itrConfig       :: !Config
+    , itrRemoteAddr   :: !SockAddr
+    , itrResourcePath :: !(Maybe [String])
+    , itrRequest      :: !(TVar (Maybe Request))
+    , itrResponse     :: !(TVar Response)
 
     -- FIXME: この三つは本來 TVar であるべきでないので、唯の Bool にす
-    -- るに越した事は無いが、それは重要でない。そんな golf で自分の貴重
-    -- な時間を /dev/null に突っ込むのは、他にしたい事が何も無くなって
-    -- からにすべき。
-    , itrRequestHasBody    :: TVar Bool
-    , itrRequestIsChunked  :: TVar Bool
-    , itrExpectedContinue  :: TVar Bool
-
-    , itrReqChunkLength    :: TVar (Maybe Int)
-    , itrReqChunkRemaining :: TVar (Maybe Int)
-    , itrReqChunkIsOver    :: TVar Bool
-    , itrReqBodyWanted     :: TVar (Maybe Int)
-    , itrReqBodyWasteAll   :: TVar Bool
-    , itrReceivedBody      :: TVar ByteString -- Resource が受領した部分は削除される
-
-    , itrWillReceiveBody   :: TVar Bool
-    , itrWillChunkBody     :: TVar Bool
-    , itrWillDiscardBody   :: TVar Bool
-    , itrWillClose         :: TVar Bool
-
-    , itrBodyToSend :: TVar ByteString
-    , itrBodyIsNull :: TVar Bool
-
-    , itrState :: TVar InteractionState
-
-    , itrWroteContinue :: TVar Bool
-    , itrWroteHeader   :: TVar Bool
+    -- るに越した事は無いが、それは重要でない。
+    , itrRequestHasBody    :: !(TVar Bool)
+    , itrRequestIsChunked  :: !(TVar Bool)
+    , itrExpectedContinue  :: !(TVar Bool)
+
+    , itrReqChunkLength    :: !(TVar (Maybe Int))
+    , itrReqChunkRemaining :: !(TVar (Maybe Int))
+    , itrReqChunkIsOver    :: !(TVar Bool)
+    , itrReqBodyWanted     :: !(TVar (Maybe Int))
+    , itrReqBodyWasteAll   :: !(TVar Bool)
+    , itrReceivedBody      :: !(TVar ByteString) -- Resource が受領した部分は削除される
+
+    , itrWillReceiveBody   :: !(TVar Bool)
+    , itrWillChunkBody     :: !(TVar Bool)
+    , itrWillDiscardBody   :: !(TVar Bool)
+    , itrWillClose         :: !(TVar Bool)
+
+    , itrBodyToSend :: !(TVar ByteString)
+    , itrBodyIsNull :: !(TVar Bool)
+
+    , itrState :: !(TVar InteractionState)
+
+    , itrWroteContinue :: !(TVar Bool)
+    , itrWroteHeader   :: !(TVar Bool)
     }
 
 -- Resource の視點で見た時の状態。常に上から下へ行き、逆行しない。初期
@@ -84,7 +81,8 @@ defaultPageContentType = "application/xhtml+xml"
 
 newInteraction :: Config -> SockAddr -> Maybe Request -> IO Interaction
 newInteraction conf addr req
-    = do request  <- newTVarIO $ req
+    = conf `seq` addr `seq` req `seq`
+      do request  <- newTVarIO $ req
          responce <- newTVarIO $ Response {
                        resVersion = HttpVersion 1 1
                      , resStatus  = Ok
@@ -150,25 +148,32 @@ newInteraction conf addr req
 
 writeItr :: Interaction -> (Interaction -> TVar a) -> a -> STM ()
 writeItr itr accessor value
-    = writeTVar (accessor itr) value
+    = itr `seq` accessor `seq` value `seq`
+      writeTVar (accessor itr) value
 
 
 readItr :: Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b
 readItr itr accessor reader
-    = readTVar (accessor itr) >>= return . reader
+    = itr `seq` accessor `seq` reader `seq`
+      readTVar (accessor itr) >>= return . reader
 
 
-readItrF :: (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b)
+readItrF :: Functor f => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b)
 readItrF itr accessor reader
-    = readItr itr accessor (fmap reader)
+    = itr `seq` accessor `seq` reader `seq`
+      readItr itr accessor (fmap reader)
+{-# SPECIALIZE readItrF :: Interaction -> (Interaction -> TVar (Maybe a)) -> (a -> b) -> STM (Maybe b) #-}
 
 
 updateItr :: Interaction -> (Interaction -> TVar a) -> (a -> a) -> STM ()
 updateItr itr accessor updator
-    = do old <- readItr itr accessor id
+    = itr `seq` accessor `seq` updator `seq`
+      do old <- readItr itr accessor id
          writeItr itr accessor (updator old)
 
 
-updateItrF :: (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM ()
+updateItrF :: Functor f => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM ()
 updateItrF itr accessor updator
-    = updateItr itr accessor (fmap updator)
+    = itr `seq` accessor `seq` updator `seq`
+      updateItr itr accessor (fmap updator)
+{-# SPECIALIZE updateItrF :: Interaction -> (Interaction -> TVar (Maybe a)) -> (a -> a) -> STM () #-}
\ No newline at end of file