diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -12,6 +12,7 @@ import Control.Concurrent (threadDelay) import Control.Monad import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Logger import Control.Monad.Trans.Class import qualified Data.ByteString as B (readFile) import qualified Data.ByteString.Char8 as B8 @@ -20,28 +21,43 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe +import Data.Tagged import qualified Data.Text as T #if MIN_VERSION_shelly(1, 0, 0) import qualified Data.Text as TL #else import qualified Data.Text.Lazy as TL #endif +import qualified Data.Text.Encoding as T import Data.Time import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Git hiding (Options) -import Git.Libgit2 (LgRepository, lgFactory, withLibGitDo) +import Git.Libgit2 (MonadLg, LgRepo, lgFactoryLogger) import Options.Applicative import Shelly (silently, shelly, run) import System.Directory import System.FilePath.Posix import System.IO (stderr) import System.Locale (defaultTimeLocale) +import System.Log.FastLogger import System.Log.Formatter (tfLogFormatter) import System.Log.Handler (setFormatter) import System.Log.Handler.Simple (streamHandler) import System.Log.Logger import System.Posix.Files +logMLogger :: Loc -> LogSource -> LogLevel -> LogStr -> IO () +logMLogger _loc src lvl str = + logM (T.unpack src) (prio lvl) (convert str) + where + prio LevelDebug = DEBUG + prio LevelInfo = INFO + prio LevelWarn = WARNING + prio LevelError = ERROR + prio (LevelOther _) = INFO + + convert = T.unpack . T.decodeUtf8 . fromLogStr + toStrict :: TL.Text -> T.Text #if MIN_VERSION_shelly(1, 0, 0) toStrict = id @@ -82,7 +98,7 @@ <> help "Resumes using last set of snapshots") main :: IO () -main = withLibGitDo $ execParser opts >>= doMain +main = execParser opts >>= doMain where opts = info (helper <*> options) (fullDesc <> progDesc desc <> header hdr) @@ -110,17 +126,19 @@ wd = if null wDir then takeDirectory gd else wDir -- Make sure we're in a known branch, and if so, let it begin - forever $ withRepository lgFactory gd $ do - infoL $ "Saving snapshots under " ++ gd - infoL $ "Working tree: " ++ wd - ref <- lookupReference "HEAD" - case ref of - Just (RefSymbolic name) -> do - infoL $ "Tracking branch " ++ T.unpack name - void $ start wd (toStrict userName) (toStrict userEmail) name - _ -> do - infoL "Cannot use git-monitor if no branch is checked out" - liftIO $ threadDelay (interval opts * 1000000) + forever $ flip runLoggingT logMLogger $ + withRepository lgFactoryLogger gd $ do + infoL $ "Saving snapshots under " ++ gd + infoL $ "Working tree: " ++ wd + ref <- lookupReference "HEAD" + case ref of + Just (RefSymbolic name) -> do + infoL $ "Tracking branch " ++ T.unpack name + void $ start wd (toStrict userName) (toStrict userEmail) + name + _ -> do + infoL "Cannot use git-monitor if no branch is checked out" + liftIO $ threadDelay (interval opts * 1000000) where initLogging debugMode = do let level | debugMode = DEBUG @@ -147,7 +165,7 @@ then resolveReference sref else return Nothing scr' <- maybe (fromJust <$> resolveReference "HEAD") return scr - sc <- lookupCommit scr' + sc <- lookupCommit (Tagged scr') let toid = commitTree sc tree <- lookupTree toid ft <- readFileTree' tree wd (isNothing scr) @@ -161,17 +179,17 @@ -- | 'snapshotTree' is the core workhorse of this utility. It periodically -- checks the filesystem for changes to Git-tracked files, and snapshots any -- changes that have occurred in them. -snapshotTree :: MonadGit m +snapshotTree :: (MonadGit LgRepo m, MonadLg m) => Options -> FilePath -> CommitAuthor -> CommitEmail -> RefName -> RefName - -> Commit (LgRepository m) - -> TreeOid (LgRepository m) - -> Map TreeFilePath (FileEntry (LgRepository m)) - -> TreeT (LgRepository m) () + -> Commit LgRepo + -> TreeOid LgRepo + -> Map TreeFilePath (FileEntry LgRepo) + -> TreeT LgRepo m () snapshotTree opts wd name email ref sref = fix $ \loop sc toid ft -> do -- Read the current working tree's state on disk ft' <- lift $ readFileTree ref wd False @@ -214,22 +232,22 @@ else loop sc' toid' ft' where - scanOldEntry :: MonadGit m - => Map TreeFilePath (FileEntry (LgRepository m)) + scanOldEntry :: (MonadGit LgRepo m, MonadLg m) + => Map TreeFilePath (FileEntry LgRepo) -> TreeFilePath - -> FileEntry (LgRepository m) - -> TreeT (LgRepository m) () + -> FileEntry LgRepo + -> TreeT LgRepo m () scanOldEntry ft fp _ = case Map.lookup fp ft of Nothing -> do lift . infoL $ "Removed: " <> B8.unpack fp dropEntry fp _ -> return () - scanNewEntry :: MonadGit m - => Map TreeFilePath (FileEntry (LgRepository m)) + scanNewEntry :: (MonadGit LgRepo m, MonadLg m) + => Map TreeFilePath (FileEntry LgRepo) -> TreeFilePath - -> FileEntry (LgRepository m) - -> TreeT (LgRepository m) () + -> FileEntry LgRepo + -> TreeT LgRepo m () scanNewEntry ft fp (FileEntry mt oid kind _) = case Map.lookup fp ft of Nothing -> do @@ -256,22 +274,22 @@ type FileTree m = Map TreeFilePath (FileEntry m) -readFileTree :: MonadGit m +readFileTree :: (MonadGit LgRepo m, MonadLg m) => RefName -> FilePath -> Bool - -> LgRepository m (FileTree (LgRepository m)) + -> m (FileTree LgRepo) readFileTree ref wdir getHash = do h <- resolveReference ref case h of Nothing -> pure Map.empty Just h' -> do - tr <- lookupTree . commitTree =<< lookupCommit h' + tr <- lookupTree . commitTree =<< lookupCommit (Tagged h') readFileTree' tr wdir getHash -readFileTree' :: MonadGit m - => Tree (LgRepository m) -> FilePath -> Bool - -> LgRepository m (FileTree (LgRepository m)) +readFileTree' :: (MonadGit LgRepo m, MonadLg m) + => Tree LgRepo -> FilePath -> Bool + -> m (FileTree LgRepo) readFileTree' tr wdir getHash = do blobs <- treeBlobEntries tr foldlM (\m (fp,oid,kind) -> do @@ -279,13 +297,13 @@ return $ maybe m (flip (Map.insert fp) m) fent) Map.empty blobs -readModTime :: MonadGit m +readModTime :: (MonadGit LgRepo m, MonadLg m) => FilePath -> Bool -> FilePath - -> BlobOid (LgRepository m) + -> BlobOid LgRepo -> BlobKind - -> LgRepository m (Maybe (FileEntry (LgRepository m))) + -> m (Maybe (FileEntry LgRepo)) readModTime wdir getHash fp oid kind = do let path = wdir fp debugL $ "Checking file: " ++ path @@ -303,10 +321,10 @@ else return oid) else return Nothing -infoL :: (Repository m, MonadIO m) => String -> m () +infoL :: MonadIO m => String -> m () infoL = liftIO . infoM "git-monitor" -debugL :: (Repository m, MonadIO m) => String -> m () +debugL :: MonadIO m => String -> m () debugL = liftIO . debugM "git-monitor" -- Main.hs (git-monitor) ends here diff --git a/git-monitor.cabal b/git-monitor.cabal --- a/git-monitor.cabal +++ b/git-monitor.cabal @@ -1,5 +1,5 @@ Name: git-monitor -Version: 2.1.0.0 +Version: 3.0.0 Synopsis: Passively snapshots working tree changes efficiently. Description: Passively snapshots working tree changes efficiently. @@ -21,16 +21,20 @@ ghc-options: -Wall Build-depends: base >= 4 && < 5 - , gitlib >= 2.1.0.0 - , gitlib-libgit2 >= 2.1.0.0 + , gitlib >= 3.0.0 + , gitlib-libgit2 >= 3.0.0 , bytestring >= 0.9.2.1 , containers >= 0.4.2.1 , directory >= 1.1.0.2 + , fast-logger >= 2.1 , filepath >= 1.3.0.0 , hslogger >= 1.2 + , monad-logger , old-locale >= 1.0.0.4 , optparse-applicative >= 0.5.2.1 , shelly >= 0.14 + , tagged >= 0.4.5 + , template-haskell , text >= 0.11.2 , time >= 1.4 , transformers >= 0.3.0.0