fsnotify 0.4.0.0 → 0.4.0.1
raw patch · 8 files changed
+323/−216 lines, 8 filesdep +sandwichdep +unliftiodep −HUnitdep −hspecdep −hspec-corenew-component:exe:tests
Dependencies added: sandwich, unliftio
Dependencies removed: HUnit, hspec, hspec-core, hspec-expectations
Files
- CHANGELOG.md +5/−0
- fsnotify.cabal +106/−76
- src/System/FSNotify.hs +22/−16
- src/System/FSNotify/Listener.hs +1/−1
- src/System/FSNotify/Types.hs +8/−4
- test/FSNotify/Test/EventTests.hs +113/−86
- test/FSNotify/Test/Util.hs +57/−24
- test/Main.hs +11/−9
CHANGELOG.md view
@@ -1,6 +1,11 @@ Changes ======= +Version 0.4.0.1+---------------++* Fix compatibility with *BSD.+ Version 0.4.0.0 ---------------
fsnotify.cabal view
@@ -1,82 +1,112 @@-Name: fsnotify-Version: 0.4.0.0-Author: Mark Dittmer <mark.s.dittmer@gmail.com>, Niklas Broberg-Maintainer: Tom McLaughlin <tom@codedown.io>-License: BSD3-License-File: LICENSE-Synopsis: Cross platform library for file change notification.-Description: Cross platform library for file creation, modification,- and deletion notification. This library builds upon- existing libraries for platform-specific Windows, Mac,- and Linux filesystem event notification.-Category: Filesystem-Cabal-Version: >= 1.10-Build-Type: Simple-Homepage: https://github.com/haskell-fswatch/hfsnotify-Extra-Source-Files:- README.md- CHANGELOG.md- test/Main.hs-+cabal-version: 1.12 -Library- Default-Language: Haskell2010- Build-Depends: base >= 4.8 && < 5- , async >= 2.0.0.0- , bytestring >= 0.10.2- , containers >= 0.4- , directory >= 1.3.0.0- , filepath >= 1.3.0.0- , monad-control >= 1.0.0.0- , safe-exceptions >= 0.1.0.0- , text >= 0.11.0- , time >= 1.1- , unix-compat >= 0.2- Exposed-Modules: System.FSNotify- , System.FSNotify.Devel- Other-Modules: System.FSNotify.Find- , System.FSNotify.Listener- , System.FSNotify.Path- , System.FSNotify.Polling- , System.FSNotify.Types- Hs-Source-Dirs: src- GHC-Options: -Wall- if os(linux)- CPP-Options: -DOS_Linux- Other-Modules: System.FSNotify.Linux- Build-Depends: hinotify >= 0.3.7,- unix >= 2.7.1.0- else- if os(windows)- CPP-Options: -DOS_Win32- Other-Modules: System.FSNotify.Win32- , System.Win32.FileNotify- , System.Win32.Notify- Build-Depends: Win32- Hs-Source-Dirs: win-src- else- if os(darwin)- CPP-Options: -DOS_Mac- Other-Modules: System.FSNotify.OSX- Build-Depends: hfsevents >= 0.1.3+-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack -Test-Suite test- Default-Language: Haskell2010- Type: exitcode-stdio-1.0- Main-Is: Main.hs- Hs-Source-Dirs: test- GHC-Options: -Wall -threaded- Other-Modules: FSNotify.Test.EventTests- , FSNotify.Test.Util+name: fsnotify+version: 0.4.0.1+synopsis: Cross platform library for file change notification.+description: Cross platform library for file creation, modification, and deletion notification. This library builds upon existing libraries for platform-specific Windows, Mac, and Linux filesystem event notification.+category: Filesystem+homepage: https://github.com/haskell-fswatch/hfsnotify+author: Mark Dittmer <mark.s.dittmer@gmail.com>, Niklas Broberg+maintainer: Tom McLaughlin <tom@codedown.io>+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ CHANGELOG.md+ test/Main.hs +library+ exposed-modules:+ System.FSNotify+ System.FSNotify.Devel+ other-modules:+ System.FSNotify.Find+ System.FSNotify.Listener+ System.FSNotify.Path+ System.FSNotify.Polling+ System.FSNotify.Types+ hs-source-dirs:+ src+ ghc-options: -Wall+ build-depends:+ async >=2.0.0.0+ , base >=4.8 && <5+ , bytestring >=0.10.2+ , containers >=0.4+ , directory >=1.3.0.0+ , filepath >=1.3.0.0+ , monad-control >=1.0.0.0+ , safe-exceptions >=0.1.0.0+ , text >=0.11.0+ , time >=1.1+ , unix-compat >=0.2 if os(linux)- CPP-Options: -DOS_Linux-+ cpp-options: -DOS_Linux if os(windows)- Build-Depends: base >= 4.3.1.0, exceptions, hspec, hspec-core, hspec-expectations, HUnit, directory, filepath, unix-compat, fsnotify, async >= 2, safe-exceptions, temporary, random, retry, Win32- else- Build-Depends: base >= 4.3.1.0, exceptions, hspec, hspec-core, hspec-expectations, HUnit, directory, filepath, unix-compat, fsnotify, async >= 2, safe-exceptions, temporary, random, retry+ cpp-options: -DOS_Windows+ if os(darwin)+ cpp-options: -DOS_Mac+ if os(freebsd) || os(netbsd) || os(openbsd)+ cpp-options: -DOS_BSD+ if os(linux)+ other-modules:+ System.FSNotify.Linux+ build-depends:+ hinotify >=0.3.7+ , unix >=2.7.1.0+ if os(windows)+ other-modules:+ System.FSNotify.Win32+ System.Win32.FileNotify+ System.Win32.Notify+ hs-source-dirs:+ win-src+ build-depends:+ Win32+ if os(darwin)+ other-modules:+ System.FSNotify.OSX+ build-depends:+ hfsevents >=0.1.3+ default-language: Haskell2010 -Source-Repository head- Type: git- Location: git://github.com/haskell-fswatch/hfsnotify+executable tests+ main-is: Main.hs+ other-modules:+ FSNotify.Test.EventTests+ FSNotify.Test.Util+ Paths_fsnotify+ hs-source-dirs:+ test+ ghc-options: -threaded -Wall+ build-depends:+ async >=2+ , base >=4.3.1.0+ , directory+ , exceptions+ , filepath+ , fsnotify+ , random+ , retry+ , safe-exceptions+ , sandwich+ , temporary+ , unix-compat+ , unliftio+ if os(linux)+ cpp-options: -DOS_Linux+ if os(windows)+ cpp-options: -DOS_Windows+ if os(darwin)+ cpp-options: -DOS_Mac+ if os(freebsd) || os(netbsd) || os(openbsd)+ cpp-options: -DOS_BSD+ if os(windows)+ build-depends:+ Win32+ default-language: Haskell2010
src/System/FSNotify.hs view
@@ -84,18 +84,17 @@ #ifdef OS_Linux import System.FSNotify.Linux-#else-# ifdef OS_Win32+#endif++#ifdef OS_Win32 import System.FSNotify.Win32-# else-# ifdef OS_Mac+#endif++#ifdef OS_Mac import System.FSNotify.OSX-# else-type NativeManager = PollManager-# endif-# endif #endif + -- | Watch manager. You need one in order to create watching jobs. data WatchManager = forall manager argType. FileListener manager argType => WatchManager { watchManagerConfig :: WatchConfig@@ -108,12 +107,15 @@ -- -- * Uses OS watch mode and single thread. defaultConfig :: WatchConfig-defaultConfig =- WatchConfig- { confWatchMode = WatchModeOS- , confThreadingMode = SingleThread- , confOnHandlerException = defaultOnHandlerException- }+defaultConfig = WatchConfig {+#ifdef OS_BSD+ confWatchMode = WatchModePoll 500000+#else+ confWatchMode = WatchModeOS+#endif+ , confThreadingMode = SingleThread+ , confOnHandlerException = defaultOnHandlerException+ } defaultOnHandlerException :: SomeException -> IO () defaultOnHandlerException e = putStrLn ("fsnotify: handler threw exception: " <> show e)@@ -149,7 +151,7 @@ withManagerConf conf = bracket (startManagerConf conf) stopManager -- | Like 'startManager', but configurable-startManagerConf :: WatchConfig -> IO (WatchManager)+startManagerConf :: WatchConfig -> IO WatchManager startManagerConf conf = do # ifdef OS_Win32 -- See https://github.com/haskell-fswatch/hfsnotify/issues/50@@ -158,12 +160,16 @@ case confWatchMode conf of WatchModePoll interval -> WatchManager conf <$> liftIO (createPollManager interval) <*> cleanupVar <*> globalWatchChan+#ifndef OS_BSD WatchModeOS -> liftIO (initSession ()) >>= createManager+#endif where- createManager :: Either Text NativeManager -> IO (WatchManager)+#ifndef OS_BSD+ createManager :: Either Text NativeManager -> IO WatchManager createManager (Right nativeManager) = WatchManager conf nativeManager <$> cleanupVar <*> globalWatchChan createManager (Left err) = throwIO $ userError $ T.unpack $ "Error: couldn't start native file manager: " <> err+#endif globalWatchChan = case confThreadingMode conf of SingleThread -> do
src/System/FSNotify/Listener.hs view
@@ -25,7 +25,7 @@ -- | A typeclass that imposes structure on watch managers capable of listening -- for events, or simulated listening for events.-class FileListener sessionType argType | sessionType -> argType where+class FileListener sessionType argType | sessionType -> argType where -- | Initialize a file listener instance. initSession :: argType -> IO (Either Text sessionType) -- ^ An initialized file listener, or a reason why one wasn't able to start.
src/System/FSNotify/Types.hs view
@@ -2,6 +2,7 @@ -- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org -- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org --+{-# LANGUAGE CPP #-} module System.FSNotify.Types ( act@@ -54,11 +55,14 @@ -- | Method of watching for changes. data WatchMode =- WatchModeOS- -- ^ Use OS-specific mechanisms to be notified of changes (inotify on Linux, FSEvents on OSX, etc.)- | WatchModePoll { watchModePollInterval :: Int }+ WatchModePoll { watchModePollInterval :: Int } -- ^ Detect changes by polling the filesystem. Less efficient and may miss fast changes. Not recommended- -- unless you're experiencing problems with 'WatchModeOS'.+ -- unless you're experiencing problems with 'WatchModeOS' (or 'WatchModeOS' is not supported on your platform).+#ifndef OS_BSD+ | WatchModeOS+ -- ^ Use OS-specific mechanisms to be notified of changes (inotify on Linux, FSEvents on OSX, etc.).+ -- Not currently available on *BSD.+#endif data ThreadingMode = SingleThread
test/FSNotify/Test/EventTests.hs view
@@ -4,130 +4,157 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+{-# HLINT ignore "Redundant multi-way if" #-} module FSNotify.Test.EventTests where -import Control.Exception.Safe+import Control.Exception.Safe (MonadThrow) import Control.Monad+import Control.Monad.IO.Class import Data.Monoid import FSNotify.Test.Util import Prelude hiding (FilePath)-import System.Directory import System.FSNotify import System.FilePath-import System.IO-import Test.Hspec+import System.IO (hPutStr)+import Test.Sandwich+import UnliftIO hiding (poll)+import UnliftIO.Directory -eventTests :: ThreadingMode -> Spec-eventTests threadingMode = describe "Tests" $- forM_ [False, True] $ \poll -> describe (if poll then "Polling" else "Native") $ do+eventTests :: (MonadUnliftIO m, MonadThrow m, HasParallelSemaphore context) => ThreadingMode -> SpecFree context m ()+eventTests threadingMode = describe "Tests" $ parallel $ do+#ifdef OS_BSD+ let pollOptions = [True]+#else+ let pollOptions = [False, True]+#endif++ forM_ pollOptions $ \poll -> describe (if poll then "Polling" else "Native") $ parallel $ 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") $- forM_ [False, True] $ \nested -> describe (if nested then "In a subdirectory" else "Right here") $- makeTestFolder threadingMode poll recursive nested $ do- unless (nested || poll || isMac || isWin) $ it "deletes the watched directory" $ \(watchedDir, _f, getEvents, _clearEvents) -> do- removeDirectory watchedDir+ forM_ [False, True] $ \recursive -> describe (if recursive then "Recursive" else "Non-recursive") $ parallel $+ forM_ [False, True] $ \nested -> describe (if nested then "Nested" else "Non-nested") $ parallel $+ eventTests' threadingMode poll recursive nested - pauseAndRetryOnExpectationFailure 3 $ getEvents >>= \case- [WatchedDirectoryRemoved {..}] | eventPath `equalFilePath` watchedDir && eventIsDirectory == IsDirectory -> return ()- events -> expectationFailure $ "Got wrong events: " <> show events - it "works with a new file" $ \(_watchedDir, f, getEvents, _clearEvents) -> do- h <- openFile f AppendMode - flip finally (hClose h) $- pauseAndRetryOnExpectationFailure 3 $ getEvents >>= \events ->- if | nested && not recursive -> events `shouldBe` []- | otherwise -> case events of- [Added {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()- _ -> expectationFailure $ "Got wrong events: " <> show events+eventTests' :: (MonadUnliftIO m, MonadThrow m, HasParallelSemaphore context, ?timeInterval :: Int) => ThreadingMode -> Bool -> Bool -> Bool -> SpecFree context m ()+eventTests' threadingMode poll recursive nested = do -- withParallelSemaphore $+ let itWithFolder name action = introduceTestFolder threadingMode poll recursive nested $ it name action - it "works with a new directory" $ \(_watchedDir, f, getEvents, _clearEvents) -> do- createDirectory f+ unless (nested || poll || isMac || isWin) $ itWithFolder "deletes the watched directory" $ do+ TestFolderContext watchedDir _f getEvents _clearEvents <- getContext testFolderContext+ removeDirectory watchedDir - pauseAndRetryOnExpectationFailure 3 $ 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+ pauseAndRetryOnExpectationFailure 3 $ liftIO getEvents >>= \case+ [WatchedDirectoryRemoved {..}] | eventPath `equalFilePath` watchedDir && eventIsDirectory == IsDirectory -> return ()+ events -> expectationFailure $ "Got wrong events: " <> show events - it "works with a deleted file" $ \(_watchedDir, f, getEvents, clearEvents) -> do- writeFile f "" >> clearEvents+ itWithFolder "works with a new file" $ do+ TestFolderContext _watchedDir f getEvents _clearEvents <- getContext testFolderContext+ h <- openFile f AppendMode - removeFile f+ flip finally (hClose h) $+ pauseAndRetryOnExpectationFailure 3 $ liftIO getEvents >>= \events ->+ if | nested && not recursive -> events `shouldBe` []+ | otherwise -> case events of+ [Added {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()+ _ -> expectationFailure $ "Got wrong events: " <> show events - pauseAndRetryOnExpectationFailure 3 $ 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+ itWithFolder "works with a new directory" $ do+ TestFolderContext _watchedDir f getEvents _clearEvents <- getContext testFolderContext+ createDirectory f - it "works with a deleted directory" $ \(_watchedDir, f, getEvents, clearEvents) -> do- createDirectory f >> clearEvents+ pauseAndRetryOnExpectationFailure 3 $ liftIO 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 - removeDirectory f+ itWithFolder "works with a deleted file" $ do+ TestFolderContext _watchedDir f getEvents clearEvents <- getContext testFolderContext+ liftIO (writeFile f "" >> clearEvents) - pauseAndRetryOnExpectationFailure 3 $ 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+ removeFile f - it "works with modified file attributes" $ \(_watchedDir, f, getEvents, clearEvents) -> do- writeFile f "" >> clearEvents+ pauseAndRetryOnExpectationFailure 3 $ liftIO 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 - changeFileAttributes f+ itWithFolder "works with a deleted directory" $ do+ TestFolderContext _watchedDir f getEvents clearEvents <- getContext testFolderContext+ createDirectory f >> liftIO clearEvents - -- 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- pauseAndRetryOnExpectationFailure 3 $ getEvents >>= \events ->- if | poll -> return ()- | nested && not recursive -> events `shouldBe` []- | otherwise -> case events of+ removeDirectory f++ pauseAndRetryOnExpectationFailure 3 $ liftIO 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++ itWithFolder "works with modified file attributes" $ do+ TestFolderContext _watchedDir f getEvents clearEvents <- getContext testFolderContext+ liftIO (writeFile f "" >> clearEvents)++ 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+ pauseAndRetryOnExpectationFailure 3 $ liftIO getEvents >>= \events ->+ if | poll -> return ()+ | nested && not recursive -> events `shouldBe` []+ | otherwise -> case events of #ifdef mingw32_HOST_OS- [Modified {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()+ [Modified {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return () #else- [ModifiedAttributes {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()+ [ModifiedAttributes {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return () #endif- _ -> expectationFailure $ "Got wrong events: " <> show events+ _ -> expectationFailure $ "Got wrong events: " <> show events - it "works with a modified file" $ \(_watchedDir, f, getEvents, clearEvents) -> do- writeFile f "" >> clearEvents+ itWithFolder "works with a modified file" $ do+ TestFolderContext _watchedDir f getEvents clearEvents <- getContext testFolderContext+ liftIO (writeFile f "" >> clearEvents) #ifdef mingw32_HOST_OS- writeFile f "foo"- do+ writeFile f "foo"+ do #else- withFile f WriteMode $ \h ->- flip finally (hClose h) $ do- hPutStr h "foo"+ withFile f WriteMode $ \h ->+ flip finally (hClose h) $ do+ liftIO $ hPutStr h "foo" #endif - pauseAndRetryOnExpectationFailure 3 $ getEvents >>= \events ->- if | nested && not recursive -> events `shouldBe` []- | otherwise -> case events of+ pauseAndRetryOnExpectationFailure 3 $ liftIO getEvents >>= \events ->+ if | nested && not recursive -> events `shouldBe` []+ | otherwise -> case events of #ifdef darwin_HOST_OS- [Modified {..}] | poll && eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()- [ModifiedAttributes {..}] | not poll && eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()+ [Modified {..}] | poll && eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()+ [ModifiedAttributes {..}] | not poll && eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return () #else- [Modified {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()+ [Modified {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return () #endif- _ -> expectationFailure $ "Got wrong events: " <> show events <> " (wanted file path " <> show f <> ")"+ _ -> expectationFailure $ "Got wrong events: " <> show events <> " (wanted file path " <> show f <> ")" #ifdef linux_HOST_OS- unless poll $- it "gets a close_write" $ \(_watchedDir, f, getEvents, clearEvents) -> do- writeFile f "" >> clearEvents- withFile f WriteMode $ flip hPutStr "asdf"- pauseAndRetryOnExpectationFailure 3 $ getEvents >>= \events ->- if | nested && not recursive -> events `shouldBe` []- | otherwise -> case events of- [cw@(CloseWrite {}), m@(Modified {})]- | eventPath cw `equalFilePath` f && eventIsDirectory cw == IsFile- && eventPath m `equalFilePath` f && eventIsDirectory m == IsFile -> return ()- [m@(Modified {}), cw@(CloseWrite {})]- | eventPath cw `equalFilePath` f && eventIsDirectory cw == IsFile- && eventPath m `equalFilePath` f && eventIsDirectory m == IsFile -> return ()- _ -> expectationFailure $ "Got wrong events: " <> show events+ unless poll $+ itWithFolder "gets a close_write" $ do+ TestFolderContext _watchedDir f getEvents clearEvents <- getContext testFolderContext+ liftIO (writeFile f "" >> clearEvents)+ liftIO $ withFile f WriteMode $ flip hPutStr "asdf"+ pauseAndRetryOnExpectationFailure 3 $ liftIO getEvents >>= \events ->+ if | nested && not recursive -> events `shouldBe` []+ | otherwise -> case events of+ [cw@(CloseWrite {}), m@(Modified {})]+ | eventPath cw `equalFilePath` f && eventIsDirectory cw == IsFile+ && eventPath m `equalFilePath` f && eventIsDirectory m == IsFile -> return ()+ [m@(Modified {}), cw@(CloseWrite {})]+ | eventPath cw `equalFilePath` f && eventIsDirectory cw == IsFile+ && eventPath m `equalFilePath` f && eventIsDirectory m == IsFile -> return ()+ _ -> expectationFailure $ "Got wrong events: " <> show events #endif
test/FSNotify/Test/Util.hs view
@@ -1,21 +1,27 @@-{-# LANGUAGE CPP, OverloadedStrings, ImplicitParams, MultiWayIf, LambdaCase, RecordWildCards, ViewPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE FlexibleContexts #-} module FSNotify.Test.Util where -import Control.Concurrent-import Control.Exception.Safe+import Control.Exception.Safe (Handler(..)) import Control.Monad import Control.Retry-import Data.IORef-import System.Directory import System.FSNotify import System.FilePath-import System.IO.Temp import System.PosixCompat.Files (touchFile) import System.Random as R-import Test.HUnit.Lang-import Test.Hspec+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@@ -48,26 +54,36 @@ isWin = False #endif -pauseAndRetryOnExpectationFailure :: (?timeInterval :: Int) => Int -> IO a -> IO a+pauseAndRetryOnExpectationFailure :: (MonadUnliftIO m, ?timeInterval :: Int) => Int -> m a -> m a pauseAndRetryOnExpectationFailure n action = threadDelay ?timeInterval >> retryOnExpectationFailure n action -retryOnExpectationFailure :: Int -> IO a -> IO a+retryOnExpectationFailure :: MonadUnliftIO m => Int -> m a -> m a #if MIN_VERSION_retry(0, 7, 0)-retryOnExpectationFailure seconds action = recovering (constantDelay 50000 <> limitRetries (seconds * 20)) [\_ -> Handler handleFn] (\_ -> action)+retryOnExpectationFailure seconds action = withRunInIO $ \runInIO -> recovering (constantDelay 50000 <> limitRetries (seconds * 20)) [\_ -> Handler handleFn] (\_ -> runInIO action) #else-retryOnExpectationFailure seconds action = recovering (constantDelay 50000 <> limitRetries (seconds * 20)) [\_ -> Handler handleFn] (action)+retryOnExpectationFailure seconds action = withRunInIO $ \runInIO -> recovering (constantDelay 50000 <> limitRetries (seconds * 20)) [\_ -> Handler handleFn] (runInIO action) #endif where handleFn :: SomeException -> IO Bool- handleFn (fromException -> Just (HUnitFailure {})) = return True+ handleFn (fromException -> Just (Reason {})) = return True handleFn _ = return False -makeTestFolder :: (?timeInterval :: Int) => ThreadingMode -> Bool -> Bool -> Bool -> SpecWith (FilePath, FilePath, IO [Event], IO ()) -> Spec-makeTestFolder threadingMode poll recursive nested = around $ \action -> do- withRandomTempDirectory $ \watchedDir -> do+data TestFolderContext = TestFolderContext {+ watchedDir :: FilePath+ , filePath :: FilePath+ , getEvents :: IO [Event]+ , clearEvents :: IO ()+ }++testFolderContext :: Label "testFolderContext" TestFolderContext+testFolderContext = Label :: Label "testFolderContext" TestFolderContext++introduceTestFolder :: (MonadUnliftIO m, ?timeInterval :: Int) => ThreadingMode -> Bool -> Bool -> Bool -> SpecFree (LabelValue "testFolderContext" TestFolderContext :> context) m () -> SpecFree context m ()+introduceTestFolder threadingMode poll recursive nested = introduceWith "Make test folder" testFolderContext $ \action -> do+ withRandomTempDirectory $ \watchedDir' -> do let fileName = "testfile"- let baseDir = if nested then watchedDir </> "subdir" else watchedDir+ let baseDir = if nested then watchedDir' </> "subdir" else watchedDir' let watchFn = if recursive then watchTree else watchDir createDirectoryIfMissing True baseDir@@ -77,21 +93,38 @@ when isMac $ threadDelay 2000000 let conf = defaultConfig {+#ifdef OS_BSD+ confWatchMode = if poll then WatchModePoll (2 * 10^(5 :: Int)) else error "No native watcher available."+#else confWatchMode = if poll then WatchModePoll (2 * 10^(5 :: Int)) else WatchModeOS+#endif , confThreadingMode = threadingMode } - withManagerConf conf $ \mgr -> do- eventsVar <- newIORef []- stop <- watchFn mgr watchedDir (const True) (\ev -> atomicModifyIORef eventsVar (\evs -> (ev:evs, ())))- let clearEvents = threadDelay ?timeInterval >> atomicWriteIORef eventsVar []- _ <- action (watchedDir, normalise $ baseDir </> fileName, readIORef eventsVar, clearEvents)- stop+ withRunInIO $ \runInIO ->+ withManagerConf conf $ \mgr -> do+ eventsVar <- newIORef []+ stop <- watchFn mgr watchedDir' (const True) (\ev -> atomicModifyIORef eventsVar (\evs -> (ev:evs, ())))+ _ <- runInIO $ action $ TestFolderContext {+ watchedDir = watchedDir'+ , filePath = normalise $ baseDir </> fileName+ , getEvents = readIORef eventsVar+ , clearEvents = threadDelay ?timeInterval >> atomicWriteIORef eventsVar []+ } + stop + -- | Use a random identifier so that every test happens in a different folder -- This is unfortunately necessary because of the madness of OS X FSEvents; see the comments in OSX.hs-withRandomTempDirectory :: (FilePath -> IO ()) -> IO ()+withRandomTempDirectory :: MonadUnliftIO m => (FilePath -> m ()) -> m () withRandomTempDirectory action = do randomID <- replicateM 10 $ R.randomRIO ('a', 'z') withSystemTempDirectory ("test." <> randomID) action++withParallelSemaphore :: forall context m. (+ MonadUnliftIO m, HasParallelSemaphore context+ ) => SpecFree context m () -> SpecFree context m ()+withParallelSemaphore = around' (defaultNodeOptions { nodeOptionsRecordTime = False, nodeOptionsVisibilityThreshold = 125 }) "claim semaphore" $ \action -> do+ s <- getContext parallelSemaphore+ bracket_ (liftIO $ waitQSem s) (liftIO $ signalQSem s) (void action)
test/Main.hs view
@@ -1,29 +1,31 @@-{-# LANGUAGE CPP, OverloadedStrings, ImplicitParams, MultiWayIf, LambdaCase, RecordWildCards, ViewPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ImplicitParams #-} module Main where import Control.Exception.Safe import Control.Monad-import Data.IORef+import Control.Monad.IO.Class import FSNotify.Test.EventTests import FSNotify.Test.Util import Prelude hiding (FilePath) import System.FSNotify import System.FilePath-import Test.Hspec+import Test.Sandwich+import UnliftIO.IORef main :: IO ()-main = do- hspec $ do+main = runSandwichWithCommandLineArgs defaultOptions $ parallelN 20 $ do describe "Configuration" $ do it "respects the confOnHandlerException option" $ do- withRandomTempDirectory $ \watchedDir -> do+ withRandomTempDirectory $ \watchedDir' -> do exceptions <- newIORef (0 :: Int) let conf = defaultConfig { confOnHandlerException = \_ -> modifyIORef exceptions (+ 1) } - withManagerConf conf $ \mgr -> do- stop <- watchDir mgr watchedDir (const True) $ \ev -> do+ liftIO $ withManagerConf conf $ \mgr -> do+ stop <- watchDir mgr watchedDir' (const True) $ \ev -> do case ev of #ifdef darwin_HOST_OS Modified {} -> throwIO $ userError "Oh no!"@@ -32,7 +34,7 @@ #endif _ -> return () - writeFile (watchedDir </> "testfile") "foo"+ writeFile (watchedDir' </> "testfile") "foo" let ?timeInterval = 5*10^(5 :: Int) pauseAndRetryOnExpectationFailure 3 $