socket is not asynchronous exception safe

[lpeterse]

From what I learned about all the subtleties of Haskell's threading and exceptions in the last days I think that the following snippet taken from Network.Socket is unsafe.

socket family stype protocol = do
    c_stype <- packSocketTypeOrThrow "socket" stype       --   (1)
    fd <- throwSocketErrorIfMinus1Retry "socket" $
                c_socket (packFamily family) c_stype protocol
    setNonBlockIfNeeded fd
    socket_status <- newMVar NotConnected                  -- (2)
    withSocketsDo $ return ()
    let sock = MkSocket fd family stype protocol socket_status
    ...
    return sock                                           --   (3)

An asynchronous exception may kick in at any safe point (unless it is masked). I would assume that at least (2) is a safe point. If an exception occurs in between (1) and (3) we are in a state where a file descriptor resource has been acquired but has no handle anymore and cannot be released. We're irrevocably leaking a file descriptor here.

[lpeterse]

I come to the conclusion that protecting the operation against asynchronous exceptions (i.e. by masking them) is the responsibility of the caller at least as long as the operation does not contain interruptible calls (maybe this should be added to the documentation).

The problem persists with synchronous exceptions. setSocketOption may throw an exception:

setSocketOption (MkSocket s _ _ _ _) so v = do
   (level, opt) <- packSocketOption' "setSocketOption" so
   with (fromIntegral v) $ \ptr_v -> do
   throwSocketErrorIfMinus1_ "setSocketOption" $
       c_setsockopt s level opt ptr_v
          (fromIntegral (sizeOf (undefined :: CInt)))
   return ()

socket calls it without a catch (in the part with the ... between (2) and (3) above):

when (family == AF_INET6) $ setSocketOption sock IPv6Only 0

Also, setNonBlockingIfNeeded which calls System.Posix.Internals.setNonBlockingFD throws exceptions which don't get caught before the socket descriptor goes out of scope.

setNonBlockingFD fd set = do
  flags <- throwErrnoIfMinus1Retry "setNonBlockingFD"
                 (c_fcntl_read fd const_f_getfl)
  let flags' | set       = flags .|. o_NONBLOCK
             | otherwise = flags .&. complement o_NONBLOCK
  when (flags /= flags') $ do
    -- An error when setting O_NONBLOCK isn't fatal: on some systems
    -- there are certain file handles on which this will fail (eg. /dev/null
    -- on FreeBSD) so we throw away the return code from fcntl_write.
    _ <- c_fcntl_write fd const_f_setfl (fromIntegral flags')
    return ()

[kazu-yamamoto]

Closing this issue thanks to #336.