cedc28a783
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. This will slow down drop (w/o --auto), dropunused, mirror, and move, by one keys db lookup per file. But I did include an optimisation to avoid a double db lookup in the drop --auto / sync --content case. I suspect that dropunused could also use PreferredContentChecked True, but haven't entirely thought it through and it's rarely used with enough files for the optimisation to matter. Sponsored-by: Dartmouth College's Datalad project
75 lines
2.8 KiB
Haskell
75 lines
2.8 KiB
Haskell
{- git-annex checking whether content is wanted
|
|
-
|
|
- Copyright 2012-2021 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
module Annex.Wanted where
|
|
|
|
import Annex.Common
|
|
import Logs.PreferredContent
|
|
import Annex.UUID
|
|
import Annex.CatFile
|
|
import Git.FilePath
|
|
import qualified Database.Keys
|
|
import Types.FileMatcher
|
|
|
|
import qualified Data.Set as S
|
|
|
|
{- Check if a file is preferred content for the local repository. -}
|
|
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 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 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
|
|
- may match some of those and not others. If any are preferred content,
|
|
- that will prevent dropping. When the other associated files are known,
|
|
- 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 =
|
|
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 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)
|
|
Nothing -> case key of
|
|
Just k ->
|
|
mapM (\f -> AssociatedFile . Just <$> fromRepo (fromTopFilePath f))
|
|
=<< Database.Keys.getAssociatedFiles k
|
|
Nothing -> pure []
|
|
l <- filterM checker' others'
|
|
if null l
|
|
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 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
|