module Main where
import Prelude
import Test.QuickCheck.Instances
import Test.Tasty
import Test.Tasty.Runners
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck
import qualified Test.QuickCheck as QuickCheck
import qualified Test.QuickCheck.Property as QuickCheck
import qualified SlaveThread as S
import qualified Control.Concurrent.SSem as SSem
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 "Invalid result" "Left user error (finalizer2 failed)" (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