X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResponseWriter.hs;h=872e07807adc12c77245818e7dff61cbf947ea27;hp=034bd782aade719fa1a3beac140fdf2780e8d62b;hb=ea2b783;hpb=17020e406a20cbef8ec17594868db559c4c5a5db diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs index 034bd78..872e078 100644 --- a/Network/HTTP/Lucu/ResponseWriter.hs +++ b/Network/HTTP/Lucu/ResponseWriter.hs @@ -9,11 +9,11 @@ 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 qualified Data.Ascii as A import Data.Monoid.Unicode import qualified Data.Sequence as S import Data.Sequence (ViewR(..)) @@ -34,6 +34,11 @@ data Context h , cReader ∷ !ThreadId } +data Phase = Initial + | WroteContinue + | WroteHeader + deriving (Eq, Ord, Show) + responseWriter ∷ HandleLike h ⇒ Config → h → InteractionQueue → ThreadId → IO () responseWriter cnf h tQueue readerTID = awaitSomethingToWrite (Context cnf h tQueue readerTID) @@ -52,57 +57,69 @@ awaitSomethingToWrite ctx@(Context {..}) atomically $ -- キューが空でなくなるまで待つ do queue ← readTVar cQueue - -- GettingBody 状態にあり、Continue が期待されてゐて、それがま - -- だ送信前なのであれば、Continue を送信する。 case S.viewr queue of - EmptyR → retry - _ :> itr → do state ← readTVar $ itrState itr - if state ≡ GettingBody then - writeContinueIfNeeded ctx itr - else - if state ≥ DecidingBody then - writeHeaderOrBodyIfNeeded ctx itr - else - retry + EmptyR → retry + queue' :> itr → do writeTVar cQueue queue' + return $ awaitSomethingToWriteOn ctx itr Initial -writeContinueIfNeeded ∷ HandleLike h ⇒ Context h → Interaction → STM (IO ()) -writeContinueIfNeeded ctx itr@(Interaction {..}) - = do expectedContinue ← readTVar itrExpectedContinue - if expectedContinue then - do wroteContinue ← readTVar itrWroteContinue - if wroteContinue then - -- 既に Continue を書込み濟 - retry - else - do reqBodyWanted ← readTVar itrReqBodyWanted - if reqBodyWanted ≢ Nothing then - return $ writeContinue ctx itr - else - retry +-- GettingBody 状態にあり、Continue が期待されてゐて、それがまだ送信前 +-- なのであれば、Continue を送信する。 +awaitSomethingToWriteOn ∷ HandleLike h + ⇒ Context h + → Interaction + → Phase + → IO () +awaitSomethingToWriteOn ctx itr phase + = join $ + atomically $ + do state ← readTVar $ itrState itr + if state ≡ GettingBody then + writeContinueIfNeeded ctx itr phase else - retry + if state ≥ DecidingBody then + writeHeaderOrBodyIfNeeded ctx itr phase + else + retry + +writeContinueIfNeeded ∷ HandleLike h + ⇒ Context h + → Interaction + → Phase + → STM (IO ()) +writeContinueIfNeeded ctx itr@(Interaction {..}) phase + | phase ≡ Initial ∧ itrExpectedContinue ≡ Just True + = do reqBodyWanted ← readTVar itrReqBodyWanted + if reqBodyWanted > 0 then + return $ writeContinue ctx itr + else + retry + | otherwise + = retry -- DecidingBody 以降の状態にあり、まだヘッダを出力する前であれば、ヘッ -- ダを出力する。ヘッダ出力後であり、bodyToSend が空でなければ、それを -- 出力する。空である時は、もし状態がDone であれば後処理をする。 -writeHeaderOrBodyIfNeeded ∷ HandleLike h ⇒ Context h → Interaction → STM (IO ()) -writeHeaderOrBodyIfNeeded ctx itr@(Interaction {..}) - = do wroteHeader ← readTVar itrWroteHeader - if not wroteHeader then - return $ writeHeader ctx itr - else - do noBodyToWrite ← isEmptyTMVar itrBodyToSend - if noBodyToWrite then - do state ← readTVar itrState - if state ≡ Done then - return $ finalize ctx itr - else - retry - else - return $ writeBodyChunk ctx itr +writeHeaderOrBodyIfNeeded ∷ HandleLike h + ⇒ Context h + → Interaction + → Phase + → STM (IO ()) +writeHeaderOrBodyIfNeeded ctx itr@(Interaction {..}) phase + | phase < WroteHeader + = return $ writeHeader ctx itr + | otherwise + = do noBodyToWrite ← isEmptyTMVar itrBodyToSend + if noBodyToWrite then + do state ← readTVar itrState + if state ≡ Done then + return $ finalize ctx itr + else + retry + else + return $ writeBodyChunk ctx itr phase writeContinue ∷ HandleLike h ⇒ Context h → Interaction → IO () -writeContinue ctx@(Context {..}) (Interaction {..}) +writeContinue ctx@(Context {..}) itr@(Interaction {..}) = do let cont = Response { resVersion = HttpVersion 1 1 , resStatus = Continue @@ -111,26 +128,30 @@ writeContinue ctx@(Context {..}) (Interaction {..}) cont' ← completeUnconditionalHeaders cConfig cont hPutBuilder cHandle $ A.toBuilder $ printResponse cont' hFlush cHandle - atomically $ writeTVar itrWroteContinue True - awaitSomethingToWrite ctx + awaitSomethingToWriteOn ctx itr WroteContinue -writeHeader ∷ HandleLike h ⇒ Context h → Interaction → IO () -writeHeader ctx@(Context {..}) (Interaction {..}) - = do res ← atomically - $ do writeTVar itrWroteHeader True - readTVar itrResponse +writeHeader ∷ HandleLike h + ⇒ Context h + → Interaction + → IO () +writeHeader ctx@(Context {..}) itr@(Interaction {..}) + = do res ← atomically $ readTVar itrResponse hPutBuilder cHandle $ A.toBuilder $ printResponse res hFlush cHandle - awaitSomethingToWrite ctx + awaitSomethingToWriteOn ctx itr WroteHeader -writeBodyChunk ∷ HandleLike h ⇒ Context h → Interaction → IO () -writeBodyChunk ctx@(Context {..}) (Interaction {..}) +writeBodyChunk ∷ HandleLike h + ⇒ Context h + → Interaction + → Phase + → IO () +writeBodyChunk ctx@(Context {..}) itr@(Interaction {..}) phase = join $ atomically $ do willDiscardBody ← readTVar itrWillDiscardBody if willDiscardBody then do _ ← tryTakeTMVar itrBodyToSend - return $ awaitSomethingToWrite ctx + return $ awaitSomethingToWriteOn ctx itr phase else do willChunkBody ← readTVar itrWillChunkBody chunk ← takeTMVar itrBodyToSend @@ -140,7 +161,7 @@ writeBodyChunk ctx@(Context {..}) (Interaction {..}) else hPutBuilder cHandle chunk hFlush cHandle - awaitSomethingToWrite ctx + awaitSomethingToWriteOn ctx itr phase finishBodyChunk ∷ HandleLike h ⇒ Context h → Interaction → IO () finishBodyChunk (Context {..}) (Interaction {..})