{-# 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 WatchType
  = UpdateOnly
  | Add
  | AddAndRemove
  deriving (Show, Eq, Ord)

watchGitOption :: WatchType -> String
watchGitOption x =
  case x of
    UpdateOnly -> "--update"
    Add -> "--ignore-removal"
    AddAndRemove -> "--no-ignore-removal"

data Watch = Watch
  { watchPath :: FilePath
  , watchWithRemoval :: WatchType
  } 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` UpdateOnly) . strOption
              ~~ [ 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"
                 ]
          , fmap (`Watch` AddAndRemove) . 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 <-
    asum
      [ 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 = 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}