Catch error in sendMany and don't throw

1 files changed, 21 insertions, 14 deletions

diff --git a/mini-http-server/Network/HTTP/Server/Mini/Printer.hs b/mini-http-server/Network/HTTP/Server/Mini/Printer.hs
index ab6c1f6..77b88ce 100644
--- a/mini-http-server/Network/HTTP/Server/Mini/Printer.hs
+++ b/mini-http-server/Network/HTTP/Server/Mini/Printer.hs
@@ -9,6 +9,7 @@ import Network.Socket
 import Network.Socket.ByteString
 
 import Network.HTTP.Server.Mini.Types
+import System.IO.Error (catchIOError)
 
 
 sendResponse :: Socket -> Response -> IO ()
@@ -20,20 +21,26 @@ sendResponse conn (Response status hdrs (BodyFile path)) =
 
 sendResponseChunks :: Socket -> Status -> [(Header, ByteString)] -> BSL.ByteString -> IO ()
 sendResponseChunks conn (Status code reason) hdrs body =
-  sendMany conn $
-    BSL.toStrict (BSB.toLazyByteString
-      (BSB.shortByteString "HTTP/1.1 "
-       <> BSB.intDec code
-       <> BSB.char8 ' '
-       <> BSB.shortByteString reason
-       <> BSB.shortByteString "\r\n"
-       <> foldMap (\(key, val) ->
-                    BSB.shortByteString key <> BSB.shortByteString ": "
-                    <> BSB.byteString (wrapHdrVal val) <> BSB.shortByteString "\r\n")
-                  hdrs
-       <> BSB.shortByteString "Content-Length: " <> BSB.int64Dec (BSL.length body)
-       <> BSB.shortByteString "\r\nConnection: close\r\n\r\n"))
-    : BSL.toChunks body
+  catchIOError
+    (sendMany conn $
+      BSL.toStrict (BSB.toLazyByteString
+        (BSB.shortByteString "HTTP/1.1 "
+         <> BSB.intDec code
+         <> BSB.char8 ' '
+         <> BSB.shortByteString reason
+         <> BSB.shortByteString "\r\n"
+         <> foldMap (\(key, val) ->
+                      BSB.shortByteString key <> BSB.shortByteString ": "
+                      <> BSB.byteString (wrapHdrVal val) <> BSB.shortByteString "\r\n")
+                    hdrs
+         <> BSB.shortByteString "Content-Length: " <> BSB.int64Dec (BSL.length body)
+         <> BSB.shortByteString "\r\nConnection: close\r\n\r\n"))
+      : BSL.toChunks body)
+    (\_ ->
+      -- If an IO error occurs during sending, that ought to be sendMany, in
+      -- which case we just exit: if we can't write, we won't be able to write
+      -- in the future, and we might as well give up on this connection.
+      return ())
 
 wrapHdrVal :: ByteString -> ByteString
 wrapHdrVal bs = BS.intercalate (BS.singleton 32) (BS.split 10 bs)