openConnection and openConnectionSSL leak file descriptors on connect failures

[twittner]

When attempting to open a connection to an address which can be successfully resolved but not connected to openConnection and openConnectionSSL leave the file descriptor belonging to the socket open.

Test-case:

module Main where

import Control.Exception
import Network.Http.Client
import qualified System.IO.Streams as S

main :: IO ()
main = sequence_
     . take 2048
     . repeat $ handle (\e -> print (e :: IOException))
         (get "http://localhost:60000" (\_ i -> S.connect i S.stdout))

One has to handle exceptions within openConnection* to ensure the socket is closed, e.g.

diff --git a/src/Network/Http/Connection.hs b/src/Network/Http/Connection.hs
index d2eb1a4..d1078ce 100644
--- a/src/Network/Http/Connection.hs
+++ b/src/Network/Http/Connection.hs
@@ -39,7 +39,7 @@ import Blaze.ByteString.Builder (Builder)
 import qualified Blaze.ByteString.Builder as Builder (flush, fromByteString,
                                                       toByteString)
 import qualified Blaze.ByteString.Builder.HTTP as Builder (chunkedTransferEncoding, chunkedTransferTerminator)
-import Control.Exception (bracket)
+import Control.Exception (bracket, bracketOnError, onException)
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Char8 as S
 import Data.Monoid (mappend, mempty)
@@ -176,19 +176,18 @@ openConnection h1' p = do
     is <- getAddrInfo (Just hints) (Just h1) (Just $ show p)
     let addr = head is
     let a = addrAddress addr
-    s <- socket (addrFamily addr) Stream defaultProtocol
-
-    connect s a
-    (i,o1) <- Streams.socketToStreams s
-
-    o2 <- Streams.builderStream o1
-
-    return Connection {
-        cHost  = h2',
-        cClose = close s,
-        cOut   = o2,
-        cIn    = i
-    }
+    bracketOnError (socket (addrFamily addr) Stream defaultProtocol) close $ \s -> do
+        connect s a
+
+        (i, o1) <- Streams.socketToStreams s
+        o2      <- Streams.builderStream o1
+
+        return Connection {
+            cHost  = h2',
+            cClose = close s,
+            cOut   = o2,
+            cIn    = i
+        }
   where
     hints = defaultHints {addrFlags = [AI_ADDRCONFIG, AI_NUMERICSERV]}
     h2' = if p == 80
@@ -234,21 +233,20 @@ openConnectionSSL ctx h1' p = do
         f = addrFamily $ head is
     s <- socket f Stream defaultProtocol

-    connect s a
-
-    ssl <- SSL.connection ctx s
-    SSL.connect ssl
+    connect s a `onException` (close s)

-    (i,o1) <- Streams.sslToStreams ssl
+    bracketOnError (SSL.connection ctx s) (closeSSL s) $ \ssl -> do
+        SSL.connect ssl

-    o2 <- Streams.builderStream o1
+        (i, o1) <- Streams.sslToStreams ssl
+        o2      <- Streams.builderStream o1

-    return Connection {
-        cHost  = h2',
-        cClose = closeSSL s ssl,
-        cOut   = o2,
-        cIn    = i
-    }
+        return Connection {
+            cHost  = h2',
+            cClose = closeSSL s ssl,
+            cOut   = o2,
+            cIn    = i
+        }
   where
     h2' :: ByteString
     h2' = if p == 443

[istathar]

Finally have some time. Will be looking at this this week.

[istathar]

Now I finally have some time. :/ Will be looking at this this week, and you can expect this addressed in 0.7.3

[joamaki]

Any progress on this?

[istathar]

I'm hammering on an IPv6 problem that may or may not be cause by this part of the code. Either way, I've hacking on http-streams this week.

[istathar]

Maybe relevant to #105