fsnotify-0.3.0.1/src/0000755000000000000000000000000013303132002012452 5ustar0000000000000000fsnotify-0.3.0.1/src/System/0000755000000000000000000000000013303132002013736 5ustar0000000000000000fsnotify-0.3.0.1/src/System/FSNotify/0000755000000000000000000000000013303132002015437 5ustar0000000000000000fsnotify-0.3.0.1/test/0000755000000000000000000000000013303132002012642 5ustar0000000000000000fsnotify-0.3.0.1/win-src/0000755000000000000000000000000013303345155013264 5ustar0000000000000000fsnotify-0.3.0.1/win-src/System/0000755000000000000000000000000013303345155014550 5ustar0000000000000000fsnotify-0.3.0.1/win-src/System/Win32/0000755000000000000000000000000013303345155015452 5ustar0000000000000000fsnotify-0.3.0.1/src/System/FSNotify.hs0000644000000000000000000001730513303132002016001 0ustar0000000000000000-- -- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org -- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org -- {-# LANGUAGE CPP, ScopedTypeVariables, ExistentialQuantification, RankNTypes #-} -- | NOTE: 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(..) , EventChannel , eventIsDirectory , eventTime , eventPath , Action , ActionPredicate -- * Starting/Stopping , WatchManager , withManager , startManager , stopManager , defaultConfig , WatchConfig(..) , Debounce(..) , withManagerConf , startManagerConf , StopListening , isPollingManager -- * Watching , watchDir , watchDirChan , watchTree , watchTreeChan ) where import Prelude hiding (FilePath) import Control.Concurrent import Control.Concurrent.Async import Control.Exception import Control.Monad import Data.Maybe import System.FSNotify.Polling import System.FSNotify.Types import System.FilePath import System.FSNotify.Listener (StopListening) #ifdef OS_Linux import System.FSNotify.Linux #else # ifdef OS_Win32 import System.FSNotify.Win32 # else # ifdef OS_Mac import System.FSNotify.OSX # else type NativeManager = PollManager # endif # endif #endif -- | Watch manager. You need one in order to create watching jobs. data WatchManager = forall manager . FileListener manager => WatchManager WatchConfig manager (MVar (Maybe (IO ()))) -- cleanup action, or Nothing if the manager is stopped -- | Default configuration -- -- * Debouncing is enabled with a time interval of 1 millisecond -- -- * Polling is disabled -- -- * The polling interval defaults to 1 second defaultConfig :: WatchConfig defaultConfig = WatchConfig { confDebounce = DebounceDefault , confPollInterval = 10^(6 :: Int) -- 1 second , confUsePolling = False } -- | Perform an IO action with a WatchManager in place. -- Tear down the WatchManager after the action is complete. 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 -- 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 _ wm cleanupVar) = do mbCleanup <- swapMVar cleanupVar Nothing fromMaybe (return ()) mbCleanup killSession wm -- | Like 'withManager', but configurable withManagerConf :: WatchConfig -> (WatchManager -> IO a) -> IO a withManagerConf conf = bracket (startManagerConf conf) stopManager -- | Like 'startManager', but configurable startManagerConf :: WatchConfig -> IO WatchManager startManagerConf conf | confUsePolling conf = pollingManager | otherwise = initSession >>= createManager where createManager :: Maybe NativeManager -> IO WatchManager createManager (Just nativeManager) = WatchManager conf nativeManager <$> cleanupVar createManager Nothing = pollingManager pollingManager = WatchManager conf <$> createPollManager <*> cleanupVar cleanupVar = newMVar (Just (return ())) -- | Does this manager use polling? isPollingManager :: WatchManager -> Bool isPollingManager (WatchManager _ wm _) = usesPolling wm -- | Watch the immediate contents of a directory by streaming events to a Chan. -- Watching the immediate contents of a directory will only report events -- associated with files within the specified directory, and not files -- within its subdirectories. watchDirChan :: WatchManager -> FilePath -> ActionPredicate -> EventChannel -> IO StopListening watchDirChan (WatchManager db wm _) = listen db wm -- | Watch all the contents of a directory by streaming events to a Chan. -- Watching all the contents of a directory will report events associated with -- files within the specified directory and its subdirectories. watchTreeChan :: WatchManager -> FilePath -> ActionPredicate -> EventChannel -> IO StopListening watchTreeChan (WatchManager db wm _) = listenRecursive db wm -- | Watch the immediate contents of a directory by committing an Action for each event. -- Watching the immediate contents of a directory will only report events -- associated with files within the specified directory, and not files -- within its subdirectories. watchDir :: WatchManager -> FilePath -> ActionPredicate -> Action -> IO StopListening watchDir wm = threadChan listen wm -- | Watch all the contents of a directory by committing an Action for each event. -- Watching all the contents of a directory will report events associated with -- files within the specified directory and its subdirectories. watchTree :: WatchManager -> FilePath -> ActionPredicate -> Action -> IO StopListening watchTree wm = threadChan listenRecursive wm threadChan :: (forall sessionType . FileListener sessionType => WatchConfig -> sessionType -> FilePath -> ActionPredicate -> EventChannel -> IO StopListening) -- (^ this is the type of listen and listenRecursive) -> WatchManager -> FilePath -> ActionPredicate -> Action -> IO StopListening threadChan listenFn (WatchManager db listener cleanupVar) path actPred action = modifyMVar cleanupVar $ \mbCleanup -> case mbCleanup of -- check if we've been stopped Nothing -> return (Nothing, return ()) -- or throw an exception? Just cleanup -> do chan <- newChan asy <- async $ readEvents chan action -- Ideally, the the asy thread should be linked to the current one -- (@link asy@), so that it doesn't die quietly. -- However, if we do that, then cancelling asy will also kill -- ourselves. I haven't figured out how to do this (probably we -- should just abandon async and use lower-level primitives). For now -- we don't link the thread. stopListener <- listenFn db listener path actPred chan let cleanThisUp = cancel asy return ( Just $ cleanup >> cleanThisUp , stopListener >> cleanThisUp ) readEvents :: EventChannel -> Action -> IO () readEvents chan action = forever $ do event <- readChan chan us <- myThreadId -- Execute the event handler in a separate thread, but throw any -- exceptions back to us. -- -- Note that there's a possibility that we may miss some exceptions, if -- an event handler finishes after the listen is cancelled (and so this -- thread is dead). How bad is that? The alternative is to kill the -- handler anyway when we're cancelling. forkFinally (action event) $ either (throwTo us) (const $ return ()) #if !MIN_VERSION_base(4,6,0) forkFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId forkFinally action and_then = mask $ \restore -> forkIO $ try (restore action) >>= and_then #endif fsnotify-0.3.0.1/src/System/FSNotify/Devel.hs0000644000000000000000000000500513303132002017032 0ustar0000000000000000-- | Some additional functions on top of "System.FSNotify". -- -- Example of compiling scss files with compass -- -- @ -- compass :: WatchManager -> FilePath -> IO () -- 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 () -- @ 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 event = case event of Added f _ _ -> action f Modified f _ _ -> action f Removed f _ _ -> action f Unknown f _ _ -> action f -- | Turn a 'FilePath' predicate into an 'Event' predicate that accepts -- only 'Added' and 'Modified' event types existsEvents :: (FilePath -> Bool) -> (Event -> Bool) existsEvents filt event = case event of Added f _ _ -> filt f Modified f _ _ -> filt f Removed _ _ _ -> False Unknown _ _ _ -> False -- | Turn a 'FilePath' predicate into an 'Event' predicate that accepts -- any event types allEvents :: (FilePath -> Bool) -> (Event -> Bool) allEvents filt event = case event of Added f _ _ -> filt f Modified f _ _ -> filt f Removed f _ _ -> filt f Unknown f _ _ -> filt f fsnotify-0.3.0.1/src/System/FSNotify/Listener.hs0000644000000000000000000000631413303132002017564 0ustar0000000000000000-- -- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org -- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org -- module System.FSNotify.Listener ( debounce , epsilonDefault , FileListener(..) , StopListening , newDebouncePayload ) where import Data.IORef (newIORef) import Data.Time (diffUTCTime, NominalDiffTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Prelude hiding (FilePath) import System.FSNotify.Types import System.FilePath -- | An action that cancels a watching/listening job type StopListening = IO () -- | A typeclass that imposes structure on watch managers capable of listening -- for events, or simulated listening for events. class FileListener sessionType where -- | Initialize a file listener instance. initSession :: IO (Maybe sessionType) -- ^ Just an initialized file listener, -- or Nothing if this file listener -- cannot be supported. -- | 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 :: WatchConfig -> sessionType -> FilePath -> ActionPredicate -> EventChannel -> IO StopListening -- | Listen for file events associated with all the contents of a directory. -- Listening for events associated with all the contents of a directory will -- report events associated with files within the specified directory and its -- subdirectories. listenRecursive :: WatchConfig -> sessionType -> FilePath -> ActionPredicate -> EventChannel -> IO StopListening -- | Does this manager use polling? usesPolling :: sessionType -> Bool -- | The default maximum difference (exclusive, in seconds) for two -- events to be considered as occuring "at the same time". epsilonDefault :: NominalDiffTime epsilonDefault = 0.001 -- | The default event that provides a basis for comparison. eventDefault :: Event eventDefault = Added "" (posixSecondsToUTCTime 0) False -- | A predicate indicating whether two events may be considered "the same -- event". This predicate is applied to the most recent dispatched event and -- the current event after the client-specified ActionPredicate is applied, -- before the event is dispatched. debounce :: NominalDiffTime -> Event -> Event -> Bool debounce epsilon e1 e2 = eventPath e1 == eventPath e2 && timeDiff > -epsilon && timeDiff < epsilon where timeDiff = diffUTCTime (eventTime e2) (eventTime e1) -- | Produces a fresh data payload used for debouncing events in a -- handler. newDebouncePayload :: Debounce -> IO DebouncePayload newDebouncePayload DebounceDefault = newIORef eventDefault >>= return . Just . DebounceData epsilonDefault newDebouncePayload (Debounce epsilon) = newIORef eventDefault >>= return . Just . DebounceData epsilon newDebouncePayload NoDebounce = return Nothing fsnotify-0.3.0.1/src/System/FSNotify/Path.hs0000644000000000000000000000640313303132002016672 0ustar0000000000000000-- -- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org -- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org -- {-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-} module System.FSNotify.Path ( findFiles , findDirs , 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 exists x = (||) <$> D.doesFileExist x <*> D.doesDirectoryExist x 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, findImmediateDirs :: FilePath -> IO [FilePath] findImmediateFiles = fileDirContents >=> mapM D.canonicalizePath . fst findImmediateDirs = fileDirContents >=> mapM D.canonicalizePath . snd findAllDirs :: FilePath -> IO [FilePath] findAllDirs path = do dirs <- findImmediateDirs path nestedDirs <- mapM findAllDirs dirs return (dirs ++ concat nestedDirs) -- * Exported functions below this point findFiles :: Bool -> FilePath -> IO [FilePath] findFiles True path = findAllFiles =<< canonicalizeDirPath path findFiles False path = findImmediateFiles =<< canonicalizeDirPath path findDirs :: Bool -> FilePath -> IO [FilePath] findDirs True path = findAllDirs =<< canonicalizeDirPath path findDirs False path = findImmediateDirs =<< canonicalizeDirPath path findFilesAndDirs :: Bool -> FilePath -> IO [FilePath] findFilesAndDirs False path = getDirectoryContentsPath =<< canonicalizeDirPath path findFilesAndDirs True path = do (files, dirs) <- fileDirContents path nestedFilesAndDirs <- concat <$> (mapM (findFilesAndDirs False) dirs) return (files ++ dirs ++ nestedFilesAndDirs) -- | add a trailing slash to ensure the path indicates a directory addTrailingSlash :: FilePath -> FilePath 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.3.0.1/src/System/FSNotify/Polling.hs0000644000000000000000000001340113303132002017376 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} -- -- 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 import Control.Monad (forM_) import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe import Data.Time.Clock (UTCTime, getCurrentTime) import Data.Time.Clock.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 EventChannel type WatchMap = Map WatchKey WatchData newtype PollManager = PollManager (MVar WatchMap) generateEvent :: UTCTime -> Bool -> EventType -> FilePath -> Maybe Event generateEvent timestamp isDir AddedEvent filePath = Just (Added filePath timestamp isDir) generateEvent timestamp isDir ModifiedEvent filePath = Just (Modified filePath timestamp isDir) generateEvent timestamp isDir RemovedEvent filePath = Just (Removed filePath timestamp isDir) generateEvents :: UTCTime -> EventType -> [(FilePath, Bool)] -> [Event] generateEvents timestamp eventType = mapMaybe (\(path, isDir) -> generateEvent timestamp isDir eventType path) -- | Do not return modified events for directories. -- These can arise when files are created inside subdirectories, resulting in the modification time -- of the directory being bumped. However, to increase consistency with the other FileListeners, -- we ignore these events. handleEvent :: EventChannel -> ActionPredicate -> Event -> IO () handleEvent _ _ (Modified _ _ True) = return () handleEvent chan actPred event | actPred event = writeChan chan event | otherwise = return () pathModMap :: Bool -> FilePath -> IO (Map FilePath (UTCTime, Bool)) pathModMap recursive path = findFilesAndDirs recursive path >>= pathModMap' where pathModMap' :: [FilePath] -> IO (Map FilePath (UTCTime, Bool)) pathModMap' files = (Map.fromList . catMaybes) <$> mapM pathAndInfo files pathAndInfo :: FilePath -> IO (Maybe (FilePath, (UTCTime, Bool))) pathAndInfo path = handle (\(_ :: IOException) -> return Nothing) $ do modTime <- getModificationTime path isDir <- doesDirectoryExist path return $ Just (path, (modTime, isDir)) pollPath :: Int -> Bool -> EventChannel -> FilePath -> ActionPredicate -> Map FilePath (UTCTime, Bool) -> IO () pollPath interval recursive chan filePath actPred oldPathMap = do threadDelay interval maybeNewPathMap <- handle (\(_ :: IOException) -> return Nothing) (Just <$> pathModMap recursive filePath) case maybeNewPathMap of -- Something went wrong while listing directories; we'll try again on the next poll Nothing -> pollPath interval recursive chan filePath actPred oldPathMap 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 chan filePath actPred newPathMap where modifiedDifference :: (UTCTime, Bool) -> (UTCTime, Bool) -> Maybe (UTCTime, Bool) modifiedDifference (newTime, isDir1) (oldTime, isDir2) | oldTime /= newTime || isDir1 /= isDir2 = Just (newTime, isDir1) | otherwise = Nothing handleEvents :: [Event] -> IO () handleEvents = mapM_ (handleEvent chan actPred) -- Additional init function exported to allow startManager to unconditionally -- create a poll manager as a fallback when other managers will not instantiate. createPollManager :: IO PollManager createPollManager = PollManager <$> newMVar Map.empty 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 -> EventChannel -> IO (IO ()) listen' isRecursive conf (PollManager mvarMap) path actPred chan = do path' <- canonicalizeDirPath path pmMap <- pathModMap isRecursive path' threadId <- forkIO $ pollPath (confPollInterval conf) isRecursive chan path' actPred pmMap let wk = WatchKey threadId modifyMVar_ mvarMap $ return . Map.insert wk (WatchData path' chan) return $ killAndUnregister mvarMap wk instance FileListener PollManager where initSession = fmap Just createPollManager killSession (PollManager mvarMap) = do watchMap <- readMVar mvarMap forM_ (Map.keys watchMap) killWatchingThread listen = listen' False listenRecursive = listen' True usesPolling = const True getModificationTime :: FilePath -> IO UTCTime getModificationTime p = fromEpoch . modificationTime <$> getFileStatus p fromEpoch :: EpochTime -> UTCTime fromEpoch = posixSecondsToUTCTime . realToFrac fsnotify-0.3.0.1/src/System/FSNotify/Types.hs0000644000000000000000000000760113303132002017103 0ustar0000000000000000-- -- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org -- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org -- module System.FSNotify.Types ( act , ActionPredicate , Action , WatchConfig(..) , Debounce(..) , DebounceData(..) , DebouncePayload , Event(..) , EventChannel , eventPath , eventTime , eventIsDirectory , IOEvent ) where import Control.Concurrent.Chan import Data.IORef (IORef) import Data.Time (NominalDiffTime) import Data.Time.Clock (UTCTime) import Prelude hiding (FilePath) import System.FilePath -- | A file event reported by a file watcher. Each event contains the -- canonical path for the file and a timestamp guaranteed to be after the -- event occurred (timestamps represent current time when FSEvents receives -- it from the OS and/or platform-specific Haskell modules). data Event = Added FilePath UTCTime Bool | Modified FilePath UTCTime Bool | Removed FilePath UTCTime Bool | Unknown FilePath UTCTime String deriving (Eq, Show) -- | Helper for extracting the path associated with an event. eventPath :: Event -> FilePath eventPath (Added path _ _) = path eventPath (Modified path _ _) = path eventPath (Removed path _ _) = path eventPath (Unknown path _ _) = path -- | Helper for extracting the time associated with an event. eventTime :: Event -> UTCTime eventTime (Added _ timestamp _) = timestamp eventTime (Modified _ timestamp _) = timestamp eventTime (Removed _ timestamp _) = timestamp eventTime (Unknown _ timestamp _) = timestamp eventIsDirectory :: Event -> Bool eventIsDirectory (Added _ _ isDir) = isDir eventIsDirectory (Modified _ _ isDir) = isDir eventIsDirectory (Removed _ _ isDir) = isDir eventIsDirectory (Unknown _ _ _) = False type EventChannel = Chan Event -- | Watch configuration data WatchConfig = WatchConfig { confDebounce :: Debounce -- ^ Debounce configuration , confPollInterval :: Int -- ^ Polling interval if polling is used (microseconds) , confUsePolling :: Bool -- ^ Force use of polling, even if a more effective method may be -- available. This is mostly for testing purposes. } -- | This specifies whether multiple events from the same file should be -- collapsed together, and how close is close enough. -- -- This is performed by ignoring any event that occurs to the same file -- until the specified time interval has elapsed. -- -- Note that the current debouncing logic may fail to report certain changes -- to a file, potentially leaving your program in a state that is not -- consistent with the filesystem. -- -- Make sure that if you are using this feature, all changes you make as a -- result of an 'Event' notification are both non-essential and idempotent. data Debounce = DebounceDefault -- ^ perform debouncing based on the default time interval of 1 millisecond | Debounce NominalDiffTime -- ^ perform debouncing based on the specified time interval | NoDebounce -- ^ do not perform debouncing type IOEvent = IORef Event -- | DebouncePayload contents. Contains epsilon value for debouncing -- near-simultaneous events and an IORef of the latest Event. Difference in -- arrival time is measured according to Event value timestamps. data DebounceData = DebounceData NominalDiffTime IOEvent -- | Data "payload" passed to event handlers to enable debouncing. This value -- is automatically derived from a 'WatchConfig' value. A value of Just -- DebounceData results in debouncing according to the given epsilon and -- IOEvent. A value of Nothing results in no debouncing. type DebouncePayload = Maybe DebounceData -- | A predicate used to determine whether to act on an event. type ActionPredicate = Event -> Bool -- | An action to be performed in response to an event. type Action = Event -> IO () -- | Predicate to always act. act :: ActionPredicate act _ = True fsnotify-0.3.0.1/src/System/FSNotify/Linux.hs0000644000000000000000000001733313303132002017101 0ustar0000000000000000-- -- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org -- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org -- {-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module System.FSNotify.Linux ( FileListener(..) , NativeManager ) where import Control.Concurrent.Chan import Control.Concurrent.MVar import Control.Exception as E import Control.Monad import qualified Data.ByteString as BS import Data.IORef (atomicModifyIORef, readIORef) import Data.String import qualified Data.Text as T import Data.Time.Clock (UTCTime, getCurrentTime) import Data.Time.Clock.POSIX import Data.Typeable import qualified GHC.Foreign as F import GHC.IO.Encoding (getFileSystemEncoding) import Prelude hiding (FilePath) import qualified Shelly as S import System.FSNotify.Listener import System.FSNotify.Path (findDirs, canonicalizeDirPath) import System.FSNotify.Types import System.FilePath import qualified System.INotify as INo import System.Posix.Files (getFileStatus, isDirectory, modificationTimeHiRes) type NativeManager = INo.INotify data EventVarietyMismatchException = EventVarietyMismatchException deriving (Show, Typeable) instance Exception EventVarietyMismatchException #if MIN_VERSION_hinotify(0, 3, 10) toRawFilePath :: FilePath -> IO BS.ByteString toRawFilePath fp = do enc <- getFileSystemEncoding F.withCString enc fp BS.packCString fromRawFilePath :: BS.ByteString -> IO FilePath fromRawFilePath bs = do enc <- getFileSystemEncoding BS.useAsCString bs (F.peekCString enc) #else toRawFilePath = return . id fromRawFilePath = return . id #endif fsnEvents :: FilePath -> UTCTime -> INo.Event -> IO [Event] fsnEvents basePath timestamp (INo.Attributes isDir (Just raw)) = fromRawFilePath raw >>= \name -> return [Modified (basePath name) timestamp isDir] fsnEvents basePath timestamp (INo.Modified isDir (Just raw)) = fromRawFilePath raw >>= \name -> return [Modified (basePath name) timestamp isDir] fsnEvents basePath timestamp (INo.Created isDir raw) = fromRawFilePath raw >>= \name -> return [Added (basePath name) timestamp isDir] fsnEvents basePath timestamp (INo.MovedOut isDir raw _cookie) = fromRawFilePath raw >>= \name -> return [Removed (basePath name) timestamp isDir] fsnEvents basePath timestamp (INo.MovedIn isDir raw _cookie) = fromRawFilePath raw >>= \name -> return [Added (basePath name) timestamp isDir] fsnEvents basePath timestamp (INo.Deleted isDir raw) = fromRawFilePath raw >>= \name -> return [Removed (basePath name) timestamp isDir] fsnEvents _ _ (INo.Ignored) = return [] fsnEvents basePath timestamp inoEvent = return [Unknown basePath timestamp (show inoEvent)] handleInoEvent :: ActionPredicate -> EventChannel -> FilePath -> DebouncePayload -> INo.Event -> IO () handleInoEvent actPred chan basePath dbp inoEvent = do currentTime <- getCurrentTime events <- fsnEvents basePath currentTime inoEvent mapM_ (handleEvent actPred chan dbp) events handleEvent :: ActionPredicate -> EventChannel -> DebouncePayload -> Event -> IO () handleEvent actPred chan dbp event = when (actPred event) $ case dbp of (Just (DebounceData epsilon ior)) -> do lastEvent <- readIORef ior unless (debounce epsilon lastEvent event) writeToChan atomicModifyIORef ior (const (event, ())) Nothing -> writeToChan where writeToChan = writeChan chan event varieties :: [INo.EventVariety] varieties = [INo.Create, INo.Delete, INo.MoveIn, INo.MoveOut, INo.Attrib, INo.Modify] instance FileListener INo.INotify where initSession = E.catch (fmap Just INo.initINotify) (\(_ :: IOException) -> return Nothing) killSession = INo.killINotify listen conf iNotify path actPred chan = do path' <- canonicalizeDirPath path dbp <- newDebouncePayload $ confDebounce conf rawPath <- toRawFilePath path' wd <- INo.addWatch iNotify varieties rawPath (handler path' dbp) return $ INo.removeWatch wd where handler :: FilePath -> DebouncePayload -> INo.Event -> IO () handler = handleInoEvent actPred chan listenRecursive conf iNotify initialPath actPred chan = do -- wdVar stores the list of created watch descriptors. We use it to -- cancel the whole recursive listening task. -- -- To avoid a race condition (when a new watch is added right after -- we've stopped listening), we replace the MVar contents with Nothing -- to signify that the listening task is cancelled, and no new watches -- should be added. wdVar <- newMVar (Just []) let stopListening = do modifyMVar_ wdVar $ \mbWds -> do maybe (return ()) (mapM_ (\x -> catch (INo.removeWatch x) (\(_ :: SomeException) -> putStrLn ("Error removing watch: " `mappend` show x)))) mbWds return Nothing listenRec initialPath wdVar return stopListening where listenRec :: FilePath -> MVar (Maybe [INo.WatchDescriptor]) -> IO () listenRec path wdVar = do path' <- canonicalizeDirPath path paths <- findDirs True path' mapM_ (pathHandler wdVar) (path':paths) pathHandler :: MVar (Maybe [INo.WatchDescriptor]) -> FilePath -> IO () pathHandler wdVar filePath = do dbp <- newDebouncePayload $ confDebounce conf rawFilePath <- toRawFilePath filePath modifyMVar_ wdVar $ \mbWds -> -- Atomically add a watch and record its descriptor. Also, check -- if the listening task is cancelled, in which case do nothing. case mbWds of Nothing -> return mbWds Just wds -> do wd <- INo.addWatch iNotify varieties rawFilePath (handler filePath dbp) return $ Just (wd:wds) where handler :: FilePath -> DebouncePayload -> INo.Event -> IO () handler baseDir dbp event = do -- When a new directory is created, add recursive inotify watches to it -- TODO: there's a race condition here; if there are files present in the directory before -- we add the watches, we'll miss them. The right thing to do would be to ls the directory -- and trigger Added events for everything we find there case event of (INo.Created True rawDirPath) -> do dirPath <- fromRawFilePath rawDirPath let newDir = baseDir dirPath timestampBeforeAddingWatch <- getPOSIXTime listenRec newDir wdVar -- Find all files/folders that might have been created *after* the timestamp, and hence might have been -- missed by the watch -- TODO: there's a chance of this generating double events, fix files <- S.shelly $ S.find (fromString newDir) forM_ files $ \file -> do let newPath = T.unpack $ S.toTextIgnore file fileStatus <- getFileStatus newPath let modTime = modificationTimeHiRes fileStatus when (modTime > timestampBeforeAddingWatch) $ do handleEvent actPred chan dbp (Added (newDir newPath) (posixSecondsToUTCTime timestampBeforeAddingWatch) (isDirectory fileStatus)) _ -> return () -- Remove watch when this directory is removed case event of (INo.DeletedSelf) -> do -- putStrLn "Watched file/folder was deleted! TODO: remove watch." return () (INo.Ignored) -> do -- putStrLn "Watched file/folder was ignored, which possibly means it was deleted. TODO: remove watch." return () _ -> return () -- Forward all events, including directory create handleInoEvent actPred chan baseDir dbp event usesPolling = const False fsnotify-0.3.0.1/src/System/FSNotify/Win32.hs0000644000000000000000000000762313303132002016705 0ustar0000000000000000-- -- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org -- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org -- {-# OPTIONS_GHC -fno-warn-orphans #-} module System.FSNotify.Win32 ( FileListener(..) , NativeManager ) where import Control.Concurrent import Control.Monad (when) import Data.Bits import Data.IORef (atomicModifyIORef, readIORef) import qualified Data.Map as Map import Data.Time (getCurrentTime, UTCTime) import Prelude 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 :: Bool -> BaseDir -> UTCTime -> WNo.Event -> Event fsnEvent isDirectory basedir timestamp (WNo.Created name) = Added (normalise (basedir name)) timestamp isDirectory fsnEvent isDirectory basedir timestamp (WNo.Modified name) = Modified (normalise (basedir name)) timestamp isDirectory fsnEvent isDirectory basedir timestamp (WNo.Deleted name) = Removed (normalise (basedir name)) timestamp isDirectory handleWNoEvent :: Bool -> BaseDir -> ActionPredicate -> EventChannel -> DebouncePayload -> WNo.Event -> IO () handleWNoEvent isDirectory basedir actPred chan dbp inoEvent = do currentTime <- getCurrentTime let event = fsnEvent isDirectory basedir currentTime inoEvent handleEvent actPred chan dbp event handleEvent :: ActionPredicate -> EventChannel -> DebouncePayload -> Event -> IO () handleEvent actPred chan dbp event | actPred event = do case dbp of (Just (DebounceData epsilon ior)) -> do lastEvent <- readIORef ior when (not $ debounce epsilon lastEvent event) $ writeChan chan event atomicModifyIORef ior (\_ -> (event, ())) Nothing -> writeChan chan event handleEvent _ _ _ _ = return () watchDirectory :: Bool -> WatchConfig -> WNo.WatchManager -> FilePath -> ActionPredicate -> EventChannel -> IO (IO ()) watchDirectory isRecursive conf watchManager@(WNo.WatchManager mvarMap) path actPred chan = do path' <- canonicalizeDirPath path dbp <- newDebouncePayload $ confDebounce conf let fileFlags = foldl (.|.) 0 [WNo.fILE_NOTIFY_CHANGE_FILE_NAME, WNo.fILE_NOTIFY_CHANGE_SIZE, WNo.fILE_NOTIFY_CHANGE_ATTRIBUTES] let dirFlags = foldl (.|.) 0 [WNo.fILE_NOTIFY_CHANGE_DIR_NAME] -- Start one watch for file events and one for directory events -- (There seems to be no other way to provide isDirectory information) wid1 <- WNo.watchDirectory watchManager path' isRecursive fileFlags (handleWNoEvent False path' actPred chan dbp) wid2 <- WNo.watchDirectory watchManager path' isRecursive dirFlags (handleWNoEvent True path' actPred chan dbp) -- The StopListening action should make sure to remove the watches from the manager after they're killed. -- Otherwise, a call to killSession would cause us to try to kill them again, resulting in an invalid handle error. return $ do WNo.killWatch wid1 modifyMVar_ mvarMap $ \watchMap -> return (Map.delete wid1 watchMap) WNo.killWatch wid2 modifyMVar_ mvarMap $ \watchMap -> return (Map.delete wid2 watchMap) instance FileListener WNo.WatchManager where -- TODO: This should actually lookup a Windows API version and possibly return -- Nothing the calls we need are not available. This will require that API -- version information be exposed by Win32-notify. initSession = fmap Just WNo.initWatchManager killSession = WNo.killWatchManager listen = watchDirectory False listenRecursive = watchDirectory True usesPolling = const False fsnotify-0.3.0.1/win-src/System/Win32/FileNotify.hsc0000644000000000000000000001374713303345155020235 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.3.0.1/win-src/System/Win32/Notify.hs0000644000000000000000000000754713303345155017273 0ustar0000000000000000 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.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 (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 () closeHandle handle 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.3.0.1/src/System/FSNotify/OSX.hs0000644000000000000000000001534413303132002016453 0ustar0000000000000000-- -- Copyright (c) 2012 Mark Dittmer - http://www.markdittmer.org -- Developed for a Google Summer of Code project - http://gsoc2012.markdittmer.org -- {-# LANGUAGE MultiWayIf #-} module System.FSNotify.OSX ( FileListener(..) , NativeManager ) where import Control.Concurrent.Chan import Control.Concurrent.MVar import Control.Monad import Data.Bits import Data.IORef (atomicModifyIORef, readIORef) import Data.Map (Map) import qualified Data.Map as Map import Data.Time.Clock (UTCTime, getCurrentTime) import Data.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 EventChannel 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 && 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 = hasFlag e FSE.eventFlagItemIsDir isFile = hasFlag e FSE.eventFlagItemIsFile isCreated = hasFlag e FSE.eventFlagItemCreated isRenamed = hasFlag e FSE.eventFlagItemRenamed isModified = hasFlag e FSE.eventFlagItemModified || hasFlag e FSE.eventFlagItemInodeMetaMod path = canonicalEventPath hasFlag event flag = FSE.eventFlags event .&. flag /= 0 handleEvent :: Bool -> ActionPredicate -> EventChannel -> FilePath -> DebouncePayload -> FSE.Event -> IO () handleEvent isRecursive actPred chan dirPath dbp fseEvent = do currentTime <- getCurrentTime events <- fsnEvents currentTime fseEvent handleEvents isRecursive actPred chan dirPath dbp events -- | For non-recursive monitoring, test if an event takes place directly inside the monitored folder isDirectlyInside :: FilePath -> Event -> Bool isDirectlyInside dirPath event = isRelevantFileEvent || isRelevantDirEvent where isRelevantFileEvent = (not $ eventIsDirectory event) && (takeDirectory dirPath == (takeDirectory $ eventPath event)) isRelevantDirEvent = eventIsDirectory event && (takeDirectory dirPath == (takeDirectory $ takeDirectory $ eventPath event)) handleEvents :: Bool -> ActionPredicate -> EventChannel -> FilePath -> DebouncePayload -> [Event] -> IO () handleEvents isRecursive actPred chan dirPath dbp (event:events) = do when (actPred event && (isRecursive || (isDirectlyInside dirPath event))) $ case dbp of (Just (DebounceData epsilon ior)) -> do lastEvent <- readIORef ior when (not $ debounce epsilon lastEvent event) (writeChan chan event) atomicModifyIORef ior (\_ -> (event, ())) Nothing -> writeChan chan event handleEvents isRecursive actPred chan dirPath dbp events handleEvents _ _ _ _ _ [] = return () listenFn :: (ActionPredicate -> EventChannel -> FilePath -> DebouncePayload -> FSE.Event -> IO a) -> WatchConfig -> OSXManager -> FilePath -> ActionPredicate -> EventChannel -> IO StopListening listenFn handler conf (OSXManager mvarMap) path actPred chan = do path' <- canonicalizeDirPath path dbp <- newDebouncePayload $ confDebounce conf unique <- newUnique eventStream <- FSE.eventStreamCreate [path'] 0.0 True False True (handler actPred chan path' dbp) modifyMVar_ mvarMap $ \watchMap -> return (Map.insert unique (WatchData eventStream chan) watchMap) return $ do FSE.eventStreamDestroy eventStream modifyMVar_ mvarMap $ \watchMap -> return $ Map.delete unique watchMap instance FileListener OSXManager where initSession = do (v1, v2, _) <- FSE.osVersion if not $ v1 > 10 || (v1 == 10 && v2 > 6) then return Nothing else fmap (Just . 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 $ handleEvent False listenRecursive = listenFn $ handleEvent True usesPolling = const False fsnotify-0.3.0.1/test/Test.hs0000644000000000000000000001203313303132002014114 0ustar0000000000000000{-# LANGUAGE CPP, OverloadedStrings, ImplicitParams, MultiWayIf #-} import Control.Concurrent import Control.Exception import Control.Monad import Data.Monoid import Prelude hiding (FilePath) import System.Directory import System.FSNotify import System.FilePath import System.IO import System.IO.Temp import System.PosixCompat.Files import System.Random as R import Test.Tasty import Test.Tasty.HUnit import EventUtils #ifdef mingw32_HOST_OS import Data.Bits import System.Win32.File (getFileAttributes, setFileAttributes, fILE_ATTRIBUTE_TEMPORARY) -- Perturb the file's attributes, to check that a modification event is emitted changeFileAttributes :: FilePath -> IO () changeFileAttributes file = do attrs <- getFileAttributes file setFileAttributes file (attrs `xor` fILE_ATTRIBUTE_TEMPORARY) #else changeFileAttributes :: FilePath -> IO () changeFileAttributes = touchFile #endif isMac :: Bool #ifdef darwin_HOST_OS isMac = True #else isMac = False #endif nativeMgrSupported :: IO Bool nativeMgrSupported = do mgr <- startManager stopManager mgr return $ not $ isPollingManager mgr main :: IO () main = do hasNative <- nativeMgrSupported unless hasNative $ putStrLn "WARNING: native manager cannot be used or tested on this platform" defaultMain $ withResource (createDirectoryIfMissing True testDirPath) (const $ removeDirectoryRecursive testDirPath) (const $ tests hasNative) -- | There's some kind of race in OS X where the creation of the containing directory shows up as an event -- I explored whether this was due to passing 0 as the sinceWhen argument to FSEventStreamCreate -- in the hfsevents package, but changing that didn't seem to help pauseBeforeStartingTest :: IO () pauseBeforeStartingTest = threadDelay 10000 tests :: Bool -> TestTree tests hasNative = testGroup "Tests" $ do poll <- if hasNative then [False, True] else [True] let ?timeInterval = if poll then 2*10^(6 :: Int) else 5*10^(5 :: Int) return $ testGroup (if poll then "Polling" else "Native") $ do recursive <- [False, True] return $ testGroup (if recursive then "Recursive" else "Non-recursive") $ do nested <- [False, True] return $ testGroup (if nested then "In a subdirectory" else "Right here") $ do t <- [ mkTest "new file" (if | isMac && not poll -> [evAddedOrModified False] | otherwise -> [evAdded False]) (const $ return ()) (\f -> openFile f AppendMode >>= hClose) , mkTest "modify file" [evModified False] (\f -> writeFile f "") (\f -> appendFile f "foo") -- This test is disabled when polling because the PollManager only keeps track of -- modification time, so it won't catch an unrelated file attribute change , mkTest "modify file attributes" (if poll then [] else [evModified False]) (\f -> writeFile f "") (\f -> if poll then return () else changeFileAttributes f) , mkTest "delete file" [evRemoved False] (\f -> writeFile f "") (\f -> removeFile f) , mkTest "new directory" (if | isMac -> [evAddedOrModified True] | otherwise -> [evAdded True]) (const $ return ()) createDirectory , mkTest "delete directory" [evRemoved True] (\f -> createDirectory f) removeDirectory ] return $ t nested recursive poll mkTest :: (?timeInterval::Int) => TestName -> [FilePath -> EventPattern] -> (FilePath -> IO a) -> (FilePath -> IO ()) -> Bool -> Bool -> Bool -> TestTree mkTest title evs prepare action nested recursive poll = do testCase title $ do -- Use a random identifier so that every test happens in a different folder -- This is unfortunately necessary because of the madness of OS X FSEvents; see the comments in OSX.hs randomID <- replicateM 10 $ R.randomRIO ('a', 'z') let pollDelay = when poll (threadDelay $ 10^(6 :: Int)) withTempDirectory testDirPath ("test." <> randomID) $ \watchedDir -> do let fileName = "testfile" let baseDir = if nested then watchedDir "subdir" else watchedDir f = normalise $ baseDir fileName watchFn = if recursive then watchTree else watchDir expect = expectEvents poll watchFn watchedDir createDirectoryIfMissing True baseDir pauseBeforeStartingTest flip finally (doesFileExist f >>= flip when (removeFile f)) $ do _ <- prepare f pauseBeforeStartingTest flip expect (pollDelay >> action f) (if | nested && (not recursive) -> [] | otherwise -> [ev f | ev <- evs]) fsnotify-0.3.0.1/test/EventUtils.hs0000644000000000000000000000723213303132002015304 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, ImplicitParams #-} module EventUtils where import Control.Applicative import Control.Concurrent import Control.Concurrent.Async hiding (poll) import Control.Monad import Data.IORef import Data.List (sortBy) import Data.Monoid import Data.Ord (comparing) import Prelude hiding (FilePath) import System.Directory import System.FSNotify import System.FilePath import System.IO.Unsafe import Test.Tasty.HUnit import Text.Printf delay :: (?timeInterval :: Int) => IO () delay = threadDelay ?timeInterval -- event patterns data EventPattern = EventPattern { patFile :: FilePath , patName :: String , patPredicate :: Event -> Bool } evAdded, evRemoved, evModified, evAddedOrModified :: Bool -> FilePath -> EventPattern evAdded isDirectory path = EventPattern path "Added" (\x -> case x of Added path' _ isDir | isDirectory == isDir -> pathMatches isDirectory path path' _ -> False ) evRemoved isDirectory path = EventPattern path "Removed" (\x -> case x of Removed path' _ isDir | isDirectory == isDir -> pathMatches isDirectory path path' _ -> False ) evModified isDirectory path = EventPattern path "Modified" (\x -> case x of Modified path' _ isDir | isDirectory == isDir -> pathMatches isDirectory path path' _ -> False ) evAddedOrModified isDirectory path = EventPattern path "AddedOrModified" (\x -> case x of Added path' _ isDir | isDirectory == isDir -> pathMatches isDirectory path path' Modified path' _ isDir | isDirectory == isDir -> pathMatches isDirectory path path' _ -> False ) pathMatches True path path' = path == path' || (path <> [pathSeparator]) == path' pathMatches False path path' = path == path' matchEvents :: [EventPattern] -> [Event] -> Assertion matchEvents expected actual = do unless (length expected == length actual) $ assertFailure $ printf "Unexpected number of events.\n Expected: %s\n Actual: %s\n" (show expected) (show actual) sequence_ $ (\f -> zipWith f expected actual) $ \pat ev -> assertBool (printf "Unexpected event.\n Expected: %s\n Actual: %s\n" (show expected) (show actual)) (patPredicate pat ev) instance Show EventPattern where show p = printf "%s %s" (patName p) (show $ patFile p) gatherEvents :: (?timeInterval :: Int) => Bool -- use polling? -> (WatchManager -> FilePath -> ActionPredicate -> Action -> IO StopListening) -- (^ this is the type of watchDir/watchTree) -> FilePath -> IO (Async [Event]) gatherEvents poll watch path = do mgr <- startManagerConf defaultConfig { confDebounce = NoDebounce , confUsePolling = poll , confPollInterval = 2 * 10^(5 :: Int) } eventsVar <- newIORef [] stop <- watch mgr path (const True) (\ev -> atomicModifyIORef eventsVar (\evs -> (ev:evs, ()))) async $ do delay stop reverse <$> readIORef eventsVar expectEvents :: (?timeInterval :: Int) => Bool -> (WatchManager -> FilePath -> ActionPredicate -> Action -> IO StopListening) -> FilePath -> [EventPattern] -> IO () -> Assertion expectEvents poll w path pats action = do a <- gatherEvents poll w path action evs <- wait a matchEvents pats $ sortBy (comparing eventTime) evs testDirPath :: FilePath testDirPath = (unsafePerformIO getCurrentDirectory) "testdir" expectEventsHere :: (?timeInterval::Int) => Bool -> [EventPattern] -> IO () -> Assertion expectEventsHere poll = expectEvents poll watchDir testDirPath expectEventsHereRec :: (?timeInterval::Int) => Bool -> [EventPattern] -> IO () -> Assertion expectEventsHereRec poll = expectEvents poll watchTree testDirPath fsnotify-0.3.0.1/LICENSE0000644000000000000000000000276213303132002012677 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.3.0.1/Setup.hs0000644000000000000000000000031413303132002013315 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.3.0.1/fsnotify.cabal0000644000000000000000000000552413303345155014535 0ustar0000000000000000Name: fsnotify Version: 0.3.0.1 Author: Mark Dittmer , Niklas Broberg Maintainer: Tom McLaughlin License: BSD3 License-File: LICENSE Synopsis: Cross platform library for file change notification. Description: Cross platform library for file creation, modification, and deletion notification. This library builds upon existing libraries for platform-specific Windows, Mac, and Linux filesystem event notification. Category: Filesystem Cabal-Version: >= 1.8 Build-Type: Simple Homepage: https://github.com/haskell-fswatch/hfsnotify Extra-Source-Files: README.md CHANGELOG.md test/Test.hs test/EventUtils.hs Library Build-Depends: base >= 4.3.1 && < 5 , bytestring >= 0.10.2 , containers >= 0.4 , directory >= 1.1.0.0 , filepath >= 1.3.0.0 , text >= 0.11.0 , time >= 1.1 , async >= 2.0.1 , unix-compat >= 0.2 Exposed-Modules: System.FSNotify , System.FSNotify.Devel Other-Modules: System.FSNotify.Listener , System.FSNotify.Path , System.FSNotify.Polling , System.FSNotify.Types Hs-Source-Dirs: src GHC-Options: -Wall if os(linux) CPP-Options: -DOS_Linux Other-Modules: System.FSNotify.Linux Build-Depends: hinotify >= 0.3.0, shelly >= 1.6.5, unix >= 2.7.1.0 else if os(windows) CPP-Options: -DOS_Win32 Other-Modules: System.FSNotify.Win32 , System.Win32.FileNotify , System.Win32.Notify Build-Depends: Win32 Hs-Source-Dirs: win-src else if os(darwin) CPP-Options: -DOS_Mac Other-Modules: System.FSNotify.OSX Build-Depends: hfsevents >= 0.1.3 Test-Suite test Type: exitcode-stdio-1.0 Main-Is: Test.hs Other-modules: EventUtils Hs-Source-Dirs: test GHC-Options: -Wall -threaded if os(windows) Build-Depends: base >= 4.3.1.0, tasty >= 0.5, tasty-hunit, directory, filepath, unix-compat, fsnotify, async >= 2, temporary, random, Win32 else Build-Depends: base >= 4.3.1.0, tasty >= 0.5, tasty-hunit, directory, filepath, unix-compat, fsnotify, async >= 2, temporary, random Source-Repository head Type: git Location: git://github.com/haskell-fswatch/hfsnotify fsnotify-0.3.0.1/README.md0000644000000000000000000000114713303345155013164 0ustar0000000000000000hfsnotify [![Linux and Mac build Status](https://travis-ci.org/haskell-fswatch/hfsnotify.svg)](https://travis-ci.org/haskell-fswatch/hfsnotify) [![Windows build status](https://ci.appveyor.com/api/projects/status/7h1msaokgpqo0q42?svg=true)](https://ci.appveyor.com/project/thomasjm/hfsnotify-v2smx) ========= 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.3.0.1/CHANGELOG.md0000644000000000000000000000374513303147041013516 0ustar0000000000000000Changes ======= 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.