diff --git a/fsnotify.cabal b/fsnotify.cabal --- a/fsnotify.cabal +++ b/fsnotify.cabal @@ -1,7 +1,7 @@ Name: fsnotify -Version: 0.0.11 +Version: 0.1 Author: Mark Dittmer -Maintainer: Mark Dittmer , Greg Weber +Maintainer: Greg Weber , Roman Cheplyaka License: BSD3 License-File: LICENSE Synopsis: Cross platform library for file change notification. @@ -12,19 +12,19 @@ Category: Filesystem Cabal-Version: >= 1.8 Build-Type: Simple -Extra-Source-Files: test/FSNotify.hs - test/Path.hs - test/Util.hs - test/watch-here.hs +Extra-Source-Files: + test/test.hs + test/EventUtils.hs Library - Build-Depends: base >= 4.3.1.0 && < 5 + Build-Depends: base >= 4.3.1 && < 5 , containers >= 0.4 - , system-fileio >= 0.3.8 && < 0.4 - , system-filepath >= 0.4.6 && <= 0.5 + , system-fileio >= 0.3.8 + , system-filepath >= 0.4.6 , text >= 0.11.0 , time >= 1.1 + , async >= 2.0.1 Exposed-Modules: System.FSNotify , System.FSNotify.Devel Other-Modules: System.FSNotify.Listener @@ -36,7 +36,7 @@ if os(linux) CPP-Options: -DOS_Linux Other-Modules: System.FSNotify.Linux - Build-Depends: hinotify >= 0.3.5 && < 0.4 + Build-Depends: hinotify >= 0.3.7 else if os(windows) CPP-Options: -DOS_Win32 @@ -48,52 +48,22 @@ Other-Modules: System.FSNotify.OSX Build-Depends: hfsevents >= 0.1.3 --- executable watch-here --- hs-source-dirs: src, test --- main-is: watch-here.hs --- build-depends: base --- , containers >= 0.4 --- , directory >= 1.1.0.2 --- , filepath >= 1.3.0.0 --- , Glob >= 0.7.1 --- , system-fileio >= 0.3.8 --- , system-filepath >= 0.4.6 --- , text >= 0.11.0 --- , time >= 1.1 - Test-Suite test Type: exitcode-stdio-1.0 - Main-Is: main.hs - -- Type: detailed-0.9 - -- Test-Module: Tests - Hs-Source-Dirs: test, src + Main-Is: test.hs + Other-modules: EventUtils + Hs-Source-Dirs: test GHC-Options: -Wall -threaded Build-depends: base >= 4.3.1.0 - , bytestring >= 0.9.2.1 - , Cabal >= 1.14.0 - , containers >= 0.4 - , Glob >= 0.7.1 - , hspec >= 1.3.0 - , random >= 1.0.1.1 - , system-filepath >= 0.4.6 - , system-fileio >= 0.3.7 - , text >= 0.10 - , time >= 1.1 - , QuickCheck >= 2.4.2 - , uniqueid >= 0.1.1 - if os(linux) - CPP-Options: -DOS_Linux - Build-Depends: hinotify >= 0.3.5 && < 0.4 - else - if os(windows) - CPP-Options: -DOS_Win32 - Build-Depends: Win32-notify >= 0.3, ghc >= 7.4.2 - else - if os(darwin) - CPP-Options: -DOS_Mac - Build-Depends: hfsevents >= 0.1.3 - + , tasty >= 0.5 + , tasty-hunit + , system-filepath >= 0.4.7 + , system-fileio >= 0.3.11 + , directory + , fsnotify + , async >= 2 + , temporary-rc Source-Repository head Type: git - Location: git://github.com/mdittmer/hfsnotify + Location: git://github.com/haskell-fswatch/hfsnotify diff --git a/src/System/FSNotify.hs b/src/System/FSNotify.hs --- a/src/System/FSNotify.hs +++ b/src/System/FSNotify.hs @@ -2,13 +2,31 @@ -- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org -- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org -- -{-# LANGUAGE CPP, ScopedTypeVariables #-} +{-# LANGUAGE CPP, ScopedTypeVariables, ExistentialQuantification, RankNTypes #-} --- | cross-platform file watching. +-- | Minimal example: +-- +-- >{-# LANGUAGE OverloadedStrings #-} -- for FilePath literals +-- > +-- >import System.FSNotify +-- >import Control.Concurrent (threadDelay) +-- >import Control.Monad (forever) +-- > +-- >main = +-- > withManager $ \mgr -> do +-- > -- start a watching job (in the background) +-- > watchDir +-- > mgr -- manager +-- > "." -- directory to watch +-- > (const True) -- predicate +-- > print -- action +-- > +-- > -- sleep forever (until interrupted) +-- > forever $ threadDelay maxBound module System.FSNotify ( - + -- * Events Event(..) , EventChannel @@ -24,8 +42,11 @@ , stopManager , defaultConfig , WatchConfig(..) + , Debounce(..) , withManagerConf , startManagerConf + , StopListening + , isPollingManager -- * Watching , watchDir @@ -34,16 +55,20 @@ , watchTreeChan ) where -import Prelude hiding (FilePath, catch) +import Prelude hiding (FilePath) +import Data.Maybe import Control.Concurrent +import Control.Concurrent.Async import Control.Exception -import Data.Map (Map) +import Control.Applicative +import Control.Monad import Filesystem.Path.CurrentOS import System.FSNotify.Polling import System.FSNotify.Types -import qualified Data.Map as Map +import System.FSNotify.Listener (StopListening) + #ifdef OS_Linux import System.FSNotify.Linux #else @@ -58,9 +83,22 @@ # endif #endif -data WatchManager = WatchManager WatchConfig (Either PollManager NativeManager) +-- | Watch manager. You need one in order to create watching jobs. +data WatchManager + = forall manager . FileListener manager + => WatchManager + WatchConfig + manager + (MVar (Maybe (IO ()))) -- cleanup action, or Nothing if the manager is stopped + +-- | Default configuration defaultConfig :: WatchConfig -defaultConfig = DebounceDefault +defaultConfig = + WatchConfig + { confDebounce = DebounceDefault + , confPollInterval = 10^(6 :: Int) -- 1 second + , confUsePolling = False + } -- | Perform an IO action with a WatchManager in place. -- Tear down the WatchManager after the action is complete. @@ -80,81 +118,98 @@ -- Stopping a watch manager will immediately stop -- watching for files and free resources. stopManager :: WatchManager -> IO () -stopManager (WatchManager _ wm) = - case wm of - Right native -> killSession native - Left poll -> killSession poll +stopManager (WatchManager _ wm cleanupVar) = do + mbCleanup <- swapMVar cleanupVar Nothing + fromMaybe (return ()) mbCleanup + killSession wm +-- | Like 'withManager', but configurable withManagerConf :: WatchConfig -> (WatchManager -> IO a) -> IO a -withManagerConf debounce = bracket (startManagerConf debounce) stopManager +withManagerConf conf = bracket (startManagerConf conf) stopManager +-- | Like 'startManager', but configurable startManagerConf :: WatchConfig -> IO WatchManager -startManagerConf debounce = initSession >>= createManager +startManagerConf conf + | confUsePolling conf = pollingManager + | otherwise = initSession >>= createManager where createManager :: Maybe NativeManager -> IO WatchManager - createManager (Just nativeManager) = return (WatchManager debounce (Right nativeManager)) - createManager Nothing = return . (WatchManager debounce) . Left =<< createPollManager + createManager (Just nativeManager) = + WatchManager conf nativeManager <$> cleanupVar + createManager Nothing = pollingManager + pollingManager = + WatchManager conf <$> createPollManager <*> cleanupVar + + cleanupVar = newMVar (Just (return ())) + +-- | Does this manager use polling? +isPollingManager :: WatchManager -> Bool +isPollingManager (WatchManager _ wm _) = usesPolling wm + -- | Watch the immediate contents of a directory by streaming events to a Chan. -- Watching the immediate contents of a directory will only report events -- associated with files within the specified directory, and not files -- within its subdirectories. -watchDirChan :: WatchManager -> FilePath -> ActionPredicate -> EventChannel -> IO () -watchDirChan (WatchManager db wm) = either (listen db) (listen db) wm +watchDirChan :: WatchManager -> FilePath -> ActionPredicate -> EventChannel -> IO StopListening +watchDirChan (WatchManager db wm _) = listen db wm -- | Watch all the contents of a directory by streaming events to a Chan. -- Watching all the contents of a directory will report events associated with -- files within the specified directory and its subdirectories. -watchTreeChan :: WatchManager -> FilePath -> ActionPredicate -> EventChannel -> IO () -watchTreeChan (WatchManager db wm) = either (listenRecursive db) (listenRecursive db) wm +watchTreeChan :: WatchManager -> FilePath -> ActionPredicate -> EventChannel -> IO StopListening +watchTreeChan (WatchManager db wm _) = listenRecursive db wm -- | 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. -watchDir :: WatchManager -> FilePath -> ActionPredicate -> Action -> IO () -watchDir (WatchManager db wm) = either runFallback runNative wm - where - runFallback = threadChanFallback $ listen db - runNative = threadChanNative $ listen db - -threadChanNative :: (NativeManager -> FilePath -> ActionPredicate -> Chan Event -> IO b) -> NativeManager -> FilePath -> ActionPredicate -> Action -> IO b -threadChanNative listener iface path actPred action = - threadChan action $ listener iface path actPred - -threadChanFallback :: (PollManager -> FilePath -> ActionPredicate -> Chan Event -> IO b) -> PollManager -> FilePath -> ActionPredicate -> Action -> IO b -threadChanFallback listener iface path actPred action = - threadChan action $ listener iface path actPred - -threadChan :: Action -> (Chan Event -> IO b) -> IO b -threadChan action runListener = do - chan <- newChan - _ <- forkIO $ readEvents chan action Map.empty - runListener chan - +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. -watchTree :: WatchManager -> FilePath -> ActionPredicate -> Action -> IO () -watchTree (WatchManager db wm) = either runFallback runNative wm - where - runFallback = threadChanFallback $ listenRecursive db - runNative = threadChanNative $ listenRecursive db +watchTree :: WatchManager -> FilePath -> ActionPredicate -> Action -> IO StopListening +watchTree wm = threadChan listenRecursive wm -type ThreadLock = MVar () -type PathLockMap = Map FilePath ThreadLock +threadChan + :: (forall sessionType . FileListener sessionType => + WatchConfig -> sessionType -> FilePath -> ActionPredicate -> EventChannel -> IO StopListening) + -- (^ 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 + -- check if we've been stopped + Nothing -> return (Nothing, return ()) -- or throw an exception? + Just cleanup -> do + chan <- newChan + asy <- async $ readEvents chan action + -- Ideally, the the asy thread should be linked to the current one + -- (@link asy@), so that it doesn't die quietly. + -- However, if we do that, then cancelling asy will also kill + -- ourselves. I haven't figured out how to do this (probably we + -- should just abandon async and use lower-level primitives). For now + -- we don't link the thread. + stopListener <- listenFn db listener path actPred chan + let cleanThisUp = cancel asy + return + ( Just $ cleanup >> cleanThisUp + , stopListener >> cleanThisUp + ) -readEvents :: EventChannel -> Action -> PathLockMap -> IO () -readEvents chan action pathMap = do +readEvents :: EventChannel -> Action -> IO () +readEvents chan action = forever $ do event <- readChan chan - let path = eventPath event - mVar <- getMVar $ Map.lookup path pathMap - _ <- takeMVar mVar >> (forkIO $ action event `finally` putMVar mVar ()) - readEvents chan action $ Map.insert path mVar pathMap - where - getMVar :: Maybe ThreadLock -> IO ThreadLock - getMVar (Just tl) = return tl - getMVar Nothing = newMVar () + us <- myThreadId + -- Execute the event handler in a separate thread, but throw any + -- exceptions back to us. + -- + -- Note that there's a possibility that we may miss some exceptions, if + -- an event handler finishes after the listen is cancelled (and so this + -- thread is dead). How bad is that? The alternative is to kill the + -- handler anyway when we're cancelling. + forkFinally (action event) $ either (throwTo us) (const $ return ()) diff --git a/src/System/FSNotify/Devel.hs b/src/System/FSNotify/Devel.hs --- a/src/System/FSNotify/Devel.hs +++ b/src/System/FSNotify/Devel.hs @@ -4,7 +4,7 @@ allEvents, existsEvents ) where -import Prelude hiding (FilePath, catch) +import Prelude hiding (FilePath) import Data.Text import Filesystem.Path.CurrentOS @@ -32,7 +32,7 @@ -> FilePath -- ^ Directory to watch -> Text -- ^ extension -> (FilePath -> IO ()) -- ^ action to run on file - -> IO () + -> IO StopListening treeExtExists man dir ext action = watchTree man dir (existsEvents $ flip hasExtension ext) (doAllEvents action) @@ -43,7 +43,7 @@ -> FilePath -- ^ Directory to watch -> Text -- ^ extension -> (FilePath -> IO ()) -- ^ action to run on file - -> IO () + -> IO StopListening treeExtAny man dir ext action = watchTree man dir (existsEvents $ flip hasExtension ext) (doAllEvents action) diff --git a/src/System/FSNotify/Linux.hs b/src/System/FSNotify/Linux.hs --- a/src/System/FSNotify/Linux.hs +++ b/src/System/FSNotify/Linux.hs @@ -13,6 +13,7 @@ import Prelude hiding (FilePath) import Control.Concurrent.Chan +import Control.Concurrent.MVar import Control.Exception import Control.Monad (when) import Data.IORef (atomicModifyIORef, readIORef) @@ -30,9 +31,6 @@ data EventVarietyMismatchException = EventVarietyMismatchException deriving (Show, Typeable) instance Exception EventVarietyMismatchException -void :: IO () -void = return () - -- Note that INo.Closed in this context is "modified" because we listen to -- CloseWrite events. fsnEvent :: FilePath -> UTCTime -> INo.Event -> Maybe Event @@ -62,7 +60,7 @@ where writeToChan = writeChan chan event -- handleEvent _ _ _ Nothing | trace ("Linux handleEvent Nothing") False = undefined -handleEvent _ _ _ Nothing = void +handleEvent _ _ _ Nothing = return () varieties :: [INo.EventVariety] varieties = [INo.Create, INo.Delete, INo.MoveIn, INo.MoveOut, INo.CloseWrite] @@ -72,28 +70,59 @@ killSession = INo.killINotify - listen db iNotify path actPred chan = do + listen conf iNotify path actPred chan = do path' <- canonicalizeDirPath path - dbp <- newDebouncePayload db - _ <- INo.addWatch iNotify varieties (encodeString path') (handler path' dbp) - void + dbp <- newDebouncePayload $ confDebounce conf + wd <- INo.addWatch iNotify varieties (encodeString path') (handler path' dbp) + return $ INo.removeWatch wd where handler :: FilePath -> DebouncePayload -> INo.Event -> IO () handler = handleInoEvent actPred chan - listenRecursive db iNotify path actPred chan = do - path' <- canonicalizeDirPath path - paths <- findDirs True path' - mapM_ pathHandler (path':paths) + listenRecursive conf iNotify initialPath actPred chan = do + -- wdVar stores the list of created watch descriptors. We use it to + -- cancel the whole recursive listening task. + -- + -- To avoid a race condition (when a new watch is added right after + -- we've stopped listening), we replace the MVar contents with Nothing + -- to signify that the listening task is cancelled, and no new watches + -- should be added. + wdVar <- newMVar (Just []) + + let + stopListening = do + modifyMVar_ wdVar $ \mbWds -> do + maybe (return ()) (mapM_ INo.removeWatch) mbWds + return Nothing + + listenRec initialPath wdVar + + return stopListening + where - pathHandler :: FilePath -> IO () - pathHandler filePath = do - dbp <- newDebouncePayload db - _ <- INo.addWatch iNotify varieties (fp filePath) (handler filePath dbp) - void + listenRec :: FilePath -> MVar (Maybe [INo.WatchDescriptor]) -> IO () + listenRec path wdVar = do + path' <- canonicalizeDirPath path + paths <- findDirs True path' + + mapM_ (pathHandler wdVar) (path':paths) + + pathHandler :: MVar (Maybe [INo.WatchDescriptor]) -> FilePath -> IO () + pathHandler wdVar filePath = do + dbp <- newDebouncePayload $ confDebounce conf + modifyMVar_ wdVar $ \mbWds -> + -- Atomically add a watch and record its descriptor. Also, check + -- if the listening task is cancelled, in which case do nothing. + case mbWds of + Nothing -> return mbWds + Just wds -> do + wd <- INo.addWatch iNotify varieties (fp filePath) (handler filePath dbp) + return $ Just (wd:wds) where handler :: FilePath -> DebouncePayload -> INo.Event -> IO () - handler baseDir _ (INo.Created True dirPath) = - listenRecursive db iNotify (baseDir (fp dirPath)) actPred chan + handler baseDir _ (INo.Created True dirPath) = do + listenRec (baseDir fp dirPath) wdVar handler baseDir dbp event = handleInoEvent actPred chan baseDir dbp event + + usesPolling = const False 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 @@ -7,6 +7,7 @@ ( debounce , epsilonDefault , FileListener(..) + , StopListening , newDebouncePayload ) where @@ -19,6 +20,9 @@ import System.FSNotify.Path (fp) import System.FSNotify.Types +-- | An action that cancels a watching/listening job +type StopListening = IO () + -- | A typeclass that imposes structure on watch managers capable of listening -- for events, or simulated listening for events. class FileListener sessionType where @@ -36,14 +40,17 @@ -- Listening for events associated with immediate contents of a directory will -- only report events associated with files within the specified directory, and -- not files within its subdirectories. - listen :: WatchConfig -> sessionType -> FilePath -> ActionPredicate -> EventChannel -> IO () + listen :: WatchConfig -> sessionType -> FilePath -> ActionPredicate -> EventChannel -> IO StopListening -- | Listen for file events associated with all the contents of a directory. -- Listening for events associated with all the contents of a directory will -- report events associated with files within the specified directory and its -- subdirectories. - listenRecursive :: WatchConfig -> sessionType -> FilePath -> ActionPredicate -> EventChannel -> IO () + listenRecursive :: WatchConfig -> sessionType -> FilePath -> ActionPredicate -> EventChannel -> IO StopListening + -- | Does this manager use polling? + usesPolling :: sessionType -> Bool + -- | The default maximum difference (exclusive, in seconds) for two -- events to be considered as occuring "at the same time". epsilonDefault :: NominalDiffTime @@ -65,7 +72,7 @@ -- | Produces a fresh data payload used for debouncing events in a -- handler. -newDebouncePayload :: WatchConfig -> IO DebouncePayload +newDebouncePayload :: Debounce -> IO DebouncePayload newDebouncePayload DebounceDefault = newIORef eventDefault >>= return . Just . DebounceData epsilonDefault newDebouncePayload (Debounce epsilon) = newIORef eventDefault >>= return . Just . DebounceData epsilon newDebouncePayload NoDebounce = return Nothing diff --git a/src/System/FSNotify/OSX.hs b/src/System/FSNotify/OSX.hs --- a/src/System/FSNotify/OSX.hs +++ b/src/System/FSNotify/OSX.hs @@ -8,17 +8,17 @@ , NativeManager ) where -import Prelude hiding (FilePath, catch) +import Prelude hiding (FilePath) import Control.Concurrent.Chan import Control.Concurrent.MVar -import Control.Monad hiding (void) +import Control.Monad import Data.Bits import Data.IORef (atomicModifyIORef, readIORef) import Data.Map (Map) import Data.Time.Clock (UTCTime, getCurrentTime) import Data.Word --- import Debug.Trace (trace) +import Data.Unique import Filesystem (isFile) import Filesystem.Path hiding (concat) import System.FSNotify.Listener @@ -30,15 +30,10 @@ data ListenType = NonRecursive | Recursive data WatchData = WatchData FSE.EventStream ListenType EventChannel --- TODO: We really should use something other than FilePath as a key to allow --- for more than one listener per FilePath. -type WatchMap = Map FilePath WatchData +type WatchMap = Map Unique WatchData data OSXManager = OSXManager (MVar WatchMap) type NativeManager = OSXManager -void :: IO () -void = return () - nil :: Word64 nil = 0x00 @@ -72,17 +67,11 @@ -- hfsevents package doesn't support non-recursive event reporting. handleNonRecursiveFSEEvent :: ActionPredicate -> EventChannel -> FilePath -> DebouncePayload -> FSE.Event -> IO () --- handleNonRecursiveFSEEvent _ _ dirPath _ fseEvent | trace ("OSX: handleNonRecursiveFSEEvent " ++ show dirPath ++ " " ++ show fseEvent) False = undefined handleNonRecursiveFSEEvent 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 _ dirPath _ (event:_ ) | trace ( "OSX: handleNonRecursiveEvents " --- ++ show dirPath ++ " " ++ show event --- ++ "\n " ++ fp (directory dirPath) --- ++ "\n " ++ fp (directory (eventPath event)) --- ++ "\n " ++ show (actPred event)) False = undefined handleNonRecursiveEvents actPred chan dirPath dbp (event:events) | directory dirPath == directory (eventPath event) && actPred event = do case dbp of @@ -93,17 +82,15 @@ Nothing -> writeChan chan event handleNonRecursiveEvents actPred chan dirPath dbp events | otherwise = handleNonRecursiveEvents actPred chan dirPath dbp events -handleNonRecursiveEvents _ _ _ _ [] = void +handleNonRecursiveEvents _ _ _ _ [] = return () handleFSEEvent :: ActionPredicate -> EventChannel -> DebouncePayload -> FSE.Event -> IO () --- handleFSEEvent _ _ _ fseEvent | trace ("OSX: handleFSEEvent " ++ show fseEvent) False = undefined handleFSEEvent actPred chan dbp fseEvent = do currentTime <- getCurrentTime events <- fsnEvents currentTime fseEvent handleEvents actPred chan dbp events handleEvents :: ActionPredicate -> EventChannel -> DebouncePayload -> [Event] -> IO () --- handleEvents actPred _ _ (event:_ ) | trace ("OSX: handleEvents " ++ show event ++ " " ++ show (actPred event)) False = undefined handleEvents actPred chan dbp (event:events) = do when (actPred event) $ case dbp of (Just (DebounceData epsilon ior)) -> do @@ -112,8 +99,26 @@ atomicModifyIORef ior (\_ -> (event, ())) Nothing -> writeChan chan event handleEvents actPred chan dbp events -handleEvents _ _ _ [] = void +handleEvents _ _ _ [] = return () +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 [fp path'] 0.0 True False True (handler actPred chan path' dbp) + modifyMVar_ mvarMap $ \watchMap -> return (Map.insert unique (WatchData eventStream NonRecursive chan) watchMap) + return $ do + FSE.eventStreamDestroy eventStream + modifyMVar_ mvarMap $ \watchMap -> return $ Map.delete unique watchMap + instance FileListener OSXManager where initSession = do (v1, v2, _) <- FSE.osVersion @@ -127,20 +132,8 @@ eventStreamDestroy' :: WatchData -> IO () eventStreamDestroy' (WatchData eventStream _ _) = FSE.eventStreamDestroy eventStream - listen db (OSXManager mvarMap) path actPred chan = do - path' <- canonicalizeDirPath path - dbp <- newDebouncePayload db - eventStream <- FSE.eventStreamCreate [fp path'] 0.0 True False True (handler path' dbp) - modifyMVar_ mvarMap $ \watchMap -> return (Map.insert path' (WatchData eventStream NonRecursive chan) watchMap) - where - handler :: FilePath -> DebouncePayload -> FSE.Event -> IO () - handler = handleNonRecursiveFSEEvent actPred chan + listen = listenFn handleNonRecursiveFSEEvent - listenRecursive db (OSXManager mvarMap) path actPred chan = do - path' <- canonicalizeDirPath path - dbp <- newDebouncePayload db - eventStream <- FSE.eventStreamCreate [fp path'] 0.0 True False True $ handler dbp - modifyMVar_ mvarMap $ \watchMap -> return (Map.insert path' (WatchData eventStream Recursive chan) watchMap) - where - handler :: DebouncePayload -> FSE.Event -> IO () - handler = handleFSEEvent actPred chan + listenRecursive = listenFn $ \actPred chan path -> handleFSEEvent actPred chan + + usesPolling = const False diff --git a/src/System/FSNotify/Polling.hs b/src/System/FSNotify/Polling.hs --- a/src/System/FSNotify/Polling.hs +++ b/src/System/FSNotify/Polling.hs @@ -59,9 +59,9 @@ modTime <- getModified path return (path, modTime) -pollPath :: Bool -> EventChannel -> FilePath -> ActionPredicate -> Map FilePath UTCTime -> IO () -pollPath recursive chan filePath actPred oldPathMap = do - threadDelay 1000000 +pollPath :: Int -> Bool -> EventChannel -> FilePath -> ActionPredicate -> Map FilePath UTCTime -> IO () +pollPath interval recursive chan filePath actPred oldPathMap = do + threadDelay interval newPathMap <- pathModMap recursive filePath currentTime <- getCurrentTime let deletedMap = Map.difference oldPathMap newPathMap @@ -83,7 +83,7 @@ handleEvents = mapM_ (handleEvent chan actPred) pollPath' :: Map FilePath UTCTime -> IO () - pollPath' = pollPath recursive chan filePath actPred + pollPath' = pollPath interval recursive chan filePath actPred -- Additional init funciton exported to allow startManager to unconditionally @@ -91,24 +91,37 @@ createPollManager :: IO PollManager createPollManager = fmap PollManager $ newMVar Map.empty +killWatchingThread :: WatchKey -> IO () +killWatchingThread (WatchKey threadId) = killThread threadId + +killAndUnregister :: MVar WatchMap -> WatchKey -> IO () +killAndUnregister mvarMap wk = do + _ <- withMVar mvarMap $ \m -> do + killWatchingThread wk + return $ Map.delete wk m + return () + instance FileListener PollManager where initSession = fmap Just createPollManager killSession (PollManager mvarMap) = do watchMap <- readMVar mvarMap - forM_ (Map.keys watchMap) killThread' - where - killThread' :: WatchKey -> IO () - killThread' (WatchKey threadId) = killThread threadId + forM_ (Map.keys watchMap) killWatchingThread - listen _ (PollManager mvarMap) path actPred chan = do + listen conf (PollManager mvarMap) path actPred chan = do path' <- canonicalizeDirPath path pmMap <- pathModMap False path' - threadId <- forkIO $ pollPath False chan path' actPred pmMap - modifyMVar_ mvarMap $ return . Map.insert (WatchKey threadId) (WatchData path' chan) + 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 - listenRecursive _ (PollManager mvarMap) path actPred chan = do + listenRecursive conf (PollManager mvarMap) path actPred chan = do path' <- canonicalizeDirPath path pmMap <- pathModMap True path' - threadId <- forkIO $ pollPath True chan path' actPred pmMap - modifyMVar_ mvarMap $ return . Map.insert (WatchKey threadId) (WatchData path' chan) + 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 + + usesPolling = const True 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 @@ -8,6 +8,7 @@ , ActionPredicate , Action , WatchConfig(..) + , Debounce(..) , DebounceData(..) , DebouncePayload , Event(..) @@ -49,8 +50,26 @@ type EventChannel = Chan Event --- | Config object, currently used just for debouncing events. -data WatchConfig = DebounceDefault | Debounce NominalDiffTime | NoDebounce +-- | Watch configuration +data WatchConfig = WatchConfig + { confDebounce :: Debounce + -- ^ Debounce configuration + , confPollInterval :: Int + -- ^ Polling interval if polling is used (microseconds) + , confUsePolling :: Bool + -- ^ Force use of polling, even if a more effective method may be + -- available. This is mostly for testing purposes. + } + +-- | This specifies whether events close to each other should be collapsed +-- together, and how close is close enough. +data Debounce + = DebounceDefault + -- ^ perform debouncing based on the default time interval + | Debounce NominalDiffTime + -- ^ perform debouncing based on the specified time interval + | NoDebounce + -- ^ do not perform debouncing type IOEvent = IORef Event diff --git a/src/System/FSNotify/Win32.hs b/src/System/FSNotify/Win32.hs --- a/src/System/FSNotify/Win32.hs +++ b/src/System/FSNotify/Win32.hs @@ -18,35 +18,39 @@ import System.FSNotify.Listener import System.FSNotify.Path (fp, canonicalizeDirPath) import System.FSNotify.Types +import Filesystem.Path import qualified System.Win32.Notify as WNo type NativeManager = WNo.WatchManager +-- | Apparently Win32 gives back relative paths, so we pass around the base +-- directory to turn them into absolute ones +type BaseDir = FilePath + -- NEXT TODO: Need to ensure we use properly canonalized paths as -- event paths. In Linux this required passing the base dir to -- handle[native]Event. -void :: IO () -void = return () - -- Win32-notify has (temporarily?) dropped support for Renamed events. -fsnEvent :: UTCTime -> WNo.Event -> Maybe Event -fsnEvent timestamp (WNo.Created False name) = Just $ Added (fp name) timestamp -fsnEvent timestamp (WNo.Modified False name) = Just $ Modified (fp name) timestamp -fsnEvent timestamp (WNo.Deleted False name) = Just $ Removed (fp name) timestamp -fsnEvent _ _ = Nothing +fsnEvent :: BaseDir -> UTCTime -> WNo.Event -> Maybe Event +fsnEvent basedir timestamp ev = + case ev of + WNo.Created False name -> Just $ Added (basedir fp name) timestamp + WNo.Modified False name -> Just $ Modified (basedir fp name) timestamp + WNo.Deleted False name -> Just $ Removed (basedir fp 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] -} -handleWNoEvent :: ActionPredicate -> EventChannel -> DebouncePayload -> WNo.Event -> IO () -handleWNoEvent actPred chan dbp inoEvent = do +handleWNoEvent :: BaseDir -> ActionPredicate -> EventChannel -> DebouncePayload -> WNo.Event -> IO () +handleWNoEvent basedir actPred chan dbp inoEvent = do currentTime <- getCurrentTime - let maybeEvent = fsnEvent currentTime inoEvent + let maybeEvent = fsnEvent basedir currentTime inoEvent case maybeEvent of Just evt -> handleEvent actPred chan dbp evt - Nothing -> void + Nothing -> return () handleEvent :: ActionPredicate -> EventChannel -> DebouncePayload -> Event -> IO () handleEvent actPred chan dbp event = when (actPred event) $ case dbp of @@ -66,20 +70,19 @@ killSession = WNo.killWatchManager - listen db watchManager path actPred chan = do + listen conf watchManager path actPred chan = do path' <- canonicalizeDirPath path - dbp <- newDebouncePayload db - _ <- WNo.watchDirectory watchManager (fp path') False varieties (handler actPred chan dbp) - void + dbp <- newDebouncePayload $ confDebounce conf + wid <- WNo.watchDirectory watchManager (fp path') False varieties (handleWNoEvent path' actPred chan dbp) + return $ WNo.killWatch wid - listenRecursive db watchManager path actPred chan = do + listenRecursive conf watchManager path actPred chan = do path' <- canonicalizeDirPath path - dbp <- newDebouncePayload db - _ <- WNo.watchDirectory watchManager (fp path') True varieties (handler actPred chan dbp) - void + dbp <- newDebouncePayload $ confDebounce conf + wid <- WNo.watchDirectory watchManager (fp path') True varieties (handleWNoEvent path' actPred chan dbp) + return $ WNo.killWatch wid -handler :: ActionPredicate -> EventChannel -> DebouncePayload -> WNo.Event -> IO () -handler = handleWNoEvent + usesPolling = const False varieties :: [WNo.EventVariety] varieties = [WNo.Create, WNo.Delete, WNo.Move, WNo.Modify] diff --git a/test/EventUtils.hs b/test/EventUtils.hs new file mode 100644 --- /dev/null +++ b/test/EventUtils.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE OverloadedStrings, ImplicitParams #-} +module EventUtils where + +import Prelude hiding (FilePath) +import Test.Tasty.HUnit +import Control.Concurrent +import Control.Concurrent.Async +import Control.Applicative +import Control.Monad +import Data.IORef +import Filesystem.Path +import Filesystem.Path.CurrentOS +import System.FSNotify +import System.IO.Unsafe +import System.Directory +import Text.Printf + +delay :: (?timeInterval :: Int) => IO () +delay = threadDelay ?timeInterval + +-- event patterns +data EventPattern = EventPattern + { patFile :: FilePath + , patName :: String + , 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) + + +matchEvents :: [EventPattern] -> [Event] -> Assertion +matchEvents expected actual = do + unless (length expected == length actual) $ + assertFailure $ printf + "Unexpected number of events.\n Expected: %s\n Actual: %s\n" + (show expected) + (show actual) + sequence_ $ (\f -> zipWith f expected actual) $ \pat ev -> + assertBool + (printf "Unexpected event.\n Expected :%s\n Actual: %s\n" + (show expected) + (show actual)) + (patPredicate pat ev) + +instance Show EventPattern where + show p = printf "%s %s" (patName p) (show $ patFile p) + +gatherEvents + :: (?timeInterval :: Int) + => Bool -- use polling? + -> (WatchManager -> FilePath -> ActionPredicate -> Action -> IO StopListening) + -- (^ this is the type of watchDir/watchTree) + -> FilePath + -> IO (Async [Event]) +gatherEvents poll watch path = do + mgr <- startManagerConf defaultConfig + { confDebounce = NoDebounce + , confUsePolling = poll + , confPollInterval = 2 * 10^5 + } + eventsVar <- newIORef [] + stop <- watch mgr path (const True) (\ev -> atomicModifyIORef eventsVar (\evs -> (ev:evs, ()))) + async $ do + delay + stop + reverse <$> readIORef eventsVar + +expectEvents + :: (?timeInterval :: Int) + => Bool + -> (WatchManager -> FilePath -> ActionPredicate -> Action -> IO StopListening) + -> FilePath -> [EventPattern] -> IO () -> Assertion +expectEvents poll w path pats action = do + a <- gatherEvents poll w path + action + evs <- wait a + matchEvents pats evs + +testDirPath :: FilePath +testDirPath = decodeString (unsafePerformIO getCurrentDirectory) "testdir" + +expectEventsHere poll = expectEvents poll watchDir testDirPath +expectEventsHereRec poll = expectEvents poll watchTree testDirPath diff --git a/test/FSNotify.hs b/test/FSNotify.hs deleted file mode 100644 --- a/test/FSNotify.hs +++ /dev/null @@ -1,198 +0,0 @@ --- --- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org --- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org --- - -module FSNotify (spec) where - -import Prelude hiding (appendFile, FilePath, writeFile) - -import Control.Concurrent.Chan (newChan, writeChan) -import Data.ByteString (empty) -import Data.Text (pack) -import Data.Time.Clock.POSIX (posixSecondsToUTCTime) -import Filesystem (removeFile, rename, writeFile, writeTextFile) -import Filesystem.Path.CurrentOS ((), FilePath) -import System.FilePath.Glob (compile, match, Pattern) -import System.FSNotify.Path (fp) -import System.FSNotify.Types -import Test.Hspec (describe, it, Spec) -import Util -type Assertion = IO () - -spec :: Spec -spec = do - describe "watchDir" $ do - it "Create file" $ testFileName "txt" >>= createFileSpec ActionEnv - it "Modify file" $ testFileName "txt" >>= modifyFileSpec ActionEnv - it "Remove file" $ testFileName "txt" >>= removeFileSpec ActionEnv - it "Rename file" $ renameInput >>= renameFileSpec ActionEnv - it "Debounce" $ testFileName "txt" >>= dbFileSpec ActionEnv - describe "watchDirChan" $ do - it "Create file" $ testFileName "txt" >>= createFileSpec ChanEnv - it "Modify file" $ testFileName "txt" >>= modifyFileSpec ChanEnv - it "Remove file" $ testFileName "txt" >>= removeFileSpec ChanEnv - it "Rename file" $ renameInput >>= renameFileSpec ChanEnv - describe "watchTree" $ do - it "Create file (pre-existing directory)" $ testFileName "txt" >>= createFileSpecR1 ActionEnv - it "Create file (create directory)" $ testFileName "txt" >>= createFileSpecR2 ActionEnv - it "Modify file" $ testFileName "txt" >>= modifyFileSpecR ActionEnv - it "Remove file" $ testFileName "txt" >>= removeFileSpecR ActionEnv - it "Rename file" $ renameInput >>= renameFileSpecR ActionEnv - describe "watchTreeChan" $ do - it "Create file (pre-existing directory)" $ testFileName "txt" >>= createFileSpecR1 ChanEnv - it "Create file (create directory)" $ testFileName "txt" >>= createFileSpecR2 ChanEnv - it "Modify file" $ testFileName "txt" >>= modifyFileSpecR ChanEnv - it "Remove file" $ testFileName "txt" >>= removeFileSpecR ChanEnv - it "Rename file" $ renameInput >>= renameFileSpecR ChanEnv - -createFileSpec :: ChanActionEnv -> FilePath -> Assertion -createFileSpec envType fileName = do - inEnv envType DirEnv act action $ matchEvents matchers - where - action :: FilePath -> IO () - action envDir = writeFile (envDir fileName) empty - matchers :: [EventPredicate] - matchers = [EventPredicate "File creation" (matchCreate fileName)] - -modifyFileSpec :: ChanActionEnv -> FilePath -> Assertion -modifyFileSpec envType fileName = do - withTempDir $ \envDir -> do - writeFile (envDir fileName) empty - inTempDirEnv envType DirEnv act action (matchEvents matchers) envDir - where - action :: FilePath -> IO () - action envDir = do - writeTextFile (envDir fileName) $ pack "Hello world" - matchers :: [EventPredicate] - matchers = [EventPredicate "File modification" (matchModify fileName)] - -removeFileSpec :: ChanActionEnv -> FilePath -> Assertion -removeFileSpec envType fileName = do - withTempDir $ \envDir -> do - writeFile (envDir fileName) empty - inTempDirEnv envType DirEnv act action (matchEvents matchers) envDir - where - action :: FilePath -> IO () - action envDir = removeFile (envDir fileName) - matchers :: [EventPredicate] - matchers = [EventPredicate "File deletion" (matchRemove fileName)] - -renameFileSpec :: ChanActionEnv -> (FilePath, FilePath) -> Assertion -renameFileSpec envType (oldFileName, newFileName) = do - withTempDir $ \envDir -> do - writeFile (envDir oldFileName) empty - inTempDirEnv envType DirEnv act action (matchEvents matchers) envDir - where - action :: FilePath -> IO () - action envDir = rename (envDir oldFileName) (envDir newFileName) - matchers :: [EventPredicate] - matchers = [ EventPredicate "Rename: File deletion" (matchRemove oldFileName) - , EventPredicate "Rename: File creation" (matchCreate newFileName) ] - --- TODO: This is a weak test. What we actually need is an interface for --- "anti-matchers" to ensure that certain events do NOT get reported. -dbFileSpec :: ChanActionEnv -> FilePath -> Assertion -dbFileSpec envType _ = do - chan <- newChan - inChanEnv envType DirEnv act (action chan) (matchEvents matchers) chan - where - action :: EventChannel -> FilePath -> IO () - action chan _ = do - writeChan chan e1 - writeChan chan e2 - matchers :: [EventPredicate] - matchers = [EventPredicate "First debounced event" (\e -> e == e1)] - e1 :: Event - e1 = Added (fp "") (posixSecondsToUTCTime 0) - e2 :: Event - e2 = Modified (fp "") (posixSecondsToUTCTime 0) - -createFileSpecR1 :: ChanActionEnv -> FilePath -> Assertion -createFileSpecR1 envType fileName = do - withTempDir $ \envDir -> do - withNestedTempDir envDir $ \envPath -> do - inTempDirEnv envType TreeEnv act (action envPath) (matchEvents matchers) envDir - where - action :: FilePath -> FilePath -> IO () - action envPath _ = do - writeFile (envPath fileName) empty - matchers :: [EventPredicate] - matchers = [EventPredicate "File creation" (matchCreate fileName)] - -createFileSpecR2 :: ChanActionEnv -> FilePath -> Assertion -createFileSpecR2 envType fileName = do - withTempDir $ \envDir -> do - inTempDirEnv envType TreeEnv act (action envDir) (matchEvents matchers) envDir - where - action :: FilePath -> FilePath -> IO () - action envDir _ = do - withNestedTempDir envDir $ \envPath -> writeFile (envPath fileName) empty - matchers :: [EventPredicate] - matchers = [EventPredicate "File creation" (matchCreate fileName)] - -modifyFileSpecR :: ChanActionEnv -> FilePath -> Assertion -modifyFileSpecR envType fileName = do - withTempDir $ \envDir -> do - withNestedTempDir envDir $ \envPath -> do - writeFile (envPath fileName) empty - inTempDirEnv envType TreeEnv act (action envPath) (matchEvents matchers) envDir - where - action :: FilePath -> FilePath -> IO () - action envPath _ = do - writeTextFile (envPath fileName) $ pack "Hello world" - matchers :: [EventPredicate] - matchers = [EventPredicate "File deletion" (matchModify fileName)] - -removeFileSpecR :: ChanActionEnv -> FilePath -> Assertion -removeFileSpecR envType fileName = do - withTempDir $ \envDir -> do - withNestedTempDir envDir $ \envPath -> do - writeFile (envPath fileName) empty - inTempDirEnv envType TreeEnv act (action envPath) (matchEvents matchers) envDir - where - action :: FilePath -> FilePath -> IO () - action envPath _ = do - removeFile (envPath fileName) - matchers :: [EventPredicate] - matchers = [EventPredicate "File deletion" (matchRemove fileName)] - -renameFileSpecR :: ChanActionEnv -> (FilePath, FilePath) -> Assertion -renameFileSpecR envType (oldFileName, newFileName) = do - withTempDir $ \envDir -> do - withNestedTempDir envDir $ \envPath -> do - writeFile (envPath oldFileName) empty - inTempDirEnv envType TreeEnv act (action envPath) (matchEvents matchers) envDir - where - action :: FilePath -> FilePath -> IO () - action envPath _ = rename (envPath oldFileName) (envPath newFileName) - matchers :: [EventPredicate] - matchers = [ EventPredicate "Rename: File deletion" (matchRemove oldFileName) - , EventPredicate "Rename: File creation" (matchCreate newFileName) ] - -renameInput :: IO (FilePath, FilePath) -renameInput = do - oldName <- testFileName "txt" - newName <- testFileName "txt" - return (oldName, newName) - -matchCreate :: FilePath -> Event -> Bool -matchCreate fileName (Added path _) = matchFP pattern path - where - pattern = compile $ "**/*" ++ fp fileName -matchCreate _ _ = False - -matchModify :: FilePath -> Event -> Bool -matchModify fileName (Modified path _) = matchFP pattern path - where - pattern = compile $ "**/*" ++ fp fileName -matchModify _ _ = False - -matchRemove :: FilePath -> Event -> Bool -matchRemove fileName (Removed path _) = matchFP pattern path - where - pattern = compile $ "**/*" ++ fp fileName -matchRemove _ _ = False - -matchFP :: Pattern -> FilePath -> Bool -matchFP pattern path = match pattern $ fp path diff --git a/test/Path.hs b/test/Path.hs deleted file mode 100644 --- a/test/Path.hs +++ /dev/null @@ -1,139 +0,0 @@ --- --- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org --- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org --- -{-# LANGUAGE CPP #-} - -module Path (spec) where - -import Prelude hiding (FilePath, writeFile) - -import Control.Applicative ((<*>)) -import Filesystem (writeFile) -import Filesystem.Path.CurrentOS (FilePath) -import Filesystem.Path ((), empty) -import System.FilePath.Glob (compile, match) -import System.FSNotify.Path (canonicalizeDirPath, canonicalizePath, findDirs, findFiles, fp) -import Test.Hspec (describe, it, Spec, shouldBe) -import Util -import qualified Data.ByteString as BS -type Assertion = IO () - --- Boolean XOR -(.^.) :: Bool -> Bool -> Bool -(.^.) True True = False -(.^.) True False = True -(.^.) False True = True -(.^.) False False = False - -hasTrailingSlash :: FilePath -> (FilePath -> IO FilePath) -> Assertion -hasTrailingSlash path canonicalizeFn = do - let expectedTail = last $ fp (fp "dir" empty) -- Get OS/filesystem's idea of a separator - actualPath <- canonicalizeFn path - let actualTail = last (fp actualPath) :: Char - actualTail `shouldBe` expectedTail - -relPath :: FilePath -relPathSlash :: FilePath -absPath :: FilePath -absPathSlash :: FilePath - -relPath = fp "." -#ifdef OS_Linux -absPath = fp "/home" -absPathSlash = fp "/home/" -relPathSlash = fp "./" empty -#else -# ifdef OS_Win32 -absPath = fp "C:" fp "Windows" -absPathSlash = fp "C:" fp "Windows" empty -relPathSlash = fp ".\\" empty -# else -# ifdef OS_Mac -absPath = fp "/Users" -absPathSlash = fp "/Users/" -relPathSlash = fp "./" -# else --- Assume UNIX-like for anything non-Linux/Windows/Mac -absPath = fp "/home" -absPathSlash = fp "/home/" -relPathSlash = fp "./" empty -# endif -# endif -#endif - - -spec :: Spec -spec = do - describe "canonicalizeDirPath" $ do - it "Absolute path keeps trailing slash" $ do - hasTrailingSlash absPathSlash canonicalizeDirPath - it "Absolute path gains trailing slash" $ do - hasTrailingSlash absPath canonicalizeDirPath - it "Relative path keeps trailing slash" $ do - hasTrailingSlash relPathSlash canonicalizeDirPath - it "Relative path gains trailing slash" $ do - hasTrailingSlash relPath canonicalizeDirPath - describe "canonicalizePath" $ do - it "Absolute path keeps trailing slash" $ do - hasTrailingSlash absPathSlash canonicalizePath - it "Relative path keeps trailing slash" $ do - hasTrailingSlash relPathSlash canonicalizePath - describe "findFiles" $ do - it "Non-recursive" $ do - withTempDir $ \tmpDir -> do - fileName <- testFileName "txt" - writeFile (tmpDir fileName) BS.empty - files <- findFiles False tmpDir - 1 `shouldBe` length files - let (resultFP:_) = files - pattern = "**/*" ++ fp fileName - result = fp resultFP - if match (compile pattern) result then - True `shouldBe` True - else - result `shouldBe` pattern - it "Recursive" $ do - withTempDir $ \tmpDir -> do - withNestedTempDir tmpDir $ \tmpPath -> do - fileName <- testFileName "txt" - writeFile (tmpPath fileName) BS.empty - files <- findFiles True tmpDir - 1 `shouldBe` length files - let (resultFP:_) = files - pattern = "**/*" ++ fp fileName - result = fp resultFP - if match (compile pattern) result then - True `shouldBe` True - else - result `shouldBe` pattern - describe "findDirs" $ do - it "Non-recursive" $ - withTempDir $ \tmpDir -> do - withNestedTempDir tmpDir $ \dirName -> do - dirs <- findDirs False tmpDir - 1 `shouldBe` length dirs - let (resultFP:_) = dirs - pattern = "**/*" ++ fp dirName - result = fp resultFP - if match (compile pattern) result then - True `shouldBe` True - else - result `shouldBe` pattern - it "Recursive" $ - withTempDir $ \tmpDir -> do - withNestedTempDir tmpDir $ \dirName1 -> do - withNestedTempDir tmpDir $ \dirName2 -> do - dirs <- findDirs False tmpDir - 2 `shouldBe` length dirs - let pats = ["**/*" ++ fp dirName1, "**/*" ++ fp dirName2] - patFns = map (match . compile) pats - dirStrings = map fp dirs - (r1:r2:r3:r4:_) = patFns <*> dirStrings - -- The two patterns should succeed once and fail once on - -- opposite tests. - if (r1 .^. r2) && (r3 .^. r4) && (r1 .^. r3) && (r2 .^. r4) then - True `shouldBe` True - else - dirStrings `shouldBe` pats - return () diff --git a/test/Util.hs b/test/Util.hs deleted file mode 100644 --- a/test/Util.hs +++ /dev/null @@ -1,186 +0,0 @@ --- --- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org --- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org --- - -module Util where - -import Prelude hiding (FilePath, catch, pred) - -import Control.Concurrent (threadDelay) -import Control.Concurrent.Chan -import Control.Concurrent.MVar (MVar, newMVar, readMVar, swapMVar) -import Control.Exception -import Control.Monad (when) -import Data.Unique.Id -import Filesystem.Path.CurrentOS hiding (concat) -import Filesystem (createTree, removeTree) -import System.IO.Error (isPermissionError) -import System.FSNotify -import System.FSNotify.Path -import System.Random -import System.Timeout (timeout) - -data ChanActionEnv = - ChanEnv - | ActionEnv -data DirTreeEnv = - DirEnv - | TreeEnv -data TestContext = TestContext ChanActionEnv DirTreeEnv ActionPredicate - -data TestReport = TestReport FilePath [Event] deriving (Show) -data TestResult = TestResult Bool String TestReport deriving (Show) -type TestAction = FilePath -> IO () -type MTestResult = MVar TestResult -type TestCase = MTestResult -> IO () -type CurriedEventProcessor = TestReport -> IO (TestResult) -type EventProcessor = MTestResult -> CurriedEventProcessor -data EventPredicate = EventPredicate String (Event -> Bool) - -void :: IO () -void = return () - -predicateName :: EventPredicate -> String -predicateName (EventPredicate name _) = name - -matchEvents :: [EventPredicate] -> EventProcessor -matchEvents preds mVar report@(TestReport _ events) = - swapMVar mVar result >> return result - where - matchMatrix :: [[Bool]] - matchMatrix = map (\(EventPredicate _ pred) -> map (\event -> pred event) events) preds - matchList :: [Bool] - matchList = map (\lst -> any id lst) matchMatrix - errorList :: [(Bool, String)] - errorList = zip matchList (map (\(EventPredicate errStr _) -> errStr) preds) - errorString :: String - errorString = foldl foldError "" errorList - foldError :: String -> (Bool, String) -> String - foldError accStr (success, errStr) = if not success then accStr ++ " " ++ errStr else accStr - status :: Bool - status = all id matchList - result = if status then - TestResult status "" report - else - TestResult status ("Failed to match events: " ++ errorString) report - -newId :: IO String -newId = randomIO >>= initIdSupply >>= return . show . hashedId . idFromSupply - -testFileName :: String -> IO FilePath -testFileName ext = do - uId <- newId - return $ fp ("test-" ++ uId ++ "." ++ ext) - -testName :: IO FilePath -testName = do - uId <- newId - return $ fp ("sandbox-" ++ uId) empty - -dirPreAction :: Int -dirPreAction = 500000 - --- Delay to keep temporary directories around long enough for events to be --- picked up by OS (in microseconds) -dirPostAction :: Int -dirPostAction = 500000 - -withTempDir :: (FilePath -> IO ()) -> IO () -withTempDir fn = withNestedTempDir empty fn - -withNestedTempDir :: FilePath -> (FilePath -> IO ()) -> IO () -withNestedTempDir firstPath fn = do - secondPath <- testName - let path = if firstPath /= empty then - firstPath secondPath - else - secondPath - bracket (createTree path >> threadDelay dirPreAction >> return path) attemptDirectoryRemoval fn - -attemptDirectoryRemoval :: FilePath -> IO () -attemptDirectoryRemoval path = do - threadDelay dirPostAction - catch - (removeTree path) - (\e -> when - (not $ isPermissionError e) - (throw e)) - -performAction :: TestAction -> FilePath -> IO () -performAction action path = action path - -reportOnAction :: FilePath -> EventChannel -> CurriedEventProcessor -> IO TestResult -reportOnAction = reportOnAction' [] - -reportOnAction' :: [Event] -> FilePath -> EventChannel -> CurriedEventProcessor -> IO TestResult -reportOnAction' events path chan processor = do - result@(TestResult status _ _) <- processor (TestReport path events) - if not status then do - event <- readChan chan - reportOnAction' (event:events) path chan processor - else - return result - -actAndReport :: TestAction -> FilePath -> EventChannel -> CurriedEventProcessor -> IO TestResult -actAndReport action path chan processor = do - performAction action path - reportOnAction path chan processor - -testTimeout :: Int -testTimeout = 3000000 - -timeoutTest :: MTestResult -> Maybe () -> IO () -timeoutTest mResult Nothing = do - result <- readMVar mResult - error $ "TIMEOUT: Last test result: " ++ show result -timeoutTest mResult (Just _) = do - result <- readMVar mResult - case result of - (TestResult False _ _) -> error $ show result - (TestResult True _ _) -> void - -runTest :: TestCase -> IO () -runTest test = do - mVar <- newMVar $ TestResult False "Timeout with no test result" (TestReport empty []) - timeout testTimeout (test mVar) >>= timeoutTest mVar - -inEnv :: ChanActionEnv -> DirTreeEnv -> ActionPredicate -> TestAction -> EventProcessor -> IO () -inEnv caEnv dtEnv reportPred action eventProcessor = - withTempDir $ inTempDirEnv caEnv dtEnv reportPred action eventProcessor - -inTempDirEnv :: ChanActionEnv -> DirTreeEnv -> ActionPredicate -> TestAction -> EventProcessor-> FilePath -> IO () -inTempDirEnv caEnv dtEnv reportPred action eventProcessor path = - withManagerConf NoDebounce $ \manager -> do - chan <- newChan - inTempDirChanEnv caEnv dtEnv reportPred action eventProcessor path manager chan - -inChanEnv :: ChanActionEnv -> DirTreeEnv -> ActionPredicate -> TestAction -> EventProcessor -> EventChannel -> IO () -inChanEnv caEnv dtEnv reportPred action eventProcessor chan = - withTempDir $ \path -> do - withManagerConf NoDebounce $ \manager -> do - inTempDirChanEnv caEnv dtEnv reportPred action eventProcessor path manager chan - -inTempDirChanEnv :: ChanActionEnv -> DirTreeEnv -> ActionPredicate -> TestAction -> EventProcessor-> FilePath -> WatchManager -> EventChannel -> IO () -inTempDirChanEnv caEnv dtEnv reportPred action eventProcessor path manager chan = do - watchInEnv caEnv dtEnv manager path reportPred chan - runTest $ \mVar -> do - _ <- actAndReport action path chan $ eventProcessor mVar - void - void - -actionAsChan :: (WatchManager -> FilePath -> ActionPredicate -> Action -> IO ()) -> - WatchManager -> FilePath -> ActionPredicate -> EventChannel -> IO () -actionAsChan actionFunction wm path ap ec = actionFunction wm path ap (writeChan ec) - -watchInEnv :: ChanActionEnv - -> DirTreeEnv - -> WatchManager - -> FilePath - -> ActionPredicate - -> EventChannel - -> IO () -watchInEnv ChanEnv DirEnv = watchDirChan -watchInEnv ChanEnv TreeEnv = watchTreeChan -watchInEnv ActionEnv DirEnv = actionAsChan watchDir -watchInEnv ActionEnv TreeEnv = actionAsChan watchTree diff --git a/test/main.hs b/test/main.hs deleted file mode 100644 --- a/test/main.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Main where - -import Test.Hspec (hspec, Spec) -import qualified Path as P -import qualified FSNotify as FSN - -main :: IO () -main = hspec spec - -spec :: Spec -spec = P.spec >> FSN.spec diff --git a/test/test.hs b/test/test.hs new file mode 100644 --- /dev/null +++ b/test/test.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE OverloadedStrings, ImplicitParams, ViewPatterns #-} +import Prelude hiding + ( FilePath, writeFile, writeFile, removeFile + , createDirectory, removeDirectory) +import Test.Tasty +import Test.Tasty.HUnit +import Filesystem +import Filesystem.Path +import Filesystem.Path.CurrentOS +import System.FSNotify +import System.IO.Temp +import Text.Printf +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 = do + hasNative <- nativeMgrSupported + unless hasNative $ + putStrLn "WARNING: native manager cannot be used or tested on this platform" + defaultMain $ + withResource + (createTree testDirPath) + (const $ removeTree testDirPath) $ + const $ tests hasNative + +tests hasNative = testGroup "Tests" $ do + poll <- + if hasNative + then [False, True] + else [True] + let ?timeInterval = + if poll + then 2*10^6 + else 5*10^5 + 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) >> writeFile f "foo") + , mkTest "delete file" [evRemoved] (\f -> writeFile f "") (\f -> removeFile f) + , mkTest "directories are ignored" [] (const $ return ()) + (\f -> createDirectory False f >> removeDirectory f) + ] + return $ t nested recursive poll + where + mkTest title evs prepare action nested recursive poll = + testCase title $ + withTempDirectory (encodeString testDirPath) "test." $ \(decodeString -> watchedDir) -> do + let baseDir = if nested then watchedDir "subdir" else watchedDir + f = baseDir filename + expect = + expectEvents poll + (if recursive then watchTree else watchDir) + watchedDir + createDirectory 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" diff --git a/test/watch-here.hs b/test/watch-here.hs deleted file mode 100644 --- a/test/watch-here.hs +++ /dev/null @@ -1,20 +0,0 @@ -{- -{-# LANGUAGE OverloadedStrings #-} -import Filesystem.Path.CurrentOS --} -import System.FSNotify -import Filesystem - -main :: IO () -main = do - -- let wd = "." - wd <- getWorkingDirectory - print wd - man <- startManager - watchTree man wd (const True) print - print "press retrun to stop" - getLine - print "watching stopped, press retrun to exit" - stopManager man - getLine - return ()