diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -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 diff --git a/git-monitor.cabal b/git-monitor.cabal --- a/git-monitor.cabal +++ b/git-monitor.cabal @@ -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