Skip to content

Commit 74a0639

Browse files
carbolymercarbolymer
committed
wip
1 parent 78b1c61 commit 74a0639

File tree

4 files changed

+171
-35
lines changed

4 files changed

+171
-35
lines changed

‎hedgehog-extras.cabal

+3
Original file line numberDiff line numberDiff line change
@@ -139,9 +139,12 @@ test-suite hedgehog-extras-test
139139
hedgehog,
140140
hedgehog-extras,
141141
network,
142+
process,
143+
resourcet,
142144
tasty,
143145
tasty-hedgehog,
144146
transformers,
147+
time,
145148
hs-source-dirs: test
146149
main-is: hedgehog-extras-test.hs
147150
type: exitcode-stdio-1.0

‎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 its cancellation to 'MonadResource'.
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

+117-26
Original file line numberDiff line numberDiff line change
@@ -1,46 +1,137 @@
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
5-
import Data.Semigroup
6-
import Hedgehog (Property)
11+
import Data.List (isPrefixOf)
12+
import Data.Time.Clock as D
13+
import GHC.Conc
14+
import GHC.Stack
15+
import Hedgehog (Property, (===))
716
import qualified Hedgehog as H
817
import qualified Hedgehog.Extras as H
9-
import qualified Hedgehog.Extras.Stock.IO.Network.Port as IO
10-
import Hedgehog.Extras.Test.TestWatchdog
11-
import qualified Hedgehog.Extras.Test.Concurrent as H
18+
import qualified Hedgehog.Extras.Stock 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)
15-
import qualified Network.Socket as N
16-
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
21+
import Prelude
22+
import qualified System.Process as P
2323

24+
-- | Check that watchdog kills test case which waits without an end
2425
hprop_check_watchdog_kills_hanged_thread :: Property
2526
hprop_check_watchdog_kills_hanged_thread = H.propertyOnce $ do
2627
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
32-
H.threadDelay 1_000_000
33-
H.noteShowM_ . liftIO $ (readMVar childTid >>= threadStatus)
28+
childTid <- H.newEmptyMVar
29+
tripwire <- H.makeTripwire
30+
31+
(result, _) <- spawnTestT $ runWithWatchdog_ watchdogCfg $ do
32+
liftIO $ myThreadId >>= H.putMVar childTid
33+
-- simulate thread hang
34+
void $ H.threadDelay 3_000_000
35+
H.triggerTripwire tripwire
36+
37+
_ <- case result of
38+
Right () -> do
39+
H.note_ "Expected failure instead of Right"
40+
H.failure
41+
Left (H.Failure _ msg _) -> do
42+
-- check we've failed because of watchdog
43+
_header:exception:_ <- pure $ lines msg
44+
H.assertWith exception $
45+
isPrefixOf "WatchdogException: "
46+
47+
-- make sure that we didn't trigger the tripwire
48+
H.checkTripwire tripwire
49+
childStatus <- liftIO $ H.readMVar childTid >>= threadStatus
50+
childStatus === ThreadFinished
51+
52+
-- | Check that watchdog kills test case which spawns:
53+
-- - a process waiting forever
54+
-- - a child threads waiting
55+
hprop_check_watchdog_kills_hanged_thread_with_its_children :: Property
56+
hprop_check_watchdog_kills_hanged_thread_with_its_children = H.propertyOnce $ do
57+
let watchdogCfg = WatchdogConfig 1
58+
childTid <- H.newEmptyMVar
59+
grandChildTid1 <- H.newEmptyMVar
60+
grandChildTid2 <- H.newEmptyMVar
61+
procHandle <- H.newEmptyMVar
62+
childTripwire <- H.makeTripwire
63+
grandChildTripwire1 <- H.makeTripwire
64+
grandChildTripwire2 <- H.makeTripwire
65+
66+
(result, _) <- spawnTestT $ runWithWatchdog_ watchdogCfg $ do
67+
liftIO $ myThreadId >>= H.putMVar childTid
68+
69+
unless H.isWin32 $ do
70+
(_, _, _, h, _) <- H.createProcess $ P.shell "tail -f /dev/null"
71+
H.putMVar procHandle h
72+
73+
H.asyncRegister_ $ do
74+
liftIO $ myThreadId >>= H.putMVar grandChildTid1
75+
threadDelay 3_000_000
76+
H.triggerTripwire grandChildTripwire1
77+
78+
H.asyncRegister_ $ do
79+
liftIO $ myThreadId >>= H.putMVar grandChildTid2
80+
threadDelay 3_000_000
81+
H.triggerTripwire grandChildTripwire2
82+
83+
void $ H.threadDelay 3_000_000
84+
H.triggerTripwire childTripwire
85+
86+
_ <- case result of
87+
Right () -> do
88+
H.note_ "Expected failure instead of Right"
89+
H.failure
90+
Left (H.Failure _ msg _) -> do
91+
-- check we've failed because of watchdog
92+
_header:exception:_ <- pure $ lines msg
93+
H.assertWith exception $
94+
isPrefixOf "WatchdogException: "
95+
96+
-- Give OS 5 seconds to do the process cleanup
97+
deadline <- D.addUTCTime 5 <$> liftIO D.getCurrentTime
98+
-- make sure that we didn't trigger the tripwire
99+
H.checkTripwire childTripwire
100+
H.checkTripwire grandChildTripwire1
101+
H.checkTripwire grandChildTripwire2
102+
103+
H.byDeadlineM 0.2 deadline "childStatus" $ do
104+
childStatus <- liftIO $ H.readMVar childTid >>= threadStatus
105+
childStatus === ThreadFinished
106+
107+
H.byDeadlineM 0.2 deadline "grandChildStatus1" $ do
108+
grandChildStatus1 <- liftIO $ H.readMVar grandChildTid1 >>= threadStatus
109+
grandChildStatus1 === ThreadFinished
110+
111+
H.byDeadlineM 0.2 deadline "grandChildStatus1" $ do
112+
grandChildStatus2 <- liftIO $ H.readMVar grandChildTid1 >>= threadStatus
113+
grandChildStatus2 === ThreadFinished
114+
115+
-- check that tail process got killed
116+
unless H.isWin32 $
117+
H.byDeadlineM 0.2 deadline "tailPid" $ do
118+
tailPid <- liftIO $ H.readMVar procHandle >>= P.getPid
119+
tailPid === Nothing
120+
34121
H.failure
35122

36-
runTestT :: HasCallStack
123+
-- | Spawn TestT in an async. Waits for the async and logs the result as well as errors journal on failure
124+
spawnTestT :: HasCallStack
37125
=> H.MonadTest m
38126
=> MonadIO m
39127
=> Show a
40-
=> H.TestT IO a
128+
=> H.TestT (ResourceT IO) a
41129
-> m (Either H.Failure a, H.Journal)
42-
runTestT testt = withFrozenCallStack $ do
43-
(res, log') <- H.evalIO . runWriterT . runExceptT . H.unTest $ testt
130+
spawnTestT testt = withFrozenCallStack $ do
131+
(res, log') <- H.evalIO $
132+
H.withAsync
133+
(runResourceT . runWriterT . runExceptT $ H.unTest testt)
134+
H.wait
44135
H.noteShow_ res
45136
H.noteShow_ log'
46137
pure (res, log')

0 commit comments

Comments
 (0)