Fix compilation errors
- Remove nonexistent confDebounce field from WatchConfig (fsnotify 0.4.4.0) - Remove unused Generic deriving and GHC.Generics import - Replace .!= with fromMaybe (not re-exported by Data.Yaml) - Add missing Data.Text import in Main.hs - Use git -C flag in runGitIn to run in the correct repo directory - Clean up unused imports
This commit is contained in:
@@ -0,0 +1,165 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE ImplicitParams #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MultiWayIf #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
||||
{-# HLINT ignore "Redundant multi-way if" #-}
|
||||
|
||||
module FSNotify.Test.EventTests where
|
||||
|
||||
import Control.Exception.Safe (MonadThrow)
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import qualified Data.List as L
|
||||
import Data.Monoid
|
||||
import Data.Ord (comparing)
|
||||
import FSNotify.Test.Util
|
||||
import Prelude hiding (FilePath)
|
||||
import System.FSNotify
|
||||
import System.FilePath
|
||||
import System.IO (hPutStr)
|
||||
import Test.Sandwich
|
||||
import UnliftIO hiding (poll)
|
||||
import UnliftIO.Directory
|
||||
|
||||
|
||||
eventTests :: (
|
||||
MonadUnliftIO m, MonadThrow m
|
||||
) => TestFolderGenerator -> ThreadingMode -> SpecFree context m ()
|
||||
eventTests testFolderGenerator threadingMode = describe "Tests" $ parallelWithoutDirectory $ do
|
||||
let pollOptions = if haveNativeWatcher then [False, True] else [True]
|
||||
|
||||
forM_ pollOptions $ \poll -> describe (if poll then "Polling" else "Native") $ parallelWithoutDirectory $ do
|
||||
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' testFolderGenerator threadingMode poll recursive nested
|
||||
|
||||
eventTests' :: (
|
||||
MonadUnliftIO m, MonadThrow m
|
||||
) => TestFolderGenerator -> ThreadingMode -> Bool -> Bool -> Bool -> SpecFree context m ()
|
||||
eventTests' testFolderGenerator threadingMode poll recursive nested = do
|
||||
let withFolder' = withTestFolder testFolderGenerator threadingMode poll recursive nested
|
||||
let withFolder action = withFolder' (const $ return ()) (\() ctx -> action ctx)
|
||||
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
|
||||
|
||||
waitForEvents getEvents $ \case
|
||||
[WatchedDirectoryRemoved {..}] | eventPath `equalFilePath` watchedDir && eventIsDirectory == IsDirectory -> return ()
|
||||
events -> expectationFailure $ "Got wrong events: " <> show events
|
||||
|
||||
it "works with a new file" $ withFolder $ \(TestFolderContext _watchedDir f getEvents _clearEvents) -> do
|
||||
let wrapper action = if | isWin -> liftIO (writeFile f "foo") >> action
|
||||
| otherwise -> withFile f AppendMode $ \_ -> action
|
||||
|
||||
wrapper $
|
||||
waitForEvents getEvents $ \events ->
|
||||
if | nested && not recursive -> events `shouldBe` []
|
||||
| isWin && not poll -> case events of
|
||||
-- On Windows, we sometimes get an extra modified event
|
||||
(sortEvents -> [Added {..}, Modified {}]) | eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()
|
||||
_ -> expectationFailure $ "Got wrong events: " <> show events
|
||||
| otherwise -> case events of
|
||||
[Added {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()
|
||||
_ -> expectationFailure $ "Got wrong events: " <> show events
|
||||
|
||||
it "works with a new directory" $ withFolder $ \(TestFolderContext _watchedDir f getEvents _clearEvents) -> do
|
||||
createDirectory f
|
||||
|
||||
waitForEvents getEvents $ \events ->
|
||||
if | nested && not recursive -> events `shouldBe` []
|
||||
| otherwise -> case events of
|
||||
[Added {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsDirectory -> return ()
|
||||
_ -> expectationFailure $ "Got wrong events: " <> show events
|
||||
|
||||
it "works with a deleted file" $ withFolder' (\f -> liftIO $ writeFile f "") $ \() (TestFolderContext _watchedDir f getEvents _clearEvents) -> do
|
||||
removeFile f
|
||||
|
||||
waitForEvents getEvents $ \events ->
|
||||
if | nested && not recursive -> events `shouldBe` []
|
||||
| otherwise -> case events of
|
||||
[Removed {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()
|
||||
_ -> expectationFailure $ "Got wrong events: " <> show events
|
||||
|
||||
unless isWin $ do
|
||||
it "works if there is bad symlink" $ withFolder' (\f -> liftIO $ createSymLink (f <> ".doesNotExist") f) $ \() (TestFolderContext _watchedDir f getEvents _clearEvents) -> do
|
||||
waitForEvents getEvents $ \events -> events `shouldBe` []
|
||||
|
||||
it "works with a deleted directory" $ withFolder' (\f -> liftIO $ createDirectory f) $ \() (TestFolderContext _watchedDir f getEvents _clearEvents) -> do
|
||||
removeDirectory f
|
||||
|
||||
waitForEvents getEvents $ \events ->
|
||||
if | nested && not recursive -> events `shouldBe` []
|
||||
| otherwise -> case events of
|
||||
[Removed {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsDirectory -> return ()
|
||||
_ -> expectationFailure $ "Got wrong events: " <> show events
|
||||
|
||||
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
|
||||
-- modification time, so it won't catch an unrelated file attribute change
|
||||
waitForEvents getEvents $ \events ->
|
||||
if | poll -> return ()
|
||||
| nested && not recursive -> events `shouldBe` []
|
||||
| isWin -> case events of
|
||||
[Modified {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()
|
||||
_ -> expectationFailure $ "Got wrong events: " <> show events
|
||||
| otherwise -> case events of
|
||||
[ModifiedAttributes {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()
|
||||
_ -> expectationFailure $ "Got wrong events: " <> show events
|
||||
|
||||
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` []
|
||||
| isMac || isFreeBSD -> case events of
|
||||
[Modified {..}] | poll && eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()
|
||||
[ModifiedAttributes {..}] | not poll && eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()
|
||||
_ -> expectationFailure $ "Got wrong events: " <> show events <> " (wanted file path " <> show f <> ")"
|
||||
| otherwise -> case events of
|
||||
[Modified {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()
|
||||
_ -> expectationFailure $ "Got wrong events: " <> show events <> " (wanted file path " <> show f <> ")"
|
||||
|
||||
when (isLinux || isFreeBSD) $ unless poll $ do
|
||||
let setup f = liftIO $ do
|
||||
h <- openFile f WriteMode
|
||||
hPutStr h "asdf" >> hFlush h
|
||||
return h
|
||||
it "gets a close_write" $ withFolder' setup $ \h (TestFolderContext _watchedDir f getEvents _clearEvents) -> do
|
||||
liftIO $ hClose h
|
||||
waitForEvents getEvents $ \events ->
|
||||
if | nested && not recursive -> events `shouldBe` []
|
||||
| otherwise -> case events of
|
||||
[CloseWrite {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()
|
||||
_ -> expectationFailure $ "Got wrong events: " <> show events
|
||||
|
||||
withSingleWriteFile :: MonadIO m => FilePath -> String -> m b -> m b
|
||||
withSingleWriteFile fp contents action = do
|
||||
liftIO $ writeFile fp contents
|
||||
action
|
||||
|
||||
withOpenWritableAndWrite :: MonadUnliftIO m => FilePath -> String -> m b -> m b
|
||||
withOpenWritableAndWrite fp contents action = do
|
||||
withFile fp WriteMode $ \h ->
|
||||
flip finally (hClose h) $ do
|
||||
liftIO $ hPutStr h contents
|
||||
action
|
||||
|
||||
sortEvents :: [Event] -> [Event]
|
||||
sortEvents = L.sortBy (comparing eventToNum)
|
||||
where
|
||||
eventToNum :: Event -> Int
|
||||
eventToNum (Added {}) = 1
|
||||
eventToNum (Modified {}) = 2
|
||||
eventToNum (ModifiedAttributes {}) = 3
|
||||
eventToNum (Removed {}) = 4
|
||||
eventToNum (WatchedDirectoryRemoved {}) = 5
|
||||
eventToNum (CloseWrite {}) = 6
|
||||
eventToNum (Unknown {}) = 7
|
||||
@@ -0,0 +1,207 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE ImplicitParams #-}
|
||||
{-# LANGUAGE NumericUnderscores #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
module FSNotify.Test.Util where
|
||||
|
||||
import Control.Exception.Safe (Handler(..))
|
||||
import Control.Monad.Logger
|
||||
import Control.Retry
|
||||
import Data.String.Interpolate
|
||||
import System.FSNotify
|
||||
import System.FilePath
|
||||
import Test.Sandwich
|
||||
import UnliftIO hiding (poll, Handler)
|
||||
import UnliftIO.Concurrent
|
||||
import UnliftIO.Directory
|
||||
|
||||
#if !MIN_VERSION_base(4,11,0)
|
||||
import Data.Monoid
|
||||
#endif
|
||||
|
||||
#ifdef mingw32_HOST_OS
|
||||
import Data.Bits
|
||||
import System.Win32.File (getFileAttributes, setFileAttributes, fILE_ATTRIBUTE_TEMPORARY)
|
||||
import System.Win32.SymbolicLink (createSymbolicLinkFile)
|
||||
|
||||
-- Perturb the file's attributes, to check that a modification event is emitted
|
||||
changeFileAttributes :: FilePath -> IO ()
|
||||
changeFileAttributes file = do
|
||||
attrs <- getFileAttributes file
|
||||
setFileAttributes file (attrs `xor` fILE_ATTRIBUTE_TEMPORARY)
|
||||
|
||||
createSymLink :: FilePath -> FilePath -> IO ()
|
||||
#if __GLASGOW_HASKELL__ < 900
|
||||
createSymLink file1 file2 = createSymbolicLinkFile file1 file2
|
||||
#else
|
||||
createSymLink file1 file2 = createSymbolicLinkFile file1 file2 True
|
||||
#endif
|
||||
|
||||
#else
|
||||
import System.PosixCompat.Files (touchFile, createSymbolicLink)
|
||||
|
||||
changeFileAttributes :: FilePath -> IO ()
|
||||
changeFileAttributes = touchFile
|
||||
|
||||
createSymLink :: FilePath -> FilePath -> IO ()
|
||||
createSymLink = createSymbolicLink
|
||||
#endif
|
||||
|
||||
|
||||
isMac :: Bool
|
||||
#ifdef darwin_HOST_OS
|
||||
isMac = True
|
||||
#else
|
||||
isMac = False
|
||||
#endif
|
||||
|
||||
isWin :: Bool
|
||||
#ifdef mingw32_HOST_OS
|
||||
isWin = True
|
||||
#else
|
||||
isWin = False
|
||||
#endif
|
||||
|
||||
isLinux :: Bool
|
||||
#ifdef linux_HOST_OS
|
||||
isLinux = True
|
||||
#else
|
||||
isLinux = False
|
||||
#endif
|
||||
|
||||
isFreeBSD :: Bool
|
||||
#ifdef freebsd_HOST_OS
|
||||
isFreeBSD = True
|
||||
#else
|
||||
isFreeBSD = False
|
||||
#endif
|
||||
|
||||
haveNativeWatcher :: Bool
|
||||
#ifdef HAVE_NATIVE_WATCHER
|
||||
haveNativeWatcher = True
|
||||
#else
|
||||
haveNativeWatcher = False
|
||||
#endif
|
||||
|
||||
waitUntil :: MonadUnliftIO m => Double -> m a -> m a
|
||||
#if MIN_VERSION_retry(0, 7, 0)
|
||||
waitUntil timeInSeconds action = withRunInIO $ \runInIO ->
|
||||
recovering policy [\_ -> Handler handleFn] (\_ -> runInIO action)
|
||||
#else
|
||||
waitUntil timeInSeconds action = withRunInIO $ \runInIO ->
|
||||
recovering policy [\_ -> Handler handleFn] (runInIO action)
|
||||
#endif
|
||||
where
|
||||
handleFn :: SomeException -> IO Bool
|
||||
handleFn (fromException -> Just (_ :: FailureReason)) = return True
|
||||
handleFn _ = return False
|
||||
|
||||
policy = limitRetriesByCumulativeDelay (round (timeInSeconds * 1000000.0)) $ capDelay 1000000 $ exponentialBackoff 1000
|
||||
|
||||
|
||||
data TestFolderContext = TestFolderContext {
|
||||
watchedDir :: FilePath
|
||||
, filePath :: FilePath
|
||||
, getEvents :: IO [Event]
|
||||
, clearEvents :: IO ()
|
||||
}
|
||||
|
||||
data TestFolderGenerator = TestFolderGenerator {
|
||||
testFolderGeneratorRootDir :: FilePath
|
||||
, testFolderGeneratorId :: MVar Int
|
||||
}
|
||||
|
||||
newTestFolderGenerator :: MonadUnliftIO m => FilePath -> m TestFolderGenerator
|
||||
newTestFolderGenerator dir = TestFolderGenerator dir <$> newMVar 0
|
||||
|
||||
withTestFolderGenerator :: MonadUnliftIO m => (TestFolderGenerator -> m a) -> m a
|
||||
withTestFolderGenerator action = do
|
||||
withSystemTempDirectory "hfsnotify-tests" $ \dir ->
|
||||
newTestFolderGenerator dir >>= action
|
||||
|
||||
withRandomTempDirectory :: MonadUnliftIO m => TestFolderGenerator -> (FilePath -> m a) -> m a
|
||||
withRandomTempDirectory (TestFolderGenerator {..}) action = do
|
||||
testId <- modifyMVar testFolderGeneratorId $ \x ->
|
||||
return (x + 1, x)
|
||||
let dir = testFolderGeneratorRootDir </> ("test_" <> show testId)
|
||||
bracket_ (createDirectory dir)
|
||||
(removePathForcibly dir)
|
||||
(action dir)
|
||||
|
||||
withTestFolder :: (
|
||||
MonadUnliftIO m, MonadLogger m
|
||||
)
|
||||
=> TestFolderGenerator
|
||||
-> ThreadingMode
|
||||
-> Bool
|
||||
-> Bool
|
||||
-> Bool
|
||||
-> (FilePath -> m b)
|
||||
-> (b -> TestFolderContext -> m a)
|
||||
-> m a
|
||||
withTestFolder testFolderGenerator threadingMode poll recursive nested setup action = do
|
||||
withRandomTempDirectory testFolderGenerator $ \watchedDir' -> do
|
||||
info [i|Got temp directory: #{watchedDir'}|]
|
||||
let fileName = "testfile"
|
||||
let baseDir = if nested then watchedDir' </> "subdir" else watchedDir'
|
||||
let watchFn = if recursive then watchTree else watchDir
|
||||
|
||||
createDirectoryIfMissing True baseDir
|
||||
|
||||
let p = normalise $ baseDir </> fileName
|
||||
|
||||
setupResult <- setup p
|
||||
|
||||
let pollInterval = 2 * 10^(5 :: Int)
|
||||
|
||||
-- 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.
|
||||
--
|
||||
-- On Windows, we occasionally see a test flake when there's no pause here.
|
||||
--
|
||||
-- So, let's put a healthy sleep between the setup actions and the watcher initialization.
|
||||
--
|
||||
-- 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), *or*
|
||||
-- the poll interval, whichever is greater.
|
||||
threadDelay (max 5_000_000 (3 * pollInterval))
|
||||
|
||||
let conf = defaultConfig {
|
||||
#ifndef HAVE_NATIVE_WATCHER
|
||||
confWatchMode = if poll then WatchModePoll pollInterval else error "No native watcher available."
|
||||
#else
|
||||
confWatchMode = if poll then WatchModePoll pollInterval else WatchModeOS
|
||||
#endif
|
||||
, confThreadingMode = threadingMode
|
||||
}
|
||||
|
||||
withRunInIO $ \runInIO ->
|
||||
withManagerConf conf $ \mgr -> do
|
||||
eventsVar <- newIORef []
|
||||
bracket
|
||||
(watchFn mgr watchedDir' (const True) (\ev -> atomicModifyIORef eventsVar (\evs -> (ev:evs, ()))))
|
||||
(\stop -> stop)
|
||||
(\_ -> runInIO $ action setupResult $ TestFolderContext {
|
||||
watchedDir = watchedDir'
|
||||
, filePath = p
|
||||
, getEvents = readIORef eventsVar
|
||||
, clearEvents = atomicWriteIORef eventsVar []
|
||||
}
|
||||
)
|
||||
|
||||
parallelWithoutDirectory :: SpecFree context m () -> SpecFree context m ()
|
||||
parallelWithoutDirectory = parallel' (defaultNodeOptions {
|
||||
nodeOptionsCreateFolder = False
|
||||
, nodeOptionsVisibilityThreshold = 70
|
||||
})
|
||||
@@ -0,0 +1,50 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE ImplicitParams #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Main where
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Data.String.Interpolate
|
||||
import FSNotify.Test.EventTests
|
||||
import FSNotify.Test.Util
|
||||
import Prelude hiding (FilePath)
|
||||
import System.FSNotify
|
||||
import System.FilePath
|
||||
import Test.Sandwich
|
||||
import UnliftIO.IORef
|
||||
|
||||
|
||||
main :: IO ()
|
||||
main =
|
||||
withTestFolderGenerator $ \testFolderGenerator ->
|
||||
runSandwichWithCommandLineArgs defaultOptions $ parallelN 20 $ do
|
||||
describe "Configuration" $ do
|
||||
it "respects the confOnHandlerException option" $ do
|
||||
withRandomTempDirectory testFolderGenerator $ \watchedDir' -> do
|
||||
info [i|Got temp dir: #{watchedDir'}|]
|
||||
exceptions <- newIORef (0 :: Int)
|
||||
let conf = defaultConfig { confOnHandlerException = \_ -> modifyIORef exceptions (+ 1) }
|
||||
|
||||
liftIO $ withManagerConf conf $ \mgr -> do
|
||||
stop <- watchDir mgr watchedDir' (const True) $ \ev -> do
|
||||
case ev of
|
||||
#ifdef darwin_HOST_OS
|
||||
Modified {} -> expectationFailure "Oh no!"
|
||||
#else
|
||||
Added {} -> expectationFailure "Oh no!"
|
||||
#endif
|
||||
_ -> return ()
|
||||
|
||||
writeFile (watchedDir' </> "testfile") "foo"
|
||||
|
||||
waitUntil 5.0 $
|
||||
readIORef exceptions >>= (`shouldBe` 1)
|
||||
|
||||
stop
|
||||
|
||||
describe "SingleThread" $ eventTests testFolderGenerator SingleThread
|
||||
describe "ThreadPerWatch" $ eventTests testFolderGenerator ThreadPerWatch
|
||||
describe "ThreadPerEvent" $ eventTests testFolderGenerator ThreadPerEvent
|
||||
Reference in New Issue
Block a user