timeout_deadlock.hs

import qualified Data.IORef as I
import qualified Control.Exception as E
import Control.Concurrent
import Control.Exception
import Control.Monad
import Network.Socket

main :: IO ()
main = do
  pairCount <- I.newIORef 0
  mgr <- initialize 1
  sequence_ $ replicate 10000 $ do
    threadDelay 10
    pair <- try $ socketPair AF_UNIX Stream defaultProtocol
    case pair of
         Left e -> do
           let _ = e :: SomeException
           print e
           putStrLn "sleep"
           threadDelay 100000
         Right (sock1, sock2) -> do
           I.atomicModifyIORef pairCount (\i -> (i + 2, ()))
           tid <- forkIO $ do
             -- block until timeout
             _ <- recv sock1 1 `finally` (do
                sClose sock1
                I.atomicModifyIORef pairCount (\i -> (i - 1, ()))
                sClose sock2
                x <- I.atomicModifyIORef pairCount (\i -> (i - 1, i - 1))
                putStrLn $ "Closed, open sockets: " ++ show x)
             return ()

           _ <- register mgr $ do
             killThread tid
             print sock1
             {-
             sClose sock1
             sClose sock2
             -}

           return ()
  threadDelay 100000000

newtype Manager = Manager (I.IORef [Handle])
data Handle = Handle (IO ()) (I.IORef State)
data State = Active | Inactive | Canceled

initialize :: Int -> IO Manager
initialize timeout = do
    ref <- I.newIORef []
    _ <- forkIO $ forever $ do
        threadDelay timeout
        ms <- I.atomicModifyIORef ref (\x -> ([], x))
        ms' <- go ms id
        I.atomicModifyIORef ref (\x -> (ms' x, ()))
    return $ Manager ref
  where
    go [] front = return front
    go (m@(Handle onTimeout iactive):rest) front = do
        state <- I.atomicModifyIORef iactive (\x -> (go' x, x))
        case state of
            Inactive -> do
                onTimeout `E.catch` ignoreAll
                go rest front
            Canceled -> go rest front
            _ -> go rest (front . (:) m)
    go' Active = Inactive
    go' x = x

ignoreAll :: E.SomeException -> IO ()
ignoreAll _ = return ()

register :: Manager -> IO () -> IO Handle
register (Manager ref) onTimeout = do
    iactive <- I.newIORef Active
    let h = Handle onTimeout iactive
    I.atomicModifyIORef ref (\x -> (h : x, ()))
    return h