diff options
| -rw-r--r-- | Annex/Content.hs | 12 | ||||
| -rw-r--r-- | Command/Drop.hs | 18 | ||||
| -rw-r--r-- | Command/DropUnused.hs | 3 | ||||
| -rw-r--r-- | Command/Move.hs | 43 | ||||
| -rw-r--r-- | doc/bugs/cyclic_drop.mdwn | 4 |
5 files changed, 54 insertions, 26 deletions
diff --git a/Annex/Content.hs b/Annex/Content.hs index ecfec66aa..dc714276d 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -7,6 +7,8 @@ module Annex.Content ( inAnnex, + lockExclusive, + lockShared, calcGitLink, logStatus, getViaTmp, @@ -41,6 +43,16 @@ inAnnex key = do error "inAnnex cannot check remote repo" inRepo $ doesFileExist . gitAnnexLocation key +{- Content is exclusively locked to indicate that it's in the process of + - being removed. -} +lockExclusive :: Key -> Annex a -> Annex a +lockExclusive key a = a -- TODO + +{- Things that rely on content being present can take a shared lock to + - avoid it vanishing from under them. -} +lockShared :: Key -> Annex a -> Annex a +lockShared key a = a -- TODO + {- Calculates the relative path to use to link a file to a key. -} calcGitLink :: FilePath -> Key -> Annex FilePath calcGitLink file key = do diff --git a/Command/Drop.hs b/Command/Drop.hs index 2267bd941..e81bd9d7d 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -52,17 +52,19 @@ startRemote file numcopies key remote = do next $ performRemote key numcopies remote performLocal :: Key -> Maybe Int -> CommandPerform -performLocal key numcopies = do +performLocal key numcopies = lockExclusive key $ do (remotes, trusteduuids) <- Remote.keyPossibilitiesTrusted key untrusteduuids <- trustGet UnTrusted let tocheck = Remote.remotesWithoutUUID remotes (trusteduuids++untrusteduuids) success <- canDropKey key numcopies trusteduuids tocheck [] if success - then next $ cleanupLocal key + then do + whenM (inAnnex key) $ removeAnnex key + next $ cleanupLocal key else stop performRemote :: Key -> Maybe Int -> Remote.Remote Annex -> CommandPerform -performRemote key numcopies remote = do +performRemote key numcopies remote = lockExclusive key $ do -- Filter the remote it's being dropped from out of the lists of -- places assumed to have the key, and places to check. -- When the local repo has the key, that's one additional copy. @@ -76,20 +78,20 @@ performRemote key numcopies remote = do Remote.remotesWithoutUUID remotes (have++untrusteduuids) success <- canDropKey key numcopies have tocheck [uuid] if success - then next $ cleanupRemote key remote + then do + ok <- Remote.removeKey remote key + next $ cleanupRemote key remote ok else stop where uuid = Remote.uuid remote cleanupLocal :: Key -> CommandCleanup cleanupLocal key = do - whenM (inAnnex key) $ removeAnnex key logStatus key InfoMissing return True -cleanupRemote :: Key -> Remote.Remote Annex -> CommandCleanup -cleanupRemote key remote = do - ok <- Remote.removeKey remote key +cleanupRemote :: Key -> Remote.Remote Annex -> Bool -> CommandCleanup +cleanupRemote key remote ok = do -- better safe than sorry: assume the remote dropped the key -- even if it seemed to fail; the failure could have occurred -- after it really dropped it diff --git a/Command/DropUnused.hs b/Command/DropUnused.hs index 55c21f83b..2c3bb296a 100644 --- a/Command/DropUnused.hs +++ b/Command/DropUnused.hs @@ -55,7 +55,8 @@ perform key = maybe droplocal dropremote =<< Annex.getState Annex.fromremote dropremote name = do r <- Remote.byName name showAction $ "from " ++ Remote.name r - next $ Command.Drop.cleanupRemote key r + ok <- Remote.removeKey r key + next $ Command.Drop.cleanupRemote key r ok droplocal = Command.Drop.performLocal key (Just 0) -- force drop performOther :: (Key -> Git.Repo -> FilePath) -> Key -> CommandPerform diff --git a/Command/Move.hs b/Command/Move.hs index 5a3ea7172..e955de827 100644 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -68,7 +68,7 @@ toStart dest move file = isAnnexed file $ \(key, _) -> do showMoveAction move file next $ toPerform dest move key toPerform :: Remote.Remote Annex -> Bool -> Key -> CommandPerform -toPerform dest move key = do +toPerform dest move key = moveLock move key $ do -- Checking the remote is expensive, so not done in the start step. -- In fast mode, location tracking is assumed to be correct, -- and an explicit check is not done, when copying. When moving, @@ -88,18 +88,20 @@ toPerform dest move key = do showAction $ "to " ++ Remote.name dest ok <- Remote.storeKey dest key if ok - then next $ toCleanup dest move key + then finish else do when fastcheck $ warning "This could have failed because --fast is enabled." stop - Right True -> next $ toCleanup dest move key -toCleanup :: Remote.Remote Annex -> Bool -> Key -> CommandCleanup -toCleanup dest move key = do - Remote.remoteHasKey dest key True - if move - then Command.Drop.cleanupLocal key - else return True + Right True -> finish + where + finish = do + Remote.remoteHasKey dest key True + if move + then do + whenM (inAnnex key) $ removeAnnex key + next $ Command.Drop.cleanupLocal key + else next $ return True {- Moves (or copies) the content of an annexed file from a remote - to the current repository. @@ -117,16 +119,23 @@ fromStart src move file = isAnnexed file $ \(key, _) -> do showMoveAction move file next $ fromPerform src move key fromPerform :: Remote.Remote Annex -> Bool -> Key -> CommandPerform -fromPerform src move key = do +fromPerform src move key = moveLock move key $ do ishere <- inAnnex key if ishere - then next $ fromCleanup src move key + then handle move True else do showAction $ "from " ++ Remote.name src ok <- getViaTmp key $ Remote.retrieveKeyFile src key - if ok - then next $ fromCleanup src move key - else stop -- fail -fromCleanup :: Remote.Remote Annex -> Bool -> Key -> CommandCleanup -fromCleanup src True key = Command.Drop.cleanupRemote key src -fromCleanup _ False _ = return True + handle move ok + where + handle _ False = stop -- failed + handle False True = next $ return True -- copy complete + handle True True = do -- finish moving + ok <- Remote.removeKey src key + next $ Command.Drop.cleanupRemote key src ok + +{- Locks a key in order for it to be moved. + - No lock is needed when a key is being copied. -} +moveLock :: Bool -> Key -> Annex a -> Annex a +moveLock True key a = lockExclusive key a +moveLock False _ a = a diff --git a/doc/bugs/cyclic_drop.mdwn b/doc/bugs/cyclic_drop.mdwn index cc2943b7e..d3264c7ca 100644 --- a/doc/bugs/cyclic_drop.mdwn +++ b/doc/bugs/cyclic_drop.mdwn @@ -38,6 +38,10 @@ distinguishable from "not in annex". --- +drop --from could also cycle. Locking should fix. + +--- + move --to can also be included in the cycle, since it can drop data. Consider move to a remote that already has the content and |