diff --git a/Annex/Drop.hs b/Annex/Drop.hs index 6f55378719..416ce49e94 100644 --- a/Annex/Drop.hs +++ b/Annex/Drop.hs @@ -27,8 +27,8 @@ import qualified Data.Set as S type Reason = String -{- Drop a key from local and/or remote when allowed by the preferred content - - and numcopies settings. +{- Drop a key from local and/or remote when allowed by the preferred content, + - required content, and numcopies settings. - - Skips trying to drop from remotes that are appendonly, since those drops - would presumably fail. Also skips dropping from exporttree/importtree remotes, @@ -105,8 +105,9 @@ handleDropsFrom locs rs reason fromhere key afile si preverified runner = do checkdrop fs n u a = let afs = map (AssociatedFile . Just) fs + pcc = Command.Drop.PreferredContentChecked True in ifM (wantDrop True u (Just key) afile (Just afs)) - ( dodrop n u a + ( dodrop n u (a pcc) , return n ) @@ -126,12 +127,12 @@ handleDropsFrom locs rs reason fromhere key afile si preverified runner = do , return n ) - dropl fs n = checkdrop fs n Nothing $ \numcopies mincopies -> + dropl fs n = checkdrop fs n Nothing $ \pcc numcopies mincopies -> stopUnless (inAnnex key) $ - Command.Drop.startLocal afile ai si numcopies mincopies key preverified + Command.Drop.startLocal pcc afile ai si numcopies mincopies key preverified - dropr fs r n = checkdrop fs n (Just $ Remote.uuid r) $ \numcopies mincopies -> - Command.Drop.startRemote afile ai si numcopies mincopies key r + dropr fs r n = checkdrop fs n (Just $ Remote.uuid r) $ \pcc numcopies mincopies -> + Command.Drop.startRemote pcc afile ai si numcopies mincopies key r ai = mkActionItem (key, afile) diff --git a/Annex/Wanted.hs b/Annex/Wanted.hs index 3ce7fe328f..cb2a8e3401 100644 --- a/Annex/Wanted.hs +++ b/Annex/Wanted.hs @@ -13,6 +13,7 @@ import Annex.UUID import Annex.CatFile import Git.FilePath import qualified Database.Keys +import Types.FileMatcher import qualified Data.Set as S @@ -20,12 +21,12 @@ import qualified Data.Set as S wantGet :: Bool -> Maybe Key -> AssociatedFile -> Annex Bool wantGet d key file = isPreferredContent Nothing S.empty key file d -{- Check if a file is preferred content for a remote. -} +{- Check if a file is preferred content for a repository. -} wantSend :: Bool -> Maybe Key -> AssociatedFile -> UUID -> Annex Bool wantSend d key file to = isPreferredContent (Just to) S.empty key file d -{- Check if a file can be dropped, maybe from a remote. - - Don't drop files that are preferred content. +{- Check if a file is not preferred or required content, and can be + - dropped. When a UUID is provided, checks for that repository. - - The AssociatedFile is the one that the user requested to drop. - There may be other files that use the same key, and preferred content @@ -34,12 +35,21 @@ wantSend d key file to = isPreferredContent (Just to) S.empty key file d - they can be provided, otherwise this looks them up. -} wantDrop :: Bool -> Maybe UUID -> Maybe Key -> AssociatedFile -> (Maybe [AssociatedFile]) -> Annex Bool -wantDrop d from key file others = do +wantDrop d from key file others = + isNothing <$> checkDrop isPreferredContent d from key file others + +{- Generalization of wantDrop that can also be used with isRequiredContent. + - + - When the content should not be dropped, returns Just the file that + - the checker matches. + -} +checkDrop :: (Maybe UUID -> AssumeNotPresent -> Maybe Key -> AssociatedFile -> Bool -> Annex Bool) -> Bool -> Maybe UUID -> Maybe Key -> AssociatedFile -> (Maybe [AssociatedFile]) -> Annex (Maybe AssociatedFile) +checkDrop checker d from key file others = do u <- maybe getUUID (pure . id) from let s = S.singleton u - let checkwant f = isPreferredContent (Just u) s key f d - ifM (checkwant file) - ( return False + let checker' f = checker (Just u) s key f d + ifM (checker' file) + ( return (Just file) , do others' <- case others of Just afs -> pure (filter (/= file) afs) @@ -48,18 +58,18 @@ wantDrop d from key file others = do mapM (\f -> AssociatedFile . Just <$> fromRepo (fromTopFilePath f)) =<< Database.Keys.getAssociatedFiles k Nothing -> pure [] - l <- filterM checkwant others' + l <- filterM checker' others' if null l - then return True + then return Nothing else checkassociated l ) where -- Some associated files that are in the keys database may no -- longer correspond to files in the repository, and should -- not prevent dropping. - checkassociated [] = return True - checkassociated (AssociatedFile (Just af):fs) = - catKeyFile af >>= \case - Just k | Just k == key -> return False + checkassociated [] = return Nothing + checkassociated (af@(AssociatedFile (Just f)):fs) = + catKeyFile f >>= \case + Just k | Just k == key -> return (Just af) _ -> checkassociated fs checkassociated (AssociatedFile Nothing:fs) = checkassociated fs diff --git a/CHANGELOG b/CHANGELOG index 2296541109..1e5b360e07 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,5 +1,8 @@ git-annex (8.20210429) UNRELEASED; urgency=medium + * When two files have the same content, and a required content expression + matches one but not the other, dropping the latter file will fail as it + would also remove the content of the required file. * drop --auto: When two files have the same content, and a preferred content expression matches one but not the other, do not drop the content. * sync --content, assistant: When two unlocked files have the same diff --git a/Command/Drop.hs b/Command/Drop.hs index 6422fc26d5..f30b6f4c08 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -21,8 +21,6 @@ import Annex.Content import Annex.Wanted import Annex.Notification -import qualified Data.Set as S - cmd :: Command cmd = withGlobalOptions [jobsOption, jsonOptions, annexedMatchingOptions] $ command "drop" SectionCommon @@ -88,31 +86,32 @@ start' o from key afile ai si = checkDropAuto (autoMode o) from afile key $ \numcopies mincopies -> stopUnless wantdrop $ case from of - Nothing -> startLocal afile ai si numcopies mincopies key [] - Just remote -> startRemote afile ai si numcopies mincopies key remote + Nothing -> startLocal pcc afile ai si numcopies mincopies key [] + Just remote -> startRemote pcc afile ai si numcopies mincopies key remote where wantdrop | autoMode o = wantDrop False (Remote.uuid <$> from) (Just key) afile Nothing | otherwise = return True + pcc = PreferredContentChecked (autoMode o) startKeys :: DropOptions -> Maybe Remote -> (SeekInput, Key, ActionItem) -> CommandStart startKeys o from (si, key, ai) = start' o from key (AssociatedFile Nothing) ai si -startLocal :: AssociatedFile -> ActionItem -> SeekInput -> NumCopies -> MinCopies -> Key -> [VerifiedCopy] -> CommandStart -startLocal afile ai si numcopies mincopies key preverified = +startLocal :: PreferredContentChecked -> AssociatedFile -> ActionItem -> SeekInput -> NumCopies -> MinCopies -> Key -> [VerifiedCopy] -> CommandStart +startLocal pcc afile ai si numcopies mincopies key preverified = starting "drop" (OnlyActionOn key ai) si $ - performLocal key afile numcopies mincopies preverified + performLocal pcc key afile numcopies mincopies preverified -startRemote :: AssociatedFile -> ActionItem -> SeekInput -> NumCopies -> MinCopies -> Key -> Remote -> CommandStart -startRemote afile ai si numcopies mincopies key remote = +startRemote :: PreferredContentChecked -> AssociatedFile -> ActionItem -> SeekInput -> NumCopies -> MinCopies -> Key -> Remote -> CommandStart +startRemote pcc afile ai si numcopies mincopies key remote = starting ("drop " ++ Remote.name remote) (OnlyActionOn key ai) si $ - performRemote key afile numcopies mincopies remote + performRemote pcc key afile numcopies mincopies remote -performLocal :: Key -> AssociatedFile -> NumCopies -> MinCopies -> [VerifiedCopy] -> CommandPerform -performLocal key afile numcopies mincopies preverified = lockContentForRemoval key fallback $ \contentlock -> do +performLocal :: PreferredContentChecked -> Key -> AssociatedFile -> NumCopies -> MinCopies -> [VerifiedCopy] -> CommandPerform +performLocal pcc key afile numcopies mincopies preverified = lockContentForRemoval key fallback $ \contentlock -> do u <- getUUID (tocheck, verified) <- verifiableCopies key [u] - doDrop u (Just contentlock) key afile numcopies mincopies [] (preverified ++ verified) tocheck + doDrop pcc u (Just contentlock) key afile numcopies mincopies [] (preverified ++ verified) tocheck ( \proof -> do fastDebug "Command.Drop" $ unwords [ "Dropping from here" @@ -134,12 +133,12 @@ performLocal key afile numcopies mincopies preverified = lockContentForRemoval k -- to be done except for cleaning up. fallback = next $ cleanupLocal key -performRemote :: Key -> AssociatedFile -> NumCopies -> MinCopies -> Remote -> CommandPerform -performRemote key afile numcopies mincopies remote = do +performRemote :: PreferredContentChecked -> Key -> AssociatedFile -> NumCopies -> MinCopies -> Remote -> CommandPerform +performRemote pcc key afile numcopies mincopies remote = do -- Filter the uuid it's being dropped from out of the lists of -- places assumed to have the key, and places to check. (tocheck, verified) <- verifiableCopies key [uuid] - doDrop uuid Nothing key afile numcopies mincopies [uuid] verified tocheck + doDrop pcc uuid Nothing key afile numcopies mincopies [uuid] verified tocheck ( \proof -> do fastDebug "Command.Drop" $ unwords [ "Dropping from remote" @@ -169,12 +168,11 @@ cleanupRemote key remote ok = do - 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. -} doDrop - :: UUID + :: PreferredContentChecked + -> UUID -> Maybe ContentRemovalLock -> Key -> AssociatedFile @@ -185,10 +183,10 @@ doDrop -> [UnVerifiedCopy] -> (Maybe SafeDropProof -> CommandPerform, CommandPerform) -> CommandPerform -doDrop dropfrom contentlock key afile numcopies mincopies skip preverified check (dropaction, nodropaction) = +doDrop pcc dropfrom contentlock key afile numcopies mincopies skip preverified check (dropaction, nodropaction) = ifM (Annex.getState Annex.force) ( dropaction Nothing - , ifM (checkRequiredContent dropfrom key afile) + , ifM (checkRequiredContent pcc dropfrom key afile) ( verifyEnoughCopiesToDrop nolocmsg key contentlock numcopies mincopies skip preverified check @@ -203,18 +201,27 @@ doDrop dropfrom contentlock key afile numcopies mincopies skip preverified check showLongNote "(Use --force to override this check, or adjust numcopies.)" a -checkRequiredContent :: UUID -> Key -> AssociatedFile -> Annex Bool -checkRequiredContent u k afile = - ifM (isRequiredContent (Just u) S.empty (Just k) afile False) - ( requiredContent - , return True - ) +{- Checking preferred content also checks required content, so when + - auto mode causes preferred content to be checked, it's redundant + - for checkRequiredContent to separately check required content, and + - providing this avoids that extra work. -} +newtype PreferredContentChecked = PreferredContentChecked Bool -requiredContent :: Annex Bool -requiredContent = do - showLongNote "That file is required content, it cannot be dropped!" - showLongNote "(Use --force to override this check, or adjust required content configuration.)" - return False +checkRequiredContent :: PreferredContentChecked -> UUID -> Key -> AssociatedFile -> Annex Bool +checkRequiredContent (PreferredContentChecked True) _ _ _ = return True +checkRequiredContent (PreferredContentChecked False) u k afile = + checkDrop isRequiredContent False (Just u) (Just k) afile Nothing >>= \case + Nothing -> return True + Just afile' -> do + if afile == afile' + then showLongNote "That file is required content. It cannot be dropped!" + else showLongNote $ "That file has the same content as another file" + ++ case afile' of + AssociatedFile (Just f) -> " (" ++ fromRawFilePath f ++ ")," + AssociatedFile Nothing -> "" + ++ " which is required content. It cannot be dropped!" + showLongNote "(Use --force to override this check, or adjust required content configuration.)" + return False {- In auto mode, only runs the action if there are enough - copies on other semitrusted repositories. -} diff --git a/Command/DropUnused.hs b/Command/DropUnused.hs index 6c7ca34d41..0b81a9e467 100644 --- a/Command/DropUnused.hs +++ b/Command/DropUnused.hs @@ -49,7 +49,7 @@ perform :: Maybe Remote -> NumCopies -> MinCopies -> Key -> CommandPerform perform from numcopies mincopies key = case from of Just r -> do showAction $ "from " ++ Remote.name r - Command.Drop.performRemote key (AssociatedFile Nothing) numcopies mincopies r + Command.Drop.performRemote pcc key (AssociatedFile Nothing) numcopies mincopies r Nothing -> ifM (inAnnex key) ( droplocal , ifM (objectFileExists key) @@ -63,7 +63,8 @@ perform from numcopies mincopies key = case from of ) ) where - droplocal = Command.Drop.performLocal key (AssociatedFile Nothing) numcopies mincopies [] + droplocal = Command.Drop.performLocal pcc key (AssociatedFile Nothing) numcopies mincopies [] + pcc = Command.Drop.PreferredContentChecked False performOther :: (Key -> Git.Repo -> RawFilePath) -> Key -> CommandPerform performOther filespec key = do diff --git a/Command/Mirror.hs b/Command/Mirror.hs index 61c9a1f888..b5f49b2373 100644 --- a/Command/Mirror.hs +++ b/Command/Mirror.hs @@ -69,7 +69,7 @@ startKey o afile (si, key, ai) = case fromToOptions o of ( Command.Move.toStart Command.Move.RemoveNever afile key ai si =<< getParsed r , do (numcopies, mincopies) <- getnummincopies - Command.Drop.startRemote afile ai si numcopies mincopies key =<< getParsed r + Command.Drop.startRemote pcc afile ai si numcopies mincopies key =<< getParsed r ) FromRemote r -> checkFailedTransferDirection ai Download $ do haskey <- flip Remote.hasKey key =<< getParsed r @@ -82,10 +82,11 @@ startKey o afile (si, key, ai) = case fromToOptions o of Right False -> ifM (inAnnex key) ( do (numcopies, mincopies) <- getnummincopies - Command.Drop.startLocal afile ai si numcopies mincopies key [] + Command.Drop.startLocal pcc afile ai si numcopies mincopies key [] , stop ) where getnummincopies = case afile of AssociatedFile Nothing -> (,) <$> getNumCopies <*> getMinCopies AssociatedFile (Just af) -> getFileNumMinCopies af + pcc = Command.Drop.PreferredContentChecked False diff --git a/Command/Move.hs b/Command/Move.hs index fcb7390a6a..6d2cc50c30 100644 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -293,7 +293,7 @@ toHereStart removewhen afile key ai si = - repository reduces the number of copies, and should fail if - that would violate numcopies settings. - - - On the other hand, when the destiation repository does not already + - On the other hand, when the destination repository does not already - have a copy of a file, it can be dropped without making numcopies - worse, so the move is allowed even if numcopies is not met. - @@ -311,7 +311,7 @@ toHereStart removewhen afile key ai si = -} willDropMakeItWorse :: UUID -> UUID -> DestStartedWithCopy -> Key -> AssociatedFile -> Annex DropCheck willDropMakeItWorse srcuuid destuuid (DestStartedWithCopy deststartedwithcopy) key afile = - ifM (Command.Drop.checkRequiredContent srcuuid key afile) + ifM (Command.Drop.checkRequiredContent (Command.Drop.PreferredContentChecked False) srcuuid key afile) ( if deststartedwithcopy then unlessforced DropCheckNumCopies else ifM checktrustlevel diff --git a/Logs/PreferredContent.hs b/Logs/PreferredContent.hs index adb0189ec3..1391bde4ce 100644 --- a/Logs/PreferredContent.hs +++ b/Logs/PreferredContent.hs @@ -46,8 +46,8 @@ import Logs.Remote import Types.StandardGroups import Limit -{- Checks if a file is preferred content for the specified repository - - (or the current repository if none is specified). -} +{- Checks if a file is preferred content (or required content) for the + - specified repository (or the current repository if none is specified). -} isPreferredContent :: Maybe UUID -> AssumeNotPresent -> Maybe Key -> AssociatedFile -> Bool -> Annex Bool isPreferredContent = checkMap preferredContentMap diff --git a/Test.hs b/Test.hs index 300ec157ff..c5d419074a 100644 --- a/Test.hs +++ b/Test.hs @@ -376,6 +376,7 @@ unitTests note = testGroup ("Unit Tests " ++ note) , testCase "bup remote" test_bup_remote , testCase "crypto" test_crypto , testCase "preferred content" test_preferred_content + , testCase "required_content" test_required_content , testCase "add subdirs" test_add_subdirs , testCase "addurl" test_addurl ] @@ -749,6 +750,27 @@ test_preferred_content = intmpclonerepo $ do git_annex "get" ["--auto", annexedfile] "get --auto of file with exclude=*" annexed_notpresent annexedfile +test_required_content :: Assertion +test_required_content = intmpclonerepo $ do + git_annex "get" [annexedfile] "get" + annexed_present annexedfile + git_annex "required" [".", "include=" ++ annexedfile] "annexedfile required" + + git_annex_shouldfail "drop" [annexedfile] "drop of required content should fail" + annexed_present annexedfile + + git_annex "drop" ["--auto", annexedfile] "drop --auto of required content skips it" + annexed_present annexedfile + + writecontent annexedfiledup $ content annexedfiledup + add_annex annexedfiledup "add of second file with same content failed" + annexed_present annexedfiledup + annexed_present annexedfile + + git_annex_shouldfail "drop" [annexedfiledup] "drop of file sharing required content should fail" + annexed_present annexedfiledup + annexed_present annexedfile + test_lock :: Assertion test_lock = intmpclonerepo $ do annexed_notpresent annexedfile