git-monitor 3.0.1 → 3.1.1
raw patch · 2 files changed
+85/−124 lines, 2 filesdep +lifted-asyncdep +loggingdep +unordered-containersdep −fast-loggerdep −hsloggerdep ~gitlib
Dependencies added: lifted-async, logging, unordered-containers
Dependencies removed: fast-logger, hslogger
Dependency ranges changed: gitlib
Files
- Main.hs +76/−116
- git-monitor.cabal +9/−8
Main.hs view
@@ -1,8 +1,8 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-}@@ -10,77 +10,44 @@ module Main where import Control.Concurrent (threadDelay)+import Control.Concurrent.Async.Lifted import Control.Exception+import Control.Logging 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-import Data.Foldable (foldlM)+import Data.Foldable (foldl') import Data.Function (fix)-import Data.Map (Map)-import qualified Data.Map as Map+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as Map import Data.Maybe import Data.Tagged+import Data.Text (pack) 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 (MonadLg, LgRepo, lgFactoryLogger) import Options.Applicative+import Prelude hiding (log) 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-#else-toStrict = TL.toStrict-#endif--fromStrict :: T.Text -> TL.Text-#if MIN_VERSION_shelly(1, 0, 0)-fromStrict = id-#else-fromStrict = TL.fromStrict-#endif- data Options = Options- { quiet :: Bool- , verbose :: Bool- , debug :: Bool- , gitDir :: FilePath- , workingDir :: FilePath- , interval :: Int- , resume :: Bool+ { optQuiet :: Bool+ , optVerbose :: Bool+ , optDebug :: Bool+ , optGitDir :: FilePath+ , optWorkingDir :: FilePath+ , optInterval :: Int+ , optResume :: Bool } options :: Parser Options@@ -95,61 +62,55 @@ <> help "The working tree to snapshot (def: \".\")") <*> option (short 'i' <> long "interval" <> value 60 <> help "Snapshot each N seconds")- <*> switch (short 'r' <> long "resume" <> value False+ <*> switch (short 'r' <> long "resume" <> help "Resumes using last set of snapshots") main :: IO ()-main = execParser opts >>= doMain+main = execParser opts >>= withStdoutLogging . doMain where opts = info (helper <*> options) (fullDesc <> progDesc desc <> header hdr)- hdr = "git-monitor 1.0.0 - quickly snapshot working tree changes"+ hdr = "git-monitor 3.1.0 - quickly snapshot working tree changes" desc = "\nPassively snapshot working tree changes efficiently.\n\nThe intended usage is to run \"git monitor &\" in your project\ndirectory before you begin a hacking session.\n\nSnapshots are kept in refs/snapshots/refs/heads/$BRANCH" doMain :: Options -> IO () doMain opts = do -- Setup logging service if --verbose is used- unless (quiet opts) $ initLogging (debug opts)+ setLogTimeFormat "%H:%M:%S"+ setLogLevel $ if optQuiet opts+ then LevelError+ else if optDebug opts+ then LevelDebug+ else LevelInfo -- Ask Git for the user name and email in this repository (userName,userEmail) <- shelly $ silently $- (,) <$> (TL.init <$> run "git" ["config", "user.name"])- <*> (TL.init <$> run "git" ["config", "user.email"])+ (,) <$> (T.init <$> run "git" ["config", "user.name"])+ <*> (T.init <$> run "git" ["config", "user.email"]) - let gDir = gitDir opts+ let gDir = optGitDir opts isDir <- doesDirectoryExist gDir gd <- if isDir then return gDir else shelly $ silently $- TL.unpack . TL.init <$> run "git" ["rev-parse", "--git-dir"]+ T.unpack . T.init <$> run "git" ["rev-parse", "--git-dir"] - let wDir = workingDir opts+ let wDir = optWorkingDir opts wd = if null wDir then takeDirectory gd else wDir -- Make sure we're in a known branch, and if so, let it begin- 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)+ forever $ withRepository lgFactoryLogger gd $ do+ log' $ pack $ "Saving snapshots under " ++ gd+ log' $ pack $ "Working tree: " ++ wd+ ref <- lookupReference "HEAD"+ case ref of+ Just (RefSymbolic name) -> do+ log' $ "Tracking branch " <> name+ void $ start wd userName userEmail name+ _ -> do+ log' "Cannot use git-monitor if no branch is checked out"+ liftIO $ threadDelay (optInterval opts * 1000000) where- initLogging debugMode = do- let level | debugMode = DEBUG- | otherwise = INFO- h <- (`setFormatter` tfLogFormatter "%H:%M:%S" "$time - [$prio] $msg")- <$> streamHandler System.IO.stderr level- removeAllHandlers- updateGlobalLogger "git-monitor" (setLevel level)- updateGlobalLogger "git-monitor" (addHandler h)- start wd userName userEmail ref = do let sref = "refs/snapshots/" <> ref @@ -162,20 +123,24 @@ -- Also, it is useful to root the snapshot history at the current HEAD -- commit. Note that it must be a Just value at this point, see -- above.- scr <- if resume opts+ scr <- if optResume opts then resolveReference sref else return Nothing- scr' <- maybe (fromJust <$> resolveReference "HEAD") return scr- sc <- lookupCommit (Tagged scr')- let toid = commitTree sc- tree <- lookupTree toid- ft <- readFileTree' tree wd (isNothing scr)+ scr' <- maybe (resolveReference "HEAD") (return . Just) scr+ case scr' of+ Nothing -> errorL "Failed to lookup reference"+ Just r -> do+ sc <- lookupCommit (Tagged r)+ let toid = commitTree sc+ tree <- lookupTree toid+ ft <- readFileTree' tree wd (isNothing scr) - -- Begin the snapshotting process, which continues indefinitely until- -- the process is stopped. It is safe to cancel this process at any- -- time, typically using SIGINT (C-c) or even SIGKILL.- mutateTreeOid toid $- snapshotTree opts wd userName userEmail ref sref sc toid ft+ -- Begin the snapshotting process, which continues+ -- indefinitely until the process is stopped. It is safe to+ -- cancel this process at any time, typically using SIGINT+ -- (C-c) or even SIGKILL.+ mutateTreeOid toid $+ snapshotTree opts wd userName userEmail ref sref sc toid ft -- | 'snapshotTree' is the core workhorse of this utility. It periodically -- checks the filesystem for changes to Git-tracked files, and snapshots any@@ -189,7 +154,7 @@ -> RefName -> Commit LgRepo -> TreeOid LgRepo- -> Map TreeFilePath (FileEntry LgRepo)+ -> HashMap 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@@ -216,50 +181,48 @@ c <- lift $ createCommit [commitOid sc] toid' sig sig (T.pack msg) (Just sref)- lift $ infoL $ "Commit "- ++ (T.unpack . renderObjOid . commitOid $ c)+ lift $ log' $ "Commit " <> (renderObjOid . commitOid $ c) return c else return sc -- Wait a given number of seconds- liftIO $ threadDelay (interval opts * 1000000)+ liftIO $ threadDelay (optInterval opts * 1000000) -- Rinse, wash, repeat. ref' <- lift $ lookupReference "HEAD" let curRef = case ref' of Just (RefSymbolic ref'') -> ref''; _ -> "" if ref /= curRef- then lift $ infoL $ "Branch changed to " ++ T.unpack curRef- ++ ", restarting"+ then lift $ log' $ "Branch changed to " <> curRef <> ", restarting" else loop sc' toid' ft' where scanOldEntry :: (MonadGit LgRepo m, MonadLg m)- => Map TreeFilePath (FileEntry LgRepo)+ => HashMap TreeFilePath (FileEntry LgRepo) -> TreeFilePath -> FileEntry LgRepo -> TreeT LgRepo m () scanOldEntry ft fp _ = case Map.lookup fp ft of Nothing -> do- lift . infoL $ "Removed: " <> B8.unpack fp+ log' $ "Removed: " <> T.decodeUtf8 fp dropEntry fp _ -> return () scanNewEntry :: (MonadGit LgRepo m, MonadLg m)- => Map TreeFilePath (FileEntry LgRepo)+ => HashMap TreeFilePath (FileEntry LgRepo) -> TreeFilePath -> FileEntry LgRepo -> TreeT LgRepo m () scanNewEntry ft fp (FileEntry mt oid kind _) = case Map.lookup fp ft of Nothing -> do- lift . infoL $ "Added to snapshot: " ++ B8.unpack fp+ log' $ "Added to snapshot: " <> T.decodeUtf8 fp putBlob' fp oid kind Just (FileEntry oldMt oldOid oldKind fileOid) | oid /= oldOid || kind /= oldKind -> do- lift . infoL $ "Changed: " ++ B8.unpack fp+ log' $ "Changed: " <> T.decodeUtf8 fp putBlob' fp oid kind | mt /= oldMt || oid /= fileOid -> do- lift . infoL $ "Changed: " ++ B8.unpack fp+ log' $ "Changed: " <> T.decodeUtf8 fp path <- liftIO $ canonicalizePath (wd </> B8.unpack fp) contents <- liftIO $ B.readFile path newOid <- lift $ createBlob (BlobString contents)@@ -273,7 +236,7 @@ , fileChecksum :: BlobOid m } -type FileTree m = Map TreeFilePath (FileEntry m)+type FileTree m = HashMap TreeFilePath (FileEntry m) readFileTree :: (MonadGit LgRepo m, MonadLg m) => RefName@@ -293,10 +256,13 @@ -> m (FileTree LgRepo) readFileTree' tr wdir getHash = do blobs <- treeBlobEntries tr- foldlM (\m (fp,oid,kind) -> do- fent <- readModTime wdir getHash (B8.unpack fp) oid kind- return $ maybe m (flip (Map.insert fp) m) fent)- Map.empty blobs+ stats <- mapConcurrently go blobs+ return $ foldl' (\m (!fp,!fent) -> maybe m (flip (Map.insert fp) m) fent)+ Map.empty stats+ where+ go (!fp,!oid,!kind) = do+ fent <- readModTime wdir getHash (B8.unpack fp) oid kind+ fent `seq` return (fp,fent) readModTime :: (MonadGit LgRepo m, MonadLg m) => FilePath@@ -307,7 +273,7 @@ -> m (Maybe (FileEntry LgRepo)) readModTime wdir getHash fp oid kind = do let path = wdir </> fp- debugL $ "Checking file: " ++ path+ debug' $ pack $ "Checking file: " ++ path estatus <- liftIO $ try $ getSymbolicLinkStatus path case (estatus :: Either SomeException FileStatus) of Right status | isRegularFile status ->@@ -321,11 +287,5 @@ =<< liftIO (B.readFile path) else return oid) _ -> return Nothing--infoL :: MonadIO m => String -> m ()-infoL = liftIO . infoM "git-monitor"--debugL :: MonadIO m => String -> m ()-debugL = liftIO . debugM "git-monitor" -- Main.hs (git-monitor) ends here
git-monitor.cabal view
@@ -1,14 +1,14 @@ Name: git-monitor-Version: 3.0.1+Version: 3.1.1 Synopsis: Passively snapshots working tree changes efficiently. Description: Passively snapshots working tree changes efficiently. -Homepage: http://github.com/fpco/gitlib+Homepage: http://github.com/jwiegley/gitlib License: BSD3 License-file: LICENSE Author: John Wiegley-Maintainer: John Wiegley <johnw@fpcomplete.com>+Maintainer: John Wiegley <johnw@newartisans.com> Category: Development Build-type: Simple Cabal-version: >= 1.10@@ -18,17 +18,16 @@ Executable git-monitor Main-is: Main.hs Default-language: Haskell2010- ghc-options: -Wall+ ghc-options: -Wall -threaded -rtsopts Build-depends: base >= 4 && < 5- , gitlib >= 3.0.0+ , gitlib >= 3.0.1 , gitlib-libgit2 >= 3.0.0 , bytestring >= 0.9.2.1 , containers >= 0.4.2.1 , directory >= 1.1.0.2- , fast-logger >= 2.1+ , logging >= 1.3.0 , filepath >= 1.3.0.0- , hslogger >= 1.2 , monad-logger , old-locale >= 1.0.0.4 , optparse-applicative >= 0.5.2.1@@ -38,8 +37,10 @@ , text >= 0.11.2 , time >= 1.4 , transformers >= 0.3.0.0+ , unordered-containers >= 0.2.3.0+ , lifted-async >= 0.1.1 , unix Source-repository head type: git- location: git://github.com/fpco/gitlib+ location: git://github.com/jwiegley/gitlib