check for direct mode file change when copying to a local git remote
This commit is contained in:
parent
a8c8c95435
commit
a6a5ed8121
2 changed files with 53 additions and 32 deletions
|
@ -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.
|
||||
|
|
|
@ -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)
|
||||
)
|
||||
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue