packages feed

fsnotify 0.4.1.0 → 0.4.2.0

raw patch · 15 files changed

+549/−365 lines, 15 filesdep +monad-loggerdep +string-interpolatedep ~basedep ~directorydep ~filepathnew-component:exe:examplePVP ok

version bump matches the API change (PVP)

Dependencies added: monad-logger, string-interpolate

Dependency ranges changed: base, directory, filepath, hfsevents, hinotify, safe-exceptions, text, unix-compat, unliftio

API changes (from Hackage documentation)

Files

CHANGELOG.md view
@@ -1,13 +1,27 @@ Changes ======= +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)+* 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)+* Export `WatchConfig` type (#108).  Version 0.4.0.1 ---------------@@ -19,7 +33,7 @@  API breaking update. -* New options for threading control (single-threaded, thread-per-watch, and thread-per-manager)+* 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.@@ -27,7 +41,7 @@   * 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 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.
+ 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,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.0.+-- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack  name:           fsnotify-version:        0.4.1.0+version:        0.4.2.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@@ -32,6 +32,8 @@       System.FSNotify.Types   hs-source-dirs:       src+  default-extensions:+      ScopedTypeVariables   ghc-options: -Wall   build-depends:       async >=2.0.0.0@@ -42,7 +44,7 @@     , filepath >=1.3.0.0     , monad-control >=1.0.0.0     , safe-exceptions >=0.1.0.0-    , text >=0.11.0+    , text >=0.11.0 && <2.2     , time >=1.1     , unix-compat >=0.2   default-language: Haskell2010@@ -57,9 +59,15 @@   if os(linux)     other-modules:         System.FSNotify.Linux+        System.FSNotify.Linux.Util     build-depends:-        hinotify >=0.3.7-      , unix >=2.7.1.0+        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@@ -73,8 +81,41 @@     other-modules:         System.FSNotify.OSX     build-depends:-        hfsevents >=0.1.3+        hfsevents >=0.1.8 +executable example+  main-is: Main.hs+  other-modules:+      Paths_fsnotify+  hs-source-dirs:+      example+  default-extensions:+      ScopedTypeVariables+  ghc-options: -threaded -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)+    cpp-options: -DOS_Linux+  if os(windows)+    cpp-options: -DOS_Win32+  if os(darwin)+    cpp-options: -DOS_Mac+  if os(freebsd) || os(netbsd) || os(openbsd)+    cpp-options: -DOS_BSD+ test-suite tests   type: exitcode-stdio-1.0   main-is: Main.hs@@ -84,6 +125,8 @@       Paths_fsnotify   hs-source-dirs:       test+  default-extensions:+      ScopedTypeVariables   ghc-options: -threaded -Wall   build-depends:       async >=2@@ -92,9 +135,11 @@     , exceptions     , filepath     , fsnotify+    , monad-logger     , random     , retry     , safe-exceptions+    , string-interpolate     , temporary     , unix-compat     , unliftio >=0.2.20
src/System/FSNotify.hs view
@@ -3,14 +3,13 @@ -- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org -- {-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE NamedFieldPuns #-}  -- | This library does not currently report changes made to directories, -- only files within watched directories.@@ -77,7 +76,7 @@ import Control.Exception.Safe as E import Control.Monad import Control.Monad.IO.Class-import Data.Text as T+import qualified Data.Text as T import System.FSNotify.Polling import System.FSNotify.Types import System.FilePath@@ -103,11 +102,11 @@  -- | Watch manager. You need one in order to create watching jobs. data WatchManager = forall manager argType. FileListener manager argType =>-  WatchManager { watchManagerConfig :: WatchConfig-               , watchManagerManager :: manager-               , watchManagerCleanupVar :: (MVar (Maybe (IO ()))) -- cleanup action, or Nothing if the manager is stopped-               , watchManagerGlobalChan :: Maybe (EventAndActionChannel, Async ())-               }+  WatchManager {+    watchManagerConfig :: WatchConfig+    , watchManagerManager :: manager+    , watchManagerGlobalChan :: Maybe (EventAndActionChannel, Async ())+    }  -- | Default configuration --@@ -145,8 +144,6 @@ -- watching for files and free resources. stopManager :: WatchManager -> IO () stopManager (WatchManager {..}) = do-  mbCleanup <- swapMVar watchManagerCleanupVar Nothing-  maybe (return ()) liftIO mbCleanup   liftIO $ killSession watchManagerManager   case watchManagerGlobalChan of     Nothing -> return ()@@ -165,15 +162,15 @@ # endif    case confWatchMode conf of-    WatchModePoll interval -> WatchManager conf <$> liftIO (createPollManager interval) <*> cleanupVar <*> globalWatchChan+    WatchModePoll interval -> WatchManager conf <$> liftIO (createPollManager interval) <*> globalWatchChan #ifndef OS_BSD     WatchModeOS -> liftIO (initSession ()) >>= createManager #endif    where #ifndef OS_BSD-    createManager :: Either Text NativeManager -> IO WatchManager-    createManager (Right nativeManager) = WatchManager conf nativeManager <$> cleanupVar <*> globalWatchChan+    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 @@ -188,8 +185,6 @@         return $ Just (globalChan, globalReaderThread)       _ -> return Nothing -    cleanupVar = newMVar (Just (return ()))- -- | 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@@ -222,25 +217,10 @@  threadChan :: (forall a b. ListenFn a b) -> WatchManager -> FilePath -> ActionPredicate -> Action -> IO StopListening threadChan listenFn (WatchManager {watchManagerGlobalChan=(Just (globalChan, _)), ..}) path actPred action =-  modifyMVar watchManagerCleanupVar $ \case-    Nothing -> return (Nothing, return ()) -- we've been stopped. Throw an exception?-    Just cleanup -> do-      stopListener <- liftIO $ listenFn watchManagerConfig watchManagerManager path actPred (\event -> writeChan globalChan (event, action))-      return (Just (cleanup >> stopListener), stopListener)-threadChan listenFn (WatchManager {watchManagerGlobalChan=Nothing, ..}) path actPred action =-  modifyMVar watchManagerCleanupVar $ \case-    Nothing -> return (Nothing, return ()) -- we've been stopped. Throw an exception?-    Just cleanup -> do-      chan <- newChan-      let forkThreadPerEvent = case confThreadingMode watchManagerConfig of-            SingleThread -> error "Should never happen"-            ThreadPerWatch -> False-            ThreadPerEvent -> True-      readerThread <- async $ readEvents forkThreadPerEvent chan-      stopListener <- liftIO $ listenFn watchManagerConfig watchManagerManager path actPred (writeChan chan)-      return (Just (cleanup >> stopListener >> cancel readerThread), stopListener >> cancel readerThread)--  where-    readEvents :: Bool -> EventChannel -> IO ()-    readEvents True chan = forever $ readChan chan >>= (async . action)-    readEvents False chan = forever $ readChan chan >>= 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/Linux.hs view
@@ -2,15 +2,10 @@ -- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org -- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org ---{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE OverloadedStrings #-}  {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -22,23 +17,19 @@ import Control.Concurrent.MVar import Control.Exception.Safe as E import Control.Monad-import qualified Data.ByteString as BS import Data.Function import Data.Monoid import Data.String import Data.Time.Clock (UTCTime) import Data.Time.Clock.POSIX-import qualified GHC.Foreign as F-import GHC.IO.Encoding (getFileSystemEncoding) import Prelude hiding (FilePath)-import System.Directory (canonicalizePath) import System.FSNotify.Find+import System.FSNotify.Linux.Util import System.FSNotify.Listener import System.FSNotify.Types-import System.FilePath (FilePath, (</>))+import System.FilePath ((</>)) import qualified System.INotify as INo import System.Posix.ByteString (RawFilePath)-import System.Posix.Directory.ByteString (openDirStream, readDirStream, closeDirStream) import System.Posix.Files (getFileStatus, isDirectory, modificationTimeHiRes)  @@ -151,7 +142,6 @@       wd <- INo.addWatch listenerINotify varieties hinotifyPath (handleRecursiveEvent rawFilePath actPred callback watchStillExistsVar isRootWatchedDir listener wdVar)       return $ Just ((wd, watchStillExistsVar):wds) - 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@@ -188,70 +178,3 @@   case event of     INo.DeletedSelf | not isRootWatchedDir -> return ()     _ -> handleInoEvent actPred callback baseDir watchStillExistsVar event------ * Util--canonicalizeRawDirPath :: RawFilePath -> IO RawFilePath-canonicalizeRawDirPath p = fromRawFilePath p >>= canonicalizePath >>= toRawFilePath---- | Same as </> but for RawFilePath--- TODO: make sure this is correct or find in a library-(<//>) :: RawFilePath -> RawFilePath -> RawFilePath-x <//> y = x <> "/" <> y--traverseAllDirs :: RawFilePath -> (RawFilePath -> IO ()) -> IO ()-traverseAllDirs dir cb = traverseAll dir $ \subPath ->-  -- TODO: wish we didn't need fromRawFilePath here-  -- TODO: make sure this does the right thing with symlinks-  fromRawFilePath subPath >>= getFileStatus >>= \case-    (isDirectory -> True) -> cb subPath >> return True-    _ -> return False--traverseAll :: RawFilePath -> (RawFilePath -> IO Bool) -> IO ()-traverseAll dir cb = bracket (openDirStream dir) closeDirStream $ \dirStream ->-  fix $ \loop -> do-    readDirStream dirStream >>= \case-      x | BS.null x -> return ()-      "." -> loop-      ".." -> loop-      subDir -> flip finally loop $ do-        -- TODO: canonicalize?-        let fullSubDir = dir <//> subDir-        shouldRecurse <- cb fullSubDir-        when shouldRecurse $ traverseAll fullSubDir cb--boolToIsDirectory :: Bool -> EventIsDirectory-boolToIsDirectory False = IsFile-boolToIsDirectory True = IsDirectory--toRawFilePath :: FilePath -> IO BS.ByteString-toRawFilePath fp = do-  enc <- getFileSystemEncoding-  F.withCString enc fp BS.packCString--fromRawFilePath :: BS.ByteString -> IO FilePath-fromRawFilePath bs = do-  enc <- getFileSystemEncoding-  BS.useAsCString bs (F.peekCString enc)--#if MIN_VERSION_hinotify(0, 3, 10)-fromHinotifyPath :: BS.ByteString -> IO FilePath-fromHinotifyPath = fromRawFilePath--rawToHinotifyPath :: BS.ByteString -> IO BS.ByteString-rawToHinotifyPath = return--rawFromHinotifyPath :: BS.ByteString -> IO BS.ByteString-rawFromHinotifyPath = return-#else-fromHinotifyPath :: FilePath -> IO FilePath-fromHinotifyPath = return--rawToHinotifyPath :: BS.ByteString -> IO FilePath-rawToHinotifyPath = fromRawFilePath--rawFromHinotifyPath :: FilePath -> IO BS.ByteString-rawFromHinotifyPath = toRawFilePath-#endif
+ 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 (getFileStatus, 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: make sure this does the right thing with symlinks+  fromRawFilePath subPath >>= getFileStatus >>= \case+    (isDirectory -> True) -> cb subPath >> return True+    _ -> return False++traverseAll :: RawFilePath -> (RawFilePath -> IO Bool) -> IO ()+traverseAll dir cb = bracket (openDirStream dir) closeDirStream $ \dirStream ->+  fix $ \loop -> do+    readDirStream dirStream >>= \case+      x | BS.null x -> return ()+      "." -> loop+      ".." -> loop+      subDir -> flip finally loop $ do+        -- TODO: canonicalize?+        let fullSubDir = dir <//> subDir+        shouldRecurse <- cb fullSubDir+        when shouldRecurse $ traverseAll fullSubDir cb++boolToIsDirectory :: Bool -> EventIsDirectory+boolToIsDirectory False = IsFile+boolToIsDirectory True = IsDirectory++toRawFilePath :: FilePath -> IO BS.ByteString+toRawFilePath fp = do+  enc <- getFileSystemEncoding+  F.withCString enc fp BS.packCString++fromRawFilePath :: BS.ByteString -> IO FilePath+fromRawFilePath bs = do+  enc <- getFileSystemEncoding+  BS.useAsCString bs (F.peekCString enc)++#if MIN_VERSION_hinotify(0, 3, 10)+fromHinotifyPath :: BS.ByteString -> IO FilePath+fromHinotifyPath = fromRawFilePath++rawToHinotifyPath :: BS.ByteString -> IO BS.ByteString+rawToHinotifyPath = return++rawFromHinotifyPath :: BS.ByteString -> IO BS.ByteString+rawFromHinotifyPath = return+#else+fromHinotifyPath :: FilePath -> IO FilePath+fromHinotifyPath = return++rawToHinotifyPath :: BS.ByteString -> IO FilePath+rawToHinotifyPath = fromRawFilePath++rawFromHinotifyPath :: FilePath -> IO BS.ByteString+rawFromHinotifyPath = toRawFilePath+#endif
src/System/FSNotify/OSX.hs view
@@ -105,13 +105,15 @@     isRelevantFileEvent = (eventIsDirectory event == IsFile) && (takeDirectory dirPath == (takeDirectory $ eventPath event))     isRelevantDirEvent = (eventIsDirectory event == IsDirectory) && (takeDirectory dirPath == (takeDirectory $ takeDirectory $ eventPath event)) -listenFn :: (ActionPredicate -> EventCallback -> FilePath -> FSE.Event -> IO a)-         -> WatchConfig-         -> OSXManager-         -> FilePath-         -> ActionPredicate-         -> EventCallback-         -> IO StopListening+listenFn :: (+  ActionPredicate -> EventCallback -> FilePath -> FSE.Event -> IO a+  )+  -> WatchConfig+  -> OSXManager+  -> FilePath+  -> ActionPredicate+  -> EventCallback+  -> IO StopListening listenFn handler conf (OSXManager mvarMap) path actPred callback = do   path' <- canonicalizeDirPath path   unique <- newUnique
src/System/FSNotify/Polling.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-}
src/System/FSNotify/Types.hs view
@@ -39,12 +39,12 @@   | 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+  -- | Note: Linux-only   | CloseWrite  { eventPath :: FilePath, eventTime :: UTCTime, eventIsDirectory :: EventIsDirectory }-  -- ^ Note: Linux-only+  -- | Note: Linux-only   | Unknown  { eventPath :: FilePath, eventTime :: UTCTime, eventIsDirectory :: EventIsDirectory, eventString :: String }-  -- ^ Note: Linux-only   deriving (Eq, Show)  type EventChannel = Chan Event@@ -55,7 +55,10 @@  -- | Method of watching for changes. data WatchMode =-  WatchModePoll { watchModePollInterval :: Int }+  WatchModePoll {+    watchModePollInterval :: Int+    -- ^ Polling interval in microseconds.+  }   -- ^ 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). #ifndef OS_BSD
src/System/FSNotify/Win32.hs view
@@ -22,33 +22,28 @@ 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 :: EventIsDirectory -> BaseDir -> UTCTime -> WNo.Event -> Event+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 :: EventIsDirectory -> BaseDir -> ActionPredicate -> EventCallback -> WNo.Event -> IO ()+handleWNoEvent :: EventIsDirectory -> FilePath -> ActionPredicate -> EventCallback -> WNo.Event -> IO () handleWNoEvent isDirectory basedir actPred callback inoEvent = do   currentTime <- getCurrentTime   let event = fsnEvent isDirectory basedir currentTime inoEvent   when (actPred event) $ callback event  watchDirectory :: Bool -> WatchConfig -> WNo.WatchManager -> FilePath -> ActionPredicate -> EventCallback -> IO (IO ())-watchDirectory isRecursive conf watchManager@(WNo.WatchManager mvarMap) path actPred callback = do+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 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
test/FSNotify/Test/EventTests.hs view
@@ -1,10 +1,12 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ImplicitParams #-}-{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# HLINT ignore "Redundant multi-way if" #-} @@ -13,7 +15,9 @@ 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@@ -24,89 +28,80 @@ import UnliftIO.Directory  -eventTests :: (MonadUnliftIO m, MonadThrow m, HasParallelSemaphore' context) => ThreadingMode -> SpecFree context m ()-eventTests threadingMode = describe "Tests" $ parallel $ do+eventTests :: (+  MonadUnliftIO m, MonadThrow m+  ) => TestFolderGenerator -> ThreadingMode -> SpecFree context m ()+eventTests testFolderGenerator threadingMode = describe "Tests" $ parallelWithoutDirectory $ do   let pollOptions = if isBSD then [True] else [False, True] -  forM_ pollOptions $ \poll -> describe (if poll then "Polling" else "Native") $ parallel $ do-    let ?timeInterval = if poll then 2*10^(6 :: Int) else 5*10^(5 :: Int)-    forM_ [False, True] $ \recursive -> describe (if recursive then "Recursive" else "Non-recursive") $ parallel $-      forM_ [False, True] $ \nested -> describe (if nested then "Nested" else "Non-nested") $ parallel $-        eventTests' threadingMode poll recursive nested--+  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, HasParallelSemaphore' context, ?timeInterval :: Int) => ThreadingMode -> Bool -> Bool -> Bool -> SpecFree context m ()-eventTests' threadingMode poll recursive nested = do -- withParallelSemaphore $-  let itWithFolder name action = introduceTestFolder threadingMode poll recursive nested $ it name action+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) $ itWithFolder "deletes the watched directory" $ do-    TestFolderContext watchedDir _f getEvents _clearEvents <- getContext testFolderContext+  unless (nested || poll || isMac || isWin) $ it "deletes the watched directory" $ withFolder $ \(TestFolderContext watchedDir _f getEvents _clearEvents) -> do     removeDirectory watchedDir -    pauseAndRetryOnExpectationFailure 3 $ liftIO getEvents >>= \case+    waitForEvents getEvents $ \case       [WatchedDirectoryRemoved {..}] | eventPath `equalFilePath` watchedDir && eventIsDirectory == IsDirectory -> return ()       events -> expectationFailure $ "Got wrong events: " <> show events -  itWithFolder "works with a new file" $ do-    TestFolderContext _watchedDir f getEvents _clearEvents <- getContext testFolderContext-+  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 $-      pauseAndRetryOnExpectationFailure 3 $ liftIO getEvents >>= \events ->+      waitForEvents getEvents $ \events ->         if | nested && not recursive -> events `shouldBe` []            | isWin && not poll -> case events of-               [Modified {}, Added {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()+               -- 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 -  itWithFolder "works with a new directory" $ do-    TestFolderContext _watchedDir f getEvents _clearEvents <- getContext testFolderContext+  it "works with a new directory" $ withFolder $ \(TestFolderContext _watchedDir f getEvents _clearEvents) -> do     createDirectory f -    pauseAndRetryOnExpectationFailure 3 $ liftIO getEvents >>= \events ->+    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 -  itWithFolder "works with a deleted file" $ do-    TestFolderContext _watchedDir f getEvents clearEvents <- getContext testFolderContext-    liftIO (writeFile f "" >> clearEvents)-+  it "works with a deleted file" $ withFolder' (\f -> liftIO $ writeFile f "") $ \() (TestFolderContext _watchedDir f getEvents _clearEvents) -> do     removeFile f -    pauseAndRetryOnExpectationFailure 3 $ liftIO getEvents >>= \events ->+    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 -  itWithFolder "works with a deleted directory" $ do-    TestFolderContext _watchedDir f getEvents clearEvents <- getContext testFolderContext-    createDirectory f >> liftIO clearEvents-+  it "works with a deleted directory" $ withFolder' (\f -> liftIO $ createDirectory f) $ \() (TestFolderContext _watchedDir f getEvents _clearEvents) -> do     removeDirectory f -    pauseAndRetryOnExpectationFailure 3 $ liftIO getEvents >>= \events ->+    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 -  itWithFolder "works with modified file attributes" $ do-    TestFolderContext _watchedDir f getEvents clearEvents <- getContext testFolderContext-    liftIO (writeFile f "" >> clearEvents)-+  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-    pauseAndRetryOnExpectationFailure 3 $ liftIO getEvents >>= \events ->+    waitForEvents getEvents $ \events ->       if | poll -> return ()          | nested && not recursive -> events `shouldBe` []          | isWin -> case events of@@ -116,12 +111,9 @@              [ModifiedAttributes {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()              _ -> expectationFailure $ "Got wrong events: " <> show events -  itWithFolder "works with a modified file" $ do-    TestFolderContext _watchedDir f getEvents clearEvents <- getContext testFolderContext-    liftIO (writeFile f "" >> clearEvents)-+  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") $-      pauseAndRetryOnExpectationFailure 3 $ liftIO getEvents >>= \events ->+      waitForEvents getEvents $ \events ->         if | nested && not recursive -> events `shouldBe` []            | isMac -> case events of                [Modified {..}] | poll && eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()@@ -131,20 +123,17 @@                [Modified {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()                _ -> expectationFailure $ "Got wrong events: " <> show events <> " (wanted file path " <> show f <> ")" -  when isLinux $ unless poll $-    itWithFolder "gets a close_write" $ do-      TestFolderContext _watchedDir f getEvents clearEvents <- getContext testFolderContext-      liftIO (writeFile f "" >> clearEvents)-      liftIO $ withFile f WriteMode $ flip hPutStr "asdf"-      pauseAndRetryOnExpectationFailure 3 $ liftIO getEvents >>= \events ->+  when isLinux $ 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-               [cw@(CloseWrite {}), m@(Modified {})]-                 | eventPath cw `equalFilePath` f && eventIsDirectory cw == IsFile-                   && eventPath m `equalFilePath` f && eventIsDirectory m == IsFile -> return ()-               [m@(Modified {}), cw@(CloseWrite {})]-                 | eventPath cw `equalFilePath` f && eventIsDirectory cw == IsFile-                   && eventPath m `equalFilePath` f && eventIsDirectory m == IsFile -> return ()+               [CloseWrite {..}] | eventPath `equalFilePath` f && eventIsDirectory == IsFile -> return ()                _ -> expectationFailure $ "Got wrong events: " <> show events  withSingleWriteFile :: MonadIO m => FilePath -> String -> m b -> m b@@ -158,3 +147,15 @@     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
@@ -1,28 +1,29 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE DataKinds #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ConstraintKinds #-}  module FSNotify.Test.Util where  import Control.Exception.Safe (Handler(..))-import Control.Monad+import Control.Monad.Logger import Control.Retry+import Data.String.Interpolate import System.FSNotify import System.FilePath-import System.PosixCompat.Files (touchFile)-import System.Random as R 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@@ -30,12 +31,15 @@ #ifdef mingw32_HOST_OS import Data.Bits import System.Win32.File (getFileAttributes, setFileAttributes, fILE_ATTRIBUTE_TEMPORARY)+ -- Perturb the file's attributes, to check that a modification event is emitted changeFileAttributes :: FilePath -> IO () changeFileAttributes file = do   attrs <- getFileAttributes file   setFileAttributes file (attrs `xor` fILE_ATTRIBUTE_TEMPORARY) #else+import System.PosixCompat.Files (touchFile)+ changeFileAttributes :: FilePath -> IO () changeFileAttributes = touchFile #endif@@ -69,21 +73,22 @@ isBSD = False #endif -pauseAndRetryOnExpectationFailure :: (MonadUnliftIO m, ?timeInterval :: Int) => Int -> m a -> m a-pauseAndRetryOnExpectationFailure n action = threadDelay ?timeInterval >> retryOnExpectationFailure n action--retryOnExpectationFailure :: MonadUnliftIO m => Int -> m a -> m a+waitUntil :: MonadUnliftIO m => Double -> m a -> m a #if MIN_VERSION_retry(0, 7, 0)-retryOnExpectationFailure seconds action = withRunInIO $ \runInIO -> recovering (constantDelay 50000 <> limitRetries (seconds * 20)) [\_ -> Handler handleFn] (\_ -> runInIO action)+waitUntil timeInSeconds action = withRunInIO $ \runInIO ->+  recovering policy [\_ -> Handler handleFn] (\_ -> runInIO action) #else-retryOnExpectationFailure seconds action = withRunInIO $ \runInIO -> recovering (constantDelay 50000 <> limitRetries (seconds * 20)) [\_ -> Handler handleFn] (runInIO action)+waitUntil timeInSeconds action = withRunInIO $ \runInIO ->+  recovering policy [\_ -> Handler handleFn] (runInIO action) #endif   where     handleFn :: SomeException -> IO Bool-    handleFn (fromException -> Just (Reason {})) = return True+    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@@ -91,27 +96,73 @@   , clearEvents :: IO ()   } -testFolderContext :: Label "testFolderContext" TestFolderContext-testFolderContext = Label :: Label "testFolderContext" TestFolderContext+data TestFolderGenerator = TestFolderGenerator {+  testFolderGeneratorRootDir :: FilePath+  , testFolderGeneratorId :: MVar Int+  } -introduceTestFolder :: (MonadUnliftIO m, ?timeInterval :: Int) => ThreadingMode -> Bool -> Bool -> Bool -> SpecFree (LabelValue "testFolderContext" TestFolderContext :> context) m () -> SpecFree context m ()-introduceTestFolder threadingMode poll recursive nested = introduceWith "Make test folder" testFolderContext $ \action -> do-  withRandomTempDirectory $ \watchedDir' -> do+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 -    -- On Mac, delay before starting the watcher because otherwise creation of "subdir"-    -- can get picked up.-    when isMac $ threadDelay 2000000+    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 { #ifdef OS_BSD-          confWatchMode = if poll then WatchModePoll (2 * 10^(5 :: Int)) else error "No native watcher available."+          confWatchMode = if poll then WatchModePoll pollInterval else error "No native watcher available." #else-          confWatchMode = if poll then WatchModePoll (2 * 10^(5 :: Int)) else WatchModeOS+          confWatchMode = if poll then WatchModePoll pollInterval else WatchModeOS #endif           , confThreadingMode = threadingMode           }@@ -119,32 +170,19 @@     withRunInIO $ \runInIO ->       withManagerConf conf $ \mgr -> do         eventsVar <- newIORef []-        stop <- watchFn mgr watchedDir' (const True) (\ev -> atomicModifyIORef eventsVar (\evs -> (ev:evs, ())))-        _ <- runInIO $ action $ TestFolderContext {-          watchedDir = watchedDir'-          , filePath = normalise $ baseDir </> fileName-          , getEvents = readIORef eventsVar-          , clearEvents = threadDelay ?timeInterval >> atomicWriteIORef eventsVar []-          }--        stop----- | Use a random identifier so that every test happens in a different folder--- This is unfortunately necessary because of the madness of OS X FSEvents; see the comments in OSX.hs-withRandomTempDirectory :: MonadUnliftIO m => (FilePath -> m ()) -> m ()-withRandomTempDirectory action = do-  randomID <- liftIO $ replicateM 10 $ R.randomRIO ('a', 'z')-  withSystemTempDirectory ("test." <> randomID) action--withParallelSemaphore :: forall context m. (-  MonadUnliftIO m, HasLabel context "parallelSemaphore" QSem-  ) => SpecFree context m () -> SpecFree context m ()-withParallelSemaphore = around' (defaultNodeOptions { nodeOptionsRecordTime = False, nodeOptionsVisibilityThreshold = 125 }) "claim semaphore" $ \action -> do-  s <- getContext parallelSemaphore'-  bracket_ (liftIO $ waitQSem s) (liftIO $ signalQSem s) (void action)--parallelSemaphore' :: Label "parallelSemaphore" QSem-parallelSemaphore' = Label+        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 []+            }+          ) -type HasParallelSemaphore' context = HasLabel context "parallelSemaphore" QSem+parallelWithoutDirectory :: SpecFree context m () -> SpecFree context m ()+parallelWithoutDirectory = parallel' (defaultNodeOptions {+                                         nodeOptionsCreateFolder = False+                                         , nodeOptionsVisibilityThreshold = 70+                                         })
test/Main.hs view
@@ -1,12 +1,13 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}  module Main where -import Control.Exception.Safe import Control.Monad import Control.Monad.IO.Class+import Data.String.Interpolate import FSNotify.Test.EventTests import FSNotify.Test.Util import Prelude hiding (FilePath)@@ -17,10 +18,13 @@   main :: IO ()-main = runSandwichWithCommandLineArgs defaultOptions $ parallelN 20 $ do+main =+  withTestFolderGenerator $ \testFolderGenerator ->+  runSandwichWithCommandLineArgs defaultOptions $ parallelN 20 $ do     describe "Configuration" $ do       it "respects the confOnHandlerException option" $ do-        withRandomTempDirectory $ \watchedDir' -> do+        withRandomTempDirectory testFolderGenerator $ \watchedDir' -> do+          info [i|Got temp dir: #{watchedDir'}|]           exceptions <- newIORef (0 :: Int)           let conf = defaultConfig { confOnHandlerException = \_ -> modifyIORef exceptions (+ 1) } @@ -28,20 +32,19 @@             stop <- watchDir mgr watchedDir' (const True) $ \ev -> do               case ev of #ifdef darwin_HOST_OS-                Modified {} -> throwIO $ userError "Oh no!"+                Modified {} -> expectationFailure "Oh no!" #else-                Added {} -> throwIO $ userError "Oh no!"+                Added {} -> expectationFailure "Oh no!" #endif                 _ -> return ()              writeFile (watchedDir' </> "testfile") "foo" -            let ?timeInterval = 5*10^(5 :: Int)-            pauseAndRetryOnExpectationFailure 3 $+            waitUntil 5.0 $               readIORef exceptions >>= (`shouldBe` 1)              stop -    describe "SingleThread" $ eventTests SingleThread-    describe "ThreadPerWatch" $ eventTests ThreadPerWatch-    describe "ThreadPerEvent" $ eventTests ThreadPerEvent+    describe "SingleThread" $ eventTests testFolderGenerator SingleThread+    describe "ThreadPerWatch" $ eventTests testFolderGenerator ThreadPerWatch+    describe "ThreadPerEvent" $ eventTests testFolderGenerator ThreadPerEvent
win-src/System/Win32/FileNotify.hsc view
@@ -3,20 +3,42 @@ {-# LANGUAGE InterruptibleFFI #-}
 #endif
 
-module System.Win32.FileNotify
-       ( Handle
-       , Action(..)
-       , getWatchHandle
-       , readDirectoryChanges
-       ) where
-
-import System.Win32.File
-import System.Win32.Types
+{-# LANGUAGE LambdaCase #-}
 
-import Foreign
-import Foreign.C
+module System.Win32.FileNotify (
+  Handle
+  , Action(..)
+  , getWatchHandle
+  , readDirectoryChanges
+  ) where
 
-import Data.Bits
+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>
@@ -24,23 +46,23 @@ 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
+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 [(Action, String)]
-readDirectoryChanges h wst mask = do
+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) wst mask bret
-      readChanges buffer
+      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)
@@ -72,14 +94,15 @@ 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
+ , _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
+-- 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 ())
@@ -107,15 +130,28 @@   return $ FILE_NOTIFY_INFORMATION neof acti fnam
 
 
-readDirectoryChangesW :: Handle -> Ptr FILE_NOTIFY_INFORMATION -> DWORD -> BOOL -> FileNotificationFlag -> LPDWORD -> IO ()
-readDirectoryChangesW h buf bufSize wst f br =
-  failIfFalse_ "ReadDirectoryChangesW" $ c_ReadDirectoryChangesW h (castPtr buf) bufSize wst f br nullPtr nullFunPtr
+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 wst f over =
-  failIfFalse_ "ReadDirectoryChangesW" $ c_ReadDirectoryChangesW h (castPtr buf) bufSize wst f nullPtr over nullFunPtr
+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
@@ -149,12 +185,12 @@ 
 -- 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
+ , _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
@@ -1,7 +1,8 @@-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE QuasiQuotes #-}
 
-module System.Win32.Notify
-  ( Event(..)
+module System.Win32.Notify (
+  Event(..)
   , EventVariety(..)
   , Handler
   , WatchId(..)
@@ -11,6 +12,7 @@   , killWatchManager
   , watch
   , watchDirectory
+
   , fILE_NOTIFY_CHANGE_FILE_NAME
   , fILE_NOTIFY_CHANGE_DIR_NAME
   , fILE_NOTIFY_CHANGE_ATTRIBUTES
@@ -22,84 +24,92 @@   ) where
 
 import Control.Concurrent
-import Control.Concurrent.MVar
-import Control.Exception.Safe (SomeException, catch)
-import Control.Monad (forever)
-import Data.Bits
-import Data.List (intersect)
+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 System.Directory
+import Foreign.C.Error (errnoToIOError)
 import System.FilePath
-import System.Win32 (closeHandle)
+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 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)
+  -- | 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 ThreadId Handle deriving (Eq, Ord, Show)
+data WatchId = WatchId [ThreadId] Handle deriving (Eq, Ord, Show)
 type WatchMap = Map WatchId Handler
-data WatchManager = WatchManager { watchManagerWatchMap :: (MVar WatchMap) }
+data WatchManager = WatchManager { watchManagerWatchMap :: MVar WatchMap }
 
 initWatchManager :: IO WatchManager
-initWatchManager =  do
-  mvarMap <- newMVar Map.empty
-  return (WatchManager mvarMap)
+initWatchManager = WatchManager <$> newMVar Map.empty
 
 killWatchManager :: WatchManager -> IO ()
 killWatchManager (WatchManager mvarMap) = do
-  watchMap <- readMVar mvarMap
-  flip mapM_ (Map.keys watchMap) $ killWatch
+  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 watchHandle chanEvents
-  modifyMVar_ mvarMap $ \watchMap -> return (Map.insert (WatchId tid1 tid2 watchHandle) handler watchMap)
-  return (WatchId tid1 tid2 watchHandle)
+  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
 
-    osEventsReader :: Handle -> Chan [Event] -> IO ()
-    osEventsReader watchHandle chanEvents = forever $ do
-      (readDirectoryChanges watchHandle watchSubTree flags >>= (actsToEvents dir) >>= writeChan chanEvents)
-
 watch :: WatchManager -> FilePath -> Bool -> FileNotificationFlag -> IO (WatchId, Chan [Event])
 watch (WatchManager mvarMap) dir watchSubTree flags = do
   watchHandle <- getWatchHandle dir
   chanEvents <- newChan
-  tid <- forkIO $ osEventsReader watchHandle chanEvents
-  modifyMVar_ mvarMap $ \watchMap -> return (Map.insert (WatchId tid tid watchHandle) (const $ return ()) watchMap)
-  return ((WatchId tid tid watchHandle), chanEvents)
+  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)
 
-  where
-    osEventsReader :: Handle -> Chan [Event] -> IO ()
-    osEventsReader watchHandle chanEvents = forever $ do
-      (readDirectoryChanges watchHandle watchSubTree flags >>= (actsToEvents dir) >>= writeChan 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 tid1 tid2 handle) = do
-  killThread tid1
-  if tid1 /= tid2 then killThread tid2 else return ()
-  catch (closeHandle handle) $ \(e :: SomeException) -> return ()
+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