- awaitSomethingToWrite :: IO ()
- awaitSomethingToWrite
- = do action
- <- atomically $
- do -- キューが空でなくなるまで待つ
- queue <- readTVar tQueue
- when (S.null queue)
- retry
- let _ :> itr = S.viewr queue
-
- -- GettingBody 状態にあり、Continue が期待され
- -- てゐて、それがまだ送信前なのであれば、
- -- Continue を送信する。
- state <- readTVar (itrState itr)
-
- if state == GettingBody then
- writeContinueIfNecessary itr
- else
- if state >= DecidingBody then
- writeHeaderOrBodyIfNecessary itr
- else
- retry
- action
-
- writeContinueIfNecessary :: Interaction -> STM (IO ())
- writeContinueIfNecessary itr
- = do expectedContinue <- readTVar (itrExpectedContinue itr)
- if expectedContinue then
-
- do wroteContinue <- readTVar $ itrWroteContinue itr
- if wroteContinue then
- -- 既に Continue を書込み濟
- retry
+ handleIOE ∷ IOException → IO ()
+ handleIOE e
+ | isIllegalOperation e
+ = return () -- EPIPE: should be ignored at all.
+ | otherwise
+ = terminate e
+
+ handleAsyncE ∷ AsyncException → IO ()
+ handleAsyncE ThreadKilled = terminate'
+ handleAsyncE e = terminate e
+
+ handleBIOS ∷ BlockedIndefinitelyOnSTM → IO ()
+ handleBIOS = terminate
+
+ handleOthers ∷ SomeException → IO ()
+ handleOthers = terminate
+
+ terminate ∷ Exception e ⇒ e → IO ()
+ terminate e
+ = do hPutStrLn stderr "requestWriter caught an exception:"
+ hPutStrLn stderr (show $ toException e)
+ terminate'
+
+ terminate' ∷ IO ()
+ terminate' = hClose h
+
+awaitSomethingToWrite ∷ HandleLike h ⇒ Context h → IO ()
+awaitSomethingToWrite ctx@(Context {..})
+ = join $
+ atomically $
+ do queue ← readTVar cQueue
+ case S.viewr queue of
+ EmptyR → retry
+ queue' :> itr → do writeTVar cQueue queue'
+ return $ writeContinueIfNeeded ctx itr
+
+writeContinueIfNeeded ∷ HandleLike h
+ ⇒ Context h
+ → Interaction
+ → IO ()
+writeContinueIfNeeded ctx@(Context {..}) itr@(Interaction {..})
+ = do isNeeded ← atomically $ readTMVar itrSendContinue
+ when isNeeded
+ $ do let cont = Response {
+ resVersion = HttpVersion 1 1
+ , resStatus = Continue
+ , resHeaders = (∅)
+ }
+ cont' ← completeUnconditionalHeaders cConfig cont
+ hPutBuilder cHandle $ A.toBuilder $ printResponse cont'
+ hFlush cHandle
+ writeHeader ctx itr
+
+writeHeader ∷ HandleLike h
+ ⇒ Context h
+ → Interaction
+ → IO ()
+writeHeader ctx@(Context {..}) itr@(Interaction {..})
+ = do res ← atomically $
+ do state ← readTVar itrState
+ if state ≥ SendingBody then
+ readTVar itrResponse
+ else
+ retry -- Too early to write header fields.
+ hPutBuilder cHandle $ A.toBuilder $ printResponse res
+ hFlush cHandle
+ writeBodyIfNeeded ctx itr
+
+writeBodyIfNeeded ∷ HandleLike h
+ ⇒ Context h
+ → Interaction
+ → IO ()
+writeBodyIfNeeded ctx itr@(Interaction {..})
+ = join $
+ atomically $
+ do willDiscardBody ← readTVar itrWillDiscardBody
+ if willDiscardBody then
+ return $ discardBody ctx itr
+ else
+ do willChunkBody ← readTVar itrWillChunkBody
+ if willChunkBody then
+ return $ writeChunkedBody ctx itr
+ else
+ return $ writeNonChunkedBody ctx itr
+
+discardBody ∷ HandleLike h
+ ⇒ Context h
+ → Interaction
+ → IO ()
+discardBody ctx itr@(Interaction {..})
+ = join $
+ atomically $
+ do chunk ← tryTakeTMVar itrBodyToSend
+ case chunk of
+ Just _ → return $ discardBody ctx itr
+ Nothing → do state ← readTVar itrState
+ if state ≡ Done then
+ return $ finalize ctx itr