diff options
Diffstat (limited to 'Command')
| -rw-r--r-- | Command/Drop.hs | 100 | ||||
| -rw-r--r-- | Command/DropKey.hs | 2 | ||||
| -rw-r--r-- | Command/DropUnused.hs | 2 | ||||
| -rw-r--r-- | Command/Import.hs | 15 | ||||
| -rw-r--r-- | Command/LockContent.hs | 46 | ||||
| -rw-r--r-- | Command/Mirror.hs | 2 | ||||
| -rw-r--r-- | Command/Move.hs | 21 | ||||
| -rw-r--r-- | Command/Sync.hs | 4 | ||||
| -rw-r--r-- | Command/TestRemote.hs | 10 | ||||
| -rw-r--r-- | Command/Uninit.hs | 2 |
10 files changed, 138 insertions, 66 deletions
diff --git a/Command/Drop.hs b/Command/Drop.hs index b23f81758..5c5328618 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -20,6 +20,7 @@ import Annex.Content import Annex.Wanted import Annex.Notification +import System.Log.Logger (debugM) import qualified Data.Set as S cmd :: Command @@ -64,11 +65,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,35 +79,31 @@ 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 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 --- 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 - (remotes, trusteduuids) <- Remote.keyPossibilitiesTrusted key - let trusteduuids' = case knownpresentremote of - Nothing -> trusteduuids - Just r -> Remote.uuid r:trusteduuids - untrusteduuids <- trustGet UnTrusted - let tocheck = Remote.remotesWithoutUUID remotes (trusteduuids'++untrusteduuids) +performLocal :: Key -> AssociatedFile -> NumCopies -> [VerifiedCopy] -> CommandPerform +performLocal key afile numcopies preverified = lockContentForRemoval key $ \contentlock -> do u <- getUUID - ifM (canDrop u key afile numcopies trusteduuids' tocheck []) - ( do + (tocheck, verified) <- verifiableCopies key [u] + doDrop u (Just contentlock) key afile numcopies [] (preverified ++ verified) tocheck + ( \proof -> do + liftIO $ debugM "drop" $ unwords + [ "Dropping from here" + , "proof:" + , show proof + ] removeAnnex contentlock notifyDrop afile True next $ cleanupLocal key - , do + , do notifyDrop afile False stop ) @@ -117,14 +114,19 @@ 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 have = 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 - ok <- Remote.removeKey remote key - next $ cleanupRemote key remote ok + (tocheck, verified) <- verifiableCopies key [uuid] + doDrop uuid Nothing key afile numcopies [uuid] verified tocheck + ( \proof -> do + liftIO $ debugM "drop" $ unwords + [ "Dropping from remote" + , show remote + , "proof:" + , show proof + ] + ok <- Remote.removeKey remote key + next $ cleanupRemote key remote ok + , stop + ) where uuid = Remote.uuid remote @@ -139,30 +141,42 @@ 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). Can be provided with - - some locations where the key is known/assumed to be present. +{- 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] -> [Remote] -> [UUID] -> Annex Bool -canDrop dropfrom key afile numcopies have check skip = +doDrop + :: UUID + -> Maybe ContentRemovalLock + -> Key + -> AssociatedFile + -> NumCopies + -> [UUID] + -> [VerifiedCopy] + -> [UnVerifiedCopy] + -> (Maybe SafeDropProof -> CommandPerform, CommandPerform) + -> CommandPerform +doDrop dropfrom contentlock 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 have check - ) - ( return True - , do - hint - return False - ) + ( dropaction Nothing + , ifM (checkRequiredContent dropfrom key afile) + ( verifyEnoughCopiesToDrop nolocmsg key + contentlock numcopies + skip preverified check + (dropaction . Just) + (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/DropKey.hs b/Command/DropKey.hs index 5d44f0fcd..3dea4b4b7 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 = lockContentForRemoval key $ \contentlock -> do removeAnnex contentlock next $ cleanup key diff --git a/Command/DropUnused.hs b/Command/DropUnused.hs index 98fcef6ea..9c2ae972a 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 e84618173..a96c08055 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 $ @@ -83,7 +81,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,13 +132,12 @@ 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 - (remotes, trusteduuids) <- knownCopies key - untrusteduuids <- trustGet UnTrusted - let tocheck = Remote.remotesWithoutUUID remotes (trusteduuids++untrusteduuids) - verifyEnoughCopies [] key need [] trusteduuids tocheck + (tocheck, preverified) <- verifiableCopies key [] + verifyEnoughCopiesToDrop [] key Nothing need [] preverified tocheck + (const yes) no diff --git a/Command/LockContent.hs b/Command/LockContent.hs new file mode 100644 index 000000000..72b2bb096 --- /dev/null +++ b/Command/LockContent.hs @@ -0,0 +1,46 @@ +{- git-annex-shell command + - + - Copyright 2015 Joey Hess <id@joeyh.name> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.LockContent where + +import Common.Annex +import Command +import Annex.Content +import Types.Key +import Remote.Helper.Ssh (contentLockedMarker) + +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 (const 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 contentLockedMarker + hFlush stdout + _ <- getLine + return True + , return False + ) +start _ = error "Specify exactly 1 key." diff --git a/Command/Mirror.hs b/Command/Mirror.hs index 0555d025c..a8caf9da7 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/Move.hs b/Command/Move.hs index a83ea04dd..9a289d8b6 100644 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2010-2013 Joey Hess <id@joeyh.name> + - Copyright 2010-2015 Joey Hess <id@joeyh.name> - - 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) $ @@ -123,7 +126,7 @@ toPerform dest move key afile fastcheck isthere = finish where finish - | move = lockContent key $ \contentlock -> do + | move = lockContentForRemoval key $ \contentlock -> do removeAnnex contentlock next $ Command.Drop.cleanupLocal key | otherwise = next $ return True @@ -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/Command/Sync.hs b/Command/Sync.hs index 964b45dc2..49dfe811e 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/Command/TestRemote.hs b/Command/TestRemote.hs index 7ee5f1359..be1b9a324 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 + 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 - lockContent k removeAnnex + lockContentForRemoval k removeAnnex get , check "fsck downloaded object" fsck , check "retrieveKeyFile resume from 0" $ do tmp <- prepTmp k liftIO $ writeFile tmp "" - lockContent 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 - lockContent 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 -> lockContent 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 c49cc4ba0..cc237db5e 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 + lockContentForRemoval k removeAnnex go c ks , go (k:c) ks ) |