Test simplification

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` []

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 []
             }
           )
 

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