fsnotify 0.2.1.2 → 0.4.4.0
raw patch · 22 files changed
Files
- CHANGELOG.md +69/−0
- README.md +1/−2
- example/Main.hs +35/−0
- fsnotify.cabal +144/−70
- src/System/FSNotify.hs +128/−133
- src/System/FSNotify/Devel.hs +28/−30
- src/System/FSNotify/Find.hs +32/−0
- src/System/FSNotify/Linux.hs +137/−115
- src/System/FSNotify/Linux/Util.hs +100/−0
- src/System/FSNotify/Listener.hs +19/−48
- src/System/FSNotify/OSX.hs +76/−75
- src/System/FSNotify/Path.hs +29/−27
- src/System/FSNotify/Polling.hs +92/−83
- src/System/FSNotify/Types.hs +67/−70
- src/System/FSNotify/Win32.hs +45/−61
- test/EventUtils.hs +0/−102
- test/FSNotify/Test/EventTests.hs +165/−0
- test/FSNotify/Test/Util.hs +207/−0
- test/Main.hs +50/−0
- test/test.hs +0/−88
- win-src/System/Win32/FileNotify.hsc +196/−0
- win-src/System/Win32/Notify.hs +123/−0
CHANGELOG.md view
@@ -1,6 +1,75 @@ Changes ======= +Version 0.4.4.0+----------+* Use hinotify and -DHAVE_NATIVE_WATCHER for FreeBSD (#121)+* Start testing FreeBSD in CI (#122)++Version 0.4.3.0+----------+* Use polling as a generic fallback and add support for WASM (https://github.com/haskell-fswatch/hfsnotify/pull/110)+* Gracefully handle broken symlinks (https://github.com/haskell-fswatch/hfsnotify/pull/120)++Version 0.4.2.0+----------++* Bump hfsevents constraint to >= 0.1.8 to pick up race condition fix (see https://github.com/luite/hfsevents/pull/19).+* Compatibility with text-2.1.2 and an upper bound of 2.2.+* Lots of CI and test improvements.++Version 0.4.1.1+---------------++* Document polling interval units (#111).+* Fix compat with text-2.1.2 (closes #116).+* Remove some redundant cleanup code paths.++Version 0.4.1.0+---------------++* Add `unliftio` lower bound (#106).+* Change the tests back to a test-suite to avoid building for library users. (#107).+* Fix up Windows compatibility.+* Export `WatchConfig` type (#108).++Version 0.4.0.1+---------------++* Fix compatibility with *BSD.++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+---------------++API breaking update with a number of bugfixes and improvements.++* Now we can detect directory creation/deletion. A boolean flag has been added+ to `Event` to indicate if the event pertains to a directory or not. This is the+ only API change.+* Test stability improvements + CI test suites now passing on Windows, Linux, and Mac.+* Interpreting OSX hfsevents flags is more sane now (see comments in OSX.hs for details).+* Improve a race condition when adding watches on Linux.+* Improve robustness of the PollManager.+* Fix double call to `closeHandle` on Windows.+* Remove comments about locking from the documentation.+ Version 0.2.1.2 ---------------
README.md view
@@ -1,8 +1,7 @@-hfsnotify+ ========= Unified Haskell interface for basic file system notifications.- This is a library. There are executables built on top of it.
+ example/Main.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE QuasiQuotes #-}++module Main where++import Control.Concurrent+import Data.String.Interpolate+import System.FSNotify+import System.FilePath+import UnliftIO.Temporary+++main :: IO ()+main = do+ withSystemTempDirectory "fsnotify-foo" $ \dir -> do+ putStrLn [i|Starting watch on dir: #{dir}|]++ let conf = defaultConfig++ withManagerConf conf $ \mgr -> do+ stop <- watchDir mgr dir (const True) $ \ev -> do+ putStrLn [i|Got event: #{ev}|]+ threadDelay 3_000_000++ putStrLn [i|Writing to #{dir </> "bar"}|]+ writeFile (dir </> "bar") "asdf"+ threadDelay 3_000_000++ putStrLn [i|Stopping|]+ stop+ putStrLn [i|Stopped|]+ threadDelay 3_000_000++ putStrLn [i|Exited withManagerConf|]+ threadDelay 3_000_000
fsnotify.cabal view
@@ -1,74 +1,148 @@-Name: fsnotify-Version: 0.2.1.2-Author: Mark Dittmer <mark.s.dittmer@gmail.com>-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.-Description: Cross platform library for file creation, modification,- and deletion notification. This library builds upon- existing libraries for platform-specific Windows, Mac,- and Linux filesystem event notification.-Category: Filesystem-Cabal-Version: >= 1.8-Build-Type: Simple-Homepage: https://github.com/haskell-fswatch/hfsnotify-Extra-Source-Files:- README.md- CHANGELOG.md- test/test.hs- test/EventUtils.hs+cabal-version: 1.12 +-- This file has been generated from package.yaml by hpack version 0.38.0.+--+-- see: https://github.com/sol/hpack -Library- Build-Depends: base >= 4.3.1 && < 5- , bytestring >= 0.10.2- , containers >= 0.4- , directory >= 1.1.0.0- , filepath >= 1.3.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- , System.FSNotify.Path- , System.FSNotify.Polling- , System.FSNotify.Types- Hs-Source-Dirs: src- GHC-Options: -Wall- if os(linux)- CPP-Options: -DOS_Linux- Other-Modules: System.FSNotify.Linux- Build-Depends: hinotify >= 0.3.10- else- if os(windows)- CPP-Options: -DOS_Win32- Other-Modules: System.FSNotify.Win32- Build-Depends: Win32-notify >= 0.3- else- if os(darwin)- CPP-Options: -DOS_Mac- Other-Modules: System.FSNotify.OSX- Build-Depends: hfsevents >= 0.1.3+name: fsnotify+version: 0.4.4.0+synopsis: Cross platform library for file change notification.+description: Cross platform library for file creation, modification, and deletion notification. This library builds upon existing libraries for platform-specific Windows, Mac, and Linux filesystem event notification.+category: Filesystem+homepage: https://github.com/haskell-fswatch/hfsnotify+author: Mark Dittmer <mark.s.dittmer@gmail.com>, Niklas Broberg+maintainer: Tom McLaughlin <tom@codedown.io>+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ CHANGELOG.md+ test/Main.hs -Test-Suite test- Type: exitcode-stdio-1.0- Main-Is: test.hs- Other-modules: EventUtils- Hs-Source-Dirs: test- GHC-Options: -Wall -threaded- Build-depends: base >= 4.3.1.0- , tasty >= 0.5- , tasty-hunit- , directory- , filepath- , unix-compat- , fsnotify- , async >= 2- , temporary+library+ exposed-modules:+ System.FSNotify+ System.FSNotify.Devel+ other-modules:+ System.FSNotify.Find+ System.FSNotify.Listener+ System.FSNotify.Path+ System.FSNotify.Polling+ System.FSNotify.Types+ hs-source-dirs:+ src+ default-extensions:+ ScopedTypeVariables+ ghc-options: -Wall+ build-depends:+ async >=2.0.0.0+ , base >=4.8 && <5+ , bytestring >=0.10.2+ , containers >=0.4+ , directory >=1.3.0.0+ , filepath >=1.3.0.0+ , monad-control >=1.0.0.0+ , safe-exceptions >=0.1.0.0+ , text >=0.11.0 && <2.2+ , time >=1.1+ , unix-compat >=0.2+ default-language: Haskell2010+ if os(linux) || os(windows) || os(darwin) || os(freebsd)+ cpp-options: -DHAVE_NATIVE_WATCHER+ if os(linux) || os(freebsd)+ other-modules:+ System.FSNotify.Linux+ System.FSNotify.Linux.Util+ build-depends:+ unix >=2.7.1.0+ if os(linux) && impl(ghc >= 9.10)+ build-depends:+ hinotify >=0.4.2+ if os(linux) && impl(ghc < 9.10)+ build-depends:+ hinotify >=0.3.9+ if os(windows)+ other-modules:+ System.FSNotify.Win32+ System.Win32.FileNotify+ System.Win32.Notify+ hs-source-dirs:+ win-src+ build-depends:+ Win32+ if os(darwin)+ other-modules:+ System.FSNotify.OSX+ build-depends:+ hfsevents >=0.1.8+ if os(freebsd)+ build-depends:+ hinotify >=0.4.1 -Source-Repository head- Type: git- Location: git://github.com/haskell-fswatch/hfsnotify+executable example+ main-is: Main.hs+ other-modules:+ Paths_fsnotify+ hs-source-dirs:+ example+ default-extensions:+ ScopedTypeVariables+ ghc-options: -Wall+ build-depends:+ base+ , directory+ , exceptions+ , filepath+ , fsnotify+ , monad-logger+ , random+ , retry+ , safe-exceptions+ , string-interpolate+ , temporary+ , unix-compat+ , unliftio+ default-language: Haskell2010+ if os(linux) || os(windows) || os(darwin) || os(freebsd)+ cpp-options: -DHAVE_NATIVE_WATCHER+ if !arch(wasm32)+ ghc-options: -threaded++test-suite tests+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules:+ FSNotify.Test.EventTests+ FSNotify.Test.Util+ Paths_fsnotify+ hs-source-dirs:+ test+ default-extensions:+ ScopedTypeVariables+ ghc-options: -threaded -Wall+ build-depends:+ async >=2+ , base >=4.3.1.0+ , directory+ , exceptions+ , filepath+ , fsnotify+ , monad-logger+ , random+ , retry+ , safe-exceptions+ , string-interpolate+ , temporary+ , unix-compat+ , unliftio >=0.2.20+ default-language: Haskell2010+ if os(linux) || os(windows) || os(darwin) || os(freebsd)+ cpp-options: -DHAVE_NATIVE_WATCHER+ if os(windows)+ build-depends:+ Win32+ , sandwich >=0.1.1.1+ else+ build-depends:+ sandwich
src/System/FSNotify.hs view
@@ -2,9 +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, ScopedTypeVariables, ExistentialQuantification, RankNTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-} --- | NOTE: This library does not currently report changes made to directories,+-- | This library does not currently report changes made to directories, -- only files within watched directories. -- -- Minimal example:@@ -27,95 +34,104 @@ -- > -- sleep forever (until interrupted) -- > forever $ threadDelay 1000000 -module System.FSNotify- (+module System.FSNotify (+ -- * Events+ Event(..)+ , EventIsDirectory(..)+ , EventChannel+ , Action+ , ActionPredicate - -- * Events- Event(..)- , EventChannel- , eventTime- , eventPath- , Action- , ActionPredicate+ -- * Starting/Stopping+ , WatchManager+ , withManager+ , startManager+ , stopManager - -- * Starting/Stopping- , WatchManager- , withManager- , startManager- , stopManager- , defaultConfig- , WatchConfig(..)- , Debounce(..)- , withManagerConf- , startManagerConf- , StopListening- , isPollingManager+ -- * Configuration+ , defaultConfig+ , WatchConfig+ , confWatchMode+ , confThreadingMode+ , confOnHandlerException+ , WatchMode(..)+ , ThreadingMode(..) - -- * Watching- , watchDir- , watchDirChan- , watchTree- , watchTreeChan- ) where+ -- * Lower level+ , withManagerConf+ , startManagerConf+ , StopListening + -- * Watching+ , watchDir+ , watchDirChan+ , watchTree+ , watchTreeChan+ ) where+ import Prelude hiding (FilePath) -import Data.Maybe import Control.Concurrent import Control.Concurrent.Async-import Control.Exception-import Control.Applicative+import Control.Exception.Safe as E import Control.Monad-import System.FilePath+import Control.Monad.IO.Class+import qualified 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) -#ifdef OS_Linux+#if !MIN_VERSION_base(4,11,0)+import Data.Monoid+#endif++#if defined(linux_HOST_OS) || defined(freebsd_HOST_OS) import System.FSNotify.Linux-#else-# ifdef OS_Win32+#endif++#ifdef mingw32_HOST_OS import System.FSNotify.Win32-# else-# ifdef OS_Mac+#endif++#ifdef darwin_HOST_OS import System.FSNotify.OSX-# else-type NativeManager = PollManager-# endif-# endif #endif + -- | Watch manager. You need one in order to create watching jobs.-data WatchManager- = forall manager . 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+ , 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 (if possible) and single thread. defaultConfig :: WatchConfig-defaultConfig =- WatchConfig- { confDebounce = DebounceDefault- , confPollInterval = 10^(6 :: Int) -- 1 second- , confUsePolling = False- }+defaultConfig = WatchConfig {+#ifndef HAVE_NATIVE_WATCHER+ confWatchMode = WatchModePoll 500000+#else+ confWatchMode = WatchModeOS+#endif+ , 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,105 +143,84 @@ -- 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+ liftIO $ killSession watchManagerManager+ case watchManagerGlobalChan of+ Nothing -> return ()+ Just (_, t) -> cancel t --- | Like 'withManager', but configurable+-- | Like 'withManager', but configurable. withManagerConf :: WatchConfig -> (WatchManager -> IO a) -> IO a withManagerConf conf = bracket (startManagerConf conf) stopManager --- | Like 'startManager', but configurable+-- | Like 'startManager', but configurable. startManagerConf :: WatchConfig -> IO WatchManager-startManagerConf conf- | confUsePolling conf = pollingManager- | otherwise = initSession >>= createManager- where- createManager :: Maybe NativeManager -> IO WatchManager- createManager (Just nativeManager) =- WatchManager conf nativeManager <$> cleanupVar- createManager Nothing = pollingManager+startManagerConf conf = do+# ifdef mingw32_HOST_OS+ -- See https://github.com/haskell-fswatch/hfsnotify/issues/50+ unless rtsSupportsBoundThreads $ throwIO $ userError "startManagerConf must be called with -threaded on Windows"+# endif - pollingManager =- WatchManager conf <$> createPollManager <*> cleanupVar+ case confWatchMode conf of+ WatchModePoll interval -> WatchManager conf <$> liftIO (createPollManager interval) <*> globalWatchChan+#ifdef HAVE_NATIVE_WATCHER+ WatchModeOS -> liftIO (initSession ()) >>= createManager+#endif - cleanupVar = newMVar (Just (return ()))+ where+#ifdef HAVE_NATIVE_WATCHER+ createManager :: Either T.Text NativeManager -> IO WatchManager+ createManager (Right nativeManager) = WatchManager conf nativeManager <$> globalWatchChan+ createManager (Left err) = throwIO $ userError $ T.unpack $ "Error: couldn't start native file manager: " <> err+#endif --- | Does this manager use polling?-isPollingManager :: WatchManager -> Bool-isPollingManager (WatchManager _ wm _) = usesPolling wm+ 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 -- | 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. No two events pertaining to the same FilePath will--- be executed concurrently.+-- within its subdirectories. watchDir :: WatchManager -> FilePath -> ActionPredicate -> Action -> IO StopListening-watchDir wm = threadChan listen wm+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. No two events--- pertaining to the same FilePath will be executed concurrently.+-- files within the specified directory and its subdirectories. watchTree :: WatchManager -> FilePath -> ActionPredicate -> Action -> IO StopListening-watchTree wm = threadChan listenRecursive wm--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- )+watchTree wm@(WatchManager {watchManagerConfig}) fp actionPredicate action = threadChan listenRecursive wm fp actionPredicate wrappedAction+ where wrappedAction x = handle (confOnHandlerException watchManagerConfig) (action x) -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 ())+-- * Main threading logic -#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+threadChan :: (forall a b. ListenFn a b) -> WatchManager -> FilePath -> ActionPredicate -> Action -> IO StopListening+threadChan listenFn (WatchManager {watchManagerGlobalChan=(Just (globalChan, _)), ..}) path actPred action =+ listenFn watchManagerConfig watchManagerManager path actPred (\event -> writeChan globalChan (event, action))+threadChan listenFn (WatchManager {watchManagerGlobalChan=Nothing, ..}) path actPred action = do+ let wrappedAction = case confThreadingMode watchManagerConfig of+ SingleThread -> error "Should never happen"+ ThreadPerWatch -> action+ ThreadPerEvent -> void . async . action+ listenFn watchManagerConfig watchManagerManager path actPred wrappedAction
src/System/FSNotify/Devel.hs view
@@ -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,63 +15,59 @@ -- return () -- @ -module System.FSNotify.Devel- ( treeExtAny, treeExtExists,- doAllEvents,- allEvents, existsEvents- ) where+{-# LANGUAGE NamedFieldPuns #-} -import Prelude hiding (FilePath)+module System.FSNotify.Devel (+ treeExtAny+ , treeExtExists+ , doAllEvents+ , allEvents+ , existsEvents+ ) where import Data.Text-import System.FilePath+import Prelude hiding (FilePath) import System.FSNotify import System.FSNotify.Path (hasThisExtension)+import System.FilePath -- | In the given directory tree, watch for any 'Added' and 'Modified' -- events (but ignore 'Removed' events) for files with the given file -- 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+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+ 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+allEvents filt = filt . eventPath
+ src/System/FSNotify/Find.hs view
@@ -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)
src/System/FSNotify/Linux.hs view
@@ -2,112 +2,105 @@ -- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org -- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org ---{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module System.FSNotify.Linux- ( FileListener(..)- , NativeManager- ) where+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ViewPatterns #-} -import Prelude hiding (FilePath)+{-# OPTIONS_GHC -fno-warn-orphans #-} +module System.FSNotify.Linux (+ FileListener(..)+ , NativeManager+ ) where -import Control.Concurrent.Chan import Control.Concurrent.MVar-import Control.Exception as E-import Control.Monad (when)-import qualified Data.ByteString as BS-import Data.IORef (atomicModifyIORef, readIORef)-import Data.Time.Clock (UTCTime, getCurrentTime)-import Data.Typeable--- import Debug.Trace (trace)-import qualified GHC.Foreign as F-import GHC.IO.Encoding (getFileSystemEncoding)-import System.FilePath+import Control.Exception.Safe as E+import Control.Monad+import Data.Function+import Data.Monoid+import Data.String+import Data.Time.Clock (UTCTime)+import Data.Time.Clock.POSIX+import Prelude hiding (FilePath)+import System.FSNotify.Find+import System.FSNotify.Linux.Util import System.FSNotify.Listener-import System.FSNotify.Path (findDirs, canonicalizeDirPath) import System.FSNotify.Types+import System.FilePath ((</>)) import qualified System.INotify as INo+import System.Posix.ByteString (RawFilePath)+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 -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)+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)] --- Note that INo.Closed in this context is "modified" because we listen to--- CloseWrite events.-fsnEvent :: FilePath -> UTCTime -> INo.Event -> IO (Maybe Event)-fsnEvent basePath timestamp event = case event of- INo.Created False raw -> do- name <- fromRawFilePath raw- return $ Just (Added (basePath </> name) timestamp)- INo.Closed False (Just raw) _ -> do- name <- fromRawFilePath raw- return $ Just (Modified (basePath </> name) timestamp)- INo.MovedOut False raw _ -> do- name <- fromRawFilePath raw- return $ Just (Removed (basePath </> name) timestamp)- INo.MovedIn False raw _ -> do- name <- fromRawFilePath raw- return $ Just (Added (basePath </> name) timestamp)- INo.Deleted False raw -> do- name <- fromRawFilePath raw- return $ Just (Removed (basePath </> name) timestamp)- _ ->- return Nothing+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 _ _ basePath _ inoEvent | trace ("Linux: handleInoEvent " ++ show basePath ++ " " ++ show inoEvent) False = undefined-handleInoEvent actPred chan basePath dbp inoEvent = do currentTime <- getCurrentTime- maybeFsnEvent <- fsnEvent basePath currentTime inoEvent- handleEvent actPred chan dbp maybeFsnEvent--handleEvent :: ActionPredicate -> EventChannel -> DebouncePayload -> Maybe Event -> IO ()--- handleEvent actPred _ _ (Just event) | trace ("Linux: handleEvent " ++ show (actPred event) ++ " " ++ show event) False = undefined-handleEvent actPred chan dbp (Just event) =- when (actPred event) $ case dbp of- (Just (DebounceData epsilon ior)) -> do- lastEvent <- readIORef ior- when (not $ debounce epsilon lastEvent event) writeToChan- atomicModifyIORef ior (\_ -> (event, ()))- Nothing -> writeToChan- where- writeToChan = writeChan chan event--- handleEvent _ _ _ Nothing | trace ("Linux handleEvent Nothing") False = undefined-handleEvent _ _ _ Nothing = return ()+ events <- fsnEvents basePath currentTime inoEvent+ forM_ events $ \event -> when (actPred event) $ callback event varieties :: [INo.EventVariety]-varieties = [INo.Create, INo.Delete, INo.MoveIn, INo.MoveOut, INo.CloseWrite]+varieties = [INo.Create, INo.Delete, INo.MoveIn, INo.MoveOut, INo.Attrib, INo.Modify, 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. --@@ -118,41 +111,70 @@ wdVar <- newMVar (Just []) let- stopListening = do- modifyMVar_ wdVar $ \mbWds -> do- maybe (return ()) (mapM_ INo.removeWatch) 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 _ (INo.Created True rawDirPath) = do- dirPath <- fromRawFilePath rawDirPath- listenRec (baseDir </> dirPath) wdVar- handler baseDir dbp event =- handleInoEvent actPred chan baseDir dbp event+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) - usesPolling = const False+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++ newDir <- fromRawFilePath newRawDir++ -- 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++ _ -> 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
+ src/System/FSNotify/Linux/Util.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}++module System.FSNotify.Linux.Util (+ canonicalizePath+ , canonicalizeRawDirPath+ , (<//>)+ , traverseAllDirs++ , boolToIsDirectory++ , fromRawFilePath+ , toRawFilePath++ , fromHinotifyPath++ , rawToHinotifyPath+ , rawFromHinotifyPath+ ) where++import Control.Exception.Safe as E+import Control.Monad+import qualified Data.ByteString as BS+import Data.Function+import Data.Monoid+import qualified GHC.Foreign as F+import GHC.IO.Encoding (getFileSystemEncoding)+import Prelude hiding (FilePath)+import System.Directory (canonicalizePath)+import System.FSNotify.Types+import System.FilePath (FilePath)+import System.Posix.ByteString (RawFilePath)+import System.Posix.Directory.ByteString (openDirStream, readDirStream, closeDirStream)+import System.Posix.Files (getSymbolicLinkStatus, isDirectory)+++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: should this follow symlinks? (What then about symlinks that escape the parent?)+ fromRawFilePath subPath >>= getSymbolicLinkStatus >>= \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
src/System/FSNotify/Listener.hs view
@@ -1,34 +1,34 @@+{-# 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.Text import Prelude hiding (FilePath)--import Data.IORef (newIORef)-import Data.Time (diffUTCTime, NominalDiffTime)-import Data.Time.Clock.POSIX (posixSecondsToUTCTime)-import System.FilePath import System.FSNotify.Types+import System.FilePath --- | An action that cancels a watching/listening job+-- | 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@@ -39,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)---- | 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
src/System/FSNotify/OSX.hs view
@@ -3,33 +3,34 @@ -- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org -- -module System.FSNotify.OSX- ( FileListener(..)- , NativeManager- ) where+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MultiParamTypeClasses #-} -import Prelude hiding (FilePath)+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)-import Data.Word import Data.Unique-import System.FilePath+import Data.Word+import Prelude hiding (FilePath) import System.Directory import System.FSNotify.Listener import System.FSNotify.Path (canonicalizeDirPath) import System.FSNotify.Types-import qualified Data.Map as Map+import System.FilePath import qualified System.OSX.FSEvents as FSE -data ListenType = NonRecursive | Recursive-data WatchData = WatchData FSE.EventStream ListenType EventChannel +data WatchData = WatchData FSE.EventStream EventCallback+ type WatchMap = Map Unique WatchData data OSXManager = OSXManager (MVar WatchMap) type NativeManager = OSXManager@@ -47,93 +48,93 @@ dirFlag = FSE.eventFlagItemIsDir path = FSE.eventPath event +-- We have to be careful about interpreting the flags in a given event, because+-- "really it's an OR of all the changes made since the FSEventsListener is created"+-- See https://stackoverflow.com/questions/18415285/osx-fseventstreameventflags-not-working-correctly+-- Thus, we try to look at whether the path exists or not to determine whether it was created, modified, etc.++-- Note that there's still some bugs possible due to event coalescing, which the docs say is a possibility:+-- for example, a file could be created and modified within a short time interval, and then we'd only emit one+-- event (the "modified" one, given the logic below)+-- See https://developer.apple.com/library/content/documentation/Darwin/Conceptual/FSEvents_ProgGuide/UsingtheFSEventsFramework/UsingtheFSEventsFramework.html fsnEvents :: UTCTime -> FSE.Event -> IO [Event]-fsnEvents timestamp fseEvent = liftM concat . sequence $ map (\f -> f fseEvent) (eventFunctions timestamp)+fsnEvents timestamp e = do+ -- Note: we *don't* want to use the canonical event path in the existence check, because of the aforementioned crazy event coalescing.+ -- For example, suppose a directory is created and deleted, and then a file is created with the same name. This means the isDirectory flag might+ -- still be turned on, which could lead us to construct a canonical event path with a trailing slash, which would then cause the existence+ -- check to fail and make us think the file was removed.+ -- The upshot of this is that the canonical event paths in the events we emit can't really be trusted, but hey, that's what the extra flag+ -- on the event is for :(+ exists <- doesPathExist $ FSE.eventPath e++ -- Uncomment for an easy way to see flag activity when testing manually+ -- putStrLn $ show ["Event", show e, "isDirectory", show isDirectory, "isFile", show isFile, "isModified", show isModified, "isCreated", show isCreated, "path", path e, "exists", show exists]++ return $ if | exists && isModified -> [Modified (path e) timestamp isDirectory]+ | exists && isModifiedAttributes -> [ModifiedAttributes (path e) timestamp isDirectory]+ | exists && isCreated -> [Added (path e) timestamp isDirectory]+ | (not exists) && hasFlag e FSE.eventFlagItemRemoved -> [Removed (path e) timestamp isDirectory]++ -- Rename stuff+ | exists && isRenamed -> [Added (path e) timestamp isDirectory]+ | (not exists) && isRenamed -> [Removed (path e) timestamp isDirectory]++ | otherwise -> [] where- eventFunctions :: UTCTime -> [FSE.Event -> IO [Event]]- eventFunctions t = [addedFn t, modifFn t, removFn t, renamFn t]- addedFn t e = if hasFlag e FSE.eventFlagItemCreated then return [Added (path e) t] else return []- modifFn t e = if (hasFlag e FSE.eventFlagItemModified- || hasFlag e FSE.eventFlagItemInodeMetaMod) then return [Modified (path e) t] else return []- removFn t e = if hasFlag e FSE.eventFlagItemRemoved then return [Removed (path e) t] else return []- renamFn t e = if hasFlag e FSE.eventFlagItemRenamed then- doesFileExist (path e) >>= \exists -> if exists then return [Added (path e) t] else return [Removed (path e) t]- else- return []+ isDirectory = 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+ isModifiedAttributes = hasFlag e FSE.eventFlagItemInodeMetaMod path = canonicalEventPath hasFlag event flag = FSE.eventFlags event .&. flag /= 0 --- Separate logic is needed for non-recursive events in OSX because the--- hfsevents package doesn't support non-recursive event reporting.--handleNonRecursiveFSEEvent :: ActionPredicate -> EventChannel -> FilePath -> DebouncePayload -> FSE.Event -> IO ()-handleNonRecursiveFSEEvent actPred chan dirPath dbp fseEvent = do- currentTime <- getCurrentTime- events <- fsnEvents currentTime fseEvent- handleNonRecursiveEvents actPred chan dirPath dbp events-handleNonRecursiveEvents :: ActionPredicate -> EventChannel -> FilePath -> DebouncePayload -> [Event] -> IO ()-handleNonRecursiveEvents actPred chan dirPath dbp (event:events)- | takeDirectory dirPath == takeDirectory (eventPath event) && actPred event = do- case dbp of- (Just (DebounceData epsilon ior)) -> do- lastEvent <- readIORef ior- when (not $ debounce epsilon lastEvent event) (writeChan chan event)- atomicModifyIORef ior (\_ -> (event, ()))- Nothing -> writeChan chan event- handleNonRecursiveEvents actPred chan dirPath dbp events- | otherwise = handleNonRecursiveEvents actPred chan dirPath dbp events-handleNonRecursiveEvents _ _ _ _ [] = return ()--handleFSEEvent :: ActionPredicate -> EventChannel -> DebouncePayload -> FSE.Event -> IO ()-handleFSEEvent actPred chan 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 actPred chan dbp events+ forM_ events $ \event ->+ when (actPred event && (isRecursive || (isDirectlyInside dirPath event))) $+ callback event -handleEvents :: ActionPredicate -> EventChannel -> DebouncePayload -> [Event] -> IO ()-handleEvents actPred chan dbp (event:events) = do- when (actPred event) $ case dbp of- (Just (DebounceData epsilon ior)) -> do- lastEvent <- readIORef ior- when (not $ debounce epsilon lastEvent event) (writeChan chan event)- atomicModifyIORef ior (\_ -> (event, ()))- Nothing -> writeChan chan event- handleEvents actPred chan dbp events-handleEvents _ _ _ [] = return ()+-- | 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 = (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 NonRecursive 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 forM_ (Map.elems watchMap) eventStreamDestroy' where eventStreamDestroy' :: WatchData -> IO ()- eventStreamDestroy' (WatchData eventStream _ _) = FSE.eventStreamDestroy eventStream-- listen = listenFn handleNonRecursiveFSEEvent-- listenRecursive = listenFn $ \actPred chan _ -> handleFSEEvent actPred chan+ eventStreamDestroy' (WatchData eventStream _) = FSE.eventStreamDestroy eventStream - usesPolling = const False+ listen = listenFn $ handleFSEEvent False+ listenRecursive = listenFn $ handleFSEEvent True
src/System/FSNotify/Path.hs view
@@ -2,36 +2,40 @@ -- 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 #-} - -module System.FSNotify.Path - ( findFiles - , findDirs - , canonicalizeDirPath - , canonicalizePath - , hasThisExtension - ) where +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} -import Prelude hiding (FilePath) +module System.FSNotify.Path ( + findFiles + , findFilesAndDirs + , canonicalizeDirPath + , canonicalizePath + , hasThisExtension + ) where -import Control.Applicative import Control.Monad --- import Filesystem --- import Filesystem.Path hiding (concat) - import qualified Data.Text as T +import Prelude hiding (FilePath) import qualified System.Directory as D -import System.PosixCompat.Files as PF import System.FilePath +import System.PosixCompat.Files as PF getDirectoryContentsPath :: FilePath -> IO [FilePath] -getDirectoryContentsPath path = (map (path </>)) . filter (not . dots) <$> D.getDirectoryContents path +getDirectoryContentsPath path = + ((map (path </>)) . filter (not . dots) <$> D.getDirectoryContents path) >>= filterM exists where +#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 -fileDirContents :: FilePath -> IO ([FilePath],[FilePath]) +fileDirContents :: FilePath -> IO ([FilePath], [FilePath]) fileDirContents path = do contents <- getDirectoryContentsPath path stats <- mapM getFileStatus contents @@ -46,23 +50,21 @@ 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 + return (files ++ dirs ++ nestedFilesAndDirs) -- | add a trailing slash to ensure the path indicates a directory addTrailingSlash :: FilePath -> FilePath
src/System/FSNotify/Polling.hs view
@@ -1,98 +1,113 @@+{-# 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 -- -module System.FSNotify.Polling- ( createPollManager+module System.FSNotify.Polling (+ createPollManager , PollManager(..) , FileListener(..) ) where -import Prelude hiding (FilePath)--import Control.Applicative import Control.Concurrent+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 Debug.Trace (trace)-import System.FilePath+import Prelude hiding (FilePath)+import System.Directory (doesDirectoryExist) import System.FSNotify.Listener-import System.FSNotify.Path (findFiles, canonicalizeDirPath)+import System.FSNotify.Path (findFilesAndDirs, canonicalizeDirPath) import System.FSNotify.Types+import System.FilePath import System.PosixCompat.Files import System.PosixCompat.Types-import qualified Data.Map as Map-import Control.Monad (forM_) -data EventType =- AddedEvent- | ModifiedEvent- | RemovedEvent -data WatchKey = WatchKey ThreadId deriving (Eq, Ord)-data WatchData = WatchData FilePath EventChannel-type WatchMap = Map WatchKey WatchData-data PollManager = PollManager (MVar WatchMap)+data EventType = AddedEvent+ | ModifiedEvent+ | RemovedEvent -generateEvent :: UTCTime -> EventType -> FilePath -> Maybe Event-generateEvent timestamp AddedEvent filePath = Just (Added filePath timestamp)-generateEvent timestamp ModifiedEvent filePath = Just (Modified filePath timestamp)-generateEvent timestamp RemovedEvent filePath = Just (Removed filePath timestamp)+newtype WatchKey = WatchKey ThreadId deriving (Eq, Ord)+data WatchData = WatchData FilePath EventCallback+type WatchMap = Map WatchKey WatchData+data PollManager = PollManager {+ pollManagerWatchMap :: MVar WatchMap+ , pollManagerInterval :: Int+ } -generateEvents :: UTCTime -> EventType -> [FilePath] -> [Event]-generateEvents timestamp eventType = mapMaybe (generateEvent timestamp eventType)+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) -handleEvent :: EventChannel -> ActionPredicate -> Event -> IO ()-handleEvent chan actPred event- | actPred event = writeChan chan event- | otherwise = return ()+generateEvents :: UTCTime -> EventType -> [(FilePath, EventIsDirectory)] -> [Event]+generateEvents timestamp eventType = mapMaybe (\(path, isDir) -> generateEvent timestamp isDir eventType path) -pathModMap :: Bool -> FilePath -> IO (Map FilePath UTCTime)-pathModMap True path = findFiles True path >>= pathModMap'-pathModMap False path = findFiles False path >>= pathModMap'+-- | 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 :: EventCallback -> ActionPredicate -> Event -> IO ()+handleEvent _ _ (Modified _ _ IsDirectory) = return ()+handleEvent callback actPred event+ | actPred event = callback event+ | otherwise = return () -pathModMap' :: [FilePath] -> IO (Map FilePath UTCTime)-pathModMap' files = fmap Map.fromList $ mapM pathAndTime files+pathModMap :: Bool -> FilePath -> IO (Map FilePath (UTCTime, EventIsDirectory))+pathModMap recursive path = findFilesAndDirs recursive path >>= pathModMap' where- pathAndTime :: FilePath -> IO (FilePath, UTCTime)- pathAndTime path = do- modTime <- getModificationTime path- return (path, modTime)+ pathModMap' :: [FilePath] -> IO (Map FilePath (UTCTime, EventIsDirectory))+ pathModMap' files = (Map.fromList . catMaybes) <$> mapM pathAndInfo files -pollPath :: Int -> Bool -> EventChannel -> FilePath -> ActionPredicate -> Map FilePath UTCTime -> IO ()-pollPath interval recursive chan filePath actPred oldPathMap = do+ 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 -> EventCallback -> FilePath -> ActionPredicate -> Map FilePath (UTCTime, EventIsDirectory) -> IO ()+pollPath interval recursive callback filePath actPred oldPathMap = do threadDelay interval- newPathMap <- pathModMap recursive filePath- currentTime <- getCurrentTime- let deletedMap = Map.difference oldPathMap newPathMap- createdMap = Map.difference newPathMap oldPathMap- modifiedAndCreatedMap = Map.differenceWith modifiedDifference newPathMap oldPathMap- modifiedMap = Map.difference modifiedAndCreatedMap createdMap- generateEvents' = generateEvents currentTime- handleEvents $ generateEvents' AddedEvent $ Map.keys createdMap- handleEvents $ generateEvents' ModifiedEvent $ Map.keys modifiedMap- handleEvents $ generateEvents' RemovedEvent $ Map.keys deletedMap- pollPath' newPathMap+ maybeNewPathMap <- handle (\(_ :: IOException) -> return Nothing) (Just <$> pathModMap recursive filePath)+ case maybeNewPathMap of+ -- Something went wrong while listing directories; we'll try again on the next poll+ Nothing -> pollPath interval recursive callback filePath actPred oldPathMap++ Just newPathMap -> do+ currentTime <- getCurrentTime+ let deletedMap = Map.difference oldPathMap newPathMap+ createdMap = Map.difference newPathMap oldPathMap+ modifiedAndCreatedMap = Map.differenceWith modifiedDifference newPathMap oldPathMap+ modifiedMap = Map.difference modifiedAndCreatedMap createdMap+ generateEvents' = generateEvents currentTime++ handleEvents $ generateEvents' AddedEvent [(path, isDir) | (path, (_, isDir)) <- Map.toList createdMap]+ handleEvents $ generateEvents' ModifiedEvent [(path, isDir) | (path, (_, isDir)) <- Map.toList modifiedMap]+ handleEvents $ generateEvents' RemovedEvent [(path, isDir) | (path, (_, isDir)) <- Map.toList deletedMap]++ pollPath interval recursive callback filePath actPred newPathMap+ where- modifiedDifference :: UTCTime -> UTCTime -> Maybe UTCTime- modifiedDifference newTime oldTime- | oldTime /= newTime = Just newTime- | otherwise = Nothing+ 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)-- pollPath' :: Map FilePath UTCTime -> IO ()- pollPath' = pollPath interval recursive chan filePath actPred+ handleEvents = mapM_ (handleEvent callback actPred) --- Additional init funciton exported to allow startManager to unconditionally+-- Additional init function exported to allow startManager to unconditionally -- create a poll manager as a fallback when other managers will not instantiate.-createPollManager :: IO PollManager-createPollManager = fmap PollManager $ newMVar Map.empty+createPollManager :: Int -> IO PollManager+createPollManager interval = PollManager <$> newMVar Map.empty <*> pure interval killWatchingThread :: WatchKey -> IO () killWatchingThread (WatchKey threadId) = killThread threadId@@ -104,35 +119,29 @@ return $ Map.delete wk m return () -instance FileListener PollManager where- initSession = fmap Just createPollManager+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 interval isRecursive callback path' actPred pmMap+ let wk = WatchKey threadId+ modifyMVar_ mvarMap $ return . Map.insert wk (WatchData path' callback)+ return $ killAndUnregister mvarMap wk - killSession (PollManager mvarMap) = do- watchMap <- readMVar mvarMap- forM_ (Map.keys watchMap) killWatchingThread - listen conf (PollManager mvarMap) path actPred chan = do- path' <- canonicalizeDirPath path- pmMap <- pathModMap False path'- threadId <- forkIO $ pollPath (confPollInterval conf) False chan path' actPred pmMap- let wk = WatchKey threadId- modifyMVar_ mvarMap $ return . Map.insert wk (WatchData path' chan)- return $ killAndUnregister mvarMap wk+instance FileListener PollManager Int where+ initSession interval = Right <$> createPollManager interval - listenRecursive conf (PollManager mvarMap) path actPred chan = do- path' <- canonicalizeDirPath path- pmMap <- pathModMap True path'- threadId <- forkIO $ pollPath (confPollInterval conf) True chan path' actPred pmMap- let wk = WatchKey threadId- modifyMVar_ mvarMap $ return . Map.insert wk (WatchData path' chan)- return $ killAndUnregister mvarMap wk+ killSession (PollManager mvarMap _) = do+ watchMap <- readMVar mvarMap+ forM_ (Map.keys watchMap) killWatchingThread - usesPolling = const True+ listen = listen' False + listenRecursive = listen' True getModificationTime :: FilePath -> IO UTCTime getModificationTime p = fromEpoch . modificationTime <$> getFileStatus p- fromEpoch :: EpochTime -> UTCTime fromEpoch = posixSecondsToUTCTime . realToFrac
src/System/FSNotify/Types.hs view
@@ -2,103 +2,100 @@ -- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org -- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org ----module System.FSNotify.Types- ( act- , ActionPredicate- , Action- , WatchConfig(..)- , Debounce(..)- , DebounceData(..)- , DebouncePayload- , Event(..)- , EventChannel- , eventPath- , eventTime- , IOEvent- ) where+{-# LANGUAGE CPP #-} -import Prelude hiding (FilePath)+module System.FSNotify.Types (+ act+ , ActionPredicate+ , Action+ , DebounceFn+ , WatchConfig(..)+ , WatchMode(..)+ , ThreadingMode(..)+ , Event(..)+ , EventIsDirectory(..)+ , EventCallback+ , EventChannel+ , 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- | Modified FilePath UTCTime- | Removed FilePath UTCTime+ 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 }+ -- | Note: Linux-only+ | WatchedDirectoryRemoved { eventPath :: FilePath, eventTime :: UTCTime, eventIsDirectory :: EventIsDirectory }+ -- | Note: Linux-only+ | CloseWrite { eventPath :: FilePath, eventTime :: UTCTime, eventIsDirectory :: EventIsDirectory }+ -- | Note: Linux-only+ | Unknown { eventPath :: FilePath, eventTime :: UTCTime, eventIsDirectory :: EventIsDirectory, eventString :: String } deriving (Eq, Show) --- | Helper for extracting the path associated with an event.-eventPath :: Event -> FilePath-eventPath (Added path _) = path-eventPath (Modified path _) = path-eventPath (Removed path _) = path+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+type EventCallback = Event -> IO () -type EventChannel = Chan Event+type EventAndActionChannel = Chan (Event, Action) --- | 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.+-- | Method of watching for changes.+data WatchMode =+ WatchModePoll {+ watchModePollInterval :: Int+ -- ^ Polling interval in microseconds. }---- | 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+ -- ^ Detect changes by polling the filesystem. Less efficient and may miss fast changes. Not recommended+ -- unless you're experiencing problems with 'WatchModeOS' (or 'WatchModeOS' is not supported on your platform).+#ifdef HAVE_NATIVE_WATCHER+ | WatchModeOS+ -- ^ Use OS-specific mechanisms to be notified of changes (inotify on Linux, FSEvents on OSX, etc.).+ -- Not currently available on e.g. *BSD and Wasm/WASI.+#endif -type IOEvent = IORef 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. --- | 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+-- | Watch configuration.+data WatchConfig = WatchConfig+ { confWatchMode :: WatchMode+ -- ^ Watch mode to use.+ , confThreadingMode :: ThreadingMode+ -- ^ Threading mode to use.+ , confOnHandlerException :: SomeException -> IO ()+ -- ^ Called when a handler throws an exception.+ } --- | 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+type IOEvent = IORef Event -- | 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
src/System/FSNotify/Win32.hs view
@@ -2,87 +2,71 @@ -- 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- ( FileListener(..)- , NativeManager- ) where--import Prelude+module System.FSNotify.Win32 (+ FileListener(..)+ , NativeManager+ ) where -import Control.Concurrent.Chan+import Control.Concurrent import Control.Monad (when)-import Data.IORef (atomicModifyIORef, readIORef)+import Data.Bits+import qualified Data.Map as Map import Data.Time (getCurrentTime, UTCTime)+import Prelude import System.FSNotify.Listener import System.FSNotify.Path (canonicalizeDirPath) import System.FSNotify.Types import System.FilePath 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.+type NativeManager = WNo.WatchManager -- Win32-notify has (temporarily?) dropped support for Renamed events.-fsnEvent :: BaseDir -> UTCTime -> WNo.Event -> Maybe Event-fsnEvent basedir timestamp ev =- case ev of- WNo.Created False name -> Just $ Added (basedir </> name) timestamp- WNo.Modified False name -> Just $ Modified (basedir </> name) timestamp- WNo.Deleted False name -> Just $ Removed (basedir </> name) timestamp- _ -> Nothing-{--fsnEvents timestamp (WNo.Renamed False (Just oldName) newName) = [Removed (fp oldName) timestamp, Added (fp newName) timestamp]-fsnEvents timestamp (WNo.Renamed False Nothing newName) = [Added (fp newName) timestamp]--}+fsnEvent :: EventIsDirectory -> FilePath -> UTCTime -> WNo.Event -> Event+fsnEvent isDirectory basedir timestamp (WNo.Created name) = Added (normalise (basedir </> name)) timestamp isDirectory+fsnEvent isDirectory basedir timestamp (WNo.Modified name) = Modified (normalise (basedir </> name)) timestamp isDirectory+fsnEvent isDirectory basedir timestamp (WNo.Deleted name) = Removed (normalise (basedir </> name)) timestamp isDirectory -handleWNoEvent :: BaseDir -> ActionPredicate -> EventChannel -> DebouncePayload -> WNo.Event -> IO ()-handleWNoEvent basedir actPred chan dbp inoEvent = do+handleWNoEvent :: EventIsDirectory -> FilePath -> ActionPredicate -> EventCallback -> WNo.Event -> IO ()+handleWNoEvent isDirectory basedir actPred callback inoEvent = do currentTime <- getCurrentTime- let maybeEvent = fsnEvent basedir currentTime inoEvent- case maybeEvent of- Just evt -> handleEvent actPred chan dbp evt- Nothing -> return ()-handleEvent :: ActionPredicate -> EventChannel -> DebouncePayload -> Event -> IO ()-handleEvent actPred chan dbp event =- when (actPred event) $ case dbp of- (Just (DebounceData epsilon ior)) -> do- lastEvent <- readIORef ior- when (not $ debounce epsilon lastEvent event) writeToChan- atomicModifyIORef ior (\_ -> (event, ()))- Nothing -> writeToChan- where- writeToChan = writeChan chan event+ let event = fsnEvent isDirectory basedir currentTime inoEvent+ when (actPred event) $ callback event -instance FileListener WNo.WatchManager where+watchDirectory :: Bool -> WatchConfig -> WNo.WatchManager -> FilePath -> ActionPredicate -> EventCallback -> IO (IO ())+watchDirectory isRecursive _conf watchManager@(WNo.WatchManager mvarMap) path actPred callback = do+ path' <- canonicalizeDirPath path++ 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 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.+ return $ do+ WNo.killWatch wid1+ modifyMVar_ mvarMap $ \watchMap -> return (Map.delete wid1 watchMap)++ WNo.killWatch wid2+ modifyMVar_ mvarMap $ \watchMap -> return (Map.delete wid2 watchMap)++instance FileListener WNo.WatchManager () where -- TODO: This should actually lookup a Windows API version and possibly return -- Nothing the calls we need are not available. This will require that API -- version information be exposed by Win32-notify.- initSession = fmap Just WNo.initWatchManager+ initSession _ = Right <$> WNo.initWatchManager killSession = WNo.killWatchManager - listen conf watchManager path actPred chan = do- path' <- canonicalizeDirPath path- dbp <- newDebouncePayload $ confDebounce conf- wid <- WNo.watchDirectory watchManager path' False varieties (handleWNoEvent path' actPred chan dbp)- return $ WNo.killWatch wid-- listenRecursive conf watchManager path actPred chan = do- path' <- canonicalizeDirPath path- dbp <- newDebouncePayload $ confDebounce conf- wid <- WNo.watchDirectory watchManager path' True varieties (handleWNoEvent path' actPred chan dbp)- return $ WNo.killWatch wid-- usesPolling = const False--varieties :: [WNo.EventVariety]-varieties = [WNo.Create, WNo.Delete, WNo.Move, WNo.Modify]+ listen = watchDirectory False+ listenRecursive = watchDirectory True
− test/EventUtils.hs
@@ -1,102 +0,0 @@-{-# LANGUAGE OverloadedStrings, ImplicitParams #-}-module EventUtils where--import Prelude hiding (FilePath)-import Test.Tasty.HUnit-import Control.Concurrent-import Control.Concurrent.Async hiding (poll)-import Control.Applicative-import Control.Monad-import Data.IORef-import Data.List (sortBy)-import Data.Ord (comparing)-import System.FilePath-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 :: 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
+ test/FSNotify/Test/EventTests.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+{-# HLINT ignore "Redundant multi-way if" #-}++module FSNotify.Test.EventTests where++import Control.Exception.Safe (MonadThrow)+import Control.Monad+import Control.Monad.IO.Class+import qualified Data.List as L+import Data.Monoid+import Data.Ord (comparing)+import FSNotify.Test.Util+import Prelude hiding (FilePath)+import System.FSNotify+import System.FilePath+import System.IO (hPutStr)+import Test.Sandwich+import UnliftIO hiding (poll)+import UnliftIO.Directory+++eventTests :: (+ MonadUnliftIO m, MonadThrow m+ ) => TestFolderGenerator -> ThreadingMode -> SpecFree context m ()+eventTests testFolderGenerator threadingMode = describe "Tests" $ parallelWithoutDirectory $ do+ let pollOptions = if haveNativeWatcher then [False, True] else [True]++ forM_ pollOptions $ \poll -> describe (if poll then "Polling" else "Native") $ parallelWithoutDirectory $ do+ forM_ [False, True] $ \recursive -> describe (if recursive then "Recursive" else "Non-recursive") $ parallelWithoutDirectory $+ forM_ [False, True] $ \nested -> describe (if nested then "Nested" else "Non-nested") $ parallelWithoutDirectory $+ eventTests' testFolderGenerator threadingMode poll recursive nested++eventTests' :: (+ MonadUnliftIO m, MonadThrow m+ ) => TestFolderGenerator -> ThreadingMode -> Bool -> Bool -> Bool -> SpecFree context m ()+eventTests' testFolderGenerator threadingMode poll recursive nested = do+ let withFolder' = withTestFolder testFolderGenerator threadingMode poll recursive nested+ let withFolder action = withFolder' (const $ return ()) (\() ctx -> action ctx)+ let waitForEvents getEvents action = waitUntil 5.0 (liftIO getEvents >>= action)++ unless (nested || poll || isMac || isWin) $ it "deletes the watched directory" $ withFolder $ \(TestFolderContext watchedDir _f getEvents _clearEvents) -> do+ removeDirectory watchedDir++ waitForEvents getEvents $ \case+ [WatchedDirectoryRemoved {..}] | eventPath `equalFilePath` watchedDir && eventIsDirectory == IsDirectory -> return ()+ events -> expectationFailure $ "Got wrong events: " <> show events++ it "works with a new file" $ withFolder $ \(TestFolderContext _watchedDir f getEvents _clearEvents) -> do+ let wrapper action = if | isWin -> liftIO (writeFile f "foo") >> action+ | otherwise -> withFile f AppendMode $ \_ -> action++ wrapper $+ waitForEvents getEvents $ \events ->+ if | nested && not recursive -> events `shouldBe` []+ | isWin && not poll -> case events of+ -- On Windows, we sometimes get an extra modified event+ (sortEvents -> [Added {..}, Modified {}]) | eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()+ _ -> expectationFailure $ "Got wrong events: " <> show events+ | otherwise -> case events of+ [Added {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()+ _ -> expectationFailure $ "Got wrong events: " <> show events++ it "works with a new directory" $ withFolder $ \(TestFolderContext _watchedDir f getEvents _clearEvents) -> do+ createDirectory f++ waitForEvents 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" $ withFolder' (\f -> liftIO $ writeFile f "") $ \() (TestFolderContext _watchedDir f getEvents _clearEvents) -> do+ removeFile f++ waitForEvents 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++ unless isWin $ do+ it "works if there is bad symlink" $ withFolder' (\f -> liftIO $ createSymLink (f <> ".doesNotExist") f) $ \() (TestFolderContext _watchedDir f getEvents _clearEvents) -> do+ waitForEvents getEvents $ \events -> events `shouldBe` []++ it "works with a deleted directory" $ withFolder' (\f -> liftIO $ createDirectory f) $ \() (TestFolderContext _watchedDir f getEvents _clearEvents) -> do+ removeDirectory f++ waitForEvents 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" $ withFolder' (\f -> liftIO $ writeFile f "") $ \() (TestFolderContext _watchedDir f getEvents _clearEvents) -> do+ liftIO $ changeFileAttributes f++ -- This test is disabled when polling because the PollManager only keeps track of+ -- modification time, so it won't catch an unrelated file attribute change+ waitForEvents getEvents $ \events ->+ if | poll -> return ()+ | nested && not recursive -> events `shouldBe` []+ | isWin -> case events of+ [Modified {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()+ _ -> expectationFailure $ "Got wrong events: " <> show events+ | otherwise -> case events of+ [ModifiedAttributes {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()+ _ -> expectationFailure $ "Got wrong events: " <> show events++ it "works with a modified file" $ withFolder' (\f -> liftIO $ writeFile f "") $ \() (TestFolderContext _watchedDir f getEvents _clearEvents) -> do+ (if isWin then withSingleWriteFile f "foo" else withOpenWritableAndWrite f "foo") $+ waitForEvents getEvents $ \events ->+ if | nested && not recursive -> events `shouldBe` []+ | isMac || isFreeBSD -> case events of+ [Modified {..}] | poll && eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()+ [ModifiedAttributes {..}] | not poll && eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()+ _ -> expectationFailure $ "Got wrong events: " <> show events <> " (wanted file path " <> show f <> ")"+ | otherwise -> case events of+ [Modified {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()+ _ -> expectationFailure $ "Got wrong events: " <> show events <> " (wanted file path " <> show f <> ")"++ when (isLinux || isFreeBSD) $ unless poll $ do+ let setup f = liftIO $ do+ h <- openFile f WriteMode+ hPutStr h "asdf" >> hFlush h+ return h+ it "gets a close_write" $ withFolder' setup $ \h (TestFolderContext _watchedDir f getEvents _clearEvents) -> do+ liftIO $ hClose h+ waitForEvents getEvents $ \events ->+ if | nested && not recursive -> events `shouldBe` []+ | otherwise -> case events of+ [CloseWrite {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()+ _ -> expectationFailure $ "Got wrong events: " <> show events++withSingleWriteFile :: MonadIO m => FilePath -> String -> m b -> m b+withSingleWriteFile fp contents action = do+ liftIO $ writeFile fp contents+ action++withOpenWritableAndWrite :: MonadUnliftIO m => FilePath -> String -> m b -> m b+withOpenWritableAndWrite fp contents action = do+ withFile fp WriteMode $ \h ->+ flip finally (hClose h) $ do+ liftIO $ hPutStr h contents+ action++sortEvents :: [Event] -> [Event]+sortEvents = L.sortBy (comparing eventToNum)+ where+ eventToNum :: Event -> Int+ eventToNum (Added {}) = 1+ eventToNum (Modified {}) = 2+ eventToNum (ModifiedAttributes {}) = 3+ eventToNum (Removed {}) = 4+ eventToNum (WatchedDirectoryRemoved {}) = 5+ eventToNum (CloseWrite {}) = 6+ eventToNum (Unknown {}) = 7
+ test/FSNotify/Test/Util.hs view
@@ -0,0 +1,207 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns #-}++module FSNotify.Test.Util where++import Control.Exception.Safe (Handler(..))+import Control.Monad.Logger+import Control.Retry+import Data.String.Interpolate+import System.FSNotify+import System.FilePath+import Test.Sandwich+import UnliftIO hiding (poll, Handler)+import UnliftIO.Concurrent+import UnliftIO.Directory++#if !MIN_VERSION_base(4,11,0)+import Data.Monoid+#endif++#ifdef mingw32_HOST_OS+import Data.Bits+import System.Win32.File (getFileAttributes, setFileAttributes, fILE_ATTRIBUTE_TEMPORARY)+import System.Win32.SymbolicLink (createSymbolicLinkFile)++-- 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)++createSymLink :: FilePath -> FilePath -> IO ()+#if __GLASGOW_HASKELL__ < 900+createSymLink file1 file2 = createSymbolicLinkFile file1 file2+#else+createSymLink file1 file2 = createSymbolicLinkFile file1 file2 True+#endif++#else+import System.PosixCompat.Files (touchFile, createSymbolicLink)++changeFileAttributes :: FilePath -> IO ()+changeFileAttributes = touchFile++createSymLink :: FilePath -> FilePath -> IO ()+createSymLink = createSymbolicLink+#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++isLinux :: Bool+#ifdef linux_HOST_OS+isLinux = True+#else+isLinux = False+#endif++isFreeBSD :: Bool+#ifdef freebsd_HOST_OS+isFreeBSD = True+#else+isFreeBSD = False+#endif++haveNativeWatcher :: Bool+#ifdef HAVE_NATIVE_WATCHER+haveNativeWatcher = True+#else+haveNativeWatcher = False+#endif++waitUntil :: MonadUnliftIO m => Double -> m a -> m a+#if MIN_VERSION_retry(0, 7, 0)+waitUntil timeInSeconds action = withRunInIO $ \runInIO ->+ recovering policy [\_ -> Handler handleFn] (\_ -> runInIO action)+#else+waitUntil timeInSeconds action = withRunInIO $ \runInIO ->+ recovering policy [\_ -> Handler handleFn] (runInIO action)+#endif+ where+ handleFn :: SomeException -> IO Bool+ handleFn (fromException -> Just (_ :: FailureReason)) = return True+ handleFn _ = return False++ policy = limitRetriesByCumulativeDelay (round (timeInSeconds * 1000000.0)) $ capDelay 1000000 $ exponentialBackoff 1000+++data TestFolderContext = TestFolderContext {+ watchedDir :: FilePath+ , filePath :: FilePath+ , getEvents :: IO [Event]+ , clearEvents :: IO ()+ }++data TestFolderGenerator = TestFolderGenerator {+ testFolderGeneratorRootDir :: FilePath+ , testFolderGeneratorId :: MVar Int+ }++newTestFolderGenerator :: MonadUnliftIO m => FilePath -> m TestFolderGenerator+newTestFolderGenerator dir = TestFolderGenerator dir <$> newMVar 0++withTestFolderGenerator :: MonadUnliftIO m => (TestFolderGenerator -> m a) -> m a+withTestFolderGenerator action = do+ withSystemTempDirectory "hfsnotify-tests" $ \dir ->+ newTestFolderGenerator dir >>= action++withRandomTempDirectory :: MonadUnliftIO m => TestFolderGenerator -> (FilePath -> m a) -> m a+withRandomTempDirectory (TestFolderGenerator {..}) action = do+ testId <- modifyMVar testFolderGeneratorId $ \x ->+ return (x + 1, x)+ let dir = testFolderGeneratorRootDir </> ("test_" <> show testId)+ bracket_ (createDirectory dir)+ (removePathForcibly dir)+ (action dir)++withTestFolder :: (+ MonadUnliftIO m, MonadLogger m+ )+ => TestFolderGenerator+ -> ThreadingMode+ -> Bool+ -> Bool+ -> Bool+ -> (FilePath -> m b)+ -> (b -> TestFolderContext -> m a)+ -> m a+withTestFolder testFolderGenerator threadingMode poll recursive nested setup action = do+ withRandomTempDirectory testFolderGenerator $ \watchedDir' -> do+ info [i|Got temp directory: #{watchedDir'}|]+ let fileName = "testfile"+ let baseDir = if nested then watchedDir' </> "subdir" else watchedDir'+ let watchFn = if recursive then watchTree else watchDir++ createDirectoryIfMissing True baseDir++ let p = normalise $ baseDir </> fileName++ setupResult <- setup p++ let pollInterval = 2 * 10^(5 :: Int)++ -- Delay before starting the watcher to make sure setup events picked up.+ --+ -- For MacOS, we can apparently get an event for the creation of "subdir" when doing nested tests,+ -- even though we create the watcher after this.+ --+ -- On Windows, we occasionally see a test flake when there's no pause here.+ --+ -- So, let's put a healthy sleep between the setup actions and the watcher initialization.+ --+ -- When polling, we want to ensure we wait at least as long as the effective filesystem modification+ -- time granularity (which on Linux can be on the order of 10 milliseconds), *or*+ -- the poll interval, whichever is greater.+ threadDelay (max 5_000_000 (3 * pollInterval))++ let conf = defaultConfig {+#ifndef HAVE_NATIVE_WATCHER+ confWatchMode = if poll then WatchModePoll pollInterval else error "No native watcher available."+#else+ confWatchMode = if poll then WatchModePoll pollInterval else WatchModeOS+#endif+ , confThreadingMode = threadingMode+ }++ withRunInIO $ \runInIO ->+ withManagerConf conf $ \mgr -> do+ eventsVar <- newIORef []+ bracket+ (watchFn mgr watchedDir' (const True) (\ev -> atomicModifyIORef eventsVar (\evs -> (ev:evs, ()))))+ (\stop -> stop)+ (\_ -> runInIO $ action setupResult $ TestFolderContext {+ watchedDir = watchedDir'+ , filePath = p+ , getEvents = readIORef eventsVar+ , clearEvents = atomicWriteIORef eventsVar []+ }+ )++parallelWithoutDirectory :: SpecFree context m () -> SpecFree context m ()+parallelWithoutDirectory = parallel' (defaultNodeOptions {+ nodeOptionsCreateFolder = False+ , nodeOptionsVisibilityThreshold = 70+ })
+ test/Main.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++module Main where++import Control.Monad+import Control.Monad.IO.Class+import Data.String.Interpolate+import FSNotify.Test.EventTests+import FSNotify.Test.Util+import Prelude hiding (FilePath)+import System.FSNotify+import System.FilePath+import Test.Sandwich+import UnliftIO.IORef+++main :: IO ()+main =+ withTestFolderGenerator $ \testFolderGenerator ->+ runSandwichWithCommandLineArgs defaultOptions $ parallelN 20 $ do+ describe "Configuration" $ do+ it "respects the confOnHandlerException option" $ do+ withRandomTempDirectory testFolderGenerator $ \watchedDir' -> do+ info [i|Got temp dir: #{watchedDir'}|]+ exceptions <- newIORef (0 :: Int)+ let conf = defaultConfig { confOnHandlerException = \_ -> modifyIORef exceptions (+ 1) }++ liftIO $ withManagerConf conf $ \mgr -> do+ stop <- watchDir mgr watchedDir' (const True) $ \ev -> do+ case ev of+#ifdef darwin_HOST_OS+ Modified {} -> expectationFailure "Oh no!"+#else+ Added {} -> expectationFailure "Oh no!"+#endif+ _ -> return ()++ writeFile (watchedDir' </> "testfile") "foo"++ waitUntil 5.0 $+ readIORef exceptions >>= (`shouldBe` 1)++ stop++ describe "SingleThread" $ eventTests testFolderGenerator SingleThread+ describe "ThreadPerWatch" $ eventTests testFolderGenerator ThreadPerWatch+ describe "ThreadPerEvent" $ eventTests testFolderGenerator ThreadPerEvent
− test/test.hs
@@ -1,88 +0,0 @@-{-# LANGUAGE OverloadedStrings, ImplicitParams #-}-import Prelude hiding- ( FilePath )-import Control.Applicative-import Test.Tasty-import Test.Tasty.HUnit-import System.Directory-import System.FilePath-import System.FSNotify-import System.IO.Error-import System.IO.Temp-import System.PosixCompat.Files-import Control.Monad-import Control.Exception-import Control.Concurrent--import EventUtils--nativeMgrSupported :: IO Bool-nativeMgrSupported = do- mgr <- startManager- stopManager mgr- return $ not $ isPollingManager mgr--main :: IO ()-main = do- hasNative <- nativeMgrSupported- unless hasNative $- putStrLn "WARNING: native manager cannot be used or tested on this platform"- defaultMain $- withResource- (createDirectoryIfMissing True testDirPath)- (const $ removeDirectoryRecursive testDirPath) $- const $ tests hasNative--tests :: Bool -> TestTree-tests hasNative = testGroup "Tests" $ do- poll <-- if hasNative- then [False, True]- else [True]- let ?timeInterval =- if poll- then 2*10^(6 :: Int)- else 5*10^(5 :: Int)- return $ testGroup (if poll then "Polling" else "Native") $ do- recursive <- [False, True]- return $ testGroup (if recursive then "Recursive" else "Non-recursive") $ do- nested <- [False, True]- return $ testGroup (if nested then "In a subdirectory" else "Right here") $ do- t <-- [ mkTest "new file"- (if poll then [evAdded] else [evAdded, evModified])- (const $ return ())- (\f -> writeFile f "foo")- , mkTest "modify file" [evModified] (\f -> writeFile f "")- (\f -> when poll (threadDelay $ 10^(6 :: Int)) >> writeFile f "foo")- , mkTest "delete file" [evRemoved] (\f -> writeFile f "") (\f -> removeFile f)- , mkTest "directories are ignored" [] (const $ return ())- (\f -> createDirectory f >> removeDirectory f)- ]- return $ t nested recursive poll- where- mkTest title evs prepare action nested recursive poll =- testCase title $- withTempDirectory testDirPath "test." $ \watchedDir -> do- let baseDir = if nested then watchedDir </> "subdir" else watchedDir- f = baseDir </> fileName- expect =- expectEvents poll- (if recursive then watchTree else watchDir)- watchedDir- createDirectoryIfMissing True baseDir- (prepare f >>- expect (if not nested || recursive then map ($ f) evs else []) (action f))- `finally` (isFile f >>= \b -> when b (removeFile f))-- fileName = "testfile"-----------------------------------------------------------------------------------isFile :: FilePath -> IO Bool-isFile p = handleJust h return checkFile- where- h e = if isDoesNotExistError e- then Just False- else Nothing- checkFile = isRegularFile <$> getFileStatus p
+ win-src/System/Win32/FileNotify.hsc view
@@ -0,0 +1,196 @@+{-# LANGUAGE ForeignFunctionInterface #-} +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE InterruptibleFFI #-} +#endif + +{-# LANGUAGE LambdaCase #-} + +module System.Win32.FileNotify ( + Handle + , Action(..) + , getWatchHandle + , readDirectoryChanges + ) where + +import Data.Char (isSpace) +import Foreign ((.|.), Ptr, FunPtr, alloca, allocaBytes, castPtr, nullFunPtr, peekByteOff, plusPtr) +import Foreign.C (peekCWStringLen) +import Numeric (showHex) +import System.Win32.File ( + FileNotificationFlag + , LPOVERLAPPED + , createFile + , oPEN_EXISTING + , fILE_FLAG_BACKUP_SEMANTICS + , fILE_LIST_DIRECTORY + , fILE_SHARE_READ + , fILE_SHARE_WRITE + ) +import System.Win32.Types ( + BOOL + , DWORD + , ErrCode + , HANDLE + , LPDWORD + , LPVOID + , getErrorMessage + , getLastError + , localFree + , nullPtr + ) +import System.Win32.Types (peekTString) + + +#include <windows.h> + +type Handle = HANDLE + +getWatchHandle :: FilePath -> IO Handle +getWatchHandle dir = createFile dir + fILE_LIST_DIRECTORY -- Access mode + (fILE_SHARE_READ .|. fILE_SHARE_WRITE) -- Share mode + Nothing -- security attributes + oPEN_EXISTING -- Create mode, we want to look at an existing directory + fILE_FLAG_BACKUP_SEMANTICS -- File attribute, nb NOT using OVERLAPPED since we work synchronously + Nothing -- No template file + + +readDirectoryChanges :: Handle -> Bool -> FileNotificationFlag -> IO (Either (ErrCode, String) [(Action, String)]) +readDirectoryChanges h watchSubTree mask = do + let maxBuf = 16384 + allocaBytes maxBuf $ \buffer -> do + alloca $ \bret -> do + readDirectoryChangesW h buffer (toEnum maxBuf) watchSubTree mask bret >>= \case + Left err -> return $ Left err + Right () -> Right <$> readChanges buffer + +data Action = FileAdded | FileRemoved | FileModified | FileRenamedOld | FileRenamedNew + deriving (Show, Read, Eq, Ord, Enum) + +readChanges :: Ptr FILE_NOTIFY_INFORMATION -> IO [(Action, String)] +readChanges pfni = do + fni <- peekFNI pfni + let entry = (faToAction $ fniAction fni, fniFileName fni) + nioff = fromEnum $ fniNextEntryOffset fni + entries <- if nioff == 0 then return [] else readChanges $ pfni `plusPtr` nioff + return $ entry:entries + +faToAction :: FileAction -> Action +faToAction fa = toEnum $ fromEnum fa - 1 + +------------------------------------------------------------------- +-- Low-level stuff that binds to notifications in the Win32 API + +-- Defined in System.Win32.File, but with too few cases: +-- type AccessMode = UINT + +#if !(MIN_VERSION_Win32(2,4,0)) +#{enum AccessMode, + , fILE_LIST_DIRECTORY = FILE_LIST_DIRECTORY + } +-- there are many more cases but I only need this one. +#endif + +type FileAction = DWORD + +#{enum FileAction, + , _fILE_ACTION_ADDED = FILE_ACTION_ADDED + , _fILE_ACTION_REMOVED = FILE_ACTION_REMOVED + , _fILE_ACTION_MODIFIED = FILE_ACTION_MODIFIED + , _fILE_ACTION_RENAMED_OLD_NAME = FILE_ACTION_RENAMED_OLD_NAME + , _fILE_ACTION_RENAMED_NEW_NAME = FILE_ACTION_RENAMED_NEW_NAME + } + +-- type WCHAR = Word16 + +-- This is a bit overkill for now, I'll only use nullFunPtr anyway, +-- but who knows, maybe someday I'll want asynchronous callbacks on the OS level. +type LPOVERLAPPED_COMPLETION_ROUTINE = FunPtr ((DWORD, DWORD, LPOVERLAPPED) -> IO ()) + +data FILE_NOTIFY_INFORMATION = FILE_NOTIFY_INFORMATION + { fniNextEntryOffset, fniAction :: DWORD + , fniFileName :: String + } + +-- instance Storable FILE_NOTIFY_INFORMATION where +-- ... well, we can't write an instance since the struct is not of fix size, +-- so we'll have to do it the hard way, and not get anything for free. Sigh. + +-- sizeOfFNI :: FILE_NOTIFY_INFORMATION -> Int +-- sizeOfFNI fni = (#size FILE_NOTIFY_INFORMATION) + (#size WCHAR) * (length (fniFileName fni) - 1) + +peekFNI :: Ptr FILE_NOTIFY_INFORMATION -> IO FILE_NOTIFY_INFORMATION +peekFNI buf = do + neof <- (#peek FILE_NOTIFY_INFORMATION, NextEntryOffset) buf + acti <- (#peek FILE_NOTIFY_INFORMATION, Action) buf + fnle <- (#peek FILE_NOTIFY_INFORMATION, FileNameLength) buf + fnam <- peekCWStringLen + (buf `plusPtr` (#offset FILE_NOTIFY_INFORMATION, FileName), -- start of array + fromEnum (fnle :: DWORD) `div` 2 ) -- fnle is the length in *bytes*, and a WCHAR is 2 bytes + return $ FILE_NOTIFY_INFORMATION neof acti fnam + + +readDirectoryChangesW :: Handle -> Ptr FILE_NOTIFY_INFORMATION -> DWORD -> BOOL -> FileNotificationFlag -> LPDWORD -> IO (Either (ErrCode, String) ()) +readDirectoryChangesW h buf bufSize watchSubTree f br = + c_ReadDirectoryChangesW h (castPtr buf) bufSize watchSubTree f br nullPtr nullFunPtr >>= \case + True -> return $ Right () + False -> do + -- Extract the failure message, as done in https://hackage.haskell.org/package/Win32-2.14.0.0/docs/src/System.Win32.WindowsString.Types.html#errorWin + err_code <- getLastError + msg <- getErrorMessage err_code >>= \case + x | x == nullPtr -> return $ "Error 0x" ++ Numeric.showHex err_code "" + c_msg -> do + msg <- peekTString c_msg + -- We ignore failure of freeing c_msg, given we're already failing + _ <- localFree c_msg + return msg + let msg' = reverse $ dropWhile isSpace $ reverse msg -- drop trailing \n + return $ Left (err_code, msg') + +{- +asynchReadDirectoryChangesW :: Handle -> Ptr FILE_NOTIFY_INFORMATION -> DWORD -> BOOL -> FileNotificationFlag + -> LPOVERLAPPED -> IO () +asynchReadDirectoryChangesW h buf bufSize watchSubTree f over = + failIfFalse_ "ReadDirectoryChangesW" $ c_ReadDirectoryChangesW h (castPtr buf) bufSize watchSubTree f nullPtr over nullFunPtr + +cbReadDirectoryChangesW :: Handle -> Ptr FILE_NOTIFY_INFORMATION -> DWORD -> BOOL -> FileNotificationFlag + -> LPOVERLAPPED -> IO BOOL +cbReadDirectoryChanges +-} + +-- The interruptible qualifier will keep threads listening for events from hanging blocking when killed +#if __GLASGOW_HASKELL__ >= 701 +foreign import stdcall interruptible "windows.h ReadDirectoryChangesW" +#else +foreign import stdcall safe "windows.h ReadDirectoryChangesW" +#endif + c_ReadDirectoryChangesW :: Handle -> LPVOID -> DWORD -> BOOL -> DWORD -> LPDWORD -> LPOVERLAPPED -> LPOVERLAPPED_COMPLETION_ROUTINE -> IO BOOL + +{- +type CompletionRoutine :: (DWORD, DWORD, LPOVERLAPPED) -> IO () +foreign import ccall "wrapper" + mkCompletionRoutine :: CompletionRoutine -> IO (FunPtr CompletionRoutine) + +type LPOVERLAPPED = Ptr OVERLAPPED +type LPOVERLAPPED_COMPLETION_ROUTINE = FunPtr CompletionRoutine + +data OVERLAPPED = OVERLAPPED + { + } + + +-- In System.Win32.File, but missing a crucial case: +-- type FileNotificationFlag = DWORD +-} + +-- See https://msdn.microsoft.com/en-us/library/windows/desktop/aa365465(v=vs.85).aspx +#{enum FileNotificationFlag, + , _fILE_NOTIFY_CHANGE_FILE_NAME = FILE_NOTIFY_CHANGE_FILE_NAME + , _fILE_NOTIFY_CHANGE_DIR_NAME = FILE_NOTIFY_CHANGE_DIR_NAME + , _fILE_NOTIFY_CHANGE_ATTRIBUTES = FILE_NOTIFY_CHANGE_ATTRIBUTES + , _fILE_NOTIFY_CHANGE_SIZE = FILE_NOTIFY_CHANGE_SIZE + , _fILE_NOTIFY_CHANGE_LAST_WRITE = FILE_NOTIFY_CHANGE_LAST_WRITE + , _fILE_NOTIFY_CHANGE_LAST_ACCESS = FILE_NOTIFY_CHANGE_LAST_ACCESS + , _fILE_NOTIFY_CHANGE_CREATION = FILE_NOTIFY_CHANGE_CREATION + , _fILE_NOTIFY_CHANGE_SECURITY = FILE_NOTIFY_CHANGE_SECURITY + }
+ win-src/System/Win32/Notify.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE QuasiQuotes #-} + +module System.Win32.Notify ( + Event(..) + , EventVariety(..) + , Handler + , WatchId(..) + , WatchManager(..) + , initWatchManager + , killWatch + , killWatchManager + , watch + , watchDirectory + + , fILE_NOTIFY_CHANGE_FILE_NAME + , fILE_NOTIFY_CHANGE_DIR_NAME + , fILE_NOTIFY_CHANGE_ATTRIBUTES + , fILE_NOTIFY_CHANGE_SIZE + , fILE_NOTIFY_CHANGE_LAST_WRITE + -- , fILE_NOTIFY_CHANGE_LAST_ACCESS + -- , fILE_NOTIFY_CHANGE_CREATION + , fILE_NOTIFY_CHANGE_SECURITY + ) where + +import Control.Concurrent +import Control.Exception.Safe (SomeException, catch, throwIO) +import Control.Monad (forM_, forever) +import Data.Function (fix) +import Data.Map (Map) +import qualified Data.Map as Map +import Foreign.C.Error (errnoToIOError) +import System.FilePath +import System.IO.Error (ioeSetErrorString) +import System.Win32.File +import System.Win32.FileNotify +import System.Win32.Types (c_maperrno_func) + + +data EventVariety = + Modify + | Create + | Delete + | Move + deriving Eq + +data Event + -- | A file was modified. @Modified isDirectory file@ + = Modified { filePath :: FilePath } + -- | A file was created. @Created isDirectory file@ + | Created { filePath :: FilePath } + -- | A file was deleted. @Deleted isDirectory file@ + | Deleted { filePath :: FilePath } + deriving (Eq, Show) + +type Handler = Event -> IO () + +data WatchId = WatchId [ThreadId] Handle deriving (Eq, Ord, Show) +type WatchMap = Map WatchId Handler +data WatchManager = WatchManager { watchManagerWatchMap :: MVar WatchMap } + +initWatchManager :: IO WatchManager +initWatchManager = WatchManager <$> newMVar Map.empty + +killWatchManager :: WatchManager -> IO () +killWatchManager (WatchManager mvarMap) = do + modifyMVar_ mvarMap $ \watchMap -> do + forM_ (Map.keys watchMap) killWatch + return mempty + +watchDirectory :: WatchManager -> FilePath -> Bool -> FileNotificationFlag -> Handler -> IO WatchId +watchDirectory (WatchManager mvarMap) dir watchSubTree flags handler = do + watchHandle <- getWatchHandle dir + chanEvents <- newChan + tid1 <- forkIO $ dispatcher chanEvents + tid2 <- forkIO $ osEventsReader dir watchSubTree flags watchHandle chanEvents + let wid = WatchId [tid1, tid2] watchHandle + modifyMVar mvarMap $ \watchMap -> + return (Map.insert wid handler watchMap, wid) + + where + dispatcher :: Chan [Event] -> IO () + dispatcher chanEvents = forever $ readChan chanEvents >>= mapM_ handler + +watch :: WatchManager -> FilePath -> Bool -> FileNotificationFlag -> IO (WatchId, Chan [Event]) +watch (WatchManager mvarMap) dir watchSubTree flags = do + watchHandle <- getWatchHandle dir + chanEvents <- newChan + tid <- forkIO $ osEventsReader dir watchSubTree flags watchHandle chanEvents + let wid = WatchId [tid] watchHandle + modifyMVar_ mvarMap $ \watchMap -> + return (Map.insert wid (const $ return ()) watchMap) + return (wid, chanEvents) + +osEventsReader :: FilePath -> Bool -> FileNotificationFlag -> Handle -> Chan [Event] -> IO () +osEventsReader dir watchSubTree flags watchHandle chanEvents = fix $ \loop -> + readDirectoryChanges watchHandle watchSubTree flags >>= \case + -- ERROR_OPERATION_ABORTED: this happens when the event read thread is killed. + -- https://learn.microsoft.com/en-us/windows/win32/debug/system-error-codes--500-999- + -- Just return silently. + Left (995, _) -> return () + Left (err_code, msg) -> do + errno <- c_maperrno_func err_code + throwIO (errnoToIOError "ReadDirectoryChangesW" errno Nothing Nothing `ioeSetErrorString` msg) + Right events -> actsToEvents dir events >>= writeChan chanEvents >> loop + +killWatch :: WatchId -> IO () +killWatch (WatchId tids handle) = do + forM_ tids killThread + -- catch (closeHandle handle) $ \(e :: SomeException) -> + -- putStrLn ([i|Failed to kill watch #{handle}: #{e}|]) + catch (closeHandle handle) $ \(_ :: SomeException) -> return () + +actsToEvents :: FilePath -> [(Action, String)] -> IO [Event] +actsToEvents baseDir = mapM actToEvent + where + actToEvent (act, fn) = do + case act of + FileModified -> return $ Modified $ baseDir </> fn + FileAdded -> return $ Created $ baseDir </> fn + FileRemoved -> return $ Deleted $ baseDir </> fn + FileRenamedOld -> return $ Deleted $ baseDir </> fn + FileRenamedNew -> return $ Created $ baseDir </> fn