X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResponseWriter.hs;fp=Network%2FHTTP%2FLucu%2FResponseWriter.hs;h=034bd782aade719fa1a3beac140fdf2780e8d62b;hb=2bb7a0baa35dadb5d36d3f9fa98bd242baabc6d1;hp=738207183ef8a04c387859dfdb1d16737b42d384;hpb=cc55fb9a095c9c583ed6fe2ded3eaf6401fb760f;p=Lucu.git diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs index 7382071..034bd78 100644 --- 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 してゐる最中なので、スレッ -- ドを豫め殺して置かないとをかしくなる。