git-monitor 2.1.0.0 → 3.0.0
raw patch · 2 files changed
+63/−41 lines, 2 filesdep +fast-loggerdep +monad-loggerdep +taggeddep ~gitlibdep ~gitlib-libgit2
Dependencies added: fast-logger, monad-logger, tagged, template-haskell
Dependency ranges changed: gitlib, gitlib-libgit2
Files
- Main.hs +56/−38
- git-monitor.cabal +7/−3
Main.hs view
@@ -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
git-monitor.cabal view
@@ -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