X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResponseWriter.hs;h=1106f14e14dcf06111e8abb872b2bfe5905083db;hb=1f0a19cbad7c4b64a773d7f1c1ae9180448624e6;hp=872e07807adc12c77245818e7dff61cbf947ea27;hpb=ea2b7838f1b3d9d4923a220a601be2e04cc559d7;p=Lucu.git

diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs
index 872e078..1106f14 100644
--- a/Network/HTTP/Lucu/ResponseWriter.hs
+++ b/Network/HTTP/Lucu/ResponseWriter.hs
@@ -25,6 +25,7 @@ import Network.HTTP.Lucu.Postprocess
 import Network.HTTP.Lucu.Response
 import Prelude.Unicode
 import System.IO (hPutStrLn, stderr)
+import System.IO.Error
 
 data Context h
     = Context {
@@ -43,13 +44,37 @@ responseWriter ∷ HandleLike h ⇒ Config → h → InteractionQueue → Thread
 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 {..})
@@ -88,8 +113,8 @@ writeContinueIfNeeded ∷ HandleLike h
                       → STM (IO ())
 writeContinueIfNeeded ctx itr@(Interaction {..}) phase
     | phase ≡ Initial ∧ itrExpectedContinue ≡ Just True
-        = do reqBodyWanted ← readTVar itrReqBodyWanted
-             if reqBodyWanted > 0 then
+        = do isRequested ← isEmptyTMVar itrGetBodyRequest
+             if isRequested then
                  return $ writeContinue ctx itr
              else
                  retry