From 9461019e9a8d63c3106001b65b8ffaf945f330b1 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 8 Oct 2015 13:31:55 -0400 Subject: [PATCH 01/30] open lock file ReadOnly when taking shared lock It's only necessary to open a file for write when taking an exclusive lock. --- Utility/LockFile/Posix.hs | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/Utility/LockFile/Posix.hs b/Utility/LockFile/Posix.hs index 18d9e4fc14..8f06ae69ed 100644 --- a/Utility/LockFile/Posix.hs +++ b/Utility/LockFile/Posix.hs @@ -39,7 +39,7 @@ lockExclusive = lock WriteLock -- Tries to take an exclusive lock, but does not block. tryLockExclusive :: Maybe FileMode -> LockFile -> IO (Maybe LockHandle) tryLockExclusive mode lockfile = do - l <- openLockFile mode lockfile + l <- openLockFile WriteLock mode lockfile v <- tryIO $ setLock l (WriteLock, AbsoluteSeek, 0, 0) case v of Left _ -> do @@ -51,16 +51,20 @@ tryLockExclusive mode lockfile = do -- If it's Nothing then this only succeeds when the lock file already exists. lock :: LockRequest -> Maybe FileMode -> LockFile -> IO LockHandle lock lockreq mode lockfile = do - l <- openLockFile mode lockfile + l <- openLockFile lockreq mode lockfile waitToSetLock l (lockreq, AbsoluteSeek, 0, 0) return (LockHandle l) -- Close on exec flag is set so child processes do not inherit the lock. -openLockFile :: Maybe FileMode -> LockFile -> IO Fd -openLockFile filemode lockfile = do - l <- openFd lockfile ReadWrite filemode defaultFileFlags +openLockFile :: LockRequest -> Maybe FileMode -> LockFile -> IO Fd +openLockFile lockreq filemode lockfile = do + l <- openFd lockfile openfor filemode defaultFileFlags setFdOption l CloseOnExec True return l + where + openfor = case lockreq of + ReadLock -> ReadOnly + _ -> ReadWrite -- Returns Nothing when the file doesn't exist, for cases where -- that is different from it not being locked. @@ -81,7 +85,7 @@ getLockStatus lockfile = do getLockStatus' :: LockFile -> IO (Maybe (Maybe ProcessID)) getLockStatus' lockfile = go =<< catchMaybeIO open where - open = openFd lockfile ReadOnly Nothing defaultFileFlags + open = openLockFile ReadLock Nothing lockfile go Nothing = return Nothing go (Just h) = do v <- getLock h (ReadLock, AbsoluteSeek, 0, 0) From c8fad345f238b2f2b0c77f262e6051111427819d Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 8 Oct 2015 13:40:23 -0400 Subject: [PATCH 02/30] add tryLockShared --- Utility/LockFile/Posix.hs | 25 +++++++++++++++++-------- Utility/LockPool/Posix.hs | 9 +++++++++ 2 files changed, 26 insertions(+), 8 deletions(-) diff --git a/Utility/LockFile/Posix.hs b/Utility/LockFile/Posix.hs index 8f06ae69ed..cf88fa87d8 100644 --- a/Utility/LockFile/Posix.hs +++ b/Utility/LockFile/Posix.hs @@ -9,6 +9,7 @@ module Utility.LockFile.Posix ( LockHandle, lockShared, lockExclusive, + tryLockShared, tryLockExclusive, checkLocked, getLockStatus, @@ -36,16 +37,13 @@ lockShared = lock ReadLock lockExclusive :: Maybe FileMode -> LockFile -> IO LockHandle lockExclusive = lock WriteLock +-- Tries to take a shared lock, but does not block. +tryLockShared :: Maybe FileMode -> LockFile -> IO (Maybe LockHandle) +tryLockShared = tryLock ReadLock + -- Tries to take an exclusive lock, but does not block. tryLockExclusive :: Maybe FileMode -> LockFile -> IO (Maybe LockHandle) -tryLockExclusive mode lockfile = do - l <- openLockFile WriteLock mode lockfile - v <- tryIO $ setLock l (WriteLock, AbsoluteSeek, 0, 0) - case v of - Left _ -> do - closeFd l - return Nothing - Right _ -> return $ Just $ LockHandle l +tryLockExclusive = tryLock WriteLock -- Setting the FileMode allows creation of a new lock file. -- If it's Nothing then this only succeeds when the lock file already exists. @@ -55,6 +53,17 @@ lock lockreq mode lockfile = do waitToSetLock l (lockreq, AbsoluteSeek, 0, 0) return (LockHandle l) +-- Tries to take an lock, but does not block. +tryLock :: LockRequest -> Maybe FileMode -> LockFile -> IO (Maybe LockHandle) +tryLock lockreq mode lockfile = do + l <- openLockFile lockreq mode lockfile + v <- tryIO $ setLock l (lockreq, AbsoluteSeek, 0, 0) + case v of + Left _ -> do + closeFd l + return Nothing + Right _ -> return $ Just $ LockHandle l + -- Close on exec flag is set so child processes do not inherit the lock. openLockFile :: LockRequest -> Maybe FileMode -> LockFile -> IO Fd openLockFile lockreq filemode lockfile = do diff --git a/Utility/LockPool/Posix.hs b/Utility/LockPool/Posix.hs index 506d7b560b..82e0c8e5e9 100644 --- a/Utility/LockPool/Posix.hs +++ b/Utility/LockPool/Posix.hs @@ -9,6 +9,7 @@ module Utility.LockPool.Posix ( LockHandle, lockShared, lockExclusive, + tryLockShared, tryLockExclusive, checkLocked, getLockStatus, @@ -35,11 +36,19 @@ lockShared mode file = makeLockHandle (P.waitTakeLock P.lockPool file LockShared) (F.lockShared mode file) +-- Takes an exclusive lock, blocking until the lock is available. lockExclusive :: Maybe FileMode -> LockFile -> IO LockHandle lockExclusive mode file = makeLockHandle (P.waitTakeLock P.lockPool file LockExclusive) (F.lockExclusive mode file) +-- Tries to take a shared lock, but does not block. +tryLockShared :: Maybe FileMode -> LockFile -> IO (Maybe LockHandle) +tryLockShared mode file = tryMakeLockHandle + (P.tryTakeLock P.lockPool file LockShared) + (F.tryLockShared mode file) + +-- Tries to take an exclusive lock, but does not block. tryLockExclusive :: Maybe FileMode -> LockFile -> IO (Maybe LockHandle) tryLockExclusive mode file = tryMakeLockHandle (P.tryTakeLock P.lockPool file LockExclusive) From f52d4b684db772b9272cfa14526a33f55e068c3f Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 8 Oct 2015 14:26:21 -0400 Subject: [PATCH 03/30] export FileMode type --- Utility/FileMode.hs | 27 ++++++++++++++++++++++++++- 1 file changed, 26 insertions(+), 1 deletion(-) diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs index fdf1b56ba9..83d53388eb 100644 --- a/Utility/FileMode.hs +++ b/Utility/FileMode.hs @@ -7,7 +7,32 @@ {-# LANGUAGE CPP #-} -module Utility.FileMode where +module Utility.FileMode ( + FileMode, + modifyFileMode, + addModes, + removeModes, + writeModes, + readModes, + executeModes, + otherGroupModes, + preventWrite, + allowWrite, + allowRead, + groupSharedModes, + groupWriteRead, + checkMode, + isSymLink, + isExecutable, + noUmask, + withUmask, + combineModes, + isSticky, + stickyMode, + setSticky, + writeFileProtected, + writeFileProtected' +) where import System.IO import Control.Monad From 4d50958ed7830eef42dea2aa2f40013742f708de Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 8 Oct 2015 14:27:37 -0400 Subject: [PATCH 04/30] add lockContentShared Also, rename lockContent to lockContentExclusive inAnnexSafe should perhaps be eliminated, and instead use `lockContentShared inAnnex`. However, I'm waiting on that, as there are only 2 call sites for inAnnexSafe and it's fiddly. --- Annex/Content.hs | 120 +++++++++++++++++++++++++----------- Assistant/Unused.hs | 2 +- Assistant/Upgrade.hs | 2 +- Command/Drop.hs | 6 +- Command/DropKey.hs | 2 +- Command/Move.hs | 2 +- Command/TestRemote.hs | 10 +-- Command/Uninit.hs | 2 +- Remote/Git.hs | 2 +- Utility/LockPool/Posix.hs | 1 + Utility/LockPool/Windows.hs | 1 + 11 files changed, 100 insertions(+), 50 deletions(-) diff --git a/Annex/Content.hs b/Annex/Content.hs index 5032e26911..14dc4d4e5f 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -12,7 +12,8 @@ module Annex.Content ( inAnnex', inAnnexSafe, inAnnexCheck, - lockContent, + lockContentShared, + lockContentExclusive, getViaTmp, getViaTmp', checkDiskSpaceToGet, @@ -165,57 +166,104 @@ contentLockFile key = ifM isDirect contentLockFile key = Just <$> calcRepo (gitAnnexContentLock key) #endif -newtype ContentLock = ContentLock Key - -{- Content is exclusively locked while running an action that might remove - - it. (If the content is not present, no locking is done.) +{- Prevents the content from being removed while the action is running. + - Uses a shared lock. + - + - Does not actually check if the content is present. Use inAnnex for that. + - However, since the contentLockFile is the content file in indirect mode, + - if the content is not present, locking it will fail. + - + - If locking fails, throws an exception rather than running the action. + - + - Note that, in direct mode, nothing prevents the user from directly + - editing or removing the content, even while it's locked by this. -} -lockContent :: Key -> (ContentLock -> Annex a) -> Annex a -lockContent key a = do +lockContentShared :: Key -> Annex a -> Annex a +lockContentShared = lockContentUsing lock + where +#ifndef mingw32_HOST_OS + lock contentfile Nothing = liftIO $ tryLockShared Nothing contentfile + lock _ (Just lockfile) = posixLocker tryLockShared lockfile +#else + lock = winLocker lockShared +#endif + +newtype ContentLockExclusive = ContentLockExclusive Key + +{- Exclusively locks content, while performing an action that + - might remove it. + - + - (If the content is not present, no locking is done.) + -} +lockContentExclusive :: Key -> (ContentLockExclusive -> Annex a) -> Annex a +lockContentExclusive key a = lockContentUsing lock key $ + a $ ContentLockExclusive key + where +#ifndef mingw32_HOST_OS + {- Since content files are stored with the write bit disabled, have + - to fiddle with permissions to open for an exclusive lock. -} + lock contentfile Nothing = bracket_ + (thawContent contentfile) + (freezeContent contentfile) + (liftIO $ tryLockExclusive Nothing contentfile) + lock _ (Just lockfile) = posixLocker tryLockExclusive lockfile +#else + lock = winLocker lockExclusive +#endif + +{- Passed the object content file, and maybe a separate lock file to use, + - when the content file itself should not be locked. -} +type ContentLocker = FilePath -> Maybe LockFile -> Annex (Maybe LockHandle) + +#ifndef mingw32_HOST_OS +posixLocker :: (Maybe FileMode -> LockFile -> IO (Maybe LockHandle)) -> LockFile -> Annex (Maybe LockHandle) +posixLocker takelock lockfile = do + mode <- annexFileMode + modifyContent lockfile $ + liftIO $ takelock (Just mode) lockfile + +#else +winLocker :: (LockFile -> IO (Maybe LockHandle)) -> ContentLocker +winLocker takelock _ (Just lockfile) = do + modifyContent lockfile $ + void $ liftIO $ tryIO $ + writeFile lockfile "" + liftIO $ takelock lockfile +-- never reached; windows always uses a separate lock file +winLocker _ _ Nothing = return Nothing +#endif + +lockContentUsing :: ContentLocker -> Key -> Annex a -> Annex a +lockContentUsing locker key a = do contentfile <- calcRepo $ gitAnnexLocation key lockfile <- contentLockFile key bracket (lock contentfile lockfile) (unlock lockfile) - (const $ a $ ContentLock key ) + (const $ a) where alreadylocked = error "content is locked" - cleanuplockfile lockfile = modifyContent lockfile $ - void $ liftIO $ tryIO $ - nukeFile lockfile -#ifndef mingw32_HOST_OS - {- Since content files are stored with the write bit disabled, have - - to fiddle with permissions to open for an exclusive lock. -} - lock contentfile Nothing = trylock $ bracket_ - (thawContent contentfile) - (freezeContent contentfile) + failedtolock e = error $ "failed to lock content: " ++ show e + + lock contentfile lockfile = (maybe alreadylocked return - =<< liftIO (tryLockExclusive Nothing contentfile)) - lock _ (Just lockfile) = trylock $ do - mode <- annexFileMode - maybe alreadylocked return - =<< modifyContent lockfile - (liftIO $ tryLockExclusive (Just mode) lockfile) + =<< locker contentfile lockfile) + `catchIO` failedtolock + +#ifndef mingw32_HOST_OS unlock mlockfile lck = do maybe noop cleanuplockfile mlockfile liftIO $ dropLock lck - - failedtolock e = error $ "failed to lock content: " ++ show e - trylock locker = locker `catchIO` failedtolock #else - lock _ (Just lockfile) = do - modifyContent lockfile $ - void $ liftIO $ tryIO $ - writeFile lockfile "" - maybe alreadylocked (return . Just) - =<< liftIO (lockExclusive lockfile) - -- never reached; windows always uses a separate lock file - lock _ Nothing = return Nothing unlock mlockfile mlockhandle = do liftIO $ maybe noop dropLock mlockhandle maybe noop cleanuplockfile mlockfile #endif + cleanuplockfile lockfile = modifyContent lockfile $ + void $ liftIO $ tryIO $ + nukeFile lockfile + {- Runs an action, passing it the temp file to get, - and if the action succeeds, verifies the file matches - the key and moves the file into the annex as a key's content. -} @@ -497,8 +545,8 @@ cleanObjectLoc key cleaner = do - In direct mode, deletes the associated files or files, and replaces - them with symlinks. -} -removeAnnex :: ContentLock -> Annex () -removeAnnex (ContentLock key) = withObjectLoc key remove removedirect +removeAnnex :: ContentLockExclusive -> Annex () +removeAnnex (ContentLockExclusive key) = withObjectLoc key remove removedirect where remove file = cleanObjectLoc key $ do secureErase file diff --git a/Assistant/Unused.hs b/Assistant/Unused.hs index 194739367e..c71604679d 100644 --- a/Assistant/Unused.hs +++ b/Assistant/Unused.hs @@ -77,7 +77,7 @@ expireUnused duration = do forM_ oldkeys $ \k -> do debug ["removing old unused key", key2file k] liftAnnex $ do - lockContent k removeAnnex + lockContentExclusive k removeAnnex logStatus k InfoMissing where boundry = durationToPOSIXTime <$> duration diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs index 3439cabbff..88ef5bed15 100644 --- a/Assistant/Upgrade.hs +++ b/Assistant/Upgrade.hs @@ -97,7 +97,7 @@ startDistributionDownload d = go =<< liftIO . newVersionLocation d =<< liftIO ol , transferKey = k } cleanup = liftAnnex $ do - lockContent k removeAnnex + lockContentExclusive k removeAnnex setUrlMissing webUUID k u logStatus k InfoMissing diff --git a/Command/Drop.hs b/Command/Drop.hs index b23f81758d..6bbdb58fd2 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -88,12 +88,12 @@ startRemote afile numcopies key remote = do showStart' ("drop " ++ Remote.name remote) key afile next $ performRemote key afile numcopies remote --- Note that lockContent is called before checking if the key is present --- on enough remotes to allow removal. This avoids a scenario where two +-- Note that lockContentExclusive is called before checking if the key is +-- present on enough remotes to allow removal. This avoids a scenario where two -- or more remotes are trying to remove a key at the same time, and each -- see the key is present on the other. performLocal :: Key -> AssociatedFile -> NumCopies -> Maybe Remote -> CommandPerform -performLocal key afile numcopies knownpresentremote = lockContent key $ \contentlock -> do +performLocal key afile numcopies knownpresentremote = lockContentExclusive key $ \contentlock -> do (remotes, trusteduuids) <- Remote.keyPossibilitiesTrusted key let trusteduuids' = case knownpresentremote of Nothing -> trusteduuids diff --git a/Command/DropKey.hs b/Command/DropKey.hs index 5d44f0fcdc..cdb19cabb3 100644 --- a/Command/DropKey.hs +++ b/Command/DropKey.hs @@ -31,7 +31,7 @@ start key = stopUnless (inAnnex key) $ do next $ perform key perform :: Key -> CommandPerform -perform key = lockContent key $ \contentlock -> do +perform key = lockContentExclusive key $ \contentlock -> do removeAnnex contentlock next $ cleanup key diff --git a/Command/Move.hs b/Command/Move.hs index a83ea04dde..072c00663b 100644 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -123,7 +123,7 @@ toPerform dest move key afile fastcheck isthere = finish where finish - | move = lockContent key $ \contentlock -> do + | move = lockContentExclusive key $ \contentlock -> do removeAnnex contentlock next $ Command.Drop.cleanupLocal key | otherwise = next $ return True diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs index 7ee5f13591..3a44a1bde2 100644 --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -120,7 +120,7 @@ test st r k = , check "storeKey when already present" store , present True , check "retrieveKeyFile" $ do - lockContent k removeAnnex + lockContentExclusive k removeAnnex get , check "fsck downloaded object" fsck , check "retrieveKeyFile resume from 33%" $ do @@ -130,20 +130,20 @@ test st r k = sz <- hFileSize h L.hGet h $ fromInteger $ sz `div` 3 liftIO $ L.writeFile tmp partial - lockContent k removeAnnex + lockContentExclusive k removeAnnex get , check "fsck downloaded object" fsck , check "retrieveKeyFile resume from 0" $ do tmp <- prepTmp k liftIO $ writeFile tmp "" - lockContent k removeAnnex + lockContentExclusive k removeAnnex get , check "fsck downloaded object" fsck , check "retrieveKeyFile resume from end" $ do loc <- Annex.calcRepo (gitAnnexLocation k) tmp <- prepTmp k void $ liftIO $ copyFileExternal CopyAllMetaData loc tmp - lockContent k removeAnnex + lockContentExclusive k removeAnnex get , check "fsck downloaded object" fsck , check "removeKey when present" remove @@ -189,7 +189,7 @@ testUnavailable st r k = cleanup :: [Remote] -> [Key] -> Bool -> CommandCleanup cleanup rs ks ok = do forM_ rs $ \r -> forM_ ks (Remote.removeKey r) - forM_ ks $ \k -> lockContent k removeAnnex + forM_ ks $ \k -> lockContentExclusive k removeAnnex return ok chunkSizes :: Int -> Bool -> [Int] diff --git a/Command/Uninit.hs b/Command/Uninit.hs index c49cc4ba0e..38e0620025 100644 --- a/Command/Uninit.hs +++ b/Command/Uninit.hs @@ -105,7 +105,7 @@ removeUnannexed = go [] go c [] = return c go c (k:ks) = ifM (inAnnexCheck k $ liftIO . enoughlinks) ( do - lockContent k removeAnnex + lockContentExclusive k removeAnnex go c ks , go (k:c) ks ) diff --git a/Remote/Git.hs b/Remote/Git.hs index f7a0b4a392..8f7e69cbd3 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -350,7 +350,7 @@ dropKey r key commitOnCleanup r $ onLocal r $ do ensureInitialized whenM (Annex.Content.inAnnex key) $ do - Annex.Content.lockContent key + Annex.Content.lockContentExclusive key Annex.Content.removeAnnex logStatus key InfoMissing Annex.Content.saveState True diff --git a/Utility/LockPool/Posix.hs b/Utility/LockPool/Posix.hs index 82e0c8e5e9..db6b1d3ddf 100644 --- a/Utility/LockPool/Posix.hs +++ b/Utility/LockPool/Posix.hs @@ -6,6 +6,7 @@ -} module Utility.LockPool.Posix ( + P.LockFile, LockHandle, lockShared, lockExclusive, diff --git a/Utility/LockPool/Windows.hs b/Utility/LockPool/Windows.hs index 754650c30b..a88525a9ba 100644 --- a/Utility/LockPool/Windows.hs +++ b/Utility/LockPool/Windows.hs @@ -6,6 +6,7 @@ -} module Utility.LockPool.Windows ( + P.LockFile, LockHandle, lockShared, lockExclusive, From 5240a9f315d1b95b5df2b9636609d0da00d05cd2 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 8 Oct 2015 14:47:46 -0400 Subject: [PATCH 05/30] git-annex-shell: Added lockcontent command, to prevent dropping of key's content. --- CmdLine/GitAnnexShell.hs | 2 ++ Command/LockContent.hs | 45 ++++++++++++++++++++++++++++++++++++++++ debian/changelog | 2 ++ doc/git-annex-shell.mdwn | 11 ++++++++++ 4 files changed, 60 insertions(+) create mode 100644 Command/LockContent.hs diff --git a/CmdLine/GitAnnexShell.hs b/CmdLine/GitAnnexShell.hs index 59c861582d..f9678d1449 100644 --- a/CmdLine/GitAnnexShell.hs +++ b/CmdLine/GitAnnexShell.hs @@ -20,6 +20,7 @@ import Remote.GCrypt (getGCryptUUID) import qualified Command.ConfigList import qualified Command.InAnnex +import qualified Command.LockContent import qualified Command.DropKey import qualified Command.RecvKey import qualified Command.SendKey @@ -32,6 +33,7 @@ cmds_readonly :: [Command] cmds_readonly = [ Command.ConfigList.cmd , gitAnnexShellCheck Command.InAnnex.cmd + , gitAnnexShellCheck Command.LockContent.cmd , gitAnnexShellCheck Command.SendKey.cmd , gitAnnexShellCheck Command.TransferInfo.cmd , gitAnnexShellCheck Command.NotifyChanges.cmd diff --git a/Command/LockContent.hs b/Command/LockContent.hs new file mode 100644 index 0000000000..bab5c92767 --- /dev/null +++ b/Command/LockContent.hs @@ -0,0 +1,45 @@ +{- git-annex-shell command + - + - Copyright 2015 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.LockContent where + +import Common.Annex +import Command +import Annex.Content +import Types.Key + +cmd :: Command +cmd = noCommit $ + command "lockcontent" SectionPlumbing + "locks key's content in the annex, preventing it being dropped" + paramKey + (withParams seek) + +seek :: CmdParams -> CommandSeek +seek = withWords start + +-- First, lock the content. Then, make sure the content is actually +-- present, and print out a "1". Wait for the caller to send a line before +-- dropping the lock. +start :: [String] -> CommandStart +start [ks] = do + ok <- lockContentShared k locksuccess + `catchNonAsync` (const $ return False) + liftIO $ if ok + then exitSuccess + else exitFailure + where + k = fromMaybe (error "bad key") (file2key ks) + locksuccess = ifM (inAnnex k) + ( liftIO $ do + putStrLn "OK" + hFlush stdout + _ <- getLine + return True + , return False + ) +start _ = error "Specify exactly 1 key." diff --git a/debian/changelog b/debian/changelog index ddeb943384..f3ffa59758 100644 --- a/debian/changelog +++ b/debian/changelog @@ -20,6 +20,8 @@ git-annex (5.20150931) UNRELEASED; urgency=medium and stop recommending bittornado | bittorrent. * Debian: Remove dependency on transformers library, as it is now included in ghc. + * git-annex-shell: Added lockcontent command, to prevent dropping of + key's content. -- Joey Hess Thu, 01 Oct 2015 12:42:56 -0400 diff --git a/doc/git-annex-shell.mdwn b/doc/git-annex-shell.mdwn index d0e0930c59..73517ba895 100644 --- a/doc/git-annex-shell.mdwn +++ b/doc/git-annex-shell.mdwn @@ -43,6 +43,17 @@ first "/~/" or "/~user/" is expanded to the specified home directory. Exits 100 if it's unable to tell (perhaps the key is in the process of being removed from the annex). +* lockcontent directory key + + This locks a key's content in place in the annex, preventing it from + being dropped. + + Once the content is successfully locked, outputs "OK". Then the content + remains locked until a newline is received from the caller or the + connection is broken. + + Exits nonzero if the content is not present, or could not be locked. + * dropkey directory [key ...] This drops the annexed data for the specified keys. From 9cb9dab69bf830a825009c286107fd8fcbbda0e5 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 8 Oct 2015 14:51:44 -0400 Subject: [PATCH 06/30] I think this comment is stale/confusing; remove --- Annex/Content.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/Annex/Content.hs b/Annex/Content.hs index 14dc4d4e5f..8fbb49ce6b 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -192,8 +192,6 @@ newtype ContentLockExclusive = ContentLockExclusive Key {- Exclusively locks content, while performing an action that - might remove it. - - - - (If the content is not present, no locking is done.) -} lockContentExclusive :: Key -> (ContentLockExclusive -> Annex a) -> Annex a lockContentExclusive key a = lockContentUsing lock key $ From beedf1da254c7484219757fb3ffcd3c51a46e45f Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 8 Oct 2015 14:59:34 -0400 Subject: [PATCH 07/30] unused import --- Annex/Perms.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/Annex/Perms.hs b/Annex/Perms.hs index f32594ac35..2467c3c777 100644 --- a/Annex/Perms.hs +++ b/Annex/Perms.hs @@ -24,8 +24,6 @@ import Git.SharedRepository import qualified Annex import Config -import System.Posix.Types - withShared :: (SharedRepository -> Annex a) -> Annex a withShared a = a =<< coreSharedRepository <$> Annex.getGitConfig From b1abe59193463f9811431fd6b10dc9c44c16ea38 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 8 Oct 2015 15:01:38 -0400 Subject: [PATCH 08/30] add removeKey action to Remote Not implemented for any remotes yet; probably the git remote is the only one that will ever implement it. --- Command/Drop.hs | 2 +- Remote/BitTorrent.hs | 1 + Remote/Bup.hs | 1 + Remote/Ddar.hs | 1 + Remote/Directory.hs | 1 + Remote/External.hs | 1 + Remote/GCrypt.hs | 1 + Remote/Git.hs | 1 + Remote/Glacier.hs | 1 + Remote/Hook.hs | 1 + Remote/Rsync.hs | 1 + Remote/S3.hs | 1 + Remote/Tahoe.hs | 1 + Remote/Web.hs | 1 + Remote/WebDAV.hs | 1 + Types/Remote.hs | 8 +++++++- 16 files changed, 22 insertions(+), 2 deletions(-) diff --git a/Command/Drop.hs b/Command/Drop.hs index 6bbdb58fd2..8b361ed56f 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -91,7 +91,7 @@ startRemote afile numcopies key remote = do -- Note that lockContentExclusive is called before checking if the key is -- present on enough remotes to allow removal. This avoids a scenario where two -- or more remotes are trying to remove a key at the same time, and each --- see the key is present on the other. +-- sees the key is present on the other. performLocal :: Key -> AssociatedFile -> NumCopies -> Maybe Remote -> CommandPerform performLocal key afile numcopies knownpresentremote = lockContentExclusive key $ \contentlock -> do (remotes, trusteduuids) <- Remote.keyPossibilitiesTrusted key diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs index f9027ba61b..8349631de2 100644 --- a/Remote/BitTorrent.hs +++ b/Remote/BitTorrent.hs @@ -58,6 +58,7 @@ gen r _ c gc = , retrieveKeyFile = downloadKey , retrieveKeyFileCheap = downloadKeyCheap , removeKey = dropKey + , lockContent = Nothing , checkPresent = checkKey , checkPresentCheap = False , whereisKey = Nothing diff --git a/Remote/Bup.hs b/Remote/Bup.hs index a253b08897..d9d561b0dd 100644 --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -58,6 +58,7 @@ gen r u c gc = do , retrieveKeyFile = retreiveKeyFileDummy , retrieveKeyFileCheap = retrieveCheap buprepo , removeKey = removeKeyDummy + , lockContent = Nothing , checkPresent = checkPresentDummy , checkPresentCheap = bupLocal buprepo , whereisKey = Nothing diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs index b616093a38..d485d37939 100644 --- a/Remote/Ddar.hs +++ b/Remote/Ddar.hs @@ -57,6 +57,7 @@ gen r u c gc = do , retrieveKeyFile = retreiveKeyFileDummy , retrieveKeyFileCheap = retrieveCheap , removeKey = removeKeyDummy + , lockContent = Nothing , checkPresent = checkPresentDummy , checkPresentCheap = ddarLocal ddarrepo , whereisKey = Nothing diff --git a/Remote/Directory.hs b/Remote/Directory.hs index ab4137d75f..987c3079fb 100644 --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -55,6 +55,7 @@ gen r u c gc = do , retrieveKeyFile = retreiveKeyFileDummy , retrieveKeyFileCheap = retrieveCheap dir chunkconfig , removeKey = removeKeyDummy + , lockContent = Nothing , checkPresent = checkPresentDummy , checkPresentCheap = True , whereisKey = Nothing diff --git a/Remote/External.hs b/Remote/External.hs index 9f8bd4ccf7..68237b939d 100644 --- a/Remote/External.hs +++ b/Remote/External.hs @@ -81,6 +81,7 @@ gen r u c gc , retrieveKeyFile = retreiveKeyFileDummy , retrieveKeyFileCheap = \_ _ _ -> return False , removeKey = removeKeyDummy + , lockContent = Nothing , checkPresent = checkPresentDummy , checkPresentCheap = False , whereisKey = towhereis diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs index 3a63642c87..c720e55b29 100644 --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -111,6 +111,7 @@ gen' r u c gc = do , retrieveKeyFile = retreiveKeyFileDummy , retrieveKeyFileCheap = \_ _ _ -> return False , removeKey = removeKeyDummy + , lockContent = Nothing , checkPresent = checkPresentDummy , checkPresentCheap = repoCheap r , whereisKey = Nothing diff --git a/Remote/Git.hs b/Remote/Git.hs index 8f7e69cbd3..725b302b84 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -142,6 +142,7 @@ gen r u c gc , retrieveKeyFile = copyFromRemote new , retrieveKeyFileCheap = copyFromRemoteCheap new , removeKey = dropKey new + , lockContent = Nothing , checkPresent = inAnnex new , checkPresentCheap = repoCheap r , whereisKey = Nothing diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs index e699036347..8529b63415 100644 --- a/Remote/Glacier.hs +++ b/Remote/Glacier.hs @@ -55,6 +55,7 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost , retrieveKeyFile = retreiveKeyFileDummy , retrieveKeyFileCheap = retrieveCheap this , removeKey = removeKeyDummy + , lockContent = Nothing , checkPresent = checkPresentDummy , checkPresentCheap = False , whereisKey = Nothing diff --git a/Remote/Hook.hs b/Remote/Hook.hs index 98eeeb031f..5d3c0af5c5 100644 --- a/Remote/Hook.hs +++ b/Remote/Hook.hs @@ -49,6 +49,7 @@ gen r u c gc = do , retrieveKeyFile = retreiveKeyFileDummy , retrieveKeyFileCheap = retrieveCheap hooktype , removeKey = removeKeyDummy + , lockContent = Nothing , checkPresent = checkPresentDummy , checkPresentCheap = False , whereisKey = Nothing diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs index 829a2661a9..fd6c25c159 100644 --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -70,6 +70,7 @@ gen r u c gc = do , retrieveKeyFile = retreiveKeyFileDummy , retrieveKeyFileCheap = retrieveCheap o , removeKey = removeKeyDummy + , lockContent = Nothing , checkPresent = checkPresentDummy , checkPresentCheap = False , whereisKey = Nothing diff --git a/Remote/S3.hs b/Remote/S3.hs index c8a34f2e7a..d381e0b72b 100644 --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -81,6 +81,7 @@ gen r u c gc = do , retrieveKeyFile = retreiveKeyFileDummy , retrieveKeyFileCheap = retrieveCheap , removeKey = removeKeyDummy + , lockContent = Nothing , checkPresent = checkPresentDummy , checkPresentCheap = False , whereisKey = Just (getWebUrls info) diff --git a/Remote/Tahoe.hs b/Remote/Tahoe.hs index c04cdae584..2ced67e308 100644 --- a/Remote/Tahoe.hs +++ b/Remote/Tahoe.hs @@ -72,6 +72,7 @@ gen r u c gc = do , retrieveKeyFile = retrieve u hdl , retrieveKeyFileCheap = \_ _ _ -> return False , removeKey = remove + , lockContent = Nothing , checkPresent = checkKey u hdl , checkPresentCheap = False , whereisKey = Nothing diff --git a/Remote/Web.hs b/Remote/Web.hs index ae0281064b..257eba2e1c 100644 --- a/Remote/Web.hs +++ b/Remote/Web.hs @@ -52,6 +52,7 @@ gen r _ c gc = , retrieveKeyFile = downloadKey , retrieveKeyFileCheap = downloadKeyCheap , removeKey = dropKey + , lockContent = Nothing , checkPresent = checkKey , checkPresentCheap = False , whereisKey = Nothing diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs index 730093a3b2..7f4173d033 100644 --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -60,6 +60,7 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost , retrieveKeyFile = retreiveKeyFileDummy , retrieveKeyFileCheap = retrieveCheap , removeKey = removeKeyDummy + , lockContent = Nothing , checkPresent = checkPresentDummy , checkPresentCheap = False , whereisKey = Nothing diff --git a/Types/Remote.hs b/Types/Remote.hs index 24851e17cb..1bf79a81ea 100644 --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -7,6 +7,8 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE RankNTypes #-} + module Types.Remote ( RemoteConfigKey , RemoteConfig @@ -72,8 +74,12 @@ data RemoteA a = Remote { -- Retrieves a key's contents to a tmp file, if it can be done cheaply. -- It's ok to create a symlink or hardlink. retrieveKeyFileCheap :: Key -> AssociatedFile -> FilePath -> a Bool, - -- removes a key's contents (succeeds if the contents are not present) + -- Removes a key's contents (succeeds if the contents are not present) removeKey :: Key -> a Bool, + -- Uses locking to prevent removal of a key's contents, + -- and runs the passed action while it's locked. + -- This is optional; remotes do not have to support locking. + lockContent :: forall r. Maybe (Key -> a r -> a r), -- Checks if a key is present in the remote. -- Throws an exception if the remote cannot be accessed. checkPresent :: Key -> a Bool, From 90f7c4b6a234d9d49d07a06d2ea5cda41b50b453 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 8 Oct 2015 16:55:11 -0400 Subject: [PATCH 09/30] add VerifiedCopy data type There should be no behavior changes in this commit, it just adds a more expressive data type and adjusts code that had been passing around a [UUID] or sometimes a Maybe Remote to instead use [VerifiedCopy]. Although, since some functions were taking two different [UUID] lists, there's some potential for me to have gotten it horribly wrong. --- Annex/Content.hs | 12 +++++--- Annex/Drop.hs | 11 ++++---- Annex/NumCopies.hs | 24 ++++++++-------- Assistant/Drop.hs | 7 +++-- Assistant/Threads/Committer.hs | 2 +- Assistant/Threads/SanityChecker.hs | 2 +- Assistant/Threads/TransferScanner.hs | 2 +- Assistant/TransferSlots.hs | 5 ++-- Command/Drop.hs | 37 +++++++++++------------- Command/DropUnused.hs | 2 +- Command/Import.hs | 2 +- Command/LockContent.hs | 2 +- Command/Mirror.hs | 2 +- Command/Sync.hs | 4 +-- Types/NumCopies.hs | 42 +++++++++++++++++++++++++++- Types/UUID.hs | 11 ++++++-- 16 files changed, 107 insertions(+), 60 deletions(-) diff --git a/Annex/Content.hs b/Annex/Content.hs index 8fbb49ce6b..e45d9ea05c 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -67,6 +67,8 @@ import Messages.Progress import qualified Types.Remote import qualified Types.Backend import qualified Backend +import Types.NumCopies +import Annex.UUID {- Checks if a given key's content is currently present. -} inAnnex :: Key -> Annex Bool @@ -178,8 +180,10 @@ contentLockFile key = Just <$> calcRepo (gitAnnexContentLock key) - Note that, in direct mode, nothing prevents the user from directly - editing or removing the content, even while it's locked by this. -} -lockContentShared :: Key -> Annex a -> Annex a -lockContentShared = lockContentUsing lock +lockContentShared :: Key -> (VerifiedCopy -> Annex a) -> Annex a +lockContentShared key a = lockContentUsing lock key $ do + u <- getUUID + a (VerifiedCopyLock u (return ())) where #ifndef mingw32_HOST_OS lock contentfile Nothing = liftIO $ tryLockShared Nothing contentfile @@ -195,7 +199,7 @@ newtype ContentLockExclusive = ContentLockExclusive Key -} lockContentExclusive :: Key -> (ContentLockExclusive -> Annex a) -> Annex a lockContentExclusive key a = lockContentUsing lock key $ - a $ ContentLockExclusive key + a (ContentLockExclusive key) where #ifndef mingw32_HOST_OS {- Since content files are stored with the write bit disabled, have @@ -238,7 +242,7 @@ lockContentUsing locker key a = do bracket (lock contentfile lockfile) (unlock lockfile) - (const $ a) + (const a) where alreadylocked = error "content is locked" failedtolock e = error $ "failed to lock content: " ++ show e diff --git a/Annex/Drop.hs b/Annex/Drop.hs index 973e51348a..791273d8e8 100644 --- a/Annex/Drop.hs +++ b/Annex/Drop.hs @@ -32,9 +32,8 @@ type Reason = String - only ones that match the UUIDs will be dropped from. - If allowed to drop fromhere, that drop will be tried first. - - - A remote can be specified that is known to have the key. This can be - - used an an optimisation when eg, a key has just been uploaded to a - - remote. + - A VerifiedCopy can be provided as an optimisation when eg, a key + - has just been uploaded to a remote. - - In direct mode, all associated files are checked, and only if all - of them are unwanted are they dropped. @@ -42,8 +41,8 @@ type Reason = String - The runner is used to run commands, and so can be either callCommand - or commandAction. -} -handleDropsFrom :: [UUID] -> [Remote] -> Reason -> Bool -> Key -> AssociatedFile -> Maybe Remote -> (CommandStart -> CommandCleanup) -> Annex () -handleDropsFrom locs rs reason fromhere key afile knownpresentremote runner = do +handleDropsFrom :: [UUID] -> [Remote] -> Reason -> Bool -> Key -> AssociatedFile -> [VerifiedCopy] -> (CommandStart -> CommandCleanup) -> Annex () +handleDropsFrom locs rs reason fromhere key afile preverified runner = do fs <- ifM isDirect ( do l <- associatedFilesRelative key @@ -112,7 +111,7 @@ handleDropsFrom locs rs reason fromhere key afile knownpresentremote runner = do ) dropl fs n = checkdrop fs n Nothing $ \numcopies -> - Command.Drop.startLocal afile numcopies key knownpresentremote + Command.Drop.startLocal afile numcopies key preverified dropr fs r n = checkdrop fs n (Just $ Remote.uuid r) $ \numcopies -> Command.Drop.startRemote afile numcopies key r diff --git a/Annex/NumCopies.hs b/Annex/NumCopies.hs index 3f078b8f09..549c722072 100644 --- a/Annex/NumCopies.hs +++ b/Annex/NumCopies.hs @@ -96,11 +96,11 @@ verifyEnoughCopies -> Key -> NumCopies -> [UUID] -- repos to skip considering (generally untrusted remotes) - -> [UUID] -- repos that are trusted or already verified to have it + -> [VerifiedCopy] -- already known verifications -> [Remote] -- remotes to check to see if they have it -> Annex Bool -verifyEnoughCopies nolocmsg key need skip trusted tocheck = - helper [] [] (nub trusted) (nub tocheck) +verifyEnoughCopies nolocmsg key need skip preverified tocheck = + helper [] [] (deDupVerifiedCopies preverified) (nub tocheck) where helper bad missing have [] | NumCopies (length have) >= need = return True @@ -109,17 +109,17 @@ verifyEnoughCopies nolocmsg key need skip trusted tocheck = return False helper bad missing have (r:rs) | NumCopies (length have) >= need = return True + | any (== u) (map toUUID have) = helper bad missing have rs | otherwise = do - let u = Remote.uuid r - let duplicate = u `elem` have haskey <- Remote.hasKey r key - case (duplicate, haskey) of - (False, Right True) -> helper bad missing (u:have) rs - (False, Left _) -> helper (r:bad) missing have rs - (False, Right False) -> helper bad (u:missing) have rs - _ -> helper bad missing have rs + case haskey of + Right True -> helper bad missing (VerifiedCopy u:have) rs + Left _ -> helper (r:bad) missing have rs + Right False -> helper bad (u:missing) have rs + where + u = Remote.uuid r -notEnoughCopies :: Key -> NumCopies -> [UUID] -> [UUID] -> [Remote] -> String -> Annex () +notEnoughCopies :: Key -> NumCopies -> [VerifiedCopy] -> [UUID] -> [Remote] -> String -> Annex () notEnoughCopies key need have skip bad nolocmsg = do showNote "unsafe" showLongNote $ @@ -127,7 +127,7 @@ notEnoughCopies key need have skip bad nolocmsg = do show (length have) ++ " out of " ++ show (fromNumCopies need) ++ " necessary copies" Remote.showTriedRemotes bad - Remote.showLocations True key (have++skip) nolocmsg + Remote.showLocations True key (map toUUID have++skip) nolocmsg {- Cost ordered lists of remotes that the location log indicates - may have a key. diff --git a/Assistant/Drop.hs b/Assistant/Drop.hs index 57eef8f3ae..5653b7795b 100644 --- a/Assistant/Drop.hs +++ b/Assistant/Drop.hs @@ -15,11 +15,12 @@ import Assistant.DaemonStatus import Annex.Drop (handleDropsFrom, Reason) import Logs.Location import CmdLine.Action +import Types.NumCopies {- Drop from local and/or remote when allowed by the preferred content and - numcopies settings. -} -handleDrops :: Reason -> Bool -> Key -> AssociatedFile -> Maybe Remote -> Assistant () -handleDrops reason fromhere key f knownpresentremote = do +handleDrops :: Reason -> Bool -> Key -> AssociatedFile -> [VerifiedCopy] -> Assistant () +handleDrops reason fromhere key f preverified = do syncrs <- syncDataRemotes <$> getDaemonStatus locs <- liftAnnex $ loggedLocations key - liftAnnex $ handleDropsFrom locs syncrs reason fromhere key f knownpresentremote callCommandAction + liftAnnex $ handleDropsFrom locs syncrs reason fromhere key f preverified callCommandAction diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs index f4af932859..59ca69e88e 100644 --- a/Assistant/Threads/Committer.hs +++ b/Assistant/Threads/Committer.hs @@ -479,7 +479,7 @@ checkChangeContent change@(Change { changeInfo = i }) = void $ if present then queueTransfers "new file created" Next k (Just f) Upload else queueTransfers "new or renamed file wanted" Next k (Just f) Download - handleDrops "file renamed" present k (Just f) Nothing + handleDrops "file renamed" present k (Just f) [] where f = changeFile change checkChangeContent _ = noop diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs index 0f2c1245a5..f42462e52e 100644 --- a/Assistant/Threads/SanityChecker.hs +++ b/Assistant/Threads/SanityChecker.hs @@ -191,7 +191,7 @@ dailyCheck urlrenderer = do void $ liftAnnex $ setUnusedKeys unused forM_ unused $ \k -> do unlessM (queueTransfers "unused" Later k Nothing Upload) $ - handleDrops "unused" True k Nothing Nothing + handleDrops "unused" True k Nothing [] return True where diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs index 3cbaadf19f..f35c1f1f53 100644 --- a/Assistant/Threads/TransferScanner.hs +++ b/Assistant/Threads/TransferScanner.hs @@ -157,7 +157,7 @@ expensiveScan urlrenderer rs = batch <~> do present <- liftAnnex $ inAnnex key liftAnnex $ handleDropsFrom locs syncrs "expensive scan found too many copies of object" - present key (Just f) Nothing callCommandAction + present key (Just f) [] callCommandAction liftAnnex $ do let slocs = S.fromList locs let use a = return $ mapMaybe (a key slocs) syncrs diff --git a/Assistant/TransferSlots.hs b/Assistant/TransferSlots.hs index 7490ede396..232d1d6e1e 100644 --- a/Assistant/TransferSlots.hs +++ b/Assistant/TransferSlots.hs @@ -30,6 +30,7 @@ import Annex.Content import Annex.Wanted import Annex.Path import Utility.Batch +import Types.NumCopies import qualified Data.Map as M import qualified Control.Exception as E @@ -160,7 +161,7 @@ genTransfer t info = case transferRemote info of ("object uploaded to " ++ show remote) True (transferKey t) (associatedFile info) - (Just remote) + [VerifiedCopy (Remote.uuid remote)] void recordCommit , whenM (liftAnnex $ isNothing <$> checkTransfer t) $ void $ removeTransfer t @@ -225,7 +226,7 @@ finishedTransfer t (Just info) where dodrops fromhere = handleDrops ("drop wanted after " ++ describeTransfer t info) - fromhere (transferKey t) (associatedFile info) Nothing + fromhere (transferKey t) (associatedFile info) [] finishedTransfer _ _ = noop {- Pause a running transfer. -} diff --git a/Command/Drop.hs b/Command/Drop.hs index 8b361ed56f..49e4bea851 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -64,11 +64,11 @@ start' o key afile = do checkDropAuto (autoMode o) from afile key $ \numcopies -> stopUnless (want from) $ case from of - Nothing -> startLocal afile numcopies key Nothing + Nothing -> startLocal afile numcopies key [] Just remote -> do u <- getUUID if Remote.uuid remote == u - then startLocal afile numcopies key Nothing + then startLocal afile numcopies key [] else startRemote afile numcopies key remote where want from @@ -78,10 +78,10 @@ start' o key afile = do startKeys :: DropOptions -> Key -> CommandStart startKeys o key = start' o key Nothing -startLocal :: AssociatedFile -> NumCopies -> Key -> Maybe Remote -> CommandStart -startLocal afile numcopies key knownpresentremote = stopUnless (inAnnex key) $ do +startLocal :: AssociatedFile -> NumCopies -> Key -> [VerifiedCopy] -> CommandStart +startLocal afile numcopies key preverified = stopUnless (inAnnex key) $ do showStart' "drop" key afile - next $ performLocal key afile numcopies knownpresentremote + next $ performLocal key afile numcopies preverified startRemote :: AssociatedFile -> NumCopies -> Key -> Remote -> CommandStart startRemote afile numcopies key remote = do @@ -92,16 +92,14 @@ startRemote afile numcopies key remote = do -- present on enough remotes to allow removal. This avoids a scenario where two -- or more remotes are trying to remove a key at the same time, and each -- sees the key is present on the other. -performLocal :: Key -> AssociatedFile -> NumCopies -> Maybe Remote -> CommandPerform -performLocal key afile numcopies knownpresentremote = lockContentExclusive key $ \contentlock -> do +performLocal :: Key -> AssociatedFile -> NumCopies -> [VerifiedCopy] -> CommandPerform +performLocal key afile numcopies preverified = lockContentExclusive key $ \contentlock -> do (remotes, trusteduuids) <- Remote.keyPossibilitiesTrusted key - let trusteduuids' = case knownpresentremote of - Nothing -> trusteduuids - Just r -> Remote.uuid r:trusteduuids + let preverified' = preverified ++ map TrustedCopy trusteduuids untrusteduuids <- trustGet UnTrusted - let tocheck = Remote.remotesWithoutUUID remotes (trusteduuids'++untrusteduuids) + let tocheck = Remote.remotesWithoutUUID remotes (map toUUID preverified'++untrusteduuids) u <- getUUID - ifM (canDrop u key afile numcopies trusteduuids' tocheck []) + ifM (canDrop u key afile numcopies [] preverified' tocheck) ( do removeAnnex contentlock notifyDrop afile True @@ -118,11 +116,11 @@ performRemote key afile numcopies remote = do -- When the local repo has the key, that's one additional copy, -- as long as the local repo is not untrusted. (remotes, trusteduuids) <- knownCopies key - let have = filter (/= uuid) trusteduuids + let trusted = filter (/= uuid) trusteduuids untrusteduuids <- trustGet UnTrusted let tocheck = filter (/= remote) $ - Remote.remotesWithoutUUID remotes (have++untrusteduuids) - stopUnless (canDrop uuid key afile numcopies have tocheck [uuid]) $ do + Remote.remotesWithoutUUID remotes (trusted++untrusteduuids) + stopUnless (canDrop uuid key afile numcopies [uuid] (map TrustedCopy trusted) tocheck) $ do ok <- Remote.removeKey remote key next $ cleanupRemote key remote ok where @@ -140,19 +138,18 @@ cleanupRemote key remote ok = do return ok {- Checks specified remotes to verify that enough copies of a key exist to - - allow it to be safely removed (with no data loss). Can be provided with - - some locations where the key is known/assumed to be present. + - allow it to be safely removed (with no data loss). - - Also checks if it's required content, and refuses to drop if so. - - --force overrides and always allows dropping. -} -canDrop :: UUID -> Key -> AssociatedFile -> NumCopies -> [UUID] -> [Remote] -> [UUID] -> Annex Bool -canDrop dropfrom key afile numcopies have check skip = +canDrop :: UUID -> Key -> AssociatedFile -> NumCopies -> [UUID] -> [VerifiedCopy] -> [Remote] -> Annex Bool +canDrop dropfrom key afile numcopies skip preverified check = ifM (Annex.getState Annex.force) ( return True , ifM (checkRequiredContent dropfrom key afile - <&&> verifyEnoughCopies nolocmsg key numcopies skip have check + <&&> verifyEnoughCopies nolocmsg key numcopies skip preverified check ) ( return True , do diff --git a/Command/DropUnused.hs b/Command/DropUnused.hs index 98fcef6eae..9c2ae972a5 100644 --- a/Command/DropUnused.hs +++ b/Command/DropUnused.hs @@ -44,7 +44,7 @@ perform from numcopies key = case from of Just r -> do showAction $ "from " ++ Remote.name r Command.Drop.performRemote key Nothing numcopies r - Nothing -> Command.Drop.performLocal key Nothing numcopies Nothing + Nothing -> Command.Drop.performLocal key Nothing numcopies [] performOther :: (Key -> Git.Repo -> FilePath) -> Key -> CommandPerform performOther filespec key = do diff --git a/Command/Import.hs b/Command/Import.hs index e846181733..fbce4c55ae 100644 --- a/Command/Import.hs +++ b/Command/Import.hs @@ -143,4 +143,4 @@ verifiedExisting key destfile = do (remotes, trusteduuids) <- knownCopies key untrusteduuids <- trustGet UnTrusted let tocheck = Remote.remotesWithoutUUID remotes (trusteduuids++untrusteduuids) - verifyEnoughCopies [] key need [] trusteduuids tocheck + verifyEnoughCopies [] key need [] (map TrustedCopy trusteduuids) tocheck diff --git a/Command/LockContent.hs b/Command/LockContent.hs index bab5c92767..e37d4cca51 100644 --- a/Command/LockContent.hs +++ b/Command/LockContent.hs @@ -27,7 +27,7 @@ seek = withWords start -- dropping the lock. start :: [String] -> CommandStart start [ks] = do - ok <- lockContentShared k locksuccess + ok <- lockContentShared k (const locksuccess) `catchNonAsync` (const $ return False) liftIO $ if ok then exitSuccess diff --git a/Command/Mirror.hs b/Command/Mirror.hs index 0555d025cc..a8caf9da7f 100644 --- a/Command/Mirror.hs +++ b/Command/Mirror.hs @@ -65,7 +65,7 @@ startKey o afile key = case fromToOptions o of Right False -> ifM (inAnnex key) ( do numcopies <- getnumcopies - Command.Drop.startLocal afile numcopies key Nothing + Command.Drop.startLocal afile numcopies key [] , stop ) where diff --git a/Command/Sync.hs b/Command/Sync.hs index 964b45dc2a..49dfe811e0 100644 --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -460,8 +460,8 @@ syncFile ebloom rs af k = do -- includeCommandAction for drops, -- because a failure to drop does not mean -- the sync failed. - handleDropsFrom locs' rs "unwanted" True k af - Nothing callCommandAction + handleDropsFrom locs' rs "unwanted" True k af [] + callCommandAction return (got || not (null putrs)) where diff --git a/Types/NumCopies.hs b/Types/NumCopies.hs index d8ea31e694..732c928d2f 100644 --- a/Types/NumCopies.hs +++ b/Types/NumCopies.hs @@ -1,4 +1,4 @@ -{- git-annex numcopies type +{- git-annex numcopies types - - Copyright 2014 Joey Hess - @@ -7,8 +7,48 @@ module Types.NumCopies where +import Types.UUID + +import qualified Data.Map as M + newtype NumCopies = NumCopies Int deriving (Ord, Eq) fromNumCopies :: NumCopies -> Int fromNumCopies (NumCopies n) = n + +data VerifiedCopy + {- Use when a repository cannot be accessed, but it's + - a trusted repository, which is presumably not going to + - lose a copy. This is the weakest level of verification. -} + = TrustedCopy UUID + {- Represents a recent verification that a copy of an + - object exists in a repository with the given UUID. -} + | VerifiedCopy UUID + {- The strongest proof of the existence of a copy. + - Until its associated action is called to unlock it, + - the copy is locked in the repository and is guaranteed + - not to be dropped by any git-annex process. -} + | VerifiedCopyLock UUID (IO ()) + +instance ToUUID VerifiedCopy where + toUUID (VerifiedCopy u) = u + toUUID (VerifiedCopyLock u _) = u + toUUID (TrustedCopy u) = u + +instance Show VerifiedCopy where + show (TrustedCopy u) = "TrustedCopy " ++ show u + show (VerifiedCopy u) = "VerifiedCopy " ++ show u + show (VerifiedCopyLock u _) = "VerifiedCopyLock " ++ show u + +strongestVerifiedCopy :: VerifiedCopy -> VerifiedCopy -> VerifiedCopy +strongestVerifiedCopy a@(VerifiedCopyLock _ _) _ = a +strongestVerifiedCopy _ b@(VerifiedCopyLock _ _) = b +strongestVerifiedCopy a@(VerifiedCopy _) _ = a +strongestVerifiedCopy _ b@(VerifiedCopy _) = b +strongestVerifiedCopy a@(TrustedCopy _) _ = a + +-- Retains stronger verifications over weaker for the same uuid. +deDupVerifiedCopies :: [VerifiedCopy] -> [VerifiedCopy] +deDupVerifiedCopies l = M.elems $ + M.fromListWith strongestVerifiedCopy (zip (map toUUID l) l) diff --git a/Types/UUID.hs b/Types/UUID.hs index de7ddd65dd..27d82b86ce 100644 --- a/Types/UUID.hs +++ b/Types/UUID.hs @@ -5,6 +5,8 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} + module Types.UUID where import qualified Data.Map as M @@ -19,9 +21,12 @@ fromUUID :: UUID -> String fromUUID (UUID u) = u fromUUID NoUUID = "" -toUUID :: String -> UUID -toUUID [] = NoUUID -toUUID s = UUID s +class ToUUID a where + toUUID :: a -> UUID + +instance ToUUID String where + toUUID [] = NoUUID + toUUID s = UUID s isUUID :: String -> Bool isUUID = isJust . U.fromString From c75c79864daba3422ef4432f12929464695d8d4d Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 8 Oct 2015 17:58:32 -0400 Subject: [PATCH 10/30] support invalidating existing VerifiedCopys --- Annex/Content.hs | 5 ++- Annex/NumCopies.hs | 2 +- Assistant/TransferSlots.hs | 2 +- Command/Drop.hs | 5 +-- Command/Import.hs | 2 +- Types/NumCopies.hs | 74 +++++++++++++++++++++++++++++--------- Types/Remote.hs | 3 ++ Types/UUID.hs | 3 ++ 8 files changed, 73 insertions(+), 23 deletions(-) diff --git a/Annex/Content.hs b/Annex/Content.hs index e45d9ea05c..d0596644ed 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -183,7 +183,10 @@ contentLockFile key = Just <$> calcRepo (gitAnnexContentLock key) lockContentShared :: Key -> (VerifiedCopy -> Annex a) -> Annex a lockContentShared key a = lockContentUsing lock key $ do u <- getUUID - a (VerifiedCopyLock u (return ())) + bracketIO + (invalidatableVerifiedCopy VerifiedCopyLock u) + invalidateVerifiedCopy + a where #ifndef mingw32_HOST_OS lock contentfile Nothing = liftIO $ tryLockShared Nothing contentfile diff --git a/Annex/NumCopies.hs b/Annex/NumCopies.hs index 549c722072..6b534591e9 100644 --- a/Annex/NumCopies.hs +++ b/Annex/NumCopies.hs @@ -113,7 +113,7 @@ verifyEnoughCopies nolocmsg key need skip preverified tocheck = | otherwise = do haskey <- Remote.hasKey r key case haskey of - Right True -> helper bad missing (VerifiedCopy u:have) rs + Right True -> helper bad missing (mkVerifiedCopy RecentlyVerifiedCopy u : have) rs Left _ -> helper (r:bad) missing have rs Right False -> helper bad (u:missing) have rs where diff --git a/Assistant/TransferSlots.hs b/Assistant/TransferSlots.hs index 232d1d6e1e..2ea09c4191 100644 --- a/Assistant/TransferSlots.hs +++ b/Assistant/TransferSlots.hs @@ -161,7 +161,7 @@ genTransfer t info = case transferRemote info of ("object uploaded to " ++ show remote) True (transferKey t) (associatedFile info) - [VerifiedCopy (Remote.uuid remote)] + [mkVerifiedCopy RecentlyVerifiedCopy remote] void recordCommit , whenM (liftAnnex $ isNothing <$> checkTransfer t) $ void $ removeTransfer t diff --git a/Command/Drop.hs b/Command/Drop.hs index 49e4bea851..26872c6c00 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -95,7 +95,7 @@ startRemote afile numcopies key remote = do performLocal :: Key -> AssociatedFile -> NumCopies -> [VerifiedCopy] -> CommandPerform performLocal key afile numcopies preverified = lockContentExclusive key $ \contentlock -> do (remotes, trusteduuids) <- Remote.keyPossibilitiesTrusted key - let preverified' = preverified ++ map TrustedCopy trusteduuids + let preverified' = preverified ++ map (mkVerifiedCopy TrustedCopy) trusteduuids untrusteduuids <- trustGet UnTrusted let tocheck = Remote.remotesWithoutUUID remotes (map toUUID preverified'++untrusteduuids) u <- getUUID @@ -117,10 +117,11 @@ performRemote key afile numcopies remote = do -- as long as the local repo is not untrusted. (remotes, trusteduuids) <- knownCopies key let trusted = filter (/= uuid) trusteduuids + let preverified = map (mkVerifiedCopy TrustedCopy) trusted untrusteduuids <- trustGet UnTrusted let tocheck = filter (/= remote) $ Remote.remotesWithoutUUID remotes (trusted++untrusteduuids) - stopUnless (canDrop uuid key afile numcopies [uuid] (map TrustedCopy trusted) tocheck) $ do + stopUnless (canDrop uuid key afile numcopies [uuid] preverified tocheck) $ do ok <- Remote.removeKey remote key next $ cleanupRemote key remote ok where diff --git a/Command/Import.hs b/Command/Import.hs index fbce4c55ae..3206ad48b7 100644 --- a/Command/Import.hs +++ b/Command/Import.hs @@ -143,4 +143,4 @@ verifiedExisting key destfile = do (remotes, trusteduuids) <- knownCopies key untrusteduuids <- trustGet UnTrusted let tocheck = Remote.remotesWithoutUUID remotes (trusteduuids++untrusteduuids) - verifyEnoughCopies [] key need [] (map TrustedCopy trusteduuids) tocheck + verifyEnoughCopies [] key need [] (map (mkVerifiedCopy TrustedCopy) trusteduuids) tocheck diff --git a/Types/NumCopies.hs b/Types/NumCopies.hs index 732c928d2f..0acb7cc3b0 100644 --- a/Types/NumCopies.hs +++ b/Types/NumCopies.hs @@ -5,11 +5,22 @@ - Licensed under the GNU GPL version 3 or higher. -} -module Types.NumCopies where +module Types.NumCopies ( + NumCopies(..), + fromNumCopies, + VerifiedCopy(..), + checkVerifiedCopy, + invalidateVerifiedCopy, + strongestVerifiedCopy, + deDupVerifiedCopies, + mkVerifiedCopy, + invalidatableVerifiedCopy, +) where import Types.UUID import qualified Data.Map as M +import Control.Concurrent.MVar newtype NumCopies = NumCopies Int deriving (Ord, Eq) @@ -17,38 +28,67 @@ newtype NumCopies = NumCopies Int fromNumCopies :: NumCopies -> Int fromNumCopies (NumCopies n) = n +-- A verification that a copy of a key exists in a repository. data VerifiedCopy {- Use when a repository cannot be accessed, but it's - - a trusted repository, which is presumably not going to - - lose a copy. This is the weakest level of verification. -} - = TrustedCopy UUID + - a trusted repository, which is on record as containing a key + - and is presumably not going to lose its copy. + - This is the weakest level of verification. -} + = TrustedCopy V {- Represents a recent verification that a copy of an - object exists in a repository with the given UUID. -} - | VerifiedCopy UUID + | RecentlyVerifiedCopy V {- The strongest proof of the existence of a copy. - Until its associated action is called to unlock it, - the copy is locked in the repository and is guaranteed - not to be dropped by any git-annex process. -} - | VerifiedCopyLock UUID (IO ()) + | VerifiedCopyLock V + deriving (Show) instance ToUUID VerifiedCopy where - toUUID (VerifiedCopy u) = u - toUUID (VerifiedCopyLock u _) = u - toUUID (TrustedCopy u) = u + toUUID = _getUUID . toV + +toV :: VerifiedCopy -> V +toV (TrustedCopy v) = v +toV (RecentlyVerifiedCopy v) = v +toV (VerifiedCopyLock v) = v -instance Show VerifiedCopy where - show (TrustedCopy u) = "TrustedCopy " ++ show u - show (VerifiedCopy u) = "VerifiedCopy " ++ show u - show (VerifiedCopyLock u _) = "VerifiedCopyLock " ++ show u +-- Checks that it's still valid. +checkVerifiedCopy :: VerifiedCopy -> IO Bool +checkVerifiedCopy = _checkVerifiedCopy . toV + +invalidateVerifiedCopy :: VerifiedCopy -> IO () +invalidateVerifiedCopy = _invalidateVerifiedCopy . toV + +data V = V + { _getUUID :: UUID + , _checkVerifiedCopy :: IO Bool + , _invalidateVerifiedCopy :: IO () + } + +instance Show V where + show v = show (_getUUID v) strongestVerifiedCopy :: VerifiedCopy -> VerifiedCopy -> VerifiedCopy -strongestVerifiedCopy a@(VerifiedCopyLock _ _) _ = a -strongestVerifiedCopy _ b@(VerifiedCopyLock _ _) = b -strongestVerifiedCopy a@(VerifiedCopy _) _ = a -strongestVerifiedCopy _ b@(VerifiedCopy _) = b +strongestVerifiedCopy a@(VerifiedCopyLock _) _ = a +strongestVerifiedCopy _ b@(VerifiedCopyLock _) = b +strongestVerifiedCopy a@(RecentlyVerifiedCopy _) _ = a +strongestVerifiedCopy _ b@(RecentlyVerifiedCopy _) = b strongestVerifiedCopy a@(TrustedCopy _) _ = a -- Retains stronger verifications over weaker for the same uuid. deDupVerifiedCopies :: [VerifiedCopy] -> [VerifiedCopy] deDupVerifiedCopies l = M.elems $ M.fromListWith strongestVerifiedCopy (zip (map toUUID l) l) + +mkVerifiedCopy :: ToUUID u => (V -> VerifiedCopy) -> u -> VerifiedCopy +mkVerifiedCopy mk u = mk $ V (toUUID u) (return True) (return ()) + +invalidatableVerifiedCopy :: ToUUID u => (V -> VerifiedCopy) -> u -> IO VerifiedCopy +invalidatableVerifiedCopy mk u = do + v <- newEmptyMVar + let invalidate = do + _ <- tryPutMVar v () + return () + let check = isEmptyMVar v + return $ mk $ V (toUUID u) check invalidate diff --git a/Types/Remote.hs b/Types/Remote.hs index 1bf79a81ea..9e5f9f735a 100644 --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -131,6 +131,9 @@ instance Eq (RemoteA a) where instance Ord (RemoteA a) where compare = comparing uuid +instance ToUUID (RemoteA a) where + toUUID = uuid + -- Use Verified when the content of a key is verified as part of a -- transfer, and so a separate verification step is not needed. data Verification = UnVerified | Verified diff --git a/Types/UUID.hs b/Types/UUID.hs index 27d82b86ce..4212eaa7f9 100644 --- a/Types/UUID.hs +++ b/Types/UUID.hs @@ -24,6 +24,9 @@ fromUUID NoUUID = "" class ToUUID a where toUUID :: a -> UUID +instance ToUUID UUID where + toUUID = id + instance ToUUID String where toUUID [] = NoUUID toUUID s = UUID s From b17f5da6c94b8047ed08af684f4a9f8786d68ddb Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 8 Oct 2015 18:11:39 -0400 Subject: [PATCH 11/30] require 1 locked copy while dropping from local or a remote See doc/bugs/concurrent_drop--from_presence_checking_failures.mdwn for discussion about why 1 locked copy is all we can require, and how this fixes concurrent dropping bugs. Note that, since nothing yet generates a VerifiedCopyLock yet, this commit breaks dropping temporarily. --- Annex/NumCopies.hs | 26 +++++++++++++++++++++++++- 1 file changed, 25 insertions(+), 1 deletion(-) diff --git a/Annex/NumCopies.hs b/Annex/NumCopies.hs index 6b534591e9..6368554019 100644 --- a/Annex/NumCopies.hs +++ b/Annex/NumCopies.hs @@ -108,7 +108,11 @@ verifyEnoughCopies nolocmsg key need skip preverified tocheck = notEnoughCopies key need have (skip++missing) bad nolocmsg return False helper bad missing have (r:rs) - | NumCopies (length have) >= need = return True + | verifiedEnoughCopies need have = do + stillhave <- liftIO $ filterM checkVerifiedCopy have + if verifiedEnoughCopies need stillhave + then return True + else helper bad missing stillhave (r:rs) | any (== u) (map toUUID have) = helper bad missing have rs | otherwise = do haskey <- Remote.hasKey r key @@ -119,6 +123,26 @@ verifyEnoughCopies nolocmsg key need skip preverified tocheck = where u = Remote.uuid r +{- Check whether enough verification has been done of copies to allow + - dropping content safely. + - + - Unless numcopies is 0, at least one VerifiedCopyLock is required. + - This prevents races between concurrent drops from dropping the last + - copy, no matter what. + - + - The other N-1 copies can be less strong verifications. While those + - are subject to concurrent drop races, and so could be dropped + - all at once, causing numcopies to be violated, this is the best that can + - be done without requiring all special remotes to support locking. + -} +verifiedEnoughCopies :: NumCopies -> [VerifiedCopy] -> Bool +verifiedEnoughCopies (NumCopies n) l + | n == 0 = True + | otherwise = length l >= n && any islock l + where + islock (VerifiedCopyLock _) = True + islock _ = False + notEnoughCopies :: Key -> NumCopies -> [VerifiedCopy] -> [UUID] -> [Remote] -> String -> Annex () notEnoughCopies key need have skip bad nolocmsg = do showNote "unsafe" From e4a33967a12c9435556a7642e56af25e46dda454 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 8 Oct 2015 18:20:36 -0400 Subject: [PATCH 12/30] try harder to verify until at least one VerifiedCopyLock is obtained This avoids a failure where eg, we start with RecentlyVerifiedCopies for all remotes, and so didn't do any active verification, which is required. Also, dedup the list of VerifiedCopies when checking if we have enough, in case 2 copies of a UUID slip in. --- Annex/NumCopies.hs | 27 +++++++++++++++------------ 1 file changed, 15 insertions(+), 12 deletions(-) diff --git a/Annex/NumCopies.hs b/Annex/NumCopies.hs index 6368554019..7509465703 100644 --- a/Annex/NumCopies.hs +++ b/Annex/NumCopies.hs @@ -77,7 +77,11 @@ getFileNumCopies' file = maybe getGlobalNumCopies (return . Just) =<< getattr {- Checks if numcopies are satisfied for a file by running a comparison - between the number of (not untrusted) copies that are - - belived to exist, and the configured value. -} + - belived to exist, and the configured value. + - + - This is good enough for everything except dropping the file, which + - requires active verification of the copies. + -} numCopiesCheck :: FilePath -> Key -> (Int -> Int -> v) -> Annex v numCopiesCheck file key vs = do have <- trustExclude UnTrusted =<< Remote.keyLocations key @@ -89,14 +93,14 @@ numCopiesCheck' file vs have = do return $ length have `vs` needed {- Verifies that enough copies of a key exist amoung the listed remotes, - - priting an informative message if not. + - printing an informative message if not. -} verifyEnoughCopies :: String -- message to print when there are no known locations -> Key -> NumCopies -> [UUID] -- repos to skip considering (generally untrusted remotes) - -> [VerifiedCopy] -- already known verifications + -> [VerifiedCopy] -- copies already verified to exist -> [Remote] -- remotes to check to see if they have it -> Annex Bool verifyEnoughCopies nolocmsg key need skip preverified tocheck = @@ -113,15 +117,13 @@ verifyEnoughCopies nolocmsg key need skip preverified tocheck = if verifiedEnoughCopies need stillhave then return True else helper bad missing stillhave (r:rs) - | any (== u) (map toUUID have) = helper bad missing have rs + | any isFullVerification have = helper bad missing have rs | otherwise = do haskey <- Remote.hasKey r key case haskey of - Right True -> helper bad missing (mkVerifiedCopy RecentlyVerifiedCopy u : have) rs + Right True -> helper bad missing (mkVerifiedCopy RecentlyVerifiedCopy r : have) rs Left _ -> helper (r:bad) missing have rs - Right False -> helper bad (u:missing) have rs - where - u = Remote.uuid r + Right False -> helper bad (Remote.uuid r:missing) have rs {- Check whether enough verification has been done of copies to allow - dropping content safely. @@ -138,10 +140,11 @@ verifyEnoughCopies nolocmsg key need skip preverified tocheck = verifiedEnoughCopies :: NumCopies -> [VerifiedCopy] -> Bool verifiedEnoughCopies (NumCopies n) l | n == 0 = True - | otherwise = length l >= n && any islock l - where - islock (VerifiedCopyLock _) = True - islock _ = False + | otherwise = length (deDupVerifiedCopies l) >= n && any isFullVerification l + +isFullVerification :: VerifiedCopy -> Bool +isFullVerification (VerifiedCopyLock _) = True +isFullVerification _ = False notEnoughCopies :: Key -> NumCopies -> [VerifiedCopy] -> [UUID] -> [Remote] -> String -> Annex () notEnoughCopies key need have skip bad nolocmsg = do From 7f5958eec2d24754548477db8c50fb6ee968c938 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 8 Oct 2015 18:32:31 -0400 Subject: [PATCH 13/30] TrustedCopy is good enough to allow dropping By definition, a trusted repository is trusted to always have its location tracking log accurate. Thus, it should never be in a position where content is being dropped from it concurrently, as that would result in the location tracking log not being accurate. --- Annex/NumCopies.hs | 28 +++++++++++++++------------- Types/NumCopies.hs | 15 +++++++-------- 2 files changed, 22 insertions(+), 21 deletions(-) diff --git a/Annex/NumCopies.hs b/Annex/NumCopies.hs index 7509465703..a06ef0c5e9 100644 --- a/Annex/NumCopies.hs +++ b/Annex/NumCopies.hs @@ -104,7 +104,7 @@ verifyEnoughCopies -> [Remote] -- remotes to check to see if they have it -> Annex Bool verifyEnoughCopies nolocmsg key need skip preverified tocheck = - helper [] [] (deDupVerifiedCopies preverified) (nub tocheck) + helper [] [] preverified (nub tocheck) where helper bad missing have [] | NumCopies (length have) >= need = return True @@ -117,7 +117,7 @@ verifyEnoughCopies nolocmsg key need skip preverified tocheck = if verifiedEnoughCopies need stillhave then return True else helper bad missing stillhave (r:rs) - | any isFullVerification have = helper bad missing have rs + | any safeVerification have = helper bad missing have rs | otherwise = do haskey <- Remote.hasKey r key case haskey of @@ -128,23 +128,25 @@ verifyEnoughCopies nolocmsg key need skip preverified tocheck = {- Check whether enough verification has been done of copies to allow - dropping content safely. - - - Unless numcopies is 0, at least one VerifiedCopyLock is required. - - This prevents races between concurrent drops from dropping the last - - copy, no matter what. + - Unless numcopies is 0, at least one VerifiedCopyLock or TrustedCopy + - is required. A VerifiedCopyLock prevents races between concurrent + - drops from dropping the last copy, no matter what. - - - The other N-1 copies can be less strong verifications. While those - - are subject to concurrent drop races, and so could be dropped - - all at once, causing numcopies to be violated, this is the best that can - - be done without requiring all special remotes to support locking. + - The other N-1 copies can be less strong verifications, like + - RecentlyVerifiedCopy. While those are subject to concurrent drop races, + - and so could be dropped all at once, causing numcopies to be violated, + - this is the best that can be done without requiring all special remotes + - to support locking. -} verifiedEnoughCopies :: NumCopies -> [VerifiedCopy] -> Bool verifiedEnoughCopies (NumCopies n) l | n == 0 = True - | otherwise = length (deDupVerifiedCopies l) >= n && any isFullVerification l + | otherwise = length (deDupVerifiedCopies l) >= n && any safeVerification l -isFullVerification :: VerifiedCopy -> Bool -isFullVerification (VerifiedCopyLock _) = True -isFullVerification _ = False +safeVerification :: VerifiedCopy -> Bool +safeVerification (VerifiedCopyLock _) = True +safeVerification (TrustedCopy _) = True +safeVerification (RecentlyVerifiedCopy _) = False notEnoughCopies :: Key -> NumCopies -> [VerifiedCopy] -> [UUID] -> [Remote] -> String -> Annex () notEnoughCopies key need have skip bad nolocmsg = do diff --git a/Types/NumCopies.hs b/Types/NumCopies.hs index 0acb7cc3b0..1a3b973cc3 100644 --- a/Types/NumCopies.hs +++ b/Types/NumCopies.hs @@ -30,14 +30,13 @@ fromNumCopies (NumCopies n) = n -- A verification that a copy of a key exists in a repository. data VerifiedCopy - {- Use when a repository cannot be accessed, but it's - - a trusted repository, which is on record as containing a key - - and is presumably not going to lose its copy. - - This is the weakest level of verification. -} - = TrustedCopy V {- Represents a recent verification that a copy of an - object exists in a repository with the given UUID. -} - | RecentlyVerifiedCopy V + = RecentlyVerifiedCopy V + {- Use when a repository cannot be accessed, but it's + - a trusted repository, which is on record as containing a key + - and is presumably not going to lose its copy. -} + | TrustedCopy V {- The strongest proof of the existence of a copy. - Until its associated action is called to unlock it, - the copy is locked in the repository and is guaranteed @@ -72,9 +71,9 @@ instance Show V where strongestVerifiedCopy :: VerifiedCopy -> VerifiedCopy -> VerifiedCopy strongestVerifiedCopy a@(VerifiedCopyLock _) _ = a strongestVerifiedCopy _ b@(VerifiedCopyLock _) = b +strongestVerifiedCopy a@(TrustedCopy _) _ = a +strongestVerifiedCopy _ b@(TrustedCopy _) = b strongestVerifiedCopy a@(RecentlyVerifiedCopy _) _ = a -strongestVerifiedCopy _ b@(RecentlyVerifiedCopy _) = b -strongestVerifiedCopy a@(TrustedCopy _) _ = a -- Retains stronger verifications over weaker for the same uuid. deDupVerifiedCopies :: [VerifiedCopy] -> [VerifiedCopy] From f57ac29be1f83dccd26bc6e6bb75250b4e645745 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 9 Oct 2015 10:30:22 -0400 Subject: [PATCH 14/30] refactor --- Annex/Content.hs | 5 +---- Types/NumCopies.hs | 35 ++++++++++++++++++++++++++--------- 2 files changed, 27 insertions(+), 13 deletions(-) diff --git a/Annex/Content.hs b/Annex/Content.hs index d0596644ed..da29aa4ed2 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -183,10 +183,7 @@ contentLockFile key = Just <$> calcRepo (gitAnnexContentLock key) lockContentShared :: Key -> (VerifiedCopy -> Annex a) -> Annex a lockContentShared key a = lockContentUsing lock key $ do u <- getUUID - bracketIO - (invalidatableVerifiedCopy VerifiedCopyLock u) - invalidateVerifiedCopy - a + withVerifiedCopy VerifiedCopyLock u a where #ifndef mingw32_HOST_OS lock contentfile Nothing = liftIO $ tryLockShared Nothing contentfile diff --git a/Types/NumCopies.hs b/Types/NumCopies.hs index 1a3b973cc3..38bce6818b 100644 --- a/Types/NumCopies.hs +++ b/Types/NumCopies.hs @@ -15,12 +15,16 @@ module Types.NumCopies ( deDupVerifiedCopies, mkVerifiedCopy, invalidatableVerifiedCopy, + withVerifiedCopy, ) where import Types.UUID +import Utility.Exception (bracketIO) import qualified Data.Map as M import Control.Concurrent.MVar +import Control.Monad.Catch (MonadMask) +import Control.Monad.IO.Class (MonadIO) newtype NumCopies = NumCopies Int deriving (Ord, Eq) @@ -44,6 +48,15 @@ data VerifiedCopy | VerifiedCopyLock V deriving (Show) +data V = V + { _getUUID :: UUID + , _checkVerifiedCopy :: IO Bool + , _invalidateVerifiedCopy :: IO () + } + +instance Show V where + show v = show (_getUUID v) + instance ToUUID VerifiedCopy where toUUID = _getUUID . toV @@ -59,15 +72,6 @@ checkVerifiedCopy = _checkVerifiedCopy . toV invalidateVerifiedCopy :: VerifiedCopy -> IO () invalidateVerifiedCopy = _invalidateVerifiedCopy . toV -data V = V - { _getUUID :: UUID - , _checkVerifiedCopy :: IO Bool - , _invalidateVerifiedCopy :: IO () - } - -instance Show V where - show v = show (_getUUID v) - strongestVerifiedCopy :: VerifiedCopy -> VerifiedCopy -> VerifiedCopy strongestVerifiedCopy a@(VerifiedCopyLock _) _ = a strongestVerifiedCopy _ b@(VerifiedCopyLock _) = b @@ -91,3 +95,16 @@ invalidatableVerifiedCopy mk u = do return () let check = isEmptyMVar v return $ mk $ V (toUUID u) check invalidate + +-- Constructs a VerifiedCopy, and runs the action, ensuring that the +-- verified copy is invalidated when the action returns, or on error. +withVerifiedCopy + :: (Monad m, MonadMask m, MonadIO m, ToUUID u) + => (V -> VerifiedCopy) + -> u + -> (VerifiedCopy -> m a) + -> m a +withVerifiedCopy mk u = bracketIO setup cleanup + where + setup = invalidatableVerifiedCopy mk u + cleanup = invalidateVerifiedCopy From cf79dffa4cae189ae57d8467cb7f915156463978 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 9 Oct 2015 11:09:46 -0400 Subject: [PATCH 15/30] improve drop proof code --- Annex/NumCopies.hs | 61 ++++++++++++++++------------------------------ Command/Drop.hs | 41 ++++++++++++++++--------------- Command/Import.hs | 10 +++++--- Types/NumCopies.hs | 39 +++++++++++++++++++++++++++++ debian/changelog | 11 +++++++-- 5 files changed, 97 insertions(+), 65 deletions(-) diff --git a/Annex/NumCopies.hs b/Annex/NumCopies.hs index a06ef0c5e9..6c069c7632 100644 --- a/Annex/NumCopies.hs +++ b/Annex/NumCopies.hs @@ -15,7 +15,7 @@ module Annex.NumCopies ( defaultNumCopies, numCopiesCheck, numCopiesCheck', - verifyEnoughCopies, + verifyEnoughCopiesToDrop, knownCopies, ) where @@ -93,31 +93,35 @@ numCopiesCheck' file vs have = do return $ length have `vs` needed {- Verifies that enough copies of a key exist amoung the listed remotes, - - printing an informative message if not. + - running an action with a proof if so, and printing an informative + - message if not. -} -verifyEnoughCopies +verifyEnoughCopiesToDrop :: String -- message to print when there are no known locations -> Key -> NumCopies -> [UUID] -- repos to skip considering (generally untrusted remotes) -> [VerifiedCopy] -- copies already verified to exist - -> [Remote] -- remotes to check to see if they have it - -> Annex Bool -verifyEnoughCopies nolocmsg key need skip preverified tocheck = + -> [Remote] -- remotes to check to see if they have copies + -> (SafeDropProof -> Annex a) -- action to perform to drop + -> Annex a -- action to perform when unable to drop + -> Annex a +verifyEnoughCopiesToDrop nolocmsg key need skip preverified tocheck dropaction nodropaction = helper [] [] preverified (nub tocheck) where - helper bad missing have [] - | NumCopies (length have) >= need = return True - | otherwise = do - notEnoughCopies key need have (skip++missing) bad nolocmsg - return False + helper bad missing have [] = do + p <- liftIO $ mkSafeDropProof need have + case p of + Right proof -> dropaction proof + Left stillhave -> do + notEnoughCopies key need stillhave (skip++missing) bad nolocmsg + nodropaction helper bad missing have (r:rs) - | verifiedEnoughCopies need have = do - stillhave <- liftIO $ filterM checkVerifiedCopy have - if verifiedEnoughCopies need stillhave - then return True - else helper bad missing stillhave (r:rs) - | any safeVerification have = helper bad missing have rs + | isSafeDrop need have = do + p <- liftIO $ mkSafeDropProof need have + case p of + Right proof -> dropaction proof + Left stillhave -> helper bad missing stillhave (r:rs) | otherwise = do haskey <- Remote.hasKey r key case haskey of @@ -125,29 +129,6 @@ verifyEnoughCopies nolocmsg key need skip preverified tocheck = Left _ -> helper (r:bad) missing have rs Right False -> helper bad (Remote.uuid r:missing) have rs -{- Check whether enough verification has been done of copies to allow - - dropping content safely. - - - - Unless numcopies is 0, at least one VerifiedCopyLock or TrustedCopy - - is required. A VerifiedCopyLock prevents races between concurrent - - drops from dropping the last copy, no matter what. - - - - The other N-1 copies can be less strong verifications, like - - RecentlyVerifiedCopy. While those are subject to concurrent drop races, - - and so could be dropped all at once, causing numcopies to be violated, - - this is the best that can be done without requiring all special remotes - - to support locking. - -} -verifiedEnoughCopies :: NumCopies -> [VerifiedCopy] -> Bool -verifiedEnoughCopies (NumCopies n) l - | n == 0 = True - | otherwise = length (deDupVerifiedCopies l) >= n && any safeVerification l - -safeVerification :: VerifiedCopy -> Bool -safeVerification (VerifiedCopyLock _) = True -safeVerification (TrustedCopy _) = True -safeVerification (RecentlyVerifiedCopy _) = False - notEnoughCopies :: Key -> NumCopies -> [VerifiedCopy] -> [UUID] -> [Remote] -> String -> Annex () notEnoughCopies key need have skip bad nolocmsg = do showNote "unsafe" diff --git a/Command/Drop.hs b/Command/Drop.hs index 26872c6c00..fa8ac45ad1 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -99,12 +99,12 @@ performLocal key afile numcopies preverified = lockContentExclusive key $ \conte untrusteduuids <- trustGet UnTrusted let tocheck = Remote.remotesWithoutUUID remotes (map toUUID preverified'++untrusteduuids) u <- getUUID - ifM (canDrop u key afile numcopies [] preverified' tocheck) + doDrop u key afile numcopies [] preverified' tocheck ( do removeAnnex contentlock notifyDrop afile True next $ cleanupLocal key - , do + , do notifyDrop afile False stop ) @@ -121,9 +121,12 @@ performRemote key afile numcopies remote = do untrusteduuids <- trustGet UnTrusted let tocheck = filter (/= remote) $ Remote.remotesWithoutUUID remotes (trusted++untrusteduuids) - stopUnless (canDrop uuid key afile numcopies [uuid] preverified tocheck) $ do - ok <- Remote.removeKey remote key - next $ cleanupRemote key remote ok + doDrop uuid key afile numcopies [uuid] preverified tocheck + ( do + ok <- Remote.removeKey remote key + next $ cleanupRemote key remote ok + , stop + ) where uuid = Remote.uuid remote @@ -138,29 +141,29 @@ cleanupRemote key remote ok = do Remote.logStatus remote key InfoMissing return ok -{- Checks specified remotes to verify that enough copies of a key exist to - - allow it to be safely removed (with no data loss). +{- Before running the dropaction, checks specified remotes to + - verify that enough copies of a key exist to allow it to be + - safely removed (with no data loss). - - Also checks if it's required content, and refuses to drop if so. - - --force overrides and always allows dropping. -} -canDrop :: UUID -> Key -> AssociatedFile -> NumCopies -> [UUID] -> [VerifiedCopy] -> [Remote] -> Annex Bool -canDrop dropfrom key afile numcopies skip preverified check = +doDrop :: UUID -> Key -> AssociatedFile -> NumCopies -> [UUID] -> [VerifiedCopy] -> [Remote] -> (CommandPerform, CommandPerform) -> CommandPerform +doDrop dropfrom key afile numcopies skip preverified check (dropaction, nodropaction) = ifM (Annex.getState Annex.force) - ( return True - , ifM (checkRequiredContent dropfrom key afile - <&&> verifyEnoughCopies nolocmsg key numcopies skip preverified check - ) - ( return True - , do - hint - return False - ) + ( dropaction + , ifM (checkRequiredContent dropfrom key afile) + ( verifyEnoughCopiesToDrop nolocmsg key numcopies + skip preverified check (const dropaction) (forcehint nodropaction) + , stop + ) ) where nolocmsg = "Rather than dropping this file, try using: git annex move" - hint = showLongNote "(Use --force to override this check, or adjust numcopies.)" + forcehint a = do + showLongNote "(Use --force to override this check, or adjust numcopies.)" + a checkRequiredContent :: UUID -> Key -> AssociatedFile -> Annex Bool checkRequiredContent u k afile = diff --git a/Command/Import.hs b/Command/Import.hs index 3206ad48b7..f486da7c5c 100644 --- a/Command/Import.hs +++ b/Command/Import.hs @@ -83,7 +83,7 @@ start mode (srcfile, destfile) = where deletedup k = do showNote $ "duplicate of " ++ key2file k - ifM (verifiedExisting k destfile) + verifyExisting k destfile ( do liftIO $ removeFile srcfile next $ return True @@ -134,8 +134,8 @@ start mode (srcfile, destfile) = SkipDuplicates -> checkdup Nothing (Just importfile) _ -> return (Just importfile) -verifiedExisting :: Key -> FilePath -> Annex Bool -verifiedExisting key destfile = do +verifyExisting :: Key -> FilePath -> (CommandPerform, CommandPerform) -> CommandPerform +verifyExisting key destfile (yes, no) = do -- Look up the numcopies setting for the file that it would be -- imported to, if it were imported. need <- getFileNumCopies destfile @@ -143,4 +143,6 @@ verifiedExisting key destfile = do (remotes, trusteduuids) <- knownCopies key untrusteduuids <- trustGet UnTrusted let tocheck = Remote.remotesWithoutUUID remotes (trusteduuids++untrusteduuids) - verifyEnoughCopies [] key need [] (map (mkVerifiedCopy TrustedCopy) trusteduuids) tocheck + let preverified = map (mkVerifiedCopy TrustedCopy) trusteduuids + verifyEnoughCopiesToDrop [] key need [] preverified tocheck + (const yes) no diff --git a/Types/NumCopies.hs b/Types/NumCopies.hs index 38bce6818b..23df6610a2 100644 --- a/Types/NumCopies.hs +++ b/Types/NumCopies.hs @@ -16,6 +16,9 @@ module Types.NumCopies ( mkVerifiedCopy, invalidatableVerifiedCopy, withVerifiedCopy, + isSafeDrop, + SafeDropProof, + mkSafeDropProof, ) where import Types.UUID @@ -25,6 +28,7 @@ import qualified Data.Map as M import Control.Concurrent.MVar import Control.Monad.Catch (MonadMask) import Control.Monad.IO.Class (MonadIO) +import Control.Monad newtype NumCopies = NumCopies Int deriving (Ord, Eq) @@ -108,3 +112,38 @@ withVerifiedCopy mk u = bracketIO setup cleanup where setup = invalidatableVerifiedCopy mk u cleanup = invalidateVerifiedCopy + +{- Check whether enough verification has been done of copies to allow + - dropping content safely. + - + - Unless numcopies is 0, at least one VerifiedCopyLock or TrustedCopy + - is required. A VerifiedCopyLock prevents races between concurrent + - drops from dropping the last copy, no matter what. + - + - The other N-1 copies can be less strong verifications, like + - RecentlyVerifiedCopy. While those are subject to concurrent drop races, + - and so could be dropped all at once, causing numcopies to be violated, + - this is the best that can be done without requiring all special remotes + - to support locking. + -} +isSafeDrop :: NumCopies -> [VerifiedCopy] -> Bool +isSafeDrop (NumCopies n) l + | n == 0 = True + | otherwise = length (deDupVerifiedCopies l) >= n && any fullVerification l + +fullVerification :: VerifiedCopy -> Bool +fullVerification (VerifiedCopyLock _) = True +fullVerification (TrustedCopy _) = True +fullVerification (RecentlyVerifiedCopy _) = False + +-- A proof that it's currently safe to drop an object. +data SafeDropProof = SafeDropProof NumCopies [VerifiedCopy] + +-- Make sure that none of the VerifiedCopies have become invalidated +-- before constructing proof. +mkSafeDropProof :: NumCopies -> [VerifiedCopy] -> IO (Either [VerifiedCopy] SafeDropProof) +mkSafeDropProof need have = do + stillhave <- filterM checkVerifiedCopy have + return $ if isSafeDrop need stillhave + then Right (SafeDropProof need stillhave) + else Left stillhave diff --git a/debian/changelog b/debian/changelog index f3ffa59758..bd503b55ec 100644 --- a/debian/changelog +++ b/debian/changelog @@ -20,9 +20,16 @@ git-annex (5.20150931) UNRELEASED; urgency=medium and stop recommending bittornado | bittorrent. * Debian: Remove dependency on transformers library, as it is now included in ghc. + * Fix a longstanding bug, where dropping a file from a remote + could race with other drops of the same file, and result in + all copies of its content being lost. * git-annex-shell: Added lockcontent command, to prevent dropping of - key's content. - + a key's content. This is necessary due to the above bugfix. + * When a remote uses an old version of git-annex-shell without the + new lockcontent command, git-annex may not trust the remote enough + to be able to drop content. + Solution: Upgrade git-annex-shell to this version. + -- Joey Hess Thu, 01 Oct 2015 12:42:56 -0400 git-annex (5.20150930) unstable; urgency=medium From ceb581953881da5e84dcbe831c6bb9008fbde059 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 9 Oct 2015 12:36:04 -0400 Subject: [PATCH 16/30] finish and use lockContent interface --- Annex/NumCopies.hs | 19 +++++++++++++------ Types/Remote.hs | 6 ++++-- 2 files changed, 17 insertions(+), 8 deletions(-) diff --git a/Annex/NumCopies.hs b/Annex/NumCopies.hs index 6c069c7632..7874fb0e9a 100644 --- a/Annex/NumCopies.hs +++ b/Annex/NumCopies.hs @@ -26,6 +26,7 @@ import Logs.NumCopies import Logs.Trust import Annex.CheckAttr import qualified Remote +import qualified Types.Remote as Remote import Annex.UUID import Annex.Content @@ -122,12 +123,18 @@ verifyEnoughCopiesToDrop nolocmsg key need skip preverified tocheck dropaction n case p of Right proof -> dropaction proof Left stillhave -> helper bad missing stillhave (r:rs) - | otherwise = do - haskey <- Remote.hasKey r key - case haskey of - Right True -> helper bad missing (mkVerifiedCopy RecentlyVerifiedCopy r : have) rs - Left _ -> helper (r:bad) missing have rs - Right False -> helper bad (Remote.uuid r:missing) have rs + | otherwise = case Remote.lockContent r of + Nothing -> fallback + Just lockcontent -> lockcontent key $ \v -> case v of + Nothing -> fallback + Just vc -> helper bad missing (vc : have) rs + where + fallback = do + haskey <- Remote.hasKey r key + case haskey of + Right True -> helper bad missing (mkVerifiedCopy RecentlyVerifiedCopy r : have) rs + Left _ -> helper (r:bad) missing have rs + Right False -> helper bad (Remote.uuid r:missing) have rs notEnoughCopies :: Key -> NumCopies -> [VerifiedCopy] -> [UUID] -> [Remote] -> String -> Annex () notEnoughCopies key need have skip bad nolocmsg = do diff --git a/Types/Remote.hs b/Types/Remote.hs index 9e5f9f735a..511a85afab 100644 --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -30,6 +30,7 @@ import Types.GitConfig import Types.Availability import Types.Creds import Types.UrlContents +import Types.NumCopies import Config.Cost import Utility.Metered import Git.Types @@ -77,9 +78,10 @@ data RemoteA a = Remote { -- Removes a key's contents (succeeds if the contents are not present) removeKey :: Key -> a Bool, -- Uses locking to prevent removal of a key's contents, - -- and runs the passed action while it's locked. + -- thus producing a VerifiedCopy. + -- The action must be run whether or not the locking succeeds. -- This is optional; remotes do not have to support locking. - lockContent :: forall r. Maybe (Key -> a r -> a r), + lockContent :: forall r. Maybe (Key -> (Maybe VerifiedCopy -> a r) -> a r), -- Checks if a key is present in the remote. -- Throws an exception if the remote cannot be accessed. checkPresent :: Key -> a Bool, From 4c6095b6f5b4933d11839f434f6abac760dfc66c Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 9 Oct 2015 13:07:03 -0400 Subject: [PATCH 17/30] content locking during drop working for local git remotes Only ssh remotes lack locking now --- Annex/NumCopies.hs | 38 +++++++++++++++++++++++++++++++++++--- Remote/Git.hs | 13 ++++++++++++- Types/NumCopies.hs | 2 +- Types/Remote.hs | 7 ++++--- 4 files changed, 52 insertions(+), 8 deletions(-) diff --git a/Annex/NumCopies.hs b/Annex/NumCopies.hs index 7874fb0e9a..be1db4be80 100644 --- a/Annex/NumCopies.hs +++ b/Annex/NumCopies.hs @@ -5,6 +5,8 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-} + module Annex.NumCopies ( module Types.NumCopies, module Logs.NumCopies, @@ -30,6 +32,10 @@ import qualified Types.Remote as Remote import Annex.UUID import Annex.Content +import Control.Exception +import qualified Control.Monad.Catch as M +import Data.Typeable + defaultNumCopies :: NumCopies defaultNumCopies = NumCopies 1 @@ -124,10 +130,31 @@ verifyEnoughCopiesToDrop nolocmsg key need skip preverified tocheck dropaction n Right proof -> dropaction proof Left stillhave -> helper bad missing stillhave (r:rs) | otherwise = case Remote.lockContent r of + Just lockcontent -> do + -- The remote's lockContent will throw + -- an exception if it is unable to lock, + -- in which case the fallback should be + -- run. + -- + -- On the other hand, the callback passed + -- to the lockContent could itself throw an + -- exception (ie, the eventual drop + -- action fails), and in this case we don't + -- want to use the fallback since part + -- of the drop action may have already been + -- performed. + -- + -- Differentiate between these two sorts + -- of exceptions by using DropException. + let a = lockcontent key $ \vc -> + helper bad missing (vc : have) rs + `catchNonAsync` (throw . DropException) + a `M.catches` + [ M.Handler (\ (e :: AsyncException) -> throwM e) + , M.Handler (\ (DropException e') -> throwM e') + , M.Handler (\ (_e :: SomeException) -> fallback) + ] Nothing -> fallback - Just lockcontent -> lockcontent key $ \v -> case v of - Nothing -> fallback - Just vc -> helper bad missing (vc : have) rs where fallback = do haskey <- Remote.hasKey r key @@ -136,6 +163,11 @@ verifyEnoughCopiesToDrop nolocmsg key need skip preverified tocheck dropaction n Left _ -> helper (r:bad) missing have rs Right False -> helper bad (Remote.uuid r:missing) have rs +data DropException = DropException SomeException + deriving (Typeable, Show) + +instance Exception DropException + notEnoughCopies :: Key -> NumCopies -> [VerifiedCopy] -> [UUID] -> [Remote] -> String -> Annex () notEnoughCopies key need have skip bad nolocmsg = do showNote "unsafe" diff --git a/Remote/Git.hs b/Remote/Git.hs index 725b302b84..9fa7158e5e 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -53,6 +53,7 @@ import Annex.Path import Creds import Annex.CatFile import Messages.Progress +import Types.NumCopies import Control.Concurrent import Control.Concurrent.MSampleVar @@ -142,7 +143,7 @@ gen r u c gc , retrieveKeyFile = copyFromRemote new , retrieveKeyFileCheap = copyFromRemoteCheap new , removeKey = dropKey new - , lockContent = Nothing + , lockContent = Just (lockKey new) , checkPresent = inAnnex new , checkPresentCheap = repoCheap r , whereisKey = Nothing @@ -359,6 +360,16 @@ dropKey r key | Git.repoIsHttp (repo r) = error "dropping from http remote not supported" | otherwise = commitOnCleanup r $ Ssh.dropKey (repo r) key +lockKey :: Remote -> Key -> (VerifiedCopy -> Annex r) -> Annex r +lockKey r key a + | not $ Git.repoIsUrl (repo r) = + guardUsable (repo r) cantlock $ + onLocal r $ Annex.Content.lockContentShared key a + | Git.repoIsHttp (repo r) = cantlock + | otherwise = error "TODO" + where + cantlock = error "can't lock content" + {- Tries to copy a key's content from a remote's annex to a file. -} copyFromRemote :: Remote -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification) copyFromRemote r key file dest p = parallelMetered (Just p) key file $ diff --git a/Types/NumCopies.hs b/Types/NumCopies.hs index 23df6610a2..476c33058e 100644 --- a/Types/NumCopies.hs +++ b/Types/NumCopies.hs @@ -1,6 +1,6 @@ {- git-annex numcopies types - - - Copyright 2014 Joey Hess + - Copyright 2014-2015 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} diff --git a/Types/Remote.hs b/Types/Remote.hs index 511a85afab..a393241634 100644 --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -78,10 +78,11 @@ data RemoteA a = Remote { -- Removes a key's contents (succeeds if the contents are not present) removeKey :: Key -> a Bool, -- Uses locking to prevent removal of a key's contents, - -- thus producing a VerifiedCopy. - -- The action must be run whether or not the locking succeeds. + -- thus producing a VerifiedCopy, which is passed to the callback. + -- If unable to lock, does not run the callback, and throws an + -- error. -- This is optional; remotes do not have to support locking. - lockContent :: forall r. Maybe (Key -> (Maybe VerifiedCopy -> a r) -> a r), + lockContent :: forall r. Maybe (Key -> (VerifiedCopy -> a r) -> a r), -- Checks if a key is present in the remote. -- Throws an exception if the remote cannot be accessed. checkPresent :: Key -> a Bool, From 865dd11dbf0441905739f92ecc4758d1b982ca2a Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 9 Oct 2015 13:35:28 -0400 Subject: [PATCH 18/30] fix lockKey to run callback in original Annex monad, not local remote's --- Annex.hs | 8 ++++++++ Remote/Git.hs | 11 ++++++++--- 2 files changed, 16 insertions(+), 3 deletions(-) diff --git a/Annex.hs b/Annex.hs index 78a6bf3699..d6834e24a6 100644 --- a/Annex.hs +++ b/Annex.hs @@ -13,6 +13,7 @@ module Annex ( new, run, eval, + makeRunner, getState, changeState, withState, @@ -203,6 +204,13 @@ eval s a = do mvar <- newMVar s runReaderT (runAnnex a) mvar +{- Makes a runner action, that allows diving into IO and from inside + - the IO action, running an Annex action. -} +makeRunner :: Annex (Annex a -> IO a) +makeRunner = do + mvar <- ask + return $ \a -> runReaderT (runAnnex a) mvar + getState :: (AnnexState -> v) -> Annex v getState selector = do mvar <- ask diff --git a/Remote/Git.hs b/Remote/Git.hs index 9fa7158e5e..5c429c93c9 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -361,10 +361,15 @@ dropKey r key | otherwise = commitOnCleanup r $ Ssh.dropKey (repo r) key lockKey :: Remote -> Key -> (VerifiedCopy -> Annex r) -> Annex r -lockKey r key a +lockKey r key callback | not $ Git.repoIsUrl (repo r) = - guardUsable (repo r) cantlock $ - onLocal r $ Annex.Content.lockContentShared key a + guardUsable (repo r) cantlock $ do + inorigrepo <- Annex.makeRunner + -- Lock content from perspective of remote, + -- and then run the callback in the original + -- annex monad, not the remote's. + onLocal r $ Annex.Content.lockContentShared key $ + liftIO . inorigrepo . callback | Git.repoIsHttp (repo r) = cantlock | otherwise = error "TODO" where From a5e74e9e64a8389750e73b3086da75b0d4f4d42d Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 9 Oct 2015 13:47:19 -0400 Subject: [PATCH 19/30] display drop safety proofs in debug mode --- Command/Drop.hs | 28 +++++++++++++++++++++++----- Types/NumCopies.hs | 3 ++- 2 files changed, 25 insertions(+), 6 deletions(-) diff --git a/Command/Drop.hs b/Command/Drop.hs index fa8ac45ad1..43dc51d740 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -20,6 +20,9 @@ import Annex.Content import Annex.Wanted import Annex.Notification +import Utility.ThreadScheduler + +import System.Log.Logger (debugM) import qualified Data.Set as S cmd :: Command @@ -100,7 +103,12 @@ performLocal key afile numcopies preverified = lockContentExclusive key $ \conte let tocheck = Remote.remotesWithoutUUID remotes (map toUUID preverified'++untrusteduuids) u <- getUUID doDrop u key afile numcopies [] preverified' tocheck - ( do + ( \proof -> do + liftIO $ debugM "drop" $ unwords + [ "Dropping from here" + , "proof: " + , show proof + ] removeAnnex contentlock notifyDrop afile True next $ cleanupLocal key @@ -122,7 +130,15 @@ performRemote key afile numcopies remote = do let tocheck = filter (/= remote) $ Remote.remotesWithoutUUID remotes (trusted++untrusteduuids) doDrop uuid key afile numcopies [uuid] preverified tocheck - ( do + ( \proof -> do + liftIO $ debugM "drop" $ unwords + [ "Dropping from remote" + , show remote + , "proof: " + , show proof + ] + liftIO $ print "waiting to drop.." + liftIO $ threadDelaySeconds (Seconds 10) ok <- Remote.removeKey remote key next $ cleanupRemote key remote ok , stop @@ -149,13 +165,15 @@ cleanupRemote key remote ok = do - - --force overrides and always allows dropping. -} -doDrop :: UUID -> Key -> AssociatedFile -> NumCopies -> [UUID] -> [VerifiedCopy] -> [Remote] -> (CommandPerform, CommandPerform) -> CommandPerform +doDrop :: UUID -> Key -> AssociatedFile -> NumCopies -> [UUID] -> [VerifiedCopy] -> [Remote] -> (Maybe SafeDropProof -> CommandPerform, CommandPerform) -> CommandPerform doDrop dropfrom key afile numcopies skip preverified check (dropaction, nodropaction) = ifM (Annex.getState Annex.force) - ( dropaction + ( dropaction Nothing , ifM (checkRequiredContent dropfrom key afile) ( verifyEnoughCopiesToDrop nolocmsg key numcopies - skip preverified check (const dropaction) (forcehint nodropaction) + skip preverified check + (dropaction . Just) + (forcehint nodropaction) , stop ) ) diff --git a/Types/NumCopies.hs b/Types/NumCopies.hs index 476c33058e..17080cf7c5 100644 --- a/Types/NumCopies.hs +++ b/Types/NumCopies.hs @@ -31,7 +31,7 @@ import Control.Monad.IO.Class (MonadIO) import Control.Monad newtype NumCopies = NumCopies Int - deriving (Ord, Eq) + deriving (Ord, Eq, Show) fromNumCopies :: NumCopies -> Int fromNumCopies (NumCopies n) = n @@ -138,6 +138,7 @@ fullVerification (RecentlyVerifiedCopy _) = False -- A proof that it's currently safe to drop an object. data SafeDropProof = SafeDropProof NumCopies [VerifiedCopy] + deriving (Show) -- Make sure that none of the VerifiedCopies have become invalidated -- before constructing proof. From 45e1a7c361b2f4e0d99a745c76e25d29283714f0 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 9 Oct 2015 14:57:32 -0400 Subject: [PATCH 20/30] verify local copy of content with locking --- Annex/NumCopies.hs | 114 ++++++++++++++++++++++++++------------------- Command/Drop.hs | 27 +++++------ Command/Import.hs | 5 +- Remote.hs | 33 ++++++------- 4 files changed, 93 insertions(+), 86 deletions(-) diff --git a/Annex/NumCopies.hs b/Annex/NumCopies.hs index be1db4be80..f6ce05230d 100644 --- a/Annex/NumCopies.hs +++ b/Annex/NumCopies.hs @@ -18,7 +18,8 @@ module Annex.NumCopies ( numCopiesCheck, numCopiesCheck', verifyEnoughCopiesToDrop, - knownCopies, + verifiableCopies, + UnVerifiedCopy, ) where import Common.Annex @@ -29,8 +30,8 @@ import Logs.Trust import Annex.CheckAttr import qualified Remote import qualified Types.Remote as Remote -import Annex.UUID import Annex.Content +import Annex.UUID import Control.Exception import qualified Control.Monad.Catch as M @@ -99,6 +100,9 @@ numCopiesCheck' file vs have = do NumCopies needed <- getFileNumCopies file return $ length have `vs` needed +data UnVerifiedCopy = UnVerifiedRemote Remote | UnVerifiedHere + deriving (Ord, Eq) + {- Verifies that enough copies of a key exist amoung the listed remotes, - running an action with a proof if so, and printing an informative - message if not. @@ -109,7 +113,7 @@ verifyEnoughCopiesToDrop -> NumCopies -> [UUID] -- repos to skip considering (generally untrusted remotes) -> [VerifiedCopy] -- copies already verified to exist - -> [Remote] -- remotes to check to see if they have copies + -> [UnVerifiedCopy] -- places to check to see if they have copies -> (SafeDropProof -> Annex a) -- action to perform to drop -> Annex a -- action to perform when unable to drop -> Annex a @@ -123,45 +127,45 @@ verifyEnoughCopiesToDrop nolocmsg key need skip preverified tocheck dropaction n Left stillhave -> do notEnoughCopies key need stillhave (skip++missing) bad nolocmsg nodropaction - helper bad missing have (r:rs) + helper bad missing have (c:cs) | isSafeDrop need have = do p <- liftIO $ mkSafeDropProof need have case p of Right proof -> dropaction proof - Left stillhave -> helper bad missing stillhave (r:rs) - | otherwise = case Remote.lockContent r of - Just lockcontent -> do - -- The remote's lockContent will throw - -- an exception if it is unable to lock, - -- in which case the fallback should be - -- run. - -- - -- On the other hand, the callback passed - -- to the lockContent could itself throw an - -- exception (ie, the eventual drop - -- action fails), and in this case we don't - -- want to use the fallback since part - -- of the drop action may have already been - -- performed. - -- - -- Differentiate between these two sorts - -- of exceptions by using DropException. - let a = lockcontent key $ \vc -> - helper bad missing (vc : have) rs - `catchNonAsync` (throw . DropException) - a `M.catches` - [ M.Handler (\ (e :: AsyncException) -> throwM e) - , M.Handler (\ (DropException e') -> throwM e') - , M.Handler (\ (_e :: SomeException) -> fallback) - ] - Nothing -> fallback - where - fallback = do + Left stillhave -> helper bad missing stillhave (c:cs) + | otherwise = case c of + UnVerifiedHere -> lockContentShared key contverified + UnVerifiedRemote r -> checkremote r contverified $ do haskey <- Remote.hasKey r key case haskey of - Right True -> helper bad missing (mkVerifiedCopy RecentlyVerifiedCopy r : have) rs - Left _ -> helper (r:bad) missing have rs - Right False -> helper bad (Remote.uuid r:missing) have rs + Right True -> helper bad missing (mkVerifiedCopy RecentlyVerifiedCopy r : have) cs + Left _ -> helper (r:bad) missing have cs + Right False -> helper bad (Remote.uuid r:missing) have cs + where + contverified vc = helper bad missing (vc : have) cs + + checkremote r cont fallback = case Remote.lockContent r of + Just lockcontent -> do + -- The remote's lockContent will throw an exception + -- when it is unable to lock, in which case the + -- fallback should be run. + -- + -- On the other hand, the continuation could itself + -- throw an exception (ie, the eventual drop action + -- fails), and in this case we don't want to run the + -- fallback since part of the drop action may have + -- already been performed. + -- + -- Differentiate between these two sorts + -- of exceptions by using DropException. + let a = lockcontent key $ \v -> + cont v `catchNonAsync` (throw . DropException) + a `M.catches` + [ M.Handler (\ (e :: AsyncException) -> throwM e) + , M.Handler (\ (DropException e') -> throwM e') + , M.Handler (\ (_e :: SomeException) -> fallback) + ] + Nothing -> fallback data DropException = DropException SomeException deriving (Typeable, Show) @@ -178,19 +182,31 @@ notEnoughCopies key need have skip bad nolocmsg = do Remote.showTriedRemotes bad Remote.showLocations True key (map toUUID have++skip) nolocmsg -{- Cost ordered lists of remotes that the location log indicates - - may have a key. +{- Finds locations of a key that can be used to get VerifiedCopies, + - in order to allow dropping the key. - - - Also returns a list of UUIDs that are trusted to have the key - - (some may not have configured remotes). If the current repository - - currently has the key, and is not untrusted, it is included in this list. + - Provide a list of UUIDs that the key is being dropped from. + - The returned lists will exclude any of those UUIDs. + - + - The return lists also exclude any repositories that are untrusted, + - since those should not be used for verification. + - + - The UnVerifiedCopy list is cost ordered. + - The VerifiedCopy list contains repositories that are trusted to + - contain the key. -} -knownCopies :: Key -> Annex ([Remote], [UUID]) -knownCopies key = do - (remotes, trusteduuids) <- Remote.keyPossibilitiesTrusted key +verifiableCopies :: Key -> [UUID] -> Annex ([UnVerifiedCopy], [VerifiedCopy]) +verifiableCopies key exclude = do + locs <- Remote.keyLocations key + (remotes, trusteduuids) <- Remote.remoteLocations locs + =<< trustGet Trusted + untrusteduuids <- trustGet UnTrusted + let exclude' = exclude ++ untrusteduuids + let remotes' = Remote.remotesWithoutUUID remotes (exclude' ++ trusteduuids) + let verified = map (mkVerifiedCopy TrustedCopy) $ + filter (`notElem` exclude') trusteduuids u <- getUUID - trusteduuids' <- ifM (inAnnex key <&&> (<= SemiTrusted) <$> lookupTrust u) - ( pure (u:trusteduuids) - , pure trusteduuids - ) - return (remotes, trusteduuids') + let herec = if u `elem` locs && u `notElem` exclude' + then [UnVerifiedHere] + else [] + return (herec ++ map UnVerifiedRemote remotes', verified) diff --git a/Command/Drop.hs b/Command/Drop.hs index 43dc51d740..a2bca22044 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -97,12 +97,9 @@ startRemote afile numcopies key remote = do -- sees the key is present on the other. performLocal :: Key -> AssociatedFile -> NumCopies -> [VerifiedCopy] -> CommandPerform performLocal key afile numcopies preverified = lockContentExclusive key $ \contentlock -> do - (remotes, trusteduuids) <- Remote.keyPossibilitiesTrusted key - let preverified' = preverified ++ map (mkVerifiedCopy TrustedCopy) trusteduuids - untrusteduuids <- trustGet UnTrusted - let tocheck = Remote.remotesWithoutUUID remotes (map toUUID preverified'++untrusteduuids) u <- getUUID - doDrop u key afile numcopies [] preverified' tocheck + (tocheck, verified) <- verifiableCopies key [u] + doDrop u key afile numcopies [] (preverified ++ verified) tocheck ( \proof -> do liftIO $ debugM "drop" $ unwords [ "Dropping from here" @@ -123,13 +120,8 @@ performRemote key afile numcopies remote = do -- places assumed to have the key, and places to check. -- When the local repo has the key, that's one additional copy, -- as long as the local repo is not untrusted. - (remotes, trusteduuids) <- knownCopies key - let trusted = filter (/= uuid) trusteduuids - let preverified = map (mkVerifiedCopy TrustedCopy) trusted - untrusteduuids <- trustGet UnTrusted - let tocheck = filter (/= remote) $ - Remote.remotesWithoutUUID remotes (trusted++untrusteduuids) - doDrop uuid key afile numcopies [uuid] preverified tocheck + (tocheck, verified) <- verifiableCopies key [uuid] + doDrop uuid key afile numcopies [uuid] verified tocheck ( \proof -> do liftIO $ debugM "drop" $ unwords [ "Dropping from remote" @@ -165,7 +157,16 @@ cleanupRemote key remote ok = do - - --force overrides and always allows dropping. -} -doDrop :: UUID -> Key -> AssociatedFile -> NumCopies -> [UUID] -> [VerifiedCopy] -> [Remote] -> (Maybe SafeDropProof -> CommandPerform, CommandPerform) -> CommandPerform +doDrop + :: UUID + -> Key + -> AssociatedFile + -> NumCopies + -> [UUID] + -> [VerifiedCopy] + -> [UnVerifiedCopy] + -> (Maybe SafeDropProof -> CommandPerform, CommandPerform) + -> CommandPerform doDrop dropfrom key afile numcopies skip preverified check (dropaction, nodropaction) = ifM (Annex.getState Annex.force) ( dropaction Nothing diff --git a/Command/Import.hs b/Command/Import.hs index f486da7c5c..3133393718 100644 --- a/Command/Import.hs +++ b/Command/Import.hs @@ -140,9 +140,6 @@ verifyExisting key destfile (yes, no) = do -- imported to, if it were imported. need <- getFileNumCopies destfile - (remotes, trusteduuids) <- knownCopies key - untrusteduuids <- trustGet UnTrusted - let tocheck = Remote.remotesWithoutUUID remotes (trusteduuids++untrusteduuids) - let preverified = map (mkVerifiedCopy TrustedCopy) trusteduuids + (tocheck, preverified) <- verifiableCopies key [] verifyEnoughCopiesToDrop [] key need [] preverified tocheck (const yes) no diff --git a/Remote.hs b/Remote.hs index 57a22f36b0..c38262a33c 100644 --- a/Remote.hs +++ b/Remote.hs @@ -40,7 +40,7 @@ module Remote ( remotesWithoutUUID, keyLocations, keyPossibilities, - keyPossibilitiesTrusted, + remoteLocations, nameToUUID, nameToUUID', showTriedRemotes, @@ -260,33 +260,26 @@ keyLocations key = trustExclude DeadTrusted =<< loggedLocations key - may have a key. -} keyPossibilities :: Key -> Annex [Remote] -keyPossibilities key = fst <$> keyPossibilities' key [] - -{- Cost ordered lists of remotes that the location log indicates - - may have a key. - - - - Also returns a list of UUIDs that are trusted to have the key - - (some may not have configured remotes). - -} -keyPossibilitiesTrusted :: Key -> Annex ([Remote], [UUID]) -keyPossibilitiesTrusted key = keyPossibilities' key =<< trustGet Trusted - -keyPossibilities' :: Key -> [UUID] -> Annex ([Remote], [UUID]) -keyPossibilities' key trusted = do +keyPossibilities key = do u <- getUUID - -- uuids of all remotes that are recorded to have the key - validuuids <- filter (/= u) <$> keyLocations key + locations <- filter (/= u) <$> keyLocations key + fst <$> remoteLocations locations [] - -- note that validuuids is assumed to not have dups - let validtrusteduuids = validuuids `intersect` trusted +{- Given a list of locations of a key, and a list of all + - trusted repositories, generates a cost-ordered list of + - remotes that contain the key, and a list of trusted locations of the key. + -} +remoteLocations :: [UUID] -> [UUID] -> Annex ([Remote], [UUID]) +remoteLocations locations trusted = do + let validtrustedlocations = nub locations `intersect` trusted -- remotes that match uuids that have the key allremotes <- filter (not . remoteAnnexIgnore . gitconfig) <$> remoteList - let validremotes = remotesWithUUID allremotes validuuids + let validremotes = remotesWithUUID allremotes locations - return (sortBy (comparing cost) validremotes, validtrusteduuids) + return (sortBy (comparing cost) validremotes, validtrustedlocations) {- Displays known locations of a key. -} showLocations :: Bool -> Key -> [UUID] -> String -> Annex () From b021321aae6639a21a4b125026f0ebdc5bdf56df Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 9 Oct 2015 15:01:16 -0400 Subject: [PATCH 21/30] rename constructor --- Annex/Content.hs | 2 +- Command/Import.hs | 2 -- Types/NumCopies.hs | 14 +++++++------- 3 files changed, 8 insertions(+), 10 deletions(-) diff --git a/Annex/Content.hs b/Annex/Content.hs index da29aa4ed2..40c78fd340 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -183,7 +183,7 @@ contentLockFile key = Just <$> calcRepo (gitAnnexContentLock key) lockContentShared :: Key -> (VerifiedCopy -> Annex a) -> Annex a lockContentShared key a = lockContentUsing lock key $ do u <- getUUID - withVerifiedCopy VerifiedCopyLock u a + withVerifiedCopy LockedCopy u a where #ifndef mingw32_HOST_OS lock contentfile Nothing = liftIO $ tryLockShared Nothing contentfile diff --git a/Command/Import.hs b/Command/Import.hs index 3133393718..5ac050351c 100644 --- a/Command/Import.hs +++ b/Command/Import.hs @@ -19,8 +19,6 @@ import Types.KeySource import Types.Key import Annex.CheckIgnore import Annex.NumCopies -import Types.TrustLevel -import Logs.Trust cmd :: Command cmd = withGlobalOptions fileMatchingOptions $ notBareRepo $ diff --git a/Types/NumCopies.hs b/Types/NumCopies.hs index 17080cf7c5..bbd1b38313 100644 --- a/Types/NumCopies.hs +++ b/Types/NumCopies.hs @@ -49,7 +49,7 @@ data VerifiedCopy - Until its associated action is called to unlock it, - the copy is locked in the repository and is guaranteed - not to be dropped by any git-annex process. -} - | VerifiedCopyLock V + | LockedCopy V deriving (Show) data V = V @@ -67,7 +67,7 @@ instance ToUUID VerifiedCopy where toV :: VerifiedCopy -> V toV (TrustedCopy v) = v toV (RecentlyVerifiedCopy v) = v -toV (VerifiedCopyLock v) = v +toV (LockedCopy v) = v -- Checks that it's still valid. checkVerifiedCopy :: VerifiedCopy -> IO Bool @@ -77,8 +77,8 @@ invalidateVerifiedCopy :: VerifiedCopy -> IO () invalidateVerifiedCopy = _invalidateVerifiedCopy . toV strongestVerifiedCopy :: VerifiedCopy -> VerifiedCopy -> VerifiedCopy -strongestVerifiedCopy a@(VerifiedCopyLock _) _ = a -strongestVerifiedCopy _ b@(VerifiedCopyLock _) = b +strongestVerifiedCopy a@(LockedCopy _) _ = a +strongestVerifiedCopy _ b@(LockedCopy _) = b strongestVerifiedCopy a@(TrustedCopy _) _ = a strongestVerifiedCopy _ b@(TrustedCopy _) = b strongestVerifiedCopy a@(RecentlyVerifiedCopy _) _ = a @@ -116,8 +116,8 @@ withVerifiedCopy mk u = bracketIO setup cleanup {- Check whether enough verification has been done of copies to allow - dropping content safely. - - - Unless numcopies is 0, at least one VerifiedCopyLock or TrustedCopy - - is required. A VerifiedCopyLock prevents races between concurrent + - Unless numcopies is 0, at least one LockedCopy or TrustedCopy + - is required. A LockedCopy prevents races between concurrent - drops from dropping the last copy, no matter what. - - The other N-1 copies can be less strong verifications, like @@ -132,7 +132,7 @@ isSafeDrop (NumCopies n) l | otherwise = length (deDupVerifiedCopies l) >= n && any fullVerification l fullVerification :: VerifiedCopy -> Bool -fullVerification (VerifiedCopyLock _) = True +fullVerification (LockedCopy _) = True fullVerification (TrustedCopy _) = True fullVerification (RecentlyVerifiedCopy _) = False From 1043880432f2f956f46aef4155dd4f900b2dad04 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 9 Oct 2015 15:14:25 -0400 Subject: [PATCH 22/30] improve message when drop failed due to no locked copy --- Annex/NumCopies.hs | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/Annex/NumCopies.hs b/Annex/NumCopies.hs index f6ce05230d..b51d3815b2 100644 --- a/Annex/NumCopies.hs +++ b/Annex/NumCopies.hs @@ -175,10 +175,14 @@ instance Exception DropException notEnoughCopies :: Key -> NumCopies -> [VerifiedCopy] -> [UUID] -> [Remote] -> String -> Annex () notEnoughCopies key need have skip bad nolocmsg = do showNote "unsafe" - showLongNote $ - "Could only verify the existence of " ++ - show (length have) ++ " out of " ++ show (fromNumCopies need) ++ - " necessary copies" + if length have < fromNumCopies need + then showLongNote $ + "Could only verify the existence of " ++ + show (length have) ++ " out of " ++ show (fromNumCopies need) ++ + " necessary copies" + else do + showLongNote "Unable to lock down 1 copy of file that is required to safely drop it." + showLongNote "(This could have happened because of a concurrent drop, or because a remote has too old a version of git-annex-shell installed.)" Remote.showTriedRemotes bad Remote.showLocations True key (map toUUID have++skip) nolocmsg From 6a720457070305cd82a34ffe52c7a3379591b24f Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 9 Oct 2015 15:48:02 -0400 Subject: [PATCH 23/30] fix local dropping to not require extra locking of copies, but only that the local copy be locked for removal --- Annex/Content.hs | 15 ++++++------ Annex/NumCopies.hs | 13 ++++++----- Assistant/Unused.hs | 2 +- Assistant/Upgrade.hs | 2 +- Command/Drop.hs | 16 ++++++------- Command/DropKey.hs | 2 +- Command/Import.hs | 2 +- Command/Move.hs | 2 +- Command/TestRemote.hs | 10 ++++---- Command/Uninit.hs | 2 +- Remote/Git.hs | 2 +- Types/NumCopies.hs | 54 ++++++++++++++++++++++++++++++++----------- 12 files changed, 73 insertions(+), 49 deletions(-) diff --git a/Annex/Content.hs b/Annex/Content.hs index 40c78fd340..0dc47d9e29 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -13,7 +13,8 @@ module Annex.Content ( inAnnexSafe, inAnnexCheck, lockContentShared, - lockContentExclusive, + lockContentForRemoval, + ContentRemovalLock, getViaTmp, getViaTmp', checkDiskSpaceToGet, @@ -192,14 +193,12 @@ lockContentShared key a = lockContentUsing lock key $ do lock = winLocker lockShared #endif -newtype ContentLockExclusive = ContentLockExclusive Key - {- Exclusively locks content, while performing an action that - might remove it. -} -lockContentExclusive :: Key -> (ContentLockExclusive -> Annex a) -> Annex a -lockContentExclusive key a = lockContentUsing lock key $ - a (ContentLockExclusive key) +lockContentForRemoval :: Key -> (ContentRemovalLock -> Annex a) -> Annex a +lockContentForRemoval key a = lockContentUsing lock key $ + a (ContentRemovalLock key) where #ifndef mingw32_HOST_OS {- Since content files are stored with the write bit disabled, have @@ -547,8 +546,8 @@ cleanObjectLoc key cleaner = do - In direct mode, deletes the associated files or files, and replaces - them with symlinks. -} -removeAnnex :: ContentLockExclusive -> Annex () -removeAnnex (ContentLockExclusive key) = withObjectLoc key remove removedirect +removeAnnex :: ContentRemovalLock -> Annex () +removeAnnex (ContentRemovalLock key) = withObjectLoc key remove removedirect where remove file = cleanObjectLoc key $ do secureErase file diff --git a/Annex/NumCopies.hs b/Annex/NumCopies.hs index b51d3815b2..2ddb460fd8 100644 --- a/Annex/NumCopies.hs +++ b/Annex/NumCopies.hs @@ -104,12 +104,13 @@ data UnVerifiedCopy = UnVerifiedRemote Remote | UnVerifiedHere deriving (Ord, Eq) {- Verifies that enough copies of a key exist amoung the listed remotes, - - running an action with a proof if so, and printing an informative - - message if not. + - to safely drop it, running an action with a proof if so, and + - printing an informative message if not. -} verifyEnoughCopiesToDrop :: String -- message to print when there are no known locations -> Key + -> Maybe ContentRemovalLock -> NumCopies -> [UUID] -- repos to skip considering (generally untrusted remotes) -> [VerifiedCopy] -- copies already verified to exist @@ -117,19 +118,19 @@ verifyEnoughCopiesToDrop -> (SafeDropProof -> Annex a) -- action to perform to drop -> Annex a -- action to perform when unable to drop -> Annex a -verifyEnoughCopiesToDrop nolocmsg key need skip preverified tocheck dropaction nodropaction = +verifyEnoughCopiesToDrop nolocmsg key removallock need skip preverified tocheck dropaction nodropaction = helper [] [] preverified (nub tocheck) where helper bad missing have [] = do - p <- liftIO $ mkSafeDropProof need have + p <- liftIO $ mkSafeDropProof need have removallock case p of Right proof -> dropaction proof Left stillhave -> do notEnoughCopies key need stillhave (skip++missing) bad nolocmsg nodropaction helper bad missing have (c:cs) - | isSafeDrop need have = do - p <- liftIO $ mkSafeDropProof need have + | isSafeDrop need have removallock = do + p <- liftIO $ mkSafeDropProof need have removallock case p of Right proof -> dropaction proof Left stillhave -> helper bad missing stillhave (c:cs) diff --git a/Assistant/Unused.hs b/Assistant/Unused.hs index c71604679d..55a04c597a 100644 --- a/Assistant/Unused.hs +++ b/Assistant/Unused.hs @@ -77,7 +77,7 @@ expireUnused duration = do forM_ oldkeys $ \k -> do debug ["removing old unused key", key2file k] liftAnnex $ do - lockContentExclusive k removeAnnex + lockContentForRemoval k removeAnnex logStatus k InfoMissing where boundry = durationToPOSIXTime <$> duration diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs index 88ef5bed15..177603338f 100644 --- a/Assistant/Upgrade.hs +++ b/Assistant/Upgrade.hs @@ -97,7 +97,7 @@ startDistributionDownload d = go =<< liftIO . newVersionLocation d =<< liftIO ol , transferKey = k } cleanup = liftAnnex $ do - lockContentExclusive k removeAnnex + lockContentForRemoval k removeAnnex setUrlMissing webUUID k u logStatus k InfoMissing diff --git a/Command/Drop.hs b/Command/Drop.hs index a2bca22044..d14cdad18e 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -91,15 +91,11 @@ startRemote afile numcopies key remote = do showStart' ("drop " ++ Remote.name remote) key afile next $ performRemote key afile numcopies remote --- Note that lockContentExclusive is called before checking if the key is --- present on enough remotes to allow removal. This avoids a scenario where two --- or more remotes are trying to remove a key at the same time, and each --- sees the key is present on the other. performLocal :: Key -> AssociatedFile -> NumCopies -> [VerifiedCopy] -> CommandPerform -performLocal key afile numcopies preverified = lockContentExclusive key $ \contentlock -> do +performLocal key afile numcopies preverified = lockContentForRemoval key $ \contentlock -> do u <- getUUID (tocheck, verified) <- verifiableCopies key [u] - doDrop u key afile numcopies [] (preverified ++ verified) tocheck + doDrop u (Just contentlock) key afile numcopies [] (preverified ++ verified) tocheck ( \proof -> do liftIO $ debugM "drop" $ unwords [ "Dropping from here" @@ -121,7 +117,7 @@ performRemote key afile numcopies remote = do -- When the local repo has the key, that's one additional copy, -- as long as the local repo is not untrusted. (tocheck, verified) <- verifiableCopies key [uuid] - doDrop uuid key afile numcopies [uuid] verified tocheck + doDrop uuid Nothing key afile numcopies [uuid] verified tocheck ( \proof -> do liftIO $ debugM "drop" $ unwords [ "Dropping from remote" @@ -159,6 +155,7 @@ cleanupRemote key remote ok = do -} doDrop :: UUID + -> Maybe ContentRemovalLock -> Key -> AssociatedFile -> NumCopies @@ -167,11 +164,12 @@ doDrop -> [UnVerifiedCopy] -> (Maybe SafeDropProof -> CommandPerform, CommandPerform) -> CommandPerform -doDrop dropfrom key afile numcopies skip preverified check (dropaction, nodropaction) = +doDrop dropfrom contentlock key afile numcopies skip preverified check (dropaction, nodropaction) = ifM (Annex.getState Annex.force) ( dropaction Nothing , ifM (checkRequiredContent dropfrom key afile) - ( verifyEnoughCopiesToDrop nolocmsg key numcopies + ( verifyEnoughCopiesToDrop nolocmsg key + contentlock numcopies skip preverified check (dropaction . Just) (forcehint nodropaction) diff --git a/Command/DropKey.hs b/Command/DropKey.hs index cdb19cabb3..3dea4b4b79 100644 --- a/Command/DropKey.hs +++ b/Command/DropKey.hs @@ -31,7 +31,7 @@ start key = stopUnless (inAnnex key) $ do next $ perform key perform :: Key -> CommandPerform -perform key = lockContentExclusive key $ \contentlock -> do +perform key = lockContentForRemoval key $ \contentlock -> do removeAnnex contentlock next $ cleanup key diff --git a/Command/Import.hs b/Command/Import.hs index 5ac050351c..a96c080556 100644 --- a/Command/Import.hs +++ b/Command/Import.hs @@ -139,5 +139,5 @@ verifyExisting key destfile (yes, no) = do need <- getFileNumCopies destfile (tocheck, preverified) <- verifiableCopies key [] - verifyEnoughCopiesToDrop [] key need [] preverified tocheck + verifyEnoughCopiesToDrop [] key Nothing need [] preverified tocheck (const yes) no diff --git a/Command/Move.hs b/Command/Move.hs index 072c00663b..bd1b6dd927 100644 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -123,7 +123,7 @@ toPerform dest move key afile fastcheck isthere = finish where finish - | move = lockContentExclusive key $ \contentlock -> do + | move = lockContentForRemoval key $ \contentlock -> do removeAnnex contentlock next $ Command.Drop.cleanupLocal key | otherwise = next $ return True diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs index 3a44a1bde2..be1b9a3243 100644 --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -120,7 +120,7 @@ test st r k = , check "storeKey when already present" store , present True , check "retrieveKeyFile" $ do - lockContentExclusive k removeAnnex + lockContentForRemoval k removeAnnex get , check "fsck downloaded object" fsck , check "retrieveKeyFile resume from 33%" $ do @@ -130,20 +130,20 @@ test st r k = sz <- hFileSize h L.hGet h $ fromInteger $ sz `div` 3 liftIO $ L.writeFile tmp partial - lockContentExclusive k removeAnnex + lockContentForRemoval k removeAnnex get , check "fsck downloaded object" fsck , check "retrieveKeyFile resume from 0" $ do tmp <- prepTmp k liftIO $ writeFile tmp "" - lockContentExclusive k removeAnnex + lockContentForRemoval k removeAnnex get , check "fsck downloaded object" fsck , check "retrieveKeyFile resume from end" $ do loc <- Annex.calcRepo (gitAnnexLocation k) tmp <- prepTmp k void $ liftIO $ copyFileExternal CopyAllMetaData loc tmp - lockContentExclusive k removeAnnex + lockContentForRemoval k removeAnnex get , check "fsck downloaded object" fsck , check "removeKey when present" remove @@ -189,7 +189,7 @@ testUnavailable st r k = cleanup :: [Remote] -> [Key] -> Bool -> CommandCleanup cleanup rs ks ok = do forM_ rs $ \r -> forM_ ks (Remote.removeKey r) - forM_ ks $ \k -> lockContentExclusive k removeAnnex + forM_ ks $ \k -> lockContentForRemoval k removeAnnex return ok chunkSizes :: Int -> Bool -> [Int] diff --git a/Command/Uninit.hs b/Command/Uninit.hs index 38e0620025..cc237db5e9 100644 --- a/Command/Uninit.hs +++ b/Command/Uninit.hs @@ -105,7 +105,7 @@ removeUnannexed = go [] go c [] = return c go c (k:ks) = ifM (inAnnexCheck k $ liftIO . enoughlinks) ( do - lockContentExclusive k removeAnnex + lockContentForRemoval k removeAnnex go c ks , go (k:c) ks ) diff --git a/Remote/Git.hs b/Remote/Git.hs index 5c429c93c9..a6c4315ab4 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -352,7 +352,7 @@ dropKey r key commitOnCleanup r $ onLocal r $ do ensureInitialized whenM (Annex.Content.inAnnex key) $ do - Annex.Content.lockContentExclusive key + Annex.Content.lockContentForRemoval key Annex.Content.removeAnnex logStatus key InfoMissing Annex.Content.saveState True diff --git a/Types/NumCopies.hs b/Types/NumCopies.hs index bbd1b38313..60e0db5809 100644 --- a/Types/NumCopies.hs +++ b/Types/NumCopies.hs @@ -19,9 +19,11 @@ module Types.NumCopies ( isSafeDrop, SafeDropProof, mkSafeDropProof, + ContentRemovalLock(..), ) where import Types.UUID +import Types.Key import Utility.Exception (bracketIO) import qualified Data.Map as M @@ -36,6 +38,11 @@ newtype NumCopies = NumCopies Int fromNumCopies :: NumCopies -> Int fromNumCopies (NumCopies n) = n +-- Indicates that a key's content is exclusively +-- locked locally, pending removal. +newtype ContentRemovalLock = ContentRemovalLock Key + deriving (Show) + -- A verification that a copy of a key exists in a repository. data VerifiedCopy {- Represents a recent verification that a copy of an @@ -48,7 +55,7 @@ data VerifiedCopy {- The strongest proof of the existence of a copy. - Until its associated action is called to unlock it, - the copy is locked in the repository and is guaranteed - - not to be dropped by any git-annex process. -} + - not to be removed by any git-annex process. -} | LockedCopy V deriving (Show) @@ -116,20 +123,39 @@ withVerifiedCopy mk u = bracketIO setup cleanup {- Check whether enough verification has been done of copies to allow - dropping content safely. - - - Unless numcopies is 0, at least one LockedCopy or TrustedCopy - - is required. A LockedCopy prevents races between concurrent - - drops from dropping the last copy, no matter what. + - This is carefully balanced to prevent data loss when there are races + - between concurrent drops of the same content in different repos, + - without requiring impractical amounts of locking. + - + - In particular, concurrent drop races may cause the number of copies + - to fall below NumCopies, but it will never fall below 1. + -} +isSafeDrop :: NumCopies -> [VerifiedCopy] -> Maybe ContentRemovalLock -> Bool +{- When a ContentRemovalLock is provided, the content is being + - dropped from the local repo. That lock will prevent other git repos + - that are concurrently dropping from using the local copy as a VerifiedCopy. + - So, no additional locking is needed; all we need is verifications + - of any kind of N other copies of the content. -} +isSafeDrop (NumCopies n) l (Just (ContentRemovalLock _)) = + length (deDupVerifiedCopies l) >= n +{- Dropping from a remote repo. + - + - Unless numcopies is 0, at least one LockedCopy or TrustedCopy is required. + - A LockedCopy prevents races between concurrent drops from + - dropping the last copy, no matter what. - - The other N-1 copies can be less strong verifications, like - RecentlyVerifiedCopy. While those are subject to concurrent drop races, - and so could be dropped all at once, causing numcopies to be violated, - - this is the best that can be done without requiring all special remotes - - to support locking. + - this is the best that can be done without requiring that + - all special remotes support locking. -} -isSafeDrop :: NumCopies -> [VerifiedCopy] -> Bool -isSafeDrop (NumCopies n) l +isSafeDrop (NumCopies n) l Nothing | n == 0 = True - | otherwise = length (deDupVerifiedCopies l) >= n && any fullVerification l + | otherwise = and + [ length (deDupVerifiedCopies l) >= n + , any fullVerification l + ] fullVerification :: VerifiedCopy -> Bool fullVerification (LockedCopy _) = True @@ -137,14 +163,14 @@ fullVerification (TrustedCopy _) = True fullVerification (RecentlyVerifiedCopy _) = False -- A proof that it's currently safe to drop an object. -data SafeDropProof = SafeDropProof NumCopies [VerifiedCopy] +data SafeDropProof = SafeDropProof NumCopies [VerifiedCopy] (Maybe ContentRemovalLock) deriving (Show) -- Make sure that none of the VerifiedCopies have become invalidated -- before constructing proof. -mkSafeDropProof :: NumCopies -> [VerifiedCopy] -> IO (Either [VerifiedCopy] SafeDropProof) -mkSafeDropProof need have = do +mkSafeDropProof :: NumCopies -> [VerifiedCopy] -> Maybe ContentRemovalLock -> IO (Either [VerifiedCopy] SafeDropProof) +mkSafeDropProof need have removallock = do stillhave <- filterM checkVerifiedCopy have - return $ if isSafeDrop need stillhave - then Right (SafeDropProof need stillhave) + return $ if isSafeDrop need stillhave removallock + then Right (SafeDropProof need stillhave removallock) else Left stillhave From b944da832b0433f3014396b2c7a53f1bd31f7c59 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 9 Oct 2015 15:59:42 -0400 Subject: [PATCH 24/30] tests and verified that the bug is fixed, in all the cases I identified --- Command/Drop.hs | 6 +----- .../concurrent_drop--from_presence_checking_failures.mdwn | 7 +++++++ 2 files changed, 8 insertions(+), 5 deletions(-) diff --git a/Command/Drop.hs b/Command/Drop.hs index d14cdad18e..5bbaf11c6b 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -20,8 +20,6 @@ import Annex.Content import Annex.Wanted import Annex.Notification -import Utility.ThreadScheduler - import System.Log.Logger (debugM) import qualified Data.Set as S @@ -99,7 +97,7 @@ performLocal key afile numcopies preverified = lockContentForRemoval key $ \cont ( \proof -> do liftIO $ debugM "drop" $ unwords [ "Dropping from here" - , "proof: " + , "proof:" , show proof ] removeAnnex contentlock @@ -125,8 +123,6 @@ performRemote key afile numcopies remote = do , "proof: " , show proof ] - liftIO $ print "waiting to drop.." - liftIO $ threadDelaySeconds (Seconds 10) ok <- Remote.removeKey remote key next $ cleanupRemote key remote ok , stop diff --git a/doc/bugs/concurrent_drop--from_presence_checking_failures.mdwn b/doc/bugs/concurrent_drop--from_presence_checking_failures.mdwn index 7b38af13c4..22e50766ae 100644 --- a/doc/bugs/concurrent_drop--from_presence_checking_failures.mdwn +++ b/doc/bugs/concurrent_drop--from_presence_checking_failures.mdwn @@ -73,6 +73,8 @@ as part of its check of numcopies, and keep it locked while it's asking B to drop it. Then when B tells A to drop it, it'll be locked and that'll fail (and vice-versa). +> Done, and verified the fix works in this situation. + # the bug part 2 
@@ -116,6 +118,8 @@ Note that this is analgous to the fix above; in both cases
 the change is from checking if content is in a location, to locking it in
 that location while performing a drop from another location.
 
+> Done, and verified the fix works in this situation.
+
 # the bug part 3 (where it gets really nasty)
 
 
@@ -198,6 +202,9 @@ never entirely lost.
 Dipping below desired numcopies in an unusual race condition, and then
 doing extra work later to recover may be good enough.
 
+> Implemented, and I've now verified this solves the case above.
+> Indeed, neither drop succeeds, because no copy can be locked.
+
 ### to drop from local repo
 
 When dropping an object from the local repo, lock it for drop,

From e392ec112f2928680df0dead228d783e30473acf Mon Sep 17 00:00:00 2001
From: Joey Hess 
Date: Fri, 9 Oct 2015 16:16:03 -0400
Subject: [PATCH 25/30] also generate a drop safety proof for move --from
 remote

---
 Annex/NumCopies.hs                            |  4 ++--
 Command/Drop.hs                               |  2 +-
 Command/Move.hs                               | 19 +++++++++++++++++--
 ...drop--from_presence_checking_failures.mdwn | 19 +++++++++++++++++++
 4 files changed, 39 insertions(+), 5 deletions(-)

diff --git a/Annex/NumCopies.hs b/Annex/NumCopies.hs
index 2ddb460fd8..64c78fca0e 100644
--- a/Annex/NumCopies.hs
+++ b/Annex/NumCopies.hs
@@ -19,7 +19,7 @@ module Annex.NumCopies (
 	numCopiesCheck',
 	verifyEnoughCopiesToDrop,
 	verifiableCopies,
-	UnVerifiedCopy,
+	UnVerifiedCopy(..),
 ) where
 
 import Common.Annex
@@ -115,7 +115,7 @@ verifyEnoughCopiesToDrop
 	-> [UUID] -- repos to skip considering (generally untrusted remotes)
 	-> [VerifiedCopy] -- copies already verified to exist
 	-> [UnVerifiedCopy] -- places to check to see if they have copies
-	-> (SafeDropProof -> Annex a) -- action to perform to drop
+	-> (SafeDropProof -> Annex a) -- action to perform the drop
 	-> Annex a -- action to perform when unable to drop
 	-> Annex a
 verifyEnoughCopiesToDrop nolocmsg key removallock need skip preverified tocheck dropaction nodropaction = 
diff --git a/Command/Drop.hs b/Command/Drop.hs
index 5bbaf11c6b..5c5328618b 100644
--- a/Command/Drop.hs
+++ b/Command/Drop.hs
@@ -120,7 +120,7 @@ performRemote key afile numcopies remote = do
 			liftIO $ debugM "drop" $ unwords
 				[ "Dropping from remote"
 				, show remote
-				, "proof: "
+				, "proof:"
 				, show proof
 				]
 			ok <- Remote.removeKey remote key
diff --git a/Command/Move.hs b/Command/Move.hs
index bd1b6dd927..9a289d8b69 100644
--- a/Command/Move.hs
+++ b/Command/Move.hs
@@ -1,6 +1,6 @@
 {- git-annex command
  -
- - Copyright 2010-2013 Joey Hess 
+ - Copyright 2010-2015 Joey Hess 
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -16,6 +16,9 @@ import qualified Remote
 import Annex.UUID
 import Annex.Transfer
 import Logs.Presence
+import Annex.NumCopies
+
+import System.Log.Logger (debugM)
 
 cmd :: Command
 cmd = withGlobalOptions (jobsOption : annexedMatchingOptions) $
@@ -170,6 +173,18 @@ fromPerform src move key afile = ifM (inAnnex key)
 				Remote.retrieveKeyFile src key afile t p
 	dispatch _ False = stop -- failed
 	dispatch False True = next $ return True -- copy complete
-	dispatch True True = do -- finish moving
+	-- Finish by dropping from remote, taking care to verify that
+	-- the copy here has not been lost somehow. 
+	-- (NumCopies is 1 since we're moving.)
+	dispatch True True = verifyEnoughCopiesToDrop "" key Nothing
+		(NumCopies 1) [] [] [UnVerifiedHere] dropremote faileddropremote
+	dropremote proof = do
+		liftIO $ debugM "drop" $ unwords
+			[ "Dropping from remote"
+			, show src
+			, "proof:"
+			, show proof
+			]
 		ok <- Remote.removeKey src key
 		next $ Command.Drop.cleanupRemote key src ok
+	faileddropremote = error "Unable to drop from remote."
diff --git a/doc/bugs/concurrent_drop--from_presence_checking_failures.mdwn b/doc/bugs/concurrent_drop--from_presence_checking_failures.mdwn
index 22e50766ae..de50ca431a 100644
--- a/doc/bugs/concurrent_drop--from_presence_checking_failures.mdwn
+++ b/doc/bugs/concurrent_drop--from_presence_checking_failures.mdwn
@@ -346,3 +346,22 @@ A drops                    B keeps                    C keeps
 It can race other ways, but they all work out the same way essentially,
 due to the locking.
 

+
+# the bug, with moves
+
+`git annex move --from remote` is the same as a copy followed by drop --from,
+so the same bug can occur then.
+
+But, the implementation differs from Command.Drop, so will also
+need some changes.
+
+Command.Move.toPerform already locks local content for removal before
+removing it, of course. So, that will interoperate fine with
+concurrent drops/moves. Seems fine as-is.
+
+Command.Move.fromPerform simply needs to lock the local content
+in place before dropping it from the remote. This satisfies the need
+for 1 locked copy when dropping from a remote, and so is sufficent to
+fix the bug.
+
+> done

From 6d4f741d5f31df435fdffd6084cedd21bd9ef896 Mon Sep 17 00:00:00 2001
From: Joey Hess 
Date: Fri, 9 Oct 2015 16:18:16 -0400
Subject: [PATCH 26/30] cleanup changelog

---
 debian/changelog | 14 +++++---------
 1 file changed, 5 insertions(+), 9 deletions(-)

diff --git a/debian/changelog b/debian/changelog
index bd503b55ec..81797bc4f0 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,5 +1,10 @@
 git-annex (5.20150931) UNRELEASED; urgency=medium
 
+  * Fix a longstanding bug, where dropping a file from a remote
+    could race with other drops of the same file, and result in
+    all copies of its content being lost.
+  * git-annex-shell: Added lockcontent command, to prevent dropping of
+    a key's content. This is necessary due to the above bugfix.
   * Do verification of checksums of annex objects downloaded from remotes.
   * When annex objects are received into git repositories from other git
     repos, their checksums are verified then too.
@@ -20,15 +25,6 @@ git-annex (5.20150931) UNRELEASED; urgency=medium
     and stop recommending bittornado | bittorrent.
   * Debian: Remove dependency on transformers library, as it is now
     included in ghc.
-  * Fix a longstanding bug, where dropping a file from a remote
-    could race with other drops of the same file, and result in
-    all copies of its content being lost.
-  * git-annex-shell: Added lockcontent command, to prevent dropping of
-    a key's content. This is necessary due to the above bugfix.
-  * When a remote uses an old version of git-annex-shell without the
-    new lockcontent command, git-annex may not trust the remote enough
-    to be able to drop content.
-    Solution: Upgrade git-annex-shell to this version.
     
  -- Joey Hess   Thu, 01 Oct 2015 12:42:56 -0400
 

From 3b89d5a20c0e2da33e351be5870f26ac5ac0bbc6 Mon Sep 17 00:00:00 2001
From: Joey Hess 
Date: Fri, 9 Oct 2015 16:55:41 -0400
Subject: [PATCH 27/30] implement lockContent for ssh remotes

---
 Annex/Content.hs       |  2 +-
 Command/LockContent.hs |  3 ++-
 Remote/Git.hs          | 38 ++++++++++++++++++++++++++++++++++++--
 Remote/Helper/Ssh.hs   |  5 +++++
 Types/NumCopies.hs     | 14 ++++++++------
 5 files changed, 52 insertions(+), 10 deletions(-)

diff --git a/Annex/Content.hs b/Annex/Content.hs
index 0dc47d9e29..0b15ce53b1 100644
--- a/Annex/Content.hs
+++ b/Annex/Content.hs
@@ -184,7 +184,7 @@ contentLockFile key = Just <$> calcRepo (gitAnnexContentLock key)
 lockContentShared :: Key -> (VerifiedCopy -> Annex a) -> Annex a
 lockContentShared key a = lockContentUsing lock key $ do
 	u <- getUUID
-	withVerifiedCopy LockedCopy u a
+	withVerifiedCopy LockedCopy u (return True) a
   where
 #ifndef mingw32_HOST_OS
 	lock contentfile Nothing = liftIO $ tryLockShared Nothing contentfile
diff --git a/Command/LockContent.hs b/Command/LockContent.hs
index e37d4cca51..72b2bb096e 100644
--- a/Command/LockContent.hs
+++ b/Command/LockContent.hs
@@ -11,6 +11,7 @@ import Common.Annex
 import Command
 import Annex.Content
 import Types.Key
+import Remote.Helper.Ssh (contentLockedMarker)
 
 cmd :: Command
 cmd = noCommit $ 
@@ -36,7 +37,7 @@ start [ks] = do
 	k = fromMaybe (error "bad key") (file2key ks)
 	locksuccess = ifM (inAnnex k)
 		( liftIO $ do
-			putStrLn "OK"
+			putStrLn contentLockedMarker
 			hFlush stdout
 			_ <- getLine
 			return True
diff --git a/Remote/Git.hs b/Remote/Git.hs
index a6c4315ab4..c2bd307ada 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -57,6 +57,7 @@ import Types.NumCopies
 
 import Control.Concurrent
 import Control.Concurrent.MSampleVar
+import Control.Concurrent.Async
 import qualified Data.Map as M
 import Network.URI
 
@@ -370,8 +371,41 @@ lockKey r key callback
 			-- annex monad, not the remote's.
 			onLocal r $ Annex.Content.lockContentShared key $ 
 				liftIO . inorigrepo . callback
-	| Git.repoIsHttp (repo r) = cantlock
-	| otherwise = error "TODO"
+	| Git.repoIsSsh (repo r) = do
+		Just (cmd, params) <- Ssh.git_annex_shell (repo r) "lockcontent"
+			[Param $ key2file key] []
+		(Just hin, Just hout, Nothing, p) <- liftIO $ createProcess $
+			 (proc cmd (toCommand params))
+				{ std_in = CreatePipe
+				, std_out = CreatePipe
+				}
+		-- Wait for either the process to exit, or for it to
+		-- indicate the content is locked.
+		v <- liftIO $ race 
+			(waitForProcess p)
+			(hGetLine hout)
+		let signaldone = void $ tryNonAsync $ liftIO $ do
+			hPutStrLn hout ""
+			hFlush hout
+			hClose hin
+			hClose hout
+			void $ waitForProcess p
+		let checkexited = not . isJust <$> getProcessExitCode p
+		case v of
+			Left _exited -> do
+				liftIO $ do
+					hClose hin
+					hClose hout
+				cantlock
+			Right l 
+				| l == Ssh.contentLockedMarker -> bracket_
+					noop
+					signaldone 
+					(withVerifiedCopy LockedCopy r checkexited callback)
+				| otherwise -> do
+					signaldone
+					cantlock
+	| otherwise = cantlock
   where
 	cantlock = error "can't lock content"
 
diff --git a/Remote/Helper/Ssh.hs b/Remote/Helper/Ssh.hs
index 162c34f4eb..0442ce8398 100644
--- a/Remote/Helper/Ssh.hs
+++ b/Remote/Helper/Ssh.hs
@@ -173,3 +173,8 @@ rsyncParams r direction = do
 		| direction == Download = remoteAnnexRsyncDownloadOptions gc
 		| otherwise = remoteAnnexRsyncUploadOptions gc
 	gc = gitconfig r
+
+-- Used by git-annex-shell lockcontent to indicate the content is
+-- successfully locked.
+contentLockedMarker :: String
+contentLockedMarker = "OK"
diff --git a/Types/NumCopies.hs b/Types/NumCopies.hs
index 60e0db5809..8677e22b3b 100644
--- a/Types/NumCopies.hs
+++ b/Types/NumCopies.hs
@@ -25,6 +25,7 @@ module Types.NumCopies (
 import Types.UUID
 import Types.Key
 import Utility.Exception (bracketIO)
+import Utility.Monad
 
 import qualified Data.Map as M
 import Control.Concurrent.MVar
@@ -98,14 +99,14 @@ deDupVerifiedCopies l = M.elems $
 mkVerifiedCopy :: ToUUID u => (V -> VerifiedCopy) -> u -> VerifiedCopy
 mkVerifiedCopy mk u = mk $ V (toUUID u) (return True) (return ())
 
-invalidatableVerifiedCopy :: ToUUID u => (V -> VerifiedCopy) -> u -> IO VerifiedCopy
-invalidatableVerifiedCopy mk u = do
+invalidatableVerifiedCopy :: ToUUID u => (V -> VerifiedCopy) -> u -> IO Bool -> IO VerifiedCopy
+invalidatableVerifiedCopy mk u check = do
 	v <- newEmptyMVar
 	let invalidate = do
 		_ <- tryPutMVar v ()
 		return ()
-	let check = isEmptyMVar v
-	return $ mk $ V (toUUID u) check invalidate
+	let check' = isEmptyMVar v <&&> check
+	return $ mk $ V (toUUID u) check' invalidate
 
 -- Constructs a VerifiedCopy, and runs the action, ensuring that the
 -- verified copy is invalidated when the action returns, or on error.
@@ -113,11 +114,12 @@ withVerifiedCopy
 	:: (Monad m, MonadMask m, MonadIO m, ToUUID u)
 	=> (V -> VerifiedCopy)
 	-> u
+	-> IO Bool
 	-> (VerifiedCopy -> m a)
 	-> m a
-withVerifiedCopy mk u = bracketIO setup cleanup
+withVerifiedCopy mk u check = bracketIO setup cleanup
   where
-	setup = invalidatableVerifiedCopy mk u
+	setup = invalidatableVerifiedCopy mk u check
 	cleanup = invalidateVerifiedCopy
 
 {- Check whether enough verification has been done of copies to allow

From 6145f905e006008fe595d9ad181827fb69f24071 Mon Sep 17 00:00:00 2001
From: Joey Hess 
Date: Fri, 9 Oct 2015 17:21:02 -0400
Subject: [PATCH 28/30] improve display when lockcontent fails

/dev/null stderr; ssh is still able to display a password prompt
despite this

Show some messages so the user knows it's locking a remote, and
knows if that locking failed.
---
 Remote/Git.hs             | 26 ++++++++++++++++----------
 Remote/Helper/Messages.hs | 27 +++++++++++++++------------
 debian/changelog          |  9 +++++++++
 3 files changed, 40 insertions(+), 22 deletions(-)

diff --git a/Remote/Git.hs b/Remote/Git.hs
index c2bd307ada..80c0579cc4 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -364,7 +364,7 @@ dropKey r key
 lockKey :: Remote -> Key -> (VerifiedCopy -> Annex r) -> Annex r
 lockKey r key callback
 	| not $ Git.repoIsUrl (repo r) =
-		guardUsable (repo r) cantlock $ do
+		guardUsable (repo r) failedlock $ do
 			inorigrepo <- Annex.makeRunner
 			-- Lock content from perspective of remote,
 			-- and then run the callback in the original
@@ -372,13 +372,17 @@ lockKey r key callback
 			onLocal r $ Annex.Content.lockContentShared key $ 
 				liftIO . inorigrepo . callback
 	| Git.repoIsSsh (repo r) = do
+		showLocking r
 		Just (cmd, params) <- Ssh.git_annex_shell (repo r) "lockcontent"
 			[Param $ key2file key] []
-		(Just hin, Just hout, Nothing, p) <- liftIO $ createProcess $
-			 (proc cmd (toCommand params))
-				{ std_in = CreatePipe
-				, std_out = CreatePipe
-				}
+		(Just hin, Just hout, Nothing, p) <- liftIO $ 
+			withFile devNull WriteMode $ \nullh ->
+				createProcess $
+					 (proc cmd (toCommand params))
+						{ std_in = CreatePipe
+						, std_out = CreatePipe
+						, std_err = UseHandle nullh
+						}
 		-- Wait for either the process to exit, or for it to
 		-- indicate the content is locked.
 		v <- liftIO $ race 
@@ -393,21 +397,23 @@ lockKey r key callback
 		let checkexited = not . isJust <$> getProcessExitCode p
 		case v of
 			Left _exited -> do
+				showNote "lockcontent failed"
 				liftIO $ do
 					hClose hin
 					hClose hout
-				cantlock
+				failedlock
 			Right l 
 				| l == Ssh.contentLockedMarker -> bracket_
 					noop
 					signaldone 
 					(withVerifiedCopy LockedCopy r checkexited callback)
 				| otherwise -> do
+					showNote "lockcontent failed"
 					signaldone
-					cantlock
-	| otherwise = cantlock
+					failedlock
+	| otherwise = failedlock
   where
-	cantlock = error "can't lock content"
+	failedlock = error "can't lock content"
 
 {- Tries to copy a key's content from a remote's annex to a file. -}
 copyFromRemote :: Remote -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification)
diff --git a/Remote/Helper/Messages.hs b/Remote/Helper/Messages.hs
index 377f2d2313..6e72758fb1 100644
--- a/Remote/Helper/Messages.hs
+++ b/Remote/Helper/Messages.hs
@@ -13,20 +13,23 @@ import Common.Annex
 import qualified Git
 import qualified Types.Remote as Remote
 
-class Checkable a where
-	descCheckable :: a -> String
+class Describable a where
+	describe :: a -> String
 
-instance Checkable Git.Repo where
-	descCheckable = Git.repoDescribe
+instance Describable Git.Repo where
+	describe = Git.repoDescribe
 
-instance Checkable (Remote.RemoteA a) where
-	descCheckable = Remote.name
+instance Describable (Remote.RemoteA a) where
+	describe = Remote.name
 
-instance Checkable String where
-	descCheckable = id
+instance Describable String where
+	describe = id
 
-showChecking :: Checkable a => a -> Annex ()
-showChecking v = showAction $ "checking " ++ descCheckable v
+showChecking :: Describable a => a -> Annex ()
+showChecking v = showAction $ "checking " ++ describe v
 
-cantCheck :: Checkable a => a -> e
-cantCheck v = error $ "unable to check " ++ descCheckable v
+cantCheck :: Describable a => a -> e
+cantCheck v = error $ "unable to check " ++ describe v
+
+showLocking :: Describable a => a -> Annex ()
+showLocking v = showAction $ "locking " ++ describe v
diff --git a/debian/changelog b/debian/changelog
index 81797bc4f0..250e183a6d 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -5,6 +5,15 @@ git-annex (5.20150931) UNRELEASED; urgency=medium
     all copies of its content being lost.
   * git-annex-shell: Added lockcontent command, to prevent dropping of
     a key's content. This is necessary due to the above bugfix.
+  * In some cases, the above bugfix changes what git-annex allows to be dropped:
+    - When a file is present in several special remotes,
+      but not in any accessible git repositories, dropping it from one of
+      the special remotes will now fail. Instead, the file has to be
+      moved from one of the special remotes to the git repository, and can
+      then safely be dropped from the git repository.
+    - If a git remote has too old a version of git-annex-shell installed,
+      git-annex won't trust it to hold onto a copy of a file when dropping
+      that file from some other remote.
   * Do verification of checksums of annex objects downloaded from remotes.
   * When annex objects are received into git repositories from other git
     repos, their checksums are verified then too.

From 181d4fd4594aef72455c3489e233c8c0f07b572c Mon Sep 17 00:00:00 2001
From: Joey Hess 
Date: Fri, 9 Oct 2015 17:32:12 -0400
Subject: [PATCH 29/30] close bug

---
 doc/bugs/concurrent_drop--from_presence_checking_failures.mdwn | 2 ++
 1 file changed, 2 insertions(+)

diff --git a/doc/bugs/concurrent_drop--from_presence_checking_failures.mdwn b/doc/bugs/concurrent_drop--from_presence_checking_failures.mdwn
index de50ca431a..66fe488962 100644
--- a/doc/bugs/concurrent_drop--from_presence_checking_failures.mdwn
+++ b/doc/bugs/concurrent_drop--from_presence_checking_failures.mdwn
@@ -2,6 +2,8 @@ Concurrent dropping of a file has problems when drop --from is
 used. (Also when the assistant or sync --content decided to drop from a
 remote.)
 
+> Now [[fixed|done]] --[[Joey]]
+
 [[!toc]]
 
 # refresher

From 2154b7a38f621d45ff31503c53c67c4f1a1a3d09 Mon Sep 17 00:00:00 2001
From: Joey Hess 
Date: Fri, 9 Oct 2015 18:00:37 -0400
Subject: [PATCH 30/30] add inAnnex check to local lockKey

---
 Remote/Git.hs | 8 ++++++--
 1 file changed, 6 insertions(+), 2 deletions(-)

diff --git a/Remote/Git.hs b/Remote/Git.hs
index 80c0579cc4..c80a0d1c61 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -369,8 +369,12 @@ lockKey r key callback
 			-- Lock content from perspective of remote,
 			-- and then run the callback in the original
 			-- annex monad, not the remote's.
-			onLocal r $ Annex.Content.lockContentShared key $ 
-				liftIO . inorigrepo . callback
+			onLocal r $ 
+				Annex.Content.lockContentShared key $ \vc ->
+					ifM (Annex.Content.inAnnex key)
+						( liftIO $ inorigrepo $ callback vc
+						, failedlock
+						)
 	| Git.repoIsSsh (repo r) = do
 		showLocking r
 		Just (cmd, params) <- Ssh.git_annex_shell (repo r) "lockcontent"