delta 0.2.1.1 → 0.2.1.2
raw patch · 20 files changed
+664/−567 lines, 20 filesdep +hspecPVP ok
version bump matches the API change (PVP)
Dependencies added: hspec
API changes (from Hackage documentation)
Files
- delta.cabal +50/−8
- src/System/Delta.hs +0/−82
- src/System/Delta/Base.hs +0/−28
- src/System/Delta/Callback.hs +0/−117
- src/System/Delta/Class.hs +0/−32
- src/System/Delta/FRPUtils.hs +0/−21
- src/System/Delta/FSEvents.hs +0/−55
- src/System/Delta/Poll.hs +0/−102
- src/delta-cli/Main.hs +0/−24
- src/delta-run/Main.hs +0/−98
- src/main/delta-cli/Main.hs +24/−0
- src/main/delta-run/Main.hs +120/−0
- src/main/delta/System/Delta.hs +84/−0
- src/main/delta/System/Delta/Base.hs +28/−0
- src/main/delta/System/Delta/Callback.hs +117/−0
- src/main/delta/System/Delta/Class.hs +32/−0
- src/main/delta/System/Delta/FRPUtils.hs +21/−0
- src/main/delta/System/Delta/FSEvents.hs +55/−0
- src/main/delta/System/Delta/Poll.hs +102/−0
- src/test/Main.hs +31/−0
delta.cabal view
@@ -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
− src/System/Delta.hs
@@ -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
− src/System/Delta/Base.hs
@@ -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)
− src/System/Delta/Callback.hs
@@ -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
− src/System/Delta/Class.hs
@@ -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- }-
− src/System/Delta/FRPUtils.hs
@@ -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)
− src/System/Delta/FSEvents.hs
@@ -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)
− src/System/Delta/Poll.hs
@@ -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
− src/delta-cli/Main.hs
@@ -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 <path>, where path\- \is the path of the folder / file you want to watch."
− src/delta-run/Main.hs
@@ -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)-
+ src/main/delta-cli/Main.hs view
@@ -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 <path>, where path\+ \is the path of the folder / file you want to watch."
+ src/main/delta-run/Main.hs view
@@ -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
+ src/main/delta/System/Delta.hs view
@@ -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
+ src/main/delta/System/Delta/Base.hs view
@@ -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)
+ src/main/delta/System/Delta/Callback.hs view
@@ -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
+ src/main/delta/System/Delta/Class.hs view
@@ -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+ }+
+ src/main/delta/System/Delta/FRPUtils.hs view
@@ -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)
+ src/main/delta/System/Delta/FSEvents.hs view
@@ -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)
+ src/main/delta/System/Delta/Poll.hs view
@@ -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
+ src/test/Main.hs view
@@ -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