Many changes...

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

diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs
index 738207183ef8a04c387859dfdb1d16737b42d384..034bd782aade719fa1a3beac140fdf2780e8d62b 100644 (file)
--- a/Network/HTTP/Lucu/ResponseWriter.hs
+++ b/Network/HTTP/Lucu/ResponseWriter.hs
@@ -10,20 +10,19 @@ module Network.HTTP.Lucu.ResponseWriter
     where
 import qualified Blaze.ByteString.Builder.HTTP as BB
 import qualified Data.Ascii as A
-import           Control.Concurrent
-import           Control.Concurrent.STM
-import           Control.Exception
-import           Control.Monad
+import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Exception
+import Control.Monad
 import Data.Monoid.Unicode
 import qualified Data.Sequence as S
-import           Data.Sequence (ViewR(..))
-import           Network.HTTP.Lucu.Config
-import           Network.HTTP.Lucu.HandleLike
-import           Network.HTTP.Lucu.HttpVersion
-import           Network.HTTP.Lucu.Interaction
-import           Network.HTTP.Lucu.Postprocess
-import           Network.HTTP.Lucu.Response
-import           Prelude hiding (catch)
+import Data.Sequence (ViewR(..))
+import Network.HTTP.Lucu.Config
+import Network.HTTP.Lucu.HandleLike
+import Network.HTTP.Lucu.HttpVersion
+import Network.HTTP.Lucu.Interaction
+import Network.HTTP.Lucu.Postprocess
+import Network.HTTP.Lucu.Response
 import Prelude.Unicode
 import System.IO (hPutStrLn, stderr)
 
@@ -57,7 +56,7 @@ awaitSomethingToWrite ctx@(Context {..})
          -- だ送信前なのであれば、Continue を送信する。
          case S.viewr queue of
            EmptyR   → retry
-           _ :> itr → do state ← readItr itrState itr
+           _ :> itr → do state ← readTVar $ itrState itr
                          if state ≡ GettingBody then
                              writeContinueIfNeeded ctx itr
                          else
@@ -67,15 +66,15 @@ awaitSomethingToWrite ctx@(Context {..})
                                  retry
 
 writeContinueIfNeeded ∷ HandleLike h ⇒ Context h → Interaction → STM (IO ())
-writeContinueIfNeeded ctx itr
-    = do expectedContinue ← readItr itrExpectedContinue itr
+writeContinueIfNeeded ctx itr@(Interaction {..})
+    = do expectedContinue ← readTVar itrExpectedContinue
          if expectedContinue then
-             do wroteContinue ← readItr itrWroteContinue itr
+             do wroteContinue ← readTVar itrWroteContinue
                 if wroteContinue then
                     -- 既に Continue を書込み濟
                     retry
                 else
-                    do reqBodyWanted ← readItr itrReqBodyWanted itr
+                    do reqBodyWanted ← readTVar itrReqBodyWanted
                        if reqBodyWanted ≢ Nothing then
                            return $ writeContinue ctx itr
                        else
@@ -87,14 +86,14 @@ writeContinueIfNeeded ctx itr
 -- ダを出力する。ヘッダ出力後であり、bodyToSend が空でなければ、それを
 -- 出力する。空である時は、もし状態がDone であれば後処理をする。
 writeHeaderOrBodyIfNeeded ∷ HandleLike h ⇒ Context h → Interaction → STM (IO ())
-writeHeaderOrBodyIfNeeded ctx itr
-    = do wroteHeader ← readItr itrWroteHeader itr
+writeHeaderOrBodyIfNeeded ctx itr@(Interaction {..})
+    = do wroteHeader ← readTVar itrWroteHeader
          if not wroteHeader then
              return $ writeHeader ctx itr
          else
-             do noBodyToWrite ← isEmptyTMVar (itrBodyToSend itr)
+             do noBodyToWrite ← isEmptyTMVar itrBodyToSend
                 if noBodyToWrite then
-                    do state ← readItr itrState itr
+                    do state ← readTVar itrState
                        if state ≡ Done then
                            return $ finalize ctx itr
                        else
@@ -103,7 +102,7 @@ writeHeaderOrBodyIfNeeded ctx itr
                     return $ writeBodyChunk ctx itr
 
 writeContinue ∷ HandleLike h ⇒ Context h → Interaction → IO ()
-writeContinue ctx@(Context {..}) itr
+writeContinue ctx@(Context {..}) (Interaction {..})
     = do let cont = Response {
                       resVersion = HttpVersion 1 1
                     , resStatus  = Continue
@@ -112,29 +111,29 @@ writeContinue ctx@(Context {..}) itr
          cont' ← completeUnconditionalHeaders cConfig cont
          hPutBuilder cHandle $ A.toBuilder $ printResponse cont'
          hFlush cHandle
-         atomically $ writeItr itrWroteContinue True itr
+         atomically $ writeTVar itrWroteContinue True
          awaitSomethingToWrite ctx
 
 writeHeader ∷ HandleLike h ⇒ Context h → Interaction → IO ()
-writeHeader ctx@(Context {..}) itr
+writeHeader ctx@(Context {..}) (Interaction {..})
     = do res ← atomically
-               $ do writeItr itrWroteHeader True itr
-                    readItr itrResponse itr
+               $ do writeTVar itrWroteHeader True
+                    readTVar itrResponse
          hPutBuilder cHandle $ A.toBuilder $ printResponse res
          hFlush cHandle
          awaitSomethingToWrite ctx
 
 writeBodyChunk ∷ HandleLike h ⇒ Context h → Interaction → IO ()
-writeBodyChunk ctx@(Context {..}) itr
+writeBodyChunk ctx@(Context {..}) (Interaction {..})
     = join $
       atomically $
-      do willDiscardBody ← readItr itrWillDiscardBody itr
+      do willDiscardBody ← readTVar itrWillDiscardBody
          if willDiscardBody then
-             do _ ← tryTakeTMVar (itrBodyToSend itr)
+             do _ ← tryTakeTMVar itrBodyToSend
                 return $ awaitSomethingToWrite ctx
          else
-             do willChunkBody ← readItr itrWillChunkBody itr
-                chunk         ← takeTMVar (itrBodyToSend itr)
+             do willChunkBody ← readTVar itrWillChunkBody
+                chunk         ← takeTMVar itrBodyToSend
                 return $
                     do if willChunkBody then
                            hPutBuilder cHandle $ BB.chunkedTransferEncoding chunk
@@ -144,11 +143,11 @@ writeBodyChunk ctx@(Context {..}) itr
                        awaitSomethingToWrite ctx
 
 finishBodyChunk ∷ HandleLike h ⇒ Context h → Interaction → IO ()
-finishBodyChunk (Context {..}) itr
+finishBodyChunk (Context {..}) (Interaction {..})
     = join $
       atomically $
-      do willDiscardBody ← readItr itrWillDiscardBody itr
-         willChunkBody   ← readItr itrWillChunkBody   itr
+      do willDiscardBody ← readTVar itrWillDiscardBody
+         willChunkBody   ← readTVar itrWillChunkBody
          if ((¬) willDiscardBody) ∧ willChunkBody then
              return $
                  do hPutBuilder cHandle BB.chunkedTransferTerminator
@@ -157,14 +156,14 @@ finishBodyChunk (Context {..}) itr
              return $ return ()
 
 finalize ∷ HandleLike h ⇒ Context h → Interaction → IO ()
-finalize ctx@(Context {..}) itr
+finalize ctx@(Context {..}) itr@(Interaction {..})
     = do finishBodyChunk ctx itr
          willClose ← atomically $
                      do queue ← readTVar cQueue
                         case S.viewr queue of
                           EmptyR         → return () -- this should never happen
                           remaining :> _ → writeTVar cQueue remaining
-                        readItr itrWillClose itr
+                        readTVar itrWillClose
          if willClose then
              -- reader は恐らく hWaitForInput してゐる最中なので、スレッ
              -- ドを豫め殺して置かないとをかしくなる。