diff options
Diffstat (limited to 'Main.hs')
| -rw-r--r-- | Main.hs | 129 |
1 files changed, 77 insertions, 52 deletions
@@ -75,7 +75,7 @@ opts = do <> long "message" <> metavar "MSG" <> help "commit message for auto-commits" - <> value "update to filesystem state" + <> value "[auto-acs] update #%n" <> showDefault optDebug <- flag' True (long "debug" <> help "be super verbose about what's happening") @@ -102,6 +102,24 @@ data Event | Finished deriving (Show, Eq, Ord) +data St = St + { stWatch :: S.Set Watch + , stLastAdd :: TimeSpec + , stAddsPending :: Int + , stLastPush :: TimeSpec + , stPushesPending :: Int + , stCommitSeries :: Int + } deriving (Show) + +emptyState :: St +emptyState = St S.empty 0 0 0 0 1 + +mkMsg :: Int -> String -> String +mkMsg idx ('%':'n':cs) = show idx ++ mkMsg idx cs +mkMsg idx ('%':'%':cs) = '%' : mkMsg idx cs +mkMsg idx (c:cs) = c : mkMsg idx cs +mkMsg _ [] = [] + main :: IO () main = do o <- @@ -130,56 +148,63 @@ main = 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 -> putMVar done () - Change w -> do - void . forkIO - $ delaySec (optAddCommitDelay o) >> writeChan chan AddBounce - let ws' = S.insert w ws - case optPushDelay o of - Nothing -> - loop ws' lastAdd (succ addsPending) lastPush pushesPending - Just pd -> do - void . forkIO $ delaySec pd >> writeChan chan PushBounce - loop - ws' - lastAdd - (succ addsPending) - lastPush - (succ pushesPending) - AddBounce - | not (S.null ws) - , addsPending == 1 - || intervalPassed (optAddCommitDelay o) now lastAdd -> do - for_ ws $ \w@(Watch p addAll) -> do - dbg $ "will add: " ++ show w - if addAll - then runCmd git ["add", 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 -> - loop - S.empty - lastAdd - (pred addsPending) - lastPush - pushesPending - 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 -> - loop ws lastAdd addsPending lastPush (pred pushesPending) - in loop S.empty 0 0 0 0 + 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 + | not (S.null stWatch) + , stAddsPending == 1 + || intervalPassed (optAddCommitDelay o) now stLastAdd -> do + for_ stWatch $ \w@(Watch p addAll) -> do + dbg $ "will add: " ++ show w + if addAll + then runCmd git ["add", p] + else runCmd git ["add", "--ignore-removal", 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 -- wait for the finish, then terminate takeMVar done |
