From 5fdba6b033f4327c908ae28cbcfa0b086a3cda1c Mon Sep 17 00:00:00 2001 From: Edsko de Vries Date: Sat, 11 Nov 2023 17:00:59 +0100 Subject: [PATCH] Fix bug in test suite See introduction of `skipMissedStep`; specifically, the problem was that `ourStep` did not distinguish between aggressive mode and conservative mode (effectively, it assumed aggressive mode always). This resolves a deadlock in the test suite. --- .../Test/Driver/Dialogue/Execution.hs | 90 ++++++++++--------- .../Test/Driver/Dialogue/TestClock.hs | 16 ++-- 2 files changed, 61 insertions(+), 45 deletions(-) diff --git a/test-grapesy/Test/Driver/Dialogue/Execution.hs b/test-grapesy/Test/Driver/Dialogue/Execution.hs index df33d986..b326962d 100644 --- a/test-grapesy/Test/Driver/Dialogue/Execution.hs +++ b/test-grapesy/Test/Driver/Dialogue/Execution.hs @@ -13,7 +13,6 @@ import Control.Monad.State import Data.Bifunctor import Data.Default import Data.List (sortBy) -import Data.Maybe (mapMaybe) import Data.Ord (comparing) import Data.Proxy import Data.Set qualified as Set @@ -221,6 +220,22 @@ ifAggressive Conservative _ = pure () Client-side interpretation -------------------------------------------------------------------------------} +-- | Advance the clock for all non-executed steps +-- +-- When a client or a handler exits (due to an exception, perhaps), then it is +-- important we still step the test clock at the appropriate times, to avoid the +-- rest of the tests stalling. +skipMissedSteps :: + TestClock + -> ExecutionMode + -> (ExecutionMode -> LocalStep -> Bool) + -> [(TestClockTick, LocalStep)] + -> IO () +skipMissedSteps testClock mode ourStep steps = + void $ forkIO $ + advanceTestClockAtTimes testClock $ + map fst $ filter (ourStep mode . snd) steps + clientLocal :: HasCallStack => TestClock @@ -229,29 +244,27 @@ clientLocal :: -> LocalSteps -> IO () clientLocal testClock mode call = \(LocalSteps steps) -> - flip evalStateT (Alive ()) $ go steps + evalStateT (go steps) (Alive ()) `finally` + skipMissedSteps testClock mode ourStep steps where + ourStep :: ExecutionMode -> LocalStep -> Bool + ourStep Aggressive (ClientAction _) = True + ourStep Aggressive (ServerAction _) = False + ourStep Conservative (ClientAction _) = False + ourStep Conservative (ServerAction _) = True + go :: [(TestClockTick, LocalStep)] -> StateT (ServerHealth ()) IO () go [] = return () go ((tick, step) : steps) = do waitFor "client" case step of ClientAction action -> do - liftIO $ waitForTestClockTick testClock tick + _reachedTick <- liftIO $ waitForTestClockTick testClock tick + -- TODO: We could assert that _reachedTick is True continue <- clientAct action `finally` liftIO (ifAggressive mode $ advanceTestClock testClock) - if continue then - go steps - else do - -- See discussion in serverLocal - let ourStep :: (TestClockTick, LocalStep) -> Maybe TestClockTick - ourStep (tick' , ClientAction _) = Just tick' - ourStep (_ , ServerAction _) = Nothing - liftIO $ do - void $ forkIO $ - advanceTestClockAtTimes testClock $ - mapMaybe ourStep steps + when continue $ go steps ServerAction action -> do reactToServer action `finally` liftIO (ifConservative mode $ advanceTestClock testClock) @@ -360,10 +373,10 @@ clientGlobal testClock mode withConn = \(GlobalSteps globalSteps) -> where go :: Maybe Client.Connection -> [Async ()] -> [LocalSteps] -> IO () go _ threads [] = do - -- Wait for all threads to finish - -- - -- This also ensures that if any of these threads threw an exception, - -- that is now rethrown here in the main test. + -- Wait for all threads to finish + -- + -- This also ensures that if any of these threads threw an exception, + -- that is now rethrown here in the main test. mapM_ wait threads go mConn threads (c:cs) = withAsync (runLocalSteps mConn c) $ \newThread -> @@ -373,7 +386,8 @@ clientGlobal testClock mode withConn = \(GlobalSteps globalSteps) -> runLocalSteps mConn (LocalSteps steps) = do case steps of (tick, ClientAction (Initiate (metadata, rpc))) : steps' -> do - waitForTestClockTick testClock tick + _reachedTick <- waitForTestClockTick testClock tick + -- TODO: We could assert that _reachedTick is True -- Timeouts are outside the scope of these tests: it's too finicky -- to relate timeouts (in seconds) to specific test execution. @@ -390,15 +404,15 @@ clientGlobal testClock mode withConn = \(GlobalSteps globalSteps) -> Nothing -> withConn) $ \conn -> Client.withRPC conn params proxy $ \call -> do -- We wait for the /server/ to advance the test clock (so that - -- we are use the next step doesn't happen until the connection - -- is established). + -- we are use the next step doesn't happen until the + -- connection is established). -- -- NOTE: We could instead wait for the server to send the -- initial metadata; this too would provide evidence that the - -- conneciton has been established. However, doing so precludes - -- a class of correct behaviour: the server might not respond - -- with that initial metadata until the client has sent some - -- messages. + -- connection has been established. However, doing so + -- precludes a class of correct behaviour: the server might + -- not respond with that initial metadata until the client has + -- sent some messages. clientLocal testClock mode call (LocalSteps steps') _otherwise -> @@ -458,31 +472,27 @@ serverLocal :: -> Server.Call (BinaryRpc serv meth) -> LocalSteps -> IO () serverLocal testClock mode call = \(LocalSteps steps) -> do - flip evalStateT (Alive ()) $ go steps + evalStateT (go steps) (Alive ()) `finally` + skipMissedSteps testClock mode ourStep steps where + ourStep :: ExecutionMode -> LocalStep -> Bool + ourStep Aggressive (ServerAction _) = True + ourStep Aggressive (ClientAction _) = False + ourStep Conservative (ClientAction _) = False + ourStep Conservative (ServerAction _) = True + go :: [(TestClockTick, LocalStep)] -> StateT (ClientHealth ()) IO () go [] = return () go ((tick, step) : steps) = do waitFor "server" case step of ServerAction action -> do - liftIO $ waitForTestClockTick testClock tick + _reachedTick <- liftIO $ waitForTestClockTick testClock tick + -- TODO: We could assert that _reachedTick is True continue <- serverAct action `finally` liftIO (ifAggressive mode $ advanceTestClock testClock) - if continue then - go steps - else do - -- We need to exit the scope of the handler, but we do want to - -- keep advancing the test clock when its our turn, so that we - -- don't interfere with the timing of other threads. - let ourStep :: (TestClockTick, LocalStep) -> Maybe TestClockTick - ourStep (tick' , ServerAction _) = Just tick' - ourStep (_ , ClientAction _) = Nothing - liftIO $ do - void $ forkIO $ - advanceTestClockAtTimes testClock $ - mapMaybe ourStep steps + when continue $ go steps ClientAction action -> do reactToClient action `finally` liftIO (ifConservative mode $ advanceTestClock testClock) diff --git a/test-grapesy/Test/Driver/Dialogue/TestClock.hs b/test-grapesy/Test/Driver/Dialogue/TestClock.hs index bcf09d01..fb5a6e92 100644 --- a/test-grapesy/Test/Driver/Dialogue/TestClock.hs +++ b/test-grapesy/Test/Driver/Dialogue/TestClock.hs @@ -51,23 +51,29 @@ data TestClockException = TestClockException SomeException CallStack newTestClock :: IO TestClock newTestClock = TestClock <$> newTVarIO (TestClockTick 0) -waitForTestClockTick :: HasCallStack => TestClock -> TestClockTick -> IO () +-- | Wait for the specified clock tick +-- +-- Returns @True@ if we reached the specified tick, or @False@ if the clock is +-- already past the specified tick. +waitForTestClockTick :: HasCallStack => TestClock -> TestClockTick -> IO Bool waitForTestClockTick (TestClock clock) tick = do atomically $ wait `catchSTM` \err -> throwSTM $ TestClockException err callStack where - wait :: STM () + wait :: STM Bool wait = do currentTick <- readTVar clock - unless (currentTick == tick) retry + if | currentTick > tick -> return False -- clock already past + | currentTick == tick -> return True -- reached specified tick + | otherwise -> retry -- time not yet reached advanceTestClock :: TestClock -> IO () advanceTestClock (TestClock clock) = atomically (modifyTVar clock succ) advanceTestClockAtTime :: TestClock -> TestClockTick -> IO () advanceTestClockAtTime clock tick = do - waitForTestClockTick clock tick - advanceTestClock clock + reachedTick <- waitForTestClockTick clock tick + when reachedTick $ advanceTestClock clock advanceTestClockAtTimes :: TestClock -> [TestClockTick] -> IO () advanceTestClockAtTimes = mapM_ . advanceTestClockAtTime