Still making many changes...

[Lucu.git] / Network / HTTP / Lucu / ResponseWriter.hs

diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs
index 872e07807adc12c77245818e7dff61cbf947ea27..587c01b695b1de62111a14ce9a70772cf467aa50 100644 (file)
--- 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 {..})