+writeChunkedBody ∷ HandleLike h
+ ⇒ Context h
+ → Interaction
+ → IO ()
+writeChunkedBody ctx@(Context {..}) itr@(Interaction {..})
+ = join $
+ atomically $
+ do chunk ← tryTakeTMVar itrBodyToSend
+ case chunk of
+ Just b → return $
+ do hPutBuilder cHandle $ BB.chunkedTransferEncoding b
+ hFlush cHandle
+ writeChunkedBody ctx itr
+ Nothing → do state ← readTVar itrState
+ if state ≡ Done then
+ return $ finalize ctx itr
+ else
+ retry
+
+writeNonChunkedBody ∷ HandleLike h
+ ⇒ Context h
+ → Interaction
+ → IO ()
+writeNonChunkedBody ctx@(Context {..}) itr@(Interaction {..})
+ = join $
+ atomically $
+ do chunk ← tryTakeTMVar itrBodyToSend
+ case chunk of
+ Just b → return $
+ do hPutBuilder cHandle b
+ hFlush cHandle
+ writeNonChunkedBody ctx itr
+ Nothing → do state ← readTVar itrState
+ if state ≡ Done then
+ return $ finalize ctx itr
+ else
+ retry
+
+finalize ∷ HandleLike h ⇒ Context h → Interaction → IO ()
+finalize ctx@(Context {..}) (Interaction {..})
+ = join $
+ atomically $
+ do sentContinue ← takeTMVar itrSendContinue
+ willDiscardBody ← readTVar itrWillDiscardBody
+ willChunkBody ← readTVar itrWillChunkBody
+ willClose ← readTVar itrWillClose
+ queue ← readTVar cQueue
+ case S.viewr queue of
+ queue' :> _
+ → writeTVar cQueue queue'
+ EmptyR
+ → fail "finalize: cQueue is empty, which should never happen."
+ return $
+ do when (((¬) willDiscardBody) ∧ willChunkBody)
+ $ do hPutBuilder cHandle BB.chunkedTransferTerminator
+ hFlush cHandle
+ if willClose ∨ needToClose sentContinue then
+ -- The RequestReader is probably blocking on
+ -- hWaitForInput so we have to kill it before
+ -- closing the socket.
+ -- THINKME: Couldn't that somehow be avoided?
+ do killThread cReader
+ hClose cHandle
+ else
+ awaitSomethingToWrite ctx
+ where
+ needToClose ∷ Bool → Bool
+ needToClose sentContinue
+ -- We've sent both "HTTP/1.1 100 Continue" and a final
+ -- response, so nothing prevents our connection from keeping
+ -- alive.
+ | sentContinue = False
+ -- We've got "Expect: 100-continue" but have sent a final
+ -- response without sending "HTTP/1.1 100
+ -- Continue". According to the RFC 2616 (HTTP/1.1), it is
+ -- undecidable whether the client will send us its
+ -- (rejected) request body OR start a completely new request
+ -- in this situation. So the only possible thing to do is to
+ -- brutally shutdown the connection.
+ | itrExpectedContinue ≡ Just True = True
+ -- The client didn't expect 100-continue so we haven't sent
+ -- one. No need to do anything special.
+ | otherwise = False