time-warp-0.1.1: test/Test/Control/TimeWarp/Timed/ExceptionSpec.hs
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
module Test.Control.TimeWarp.Timed.ExceptionSpec
( spec
) where
import Control.Concurrent.STM (atomically)
import Control.Concurrent.STM.TVar (TVar, modifyTVar, newTVarIO,
readTVarIO)
import Control.Exception.Base (ArithException (Overflow),
AsyncException (ThreadKilled),
SomeException (..))
import Control.Monad.Catch (catch, catchAll, throwM)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans (MonadIO)
import Test.Hspec (Spec, before, describe)
import Test.Hspec.QuickCheck (prop)
import Test.QuickCheck (NonNegative (..), Property)
import Test.QuickCheck.Monadic (monadicIO)
import Test.QuickCheck.Property (Result (reason), failed,
ioProperty, succeeded)
import Control.TimeWarp.Logging (Severity (Error), initLogging)
import Control.TimeWarp.Timed (Microsecond, TimedT, after,
fork_, fork, invoke, runTimedT,
sec, wait, for, throwTo)
import Test.Control.TimeWarp.Common ()
spec :: Spec
spec =
before (initLogging ["dunno"] Error) $
describe "WorkMode" $ do
describe "error" $ do
prop "should abort the execution"
exceptionShouldAbortExecution
prop "caught nicely"
excCaught
prop "exception from main thread caught outside of monad"
excCaughtOutside
prop "exception from main thread caught outside of monad (+ wait)"
excCaughtOutsideWithWait
prop "proper catch order (catch inside catch)"
excCatchOrder
prop "(wait + throw) - exception doesn't get lost"
excWaitThrow
prop "(wait + throw) in forked thread - exception doesn't get lost"
excWaitThrowForked
prop "catch doesn't handle future exceptions"
excCatchScope
prop "catch doesn't handle future exceptions (with wait inside)"
excCatchScopeWithWait
prop "different exceptions, catch inner"
excDiffCatchInner
prop "different exceptions, catch outer"
excDiffCatchOuter
describe "handler error" $
prop "throws"
handlerThrow
describe "async error" $ do
prop "shouldn't abort the execution"
asyncExceptionShouldntAbortExecution
prop "throwTo throws correct exception"
throwToThrowsCorrectException
prop "throwTo can kell thread"
throwToCanKillThread
-- FIXME
exceptionShouldAbortExecution
:: NonNegative Microsecond
-> Property
exceptionShouldAbortExecution (getNonNegative -> t) = (const (monadicIO $ pure ())) t
-- monadicIO $
-- do var <- liftIO $ newTVarIO (0 :: Int)
-- runTimedT $
-- fork_ $
-- do liftIO $ atomically $ writeTVar var 1
-- wait $ for t mcs
-- void $ throwM $ TextException "Error"
-- liftIO $ atomically $ writeTVar var 2
-- res <- liftIO $ readTVarIO var
-- assert $ res == 1
-- FIXME
asyncExceptionShouldntAbortExecution
:: NonNegative Microsecond
-> NonNegative Microsecond
-> Property
asyncExceptionShouldntAbortExecution (getNonNegative -> t1) (getNonNegative -> t2) = (const (const (monadicIO $ pure ()))) t1 t2
-- monadicIO $
-- do var <- liftIO $ newTVarIO (0 :: Int)
-- runTimedT $
-- do liftIO $ atomically $ writeTVar var 1
-- fork_ $
-- do wait $ for t2 mcs
-- throwM $ TextException "Error"
-- wait $ for t1 mcs
-- liftIO $ atomically $ writeTVar var 2
-- res <- liftIO $ readTVarIO var
-- assert $ res == 2
excCaught
:: Property
excCaught =
ioProperty . withCheckPoints $
\checkPoint -> runEmu $
let act = throwM ThreadKilled >> checkPoint (-1)
hnd _ = checkPoint 1
in act `catchAll` hnd
excCaughtOutside
:: Property
excCaughtOutside =
ioProperty . withCheckPoints $
\checkPoint ->
let act = do
runEmu $ wait (for 1 sec) >> throwM ThreadKilled
checkPoint (-1)
hnd _ = checkPoint 1
in do act `catchAll` hnd
checkPoint 2
excCaughtOutsideWithWait
:: Property
excCaughtOutsideWithWait =
ioProperty . withCheckPoints $
\checkPoint ->
let act = do
runEmu $ throwM ThreadKilled
checkPoint (-1)
hnd _ = checkPoint 1
in do act `catchAll` hnd
checkPoint 2
excWaitThrow
:: Property
excWaitThrow =
ioProperty . withCheckPoints $
\checkPoint ->
runEmu $
let act = do
wait (for 1 sec)
throwM ThreadKilled
hnd _ = checkPoint 1
in do act `catchAll` hnd
checkPoint 2
excWaitThrowForked
:: Property
excWaitThrowForked =
ioProperty . withCheckPoints $
\checkPoint ->
runEmu $
let act = do
wait (for 1 sec)
throwM ThreadKilled
hnd _ = checkPoint 1
in do fork_ $ act `catchAll` hnd
invoke (after 1 sec) $ checkPoint 2
excCatchOrder
:: Property
excCatchOrder =
ioProperty . withCheckPoints $
\checkPoint ->
runEmu $
let act = throwM ThreadKilled
hnd1 _ = checkPoint 1
hnd2 _ = checkPoint (-1)
in do act `catchAll` hnd1 `catchAll` hnd2
checkPoint 2
excCatchScope
:: Property
excCatchScope =
ioProperty . withCheckPoints $
\checkPoint ->
runEmu $
let act1 = checkPoint 1 `catchAll` const (checkPoint $ -1)
act2 = act1 >> throwM ThreadKilled
in do act2 `catchAll` const (checkPoint 2)
checkPoint 3
excCatchScopeWithWait :: Property
excCatchScopeWithWait =
ioProperty . withCheckPoints $
\checkPoint ->
runEmu $
let act1 = checkPoint 1 >> wait (for 1 sec)
act2 = act1 `catchAll` const (checkPoint $ -1)
act3 = act2 >> wait (for 1 sec) >> throwM ThreadKilled
in do act3 `catchAll` const (checkPoint 2)
checkPoint 3
excDiffCatchInner
:: Property
excDiffCatchInner =
ioProperty . withCheckPoints $
\checkPoint ->
runEmu $
let act = throwM ThreadKilled
hnd1 (_ :: AsyncException) = checkPoint 1
hnd2 (_ :: ArithException) = checkPoint (-1)
in do act `catch` hnd1 `catch` hnd2
checkPoint 2
excDiffCatchOuter
:: Property
excDiffCatchOuter =
ioProperty . withCheckPoints $
\checkPoint ->
runEmu $
let act = throwM Overflow
hnd1 (_ :: AsyncException) = checkPoint (-1)
hnd2 (_ :: ArithException) = checkPoint 1
in do act `catch` hnd1 `catch` hnd2
checkPoint 2
handlerThrow
:: Property
handlerThrow =
ioProperty . withCheckPoints $
\checkPoint ->
runEmu $
let act = throwM ThreadKilled
hnd1 (_ :: SomeException) = throwM Overflow
hnd2 (_ :: ArithException) = checkPoint 1
in do act `catch` hnd1 `catch` hnd2
checkPoint 2
throwToThrowsCorrectException
:: Property
throwToThrowsCorrectException =
ioProperty . withCheckPoints $
\checkPoint ->
runEmu $ do
tid <- fork $ catch (wait $ for 1 sec) $
\(_ :: ArithException) -> checkPoint 1
throwTo tid $ SomeException Overflow -- should be unwrapped
-- automatically
wait $ for 2 sec
checkPoint 2
throwToCanKillThread
:: Property
throwToCanKillThread =
ioProperty . withCheckPoints $
\checkPoint ->
runEmu $ do
tid <- fork $ wait (for 1 sec) >> checkPoint (-1)
throwTo tid Overflow
runEmu :: TimedT IO () -> IO ()
runEmu = runTimedT
-- Principle of checkpoints: every checkpoint has it's id
-- Checkpoints should be visited in according order: 1, 2, 3 ...
newtype CheckPoints = CP { getCP :: TVar (Either String Int) }
initCheckPoints :: MonadIO m => m CheckPoints
initCheckPoints = fmap CP $ liftIO $ newTVarIO $ Right 0
visitCheckPoint :: MonadIO m => CheckPoints -> Int -> m ()
visitCheckPoint cp curId = liftIO $ atomically $ modifyTVar (getCP cp) $
\wasId ->
if wasId == Right (curId - 1)
then Right curId
else Left $ either id (showError curId) wasId
where
showError cur was = mconcat
["Wrong chechpoint. Expected "
, show (was + 1)
, ", but visited "
, show cur
]
assertCheckPoints :: MonadIO m => CheckPoints -> m Result
assertCheckPoints = fmap mkRes . liftIO . readTVarIO . getCP
where
mkRes (Left msg) = failed { reason = msg }
mkRes (Right _) = succeeded
withCheckPoints :: MonadIO m => ((Int -> m ()) -> IO a) -> IO Result
withCheckPoints act = do
cp <- initCheckPoints
_ <- act $ liftIO . visitCheckPoint cp
assertCheckPoints cp