fsnotify 0.3.0.1 → 0.4.0.0

raw patch · 19 files changed

+809/−715 lines, 19 filesdep +HUnitdep +exceptionsdep +hspecdep −shellydep −tastydep −tasty-hunitdep ~asyncdep ~directorydep ~hinotifyPVP ok

version bump matches the API change (PVP)

Dependencies added: HUnit, exceptions, hspec, hspec-core, hspec-expectations, monad-control, retry, safe-exceptions

Dependencies removed: shelly, tasty, tasty-hunit

Dependency ranges changed: async, directory, hinotify

API changes (from Hackage documentation)

Files

• CHANGELOG.md +17/−0
• README.md +1/−2
• fsnotify.cabal +21/−14
• src/System/FSNotify.hs +94/−88
• src/System/FSNotify/Devel.hs +20/−26
• src/System/FSNotify/Find.hs +32/−0
• src/System/FSNotify/Linux.hs +197/−120
• src/System/FSNotify/Listener.hs +17/−45
• src/System/FSNotify/OSX.hs +25/−37
• src/System/FSNotify/Path.hs +10/−15
• src/System/FSNotify/Polling.hs +36/−35
• src/System/FSNotify/Types.hs +47/−67
• src/System/FSNotify/Win32.hs +11/−24
• test/EventUtils.hs +0/−110
• test/FSNotify/Test/EventTests.hs +133/−0
• test/FSNotify/Test/Util.hs +97/−0
• test/Main.hs +45/−0
• test/Test.hs +0/−128
• win-src/System/Win32/Notify.hs +6/−4

@@ -1,6 +1,23 @@ Changes ======= +Version 0.4.0.0+---------------++API breaking update.++* New options for threading control (single-threaded, thread-per-watch, and thread-per-manager)+* Revamp `WatchConfig` options to be less confusing and reduce boolean blindness.+* Pull out debouncing stuff, since it was never correct as it simply took the last event affecting a given file in the debounce period. Debouncing is currently not included, and should be handled as an orthogonal concern. I'd like to include some debouncing logic, but didn't want to delay this release any longer.+  * We now expose `type DebounceFn = Action -> IO Action`, which represents an arbitrary debouncer. All debouncers should be in the form of one of these functions.+  * A robust state machine debouncer is in progress but not fully implemented yet; see the `state-machine` branch.+  * Contributions are welcome! We can potentially add multiple debouncers of different complexity as modules under `System.FSNotify.Debounce.*`.+* Don't silently fall back to polling on failure of native watcher.+  Instead, throw an exception which the user can recover from by switching to polling.+* Add ModifiedAttributes event type + Linux support+* Add confOnHandlerException to be able to control what happens when a handler throws an exception.+* WatchConfig constructor is no longer exposed. Instead use `defaultConfig {...}` with the accessors.+ Version 0.3.0.0 --------------- 

@@ -1,8 +1,7 @@-hfsnotify [![Linux and Mac build Status](https://travis-ci.org/haskell-fswatch/hfsnotify.svg)](https://travis-ci.org/haskell-fswatch/hfsnotify) [![Windows build status](https://ci.appveyor.com/api/projects/status/7h1msaokgpqo0q42?svg=true)](https://ci.appveyor.com/project/thomasjm/hfsnotify-v2smx)+![CI](https://github.com/haskell-fswatch/hfsnotify/workflows/CI/badge.svg) =========  Unified Haskell interface for basic file system notifications.-  This is a library. There are executables built on top of it. 

@@ -1,5 +1,5 @@ Name:                   fsnotify-Version:                0.3.0.1+Version:                0.4.0.0 Author:                 Mark Dittmer <mark.s.dittmer@gmail.com>, Niklas Broberg Maintainer:             Tom McLaughlin <tom@codedown.io> License:                BSD3@@ -10,29 +10,32 @@                         existing libraries for platform-specific Windows, Mac,                         and Linux filesystem event notification. Category:               Filesystem-Cabal-Version:          >= 1.8+Cabal-Version:          >= 1.10 Build-Type:             Simple Homepage:               https://github.com/haskell-fswatch/hfsnotify Extra-Source-Files:   README.md   CHANGELOG.md-  test/Test.hs-  test/EventUtils.hs+  test/Main.hs   Library-  Build-Depends:          base >= 4.3.1 && < 5+  Default-Language:     Haskell2010+  Build-Depends:          base >= 4.8 && < 5+                        , async >= 2.0.0.0                         , bytestring >= 0.10.2                         , containers >= 0.4-                        , directory >= 1.1.0.0+                        , directory >= 1.3.0.0                         , filepath >= 1.3.0.0+                        , monad-control >= 1.0.0.0+                        , safe-exceptions >= 0.1.0.0                         , text >= 0.11.0                         , time >= 1.1-                        , async >= 2.0.1                         , unix-compat >= 0.2   Exposed-Modules:        System.FSNotify                         , System.FSNotify.Devel-  Other-Modules:          System.FSNotify.Listener+  Other-Modules:          System.FSNotify.Find+                        , System.FSNotify.Listener                         , System.FSNotify.Path                         , System.FSNotify.Polling                         , System.FSNotify.Types@@ -41,8 +44,7 @@   if os(linux)     CPP-Options:        -DOS_Linux     Other-Modules:      System.FSNotify.Linux-    Build-Depends:      hinotify >= 0.3.0,-                        shelly >= 1.6.5,+    Build-Depends:      hinotify >= 0.3.7,                         unix >= 2.7.1.0   else     if os(windows)@@ -59,16 +61,21 @@         Build-Depends:  hfsevents >= 0.1.3  Test-Suite test+  Default-Language:     Haskell2010   Type:                 exitcode-stdio-1.0-  Main-Is:              Test.hs-  Other-modules:        EventUtils+  Main-Is:              Main.hs   Hs-Source-Dirs:       test   GHC-Options:          -Wall -threaded+  Other-Modules:        FSNotify.Test.EventTests+                        , FSNotify.Test.Util +  if os(linux)+    CPP-Options:        -DOS_Linux+   if os(windows)-    Build-Depends:      base >= 4.3.1.0, tasty >= 0.5, tasty-hunit, directory, filepath, unix-compat, fsnotify, async >= 2, temporary, random, Win32+    Build-Depends:      base >= 4.3.1.0, exceptions, hspec, hspec-core, hspec-expectations, HUnit, directory, filepath, unix-compat, fsnotify, async >= 2, safe-exceptions, temporary, random, retry, Win32   else-    Build-Depends:      base >= 4.3.1.0, tasty >= 0.5, tasty-hunit, directory, filepath, unix-compat, fsnotify, async >= 2, temporary, random+    Build-Depends:      base >= 4.3.1.0, exceptions, hspec, hspec-core, hspec-expectations, HUnit, directory, filepath, unix-compat, fsnotify, async >= 2, safe-exceptions, temporary, random, retry  Source-Repository head   Type:                 git

@@ -2,7 +2,7 @@ -- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org -- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org ---{-# LANGUAGE CPP, ScopedTypeVariables, ExistentialQuantification, RankNTypes #-}+{-# LANGUAGE CPP, ScopedTypeVariables, ExistentialQuantification, RankNTypes, LambdaCase, OverloadedStrings, MultiWayIf, FlexibleContexts, RecordWildCards, NamedFieldPuns #-}  -- | NOTE: This library does not currently report changes made to directories, -- only files within watched directories.@@ -32,10 +32,8 @@         -- * Events          Event(..)+       , EventIsDirectory(..)        , EventChannel-       , eventIsDirectory-       , eventTime-       , eventPath        , Action        , ActionPredicate @@ -44,34 +42,46 @@        , withManager        , startManager        , stopManager++       -- * Configuration        , defaultConfig-       , WatchConfig(..)-       , Debounce(..)+       , confWatchMode+       , confThreadingMode+       , confOnHandlerException+       , WatchMode(..)+       , ThreadingMode(..)++       -- * Lower level        , withManagerConf        , startManagerConf        , StopListening-       , isPollingManager         -- * Watching        , watchDir        , watchDirChan        , watchTree        , watchTreeChan+        ) where  import Prelude hiding (FilePath)  import Control.Concurrent import Control.Concurrent.Async-import Control.Exception+import Control.Exception.Safe as E import Control.Monad-import Data.Maybe+import Control.Monad.IO.Class+import Data.Text as T import System.FSNotify.Polling import System.FSNotify.Types import System.FilePath -import System.FSNotify.Listener (StopListening)+import System.FSNotify.Listener (ListenFn, StopListening) +#if !MIN_VERSION_base(4,11,0)+import Data.Monoid+#endif+ #ifdef OS_Linux import System.FSNotify.Linux #else@@ -87,35 +97,34 @@ #endif  -- | 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+data WatchManager = forall manager argType. FileListener manager argType =>+  WatchManager { watchManagerConfig :: WatchConfig+               , watchManagerManager :: manager+               , watchManagerCleanupVar :: (MVar (Maybe (IO ()))) -- cleanup action, or Nothing if the manager is stopped+               , watchManagerGlobalChan :: Maybe (EventAndActionChannel, Async ())+               }  -- | Default configuration ----- * Debouncing is enabled with a time interval of 1 millisecond------ * Polling is disabled------ * The polling interval defaults to 1 second+-- * Uses OS watch mode and single thread. defaultConfig :: WatchConfig defaultConfig =   WatchConfig-    { confDebounce = DebounceDefault-    , confPollInterval = 10^(6 :: Int) -- 1 second-    , confUsePolling = False+    { confWatchMode = WatchModeOS+    , confThreadingMode = SingleThread+    , confOnHandlerException = defaultOnHandlerException     } +defaultOnHandlerException :: SomeException -> IO ()+defaultOnHandlerException e = putStrLn ("fsnotify: handler threw exception: " <> show e)+ -- | Perform an IO action with a WatchManager in place. -- Tear down the WatchManager after the action is complete. withManager :: (WatchManager -> IO a) -> IO a withManager  = withManagerConf defaultConfig  -- | Start a file watch manager.--- Directories can only be watched when they are managed by a started watch+-- Directories can only be watched when they are managed by a started -- watch manager. -- When finished watching. you must release resources via 'stopManager'. -- It is preferrable if possible to use 'withManager' to handle this@@ -127,102 +136,99 @@ -- Stopping a watch manager will immediately stop -- watching for files and free resources. stopManager :: WatchManager -> IO ()-stopManager (WatchManager _ wm cleanupVar) = do-  mbCleanup <- swapMVar cleanupVar Nothing-  fromMaybe (return ()) mbCleanup-  killSession wm+stopManager (WatchManager {..}) = do+  mbCleanup <- swapMVar watchManagerCleanupVar Nothing+  maybe (return ()) liftIO mbCleanup+  liftIO $ killSession watchManagerManager+  case watchManagerGlobalChan of+    Nothing -> return ()+    Just (_, t) -> cancel t  -- | Like 'withManager', but configurable withManagerConf :: WatchConfig -> (WatchManager -> IO a) -> IO a withManagerConf conf = bracket (startManagerConf conf) stopManager  -- | Like 'startManager', but configurable-startManagerConf :: WatchConfig -> IO WatchManager-startManagerConf conf-  | confUsePolling conf = pollingManager-  | otherwise = initSession >>= createManager+startManagerConf :: WatchConfig -> IO (WatchManager)+startManagerConf conf = do+# ifdef OS_Win32+  -- See https://github.com/haskell-fswatch/hfsnotify/issues/50+  unless rtsSupportsBoundThreads $ throwIO $ userError "startManagerConf must be called with -threaded on Windows"+# endif++  case confWatchMode conf of+    WatchModePoll interval -> WatchManager conf <$> liftIO (createPollManager interval) <*> cleanupVar <*> globalWatchChan+    WatchModeOS -> liftIO (initSession ()) >>= createManager+   where-    createManager :: Maybe NativeManager -> IO WatchManager-    createManager (Just nativeManager) =-      WatchManager conf nativeManager <$> cleanupVar-    createManager Nothing = pollingManager+    createManager :: Either Text NativeManager -> IO (WatchManager)+    createManager (Right nativeManager) = WatchManager conf nativeManager <$> cleanupVar <*> globalWatchChan+    createManager (Left err) = throwIO $ userError $ T.unpack $ "Error: couldn't start native file manager: " <> err -    pollingManager =-      WatchManager conf <$> createPollManager <*> cleanupVar+    globalWatchChan = case confThreadingMode conf of+      SingleThread -> do+        globalChan <- newChan+        globalReaderThread <- async $ forever $ do+          (event, action) <- readChan globalChan+          tryAny (action event) >>= \case+            Left _ -> return () -- TODO: surface the exception somehow?+            Right () -> return ()+        return $ Just (globalChan, globalReaderThread)+      _ -> return Nothing      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 StopListening-watchDirChan (WatchManager db wm _) = listen db wm+watchDirChan (WatchManager {..}) path actionPredicate chan = listen watchManagerConfig watchManagerManager path actionPredicate (writeChan chan)  -- | 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 StopListening-watchTreeChan (WatchManager db wm _) = listenRecursive db wm+watchTreeChan (WatchManager {..}) path actionPredicate chan = listenRecursive watchManagerConfig watchManagerManager path actionPredicate (writeChan chan)  -- | 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. watchDir :: WatchManager -> FilePath -> ActionPredicate -> Action -> IO StopListening-watchDir wm = threadChan listen wm+watchDir wm@(WatchManager {watchManagerConfig}) fp actionPredicate action = threadChan listen wm fp actionPredicate wrappedAction+  where wrappedAction x = handle (confOnHandlerException watchManagerConfig) (action x)  -- | 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. watchTree :: WatchManager -> FilePath -> ActionPredicate -> Action -> IO StopListening-watchTree wm = threadChan listenRecursive wm+watchTree wm@(WatchManager {watchManagerConfig}) fp actionPredicate action = threadChan listenRecursive wm fp actionPredicate wrappedAction+  where wrappedAction x = handle (confOnHandlerException watchManagerConfig) (action x) -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?+-- * Main threading logic++threadChan :: (forall a b. ListenFn a b) -> WatchManager -> FilePath -> ActionPredicate -> Action -> IO StopListening+threadChan listenFn (WatchManager {watchManagerGlobalChan=(Just (globalChan, _)), ..}) path actPred action =+  modifyMVar watchManagerCleanupVar $ \case+    Nothing -> return (Nothing, return ()) -- we've been stopped. Throw an exception?     Just cleanup -> do+      stopListener <- liftIO $ listenFn watchManagerConfig watchManagerManager path actPred (\event -> writeChan globalChan (event, action))+      return (Just (cleanup >> stopListener), stopListener)+threadChan listenFn (WatchManager {watchManagerGlobalChan=Nothing, ..}) path actPred action =+  modifyMVar watchManagerCleanupVar $ \case+    Nothing -> return (Nothing, return ()) -- we've been stopped. 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 -> IO ()-readEvents chan action = forever $ do-  event <- readChan chan-  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 ())+      let forkThreadPerEvent = case confThreadingMode watchManagerConfig of+            SingleThread -> error "Should never happen"+            ThreadPerWatch -> False+            ThreadPerEvent -> True+      readerThread <- async $ readEvents forkThreadPerEvent chan+      stopListener <- liftIO $ listenFn watchManagerConfig watchManagerManager path actPred (writeChan chan)+      return (Just (cleanup >> stopListener >> cancel readerThread), stopListener >> cancel readerThread) -#if !MIN_VERSION_base(4,6,0)-forkFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId-forkFinally action and_then =-  mask $ \restore ->-    forkIO $ try (restore action) >>= and_then-#endif+  where+    readEvents :: Bool -> EventChannel -> IO ()+    readEvents True chan = forever $ readChan chan >>= (async . action)+    readEvents False chan = forever $ readChan chan >>= action

@@ -1,9 +1,11 @@+{-# LANGUAGE FlexibleContexts #-}+ -- | Some additional functions on top of "System.FSNotify". -- -- Example of compiling scss files with compass -- -- @--- compass :: WatchManager -> FilePath -> IO ()+-- compass :: WatchManager -> FilePath -> m () -- compass man dir = do --  putStrLn $ "compass " ++ encodeString dir --  treeExtExists man dir "scss" $ \fp ->@@ -13,6 +15,8 @@ --  return () -- @ +{-# LANGUAGE NamedFieldPuns #-}+ module System.FSNotify.Devel   ( treeExtAny, treeExtExists,     doAllEvents,@@ -29,49 +33,39 @@ -- events (but ignore 'Removed' events) for files with the given file -- extension treeExtExists :: WatchManager-         -> FilePath -- ^ Directory to watch-         -> Text -- ^ extension-         -> (FilePath -> IO ()) -- ^ action to run on file-         -> IO StopListening+              -> FilePath -- ^ Directory to watch+              -> Text -- ^ extension+              -> (FilePath -> IO ()) -- ^ action to run on file+              -> IO StopListening treeExtExists man dir ext action =   watchTree man dir (existsEvents $ flip hasThisExtension ext) (doAllEvents action)  -- | In the given directory tree, watch for any events for files with the -- given file extension treeExtAny :: WatchManager-         -> FilePath -- ^ Directory to watch-         -> Text -- ^ extension-         -> (FilePath -> IO ()) -- ^ action to run on file-         -> IO StopListening+           -> FilePath -- ^ Directory to watch+           -> Text -- ^ extension+           -> (FilePath -> IO ()) -- ^ action to run on file+           -> IO StopListening treeExtAny man dir ext action =   watchTree man dir (allEvents $ flip hasThisExtension ext) (doAllEvents action)  -- | Turn a 'FilePath' callback into an 'Event' callback that ignores the -- 'Event' type and timestamp doAllEvents :: Monad m => (FilePath -> m ()) -> Event -> m ()-doAllEvents action event =-  case event of-    Added    f _ _ -> action f-    Modified f _ _ -> action f-    Removed  f _ _ -> action f-    Unknown  f _ _ -> action f+doAllEvents action = action . eventPath  -- | Turn a 'FilePath' predicate into an 'Event' predicate that accepts--- only 'Added' and 'Modified' event types+-- only 'Added', 'Modified', and 'ModifiedAttributes' event types existsEvents :: (FilePath -> Bool) -> (Event -> Bool) existsEvents filt event =   case event of-    Added    f _ _ -> filt f-    Modified f _ _ -> filt f-    Removed  _ _ _ -> False-    Unknown  _ _ _ -> False+    Added {eventPath} -> filt eventPath+    Modified {eventPath} -> filt eventPath+    ModifiedAttributes {eventPath} -> filt eventPath+    _ -> False  -- | Turn a 'FilePath' predicate into an 'Event' predicate that accepts -- any event types allEvents :: (FilePath -> Bool) -> (Event -> Bool)-allEvents filt event =-  case event of-    Added    f _ _ -> filt f-    Modified f _ _ -> filt f-    Removed  f _ _ -> filt f-    Unknown  f _ _ -> filt f+allEvents filt = filt . eventPath

@@ -0,0 +1,32 @@+-- | Adapted from how Shelly does finding in Shelly.Find+-- (shelly is BSD-licensed)++module System.FSNotify.Find where++import Control.Monad+import Control.Monad.IO.Class+import System.Directory (doesDirectoryExist, listDirectory, pathIsSymbolicLink)+import System.FilePath++find :: Bool -> FilePath -> IO [FilePath]+find followSymlinks = find' followSymlinks  []++find' :: Bool -> [FilePath] -> FilePath -> IO [FilePath]+find' followSymlinks startValue dir = do+  (rPaths, aPaths) <- lsRelAbs dir+  foldM visit startValue (zip rPaths aPaths)+  where+    visit acc (relativePath, absolutePath) = do+      isDir <- liftIO $ doesDirectoryExist absolutePath+      sym <- liftIO $ pathIsSymbolicLink absolutePath+      let newAcc = relativePath : acc+      if isDir && (followSymlinks || not sym)+        then find' followSymlinks newAcc relativePath+        else return newAcc++lsRelAbs :: FilePath -> IO ([FilePath], [FilePath])+lsRelAbs fp = do+  files <- liftIO $ listDirectory fp+  let absolute = map (fp </>) files+  let relativized = map (\p -> joinPath [fp, p]) files+  return (relativized, absolute)

@@ -2,7 +2,16 @@ -- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org -- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org ---{-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE OverloadedStrings #-}+ {-# OPTIONS_GHC -fno-warn-orphans #-}  module System.FSNotify.Linux@@ -10,94 +19,97 @@        , NativeManager        ) where -import Control.Concurrent.Chan import Control.Concurrent.MVar-import Control.Exception as E+import Control.Exception.Safe as E import Control.Monad import qualified Data.ByteString as BS-import Data.IORef (atomicModifyIORef, readIORef)+import Data.Function+import Data.Monoid import Data.String-import qualified Data.Text as T-import Data.Time.Clock (UTCTime, getCurrentTime)+import Data.Time.Clock (UTCTime) import Data.Time.Clock.POSIX-import Data.Typeable import qualified GHC.Foreign as F import GHC.IO.Encoding (getFileSystemEncoding) import Prelude hiding (FilePath)-import qualified Shelly as S+import System.Directory (canonicalizePath)+import System.FSNotify.Find import System.FSNotify.Listener-import System.FSNotify.Path (findDirs, canonicalizeDirPath) import System.FSNotify.Types-import System.FilePath+import System.FilePath (FilePath, (</>)) import qualified System.INotify as INo+import System.Posix.ByteString (RawFilePath)+import System.Posix.Directory.ByteString (openDirStream, readDirStream, closeDirStream) import System.Posix.Files (getFileStatus, isDirectory, modificationTimeHiRes) -type NativeManager = INo.INotify +data INotifyListener = INotifyListener { listenerINotify :: INo.INotify }++type NativeManager = INotifyListener+ data EventVarietyMismatchException = EventVarietyMismatchException deriving (Show, Typeable) instance Exception EventVarietyMismatchException -#if MIN_VERSION_hinotify(0, 3, 10)-toRawFilePath :: FilePath -> IO BS.ByteString-toRawFilePath fp = do-  enc <- getFileSystemEncoding-  F.withCString enc fp BS.packCString -fromRawFilePath :: BS.ByteString -> IO FilePath-fromRawFilePath bs = do-  enc <- getFileSystemEncoding-  BS.useAsCString bs (F.peekCString enc)-#else-toRawFilePath = return . id-fromRawFilePath = return . id-#endif+fsnEvents :: RawFilePath -> UTCTime -> INo.Event -> IO [Event]+fsnEvents basePath' timestamp (INo.Attributes (boolToIsDirectory -> isDir) (Just raw)) = do+  basePath <- fromRawFilePath basePath'+  fromHinotifyPath raw >>= \name -> return [ModifiedAttributes (basePath </> name) timestamp isDir]+fsnEvents basePath' timestamp (INo.Modified (boolToIsDirectory -> isDir) (Just raw)) = do+  basePath <- fromRawFilePath basePath'+  fromHinotifyPath raw >>= \name -> return [Modified (basePath </> name) timestamp isDir]+fsnEvents basePath' timestamp (INo.Closed (boolToIsDirectory -> isDir) (Just raw) True) = do+  basePath <- fromRawFilePath basePath'+  fromHinotifyPath raw >>= \name -> return [CloseWrite (basePath </> name) timestamp isDir]+fsnEvents basePath' timestamp (INo.Created (boolToIsDirectory -> isDir) raw) = do+  basePath <- fromRawFilePath basePath'+  fromHinotifyPath raw >>= \name -> return [Added (basePath </> name) timestamp isDir]+fsnEvents basePath' timestamp (INo.MovedOut (boolToIsDirectory -> isDir) raw _cookie) = do+  basePath <- fromRawFilePath basePath'+  fromHinotifyPath raw >>= \name -> return [Removed (basePath </> name) timestamp isDir]+fsnEvents basePath' timestamp (INo.MovedIn (boolToIsDirectory -> isDir) raw _cookie) = do+  basePath <- fromRawFilePath basePath'+  fromHinotifyPath raw >>= \name -> return [Added (basePath </> name) timestamp isDir]+fsnEvents basePath' timestamp (INo.Deleted (boolToIsDirectory -> isDir) raw) = do+  basePath <- fromRawFilePath basePath'+  fromHinotifyPath raw >>= \name -> return [Removed (basePath </> name) timestamp isDir]+fsnEvents basePath' timestamp INo.DeletedSelf = do+  basePath <- fromRawFilePath basePath'+  return [WatchedDirectoryRemoved basePath timestamp IsDirectory]+fsnEvents _ _ INo.Ignored = return []+fsnEvents basePath' timestamp inoEvent = do+  basePath <- fromRawFilePath basePath'+  return [Unknown basePath timestamp IsFile (show inoEvent)] -fsnEvents :: FilePath -> UTCTime -> INo.Event -> IO [Event]-fsnEvents basePath timestamp (INo.Attributes isDir (Just raw)) = fromRawFilePath raw >>= \name -> return [Modified (basePath </> name) timestamp isDir]-fsnEvents basePath timestamp (INo.Modified isDir (Just raw)) = fromRawFilePath raw >>= \name -> return [Modified (basePath </> name) timestamp isDir]-fsnEvents basePath timestamp (INo.Created isDir raw) = fromRawFilePath raw >>= \name -> return [Added (basePath </> name) timestamp isDir]-fsnEvents basePath timestamp (INo.MovedOut isDir raw _cookie) = fromRawFilePath raw >>= \name -> return [Removed (basePath </> name) timestamp isDir]-fsnEvents basePath timestamp (INo.MovedIn isDir raw _cookie) = fromRawFilePath raw >>= \name -> return [Added (basePath </> name) timestamp isDir]-fsnEvents basePath timestamp (INo.Deleted isDir raw) = fromRawFilePath raw >>= \name -> return [Removed (basePath </> name) timestamp isDir]-fsnEvents _ _ (INo.Ignored) = return []-fsnEvents basePath timestamp inoEvent = return [Unknown basePath timestamp (show inoEvent)]+handleInoEvent :: ActionPredicate -> EventCallback -> RawFilePath -> MVar Bool -> INo.Event -> IO ()+handleInoEvent actPred callback basePath watchStillExistsVar inoEvent = do+  when (INo.DeletedSelf == inoEvent) $ modifyMVar_ watchStillExistsVar $ const $ return False -handleInoEvent :: ActionPredicate -> EventChannel -> FilePath -> DebouncePayload -> INo.Event -> IO ()-handleInoEvent actPred chan basePath dbp inoEvent = do   currentTime <- getCurrentTime   events <- fsnEvents basePath currentTime inoEvent-  mapM_ (handleEvent actPred chan dbp) events--handleEvent :: ActionPredicate -> EventChannel -> DebouncePayload -> Event -> IO ()-handleEvent actPred chan dbp event =-  when (actPred event) $ case dbp of-    (Just (DebounceData epsilon ior)) -> do-      lastEvent <- readIORef ior-      unless (debounce epsilon lastEvent event) writeToChan-      atomicModifyIORef ior (const (event, ()))-    Nothing -> writeToChan-  where-    writeToChan = writeChan chan event+  forM_ events $ \event -> when (actPred event) $ callback event  varieties :: [INo.EventVariety]-varieties = [INo.Create, INo.Delete, INo.MoveIn, INo.MoveOut, INo.Attrib, INo.Modify]+varieties = [INo.Create, INo.Delete, INo.MoveIn, INo.MoveOut, INo.Attrib, INo.Modify, INo.CloseWrite, INo.DeleteSelf] -instance FileListener INo.INotify where-  initSession = E.catch (fmap Just INo.initINotify) (\(_ :: IOException) -> return Nothing)+instance FileListener INotifyListener () where+  initSession _ = E.handle (\(e :: IOException) -> return $ Left $ fromString $ show e) $ do+    inotify <- INo.initINotify+    return $ Right $ INotifyListener inotify -  killSession = INo.killINotify+  killSession (INotifyListener {listenerINotify}) = INo.killINotify listenerINotify -  listen conf iNotify path actPred chan = do-    path' <- canonicalizeDirPath path-    dbp <- newDebouncePayload $ confDebounce conf-    rawPath <- toRawFilePath path'-    wd <- INo.addWatch iNotify varieties rawPath (handler path' dbp)-    return $ INo.removeWatch wd-    where-      handler :: FilePath -> DebouncePayload -> INo.Event -> IO ()-      handler = handleInoEvent actPred chan+  listen _conf (INotifyListener {listenerINotify}) path actPred callback = do+    rawPath <- toRawFilePath path+    canonicalRawPath <- canonicalizeRawDirPath rawPath+    watchStillExistsVar <- newMVar True+    hinotifyPath <- rawToHinotifyPath canonicalRawPath+    wd <- INo.addWatch listenerINotify varieties hinotifyPath (handleInoEvent actPred callback canonicalRawPath watchStillExistsVar)+    return $+      modifyMVar_ watchStillExistsVar $ \wse -> do+        when wse $ INo.removeWatch wd+        return False -  listenRecursive conf iNotify initialPath actPred chan = do+  listenRecursive _conf listener initialPath actPred callback = do     -- wdVar stores the list of created watch descriptors. We use it to     -- cancel the whole recursive listening task.     --@@ -108,73 +120,138 @@     wdVar <- newMVar (Just [])      let-      stopListening = do-        modifyMVar_ wdVar $ \mbWds -> do-          maybe (return ()) (mapM_ (\x -> catch (INo.removeWatch x) (\(_ :: SomeException) -> putStrLn ("Error removing watch: " `mappend` show x)))) mbWds-          return Nothing+      removeWatches wds = forM_ wds $ \(wd, watchStillExistsVar) ->+        modifyMVar_ watchStillExistsVar $ \wse -> do+          when wse $+            handle (\(e :: SomeException) -> putStrLn ("Error removing watch: " <> show wd <> " (" <> show e <> ")"))+                   (INo.removeWatch wd)+          return False -    listenRec initialPath wdVar+      stopListening = modifyMVar_ wdVar $ \x -> maybe (return ()) removeWatches x >> return Nothing +    -- Add watches to this directory plus every sub-directory+    rawInitialPath <- toRawFilePath initialPath+    rawCanonicalInitialPath <- canonicalizeRawDirPath rawInitialPath+    watchDirectoryRecursively listener wdVar actPred callback True rawCanonicalInitialPath+    traverseAllDirs rawCanonicalInitialPath $ \subPath ->+      watchDirectoryRecursively listener wdVar actPred callback False subPath+     return stopListening -    where-      listenRec :: FilePath -> MVar (Maybe [INo.WatchDescriptor]) -> IO ()-      listenRec path wdVar = do-        path' <- canonicalizeDirPath path-        paths <- findDirs True path' -        mapM_ (pathHandler wdVar) (path':paths)+type RecursiveWatches = MVar (Maybe [(INo.WatchDescriptor, MVar Bool)]) -      pathHandler :: MVar (Maybe [INo.WatchDescriptor]) -> FilePath -> IO ()-      pathHandler wdVar filePath = do-        dbp <- newDebouncePayload $ confDebounce conf-        rawFilePath <- toRawFilePath filePath-        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 rawFilePath (handler filePath dbp)-              return $ Just (wd:wds)-        where-          handler :: FilePath -> DebouncePayload -> INo.Event -> IO ()-          handler baseDir dbp event = do-            -- When a new directory is created, add recursive inotify watches to it-            -- TODO: there's a race condition here; if there are files present in the directory before-            -- we add the watches, we'll miss them. The right thing to do would be to ls the directory-            -- and trigger Added events for everything we find there-            case event of-              (INo.Created True rawDirPath) -> do-                dirPath <- fromRawFilePath rawDirPath-                let newDir = baseDir </> dirPath-                timestampBeforeAddingWatch <- getPOSIXTime-                listenRec newDir wdVar+watchDirectoryRecursively :: INotifyListener -> RecursiveWatches -> ActionPredicate -> EventCallback -> Bool -> RawFilePath -> IO ()+watchDirectoryRecursively listener@(INotifyListener {listenerINotify}) wdVar actPred callback isRootWatchedDir rawFilePath = do+  modifyMVar_ wdVar $ \case+    Nothing -> return Nothing+    Just wds -> do+      watchStillExistsVar <- newMVar True+      hinotifyPath <- rawToHinotifyPath rawFilePath+      wd <- INo.addWatch listenerINotify varieties hinotifyPath (handleRecursiveEvent rawFilePath actPred callback watchStillExistsVar isRootWatchedDir listener wdVar)+      return $ Just ((wd, watchStillExistsVar):wds) -                -- Find all files/folders that might have been created *after* the timestamp, and hence might have been-                -- missed by the watch-                -- TODO: there's a chance of this generating double events, fix-                files <- S.shelly $ S.find (fromString newDir)-                forM_ files $ \file -> do-                  let newPath = T.unpack $ S.toTextIgnore file-                  fileStatus <- getFileStatus newPath-                  let modTime = modificationTimeHiRes fileStatus-                  when (modTime > timestampBeforeAddingWatch) $ do-                    handleEvent actPred chan dbp (Added (newDir </> newPath) (posixSecondsToUTCTime timestampBeforeAddingWatch) (isDirectory fileStatus)) -              _ -> return ()+handleRecursiveEvent :: RawFilePath -> ActionPredicate -> EventCallback -> MVar Bool -> Bool -> INotifyListener -> RecursiveWatches -> INo.Event -> IO ()+handleRecursiveEvent baseDir actPred callback watchStillExistsVar isRootWatchedDir listener wdVar event = do+  case event of+    (INo.Created True hiNotifyPath) -> do+      -- A new directory was created, so add recursive inotify watches to it+      rawDirPath <- rawFromHinotifyPath hiNotifyPath+      let newRawDir = baseDir <//> rawDirPath+      timestampBeforeAddingWatch <- getPOSIXTime+      watchDirectoryRecursively listener wdVar actPred callback False newRawDir -            -- Remove watch when this directory is removed-            case event of-              (INo.DeletedSelf) -> do-                -- putStrLn "Watched file/folder was deleted! TODO: remove watch."-                return ()-              (INo.Ignored) -> do-                -- putStrLn "Watched file/folder was ignored, which possibly means it was deleted. TODO: remove watch."-                return ()-              _ -> return ()+      newDir <- fromRawFilePath newRawDir -            -- Forward all events, including directory create-            handleInoEvent actPred chan baseDir dbp event+      -- Find all files/folders that might have been created *after* the timestamp, and hence might have been+      -- missed by the watch+      -- TODO: there's a chance of this generating double events, fix+      files <- find False newDir -- TODO: expose the ability to set followSymlinks to True?+      forM_ files $ \newPath -> do+        fileStatus <- getFileStatus newPath+        let modTime = modificationTimeHiRes fileStatus+        when (modTime > timestampBeforeAddingWatch) $ do+          let isDir = if isDirectory fileStatus then IsDirectory else IsFile+          let addedEvent = (Added (newDir </> newPath) (posixSecondsToUTCTime timestampBeforeAddingWatch) isDir)+          when (actPred addedEvent) $ callback addedEvent -  usesPolling = const False+    _ -> return ()++  -- If the watched directory was removed, mark the watch as already removed+  case event of+    INo.DeletedSelf -> modifyMVar_ watchStillExistsVar $ const $ return False+    _ -> return ()++  -- Forward the event. Ignore a DeletedSelf if we're not on the root directory,+  -- since the watch above us will pick up the delete of that directory.+  case event of+    INo.DeletedSelf | not isRootWatchedDir -> return ()+    _ -> handleInoEvent actPred callback baseDir watchStillExistsVar event++++-- * Util++canonicalizeRawDirPath :: RawFilePath -> IO RawFilePath+canonicalizeRawDirPath p = fromRawFilePath p >>= canonicalizePath >>= toRawFilePath++-- | Same as </> but for RawFilePath+-- TODO: make sure this is correct or find in a library+(<//>) :: RawFilePath -> RawFilePath -> RawFilePath+x <//> y = x <> "/" <> y++traverseAllDirs :: RawFilePath -> (RawFilePath -> IO ()) -> IO ()+traverseAllDirs dir cb = traverseAll dir $ \subPath ->+  -- TODO: wish we didn't need fromRawFilePath here+  -- TODO: make sure this does the right thing with symlinks+  fromRawFilePath subPath >>= getFileStatus >>= \case+    (isDirectory -> True) -> cb subPath >> return True+    _ -> return False++traverseAll :: RawFilePath -> (RawFilePath -> IO Bool) -> IO ()+traverseAll dir cb = bracket (openDirStream dir) closeDirStream $ \dirStream ->+  fix $ \loop -> do+    readDirStream dirStream >>= \case+      x | BS.null x -> return ()+      "." -> loop+      ".." -> loop+      subDir -> flip finally loop $ do+        -- TODO: canonicalize?+        let fullSubDir = dir <//> subDir+        shouldRecurse <- cb fullSubDir+        when shouldRecurse $ traverseAll fullSubDir cb++boolToIsDirectory :: Bool -> EventIsDirectory+boolToIsDirectory False = IsFile+boolToIsDirectory True = IsDirectory++toRawFilePath :: FilePath -> IO BS.ByteString+toRawFilePath fp = do+  enc <- getFileSystemEncoding+  F.withCString enc fp BS.packCString++fromRawFilePath :: BS.ByteString -> IO FilePath+fromRawFilePath bs = do+  enc <- getFileSystemEncoding+  BS.useAsCString bs (F.peekCString enc)++#if MIN_VERSION_hinotify(0, 3, 10)+fromHinotifyPath :: BS.ByteString -> IO FilePath+fromHinotifyPath = fromRawFilePath++rawToHinotifyPath :: BS.ByteString -> IO BS.ByteString+rawToHinotifyPath = return++rawFromHinotifyPath :: BS.ByteString -> IO BS.ByteString+rawFromHinotifyPath = return+#else+fromHinotifyPath :: FilePath -> IO FilePath+fromHinotifyPath = return++rawToHinotifyPath :: BS.ByteString -> IO FilePath+rawToHinotifyPath = fromRawFilePath++rawFromHinotifyPath :: FilePath -> IO BS.ByteString+rawFromHinotifyPath = toRawFilePath+#endif

@@ -1,19 +1,19 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE AllowAmbiguousTypes #-} -- -- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org -- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org -- -module System.FSNotify.Listener-       ( debounce-       , epsilonDefault-       , FileListener(..)-       , StopListening-       , newDebouncePayload-       ) where+module System.FSNotify.Listener (+  FileListener(..)+  , StopListening+  , ListenFn+  ) where -import Data.IORef (newIORef)-import Data.Time (diffUTCTime, NominalDiffTime)-import Data.Time.Clock.POSIX (posixSecondsToUTCTime)+import Data.Text import Prelude hiding (FilePath) import System.FSNotify.Types import System.FilePath@@ -21,13 +21,14 @@ -- | An action that cancels a watching/listening job type StopListening = IO () +type ListenFn sessionType argType = FileListener sessionType argType => WatchConfig -> sessionType -> FilePath -> ActionPredicate -> EventCallback -> IO StopListening+ -- | A typeclass that imposes structure on watch managers capable of listening -- for events, or simulated listening for events.-class FileListener sessionType where+class FileListener sessionType argType  | sessionType -> argType where   -- | Initialize a file listener instance.-  initSession :: IO (Maybe sessionType) -- ^ Just an initialized file listener,-                                        --   or Nothing if this file listener-                                        --   cannot be supported.+  initSession :: argType -> IO (Either Text sessionType)+  -- ^ An initialized file listener, or a reason why one wasn't able to start.    -- | Kill a file listener instance.   -- This will immediately stop acting on events for all directories being@@ -38,39 +39,10 @@   -- 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 StopListening+  listen :: ListenFn sessionType argType    -- | 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 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-epsilonDefault = 0.001---- | The default event that provides a basis for comparison.-eventDefault :: Event-eventDefault = Added "" (posixSecondsToUTCTime 0) False---- | A predicate indicating whether two events may be considered "the same--- event". This predicate is applied to the most recent dispatched event and--- the current event after the client-specified ActionPredicate is applied,--- before the event is dispatched.-debounce :: NominalDiffTime -> Event -> Event -> Bool-debounce epsilon e1 e2 =-  eventPath e1 == eventPath e2 && timeDiff > -epsilon && timeDiff < epsilon-  where-    timeDiff = diffUTCTime (eventTime e2) (eventTime e1)---- | Produces a fresh data payload used for debouncing events in a--- handler.-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+  listenRecursive :: ListenFn sessionType argType

@@ -3,18 +3,16 @@ -- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org -- -{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE MultiWayIf, OverloadedStrings, MultiParamTypeClasses #-}  module System.FSNotify.OSX        ( FileListener(..)        , NativeManager        ) where -import Control.Concurrent.Chan-import Control.Concurrent.MVar+import Control.Concurrent import Control.Monad import Data.Bits-import Data.IORef (atomicModifyIORef, readIORef) import Data.Map (Map) import qualified Data.Map as Map import Data.Time.Clock (UTCTime, getCurrentTime)@@ -29,7 +27,7 @@ import qualified System.OSX.FSEvents as FSE  -data WatchData = WatchData FSE.EventStream EventChannel+data WatchData = WatchData FSE.EventStream EventCallback  type WatchMap = Map Unique WatchData data OSXManager = OSXManager (MVar WatchMap)@@ -71,6 +69,7 @@   -- putStrLn $ show ["Event", show e, "isDirectory", show isDirectory, "isFile", show isFile, "isModified", show isModified, "isCreated", show isCreated, "path", path e, "exists", show exists]    return $ if | exists && isModified -> [Modified (path e) timestamp isDirectory]+              | exists && isModifiedAttributes -> [ModifiedAttributes (path e) timestamp isDirectory]               | exists && isCreated -> [Added (path e) timestamp isDirectory]               | (not exists) && hasFlag e FSE.eventFlagItemRemoved -> [Removed (path e) timestamp isDirectory] @@ -80,60 +79,51 @@                | otherwise -> []   where-    isDirectory = hasFlag e FSE.eventFlagItemIsDir+    isDirectory = if hasFlag e FSE.eventFlagItemIsDir then IsDirectory else IsFile     isFile = hasFlag e FSE.eventFlagItemIsFile     isCreated = hasFlag e FSE.eventFlagItemCreated     isRenamed = hasFlag e FSE.eventFlagItemRenamed-    isModified = hasFlag e FSE.eventFlagItemModified || hasFlag e FSE.eventFlagItemInodeMetaMod+    isModified = hasFlag e FSE.eventFlagItemModified+    isModifiedAttributes = hasFlag e FSE.eventFlagItemInodeMetaMod     path = canonicalEventPath     hasFlag event flag = FSE.eventFlags event .&. flag /= 0 -handleEvent :: Bool -> ActionPredicate -> EventChannel -> FilePath -> DebouncePayload -> FSE.Event -> IO ()-handleEvent isRecursive actPred chan dirPath dbp fseEvent = do+handleFSEEvent :: Bool -> ActionPredicate -> EventCallback -> FilePath -> FSE.Event -> IO ()+handleFSEEvent isRecursive actPred callback dirPath fseEvent = do   currentTime <- getCurrentTime   events <- fsnEvents currentTime fseEvent-  handleEvents isRecursive actPred chan dirPath dbp events+  forM_ events $ \event ->+    when (actPred event && (isRecursive || (isDirectlyInside dirPath event))) $+      callback event  -- | For non-recursive monitoring, test if an event takes place directly inside the monitored folder isDirectlyInside :: FilePath -> Event -> Bool isDirectlyInside dirPath event = isRelevantFileEvent || isRelevantDirEvent   where-    isRelevantFileEvent = (not $ eventIsDirectory event) && (takeDirectory dirPath == (takeDirectory $ eventPath event))-    isRelevantDirEvent = eventIsDirectory event && (takeDirectory dirPath == (takeDirectory $ takeDirectory $ eventPath event))--handleEvents :: Bool -> ActionPredicate -> EventChannel -> FilePath -> DebouncePayload -> [Event] -> IO ()-handleEvents isRecursive actPred chan dirPath dbp (event:events) = do-  when (actPred event && (isRecursive || (isDirectlyInside dirPath event))) $ case dbp of-      (Just (DebounceData epsilon ior)) -> do-        lastEvent <- readIORef ior-        when (not $ debounce epsilon lastEvent event) (writeChan chan event)-        atomicModifyIORef ior (\_ -> (event, ()))-      Nothing -> writeChan chan event-  handleEvents isRecursive actPred chan dirPath dbp events-handleEvents _ _ _ _ _ [] = return ()+    isRelevantFileEvent = (eventIsDirectory event == IsFile) && (takeDirectory dirPath == (takeDirectory $ eventPath event))+    isRelevantDirEvent = (eventIsDirectory event == IsDirectory) && (takeDirectory dirPath == (takeDirectory $ takeDirectory $ eventPath event)) -listenFn :: (ActionPredicate -> EventChannel -> FilePath -> DebouncePayload -> FSE.Event -> IO a)+listenFn :: (ActionPredicate -> EventCallback -> FilePath -> FSE.Event -> IO a)          -> WatchConfig          -> OSXManager          -> FilePath          -> ActionPredicate-         -> EventChannel+         -> EventCallback          -> IO StopListening-listenFn handler conf (OSXManager mvarMap) path actPred chan = do+listenFn handler conf (OSXManager mvarMap) path actPred callback = do   path' <- canonicalizeDirPath path-  dbp <- newDebouncePayload $ confDebounce conf   unique <- newUnique-  eventStream <- FSE.eventStreamCreate [path'] 0.0 True False True (handler actPred chan path' dbp)-  modifyMVar_ mvarMap $ \watchMap -> return (Map.insert unique (WatchData eventStream chan) watchMap)+  eventStream <- FSE.eventStreamCreate [path'] 0.0 True False True (handler actPred callback path')+  modifyMVar_ mvarMap $ \watchMap -> return (Map.insert unique (WatchData eventStream callback) watchMap)   return $ do     FSE.eventStreamDestroy eventStream     modifyMVar_ mvarMap $ \watchMap -> return $ Map.delete unique watchMap -instance FileListener OSXManager where-  initSession = do+instance FileListener OSXManager () where+  initSession _ = do     (v1, v2, _) <- FSE.osVersion-    if not $ v1 > 10 || (v1 == 10 && v2 > 6) then return Nothing else-      fmap (Just . OSXManager) $ newMVar Map.empty+    if not $ v1 > 10 || (v1 == 10 && v2 > 6) then return $ Left "Unsupported OS version" else+      (Right . OSXManager) <$> newMVar Map.empty    killSession (OSXManager mvarMap) = do     watchMap <- readMVar mvarMap@@ -142,7 +132,5 @@       eventStreamDestroy' :: WatchData -> IO ()       eventStreamDestroy' (WatchData eventStream _) = FSE.eventStreamDestroy eventStream -  listen = listenFn $ handleEvent False-  listenRecursive = listenFn $ handleEvent True--  usesPolling = const False+  listen = listenFn $ handleFSEEvent False+  listenRecursive = listenFn $ handleFSEEvent True

@@ -2,11 +2,13 @@ -- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org
 -- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org
 --
-{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
 
 module System.FSNotify.Path
        ( findFiles
-       , findDirs
        , findFilesAndDirs
        , canonicalizeDirPath
        , canonicalizePath
@@ -24,7 +26,11 @@ getDirectoryContentsPath path =
   ((map (path </>)) . filter (not . dots) <$> D.getDirectoryContents path) >>= filterM exists
   where
+#if MIN_VERSION_directory(1, 2, 7)
+    exists x = D.doesPathExist x
+#else
     exists x = (||) <$> D.doesFileExist x <*> D.doesDirectoryExist x
+#endif
     dots "."  = True
     dots ".." = True
     dots _    = False
@@ -44,31 +50,20 @@   nestedFiles <- mapM findAllFiles dirs
   return (files ++ concat nestedFiles)
 
-findImmediateFiles, findImmediateDirs :: FilePath -> IO [FilePath]
+findImmediateFiles :: FilePath -> IO [FilePath]
 findImmediateFiles = fileDirContents >=> mapM D.canonicalizePath . fst
-findImmediateDirs  = fileDirContents >=> mapM D.canonicalizePath . snd
 
-findAllDirs :: FilePath -> IO [FilePath]
-findAllDirs path = do
-  dirs <- findImmediateDirs path
-  nestedDirs <- mapM findAllDirs dirs
-  return (dirs ++ concat nestedDirs)
-
 -- * Exported functions below this point
 
 findFiles :: Bool -> FilePath -> IO [FilePath]
 findFiles True path  = findAllFiles       =<< canonicalizeDirPath path
 findFiles False path = findImmediateFiles =<<  canonicalizeDirPath path
 
-findDirs :: Bool -> FilePath -> IO [FilePath]
-findDirs True path  = findAllDirs       =<< canonicalizeDirPath path
-findDirs False path = findImmediateDirs =<< canonicalizeDirPath path
-
 findFilesAndDirs :: Bool -> FilePath -> IO [FilePath]
 findFilesAndDirs False path = getDirectoryContentsPath =<< canonicalizeDirPath path
 findFilesAndDirs True path = do
   (files, dirs) <- fileDirContents path
-  nestedFilesAndDirs <- concat <$> (mapM (findFilesAndDirs False) dirs)
+  nestedFilesAndDirs <- concat <$> mapM (findFilesAndDirs False) dirs
   return (files ++ dirs ++ nestedFilesAndDirs)
 
 -- | add a trailing slash to ensure the path indicates a directory

@@ -1,4 +1,7 @@ {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-} -- -- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org -- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org@@ -11,12 +14,12 @@   ) where  import Control.Concurrent-import Control.Exception+import Control.Exception.Safe import Control.Monad (forM_) import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe-import Data.Time.Clock (UTCTime, getCurrentTime)+import Data.Time.Clock (UTCTime) import Data.Time.Clock.POSIX import Prelude hiding (FilePath) import System.Directory (doesDirectoryExist)@@ -32,47 +35,48 @@                | RemovedEvent  newtype WatchKey = WatchKey ThreadId deriving (Eq, Ord)-data WatchData = WatchData FilePath EventChannel+data WatchData = WatchData FilePath EventCallback type WatchMap = Map WatchKey WatchData-newtype PollManager = PollManager (MVar WatchMap)+data PollManager = PollManager { pollManagerWatchMap :: MVar WatchMap+                               , pollManagerInterval :: Int } -generateEvent :: UTCTime -> Bool -> EventType -> FilePath -> Maybe Event+generateEvent :: UTCTime -> EventIsDirectory -> EventType -> FilePath -> Maybe Event generateEvent timestamp isDir AddedEvent filePath = Just (Added filePath timestamp isDir) generateEvent timestamp isDir ModifiedEvent filePath = Just (Modified filePath timestamp isDir) generateEvent timestamp isDir RemovedEvent filePath = Just (Removed filePath timestamp isDir) -generateEvents :: UTCTime -> EventType -> [(FilePath, Bool)] -> [Event]+generateEvents :: UTCTime -> EventType -> [(FilePath, EventIsDirectory)] -> [Event] generateEvents timestamp eventType = mapMaybe (\(path, isDir) -> generateEvent timestamp isDir eventType path)  -- | Do not return modified events for directories. -- These can arise when files are created inside subdirectories, resulting in the modification time -- of the directory being bumped. However, to increase consistency with the other FileListeners, -- we ignore these events.-handleEvent :: EventChannel -> ActionPredicate -> Event -> IO ()-handleEvent _ _ (Modified _ _ True) = return ()-handleEvent chan actPred event-  | actPred event = writeChan chan event+handleEvent :: EventCallback -> ActionPredicate -> Event -> IO ()+handleEvent _ _ (Modified _ _ IsDirectory) = return ()+handleEvent callback actPred event+  | actPred event = callback event   | otherwise = return () -pathModMap :: Bool -> FilePath -> IO (Map FilePath (UTCTime, Bool))+pathModMap :: Bool -> FilePath -> IO (Map FilePath (UTCTime, EventIsDirectory)) pathModMap recursive path = findFilesAndDirs recursive path >>= pathModMap'   where-    pathModMap' :: [FilePath] -> IO (Map FilePath (UTCTime, Bool))+    pathModMap' :: [FilePath] -> IO (Map FilePath (UTCTime, EventIsDirectory))     pathModMap' files = (Map.fromList . catMaybes) <$> mapM pathAndInfo files -    pathAndInfo :: FilePath -> IO (Maybe (FilePath, (UTCTime, Bool)))-    pathAndInfo path = handle (\(_ :: IOException) -> return Nothing) $ do-      modTime <- getModificationTime path-      isDir <- doesDirectoryExist path-      return $ Just (path, (modTime, isDir))+    pathAndInfo :: FilePath -> IO (Maybe (FilePath, (UTCTime, EventIsDirectory)))+    pathAndInfo p = handle (\(_ :: IOException) -> return Nothing) $ do+      modTime <- getModificationTime p+      isDir <- doesDirectoryExist p+      return $ Just (p, (modTime, if isDir then IsDirectory else IsFile)) -pollPath :: Int -> Bool -> EventChannel -> FilePath -> ActionPredicate -> Map FilePath (UTCTime, Bool) -> IO ()-pollPath interval recursive chan filePath actPred oldPathMap = do+pollPath :: Int -> Bool -> EventCallback -> FilePath -> ActionPredicate -> Map FilePath (UTCTime, EventIsDirectory) -> IO ()+pollPath interval recursive callback filePath actPred oldPathMap = do   threadDelay interval   maybeNewPathMap <- handle (\(_ :: IOException) -> return Nothing) (Just <$> pathModMap recursive filePath)   case maybeNewPathMap of     -- Something went wrong while listing directories; we'll try again on the next poll-    Nothing -> pollPath interval recursive chan filePath actPred oldPathMap+    Nothing -> pollPath interval recursive callback filePath actPred oldPathMap      Just newPathMap -> do       currentTime <- getCurrentTime@@ -86,22 +90,22 @@       handleEvents $ generateEvents' ModifiedEvent [(path, isDir) | (path, (_, isDir)) <- Map.toList modifiedMap]       handleEvents $ generateEvents' RemovedEvent [(path, isDir) | (path, (_, isDir)) <- Map.toList deletedMap] -      pollPath interval recursive chan filePath actPred newPathMap+      pollPath interval recursive callback filePath actPred newPathMap    where-    modifiedDifference :: (UTCTime, Bool) -> (UTCTime, Bool) -> Maybe (UTCTime, Bool)+    modifiedDifference :: (UTCTime, EventIsDirectory) -> (UTCTime, EventIsDirectory) -> Maybe (UTCTime, EventIsDirectory)     modifiedDifference (newTime, isDir1) (oldTime, isDir2)       | oldTime /= newTime || isDir1 /= isDir2 = Just (newTime, isDir1)       | otherwise = Nothing      handleEvents :: [Event] -> IO ()-    handleEvents = mapM_ (handleEvent chan actPred)+    handleEvents = mapM_ (handleEvent callback actPred)   -- Additional init function exported to allow startManager to unconditionally -- create a poll manager as a fallback when other managers will not instantiate.-createPollManager :: IO PollManager-createPollManager = PollManager <$> newMVar Map.empty+createPollManager :: Int -> IO PollManager+createPollManager interval  = PollManager <$> newMVar Map.empty <*> pure interval  killWatchingThread :: WatchKey -> IO () killWatchingThread (WatchKey threadId) = killThread threadId@@ -113,29 +117,26 @@     return $ Map.delete wk m   return () -listen' :: Bool -> WatchConfig -> PollManager -> FilePath -> ActionPredicate -> EventChannel -> IO (IO ())-listen' isRecursive conf (PollManager mvarMap) path actPred chan = do+listen' :: Bool -> WatchConfig -> PollManager -> FilePath -> ActionPredicate -> EventCallback -> IO (IO ())+listen' isRecursive _conf (PollManager mvarMap interval) path actPred callback = do   path' <- canonicalizeDirPath path   pmMap <- pathModMap isRecursive path'-  threadId <- forkIO $ pollPath (confPollInterval conf) isRecursive chan path' actPred pmMap+  threadId <- forkIO $ pollPath interval isRecursive callback path' actPred pmMap   let wk = WatchKey threadId-  modifyMVar_ mvarMap $ return . Map.insert wk (WatchData path' chan)+  modifyMVar_ mvarMap $ return . Map.insert wk (WatchData path' callback)   return $ killAndUnregister mvarMap wk  -instance FileListener PollManager where-  initSession = fmap Just createPollManager+instance FileListener PollManager Int where+  initSession interval = Right <$> createPollManager interval -  killSession (PollManager mvarMap) = do+  killSession (PollManager mvarMap _) = do     watchMap <- readMVar mvarMap     forM_ (Map.keys watchMap) killWatchingThread    listen = listen' False    listenRecursive = listen' True--  usesPolling = const True-  getModificationTime :: FilePath -> IO UTCTime getModificationTime p = fromEpoch . modificationTime <$> getFileStatus p

@@ -7,108 +7,88 @@        ( act        , ActionPredicate        , Action+       , DebounceFn        , WatchConfig(..)-       , Debounce(..)-       , DebounceData(..)-       , DebouncePayload+       , WatchMode(..)+       , ThreadingMode(..)        , Event(..)+       , EventIsDirectory(..)+       , EventCallback        , EventChannel-       , eventPath-       , eventTime-       , eventIsDirectory+       , EventAndActionChannel        , IOEvent        ) where  import Control.Concurrent.Chan+import Control.Exception.Safe import Data.IORef (IORef)-import Data.Time (NominalDiffTime) import Data.Time.Clock (UTCTime) import Prelude hiding (FilePath) import System.FilePath +data EventIsDirectory = IsFile | IsDirectory+  deriving (Show, Eq)+ -- | A file event reported by a file watcher. Each event contains the -- canonical path for the file and a timestamp guaranteed to be after the -- event occurred (timestamps represent current time when FSEvents receives -- it from the OS and/or platform-specific Haskell modules). data Event =-    Added    FilePath UTCTime Bool-  | Modified FilePath UTCTime Bool-  | Removed  FilePath UTCTime Bool-  | Unknown  FilePath UTCTime String+    Added { eventPath :: FilePath, eventTime :: UTCTime, eventIsDirectory :: EventIsDirectory }+  | Modified { eventPath :: FilePath, eventTime :: UTCTime, eventIsDirectory :: EventIsDirectory }+  | ModifiedAttributes { eventPath :: FilePath, eventTime :: UTCTime, eventIsDirectory :: EventIsDirectory }+  | Removed { eventPath :: FilePath, eventTime :: UTCTime, eventIsDirectory :: EventIsDirectory }+  | WatchedDirectoryRemoved  { eventPath :: FilePath, eventTime :: UTCTime, eventIsDirectory :: EventIsDirectory }+  -- ^ Note: currently only emitted on Linux+  | CloseWrite  { eventPath :: FilePath, eventTime :: UTCTime, eventIsDirectory :: EventIsDirectory }+  -- ^ Note: currently only emitted on Linux+  | Unknown  { eventPath :: FilePath, eventTime :: UTCTime, eventIsDirectory :: EventIsDirectory, eventString :: String }+  -- ^ Note: currently only emitted on Linux   deriving (Eq, Show) --- | Helper for extracting the path associated with an event.-eventPath :: Event -> FilePath-eventPath (Added    path _ _) = path-eventPath (Modified path _ _) = path-eventPath (Removed  path _ _) = path-eventPath (Unknown  path _ _) = path+type EventChannel = Chan Event --- | Helper for extracting the time associated with an event.-eventTime :: Event -> UTCTime-eventTime (Added    _ timestamp _) = timestamp-eventTime (Modified _ timestamp _) = timestamp-eventTime (Removed  _ timestamp _) = timestamp-eventTime (Unknown  _ timestamp _) = timestamp+type EventCallback = Event -> IO () -eventIsDirectory :: Event -> Bool-eventIsDirectory (Added    _ _ isDir) = isDir-eventIsDirectory (Modified _ _ isDir) = isDir-eventIsDirectory (Removed  _ _ isDir) = isDir-eventIsDirectory (Unknown  _ _ _) = False+type EventAndActionChannel = Chan (Event, Action) +-- | Method of watching for changes.+data WatchMode =+  WatchModeOS+  -- ^ Use OS-specific mechanisms to be notified of changes (inotify on Linux, FSEvents on OSX, etc.)+  | WatchModePoll { watchModePollInterval :: Int }+  -- ^ Detect changes by polling the filesystem. Less efficient and may miss fast changes. Not recommended+  -- unless you're experiencing problems with 'WatchModeOS'. -type EventChannel = Chan Event+data ThreadingMode =+  SingleThread+  -- ^ Use a single thread for the entire 'Manager'. Event handler callbacks will run sequentially.+  | ThreadPerWatch+  -- ^ Use a single thread for each watch (i.e. each call to 'watchDir', 'watchTree', etc.).+  -- Callbacks within a watch will run sequentially but callbacks from different watches may be interleaved.+  | ThreadPerEvent+  -- ^ Launch a separate thread for every event handler.  -- | 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.+  { confWatchMode :: WatchMode+    -- ^ Watch mode to use+  , confThreadingMode :: ThreadingMode+    -- ^ Threading mode to use+  , confOnHandlerException :: SomeException -> IO ()+    -- ^ Called when a handler throws an exception   } --- | This specifies whether multiple events from the same file should be--- collapsed together, and how close is close enough.------ This is performed by ignoring any event that occurs to the same file--- until the specified time interval has elapsed.------ Note that the current debouncing logic may fail to report certain changes--- to a file, potentially leaving your program in a state that is not--- consistent with the filesystem.------ Make sure that if you are using this feature, all changes you make as a--- result of an 'Event' notification are both non-essential and idempotent.-data Debounce-  = DebounceDefault-    -- ^ perform debouncing based on the default time interval of 1 millisecond-  | Debounce NominalDiffTime-    -- ^ perform debouncing based on the specified time interval-  | NoDebounce-    -- ^ do not perform debouncing- type IOEvent = IORef Event --- | DebouncePayload contents. Contains epsilon value for debouncing--- near-simultaneous events and an IORef of the latest Event. Difference in--- arrival time is measured according to Event value timestamps.-data DebounceData = DebounceData NominalDiffTime IOEvent---- | Data "payload" passed to event handlers to enable debouncing. This value--- is automatically derived from a 'WatchConfig' value. A value of Just--- DebounceData results in debouncing according to the given epsilon and--- IOEvent. A value of Nothing results in no debouncing.-type DebouncePayload = Maybe DebounceData- -- | A predicate used to determine whether to act on an event. type ActionPredicate = Event -> Bool  -- | An action to be performed in response to an event. type Action = Event -> IO ()++-- | A general debouncing function.+type DebounceFn = Action -> IO Action  -- | Predicate to always act. act :: ActionPredicate

@@ -2,6 +2,7 @@ -- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org -- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org --+{-# LANGUAGE MultiParamTypeClasses #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  module System.FSNotify.Win32@@ -12,7 +13,6 @@ import Control.Concurrent import Control.Monad (when) import Data.Bits-import Data.IORef (atomicModifyIORef, readIORef) import qualified Data.Map as Map import Data.Time (getCurrentTime, UTCTime) import Prelude@@ -33,39 +33,28 @@ -- handle[native]Event.  -- Win32-notify has (temporarily?) dropped support for Renamed events.-fsnEvent :: Bool -> BaseDir -> UTCTime -> WNo.Event -> Event+fsnEvent :: EventIsDirectory -> BaseDir -> UTCTime -> WNo.Event -> Event fsnEvent isDirectory basedir timestamp (WNo.Created name) = Added (normalise (basedir </> name)) timestamp isDirectory fsnEvent isDirectory basedir timestamp (WNo.Modified name) = Modified (normalise (basedir </> name)) timestamp isDirectory fsnEvent isDirectory basedir timestamp (WNo.Deleted name) = Removed (normalise (basedir </> name)) timestamp isDirectory -handleWNoEvent :: Bool -> BaseDir -> ActionPredicate -> EventChannel -> DebouncePayload -> WNo.Event -> IO ()-handleWNoEvent isDirectory basedir actPred chan dbp inoEvent = do+handleWNoEvent :: EventIsDirectory -> BaseDir -> ActionPredicate -> EventCallback -> WNo.Event -> IO ()+handleWNoEvent isDirectory basedir actPred callback inoEvent = do   currentTime <- getCurrentTime   let event = fsnEvent isDirectory basedir currentTime inoEvent-  handleEvent actPred chan dbp event--handleEvent :: ActionPredicate -> EventChannel -> DebouncePayload -> Event -> IO ()-handleEvent actPred chan dbp event | actPred event = do-  case dbp of-    (Just (DebounceData epsilon ior)) -> do-      lastEvent <- readIORef ior-      when (not $ debounce epsilon lastEvent event) $ writeChan chan event-      atomicModifyIORef ior (\_ -> (event, ()))-    Nothing -> writeChan chan event-handleEvent _ _ _ _ = return ()+  when (actPred event) $ callback event -watchDirectory :: Bool -> WatchConfig -> WNo.WatchManager -> FilePath -> ActionPredicate -> EventChannel -> IO (IO ())-watchDirectory isRecursive conf watchManager@(WNo.WatchManager mvarMap) path actPred chan = do+watchDirectory :: Bool -> WatchConfig -> WNo.WatchManager -> FilePath -> ActionPredicate -> EventCallback -> IO (IO ())+watchDirectory isRecursive conf watchManager@(WNo.WatchManager mvarMap) path actPred callback = do   path' <- canonicalizeDirPath path-  dbp <- newDebouncePayload $ confDebounce conf    let fileFlags = foldl (.|.) 0 [WNo.fILE_NOTIFY_CHANGE_FILE_NAME, WNo.fILE_NOTIFY_CHANGE_SIZE, WNo.fILE_NOTIFY_CHANGE_ATTRIBUTES]   let dirFlags = foldl (.|.) 0 [WNo.fILE_NOTIFY_CHANGE_DIR_NAME]    -- Start one watch for file events and one for directory events   -- (There seems to be no other way to provide isDirectory information)-  wid1 <- WNo.watchDirectory watchManager path' isRecursive fileFlags (handleWNoEvent False path' actPred chan dbp)-  wid2 <- WNo.watchDirectory watchManager path' isRecursive dirFlags (handleWNoEvent True path' actPred chan dbp)+  wid1 <- WNo.watchDirectory watchManager path' isRecursive fileFlags (handleWNoEvent IsFile path' actPred callback)+  wid2 <- WNo.watchDirectory watchManager path' isRecursive dirFlags (handleWNoEvent IsDirectory path' actPred callback)    -- The StopListening action should make sure to remove the watches from the manager after they're killed.   -- Otherwise, a call to killSession would cause us to try to kill them again, resulting in an invalid handle error.@@ -76,15 +65,13 @@     WNo.killWatch wid2     modifyMVar_ mvarMap $ \watchMap -> return (Map.delete wid2 watchMap) -instance FileListener WNo.WatchManager where+instance FileListener WNo.WatchManager () where   -- TODO: This should actually lookup a Windows API version and possibly return   -- Nothing the calls we need are not available. This will require that API   -- version information be exposed by Win32-notify.-  initSession = fmap Just WNo.initWatchManager+  initSession _ = Right <$> WNo.initWatchManager    killSession = WNo.killWatchManager    listen = watchDirectory False   listenRecursive = watchDirectory True--  usesPolling = const False

@@ -1,110 +0,0 @@-{-# LANGUAGE OverloadedStrings, ImplicitParams #-}-module EventUtils where--import Control.Applicative-import Control.Concurrent-import Control.Concurrent.Async hiding (poll)-import Control.Monad-import Data.IORef-import Data.List (sortBy)-import Data.Monoid-import Data.Ord (comparing)-import Prelude hiding (FilePath)-import System.Directory-import System.FSNotify-import System.FilePath-import System.IO.Unsafe-import Test.Tasty.HUnit-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, evAddedOrModified :: Bool -> FilePath -> EventPattern-evAdded isDirectory path = EventPattern path "Added"-  (\x -> case x of-      Added path' _ isDir | isDirectory == isDir -> pathMatches isDirectory path path'-      _ -> False-  )-evRemoved isDirectory path = EventPattern path "Removed"-  (\x -> case x of-      Removed path' _ isDir | isDirectory == isDir -> pathMatches isDirectory path path'-      _ -> False-  )-evModified isDirectory path = EventPattern path "Modified"-  (\x ->-     case x of-       Modified path' _ isDir | isDirectory == isDir -> pathMatches isDirectory path path'-       _ -> False-  )-evAddedOrModified isDirectory path = EventPattern path "AddedOrModified"-  (\x -> case x of-      Added path' _ isDir | isDirectory == isDir -> pathMatches isDirectory path path'-      Modified path' _ isDir | isDirectory == isDir -> pathMatches isDirectory path path'-      _ -> False-  )--pathMatches True path path' = path == path' || (path <> [pathSeparator]) == path'-pathMatches False path path' = path == path'--matchEvents :: [EventPattern] -> [Event] -> Assertion-matchEvents expected actual = do-  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 :: Int) }-  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 $ sortBy (comparing eventTime) evs--testDirPath :: FilePath-testDirPath = (unsafePerformIO getCurrentDirectory) </> "testdir"--expectEventsHere :: (?timeInterval::Int) => Bool -> [EventPattern] -> IO () -> Assertion-expectEventsHere poll = expectEvents poll watchDir testDirPath--expectEventsHereRec :: (?timeInterval::Int) => Bool -> [EventPattern] -> IO () -> Assertion-expectEventsHereRec poll = expectEvents poll watchTree testDirPath

@@ -0,0 +1,133 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}++module FSNotify.Test.EventTests where++import Control.Exception.Safe+import Control.Monad+import Data.Monoid+import FSNotify.Test.Util+import Prelude hiding (FilePath)+import System.Directory+import System.FSNotify+import System.FilePath+import System.IO+import Test.Hspec+++eventTests :: ThreadingMode -> Spec+eventTests threadingMode = describe "Tests" $+  forM_ [False, True] $ \poll -> describe (if poll then "Polling" else "Native") $ do+    let ?timeInterval = if poll then 2*10^(6 :: Int) else 5*10^(5 :: Int)+    forM_ [False, True] $ \recursive -> describe (if recursive then "Recursive" else "Non-recursive") $+      forM_ [False, True] $ \nested -> describe (if nested then "In a subdirectory" else "Right here") $+        makeTestFolder threadingMode poll recursive nested $ do+          unless (nested || poll || isMac || isWin) $ it "deletes the watched directory" $ \(watchedDir, _f, getEvents, _clearEvents) -> do+            removeDirectory watchedDir++            pauseAndRetryOnExpectationFailure 3 $ getEvents >>= \case+              [WatchedDirectoryRemoved {..}] | eventPath `equalFilePath` watchedDir && eventIsDirectory == IsDirectory -> return ()+              events -> expectationFailure $ "Got wrong events: " <> show events++          it "works with a new file" $ \(_watchedDir, f, getEvents, _clearEvents) -> do+            h <- openFile f AppendMode++            flip finally (hClose h) $+              pauseAndRetryOnExpectationFailure 3 $ getEvents >>= \events ->+                if | nested && not recursive -> events `shouldBe` []+                   | otherwise -> case events of+                       [Added {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()+                       _ -> expectationFailure $ "Got wrong events: " <> show events++          it "works with a new directory" $ \(_watchedDir, f, getEvents, _clearEvents) -> do+            createDirectory f++            pauseAndRetryOnExpectationFailure 3 $ getEvents >>= \events ->+              if | nested && not recursive -> events `shouldBe` []+                 | otherwise -> case events of+                     [Added {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsDirectory -> return ()+                     _ -> expectationFailure $ "Got wrong events: " <> show events++          it "works with a deleted file" $ \(_watchedDir, f, getEvents, clearEvents) -> do+            writeFile f "" >> clearEvents++            removeFile f++            pauseAndRetryOnExpectationFailure 3 $ getEvents >>= \events ->+              if | nested && not recursive -> events `shouldBe` []+                 | otherwise -> case events of+                     [Removed {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()+                     _ -> expectationFailure $ "Got wrong events: " <> show events++          it "works with a deleted directory" $ \(_watchedDir, f, getEvents, clearEvents) -> do+            createDirectory f >> clearEvents++            removeDirectory f++            pauseAndRetryOnExpectationFailure 3 $ getEvents >>= \events ->+              if | nested && not recursive -> events `shouldBe` []+                 | otherwise -> case events of+                     [Removed {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsDirectory -> return ()+                     _ -> expectationFailure $ "Got wrong events: " <> show events++          it "works with modified file attributes" $ \(_watchedDir, f, getEvents, clearEvents) -> do+            writeFile f "" >> clearEvents++            changeFileAttributes f++            -- This test is disabled when polling because the PollManager only keeps track of+            -- modification time, so it won't catch an unrelated file attribute change+            pauseAndRetryOnExpectationFailure 3 $ getEvents >>= \events ->+              if | poll -> return ()+                 | nested && not recursive -> events `shouldBe` []+                 | otherwise -> case events of+#ifdef mingw32_HOST_OS+                     [Modified {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()+#else+                     [ModifiedAttributes {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()+#endif+                     _ -> expectationFailure $ "Got wrong events: " <> show events++          it "works with a modified file" $ \(_watchedDir, f, getEvents, clearEvents) -> do+            writeFile f "" >> clearEvents++#ifdef mingw32_HOST_OS+            writeFile f "foo"+            do+#else+            withFile f WriteMode $ \h ->+              flip finally (hClose h) $ do+                hPutStr h "foo"+#endif++                pauseAndRetryOnExpectationFailure 3 $ getEvents >>= \events ->+                  if | nested && not recursive -> events `shouldBe` []+                     | otherwise -> case events of+#ifdef darwin_HOST_OS+                         [Modified {..}] | poll && eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()+                         [ModifiedAttributes {..}] | not poll && eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()+#else+                         [Modified {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()+#endif+                         _ -> expectationFailure $ "Got wrong events: " <> show events <> " (wanted file path " <> show f <> ")"++#ifdef linux_HOST_OS+          unless poll $+            it "gets a close_write" $ \(_watchedDir, f, getEvents, clearEvents) -> do+              writeFile f "" >> clearEvents+              withFile f WriteMode $ flip hPutStr "asdf"+              pauseAndRetryOnExpectationFailure 3 $ getEvents >>= \events ->+                if | nested && not recursive -> events `shouldBe` []+                   | otherwise -> case events of+                       [cw@(CloseWrite {}), m@(Modified {})]+                         | eventPath cw `equalFilePath` f && eventIsDirectory cw == IsFile+                           && eventPath m `equalFilePath` f && eventIsDirectory m == IsFile -> return ()+                       [m@(Modified {}), cw@(CloseWrite {})]+                         | eventPath cw `equalFilePath` f && eventIsDirectory cw == IsFile+                           && eventPath m `equalFilePath` f && eventIsDirectory m == IsFile -> return ()+                       _ -> expectationFailure $ "Got wrong events: " <> show events+#endif

@@ -0,0 +1,97 @@+{-# LANGUAGE CPP, OverloadedStrings, ImplicitParams, MultiWayIf, LambdaCase, RecordWildCards, ViewPatterns #-}++module FSNotify.Test.Util where++import Control.Concurrent+import Control.Exception.Safe+import Control.Monad+import Control.Retry+import Data.IORef+import System.Directory+import System.FSNotify+import System.FilePath+import System.IO.Temp+import System.PosixCompat.Files (touchFile)+import System.Random as R+import Test.HUnit.Lang+import Test.Hspec++#if !MIN_VERSION_base(4,11,0)+import Data.Monoid+#endif++#ifdef mingw32_HOST_OS+import Data.Bits+import System.Win32.File (getFileAttributes, setFileAttributes, fILE_ATTRIBUTE_TEMPORARY)+-- Perturb the file's attributes, to check that a modification event is emitted+changeFileAttributes :: FilePath -> IO ()+changeFileAttributes file = do+  attrs <- getFileAttributes file+  setFileAttributes file (attrs `xor` fILE_ATTRIBUTE_TEMPORARY)+#else+changeFileAttributes :: FilePath -> IO ()+changeFileAttributes = touchFile+#endif+++isMac :: Bool+#ifdef darwin_HOST_OS+isMac = True+#else+isMac = False+#endif++isWin :: Bool+#ifdef mingw32_HOST_OS+isWin = True+#else+isWin = False+#endif++pauseAndRetryOnExpectationFailure :: (?timeInterval :: Int) => Int -> IO a -> IO a+pauseAndRetryOnExpectationFailure n action = threadDelay ?timeInterval >> retryOnExpectationFailure n action++retryOnExpectationFailure :: Int -> IO a -> IO a+#if MIN_VERSION_retry(0, 7, 0)+retryOnExpectationFailure seconds action = recovering (constantDelay 50000 <> limitRetries (seconds * 20)) [\_ -> Handler handleFn] (\_ -> action)+#else+retryOnExpectationFailure seconds action = recovering (constantDelay 50000 <> limitRetries (seconds * 20)) [\_ -> Handler handleFn] (action)+#endif+  where+    handleFn :: SomeException -> IO Bool+    handleFn (fromException -> Just (HUnitFailure {})) = return True+    handleFn _ = return False+++makeTestFolder :: (?timeInterval :: Int) => ThreadingMode -> Bool -> Bool -> Bool -> SpecWith (FilePath, FilePath, IO [Event], IO ()) -> Spec+makeTestFolder threadingMode poll recursive nested = around $ \action -> do+  withRandomTempDirectory $ \watchedDir -> do+    let fileName = "testfile"+    let baseDir = if nested then watchedDir </> "subdir" else watchedDir+    let watchFn = if recursive then watchTree else watchDir++    createDirectoryIfMissing True baseDir++    -- On Mac, delay before starting the watcher because otherwise creation of "subdir"+    -- can get picked up.+    when isMac $ threadDelay 2000000++    let conf = defaultConfig {+          confWatchMode = if poll then WatchModePoll (2 * 10^(5 :: Int)) else WatchModeOS+          , confThreadingMode = threadingMode+          }++    withManagerConf conf $ \mgr -> do+      eventsVar <- newIORef []+      stop <- watchFn mgr watchedDir (const True) (\ev -> atomicModifyIORef eventsVar (\evs -> (ev:evs, ())))+      let clearEvents = threadDelay ?timeInterval >> atomicWriteIORef eventsVar []+      _ <- action (watchedDir, normalise $ baseDir </> fileName, readIORef eventsVar, clearEvents)+      stop+++-- | Use a random identifier so that every test happens in a different folder+-- This is unfortunately necessary because of the madness of OS X FSEvents; see the comments in OSX.hs+withRandomTempDirectory :: (FilePath -> IO ()) -> IO ()+withRandomTempDirectory action = do+  randomID <- replicateM 10 $ R.randomRIO ('a', 'z')+  withSystemTempDirectory ("test." <> randomID) action

@@ -0,0 +1,45 @@+{-# LANGUAGE CPP, OverloadedStrings, ImplicitParams, MultiWayIf, LambdaCase, RecordWildCards, ViewPatterns #-}++module Main where++import Control.Exception.Safe+import Control.Monad+import Data.IORef+import FSNotify.Test.EventTests+import FSNotify.Test.Util+import Prelude hiding (FilePath)+import System.FSNotify+import System.FilePath+import Test.Hspec+++main :: IO ()+main = do+  hspec $ do+    describe "Configuration" $ do+      it "respects the confOnHandlerException option" $ do+        withRandomTempDirectory $ \watchedDir -> do+          exceptions <- newIORef (0 :: Int)+          let conf = defaultConfig { confOnHandlerException = \_ -> modifyIORef exceptions (+ 1) }++          withManagerConf conf $ \mgr -> do+            stop <- watchDir mgr watchedDir (const True) $ \ev -> do+              case ev of+#ifdef darwin_HOST_OS+                Modified {} -> throwIO $ userError "Oh no!"+#else+                Added {} -> throwIO $ userError "Oh no!"+#endif+                _ -> return ()++            writeFile (watchedDir </> "testfile") "foo"++            let ?timeInterval = 5*10^(5 :: Int)+            pauseAndRetryOnExpectationFailure 3 $+              readIORef exceptions >>= (`shouldBe` 1)++            stop++    describe "SingleThread" $ eventTests SingleThread+    describe "ThreadPerWatch" $ eventTests ThreadPerWatch+    describe "ThreadPerEvent" $ eventTests ThreadPerEvent

@@ -1,128 +0,0 @@-{-# LANGUAGE CPP, OverloadedStrings, ImplicitParams, MultiWayIf #-}--import Control.Concurrent-import Control.Exception-import Control.Monad-import Data.Monoid-import Prelude hiding (FilePath)-import System.Directory-import System.FSNotify-import System.FilePath-import System.IO-import System.IO.Temp-import System.PosixCompat.Files-import System.Random as R-import Test.Tasty-import Test.Tasty.HUnit--import EventUtils--#ifdef mingw32_HOST_OS-import Data.Bits-import System.Win32.File (getFileAttributes, setFileAttributes, fILE_ATTRIBUTE_TEMPORARY)--- Perturb the file's attributes, to check that a modification event is emitted-changeFileAttributes :: FilePath -> IO ()-changeFileAttributes file = do-  attrs <- getFileAttributes file-  setFileAttributes file (attrs `xor` fILE_ATTRIBUTE_TEMPORARY)-#else-changeFileAttributes :: FilePath -> IO ()-changeFileAttributes = touchFile-#endif---isMac :: Bool-#ifdef darwin_HOST_OS-isMac = True-#else-isMac = False-#endif--nativeMgrSupported :: IO Bool-nativeMgrSupported = do-  mgr <- startManager-  stopManager mgr-  return $ not $ isPollingManager mgr--main :: IO ()-main = do-  hasNative <- nativeMgrSupported-  unless hasNative $ putStrLn "WARNING: native manager cannot be used or tested on this platform"-  defaultMain $ withResource (createDirectoryIfMissing True testDirPath)-                             (const $ removeDirectoryRecursive testDirPath)-                             (const $ tests hasNative)---- | There's some kind of race in OS X where the creation of the containing directory shows up as an event--- I explored whether this was due to passing 0 as the sinceWhen argument to FSEventStreamCreate--- in the hfsevents package, but changing that didn't seem to help-pauseBeforeStartingTest :: IO ()-pauseBeforeStartingTest = threadDelay 10000--tests :: Bool -> TestTree-tests hasNative = testGroup "Tests" $ do-  poll <- if hasNative then [False, True] else [True]-  let ?timeInterval = if poll then 2*10^(6 :: Int) else 5*10^(5 :: Int)--  return $ testGroup (if poll then "Polling" else "Native") $ do-    recursive <- [False, True]-    return $ testGroup (if recursive then "Recursive" else "Non-recursive") $ do-      nested <- [False, True]--      return $ testGroup (if nested then "In a subdirectory" else "Right here") $ do-        t <- [ mkTest "new file" (if | isMac && not poll -> [evAddedOrModified False]-                                     | otherwise -> [evAdded False])-                                 (const $ return ())-                                 (\f -> openFile f AppendMode >>= hClose)--             , mkTest "modify file" [evModified False]-                                    (\f -> writeFile f "")-                                    (\f -> appendFile f "foo")--             -- This test is disabled when polling because the PollManager only keeps track of-             -- modification time, so it won't catch an unrelated file attribute change-             , mkTest "modify file attributes" (if poll then [] else [evModified False])-                                               (\f -> writeFile f "")-                                               (\f -> if poll then return () else changeFileAttributes f)--             , mkTest "delete file" [evRemoved False]-                                    (\f -> writeFile f "")-                                    (\f -> removeFile f)--             , mkTest "new directory" (if | isMac -> [evAddedOrModified True]-                                          | otherwise -> [evAdded True])-                                      (const $ return ())-                                      createDirectory--             , mkTest "delete directory" [evRemoved True]-                                         (\f -> createDirectory f)-                                         removeDirectory-          ]-        return $ t nested recursive poll---mkTest :: (?timeInterval::Int) => TestName -> [FilePath -> EventPattern] -> (FilePath -> IO a) ->-          (FilePath -> IO ()) -> Bool -> Bool -> Bool -> TestTree-mkTest title evs prepare action nested recursive poll = do-  testCase title $ do-    -- Use a random identifier so that every test happens in a different folder-    -- This is unfortunately necessary because of the madness of OS X FSEvents; see the comments in OSX.hs-    randomID <- replicateM 10 $ R.randomRIO ('a', 'z')--    let pollDelay = when poll (threadDelay $ 10^(6 :: Int))--    withTempDirectory testDirPath ("test." <> randomID) $ \watchedDir -> do-      let fileName = "testfile"-      let baseDir = if nested then watchedDir </> "subdir" else watchedDir-          f = normalise $ baseDir </> fileName-          watchFn = if recursive then watchTree else watchDir-          expect = expectEvents poll watchFn watchedDir--      createDirectoryIfMissing True baseDir--      pauseBeforeStartingTest--      flip finally (doesFileExist f >>= flip when (removeFile f)) $ do-        _ <- prepare f-        pauseBeforeStartingTest-        flip expect (pollDelay >> action f) (if | nested && (not recursive) -> []-                                                | otherwise -> [ev f | ev <- evs])

@@ -1,3 +1,4 @@+{-# LANGUAGE ScopedTypeVariables #-}
 
 module System.Win32.Notify
   ( Event(..)
@@ -22,6 +23,7 @@ 
 import Control.Concurrent
 import Control.Concurrent.MVar
+import Control.Exception.Safe (SomeException, catch)
 import Control.Monad (forever)
 import Data.Bits
 import Data.List (intersect)
@@ -51,7 +53,7 @@ 
 data WatchId = WatchId ThreadId ThreadId Handle deriving (Eq, Ord, Show)
 type WatchMap = Map WatchId Handler
-data WatchManager = WatchManager (MVar WatchMap)
+data WatchManager = WatchManager { watchManagerWatchMap :: (MVar WatchMap) }
 
 initWatchManager :: IO WatchManager
 initWatchManager =  do
@@ -95,9 +97,9 @@ 
 killWatch :: WatchId -> IO ()
 killWatch (WatchId tid1 tid2 handle) = do
-    killThread tid1
-    if tid1 /= tid2 then killThread tid2 else return ()
-    closeHandle handle
+  killThread tid1
+  if tid1 /= tid2 then killThread tid2 else return ()
+  catch (closeHandle handle) $ \(e :: SomeException) -> return ()
 
 actsToEvents :: FilePath -> [(Action, String)] -> IO [Event]
 actsToEvents baseDir = mapM actToEvent