path: root/Main.hs

{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE RecordWildCards #-}

module Main where

import Data.Version (showVersion)
import Paths_git_auto_acp (version)

import Control.Applicative ((<|>), some)
import Control.Concurrent
  ( 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
  ( 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 Watch = Watch
  { watchPath :: FilePath
  , watchWithRemoval :: Bool
  } deriving (Show, Eq, Ord)

data Opts = Opts
  { optAddCommitDelay :: Float
  , optPushDelay :: Maybe Float
  , optWatches :: [Watch]
  , optMsg :: String
  , optDebug :: Bool
  } deriving (Show)

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
         ]
  optPushDelay <-
    asum
      [ flag' Nothing
          ~~ [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
             ]
      ]
  optWatches <-
    some
      $ asum
          [ fmap (`Watch` False) . strOption
              ~~ [ short 'a'
                 , long "add"
                 , metavar "PATH"
                 , help "paths to auto-add"
                 ]
          , fmap (`Watch` True) . strOption
              ~~ [ 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
         ]
  optDebug <-
    flag' True ~~ [long "debug", help "be super verbose about what's happening"]
      <|> pure False
  pure Opts {..}

delaySec :: Float -> IO ()
delaySec = threadDelay . round . (1000000 *)

intervalPassed :: (Ord a, Num a) => a -> TimeSpec -> TimeSpec -> Bool
intervalPassed i a b =
  1000000000 * i <= fromIntegral (toNanoSecs $ diffTimeSpec a b)

runCmd :: String -> [String] -> IO ()
runCmd prog args = do
  st <- rawSystem prog args
  unless (st == ExitSuccess) . hPutStrLn stderr
    $ prog ++ " failed with args " ++ show args

data Event
  = AddBounce
  | PushBounce
  | Change Watch
  | 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 <-
    customExecParser (prefs $ showHelpOnEmpty)
      $ info
          (simpleVersioner (showVersion version) <*> helper <*> opts)
          (fullDesc
             <> 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
    installHandler sigINT (Catch $ writeChan chan Finished) Nothing
    -- start some watchers
    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 $ 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@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 {- protection against triggering too early -}
              || 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 = 0
                , stCommitSeries = succ stCommitSeries
                }
          | otherwise ->
            loop
              st {stWatch = S.empty, stAddsPending = 0 `max` 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 = 0}
          | otherwise ->
            loop
              st
                { stWatch = S.empty
                , stPushesPending = 0 `max` pred stPushesPending
                }