git-monitor (empty) → 1.0.0
raw patch · 5 files changed
+354/−0 lines, 5 filesdep +basedep +bytestringdep +containerssetup-changed
Dependencies added: base, bytestring, containers, gitlib, gitlib-libgit2, gitlib-utils, hslogger, old-locale, optparse-applicative, shelly, system-fileio, system-filepath, text, time, transformers
Files
- LICENSE +28/−0
- Main.hs +285/−0
- README.md +0/−0
- Setup.hs +0/−0
- git-monitor.cabal +41/−0
+ LICENSE view
@@ -0,0 +1,28 @@+Copyright (c) 2003-2009, John Wiegley. All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++- Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++- Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++- Neither the name of New Artisans LLC nor the names of its+ contributors may be used to endorse or promote products derived from+ this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Main.hs view
@@ -0,0 +1,285 @@+{-# LANGUAGE OverloadedStrings #-}++{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}++module Main where++import Control.Concurrent (threadDelay)+import Control.Monad+import Control.Monad.IO.Class (MonadIO(..))+import qualified Data.ByteString as B (readFile)+import Data.Function (fix)+import Data.Foldable (foldlM)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+import Data.Text (Text)+import qualified Data.Text as T (pack, unpack)+import qualified Data.Text.Lazy as TL (pack, unpack, toStrict, init)+import Data.Time+import Filesystem (getModified, isDirectory, isFile, canonicalizePath)+import Filesystem.Path.CurrentOS (FilePath, (</>), parent, null)+import Git hiding (Options)+import Git.Libgit2 (lgFactory, withLibGitDo)+import Git.Utils (treeBlobEntries)+import Options.Applicative+import Prelude hiding (FilePath, null)+import Shelly (toTextIgnore, fromText, silently, shelly, run)+import System.IO (stderr)+import System.Locale (defaultTimeLocale)+import System.Log.Formatter (tfLogFormatter)+import System.Log.Handler (setFormatter)+import System.Log.Handler.Simple (streamHandler)+import System.Log.Logger++instance Read FilePath++data Options = Options+ { verbose :: Bool+ , debug :: Bool+ , gitDir :: String+ , workingDir :: String+ , interval :: Int+ , resume :: Bool+ }++options :: Parser Options+options = Options+ <$> switch (short 'v' <> long "verbose" <> help "Display info")+ <*> switch (short 'D' <> long "debug" <> help "Display debug")+ <*> strOption+ (long "git-dir" <> value ".git"+ <> help "Git repository to store snapshots in (def: \".git\")")+ <*> strOption (short 'd' <> long "work-dir" <> value ""+ <> 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+ <> help "Resumes using last set of snapshots")++main :: IO ()+main = withLibGitDo $ execParser opts >>= doMain+ where+ opts = info (helper <*> options)+ (fullDesc <> progDesc desc <> header hdr)+ hdr = "git-monitor 1.0.0 - quickly snapshot working tree changes"+ desc = "\nPassively snapshot working tree changes efficiently.\n\n\+ \The intended usage is to run \"git monitor &\" in your project\n\+ \directory before you begin a hacking session.\n\n\+ \Snapshots are kept in refs/snapshots/refs/heads/$BRANCH"++doMain :: Options -> IO ()+doMain opts = do+ -- Setup logging service if --verbose is used+ when (verbose opts) $ initLogging (debug opts)++ -- 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"])++ let gDir = fromText (TL.pack (gitDir opts))+ isDir <- isDirectory gDir+ gd <- if isDir+ then return gDir+ else shelly $ silently $+ fromText . TL.init <$> run "git" ["rev-parse", "--git-dir"]++ let wDir = fromText (TL.pack (workingDir opts))+ wd = if null wDir then parent 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 " ++ fileStr gd+ infoL $ "Working tree: " ++ fileStr wd+ ref <- lookupRef "HEAD"+ void $ case ref of+ Just (Reference _ (RefSymbolic name)) -> do+ infoL $ "Tracking branch " ++ T.unpack name+ start wd (TL.toStrict userName) (TL.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+ | verbose opts = INFO+ | otherwise = NOTICE+ 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++ -- Usually we ignore any snapshot history from a prior invocation of+ -- git-monitor, leaving those objects for git gc to cleanup; however,+ -- if --resume, continue the snapshot history from where we last left+ -- off. Note that if --resume is always used, this can end up+ -- consuming a lot of disk space over time.+ --+ -- 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+ then resolveRef sref+ else return Nothing+ scr' <- maybe (fromJust <$> resolveRef "HEAD") return scr+ sc <- resolveCommitRef scr'+ str <- resolveTreeRef (commitTree sc)+ toid <- writeTree str+ ft <- readFileTree' str 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.+ snapshotTree opts wd userName userEmail ref sref sc str toid ft++-- | '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 :: (Repository m, MonadIO m)+ => Options -> FilePath+ -> Text -> Text -> Text -> Text+ -> Commit m -> Tree m -> TreeOid m+ -> Map FilePath (FileEntry m)+ -> m ()+snapshotTree opts wd name email ref sref = fix $ \loop sc str toid ft -> do+ -- Read the current working tree's state on disk+ ft' <- readFileTree ref wd False++ -- Prune files which have been removed since the last interval, and find+ -- files which have been added or changed+ Map.foldlWithKey' (\a p e -> a >> scanOldEntry str ft' p e) (return ()) ft+ Map.foldlWithKey' (\a p e -> a >> scanNewEntry str ft p e) (return ()) ft'++ -- If the snapshot tree changed, create a new commit to reflect it+ toid' <- writeTree str+ sc' <- if toid /= toid'+ then do+ now <- liftIO getZonedTime+ let sig = Signature+ { signatureName = name+ , signatureEmail = email+ , signatureWhen = now+ }+ msg = "Snapshot at "+ ++ formatTime defaultTimeLocale "%F %T %Z" now++ c <- createCommit [commitRef sc] (treeRef str)+ sig sig (T.pack msg) (Just sref)+ infoL $ "Commit "+ ++ (T.unpack . renderObjOid . commitOid $ c)+ return c+ else return sc++ -- Wait a given number of seconds+ liftIO $ threadDelay (interval opts * 1000000)++ -- Rinse, wash, repeat.+ ref' <- lookupRef "HEAD"+ let curRef = case ref' of+ Just (Reference _ (RefSymbolic ref'')) -> ref''+ _ -> ""+ if ref /= curRef+ then infoL $ "Branch changed to " ++ T.unpack curRef+ ++ ", restarting"+ else loop sc' str toid' ft'++ where+ scanOldEntry :: (Repository m, MonadIO m)+ => Tree m+ -> Map FilePath (FileEntry m)+ -> FilePath -> FileEntry m -> m ()+ scanOldEntry str ft fp _ = case Map.lookup fp ft of+ Nothing -> do+ infoL $ "Removed: " ++ fileStr fp+ dropFromTree str fp+ _ -> return ()++ scanNewEntry :: (Repository m, MonadIO m)+ => Tree m+ -> Map FilePath (FileEntry m)+ -> FilePath -> FileEntry m -> m ()+ scanNewEntry str ft fp (FileEntry mt (BlobEntry oid exe) _) =+ case Map.lookup fp ft of+ Nothing -> do+ infoL $ "Added to snapshot: " ++ fileStr fp+ putBlob' str fp oid exe+ Just (FileEntry oldMt (BlobEntry oldOid oldExe) fileOid)+ | oid /= oldOid || exe /= oldExe -> do+ infoL $ "Changed: " ++ fileStr fp+ putBlob' str fp oid exe+ | mt /= oldMt || oid /= fileOid -> do+ path <- fileStr <$>+ liftIO (canonicalizePath (wd </> fp))+ infoL $ "Changed: " ++ fileStr fp+ contents <- liftIO $ B.readFile path+ newOid <- createBlob (BlobString contents)+ putBlob' str fp newOid exe+ | otherwise -> return ()+ _ -> return ()+ scanNewEntry _str _ft _fp (FileEntry _mt _ _foid) = return ()++data FileEntry m = FileEntry+ { fileModTime :: UTCTime+ , fileBlobEntry :: TreeEntry m+ , fileChecksum :: BlobOid m+ }++type FileTree m = Map FilePath (FileEntry m)++readFileTree :: (Repository m, MonadIO m)+ => Text -> FilePath -> Bool -> m (FileTree m)+readFileTree ref wdir getHash = do+ h <- resolveRef ref+ case h of+ Nothing -> pure Map.empty+ Just h' -> do+ tr <- resolveTreeRef . commitTree =<< resolveCommitRef h'+ readFileTree' tr wdir getHash++readFileTree' :: (Repository m, MonadIO m)+ => Tree m -> FilePath -> Bool -> m (FileTree m)+readFileTree' tr wdir getHash = do+ blobs <- treeBlobEntries tr+ foldlM (\m (fp,ent) -> do+ fent <- readModTime wdir getHash fp ent+ return $ maybe m (flip (Map.insert fp) m) fent)+ Map.empty blobs++readModTime :: (Repository m, MonadIO m)+ => FilePath -> Bool -> FilePath -> TreeEntry m+ -> m (Maybe (FileEntry m))+readModTime wdir getHash fp ent = do+ let path = wdir </> fp+ debugL $ "Checking file: " ++ fileStr path+ exists <- liftIO $ isFile path+ if exists+ then Just <$>+ (FileEntry+ <$> liftIO (getModified path)+ <*> pure ent+ <*> if getHash+ then do contents <- liftIO $ B.readFile (fileStr path)+ hashContents (BlobString contents)+ else return (blobEntryOid ent))+ else return Nothing++fileStr :: FilePath -> String+fileStr = TL.unpack . toTextIgnore++infoL :: (Repository m, MonadIO m) => String -> m ()+infoL = liftIO . infoM "git-monitor"++debugL :: (Repository m, MonadIO m) => String -> m ()+debugL = liftIO . debugM "git-monitor"++-- Main.hs (git-monitor) ends here
+ README.md view
+ Setup.hs view
+ git-monitor.cabal view
@@ -0,0 +1,41 @@+Name: git-monitor+Version: 1.0.0++Synopsis: Passively snapshots working tree changes efficiently.+Description: Passively snapshots working tree changes efficiently.++Homepage: git://github.com/fpco/gitlib+License: BSD3+License-file: LICENSE+Author: John Wiegley+Maintainer: John Wiegley <johnw@fpcomplete.com>+Category: Development+Build-type: Simple+Cabal-version: >= 1.10++Extra-Source-Files: README.md++Executable git-monitor+ Main-is: Main.hs+ Default-language: Haskell2010+ ghc-options: -Wall++ Build-depends: base >= 4 && < 5+ , bytestring >= 0.9.2.1+ , containers >= 0.4.2.1+ , gitlib >= 1.0.1+ , gitlib-utils >= 1.0.1+ , gitlib-libgit2 >= 1.0.1+ , hslogger >= 1.2+ , old-locale >= 1.0.0.4+ , optparse-applicative >= 0.5.2.1+ , shelly >= 0.14+ , system-fileio >= 0.3.11+ , system-filepath >= 0.4.7+ , text >= 0.11.2+ , time >= 1.4+ , transformers >= 0.3.0.0++Source-repository head+ type: git+ location: git://github.com/fpco/gitlib