X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FInteraction.hs;h=1c2679cd9eee65d14c5bf70d0a0b623e3abbe616;hb=cc55fb9a095c9c583ed6fe2ded3eaf6401fb760f;hp=19faec28fe7a1fb506f42d5416123f17ec52a61d;hpb=c7a8bc012b1b70353d567bfab86fc6e849d60c20;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs
index 19faec2..1c2679c 100644
--- a/Network/HTTP/Lucu/Interaction.hs
+++ b/Network/HTTP/Lucu/Interaction.hs
@@ -13,17 +13,16 @@ module Network.HTTP.Lucu.Interaction
 
     , writeItr
     , readItr
-    , readItrF
     , updateItr
-    , updateItrF
     )
     where
-import Control.Applicative
+import Blaze.ByteString.Builder (Builder)
 import Control.Concurrent.STM
 import Data.Ascii (Ascii)
 import qualified Data.ByteString as BS
 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.Headers
@@ -31,14 +30,13 @@ import Network.HTTP.Lucu.HttpVersion
 import Network.HTTP.Lucu.Request
 import Network.HTTP.Lucu.Response
 import OpenSSL.X509
-import Prelude.Unicode
 
 data Interaction = Interaction {
       itrConfig            ∷ !Config
     , itrLocalPort         ∷ !PortNumber
     , itrRemoteAddr        ∷ !SockAddr
     , itrRemoteCert        ∷ !(Maybe X509)
-    , itrResourcePath      ∷ !(Maybe [Ascii])
+    , itrResourcePath      ∷ !(Maybe [Text])
     , itrRequest           ∷ !(TVar (Maybe Request))
     , itrResponse          ∷ !(TVar Response)
 
@@ -52,14 +50,15 @@ data Interaction = Interaction {
     , itrReqBodyWanted     ∷ !(TVar (Maybe Int))
     , itrReqBodyWasteAll   ∷ !(TVar Bool)
     , itrReceivedBody      ∷ !(TVar (Seq BS.ByteString))
+    , itrReceivedBodyLen   ∷ !(TVar Int)
 
     , itrWillReceiveBody   ∷ !(TVar Bool)
     , itrWillChunkBody     ∷ !(TVar Bool)
     , itrWillDiscardBody   ∷ !(TVar Bool)
     , itrWillClose         ∷ !(TVar Bool)
 
-    , itrBodyToSend        ∷ !(TVar (Seq BS.ByteString))
-    , itrBodyIsNull        ∷ !(TVar Bool)
+    , itrBodyToSend        ∷ !(TMVar Builder)
+    , itrSentNoBody        ∷ !(TVar Bool)
 
     , itrState             ∷ !(TVar InteractionState)
 
@@ -103,14 +102,15 @@ newInteraction !conf !port !addr !cert !req
          reqBodyWanted      ← newTVarIO Nothing -- Resource が要求してゐるチャンク長
          reqBodyWasteAll    ← newTVarIO False   -- 殘りの body を讀み捨てよと云ふ要求
          receivedBody       ← newTVarIO S.empty
+         receivedBodyLen    ← newTVarIO 0
 
          willReceiveBody   ← newTVarIO False
          willChunkBody     ← newTVarIO False
          willDiscardBody   ← newTVarIO False
          willClose         ← newTVarIO False
 
-         bodyToSend ← newTVarIO S.empty
-         bodyIsNull ← newTVarIO True -- 一度でも bodyToSend が空でなくなったら False
+         bodyToSend ← newEmptyTMVarIO
+         sentNoBody ← newTVarIO True -- 一度でも bodyToSend が空でなくなったら False
 
          state ← newTVarIO ExaminingRequest
 
@@ -136,6 +136,7 @@ newInteraction !conf !port !addr !cert !req
                     , itrReqBodyWanted     = reqBodyWanted
                     , itrReqBodyWasteAll   = reqBodyWasteAll
                     , itrReceivedBody      = receivedBody
+                    , itrReceivedBodyLen   = receivedBodyLen
 
                     , itrWillReceiveBody   = willReceiveBody
                     , itrWillChunkBody     = willChunkBody
@@ -143,7 +144,7 @@ newInteraction !conf !port !addr !cert !req
                     , itrWillClose         = willClose
 
                     , itrBodyToSend = bodyToSend
-                    , itrBodyIsNull = bodyIsNull
+                    , itrSentNoBody = sentNoBody
                     
                     , itrState = state
                     
@@ -151,28 +152,28 @@ newInteraction !conf !port !addr !cert !req
                     , itrWroteHeader   = wroteHeader
                     }
 
-writeItr ∷ Interaction → (Interaction → TVar a) → a → STM ()
+{-
+chunksToLBS ∷ Seq BS.ByteString → LBS.ByteString
+{-# INLINE chunksToLBS #-}
+chunksToLBS = LBS.fromChunks ∘ toList
+
+chunksFromLBS ∷ LBS.ByteString → Seq BS.ByteString
+{-# INLINE chunksFromLBS #-}
+chunksFromLBS = S.fromList ∘ LBS.toChunks
+-}
+
+writeItr ∷ (Interaction → TVar a) → a → Interaction → STM ()
 {-# INLINE writeItr #-}
-writeItr itr accessor
-    = writeTVar (accessor itr)
+writeItr accessor a itr
+    = writeTVar (accessor itr) a
 
-readItr ∷ Interaction → (Interaction → TVar a) → (a → b) → STM b
+readItr ∷ (Interaction → TVar a) → Interaction → STM a
 {-# INLINE readItr #-}
-readItr itr accessor reader
-    = reader <$> readTVar (accessor itr)
-
-readItrF ∷ Functor f => Interaction → (Interaction → TVar (f a)) → (a → b) → STM (f b)
-{-# INLINE readItrF #-}
-readItrF itr accessor reader
-    = readItr itr accessor (fmap reader)
+readItr accessor itr
+    = readTVar (accessor itr)
 
-updateItr ∷ Interaction → (Interaction → TVar a) → (a → a) → STM ()
+updateItr ∷ (Interaction → TVar a) → (a → a) → Interaction → STM ()
 {-# INLINE updateItr #-}
-updateItr itr accessor updator
-    = do old ← readItr itr accessor id
-         writeItr itr accessor (updator old)
-
-updateItrF ∷ Functor f => Interaction → (Interaction → TVar (f a)) → (a → a) → STM ()
-{-# INLINE updateItrF #-}
-updateItrF itr accessor
-    = updateItr itr accessor ∘ fmap
+updateItr accessor updator itr
+    = do old ← readItr accessor itr
+         writeItr accessor (updator old) itr