fsnotify 0.0.11 → 0.1

raw patch · 16 files changed

+470/−761 lines, 16 filesdep +asyncdep +directorydep +fsnotifydep −Cabaldep −Globdep −QuickCheckdep ~basedep ~hinotifydep ~system-fileionew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: async, directory, fsnotify, tasty, tasty-hunit, temporary-rc

Dependencies removed: Cabal, Glob, QuickCheck, bytestring, ghc, hspec, random, uniqueid

Dependency ranges changed: base, hinotify, system-fileio, system-filepath, text

API changes (from Hackage documentation)

Files

• fsnotify.cabal +22/−52
• src/System/FSNotify.hs +112/−57
• src/System/FSNotify/Devel.hs +3/−3
• src/System/FSNotify/Linux.hs +48/−19
• src/System/FSNotify/Listener.hs +10/−3
• src/System/FSNotify/OSX.hs +28/−35
• src/System/FSNotify/Polling.hs +27/−14
• src/System/FSNotify/Types.hs +21/−2
• src/System/FSNotify/Win32.hs +25/−22
• test/EventUtils.hs +98/−0
• test/FSNotify.hs +0/−198
• test/Path.hs +0/−139
• test/Util.hs +0/−186
• test/main.hs +0/−11
• test/test.hs +76/−0
• test/watch-here.hs +0/−20

@@ -1,7 +1,7 @@ Name:                   fsnotify-Version:                0.0.11+Version:                0.1 Author:                 Mark Dittmer <mark.s.dittmer@gmail.com>-Maintainer:             Mark Dittmer <mark.s.dittmer@gmail.com>, Greg Weber <greg@gregweber.info>+Maintainer:             Greg Weber <greg@gregweber.info>, Roman Cheplyaka <roma@ro-che.info> 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

@@ -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 ())

@@ -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) 

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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 

@@ -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]

@@ -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

@@ -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

@@ -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 ()

@@ -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

@@ -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

@@ -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"

@@ -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 ()