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.2.1.1 +version: 0.2.1.2 -- A short (one-line) description of the package. synopsis: A library for detecting file changes @@ -19,12 +19,38 @@ description: Delta is a library for detecting file changes in any given directory. The package is written using the sodium FRP library but it also provides a callback based API. - + . + File changes on OS X are based on the @FSEvents@ API that is also + used by TimeMachine. On other operating systems the library + currently uses recursive descents in directories. I will include + @inotify@ for Linux. If someone would like to have a non-polling + based API for windows or BSD, I would really like it if anyone + would contribute. + . The project also contains an executable, delta-run, which allows you to run arbitrary shell commands when a file in a - directory (recursively) changes. + directory (recursively) changes. + . + @ + $> delta-run --help + Usage: delta-run [-i|--interval INTERVAL] [-v|--verbose] FILE CMD + Available options: + -h,--help Show this help text + -i,--interval INTERVAL Run at most every n seconds + -v,--verbose Print extra output + FILE The directory that is watched + CMD The command to run + @ + . + For example you could use @delta-run@ to rebuild your project + everytime the source changes like this: + @ + delta-run ./src "cabal build" + @ + + -- URL for the project homepage or repository. homepage: https://github.com/kryoxide/delta @@ -72,7 +98,7 @@ , System.Delta.FRPUtils , System.Delta - if (os(darwin) && flag(build_fs_events)) + if os(darwin) && flag(build_fs_events) exposed-modules: System.Delta.FSEvents -- Modules included in this library but not exported. @@ -89,11 +115,11 @@ , time >= 1.5 , sodium >= 0.11 - if (os(darwin) && flag(build_fs_events)) + if os(darwin) && flag(build_fs_events) build-depends: hfsevents >= 0.1.5 -- Directories containing source files. - hs-source-dirs: src + hs-source-dirs: src/main/delta/ -- Base language which the package is written in. default-language: Haskell2010 @@ -103,7 +129,7 @@ build-depends: base >= 4.6 && < 4.9 , delta - hs-source-dirs: src/delta-cli + hs-source-dirs: src/main/delta-cli main-is: Main.hs @@ -118,10 +144,26 @@ , process >= 1.2 , sodium >= 0.11 - hs-source-dirs: src/delta-run + hs-source-dirs: src/main/delta-run main-is: Main.hs default-language: Haskell2010 ghc-options: -threaded -rtsopts -with-rtsopts=-N + +test-suite tests + + build-depends: base >= 4.6 && < 4.9 + , delta + , hspec >= 1.9 + , filepath >= 1.3 + , directory >= 1.2 + + hs-source-dirs: src/test + + main-is: Main.hs + + default-language: Haskell2010 + + type: exitcode-stdio-1.0 diff --git a/src/System/Delta.hs b/src/System/Delta.hs deleted file mode 100644 --- a/src/System/Delta.hs +++ /dev/null @@ -1,82 +0,0 @@ -{-# LANGUAGE RankNTypes, CPP #-} --------------------------------------------------------------------------------- --- | --- Module : System.Delta --- Copyright: (c) Christof Schramm 2015 --- License: LGPL v2 --- --- Maintainer: Christof Schramm --- Stability: Experimental --- --- = Description --- --- 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). --- --- 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 --- directory: --- --- @ --- printNewFilePaths basePath = do --- watcher <- deltaDirWithCallbacks basePath --- withNewCallback watcher (\\x -> putStrLn $ "new file: " ++ x) --- @ --------------------------------------------------------------------------------- -module System.Delta ( module System.Delta.Base - , module System.Delta.Poll - - -- * Important functions - , deltaDir - , deltaDirWithCallbacks - - -- * FRP based interface - , FileWatcher(..) - - -- * Callback based interface - , CallbackWatcher - , CallbackId - , withCallbacks - -- ** Adding callbacks - , withDeleteCallback - , withChangedCallback - , withNewCallback - -- ** Removing callbacks - , unregisterCallback - , removeAllCallbacks - , closeCallbackWatcher - )where - -import System.Delta.Base -import System.Delta.Class -import System.Delta.Callback -import System.Delta.Poll -#if defined(__APPLE__) -import System.Delta.FSEvents -#endif - --- | 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 5 path -#endif - --- | Build a file watcher that allows to register callbacks -deltaDirWithCallbacks :: FilePath -> IO CallbackWatcher -deltaDirWithCallbacks path = deltaDir path >>= withCallbacks diff --git a/src/System/Delta/Base.hs b/src/System/Delta/Base.hs deleted file mode 100644 --- a/src/System/Delta/Base.hs +++ /dev/null @@ -1,28 +0,0 @@ -module System.Delta.Base where - -import System.IO.Error -import System.FilePath -import System.Directory -import Data.Time.Clock.POSIX - -newtype FileInfo = FileInfo (FilePath,Integer,Bool) - deriving (Ord,Eq,Show) - -fileInfoPath :: FileInfo -> FilePath -fileInfoPath (FileInfo (path,_,_)) = path - --- | File modification time in milliseconds -fileInfoTimestamp :: FileInfo -> Integer -fileInfoTimestamp (FileInfo (_,time,_)) = time - --- | Is the file a directory -fileInfoIsDir :: FileInfo -> Bool -fileInfoIsDir (FileInfo (_,_,dir)) = dir - -mkFileInfo :: FilePath -> IO (FileInfo) -mkFileInfo path = do - isDir <- doesDirectoryExist path - isFile <- doesFileExist path - modTime <- getModificationTime path - let timeMillis = 1000 * (floor $ utcTimeToPOSIXSeconds modTime) - return $ FileInfo (path, timeMillis, isDir) diff --git a/src/System/Delta/Callback.hs b/src/System/Delta/Callback.hs deleted file mode 100644 --- a/src/System/Delta/Callback.hs +++ /dev/null @@ -1,117 +0,0 @@ -{-# LANGUAGE GADTs #-} -module System.Delta.Callback ( CallbackWatcher - , CallbackId - - -- * Construction - , withCallbacks - - -- * Adding callbacks - , withDeleteCallback - , withChangedCallback - , withNewCallback - - -- * Removing callbacks - , unregisterCallback - , removeAllCallbacks - - -- * Closing the watcher - , closeCallbackWatcher - - -- * Helper functions - , callbackOnEvent - )where - -import FRP.Sodium -import System.Delta.Base -import System.Delta.Class - -import qualified Data.Map as M - -import Control.Concurrent.MVar - --- | Id of a callback in a 'CallbackWatcher' -newtype CallbackId = CallbackId Integer - deriving (Eq, Ord) - --- | Provides a callback based interface to an FRP base 'FileWatcher' -data CallbackWatcher where - CallbackWatcher :: { - baseWatcher :: FileWatcher - , nextCallbackId :: MVar CallbackId - , watcherCallbacks :: MVar (M.Map CallbackId (IO ())) - } -> CallbackWatcher - - --- | Raise the callback id of a callback watcher -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 -> IO () -> IO CallbackId -addCallbackUnregister w removeCallback = do - newId <- raiseId w - mp <- takeMVar $ watcherCallbacks w - putMVar (watcherCallbacks w) (M.insert newId removeCallback mp) - return newId - --- | Wrap a file watcher in a datatype that allows adding callbacks -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 :: 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 :: 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 :: 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 :: CallbackWatcher -> CallbackId -> IO () -unregisterCallback watcher cId = do - mp <- takeMVar $ watcherCallbacks watcher - case M.lookup cId mp of - Nothing -> return () - Just action -> action - putMVar (watcherCallbacks watcher) (M.delete cId mp) - --- | Remove all callbacks form the watcher. They will not be called after this -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 :: CallbackWatcher -> IO () -closeCallbackWatcher watcher = do - removeAllCallbacks watcher - cleanUpAndClose $ baseWatcher watcher - - --- | Add a listener to an event, return the action to unregister the listener -callbackOnEvent :: Event a -> (a -> IO ()) -> IO (IO ()) -callbackOnEvent e action = sync $ listen e action diff --git a/src/System/Delta/Class.hs b/src/System/Delta/Class.hs deleted file mode 100644 --- a/src/System/Delta/Class.hs +++ /dev/null @@ -1,32 +0,0 @@ -module System.Delta.Class where - -import FRP.Sodium -import System.Delta.Base - -import Control.Monad - --- | 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 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 -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 - } - diff --git a/src/System/Delta/FRPUtils.hs b/src/System/Delta/FRPUtils.hs deleted file mode 100644 --- a/src/System/Delta/FRPUtils.hs +++ /dev/null @@ -1,21 +0,0 @@ -module System.Delta.FRPUtils where - -import Control.Concurrent -import Control.Monad - -import FRP.Sodium - -data Ticker a = Ticker{ tickerInterval :: Int - , tickerEvent :: Event a - , tickerTerminate :: IO () - } - -periodical :: Int -- ^ Milliseconds - -> a -- ^ Item that is sent periodically - -> IO (Ticker a) -periodical ms v = do - (e,push) <- sync $ newEvent - tId <- forkIO . forever $ do - threadDelay $ 1000 * ms - sync $ push v - return $ Ticker ms e (killThread tId) diff --git a/src/System/Delta/FSEvents.hs b/src/System/Delta/FSEvents.hs deleted file mode 100644 --- a/src/System/Delta/FSEvents.hs +++ /dev/null @@ -1,55 +0,0 @@ --------------------------------------------------------------------------------- --- | --- 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 deleted file mode 100644 --- a/src/System/Delta/Poll.hs +++ /dev/null @@ -1,102 +0,0 @@ -module System.Delta.Poll ( createPollWatcher - ) where - -import Control.Applicative ((<$>)) -import Control.Concurrent -import Control.Monad (foldM) - -import qualified Data.Map as M -import Data.Maybe (catMaybes) - -import FRP.Sodium - -import System.Delta.Base -import System.Delta.Class - -import System.Directory -import System.FilePath - -import Data.List (isPrefixOf) - --- | Watch files in this directory recursively for changes every --- n seconds. -createPollWatcher :: Int -- ^ seconds interval - -> FilePath -- ^ path to watch - -> 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 $ FileWatcher newFileEvent deletedEvent changedEvent (killThread watcherId) - --- | Recursively traverse a folder, follow symbolic links but don't --- visit a file twice. -recursiveDescent path = - M.filterWithKey (\_ -> not . fileInfoIsDir) <$> -- files only - recursiveDescent' M.empty path - --- | Recursively traverse a folder, follows symbolic links, --- doesn't loop however. -recursiveDescent' :: M.Map FilePath FileInfo - -> FilePath - -> IO (M.Map FilePath FileInfo) -recursiveDescent' visited path | M.member path visited = return visited -recursiveDescent' visited path = do - isDir <- doesDirectoryExist path - inf <- mkFileInfo path - let visitedWithCurrent = M.insert path inf visited - if not isDir - then return $ visitedWithCurrent - else do - contentsUnfiltered <- getDirectoryContents path - let contentsFiltered = filter (\x -> x /= "." && x /= "..") contentsUnfiltered - contentsAbs = (combine path) <$> contentsFiltered - foldM recursiveDescent' visitedWithCurrent contentsAbs - - --- | List all files that have a larger modification time in the second --- map than in the first -diffChangedFiles :: M.Map FilePath FileInfo - -> M.Map FilePath FileInfo - -> [FileInfo] -diffChangedFiles before after = - catMaybes . M.elems $ M.intersectionWith f before after - where - f beforeInfo afterInfo = - if fileInfoTimestamp beforeInfo < fileInfoTimestamp afterInfo - then Just afterInfo - else Nothing - --- | List all files that occur in the second map but not the first -diffNewFiles :: M.Map FilePath FileInfo - -> M.Map FilePath FileInfo - -> [FileInfo] -diffNewFiles before after = M.elems $ M.difference after before - --- | List all files that occur in the first map but not the second -diffDeletedFiles :: M.Map FilePath FileInfo - -> M.Map FilePath FileInfo - -> [FileInfo] -diffDeletedFiles before after = M.elems $ M.difference before after - --- | Fork a thread that continuously polls the given paht and compares --- the results of two polls. -startWatchThread :: FilePath - -> (FilePath -> Reactive ()) -- ^ Push new files / dirs - -> (FilePath -> Reactive ()) -- ^ Push deleted files / dirs - -> (FilePath -> Reactive ()) -- ^ Push changed files / dirs - -> Int -- ^ Seconds between polls - -> IO ThreadId -startWatchThread path pushNew pushDeleted pushChanged secs = do - curr <- recursiveDescent path - forkIO $ go curr - where - go last = do - threadDelay $ secs * 1000 * 1000 - curr <- recursiveDescent path - 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 deleted file mode 100644 --- a/src/delta-cli/Main.hs +++ /dev/null @@ -1,24 +0,0 @@ -module Main where - -import System.Delta -import System.Environment - -import Control.Monad -import Control.Concurrent - -main = do - args <- getArgs - case args of - [path] -> do - watcher <- deltaDirWithCallbacks path - withNewCallback watcher (\x -> putStrLn $ "new:\t" ++ x) - withDeleteCallback watcher (\x -> putStrLn $ "del:\t" ++ x) - withChangedCallback watcher (\x -> - putStrLn $ "changed:\t" ++ x - ) - forever $ threadDelay (1000 * 1000) - _ -> putStrLn errorString - -errorString = "This is a simple command line interface to the delta\ - \library. Call the program with delta-cli , where path\ - \is the path of the folder / file you want to watch." diff --git a/src/delta-run/Main.hs b/src/delta-run/Main.hs deleted file mode 100644 --- a/src/delta-run/Main.hs +++ /dev/null @@ -1,98 +0,0 @@ -{-# LANGUAGE RecursiveDo #-} -module Main where - -import Control.Concurrent -import Control.Exception -import Control.Monad - -import FRP.Sodium hiding (value) -import FRP.Sodium.IO -import Options.Applicative - -import System.Exit -import System.Delta -import System.Delta.FRPUtils -import System.Directory -import System.IO -import System.Process - -import Debug.Trace - -data Input = Input { inputSeconds :: Int - , inputDir :: FilePath - , inputCommand :: String - } - deriving Show -main = do - input <- execParser opts - inputDirExists <- doesDirectoryExist $ inputDir input - - when (not inputDirExists) - (do - hPutStrLn stderr $ inputDir input ++ " doesn't exist" - exitFailure - ) - - bracket (deltaDir $ inputDir input) - cleanUpAndClose -- Will run after Ctrl-C - (\watcher -> do - - let mergedEvent = (newFiles watcher) `merge` - (deletedFiles watcher) `merge` - (changedFiles watcher) - - ticker <- periodical (1000 * (inputSeconds input)) () - - runE <- sync $ mkRunEvent - mergedEvent - (tickerEvent ticker) - (runCmd input) - - _ <- sync $ listen runE (id) - - -- Sleep till interrupted (or exception) - forever $ threadDelay $ 50000000 - ) - where - opts = info (helper <*> optsP) (fullDesc) - optsP = Input - <$> option auto ( long "interval" - <> short 'i' - <> metavar "INTERVAL" - <> help "Run at most every n seconds" - <> value 1 - ) - <*> argument str ( metavar "FILE" - <> help "The directory that is watched" - ) - <*> argument str ( metavar "CMD" - <> help "The command to run" - ) - runCmd input = do - (_,_,_,procHandle) <- - createProcess $ (shell $ inputCommand input){ std_in = Inherit - , std_out = Inherit - , std_err = Inherit - } - waitForProcess procHandle - return () - - -mkRunEvent :: Event FilePath -- ^ Changed / Deleted / New file event - -> Event () -- ^ The periodical event - -> IO () -- ^ Execute the input command - -> Reactive (Event (IO ())) -mkRunEvent change ticker run = do - rec - enabled <- hold True $ (const False <$> fire ) `merge` (const True <$> ticker) - fireDue <- hold False $ (const True <$> change) `merge` (const False <$> fire ) - let firable = (&&) <$> enabled <*> fireDue - - -- Only when we have become firable after not being firable - fire <- filterE (id) <$> ( collectE (\c -> \p -> ((c /= p) && c,c)) - True - (updates firable) - ) - - return (const run <$> fire) - diff --git a/src/main/delta-cli/Main.hs b/src/main/delta-cli/Main.hs new file mode 100644 --- /dev/null +++ b/src/main/delta-cli/Main.hs @@ -0,0 +1,24 @@ +module Main where + +import System.Delta +import System.Environment + +import Control.Monad +import Control.Concurrent + +main = do + args <- getArgs + case args of + [path] -> do + watcher <- deltaDirWithCallbacks path + withNewCallback watcher (\x -> putStrLn $ "new:\t" ++ x) + withDeleteCallback watcher (\x -> putStrLn $ "del:\t" ++ x) + withChangedCallback watcher (\x -> + putStrLn $ "changed:\t" ++ x + ) + forever $ threadDelay (1000 * 1000) + _ -> putStrLn errorString + +errorString = "This is a simple command line interface to the delta\ + \library. Call the program with delta-cli , where path\ + \is the path of the folder / file you want to watch." diff --git a/src/main/delta-run/Main.hs b/src/main/delta-run/Main.hs new file mode 100644 --- /dev/null +++ b/src/main/delta-run/Main.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE RecursiveDo #-} +module Main (main) where + +import Control.Concurrent +import Control.Exception +import Control.Monad + +import qualified FRP.Sodium (value) +import FRP.Sodium hiding (value) +import FRP.Sodium.IO +import Options.Applicative + +import System.Exit +import System.Delta +import System.Delta.FRPUtils +import System.Directory +import System.IO +import System.Process + +data Input = Input { inputSeconds :: Int + , inputVerbose :: Bool + , inputDir :: FilePath + , inputCommand :: String + } + deriving Show +main = do + + -- Parse command line options + input <- execParser opts + inputDirExists <- doesDirectoryExist $ inputDir input + + -- Check for existence of input dir + when (not inputDirExists) + (do + hPutStrLn stderr $ inputDir input ++ " doesn't exist" + exitFailure + ) + + -- Create a directory watcher, start running it and sleep until we get an + -- exception or an interrupt. In both cases we close the watcher and exit. + bracket (do + when (inputVerbose input) $ putStrLn "Started watching." + deltaDir $ inputDir input + ) + (\watcher -> do + when (inputVerbose input) $ putStrLn "Closing watcher." + cleanUpAndClose watcher -- Will run after Ctrl-C + ) + (\watcher -> do + -- We execute the command on all possible incoming events + let mergedEvent = (newFiles watcher) `merge` + (deletedFiles watcher) `merge` + (changedFiles watcher) + + -- Start a process + ticker <- if inputSeconds input > 0 + then Just <$> periodical (1000 * (inputSeconds input)) () + else return Nothing + + sync $ mkRunEvent (inputVerbose input) + mergedEvent + ticker + (runCmd input) + + -- Sleep till interrupted (or exception) + forever $ threadDelay $ 50000000 + ) + where + opts = info (helper <*> optsP) (fullDesc) + optsP = Input + <$> option auto ( long "interval" + <> short 'i' + <> metavar "INTERVAL" + <> help "Run at most every n seconds" + <> value 3 + ) + <*> flag False True (long "verbose" + <> short 'v' + <> help "Print extra output" + ) + <*> argument str ( metavar "FILE" + <> help "The directory that is watched" + ) + <*> argument str ( metavar "CMD" + <> help "The command to run" + ) + runCmd input = do + when (inputVerbose input) $ putStrLn "Starting process." + (_,_,_,procHandle) <- + createProcess $ (shell $ inputCommand input){ std_in = Inherit + , std_out = Inherit + , std_err = Inherit + } + waitForProcess procHandle + when (inputVerbose input) $ putStrLn "Process done" + return () + +-- | Create an action that will run the given IO action when changes occur. The +-- given action will not be run twice inbetween two firings of the ticker event. +mkRunEvent :: Bool -- ^ Verbose output + -> Event FilePath -- ^ Changed / Deleted / New file event + -> Maybe (Ticker ()) -- ^ The periodical event + -> IO () -- ^ Execute the input command + -> Reactive () +mkRunEvent verbose change tickerMaybe run = + case tickerMaybe of + Just ticker -> mdo + let tickerE = tickerEvent ticker + enabled <- hold True $ (const False <$> fire) `merge` (const True <$> tickerE) + + let fire = gate change enabled + + listen fire runAction + + return () + Nothing -> listen change runAction >> return () + where + runAction path = do + when verbose $ putStrLn ("Running command after change in file " ++ path) + run diff --git a/src/main/delta/System/Delta.hs b/src/main/delta/System/Delta.hs new file mode 100644 --- /dev/null +++ b/src/main/delta/System/Delta.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE CPP #-} +-------------------------------------------------------------------------------- +-- | +-- Module : System.Delta +-- Copyright: (c) Christof Schramm 2015 +-- License: LGPL v2 +-- +-- Maintainer: Christof Schramm +-- Stability: Experimental +-- +-- = Description +-- +-- 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). +-- +-- 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 +-- directory: +-- +-- @ +-- printNewFilePaths basePath = do +-- watcher <- deltaDirWithCallbacks basePath +-- withNewCallback watcher (\\x -> putStrLn $ "new file: " ++ x) +-- @ +-------------------------------------------------------------------------------- +module System.Delta ( module System.Delta.Base + , module System.Delta.Poll + + -- * Important functions + , deltaDir + , deltaDirWithCallbacks + + -- * FRP based interface + , FileWatcher(..) + + -- * Callback based interface + , CallbackWatcher + , CallbackId + , withCallbacks + -- ** Adding callbacks + , withDeleteCallback + , withChangedCallback + , withNewCallback + -- ** Removing callbacks + , unregisterCallback + , removeAllCallbacks + , closeCallbackWatcher + )where + +import System.Delta.Base +import System.Delta.Class +import System.Delta.Callback +import System.Delta.Poll +#ifdef darwin_HOST_OS +import System.Delta.FSEvents +#endif + +-- | 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 +#ifdef darwin_HOST_OS + createFSEventsWatcher path +-- ifdef linux_HOST_OS +-- ifdef mingw32_HOST_OS +#else + createPollWatcher 5 path +#endif + +-- | Build a file watcher that allows to register callbacks +deltaDirWithCallbacks :: FilePath -> IO CallbackWatcher +deltaDirWithCallbacks path = deltaDir path >>= withCallbacks diff --git a/src/main/delta/System/Delta/Base.hs b/src/main/delta/System/Delta/Base.hs new file mode 100644 --- /dev/null +++ b/src/main/delta/System/Delta/Base.hs @@ -0,0 +1,28 @@ +module System.Delta.Base where + +import System.IO.Error +import System.FilePath +import System.Directory +import Data.Time.Clock.POSIX + +newtype FileInfo = FileInfo (FilePath,Integer,Bool) + deriving (Ord,Eq,Show) + +fileInfoPath :: FileInfo -> FilePath +fileInfoPath (FileInfo (path,_,_)) = path + +-- | File modification time in milliseconds +fileInfoTimestamp :: FileInfo -> Integer +fileInfoTimestamp (FileInfo (_,time,_)) = time + +-- | Is the file a directory +fileInfoIsDir :: FileInfo -> Bool +fileInfoIsDir (FileInfo (_,_,dir)) = dir + +mkFileInfo :: FilePath -> IO (FileInfo) +mkFileInfo path = do + isDir <- doesDirectoryExist path + isFile <- doesFileExist path + modTime <- getModificationTime path + let timeMillis = 1000 * (floor $ utcTimeToPOSIXSeconds modTime) + return $ FileInfo (path, timeMillis, isDir) diff --git a/src/main/delta/System/Delta/Callback.hs b/src/main/delta/System/Delta/Callback.hs new file mode 100644 --- /dev/null +++ b/src/main/delta/System/Delta/Callback.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE GADTs #-} +module System.Delta.Callback ( CallbackWatcher + , CallbackId + + -- * Construction + , withCallbacks + + -- * Adding callbacks + , withDeleteCallback + , withChangedCallback + , withNewCallback + + -- * Removing callbacks + , unregisterCallback + , removeAllCallbacks + + -- * Closing the watcher + , closeCallbackWatcher + + -- * Helper functions + , callbackOnEvent + )where + +import FRP.Sodium +import System.Delta.Base +import System.Delta.Class + +import qualified Data.Map as M + +import Control.Concurrent.MVar + +-- | Id of a callback in a 'CallbackWatcher' +newtype CallbackId = CallbackId Integer + deriving (Eq, Ord) + +-- | Provides a callback based interface to an FRP base 'FileWatcher' +data CallbackWatcher where + CallbackWatcher :: { + baseWatcher :: FileWatcher + , nextCallbackId :: MVar CallbackId + , watcherCallbacks :: MVar (M.Map CallbackId (IO ())) + } -> CallbackWatcher + + +-- | Raise the callback id of a callback watcher +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 -> IO () -> IO CallbackId +addCallbackUnregister w removeCallback = do + newId <- raiseId w + mp <- takeMVar $ watcherCallbacks w + putMVar (watcherCallbacks w) (M.insert newId removeCallback mp) + return newId + +-- | Wrap a file watcher in a datatype that allows adding callbacks +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 :: 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 :: 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 :: 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 :: CallbackWatcher -> CallbackId -> IO () +unregisterCallback watcher cId = do + mp <- takeMVar $ watcherCallbacks watcher + case M.lookup cId mp of + Nothing -> return () + Just action -> action + putMVar (watcherCallbacks watcher) (M.delete cId mp) + +-- | Remove all callbacks form the watcher. They will not be called after this +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 :: CallbackWatcher -> IO () +closeCallbackWatcher watcher = do + removeAllCallbacks watcher + cleanUpAndClose $ baseWatcher watcher + + +-- | Add a listener to an event, return the action to unregister the listener +callbackOnEvent :: Event a -> (a -> IO ()) -> IO (IO ()) +callbackOnEvent e action = sync $ listen e action diff --git a/src/main/delta/System/Delta/Class.hs b/src/main/delta/System/Delta/Class.hs new file mode 100644 --- /dev/null +++ b/src/main/delta/System/Delta/Class.hs @@ -0,0 +1,32 @@ +module System.Delta.Class where + +import FRP.Sodium +import System.Delta.Base + +import Control.Monad + +-- | 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 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 +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 + } + diff --git a/src/main/delta/System/Delta/FRPUtils.hs b/src/main/delta/System/Delta/FRPUtils.hs new file mode 100644 --- /dev/null +++ b/src/main/delta/System/Delta/FRPUtils.hs @@ -0,0 +1,21 @@ +module System.Delta.FRPUtils where + +import Control.Concurrent +import Control.Monad + +import FRP.Sodium + +data Ticker a = Ticker{ tickerInterval :: Int + , tickerEvent :: Event a + , tickerTerminate :: IO () + } + +periodical :: Int -- ^ Milliseconds + -> a -- ^ Item that is sent periodically + -> IO (Ticker a) +periodical ms v = do + (e,push) <- sync $ newEvent + tId <- forkIO . forever $ do + threadDelay $ 1000 * ms + sync $ push v + return $ Ticker ms e (killThread tId) diff --git a/src/main/delta/System/Delta/FSEvents.hs b/src/main/delta/System/Delta/FSEvents.hs new file mode 100644 --- /dev/null +++ b/src/main/delta/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/main/delta/System/Delta/Poll.hs b/src/main/delta/System/Delta/Poll.hs new file mode 100644 --- /dev/null +++ b/src/main/delta/System/Delta/Poll.hs @@ -0,0 +1,102 @@ +module System.Delta.Poll ( createPollWatcher + ) where + +import Control.Applicative ((<$>)) +import Control.Concurrent +import Control.Monad (foldM) + +import qualified Data.Map as M +import Data.Maybe (catMaybes) + +import FRP.Sodium + +import System.Delta.Base +import System.Delta.Class + +import System.Directory +import System.FilePath + +import Data.List (isPrefixOf) + +-- | Watch files in this directory recursively for changes every +-- n seconds. +createPollWatcher :: Int -- ^ seconds interval + -> FilePath -- ^ path to watch + -> 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 $ FileWatcher newFileEvent deletedEvent changedEvent (killThread watcherId) + +-- | Recursively traverse a folder, follow symbolic links but don't +-- visit a file twice. +recursiveDescent path = + M.filterWithKey (\_ -> not . fileInfoIsDir) <$> -- files only + recursiveDescent' M.empty path + +-- | Recursively traverse a folder, follows symbolic links, +-- doesn't loop however. +recursiveDescent' :: M.Map FilePath FileInfo + -> FilePath + -> IO (M.Map FilePath FileInfo) +recursiveDescent' visited path | M.member path visited = return visited +recursiveDescent' visited path = do + isDir <- doesDirectoryExist path + inf <- mkFileInfo path + let visitedWithCurrent = M.insert path inf visited + if not isDir + then return $ visitedWithCurrent + else do + contentsUnfiltered <- getDirectoryContents path + let contentsFiltered = filter (\x -> x /= "." && x /= "..") contentsUnfiltered + contentsAbs = (combine path) <$> contentsFiltered + foldM recursiveDescent' visitedWithCurrent contentsAbs + + +-- | List all files that have a larger modification time in the second +-- map than in the first +diffChangedFiles :: M.Map FilePath FileInfo + -> M.Map FilePath FileInfo + -> [FileInfo] +diffChangedFiles before after = + catMaybes . M.elems $ M.intersectionWith f before after + where + f beforeInfo afterInfo = + if fileInfoTimestamp beforeInfo < fileInfoTimestamp afterInfo + then Just afterInfo + else Nothing + +-- | List all files that occur in the second map but not the first +diffNewFiles :: M.Map FilePath FileInfo + -> M.Map FilePath FileInfo + -> [FileInfo] +diffNewFiles before after = M.elems $ M.difference after before + +-- | List all files that occur in the first map but not the second +diffDeletedFiles :: M.Map FilePath FileInfo + -> M.Map FilePath FileInfo + -> [FileInfo] +diffDeletedFiles before after = M.elems $ M.difference before after + +-- | Fork a thread that continuously polls the given paht and compares +-- the results of two polls. +startWatchThread :: FilePath + -> (FilePath -> Reactive ()) -- ^ Push new files / dirs + -> (FilePath -> Reactive ()) -- ^ Push deleted files / dirs + -> (FilePath -> Reactive ()) -- ^ Push changed files / dirs + -> Int -- ^ Seconds between polls + -> IO ThreadId +startWatchThread path pushNew pushDeleted pushChanged secs = do + curr <- recursiveDescent path + forkIO $ go curr + where + go last = do + threadDelay $ secs * 1000 * 1000 + curr <- recursiveDescent path + 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/test/Main.hs b/src/test/Main.hs new file mode 100644 --- /dev/null +++ b/src/test/Main.hs @@ -0,0 +1,31 @@ +module Main where + +import Control.Exception + +import Test.Hspec + +import System.Delta +import System.Directory +import System.FilePath + +spec :: Spec +spec = do + describe "The delta library" $ do + it "should create a watcher without an exception" $ do + + bracket + (do + tempdir <- getTemporaryDirectory + createDirectory $ tempdir "opdir" + return $ tempdir "opdir" + ) + removeDirectory + (\path -> do + watcher <- deltaDir path + v <- cleanUpAndClose watcher + v `shouldBe` () + ) + + +main :: IO () +main = hspec spec