import Network.HTTP.Lucu.Response
import Prelude.Unicode
import System.IO (hPutStrLn, stderr)
+import System.IO.Error
data Context h
= Context {
responseWriter cnf h tQueue readerTID
= awaitSomethingToWrite (Context cnf h tQueue readerTID)
`catches`
- [ Handler $ \ (_ ∷ IOException) → return ()
- , Handler $ \ e → case e of
- ThreadKilled → return ()
- _ → hPutStrLn stderr (show e)
- , Handler $ \ BlockedIndefinitelyOnSTM → hPutStrLn stderr "requestWriter: blocked indefinitely"
- , Handler $ \ (e ∷ SomeException) → hPutStrLn stderr (show e)
+ [ Handler handleIOE
+ , Handler handleAsyncE
+ , Handler handleBIOS
+ , Handler handleOthers
]
+ where
+ 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 state ← readTVar $ itrState itr
- if state ≡ GettingBody then
+ if state ≡ ReceivingBody then
writeContinueIfNeeded ctx itr phase
else
- if state ≥ DecidingBody then
+ if state ≥ SendingBody then
writeHeaderOrBodyIfNeeded ctx itr phase
else
retry
→ STM (IO ())
writeContinueIfNeeded ctx itr@(Interaction {..}) phase
| phase ≡ Initial ∧ itrExpectedContinue ≡ Just True
- = do reqBodyWanted ← readTVar itrReqBodyWanted
- if reqBodyWanted > 0 then
+ = do isRequested ← isEmptyTMVar itrReceiveBodyReq
+ if isRequested then
return $ writeContinue ctx itr
else
retry