Closed lpeterse closed 5 years ago
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) )
Facts:
waitRead
on the socket.close
on the socket.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 onlyCorrect, 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 = ...
The following program causes an exception (
threadWaitSTM: invalid argument (Bad file descriptor)
) when interrupted with Ctrl+C.The expected behavior is that the thread waiting on the
accept
receives aneBadFileDescriptor :: SocketException
.Environment: