diff options
| -rw-r--r-- | Annex/CatFile.hs | 7 | ||||
| -rw-r--r-- | Command/Watch.hs | 45 | ||||
| -rw-r--r-- | Git/CatFile.hs | 17 | ||||
| -rw-r--r-- | Git/UpdateIndex.hs | 7 |
4 files changed, 54 insertions, 22 deletions
diff --git a/Annex/CatFile.hs b/Annex/CatFile.hs index bcf44551e..afb14c67f 100644 --- a/Annex/CatFile.hs +++ b/Annex/CatFile.hs @@ -8,6 +8,7 @@ module Annex.CatFile ( catFile, catObject, + catObjectDetails, catFileHandle ) where @@ -17,6 +18,7 @@ import Common.Annex import qualified Git import qualified Git.CatFile import qualified Annex +import Git.Types catFile :: Git.Branch -> FilePath -> Annex L.ByteString catFile branch file = do @@ -28,6 +30,11 @@ catObject ref = do h <- catFileHandle liftIO $ Git.CatFile.catObject h ref +catObjectDetails :: Git.Ref -> Annex (Maybe (L.ByteString, Sha)) +catObjectDetails ref = do + h <- catFileHandle + liftIO $ Git.CatFile.catObjectDetails h ref + catFileHandle :: Annex Git.CatFile.CatFileHandle catFileHandle = maybe startup return =<< Annex.getState Annex.catfilehandle where diff --git a/Command/Watch.hs b/Command/Watch.hs index c57b21ac6..e2ff8d7f9 100644 --- a/Command/Watch.hs +++ b/Command/Watch.hs @@ -18,12 +18,17 @@ import qualified Annex.Queue import qualified Command.Add import qualified Git.Command import qualified Git.UpdateIndex +import qualified Git.HashObject import qualified Backend import Annex.Content +import Annex.CatFile +import Git.Types import Control.Concurrent import Control.Concurrent.STM import Data.Time.Clock +import Data.Bits.Utils +import qualified Data.ByteString.Lazy as L #if defined linux_HOST_OS import Utility.Inotify @@ -127,6 +132,9 @@ madeChange :: FilePath -> String -> Annex (Maybe Change) madeChange file desc = liftIO $ Just <$> (Change <$> getCurrentTime <*> pure file <*> pure desc) +noChange :: Annex (Maybe Change) +noChange = return Nothing + {- Adding a file is tricky; the file has to be replaced with a symlink - but this is race prone, as the symlink could be changed immediately - after creation. To avoid that race, git add is not used to stage the @@ -139,7 +147,7 @@ onAdd :: Handler onAdd file = do showStart "add" file handle =<< Command.Add.ingest file - return Nothing + noChange where handle Nothing = showEndFail handle (Just key) = do @@ -153,22 +161,35 @@ onAdd file = do onAddSymlink :: Handler onAddSymlink file = go =<< Backend.lookupFile file where - go Nothing = do - addlink =<< liftIO (readSymbolicLink file) - madeChange file "add" + go Nothing = addlink =<< liftIO (readSymbolicLink file) go (Just (key, _)) = do link <- calcGitLink file key ifM ((==) link <$> liftIO (readSymbolicLink file)) - ( do - addlink link - madeChange file "add" + ( addlink link , do liftIO $ removeFile file liftIO $ createSymbolicLink link file addlink link - madeChange file "fix" ) - addlink link = stageSymlink file link + {- This is often called on symlinks that are already staged + - correctly, especially during the startup scan. A symlink + - may have been deleted and re-added, or added when + - the watcher was not running; so it always stages + - even symlinks that already exist. + - + - So for speed, tries to reuse the existing blob for + - the symlink target. -} + addlink link = do + v <- catObjectDetails $ Ref $ ":" ++ file + case v of + Just (currlink, sha) + | s2w8 link == L.unpack currlink -> + stageSymlink file sha + _ -> do + sha <- inRepo $ + Git.HashObject.hashObject BlobObject link + stageSymlink file sha + madeChange file "link" onDel :: Handler onDel file = do @@ -197,10 +218,10 @@ onErr msg = do {- Adds a symlink to the index, without ever accessing the actual symlink - on disk. -} -stageSymlink :: FilePath -> String -> Annex () -stageSymlink file linktext = +stageSymlink :: FilePath -> Sha -> Annex () +stageSymlink file sha = Annex.Queue.addUpdateIndex =<< - inRepo (Git.UpdateIndex.stageSymlink file linktext) + inRepo (Git.UpdateIndex.stageSymlink file sha) {- Signals that a change has been made, that needs to get committed. -} signalChange :: ChangeChan -> Change -> Annex () diff --git a/Git/CatFile.hs b/Git/CatFile.hs index d5b367945..8a320a712 100644 --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -10,7 +10,8 @@ module Git.CatFile ( catFileStart, catFileStop, catFile, - catObject + catObject, + catObjectDetails, ) where import System.IO @@ -42,7 +43,11 @@ catFile h branch file = catObject h $ Ref $ show branch ++ ":" ++ file {- Uses a running git cat-file read the content of an object. - Objects that do not exist will have "" returned. -} catObject :: CatFileHandle -> Ref -> IO L.ByteString -catObject h object = CoProcess.query h send receive +catObject h object = maybe L.empty fst <$> catObjectDetails h object + +{- Gets both the content of an object, and its Sha. -} +catObjectDetails :: CatFileHandle -> Ref -> IO (Maybe (L.ByteString, Sha)) +catObjectDetails h object = CoProcess.query h send receive where send to = do fileEncoding to @@ -55,16 +60,16 @@ catObject h object = CoProcess.query h send receive | length sha == shaSize && isJust (readObjectType objtype) -> case reads size of - [(bytes, "")] -> readcontent bytes from + [(bytes, "")] -> readcontent bytes from sha _ -> dne | otherwise -> dne _ | header == show object ++ " missing" -> dne | otherwise -> error $ "unknown response from git cat-file " ++ show (header, object) - readcontent bytes from = do + readcontent bytes from sha = do content <- S.hGet from bytes c <- hGetChar from when (c /= '\n') $ error "missing newline from git cat-file" - return $ L.fromChunks [content] - dne = return L.empty + return $ Just (L.fromChunks [content], Ref sha) + dne = return Nothing diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs index 07057ed98..31e8a45b2 100644 --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -24,7 +24,6 @@ import Git import Git.Types import Git.Command import Git.FilePath -import Git.HashObject import Git.Sha {- Streamers are passed a callback and should feed it lines in the form @@ -70,10 +69,10 @@ unstageFile file repo = do return $ pureStreamer $ "0 " ++ show nullSha ++ "\t" ++ getTopFilePath p {- A streamer that adds a symlink to the index. -} -stageSymlink :: FilePath -> String -> Repo -> IO Streamer -stageSymlink file linktext repo = do +stageSymlink :: FilePath -> Sha -> Repo -> IO Streamer +stageSymlink file sha repo = do line <- updateIndexLine - <$> hashObject BlobObject linktext repo + <$> pure sha <*> pure SymlinkBlob <*> toTopFilePath file repo return $ pureStreamer line |