git-monitor 1.4.0 → 2.0.0.0
raw patch · 2 files changed
+50/−41 lines, 2 filesdep ~gitlibdep ~gitlib-libgit2
Dependency ranges changed: gitlib, gitlib-libgit2
Files
- Main.hs +47/−38
- git-monitor.cabal +3/−3
Main.hs view
@@ -11,6 +11,7 @@ module Main where import Control.Concurrent (threadDelay)+import Control.Exception import Control.Monad import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Class@@ -21,11 +22,11 @@ import qualified Data.Map as Map import Data.Maybe import Data.Text (Text)-import qualified Data.Text as T (Text, pack, unpack)+import qualified Data.Text as T #if MIN_VERSION_shelly(1, 0, 0)-import qualified Data.Text as TL (Text, pack, unpack, init)+import qualified Data.Text as TL #else-import qualified Data.Text.Lazy as TL (Text, pack, unpack, toStrict, init)+import qualified Data.Text.Lazy as TL #endif import Data.Time import Filesystem (getModified, isDirectory, isFile, canonicalizePath)@@ -49,6 +50,13 @@ toStrict = TL.toStrict #endif +fromStrict :: T.Text -> TL.Text+#if MIN_VERSION_shelly(1, 0, 0)+fromStrict = id+#else+fromStrict = TL.fromStrict+#endif+ instance Read FilePath data Options = Options@@ -108,7 +116,7 @@ infoL $ "Working tree: " ++ fileStr wd ref <- lookupReference "HEAD" void $ case ref of- Just (Reference _ (RefSymbolic name)) -> do+ Just (RefSymbolic name) -> do infoL $ "Tracking branch " ++ T.unpack name start wd (toStrict userName) (toStrict userEmail) name _ -> do@@ -163,7 +171,7 @@ -> Text -> Commit (LgRepository m) -> TreeOid (LgRepository m)- -> Map FilePath (FileEntry (LgRepository m))+ -> Map Text (FileEntry (LgRepository m)) -> LgRepository m () snapshotTree opts wd name email ref sref = fix $ \loop sc toid ft -> do -- Read the current working tree's state on disk@@ -199,9 +207,7 @@ -- Rinse, wash, repeat. ref' <- lookupReference "HEAD"- let curRef = case ref' of- Just (Reference _ (RefSymbolic ref'')) -> ref''- _ -> ""+ let curRef = case ref' of Just (RefSymbolic ref'') -> ref''; _ -> "" if ref /= curRef then infoL $ "Branch changed to " ++ T.unpack curRef ++ ", restarting"@@ -209,48 +215,48 @@ where scanOldEntry :: MonadGit m- => Map FilePath (FileEntry (LgRepository m))- -> FilePath+ => Map Text (FileEntry (LgRepository m))+ -> Text -> FileEntry (LgRepository m) -> TreeT (LgRepository m) () scanOldEntry ft fp _ = case Map.lookup fp ft of Nothing -> do- lift . infoL $ "Removed: " ++ fileStr fp+ lift . infoL $ "Removed: " <> T.unpack fp dropEntry fp _ -> return () scanNewEntry :: MonadGit m- => Map FilePath (FileEntry (LgRepository m))- -> FilePath+ => Map Text (FileEntry (LgRepository m))+ -> Text -> FileEntry (LgRepository m) -> TreeT (LgRepository m) ()- scanNewEntry ft fp (FileEntry mt (BlobEntry oid exe) _) =+ scanNewEntry ft fp (FileEntry mt oid kind _) = case Map.lookup fp ft of Nothing -> do- lift . infoL $ "Added to snapshot: " ++ fileStr fp- putBlob' fp oid exe- Just (FileEntry oldMt (BlobEntry oldOid oldExe) fileOid)- | oid /= oldOid || exe /= oldExe -> do- lift . infoL $ "Changed: " ++ fileStr fp- putBlob' fp oid exe+ lift . infoL $ "Added to snapshot: " ++ T.unpack fp+ putBlob' fp oid kind+ Just (FileEntry oldMt oldOid oldKind fileOid)+ | oid /= oldOid || kind /= oldKind -> do+ lift . infoL $ "Changed: " ++ T.unpack fp+ putBlob' fp oid kind | mt /= oldMt || oid /= fileOid -> do path <- fileStr <$>- liftIO (canonicalizePath (wd </> fp))- lift . infoL $ "Changed: " ++ fileStr fp+ liftIO (canonicalizePath+ (wd </> fromText (fromStrict fp)))+ lift . infoL $ "Changed: " ++ T.unpack fp contents <- liftIO $ B.readFile path newOid <- lift $ createBlob (BlobString contents)- putBlob' fp newOid exe+ putBlob' fp newOid kind | otherwise -> return ()- _ -> return ()- scanNewEntry _ft _fp (FileEntry _mt _ _foid) = return () data FileEntry m = FileEntry- { fileModTime :: UTCTime- , fileBlobEntry :: TreeEntry m- , fileChecksum :: BlobOid m+ { fileModTime :: UTCTime+ , fileBlobOid :: BlobOid m+ , fileBlobKind :: BlobKind+ , fileChecksum :: BlobOid m } -type FileTree m = Map FilePath (FileEntry m)+type FileTree m = Map Text (FileEntry m) readFileTree :: MonadGit m => Text@@ -270,30 +276,33 @@ -> LgRepository m (FileTree (LgRepository m)) readFileTree' tr wdir getHash = do blobs <- treeBlobEntries tr- foldlM (\m (fp,ent) -> do- fent <- readModTime wdir getHash fp ent+ foldlM (\m (fp,oid,kind) -> do+ fent <- readModTime wdir getHash fp oid kind return $ maybe m (flip (Map.insert fp) m) fent) Map.empty blobs readModTime :: MonadGit m => FilePath -> Bool- -> FilePath- -> TreeEntry (LgRepository m)+ -> Text+ -> BlobOid (LgRepository m)+ -> BlobKind -> LgRepository m (Maybe (FileEntry (LgRepository m)))-readModTime wdir getHash fp ent = do- let path = wdir </> fp+readModTime wdir getHash fp oid kind = do+ let path = wdir </> fromText (fromStrict fp) debugL $ "Checking file: " ++ fileStr path exists <- liftIO $ isFile path if exists then Just <$> (FileEntry <$> liftIO (getModified path)- <*> pure ent+ <*> pure oid+ <*> pure kind <*> if getHash- then do contents <- liftIO $ B.readFile (fileStr path)+ then do contents <- liftIO $ evaluate+ =<< B.readFile (fileStr path) hashContents (BlobString contents)- else return (blobEntryOid ent))+ else return oid) else return Nothing fileStr :: FilePath -> String
git-monitor.cabal view
@@ -1,5 +1,5 @@ Name: git-monitor-Version: 1.4.0+Version: 2.0.0.0 Synopsis: Passively snapshots working tree changes efficiently. Description: Passively snapshots working tree changes efficiently.@@ -23,8 +23,8 @@ Build-depends: base >= 4 && < 5 , bytestring >= 0.9.2.1 , containers >= 0.4.2.1- , gitlib >= 1.4.0- , gitlib-libgit2 >= 1.4.0+ , gitlib >= 2.0.0.0+ , gitlib-libgit2 >= 2.0.0.0 , hslogger >= 1.2 , old-locale >= 1.0.0.4 , optparse-applicative >= 0.5.2.1