X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FInteraction.hs;h=20b4bc27ec956fffb6b959be6dae9c6359182694;hb=8225cc52ffe4c3d900ae1f79573089be230b80bd;hp=4ac7c093607729fe8784acc3f8e914c96fed1b66;hpb=72a3e24a952616e32845eeb4fc05048e841c91a2;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs
index 4ac7c09..20b4bc2 100644
--- a/Network/HTTP/Lucu/Interaction.hs
+++ b/Network/HTTP/Lucu/Interaction.hs
@@ -7,6 +7,7 @@ module Network.HTTP.Lucu.Interaction
     ( Interaction(..)
     , InteractionState(..)
     , InteractionQueue
+    , ReceiveBodyRequest(..)
     , newInteractionQueue
     , newInteraction
 
@@ -15,11 +16,10 @@ module Network.HTTP.Lucu.Interaction
     where
 import Blaze.ByteString.Builder (Builder)
 import Control.Concurrent.STM
-import qualified Data.ByteString as BS
+import qualified Data.ByteString as Strict
 import Data.Monoid.Unicode
 import Data.Sequence (Seq)
 import qualified Data.Sequence as S
-import Data.Text (Text)
 import Network.Socket
 import Network.HTTP.Lucu.Config
 import Network.HTTP.Lucu.HttpVersion
@@ -33,18 +33,16 @@ data Interaction = Interaction {
     , itrLocalPort         ∷ !PortNumber
     , itrRemoteAddr        ∷ !SockAddr
     , itrRemoteCert        ∷ !(Maybe X509)
-    , itrResourcePath      ∷ !(Maybe [Text])
+    , itrResourcePath      ∷ !(Maybe [Strict.ByteString])
     , itrRequest           ∷ !(Maybe Request)
 
     , itrExpectedContinue  ∷ !(Maybe Bool)
     , itrReqBodyLength     ∷ !(Maybe RequestBodyLength)
 
-    , itrReqBodyWanted     ∷ !(TVar Int)
-    , itrReqBodyWasteAll   ∷ !(TVar Bool)
-    , itrReqChunkIsOver    ∷ !(TVar Bool)
-    , itrReceivedBody      ∷ !(TVar (Seq BS.ByteString))
-    , itrReceivedBodyLen   ∷ !(TVar Int)
+    , itrReceiveBodyReq    ∷ !(TMVar ReceiveBodyRequest)
+    , itrReceivedBody      ∷ !(TMVar Strict.ByteString)
 
+    , itrSendContinue      ∷ !(TMVar Bool)
     , itrResponse          ∷ !(TVar Response)
     , itrWillChunkBody     ∷ !(TVar Bool)
     , itrWillDiscardBody   ∷ !(TVar Bool)
@@ -57,15 +55,21 @@ data Interaction = Interaction {
 
 -- |The interaction state of Resource monad. 'ExaminingRequest' is the
 -- initial state.
-data InteractionState = ExaminingRequest
-                      | GettingBody
-                      | DecidingHeader
-                      | DecidingBody
-                      | Done
-                        deriving (Show, Eq, Ord, Enum)
+data InteractionState
+    = ExaminingRequest
+    | ReceivingBody
+    | DecidingHeader
+    | SendingBody
+    | Done
+    deriving (Show, Eq, Ord, Enum)
 
 type InteractionQueue = TVar (Seq Interaction)
 
+data ReceiveBodyRequest
+    = ReceiveBody !Int -- ^ Maximum number of octets to receive.
+    | WasteAll
+    deriving (Show, Eq)
+
 newInteractionQueue ∷ IO InteractionQueue
 newInteractionQueue = newTVarIO S.empty
 
@@ -83,12 +87,10 @@ newInteraction conf@(Config {..}) port addr cert request
                    , resHeaders = (∅)
                    }
 
-         reqBodyWanted   ← newTVarIO 0
-         reqBodyWasteAll ← newTVarIO False
-         reqChunkIsOver  ← newTVarIO False
-         receivedBody    ← newTVarIO S.empty
-         receivedBodyLen ← newTVarIO 0
+         receiveBodyReq   ← newEmptyTMVarIO
+         receivedBody     ← newEmptyTMVarIO
 
+         sendContinue     ← newEmptyTMVarIO
          response         ← newTVarIO res
          willChunkBody    ← newTVarIO False
          willDiscardBody  ← newTVarIO (arWillDiscardBody ar)
@@ -99,22 +101,20 @@ newInteraction conf@(Config {..}) port addr cert request
          state            ← newTVarIO ExaminingRequest
 
          return Interaction {
-                      itrConfig       = conf
-                    , itrLocalPort    = port
-                    , itrRemoteAddr   = addr
-                    , itrRemoteCert   = cert
-                    , itrResourcePath = Nothing
-                    , itrRequest      = arRequest ar
+                      itrConfig           = conf
+                    , itrLocalPort        = port
+                    , itrRemoteAddr       = addr
+                    , itrRemoteCert       = cert
+                    , itrResourcePath     = Nothing
+                    , itrRequest          = arRequest ar
 
                     , itrExpectedContinue = arExpectedContinue ar
                     , itrReqBodyLength    = arReqBodyLength    ar
 
-                    , itrReqBodyWanted    = reqBodyWanted
-                    , itrReqBodyWasteAll  = reqBodyWasteAll
-                    , itrReqChunkIsOver   = reqChunkIsOver
+                    , itrReceiveBodyReq   = receiveBodyReq
                     , itrReceivedBody     = receivedBody
-                    , itrReceivedBodyLen  = receivedBodyLen
 
+                    , itrSendContinue     = sendContinue
                     , itrResponse         = response
                     , itrWillChunkBody    = willChunkBody
                     , itrWillDiscardBody  = willDiscardBody