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
|
||||
Reference in New Issue
Block a user