module ForkIOScheduler where
import Control.Exception
import Control.Concurrent
import Control.Concurrent.STM
import Control.Eff
import Control.Eff.Lift
import Control.Eff.Concurrent.Process
import Control.Eff.Concurrent.Process.ForkIOScheduler as Scheduler
import Control.Monad (void, forever)
import Test.Tasty
import Test.Tasty.HUnit
import Data.Dynamic
timeoutSeconds :: Integer -> Timeout
timeoutSeconds seconds = Timeout (seconds * 1000000) (show seconds ++ "s")
test_IOExceptionsIsolated :: TestTree
test_IOExceptionsIsolated =
localOption
(timeoutSeconds 30)
$ testGroup "one process throws an IO exception, the other continues unimpaired"
[ testCase ("process 2 exits with: "++ howToExit
++ " - while process 1 is busy with: " ++ busyWith)
$ do aVar <- newEmptyTMVarIO
Scheduler.defaultMain
$ do p1 <- spawn $ forever busyEffect
lift (threadDelay 1000)
void $ spawn $ do lift (threadDelay 1000)
doExit
lift (threadDelay 100000)
wasStillRunningP1 <- sendShutdown forkIoScheduler p1
lift (atomically (putTMVar aVar wasStillRunningP1))
wasStillRunningP1 <- atomically (takeTMVar aVar)
assertBool "the other process was still running" wasStillRunningP1
| (busyWith, busyEffect) <-
[ ("receiving", void (send (ReceiveMessage @SchedulerIO)))
, ("sending", void (send (SendMessage @SchedulerIO 44444 (toDyn "test message"))))
, ("sending shutdown", void (send (SendShutdown @SchedulerIO 44444)))
, ("selfpid-ing", void (send (SelfPid @SchedulerIO)))
, ("spawn-ing", void (send (Spawn @SchedulerIO (void (send (ReceiveMessage @SchedulerIO))))))
]
, (howToExit, doExit) <-
[ ("throw async exception", void (lift (throw UserInterrupt)))
, ("division by zero", void (return ((123::Int) `div` 0) >>= lift . putStrLn . show ))
, ("call 'fail'", void (fail "test fail"))
, ("call 'error'", void (error "test error"))
]
]
test_mainProcessSpawnsAChildAndReturns :: TestTree
test_mainProcessSpawnsAChildAndReturns =
localOption
(timeoutSeconds 30)
(testCase "spawn a child and return"
(Scheduler.defaultMain
(void (spawn (void (receiveMessage forkIoScheduler))))))
test_mainProcessSpawnsAChildAndExitsNormally :: TestTree
test_mainProcessSpawnsAChildAndExitsNormally =
localOption
(timeoutSeconds 30)
(testCase "spawn a child and exit normally"
(Scheduler.defaultMain
(do void (spawn (void (receiveMessage forkIoScheduler)))
void (exitNormally forkIoScheduler)
fail "This should not happen!!"
)))
test_mainProcessSpawnsAChildInABusySendLoopAndExitsNormally :: TestTree
test_mainProcessSpawnsAChildInABusySendLoopAndExitsNormally =
localOption
(timeoutSeconds 300)
(testCase "spawn a child with a busy send loop and exit normally"
(Scheduler.defaultMain
(do void (spawn (forever (void (sendMessage forkIoScheduler 1000 (toDyn "test")))))
void (exitNormally forkIoScheduler)
fail "This should not happen!!"
)))
test_mainProcessSpawnsAChildBothReturn :: TestTree
test_mainProcessSpawnsAChildBothReturn =
localOption
(timeoutSeconds 30)
(testCase "spawn a child and let it return and return"
(Scheduler.defaultMain
(do child <- spawn (void (receiveMessageAs @String forkIoScheduler))
True <- sendMessage forkIoScheduler child (toDyn "test")
return ()
)))
test_mainProcessSpawnsAChildBothExitNormally :: TestTree
test_mainProcessSpawnsAChildBothExitNormally =
localOption
(timeoutSeconds 30)
(testCase "spawn a child and let it exit and exit"
(Scheduler.defaultMain
(do child <- spawn
(do void (receiveMessageAs @String forkIoScheduler)
void (exitNormally forkIoScheduler)
error "This should not happen (child)!!"
)
True <- sendMessage forkIoScheduler child (toDyn "test")
void (exitNormally forkIoScheduler)
error "This should not happen!!"
)))