module Main where
import qualified Control.Concurrent.SSem as SSem
import qualified SlaveThread as S
import Test.Tasty
import Test.Tasty.HUnit
import Prelude
main :: IO ()
main =
defaultMain
$ testGroup "All"
$ [ testCase "Failing in finalizer doesn't break everything" $ do
finalizer1CalledVar <- newTVarIO False
finalizer2CalledVar <- newTVarIO False
result <-
let finalizer1 =
atomically $ writeTVar finalizer1CalledVar True
finalizer2 =
do
atomically $ writeTVar finalizer2CalledVar True
throwIO (userError "finalizer2 failed")
in try @SomeException $ do
S.forkFinally finalizer1 $ do
S.forkFinally finalizer2 $ threadDelay 100
threadDelay (10 ^ 4)
finalizer2Called <- atomically (readTVar finalizer2CalledVar)
finalizer1Called <- atomically (readTVar finalizer1CalledVar)
assertEqual "finalizer2 not called" True finalizer2Called
assertEqual "finalizer1 not called" True finalizer1Called
assertEqual "result is left" True (isLeft result)
assertEqual "Invalid result" True ("finalizer2 failed" `isInfixOf` show result),
testCase "Forked threads run fine" $ do
replicateM_ 100000 $ do
var <- newMVar 0
let increment = modifyMVar_ var (return . succ)
semaphore <- SSem.new 0
S.fork $ do
increment
semaphore' <- SSem.new (-1)
S.fork $ do
increment
SSem.signal semaphore'
S.fork $ do
increment
SSem.signal semaphore'
SSem.wait semaphore'
SSem.signal semaphore
SSem.wait semaphore
assertEqual "" 3 =<< readMVar var,
testCase "Killing a thread kills deep slaves" $ do
replicateM_ 100000 $ do
var <- newMVar 0
semaphore <- SSem.new 0
thread <-
S.forkFinally (SSem.signal semaphore) $ do
join $ forkWait $ do
join $ forkWait $ do
w <- forkWait $ do
threadDelay $ 10 ^ 6
modifyMVar_ var (return . succ)
threadDelay $ 10 ^ 6
modifyMVar_ var (return . succ)
w
killThread thread
SSem.wait semaphore
assertEqual "" 0 =<< readMVar var,
testCase "Dying normally kills slaves" $ do
replicateM_ 100000 $ do
var <- newIORef 0
let increment = modifyIORef var (+ 1)
semaphore <- SSem.new 0
S.forkFinally (SSem.signal semaphore) $ do
S.fork $ do
threadDelay $ 10 ^ 6
increment
S.fork $ do
threadDelay $ 10 ^ 6
increment
SSem.wait semaphore
assertEqual "" 0 =<< readIORef var,
testCase "Finalization is in order" $ do
replicateM_ 100000 $ do
var <- newMVar []
semaphore <- SSem.new 0
S.forkFinally (uninterruptibleMask_ (modifyMVar_ var (return . (1 :)) >> SSem.signal semaphore)) $ do
semaphore' <- SSem.new 0
S.forkFinally (uninterruptibleMask_ (modifyMVar_ var (return . (2 :)) >> SSem.signal semaphore')) $ do
S.forkFinally (uninterruptibleMask_ (modifyMVar_ var (return . (3 :)))) $ return ()
S.forkFinally (uninterruptibleMask_ (modifyMVar_ var (return . (3 :)))) $ return ()
SSem.wait semaphore'
SSem.wait semaphore
assertEqual "" [1, 2, 3, 3] =<< readMVar var,
testCase "Exceptions don't get lost" $ do
replicateM_ 100000 $ do
result <- try @SomeException $ do
S.fork $ do
S.fork $ do
error "!"
threadDelay $ 10 ^ 6
threadDelay $ 10 ^ 6
assertBool "" (isLeft result),
testCase "Slaves are finalized before master" $ do
replicateM_ 100000 $ do
ready <- newEmptyMVar
var <- newEmptyTMVarIO
thread <-
S.forkFinally (atomically (tryPutTMVar var 1)) $ do
S.forkFinally (atomically (tryPutTMVar var 0))
$ threadDelay
$ 10
^ 6
putMVar ready ()
threadDelay $ 10 ^ 6
takeMVar ready
killThread thread
assertEqual "First finalizer is not slave" 0 =<< atomically (readTMVar var),
testCase "Slave thread finalizer is not interrupted by its own death (#11)" $ do
-- Set up the ref that should be written to by thread 2's finalizer,
-- otherwise there's a bug.
ref <- newIORef True
-- Let the main thread know when it should check the above IORef.
done <- newEmptyMVar
-- The gist of the test below: assert that, when a thread fails (here, the
-- inner thread), its finalizer is not interrupted by a ThreadKilled
-- thrown by the parent, which was originally triggered by its own death.
S.forkFinally (putMVar done ()) $ do
-- Let thread 2 know when it should die, with thread 1's exception
-- handler in place.
ready <- newEmptyMVar
S.forkFinally
(catch @SomeException (threadDelay (10 ^ 5)) (\_ -> writeIORef ref False))
$ do
-- Wait until thread 1 is ready for us to die.
takeMVar ready
-- Die.
throwIO (userError "")
catch @SomeException
( -- Tell thread 2 we're ready for it to die
putMVar ready ()
>>
-- Sleep until thread 2 kills us.
threadDelay (10 ^ 5 * 2)
)
-- Ignore thread 2's exception, so we don't propagate it up to the
-- main thread.
(\_ -> return ())
takeMVar done
assertBool "Slave thread finalizer interrupted" =<< readIORef ref,
testCase "Master kills all slaves, even if it is thrown an exception during (#13)" $ do
survived <- newEmptyTMVarIO
ready <- newEmptyMVar
done <- newEmptyMVar
thread <-
S.fork $ do
S.forkFinally (atomically (tryPutTMVar survived True)) $ do
uninterruptibleMask_ (putMVar ready () >> threadDelay (10 ^ 6))
atomically (putTMVar survived False)
takeMVar ready
putMVar done ()
takeMVar done
threadDelay $ 10 ^ 5 -- be reasonably sure it's trying to kill its child
killThread thread
assertBool "Slave thread not killed by master" =<< atomically (takeTMVar survived)
]
forkWait :: IO a -> IO (IO ())
forkWait io =
do
v <- newEmptyMVar
S.fork $ do
r <- try @SomeException io
putMVar v ()
either throwIO return r
return $ takeMVar v