c3d40b9ec3
Each command that first checks preferred content (and/or required content) and then does something that can change the sizes of repositories needs to call prepareLiveUpdate, and plumb it through the preferred content check and the location log update. So far, only Command.Drop is done. Many other commands that don't need to do this have been updated to keep working. There may be some calls to NoLiveUpdate in places where that should be done. All will need to be double checked. Not currently in a compilable state.
75 lines
2.9 KiB
Haskell
75 lines
2.9 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 :: LiveUpdate -> Bool -> Maybe Key -> AssociatedFile -> Annex Bool
|
|
wantGet lu d key file = isPreferredContent lu Nothing S.empty key file d
|
|
|
|
{- Check if a file is preferred content for a repository. -}
|
|
wantGetBy :: LiveUpdate -> Bool -> Maybe Key -> AssociatedFile -> UUID -> Annex Bool
|
|
wantGetBy lu d key file to = isPreferredContent lu (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 :: LiveUpdate -> Bool -> Maybe UUID -> Maybe Key -> AssociatedFile -> (Maybe [AssociatedFile]) -> Annex Bool
|
|
wantDrop lu d from key file others =
|
|
isNothing <$> checkDrop isPreferredContent lu 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 :: (LiveUpdate -> Maybe UUID -> AssumeNotPresent -> Maybe Key -> AssociatedFile -> Bool -> Annex Bool) -> LiveUpdate -> Bool -> Maybe UUID -> Maybe Key -> AssociatedFile -> (Maybe [AssociatedFile]) -> Annex (Maybe AssociatedFile)
|
|
checkDrop checker lu d from key file others = do
|
|
u <- maybe getUUID (pure . id) from
|
|
let s = S.singleton u
|
|
let checker' f = checker lu (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
|