From 4494b8a7894c518d639698ed74e5bc714073b10c Mon Sep 17 00:00:00 2001 From: thomasjm Date: Tue, 5 Nov 2024 04:55:27 -0800 Subject: [PATCH] Test simplification --- test/FSNotify/Test/EventTests.hs | 31 +++++++++----------------- test/FSNotify/Test/Util.hs | 38 ++++++++++++++++++-------------- test/Main.hs | 8 +++---- 3 files changed, 36 insertions(+), 41 deletions(-) diff --git a/test/FSNotify/Test/EventTests.hs b/test/FSNotify/Test/EventTests.hs index 3e77f7b..bfc2368 100644 --- a/test/FSNotify/Test/EventTests.hs +++ b/test/FSNotify/Test/EventTests.hs @@ -32,17 +32,17 @@ eventTests threadingMode = describe "Tests" $ parallelWithoutDirectory $ do let pollOptions = if isBSD then [True] else [False, True] forM_ pollOptions $ \poll -> describe (if poll then "Polling" else "Native") $ parallelWithoutDirectory $ do - let timeInterval = if poll then 2*10^(6 :: Int) else 5*10^(5 :: Int) forM_ [False, True] $ \recursive -> describe (if recursive then "Recursive" else "Non-recursive") $ parallelWithoutDirectory $ forM_ [False, True] $ \nested -> describe (if nested then "Nested" else "Non-nested") $ parallelWithoutDirectory $ - eventTests' timeInterval threadingMode poll recursive nested + eventTests' threadingMode poll recursive nested eventTests' :: ( MonadUnliftIO m, MonadThrow m - ) => Int -> ThreadingMode -> Bool -> Bool -> Bool -> SpecFree context m () -eventTests' timeInterval threadingMode poll recursive nested = do - let withFolder = withTestFolder timeInterval threadingMode poll recursive nested - let waitForEvents getEvents action = pauseAndRetryOnExpectationFailure timeInterval 3 (liftIO getEvents >>= action) + ) => ThreadingMode -> Bool -> Bool -> Bool -> SpecFree context m () +eventTests' threadingMode poll recursive nested = do + let withFolder' = withTestFolder threadingMode poll recursive nested + let withFolder = withFolder' (const $ return ()) + let waitForEvents getEvents action = waitUntil 5.0 (liftIO getEvents >>= action) unless (nested || poll || isMac || isWin) $ it "deletes the watched directory" $ withFolder $ \(TestFolderContext watchedDir _f getEvents _clearEvents) -> do removeDirectory watchedDir @@ -76,9 +76,7 @@ eventTests' timeInterval threadingMode poll recursive nested = do [Added {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsDirectory -> return () _ -> expectationFailure $ "Got wrong events: " <> show events - it "works with a deleted file" $ withFolder $ \(TestFolderContext _watchedDir f getEvents clearEvents) -> do - liftIO (writeFile f "" >> clearEvents) - + it "works with a deleted file" $ withFolder' (\f -> liftIO $ writeFile f "") $ \(TestFolderContext _watchedDir f getEvents _clearEvents) -> do removeFile f waitForEvents getEvents $ \events -> @@ -87,9 +85,7 @@ eventTests' timeInterval threadingMode poll recursive nested = do [Removed {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return () _ -> expectationFailure $ "Got wrong events: " <> show events - it "works with a deleted directory" $ withFolder $ \(TestFolderContext _watchedDir f getEvents clearEvents) -> do - createDirectory f >> liftIO clearEvents - + it "works with a deleted directory" $ withFolder' (\f -> liftIO $ createDirectory f) $ \(TestFolderContext _watchedDir f getEvents _clearEvents) -> do removeDirectory f waitForEvents getEvents $ \events -> @@ -98,9 +94,7 @@ eventTests' timeInterval threadingMode poll recursive nested = do [Removed {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsDirectory -> return () _ -> expectationFailure $ "Got wrong events: " <> show events - it "works with modified file attributes" $ withFolder $ \(TestFolderContext _watchedDir f getEvents clearEvents) -> do - liftIO (writeFile f "" >> clearEvents) - + it "works with modified file attributes" $ withFolder' (\f -> liftIO $ writeFile f "") $ \(TestFolderContext _watchedDir f getEvents _clearEvents) -> do liftIO $ changeFileAttributes f -- This test is disabled when polling because the PollManager only keeps track of @@ -115,9 +109,7 @@ eventTests' timeInterval threadingMode poll recursive nested = do [ModifiedAttributes {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return () _ -> expectationFailure $ "Got wrong events: " <> show events - it "works with a modified file" $ withFolder $ \(TestFolderContext _watchedDir f getEvents clearEvents) -> do - liftIO (writeFile f "" >> clearEvents) - + it "works with a modified file" $ withFolder' (\f -> liftIO $ writeFile f "") $ \(TestFolderContext _watchedDir f getEvents _clearEvents) -> do (if isWin then withSingleWriteFile f "foo" else withOpenWritableAndWrite f "foo") $ waitForEvents getEvents $ \events -> if | nested && not recursive -> events `shouldBe` [] @@ -130,8 +122,7 @@ eventTests' timeInterval threadingMode poll recursive nested = do _ -> expectationFailure $ "Got wrong events: " <> show events <> " (wanted file path " <> show f <> ")" when isLinux $ unless poll $ - it "gets a close_write" $ withFolder $ \(TestFolderContext _watchedDir f getEvents clearEvents) -> do - liftIO (writeFile f "" >> clearEvents) + it "gets a close_write" $ withFolder' (\f -> liftIO $ writeFile f "") $ \(TestFolderContext _watchedDir f getEvents _clearEvents) -> do liftIO $ withFile f WriteMode $ flip hPutStr "asdf" waitForEvents getEvents $ \events -> if | nested && not recursive -> events `shouldBe` [] diff --git a/test/FSNotify/Test/Util.hs b/test/FSNotify/Test/Util.hs index c4ee1ca..90923a6 100644 --- a/test/FSNotify/Test/Util.hs +++ b/test/FSNotify/Test/Util.hs @@ -73,23 +73,20 @@ isBSD = True isBSD = False #endif -pauseAndRetryOnExpectationFailure :: (MonadUnliftIO m) => Int -> Int -> m a -> m a -pauseAndRetryOnExpectationFailure timeInterval n action = threadDelay timeInterval >> retryOnExpectationFailure n action - -retryOnExpectationFailure :: MonadUnliftIO m => Int -> m a -> m a +waitUntil :: MonadUnliftIO m => Double -> m a -> m a #if MIN_VERSION_retry(0, 7, 0) -retryOnExpectationFailure seconds action = withRunInIO $ \runInIO -> +waitUntil timeInSeconds action = withRunInIO $ \runInIO -> recovering policy [\_ -> Handler handleFn] (\_ -> runInIO action) #else -retryOnExpectationFailure seconds action = withRunInIO $ \runInIO -> +waitUntil timeInSeconds action = withRunInIO $ \runInIO -> recovering policy [\_ -> Handler handleFn] (runInIO action) #endif where handleFn :: SomeException -> IO Bool - handleFn (fromException -> Just (Reason {})) = return True + handleFn (fromException -> Just (_ :: FailureReason)) = return True handleFn _ = return False - policy = constantDelay 50000 <> limitRetries (seconds * 20) + policy = limitRetriesByCumulativeDelay (round (timeInSeconds * 1000000.0)) $ capDelay 1000000 $ exponentialBackoff 1000 data TestFolderContext = TestFolderContext { @@ -102,14 +99,14 @@ data TestFolderContext = TestFolderContext { withTestFolder :: ( MonadUnliftIO m, MonadLogger m ) - => Int - -> ThreadingMode + => ThreadingMode -> Bool -> Bool -> Bool + -> (FilePath -> m ()) -> (TestFolderContext -> m a) -> m a -withTestFolder timeInterval threadingMode poll recursive nested action = do +withTestFolder threadingMode poll recursive nested setup action = do withRandomTempDirectory $ \watchedDir' -> do info [i|Got temp directory: #{watchedDir'}|] let fileName = "testfile" @@ -118,9 +115,18 @@ withTestFolder timeInterval threadingMode poll recursive nested action = do createDirectoryIfMissing True baseDir - -- On Mac, delay before starting the watcher because otherwise creation of "subdir" - -- can get picked up. - when isMac $ threadDelay 2000000 + let p = normalise $ baseDir fileName + + setup p + + -- Delay before starting the watcher to make sure setup events picked up. + -- + -- For MacOS, we can apparently get an event for the creation of "subdir" when doing nested tests, + -- even though we create the watcher after this. + -- + -- When polling, we want to ensure we wait at least as long as the effective filesystem modification + -- time granularity, which on Linux can be on the order of 10 milliseconds. + when (isMac || poll) $ threadDelay 1000000 let conf = defaultConfig { #ifdef OS_BSD @@ -139,9 +145,9 @@ withTestFolder timeInterval threadingMode poll recursive nested action = do (\stop -> stop) (\_ -> runInIO $ action $ TestFolderContext { watchedDir = watchedDir' - , filePath = normalise $ baseDir fileName + , filePath = p , getEvents = readIORef eventsVar - , clearEvents = threadDelay timeInterval >> atomicWriteIORef eventsVar [] + , clearEvents = atomicWriteIORef eventsVar [] } ) diff --git a/test/Main.hs b/test/Main.hs index e56f44b..9b3b783 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -5,7 +5,6 @@ module Main where -import Control.Exception.Safe import Control.Monad import Control.Monad.IO.Class import Data.String.Interpolate @@ -31,16 +30,15 @@ main = runSandwichWithCommandLineArgs defaultOptions $ parallelN 20 $ do stop <- watchDir mgr watchedDir' (const True) $ \ev -> do case ev of #ifdef darwin_HOST_OS - Modified {} -> throwIO $ userError "Oh no!" + Modified {} -> expectationFailure "Oh no!" #else - Added {} -> throwIO $ userError "Oh no!" + Added {} -> expectationFailure "Oh no!" #endif _ -> return () writeFile (watchedDir' "testfile") "foo" - let timeInterval = 5*10^(5 :: Int) - pauseAndRetryOnExpectationFailure timeInterval 3 $ + waitUntil 5.0 $ readIORef exceptions >>= (`shouldBe` 1) stop