threadWaitSTM: invalid argument (Bad file descriptor)

[lpeterse]

The following program causes an exception (threadWaitSTM: invalid argument (Bad file descriptor)) when interrupted with Ctrl+C.

main :: IO ()
main = do
    bracket open close accept
  where
    open     = S.socket :: IO (S.Socket S.Inet6 S.Stream S.Default)
    close    = S.close
    accept s = do
      S.setSocketOption s (S.ReuseAddress True)
      S.setSocketOption s (S.V6Only False)
      S.bind s (S.SocketAddressInet6 S.inet6Any 22 0 0)
      S.listen s 5
      token <- newEmptyMVar
      forever $ do
        forkIO $ bracket
          (S.accept s `finally` putMVar token ())
          (S.close . fst)
          (\(stream,_)-> Server.serve config stream)
        takeMVar token

The expected behavior is that the thread waiting on the accept receives an eBadFileDescriptor :: SocketException.

Environment:

Stack-resolver: lts-12.8 (GHC 8.4.3)
socket-0.8.1.0
Linux gallifrey 4.18.5-arch1-1-ARCH #1 SMP PREEMPT Fri Aug 24 12:48:58 UTC 2018 x86_64 GNU/Linux
ghc-options: -threaded -rtsopts -with-rtsopts=-N

[lpeterse]

The only possible origin of the exception is here: https://github.com/ghc/ghc/blob/21f0f56164f50844c2150c62f950983b2376f8b6/libraries/base/GHC/Event/Thread.hs#L139

threadWaitSTM :: Event -> Fd -> IO (STM (), IO ())
threadWaitSTM evt fd = mask_ $ do
  m <- newTVarIO Nothing
  mgr <- getSystemEventManager_
  reg <- registerFd mgr (\_ e -> atomically (writeTVar m (Just e))) fd evt M.OneShot
  let waitAction =
        do mevt <- readTVar m
           case mevt of
             Nothing -> retry
             Just evt' ->
               if evt' `eventIs` evtClose
               then throwSTM $ errnoToIOError "threadWaitSTM" eBADF Nothing Nothing
               else return ()
  return (waitAction, unregisterFd_ mgr reg >> return ())

The accept operation in socket:

accept :: (Family f) => Socket f t p -> IO (Socket f t p, SocketAddress f)
accept s@(Socket mfd) =
      alloca $ \addrPtr-> alloca $ \addrPtrLen-> alloca $ \errPtr-> do
        poke addrPtrLen (fromIntegral $ sizeOf (undefined :: SocketAddress f))
        ( fix $ \again iteration-> do
            msa <- withMVar mfd $ \fd-> do
              when (fd < 0) (throwIO eBadFileDescriptor)
              bracketOnError
                ( c_accept fd addrPtr addrPtrLen errPtr )
                ( \ft-> when (ft >= 0) $ alloca $ void . c_close ft )
                ( \ft-> if ft < 0
                  then do
                    err <- SocketException <$> peek errPtr
                    unless (err == eWouldBlock || err == eAgain) (throwIO err)
                    return Nothing
                  else do
                    addr <- peek addrPtr :: IO (SocketAddress f)
                    s'@(Socket mft) <- Socket <$> newMVar ft
                    -- Register a finalizer on the new socket.
                    -- _ <- mkWeakMVar mft (close s')
                    return $ Just (s', addr)
                )
            -- If ews is Left we got EAGAIN or EWOULDBLOCK and retry.
            case msa of
              Just sa -> return sa
              Nothing -> waitRead s iteration >> (again $! iteration + 1)
          ) 0 -- This is the initial iteration value.

The close operation in socket:

close :: Socket f t p -> IO ()
close (Socket mfd) = do
  modifyMVarMasked_ mfd $ \fd-> do
    if fd < 0 then do
      return fd
    else do
      closeFdWith
        ( const $ alloca $ \errPtr-> fix $ \retry-> do
            i <- c_close fd errPtr
            when (i /= 0) $ do
              err <- SocketException <$> peek errPtr
              when (err /= eInterrupted) (throwIO err)
              retry
        ) fd
      return (-1)

Other relevant code snippets:

waitRead :: Socket f t p -> Int -> IO ()
waitRead s _ = wait s threadWaitRead threadWaitReadSTM

waitWrite :: Socket f t p -> Int -> IO ()
waitWrite s _ = wait s threadWaitWrite threadWaitWriteSTM

waitConnected :: Socket f t p -> IO ()
waitConnected  = flip waitWrite 0

wait :: Socket f t p -> (Fd -> IO ()) -> (Fd -> IO (STM (), IO ())) -> IO ()
wait (Socket mfd) threadWait threadWaitSTM
  | rtsSupportsBoundThreads = mapException
    ( const eBadFileDescriptor :: IOError -> SocketException )
    ( bracketOnError
        ( withMVar mfd $ \fd -> do
            when (fd < 0) (throwIO eBadFileDescriptor)
            threadWaitSTM fd
        ) snd ( atomically . fst )
    )
  | otherwise = do
      m <- newEmptyMVar
      bracketOnError
        ( withMVar mfd $ \fd-> do
            when (fd < 0) (throwIO eBadFileDescriptor)
            forkIO $ catch
              ( threadWait fd >> putMVar m True )
              ( \(SomeException _)-> putMVar m False )
        ) killThread
        ( const $ takeMVar m >>= flip unless (throwIO eBadFileDescriptor) )

[lpeterse]

Facts:

• The forked thread is waitRead on the socket.
• The main thread receives the interrupt exception and calls close on the socket.
• The closeFdWith correctly triggers the waiting thread to wake up.
• threadWaitSTM determines this is the close event and throws the IOException.
• wait with mapException WAS INTENDED to convert the exception to eBadFileDescriptor, but this doesn't work.

Hypothesis:

• mapException :: (Exception e1, Exception e2) => (e1 -> e2) -> a -> a is for pure contexts only

[lpeterse]

Correct, this version of wait solves the problem:

wait :: Socket f t p -> (Fd -> IO ()) -> (Fd -> IO (STM (), IO ())) -> IO ()
wait (Socket mfd) threadWait threadWaitSTM
  | rtsSupportsBoundThreads = bracketOnError
        ( withMVar mfd $ \fd -> do
            when (fd < 0) (throwIO eBadFileDescriptor)
            threadWaitSTM fd
        )
        snd ( atomically . fst ) `catch` (const (throwIO eBadFileDescriptor) :: IOError -> IO ())
  | otherwise = ...