diff --git a/Opts.hs b/Opts.hs deleted file mode 100644 --- a/Opts.hs +++ /dev/null @@ -1,30 +0,0 @@ -module Opts where - -import Options.Applicative - -data WatchOpt = WatchOpt { watchPath :: String - , includePath :: String -- ^ an reg exp to include particular files when watching dir - , excludePath :: String -- ^ an reg exp to exclude particular files when watching dir - , throttlingDelay :: Int -- ^ milliseconds to wait for duplicate events - , actionCmd :: [String] - } deriving (Show) - -watchOpt :: Parser WatchOpt -watchOpt = WatchOpt - <$> strOption (long "path" - <> metavar "PATH" - <> help "directory / file to watch" ) - <*> strOption (long "include" - <> value [] - <> metavar "INCLUDE" - <> help "pattern for including files") - <*> strOption (long "exclude" - <> value [] - <> metavar "EXCLUDE" - <> help "pattern for excluding files") - <*> option auto (long "throttle" - <> value 0 - <> metavar "MILLIS" - <> help "milliseconds to wait for duplicate events") - <*> (many . strArgument) (metavar "COMMAND" - <> help "command to run" ) diff --git a/Pipeline.hs b/Pipeline.hs deleted file mode 100644 --- a/Pipeline.hs +++ /dev/null @@ -1,50 +0,0 @@ --- poor man's streaming library, using threads communicating with MVars -module Pipeline where - -import Prelude hiding (id, (.)) - -import Control.Category -import Control.Concurrent (ThreadId, forkIO, threadDelay) -import Control.Concurrent.MVar -import Control.Monad - - -newtype Pipeline a b = Pipeline { - -- launches zero or more threads, forming a pipeline which takes from - -- the 'MVar a' and puts to the 'MVar b'. - runPipeline :: MVar a -> IO ([ThreadId], MVar b) -} - -instance Category Pipeline where - id = Pipeline $ \inputMVar -> return ([], inputMVar) - s2 . s1 = Pipeline $ \inputMVar -> do - (threads1, intermediateMVar) <- runPipeline s1 inputMVar - (threads2, outputMVar) <- runPipeline s2 intermediateMVar - return (threads1 ++ threads2, outputMVar) - - -mkPipeline :: (a -> IO b) -> Pipeline a b -mkPipeline f = Pipeline $ \inputMVar -> do - outputMVar <- newEmptyMVar - threadId <- forkIO $ forever $ do - x <- takeMVar inputMVar - y <- f x - putMVar outputMVar y - return ([threadId], outputMVar) - - --- ignore duplicate events, defined as events closer than 'delay' --- milliseconds apart -throttle :: Int -> Pipeline () () -throttle delay = Pipeline $ \inputMVar -> do - intermediateMVar <- newEmptyMVar - outputMVar <- newEmptyMVar - absorberThreadId <- forkIO $ forever $ do - () <- takeMVar inputMVar - void $ tryPutMVar intermediateMVar () -- don't block if the next thread is sleeping - sleepingThreadId <- forkIO $ forever $ do - () <- takeMVar intermediateMVar - threadDelay (1000 * delay) - _ <- tryTakeMVar intermediateMVar -- drop any event received while sleeping - putMVar outputMVar () - return ([absorberThreadId, sleepingThreadId], outputMVar) diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/fswatcher.cabal b/fswatcher.cabal --- a/fswatcher.cabal +++ b/fswatcher.cabal @@ -1,7 +1,7 @@ name: fswatcher category: Tools build-type: Simple -version: 0.2.1 +version: 0.2.2 synopsis: Watch a file/directory and run a command when it's modified description: A simple program that watches a file or a directory and runs a given command whenever the file or a file within the @@ -11,7 +11,7 @@ author: Erlend Hamberg maintainer: ehamberg@gmail.com stability: experimental -tested-with: GHC==7.6.3 +tested-with: GHC==7.6.3, GHC==8.4.4 homepage: http://www.github.com/ehamberg/fswatcher/ cabal-version: >= 1.6 @@ -20,12 +20,13 @@ build-depends: base >= 4 && < 5 , unix >= 2.5 , process >= 1.1 - , fsnotify >= 0.1 + , fsnotify >= 0.3 && < 0.4 , system-filepath >= 0.4 , directory >= 1.2 , optparse-applicative >= 0.11 , regex-pcre-builtin >= 0.94 ghc-options: -Wall + hs-source-dirs: src main-is: fswatcher.hs other-modules: Opts , Pipeline diff --git a/fswatcher.hs b/fswatcher.hs deleted file mode 100644 --- a/fswatcher.hs +++ /dev/null @@ -1,114 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -import Prelude hiding (id, (.)) - -import System.IO (hPutStrLn, stderr) -import System.Posix.Files (getFileStatus, isDirectory) -import System.Directory (canonicalizePath, getCurrentDirectory) -import Filesystem.Path ((), directory) -import Filesystem.Path.CurrentOS (decodeString, encodeString) -import Data.String (fromString) -import System.FSNotify (Event (..), StopListening, WatchManager, startManager, - stopManager, watchTree, watchDir, eventPath) -import System.Exit (ExitCode (..), exitSuccess) -import System.Process (createProcess, proc, waitForProcess) -import Control.Category -import Control.Monad (void) -import System.Posix.Signals (installHandler, Handler(Catch), sigINT, sigTERM) -import Control.Concurrent (forkIO, killThread) -import Control.Concurrent.MVar -import Text.Regex.PCRE -import Options.Applicative - -import Opts -import Pipeline - -data FileType = File | Directory deriving Eq - --- Watches a file or directory and whenever a “modified” event is registered we --- put () in the MVar that acts as a run trigger. `tryPutMVar` is used to avoid --- re-running the command many times if the file/dir is changed more than once --- while the command is already running. -watch :: FileType -> WatchManager -> String -> MVar () -> WatchOpt -> IO StopListening -watch filetype m path trigger opt = - let watchFun = case filetype of - Directory -> watchTree m path (matchFiles opt) - File -> watchDir m (encodeString $ directory $ decodeString path) isThisFile - in watchFun (\_ -> void $ tryPutMVar trigger ()) - - where isThisFile (Modified p _) = p == fromString path - isThisFile _ = False - matchFiles :: WatchOpt -> Event -> Bool - matchFiles wo event = let p = eventPath event - includes = includePath wo - excludes = excludePath wo - in - (null includes || p =~ includePath wo) - && (null excludes || not (p =~ excludePath wo)) - -runCmd :: String -> [String] -> MVar () -> IO () -runCmd cmd args trigger = do - _ <- takeMVar trigger - putStrLn $ "Running " ++ cmd ++ " " ++ unwords args ++ "..." - (_, _, _, ph) <- createProcess (proc cmd args) - exitCode <- waitForProcess ph - hPutStrLn stderr $ case exitCode of - ExitSuccess -> "Process completed successfully" - ExitFailure n -> "Process returned " ++ show n - runCmd cmd args trigger - -runWatch :: WatchOpt -> IO () -runWatch opt = do - - let path = watchPath opt - let cmd = head $ actionCmd opt - let args = drop 1 $ actionCmd opt - - m <- startManager - - -- Create an empty MVar and install INT/TERM handlers that will fill it. - -- We will wait for one of these signals before cleaning up and exiting. - interrupted <- newEmptyMVar - _ <- installHandler sigINT (Catch $ putMVar interrupted ()) Nothing - _ <- installHandler sigTERM (Catch $ putMVar interrupted ()) Nothing - - canonicalPath <- canonicalizePath path - - -- Check if path is a file or directory. - s <- getFileStatus canonicalPath - let filetype = if isDirectory s then Directory else File - - -- Check if throttling was requested. - let delay = throttlingDelay opt - let pipeline = if delay > 0 then throttle delay else id - - inputMVar <- newEmptyMVar - (pipelineThreads, outputMVar) <- runPipeline pipeline inputMVar - runThread <- forkIO $ runCmd cmd args outputMVar - stopWatcher <- watch filetype m canonicalPath inputMVar opt - - let allThreads = runThread : pipelineThreads - - -- Calculate the full path in order to print the "real" file when watching a - -- path with one or more symlinks. - currDir <- getCurrentDirectory - let fullPath = fromString currDir fromString path - putStr $ "Started to watch " ++ path - putStrLn $ if fromString canonicalPath == fullPath - then "" - else " (→ " ++ canonicalPath ++ ")" - putStrLn "Press ^C to stop." - - _ <- readMVar interrupted - putStrLn "\nStopping." - stopWatcher - stopManager m - mapM_ killThread allThreads - exitSuccess - -main :: IO () -main = execParser opts >>= runWatch - where - opts = info (helper <*> watchOpt) - ( fullDesc - <> progDesc "monitors a file or a directory for changes and runs a given command.") diff --git a/src/Opts.hs b/src/Opts.hs new file mode 100644 --- /dev/null +++ b/src/Opts.hs @@ -0,0 +1,30 @@ +module Opts where + +import Options.Applicative + +data WatchOpt = WatchOpt { watchPath :: String + , includePath :: String -- ^ an reg exp to include particular files when watching dir + , excludePath :: String -- ^ an reg exp to exclude particular files when watching dir + , throttlingDelay :: Int -- ^ milliseconds to wait for duplicate events + , actionCmd :: [String] + } deriving (Show) + +watchOpt :: Parser WatchOpt +watchOpt = WatchOpt + <$> strOption (long "path" + <> metavar "PATH" + <> help "directory / file to watch" ) + <*> strOption (long "include" + <> value [] + <> metavar "INCLUDE" + <> help "pattern for including files") + <*> strOption (long "exclude" + <> value [] + <> metavar "EXCLUDE" + <> help "pattern for excluding files") + <*> option auto (long "throttle" + <> value 0 + <> metavar "MILLIS" + <> help "milliseconds to wait for duplicate events") + <*> (some . strArgument) (metavar "COMMAND" + <> help "command to run" ) diff --git a/src/Pipeline.hs b/src/Pipeline.hs new file mode 100644 --- /dev/null +++ b/src/Pipeline.hs @@ -0,0 +1,50 @@ +-- poor man's streaming library, using threads communicating with MVars +module Pipeline where + +import Prelude hiding (id, (.)) + +import Control.Category +import Control.Concurrent (ThreadId, forkIO, threadDelay) +import Control.Concurrent.MVar +import Control.Monad + + +newtype Pipeline a b = Pipeline { + -- launches zero or more threads, forming a pipeline which takes from + -- the 'MVar a' and puts to the 'MVar b'. + runPipeline :: MVar a -> IO ([ThreadId], MVar b) +} + +instance Category Pipeline where + id = Pipeline $ \inputMVar -> return ([], inputMVar) + s2 . s1 = Pipeline $ \inputMVar -> do + (threads1, intermediateMVar) <- runPipeline s1 inputMVar + (threads2, outputMVar) <- runPipeline s2 intermediateMVar + return (threads1 ++ threads2, outputMVar) + + +mkPipeline :: (a -> IO b) -> Pipeline a b +mkPipeline f = Pipeline $ \inputMVar -> do + outputMVar <- newEmptyMVar + threadId <- forkIO $ forever $ do + x <- takeMVar inputMVar + y <- f x + putMVar outputMVar y + return ([threadId], outputMVar) + + +-- ignore duplicate events, defined as events closer than 'delay' +-- milliseconds apart +throttle :: Int -> Pipeline () () +throttle delay = Pipeline $ \inputMVar -> do + intermediateMVar <- newEmptyMVar + outputMVar <- newEmptyMVar + absorberThreadId <- forkIO $ forever $ do + () <- takeMVar inputMVar + void $ tryPutMVar intermediateMVar () -- don't block if the next thread is sleeping + sleepingThreadId <- forkIO $ forever $ do + () <- takeMVar intermediateMVar + threadDelay (1000 * delay) + _ <- tryTakeMVar intermediateMVar -- drop any event received while sleeping + putMVar outputMVar () + return ([absorberThreadId, sleepingThreadId], outputMVar) diff --git a/src/fswatcher.hs b/src/fswatcher.hs new file mode 100644 --- /dev/null +++ b/src/fswatcher.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Prelude hiding (id, (.)) + +import System.IO (hPutStrLn, stderr) +import System.Posix.Files (getFileStatus, isDirectory) +import System.Directory (canonicalizePath, getCurrentDirectory) +import Filesystem.Path ((), directory) +import Filesystem.Path.CurrentOS (decodeString, encodeString) +import Data.String (fromString) +import System.FSNotify (Event (..), StopListening, WatchManager, startManager, + stopManager, watchTree, watchDir, eventPath) +import System.Exit (ExitCode (..), exitSuccess) +import System.Process (createProcess, proc, waitForProcess) +import Control.Category +import Control.Monad (void) +import System.Posix.Signals (installHandler, Handler(Catch), sigINT, sigTERM) +import Control.Concurrent (forkIO, killThread) +import Control.Concurrent.MVar +import Text.Regex.PCRE +import Options.Applicative + +import Opts +import Pipeline + +data FileType = File | Directory deriving Eq + +-- Watches a file or directory and whenever a “modified” event is registered we +-- put () in the MVar that acts as a run trigger. `tryPutMVar` is used to avoid +-- re-running the command many times if the file/dir is changed more than once +-- while the command is already running. +watch :: FileType -> WatchManager -> String -> MVar () -> WatchOpt -> IO StopListening +watch filetype m path trigger opt = + let watchFun = case filetype of + Directory -> watchTree m path (matchFiles opt) + File -> watchDir m (encodeString $ directory $ decodeString path) isThisFile + in watchFun (\_ -> void $ tryPutMVar trigger ()) + + where isThisFile :: Event -> Bool + isThisFile (Modified p _ _) = p == fromString path + isThisFile _ = False + matchFiles :: WatchOpt -> Event -> Bool + matchFiles wo event = let p = eventPath event + includes = includePath wo + excludes = excludePath wo + in + (null includes || p =~ includePath wo) + && (null excludes || not (p =~ excludePath wo)) + +runCmd :: String -> [String] -> MVar () -> IO () +runCmd cmd args trigger = do + _ <- takeMVar trigger + putStrLn $ "Running " ++ cmd ++ " " ++ unwords args ++ "..." + (_, _, _, ph) <- createProcess (proc cmd args) + exitCode <- waitForProcess ph + hPutStrLn stderr $ case exitCode of + ExitSuccess -> "Process completed successfully" + ExitFailure n -> "Process returned " ++ show n + runCmd cmd args trigger + +runWatch :: WatchOpt -> IO () +runWatch opt = do + + let path = watchPath opt + let cmd = head $ actionCmd opt + let args = drop 1 $ actionCmd opt + + m <- startManager + + -- Create an empty MVar and install INT/TERM handlers that will fill it. + -- We will wait for one of these signals before cleaning up and exiting. + interrupted <- newEmptyMVar + _ <- installHandler sigINT (Catch $ putMVar interrupted ()) Nothing + _ <- installHandler sigTERM (Catch $ putMVar interrupted ()) Nothing + + canonicalPath <- canonicalizePath path + + -- Check if path is a file or directory. + s <- getFileStatus canonicalPath + let filetype = if isDirectory s then Directory else File + + -- Check if throttling was requested. + let delay = throttlingDelay opt + let pipeline = if delay > 0 then throttle delay else id + + inputMVar <- newEmptyMVar + (pipelineThreads, outputMVar) <- runPipeline pipeline inputMVar + runThread <- forkIO $ runCmd cmd args outputMVar + stopWatcher <- watch filetype m canonicalPath inputMVar opt + + let allThreads = runThread : pipelineThreads + + -- Calculate the full path in order to print the "real" file when watching a + -- path with one or more symlinks. + currDir <- getCurrentDirectory + let fullPath = fromString currDir fromString path + putStr $ "Started to watch " ++ path + putStrLn $ if fromString canonicalPath == fullPath + then "" + else " (→ " ++ canonicalPath ++ ")" + putStrLn "Press ^C to stop." + + _ <- readMVar interrupted + putStrLn "\nStopping." + stopWatcher + stopManager m + mapM_ killThread allThreads + exitSuccess + +main :: IO () +main = execParser opts >>= runWatch + where + opts = info (helper <*> watchOpt) + ( fullDesc + <> progDesc "monitors a file or a directory for changes and runs a given command.")