git-monitor 2.0.2.0 → 2.1.0.0
raw patch · 2 files changed
+41/−51 lines, 2 filesdep +directorydep +filepathdep −system-fileiodep −system-filepathdep ~gitlibdep ~gitlib-libgit2
Dependencies added: directory, filepath
Dependencies removed: system-fileio, system-filepath
Dependency ranges changed: gitlib, gitlib-libgit2
Files
- Main.hs +36/−46
- git-monitor.cabal +5/−5
Main.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}- {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-}@@ -15,12 +14,12 @@ import Control.Monad.IO.Class (MonadIO(..)) 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.Function (fix) import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe-import Data.Text (Text) import qualified Data.Text as T #if MIN_VERSION_shelly(1, 0, 0) import qualified Data.Text as TL@@ -29,20 +28,19 @@ #endif import Data.Time import Data.Time.Clock.POSIX (posixSecondsToUTCTime)-import Filesystem (isDirectory, canonicalizePath)-import Filesystem.Path.CurrentOS (FilePath, (</>), parent, null) import Git hiding (Options) import Git.Libgit2 (LgRepository, lgFactory, withLibGitDo) import Options.Applicative-import Prelude hiding (FilePath, null)-import Shelly (toTextIgnore, fromText, silently, shelly, run)+import Shelly (silently, shelly, run)+import System.Directory+import System.FilePath.Posix 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-import System.Posix.Files hiding (isDirectory)+import System.Posix.Files toStrict :: TL.Text -> T.Text #if MIN_VERSION_shelly(1, 0, 0)@@ -58,14 +56,12 @@ fromStrict = TL.fromStrict #endif -instance Read FilePath- data Options = Options { quiet :: Bool , verbose :: Bool , debug :: Bool- , gitDir :: String- , workingDir :: String+ , gitDir :: FilePath+ , workingDir :: FilePath , interval :: Int , resume :: Bool }@@ -103,20 +99,20 @@ (,) <$> (TL.init <$> run "git" ["config", "user.name"]) <*> (TL.init <$> run "git" ["config", "user.email"]) - let gDir = fromText (TL.pack (gitDir opts))- isDir <- isDirectory gDir+ let gDir = gitDir opts+ isDir <- doesDirectoryExist gDir gd <- if isDir then return gDir else shelly $ silently $- fromText . TL.init <$> run "git" ["rev-parse", "--git-dir"]+ TL.unpack . TL.init <$> run "git" ["rev-parse", "--git-dir"] - let wDir = fromText (TL.pack (workingDir opts))- wd = if null wDir then parent gd else wDir+ let wDir = workingDir 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 $ withRepository lgFactory gd $ do- infoL $ "Saving snapshots under " ++ fileStr gd- infoL $ "Working tree: " ++ fileStr wd+ infoL $ "Saving snapshots under " ++ gd+ infoL $ "Working tree: " ++ wd ref <- lookupReference "HEAD" case ref of Just (RefSymbolic name) -> do@@ -168,13 +164,13 @@ snapshotTree :: MonadGit m => Options -> FilePath- -> Text- -> Text- -> Text- -> Text+ -> CommitAuthor+ -> CommitEmail+ -> RefName+ -> RefName -> Commit (LgRepository m) -> TreeOid (LgRepository m)- -> Map Text (FileEntry (LgRepository m))+ -> Map TreeFilePath (FileEntry (LgRepository m)) -> TreeT (LgRepository m) () snapshotTree opts wd name email ref sref = fix $ \loop sc toid ft -> do -- Read the current working tree's state on disk@@ -219,35 +215,33 @@ where scanOldEntry :: MonadGit m- => Map Text (FileEntry (LgRepository m))- -> Text+ => Map TreeFilePath (FileEntry (LgRepository m))+ -> TreeFilePath -> FileEntry (LgRepository m) -> TreeT (LgRepository m) () scanOldEntry ft fp _ = case Map.lookup fp ft of Nothing -> do- lift . infoL $ "Removed: " <> T.unpack fp+ lift . infoL $ "Removed: " <> B8.unpack fp dropEntry fp _ -> return () scanNewEntry :: MonadGit m- => Map Text (FileEntry (LgRepository m))- -> Text+ => Map TreeFilePath (FileEntry (LgRepository m))+ -> TreeFilePath -> FileEntry (LgRepository m) -> TreeT (LgRepository m) () scanNewEntry ft fp (FileEntry mt oid kind _) = case Map.lookup fp ft of Nothing -> do- lift . infoL $ "Added to snapshot: " ++ T.unpack fp+ lift . infoL $ "Added to snapshot: " ++ B8.unpack fp putBlob' fp oid kind Just (FileEntry oldMt oldOid oldKind fileOid) | oid /= oldOid || kind /= oldKind -> do- lift . infoL $ "Changed: " ++ T.unpack fp+ lift . infoL $ "Changed: " ++ B8.unpack fp putBlob' fp oid kind | mt /= oldMt || oid /= fileOid -> do- path <- fileStr <$>- liftIO (canonicalizePath- (wd </> fromText (fromStrict fp)))- lift . infoL $ "Changed: " ++ T.unpack fp+ lift . infoL $ "Changed: " ++ B8.unpack fp+ path <- liftIO $ canonicalizePath (wd </> B8.unpack fp) contents <- liftIO $ B.readFile path newOid <- lift $ createBlob (BlobString contents) putBlob' fp newOid kind@@ -260,10 +254,10 @@ , fileChecksum :: BlobOid m } -type FileTree m = Map Text (FileEntry m)+type FileTree m = Map TreeFilePath (FileEntry m) readFileTree :: MonadGit m- => Text+ => RefName -> FilePath -> Bool -> LgRepository m (FileTree (LgRepository m))@@ -281,22 +275,21 @@ readFileTree' tr wdir getHash = do blobs <- treeBlobEntries tr foldlM (\m (fp,oid,kind) -> do- fent <- readModTime wdir getHash fp oid kind+ fent <- readModTime wdir getHash (B8.unpack fp) oid kind return $ maybe m (flip (Map.insert fp) m) fent) Map.empty blobs readModTime :: MonadGit m => FilePath -> Bool- -> Text+ -> FilePath -> BlobOid (LgRepository m) -> BlobKind -> LgRepository m (Maybe (FileEntry (LgRepository m))) readModTime wdir getHash fp oid kind = do- let path = wdir </> fromText (fromStrict fp)- fstr = fileStr path- debugL $ "Checking file: " ++ fstr- status <- liftIO $ getSymbolicLinkStatus fstr+ let path = wdir </> fp+ debugL $ "Checking file: " ++ path+ status <- liftIO $ getSymbolicLinkStatus path if isRegularFile status then Just <$> (FileEntry@@ -306,12 +299,9 @@ <*> pure kind <*> if getHash then hashContents . BlobString- =<< liftIO (B.readFile fstr)+ =<< liftIO (B.readFile path) else return oid) else return Nothing--fileStr :: FilePath -> String-fileStr = TL.unpack . toTextIgnore infoL :: (Repository m, MonadIO m) => String -> m () infoL = liftIO . infoM "git-monitor"
git-monitor.cabal view
@@ -1,5 +1,5 @@ Name: git-monitor-Version: 2.0.2.0+Version: 2.1.0.0 Synopsis: Passively snapshots working tree changes efficiently. Description: Passively snapshots working tree changes efficiently.@@ -21,16 +21,16 @@ ghc-options: -Wall Build-depends: base >= 4 && < 5+ , gitlib >= 2.1.0.0+ , gitlib-libgit2 >= 2.1.0.0 , bytestring >= 0.9.2.1 , containers >= 0.4.2.1- , gitlib >= 2.0.1.1- , gitlib-libgit2 >= 2.0.1.0+ , directory >= 1.1.0.2+ , filepath >= 1.3.0.0 , 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