diff options
| -rw-r--r-- | Main.hs | 246 | ||||
| -rw-r--r-- | git-auto-acp.cabal | 3 |
2 files changed, 148 insertions, 101 deletions
@@ -6,21 +6,60 @@ module Main where import Data.Version (showVersion) import Paths_git_auto_acp (version) +import Control.Applicative (some) import Control.Concurrent -import Control.Monad -import Data.Foldable -import Data.Maybe -import qualified Data.Set as S + ( Chan + , MVar + , forkIO + , newChan + , newEmptyMVar + , putMVar + , readChan + , takeMVar + , threadDelay + , writeChan + ) +import Control.Monad (unless, void) +import Data.Foldable (asum, for_) +import Data.Maybe (fromMaybe) +import qualified Data.Set as S (Set, empty, insert, null) import Options.Applicative + ( Parser + , auto + , customExecParser + , flag' + , footer + , fullDesc + , header + , help + , helper + , info + , long + , metavar + , option + , prefs + , short + , showDefault + , showHelpOnEmpty + , simpleVersioner + , strOption + , value + ) import System.Clock -import System.Environment -import System.Exit -import System.FSNotify -import System.FSNotify.Devel -import System.FilePath -import System.IO -import System.Posix.Signals -import System.Process + ( Clock(Monotonic) + , TimeSpec + , diffTimeSpec + , getTime + , toNanoSecs + ) +import System.Environment (lookupEnv) +import System.Exit (ExitCode(ExitSuccess)) +import System.FSNotify (watchTree, withManager) +import System.FSNotify.Devel (allEvents) +import System.FilePath (splitDirectories) +import System.IO (hPutStrLn, stderr) +import System.Posix.Signals (Handler(Catch), installHandler, sigINT) +import System.Process (rawSystem) data WatchType = UpdateOnly @@ -50,54 +89,65 @@ data Opts = Opts opts :: Parser Opts opts = do + let infix 8 ~~ + (~~) f = f . mconcat optAddCommitDelay <- option auto - $ short 'd' - <> long "commit-delay" - <> help "debuounce delay for adding and commiting new changes" - <> value 5 - <> showDefault + ~~ [ short 'd' + , long "commit-delay" + , help "debuounce delay for adding and commiting new changes" + , value 5 + , showDefault + ] optPushDelay <- asum [ flag' Nothing - $ short 'L' <> long "local" <> help "only work locally, do not push" + ~~ [short 'L', long "local", help "only work locally, do not push"] , fmap Just . option auto - $ short 'D' - <> long "push-delay" - <> help "push changes upstream with this debuounce delay" - <> value 60 - <> showDefault + ~~ [ short 'D' + , long "push-delay" + , help "push changes upstream with this debuounce delay" + , value 60 + , showDefault + ] ] optWatches <- some $ asum [ fmap (`Watch` UpdateOnly) . strOption - $ short 'u' - <> long "update" - <> metavar "PATH" - <> help "like `--add' but does not add new files" + ~~ [ short 'u' + , long "update" + , metavar "PATH" + , help "like `--add' but does not add new files" + ] , fmap (`Watch` Add) . strOption - $ short 'a' - <> long "add" - <> metavar "PATH" - <> help "paths to auto-add" + ~~ [ short 'a' + , long "add" + , metavar "PATH" + , help "paths to auto-add" + ] , fmap (`Watch` AddAndRemove) . strOption - $ short 'A' - <> long "add-all" - <> metavar "PATH" - <> help "like `--add' but also auto-adds file removals" + ~~ [ short 'A' + , long "add-all" + , metavar "PATH" + , help "like `--add' but also auto-adds file removals" + ] ] optMsg <- strOption - $ short 'm' - <> long "message" - <> metavar "MSG" - <> help "commit message for auto-commits" - <> value "[auto-acs] update #%n" - <> showDefault + ~~ [ short 'm' + , long "message" + , metavar "MSG" + , help "commit message for auto-commits" + , value "[auto-acs] update #%n" + , showDefault + ] optDebug <- - flag' True (long "debug" <> help "be super verbose about what's happening") - <|> pure False + asum + [ flag' True + ~~ [long "debug", help "be super verbose about what's happening"] + , pure False + ] pure Opts {..} delaySec :: Float -> IO () @@ -143,7 +193,7 @@ main = do o <- customExecParser (prefs $ showHelpOnEmpty) $ info - (opts <**> helper <**> simpleVersioner (showVersion version)) + (simpleVersioner (showVersion version) <*> helper <*> opts) (fullDesc <> header "git-auto-acp -- automatically add-commit-push files" <> (footer @@ -166,61 +216,57 @@ main = do dbg $ "fsnotify says: " ++ show ev writeChan chan (Change w) -- start the event crunching thread - let loop st@St {..} = do - ev <- readChan chan - dbg $ "processing event: " ++ show ev - now <- getTime Monotonic - case ev of - Finished -> putMVar done () - Change w -> do - void . forkIO - $ delaySec (optAddCommitDelay o) >> writeChan chan AddBounce - let ws' = S.insert w stWatch - case optPushDelay o of - Nothing -> - loop st {stWatch = ws', stAddsPending = succ stAddsPending} - Just pd -> do - void . forkIO $ delaySec pd >> writeChan chan PushBounce - loop - st - { stWatch = ws' - , stAddsPending = succ stAddsPending - , stPushesPending = succ stPushesPending - } - AddBounce -- TODO the last trigger looks nice but may cause double add, instead track an increasing token or such - | not (S.null stWatch) - , stAddsPending == 1 - || intervalPassed (optAddCommitDelay o) now stLastAdd -> do - for_ stWatch $ \w@(Watch p wtype) -> do - dbg $ "will add: " ++ show w - runCmd git ["add", watchGitOption wtype, p] - dbg "commit!" - runCmd - git - ["commit", "--message", mkMsg stCommitSeries $ optMsg o] - loop - st - { stWatch = S.empty - , stLastAdd = now - , stAddsPending = pred stAddsPending - , stCommitSeries = succ stCommitSeries - } - | otherwise -> - loop st {stWatch = S.empty, stAddsPending = pred stAddsPending} - PushBounce - | Just pd <- optPushDelay o - , stPushesPending == 1 || intervalPassed pd now stLastPush -> do - dbg $ "push!" - runCmd git ["push"] - loop - st - { stWatch = S.empty - , stLastPush = now - , stPushesPending = pred stPushesPending - } - | otherwise -> - loop - st {stWatch = S.empty, stPushesPending = pred stPushesPending} - void . forkIO $ loop emptyState + void . forkIO $ mainLoop git dbg chan done o emptyState -- wait for the finish, then terminate takeMVar done + +mainLoop :: + String -> ([Char] -> IO ()) -> Chan Event -> MVar () -> Opts -> St -> IO () +mainLoop git dbg chan done o = loop + where + loop st = do + ev <- readChan chan + dbg $ "processing event: " ++ show ev + now <- getTime Monotonic + handle now st ev + handle _ _ Finished = putMVar done () + handle _ st@St {..} (Change w) = do + void . forkIO $ delaySec (optAddCommitDelay o) >> writeChan chan AddBounce + let ws' = S.insert w stWatch + case optPushDelay o of + Nothing -> loop st {stWatch = ws', stAddsPending = succ stAddsPending} + Just pd -> do + void . forkIO $ delaySec pd >> writeChan chan PushBounce + loop + st + { stWatch = ws' + , stAddsPending = succ stAddsPending + , stPushesPending = succ stPushesPending + } + handle now st@St {..} AddBounce + | not (S.null stWatch) + , stAddsPending == 1 {- protection against triggering too early -} + || intervalPassed (optAddCommitDelay o) now stLastAdd = do + for_ stWatch $ \w@(Watch p wtype) -> do + dbg $ "will add: " ++ show w + runCmd git ["add", watchGitOption wtype, p] + dbg "commit!" + runCmd git ["commit", "--message", mkMsg stCommitSeries $ optMsg o] + loop + st + { stWatch = S.empty + , stLastAdd = now + , stAddsPending = 0 + , stCommitSeries = succ stCommitSeries + } + | otherwise = + loop st {stWatch = S.empty, stAddsPending = 0 `max` pred stAddsPending} + handle now st@St {..} PushBounce + | Just pd <- optPushDelay o + , stPushesPending == 1 || intervalPassed pd now stLastPush = do + dbg $ "push!" + runCmd git ["push"] + loop st {stWatch = S.empty, stLastPush = now, stPushesPending = 0} + | otherwise = + loop + st {stWatch = S.empty, stPushesPending = 0 `max` pred stPushesPending} diff --git a/git-auto-acp.cabal b/git-auto-acp.cabal index ba24d89..1f56ede 100644 --- a/git-auto-acp.cabal +++ b/git-auto-acp.cabal @@ -18,7 +18,8 @@ extra-doc-files: -- extra-source-files: common warnings - ghc-options: -Wall + -- sometimes useful: -ddump-minimal-imports + ghc-options: -Wall -Wmissing-import-lists -Wunused-imports executable git-auto-acp import: warnings |