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

module Main where

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

import Control.Concurrent
import Control.Monad
import Data.Foldable
import Data.Maybe
import qualified Data.Set as S
import Options.Applicative
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

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
  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
          (opts <**> helper <**> simpleVersioner (showVersion version))
          (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
    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 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