git-annex info was displaying a message that didn't make sense in
context.
In calcRepoSizes, it seems better to return the information from the
git-annex branch, rather than giving up. Especially since balanced
preferred content uses it, and we can't just give up evaluating a
preferred content expression if git-annex is to be usable in such a
readonly repo.
Commit
6d7ecd9e5d1571d1dc7e59106f848abccdf7fd0e nobly wanted git-annex
to behave the same with such unmerged branches as it does when it can
merge them. But for the purposes of preferred content, it seems to me
there's a sense that such an unmerged branch is the same as a remote we
have not pulled from. The balanced preferred content will either way
operate under outdated information, and so make not the best choices.
{- management of the git-annex branch
-
- - Copyright 2011-2023 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2024 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
performTransitions,
withIndex,
precache,
+ UnmergedBranches(..),
overBranchFileContents,
updatedFromTree,
) where
inRepo $ Git.Branch.commitTree cmode
["graft cleanup"] [c] origtree
+{- UnmergedBranches is used to indicate when a value was calculated in a
+ - read-only repository that has other git-annex branches that have not
+ - been merged in. The value does not include information from those
+ - branches.
+ -}
+data UnmergedBranches t
+ = UnmergedBranches t
+ | NoUnmergedBranches t
+
{- Runs an action on the content of selected files from the branch.
- This is much faster than reading the content of each file in turn,
- because it lets git cat-file stream content without blocking.
- with different content. This happens rarely, only when the journal
- contains additional information, and the last version of the
- file it returns is the most current one.
- -
- - In a read-only repository that has other git-annex branches that have
- - not been merged in, returns Nothing, because it's not possible to
- - efficiently handle that.
-}
overBranchFileContents
:: (RawFilePath -> Maybe v)
-> (Annex (Maybe (v, RawFilePath, Maybe L.ByteString)) -> Annex a)
- -> Annex (Maybe a)
+ -> Annex (UnmergedBranches a)
overBranchFileContents select go = do
st <- update
- if not (null (unmergedRefs st))
- then return Nothing
- else Just <$> overBranchFileContents' select go st
+ v <- overBranchFileContents' select go st
+ return $ if not (null (unmergedRefs st))
+ then UnmergedBranches v
+ else NoUnmergedBranches v
overBranchFileContents'
:: (RawFilePath -> Maybe v)
module Annex.RepoSize where
import Annex.Common
+import Annex.Branch (UnmergedBranches(..))
import Types.RepoSize
import Logs.Location
import Logs.UUID
calcRepoSizes = do
knownuuids <- M.keys <$> uuidDescMap
let startmap = M.fromList $ map (\u -> (u, RepoSize 0)) knownuuids
- overLocationLogs startmap $ \k locs m ->
- return $
- let sz = fromMaybe 0 $ fromKey keySize k
- in foldl' (flip $ M.alter $ addksz sz) m locs
+ overLocationLogs startmap accum >>= \case
+ UnmergedBranches m -> return m
+ NoUnmergedBranches m -> return m
where
addksz ksz (Just (RepoSize sz)) = Just $ RepoSize $ sz + ksz
addksz ksz Nothing = Just $ RepoSize ksz
+ accum k locs m = return $
+ let sz = fromMaybe 0 $ fromKey keySize k
+ in foldl' (flip $ M.alter $ addksz sz) m locs
overLocationLogs' ()
(\reader cont -> checktimelimit (discard reader) cont)
(\k _ () -> keyaction Nothing (SeekInput [], k, mkActionItem k))
+ >>= \case
+ Annex.Branch.NoUnmergedBranches () -> return ()
+ Annex.Branch.UnmergedBranches () -> giveup "This repository is read-only, and there are unmerged git-annex branches, which prevents operating on all keys. (Set annex.merge-annex-branches to false to ignore the unmerged git-annex branches.)"
runkeyaction getks = do
keyaction <- mkkeyaction
import Logs.UUID
import Logs.Trust
import Logs.Location
+import Annex.Branch (UnmergedBranches(..))
import Annex.NumCopies
import Git.Config (boolConfig)
import qualified Git.LsTree as LsTree
Just _ -> return s
Nothing -> do
matcher <- lift getKeyOnlyMatcher
- !(d, rd) <- lift $ overLocationLogs (emptyKeyInfo, mempty) $ \k locs (d, rd) -> do
+ r <- lift $ overLocationLogs (emptyKeyInfo, mempty) $ \k locs (d, rd) -> do
ifM (matchOnKey matcher k)
( do
alivelocs <- snd
return (d', rd')
, return (d, rd)
)
- let s' = s { allRepoData = Just d, repoData = rd }
- put s'
- return s'
+ case r of
+ NoUnmergedBranches (!(d, rd)) -> do
+ let s' = s { allRepoData = Just d, repoData = rd }
+ put s'
+ return s'
+ UnmergedBranches _ -> do
+ lift $ warning "This repository is read-only, and there are unmerged git-annex branches. Information from those branches is not included here."
+ return s
where
accumrepodata k = M.alter (Just . addKey k . fromMaybe emptyKeyInfo)
-- is faster than diffing from the empty tree
-- and looking up every log file.
scanbranch = Annex.Branch.overBranchFileContents toscan goscan >>= \case
- Just () -> return ()
- Nothing -> scandiff
+ Annex.Branch.NoUnmergedBranches () -> return ()
+ Annex.Branch.UnmergedBranches () -> scandiff
toscan f
| isUrlLog f = Just ()
maxsizes <- getMaxSizes
-- XXX do not calc this every time!
sizemap <- calcRepoSizes
+ let keysize = fromMaybe 0 (fromKey keySize key)
let hasspace u = case (M.lookup u maxsizes, M.lookup u sizemap) of
(Just (MaxSize maxsize), Just (RepoSize reposize)) ->
- reposize + fromMaybe 0 (fromKey keySize key)
- <= maxsize
+ if maybe False (`S.member` notpresent) mu
+ then reposize <= maxsize
+ else reposize + keysize <= maxsize
_ -> True
let candidates = S.filter hasspace groupmembers
return $ if S.null candidates
return there
{- This is much faster than loggedKeys. -}
-overLocationLogs :: v -> (Key -> [UUID] -> v -> Annex v) -> Annex v
+overLocationLogs :: v -> (Key -> [UUID] -> v -> Annex v) -> Annex (Annex.Branch.UnmergedBranches v)
overLocationLogs v = overLocationLogs' v (flip const)
overLocationLogs'
:: v
-> (Annex (Maybe (Key, RawFilePath, Maybe L.ByteString)) -> Annex v -> Annex v)
-> (Key -> [UUID] -> v -> Annex v)
- -> Annex v
+ -> Annex (Annex.Branch.UnmergedBranches v)
overLocationLogs' iv discarder keyaction = do
config <- Annex.getGitConfig
clusters <- getClusters
-
+
let getk = locationLogFileKey config
let go v reader = reader >>= \case
Just (k, f, content) -> discarder reader $ do
)
Nothing -> return v
- Annex.Branch.overBranchFileContents getk (go iv) >>= \case
- Just r -> return r
- Nothing -> giveup "This repository is read-only, and there are unmerged git-annex branches, which prevents operating on all keys. (Set annex.merge-annex-branches to false to ignore the unmerged git-annex branches.)"
+ Annex.Branch.overBranchFileContents getk (go iv)
-- Cannot import Logs.Cluster due to a cycle.
-- Annex.clusters gets populated when starting up git-annex.
projects / git-annex.git / commitdiff