fsnotify-0.4.1.0/src/0000755000000000000000000000000013552547415012503 5ustar0000000000000000fsnotify-0.4.1.0/src/System/0000755000000000000000000000000014313514036013754 5ustar0000000000000000fsnotify-0.4.1.0/src/System/FSNotify/0000755000000000000000000000000014317164344015464 5ustar0000000000000000fsnotify-0.4.1.0/test/0000755000000000000000000000000014305623230012656 5ustar0000000000000000fsnotify-0.4.1.0/test/FSNotify/0000755000000000000000000000000014305535730014366 5ustar0000000000000000fsnotify-0.4.1.0/test/FSNotify/Test/0000755000000000000000000000000014323126776015313 5ustar0000000000000000fsnotify-0.4.1.0/win-src/0000755000000000000000000000000014305535730013270 5ustar0000000000000000fsnotify-0.4.1.0/win-src/System/0000755000000000000000000000000014305535730014554 5ustar0000000000000000fsnotify-0.4.1.0/win-src/System/Win32/0000755000000000000000000000000014306261200015443 5ustar0000000000000000fsnotify-0.4.1.0/src/System/FSNotify.hs0000644000000000000000000002214314316427552016024 0ustar0000000000000000-- -- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org -- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org -- {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NamedFieldPuns #-} -- | This library does not currently report changes made to directories, -- only files within watched directories. -- -- Minimal example: -- -- >{-# LANGUAGE OverloadedStrings #-} -- for FilePath literals -- > -- >import System.FSNotify -- >import Control.Concurrent (threadDelay) -- >import Control.Monad (forever) -- > -- >main = -- > withManager $ \mgr -> do -- > -- start a watching job (in the background) -- > watchDir -- > mgr -- manager -- > "." -- directory to watch -- > (const True) -- predicate -- > print -- action -- > -- > -- sleep forever (until interrupted) -- > forever $ threadDelay 1000000 module System.FSNotify ( -- * Events Event(..) , EventIsDirectory(..) , EventChannel , Action , ActionPredicate -- * Starting/Stopping , WatchManager , withManager , startManager , stopManager -- * Configuration , defaultConfig , WatchConfig , confWatchMode , confThreadingMode , confOnHandlerException , WatchMode(..) , ThreadingMode(..) -- * Lower level , withManagerConf , startManagerConf , StopListening -- * Watching , watchDir , watchDirChan , watchTree , watchTreeChan ) where import Prelude hiding (FilePath) import Control.Concurrent import Control.Concurrent.Async import Control.Exception.Safe as E import Control.Monad import Control.Monad.IO.Class import Data.Text as T import System.FSNotify.Polling import System.FSNotify.Types import System.FilePath import System.FSNotify.Listener (ListenFn, StopListening) #if !MIN_VERSION_base(4,11,0) import Data.Monoid #endif #ifdef OS_Linux import System.FSNotify.Linux #endif #ifdef OS_Win32 import System.FSNotify.Win32 #endif #ifdef OS_Mac import System.FSNotify.OSX #endif -- | 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 ()) } -- | Default configuration -- -- * Uses OS watch mode and single thread. defaultConfig :: WatchConfig defaultConfig = WatchConfig { #ifdef OS_BSD 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 manager. -- When finished watching. you must release resources via 'stopManager'. -- It is preferrable if possible to use 'withManager' to handle this -- automatically. startManager :: IO WatchManager startManager = startManagerConf defaultConfig -- | Stop a file watch manager. -- Stopping a watch manager will immediately stop -- 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 () Just (_, t) -> cancel t -- | Like 'withManager', but configurable. withManagerConf :: WatchConfig -> (WatchManager -> IO a) -> IO a withManagerConf conf = bracket (startManagerConf conf) stopManager -- | Like 'startManager', but configurable. startManagerConf :: WatchConfig -> IO WatchManager startManagerConf conf = do # ifdef OS_Win32 -- See https://github.com/haskell-fswatch/hfsnotify/issues/50 unless rtsSupportsBoundThreads $ throwIO $ userError "startManagerConf must be called with -threaded on Windows" # endif case confWatchMode conf of WatchModePoll interval -> WatchManager conf <$> liftIO (createPollManager interval) <*> cleanupVar <*> globalWatchChan #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 (Left err) = throwIO $ userError $ T.unpack $ "Error: couldn't start native file manager: " <> err #endif globalWatchChan = case confThreadingMode conf of SingleThread -> do globalChan <- newChan globalReaderThread <- async $ forever $ do (event, action) <- readChan globalChan tryAny (action event) >>= \case Left _ -> return () -- TODO: surface the exception somehow? Right () -> return () return $ Just (globalChan, globalReaderThread) _ -> return Nothing cleanupVar = newMVar (Just (return ())) -- | 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 {..}) 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 {..}) path actionPredicate chan = listenRecursive watchManagerConfig watchManagerManager path actionPredicate (writeChan chan) -- | Watch the immediate contents of a directory by committing an Action for each event. -- Watching the immediate contents of a directory will only report events -- associated with files within the specified directory, and not files -- within its subdirectories. watchDir :: WatchManager -> FilePath -> ActionPredicate -> Action -> IO StopListening watchDir wm@(WatchManager {watchManagerConfig}) fp actionPredicate action = threadChan listen wm fp actionPredicate wrappedAction where wrappedAction x = handle (confOnHandlerException watchManagerConfig) (action x) -- | Watch all the contents of a directory by committing an Action for each event. -- Watching all the contents of a directory will report events associated with -- files within the specified directory and its subdirectories. watchTree :: WatchManager -> FilePath -> ActionPredicate -> Action -> IO StopListening watchTree wm@(WatchManager {watchManagerConfig}) fp actionPredicate action = threadChan listenRecursive wm fp actionPredicate wrappedAction where wrappedAction x = handle (confOnHandlerException watchManagerConfig) (action x) -- * Main threading logic threadChan :: (forall a b. ListenFn a b) -> WatchManager -> FilePath -> ActionPredicate -> Action -> IO StopListening threadChan listenFn (WatchManager {watchManagerGlobalChan=(Just (globalChan, _)), ..}) path actPred action = modifyMVar watchManagerCleanupVar $ \case Nothing -> return (Nothing, return ()) -- we've been stopped. Throw an exception? Just cleanup -> do stopListener <- liftIO $ listenFn watchManagerConfig watchManagerManager path actPred (\event -> writeChan globalChan (event, action)) return (Just (cleanup >> stopListener), stopListener) threadChan listenFn (WatchManager {watchManagerGlobalChan=Nothing, ..}) path actPred action = modifyMVar watchManagerCleanupVar $ \case Nothing -> return (Nothing, return ()) -- we've been stopped. Throw an exception? Just cleanup -> do chan <- newChan 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 fsnotify-0.4.1.0/src/System/FSNotify/Devel.hs0000644000000000000000000000465414316425707017072 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} -- | Some additional functions on top of "System.FSNotify". -- -- Example of compiling scss files with compass -- -- @ -- compass :: WatchManager -> FilePath -> m () -- compass man dir = do -- putStrLn $ "compass " ++ encodeString dir -- treeExtExists man dir "scss" $ \fp -> -- when ("deploy" `notElem` splitDirectories fp) $ do -- let d = encodeString $ head (splitDirectories rel) -- system "cd " ++ d ++ "&& bundle exec compass compile" -- return () -- @ {-# LANGUAGE NamedFieldPuns #-} module System.FSNotify.Devel ( treeExtAny , treeExtExists , doAllEvents , allEvents , existsEvents ) where import Data.Text 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 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 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 = action . eventPath -- | Turn a 'FilePath' predicate into an 'Event' predicate that accepts -- only 'Added', 'Modified', and 'ModifiedAttributes' event types existsEvents :: (FilePath -> Bool) -> (Event -> Bool) existsEvents filt event = case event of 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 = filt . eventPath fsnotify-0.4.1.0/src/System/FSNotify/Find.hs0000644000000000000000000000212214305535730016673 0ustar0000000000000000-- | 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) fsnotify-0.4.1.0/src/System/FSNotify/Listener.hs0000644000000000000000000000361514316427203017605 0ustar0000000000000000{-# 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 ( FileListener(..) , StopListening , ListenFn ) where import Data.Text import Prelude hiding (FilePath) import System.FSNotify.Types import System.FilePath -- | 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 argType | sessionType -> argType where -- | Initialize a file listener instance. 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 -- watched. killSession :: sessionType -> IO () -- | Listen for file events associated with the immediate contents of a directory. -- 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 :: 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 :: ListenFn sessionType argType fsnotify-0.4.1.0/src/System/FSNotify/Path.hs0000644000000000000000000000562314316425740016721 0ustar0000000000000000-- -- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org -- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org -- {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE CPP #-} module System.FSNotify.Path ( findFiles , findFilesAndDirs , canonicalizeDirPath , canonicalizePath , hasThisExtension ) where import Control.Monad import qualified Data.Text as T import Prelude hiding (FilePath) import qualified System.Directory as D import System.FilePath import System.PosixCompat.Files as PF getDirectoryContentsPath :: FilePath -> IO [FilePath] 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 path = do contents <- getDirectoryContentsPath path stats <- mapM getFileStatus contents let pairs = zip stats contents let files = [ f | (s, f) <- pairs, PF.isRegularFile s] let dirs = [ d | (s, d) <- pairs, PF.isDirectory s] return (files, dirs) findAllFiles :: FilePath -> IO [FilePath] findAllFiles path = do (files, dirs) <- fileDirContents path nestedFiles <- mapM findAllFiles dirs return (files ++ concat nestedFiles) findImmediateFiles :: FilePath -> IO [FilePath] findImmediateFiles = fileDirContents >=> mapM D.canonicalizePath . fst -- * Exported functions below this point findFiles :: Bool -> FilePath -> IO [FilePath] findFiles True path = findAllFiles =<< canonicalizeDirPath path findFiles False path = findImmediateFiles =<< 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 addTrailingSlash = addTrailingPathSeparator canonicalizeDirPath :: FilePath -> IO FilePath canonicalizeDirPath path = addTrailingSlash `fmap` D.canonicalizePath path -- | bugfix older version of canonicalizePath (system-fileio <= 0.3.7) loses trailing slash canonicalizePath :: FilePath -> IO FilePath canonicalizePath path = let was_dir = null (takeFileName path) in if not was_dir then D.canonicalizePath path else canonicalizeDirPath path hasThisExtension :: FilePath -> T.Text -> Bool hasThisExtension p ext = takeExtension p == T.unpack ext fsnotify-0.4.1.0/src/System/FSNotify/Polling.hs0000644000000000000000000001413614317164344017431 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} -- -- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org -- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org -- module System.FSNotify.Polling ( createPollManager , PollManager(..) , FileListener(..) ) where 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) import Data.Time.Clock.POSIX import Prelude hiding (FilePath) import System.Directory (doesDirectoryExist) import System.FSNotify.Listener import System.FSNotify.Path (findFilesAndDirs, canonicalizeDirPath) import System.FSNotify.Types import System.FilePath import System.PosixCompat.Files import System.PosixCompat.Types data EventType = AddedEvent | ModifiedEvent | RemovedEvent 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 } generateEvent :: UTCTime -> EventIsDirectory -> EventType -> FilePath -> Maybe Event generateEvent timestamp isDir AddedEvent filePath = Just (Added filePath timestamp isDir) generateEvent timestamp isDir ModifiedEvent filePath = Just (Modified filePath timestamp isDir) generateEvent timestamp isDir RemovedEvent filePath = Just (Removed filePath timestamp isDir) generateEvents :: UTCTime -> EventType -> [(FilePath, EventIsDirectory)] -> [Event] generateEvents timestamp eventType = mapMaybe (\(path, isDir) -> generateEvent timestamp isDir eventType path) -- | Do not return modified events for directories. -- These can arise when files are created inside subdirectories, resulting in the modification time -- of the directory being bumped. However, to increase consistency with the other FileListeners, -- we ignore these events. handleEvent :: EventCallback -> ActionPredicate -> Event -> IO () handleEvent _ _ (Modified _ _ IsDirectory) = return () handleEvent callback actPred event | actPred event = callback event | otherwise = return () pathModMap :: Bool -> FilePath -> IO (Map FilePath (UTCTime, EventIsDirectory)) pathModMap recursive path = findFilesAndDirs recursive path >>= pathModMap' where pathModMap' :: [FilePath] -> IO (Map FilePath (UTCTime, EventIsDirectory)) pathModMap' files = (Map.fromList . catMaybes) <$> mapM pathAndInfo files 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 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, 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 callback actPred) -- Additional init function exported to allow startManager to unconditionally -- create a poll manager as a fallback when other managers will not instantiate. createPollManager :: Int -> IO PollManager createPollManager interval = PollManager <$> newMVar Map.empty <*> pure interval killWatchingThread :: WatchKey -> IO () killWatchingThread (WatchKey threadId) = killThread threadId killAndUnregister :: MVar WatchMap -> WatchKey -> IO () killAndUnregister mvarMap wk = do _ <- withMVar mvarMap $ \m -> do killWatchingThread wk return $ Map.delete wk m return () 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 instance FileListener PollManager Int where initSession interval = Right <$> createPollManager interval killSession (PollManager mvarMap _) = do watchMap <- readMVar mvarMap forM_ (Map.keys watchMap) killWatchingThread listen = listen' False listenRecursive = listen' True getModificationTime :: FilePath -> IO UTCTime getModificationTime p = fromEpoch . modificationTime <$> getFileStatus p fromEpoch :: EpochTime -> UTCTime fromEpoch = posixSecondsToUTCTime . realToFrac fsnotify-0.4.1.0/src/System/FSNotify/Types.hs0000644000000000000000000000670714316427316017136 0ustar0000000000000000-- -- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org -- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org -- {-# LANGUAGE CPP #-} 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.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 { eventPath :: FilePath, eventTime :: UTCTime, eventIsDirectory :: EventIsDirectory } | Modified { eventPath :: FilePath, eventTime :: UTCTime, eventIsDirectory :: EventIsDirectory } | ModifiedAttributes { eventPath :: FilePath, eventTime :: UTCTime, eventIsDirectory :: EventIsDirectory } | Removed { eventPath :: FilePath, eventTime :: UTCTime, eventIsDirectory :: EventIsDirectory } | WatchedDirectoryRemoved { eventPath :: FilePath, eventTime :: UTCTime, eventIsDirectory :: EventIsDirectory } -- ^ Note: Linux-only | CloseWrite { eventPath :: FilePath, eventTime :: UTCTime, eventIsDirectory :: EventIsDirectory } -- ^ Note: Linux-only | Unknown { eventPath :: FilePath, eventTime :: UTCTime, eventIsDirectory :: EventIsDirectory, eventString :: String } -- ^ Note: Linux-only deriving (Eq, Show) type EventChannel = Chan Event type EventCallback = Event -> IO () type EventAndActionChannel = Chan (Event, Action) -- | Method of watching for changes. data WatchMode = WatchModePoll { watchModePollInterval :: Int } -- ^ Detect changes by polling the filesystem. Less efficient and may miss fast changes. Not recommended -- unless you're experiencing problems with 'WatchModeOS' (or 'WatchModeOS' is not supported on your platform). #ifndef OS_BSD | WatchModeOS -- ^ Use OS-specific mechanisms to be notified of changes (inotify on Linux, FSEvents on OSX, etc.). -- Not currently available on *BSD. #endif data ThreadingMode = SingleThread -- ^ Use a single thread for the entire 'Manager'. Event handler callbacks will run sequentially. | ThreadPerWatch -- ^ Use a single thread for each watch (i.e. each call to 'watchDir', 'watchTree', etc.). -- Callbacks within a watch will run sequentially but callbacks from different watches may be interleaved. | ThreadPerEvent -- ^ Launch a separate thread for every event handler. -- | Watch configuration. data WatchConfig = WatchConfig { confWatchMode :: WatchMode -- ^ Watch mode to use. , confThreadingMode :: ThreadingMode -- ^ Threading mode to use. , confOnHandlerException :: SomeException -> IO () -- ^ Called when a handler throws an exception. } 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 act _ = True fsnotify-0.4.1.0/src/System/FSNotify/Linux.hs0000644000000000000000000002545314316425717017133 0ustar0000000000000000-- -- 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 #-} module System.FSNotify.Linux ( FileListener(..) , NativeManager ) where 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.Listener import System.FSNotify.Types import System.FilePath (FilePath, ()) import qualified System.INotify as INo import System.Posix.ByteString (RawFilePath) import System.Posix.Directory.ByteString (openDirStream, readDirStream, closeDirStream) import System.Posix.Files (getFileStatus, isDirectory, modificationTimeHiRes) data INotifyListener = INotifyListener { listenerINotify :: INo.INotify } type NativeManager = INotifyListener data EventVarietyMismatchException = EventVarietyMismatchException deriving (Show, Typeable) instance Exception EventVarietyMismatchException 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)] 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 currentTime <- getCurrentTime 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.Attrib, INo.Modify, INo.CloseWrite, INo.DeleteSelf] instance FileListener INotifyListener () where initSession _ = E.handle (\(e :: IOException) -> return $ Left $ fromString $ show e) $ do inotify <- INo.initINotify return $ Right $ INotifyListener inotify killSession (INotifyListener {listenerINotify}) = INo.killINotify listenerINotify 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 listener initialPath actPred callback = do -- wdVar stores the list of created watch descriptors. We use it to -- cancel the whole recursive listening task. -- -- To avoid a race condition (when a new watch is added right after -- we've stopped listening), we replace the MVar contents with Nothing -- to signify that the listening task is cancelled, and no new watches -- should be added. wdVar <- newMVar (Just []) let 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 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 type RecursiveWatches = MVar (Maybe [(INo.WatchDescriptor, MVar Bool)]) 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) 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 -- * 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 fsnotify-0.4.1.0/src/System/FSNotify/Win32.hs0000644000000000000000000000664114315621362016725 0ustar0000000000000000-- -- 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 Control.Concurrent import Control.Monad (when) 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. -- Win32-notify has (temporarily?) dropped support for Renamed events. fsnEvent :: EventIsDirectory -> BaseDir -> UTCTime -> WNo.Event -> Event fsnEvent isDirectory basedir timestamp (WNo.Created name) = Added (normalise (basedir name)) timestamp isDirectory fsnEvent isDirectory basedir timestamp (WNo.Modified name) = Modified (normalise (basedir name)) timestamp isDirectory fsnEvent isDirectory basedir timestamp (WNo.Deleted name) = Removed (normalise (basedir name)) timestamp isDirectory handleWNoEvent :: EventIsDirectory -> BaseDir -> 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 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 _ = Right <$> WNo.initWatchManager killSession = WNo.killWatchManager listen = watchDirectory False listenRecursive = watchDirectory True fsnotify-0.4.1.0/win-src/System/Win32/FileNotify.hsc0000644000000000000000000001374714305535730020241 0ustar0000000000000000{-# LANGUAGE ForeignFunctionInterface #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE InterruptibleFFI #-} #endif module System.Win32.FileNotify ( Handle , Action(..) , getWatchHandle , readDirectoryChanges ) where import System.Win32.File import System.Win32.Types import Foreign import Foreign.C import Data.Bits #include 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 [(Action, String)] readDirectoryChanges h wst mask = do let maxBuf = 16384 allocaBytes maxBuf $ \buffer -> do alloca $ \bret -> do readDirectoryChangesW h buffer (toEnum maxBuf) wst mask bret 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 () readDirectoryChangesW h buf bufSize wst f br = failIfFalse_ "ReadDirectoryChangesW" $ c_ReadDirectoryChangesW h (castPtr buf) bufSize wst f br nullPtr nullFunPtr {- 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 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 } fsnotify-0.4.1.0/win-src/System/Win32/Notify.hs0000644000000000000000000001000614306261215017252 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} 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.Concurrent.MVar import Control.Exception.Safe (SomeException, catch) import Control.Monad (forever) import Data.Bits import Data.List (intersect) import Data.Map (Map) import qualified Data.Map as Map import System.Directory import System.FilePath import System.Win32 (closeHandle) import System.Win32.File import System.Win32.FileNotify 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 ThreadId Handle deriving (Eq, Ord, Show) type WatchMap = Map WatchId Handler data WatchManager = WatchManager { watchManagerWatchMap :: (MVar WatchMap) } initWatchManager :: IO WatchManager initWatchManager = do mvarMap <- newMVar Map.empty return (WatchManager mvarMap) killWatchManager :: WatchManager -> IO () killWatchManager (WatchManager mvarMap) = do watchMap <- readMVar mvarMap flip mapM_ (Map.keys watchMap) $ killWatch 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) 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) where osEventsReader :: Handle -> Chan [Event] -> IO () osEventsReader watchHandle chanEvents = forever $ do (readDirectoryChanges watchHandle watchSubTree flags >>= (actsToEvents dir) >>= writeChan chanEvents) 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 () 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 fsnotify-0.4.1.0/src/System/FSNotify/OSX.hs0000644000000000000000000001443714316427643016505 0ustar0000000000000000-- -- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org -- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org -- {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE MultiParamTypeClasses #-} module System.FSNotify.OSX ( FileListener(..) , NativeManager ) where import Control.Concurrent import Control.Monad import Data.Bits import Data.Map (Map) import qualified Data.Map as Map import Data.Time.Clock (UTCTime, getCurrentTime) import Data.Unique import Data.Word import Prelude hiding (FilePath) import System.Directory import System.FSNotify.Listener import System.FSNotify.Path (canonicalizeDirPath) import System.FSNotify.Types import System.FilePath import qualified System.OSX.FSEvents as FSE data WatchData = WatchData FSE.EventStream EventCallback type WatchMap = Map Unique WatchData data OSXManager = OSXManager (MVar WatchMap) type NativeManager = OSXManager nil :: Word64 nil = 0x00 -- OS X reports the absolute (canonical) path without a trailing slash. Add -- the trailing slash when the path refers to a directory canonicalEventPath :: FSE.Event -> FilePath canonicalEventPath event = if flags .&. dirFlag /= nil then addTrailingPathSeparator path else path where flags = FSE.eventFlags event 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 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 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 handleFSEEvent :: Bool -> ActionPredicate -> EventCallback -> FilePath -> FSE.Event -> IO () handleFSEEvent isRecursive actPred callback dirPath fseEvent = do currentTime <- getCurrentTime events <- fsnEvents currentTime fseEvent forM_ events $ \event -> when (actPred event && (isRecursive || (isDirectlyInside dirPath event))) $ callback event -- | For non-recursive monitoring, test if an event takes place directly inside the monitored folder isDirectlyInside :: FilePath -> Event -> Bool isDirectlyInside dirPath event = isRelevantFileEvent || isRelevantDirEvent where isRelevantFileEvent = (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 handler conf (OSXManager mvarMap) path actPred callback = do path' <- canonicalizeDirPath path unique <- newUnique 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 (v1, v2, _) <- FSE.osVersion 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 $ handleFSEEvent False listenRecursive = listenFn $ handleFSEEvent True fsnotify-0.4.1.0/test/Main.hs0000644000000000000000000000270714312531670014110 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ImplicitParams #-} module Main where import Control.Exception.Safe import Control.Monad import Control.Monad.IO.Class 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 = runSandwichWithCommandLineArgs defaultOptions $ parallelN 20 $ do describe "Configuration" $ do it "respects the confOnHandlerException option" $ do withRandomTempDirectory $ \watchedDir' -> do 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 {} -> throwIO $ userError "Oh no!" #else Added {} -> throwIO $ userError "Oh no!" #endif _ -> return () writeFile (watchedDir' "testfile") "foo" let ?timeInterval = 5*10^(5 :: Int) pauseAndRetryOnExpectationFailure 3 $ readIORef exceptions >>= (`shouldBe` 1) stop describe "SingleThread" $ eventTests SingleThread describe "ThreadPerWatch" $ eventTests ThreadPerWatch describe "ThreadPerEvent" $ eventTests ThreadPerEvent fsnotify-0.4.1.0/test/FSNotify/Test/EventTests.hs0000644000000000000000000001777014323127357017763 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# 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 Data.Monoid 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, HasParallelSemaphore' context) => ThreadingMode -> SpecFree context m () eventTests threadingMode = describe "Tests" $ parallel $ 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 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 unless (nested || poll || isMac || isWin) $ itWithFolder "deletes the watched directory" $ do TestFolderContext watchedDir _f getEvents _clearEvents <- getContext testFolderContext removeDirectory watchedDir pauseAndRetryOnExpectationFailure 3 $ liftIO 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 let wrapper action = if | isWin -> liftIO (writeFile f "foo") >> action | otherwise -> withFile f AppendMode $ \_ -> action wrapper $ pauseAndRetryOnExpectationFailure 3 $ liftIO getEvents >>= \events -> if | nested && not recursive -> events `shouldBe` [] | isWin && not poll -> case events of [Modified {}, Added {..}] | 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 createDirectory f pauseAndRetryOnExpectationFailure 3 $ liftIO 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) removeFile f pauseAndRetryOnExpectationFailure 3 $ liftIO 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 removeDirectory f pauseAndRetryOnExpectationFailure 3 $ liftIO 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) 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 -> 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 itWithFolder "works with a modified file" $ do TestFolderContext _watchedDir f getEvents clearEvents <- getContext testFolderContext liftIO (writeFile f "" >> clearEvents) (if isWin then withSingleWriteFile f "foo" else withOpenWritableAndWrite f "foo") $ pauseAndRetryOnExpectationFailure 3 $ liftIO getEvents >>= \events -> if | nested && not recursive -> events `shouldBe` [] | isMac -> 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 $ 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 -> if | nested && not recursive -> events `shouldBe` [] | otherwise -> case events of [cw@(CloseWrite {}), m@(Modified {})] | eventPath cw `equalFilePath` f && eventIsDirectory cw == IsFile && eventPath m `equalFilePath` f && eventIsDirectory m == IsFile -> return () [m@(Modified {}), cw@(CloseWrite {})] | eventPath cw `equalFilePath` f && eventIsDirectory cw == IsFile && eventPath m `equalFilePath` f && eventIsDirectory m == IsFile -> return () _ -> expectationFailure $ "Got wrong events: " <> show events 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 fsnotify-0.4.1.0/test/FSNotify/Test/Util.hs0000644000000000000000000001202514317164356016563 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-} module FSNotify.Test.Util where import Control.Exception.Safe (Handler(..)) import Control.Monad import Control.Retry 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 #ifdef mingw32_HOST_OS import Data.Bits import System.Win32.File (getFileAttributes, setFileAttributes, fILE_ATTRIBUTE_TEMPORARY) -- Perturb the file's attributes, to check that a modification event is emitted changeFileAttributes :: FilePath -> IO () changeFileAttributes file = do attrs <- getFileAttributes file setFileAttributes file (attrs `xor` fILE_ATTRIBUTE_TEMPORARY) #else changeFileAttributes :: FilePath -> IO () changeFileAttributes = touchFile #endif isMac :: Bool #ifdef darwin_HOST_OS isMac = True #else isMac = False #endif isWin :: Bool #ifdef mingw32_HOST_OS isWin = True #else isWin = False #endif isLinux :: Bool #ifdef linux_HOST_OS isLinux = True #else isLinux = False #endif isBSD :: Bool #ifdef OS_BSD isBSD = True #else 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 #if MIN_VERSION_retry(0, 7, 0) retryOnExpectationFailure seconds action = withRunInIO $ \runInIO -> recovering (constantDelay 50000 <> limitRetries (seconds * 20)) [\_ -> Handler handleFn] (\_ -> runInIO action) #else retryOnExpectationFailure seconds action = withRunInIO $ \runInIO -> recovering (constantDelay 50000 <> limitRetries (seconds * 20)) [\_ -> Handler handleFn] (runInIO action) #endif where handleFn :: SomeException -> IO Bool handleFn (fromException -> Just (Reason {})) = return True handleFn _ = return False data TestFolderContext = TestFolderContext { watchedDir :: FilePath , filePath :: FilePath , getEvents :: IO [Event] , clearEvents :: IO () } testFolderContext :: Label "testFolderContext" TestFolderContext testFolderContext = Label :: Label "testFolderContext" TestFolderContext 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 let fileName = "testfile" let baseDir = if nested then watchedDir' "subdir" else watchedDir' let watchFn = if recursive then watchTree else watchDir createDirectoryIfMissing True baseDir -- On Mac, delay before starting the watcher because otherwise creation of "subdir" -- can get picked up. when isMac $ threadDelay 2000000 let conf = defaultConfig { #ifdef OS_BSD confWatchMode = if poll then WatchModePoll (2 * 10^(5 :: Int)) else error "No native watcher available." #else confWatchMode = if poll then WatchModePoll (2 * 10^(5 :: Int)) else WatchModeOS #endif , confThreadingMode = threadingMode } 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 type HasParallelSemaphore' context = HasLabel context "parallelSemaphore" QSem fsnotify-0.4.1.0/README.md0000644000000000000000000000060614305535730013167 0ustar0000000000000000![CI](https://github.com/haskell-fswatch/hfsnotify/workflows/CI/badge.svg) ========= Unified Haskell interface for basic file system notifications. This is a library. There are executables built on top of it. * [spy](https://hackage.haskell.org/package/spy) * [steeloverseer](https://github.com/schell/steeloverseer) Requirements ============ Windows ------- compile with -fthreaded fsnotify-0.4.1.0/CHANGELOG.md0000644000000000000000000000715114323126604013517 0ustar0000000000000000Changes ======= 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 --------------- Update to the new hinotify API (v0.3.10) Version 0.2.1.1 --------------- Catch IO exceptions when initialising inotify on Linux Version 0.2.1 ------------- Don't use `system-filepath` Version 0.2 ----------- Use filepath instead of deprecated system-filepath Version 0.1.0.3 --------------- * Fix the tests Version 0.1.0.2 --------------- * Restore compatibility with GHC 7.4 * Fix a bug in `treeExtAny`, which previously work identically to `treeExtExists` * Improve documentation Version 0.1.0.1 --------------- Include CHANGELOG.md and README.md in the source distribution. Version 0.1 ----------- * Allow to stop a listening job. Note this changes the return type of watching functions from `()` to `IO ()`. * Previously, some care was taken to prevent multiple callbacks from running simultaneously. It is now the user's responsibility. See [#43](https://github.com/haskell-fswatch/hfsnotify/issues/43) for details. * Previously, paths returned to callbacks were relative on Windows. Now they are absolute, like on the other platforms. * The `WatchConfig` type has changed. Previously, it only specified debouncing parameters. Now it also contains polling parameters. * The `isPollingManager` function is added to determine, at runtime, whether the polling implementation is used. fsnotify-0.4.1.0/LICENSE0000644000000000000000000000276213603763113012720 0ustar0000000000000000Copyright (c) 2012, Mark Dittmer All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Mark Dittmer nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. fsnotify-0.4.1.0/Setup.hs0000644000000000000000000000031413603763113013336 0ustar0000000000000000-- -- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org -- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org -- import Distribution.Simple main = defaultMain fsnotify-0.4.1.0/fsnotify.cabal0000644000000000000000000000544614323126624014542 0ustar0000000000000000cabal-version: 1.12 -- This file has been generated from package.yaml by hpack version 0.35.0. -- -- see: https://github.com/sol/hpack name: fsnotify version: 0.4.1.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 , Niklas Broberg maintainer: Tom McLaughlin license: BSD3 license-file: LICENSE build-type: Simple extra-source-files: README.md CHANGELOG.md test/Main.hs 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 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 , time >=1.1 , unix-compat >=0.2 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 if os(linux) other-modules: System.FSNotify.Linux build-depends: hinotify >=0.3.7 , unix >=2.7.1.0 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.3 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 ghc-options: -threaded -Wall build-depends: async >=2 , base >=4.3.1.0 , directory , exceptions , filepath , fsnotify , random , retry , safe-exceptions , temporary , unix-compat , unliftio >=0.2.20 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 if os(windows) build-depends: Win32 , sandwich >=0.1.1.1 else build-depends: sandwich