Skip to content

Commit 5c4be79

Browse files
carbolymercarbolymer
committed
wip
1 parent 78b1c61 commit 5c4be79

File tree

4 files changed

+135
-29
lines changed

4 files changed

+135
-29
lines changed

‎hedgehog-extras.cabal

+2
Original file line numberDiff line numberDiff line change
@@ -139,6 +139,8 @@ test-suite hedgehog-extras-test
139139
hedgehog,
140140
hedgehog-extras,
141141
network,
142+
process,
143+
resourcet,
142144
tasty,
143145
tasty-hedgehog,
144146
transformers,

‎src/Hedgehog/Extras/Test/Concurrent.hs

+19-1
Original file line numberDiff line numberDiff line change
@@ -66,13 +66,16 @@ __Don't use concurrency abstractions from this module, when you need to aggregat
6666
-}
6767
module Hedgehog.Extras.Test.Concurrent
6868
( threadDelay
69+
, asyncRegister_
6970
-- * Re-exports of concurrency abstractions from @lifted-base@
7071
, module Control.Concurrent.Async.Lifted
72+
, module Control.Concurrent.MVar.Lifted
7173
, module System.Timeout.Lifted
7274
) where
7375

7476
import Control.Applicative
7577
import Control.Concurrent.Async.Lifted
78+
import Control.Concurrent.MVar.Lifted
7679
import qualified Control.Concurrent.Lifted as IO
7780
import Control.Monad.Base
7881
import Control.Monad.IO.Class
@@ -87,11 +90,26 @@ import qualified UnliftIO
8790

8891
import Hedgehog
8992
import qualified Hedgehog as H
93+
import Control.Monad.Catch (MonadCatch)
94+
import Control.Monad
95+
import GHC.Stack
9096

9197
-- | Delay the thread by 'n' milliseconds.
92-
threadDelay :: (MonadTest m, MonadIO m) => Int -> m ()
98+
threadDelay :: (HasCallStack, MonadTest m, MonadIO m) => Int -> m ()
9399
threadDelay n = GHC.withFrozenCallStack . H.evalIO $ IO.threadDelay n
94100

101+
-- | Runs an action in background, and registers cleanup to `MonadResource m`
102+
asyncRegister_ :: HasCallStack
103+
=> MonadTest m
104+
=> MonadResource m
105+
=> MonadCatch m
106+
=> IO a -- ^ Action to run in background
107+
-> m ()
108+
asyncRegister_ act = void . H.evalM $ allocate (async act) cleanUp
109+
where
110+
cleanUp :: Async a -> IO ()
111+
cleanUp a = cancel a >> void (link a)
112+
95113
instance MonadBase IO (ResourceT IO) where
96114
liftBase = liftIO
97115

‎src/Hedgehog/Extras/Test/Tripwire.hs

+32-8
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,12 @@
11
{-# LANGUAGE RankNTypes #-}
2-
module Hedgehog.Extras.Test.Tripwire where
2+
module Hedgehog.Extras.Test.Tripwire
3+
( Tripwire
4+
, makeTripwire
5+
, triggerTripwire
6+
, resetTripwire
7+
, checkTripwire
8+
, isTriggered
9+
) where
310

411
import Control.Monad.IO.Class
512
import GHC.Stack
@@ -11,27 +18,44 @@ import qualified Hedgehog.Internal.Property as H
1118
import Control.Concurrent.MVar
1219
import Control.Monad
1320

14-
data Tripwire = Tripwire (MVar CallStack)
21+
-- | Represents a tripwire which can be triggered only once
22+
newtype Tripwire = Tripwire (MVar CallStack)
1523

24+
-- | Creates a new tripwire
1625
makeTripwire :: MonadIO m => m Tripwire
1726
makeTripwire = Tripwire <$> liftIO newEmptyMVar
1827

28+
-- | Triggers the tripwire and registers the place of the first trigger. Idempotent.
29+
-- Does not do do anything besides just registering the place where this function is called.
1930
triggerTripwire :: HasCallStack
2031
=> MonadIO m
2132
=> Tripwire
2233
-> m ()
2334
triggerTripwire (Tripwire mv) = withFrozenCallStack $
24-
liftIO $ putMVar mv callStack
35+
void . liftIO $ tryPutMVar mv callStack
2536

37+
-- | Restore tripwire to initial non triggered state
38+
resetTripwire :: MonadIO m
39+
=> Tripwire
40+
-> m ()
41+
resetTripwire (Tripwire mv) = liftIO $ void $ tryTakeMVar mv
42+
43+
-- | Check if the tripwire is triggered. Return the first trigger location.
44+
isTriggered :: MonadIO m
45+
=> Tripwire
46+
-> m (Maybe CallStack)
47+
isTriggered (Tripwire mv) = liftIO $ tryReadMVar mv
48+
49+
-- | Fails the test if the tripwire was triggered. Prints the callstack where the tripwire was triggered.
2650
checkTripwire :: HasCallStack
2751
=> MonadTest m
2852
=> MonadIO m
2953
=> Tripwire
3054
-> m ()
31-
checkTripwire (Tripwire mv) = withFrozenCallStack $ do
32-
liftIO (tryReadMVar mv)
33-
>>= void . mapM (\cs -> do
34-
H.note_ $ prettyCallStack cs
55+
checkTripwire = withFrozenCallStack $ do
56+
isTriggered >=> void . mapM
57+
(\cs -> do
58+
H.note_ $ "Tripwire has been tripped at: " <> prettyCallStack cs
3559
H.failure
36-
)
60+
)
3761

‎test/Hedgehog/Extras/Test/TestWatchdogSpec.hs

+82-20
Original file line numberDiff line numberDiff line change
@@ -1,46 +1,108 @@
11
{-# LANGUAGE NumericUnderscores #-}
22
module Hedgehog.Extras.Test.TestWatchdogSpec where
33

4+
import Control.Concurrent
5+
import Control.Monad
6+
import Control.Monad.IO.Class
7+
import Control.Monad.Trans.Except (runExceptT)
8+
import Control.Monad.Trans.Resource (ResourceT, runResourceT)
9+
import Control.Monad.Trans.Writer.Lazy (runWriterT)
410
import Data.Function
511
import Data.Semigroup
6-
import Hedgehog (Property)
12+
import GHC.Conc
13+
import GHC.Stack
14+
import Hedgehog (Property, (===))
715
import qualified Hedgehog as H
816
import qualified Hedgehog.Extras as H
917
import qualified Hedgehog.Extras.Stock.IO.Network.Port as IO
10-
import Hedgehog.Extras.Test.TestWatchdog
1118
import qualified Hedgehog.Extras.Test.Concurrent as H
19+
import Hedgehog.Extras.Test.TestWatchdog
1220
import qualified Hedgehog.Internal.Property as H
13-
import Control.Monad.Trans.Writer.Lazy (runWriterT)
14-
import Control.Monad.Trans.Except (runExceptT)
1521
import qualified Network.Socket as N
22+
import Prelude
1623
import Text.Show
17-
import Control.Monad
18-
import Prelude
19-
import Control.Monad.IO.Class
20-
import GHC.Stack
21-
import Control.Concurrent
22-
import GHC.Conc
24+
import qualified System.Process as P
2325

2426
hprop_check_watchdog_kills_hanged_thread :: Property
2527
hprop_check_watchdog_kills_hanged_thread = H.propertyOnce $ do
2628
let watchdogCfg = WatchdogConfig 1
27-
childTid <- liftIO $ newEmptyMVar
28-
(res, log') <- runTestT $ runWithWatchdog_ watchdogCfg $ do
29-
liftIO $ myThreadId >>= putMVar childTid
30-
void . forever $ H.threadDelay 1_000_000
31-
H.success
29+
childTid <- H.newEmptyMVar
30+
tripwire <- H.makeTripwire
31+
32+
_ <- spawnTestT $ runWithWatchdog_ watchdogCfg $ do
33+
liftIO $ myThreadId >>= H.putMVar childTid
34+
-- simulate thread hang
35+
void $ H.threadDelay 3_000_000
36+
H.triggerTripwire tripwire
37+
38+
-- make sure that we accidentally didn't trigger the tripwire
39+
H.checkTripwire tripwire
40+
childStatus <- liftIO $ H.readMVar childTid >>= threadStatus
41+
childStatus === ThreadFinished
42+
43+
-- TODO make only unix test case
44+
hprop_check_watchdog_kills_hanged_thread_with_its_children :: Property
45+
hprop_check_watchdog_kills_hanged_thread_with_its_children = H.propertyOnce $ do
46+
let watchdogCfg = WatchdogConfig 1
47+
childTid <- H.newEmptyMVar
48+
grandChildTid1 <- H.newEmptyMVar
49+
grandChildTid2 <- H.newEmptyMVar
50+
procHandle <- H.newEmptyMVar
51+
childTripwire <- H.makeTripwire
52+
grandChildTripwire <- H.makeTripwire
53+
54+
_ <- spawnTestT $ runWithWatchdog_ watchdogCfg $ do
55+
liftIO $ myThreadId >>= H.putMVar childTid
56+
57+
(_, _, _, h, _) <- H.createProcess $ P.shell "tail -f /dev/null"
58+
H.putMVar procHandle h
59+
60+
H.asyncRegister_ $ do
61+
liftIO $ myThreadId >>= H.putMVar grandChildTid1
62+
threadDelay 3_000_000
63+
H.triggerTripwire grandChildTripwire
64+
65+
H.asyncRegister_ $ do
66+
liftIO $ myThreadId >>= H.putMVar grandChildTid2
67+
threadDelay 3_000_000
68+
H.triggerTripwire grandChildTripwire
69+
70+
void $ H.threadDelay 3_000_000
71+
H.triggerTripwire childTripwire
72+
73+
-- wait for OS to kill the spawned process
74+
t <- liftIO getUtcTime
75+
H.byDeadlineM
3276
H.threadDelay 1_000_000
33-
H.noteShowM_ . liftIO $ (readMVar childTid >>= threadStatus)
77+
-- make sure that we accidentally didn't trigger the tripwire
78+
H.checkTripwire childTripwire
79+
H.checkTripwire grandChildTripwire
80+
81+
childStatus <- liftIO $ H.readMVar childTid >>= threadStatus
82+
childStatus === ThreadFinished
83+
84+
grandChildStatus1 <- liftIO $ H.readMVar grandChildTid1 >>= threadStatus
85+
grandChildStatus1 === ThreadFinished
86+
87+
grandChildStatus2 <- liftIO $ H.readMVar grandChildTid1 >>= threadStatus
88+
grandChildStatus2 === ThreadFinished
89+
90+
-- check that tail process got killed
91+
tailPid <- liftIO $ H.readMVar procHandle >>= P.getPid
92+
tailPid === Nothing
3493
H.failure
3594

36-
runTestT :: HasCallStack
95+
spawnTestT :: HasCallStack
3796
=> H.MonadTest m
3897
=> MonadIO m
3998
=> Show a
40-
=> H.TestT IO a
99+
=> H.TestT (ResourceT IO) a
41100
-> m (Either H.Failure a, H.Journal)
42-
runTestT testt = withFrozenCallStack $ do
43-
(res, log') <- H.evalIO . runWriterT . runExceptT . H.unTest $ testt
101+
spawnTestT testt = withFrozenCallStack $ do
102+
(res, log') <- H.evalIO $
103+
H.withAsync
104+
(runResourceT . runWriterT . runExceptT $ H.unTest testt)
105+
H.wait
44106
H.noteShow_ res
45107
H.noteShow_ log'
46108
pure (res, log')

0 commit comments

Comments
 (0)