check for direct mode file change when copying to a local git remote

This commit is contained in:
Joey Hess 2013-01-10 11:45:44 -04:00
parent a8c8c95435
commit a6a5ed8121
2 changed files with 53 additions and 32 deletions

View file

@ -11,11 +11,13 @@ module Annex.Content (
lockContent,
calcGitLink,
getViaTmp,
getViaTmpChecked,
getViaTmpUnchecked,
withTmp,
checkDiskSpace,
moveAnnex,
sendAnnex,
prepSendAnnex,
removeAnnex,
fromAnnex,
moveBad,
@ -135,7 +137,16 @@ calcGitLink file key = do
- and if the action succeeds, moves the temp file into
- the annex as a key's content. -}
getViaTmp :: Key -> (FilePath -> Annex Bool) -> Annex Bool
getViaTmp key action = do
getViaTmp = getViaTmpChecked (return True)
{- Like getViaTmp, but does not check that there is enough disk space
- for the incoming key. For use when the key content is already on disk
- and not being copied into place. -}
getViaTmpUnchecked :: Key -> (FilePath -> Annex Bool) -> Annex Bool
getViaTmpUnchecked = finishGetViaTmp (return True)
getViaTmpChecked :: Annex Bool -> Key -> (FilePath -> Annex Bool) -> Annex Bool
getViaTmpChecked check key action = do
tmp <- fromRepo $ gitAnnexTmpLocation key
-- Check that there is enough free disk space.
@ -148,23 +159,14 @@ getViaTmp key action = do
ifM (checkDiskSpace Nothing key alreadythere)
( do
when e $ thawContent tmp
getViaTmpUnchecked key action
finishGetViaTmp check key action
, return False
)
prepTmp :: Key -> Annex FilePath
prepTmp key = do
tmp <- fromRepo $ gitAnnexTmpLocation key
createAnnexDirectory (parentDir tmp)
return tmp
{- Like getViaTmp, but does not check that there is enough disk space
- for the incoming key. For use when the key content is already on disk
- and not being copied into place. -}
getViaTmpUnchecked :: Key -> (FilePath -> Annex Bool) -> Annex Bool
getViaTmpUnchecked key action = do
finishGetViaTmp :: Annex Bool -> Key -> (FilePath -> Annex Bool) -> Annex Bool
finishGetViaTmp check key action = do
tmpfile <- prepTmp key
ifM (action tmpfile)
ifM (action tmpfile <&&> check)
( do
moveAnnex key tmpfile
logStatus key InfoPresent
@ -175,6 +177,12 @@ getViaTmpUnchecked key action = do
return False
)
prepTmp :: Key -> Annex FilePath
prepTmp key = do
tmp <- fromRepo $ gitAnnexTmpLocation key
createAnnexDirectory (parentDir tmp)
return tmp
{- Creates a temp file, runs an action on it, and cleans up the temp file. -}
withTmp :: Key -> (FilePath -> Annex a) -> Annex a
withTmp key action = do
@ -263,27 +271,38 @@ replaceFile file a = do
-
- In direct mode, it's possible for the file to change as it's being sent.
- If this happens, runs the rollback action and returns False. The
- rollback action should remove the data that was transferred for the key.
- rollback action should remove the data that was transferred.
-}
sendAnnex :: Key -> (Annex ()) -> (FilePath -> Annex Bool) -> Annex Bool
sendAnnex key rollback a = withObjectLoc key sendobject senddirect
sendAnnex key rollback sendobject = go =<< prepSendAnnex key
where
sendobject = a
senddirect [] = return False
senddirect (f:fs) = do
go Nothing = return False
go (Just (f, checksuccess)) = do
r <- sendobject f
ifM checksuccess
( return r
, do
rollback
return False
)
{- Returns a file that contains an object's content,
- and an check to run after the transfer is complete.
-
- In direct mode, it's possible for the file to change as it's being sent,
- and the check detects this case and returns False.
-}
prepSendAnnex :: Key -> Annex (Maybe (FilePath, Annex Bool))
prepSendAnnex key = withObjectLoc key indirect direct
where
indirect f = return $ Just (f, return True)
direct [] = return Nothing
direct (f:fs) = do
cache <- recordedCache key
-- check that we have a good file
ifM (compareCache f cache)
( do
r <- sendobject f
-- see if file changed while it was being sent
ifM (compareCache f cache)
( return r
, do
rollback
return False
)
, senddirect fs
( return $ Just (f, compareCache f cache)
, direct fs
)
{- Performs an action, passing it the location to use for a key's content.

View file

@ -331,13 +331,15 @@ copyFromRemoteCheap r key file
copyToRemote :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
copyToRemote r key file p
| not $ Git.repoIsUrl (repo r) =
guardUsable (repo r) False $ commitOnCleanup r $ copylocal
guardUsable (repo r) False $ commitOnCleanup r $
copylocal =<< Annex.Content.prepSendAnnex key
| Git.repoIsSsh (repo r) = commitOnCleanup r $
Annex.Content.sendAnnex key noop $ \object ->
rsyncHelper (Just p) =<< rsyncParamsRemote r False key object file
| otherwise = error "copying to non-ssh repo not supported"
where
copylocal = Annex.Content.sendAnnex key noop $ \object -> do
copylocal Nothing = return False
copylocal (Just (object, checksuccess)) = do
let params = rsyncParams r
u <- getUUID
-- run copy from perspective of remote
@ -347,7 +349,7 @@ copyToRemote r key file p
ensureInitialized
download u key file noRetry $
Annex.Content.saveState True `after`
Annex.Content.getViaTmp key
Annex.Content.getViaTmpChecked checksuccess key
(\d -> rsyncOrCopyFile params object d p)
)