diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,11 @@ Changes ======= +Version 0.4.0.1 +--------------- + +* Fix compatibility with *BSD. + Version 0.4.0.0 --------------- diff --git a/fsnotify.cabal b/fsnotify.cabal --- a/fsnotify.cabal +++ b/fsnotify.cabal @@ -1,82 +1,112 @@ -Name: fsnotify -Version: 0.4.0.0 -Author: Mark Dittmer , Niklas Broberg -Maintainer: Tom McLaughlin -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 , Niklas Broberg +maintainer: Tom McLaughlin +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 diff --git a/src/System/FSNotify.hs b/src/System/FSNotify.hs --- a/src/System/FSNotify.hs +++ b/src/System/FSNotify.hs @@ -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 diff --git a/src/System/FSNotify/Listener.hs b/src/System/FSNotify/Listener.hs --- a/src/System/FSNotify/Listener.hs +++ b/src/System/FSNotify/Listener.hs @@ -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. diff --git a/src/System/FSNotify/Types.hs b/src/System/FSNotify/Types.hs --- a/src/System/FSNotify/Types.hs +++ b/src/System/FSNotify/Types.hs @@ -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 diff --git a/test/FSNotify/Test/EventTests.hs b/test/FSNotify/Test/EventTests.hs --- a/test/FSNotify/Test/EventTests.hs +++ b/test/FSNotify/Test/EventTests.hs @@ -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 diff --git a/test/FSNotify/Test/Util.hs b/test/FSNotify/Test/Util.hs --- a/test/FSNotify/Test/Util.hs +++ b/test/FSNotify/Test/Util.hs @@ -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) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 $