initial undebugged version

1 files changed, 164 insertions, 0 deletions

diff --git a/Main.hs b/Main.hs
new file mode 100644
index 0000000..070524f
--- /dev/null
+++ b/Main.hs
@@ -0,0 +1,164 @@
+{-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Main
+  ( 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.FilePath.Glob
+import System.IO
+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
+  } 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` False) . strOption
+              $ short 'A'
+                  <> long "add-all"
+                  <> metavar "PATH"
+                  <> help "like `--add' but auto-adds file removals"
+          ]
+  optMsg <-
+    strOption
+      $ short 'm'
+          <> long "message"
+          <> metavar "MSG"
+          <> help "commit message for auto-commits"
+          <> value "update to filesystem state"
+          <> showDefault
+  pure Opts {..}
+
+data Event
+  = AddBounce
+  | PushBounce
+  | Change Watch
+  | Finished
+  deriving (Show, Eq, Ord)
+
+delaySec :: Float -> IO ()
+delaySec = threadDelay . round . (1000000 *)
+
+intervalPassed i a b =
+  1000000000 * i <= fromIntegral (toNanoSecs $ diffTimeSpec a b)
+
+runCmd prog args = do
+  st <- rawSystem prog args
+  unless (st == ExitSuccess) . hPutStrLn stderr
+    $ prog ++ " failed with args " ++ show args
+
+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."))
+  git <- fromMaybe "git" <$> lookupEnv "AUTO_ACP_GIT"
+  withManager $ \fsmgr -> do
+    chan <- newChan
+    done <- newEmptyMVar
+    -- start some watchers
+    for_ (optWatches o) $ \w@(Watch path _) ->
+      watchTree fsmgr path (const True) . const $ writeChan chan (Change w)
+    -- start the event crunching thread
+    forkIO
+      $ let loop ws lastAdd addsPending lastPush pushesPending = do
+              ev <- readChan chan
+              now <- getTime Monotonic
+              case ev of
+                Finished -> pure ()
+                Change w -> do
+                  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
+                      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 $ \(Watch p all) -> do
+                      if all
+                        then runCmd git ["add", p]
+                        else runCmd git ["add", "--all", p]
+                    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
+                    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
+    -- wait for the finish, then terminate
+    takeMVar done