)
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(..))
, 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)
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
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
else
hPutBuilder cHandle chunk
hFlush cHandle
- awaitSomethingToWrite ctx
+ awaitSomethingToWriteOn ctx itr phase
finishBodyChunk ∷ HandleLike h ⇒ Context h → Interaction → IO ()
finishBodyChunk (Context {..}) (Interaction {..})