diff --git a/delta.cabal b/delta.cabal --- a/delta.cabal +++ b/delta.cabal @@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.1.2.0 +version: 0.2.0.0 -- A short (one-line) description of the package. synopsis: A library for detecting file changes @@ -51,11 +51,15 @@ -- extra-source-files: -- Constraint on the version of Cabal needed to build this package. -cabal-version: >= 1.18 +cabal-version: >= 1.16 +flag build_fs_events + description: Build in FSEvents support (OS X) + default: True + source-repository head type: git - location: https://github.com/kryoxide/delta/ + location: https://github.com/kryoxide/delta.git library -- Modules exported by the library. @@ -64,6 +68,10 @@ , System.Delta.Callback , System.Delta.Class , System.Delta + + if os(darwin) + exposed-modules: System.Delta.FSEvents + -- Modules included in this library but not exported. -- other-modules: @@ -77,7 +85,9 @@ , filepath >= 1.3 , time >= 1.5 , sodium >= 0.11 - + if os(darwin) + build-depends: hfsevents >= 0.1.5 + -- Directories containing source files. hs-source-dirs: src diff --git a/src/System/Delta.hs b/src/System/Delta.hs --- a/src/System/Delta.hs +++ b/src/System/Delta.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RankNTypes, CPP #-} -------------------------------------------------------------------------------- -- | -- Module : System.Delta @@ -13,9 +13,13 @@ -- An umberella package for the delta library. This library can be used to monitor -- changed / new / deleted files in a given directory (or set of directories). -- --- Currently this library polls the directories of interest recursively in certain --- intervals, but I will add OS-specific functionality to monitor the filesystem. +-- On non OS X systems this library polls the directories of interest +-- recursively in certain intervals, but I will add OS-specific functionality to +-- monitor the filesystem. -- +-- On OS X this library can use the File System Events API to detect changes +-- without recursive directory traversal. +-- -- = Examples -- -- Create a watcher that prints a line if a new file is created in the monitored @@ -35,11 +39,9 @@ , deltaDirWithCallbacks -- * FRP based interface - , module System.Delta.Class , FileWatcher(..) -- * Callback based interface - , module System.Delta.Callback , CallbackWatcher , CallbackId , withCallbacks @@ -50,18 +52,31 @@ -- ** Removing callbacks , unregisterCallback , removeAllCallbacks - , closeCallbackWatcher + , closeCallbackWatcher )where import System.Delta.Base -import System.Delta.Poll import System.Delta.Class import System.Delta.Callback +import System.Delta.Poll +#if defined(__APPLE__) +import System.Delta.FSEvents +#endif --- | Build a file watcher, this method will change later -deltaDir :: FilePath -> IO PollWatcher -deltaDir path = defaultWatcher path +-- | Build a file watcher, the concrete implementation is operating system +-- dependent. +-- +-- * The default uses polling ('createPollWatcher') +-- +-- * The watcher for OS X uses the FS Events API 'createFSEventsWatcher' +deltaDir :: FilePath -> IO FileWatcher +deltaDir path = do +#if defined(__APPLE__) + createFSEventsWatcher path +#else + createPollWatcher 10 path +#endif -- | Build a file watcher that allows to register callbacks -deltaDirWithCallbacks :: FilePath -> IO (CallbackWatcher PollWatcher) +deltaDirWithCallbacks :: FilePath -> IO CallbackWatcher deltaDirWithCallbacks path = deltaDir path >>= withCallbacks diff --git a/src/System/Delta/Callback.hs b/src/System/Delta/Callback.hs --- a/src/System/Delta/Callback.hs +++ b/src/System/Delta/Callback.hs @@ -31,23 +31,23 @@ deriving (Eq, Ord) -- | Provides a callback based interface to an FRP base 'FileWatcher' -data CallbackWatcher w where - CallbackWatcher :: FileWatcher w => { - baseWatcher :: w +data CallbackWatcher where + CallbackWatcher :: { + baseWatcher :: FileWatcher , nextCallbackId :: MVar CallbackId , watcherCallbacks :: MVar (M.Map CallbackId (IO ())) - } -> CallbackWatcher w + } -> CallbackWatcher -- | Raise the callback id of a callback watcher -raiseId :: CallbackWatcher w -> IO (CallbackId) +raiseId :: CallbackWatcher -> IO (CallbackId) raiseId w = do (CallbackId n) <- takeMVar $ nextCallbackId w putMVar (nextCallbackId w) (CallbackId $ n+1) return (CallbackId n) -- | Add an action to unregister a callback -addCallbackUnregister :: CallbackWatcher w -> IO () -> IO CallbackId +addCallbackUnregister :: CallbackWatcher -> IO () -> IO CallbackId addCallbackUnregister w removeCallback = do newId <- raiseId w mp <- takeMVar $ watcherCallbacks w @@ -55,42 +55,39 @@ return newId -- | Wrap a file watcher in a datatype that allows adding callbacks -withCallbacks :: (FileWatcher a) => a -> IO (CallbackWatcher a) +withCallbacks :: FileWatcher -> IO CallbackWatcher withCallbacks w = do nextIdVar <- newMVar (CallbackId 0) callbacks <- newMVar (M.empty) return $ CallbackWatcher w nextIdVar callbacks -- | Add a callback that is executed when file deletion is detected -withDeleteCallback :: (FileWatcher a) - => CallbackWatcher a - -> (FilePath -> IO ()) -- ^ An IO action on the deleted path - -> IO (CallbackId) +withDeleteCallback :: CallbackWatcher + -> (FilePath -> IO ()) -- ^ An IO action on the deleted path + -> IO (CallbackId) withDeleteCallback watcher action = do unregisterCallback <- callbackOnEvent (deletedFiles $ baseWatcher watcher) action addCallbackUnregister watcher unregisterCallback -- | Add a callback that is executed when file creation is detected -withNewCallback :: (FileWatcher a) - => CallbackWatcher a - -> (FilePath -> IO ()) -- ^ An IO action on the new path - -> IO (CallbackId) +withNewCallback :: CallbackWatcher + -> (FilePath -> IO ()) -- ^ An IO action on the new path + -> IO (CallbackId) withNewCallback watcher action = do unregisterCallback <- callbackOnEvent (newFiles $ baseWatcher watcher) action addCallbackUnregister watcher unregisterCallback -- | Add a callback on a changed file -withChangedCallback :: (FileWatcher a) - => CallbackWatcher a - -> (FileInfo -> IO ()) -- ^ Action on changed file - -> IO (CallbackId) +withChangedCallback :: CallbackWatcher + -> (FilePath -> IO ()) -- ^ Action on changed file + -> IO (CallbackId) withChangedCallback watcher action = do unregisterCallback <- callbackOnEvent (changedFiles $ baseWatcher watcher) action addCallbackUnregister watcher unregisterCallback -- | Unregister the given CallbackId from the FileWatcher -- does nothing if the CallbackId is not in the watcher -unregisterCallback :: (FileWatcher a) => CallbackWatcher a -> CallbackId -> IO () +unregisterCallback :: CallbackWatcher -> CallbackId -> IO () unregisterCallback watcher cId = do mp <- takeMVar $ watcherCallbacks watcher case M.lookup cId mp of @@ -99,14 +96,14 @@ putMVar (watcherCallbacks watcher) (M.delete cId mp) -- | Remove all callbacks form the watcher. They will not be called after this -removeAllCallbacks :: (FileWatcher a) => CallbackWatcher a -> IO () +removeAllCallbacks :: CallbackWatcher -> IO () removeAllCallbacks watcher = do mp <- takeMVar $ watcherCallbacks watcher putMVar (watcherCallbacks watcher) M.empty sequence_ (M.elems mp) -- | Remove all callbacks and close the underlying FileWatcher -closeCallbackWatcher :: FileWatcher a => CallbackWatcher a -> IO () +closeCallbackWatcher :: CallbackWatcher -> IO () closeCallbackWatcher watcher = do removeAllCallbacks watcher cleanUpAndClose $ baseWatcher watcher diff --git a/src/System/Delta/Class.hs b/src/System/Delta/Class.hs --- a/src/System/Delta/Class.hs +++ b/src/System/Delta/Class.hs @@ -5,39 +5,28 @@ import Control.Monad --- | A class for watching a directory based on functional reactive programming +-- | A type for watching a directory based on functional reactive programming -- At the core of this class are three event streams: -- --- * @changedFiles@ is a stream of 'FileInfo's on changed files +-- * @changedFiles@ is a stream of canonicalized 'FilePath's on changed files -- -- * @newFiles@ is a stream of canonicalized 'FilePath's of newly created files -- -- * @deletedFiles@ is a stream of canonicalized 'FilePath's of deleted files -class FileWatcher a where - -- | Each type provides a default watcher for a pass - defaultWatcher :: FilePath -> IO a - - -- | An event that gives some info on changed files (disjunct from - -- deleted and new files) - changedFiles :: a -> Event FileInfo - - -- | An event that fires for each new file - newFiles :: a -> Event FilePath - - -- | An event that fires for each deleted path - deletedFiles :: a -> Event FilePath - - -- | Free all possibly used resources. No event will fire after - -- this. - cleanUpAndClose :: a -> IO () - - -- | Merge two watchers that are watching different directories - mergeWatchers :: a -> a -> a +data FileWatcher = + FileWatcher { newFiles :: Event FilePath -- ^ Newly created files, renamed + -- files + , deletedFiles :: Event FilePath -- ^ Deleted files, renamed files + , changedFiles :: Event FilePath -- ^ Changed files + , cleanUpAndClose :: IO () -- ^ A function to clean and close + -- ^ this watcher + } +-- | Merge two watchers that are watching different directories +mergeWatchers :: FileWatcher -> FileWatcher -> FileWatcher +mergeWatchers w1 w2 = FileWatcher{ + newFiles = (newFiles w1) `merge` (newFiles w2) + , deletedFiles = (deletedFiles w1) `merge` (deletedFiles w2) + , changedFiles = (changedFiles w1) `merge` (changedFiles w2) + , cleanUpAndClose = cleanUpAndClose w1 >> cleanUpAndClose w2 + } - -- | Create a watcher on all of the given paths - watchPaths :: (FileWatcher a) => [FilePath] -> Maybe (IO a) - watchPaths [] = Nothing - watchPaths paths = Just $ do - watchers <- mapM defaultWatcher paths - let combinedWatcher = foldl1 mergeWatchers watchers - return $ combinedWatcher diff --git a/src/System/Delta/FSEvents.hs b/src/System/Delta/FSEvents.hs new file mode 100644 --- /dev/null +++ b/src/System/Delta/FSEvents.hs @@ -0,0 +1,55 @@ +-------------------------------------------------------------------------------- +-- | +-- Module: System.Delta.FSEvents +-- +-- Uses the FSEvents API on MacOS to detect file changes. + +-------------------------------------------------------------------------------- +module System.Delta.FSEvents ( createFSEventsWatcher + ) where + +import Control.Monad + +import Data.Bits +import Data.Word + +import qualified FRP.Sodium as Sodium +import FRP.Sodium (sync,merge) + +import System.Delta.Class +import System.OSX.FSEvents + +-- | Helper Method +(=<=) :: Event -> Word64 -> Bool +(Event{eventFlags=fls}) =<= flags = 0 < (fls .&. flags) + +itemIsFile :: Event -> Bool +itemIsFile e = e =<= eventFlagItemIsFile + +itemIsDir :: Event -> Bool +itemIsDir = (=<= eventFlagItemIsDir) + +itemIsCreated :: Event -> Bool +itemIsCreated = (=<= eventFlagItemCreated) + +itemIsRemoved :: Event -> Bool +itemIsRemoved = (=<= eventFlagItemRemoved) + +itemIsChanged :: Event -> Bool +itemIsChanged = (=<= eventFlagItemModified) + +createFSEventsWatcher path = do + (changedEvent, pushChanged) <- sync $ Sodium.newEvent + (deletedEvent, pushDeleted) <- sync $ Sodium.newEvent + (newFileEvent, pushNewFile) <- sync $ Sodium.newEvent + let callback = \e -> + when (itemIsFile e) $ do + when (itemIsCreated e) (sync $ pushNewFile $ eventPath e) + when (itemIsRemoved e) (sync $ pushDeleted $ eventPath e) + when (itemIsChanged e) (sync $ pushChanged $ eventPath e) + evStream <- eventStreamCreate [path] 1 False False True callback + return $ FileWatcher + newFileEvent + deletedEvent + changedEvent + (eventStreamDestroy evStream) diff --git a/src/System/Delta/Poll.hs b/src/System/Delta/Poll.hs --- a/src/System/Delta/Poll.hs +++ b/src/System/Delta/Poll.hs @@ -1,6 +1,5 @@ -module System.Delta.Poll ( PollWatcher - , createPollWatcher - )where +module System.Delta.Poll ( createPollWatcher + ) where import Control.Applicative ((<$>)) import Control.Concurrent @@ -19,40 +18,18 @@ import Data.List (isPrefixOf) -data PollWatcher = PollWatcher - [FilePath] - (Event FileInfo) - (Event FilePath) - (Event FilePath) - [ThreadId] - -instance FileWatcher PollWatcher where - defaultWatcher = createPollWatcher 3 - changedFiles (PollWatcher _ e _ _ _) = e - newFiles (PollWatcher _ _ e _ _) = e - deletedFiles (PollWatcher _ _ _ e _) = e - cleanUpAndClose (PollWatcher _ _ _ _ tIds) = mapM_ killThread tIds - mergeWatchers (PollWatcher pA cA nA dA idsA) (PollWatcher pB cB nB dB idsB) = - PollWatcher - (pA ++ pB) - (merge cA cB) - (merge nA nB) - (merge dA dB) - (idsA ++ idsB) - - -- | Watch files in this directory recursively for changes every -- n seconds. createPollWatcher :: Int -- ^ seconds interval -> FilePath -- ^ path to watch - -> IO PollWatcher + -> IO FileWatcher createPollWatcher secs path = do (changedEvent, pushChanged) <- sync $ newEvent (deletedEvent, pushDeleted) <- sync $ newEvent (newFileEvent, pushNewFile) <- sync $ newEvent canonPath <- canonicalizePath path watcherId <- startWatchThread canonPath pushNewFile pushDeleted pushChanged secs - return $ PollWatcher [canonPath] changedEvent newFileEvent deletedEvent [watcherId] + return $ FileWatcher newFileEvent deletedEvent changedEvent (killThread watcherId) -- | Recursively traverse a folder, follow symbolic links but don't -- visit a file twice. @@ -107,7 +84,7 @@ startWatchThread :: FilePath -> (FilePath -> Reactive ()) -- ^ Push new files / dirs -> (FilePath -> Reactive ()) -- ^ Push deleted files / dirs - -> (FileInfo -> Reactive ()) -- ^ Push changed files / dirs + -> (FilePath -> Reactive ()) -- ^ Push changed files / dirs -> Int -- ^ Seconds between polls -> IO ThreadId startWatchThread path pushNew pushDeleted pushChanged secs = do @@ -117,7 +94,7 @@ go last = do threadDelay $ secs * 1000 * 1000 curr <- recursiveDescent path - sync $ mapM_ (pushChanged) (diffChangedFiles last curr) + sync $ mapM_ (pushChanged) (fileInfoPath <$> diffChangedFiles last curr) sync $ mapM_ (pushNew ) (fileInfoPath <$> diffNewFiles last curr) sync $ mapM_ (pushDeleted) (fileInfoPath <$> diffDeletedFiles last curr) go curr diff --git a/src/delta-cli/Main.hs b/src/delta-cli/Main.hs --- a/src/delta-cli/Main.hs +++ b/src/delta-cli/Main.hs @@ -13,7 +13,7 @@ watcher <- deltaDirWithCallbacks path withNewCallback watcher (\x -> putStrLn $ "new:\t" ++ x) withDeleteCallback watcher (\x -> putStrLn $ "del:\t" ++ x) - withChangedCallback watcher (\(FileInfo(x,_,_)) -> + withChangedCallback watcher (\x -> putStrLn $ "changed:\t" ++ x ) forever $ threadDelay (1000 * 1000)