diff options
Diffstat (limited to 'Main.hs')
| -rw-r--r-- | Main.hs | 37 |
1 files changed, 26 insertions, 11 deletions
@@ -1,9 +1,7 @@ {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE RecordWildCards #-} -module Main - ( main - ) where +module Main where import Data.Version (showVersion) import Paths_git_auto_acp (version) @@ -21,6 +19,7 @@ import System.FSNotify import System.FSNotify.Devel import System.FilePath import System.IO +import System.Posix.Signals import System.Process data Watch = Watch @@ -33,6 +32,7 @@ data Opts = Opts , optPushDelay :: Maybe Float , optWatches :: [Watch] , optMsg :: String + , optDebug :: Bool } deriving (Show) opts :: Parser Opts @@ -67,7 +67,7 @@ opts = do $ short 'A' <> long "add-all" <> metavar "PATH" - <> help "like `--add' but auto-adds file removals" + <> help "like `--add' but also auto-adds file removals" ] optMsg <- strOption @@ -77,6 +77,9 @@ opts = do <> help "commit message for auto-commits" <> value "update to filesystem state" <> showDefault + optDebug <- + flag' True (long "debug" <> help "be super verbose about what's happening") + <|> pure False pure Opts {..} delaySec :: Float -> IO () @@ -109,23 +112,32 @@ main = do <> header "git-auto-acp -- automatically add-commit-push files" <> (footer "This program is free software; see LICENSE file for details.")) + let dbg + | optDebug o = hPutStrLn stderr . ("*** " ++) + | otherwise = const $ pure () git <- fromMaybe "git" <$> lookupEnv "AUTO_ACP_GIT" + dbg $ "using git: " ++ git gitDir <- fromMaybe ".git" <$> lookupEnv "AUTO_ACP_GIT_DIRNAME" + dbg $ "filtering out git directory: " ++ gitDir withManager $ \fsmgr -> do chan <- newChan - done <- newEmptyMVar -- TODO catch sigterm + done <- newEmptyMVar + installHandler sigINT (Catch $ writeChan chan Finished) Nothing -- start some watchers - for_ (optWatches o) $ \w@(Watch path _) -> - watchTree fsmgr path (allEvents $ not . elem gitDir . splitPath) . const - $ writeChan chan (Change w) + for_ (optWatches o) $ \w@(Watch path _) -> do + dbg $ "starting a watch: " ++ show w + watchTree fsmgr path (allEvents $ not . elem gitDir . splitDirectories) $ \ev -> do + dbg $ "fsnotify says: " ++ show ev + writeChan chan (Change w) -- start the event crunching thread void . forkIO $ let loop :: S.Set Watch -> TimeSpec -> Int -> TimeSpec -> Int -> IO () loop ws lastAdd addsPending lastPush pushesPending = do ev <- readChan chan + dbg $ "processing event: " ++ show ev now <- getTime Monotonic case ev of - Finished -> pure () + Finished -> putMVar done () Change w -> do void . forkIO $ delaySec (optAddCommitDelay o) >> writeChan chan AddBounce @@ -145,10 +157,12 @@ main = do | not (S.null ws) , addsPending == 1 || intervalPassed (optAddCommitDelay o) now lastAdd -> do - for_ ws $ \(Watch p addAll) -> do + for_ ws $ \w@(Watch p addAll) -> do + dbg $ "will add: " ++ show w if addAll then runCmd git ["add", p] - else runCmd git ["add", "--all", p] + else runCmd git ["add", "--ignore-removal", p] + dbg "commit!" runCmd git ["commit", "--message", optMsg o] loop S.empty now (pred addsPending) lastPush pushesPending | otherwise -> @@ -161,6 +175,7 @@ main = do PushBounce | Just pd <- optPushDelay o , pushesPending == 1 || intervalPassed pd now lastPush -> do + dbg $ "push!" runCmd git ["push"] loop ws lastAdd addsPending now (pred pushesPending) | otherwise -> |