fsnotify 0.2.1.2 → 0.3.0.0
raw patch · 14 files changed
+487/−387 lines, 14 filesdep +Win32dep +randomdep +shellydep ~basedep ~directorydep ~hinotifynew-uploaderPVP ok
version bump matches the API change (PVP)
Dependencies added: Win32, random, shelly, unix
Dependency ranges changed: base, directory, hinotify
API changes (from Hackage documentation)
+ System.FSNotify: Unknown :: FilePath -> UTCTime -> String -> Event
+ System.FSNotify: eventIsDirectory :: Event -> Bool
- System.FSNotify: Added :: FilePath -> UTCTime -> Event
+ System.FSNotify: Added :: FilePath -> UTCTime -> Bool -> Event
- System.FSNotify: Modified :: FilePath -> UTCTime -> Event
+ System.FSNotify: Modified :: FilePath -> UTCTime -> Bool -> Event
- System.FSNotify: Removed :: FilePath -> UTCTime -> Event
+ System.FSNotify: Removed :: FilePath -> UTCTime -> Bool -> Event
Files
- README.md +1/−1
- fsnotify.cabal +12/−14
- src/System/FSNotify.hs +6/−9
- src/System/FSNotify/Devel.hs +14/−12
- src/System/FSNotify/Linux.hs +68/−46
- src/System/FSNotify/Listener.hs +3/−4
- src/System/FSNotify/OSX.hs +69/−60
- src/System/FSNotify/Path.hs +16/−9
- src/System/FSNotify/Polling.hs +72/−66
- src/System/FSNotify/Types.hs +21/−11
- src/System/FSNotify/Win32.hs +42/−40
- test/EventUtils.hs +35/−27
- test/Test.hs +128/−0
- test/test.hs +0/−88
README.md view
@@ -1,4 +1,4 @@-hfsnotify+hfsnotify [](https://travis-ci.org/codedownio/hfsnotify) [](https://ci.appveyor.com/project/thomasjm/hfsnotify) ========= Unified Haskell interface for basic file system notifications.
fsnotify.cabal view
@@ -1,7 +1,7 @@ Name: fsnotify-Version: 0.2.1.2+Version: 0.3.0.0 Author: Mark Dittmer <mark.s.dittmer@gmail.com>-Maintainer: Greg Weber <greg@gregweber.info>, Roman Cheplyaka <roma@ro-che.info>+Maintainer: Tom McLaughlin <tom@codedown.io> License: BSD3 License-File: LICENSE Synopsis: Cross platform library for file change notification.@@ -16,7 +16,7 @@ Extra-Source-Files: README.md CHANGELOG.md- test/test.hs+ test/Test.hs test/EventUtils.hs @@ -41,7 +41,9 @@ if os(linux) CPP-Options: -DOS_Linux Other-Modules: System.FSNotify.Linux- Build-Depends: hinotify >= 0.3.10+ Build-Depends: hinotify >= 0.3.0,+ shelly >= 1.6.5,+ unix >= 2.7.1.0 else if os(windows) CPP-Options: -DOS_Win32@@ -55,19 +57,15 @@ Test-Suite test Type: exitcode-stdio-1.0- Main-Is: test.hs+ Main-Is: Test.hs Other-modules: EventUtils Hs-Source-Dirs: test GHC-Options: -Wall -threaded- Build-depends: base >= 4.3.1.0- , tasty >= 0.5- , tasty-hunit- , directory- , filepath- , unix-compat- , fsnotify- , async >= 2- , temporary++ if os(windows)+ Build-Depends: base >= 4.3.1.0, tasty >= 0.5, tasty-hunit, directory, filepath, unix-compat, fsnotify, async >= 2, temporary, random, Win32+ else+ Build-Depends: base >= 4.3.1.0, tasty >= 0.5, tasty-hunit, directory, filepath, unix-compat, fsnotify, async >= 2, temporary, random Source-Repository head Type: git
src/System/FSNotify.hs view
@@ -33,6 +33,7 @@ -- * Events Event(..) , EventChannel+ , eventIsDirectory , eventTime , eventPath , Action@@ -60,15 +61,14 @@ import Prelude hiding (FilePath) -import Data.Maybe import Control.Concurrent import Control.Concurrent.Async import Control.Exception-import Control.Applicative import Control.Monad-import System.FilePath+import Data.Maybe import System.FSNotify.Polling import System.FSNotify.Types+import System.FilePath import System.FSNotify.Listener (StopListening) @@ -172,15 +172,13 @@ -- | Watch the immediate contents of a directory by committing an Action for each event. -- Watching the immediate contents of a directory will only report events -- associated with files within the specified directory, and not files--- within its subdirectories. No two events pertaining to the same FilePath will--- be executed concurrently.+-- within its subdirectories. watchDir :: WatchManager -> FilePath -> ActionPredicate -> Action -> IO StopListening watchDir wm = threadChan listen wm -- | Watch all the contents of a directory by committing an Action for each event. -- Watching all the contents of a directory will report events associated with--- files within the specified directory and its subdirectories. No two events--- pertaining to the same FilePath will be executed concurrently.+-- files within the specified directory and its subdirectories. watchTree :: WatchManager -> FilePath -> ActionPredicate -> Action -> IO StopListening watchTree wm = threadChan listenRecursive wm @@ -190,8 +188,7 @@ -- (^ this is the type of listen and listenRecursive) -> WatchManager -> FilePath -> ActionPredicate -> Action -> IO StopListening threadChan listenFn (WatchManager db listener cleanupVar) path actPred action =- modifyMVar cleanupVar $ \mbCleanup ->- case mbCleanup of+ modifyMVar cleanupVar $ \mbCleanup -> case mbCleanup of -- check if we've been stopped Nothing -> return (Nothing, return ()) -- or throw an exception? Just cleanup -> do
src/System/FSNotify/Devel.hs view
@@ -19,12 +19,11 @@ allEvents, existsEvents ) where -import Prelude hiding (FilePath)- import Data.Text-import System.FilePath+import Prelude hiding (FilePath) import System.FSNotify import System.FSNotify.Path (hasThisExtension)+import System.FilePath -- | In the given directory tree, watch for any 'Added' and 'Modified' -- events (but ignore 'Removed' events) for files with the given file@@ -52,24 +51,27 @@ doAllEvents :: Monad m => (FilePath -> m ()) -> Event -> m () doAllEvents action event = case event of- Added f _ -> action f- Modified f _ -> action f- Removed f _ -> action f+ Added f _ _ -> action f+ Modified f _ _ -> action f+ Removed f _ _ -> action f+ Unknown f _ _ -> action f -- | Turn a 'FilePath' predicate into an 'Event' predicate that accepts -- only 'Added' and 'Modified' event types existsEvents :: (FilePath -> Bool) -> (Event -> Bool) existsEvents filt event = case event of- Added f _ -> filt f- Modified f _ -> filt f- Removed _ _ -> False+ Added f _ _ -> filt f+ Modified f _ _ -> filt f+ Removed _ _ _ -> False+ Unknown _ _ _ -> False -- | Turn a 'FilePath' predicate into an 'Event' predicate that accepts -- any event types allEvents :: (FilePath -> Bool) -> (Event -> Bool) allEvents filt event = case event of- Added f _ -> filt f- Modified f _ -> filt f- Removed f _ -> filt f+ Added f _ _ -> filt f+ Modified f _ _ -> filt f+ Removed f _ _ -> filt f+ Unknown f _ _ -> filt f
src/System/FSNotify/Linux.hs view
@@ -2,8 +2,7 @@ -- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org -- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org ---{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module System.FSNotify.Linux@@ -11,31 +10,34 @@ , NativeManager ) where -import Prelude hiding (FilePath)-- import Control.Concurrent.Chan import Control.Concurrent.MVar import Control.Exception as E-import Control.Monad (when)+import Control.Monad import qualified Data.ByteString as BS import Data.IORef (atomicModifyIORef, readIORef)+import Data.String+import qualified Data.Text as T import Data.Time.Clock (UTCTime, getCurrentTime)+import Data.Time.Clock.POSIX import Data.Typeable--- import Debug.Trace (trace) import qualified GHC.Foreign as F import GHC.IO.Encoding (getFileSystemEncoding)-import System.FilePath+import Prelude hiding (FilePath)+import qualified Shelly as S import System.FSNotify.Listener import System.FSNotify.Path (findDirs, canonicalizeDirPath) import System.FSNotify.Types+import System.FilePath import qualified System.INotify as INo+import System.Posix.Files (getFileStatus, isDirectory, modificationTimeHiRes) type NativeManager = INo.INotify data EventVarietyMismatchException = EventVarietyMismatchException deriving (Show, Typeable) instance Exception EventVarietyMismatchException +#if MIN_VERSION_hinotify(0, 3, 10) toRawFilePath :: FilePath -> IO BS.ByteString toRawFilePath fp = do enc <- getFileSystemEncoding@@ -45,52 +47,40 @@ fromRawFilePath bs = do enc <- getFileSystemEncoding BS.useAsCString bs (F.peekCString enc)+#else+toRawFilePath = return . id+fromRawFilePath = return . id+#endif --- Note that INo.Closed in this context is "modified" because we listen to--- CloseWrite events.-fsnEvent :: FilePath -> UTCTime -> INo.Event -> IO (Maybe Event)-fsnEvent basePath timestamp event = case event of- INo.Created False raw -> do- name <- fromRawFilePath raw- return $ Just (Added (basePath </> name) timestamp)- INo.Closed False (Just raw) _ -> do- name <- fromRawFilePath raw- return $ Just (Modified (basePath </> name) timestamp)- INo.MovedOut False raw _ -> do- name <- fromRawFilePath raw- return $ Just (Removed (basePath </> name) timestamp)- INo.MovedIn False raw _ -> do- name <- fromRawFilePath raw- return $ Just (Added (basePath </> name) timestamp)- INo.Deleted False raw -> do- name <- fromRawFilePath raw- return $ Just (Removed (basePath </> name) timestamp)- _ ->- return Nothing+fsnEvents :: FilePath -> UTCTime -> INo.Event -> IO [Event]+fsnEvents basePath timestamp (INo.Attributes isDir (Just raw)) = fromRawFilePath raw >>= \name -> return [Modified (basePath </> name) timestamp isDir]+fsnEvents basePath timestamp (INo.Modified isDir (Just raw)) = fromRawFilePath raw >>= \name -> return [Modified (basePath </> name) timestamp isDir]+fsnEvents basePath timestamp (INo.Created isDir raw) = fromRawFilePath raw >>= \name -> return [Added (basePath </> name) timestamp isDir]+fsnEvents basePath timestamp (INo.MovedOut isDir raw _cookie) = fromRawFilePath raw >>= \name -> return [Removed (basePath </> name) timestamp isDir]+fsnEvents basePath timestamp (INo.MovedIn isDir raw _cookie) = fromRawFilePath raw >>= \name -> return [Added (basePath </> name) timestamp isDir]+fsnEvents basePath timestamp (INo.Deleted isDir raw) = fromRawFilePath raw >>= \name -> return [Removed (basePath </> name) timestamp isDir]+fsnEvents _ _ (INo.Ignored) = return []+fsnEvents basePath timestamp inoEvent = return [Unknown basePath timestamp (show inoEvent)] handleInoEvent :: ActionPredicate -> EventChannel -> FilePath -> DebouncePayload -> INo.Event -> IO ()--- handleInoEvent _ _ basePath _ inoEvent | trace ("Linux: handleInoEvent " ++ show basePath ++ " " ++ show inoEvent) False = undefined handleInoEvent actPred chan basePath dbp inoEvent = do currentTime <- getCurrentTime- maybeFsnEvent <- fsnEvent basePath currentTime inoEvent- handleEvent actPred chan dbp maybeFsnEvent+ events <- fsnEvents basePath currentTime inoEvent+ mapM_ (handleEvent actPred chan dbp) events -handleEvent :: ActionPredicate -> EventChannel -> DebouncePayload -> Maybe Event -> IO ()--- handleEvent actPred _ _ (Just event) | trace ("Linux: handleEvent " ++ show (actPred event) ++ " " ++ show event) False = undefined-handleEvent actPred chan dbp (Just event) =+handleEvent :: ActionPredicate -> EventChannel -> DebouncePayload -> Event -> IO ()+handleEvent actPred chan dbp event = when (actPred event) $ case dbp of (Just (DebounceData epsilon ior)) -> do lastEvent <- readIORef ior- when (not $ debounce epsilon lastEvent event) writeToChan- atomicModifyIORef ior (\_ -> (event, ()))- Nothing -> writeToChan+ unless (debounce epsilon lastEvent event) writeToChan+ atomicModifyIORef ior (const (event, ()))+ Nothing -> writeToChan where writeToChan = writeChan chan event--- handleEvent _ _ _ Nothing | trace ("Linux handleEvent Nothing") False = undefined-handleEvent _ _ _ Nothing = return () varieties :: [INo.EventVariety]-varieties = [INo.Create, INo.Delete, INo.MoveIn, INo.MoveOut, INo.CloseWrite]+varieties = [INo.Create, INo.Delete, INo.MoveIn, INo.MoveOut, INo.Attrib, INo.Modify] instance FileListener INo.INotify where initSession = E.catch (fmap Just INo.initINotify) (\(_ :: IOException) -> return Nothing)@@ -120,7 +110,7 @@ let stopListening = do modifyMVar_ wdVar $ \mbWds -> do- maybe (return ()) (mapM_ INo.removeWatch) mbWds+ maybe (return ()) (mapM_ (\x -> catch (INo.removeWatch x) (\(_ :: SomeException) -> putStrLn ("Error removing watch: " `mappend` show x)))) mbWds return Nothing listenRec initialPath wdVar@@ -149,10 +139,42 @@ return $ Just (wd:wds) where handler :: FilePath -> DebouncePayload -> INo.Event -> IO ()- handler baseDir _ (INo.Created True rawDirPath) = do- dirPath <- fromRawFilePath rawDirPath- listenRec (baseDir </> dirPath) wdVar- handler baseDir dbp event =+ handler baseDir dbp event = do+ -- When a new directory is created, add recursive inotify watches to it+ -- TODO: there's a race condition here; if there are files present in the directory before+ -- we add the watches, we'll miss them. The right thing to do would be to ls the directory+ -- and trigger Added events for everything we find there+ case event of+ (INo.Created True rawDirPath) -> do+ dirPath <- fromRawFilePath rawDirPath+ let newDir = baseDir </> dirPath+ timestampBeforeAddingWatch <- getPOSIXTime+ listenRec newDir wdVar++ -- Find all files/folders that might have been created *after* the timestamp, and hence might have been+ -- missed by the watch+ -- TODO: there's a chance of this generating double events, fix+ files <- S.shelly $ S.find (fromString newDir)+ forM_ files $ \file -> do+ let newPath = T.unpack $ S.toTextIgnore file+ fileStatus <- getFileStatus newPath+ let modTime = modificationTimeHiRes fileStatus+ when (modTime > timestampBeforeAddingWatch) $ do+ handleEvent actPred chan dbp (Added (newDir </> newPath) (posixSecondsToUTCTime timestampBeforeAddingWatch) (isDirectory fileStatus))++ _ -> return ()++ -- Remove watch when this directory is removed+ case event of+ (INo.DeletedSelf) -> do+ -- putStrLn "Watched file/folder was deleted! TODO: remove watch."+ return ()+ (INo.Ignored) -> do+ -- putStrLn "Watched file/folder was ignored, which possibly means it was deleted. TODO: remove watch."+ return ()+ _ -> return ()++ -- Forward all events, including directory create handleInoEvent actPred chan baseDir dbp event usesPolling = const False
src/System/FSNotify/Listener.hs view
@@ -11,13 +11,12 @@ , newDebouncePayload ) where -import Prelude hiding (FilePath)- import Data.IORef (newIORef) import Data.Time (diffUTCTime, NominalDiffTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime)-import System.FilePath+import Prelude hiding (FilePath) import System.FSNotify.Types+import System.FilePath -- | An action that cancels a watching/listening job type StopListening = IO ()@@ -57,7 +56,7 @@ -- | The default event that provides a basis for comparison. eventDefault :: Event-eventDefault = Added "" (posixSecondsToUTCTime 0)+eventDefault = Added "" (posixSecondsToUTCTime 0) False -- | A predicate indicating whether two events may be considered "the same -- event". This predicate is applied to the most recent dispatched event and
src/System/FSNotify/OSX.hs view
@@ -3,33 +3,34 @@ -- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org -- +{-# LANGUAGE MultiWayIf #-}+ module System.FSNotify.OSX ( FileListener(..) , NativeManager ) where -import Prelude hiding (FilePath)- import Control.Concurrent.Chan import Control.Concurrent.MVar import Control.Monad import Data.Bits import Data.IORef (atomicModifyIORef, readIORef) import Data.Map (Map)+import qualified Data.Map as Map import Data.Time.Clock (UTCTime, getCurrentTime)-import Data.Word import Data.Unique-import System.FilePath+import Data.Word+import Prelude hiding (FilePath) import System.Directory import System.FSNotify.Listener import System.FSNotify.Path (canonicalizeDirPath) import System.FSNotify.Types-import qualified Data.Map as Map+import System.FilePath import qualified System.OSX.FSEvents as FSE -data ListenType = NonRecursive | Recursive-data WatchData = WatchData FSE.EventStream ListenType EventChannel +data WatchData = WatchData FSE.EventStream EventChannel+ type WatchMap = Map Unique WatchData data OSXManager = OSXManager (MVar WatchMap) type NativeManager = OSXManager@@ -47,74 +48,83 @@ dirFlag = FSE.eventFlagItemIsDir path = FSE.eventPath event +-- We have to be careful about interpreting the flags in a given event, because+-- "really it's an OR of all the changes made since the FSEventsListener is created"+-- See https://stackoverflow.com/questions/18415285/osx-fseventstreameventflags-not-working-correctly+-- Thus, we try to look at whether the path exists or not to determine whether it was created, modified, etc.++-- Note that there's still some bugs possible due to event coalescing, which the docs say is a possibility:+-- for example, a file could be created and modified within a short time interval, and then we'd only emit one+-- event (the "modified" one, given the logic below)+-- See https://developer.apple.com/library/content/documentation/Darwin/Conceptual/FSEvents_ProgGuide/UsingtheFSEventsFramework/UsingtheFSEventsFramework.html fsnEvents :: UTCTime -> FSE.Event -> IO [Event]-fsnEvents timestamp fseEvent = liftM concat . sequence $ map (\f -> f fseEvent) (eventFunctions timestamp)+fsnEvents timestamp e = do+ -- Note: we *don't* want to use the canonical event path in the existence check, because of the aforementioned crazy event coalescing.+ -- For example, suppose a directory is created and deleted, and then a file is created with the same name. This means the isDirectory flag might+ -- still be turned on, which could lead us to construct a canonical event path with a trailing slash, which would then cause the existence+ -- check to fail and make us think the file was removed.+ -- The upshot of this is that the canonical event paths in the events we emit can't really be trusted, but hey, that's what the extra flag+ -- on the event is for :(+ exists <- doesPathExist $ FSE.eventPath e++ -- Uncomment for an easy way to see flag activity when testing manually+ -- putStrLn $ show ["Event", show e, "isDirectory", show isDirectory, "isFile", show isFile, "isModified", show isModified, "isCreated", show isCreated, "path", path e, "exists", show exists]++ return $ if | exists && isModified -> [Modified (path e) timestamp isDirectory]+ | exists && isCreated -> [Added (path e) timestamp isDirectory]+ | (not exists) && hasFlag e FSE.eventFlagItemRemoved -> [Removed (path e) timestamp isDirectory]++ -- Rename stuff+ | exists && isRenamed -> [Added (path e) timestamp isDirectory]+ | (not exists) && isRenamed -> [Removed (path e) timestamp isDirectory]++ | otherwise -> [] where- eventFunctions :: UTCTime -> [FSE.Event -> IO [Event]]- eventFunctions t = [addedFn t, modifFn t, removFn t, renamFn t]- addedFn t e = if hasFlag e FSE.eventFlagItemCreated then return [Added (path e) t] else return []- modifFn t e = if (hasFlag e FSE.eventFlagItemModified- || hasFlag e FSE.eventFlagItemInodeMetaMod) then return [Modified (path e) t] else return []- removFn t e = if hasFlag e FSE.eventFlagItemRemoved then return [Removed (path e) t] else return []- renamFn t e = if hasFlag e FSE.eventFlagItemRenamed then- doesFileExist (path e) >>= \exists -> if exists then return [Added (path e) t] else return [Removed (path e) t]- else- return []+ isDirectory = hasFlag e FSE.eventFlagItemIsDir+ isFile = hasFlag e FSE.eventFlagItemIsFile+ isCreated = hasFlag e FSE.eventFlagItemCreated+ isRenamed = hasFlag e FSE.eventFlagItemRenamed+ isModified = hasFlag e FSE.eventFlagItemModified || hasFlag e FSE.eventFlagItemInodeMetaMod path = canonicalEventPath hasFlag event flag = FSE.eventFlags event .&. flag /= 0 --- Separate logic is needed for non-recursive events in OSX because the--- hfsevents package doesn't support non-recursive event reporting.--handleNonRecursiveFSEEvent :: ActionPredicate -> EventChannel -> FilePath -> DebouncePayload -> FSE.Event -> IO ()-handleNonRecursiveFSEEvent actPred chan dirPath dbp fseEvent = do+handleEvent :: Bool -> ActionPredicate -> EventChannel -> FilePath -> DebouncePayload -> FSE.Event -> IO ()+handleEvent isRecursive actPred chan dirPath dbp fseEvent = do currentTime <- getCurrentTime events <- fsnEvents currentTime fseEvent- handleNonRecursiveEvents actPred chan dirPath dbp events-handleNonRecursiveEvents :: ActionPredicate -> EventChannel -> FilePath -> DebouncePayload -> [Event] -> IO ()-handleNonRecursiveEvents actPred chan dirPath dbp (event:events)- | takeDirectory dirPath == takeDirectory (eventPath event) && actPred event = do- case dbp of- (Just (DebounceData epsilon ior)) -> do- lastEvent <- readIORef ior- when (not $ debounce epsilon lastEvent event) (writeChan chan event)- atomicModifyIORef ior (\_ -> (event, ()))- Nothing -> writeChan chan event- handleNonRecursiveEvents actPred chan dirPath dbp events- | otherwise = handleNonRecursiveEvents actPred chan dirPath dbp events-handleNonRecursiveEvents _ _ _ _ [] = return ()+ handleEvents isRecursive actPred chan dirPath dbp events -handleFSEEvent :: ActionPredicate -> EventChannel -> DebouncePayload -> FSE.Event -> IO ()-handleFSEEvent actPred chan dbp fseEvent = do- currentTime <- getCurrentTime- events <- fsnEvents currentTime fseEvent- handleEvents actPred chan dbp events+-- | For non-recursive monitoring, test if an event takes place directly inside the monitored folder+isDirectlyInside :: FilePath -> Event -> Bool+isDirectlyInside dirPath event = isRelevantFileEvent || isRelevantDirEvent+ where+ isRelevantFileEvent = (not $ eventIsDirectory event) && (takeDirectory dirPath == (takeDirectory $ eventPath event))+ isRelevantDirEvent = eventIsDirectory event && (takeDirectory dirPath == (takeDirectory $ takeDirectory $ eventPath event)) -handleEvents :: ActionPredicate -> EventChannel -> DebouncePayload -> [Event] -> IO ()-handleEvents actPred chan dbp (event:events) = do- when (actPred event) $ case dbp of+handleEvents :: Bool -> ActionPredicate -> EventChannel -> FilePath -> DebouncePayload -> [Event] -> IO ()+handleEvents isRecursive actPred chan dirPath dbp (event:events) = do+ when (actPred event && (isRecursive || (isDirectlyInside dirPath event))) $ case dbp of (Just (DebounceData epsilon ior)) -> do lastEvent <- readIORef ior when (not $ debounce epsilon lastEvent event) (writeChan chan event) atomicModifyIORef ior (\_ -> (event, ()))- Nothing -> writeChan chan event- handleEvents actPred chan dbp events-handleEvents _ _ _ [] = return ()+ Nothing -> writeChan chan event+ handleEvents isRecursive actPred chan dirPath dbp events+handleEvents _ _ _ _ _ [] = return () -listenFn- :: (ActionPredicate -> EventChannel -> FilePath -> DebouncePayload -> FSE.Event -> IO a)- -> WatchConfig- -> OSXManager- -> FilePath- -> ActionPredicate- -> EventChannel- -> IO StopListening+listenFn :: (ActionPredicate -> EventChannel -> FilePath -> DebouncePayload -> FSE.Event -> IO a)+ -> WatchConfig+ -> OSXManager+ -> FilePath+ -> ActionPredicate+ -> EventChannel+ -> IO StopListening listenFn handler conf (OSXManager mvarMap) path actPred chan = do path' <- canonicalizeDirPath path dbp <- newDebouncePayload $ confDebounce conf unique <- newUnique eventStream <- FSE.eventStreamCreate [path'] 0.0 True False True (handler actPred chan path' dbp)- modifyMVar_ mvarMap $ \watchMap -> return (Map.insert unique (WatchData eventStream NonRecursive chan) watchMap)+ modifyMVar_ mvarMap $ \watchMap -> return (Map.insert unique (WatchData eventStream chan) watchMap) return $ do FSE.eventStreamDestroy eventStream modifyMVar_ mvarMap $ \watchMap -> return $ Map.delete unique watchMap@@ -130,10 +140,9 @@ forM_ (Map.elems watchMap) eventStreamDestroy' where eventStreamDestroy' :: WatchData -> IO ()- eventStreamDestroy' (WatchData eventStream _ _) = FSE.eventStreamDestroy eventStream-- listen = listenFn handleNonRecursiveFSEEvent+ eventStreamDestroy' (WatchData eventStream _) = FSE.eventStreamDestroy eventStream - listenRecursive = listenFn $ \actPred chan _ -> handleFSEEvent actPred chan+ listen = listenFn $ handleEvent False+ listenRecursive = listenFn $ handleEvent True usesPolling = const False
src/System/FSNotify/Path.hs view
@@ -7,31 +7,29 @@ module System.FSNotify.Path ( findFiles , findDirs + , findFilesAndDirs , canonicalizeDirPath , canonicalizePath , hasThisExtension ) where -import Prelude hiding (FilePath) - -import Control.Applicative import Control.Monad --- import Filesystem --- import Filesystem.Path hiding (concat) - import qualified Data.Text as T +import Prelude hiding (FilePath) import qualified System.Directory as D -import System.PosixCompat.Files as PF import System.FilePath +import System.PosixCompat.Files as PF getDirectoryContentsPath :: FilePath -> IO [FilePath] -getDirectoryContentsPath path = (map (path </>)) . filter (not . dots) <$> D.getDirectoryContents path +getDirectoryContentsPath path = + ((map (path </>)) . filter (not . dots) <$> D.getDirectoryContents path) >>= filterM exists where + exists x = (||) <$> D.doesFileExist x <*> D.doesDirectoryExist x dots "." = True dots ".." = True dots _ = False -fileDirContents :: FilePath -> IO ([FilePath],[FilePath]) +fileDirContents :: FilePath -> IO ([FilePath], [FilePath]) fileDirContents path = do contents <- getDirectoryContentsPath path stats <- mapM getFileStatus contents @@ -56,6 +54,8 @@ nestedDirs <- mapM findAllDirs dirs return (dirs ++ concat nestedDirs) +-- * Exported functions below this point + findFiles :: Bool -> FilePath -> IO [FilePath] findFiles True path = findAllFiles =<< canonicalizeDirPath path findFiles False path = findImmediateFiles =<< canonicalizeDirPath path @@ -63,6 +63,13 @@ findDirs :: Bool -> FilePath -> IO [FilePath] findDirs True path = findAllDirs =<< canonicalizeDirPath path findDirs False path = findImmediateDirs =<< canonicalizeDirPath path + +findFilesAndDirs :: Bool -> FilePath -> IO [FilePath] +findFilesAndDirs False path = getDirectoryContentsPath =<< canonicalizeDirPath path +findFilesAndDirs True path = do + (files, dirs) <- fileDirContents path + nestedFilesAndDirs <- concat <$> (mapM (findFilesAndDirs False) dirs) + return (files ++ dirs ++ nestedFilesAndDirs) -- | add a trailing slash to ensure the path indicates a directory addTrailingSlash :: FilePath -> FilePath
src/System/FSNotify/Polling.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ScopedTypeVariables #-} -- -- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org -- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org@@ -9,90 +10,98 @@ , FileListener(..) ) where -import Prelude hiding (FilePath)--import Control.Applicative import Control.Concurrent+import Control.Exception+import Control.Monad (forM_) import Data.Map (Map)+import qualified Data.Map as Map import Data.Maybe import Data.Time.Clock (UTCTime, getCurrentTime) import Data.Time.Clock.POSIX--- import Debug.Trace (trace)-import System.FilePath+import Prelude hiding (FilePath)+import System.Directory (doesDirectoryExist) import System.FSNotify.Listener-import System.FSNotify.Path (findFiles, canonicalizeDirPath)+import System.FSNotify.Path (findFilesAndDirs, canonicalizeDirPath) import System.FSNotify.Types+import System.FilePath import System.PosixCompat.Files import System.PosixCompat.Types-import qualified Data.Map as Map-import Control.Monad (forM_) -data EventType =- AddedEvent- | ModifiedEvent- | RemovedEvent+data EventType = AddedEvent+ | ModifiedEvent+ | RemovedEvent -data WatchKey = WatchKey ThreadId deriving (Eq, Ord)+newtype WatchKey = WatchKey ThreadId deriving (Eq, Ord) data WatchData = WatchData FilePath EventChannel type WatchMap = Map WatchKey WatchData-data PollManager = PollManager (MVar WatchMap)+newtype PollManager = PollManager (MVar WatchMap) -generateEvent :: UTCTime -> EventType -> FilePath -> Maybe Event-generateEvent timestamp AddedEvent filePath = Just (Added filePath timestamp)-generateEvent timestamp ModifiedEvent filePath = Just (Modified filePath timestamp)-generateEvent timestamp RemovedEvent filePath = Just (Removed filePath timestamp)+generateEvent :: UTCTime -> Bool -> EventType -> FilePath -> Maybe Event+generateEvent timestamp isDir AddedEvent filePath = Just (Added filePath timestamp isDir)+generateEvent timestamp isDir ModifiedEvent filePath = Just (Modified filePath timestamp isDir)+generateEvent timestamp isDir RemovedEvent filePath = Just (Removed filePath timestamp isDir) -generateEvents :: UTCTime -> EventType -> [FilePath] -> [Event]-generateEvents timestamp eventType = mapMaybe (generateEvent timestamp eventType)+generateEvents :: UTCTime -> EventType -> [(FilePath, Bool)] -> [Event]+generateEvents timestamp eventType = mapMaybe (\(path, isDir) -> generateEvent timestamp isDir eventType path) +-- | Do not return modified events for directories.+-- These can arise when files are created inside subdirectories, resulting in the modification time+-- of the directory being bumped. However, to increase consistency with the other FileListeners,+-- we ignore these events. handleEvent :: EventChannel -> ActionPredicate -> Event -> IO ()+handleEvent _ _ (Modified _ _ True) = return () handleEvent chan actPred event | actPred event = writeChan chan event- | otherwise = return ()--pathModMap :: Bool -> FilePath -> IO (Map FilePath UTCTime)-pathModMap True path = findFiles True path >>= pathModMap'-pathModMap False path = findFiles False path >>= pathModMap'+ | otherwise = return () -pathModMap' :: [FilePath] -> IO (Map FilePath UTCTime)-pathModMap' files = fmap Map.fromList $ mapM pathAndTime files+pathModMap :: Bool -> FilePath -> IO (Map FilePath (UTCTime, Bool))+pathModMap recursive path = findFilesAndDirs recursive path >>= pathModMap' where- pathAndTime :: FilePath -> IO (FilePath, UTCTime)- pathAndTime path = do+ pathModMap' :: [FilePath] -> IO (Map FilePath (UTCTime, Bool))+ pathModMap' files = (Map.fromList . catMaybes) <$> mapM pathAndInfo files++ pathAndInfo :: FilePath -> IO (Maybe (FilePath, (UTCTime, Bool)))+ pathAndInfo path = handle (\(_ :: IOException) -> return Nothing) $ do modTime <- getModificationTime path- return (path, modTime)+ isDir <- doesDirectoryExist path+ return $ Just (path, (modTime, isDir)) -pollPath :: Int -> Bool -> EventChannel -> FilePath -> ActionPredicate -> Map FilePath UTCTime -> IO ()+pollPath :: Int -> Bool -> EventChannel -> FilePath -> ActionPredicate -> Map FilePath (UTCTime, Bool) -> IO () pollPath interval recursive chan filePath actPred oldPathMap = do threadDelay interval- newPathMap <- pathModMap recursive filePath- currentTime <- getCurrentTime- let deletedMap = Map.difference oldPathMap newPathMap- createdMap = Map.difference newPathMap oldPathMap- modifiedAndCreatedMap = Map.differenceWith modifiedDifference newPathMap oldPathMap- modifiedMap = Map.difference modifiedAndCreatedMap createdMap- generateEvents' = generateEvents currentTime- handleEvents $ generateEvents' AddedEvent $ Map.keys createdMap- handleEvents $ generateEvents' ModifiedEvent $ Map.keys modifiedMap- handleEvents $ generateEvents' RemovedEvent $ Map.keys deletedMap- pollPath' newPathMap+ maybeNewPathMap <- handle (\(_ :: IOException) -> return Nothing) (Just <$> pathModMap recursive filePath)+ case maybeNewPathMap of+ -- Something went wrong while listing directories; we'll try again on the next poll+ Nothing -> pollPath interval recursive chan filePath actPred oldPathMap++ Just newPathMap -> do+ currentTime <- getCurrentTime+ let deletedMap = Map.difference oldPathMap newPathMap+ createdMap = Map.difference newPathMap oldPathMap+ modifiedAndCreatedMap = Map.differenceWith modifiedDifference newPathMap oldPathMap+ modifiedMap = Map.difference modifiedAndCreatedMap createdMap+ generateEvents' = generateEvents currentTime++ handleEvents $ generateEvents' AddedEvent [(path, isDir) | (path, (_, isDir)) <- Map.toList createdMap]+ handleEvents $ generateEvents' ModifiedEvent [(path, isDir) | (path, (_, isDir)) <- Map.toList modifiedMap]+ handleEvents $ generateEvents' RemovedEvent [(path, isDir) | (path, (_, isDir)) <- Map.toList deletedMap]++ pollPath interval recursive chan filePath actPred newPathMap+ where- modifiedDifference :: UTCTime -> UTCTime -> Maybe UTCTime- modifiedDifference newTime oldTime- | oldTime /= newTime = Just newTime- | otherwise = Nothing+ modifiedDifference :: (UTCTime, Bool) -> (UTCTime, Bool) -> Maybe (UTCTime, Bool)+ modifiedDifference (newTime, isDir1) (oldTime, isDir2)+ | oldTime /= newTime || isDir1 /= isDir2 = Just (newTime, isDir1)+ | otherwise = Nothing handleEvents :: [Event] -> IO () handleEvents = mapM_ (handleEvent chan actPred) - pollPath' :: Map FilePath UTCTime -> IO ()- pollPath' = pollPath interval recursive chan filePath actPred ---- Additional init funciton exported to allow startManager to unconditionally+-- Additional init function exported to allow startManager to unconditionally -- create a poll manager as a fallback when other managers will not instantiate. createPollManager :: IO PollManager-createPollManager = fmap PollManager $ newMVar Map.empty+createPollManager = PollManager <$> newMVar Map.empty killWatchingThread :: WatchKey -> IO () killWatchingThread (WatchKey threadId) = killThread threadId@@ -104,6 +113,16 @@ return $ Map.delete wk m return () +listen' :: Bool -> WatchConfig -> PollManager -> FilePath -> ActionPredicate -> EventChannel -> IO (IO ())+listen' isRecursive conf (PollManager mvarMap) path actPred chan = do+ path' <- canonicalizeDirPath path+ pmMap <- pathModMap isRecursive path'+ threadId <- forkIO $ pollPath (confPollInterval conf) isRecursive chan path' actPred pmMap+ let wk = WatchKey threadId+ modifyMVar_ mvarMap $ return . Map.insert wk (WatchData path' chan)+ return $ killAndUnregister mvarMap wk++ instance FileListener PollManager where initSession = fmap Just createPollManager @@ -111,28 +130,15 @@ watchMap <- readMVar mvarMap forM_ (Map.keys watchMap) killWatchingThread - listen conf (PollManager mvarMap) path actPred chan = do- path' <- canonicalizeDirPath path- pmMap <- pathModMap False path'- threadId <- forkIO $ pollPath (confPollInterval conf) False chan path' actPred pmMap- let wk = WatchKey threadId- modifyMVar_ mvarMap $ return . Map.insert wk (WatchData path' chan)- return $ killAndUnregister mvarMap wk+ listen = listen' False - listenRecursive conf (PollManager mvarMap) path actPred chan = do- path' <- canonicalizeDirPath path- pmMap <- pathModMap True path'- threadId <- forkIO $ pollPath (confPollInterval conf) True chan path' actPred pmMap- let wk = WatchKey threadId- modifyMVar_ mvarMap $ return . Map.insert wk (WatchData path' chan)- return $ killAndUnregister mvarMap wk+ listenRecursive = listen' True usesPolling = const True getModificationTime :: FilePath -> IO UTCTime getModificationTime p = fromEpoch . modificationTime <$> getFileStatus p- fromEpoch :: EpochTime -> UTCTime fromEpoch = posixSecondsToUTCTime . realToFrac
src/System/FSNotify/Types.hs view
@@ -15,15 +15,15 @@ , EventChannel , eventPath , eventTime+ , eventIsDirectory , IOEvent ) where -import Prelude hiding (FilePath)- import Control.Concurrent.Chan import Data.IORef (IORef) import Data.Time (NominalDiffTime) import Data.Time.Clock (UTCTime)+import Prelude hiding (FilePath) import System.FilePath -- | A file event reported by a file watcher. Each event contains the@@ -31,22 +31,32 @@ -- event occurred (timestamps represent current time when FSEvents receives -- it from the OS and/or platform-specific Haskell modules). data Event =- Added FilePath UTCTime- | Modified FilePath UTCTime- | Removed FilePath UTCTime+ Added FilePath UTCTime Bool+ | Modified FilePath UTCTime Bool+ | Removed FilePath UTCTime Bool+ | Unknown FilePath UTCTime String deriving (Eq, Show) -- | Helper for extracting the path associated with an event. eventPath :: Event -> FilePath-eventPath (Added path _) = path-eventPath (Modified path _) = path-eventPath (Removed path _) = path+eventPath (Added path _ _) = path+eventPath (Modified path _ _) = path+eventPath (Removed path _ _) = path+eventPath (Unknown path _ _) = path -- | Helper for extracting the time associated with an event. eventTime :: Event -> UTCTime-eventTime (Added _ timestamp) = timestamp-eventTime (Modified _ timestamp) = timestamp-eventTime (Removed _ timestamp) = timestamp+eventTime (Added _ timestamp _) = timestamp+eventTime (Modified _ timestamp _) = timestamp+eventTime (Removed _ timestamp _) = timestamp+eventTime (Unknown _ timestamp _) = timestamp++eventIsDirectory :: Event -> Bool+eventIsDirectory (Added _ _ isDir) = isDir+eventIsDirectory (Modified _ _ isDir) = isDir+eventIsDirectory (Removed _ _ isDir) = isDir+eventIsDirectory (Unknown _ _ _) = False+ type EventChannel = Chan Event
src/System/FSNotify/Win32.hs view
@@ -9,12 +9,13 @@ , NativeManager ) where -import Prelude--import Control.Concurrent.Chan+import Control.Concurrent import Control.Monad (when)+import Data.Bits import Data.IORef (atomicModifyIORef, readIORef)+import qualified Data.Map as Map import Data.Time (getCurrentTime, UTCTime)+import Prelude import System.FSNotify.Listener import System.FSNotify.Path (canonicalizeDirPath) import System.FSNotify.Types@@ -32,36 +33,49 @@ -- handle[native]Event. -- Win32-notify has (temporarily?) dropped support for Renamed events.-fsnEvent :: BaseDir -> UTCTime -> WNo.Event -> Maybe Event-fsnEvent basedir timestamp ev =- case ev of- WNo.Created False name -> Just $ Added (basedir </> name) timestamp- WNo.Modified False name -> Just $ Modified (basedir </> name) timestamp- WNo.Deleted False name -> Just $ Removed (basedir </> name) timestamp- _ -> Nothing-{--fsnEvents timestamp (WNo.Renamed False (Just oldName) newName) = [Removed (fp oldName) timestamp, Added (fp newName) timestamp]-fsnEvents timestamp (WNo.Renamed False Nothing newName) = [Added (fp newName) timestamp]--}+fsnEvent :: Bool -> BaseDir -> UTCTime -> WNo.Event -> Event+fsnEvent isDirectory basedir timestamp (WNo.Created name) = Added (normalise (basedir </> name)) timestamp isDirectory+fsnEvent isDirectory basedir timestamp (WNo.Modified name) = Modified (normalise (basedir </> name)) timestamp isDirectory+fsnEvent isDirectory basedir timestamp (WNo.Deleted name) = Removed (normalise (basedir </> name)) timestamp isDirectory -handleWNoEvent :: BaseDir -> ActionPredicate -> EventChannel -> DebouncePayload -> WNo.Event -> IO ()-handleWNoEvent basedir actPred chan dbp inoEvent = do+handleWNoEvent :: Bool -> BaseDir -> ActionPredicate -> EventChannel -> DebouncePayload -> WNo.Event -> IO ()+handleWNoEvent isDirectory basedir actPred chan dbp inoEvent = do currentTime <- getCurrentTime- let maybeEvent = fsnEvent basedir currentTime inoEvent- case maybeEvent of- Just evt -> handleEvent actPred chan dbp evt- Nothing -> return ()+ let event = fsnEvent isDirectory basedir currentTime inoEvent+ handleEvent actPred chan dbp event+ handleEvent :: ActionPredicate -> EventChannel -> DebouncePayload -> Event -> IO ()-handleEvent actPred chan dbp event =- when (actPred event) $ case dbp of+handleEvent actPred chan dbp event | actPred event = do+ case dbp of (Just (DebounceData epsilon ior)) -> do lastEvent <- readIORef ior- when (not $ debounce epsilon lastEvent event) writeToChan+ when (not $ debounce epsilon lastEvent event) $ writeChan chan event atomicModifyIORef ior (\_ -> (event, ()))- Nothing -> writeToChan- where- writeToChan = writeChan chan event+ Nothing -> writeChan chan event+handleEvent _ _ _ _ = return () +watchDirectory :: Bool -> WatchConfig -> WNo.WatchManager -> FilePath -> ActionPredicate -> EventChannel -> IO (IO ())+watchDirectory isRecursive conf watchManager@(WNo.WatchManager mvarMap) path actPred chan = do+ path' <- canonicalizeDirPath path+ dbp <- newDebouncePayload $ confDebounce conf++ let fileFlags = foldl (.|.) 0 [WNo.fILE_NOTIFY_CHANGE_FILE_NAME, WNo.fILE_NOTIFY_CHANGE_SIZE, WNo.fILE_NOTIFY_CHANGE_ATTRIBUTES]+ let dirFlags = foldl (.|.) 0 [WNo.fILE_NOTIFY_CHANGE_DIR_NAME]++ -- Start one watch for file events and one for directory events+ -- (There seems to be no other way to provide isDirectory information)+ wid1 <- WNo.watchDirectory watchManager path' isRecursive fileFlags (handleWNoEvent False path' actPred chan dbp)+ wid2 <- WNo.watchDirectory watchManager path' isRecursive dirFlags (handleWNoEvent True path' actPred chan dbp)++ -- The StopListening action should make sure to remove the watches from the manager after they're killed.+ -- Otherwise, a call to killSession would cause us to try to kill them again, resulting in an invalid handle error.+ return $ do+ WNo.killWatch wid1+ modifyMVar_ mvarMap $ \watchMap -> return (Map.delete wid1 watchMap)++ WNo.killWatch wid2+ modifyMVar_ mvarMap $ \watchMap -> return (Map.delete wid2 watchMap)+ instance FileListener WNo.WatchManager where -- TODO: This should actually lookup a Windows API version and possibly return -- Nothing the calls we need are not available. This will require that API@@ -70,19 +84,7 @@ killSession = WNo.killWatchManager - listen conf watchManager path actPred chan = do- path' <- canonicalizeDirPath path- dbp <- newDebouncePayload $ confDebounce conf- wid <- WNo.watchDirectory watchManager path' False varieties (handleWNoEvent path' actPred chan dbp)- return $ WNo.killWatch wid-- listenRecursive conf watchManager path actPred chan = do- path' <- canonicalizeDirPath path- dbp <- newDebouncePayload $ confDebounce conf- wid <- WNo.watchDirectory watchManager path' True varieties (handleWNoEvent path' actPred chan dbp)- return $ WNo.killWatch wid+ listen = watchDirectory False+ listenRecursive = watchDirectory True usesPolling = const False--varieties :: [WNo.EventVariety]-varieties = [WNo.Create, WNo.Delete, WNo.Move, WNo.Modify]
test/EventUtils.hs view
@@ -1,19 +1,20 @@ {-# LANGUAGE OverloadedStrings, ImplicitParams #-} module EventUtils where -import Prelude hiding (FilePath)-import Test.Tasty.HUnit+import Control.Applicative import Control.Concurrent import Control.Concurrent.Async hiding (poll)-import Control.Applicative import Control.Monad import Data.IORef import Data.List (sortBy)+import Data.Monoid import Data.Ord (comparing)-import System.FilePath+import Prelude hiding (FilePath)+import System.Directory import System.FSNotify+import System.FilePath import System.IO.Unsafe-import System.Directory+import Test.Tasty.HUnit import Text.Printf delay :: (?timeInterval :: Int) => IO ()@@ -26,23 +27,32 @@ , patPredicate :: Event -> Bool } -evAdded, evRemoved, evModified :: FilePath -> EventPattern-evAdded path =- EventPattern- path- "Added"- (\x -> case x of Added path' _ -> path == path'; _ -> False)-evRemoved path =- EventPattern- path- "Removed"- (\x -> case x of Removed path' _ -> path == path'; _ -> False)-evModified path =- EventPattern- path- "Modified"- (\x -> case x of Modified path' _ -> path == path'; _ -> False)+evAdded, evRemoved, evModified, evAddedOrModified :: Bool -> FilePath -> EventPattern+evAdded isDirectory path = EventPattern path "Added"+ (\x -> case x of+ Added path' _ isDir | isDirectory == isDir -> pathMatches isDirectory path path'+ _ -> False+ )+evRemoved isDirectory path = EventPattern path "Removed"+ (\x -> case x of+ Removed path' _ isDir | isDirectory == isDir -> pathMatches isDirectory path path'+ _ -> False+ )+evModified isDirectory path = EventPattern path "Modified"+ (\x ->+ case x of+ Modified path' _ isDir | isDirectory == isDir -> pathMatches isDirectory path path'+ _ -> False+ )+evAddedOrModified isDirectory path = EventPattern path "AddedOrModified"+ (\x -> case x of+ Added path' _ isDir | isDirectory == isDir -> pathMatches isDirectory path path'+ Modified path' _ isDir | isDirectory == isDir -> pathMatches isDirectory path path'+ _ -> False+ ) +pathMatches True path path' = path == path' || (path <> [pathSeparator]) == path'+pathMatches False path path' = path == path' matchEvents :: [EventPattern] -> [Event] -> Assertion matchEvents expected actual = do@@ -53,7 +63,7 @@ (show actual) sequence_ $ (\f -> zipWith f expected actual) $ \pat ev -> assertBool- (printf "Unexpected event.\n Expected :%s\n Actual: %s\n"+ (printf "Unexpected event.\n Expected: %s\n Actual: %s\n" (show expected) (show actual)) (patPredicate pat ev)@@ -69,11 +79,9 @@ -> FilePath -> IO (Async [Event]) gatherEvents poll watch path = do- mgr <- startManagerConf defaultConfig- { confDebounce = NoDebounce- , confUsePolling = poll- , confPollInterval = 2 * 10^(5 :: Int)- }+ mgr <- startManagerConf defaultConfig { confDebounce = NoDebounce+ , confUsePolling = poll+ , confPollInterval = 2 * 10^(5 :: Int) } eventsVar <- newIORef [] stop <- watch mgr path (const True) (\ev -> atomicModifyIORef eventsVar (\evs -> (ev:evs, ()))) async $ do
+ test/Test.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE CPP, OverloadedStrings, ImplicitParams, MultiWayIf #-}++import Control.Concurrent+import Control.Exception+import Control.Monad+import Data.Monoid+import Prelude hiding (FilePath)+import System.Directory+import System.FSNotify+import System.FilePath+import System.IO+import System.IO.Temp+import System.PosixCompat.Files+import System.Random as R+import Test.Tasty+import Test.Tasty.HUnit++import EventUtils++#ifdef mingw32_HOST_OS+import Data.Bits+import System.Win32.File (getFileAttributes, setFileAttributes, fILE_ATTRIBUTE_TEMPORARY)+-- 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)+#else+changeFileAttributes :: FilePath -> IO ()+changeFileAttributes = touchFile+#endif+++isMac :: Bool+#ifdef darwin_HOST_OS+isMac = True+#else+isMac = False+#endif++nativeMgrSupported :: IO Bool+nativeMgrSupported = do+ mgr <- startManager+ stopManager mgr+ return $ not $ isPollingManager mgr++main :: IO ()+main = do+ hasNative <- nativeMgrSupported+ unless hasNative $ putStrLn "WARNING: native manager cannot be used or tested on this platform"+ defaultMain $ withResource (createDirectoryIfMissing True testDirPath)+ (const $ removeDirectoryRecursive testDirPath)+ (const $ tests hasNative)++-- | There's some kind of race in OS X where the creation of the containing directory shows up as an event+-- I explored whether this was due to passing 0 as the sinceWhen argument to FSEventStreamCreate+-- in the hfsevents package, but changing that didn't seem to help+pauseBeforeStartingTest :: IO ()+pauseBeforeStartingTest = threadDelay 10000++tests :: Bool -> TestTree+tests hasNative = testGroup "Tests" $ do+ poll <- if hasNative then [False, True] else [True]+ let ?timeInterval = if poll then 2*10^(6 :: Int) else 5*10^(5 :: Int)++ return $ testGroup (if poll then "Polling" else "Native") $ do+ recursive <- [False, True]+ return $ testGroup (if recursive then "Recursive" else "Non-recursive") $ do+ nested <- [False, True]++ return $ testGroup (if nested then "In a subdirectory" else "Right here") $ do+ t <- [ mkTest "new file" (if | isMac && not poll -> [evAddedOrModified False]+ | otherwise -> [evAdded False])+ (const $ return ())+ (\f -> openFile f AppendMode >>= hClose)++ , mkTest "modify file" [evModified False]+ (\f -> writeFile f "")+ (\f -> appendFile f "foo")++ -- 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+ , mkTest "modify file attributes" (if poll then [] else [evModified False])+ (\f -> writeFile f "")+ (\f -> if poll then return () else changeFileAttributes f)++ , mkTest "delete file" [evRemoved False]+ (\f -> writeFile f "")+ (\f -> removeFile f)++ , mkTest "new directory" (if | isMac -> [evAddedOrModified True]+ | otherwise -> [evAdded True])+ (const $ return ())+ createDirectory++ , mkTest "delete directory" [evRemoved True]+ (\f -> createDirectory f)+ removeDirectory+ ]+ return $ t nested recursive poll+++mkTest :: (?timeInterval::Int) => TestName -> [FilePath -> EventPattern] -> (FilePath -> IO a) ->+ (FilePath -> IO ()) -> Bool -> Bool -> Bool -> TestTree+mkTest title evs prepare action nested recursive poll = do+ testCase title $ do+ -- 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+ randomID <- replicateM 10 $ R.randomRIO ('a', 'z')++ let pollDelay = when poll (threadDelay $ 10^(6 :: Int))++ withTempDirectory testDirPath ("test." <> randomID) $ \watchedDir -> do+ let fileName = "testfile"+ let baseDir = if nested then watchedDir </> "subdir" else watchedDir+ f = normalise $ baseDir </> fileName+ watchFn = if recursive then watchTree else watchDir+ expect = expectEvents poll watchFn watchedDir++ createDirectoryIfMissing True baseDir++ pauseBeforeStartingTest++ flip finally (doesFileExist f >>= flip when (removeFile f)) $ do+ _ <- prepare f+ pauseBeforeStartingTest+ flip expect (pollDelay >> action f) (if | nested && (not recursive) -> []+ | otherwise -> [ev f | ev <- evs])
− test/test.hs
@@ -1,88 +0,0 @@-{-# LANGUAGE OverloadedStrings, ImplicitParams #-}-import Prelude hiding- ( FilePath )-import Control.Applicative-import Test.Tasty-import Test.Tasty.HUnit-import System.Directory-import System.FilePath-import System.FSNotify-import System.IO.Error-import System.IO.Temp-import System.PosixCompat.Files-import Control.Monad-import Control.Exception-import Control.Concurrent--import EventUtils--nativeMgrSupported :: IO Bool-nativeMgrSupported = do- mgr <- startManager- stopManager mgr- return $ not $ isPollingManager mgr--main :: IO ()-main = do- hasNative <- nativeMgrSupported- unless hasNative $- putStrLn "WARNING: native manager cannot be used or tested on this platform"- defaultMain $- withResource- (createDirectoryIfMissing True testDirPath)- (const $ removeDirectoryRecursive testDirPath) $- const $ tests hasNative--tests :: Bool -> TestTree-tests hasNative = testGroup "Tests" $ do- poll <-- if hasNative- then [False, True]- else [True]- let ?timeInterval =- if poll- then 2*10^(6 :: Int)- else 5*10^(5 :: Int)- return $ testGroup (if poll then "Polling" else "Native") $ do- recursive <- [False, True]- return $ testGroup (if recursive then "Recursive" else "Non-recursive") $ do- nested <- [False, True]- return $ testGroup (if nested then "In a subdirectory" else "Right here") $ do- t <-- [ mkTest "new file"- (if poll then [evAdded] else [evAdded, evModified])- (const $ return ())- (\f -> writeFile f "foo")- , mkTest "modify file" [evModified] (\f -> writeFile f "")- (\f -> when poll (threadDelay $ 10^(6 :: Int)) >> writeFile f "foo")- , mkTest "delete file" [evRemoved] (\f -> writeFile f "") (\f -> removeFile f)- , mkTest "directories are ignored" [] (const $ return ())- (\f -> createDirectory f >> removeDirectory f)- ]- return $ t nested recursive poll- where- mkTest title evs prepare action nested recursive poll =- testCase title $- withTempDirectory testDirPath "test." $ \watchedDir -> do- let baseDir = if nested then watchedDir </> "subdir" else watchedDir- f = baseDir </> fileName- expect =- expectEvents poll- (if recursive then watchTree else watchDir)- watchedDir- createDirectoryIfMissing True baseDir- (prepare f >>- expect (if not nested || recursive then map ($ f) evs else []) (action f))- `finally` (isFile f >>= \b -> when b (removeFile f))-- fileName = "testfile"-----------------------------------------------------------------------------------isFile :: FilePath -> IO Bool-isFile p = handleJust h return checkFile- where- h e = if isDoesNotExistError e- then Just False- else Nothing- checkFile = isRegularFile <$> getFileStatus p