+writeContinueIfNeeded ∷ HandleLike h ⇒ Context h → Interaction → STM (IO ())
+writeContinueIfNeeded ctx itr
+ = do expectedContinue ← readItr itrExpectedContinue itr
+ if expectedContinue then
+ do wroteContinue ← readItr itrWroteContinue itr
+ if wroteContinue then
+ -- 既に Continue を書込み濟
+ retry
+ else
+ do reqBodyWanted ← readItr itrReqBodyWanted itr
+ if reqBodyWanted ≢ Nothing then
+ return $ writeContinue ctx itr
+ else
+ retry
+ else
+ retry
+
+-- DecidingBody 以降の状態にあり、まだヘッダを出力する前であれば、ヘッ
+-- ダを出力する。ヘッダ出力後であり、bodyToSend が空でなければ、それを
+-- 出力する。空である時は、もし状態がDone であれば後処理をする。
+writeHeaderOrBodyIfNeeded ∷ HandleLike h ⇒ Context h → Interaction → STM (IO ())
+writeHeaderOrBodyIfNeeded ctx itr
+ = do wroteHeader ← readItr itrWroteHeader itr
+ if not wroteHeader then
+ return $ writeHeader ctx itr
+ else
+ do noBodyToWrite ← isEmptyTMVar (itrBodyToSend itr)
+ if noBodyToWrite then
+ do state ← readItr itrState itr
+ if state ≡ Done then
+ return $ finalize ctx itr
+ else
+ retry
+ else
+ return $ writeBodyChunk ctx itr
+
+writeContinue ∷ HandleLike h ⇒ Context h → Interaction → IO ()
+writeContinue ctx@(Context {..}) itr
+ = do let cont = Response {
+ resVersion = HttpVersion 1 1
+ , resStatus = Continue
+ , resHeaders = (∅)
+ }
+ cont' ← completeUnconditionalHeaders cConfig cont
+ hPutBuilder cHandle $ A.toBuilder $ printResponse cont'
+ hFlush cHandle
+ atomically $ writeItr itrWroteContinue True itr
+ awaitSomethingToWrite ctx
+
+writeHeader ∷ HandleLike h ⇒ Context h → Interaction → IO ()
+writeHeader ctx@(Context {..}) itr
+ = do res ← atomically
+ $ do writeItr itrWroteHeader True itr
+ readItr itrResponse itr
+ hPutBuilder cHandle $ A.toBuilder $ printResponse res
+ hFlush cHandle
+ awaitSomethingToWrite ctx
+
+writeBodyChunk ∷ HandleLike h ⇒ Context h → Interaction → IO ()
+writeBodyChunk ctx@(Context {..}) itr
+ = join $
+ atomically $
+ do willDiscardBody ← readItr itrWillDiscardBody itr
+ if willDiscardBody then
+ do _ ← tryTakeTMVar (itrBodyToSend itr)
+ return $ awaitSomethingToWrite ctx
+ else
+ do willChunkBody ← readItr itrWillChunkBody itr
+ chunk ← takeTMVar (itrBodyToSend itr)
+ return $
+ do if willChunkBody then
+ hPutBuilder cHandle $ BB.chunkedTransferEncoding chunk
+ else
+ hPutBuilder cHandle chunk
+ hFlush cHandle
+ awaitSomethingToWrite ctx
+
+finishBodyChunk ∷ HandleLike h ⇒ Context h → Interaction → IO ()
+finishBodyChunk (Context {..}) itr
+ = join $
+ atomically $
+ do willDiscardBody ← readItr itrWillDiscardBody itr
+ willChunkBody ← readItr itrWillChunkBody itr
+ if ((¬) willDiscardBody) ∧ willChunkBody then
+ return $
+ do hPutBuilder cHandle BB.chunkedTransferTerminator
+ hFlush cHandle
+ else
+ return $ return ()
+
+finalize ∷ HandleLike h ⇒ Context h → Interaction → IO ()
+finalize ctx@(Context {..}) itr
+ = 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
+ if willClose then
+ -- reader は恐らく hWaitForInput してゐる最中なので、スレッ
+ -- ドを豫め殺して置かないとをかしくなる。
+ do killThread cReader
+ hClose cHandle
+ else
+ awaitSomethingToWrite ctx