Many improvements

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

diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs
index 6b872ca5ff24a38ab16b74fb32d4df7d40e06abd..491c029b60ffbd51e2e7e425e3911325409cf389 100644 (file)
--- a/Network/HTTP/Lucu/Interaction.hs
+++ b/Network/HTTP/Lucu/Interaction.hs
@@ -3,7 +3,7 @@ module Network.HTTP.Lucu.Interaction
     , InteractionState(..)
     , InteractionQueue
     , newInteractionQueue -- IO InteractionQueue
-    , newInteraction      -- HostName -> Maybe Request -> IO Interaction
+    , newInteraction      -- Config -> HostName -> Maybe Request -> IO Interaction
 
     , writeItr   -- Interaction -> (Interaction -> TVar a) -> a -> STM ()
     , readItr    -- Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b
@@ -19,25 +19,34 @@ import           Data.ByteString.Lazy.Char8 (ByteString)
 import qualified Data.Sequence as S
 import           Data.Sequence (Seq)
 import           Network
+import           Network.HTTP.Lucu.Config
 import           Network.HTTP.Lucu.Request
 import           Network.HTTP.Lucu.Response
 
 data Interaction = Interaction {
-      itrRemoteHost  :: HostName
+      itrConfig      :: Config
+    , itrRemoteHost  :: HostName
     , itrRequest     :: Maybe Request
     , itrResponse    :: TVar (Maybe Response)
 
     , itrRequestHasBody    :: TVar Bool
-    , itrRequestBodyLength :: TVar (Maybe Integer) -- chunked の場合は不明
     , itrRequestIsChunked  :: TVar Bool
-    , itrReceivedBody      :: TVar ByteString -- Resource が受領した部分は削除される
-    
     , itrExpectedContinue  :: TVar Bool
 
-    , itrWillChunkBody    :: TVar Bool
-    , itrWillDiscardBody  :: TVar Bool
-    , itrWillClose        :: TVar Bool
-    , itrBodyToSend       :: TVar ByteString
+    , 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
 
@@ -53,7 +62,7 @@ data InteractionState = ExaminingHeader
                       | DecidingHeader
                       | DecidingBody
                       | Done
-                        deriving (Show, Eq, Ord)
+                        deriving (Show, Eq, Ord, Enum)
 
 type InteractionQueue = TVar (Seq Interaction)
 
@@ -62,21 +71,28 @@ newInteractionQueue :: IO InteractionQueue
 newInteractionQueue = newTVarIO S.empty
 
 
-newInteraction :: HostName -> Maybe Request -> IO Interaction
-newInteraction host req
+newInteraction :: Config -> HostName -> Maybe Request -> IO Interaction
+newInteraction conf host req
     = do responce <- newTVarIO Nothing
 
-         requestHasBody    <- newTVarIO False
-         requestBodyLength <- newTVarIO Nothing
-         requestIsChunked  <- newTVarIO False
-         receivedBody      <- newTVarIO B.empty
-
-         expectedContinue <- newTVarIO False
-
-         willChunkBody   <- newTVarIO False
-         willDiscardBody <- newTVarIO False
-         willClose       <- newTVarIO False
-         bodyToSend      <- newTVarIO B.empty
+         requestHasBody     <- newTVarIO False
+         requestIsChunked   <- newTVarIO False
+         expectedContinue   <- newTVarIO False
+         
+         reqChunkLength     <- newTVarIO Nothing -- 現在のチャンク長
+         reqChunkRemaining  <- newTVarIO Nothing -- 現在のチャンクの殘り
+         reqChunkIsOver     <- newTVarIO False   -- 最後のチャンクを讀み終へた
+         reqBodyWanted      <- newTVarIO Nothing -- Resource が要求してゐるチャンク長
+         reqBodyWasteAll    <- newTVarIO False   -- 殘りの body を讀み捨てよと云ふ要求
+         receivedBody       <- newTVarIO B.empty
+
+         willReceiveBody   <- newTVarIO False
+         willChunkBody     <- newTVarIO False
+         willDiscardBody   <- newTVarIO False
+         willClose         <- newTVarIO False
+
+         bodyToSend <- newTVarIO B.empty
+         bodyIsNull <- newTVarIO True -- 一度でも bodyToSend が空でなくなったら False
 
          state <- newTVarIO undefined
 
@@ -84,21 +100,29 @@ newInteraction host req
          wroteHeader   <- newTVarIO False
 
          return $ Interaction {
-                      itrRemoteHost = host
+                      itrConfig     = conf
+                    , itrRemoteHost = host
                     , itrRequest    = req
                     , itrResponse   = responce
 
                     , itrRequestHasBody    = requestHasBody
-                    , itrRequestBodyLength = requestBodyLength
                     , itrRequestIsChunked  = requestIsChunked
+                    , itrExpectedContinue = expectedContinue
+
+                    , itrReqChunkLength    = reqChunkLength
+                    , itrReqChunkRemaining = reqChunkRemaining
+                    , itrReqChunkIsOver    = reqChunkIsOver
+                    , itrReqBodyWanted     = reqBodyWanted
+                    , itrReqBodyWasteAll   = reqBodyWasteAll
                     , itrReceivedBody      = receivedBody
 
-                    , itrExpectedContinue = expectedContinue
+                    , itrWillReceiveBody   = willReceiveBody
+                    , itrWillChunkBody     = willChunkBody
+                    , itrWillDiscardBody   = willDiscardBody
+                    , itrWillClose         = willClose
 
-                    , itrWillChunkBody    = willChunkBody
-                    , itrWillDiscardBody  = willDiscardBody
-                    , itrWillClose        = willClose
-                    , itrBodyToSend       = bodyToSend
+                    , itrBodyToSend = bodyToSend
+                    , itrBodyIsNull = bodyIsNull
                     
                     , itrState = state