diff --git a/Annex.hs b/Annex.hs --- a/Annex.hs +++ b/Annex.hs @@ -1,6 +1,6 @@ {- git-annex monad - - - Copyright 2010-2021 Joey Hess + - Copyright 2010-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -75,9 +75,11 @@ import Types.TransferrerPool import Types.VectorClock import Types.Cluster +import Types.RepoSize import Annex.VectorClock.Utility import Annex.Debug.Utility import qualified Database.Keys.Handle as Keys +import Database.RepoSize.Handle import Utility.InodeCache import Utility.Url import Utility.ResourcePool @@ -131,6 +133,8 @@ , forcenumcopies :: Maybe NumCopies , forcemincopies :: Maybe MinCopies , forcebackend :: Maybe String + , reposizes :: MVar (Maybe (M.Map UUID (RepoSize, SizeOffset))) + , rebalance :: Bool , useragent :: Maybe String , desktopnotify :: DesktopNotify , gitcredentialcache :: TMVar CredentialCache @@ -147,6 +151,7 @@ tp <- newTransferrerPool cm <- newTMVarIO M.empty cc <- newTMVarIO (CredentialCache M.empty) + rs <- newMVar Nothing return $ AnnexRead { branchstate = bs , activekeys = emptyactivekeys @@ -164,6 +169,8 @@ , forcebackend = Nothing , forcenumcopies = Nothing , forcemincopies = Nothing + , reposizes = rs + , rebalance = False , useragent = Nothing , desktopnotify = mempty , gitcredentialcache = cc @@ -198,6 +205,7 @@ , requiredcontentmap :: Maybe (FileMatcherMap Annex) , remoteconfigmap :: Maybe (M.Map UUID RemoteConfig) , clusters :: Maybe (Annex Clusters) + , maxsizes :: Maybe (M.Map UUID MaxSize) , forcetrust :: TrustMap , trustmap :: Maybe TrustMap , groupmap :: Maybe GroupMap @@ -218,6 +226,7 @@ , insmudgecleanfilter :: Bool , getvectorclock :: IO CandidateVectorClock , proxyremote :: Maybe (Either ClusterUUID (Types.Remote.RemoteA Annex)) + , reposizehandle :: Maybe RepoSizeHandle } newAnnexState :: GitConfig -> Git.Repo -> IO AnnexState @@ -252,6 +261,7 @@ , requiredcontentmap = Nothing , remoteconfigmap = Nothing , clusters = Nothing + , maxsizes = Nothing , forcetrust = M.empty , trustmap = Nothing , groupmap = Nothing @@ -272,6 +282,7 @@ , insmudgecleanfilter = False , getvectorclock = vc , proxyremote = Nothing + , reposizehandle = Nothing } {- Makes an Annex state object for the specified git repo. diff --git a/Annex/Balanced.hs b/Annex/Balanced.hs new file mode 100644 --- /dev/null +++ b/Annex/Balanced.hs @@ -0,0 +1,47 @@ +{- Balancing between UUIDs + - + - Copyright 2024 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Annex.Balanced where + +import Key +import Types.UUID +import Utility.Hash + +import Data.List +import Data.Maybe +import Data.Bits (shiftL) +import qualified Data.Set as S +import qualified Data.ByteArray as BA + +-- The Int is how many UUIDs to pick. +type BalancedPicker = S.Set UUID -> Key -> Int -> [UUID] + +-- The set of UUIDs provided here are all the UUIDs that are ever +-- expected to be picked amoung. A subset of that can be provided +-- when later using the BalancedPicker. Neither set can be empty. +balancedPicker :: S.Set UUID -> BalancedPicker +balancedPicker s = \s' key num -> + let n = calcMac tointeger HmacSha256 combineduuids (serializeKey' key) + m = fromIntegral (S.size s') + in map (\i -> S.elemAt (fromIntegral ((n + i) `mod` m)) s') + [0..fromIntegral (num - 1)] + where + combineduuids = mconcat (map fromUUID (S.toAscList s)) + + tointeger :: Digest a -> Integer + tointeger = foldl' (\i b -> (i `shiftL` 8) + fromIntegral b) 0 + . BA.unpack + +{- The selection for a given key never changes. -} +prop_balanced_stable :: Bool +prop_balanced_stable = and + [ balancedPicker us us k 1 == [toUUID "332"] + , balancedPicker us us k 3 == [toUUID "332", toUUID "333", toUUID "334"] + ] + where + us = S.fromList $ map (toUUID . show) [1..500 :: Int] + k = fromJust $ deserializeKey "WORM--test" diff --git a/Annex/Branch.hs b/Annex/Branch.hs --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -1,6 +1,6 @@ {- management of the git-annex branch - - - Copyright 2011-2023 Joey Hess + - Copyright 2011-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -21,6 +21,7 @@ updateTo, get, getHistorical, + getRef, getUnmergedRefs, RegardingUUID(..), change, @@ -36,7 +37,11 @@ performTransitions, withIndex, precache, + UnmergedBranches(..), + FileContents, overBranchFileContents, + overJournalFileContents, + combineStaleJournalWithBranch, updatedFromTree, ) where @@ -122,7 +127,7 @@ create = void getBranch {- Returns the sha of the branch, creating it first if necessary. -} -getBranch :: Annex Git.Ref +getBranch :: Annex Git.Sha getBranch = maybe (hasOrigin >>= go >>= use) return =<< branchsha where go True = do @@ -405,15 +410,24 @@ change :: Journalable content => RegardingUUID -> RawFilePath -> (L.ByteString -> content) -> Annex () change ru file f = lockJournal $ \jl -> f <$> getToChange ru file >>= set jl ru file -{- Applies a function which can modify the content of a file, or not. -} -maybeChange :: Journalable content => RegardingUUID -> RawFilePath -> (L.ByteString -> Maybe content) -> Annex () -maybeChange ru file f = lockJournal $ \jl -> do +{- Applies a function which can modify the content of a file, or not. + - + - When the file was modified, runs the onchange action, and returns + - True. The action is run while the journal is still locked, + - so another concurrent call to this cannot happen while it is running. -} +maybeChange :: Journalable content => RegardingUUID -> RawFilePath -> (L.ByteString -> Maybe content) -> Annex () -> Annex Bool +maybeChange ru file f onchange = lockJournal $ \jl -> do v <- getToChange ru file case f v of Just jv -> let b = journalableByteString jv - in when (v /= b) $ set jl ru file b - _ -> noop + in if v /= b + then do + set jl ru file b + onchange + return True + else return False + _ -> return False data ChangeOrAppend t = Change t | Append t @@ -705,8 +719,8 @@ return (committedref /= branchref) {- Record that the branch's index has been updated to correspond to a - - given ref of the branch. -} -setIndexSha :: Git.Ref -> Annex () + - given sha of the branch. -} +setIndexSha :: Git.Sha -> Annex () setIndexSha ref = do f <- fromRepo gitAnnexIndexStatus writeLogFile f $ fromRef ref ++ "\n" @@ -977,6 +991,17 @@ 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 + +type FileContents t b = Maybe (t, RawFilePath, Maybe (L.ByteString, Maybe b)) + {- 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. @@ -985,60 +1010,60 @@ - the next file and its contents. When there are no more files, the - callback will return Nothing. - - - In some cases the callback may return the same file more than once, - - 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. + - Returns the accumulated result of the callback, as well as the sha of + - the branch at the point it was read. -} overBranchFileContents - :: (RawFilePath -> Maybe v) - -> (Annex (Maybe (v, RawFilePath, Maybe L.ByteString)) -> Annex a) - -> Annex (Maybe a) -overBranchFileContents select go = do + :: Bool + -- ^ Should files in the journal be ignored? When False, + -- the content of journalled files is combined with files in the + -- git-annex branch. And also, at the end, the callback is run + -- on each journalled file, in case some journalled files are new + -- files that do not yet appear in the branch. Note that this means + -- the callback can be run more than once on the same filename, + -- and in this case it's also possible for the callback to be + -- passed some of the same file content repeatedly. + -> (RawFilePath -> Maybe v) + -> (Annex (FileContents v Bool) -> Annex a) + -> Annex (UnmergedBranches (a, Git.Sha)) +overBranchFileContents ignorejournal select go = do st <- update - if not (null (unmergedRefs st)) - then return Nothing - else Just <$> overBranchFileContents' select go st + let st' = if ignorejournal + then st { journalIgnorable = True } + else st + v <- overBranchFileContents' select go st' + return $ if not (null (unmergedRefs st)) + then UnmergedBranches v + else NoUnmergedBranches v overBranchFileContents' :: (RawFilePath -> Maybe v) - -> (Annex (Maybe (v, RawFilePath, Maybe L.ByteString)) -> Annex a) + -> (Annex (FileContents v Bool) -> Annex a) -> BranchState - -> Annex a + -> Annex (a, Git.Sha) overBranchFileContents' select go st = do g <- Annex.gitRepo + branchsha <- getBranch (l, cleanup) <- inRepo $ Git.LsTree.lsTree Git.LsTree.LsTreeRecursive (Git.LsTree.LsTreeLong False) - fullname + branchsha let select' f = fmap (\v -> (v, f)) (select f) buf <- liftIO newEmptyMVar let go' reader = go $ liftIO reader >>= \case Just ((v, f), content) -> do - content' <- checkjournal f content + content' <- checkjournal f content >>= return . \case + Nothing -> Nothing + Just c -> Just (c, Just False) return (Just (v, f, content')) Nothing | journalIgnorable st -> return Nothing - -- The journal did not get committed to the - -- branch, and may contain files that - -- are not present in the branch, which - -- need to be provided to the action still. - -- This can cause the action to be run a - -- second time with a file it already ran on. - | otherwise -> liftIO (tryTakeMVar buf) >>= \case - Nothing -> do - jfs <- journalledFiles - pjfs <- journalledFilesPrivate - drain buf jfs pjfs - Just (jfs, pjfs) -> drain buf jfs pjfs - catObjectStreamLsTree l (select' . getTopFilePath . Git.LsTree.file) g go' + | otherwise -> + overJournalFileContents' buf (handlestale branchsha) select + res <- catObjectStreamLsTree l (select' . getTopFilePath . Git.LsTree.file) g go' `finally` liftIO (void cleanup) + return (res, branchsha) where - -- Check the journal, in case it did not get committed to the branch checkjournal f branchcontent | journalIgnorable st = return branchcontent | otherwise = getJournalFileStale (GetPrivate True) f >>= return . \case @@ -1047,20 +1072,54 @@ Just journalledcontent PossiblyStaleJournalledContent journalledcontent -> Just (fromMaybe mempty branchcontent <> journalledcontent) - - drain buf fs pfs = case getnext fs pfs of + + handlestale branchsha f journalledcontent = do + -- This is expensive, but happens only when there is a + -- private journal file. + branchcontent <- getRef branchsha f + return (combineStaleJournalWithBranch branchcontent journalledcontent, Just True) + +combineStaleJournalWithBranch :: L.ByteString -> L.ByteString -> L.ByteString +combineStaleJournalWithBranch branchcontent journalledcontent = + branchcontent <> journalledcontent + +{- Like overBranchFileContents but only reads the content of journalled + - files. + -} +overJournalFileContents + :: (RawFilePath -> L.ByteString -> Annex (L.ByteString, Maybe b)) + -- ^ Called with the journalled file content when the journalled + -- content may be stale or lack information committed to the + -- git-annex branch. + -> (RawFilePath -> Maybe v) + -> (Annex (FileContents v b) -> Annex a) + -> Annex a +overJournalFileContents handlestale select go = do + buf <- liftIO newEmptyMVar + go $ overJournalFileContents' buf handlestale select + +overJournalFileContents' + :: MVar ([RawFilePath], [RawFilePath]) + -> (RawFilePath -> L.ByteString -> Annex (L.ByteString, Maybe b)) + -> (RawFilePath -> Maybe a) + -> Annex (FileContents a b) +overJournalFileContents' buf handlestale select = + liftIO (tryTakeMVar buf) >>= \case + Nothing -> do + jfs <- journalledFiles + pjfs <- journalledFilesPrivate + drain jfs pjfs + Just (jfs, pjfs) -> drain jfs pjfs + where + drain fs pfs = case getnext fs pfs of Just (v, f, fs', pfs') -> do liftIO $ putMVar buf (fs', pfs') content <- getJournalFileStale (GetPrivate True) f >>= \case NoJournalledContent -> return Nothing JournalledContent journalledcontent -> - return (Just journalledcontent) - PossiblyStaleJournalledContent journalledcontent -> do - -- This is expensive, but happens - -- only when there is a private - -- journal file. - content <- getRef fullname f - return (Just (content <> journalledcontent)) + return (Just (journalledcontent, Nothing)) + PossiblyStaleJournalledContent journalledcontent -> + Just <$> handlestale f journalledcontent return (Just (v, f, content)) Nothing -> do liftIO $ putMVar buf ([], []) diff --git a/Annex/Cluster.hs b/Annex/Cluster.hs --- a/Annex/Cluster.hs +++ b/Annex/Cluster.hs @@ -5,7 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE RankNTypes, OverloadedStrings #-} +{-# LANGUAGE RankNTypes, OverloadedStrings, TupleSections #-} module Annex.Cluster where @@ -19,6 +19,7 @@ import Annex.Proxy import Annex.UUID import Annex.BranchState +import Annex.RepoSize.LiveUpdate import Logs.Location import Logs.PreferredContent import Types.Command @@ -108,7 +109,15 @@ , proxyPUT = \af k -> do locs <- S.fromList <$> loggedLocations k let l = filter (flip S.notMember locs . Remote.uuid . remote) nodes - l' <- filterM (\n -> isPreferredContent (Just (Remote.uuid (remote n))) mempty (Just k) af True) l + let checkpreferred n = do + let u = Just (Remote.uuid (remote n)) + lu <- prepareLiveUpdate u k AddingKey + ifM (isPreferredContent lu u mempty (Just k) af True) + ( return $ Just $ n + { remoteLiveUpdate = lu } + , return Nothing + ) + l' <- catMaybes <$> mapM checkpreferred l -- PUT to no nodes doesn't work, so fall -- back to all nodes. return $ nonempty [l', l] nodes diff --git a/Annex/Common.hs b/Annex/Common.hs --- a/Annex/Common.hs +++ b/Annex/Common.hs @@ -11,6 +11,7 @@ import Annex.Debug as X (fastDebug, debug) import Messages as X import Git.Quote as X +import Types.RepoSize as X #ifndef mingw32_HOST_OS import System.Posix.IO as X hiding (createPipe, append) #endif diff --git a/Annex/Content.hs b/Annex/Content.hs --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -788,7 +788,7 @@ createAnnexDirectory (parentDir dest) cleanObjectLoc key $ liftIO $ moveFile src dest - logStatus key InfoMissing + logStatus NoLiveUpdate key InfoMissing return dest data KeyLocation = InAnnex | InAnywhere diff --git a/Annex/Drop.hs b/Annex/Drop.hs --- a/Annex/Drop.hs +++ b/Annex/Drop.hs @@ -29,9 +29,9 @@ - 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, - - which don't allow dropping individual keys, and from thirdPartyPopulated - - remotes. + - would presumably fail. Also skips dropping from exporttree/importtree + - remotes, which don't allow dropping individual keys, and from + - thirdPartyPopulated remotes. - - The UUIDs are ones where the content is believed to be present. - The Remote list can include other remotes that do not have the content; @@ -92,11 +92,12 @@ dropr fs r n >>= go fs rest | otherwise = pure n - checkdrop fs n u a = + checkdrop fs n u a = do 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 pcc) + let pcc = Command.Drop.PreferredContentChecked True + lu <- prepareLiveUpdate u key RemovingKey + ifM (wantDrop lu True u (Just key) afile (Just afs)) + ( dodrop n u (a lu pcc) , return n ) @@ -116,12 +117,16 @@ , return n ) - dropl fs n = checkdrop fs n Nothing $ \pcc numcopies mincopies -> + dropl fs n = checkdrop fs n Nothing $ \lu pcc numcopies mincopies -> stopUnless (inAnnex key) $ - Command.Drop.startLocal pcc afile ai si numcopies mincopies key preverified (Command.Drop.DroppingUnused False) + Command.Drop.startLocal lu pcc afile ai si + numcopies mincopies key preverified + (Command.Drop.DroppingUnused False) - dropr fs r n = checkdrop fs n (Just $ Remote.uuid r) $ \pcc numcopies mincopies -> - Command.Drop.startRemote pcc afile ai si numcopies mincopies key (Command.Drop.DroppingUnused False) r + dropr fs r n = checkdrop fs n (Just $ Remote.uuid r) $ \lu pcc numcopies mincopies -> + Command.Drop.startRemote lu pcc afile ai si + numcopies mincopies key + (Command.Drop.DroppingUnused False) r ai = mkActionItem (key, afile) diff --git a/Annex/FileMatcher.hs b/Annex/FileMatcher.hs --- a/Annex/FileMatcher.hs +++ b/Annex/FileMatcher.hs @@ -1,6 +1,6 @@ {- git-annex file matching - - - Copyright 2012-2023 Joey Hess + - Copyright 2012-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -42,6 +42,7 @@ import Types.Remote (RemoteConfig) import Types.ProposedAccepted import Annex.CheckAttr +import Annex.RepoSize.LiveUpdate import qualified Git.Config #ifdef WITH_MAGICMIME import Annex.Magic @@ -53,22 +54,22 @@ type GetFileMatcher = RawFilePath -> Annex (FileMatcher Annex) -checkFileMatcher :: GetFileMatcher -> RawFilePath -> Annex Bool -checkFileMatcher getmatcher file = - checkFileMatcher' getmatcher file (return True) +checkFileMatcher :: LiveUpdate -> GetFileMatcher -> RawFilePath -> Annex Bool +checkFileMatcher lu getmatcher file = + checkFileMatcher' lu getmatcher file (return True) -- | Allows running an action when no matcher is configured for the file. -checkFileMatcher' :: GetFileMatcher -> RawFilePath -> Annex Bool -> Annex Bool -checkFileMatcher' getmatcher file notconfigured = do +checkFileMatcher' :: LiveUpdate -> GetFileMatcher -> RawFilePath -> Annex Bool -> Annex Bool +checkFileMatcher' lu getmatcher file notconfigured = do matcher <- getmatcher file - checkMatcher matcher Nothing afile S.empty notconfigured d + checkMatcher matcher Nothing afile lu S.empty notconfigured d where afile = AssociatedFile (Just file) -- checkMatcher will never use this, because afile is provided. d = return True -checkMatcher :: FileMatcher Annex -> Maybe Key -> AssociatedFile -> AssumeNotPresent -> Annex Bool -> Annex Bool -> Annex Bool -checkMatcher matcher mkey afile notpresent notconfigured d +checkMatcher :: FileMatcher Annex -> Maybe Key -> AssociatedFile -> LiveUpdate -> AssumeNotPresent -> Annex Bool -> Annex Bool -> Annex Bool +checkMatcher matcher mkey afile lu notpresent notconfigured d | isEmpty (fst matcher) = notconfigured | otherwise = case (mkey, afile) of (_, AssociatedFile (Just file)) -> @@ -85,16 +86,19 @@ in go (MatchingInfo i) (Nothing, _) -> d where - go mi = checkMatcher' matcher mi notpresent + go mi = checkMatcher' matcher mi lu notpresent -checkMatcher' :: FileMatcher Annex -> MatchInfo -> AssumeNotPresent -> Annex Bool -checkMatcher' (matcher, (MatcherDesc matcherdesc)) mi notpresent = do - (matches, desc) <- runWriterT $ matchMrun' matcher $ \op -> - matchAction op notpresent mi - explain (mkActionItem mi) $ UnquotedString <$> - describeMatchResult matchDesc desc - ((if matches then "matches " else "does not match ") ++ matcherdesc ++ ": ") - return matches +checkMatcher' :: FileMatcher Annex -> MatchInfo -> LiveUpdate -> AssumeNotPresent -> Annex Bool +checkMatcher' (matcher, (MatcherDesc matcherdesc)) mi lu notpresent = + checkLiveUpdate lu matcher go + where + go = do + (matches, desc) <- runWriterT $ matchMrun' matcher $ \op -> + matchAction op lu notpresent mi + explain (mkActionItem mi) $ UnquotedString <$> + describeMatchResult matchDesc desc + ((if matches then "matches " else "does not match ") ++ matcherdesc ++ ": ") + return matches fileMatchInfo :: RawFilePath -> Maybe Key -> Annex MatchInfo fileMatchInfo file mkey = do @@ -171,6 +175,10 @@ , ValueToken "metadata" (usev limitMetaData) , ValueToken "inallgroup" (usev $ limitInAllGroup $ getGroupMap pcd) , ValueToken "onlyingroup" (usev $ limitOnlyInGroup $ getGroupMap pcd) + , ValueToken "balanced" (usev $ limitBalanced (repoUUID pcd) (getGroupMap pcd)) + , ValueToken "fullybalanced" (usev $ limitFullyBalanced (repoUUID pcd) (getGroupMap pcd)) + , ValueToken "sizebalanced" (usev $ limitSizeBalanced (repoUUID pcd) (getGroupMap pcd)) + , ValueToken "fullysizebalanced" (usev $ limitFullySizeBalanced (repoUUID pcd) (getGroupMap pcd)) ] ++ commonTokens LimitAnnexFiles where preferreddir = maybe "public" fromProposedAccepted $ @@ -255,9 +263,9 @@ matchalways True = return (MOp limitAnything, matcherdesc) matchalways False = return (MOp limitNothing, matcherdesc) -checkAddUnlockedMatcher :: AddUnlockedMatcher -> MatchInfo -> Annex Bool -checkAddUnlockedMatcher (AddUnlockedMatcher matcher) mi = - checkMatcher' matcher mi S.empty +checkAddUnlockedMatcher :: LiveUpdate -> AddUnlockedMatcher -> MatchInfo -> Annex Bool +checkAddUnlockedMatcher lu (AddUnlockedMatcher matcher) mi = + checkMatcher' matcher mi lu S.empty simply :: MatchFiles Annex -> ParseResult (MatchFiles Annex) simply = Right . Operation @@ -267,12 +275,13 @@ call :: String -> Either String (Matcher (MatchFiles Annex)) -> ParseResult (MatchFiles Annex) call desc (Right sub) = Right $ Operation $ MatchFiles - { matchAction = \notpresent mi -> - matchMrun sub $ \o -> matchAction o notpresent mi + { matchAction = \lu notpresent mi -> + matchMrun sub $ \o -> matchAction o lu notpresent mi , matchNeedsFileName = any matchNeedsFileName sub , matchNeedsFileContent = any matchNeedsFileContent sub , matchNeedsKey = any matchNeedsKey sub , matchNeedsLocationLog = any matchNeedsLocationLog sub + , matchNeedsLiveRepoSize = any matchNeedsLiveRepoSize sub , matchDesc = matchDescSimple desc } call _ (Left err) = Left err diff --git a/Annex/Import.hs b/Annex/Import.hs --- a/Annex/Import.hs +++ b/Annex/Import.hs @@ -44,6 +44,7 @@ import Annex.CheckIgnore import Annex.CatFile import Annex.VectorClock +import Annex.SpecialRemote.Config import Command import Backend import Types.Key @@ -190,11 +191,11 @@ let updater db moldkey _newkey _ = case moldkey of Just oldkey | not (isGitShaKey oldkey) -> unlessM (stillpresent db oldkey) $ - logChange oldkey (Remote.uuid remote) InfoMissing + logChange NoLiveUpdate oldkey (Remote.uuid remote) InfoMissing _ -> noop -- When the remote is versioned, it still contains keys -- that are not present in the new tree. - unless (Remote.versionedExport (Remote.exportActions remote)) $ do + unless (isVersioning (Remote.config remote)) $ do db <- Export.openDb (Remote.uuid remote) forM_ (exportedTreeishes oldexport) $ \oldtree -> Export.runExportDiffUpdater updater db oldtree finaltree @@ -762,7 +763,7 @@ tryNonAsync (importkey loc cid sz nullMeterUpdate) >>= \case Right (Just k) -> do recordcidkeyindb db cid k - logChange k (Remote.uuid remote) InfoPresent + logChange NoLiveUpdate k (Remote.uuid remote) InfoPresent return $ Just (loc, Right k) Right Nothing -> return Nothing Left e -> do @@ -798,7 +799,7 @@ , providedMimeEncoding = Nothing , providedLinkType = Nothing } - islargefile <- checkMatcher' matcher mi mempty + islargefile <- checkMatcher' matcher mi NoLiveUpdate mempty metered Nothing sz bwlimit $ const $ if islargefile then doimportlarge importkey cidmap loc cid sz f else doimportsmall cidmap loc cid sz @@ -822,7 +823,7 @@ Just k -> checkSecureHashes k >>= \case Nothing -> do recordcidkey cidmap cid k - logChange k (Remote.uuid remote) InfoPresent + logChange NoLiveUpdate k (Remote.uuid remote) InfoPresent if importcontent then getcontent k else return (Just (k, True)) @@ -838,7 +839,7 @@ (combineMeterUpdate p' p) ok <- moveAnnex k af tmpfile when ok $ - logStatus k InfoPresent + logStatus NoLiveUpdate k InfoPresent return (Just (k, ok)) checkDiskSpaceToGet k Nothing Nothing $ notifyTransfer Download af $ @@ -882,8 +883,8 @@ ok <- moveAnnex k af tmpfile when ok $ do recordcidkey cidmap cid k - logStatus k InfoPresent - logChange k (Remote.uuid remote) InfoPresent + logStatus NoLiveUpdate k InfoPresent + logChange NoLiveUpdate k (Remote.uuid remote) InfoPresent return (Right k, ok) Just sha -> do recordcidkey cidmap cid k @@ -909,7 +910,7 @@ , contentFile = tmpfile , matchKey = Nothing } - islargefile <- checkMatcher' matcher mi mempty + islargefile <- checkMatcher' matcher mi NoLiveUpdate mempty if islargefile then do backend <- chooseBackend f @@ -1084,7 +1085,7 @@ not . null <$> Export.getExportTreeKey dbhandle loc matchesImportLocation :: FileMatcher Annex -> ImportLocation -> Integer -> Annex Bool -matchesImportLocation matcher loc sz = checkMatcher' matcher mi mempty +matchesImportLocation matcher loc sz = checkMatcher' matcher mi NoLiveUpdate mempty where mi = MatchingInfo $ ProvidedInfo { providedFilePath = Just (fromImportLocation loc) diff --git a/Annex/Ingest.hs b/Annex/Ingest.hs --- a/Annex/Ingest.hs +++ b/Annex/Ingest.hs @@ -288,7 +288,7 @@ (f:_) -> do ic <- withTSDelta (liftIO . genInodeCache f) void $ linkToAnnex key f ic - _ -> logStatus key InfoMissing + _ -> logStatus NoLiveUpdate key InfoMissing {- On error, put the file back so it doesn't seem to have vanished. - This can be called before or after the symlink is in place. -} @@ -349,7 +349,7 @@ addUnlocked :: AddUnlockedMatcher -> MatchInfo -> Bool -> Annex Bool addUnlocked matcher mi contentpresent = ((not . coreSymlinks <$> Annex.getGitConfig) <||> - (checkAddUnlockedMatcher matcher mi) <||> + (checkAddUnlockedMatcher NoLiveUpdate matcher mi) <||> (maybe False go . snd <$> getCurrentBranch) ) where diff --git a/Annex/Locations.hs b/Annex/Locations.hs --- a/Annex/Locations.hs +++ b/Annex/Locations.hs @@ -27,6 +27,8 @@ gitAnnexInodeSentinalCache, annexLocationsBare, annexLocationsNonBare, + annexLocation, + exportAnnexObjectLocation, gitAnnexDir, gitAnnexObjectDir, gitAnnexTmpOtherDir, @@ -73,6 +75,9 @@ gitAnnexContentIdentifierLock, gitAnnexImportFeedDbDir, gitAnnexImportFeedDbLock, + gitAnnexRepoSizeDbDir, + gitAnnexRepoSizeDbLock, + gitAnnexRepoSizeLiveDir, gitAnnexScheduleState, gitAnnexTransferDir, gitAnnexCredsDir, @@ -121,6 +126,7 @@ import Types.GitConfig import Types.Difference import Types.BranchState +import Types.Export import qualified Git import qualified Git.Types as Git import Git.FilePath @@ -152,8 +158,8 @@ objectDir = P.addTrailingPathSeparator $ annexDir P. "objects" {- Annexed file's possible locations relative to the .git directory - - in a non-bare repository. - - + - in a non-bare eepository. + - - Normally it is hashDirMixed. However, it's always possible that a - bare repository was converted to non-bare, or that the cripped - filesystem setting changed, so still need to check both. -} @@ -169,6 +175,13 @@ annexLocation :: GitConfig -> Key -> (HashLevels -> Hasher) -> RawFilePath annexLocation config key hasher = objectDir P. keyPath key (hasher $ objectHashLevels config) +{- For exportree remotes with annexobjects=true, objects are stored + - in this location as well as in the exported tree. -} +exportAnnexObjectLocation :: GitConfig -> Key -> ExportLocation +exportAnnexObjectLocation gc k = + mkExportLocation $ + ".git" P. annexLocation gc k hashDirLower + {- Number of subdirectories from the gitAnnexObjectDir - to the gitAnnexLocation. -} gitAnnexLocationDepth :: GitConfig -> Int @@ -505,6 +518,21 @@ gitAnnexImportFeedDbLock :: Git.Repo -> GitConfig -> RawFilePath gitAnnexImportFeedDbLock r c = gitAnnexImportFeedDbDir r c <> ".lck" +{- Directory containing reposize database. -} +gitAnnexRepoSizeDbDir :: Git.Repo -> GitConfig -> RawFilePath +gitAnnexRepoSizeDbDir r c = + fromMaybe (gitAnnexDir r) (annexDbDir c) P. "reposize" P. "db" + +{- Lock file for the reposize database. -} +gitAnnexRepoSizeDbLock :: Git.Repo -> GitConfig -> RawFilePath +gitAnnexRepoSizeDbLock r c = + fromMaybe (gitAnnexDir r) (annexDbDir c) P. "reposize" P. "lock" + +{- Directory containing liveness pid files. -} +gitAnnexRepoSizeLiveDir :: Git.Repo -> GitConfig -> RawFilePath +gitAnnexRepoSizeLiveDir r c = + fromMaybe (gitAnnexDir r) (annexDbDir c) P. "reposize" P. "live" + {- .git/annex/schedulestate is used to store information about when - scheduled jobs were last run. -} gitAnnexScheduleState :: Git.Repo -> RawFilePath @@ -576,7 +604,7 @@ gitAnnexPrivateIndex :: Git.Repo -> RawFilePath gitAnnexPrivateIndex r = gitAnnexDir r P. "index-private" -{- Holds the ref of the git-annex branch that the index was last updated to. +{- Holds the sha of the git-annex branch that the index was last updated to. - - The .lck in the name is a historical accident; this is not used as a - lock. -} diff --git a/Annex/LockFile.hs b/Annex/LockFile.hs --- a/Annex/LockFile.hs +++ b/Annex/LockFile.hs @@ -1,6 +1,6 @@ {- git-annex lock files. - - - Copyright 2012-2020 Joey Hess + - Copyright 2012-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -16,6 +16,7 @@ withExclusiveLock, takeExclusiveLock, tryExclusiveLock, + trySharedLock, ) where import Annex.Common @@ -111,3 +112,16 @@ unlock = maybe noop dropLock go Nothing = return Nothing go (Just _) = Just <$> a + +{- Tries to take a shared lock, without blocking. + - + - Does not create the lock directory or lock file if it does not exist, + - taking an exclusive lock will create them. + -} +trySharedLock :: RawFilePath -> Annex (Maybe LockHandle) +trySharedLock lockfile = debugLocks $ +#ifndef mingw32_HOST_OS + tryLockShared Nothing lockfile +#else + liftIO $ lockShared lockfile +#endif diff --git a/Annex/Proxy.hs b/Annex/Proxy.hs --- a/Annex/Proxy.hs +++ b/Annex/Proxy.hs @@ -19,12 +19,15 @@ import Annex.Concurrent import Annex.Tmp import Annex.Verify +import Annex.UUID import Logs.Proxy import Logs.Cluster import Logs.UUID import Logs.Location import Utility.Tmp.Dir import Utility.Metered +import Git.Types +import qualified Database.Export as Export import Control.Concurrent.STM import Control.Concurrent.Async @@ -63,8 +66,12 @@ owaitv <- liftIO newEmptyTMVarIO iclosedv <- liftIO newEmptyTMVarIO oclosedv <- liftIO newEmptyTMVarIO + exportdb <- ifM (Remote.isExportSupported r) + ( Just <$> Export.openDb (Remote.uuid r) + , pure Nothing + ) worker <- liftIO . async =<< forkState - (proxySpecialRemote protoversion r ihdl ohdl owaitv oclosedv) + (proxySpecialRemote protoversion r ihdl ohdl owaitv oclosedv exportdb) let remoteconn = P2PConnection { connRepo = Nothing , connCheckAuth = const False @@ -75,6 +82,7 @@ let closeremoteconn = do liftIO $ atomically $ putTMVar oclosedv () join $ liftIO (wait worker) + maybe noop Export.closeDb exportdb return $ Just ( remoterunst , remoteconn @@ -89,8 +97,9 @@ -> TMVar (Either L.ByteString Message) -> TMVar () -> TMVar () + -> Maybe Export.ExportHandle -> Annex () -proxySpecialRemote protoversion r ihdl ohdl owaitv oclosedv = go +proxySpecialRemote protoversion r ihdl ohdl owaitv oclosedv mexportdb = go where go :: Annex () go = liftIO receivemessage >>= \case @@ -167,7 +176,7 @@ proxyput af k = do liftIO $ sendmessage $ PUT_FROM (Offset 0) withproxytmpfile k $ \tmpfile -> do - let store = tryNonAsync (Remote.storeKey r k af (Just (decodeBS tmpfile)) nullMeterUpdate) >>= \case + let store = tryNonAsync (storeput k af (decodeBS tmpfile)) >>= \case Right () -> liftIO $ sendmessage SUCCESS Left err -> liftIO $ propagateerror err liftIO receivemessage >>= \case @@ -191,6 +200,25 @@ _ -> giveup "protocol error" liftIO $ removeWhenExistsWith removeFile (fromRawFilePath tmpfile) + storeput k af tmpfile = case mexportdb of + Just exportdb -> liftIO (Export.getExportTree exportdb k) >>= \case + [] -> storeputkey k af tmpfile + locs -> do + havelocs <- liftIO $ S.fromList + <$> Export.getExportedLocation exportdb k + let locs' = filter (`S.notMember` havelocs) locs + forM_ locs' $ \loc -> + storeputexport exportdb k loc tmpfile + liftIO $ Export.flushDbQueue exportdb + Nothing -> storeputkey k af tmpfile + + storeputkey k af tmpfile = + Remote.storeKey r k af (Just tmpfile) nullMeterUpdate + + storeputexport exportdb k loc tmpfile = do + Remote.storeExport (Remote.exportActions r) tmpfile k loc nullMeterUpdate + liftIO $ Export.addExportedLocation exportdb k loc + receivetofile iv h n = liftIO receivebytestring >>= \case Just b -> do liftIO $ atomically $ @@ -248,9 +276,9 @@ {- Check if this repository can proxy for a specified remote uuid, - and if so enable proxying for it. -} checkCanProxy :: UUID -> UUID -> Annex Bool -checkCanProxy remoteuuid ouruuid = do - ourproxies <- M.lookup ouruuid <$> getProxies - checkCanProxy' ourproxies remoteuuid >>= \case +checkCanProxy remoteuuid myuuid = do + myproxies <- M.lookup myuuid <$> getProxies + checkCanProxy' myproxies remoteuuid >>= \case Right v -> do Annex.changeState $ \st -> st { Annex.proxyremote = Just v } return True @@ -266,32 +294,12 @@ Just cu -> proxyforcluster cu Nothing -> proxyfor ps where - -- This repository may have multiple remotes that access the same - -- repository. Proxy for the lowest cost one that is configured to - -- be used as a proxy. proxyfor ps = do rs <- concat . Remote.byCost <$> Remote.remoteList myclusters <- annexClusters <$> Annex.getGitConfig - let sameuuid r = Remote.uuid r == remoteuuid - let samename r p = Remote.name r == proxyRemoteName p - case headMaybe (filter (\r -> sameuuid r && proxyisconfigured rs myclusters r && any (samename r) ps) rs) of + case canProxyForRemote rs ps myclusters remoteuuid of Nothing -> notconfigured Just r -> return (Right (Right r)) - - -- Only proxy for a remote when the git configuration - -- allows it. This is important to prevent changes to - -- the git-annex branch causing unexpected proxying for remotes. - proxyisconfigured rs myclusters r - | remoteAnnexProxy (Remote.gitconfig r) = True - -- Proxy for remotes that are configured as cluster nodes. - | any (`M.member` myclusters) (fromMaybe [] $ remoteAnnexClusterNode $ Remote.gitconfig r) = True - -- Proxy for a remote when it is proxied by another remote - -- which is itself configured as a cluster gateway. - | otherwise = case remoteAnnexProxiedBy (Remote.gitconfig r) of - Just proxyuuid -> not $ null $ - concatMap (remoteAnnexClusterGateway . Remote.gitconfig) $ - filter (\p -> Remote.uuid p == proxyuuid) rs - Nothing -> False proxyforcluster cu = do clusters <- getClusters @@ -304,8 +312,59 @@ "not configured to proxy for repository " ++ fromUUIDDesc desc Nothing -> return $ Left Nothing +{- Remotes that this repository is configured to proxy for. + - + - When there are multiple remotes that access the same repository, + - this picks the lowest cost one that is configured to be used as a proxy. + -} +proxyForRemotes :: Annex [Remote] +proxyForRemotes = do + myuuid <- getUUID + (M.lookup myuuid <$> getProxies) >>= \case + Nothing -> return [] + Just myproxies -> do + let myproxies' = S.toList myproxies + rs <- concat . Remote.byCost <$> Remote.remoteList + myclusters <- annexClusters <$> Annex.getGitConfig + return $ mapMaybe (canProxyForRemote rs myproxies' myclusters . Remote.uuid) rs + +-- Only proxy for a remote when the git configuration allows it. +-- This is important to prevent changes to the git-annex branch +-- causing unexpected proxying for remotes. +canProxyForRemote + :: [Remote] -- ^ must be sorted by cost + -> [Proxy] + -> M.Map RemoteName ClusterUUID + -> UUID + -> (Maybe Remote) +canProxyForRemote rs myproxies myclusters remoteuuid = + headMaybe $ filter canproxy rs + where + canproxy r = + sameuuid r && + proxyisconfigured r && + any (isproxyfor r) myproxies + + sameuuid r = Remote.uuid r == remoteuuid + + isproxyfor r p = + proxyRemoteUUID p == remoteuuid && + Remote.name r == proxyRemoteName p + + proxyisconfigured r + | remoteAnnexProxy (Remote.gitconfig r) = True + -- Proxy for remotes that are configured as cluster nodes. + | any (`M.member` myclusters) (fromMaybe [] $ remoteAnnexClusterNode $ Remote.gitconfig r) = True + -- Proxy for a remote when it is proxied by another remote + -- which is itself configured as a cluster gateway. + | otherwise = case remoteAnnexProxiedBy (Remote.gitconfig r) of + Just proxyuuid -> not $ null $ + concatMap (remoteAnnexClusterGateway . Remote.gitconfig) $ + filter (\p -> Remote.uuid p == proxyuuid) rs + Nothing -> False + mkProxyMethods :: ProxyMethods mkProxyMethods = ProxyMethods - { removedContent = \u k -> logChange k u InfoMissing - , addedContent = \u k -> logChange k u InfoPresent + { removedContent = \lu u k -> logChange lu k u InfoMissing + , addedContent = \lu u k -> logChange lu k u InfoPresent } diff --git a/Annex/RepoSize.hs b/Annex/RepoSize.hs new file mode 100644 --- /dev/null +++ b/Annex/RepoSize.hs @@ -0,0 +1,230 @@ +{- git-annex repo sizes + - + - Copyright 2024 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE OverloadedStrings, BangPatterns #-} + +module Annex.RepoSize ( + getRepoSizes, + getLiveRepoSizes, +) where + +import Annex.Common +import qualified Annex +import Annex.Branch (UnmergedBranches(..), getBranch) +import qualified Database.RepoSize as Db +import Annex.Journal +import Annex.RepoSize.LiveUpdate +import Logs +import Logs.Location +import Logs.UUID +import Git.Types (Sha) +import Git.FilePath +import Git.CatFile +import qualified Git.DiffTree as DiffTree + +import Control.Concurrent +import Control.Concurrent.Async +import qualified Data.Map.Strict as M +import qualified Data.Set as S + +{- Gets the repo size map. Cached for speed. + - + - Note that this is the size of all repositories as of the first time it + - was called. It does not update while git-annex is running. + -} +getRepoSizes :: Bool -> Annex (M.Map UUID RepoSize) +getRepoSizes quiet = M.map fst <$> getRepoSizes' quiet + +getRepoSizes' :: Bool -> Annex (M.Map UUID (RepoSize, SizeOffset)) +getRepoSizes' quiet = do + rsv <- Annex.getRead Annex.reposizes + liftIO (takeMVar rsv) >>= \case + Just sizemap -> do + liftIO $ putMVar rsv (Just sizemap) + return sizemap + Nothing -> calcRepoSizes quiet rsv + +{- Like getRepoSizes, but with live updates. -} +getLiveRepoSizes :: Bool -> Annex (M.Map UUID RepoSize) +getLiveRepoSizes quiet = do + sizemap <- getRepoSizes' quiet + go sizemap `onException` return (M.map fst sizemap) + where + go sizemap = do + h <- Db.getRepoSizeHandle + checkStaleSizeChanges h + liveoffsets <- liftIO $ Db.liveRepoOffsets h wantlivesizechange + let calc u (RepoSize size, SizeOffset startoffset) = + case M.lookup u liveoffsets of + Nothing -> RepoSize size + Just (SizeOffset offset) -> RepoSize $ + size + (offset - startoffset) + return $ M.mapWithKey calc sizemap + + -- When a live update is in progress, only count it + -- when it makes a repository larger. Better to err on the side + -- of repositories being too large than assume that drops will + -- always succeed. + wantlivesizechange AddingKey = True + wantlivesizechange RemovingKey = False + +{- Fills an empty Annex.reposizes MVar with current information + - from the git-annex branch, supplimented with journalled but + - not yet committed information. + -} +calcRepoSizes :: Bool -> MVar (Maybe (M.Map UUID (RepoSize, SizeOffset))) -> Annex (M.Map UUID (RepoSize, SizeOffset)) +calcRepoSizes quiet rsv = go `onException` failed + where + go = do + h <- Db.getRepoSizeHandle + (oldsizemap, moldbranchsha) <- liftIO $ Db.getRepoSizes h + !sizemap <- case moldbranchsha of + Nothing -> calculatefromscratch h + Just oldbranchsha -> do + currbranchsha <- getBranch + if oldbranchsha == currbranchsha + then calcJournalledRepoSizes h oldsizemap oldbranchsha + else incrementalupdate h oldsizemap oldbranchsha currbranchsha + liftIO $ putMVar rsv (Just sizemap) + return sizemap + + calculatefromscratch h = do + unless quiet $ + showSideAction "calculating repository sizes" + use h =<< calcBranchRepoSizes + + incrementalupdate h oldsizemap oldbranchsha currbranchsha = + use h =<< diffBranchRepoSizes quiet oldsizemap oldbranchsha currbranchsha + + use h (sizemap, branchsha) = do + liftIO $ Db.setRepoSizes h sizemap branchsha + calcJournalledRepoSizes h sizemap branchsha + + failed = do + liftIO $ putMVar rsv (Just M.empty) + return M.empty + +{- Sum up the sizes of all keys in all repositories, from the information + - in the git-annex branch, but not the journal. Retuns the sha of the + - branch commit that was used. + - + - The map includes the UUIDs of all known repositories, including + - repositories that are empty. But clusters are not included. + - + - Note that private repositories, which do not get recorded in + - the git-annex branch, will have 0 size. journalledRepoSizes + - takes care of getting repo sizes for those. + -} +calcBranchRepoSizes :: Annex (M.Map UUID RepoSize, Sha) +calcBranchRepoSizes = do + knownuuids <- M.keys <$> uuidDescMap + let startmap = M.fromList $ map (\u -> (u, RepoSize 0)) knownuuids + overLocationLogs True True startmap accumsizes >>= \case + UnmergedBranches v -> return v + NoUnmergedBranches v -> return v + where + accumsizes k locs m = return $ + foldl' (flip $ M.alter $ addKeyRepoSize k) m locs + +{- Given the RepoSizes calculated from the git-annex branch, updates it with + - data from journalled location logs. + -} +calcJournalledRepoSizes + :: Db.RepoSizeHandle + -> M.Map UUID RepoSize + -> Sha + -> Annex (M.Map UUID (RepoSize, SizeOffset)) +calcJournalledRepoSizes h startmap branchsha + -- Lock the journal to prevent updates to the size offsets + -- in the repository size database while this is processing + -- the journal files. + | Db.isOpenDb h = lockJournal $ \_jl -> go + -- When the repository is not writable, the database won't have + -- been opened, and locking the journal would also not succeed. + -- But there is no need to lock the journal in this case, + -- since no offsets will be read from the database. + | otherwise = go + where + go = do + sizemap <- overLocationLogsJournal startmap branchsha + (\k v m' -> pure (accumRepoSizes k v m')) + Nothing + offsets <- liftIO $ Db.recordedRepoOffsets h + let getoffset u = fromMaybe (SizeOffset 0) $ M.lookup u offsets + return $ M.mapWithKey (\u sz -> (sz, getoffset u)) sizemap + +{- Incremental update by diffing. -} +diffBranchRepoSizes :: Bool -> M.Map UUID RepoSize -> Sha -> Sha -> Annex (M.Map UUID RepoSize, Sha) +diffBranchRepoSizes quiet oldsizemap oldbranchsha newbranchsha = do + g <- Annex.gitRepo + catObjectStream g $ \feeder closer reader -> do + (l, cleanup) <- inRepo $ + DiffTree.diffTreeRecursive oldbranchsha newbranchsha + feedtid <- liftIO $ async $ do + forM_ l $ feedpairs feeder + closer + newsizemap <- readpairs 100000 reader oldsizemap Nothing + liftIO $ wait feedtid + ifM (liftIO cleanup) + ( do + newsizemap' <- addemptyrepos newsizemap + return (newsizemap', newbranchsha) + , return (oldsizemap, oldbranchsha) + ) + where + feedpairs feeder ti = + let f = getTopFilePath (DiffTree.file ti) + in case extLogFileKey locationLogExt f of + Nothing -> noop + Just k -> do + feeder (k, DiffTree.srcsha ti) + feeder (k, DiffTree.dstsha ti) + + readpairs n reader sizemap Nothing = liftIO reader >>= \case + Just (_k, oldcontent) -> readpairs n reader sizemap (Just oldcontent) + Nothing -> return sizemap + readpairs n reader sizemap (Just oldcontent) = liftIO reader >>= \case + Just (k, newcontent) -> + let prevlog = parselog oldcontent + currlog = parselog newcontent + newlocs = S.difference currlog prevlog + removedlocs = S.difference prevlog currlog + !sizemap' = accumRepoSizes k (newlocs, removedlocs) sizemap + in do + n' <- if quiet + then pure n + else countdownToMessage n $ + showSideAction "calculating repository sizes" + readpairs n' reader sizemap' Nothing + Nothing -> return sizemap + parselog = maybe mempty (S.fromList . parseLoggedLocationsWithoutClusters) + + addemptyrepos newsizemap = do + knownuuids <- M.keys <$> uuidDescMap + return $ foldl' + (\m u -> M.insertWith (flip const) u (RepoSize 0) m) + newsizemap + knownuuids + +addKeyRepoSize :: Key -> Maybe RepoSize -> Maybe RepoSize +addKeyRepoSize k mrs = case mrs of + Just (RepoSize sz) -> Just $ RepoSize $ sz + ksz + Nothing -> Just $ RepoSize ksz + where + ksz = fromMaybe 0 $ fromKey keySize k + +removeKeyRepoSize :: Key -> Maybe RepoSize -> Maybe RepoSize +removeKeyRepoSize k mrs = case mrs of + Just (RepoSize sz) -> Just $ RepoSize $ sz - ksz + Nothing -> Nothing + where + ksz = fromMaybe 0 $ fromKey keySize k + +accumRepoSizes :: Key -> (S.Set UUID, S.Set UUID) -> M.Map UUID RepoSize -> M.Map UUID RepoSize +accumRepoSizes k (newlocs, removedlocs) sizemap = + let !sizemap' = foldl' (flip $ M.alter $ addKeyRepoSize k) sizemap newlocs + in foldl' (flip $ M.alter $ removeKeyRepoSize k) sizemap' removedlocs diff --git a/Annex/RepoSize/LiveUpdate.hs b/Annex/RepoSize/LiveUpdate.hs new file mode 100644 --- /dev/null +++ b/Annex/RepoSize/LiveUpdate.hs @@ -0,0 +1,189 @@ +{- git-annex repo sizes, live updates + - + - Copyright 2024 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE BangPatterns #-} + +module Annex.RepoSize.LiveUpdate where + +import Annex.Common +import Logs.Presence.Pure +import Database.RepoSize.Handle +import Annex.UUID +import Types.FileMatcher +import Annex.LockFile +import Annex.LockPool +import qualified Database.RepoSize as Db +import qualified Utility.Matcher as Matcher +import Utility.PID + +import Control.Concurrent +import Text.Read +import Data.Time.Clock.POSIX +import qualified Utility.RawFilePath as R +import qualified System.FilePath.ByteString as P + +{- Called when a location log change is journalled, so the LiveUpdate + - is done. This is called with the journal still locked, so no concurrent + - changes can happen while it's running. Waits for the database + - to be updated. -} +updateRepoSize :: LiveUpdate -> UUID -> Key -> LogStatus -> Annex () +updateRepoSize lu u k s = liftIO $ finishedLiveUpdate lu u k sc + where + sc = case s of + InfoPresent -> AddingKey + InfoMissing -> RemovingKey + InfoDead -> RemovingKey + +-- When the UUID is Nothing, it's a live update of the local repository. +prepareLiveUpdate :: Maybe UUID -> Key -> SizeChange -> Annex LiveUpdate +prepareLiveUpdate mu k sc = do + h <- Db.getRepoSizeHandle + u <- maybe getUUID pure mu + needv <- liftIO newEmptyMVar + startv <- liftIO newEmptyMVar + readyv <- liftIO newEmptyMVar + donev <- liftIO newEmptyMVar + void $ liftIO $ forkIO $ waitstart startv readyv donev h u + return (LiveUpdate needv startv readyv donev) + where + {- Wait for checkLiveUpdate to request a start, or for the + - LiveUpdate to get garbage collected in the case where + - it is not needed. + - + - Deferring updating the database until here avoids overhead + - except in cases where preferred content expressions + - need live updates. + -} + waitstart startv readyv donev h u = + tryNonAsync (takeMVar startv) >>= \case + Right () -> do + pid <- getPID + cid <- mkSizeChangeId pid + Db.startingLiveSizeChange h u k sc cid + putMVar readyv () + waitdone donev h u cid + Left _ -> noop + + {- Wait for finishedLiveUpdate to be called, or for the LiveUpdate + - to get garbage collected in the case where the change didn't + - actually happen. Updates the database. -} + waitdone donev h u cid = tryNonAsync (takeMVar donev) >>= \case + Right (Just (u', k', sc', finishv)) + | u' == u && k' == k && sc' == sc -> do + Db.successfullyFinishedLiveSizeChange h u k sc cid + putMVar finishv () + -- Not the update we were expecting. This can + -- happen when eg, storing to a cluster + -- causes fanout and so this is called with + -- other UUIDs. + | otherwise -> do + putMVar finishv () + waitdone donev h u cid + Right Nothing -> abandoned h u cid + Left _ -> abandoned h u cid + abandoned h u cid = Db.removeStaleLiveSizeChange h u k sc cid + +-- Called when a preferred content check indicates that a live update is +-- needed. Can be called more than once on the same LiveUpdate. +needLiveUpdate :: LiveUpdate -> Annex () +needLiveUpdate NoLiveUpdate = noop +needLiveUpdate lu = liftIO $ void $ tryPutMVar (liveUpdateNeeded lu) () + +-- needLiveUpdate has to be called inside this to take effect. If the +-- action calls needLiveUpdate and then returns True, the live update is +-- started. If the action calls needLiveUpdate and then returns False, +-- the live update is not started. +-- +-- This can be called more than once on the same LiveUpdate. It will +-- only start it once. +-- +-- This serializes calls to the action, so that if the action +-- queries getLiveRepoSizes it will not race with another such action +-- that may also be starting a live update. +checkLiveUpdate + :: LiveUpdate + -> Matcher.Matcher (MatchFiles Annex) + -> Annex Bool + -> Annex Bool +checkLiveUpdate NoLiveUpdate _ a = a +checkLiveUpdate lu matcher a + | Matcher.introspect matchNeedsLiveRepoSize matcher = + Db.lockDbWhile (const go) go + | otherwise = a + where + go = do + r <- a + needed <- liftIO $ isJust <$> tryTakeMVar (liveUpdateNeeded lu) + when (r && needed) $ do + liftIO $ void $ tryPutMVar (liveUpdateStart lu) () + liftIO $ void $ readMVar (liveUpdateReady lu) + return r + +finishedLiveUpdate :: LiveUpdate -> UUID -> Key -> SizeChange -> IO () +finishedLiveUpdate NoLiveUpdate _ _ _ = noop +finishedLiveUpdate lu u k sc = + whenM (not <$> isEmptyMVar (liveUpdateReady lu)) $ do + finishv <- newEmptyMVar + tryNonAsync (putMVar (liveUpdateDone lu) (Just (u, k, sc, finishv))) >>= \case + Right () -> void $ tryNonAsync $ takeMVar finishv + Left _ -> noop + +{- Checks for other git-annex processes that might have been interrupted + - and left the database populated with stale live size changes. Those + - are removed from the database. + - + - Also registers the current process so that other calls to this will not + - consider it stale while it's running. + - + - This checks the first time it is called, and again if it's been more + - than 1 minute since the last check. + -} +checkStaleSizeChanges :: RepoSizeHandle -> Annex () +checkStaleSizeChanges h@(RepoSizeHandle (Just _) livev) = do + livedir <- calcRepo' gitAnnexRepoSizeLiveDir + pid <- liftIO getPID + let pidlockfile = show pid + now <- liftIO getPOSIXTime + liftIO (takeMVar livev) >>= \case + Nothing -> do + lck <- takeExclusiveLock $ + livedir P. toRawFilePath pidlockfile + go livedir lck pidlockfile now + Just v@(lck, lastcheck) + | now >= lastcheck + 60 -> + go livedir lck pidlockfile now + | otherwise -> + liftIO $ putMVar livev (Just v) + where + go livedir lck pidlockfile now = do + void $ tryNonAsync $ do + lockfiles <- liftIO $ filter (not . dirCruft) + <$> getDirectoryContents (fromRawFilePath livedir) + stale <- forM lockfiles $ \lockfile -> + if (lockfile /= pidlockfile) + then case readMaybe lockfile of + Nothing -> return Nothing + Just pid -> checkstale livedir lockfile pid + else return Nothing + let stale' = catMaybes stale + unless (null stale') $ liftIO $ do + Db.removeStaleLiveSizeChanges h (map fst stale') + mapM_ snd stale' + liftIO $ putMVar livev (Just (lck, now)) + + checkstale livedir lockfile pid = + let f = livedir P. toRawFilePath lockfile + in trySharedLock f >>= \case + Nothing -> return Nothing + Just lck -> do + return $ Just + ( StaleSizeChanger (SizeChangeProcessId pid) + , do + dropLock lck + removeWhenExistsWith R.removeLink f + ) +checkStaleSizeChanges (RepoSizeHandle Nothing _) = noop diff --git a/Annex/SpecialRemote/Config.hs b/Annex/SpecialRemote/Config.hs --- a/Annex/SpecialRemote/Config.hs +++ b/Annex/SpecialRemote/Config.hs @@ -93,6 +93,9 @@ importTreeField :: RemoteConfigField importTreeField = Accepted "importtree" + +versioningField :: RemoteConfigField +versioningField = Accepted "versioning" exportTree :: ParsedRemoteConfig -> Bool exportTree = fromMaybe False . getRemoteConfigValue exportTreeField @@ -100,6 +103,15 @@ importTree :: ParsedRemoteConfig -> Bool importTree = fromMaybe False . getRemoteConfigValue importTreeField +isVersioning :: ParsedRemoteConfig -> Bool +isVersioning = fromMaybe False . getRemoteConfigValue versioningField + +annexObjectsField :: RemoteConfigField +annexObjectsField = Accepted "annexobjects" + +annexObjects :: ParsedRemoteConfig -> Bool +annexObjects = fromMaybe False . getRemoteConfigValue annexObjectsField + {- Parsers for fields that are common to all special remotes. -} commonFieldParsers :: [RemoteConfigFieldParser] commonFieldParsers = @@ -124,6 +136,8 @@ (FieldDesc "export trees of files to this remote") , yesNoParser importTreeField (Just False) (FieldDesc "import trees of files from this remote") + , yesNoParser annexObjectsField (Just False) + (FieldDesc "store other objects in remote along with exported trees") ] autoEnableFieldParser :: RemoteConfigFieldParser diff --git a/Annex/Wanted.hs b/Annex/Wanted.hs --- a/Annex/Wanted.hs +++ b/Annex/Wanted.hs @@ -18,12 +18,12 @@ 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 +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 :: Bool -> Maybe Key -> AssociatedFile -> UUID -> Annex Bool -wantGetBy d key file to = isPreferredContent (Just to) S.empty key file d +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. @@ -34,20 +34,20 @@ - 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 +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 :: (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 +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 (Just u) s key f d + let checker' f = checker lu (Just u) s key f d ifM (checker' file) ( return (Just file) , do diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs --- a/Assistant/Threads/Committer.hs +++ b/Assistant/Threads/Committer.hs @@ -322,7 +322,7 @@ | not annexdotfiles && dotfile f = return (Right change) | otherwise = - ifM (liftAnnex $ checkFileMatcher largefilematcher f) + ifM (liftAnnex $ checkFileMatcher NoLiveUpdate largefilematcher f) ( return (Left change) , return (Right change) ) @@ -395,7 +395,7 @@ return Nothing done change file key = liftAnnex $ do - logStatus key InfoPresent + logStatus NoLiveUpdate key InfoPresent mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus (toRawFilePath file) stagePointerFile (toRawFilePath file) mode =<< hashPointerFile key showEndOk diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs --- a/Assistant/Threads/TransferScanner.hs +++ b/Assistant/Threads/TransferScanner.hs @@ -171,9 +171,9 @@ "expensive scan found too many copies of object" present key af (SeekInput []) [] callCommandAction ts <- if present - then liftAnnex . filterM (wantGetBy True (Just key) af . Remote.uuid . fst) + then liftAnnex . filterM (wantGetBy NoLiveUpdate True (Just key) af . Remote.uuid . fst) =<< use syncDataRemotes (genTransfer Upload False) - else ifM (liftAnnex $ wantGet True (Just key) af) + else ifM (liftAnnex $ wantGet NoLiveUpdate True (Just key) af) ( use downloadRemotes (genTransfer Download True) , return [] ) let unwanted' = S.difference unwanted slocs return (unwanted', ts) diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -214,7 +214,7 @@ Database.Keys.removeAssociatedFile oldkey =<< inRepo (toTopFilePath (toRawFilePath file)) unlessM (inAnnex oldkey) $ - logStatus oldkey InfoMissing + logStatus NoLiveUpdate oldkey InfoMissing addlink file key = do mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus (toRawFilePath file) liftAnnex $ stagePointerFile (toRawFilePath file) mode =<< hashPointerFile key diff --git a/Assistant/TransferQueue.hs b/Assistant/TransferQueue.hs --- a/Assistant/TransferQueue.hs +++ b/Assistant/TransferQueue.hs @@ -60,7 +60,7 @@ - condition. Honors preferred content settings. -} queueTransfersMatching :: (UUID -> Bool) -> Reason -> Schedule -> Key -> AssociatedFile -> Direction -> Assistant Bool queueTransfersMatching matching reason schedule k f direction - | direction == Download = ifM (liftAnnex $ wantGet True (Just k) f) + | direction == Download = ifM (liftAnnex $ wantGet NoLiveUpdate True (Just k) f) ( go , return False ) @@ -89,7 +89,7 @@ - already have it. -} | otherwise = do s <- locs - filterM (wantGetBy True (Just k) f . Remote.uuid) $ + filterM (wantGetBy NoLiveUpdate True (Just k) f . Remote.uuid) $ filter (\r -> not (inset s r || Remote.readonly r)) (syncDataRemotes st) where diff --git a/Assistant/TransferSlots.hs b/Assistant/TransferSlots.hs --- a/Assistant/TransferSlots.hs +++ b/Assistant/TransferSlots.hs @@ -210,11 +210,11 @@ shouldTransfer :: Transfer -> TransferInfo -> Annex Bool shouldTransfer t info | transferDirection t == Download = - (not <$> inAnnex key) <&&> wantGet True (Just key) file + (not <$> inAnnex key) <&&> wantGet NoLiveUpdate True (Just key) file | transferDirection t == Upload = case transferRemote info of Nothing -> return False Just r -> notinremote r - <&&> wantGetBy True (Just key) file (Remote.uuid r) + <&&> wantGetBy NoLiveUpdate True (Just key) file (Remote.uuid r) | otherwise = return False where key = transferKey t diff --git a/Assistant/Unused.hs b/Assistant/Unused.hs --- a/Assistant/Unused.hs +++ b/Assistant/Unused.hs @@ -77,7 +77,7 @@ debug ["removing old unused key", serializeKey k] liftAnnex $ tryNonAsync $ do lockContentForRemoval k noop removeAnnex - logStatus k InfoMissing + logStatus NoLiveUpdate k InfoMissing where boundary = durationToPOSIXTime <$> duration tooold now (_, mt) = case boundary of diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs --- a/Assistant/Upgrade.hs +++ b/Assistant/Upgrade.hs @@ -101,7 +101,7 @@ cleanup = liftAnnex $ do lockContentForRemoval k noop removeAnnex setUrlMissing k u - logStatus k InfoMissing + logStatus NoLiveUpdate k InfoMissing {- Called once the download is done. - Passed an action that can be used to clean up the downloaded file. diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,35 @@ +git-annex (10.20240831) upstream; urgency=medium + + * Special remotes configured with exporttree=yes annexobjects=yes + can store objects in .git/annex/objects, as well as an exported tree. + * Support proxying to special remotes configured with + exporttree=yes annexobjects=yes, and allow such remotes to be used as + cluster nodes. + * post-retrieve: When proxying is enabled for an exporttree=yes + special remote (or it is a cluster node) and the configured + remote.name.annex-tracking-branch is received, the tree is + exported to the special remote. + * Support "balanced=", "fullybalanced=", "sizebalanced=" and + "fullysizebalanced=" in preferred content expressions. + * Added --rebalance option. + * Added the annex.fullybalancedthreshhold git config. + * maxsize: New command to tell git-annex how large the expected maximum + size of a repository is, and to display repository sizes. + * vicfg: Include maxsize configuration. + * info: Improved speed by using new repository size tracking. + * lookupkey: Allow using --ref in a bare repository. + * export: Added --from option. + * git-remote-annex: Store objects in exportree=yes special remotes + in the same paths used by annexobjects=yes. This is a backwards + compatible change. + * updateproxy, updatecluster: Prevent using an exporttree=yes special + remote that does not have annexobjects=yes, since it will not work. + * The config versioning=true is now reserved for use by versioned special + remotes. External special remotes should not use that config for their + own purposes. + + -- Joey Hess Sat, 31 Aug 2024 19:48:17 -0400 + git-annex (10.20240808) upstream; urgency=medium * Remove debug output (to stderr) accidentially included in diff --git a/CmdLine.hs b/CmdLine.hs --- a/CmdLine.hs +++ b/CmdLine.hs @@ -31,7 +31,7 @@ {- Parses input arguments, finds a matching Command, and runs it. -} dispatch :: Bool -> Bool -> CmdParams -> [Command] -> [(String, String)] -> IO Git.Repo -> String -> String -> IO () -dispatch addonok fuzzyok allargs allcmds fields getgitrepo progname progdesc = +dispatch addonok fuzzyok allargs allcmds fields getgitrepo progname progdesc = do go addonok allcmds $ findAddonCommand subcommandname >>= \case Just c -> go addonok (c:allcmds) noop diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -131,6 +131,7 @@ import qualified Command.UpdateCluster import qualified Command.ExtendCluster import qualified Command.UpdateProxy +import qualified Command.MaxSize import qualified Command.Version import qualified Command.RemoteDaemon #ifdef WITH_ASSISTANT @@ -261,6 +262,7 @@ , Command.UpdateCluster.cmd , Command.ExtendCluster.cmd , Command.UpdateProxy.cmd + , Command.MaxSize.cmd , Command.Version.cmd , Command.RemoteDaemon.cmd #ifdef WITH_ASSISTANT diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs --- a/CmdLine/GitAnnex/Options.hs +++ b/CmdLine/GitAnnex/Options.hs @@ -56,6 +56,11 @@ <> help "override minimum number of copies" <> hidden ) + , annexFlag (setrebalance True) + ( long "rebalance" + <> help "move content as needed to improve balance" + <> hidden + ) , annexOption (setAnnexState . Remote.forceTrust Trusted) $ strOption ( long "trust" <> metavar paramRemote <> help "deprecated, does not override trust setting" @@ -103,6 +108,7 @@ where setnumcopies n = setAnnexRead $ \rd -> rd { Annex.forcenumcopies = Just $ configuredNumCopies n } setmincopies n = setAnnexRead $ \rd -> rd { Annex.forcemincopies = Just $ configuredMinCopies n } + setrebalance v = setAnnexRead $ \rd -> rd { Annex.rebalance = v } setuseragent v = setAnnexRead $ \rd -> rd { Annex.useragent = Just v } setdesktopnotify v = setAnnexRead $ \rd -> rd { Annex.desktopnotify = Annex.desktopnotify rd <> v } setgitconfig v = Annex.addGitConfigOverride v diff --git a/CmdLine/GitRemoteAnnex.hs b/CmdLine/GitRemoteAnnex.hs --- a/CmdLine/GitRemoteAnnex.hs +++ b/CmdLine/GitRemoteAnnex.hs @@ -1010,14 +1010,13 @@ -- inside the .git/annex/objects/ directory in the remote. -- -- The first ExportLocation in the returned list is the one that --- is the same as the local repository would use. But it's possible --- that one of the others in the list was used by another repository to --- upload a git key. +-- should be used to store a key. But it's possible +-- that one of the others in the list was used. keyExportLocations :: Remote -> Key -> GitConfig -> UUID -> Maybe [ExportLocation] keyExportLocations rmt k cfg uuid | exportTree (Remote.config rmt) || importTree (Remote.config rmt) = Just $ map (\p -> mkExportLocation (".git" P. p)) $ - concatMap (`annexLocationsNonBare` k) cfgs + concatMap (`annexLocationsBare` k) cfgs | otherwise = Nothing where -- When git-annex has not been initialized yet (eg, when cloning), diff --git a/CmdLine/Seek.hs b/CmdLine/Seek.hs --- a/CmdLine/Seek.hs +++ b/CmdLine/Seek.hs @@ -284,9 +284,12 @@ let discard reader = reader >>= \case Nothing -> noop Just _ -> discard reader - overLocationLogs' () + overLocationLogs' False False () (\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 diff --git a/Command.hs b/Command.hs --- a/Command.hs +++ b/Command.hs @@ -21,6 +21,7 @@ import CmdLine.GitAnnex.Options as ReExported import CmdLine.Batch as ReExported import Options.Applicative as ReExported hiding (command) +import Annex.RepoSize.LiveUpdate as ReExported import qualified Git import Annex.Init import Annex.Startup diff --git a/Command/Add.hs b/Command/Add.hs --- a/Command/Add.hs +++ b/Command/Add.hs @@ -95,7 +95,7 @@ annexdotfiles <- getGitConfigVal annexDotFiles let gofile includingsmall (si, file) = case largeFilesOverride o of Nothing -> ifM (pure (annexdotfiles || not (dotfile file)) - <&&> (checkFileMatcher largematcher file + <&&> (checkFileMatcher NoLiveUpdate largematcher file <||> Annex.getRead Annex.force)) ( start dr si file addunlockedmatcher , if includingsmall @@ -267,5 +267,5 @@ cleanup key hascontent = do maybeShowJSON $ JSONChunk [("key", serializeKey key)] when hascontent $ - logStatus key InfoPresent + logStatus NoLiveUpdate key InfoPresent return True diff --git a/Command/AddUnused.hs b/Command/AddUnused.hs --- a/Command/AddUnused.hs +++ b/Command/AddUnused.hs @@ -32,7 +32,7 @@ (ActionItemTreeFile file) (SeekInput [show n]) $ next $ do - logStatus key InfoPresent + logStatus NoLiveUpdate key InfoPresent addSymlink file key Nothing return True diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -323,7 +323,7 @@ Just (exists, samesize, url') | exists && (samesize || relaxedOption (downloadOptions o)) -> do setUrlPresent key url' - logChange key u InfoPresent + logChange NoLiveUpdate key u InfoPresent next $ return True | otherwise -> do warning $ UnquotedString $ "while adding a new url to an already annexed file, " ++ if exists @@ -511,7 +511,7 @@ createWorkTreeDirectory (P.takeDirectory file) liftIO $ moveFile tmp file largematcher <- largeFilesMatcher - large <- checkFileMatcher largematcher file + large <- checkFileMatcher NoLiveUpdate largematcher file if large then do -- Move back to tmp because addAnnexedFile @@ -525,11 +525,11 @@ go = do maybeShowJSON $ JSONChunk [("key", serializeKey key)] setUrlPresent key url - logChange key u InfoPresent + logChange NoLiveUpdate key u InfoPresent ifM (addAnnexedFile addunlockedmatcher file key mtmp) ( do when (isJust mtmp) $ - logStatus key InfoPresent + logStatus NoLiveUpdate key InfoPresent , maybe noop (\tmp -> pruneTmpWorkDirBefore tmp (liftIO . removeWhenExistsWith R.removeLink)) mtmp ) diff --git a/Command/Copy.hs b/Command/Copy.hs --- a/Command/Copy.hs +++ b/Command/Copy.hs @@ -72,15 +72,28 @@ FromAnywhereToRemote _ -> Nothing , usesLocationLog = True } - keyaction = Command.Move.startKey fto Command.Move.RemoveNever + keyaction = Command.Move.startKey NoLiveUpdate fto Command.Move.RemoveNever {- A copy is just a move that does not delete the source file. - However, auto mode avoids unnecessary copies, and avoids getting or - sending non-preferred content. -} start :: CopyOptions -> FromToHereOptions -> SeekInput -> RawFilePath -> Key -> CommandStart -start o fto si file key = stopUnless shouldCopy $ - Command.Move.start fto Command.Move.RemoveNever si file key +start o fto si file key = do + ru <- case fto of + FromOrToRemote (ToRemote dest) -> getru dest + FromOrToRemote (FromRemote _) -> pure Nothing + ToHere -> pure Nothing + FromRemoteToRemote _ dest -> getru dest + FromAnywhereToRemote dest -> getru dest + lu <- prepareLiveUpdate ru key AddingKey + start' lu o fto si file key where + getru dest = Just . Remote.uuid <$> getParsed dest + +start' :: LiveUpdate -> CopyOptions -> FromToHereOptions -> SeekInput -> RawFilePath -> Key -> CommandStart +start' lu o fto si file key = stopUnless shouldCopy $ + Command.Move.start lu fto Command.Move.RemoveNever si file key + where shouldCopy | autoMode o = want <||> numCopiesCheck file key (<) | otherwise = return True @@ -93,5 +106,5 @@ checkwantsend dest = (Remote.uuid <$> getParsed dest) >>= - wantGetBy False (Just key) (AssociatedFile (Just file)) - checkwantget = wantGet False (Just key) (AssociatedFile (Just file)) + wantGetBy lu False (Just key) (AssociatedFile (Just file)) + checkwantget = wantGet lu False (Just key) (AssociatedFile (Just file)) diff --git a/Command/DiffDriver.hs b/Command/DiffDriver.hs --- a/Command/DiffDriver.hs +++ b/Command/DiffDriver.hs @@ -125,7 +125,7 @@ unlessM (inAnnex k) $ commandAction $ starting "get" ai si $ - Command.Get.perform k af + Command.Get.perform NoLiveUpdate k af repoint k where ai = OnlyActionOn k (ActionItemKey k) diff --git a/Command/Drop.hs b/Command/Drop.hs --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -83,15 +83,17 @@ ai = mkActionItem (key, afile) start' :: DropOptions -> Maybe Remote -> Key -> AssociatedFile -> ActionItem -> SeekInput -> CommandStart -start' o from key afile ai si = - checkDropAuto (autoMode o) from afile key $ \numcopies mincopies -> - stopUnless wantdrop $ +start' o from key afile ai si = do + checkDropAuto (autoMode o) from afile key $ \numcopies mincopies -> do + lu <- prepareLiveUpdate remoteuuid key RemovingKey + stopUnless (wantdrop lu) $ case from of - Nothing -> startLocal pcc afile ai si numcopies mincopies key [] ud - Just remote -> startRemote pcc afile ai si numcopies mincopies key ud remote + Nothing -> startLocal lu pcc afile ai si numcopies mincopies key [] ud + Just remote -> startRemote lu pcc afile ai si numcopies mincopies key ud remote where - wantdrop - | autoMode o = wantDrop False (Remote.uuid <$> from) (Just key) afile Nothing + remoteuuid = Remote.uuid <$> from + wantdrop lu + | autoMode o = wantDrop lu False remoteuuid (Just key) afile Nothing | otherwise = return True pcc = PreferredContentChecked (autoMode o) ud = case (batchOption o, keyOptions o) of @@ -101,22 +103,22 @@ startKeys :: DropOptions -> Maybe Remote -> (SeekInput, Key, ActionItem) -> CommandStart startKeys o from (si, key, ai) = start' o from key (AssociatedFile Nothing) ai si -startLocal :: PreferredContentChecked -> AssociatedFile -> ActionItem -> SeekInput -> NumCopies -> MinCopies -> Key -> [VerifiedCopy] -> DroppingUnused -> CommandStart -startLocal pcc afile ai si numcopies mincopies key preverified ud = +startLocal :: LiveUpdate -> PreferredContentChecked -> AssociatedFile -> ActionItem -> SeekInput -> NumCopies -> MinCopies -> Key -> [VerifiedCopy] -> DroppingUnused -> CommandStart +startLocal lu pcc afile ai si numcopies mincopies key preverified ud = starting "drop" (OnlyActionOn key ai) si $ - performLocal pcc key afile numcopies mincopies preverified ud + performLocal lu pcc key afile numcopies mincopies preverified ud -startRemote :: PreferredContentChecked -> AssociatedFile -> ActionItem -> SeekInput -> NumCopies -> MinCopies -> Key -> DroppingUnused -> Remote -> CommandStart -startRemote pcc afile ai si numcopies mincopies key ud remote = +startRemote :: LiveUpdate -> PreferredContentChecked -> AssociatedFile -> ActionItem -> SeekInput -> NumCopies -> MinCopies -> Key -> DroppingUnused -> Remote -> CommandStart +startRemote lu pcc afile ai si numcopies mincopies key ud remote = starting "drop" (OnlyActionOn key ai) si $ do showAction $ UnquotedString $ "from " ++ Remote.name remote - performRemote pcc key afile numcopies mincopies remote ud + performRemote lu pcc key afile numcopies mincopies remote ud -performLocal :: PreferredContentChecked -> Key -> AssociatedFile -> NumCopies -> MinCopies -> [VerifiedCopy] -> DroppingUnused -> CommandPerform -performLocal pcc key afile numcopies mincopies preverified ud = lockContentForRemoval key fallback $ \contentlock -> do +performLocal :: LiveUpdate -> PreferredContentChecked -> Key -> AssociatedFile -> NumCopies -> MinCopies -> [VerifiedCopy] -> DroppingUnused -> CommandPerform +performLocal lu pcc key afile numcopies mincopies preverified ud = lockContentForRemoval key fallback $ \contentlock -> do u <- getUUID (tocheck, verified) <- verifiableCopies key [u] - doDrop pcc u (Just contentlock) key afile numcopies mincopies [] (preverified ++ verified) tocheck + doDrop lu pcc u (Just contentlock) key afile numcopies mincopies [] (preverified ++ verified) tocheck ( \proof -> do fastDebug "Command.Drop" $ unwords [ "Dropping from here" @@ -125,7 +127,7 @@ ] removeAnnex contentlock notifyDrop afile True - next $ cleanupLocal key ud + next $ cleanupLocal lu key ud , do notifyDrop afile False stop @@ -136,14 +138,14 @@ -- is present, but due to buffering, may find it present for the -- second file before the first is dropped. If so, nothing remains -- to be done except for cleaning up. - fallback = next $ cleanupLocal key ud + fallback = next $ cleanupLocal lu key ud -performRemote :: PreferredContentChecked -> Key -> AssociatedFile -> NumCopies -> MinCopies -> Remote -> DroppingUnused -> CommandPerform -performRemote pcc key afile numcopies mincopies remote ud = do +performRemote :: LiveUpdate -> PreferredContentChecked -> Key -> AssociatedFile -> NumCopies -> MinCopies -> Remote -> DroppingUnused -> CommandPerform +performRemote lu pcc key afile numcopies mincopies remote ud = 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 pcc uuid Nothing key afile numcopies mincopies [uuid] verified tocheck + doDrop lu pcc uuid Nothing key afile numcopies mincopies [uuid] verified tocheck ( \proof -> do fastDebug "Command.Drop" $ unwords [ "Dropping from remote" @@ -152,21 +154,21 @@ , show proof ] ok <- Remote.action (Remote.removeKey remote proof key) - next $ cleanupRemote key remote ud ok + next $ cleanupRemote lu key remote ud ok , stop ) where uuid = Remote.uuid remote -cleanupLocal :: Key -> DroppingUnused -> CommandCleanup -cleanupLocal key ud = do - logStatus key (dropStatus ud) +cleanupLocal :: LiveUpdate -> Key -> DroppingUnused -> CommandCleanup +cleanupLocal lu key ud = do + logStatus lu key (dropStatus ud) return True -cleanupRemote :: Key -> Remote -> DroppingUnused -> Bool -> CommandCleanup -cleanupRemote key remote ud ok = do +cleanupRemote :: LiveUpdate -> Key -> Remote -> DroppingUnused -> Bool -> CommandCleanup +cleanupRemote lu key remote ud ok = do when ok $ - Remote.logStatus remote key (dropStatus ud) + Remote.logStatus lu remote key (dropStatus ud) return ok {- Set when the user explicitly chose to operate on unused content. @@ -189,7 +191,8 @@ - --force overrides and always allows dropping. -} doDrop - :: PreferredContentChecked + :: LiveUpdate + -> PreferredContentChecked -> UUID -> Maybe ContentRemovalLock -> Key @@ -201,10 +204,10 @@ -> [UnVerifiedCopy] -> (Maybe SafeDropProof -> CommandPerform, CommandPerform) -> CommandPerform -doDrop pcc dropfrom contentlock key afile numcopies mincopies skip preverified check (dropaction, nodropaction) = +doDrop lu pcc dropfrom contentlock key afile numcopies mincopies skip preverified check (dropaction, nodropaction) = ifM (Annex.getRead Annex.force) ( dropaction Nothing - , ifM (checkRequiredContent pcc dropfrom key afile) + , ifM (checkRequiredContent lu pcc dropfrom key afile) ( verifyEnoughCopiesToDrop nolocmsg key (Just dropfrom) contentlock numcopies mincopies skip preverified check @@ -225,10 +228,10 @@ - providing this avoids that extra work. -} newtype PreferredContentChecked = PreferredContentChecked Bool -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 +checkRequiredContent :: LiveUpdate -> PreferredContentChecked -> UUID -> Key -> AssociatedFile -> Annex Bool +checkRequiredContent _ (PreferredContentChecked True) _ _ _ = return True +checkRequiredContent lu (PreferredContentChecked False) u k afile = + checkDrop isRequiredContent lu False (Just u) (Just k) afile Nothing >>= \case Nothing -> return True Just afile' -> do if afile == afile' diff --git a/Command/DropKey.hs b/Command/DropKey.hs --- a/Command/DropKey.hs +++ b/Command/DropKey.hs @@ -55,5 +55,5 @@ cleanup :: Key -> CommandCleanup cleanup key = do - logStatus key InfoMissing + logStatus NoLiveUpdate key InfoMissing return True diff --git a/Command/DropUnused.hs b/Command/DropUnused.hs --- a/Command/DropUnused.hs +++ b/Command/DropUnused.hs @@ -57,7 +57,8 @@ perform from numcopies mincopies key = case from of Just r -> do showAction $ UnquotedString $ "from " ++ Remote.name r - Command.Drop.performRemote pcc key (AssociatedFile Nothing) numcopies mincopies r ud + Command.Drop.performRemote NoLiveUpdate pcc key + (AssociatedFile Nothing) numcopies mincopies r ud Nothing -> ifM (inAnnex key) ( droplocal , ifM (objectFileExists key) @@ -71,7 +72,8 @@ ) ) where - droplocal = Command.Drop.performLocal pcc key (AssociatedFile Nothing) numcopies mincopies [] ud + droplocal = Command.Drop.performLocal NoLiveUpdate pcc + key (AssociatedFile Nothing) numcopies mincopies [] ud pcc = Command.Drop.PreferredContentChecked False ud = Command.Drop.DroppingUnused True diff --git a/Command/Export.hs b/Command/Export.hs --- a/Command/Export.hs +++ b/Command/Export.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2017-2023 Joey Hess + - Copyright 2017-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -21,6 +21,7 @@ import Git.FilePath import Git.Sha import qualified Remote +import qualified Types.Remote as Remote import Types.Remote import Types.Export import Annex.Export @@ -29,6 +30,7 @@ import Annex.CatFile import Annex.FileMatcher import Annex.RemoteTrackingBranch +import Annex.SpecialRemote.Config import Logs.Location import Logs.Export import Logs.PreferredContent @@ -41,6 +43,7 @@ import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import qualified Data.Map as M +import qualified Data.Set as S import Control.Concurrent cmd :: Command @@ -53,6 +56,7 @@ { exportTreeish :: Git.Ref -- ^ can be a tree, a branch, a commit, or a tag , exportRemote :: DeferredParse Remote + , sourceRemote :: [DeferredParse Remote] , exportTracking :: Bool } @@ -60,6 +64,7 @@ optParser _ = ExportOptions <$> (Git.Ref <$> parsetreeish) <*> (mkParseRemoteOption <$> parseToOption) + <*> many (mkParseRemoteOption <$> parseFromOption) <*> parsetracking where parsetreeish = argument str @@ -82,6 +87,9 @@ unlessM (isExportSupported r) $ giveup "That remote does not support exports." + srcrs <- concat . Remote.byCost + <$> mapM getParsed (sourceRemote o) + -- handle deprecated option when (exportTracking o) $ setConfig (remoteAnnexConfig r "tracking-branch") @@ -92,12 +100,15 @@ inRepo (Git.Ref.tree (exportTreeish o)) mtbcommitsha <- getExportCommit r (exportTreeish o) + seekExport r tree mtbcommitsha srcrs +seekExport :: Remote -> ExportFiltered Git.Ref -> Maybe (RemoteTrackingBranch, Sha) -> [Remote] -> CommandSeek +seekExport r tree mtbcommitsha srcrs = do db <- openDb (uuid r) writeLockDbWhile db $ do changeExport r db tree unlessM (Annex.getRead Annex.fast) $ do - void $ fillExport r db tree mtbcommitsha + void $ fillExport r db tree mtbcommitsha srcrs closeDb db -- | When the treeish is a branch like master or refs/heads/master @@ -150,16 +161,15 @@ [oldtreesha] -> do diffmap <- mkDiffMap oldtreesha new db let seekdiffmap a = mapM_ a (M.toList diffmap) - -- Rename old files to temp, or delete. - let deleteoldf = \ek oldf -> commandAction $ - startUnexport' r db oldf ek + let disposeoldf = \ek oldf -> commandAction $ + startDispose r db oldf ek seekdiffmap $ \case (ek, (oldf:oldfs, _newf:_)) -> do commandAction $ startMoveToTempName r db oldf ek - forM_ oldfs (deleteoldf ek) + forM_ oldfs (disposeoldf ek) (ek, (oldfs, [])) -> - forM_ oldfs (deleteoldf ek) + forM_ oldfs (disposeoldf ek) (_ek, ([], _)) -> noop waitForAllRunningCommandActions -- Rename from temp to new files. @@ -237,8 +247,8 @@ -- -- Once all exported files have reached the remote, updates the -- remote tracking branch. -fillExport :: Remote -> ExportHandle -> ExportFiltered Git.Ref -> Maybe (RemoteTrackingBranch, Sha) -> Annex Bool -fillExport r db (ExportFiltered newtree) mtbcommitsha = do +fillExport :: Remote -> ExportHandle -> ExportFiltered Git.Ref -> Maybe (RemoteTrackingBranch, Sha) -> [Remote] -> Annex Bool +fillExport r db (ExportFiltered newtree) mtbcommitsha srcrs = do (l, cleanup) <- inRepo $ Git.LsTree.lsTree Git.LsTree.LsTreeRecursive (Git.LsTree.LsTreeLong False) @@ -246,7 +256,7 @@ cvar <- liftIO $ newMVar (FileUploaded False) allfilledvar <- liftIO $ newMVar (AllFilled True) commandActions $ - map (startExport r db cvar allfilledvar) l + map (startExport r srcrs db cvar allfilledvar) l void $ liftIO $ cleanup waitForAllRunningCommandActions @@ -259,8 +269,8 @@ liftIO $ fromFileUploaded <$> takeMVar cvar -startExport :: Remote -> ExportHandle -> MVar FileUploaded -> MVar AllFilled -> Git.LsTree.TreeItem -> CommandStart -startExport r db cvar allfilledvar ti = do +startExport :: Remote -> [Remote] -> ExportHandle -> MVar FileUploaded -> MVar AllFilled -> Git.LsTree.TreeItem -> CommandStart +startExport r srcrs db cvar allfilledvar ti = do ek <- exportKey (Git.LsTree.sha ti) stopUnless (notrecordedpresent ek) $ starting ("export " ++ name r) ai si $ @@ -268,7 +278,7 @@ ( next $ cleanupExport r db ek loc False , do liftIO $ modifyMVar_ cvar (pure . const (FileUploaded True)) - performExport r db ek af (Git.LsTree.sha ti) loc allfilledvar + performExport r srcrs db ek af (Git.LsTree.sha ti) loc allfilledvar ) where loc = mkExportLocation f @@ -291,26 +301,10 @@ else notElem (uuid r) <$> loggedLocations ek ) -performExport :: Remote -> ExportHandle -> Key -> AssociatedFile -> Sha -> ExportLocation -> MVar AllFilled -> CommandPerform -performExport r db ek af contentsha loc allfilledvar = do - let storer = storeExport (exportActions r) +performExport :: Remote -> [Remote] -> ExportHandle -> Key -> AssociatedFile -> Sha -> ExportLocation -> MVar AllFilled -> CommandPerform +performExport r srcrs db ek af contentsha loc allfilledvar = do sent <- tryNonAsync $ if not (isGitShaKey ek) - then ifM (inAnnex ek) - ( notifyTransfer Upload af $ - -- alwaysUpload because the same key - -- could be used for more than one export - -- location, and concurrently uploading - -- of the content should still be allowed. - alwaysUpload (uuid r) ek af Nothing stdRetry $ \pm -> do - let rollback = void $ - performUnexport r db [ek] loc - sendAnnex ek Nothing rollback $ \f _sz -> - Remote.action $ - storer f ek loc pm - , do - showNote "not available" - return False - ) + then tryrenameannexobject $ sendannexobject -- Sending a non-annexed file. else withTmpFile "export" $ \tmp h -> do b <- catObject contentsha @@ -327,12 +321,71 @@ Left err -> do failedsend throwM err + where + storer = storeExport (exportActions r) + + sendannexobject = ifM (inAnnex ek) + ( sendlocalannexobject + , do + locs <- S.fromList <$> loggedLocations ek + case filter (\sr -> S.member (Remote.uuid sr) locs) srcrs of + [] -> do + showNote "not available" + return False + (srcr:_) -> getsendannexobject srcr + ) + + sendlocalannexobject = sendwith $ \p -> do + let rollback = void $ + performUnexport r db [ek] loc + sendAnnex ek Nothing rollback $ \f _sz -> + Remote.action $ + storer f ek loc p + + sendwith a = + notifyTransfer Upload af $ + -- alwaysUpload because the same key + -- could be used for more than one export + -- location, and concurrently uploading + -- of the content should still be allowed. + alwaysUpload (uuid r) ek af Nothing stdRetry a + -- Similar to Command.Move.fromToPerform, use a regular download + -- of a local copy, lock early, and drop the local copy after sending. + getsendannexobject srcr = do + showAction $ UnquotedString $ "from " ++ Remote.name srcr + ifM (notifyTransfer Download af $ download srcr ek af stdRetry) + ( lockContentForRemoval ek (return False) $ \contentlock -> do + showAction $ UnquotedString $ "to " ++ Remote.name r + sendlocalannexobject + `finally` removeAnnex contentlock + , return False + ) + + tryrenameannexobject fallback + | annexObjects (Remote.config r) = do + case renameExport (exportActions r) of + Just renameaction -> do + locs <- loggedLocations ek + gc <- Annex.getGitConfig + let objloc = exportAnnexObjectLocation gc ek + if Remote.uuid r `elem` locs + then tryNonAsync (renameaction ek objloc loc) >>= \case + Right (Just ()) -> do + liftIO $ addExportedLocation db ek loc + liftIO $ flushDbQueue db + return True + Left _err -> fallback + Right Nothing -> fallback + else fallback + Nothing -> fallback + | otherwise = fallback + cleanupExport :: Remote -> ExportHandle -> Key -> ExportLocation -> Bool -> CommandCleanup cleanupExport r db ek loc sent = do liftIO $ addExportedLocation db ek loc when (sent && not (isGitShaKey ek)) $ - logChange ek (uuid r) InfoPresent + logChange NoLiveUpdate ek (uuid r) InfoPresent return True startUnexport :: Remote -> ExportHandle -> TopFilePath -> [Git.Sha] -> CommandStart @@ -348,16 +401,6 @@ ai = ActionItemTreeFile f' si = SeekInput [] -startUnexport' :: Remote -> ExportHandle -> TopFilePath -> Key -> CommandStart -startUnexport' r db f ek = - starting ("unexport " ++ name r) ai si $ - performUnexport r db [ek] loc - where - loc = mkExportLocation f' - f' = getTopFilePath f - ai = ActionItemTreeFile f' - si = SeekInput [] - -- Unlike a usual drop from a repository, this does not check that -- numcopies is satisfied before removing the content. Typically an export -- remote is untrusted, so would not count as a copy anyway. @@ -379,18 +422,43 @@ removeExportedLocation db ek loc flushDbQueue db - -- A versionedExport remote supports removeExportLocation to remove + -- A versioned remote supports removeExportLocation to remove -- the file from the exported tree, but still retains the content -- and allows retrieving it. - unless (versionedExport (exportActions r)) $ do + unless (isVersioning (Remote.config r)) $ do remaininglocs <- liftIO $ concat <$> forM eks (getExportedLocation db) when (null remaininglocs) $ forM_ eks $ \ek -> - logChange ek (uuid r) InfoMissing + -- When annexobject=true, a key that + -- was unexported may still be present + -- on the remote. + if annexObjects (Remote.config r) + then tryNonAsync (checkPresent r ek) >>= \case + Right False -> + logChange NoLiveUpdate ek (uuid r) InfoMissing + _ -> noop + else logChange NoLiveUpdate ek (uuid r) InfoMissing removeEmptyDirectories r db loc eks +-- Dispose of an old exported file by either unexporting it, or by moving +-- it to the annexobjects location. +startDispose :: Remote -> ExportHandle -> TopFilePath -> Key -> CommandStart +startDispose r db f ek = + starting ("unexport " ++ name r) ai si $ + if annexObjects (Remote.config r) && not (isGitShaKey ek) + then do + gc <- Annex.getGitConfig + performRename False r db ek loc + (exportAnnexObjectLocation gc ek) + else performUnexport r db [ek] loc + where + loc = mkExportLocation f' + f' = getTopFilePath f + ai = ActionItemTreeFile f' + si = SeekInput [] + startRecoverIncomplete :: Remote -> ExportHandle -> Git.Sha -> TopFilePath -> CommandStart startRecoverIncomplete r db sha oldf | sha `elem` nullShas = stop @@ -408,7 +476,7 @@ startMoveToTempName :: Remote -> ExportHandle -> TopFilePath -> Key -> CommandStart startMoveToTempName r db f ek = case renameExport (exportActions r) of Just _ -> starting ("rename " ++ name r) ai si $ - performRename r db ek loc tmploc + performRename True r db ek loc tmploc Nothing -> starting ("unexport " ++ name r) ai' si $ performUnexport r db [ek] loc where @@ -424,7 +492,7 @@ startMoveFromTempName r db ek f = case renameExport (exportActions r) of Just _ -> stopUnless (liftIO $ elem tmploc <$> getExportedLocation db ek) $ starting ("rename " ++ name r) ai si $ - performRename r db ek tmploc loc + performRename True r db ek tmploc loc Nothing -> starting ("unexport " ++ name r) ai' si $ performUnexport r db [ek] tmploc where @@ -436,12 +504,14 @@ ai' = ActionItemTreeFile (fromExportLocation tmploc) si = SeekInput [] -performRename :: Remote -> ExportHandle -> Key -> ExportLocation -> ExportLocation -> CommandPerform -performRename r db ek src dest = case renameExport (exportActions r) of +performRename :: Bool -> Remote -> ExportHandle -> Key -> ExportLocation -> ExportLocation -> CommandPerform +performRename warnonfail r db ek src dest = case renameExport (exportActions r) of Just renameaction -> tryNonAsync (renameaction ek src dest) >>= \case Right (Just ()) -> next $ cleanupRename r db ek src dest Left err -> do - warning $ UnquotedString $ "rename failed (" ++ show err ++ "); deleting instead" + when warnonfail $ + warning $ UnquotedString $ + "rename failed (" ++ show err ++ "); deleting instead" fallbackdelete Right Nothing -> fallbackdelete -- remote does not support renaming @@ -548,7 +618,7 @@ , providedMimeEncoding = Nothing , providedLinkType = Nothing } - ifM (checkMatcher' matcher mi mempty) + ifM (checkMatcher' matcher mi NoLiveUpdate mempty) ( return (Just ti) , excluded ) diff --git a/Command/Fsck.hs b/Command/Fsck.hs --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -334,12 +334,12 @@ whenM (annexSecureHashesOnly <$> Annex.getGitConfig) $ warning $ "** Despite annex.securehashesonly being set, " <> QuotedPath obj <> " has content present in the annex using an insecure " <> UnquotedString (decodeBS (formatKeyVariety (fromKey keyVariety key))) <> " key" - verifyLocationLog' key ai present u (logChange key u) + verifyLocationLog' key ai present u (logChange NoLiveUpdate key u) verifyLocationLogRemote :: Key -> ActionItem -> Remote -> Bool -> Annex Bool verifyLocationLogRemote key ai remote present = verifyLocationLog' key ai present (Remote.uuid remote) - (Remote.logStatus remote key) + (Remote.logStatus NoLiveUpdate remote key) verifyLocationLog' :: Key -> ActionItem -> Bool -> UUID -> (LogStatus -> Annex ()) -> Annex Bool verifyLocationLog' key ai present u updatestatus = do @@ -385,7 +385,7 @@ go requiredlocs = do presentlocs <- S.fromList <$> loggedLocations key missinglocs <- filterM - (\u -> isRequiredContent (Just u) S.empty (Just key) afile False) + (\u -> isRequiredContent NoLiveUpdate (Just u) S.empty (Just key) afile False) (S.toList $ S.difference requiredlocs presentlocs) if null missinglocs then return True @@ -641,7 +641,7 @@ dropped <- tryNonAsync (Remote.removeKey remote Nothing key) when (isRight dropped) $ - Remote.logStatus remote key InfoMissing + Remote.logStatus NoLiveUpdate remote key InfoMissing return $ case (movedbad, dropped) of (True, Right ()) -> "moved from " ++ Remote.name remote ++ " to " ++ fromRawFilePath destbad diff --git a/Command/Get.hs b/Command/Get.hs --- a/Command/Get.hs +++ b/Command/Get.hs @@ -56,42 +56,44 @@ ww = WarnUnmatchLsFiles "get" start :: GetOptions -> Maybe Remote -> SeekInput -> RawFilePath -> Key -> CommandStart -start o from si file key = start' expensivecheck from key afile ai si +start o from si file key = do + lu <- prepareLiveUpdate Nothing key AddingKey + start' lu (expensivecheck lu) from key afile ai si where afile = AssociatedFile (Just file) ai = mkActionItem (key, afile) - expensivecheck + expensivecheck lu | autoMode o = numCopiesCheck file key (<) - <||> wantGet False (Just key) afile + <||> wantGet lu False (Just key) afile | otherwise = return True startKeys :: Maybe Remote -> (SeekInput, Key, ActionItem) -> CommandStart startKeys from (si, key, ai) = checkFailedTransferDirection ai Download $ - start' (return True) from key (AssociatedFile Nothing) ai si + start' NoLiveUpdate (return True) from key (AssociatedFile Nothing) ai si -start' :: Annex Bool -> Maybe Remote -> Key -> AssociatedFile -> ActionItem -> SeekInput -> CommandStart -start' expensivecheck from key afile ai si = +start' :: LiveUpdate -> Annex Bool -> Maybe Remote -> Key -> AssociatedFile -> ActionItem -> SeekInput -> CommandStart +start' lu expensivecheck from key afile ai si = stopUnless expensivecheck $ case from of - Nothing -> go $ perform key afile + Nothing -> go $ perform lu key afile Just src -> stopUnless (Command.Move.fromOk src key) $ - go $ Command.Move.fromPerform src Command.Move.RemoveNever key afile + go $ Command.Move.fromPerform lu src Command.Move.RemoveNever key afile where go = starting "get" (OnlyActionOn key ai) si -perform :: Key -> AssociatedFile -> CommandPerform -perform key afile = stopUnless (getKey key afile) $ +perform :: LiveUpdate -> Key -> AssociatedFile -> CommandPerform +perform lu key afile = stopUnless (getKey lu key afile) $ next $ return True -- no cleanup needed {- Try to find a copy of the file in one of the remotes, - and copy it to here. -} -getKey :: Key -> AssociatedFile -> Annex Bool -getKey key afile = getKey' key afile +getKey :: LiveUpdate -> Key -> AssociatedFile -> Annex Bool +getKey lu key afile = getKey' lu key afile =<< Remote.keyPossibilities (Remote.IncludeIgnored False) key -getKey' :: Key -> AssociatedFile -> [Remote] -> Annex Bool -getKey' key afile = dispatch +getKey' :: LiveUpdate -> Key -> AssociatedFile -> [Remote] -> Annex Bool +getKey' lu key afile = dispatch where dispatch [] = do showNote (UnquotedString "not available") @@ -119,5 +121,5 @@ | otherwise = return True docopy r witness = do showAction $ UnquotedString $ "from " ++ Remote.name r - logStatusAfter key $ + logStatusAfter lu key $ download r key afile stdRetry witness diff --git a/Command/Import.hs b/Command/Import.hs --- a/Command/Import.hs +++ b/Command/Import.hs @@ -256,7 +256,7 @@ , inodeCache = newcache } } - ifM (checkFileMatcher largematcher destfile) + ifM (checkFileMatcher NoLiveUpdate largematcher destfile) ( ingestAdd' nullMeterUpdate (Just ld') (Just k) >>= maybe stop diff --git a/Command/Info.hs b/Command/Info.hs --- a/Command/Info.hs +++ b/Command/Info.hs @@ -1,16 +1,18 @@ {- git-annex command - - - Copyright 2011-2023 Joey Hess + - Copyright 2011-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE BangPatterns, DeriveDataTypeable, PackageImports, OverloadedStrings #-} +{-# LANGUAGE BangPatterns, DeriveDataTypeable, PackageImports #-} +{-# LANGUAGE OverloadedStrings, FlexibleContexts #-} module Command.Info where import "mtl" Control.Monad.State.Strict import qualified Data.Map.Strict as M +import qualified Data.Set as S import qualified Data.Vector as V import qualified System.FilePath.ByteString as P import System.PosixCompat.Files (isDirectory) @@ -33,6 +35,7 @@ import Logs.UUID import Logs.Trust import Logs.Location +import Annex.Branch (UnmergedBranches(..), getUnmergedRefs) import Annex.NumCopies import Git.Config (boolConfig) import qualified Git.LsTree as LsTree @@ -47,6 +50,7 @@ import qualified Limit import Messages.JSON (DualDisp(..), ObjectMap(..)) import Annex.BloomFilter +import Annex.RepoSize import qualified Command.Unused import qualified Utility.RawFilePath as R @@ -568,7 +572,8 @@ let maxlen = maximum (map (length . snd) l) descm <- lift Remote.uuidDescriptions -- This also handles json display. - s <- lift $ Remote.prettyPrintUUIDsWith (Just "size") desc descm (Just . show) $ + s <- lift $ Remote.prettyPrintUUIDsWith (Just "size") desc descm + (\sz -> Just $ show sz ++ ": ") $ map (\(u, sz) -> (u, Just $ mkdisp sz maxlen)) l return $ if count then countRepoList (length l) s @@ -639,22 +644,50 @@ case allRepoData s of Just _ -> return s Nothing -> do - matcher <- lift getKeyOnlyMatcher - !(d, rd) <- lift $ overLocationLogs (emptyKeyInfo, mempty) $ \k locs (d, rd) -> do - ifM (matchOnKey matcher k) - ( do - alivelocs <- snd - <$> trustPartition DeadTrusted locs - let !d' = addKeyCopies (genericLength alivelocs) k d - let !rd' = foldl' (flip (accumrepodata k)) rd alivelocs - return (d', rd') - , return (d, rd) - ) - let s' = s { allRepoData = Just d, repoData = rd } + s' <- ifM (lift Limit.limited) + ( limitedcalc s + , usereposizes s + ) put s' return s' where + usereposizes s = do + sizemap <- lift $ getRepoSizes True + deadset <- lift $ S.fromList <$> trustGet DeadTrusted + let sizemap' = M.filter (> 0) $ M.withoutKeys sizemap deadset + lift $ unlessM (null <$> getUnmergedRefs) + warnunmerged + return $ s + { allRepoData = Just $ + convsize (sum (M.elems sizemap')) + , repoData = M.map convsize sizemap' + } + + limitedcalc s = do + matcher <- lift getKeyOnlyMatcher + r <- lift $ overLocationLogs False False (emptyKeyInfo, mempty) $ \k locs (d, rd) -> do + ifM (matchOnKey matcher k) + ( do + alivelocs <- snd + <$> trustPartition DeadTrusted locs + let !d' = addKeyCopies (genericLength alivelocs) k d + let !rd' = foldl' (flip (accumrepodata k)) rd alivelocs + return (d', rd') + , return (d, rd) + ) + (!(d, rd), _) <- case r of + NoUnmergedBranches v -> + return v + UnmergedBranches v -> do + lift warnunmerged + return v + return $ s { allRepoData = Just d, repoData = rd } + accumrepodata k = M.alter (Just . addKey k . fromMaybe emptyKeyInfo) + + convsize (RepoSize sz) = emptyKeyInfo { sizeKeys = sz } + + warnunmerged = warning "There are unmerged git-annex branches. Information from those branches is not included here." cachedNumCopiesStats :: StatState (Maybe NumCopiesStats) cachedNumCopiesStats = numCopiesStats <$> get diff --git a/Command/Lock.hs b/Command/Lock.hs --- a/Command/Lock.hs +++ b/Command/Lock.hs @@ -98,7 +98,7 @@ ) Nothing -> lostcontent - lostcontent = logStatus key InfoMissing + lostcontent = logStatus NoLiveUpdate key InfoMissing errorModified :: a errorModified = giveup "Locking this file would discard any changes you have made to it. Use 'git annex add' to stage your changes. (Or, use --force to override)" diff --git a/Command/LookupKey.hs b/Command/LookupKey.hs --- a/Command/LookupKey.hs +++ b/Command/LookupKey.hs @@ -15,7 +15,7 @@ import Utility.SafeOutput cmd :: Command -cmd = notBareRepo $ noCommit $ noMessages $ +cmd = noCommit $ noMessages $ command "lookupkey" SectionPlumbing "looks up key used for file" (paramRepeating paramFile) @@ -35,9 +35,11 @@ run :: LookupKeyOptions -> SeekInput -> String -> Annex Bool run o _ file | refOption o = catKey (Ref (toRawFilePath file)) >>= display - | otherwise = seekSingleGitFile file >>= \case - Nothing -> return False - Just file' -> catKeyFile file' >>= display + | otherwise = do + checkNotBareRepo + seekSingleGitFile file >>= \case + Nothing -> return False + Just file' -> catKeyFile file' >>= display display :: Maybe Key -> Annex Bool display (Just k) = do diff --git a/Command/MatchExpression.hs b/Command/MatchExpression.hs --- a/Command/MatchExpression.hs +++ b/Command/MatchExpression.hs @@ -90,7 +90,7 @@ , liftIO exitFailure ) where - checkmatcher matcher = checkMatcher' matcher (matchinfo o) S.empty + checkmatcher matcher = checkMatcher' matcher (matchinfo o) NoLiveUpdate S.empty bail :: String -> IO a bail s = do diff --git a/Command/MaxSize.hs b/Command/MaxSize.hs new file mode 100644 --- /dev/null +++ b/Command/MaxSize.hs @@ -0,0 +1,137 @@ +{- git-annex command + - + - Copyright 2024 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE OverloadedStrings #-} + +module Command.MaxSize where + +import Command +import qualified Remote +import Annex.RepoSize +import Logs.MaxSize +import Logs.Trust +import Utility.DataUnits +import Utility.Percentage + +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Data.Text as T + +cmd :: Command +cmd = noMessages $ withAnnexOptions [jsonOptions] $ + command "maxsize" SectionSetup + "configure maximum size of repositoriy" + (paramPair paramRepository (paramOptional paramSize)) + (seek <$$> optParser) + +data MaxSizeOptions = MaxSizeOptions + { cmdparams :: CmdParams + , bytesOption :: Bool + } + +optParser :: CmdParamsDesc -> Parser MaxSizeOptions +optParser desc = MaxSizeOptions + <$> cmdParams desc + <*> switch + ( long "bytes" + <> help "display sizes in bytes" + ) + +seek :: MaxSizeOptions -> CommandSeek +seek o = case cmdparams o of + (rname:[]) -> commandAction $ do + enableNormalOutput + showCustom "maxsize" (SeekInput [rname]) $ do + u <- Remote.nameToUUID rname + v <- M.lookup u <$> getMaxSizes + maybeAddJSONField "maxsize" (fromMaxSize <$> v) + showRaw $ encodeBS $ case v of + Just (MaxSize n) -> + formatSize o (preciseSize storageUnits True) n + Nothing -> "" + return True + stop + (rname:sz:[]) -> commandAction $ do + u <- Remote.nameToUUID rname + let si = SeekInput (cmdparams o) + let ai = ActionItemOther (Just (UnquotedString rname)) + startingUsualMessages "maxsize" ai si $ + case readSize dataUnits sz of + Nothing -> giveup "Unable to parse size." + Just n -> do + recordMaxSize u (MaxSize n) + next $ return True + [] -> commandAction $ sizeOverview o + _ -> giveup "Too many parameters" + +sizeOverview :: MaxSizeOptions -> CommandStart +sizeOverview o = do + enableNormalOutput + showCustom "maxsize" (SeekInput []) $ do + descmap <- Remote.uuidDescriptions + deadset <- S.fromList <$> trustGet DeadTrusted + maxsizes <- getMaxSizes + reposizes <- getRepoSizes True + -- Add repos too new and empty to have a reposize, + -- whose maxsize has been set. + let reposizes' = foldl' + (\m u -> M.insertWith (flip const) u (RepoSize 0) m) + reposizes + (M.keys maxsizes) + let reposizes'' = flip M.withoutKeys deadset reposizes' + let l = reverse $ sortOn snd $ M.toList $ + M.mapWithKey (gather maxsizes) reposizes'' + v <- Remote.prettyPrintUUIDsWith' False (Just "size") + "repositories" descmap showsizes l + showRaw $ encodeBS $ tablerow (zip widths headers) + showRaw $ encodeBS $ dropWhileEnd (== '\n') v + return True + stop + where + sizefield = "size" :: T.Text + maxsizefield = "maxsize" :: T.Text + + gather maxsizes u (RepoSize currsize) = Just $ M.fromList + [ (sizefield, Just currsize) + , (maxsizefield, fromMaxSize <$> M.lookup u maxsizes) + ] + + (widths, headers) = unzip + [ (7, "size") + , (7, "maxsize") + , (6, "%full") + , (0, "repository") + ] + + showsizes m = do + size <- M.lookup sizefield m + maxsize <- M.lookup maxsizefield m + return $ tablerow $ zip widths + [ formatsize size + , formatsize maxsize + , case (size, maxsize) of + (Just size', Just maxsize') + | size' <= maxsize' -> + showPercentage 0 $ + percentage maxsize' size' + | otherwise -> ">100%" + _ -> "" + , "" + ] + + formatsize = maybe "" (formatSize o (roughSize' storageUnits True 0)) + + padcolumn width s = replicate (width - length s) ' ' ++ s + + tablerow [] = "" + tablerow ((_, s):[]) = " " ++ s + tablerow ((width, s):l) = padcolumn width s ++ " " ++ tablerow l + +formatSize :: MaxSizeOptions -> (ByteSize -> String) -> ByteSize -> String +formatSize o f n + | bytesOption o = show n + | otherwise = f n diff --git a/Command/Migrate.hs b/Command/Migrate.hs --- a/Command/Migrate.hs +++ b/Command/Migrate.hs @@ -174,7 +174,7 @@ starting "migrate" ai (SeekInput []) $ ifM (Command.ReKey.linkKey' v oldkey newkey) ( do - logStatus newkey InfoPresent + logStatus NoLiveUpdate newkey InfoPresent next $ return True , next $ return False ) diff --git a/Command/Mirror.hs b/Command/Mirror.hs --- a/Command/Mirror.hs +++ b/Command/Mirror.hs @@ -66,10 +66,10 @@ startKey :: MirrorOptions -> AssociatedFile -> (SeekInput, Key, ActionItem) -> CommandStart startKey o afile (si, key, ai) = case fromToOptions o of ToRemote r -> checkFailedTransferDirection ai Upload $ ifM (inAnnex key) - ( Command.Move.toStart Command.Move.RemoveNever afile key ai si =<< getParsed r + ( Command.Move.toStart NoLiveUpdate Command.Move.RemoveNever afile key ai si =<< getParsed r , do (numcopies, mincopies) <- getSafestNumMinCopies afile key - Command.Drop.startRemote pcc afile ai si numcopies mincopies key (Command.Drop.DroppingUnused False) + Command.Drop.startRemote NoLiveUpdate pcc afile ai si numcopies mincopies key (Command.Drop.DroppingUnused False) =<< getParsed r ) FromRemote r -> checkFailedTransferDirection ai Download $ do @@ -78,12 +78,12 @@ Left _ -> stop Right True -> ifM (inAnnex key) ( stop - , Command.Get.start' (return True) Nothing key afile ai si + , Command.Get.start' NoLiveUpdate (return True) Nothing key afile ai si ) Right False -> ifM (inAnnex key) ( do (numcopies, mincopies) <- getSafestNumMinCopies afile key - Command.Drop.startLocal pcc afile ai si numcopies mincopies key [] (Command.Drop.DroppingUnused False) + Command.Drop.startLocal NoLiveUpdate pcc afile ai si numcopies mincopies key [] (Command.Drop.DroppingUnused False) , stop ) where diff --git a/Command/Move.hs b/Command/Move.hs --- a/Command/Move.hs +++ b/Command/Move.hs @@ -75,7 +75,7 @@ batchAnnexed fmt seeker keyaction where seeker = AnnexedFileSeeker - { startAction = const $ start fto (removeWhen o) + { startAction = const $ start NoLiveUpdate fto (removeWhen o) , checkContentPresent = case fto of FromOrToRemote (FromRemote _) -> Nothing FromOrToRemote (ToRemote _) -> Just True @@ -84,7 +84,7 @@ FromAnywhereToRemote _ -> Nothing , usesLocationLog = True } - keyaction = startKey fto (removeWhen o) + keyaction = startKey NoLiveUpdate fto (removeWhen o) ww = WarnUnmatchLsFiles "move" stages :: FromToHereOptions -> UsedStages @@ -94,49 +94,49 @@ stages (FromRemoteToRemote _ _) = transferStages stages (FromAnywhereToRemote _) = transferStages -start :: FromToHereOptions -> RemoveWhen -> SeekInput -> RawFilePath -> Key -> CommandStart -start fromto removewhen si f k = start' fromto removewhen afile si k ai +start :: LiveUpdate -> FromToHereOptions -> RemoveWhen -> SeekInput -> RawFilePath -> Key -> CommandStart +start lu fromto removewhen si f k = start' lu fromto removewhen afile si k ai where afile = AssociatedFile (Just f) ai = mkActionItem (k, afile) -startKey :: FromToHereOptions -> RemoveWhen -> (SeekInput, Key, ActionItem) -> CommandStart -startKey fromto removewhen (si, k, ai) = - start' fromto removewhen (AssociatedFile Nothing) si k ai +startKey :: LiveUpdate -> FromToHereOptions -> RemoveWhen -> (SeekInput, Key, ActionItem) -> CommandStart +startKey lu fromto removewhen (si, k, ai) = + start' lu fromto removewhen (AssociatedFile Nothing) si k ai -start' :: FromToHereOptions -> RemoveWhen -> AssociatedFile -> SeekInput -> Key -> ActionItem -> CommandStart -start' fromto removewhen afile si key ai = +start' :: LiveUpdate -> FromToHereOptions -> RemoveWhen -> AssociatedFile -> SeekInput -> Key -> ActionItem -> CommandStart +start' lu fromto removewhen afile si key ai = case fromto of FromOrToRemote (FromRemote src) -> checkFailedTransferDirection ai Download $ - fromStart removewhen afile key ai si =<< getParsed src + fromStart lu removewhen afile key ai si =<< getParsed src FromOrToRemote (ToRemote dest) -> checkFailedTransferDirection ai Upload $ - toStart removewhen afile key ai si =<< getParsed dest + toStart lu removewhen afile key ai si =<< getParsed dest ToHere -> checkFailedTransferDirection ai Download $ - toHereStart removewhen afile key ai si + toHereStart lu removewhen afile key ai si FromRemoteToRemote src dest -> do src' <- getParsed src dest' <- getParsed dest - fromToStart removewhen afile key ai si src' dest' + fromToStart lu removewhen afile key ai si src' dest' FromAnywhereToRemote dest -> do dest' <- getParsed dest - fromAnywhereToStart removewhen afile key ai si dest' + fromAnywhereToStart lu removewhen afile key ai si dest' describeMoveAction :: RemoveWhen -> String describeMoveAction RemoveNever = "copy" describeMoveAction _ = "move" -toStart :: RemoveWhen -> AssociatedFile -> Key -> ActionItem -> SeekInput -> Remote -> CommandStart -toStart removewhen afile key ai si dest = do +toStart :: LiveUpdate -> RemoveWhen -> AssociatedFile -> Key -> ActionItem -> SeekInput -> Remote -> CommandStart +toStart lu removewhen afile key ai si dest = do u <- getUUID if u == Remote.uuid dest then stop - else toStart' dest removewhen afile key ai si + else toStart' lu dest removewhen afile key ai si -toStart' :: Remote -> RemoveWhen -> AssociatedFile -> Key -> ActionItem -> SeekInput -> CommandStart -toStart' dest removewhen afile key ai si = do +toStart' :: LiveUpdate -> Remote -> RemoveWhen -> AssociatedFile -> Key -> ActionItem -> SeekInput -> CommandStart +toStart' lu dest removewhen afile key ai si = do fast <- Annex.getRead Annex.fast if fast && removewhen == RemoveNever then ifM (expectedPresent dest key) @@ -147,18 +147,18 @@ where go fastcheck isthere = starting (describeMoveAction removewhen) (OnlyActionOn key ai) si $ - toPerform dest removewhen key afile fastcheck =<< isthere + toPerform lu dest removewhen key afile fastcheck =<< isthere expectedPresent :: Remote -> Key -> Annex Bool expectedPresent dest key = do remotes <- Remote.keyPossibilities (Remote.IncludeIgnored True) key return $ dest `elem` remotes -toPerform :: Remote -> RemoveWhen -> Key -> AssociatedFile -> Bool -> Either String Bool -> CommandPerform +toPerform :: LiveUpdate -> Remote -> RemoveWhen -> Key -> AssociatedFile -> Bool -> Either String Bool -> CommandPerform toPerform = toPerform' Nothing -toPerform' :: Maybe ContentRemovalLock -> Remote -> RemoveWhen -> Key -> AssociatedFile -> Bool -> Either String Bool -> CommandPerform -toPerform' mcontentlock dest removewhen key afile fastcheck isthere = do +toPerform' :: Maybe ContentRemovalLock -> LiveUpdate -> Remote -> RemoveWhen -> Key -> AssociatedFile -> Bool -> Either String Bool -> CommandPerform +toPerform' mcontentlock lu dest removewhen key afile fastcheck isthere = do srcuuid <- getUUID case isthere of Left err -> do @@ -170,7 +170,7 @@ upload dest key afile stdRetry if ok then finish deststartedwithcopy $ - Remote.logStatus dest key InfoPresent + Remote.logStatus lu dest key InfoPresent else do logMoveCleanup deststartedwithcopy when fastcheck $ @@ -179,7 +179,7 @@ Right True -> logMove srcuuid destuuid True key $ \deststartedwithcopy -> finish deststartedwithcopy $ unlessM (expectedPresent dest key) $ - Remote.logStatus dest key InfoPresent + Remote.logStatus lu dest key InfoPresent where destuuid = Remote.uuid dest finish deststartedwithcopy setpresentremote = case removewhen of @@ -189,7 +189,7 @@ next $ return True RemoveSafe -> lockcontentforremoval $ \contentlock -> do srcuuid <- getUUID - r <- willDropMakeItWorse srcuuid destuuid deststartedwithcopy key afile >>= \case + r <- willDropMakeItWorse lu srcuuid destuuid deststartedwithcopy key afile >>= \case DropAllowed -> drophere setpresentremote contentlock "moved" DropCheckNumCopies -> do (numcopies, mincopies) <- getSafestNumMinCopies afile key @@ -214,7 +214,7 @@ removeAnnex contentlock next $ do () <- setpresentremote - Command.Drop.cleanupLocal key (Command.Drop.DroppingUnused False) + Command.Drop.cleanupLocal lu key (Command.Drop.DroppingUnused False) faileddrophere setpresentremote = do showLongNote "(Use --force to override this check, or adjust numcopies.)" showLongNote "Content not dropped from here." @@ -231,13 +231,14 @@ -- is present, but due to buffering, may find it present for the -- second file before the first is dropped. If so, nothing remains -- to be done except for cleaning up. - lockfailed = next $ Command.Drop.cleanupLocal key (Command.Drop.DroppingUnused False) + lockfailed = next $ Command.Drop.cleanupLocal lu key + (Command.Drop.DroppingUnused False) -fromStart :: RemoveWhen -> AssociatedFile -> Key -> ActionItem -> SeekInput -> Remote -> CommandStart -fromStart removewhen afile key ai si src = +fromStart :: LiveUpdate -> RemoveWhen -> AssociatedFile -> Key -> ActionItem -> SeekInput -> Remote -> CommandStart +fromStart lu removewhen afile key ai si src = stopUnless (fromOk src key) $ starting (describeMoveAction removewhen) (OnlyActionOn key ai) si $ - fromPerform src removewhen key afile + fromPerform lu src removewhen key afile fromOk :: Remote -> Key -> Annex Bool fromOk src key @@ -257,14 +258,14 @@ remotes <- Remote.keyPossibilities (Remote.IncludeIgnored True) key return $ u /= Remote.uuid src && elem src remotes -fromPerform :: Remote -> RemoveWhen -> Key -> AssociatedFile -> CommandPerform -fromPerform src removewhen key afile = do +fromPerform :: LiveUpdate -> Remote -> RemoveWhen -> Key -> AssociatedFile -> CommandPerform +fromPerform lu src removewhen key afile = do present <- inAnnex key - finish <- fromPerform' present True src key afile + finish <- fromPerform' lu present True src key afile finish removewhen -fromPerform' :: Bool -> Bool -> Remote -> Key -> AssociatedFile -> Annex (RemoveWhen -> CommandPerform) -fromPerform' present updatelocationlog src key afile = do +fromPerform' :: LiveUpdate -> Bool -> Bool -> Remote -> Key -> AssociatedFile -> Annex (RemoveWhen -> CommandPerform) +fromPerform' lu present updatelocationlog src key afile = do showAction $ UnquotedString $ "from " ++ Remote.name src destuuid <- getUUID logMove (Remote.uuid src) destuuid present key $ \deststartedwithcopy -> @@ -279,7 +280,7 @@ download src key afile stdRetry logdownload a - | updatelocationlog = logStatusAfter key a + | updatelocationlog = logStatusAfter lu key a | otherwise = a finish deststartedwithcopy False _ = do @@ -291,17 +292,20 @@ finish deststartedwithcopy True RemoveSafe = do destuuid <- getUUID lockContentShared key Nothing $ \_lck -> - fromDrop src destuuid deststartedwithcopy key afile id + fromDrop lu src destuuid deststartedwithcopy key afile id -fromDrop :: Remote -> UUID -> DestStartedWithCopy -> Key -> AssociatedFile -> ([UnVerifiedCopy] -> [UnVerifiedCopy])-> CommandPerform -fromDrop src destuuid deststartedwithcopy key afile adjusttocheck = - willDropMakeItWorse (Remote.uuid src) destuuid deststartedwithcopy key afile >>= \case +fromDrop :: LiveUpdate -> Remote -> UUID -> DestStartedWithCopy -> Key -> AssociatedFile -> ([UnVerifiedCopy] -> [UnVerifiedCopy])-> CommandPerform +fromDrop lu src destuuid deststartedwithcopy key afile adjusttocheck = + willDropMakeItWorse lu (Remote.uuid src) destuuid deststartedwithcopy key afile >>= \case DropAllowed -> dropremote Nothing "moved" DropCheckNumCopies -> do (numcopies, mincopies) <- getSafestNumMinCopies afile key (tocheck, verified) <- verifiableCopies key [Remote.uuid src] - verifyEnoughCopiesToDrop "" key (Just (Remote.uuid src)) Nothing numcopies mincopies [Remote.uuid src] verified - (adjusttocheck tocheck) dropremotewithproof faileddropremote + verifyEnoughCopiesToDrop "" key + (Just (Remote.uuid src)) Nothing + numcopies mincopies [Remote.uuid src] + verified (adjusttocheck tocheck) + dropremotewithproof faileddropremote DropWorse -> faileddropremote where showproof proof = "proof: " ++ show proof @@ -318,7 +322,8 @@ ok <- Remote.action (Remote.removeKey src mproof key) when ok $ logMoveCleanup deststartedwithcopy - next $ Command.Drop.cleanupRemote key src (Command.Drop.DroppingUnused False) ok + next $ Command.Drop.cleanupRemote lu key src + (Command.Drop.DroppingUnused False) ok faileddropremote = do showLongNote "(Use --force to override this check, or adjust numcopies.)" @@ -331,27 +336,27 @@ - - When moving, the content is removed from all the reachable remotes that - it can safely be removed from. -} -toHereStart :: RemoveWhen -> AssociatedFile -> Key -> ActionItem -> SeekInput -> CommandStart -toHereStart removewhen afile key ai si = +toHereStart :: LiveUpdate -> RemoveWhen -> AssociatedFile -> Key -> ActionItem -> SeekInput -> CommandStart +toHereStart lu removewhen afile key ai si = startingNoMessage (OnlyActionOn key ai) $ do rs <- Remote.keyPossibilities (Remote.IncludeIgnored False) key forM_ rs $ \r -> includeCommandAction $ starting (describeMoveAction removewhen) ai si $ - fromPerform r removewhen key afile + fromPerform lu r removewhen key afile next $ return True -fromToStart :: RemoveWhen -> AssociatedFile -> Key -> ActionItem -> SeekInput -> Remote -> Remote -> CommandStart -fromToStart removewhen afile key ai si src dest = +fromToStart :: LiveUpdate -> RemoveWhen -> AssociatedFile -> Key -> ActionItem -> SeekInput -> Remote -> Remote -> CommandStart +fromToStart lu removewhen afile key ai si src dest = stopUnless somethingtodo $ do u <- getUUID if u == Remote.uuid src - then toStart removewhen afile key ai si dest + then toStart lu removewhen afile key ai si dest else if u == Remote.uuid dest - then fromStart removewhen afile key ai si src + then fromStart lu removewhen afile key ai si src else stopUnless (fromOk src key) $ starting (describeMoveAction removewhen) (OnlyActionOn key ai) si $ - fromToPerform src dest removewhen key afile + fromToPerform lu src dest removewhen key afile where somethingtodo | Remote.uuid src == Remote.uuid dest = return False @@ -361,22 +366,22 @@ then not <$> expectedPresent dest key else return True -fromAnywhereToStart :: RemoveWhen -> AssociatedFile -> Key -> ActionItem -> SeekInput -> Remote -> CommandStart -fromAnywhereToStart removewhen afile key ai si dest = +fromAnywhereToStart :: LiveUpdate -> RemoveWhen -> AssociatedFile -> Key -> ActionItem -> SeekInput -> Remote -> CommandStart +fromAnywhereToStart lu removewhen afile key ai si dest = stopUnless somethingtodo $ do u <- getUUID if u == Remote.uuid dest - then toHereStart removewhen afile key ai si + then toHereStart lu removewhen afile key ai si else startingNoMessage (OnlyActionOn key ai) $ do rs <- filter (/= dest) <$> Remote.keyPossibilities (Remote.IncludeIgnored False) key forM_ rs $ \r -> includeCommandAction $ starting (describeMoveAction removewhen) ai si $ - fromToPerform r dest removewhen key afile + fromToPerform lu r dest removewhen key afile whenM (inAnnex key) $ void $ includeCommandAction $ - toStart removewhen afile key ai si dest + toStart lu removewhen afile key ai si dest next $ return True where somethingtodo = do @@ -400,8 +405,8 @@ - may end up locally present, or not. This is similar to the behavior - when running `git-annex move --to` concurrently with git-annex get. -} -fromToPerform :: Remote -> Remote -> RemoveWhen -> Key -> AssociatedFile -> CommandPerform -fromToPerform src dest removewhen key afile = do +fromToPerform :: LiveUpdate -> Remote -> Remote -> RemoveWhen -> Key -> AssociatedFile -> CommandPerform +fromToPerform lu src dest removewhen key afile = do hereuuid <- getUUID loggedpresent <- any (== hereuuid) <$> loggedLocations key @@ -441,7 +446,7 @@ "to " ++ Remote.name dest -- The log may not indicate dest's copy -- yet, so make sure it does. - logChange key (Remote.uuid dest) InfoPresent + logChange lu key (Remote.uuid dest) InfoPresent -- Drop from src, checking copies including -- the one already in dest. dropfromsrc id @@ -472,13 +477,13 @@ ) ) - fromsrc present = fromPerform' present False src key afile + fromsrc present = fromPerform' lu present False src key afile - todest mcontentlock removewhen' = toPerform' mcontentlock dest removewhen' key afile False + todest mcontentlock removewhen' = toPerform' mcontentlock lu dest removewhen' key afile False dropfromsrc adjusttocheck = case removewhen of RemoveSafe -> logMove (Remote.uuid src) (Remote.uuid dest) True key $ \deststartedwithcopy -> - fromDrop src (Remote.uuid dest) deststartedwithcopy key afile adjusttocheck + fromDrop lu src (Remote.uuid dest) deststartedwithcopy key afile adjusttocheck RemoveNever -> next (return True) combinecleanups a b = a >>= \case @@ -521,9 +526,9 @@ - This function checks all that. It needs to know if the destination - repository already had a copy of the file before the move began. -} -willDropMakeItWorse :: UUID -> UUID -> DestStartedWithCopy -> Key -> AssociatedFile -> Annex DropCheck -willDropMakeItWorse srcuuid destuuid (DestStartedWithCopy deststartedwithcopy _) key afile = - ifM (Command.Drop.checkRequiredContent (Command.Drop.PreferredContentChecked False) srcuuid key afile) +willDropMakeItWorse :: LiveUpdate -> UUID -> UUID -> DestStartedWithCopy -> Key -> AssociatedFile -> Annex DropCheck +willDropMakeItWorse lu srcuuid destuuid (DestStartedWithCopy deststartedwithcopy _) key afile = + ifM (Command.Drop.checkRequiredContent lu (Command.Drop.PreferredContentChecked False) srcuuid key afile) ( if deststartedwithcopy || isClusterUUID srcuuid then unlessforced DropCheckNumCopies else ifM checktrustlevel diff --git a/Command/Multicast.hs b/Command/Multicast.hs --- a/Command/Multicast.hs +++ b/Command/Multicast.hs @@ -213,7 +213,7 @@ Nothing -> do warning $ "Received a file " <> QuotedPath (toRawFilePath f) <> " that is not a git-annex key. Deleting this file." liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f) - Just k -> void $ logStatusAfter k $ + Just k -> void $ logStatusAfter NoLiveUpdate k $ getViaTmpFromDisk RetrievalVerifiableKeysSecure AlwaysVerify k (AssociatedFile Nothing) $ \dest -> unVerified $ liftIO $ catchBoolIO $ do R.rename (toRawFilePath f) dest diff --git a/Command/PostReceive.hs b/Command/PostReceive.hs --- a/Command/PostReceive.hs +++ b/Command/PostReceive.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2017 Joey Hess + - Copyright 2017-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -11,11 +11,24 @@ import Command import qualified Annex -import Git.Types import Annex.UpdateInstead import Annex.CurrentBranch import Command.Sync (mergeLocal, prepMerge, mergeConfig, SyncOptions(..)) +import Annex.Proxy +import Remote +import qualified Types.Remote as Remote +import Config +import Git.Types +import Git.Sha +import Git.FilePath +import qualified Git.Ref +import Command.Export (filterExport, getExportCommit, seekExport) +import Command.Sync (syncBranch) +import qualified Data.Set as S +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 + -- This does not need to modify the git-annex branch to update the -- work tree, but auto-initialization might change the git-annex branch. -- Since it would be surprising for a post-receive hook to make such a @@ -28,10 +41,63 @@ (withParams seek) seek :: CmdParams -> CommandSeek -seek _ = whenM needUpdateInsteadEmulation $ do +seek _ = do fixPostReceiveHookEnv - commandAction updateInsteadEmulation + whenM needUpdateInsteadEmulation $ + commandAction updateInsteadEmulation + proxyExportTree +updateInsteadEmulation :: CommandStart +updateInsteadEmulation = do + prepMerge + let o = def { notOnlyAnnexOption = True } + mc <- mergeConfig False + mergeLocal mc o =<< getCurrentBranch + +proxyExportTree :: CommandSeek +proxyExportTree = do + rbs <- catMaybes <$> (mapM canexport =<< proxyForRemotes) + unless (null rbs) $ do + pushedbranches <- liftIO $ + S.fromList . map snd . parseHookInput + <$> B.hGetContents stdin + let waspushed (r, (b, d)) + | S.member (Git.Ref.branchRef b) pushedbranches = + Just (r, b, d) + | S.member (Git.Ref.branchRef (syncBranch b)) pushedbranches = + Just (r, syncBranch b, d) + | otherwise = Nothing + case headMaybe (mapMaybe waspushed rbs) of + Just (r, b, Nothing) -> go r b + Just (r, b, Just d) -> go r $ + Git.Ref.branchFileRef b (getTopFilePath d) + Nothing -> noop + where + canexport r = case remoteAnnexTrackingBranch (Remote.gitconfig r) of + Nothing -> return Nothing + Just branch -> + ifM (isExportSupported r) + ( return (Just (r, splitRemoteAnnexTrackingBranchSubdir branch)) + , return Nothing + ) + + go r b = inRepo (Git.Ref.tree b) >>= \case + Nothing -> return () + Just t -> do + tree <- filterExport r t + mtbcommitsha <- getExportCommit r b + seekExport r tree mtbcommitsha [r] + +parseHookInput :: B.ByteString -> [((Sha, Sha), Ref)] +parseHookInput = mapMaybe parse . B8.lines + where + parse l = case B8.words l of + (oldb:newb:refb:[]) -> do + old <- extractSha oldb + new <- extractSha newb + return ((old, new), Ref refb) + _ -> Nothing + {- When run by the post-receive hook, the cwd is the .git directory, - and GIT_DIR=. It's not clear why git does this. - @@ -50,9 +116,3 @@ } _ -> noop -updateInsteadEmulation :: CommandStart -updateInsteadEmulation = do - prepMerge - let o = def { notOnlyAnnexOption = True } - mc <- mergeConfig False - mergeLocal mc o =<< getCurrentBranch diff --git a/Command/ReKey.hs b/Command/ReKey.hs --- a/Command/ReKey.hs +++ b/Command/ReKey.hs @@ -149,6 +149,6 @@ return (MigrationRecord sha) ) whenM (inAnnex newkey) $ - logStatus newkey InfoPresent + logStatus NoLiveUpdate newkey InfoPresent a newkeyrec return True diff --git a/Command/RecvKey.hs b/Command/RecvKey.hs --- a/Command/RecvKey.hs +++ b/Command/RecvKey.hs @@ -30,7 +30,7 @@ let rsp = RetrievalAllKeysSecure ifM (getViaTmp rsp DefaultVerify key (AssociatedFile Nothing) Nothing go) ( do - logStatus key InfoPresent + logStatus NoLiveUpdate key InfoPresent _ <- quiesce True return True , return False diff --git a/Command/RegisterUrl.hs b/Command/RegisterUrl.hs --- a/Command/RegisterUrl.hs +++ b/Command/RegisterUrl.hs @@ -86,5 +86,5 @@ -- does not have an OtherDownloader, but this command needs to do -- it for urls claimed by other remotes as well. case snd (getDownloader url) of - OtherDownloader -> logChange key (Remote.uuid remote) InfoPresent + OtherDownloader -> logChange NoLiveUpdate key (Remote.uuid remote) InfoPresent _ -> return () diff --git a/Command/Reinject.hs b/Command/Reinject.hs --- a/Command/Reinject.hs +++ b/Command/Reinject.hs @@ -133,5 +133,5 @@ cleanup :: Key -> CommandCleanup cleanup key = do - logStatus key InfoPresent + logStatus NoLiveUpdate key InfoPresent return True diff --git a/Command/SetKey.hs b/Command/SetKey.hs --- a/Command/SetKey.hs +++ b/Command/SetKey.hs @@ -48,5 +48,5 @@ cleanup :: Key -> CommandCleanup cleanup key = do - logStatus key InfoPresent + logStatus NoLiveUpdate key InfoPresent return True diff --git a/Command/SetPresentKey.hs b/Command/SetPresentKey.hs --- a/Command/SetPresentKey.hs +++ b/Command/SetPresentKey.hs @@ -54,5 +54,5 @@ perform :: Key -> UUID -> LogStatus -> CommandPerform perform k u s = next $ do - logChange k u s + logChange NoLiveUpdate k u s return True diff --git a/Command/Smudge.hs b/Command/Smudge.hs --- a/Command/Smudge.hs +++ b/Command/Smudge.hs @@ -191,7 +191,7 @@ =<< lockDown cfg (fromRawFilePath file) postingest (Just k, _) = do - logStatus k InfoPresent + logStatus NoLiveUpdate k InfoPresent return k postingest _ = giveup "could not add file to the annex" @@ -248,7 +248,7 @@ where go = do matcher <- largeFilesMatcher - checkFileMatcher' matcher file d + checkFileMatcher' NoLiveUpdate matcher file d checkwasannexed = pure $ isJust moldkey diff --git a/Command/Sync.hs b/Command/Sync.hs --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -28,6 +28,7 @@ parseUnrelatedHistoriesOption, SyncOptions(..), OperationMode(..), + syncBranch, ) where import Command @@ -87,8 +88,6 @@ import Control.Concurrent.MVar import qualified Data.Map as M -import qualified Data.ByteString as S -import Data.Char cmd :: Command cmd = withAnnexOptions [jobsOption, backendOption] $ @@ -307,15 +306,15 @@ -- repositories, in case that lets content -- be dropped from other repositories. exportedcontent <- withbranch $ - seekExportContent (Just o) - (filter isExport contentremotes) + seekExportContent (Just o) contentremotes -- Sync content with remotes, including -- importing from import remotes (since -- importing only downloads new files not -- old files) let shouldsynccontent r - | isExport r && not (isImport r) = False + | isExport r && not (isImport r) + && not (exportHasAnnexObjects r) = False | otherwise = True syncedcontent <- withbranch $ seekSyncContent o @@ -927,37 +926,41 @@ return (got || not (null putrs)) where - wantget have inhere = allM id + wantget lu have inhere = allM id [ pure (pullOption o || operationMode o == SatisfyMode) , pure (not $ null have) , pure (not inhere) - , wantGet True (Just k) af + , wantGet lu True (Just k) af ] - handleget have inhere = ifM (wantget have inhere) - ( return [ get have ] - , return [] - ) - get have = includeCommandAction $ starting "get" ai si $ - stopUnless (getKey' k af have) $ + handleget have inhere = do + lu <- prepareLiveUpdate Nothing k AddingKey + ifM (wantget lu have inhere) + ( return [ get lu have ] + , return [] + ) + get lu have = includeCommandAction $ starting "get" ai si $ + stopUnless (getKey' lu k af have) $ next $ return True - wantput r + wantput lu r | pushOption o == False && operationMode o /= SatisfyMode = return False | Remote.readonly r || remoteAnnexReadOnly (Remote.gitconfig r) = return False - | isExport r || isImport r = return False + | isImport r && not (isExport r) = return False + | isExport r && not (exportHasAnnexObjects r) = return False | isThirdPartyPopulated r = return False - | otherwise = wantGetBy True (Just k) af (Remote.uuid r) + | otherwise = wantGetBy lu True (Just k) af (Remote.uuid r) handleput lack inhere | inhere = catMaybes <$> - ( forM lack $ \r -> - ifM (wantput r <&&> put r) + ( forM lack $ \r -> do + lu <- prepareLiveUpdate (Just (Remote.uuid r)) k AddingKey + ifM (wantput lu r <&&> put lu r) ( return (Just (Remote.uuid r)) , return Nothing ) ) | otherwise = return [] - put dest = includeCommandAction $ - Command.Move.toStart' dest Command.Move.RemoveNever af k ai si + put lu dest = includeCommandAction $ + Command.Move.toStart' lu dest Command.Move.RemoveNever af k ai si ai = mkActionItem (k, af) si = SeekInput [] @@ -975,7 +978,13 @@ - Returns True if any file transfers were made. -} seekExportContent :: Maybe SyncOptions -> [Remote] -> CurrBranch -> Annex Bool -seekExportContent o rs (mcurrbranch, madj) +seekExportContent o rs currbranch = + seekExportContent' o (filter canexportcontent rs) currbranch + where + canexportcontent r = isExport r && not (isProxied r) + +seekExportContent' :: Maybe SyncOptions -> [Remote] -> CurrBranch -> Annex Bool +seekExportContent' o rs (mcurrbranch, madj) | null rs = return False | otherwise = do -- Propagate commits from the adjusted branch, so that @@ -1013,7 +1022,7 @@ | tree == currtree -> do filteredtree <- Command.Export.filterExport r tree Command.Export.changeExport r db filteredtree - Command.Export.fillExport r db filteredtree mtbcommitsha + Command.Export.fillExport r db filteredtree mtbcommitsha [] | otherwise -> cannotupdateexport r db Nothing False (Nothing, _, _) -> cannotupdateexport r db (Just (Git.fromRef b ++ " does not exist")) True (_, Nothing, _) -> cannotupdateexport r db (Just "no branch is currently checked out") True @@ -1056,7 +1065,7 @@ -- filling in any files that did not get transferred -- to the existing exported tree. let filteredtree = Command.Export.ExportFiltered tree - Command.Export.fillExport r db filteredtree mtbcommitsha + Command.Export.fillExport r db filteredtree mtbcommitsha [] fillexistingexport r _ _ _ = do warnExportImportConflict r return False @@ -1147,14 +1156,11 @@ isImport :: Remote -> Bool isImport = importTree . Remote.config +isProxied :: Remote -> Bool +isProxied = isJust . remoteAnnexProxiedBy . Remote.gitconfig + +exportHasAnnexObjects :: Remote -> Bool +exportHasAnnexObjects = annexObjects . Remote.config + isThirdPartyPopulated :: Remote -> Bool isThirdPartyPopulated = Remote.thirdPartyPopulated . Remote.remotetype - -splitRemoteAnnexTrackingBranchSubdir :: Git.Ref -> (Git.Ref, Maybe TopFilePath) -splitRemoteAnnexTrackingBranchSubdir tb = (branch, subdir) - where - (b, p) = separate' (== (fromIntegral (ord ':'))) (Git.fromRef' tb) - branch = Git.Ref b - subdir = if S.null p - then Nothing - else Just (asTopFilePath p) diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -298,7 +298,7 @@ Just verifier -> do loc <- Annex.calcRepo (gitAnnexLocation k) verifier k loc - get r k = logStatusAfter k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) Nothing $ \dest -> + get r k = logStatusAfter NoLiveUpdate k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) Nothing $ \dest -> tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) (fromRawFilePath dest) nullMeterUpdate (RemoteVerify r)) >>= \case Right v -> return (True, v) Left _ -> return (False, UnVerified) @@ -372,13 +372,13 @@ , check (`notElem` [Right True, Right False]) "checkPresent" $ \r k -> Remote.checkPresent r k , check (== Right False) "retrieveKeyFile" $ \r k -> - logStatusAfter k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) Nothing $ \dest -> + logStatusAfter NoLiveUpdate k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) Nothing $ \dest -> tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) (fromRawFilePath dest) nullMeterUpdate (RemoteVerify r)) >>= \case Right v -> return (True, v) Left _ -> return (False, UnVerified) , check (== Right False) "retrieveKeyFileCheap" $ \r k -> case Remote.retrieveKeyFileCheap r of Nothing -> return False - Just a -> logStatusAfter k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) Nothing $ \dest -> + Just a -> logStatusAfter NoLiveUpdate k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) Nothing $ \dest -> unVerified $ isRight <$> tryNonAsync (a k (AssociatedFile Nothing) (fromRawFilePath dest)) ] diff --git a/Command/TransferKey.hs b/Command/TransferKey.hs --- a/Command/TransferKey.hs +++ b/Command/TransferKey.hs @@ -54,7 +54,7 @@ upload' (uuid remote) key af Nothing stdRetry $ \p -> do tryNonAsync (Remote.storeKey remote key af Nothing p) >>= \case Right () -> do - Remote.logStatus remote key InfoPresent + Remote.logStatus NoLiveUpdate remote key InfoPresent return True Left e -> do warning (UnquotedString (show e)) @@ -63,7 +63,7 @@ fromPerform :: Key -> AssociatedFile -> Remote -> CommandPerform fromPerform key af remote = go Upload af $ download' (uuid remote) key af Nothing stdRetry $ \p -> - logStatusAfter key $ getViaTmp (retrievalSecurityPolicy remote) vc key af Nothing $ \t -> + logStatusAfter NoLiveUpdate key $ getViaTmp (retrievalSecurityPolicy remote) vc key af Nothing $ \t -> tryNonAsync (Remote.retrieveKeyFile remote key af (fromRawFilePath t) p vc) >>= \case Right v -> return (True, v) Left e -> do diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs --- a/Command/TransferKeys.hs +++ b/Command/TransferKeys.hs @@ -46,11 +46,11 @@ warning (UnquotedString (show e)) return False Right () -> do - Remote.logStatus remote key InfoPresent + Remote.logStatus NoLiveUpdate remote key InfoPresent return True | otherwise = notifyTransfer direction af $ download' (Remote.uuid remote) key af Nothing stdRetry $ \p -> - logStatusAfter key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key af Nothing $ \t -> do + logStatusAfter NoLiveUpdate key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key af Nothing $ \t -> do r <- tryNonAsync (Remote.retrieveKeyFile remote key af (fromRawFilePath t) p (RemoteVerify remote)) >>= \case Left e -> do warning (UnquotedString (show e)) diff --git a/Command/Transferrer.hs b/Command/Transferrer.hs --- a/Command/Transferrer.hs +++ b/Command/Transferrer.hs @@ -67,12 +67,12 @@ warning (UnquotedString (show e)) return False Right () -> do - Remote.logStatus remote key InfoPresent + Remote.logStatus NoLiveUpdate remote key InfoPresent return True runner (AssistantDownloadRequest _ key (TransferAssociatedFile file)) remote = notifyTransfer Download file $ download' (Remote.uuid remote) key file Nothing stdRetry $ \p -> - logStatusAfter key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file Nothing $ \t -> do + logStatusAfter NoLiveUpdate key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file Nothing $ \t -> do r <- tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p (RemoteVerify remote)) >>= \case Left e -> do warning (UnquotedString (show e)) diff --git a/Command/UpdateCluster.hs b/Command/UpdateCluster.hs --- a/Command/UpdateCluster.hs +++ b/Command/UpdateCluster.hs @@ -34,10 +34,17 @@ start :: CommandStart start = startingCustomOutput (ActionItemOther Nothing) $ do rs <- R.remoteList - let getnode r = do - clusternames <- remoteAnnexClusterNode (R.gitconfig r) - return $ M.fromList $ zip clusternames (repeat (S.singleton r)) - let myclusternodes = M.unionsWith S.union (mapMaybe getnode rs) + let getnode r = case remoteAnnexClusterNode (R.gitconfig r) of + Nothing -> return Nothing + Just [] -> return Nothing + Just clusternames -> + ifM (Command.UpdateProxy.checkCanProxy r "Cannot use this special remote as a cluster node.") + ( return $ Just $ M.fromList $ + zip clusternames (repeat (S.singleton r)) + , return Nothing + ) + myclusternodes <- M.unionsWith S.union . catMaybes + <$> mapM getnode rs myclusters <- annexClusters <$> Annex.getGitConfig recordedclusters <- getClusters descs <- R.uuidDescriptions diff --git a/Command/UpdateProxy.hs b/Command/UpdateProxy.hs --- a/Command/UpdateProxy.hs +++ b/Command/UpdateProxy.hs @@ -14,6 +14,7 @@ import Annex.UUID import qualified Remote as R import qualified Types.Remote as R +import Annex.SpecialRemote.Config import Utility.SafeOutput import qualified Data.Map as M @@ -30,8 +31,8 @@ start :: CommandStart start = startingCustomOutput (ActionItemOther Nothing) $ do rs <- R.remoteList - let remoteproxies = S.fromList $ map mkproxy $ - filter (isproxy . R.gitconfig) rs + remoteproxies <- S.fromList . map mkproxy + <$> filterM isproxy rs clusterproxies <- getClusterProxies remoteproxies let proxies = S.union remoteproxies clusterproxies u <- getUUID @@ -54,9 +55,33 @@ "Stopped proxying for " ++ proxyRemoteName p _ -> noop - isproxy c = remoteAnnexProxy c || not (null (remoteAnnexClusterNode c)) - mkproxy r = Proxy (R.uuid r) (R.name r) + + isproxy r + | remoteAnnexProxy (R.gitconfig r) || not (null (remoteAnnexClusterNode (R.gitconfig r))) = + checkCanProxy r "Cannot proxy to this special remote." + | otherwise = pure False + +checkCanProxy :: Remote -> String -> Annex Bool +checkCanProxy r cannotmessage = + ifM (R.isExportSupported r) + ( if annexObjects (R.config r) + then pure True + else do + warnannexobjects + pure False + , pure True + ) + where + warnannexobjects = warning $ UnquotedString $ unwords + [ R.name r + , "is configured with exporttree=yes, but without" + , "annexobjects=yes." + , cannotmessage + , "Suggest you run: git-annex enableremote" + , R.name r + , "annexobjects=yes" + ] -- Automatically proxy nodes of any cluster this repository is configured -- to serve as a gateway for. Also proxy other cluster nodes that are diff --git a/Command/Vicfg.hs b/Command/Vicfg.hs --- a/Command/Vicfg.hs +++ b/Command/Vicfg.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2012-2022 Joey Hess + - Copyright 2012-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -27,11 +27,13 @@ import Logs.Schedule import Logs.Config import Logs.NumCopies +import Logs.MaxSize import Types.StandardGroups import Types.ScheduledActivity import Types.NumCopies import Remote import Git.Types (fromConfigKey, fromConfigValue) +import Utility.DataUnits import qualified Utility.RawFilePath as R cmd :: Command @@ -76,6 +78,7 @@ , cfgGlobalConfigs :: M.Map ConfigKey ConfigValue , cfgNumCopies :: Maybe NumCopies , cfgMinCopies :: Maybe MinCopies + , cfgMaxSizeMap :: M.Map UUID (Maybe MaxSize) } getCfg :: Annex Cfg @@ -89,6 +92,7 @@ <*> loadGlobalConfig <*> getGlobalNumCopies <*> getGlobalMinCopies + <*> (M.map Just <$> getMaxSizes) setCfg :: Cfg -> Cfg -> Annex () setCfg curcfg newcfg = do @@ -102,6 +106,10 @@ mapM_ (uncurry setGlobalConfig) $ M.toList $ cfgGlobalConfigs diff maybe noop setGlobalNumCopies $ cfgNumCopies diff maybe noop setGlobalMinCopies $ cfgMinCopies diff + mapM_ (uncurry setmaxsize) $ M.toList $ cfgMaxSizeMap diff + where + setmaxsize _u Nothing = noop + setmaxsize u (Just sz) = recordMaxSize u sz {- Default config has all the keys from the input config, but with their - default values. -} @@ -116,6 +124,7 @@ , cfgGlobalConfigs = mapdef $ cfgGlobalConfigs curcfg , cfgNumCopies = Nothing , cfgMinCopies = Nothing + , cfgMaxSizeMap = mapdef $ cfgMaxSizeMap curcfg } where mapdef :: forall k v. Default v => M.Map k v -> M.Map k v @@ -132,6 +141,7 @@ , cfgGlobalConfigs = diff cfgGlobalConfigs , cfgNumCopies = cfgNumCopies newcfg , cfgMinCopies = cfgMinCopies newcfg + , cfgMaxSizeMap = diff cfgMaxSizeMap } where diff f = M.differenceWith (\x y -> if x == y then Nothing else Just x) @@ -146,6 +156,7 @@ , grouppreferredcontent , standardgroups , requiredcontent + , maxsizes , schedule , numcopies , globalconfigs @@ -215,6 +226,12 @@ , fromGroup (fromStandardGroup g), "=", standardPreferredContent g ] + maxsizes = settings cfg descs cfgMaxSizeMap + [ com "Maximum repository sizes" + ] + (\(sz, u) -> line "maxsize" u $ maybe "" (\(MaxSize n) -> preciseSize storageUnits False n) sz) + (\u -> line "maxsize" u "") + schedule = settings cfg descs cfgScheduleMap [ com "Scheduled activities" , com "(Separate multiple activities with \"; \")" @@ -311,6 +328,11 @@ Nothing -> let m = M.insert (toGroup f) val (cfgGroupPreferredContentMap cfg) in Right $ cfg { cfgGroupPreferredContentMap = m } + | setting == "maxsize" = case readSize dataUnits val of + Nothing -> Left "parse error (expected a size such as \"100 gb\")" + Just n -> + let m = M.insert u (Just (MaxSize n)) (cfgMaxSizeMap cfg) + in Right $ cfg { cfgMaxSizeMap = m } | setting == "schedule" = case parseScheduledActivities val of Left e -> Left e Right l -> diff --git a/Command/Wanted.hs b/Command/Wanted.hs --- a/Command/Wanted.hs +++ b/Command/Wanted.hs @@ -30,7 +30,7 @@ command name SectionSetup desc pdesc (withParams' seek completeRemotes) where - pdesc = paramPair paramRemote (paramOptional paramExpression) + pdesc = paramPair paramRepository (paramOptional paramExpression) seek = withWords (commandAction . start) diff --git a/Config.hs b/Config.hs --- a/Config.hs +++ b/Config.hs @@ -26,8 +26,12 @@ import Types.GitConfig import Types.RemoteConfig import Git.Types +import Git.FilePath import Annex.SpecialRemote.Config +import Data.Char +import qualified Data.ByteString as S + {- Looks up a setting in git config. This is not as efficient as using the - GitConfig type. -} getConfig :: ConfigKey -> ConfigValue -> Annex ConfigValue @@ -99,3 +103,12 @@ #else pidLockFile = pure Nothing #endif + +splitRemoteAnnexTrackingBranchSubdir :: Git.Ref -> (Git.Ref, Maybe TopFilePath) +splitRemoteAnnexTrackingBranchSubdir tb = (branch, subdir) + where + (b, p) = separate' (== (fromIntegral (ord ':'))) (Git.fromRef' tb) + branch = Git.Ref b + subdir = if S.null p + then Nothing + else Just (asTopFilePath p) diff --git a/Crypto.hs b/Crypto.hs --- a/Crypto.hs +++ b/Crypto.hs @@ -245,7 +245,7 @@ macWithCipher :: Mac -> Cipher -> S.ByteString -> String macWithCipher mac c = macWithCipher' mac (cipherMac c) macWithCipher' :: Mac -> S.ByteString -> S.ByteString -> String -macWithCipher' mac c s = calcMac mac c s +macWithCipher' mac c s = calcMac show mac c s {- Ensure that macWithCipher' returns the same thing forevermore. -} prop_HmacSha1WithCipher_sane :: Bool diff --git a/Database/ImportFeed.hs b/Database/ImportFeed.hs --- a/Database/ImportFeed.hs +++ b/Database/ImportFeed.hs @@ -187,9 +187,9 @@ -- When initially populating the database, this -- 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 + scanbranch = Annex.Branch.overBranchFileContents False toscan goscan >>= \case + Annex.Branch.NoUnmergedBranches ((), _) -> return () + Annex.Branch.UnmergedBranches ((), _) -> scandiff toscan f | isUrlLog f = Just () @@ -197,7 +197,7 @@ | otherwise = Nothing goscan reader = reader >>= \case - Just ((), f, Just content) + Just ((), f, Just (content, _)) | isUrlLog f -> do knownurls (parseUrlLog content) goscan reader diff --git a/Database/Keys.hs b/Database/Keys.hs --- a/Database/Keys.hs +++ b/Database/Keys.hs @@ -476,18 +476,10 @@ dbwriter dbchanged n catreader = liftIO catreader >>= \case Just (ka, content) -> do changed <- ka (parseLinkTargetOrPointerLazy =<< content) - !n' <- countdownToMessage n + n' <- countdownToMessage n $ + showSideAction "scanning for annexed files" dbwriter (dbchanged || changed) n' catreader Nothing -> return dbchanged - - -- When the diff is large, the scan can take a while, - -- so let the user know what's going on. - countdownToMessage n - | n < 1 = return 0 - | n == 1 = do - showSideAction "scanning for annexed files" - return 0 - | otherwise = return (pred n) -- How large is large? Too large and there will be a long -- delay before the message is shown; too short and the message diff --git a/Database/Queue.hs b/Database/Queue.hs --- a/Database/Queue.hs +++ b/Database/Queue.hs @@ -14,6 +14,7 @@ closeDbQueue, flushDbQueue, QueueSize, + LastCommitTime, queueDb, ) where diff --git a/Database/RepoSize.hs b/Database/RepoSize.hs new file mode 100644 --- /dev/null +++ b/Database/RepoSize.hs @@ -0,0 +1,422 @@ +{- Sqlite database used to track the sizes of repositories. + - + - Copyright 2024 Joey Hess + -: + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings, GADTs, FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DataKinds, FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeOperators #-} +#if MIN_VERSION_persistent_template(2,8,0) +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE StandaloneDeriving #-} +#endif + +module Database.RepoSize ( + RepoSizeHandle, + getRepoSizeHandle, + openDb, + closeDb, + isOpenDb, + lockDbWhile, + getRepoSizes, + setRepoSizes, + startingLiveSizeChange, + successfullyFinishedLiveSizeChange, + removeStaleLiveSizeChange, + removeStaleLiveSizeChanges, + recordedRepoOffsets, + liveRepoOffsets, +) where + +import Annex.Common +import qualified Annex +import Database.RepoSize.Handle +import qualified Database.Handle as H +import Database.Init +import Database.Utility +import Database.Types +import Annex.LockFile +import Git.Types +import qualified Utility.RawFilePath as R + +import Database.Persist.Sql hiding (Key) +import Database.Persist.TH +import qualified System.FilePath.ByteString as P +import qualified Data.Map.Strict as M +import qualified Data.Set as S +import Control.Exception +import Control.Concurrent + +share [mkPersist sqlSettings, mkMigrate "migrateRepoSizes"] [persistLowerCase| +-- Corresponds to location log information from the git-annex branch. +RepoSizes + repo UUID + size FileSize + UniqueRepo repo +-- The last git-annex branch commit that was used to update RepoSizes. +AnnexBranch + commit SSha + UniqueCommit commit +-- Changes that are currently being made that affect repo sizes. +-- (Only updated when preferred content expressions are in use that need +-- live size changes.) +LiveSizeChanges + repo UUID + key Key + changeid SizeChangeUniqueId + changepid SizeChangeProcessId + change SizeChange + UniqueLiveSizeChange repo key changeid changepid +-- A rolling total of size changes that were removed from LiveSizeChanges +-- upon successful completion. +SizeChanges + repo UUID + rollingtotal FileSize + UniqueRepoRollingTotal repo +-- The most recent size changes that were removed from LiveSizeChanges +-- upon successful completion. +RecentChanges + repo UUID + key Key + change SizeChange + UniqueRecentChange repo key +|] + +{- Gets a handle to the database. It's cached in Annex state. -} +getRepoSizeHandle :: Annex RepoSizeHandle +getRepoSizeHandle = Annex.getState Annex.reposizehandle >>= \case + Just h -> return h + Nothing -> do + h <- openDb + Annex.changeState $ \s -> s { Annex.reposizehandle = Just h } + return h + +{- Opens the database, creating it if it doesn't exist yet. + - + - Multiple readers and writers can have the database open at the same + - time. Database.Handle deals with the concurrency issues. + - The lock is held while opening the database, so that when + - the database doesn't exist yet, one caller wins the lock and + - can create it undisturbed. + -} +openDb :: Annex RepoSizeHandle +openDb = lockDbWhile permerr $ do + dbdir <- calcRepo' gitAnnexRepoSizeDbDir + let db = dbdir P. "db" + unlessM (liftIO $ R.doesPathExist db) $ do + initDb db $ void $ + runMigrationSilent migrateRepoSizes + h <- liftIO $ H.openDb db "repo_sizes" + mkhandle (Just h) + where + mkhandle mh = do + livev <- liftIO $ newMVar Nothing + return $ RepoSizeHandle mh livev + + -- If permissions don't allow opening the database, + -- just don't use it. Since this database is just a cache + -- of information available in the git-annex branch, the same + -- information can be queried from the branch, though much less + -- efficiently. + permerr _e = mkhandle Nothing + +-- When the repository cannot be written to, openDb returns a +-- RepoSizeHandle that is not actually open, all operations on it will do +-- nothing. +isOpenDb :: RepoSizeHandle -> Bool +isOpenDb (RepoSizeHandle (Just _) _) = True +isOpenDb (RepoSizeHandle Nothing _) = False + +closeDb :: RepoSizeHandle -> Annex () +closeDb (RepoSizeHandle (Just h) _) = liftIO $ H.closeDb h +closeDb (RepoSizeHandle Nothing _) = noop + +-- This does not prevent another process that has already +-- opened the db from changing it at the same time. +lockDbWhile :: (IOException -> Annex a) -> Annex a -> Annex a +lockDbWhile permerr a = do + lck <- calcRepo' gitAnnexRepoSizeDbLock + catchPermissionDenied permerr $ withExclusiveLock lck a + +{- Gets the sizes of repositories as of a commit to the git-annex + - branch. -} +getRepoSizes :: RepoSizeHandle -> IO (M.Map UUID RepoSize, Maybe Sha) +getRepoSizes (RepoSizeHandle (Just h) _) = H.queryDb h $ do + sizemap <- M.fromList <$> getRepoSizes' + annexbranchsha <- getAnnexBranchCommit + return (sizemap, annexbranchsha) +getRepoSizes (RepoSizeHandle Nothing _) = return (mempty, Nothing) + +getRepoSizes' :: SqlPersistM [(UUID, RepoSize)] +getRepoSizes' = map conv <$> selectList [] [] + where + conv entity = + let RepoSizes u sz = entityVal entity + in (u, RepoSize sz) + +getAnnexBranchCommit :: SqlPersistM (Maybe Sha) +getAnnexBranchCommit = do + l <- selectList ([] :: [Filter AnnexBranch]) [] + case l of + (s:[]) -> return $ Just $ fromSSha $ + annexBranchCommit $ entityVal s + _ -> return Nothing + +{- Updates the recorded sizes of all repositories. + - + - This can be called without locking since the update runs in a single + - transaction. + - + - Any repositories that are not in the provided map, but do have a size + - recorded in the database will have it cleared. This is unlikely to + - happen, but ensures that the database is consistent. + -} +setRepoSizes :: RepoSizeHandle -> M.Map UUID RepoSize -> Sha -> IO () +setRepoSizes (RepoSizeHandle (Just h) _) sizemap branchcommitsha = + H.commitDb h $ do + l <- getRepoSizes' + forM_ (map fst l) $ \u -> + unless (M.member u sizemap) $ + unsetRepoSize u + forM_ (M.toList sizemap) $ + uncurry setRepoSize + clearRecentChanges + recordAnnexBranchCommit branchcommitsha +setRepoSizes (RepoSizeHandle Nothing _) _ _ = noop + +setRepoSize :: UUID -> RepoSize -> SqlPersistM () +setRepoSize u (RepoSize sz) = + void $ upsertBy + (UniqueRepo u) + (RepoSizes u sz) + [RepoSizesSize =. sz] + +unsetRepoSize :: UUID -> SqlPersistM () +unsetRepoSize u = deleteWhere [RepoSizesRepo ==. u] + +recordAnnexBranchCommit :: Sha -> SqlPersistM () +recordAnnexBranchCommit branchcommitsha = do + deleteWhere ([] :: [Filter AnnexBranch]) + void $ insertUniqueFast $ AnnexBranch $ toSSha branchcommitsha + +startingLiveSizeChange :: RepoSizeHandle -> UUID -> Key -> SizeChange -> SizeChangeId -> IO () +startingLiveSizeChange (RepoSizeHandle (Just h) _) u k sc cid = + H.commitDb h $ void $ upsertBy + (UniqueLiveSizeChange u k + (sizeChangeUniqueId cid) + (sizeChangeProcessId cid)) + (LiveSizeChanges u k + (sizeChangeUniqueId cid) + (sizeChangeProcessId cid) + sc) + [ LiveSizeChangesChange =. sc + , LiveSizeChangesChangeid =. sizeChangeUniqueId cid + , LiveSizeChangesChangepid =. sizeChangeProcessId cid + ] +startingLiveSizeChange (RepoSizeHandle Nothing _) _ _ _ _ = noop + +{- A live size change has successfully finished. + - + - Update the rolling total, add as a recent change, + - and remove the live change in the same transaction. + - + - But, it's possible that the same change has been done by two + - different processes or threads. If there is a matching recent change, + - then this one is redundant, so remove it without updating the rolling + - total. + -} +successfullyFinishedLiveSizeChange :: RepoSizeHandle -> UUID -> Key -> SizeChange -> SizeChangeId -> IO () +successfullyFinishedLiveSizeChange (RepoSizeHandle (Just h) _) u k sc cid = + H.commitDb h $ do + getRecentChange u k >>= \case + Just sc' | sc == sc' -> remove + _ -> go + where + go = do + rollingtotal <- getSizeChangeFor u + setSizeChangeFor u (updateRollingTotal rollingtotal sc k) + addRecentChange u k sc + remove + remove = removeLiveSizeChange u k sc cid +successfullyFinishedLiveSizeChange (RepoSizeHandle Nothing _) _ _ _ _ = noop + +updateRollingTotal :: FileSize -> SizeChange -> Key -> FileSize +updateRollingTotal t sc k = case sc of + AddingKey -> t + ksz + RemovingKey -> t - ksz + where + ksz = fromMaybe 0 $ fromKey keySize k + +removeStaleLiveSizeChange :: RepoSizeHandle -> UUID -> Key -> SizeChange -> SizeChangeId -> IO () +removeStaleLiveSizeChange (RepoSizeHandle (Just h) _) u k sc cid = + H.commitDb h $ removeLiveSizeChange u k sc cid +removeStaleLiveSizeChange (RepoSizeHandle Nothing _) _ _ _ _ = noop + +removeLiveSizeChange :: UUID -> Key -> SizeChange -> SizeChangeId -> SqlPersistM () +removeLiveSizeChange u k sc cid = + deleteWhere + [ LiveSizeChangesRepo ==. u + , LiveSizeChangesKey ==. k + , LiveSizeChangesChangeid ==. sizeChangeUniqueId cid + , LiveSizeChangesChangepid ==. sizeChangeProcessId cid + , LiveSizeChangesChange ==. sc + ] + +removeStaleLiveSizeChanges :: RepoSizeHandle -> [StaleSizeChanger] -> IO () +removeStaleLiveSizeChanges (RepoSizeHandle (Just h) _) stale = do + let stalepids = map staleSizeChangerProcessId stale + H.commitDb h $ deleteWhere [ LiveSizeChangesChangepid <-. stalepids ] +removeStaleLiveSizeChanges (RepoSizeHandle Nothing _) _ = noop + +getLiveSizeChangesMap :: SqlPersistM (M.Map UUID [(Key, (SizeChange, SizeChangeId))]) +getLiveSizeChangesMap = M.fromListWith (++) . map conv <$> getLiveSizeChanges + where + conv (LiveSizeChanges u k cid pid sc) = (u, [(k, (sc, sid))]) + where + sid = SizeChangeId cid pid + +getLiveSizeChangesList :: SqlPersistM [(UUID, Key, SizeChange)] +getLiveSizeChangesList = map conv <$> getLiveSizeChanges + where + conv (LiveSizeChanges u k _cid _pid sc) = (u, k, sc) + +getLiveSizeChanges :: SqlPersistM [LiveSizeChanges] +getLiveSizeChanges = map entityVal <$> selectList [] [] + +getSizeChanges :: SqlPersistM (M.Map UUID FileSize) +getSizeChanges = M.fromList . map conv <$> selectList [] [] + where + conv entity = + let SizeChanges u n = entityVal entity + in (u, n) + +getSizeChangeFor :: UUID -> SqlPersistM FileSize +getSizeChangeFor u = do + l <- selectList [SizeChangesRepo ==. u] [] + return $ case l of + (s:_) -> sizeChangesRollingtotal $ entityVal s + [] -> 0 + +setSizeChangeFor :: UUID -> FileSize -> SqlPersistM () +setSizeChangeFor u sz = + void $ upsertBy + (UniqueRepoRollingTotal u) + (SizeChanges u sz) + [SizeChangesRollingtotal =. sz] + +addRecentChange :: UUID -> Key -> SizeChange -> SqlPersistM () +addRecentChange u k sc = + void $ upsertBy + (UniqueRecentChange u k) + (RecentChanges u k sc) + [RecentChangesChange =. sc] + +getRecentChange :: UUID -> Key -> SqlPersistM (Maybe SizeChange) +getRecentChange u k = do + l <- selectList + [ RecentChangesRepo ==. u + , RecentChangesKey ==. k + ] [] + return $ case l of + (s:_) -> Just $ recentChangesChange $ entityVal s + [] -> Nothing + +getRecentChanges :: SqlPersistM [(UUID, Key, SizeChange)] +getRecentChanges = map conv <$> selectList [] [] + where + conv entity = + let RecentChanges u k sc = entityVal entity + in (u, k, sc) + +{- Clears recent changes, except when there is a live change that is + - redundant with a recent change. -} +clearRecentChanges :: SqlPersistM () +clearRecentChanges = do + live <- getLiveSizeChangesList + if null live + then deleteWhere ([] :: [Filter RecentChanges]) + else do + let liveset = S.fromList live + rcs <- getRecentChanges + forM_ rcs $ \rc@(u, k, sc) -> + when (S.notMember rc liveset) $ + deleteWhere + [ RecentChangesRepo ==. u + , RecentChangesKey ==. k + , RecentChangesChange ==. sc + ] + +{- Gets the recorded offsets to sizes of Repos, not including live + - changes. -} +recordedRepoOffsets :: RepoSizeHandle -> IO (M.Map UUID SizeOffset) +recordedRepoOffsets (RepoSizeHandle (Just h) _) = + M.map SizeOffset <$> H.queryDb h getSizeChanges +recordedRepoOffsets (RepoSizeHandle Nothing _) = pure mempty + +{- Gets the offsets to sizes of Repos, including all live changes that + - are happening now whose SizeChange matches the provided function. + - + - This does not necessarily include all changes that have been made, + - only ones that had startingLiveSizeChange called for them will be + - included. + - + - In the unlikely case where two live changes are occurring, one + - adding a key and the other removing the same key, the one + - adding the key is used, in order to err on the side of a larger + - repository size. + - + - In the case where the same live change is recorded by two different + - processes or threads, the first to complete will record it as a recent + - change. This omits live changes that are redundant due to a recent + - change already being recorded for the same change. + - + - This is only expensive when there are a lot of live changes happening at + - the same time. + -} +liveRepoOffsets :: RepoSizeHandle -> (SizeChange -> Bool) -> IO (M.Map UUID SizeOffset) +liveRepoOffsets (RepoSizeHandle (Just h) _) wantedsizechange = H.queryDb h $ do + sizechanges <- getSizeChanges + livechanges <- getLiveSizeChangesMap + let us = S.toList $ S.fromList $ + M.keys sizechanges ++ M.keys livechanges + M.fromList <$> forM us (go sizechanges livechanges) + where + go sizechanges livechanges u = do + let livechangesbykey = + M.fromListWith (++) $ + map (\(k, v) -> (k, [v])) $ + fromMaybe [] $ + M.lookup u livechanges + livechanges' <- combinelikelivechanges <$> + filterM (nonredundantlivechange livechangesbykey u) + (fromMaybe [] $ M.lookup u livechanges) + let sizechange = foldl' + (\t (k, sc) -> if wantedsizechange sc then updateRollingTotal t sc k else t) + (fromMaybe 0 (M.lookup u sizechanges)) + livechanges' + return (u, SizeOffset sizechange) + + combinelikelivechanges = + S.elems + . S.fromList + . map (\(k, (sc, _)) -> (k, sc)) + + nonredundantlivechange livechangesbykey u (k, (sc, cid)) + | null (competinglivechanges livechangesbykey k sc cid) = + getRecentChange u k >>= pure . \case + Nothing -> True + Just sc' -> sc /= sc' + | otherwise = pure False + + competinglivechanges livechangesbykey k RemovingKey cid = + filter (\(sc', cid') -> cid /= cid' && sc' == AddingKey) + (fromMaybe [] $ M.lookup k livechangesbykey) + competinglivechanges _ _ AddingKey _ = [] +liveRepoOffsets (RepoSizeHandle Nothing _) _ = pure mempty diff --git a/Database/RepoSize/Handle.hs b/Database/RepoSize/Handle.hs new file mode 100644 --- /dev/null +++ b/Database/RepoSize/Handle.hs @@ -0,0 +1,22 @@ +{- Sqlite database used to track the sizes of repositories. + - + - Copyright 2024 Joey Hess + -: + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Database.RepoSize.Handle where + +import qualified Database.Handle as H +import Utility.LockPool (LockHandle) + +import Control.Concurrent +import Data.Time.Clock.POSIX + +data RepoSizeHandle = RepoSizeHandle + (Maybe H.DbHandle) + -- ^ Nothing if the database was not able to be opened due to + -- permissions. + (MVar (Maybe (LockHandle, POSIXTime))) + -- ^ Live update lock and time of last check for stale live + -- updates. diff --git a/Git/CatFile.hs b/Git/CatFile.hs --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -330,9 +330,12 @@ :: (MonadMask m, MonadIO m) => Repo -> ( - ((v, Ref) -> IO ()) -- ^ call to feed values in - -> IO () -- call once all values are fed in - -> IO (Maybe (v, Maybe L.ByteString)) -- call to read results + ((v, Ref) -> IO ()) + -- ^ call to feed values in + -> IO () + -- ^ call once all values are fed in + -> IO (Maybe (v, Maybe L.ByteString)) + -- ^ call to read results -> m a ) -> m a @@ -350,9 +353,12 @@ :: (MonadMask m, MonadIO m) => Repo -> ( - ((v, Ref) -> IO ()) -- ^ call to feed values in - -> IO () -- call once all values are fed in - -> IO (Maybe (v, Maybe (Sha, FileSize, ObjectType))) -- call to read results + ((v, Ref) -> IO ()) + -- ^ call to feed values in + -> IO () + -- ^ call once all values are fed in + -> IO (Maybe (v, Maybe (Sha, FileSize, ObjectType))) + -- ^ call to read results -> m a ) -> m a diff --git a/Limit.hs b/Limit.hs --- a/Limit.hs +++ b/Limit.hs @@ -1,6 +1,6 @@ {- user-specified limits on files to act on - - - Copyright 2011-2023 Joey Hess + - Copyright 2011-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -17,6 +17,9 @@ import Annex.WorkTree import Annex.UUID import Annex.Magic +import Annex.RepoSize +import Annex.RepoSize.LiveUpdate +import Logs.MaxSize import Annex.Link import Types.Link import Logs.Trust @@ -64,7 +67,7 @@ run matcher i = do (match, desc) <- runWriterT $ Utility.Matcher.matchMrun' matcher $ \o -> - matchAction o S.empty i + matchAction o NoLiveUpdate S.empty i explain (mkActionItem i) $ UnquotedString <$> Utility.Matcher.describeMatchResult matchDesc desc (if match then "matches:" else "does not match:") @@ -106,11 +109,12 @@ limitInclude :: MkLimit Annex limitInclude glob = Right $ MatchFiles - { matchAction = const $ matchGlobFile glob + { matchAction = const $ const $ matchGlobFile glob , matchNeedsFileName = True , matchNeedsFileContent = False , matchNeedsKey = False , matchNeedsLocationLog = False + , matchNeedsLiveRepoSize = False , matchDesc = "include" =? glob } @@ -120,11 +124,12 @@ limitExclude :: MkLimit Annex limitExclude glob = Right $ MatchFiles - { matchAction = const $ not <$$> matchGlobFile glob + { matchAction = const $ const $ not <$$> matchGlobFile glob , matchNeedsFileName = True , matchNeedsFileContent = False , matchNeedsKey = False , matchNeedsLocationLog = False + , matchNeedsLiveRepoSize = False , matchDesc = "exclude" =? glob } @@ -145,11 +150,12 @@ limitIncludeSameContent :: MkLimit Annex limitIncludeSameContent glob = Right $ MatchFiles - { matchAction = const $ matchSameContentGlob glob + { matchAction = const $ const $ matchSameContentGlob glob , matchNeedsFileName = True , matchNeedsFileContent = False , matchNeedsKey = False , matchNeedsLocationLog = False + , matchNeedsLiveRepoSize = False , matchDesc = "includesamecontent" =? glob } @@ -160,11 +166,12 @@ limitExcludeSameContent :: MkLimit Annex limitExcludeSameContent glob = Right $ MatchFiles - { matchAction = const $ not <$$> matchSameContentGlob glob + { matchAction = const $ const $ not <$$> matchSameContentGlob glob , matchNeedsFileName = True , matchNeedsFileContent = False , matchNeedsKey = False , matchNeedsLocationLog = False + , matchNeedsLiveRepoSize = False , matchDesc = "excludesamecontent" =? glob } @@ -236,11 +243,12 @@ -> MkLimit Annex matchMagic limitname querymagic selectprovidedinfo selectuserprovidedinfo (Just magic) glob = Right $ MatchFiles - { matchAction = const go + { matchAction = const $ const go , matchNeedsFileName = False , matchNeedsFileContent = True , matchNeedsKey = False , matchNeedsLocationLog = False + , matchNeedsLiveRepoSize = False , matchDesc = limitname =? glob } where @@ -263,21 +271,23 @@ addUnlocked :: Annex () addUnlocked = addLimit $ Right $ MatchFiles - { matchAction = const $ matchLockStatus False + { matchAction = const $ const $ matchLockStatus False , matchNeedsFileName = True , matchNeedsFileContent = False , matchNeedsKey = False , matchNeedsLocationLog = False + , matchNeedsLiveRepoSize = False , matchDesc = matchDescSimple "unlocked" } addLocked :: Annex () addLocked = addLimit $ Right $ MatchFiles - { matchAction = const $ matchLockStatus True + { matchAction = const $ const $ matchLockStatus True , matchNeedsFileName = True , matchNeedsFileContent = False , matchNeedsKey = False , matchNeedsLocationLog = False + , matchNeedsLiveRepoSize = False , matchDesc = matchDescSimple "locked" } @@ -308,11 +318,12 @@ where (name, date) = separate (== '@') s use inhere a = Right $ MatchFiles - { matchAction = checkKey . a + { matchAction = const $ checkKey . a , matchNeedsFileName = False , matchNeedsFileContent = False , matchNeedsKey = True , matchNeedsLocationLog = not inhere + , matchNeedsLiveRepoSize = False , matchDesc = "in" =? s } checkinuuid u notpresent key @@ -336,20 +347,21 @@ addExpectedPresent = do hereu <- getUUID addLimit $ Right $ MatchFiles - { matchAction = const $ checkKey $ \key -> do + { matchAction = const $ const $ checkKey $ \key -> do us <- Remote.keyLocations key return $ hereu `elem` us , matchNeedsFileName = False , matchNeedsFileContent = False , matchNeedsKey = True , matchNeedsLocationLog = True + , matchNeedsLiveRepoSize = False , matchDesc = matchDescSimple "expected-present" } {- Limit to content that is currently present on a uuid. -} limitPresent :: Maybe UUID -> MatchFiles Annex limitPresent u = MatchFiles - { matchAction = const $ checkKey $ \key -> do + { matchAction = const $ const $ checkKey $ \key -> do hereu <- getUUID if u == Just hereu || isNothing u then inAnnex key @@ -360,17 +372,19 @@ , matchNeedsFileContent = False , matchNeedsKey = True , matchNeedsLocationLog = not (isNothing u) + , matchNeedsLiveRepoSize = False , matchDesc = matchDescSimple "present" } {- Limit to content that is in a directory, anywhere in the repository tree -} limitInDir :: FilePath -> String -> MatchFiles Annex limitInDir dir desc = MatchFiles - { matchAction = const go + { matchAction = const $ const go , matchNeedsFileName = True , matchNeedsFileContent = False , matchNeedsKey = False , matchNeedsLocationLog = False + , matchNeedsLiveRepoSize = False , matchDesc = matchDescSimple desc } where @@ -397,12 +411,13 @@ go num good = case readish num of Nothing -> Left "bad number for copies" Just n -> Right $ MatchFiles - { matchAction = \notpresent -> checkKey $ + { matchAction = const $ \notpresent -> checkKey $ go' n good notpresent , matchNeedsFileName = False , matchNeedsFileContent = False , matchNeedsKey = True , matchNeedsLocationLog = True + , matchNeedsLiveRepoSize = False , matchDesc = "copies" =? want } go' n good notpresent key = do @@ -422,12 +437,13 @@ limitLackingCopies :: String -> Bool -> MkLimit Annex limitLackingCopies desc approx want = case readish want of Just needed -> Right $ MatchFiles - { matchAction = \notpresent mi -> flip checkKey mi $ + { matchAction = const $ \notpresent mi -> flip checkKey mi $ go mi needed notpresent , matchNeedsFileName = False , matchNeedsFileContent = False , matchNeedsKey = True , matchNeedsLocationLog = True + , matchNeedsLiveRepoSize = False , matchDesc = matchDescSimple desc } Nothing -> Left "bad value for number of lacking copies" @@ -453,17 +469,18 @@ -} limitUnused :: MatchFiles Annex limitUnused = MatchFiles - { matchAction = go + { matchAction = const $ const go , matchNeedsFileName = True , matchNeedsFileContent = False , matchNeedsKey = True , matchNeedsLocationLog = False + , matchNeedsLiveRepoSize = False , matchDesc = matchDescSimple "unused" } where - go _ (MatchingFile _) = return False - go _ (MatchingInfo p) = maybe (pure False) isunused (providedKey p) - go _ (MatchingUserInfo p) = do + go (MatchingFile _) = return False + go (MatchingInfo p) = maybe (pure False) isunused (providedKey p) + go (MatchingUserInfo p) = do k <- getUserInfo (userProvidedKey p) isunused k @@ -476,11 +493,12 @@ {- Limit that matches any version of any file or key. -} limitAnything :: MatchFiles Annex limitAnything = MatchFiles - { matchAction = \_ _ -> return True + { matchAction = \_ _ _ -> return True , matchNeedsFileName = False , matchNeedsFileContent = False , matchNeedsKey = False , matchNeedsLocationLog = False + , matchNeedsLiveRepoSize = False , matchDesc = matchDescSimple "anything" } @@ -491,11 +509,12 @@ {- Limit that never matches. -} limitNothing :: MatchFiles Annex limitNothing = MatchFiles - { matchAction = \_ _ -> return False + { matchAction = \_ _ _ -> return False , matchNeedsFileName = False , matchNeedsFileContent = False , matchNeedsKey = False , matchNeedsLocationLog = False + , matchNeedsLiveRepoSize = False , matchDesc = matchDescSimple "nothing" } @@ -506,7 +525,7 @@ limitInAllGroup :: Annex GroupMap -> MkLimit Annex limitInAllGroup getgroupmap groupname = Right $ MatchFiles - { matchAction = \notpresent mi -> do + { matchAction = const $ \notpresent mi -> do m <- getgroupmap let want = fromMaybe S.empty $ M.lookup (toGroup groupname) $ uuidsByGroup m if S.null want @@ -519,6 +538,7 @@ , matchNeedsFileContent = False , matchNeedsKey = True , matchNeedsLocationLog = True + , matchNeedsLiveRepoSize = False , matchDesc = "inallgroup" =? groupname } where @@ -534,7 +554,7 @@ limitOnlyInGroup :: Annex GroupMap -> MkLimit Annex limitOnlyInGroup getgroupmap groupname = Right $ MatchFiles - { matchAction = \notpresent mi -> do + { matchAction = const $ \notpresent mi -> do m <- getgroupmap let want = fromMaybe S.empty $ M.lookup (toGroup groupname) $ uuidsByGroup m if S.null want @@ -544,6 +564,7 @@ , matchNeedsFileContent = False , matchNeedsKey = True , matchNeedsLocationLog = True + , matchNeedsLiveRepoSize = False , matchDesc = "inallgroup" =? groupname } where @@ -553,17 +574,189 @@ return $ not (S.null $ present `S.intersection` want) && S.null (S.filter (`S.notMember` want) present) +limitBalanced :: Maybe UUID -> Annex GroupMap -> MkLimit Annex +limitBalanced mu getgroupmap groupname = do + fullybalanced <- limitFullyBalanced' "balanced" mu getgroupmap groupname + limitBalanced' "balanced" fullybalanced mu groupname + +limitBalanced' :: String -> MatchFiles Annex -> Maybe UUID -> MkLimit Annex +limitBalanced' termname fullybalanced mu groupname = do + copies <- limitCopies $ if ':' `elem` groupname + then groupname + else groupname ++ ":1" + let present = limitPresent mu + Right $ MatchFiles + { matchAction = \lu a i -> + ifM (Annex.getRead Annex.rebalance) + ( matchAction fullybalanced lu a i + , matchAction present lu a i <||> + ((not <$> matchAction copies lu a i) + <&&> matchAction fullybalanced lu a i + ) + ) + , matchNeedsFileName = + matchNeedsFileName present || + matchNeedsFileName fullybalanced || + matchNeedsFileName copies + , matchNeedsFileContent = + matchNeedsFileContent present || + matchNeedsFileContent fullybalanced || + matchNeedsFileContent copies + , matchNeedsKey = + matchNeedsKey present || + matchNeedsKey fullybalanced || + matchNeedsKey copies + , matchNeedsLocationLog = + matchNeedsLocationLog present || + matchNeedsLocationLog fullybalanced || + matchNeedsLocationLog copies + , matchNeedsLiveRepoSize = True + , matchDesc = termname =? groupname + } + +limitFullyBalanced :: Maybe UUID -> Annex GroupMap -> MkLimit Annex +limitFullyBalanced = limitFullyBalanced' "fullybalanced" + +limitFullyBalanced' :: String -> Maybe UUID -> Annex GroupMap -> MkLimit Annex +limitFullyBalanced' = limitFullyBalanced'' $ \n key candidates -> do + maxsizes <- getMaxSizes + sizemap <- getLiveRepoSizes False + threshhold <- annexFullyBalancedThreshhold <$> Annex.getGitConfig + let toofull u = + case (M.lookup u maxsizes, M.lookup u sizemap) of + (Just (MaxSize maxsize), Just (RepoSize reposize)) -> + fromIntegral reposize >= fromIntegral maxsize * threshhold + _ -> False + needsizebalance <- ifM (Annex.getRead Annex.rebalance) + ( return $ n > 1 && + n > S.size candidates + - S.size (S.filter toofull candidates) + , return False + ) + if needsizebalance + then filterCandidatesFullySizeBalanced maxsizes sizemap n key candidates + else do + currentlocs <- S.fromList <$> loggedLocations key + let keysize = fromMaybe 0 (fromKey keySize key) + let hasspace u = case (M.lookup u maxsizes, M.lookup u sizemap) of + (Just maxsize, Just reposize) -> + repoHasSpace keysize (u `S.member` currentlocs) reposize maxsize + _ -> True + return $ S.filter hasspace candidates + +repoHasSpace :: Integer -> Bool -> RepoSize -> MaxSize -> Bool +repoHasSpace keysize inrepo (RepoSize reposize) (MaxSize maxsize) + | inrepo = + reposize <= maxsize + | otherwise = + reposize + keysize <= maxsize + +limitFullyBalanced'' + :: (Int -> Key -> S.Set UUID -> Annex (S.Set UUID)) + -> String + -> Maybe UUID + -> Annex GroupMap + -> MkLimit Annex +limitFullyBalanced'' filtercandidates termname mu getgroupmap want = + case splitc ':' want of + [g] -> go g 1 + [g, n] -> maybe + (Left $ "bad number for " ++ termname) + (go g) + (readish n) + _ -> Left $ "bad value for " ++ termname + where + go s n = limitFullyBalanced''' filtercandidates termname mu + getgroupmap (toGroup s) n want + +limitFullyBalanced''' + :: (Int -> Key -> S.Set UUID -> Annex (S.Set UUID)) + -> String + -> Maybe UUID + -> Annex GroupMap + -> Group + -> Int + -> MkLimit Annex +limitFullyBalanced''' filtercandidates termname mu getgroupmap g n want = Right $ MatchFiles + { matchAction = \lu -> const $ checkKey $ \key -> do + gm <- getgroupmap + let groupmembers = fromMaybe S.empty $ + M.lookup g (uuidsByGroup gm) + candidates <- filtercandidates n key groupmembers + let wanted = if S.null candidates + then False + else case (mu, M.lookup g (balancedPickerByGroup gm)) of + (Just u, Just picker) -> + u `elem` picker candidates key n + _ -> False + when wanted $ + needLiveUpdate lu + return wanted + , matchNeedsFileName = False + , matchNeedsFileContent = False + , matchNeedsKey = True + , matchNeedsLocationLog = False + , matchNeedsLiveRepoSize = True + , matchDesc = termname =? want + } + +limitSizeBalanced :: Maybe UUID -> Annex GroupMap -> MkLimit Annex +limitSizeBalanced mu getgroupmap groupname = do + fullysizebalanced <- limitFullySizeBalanced' "sizebalanced" mu getgroupmap groupname + limitBalanced' "sizebalanced" fullysizebalanced mu groupname + +limitFullySizeBalanced :: Maybe UUID -> Annex GroupMap -> MkLimit Annex +limitFullySizeBalanced = limitFullySizeBalanced' "fullysizebalanced" + +limitFullySizeBalanced' :: String -> Maybe UUID -> Annex GroupMap -> MkLimit Annex +limitFullySizeBalanced' = limitFullyBalanced'' $ \n key candidates -> do + maxsizes <- getMaxSizes + sizemap <- getLiveRepoSizes False + filterCandidatesFullySizeBalanced maxsizes sizemap n key candidates + +filterCandidatesFullySizeBalanced + :: M.Map UUID MaxSize + -> M.Map UUID RepoSize + -> Int + -> Key + -> S.Set UUID + -> Annex (S.Set UUID) +filterCandidatesFullySizeBalanced maxsizes sizemap n key candidates = do + currentlocs <- S.fromList <$> loggedLocations key + let keysize = fromMaybe 0 (fromKey keySize key) + let go u = case (M.lookup u maxsizes, M.lookup u sizemap, u `S.member` currentlocs) of + (Just maxsize, Just reposize, inrepo) + | repoHasSpace keysize inrepo reposize maxsize -> + proportionfree keysize inrepo u reposize maxsize + | otherwise -> Nothing + _ -> Nothing + return $ S.fromList $ + map fst $ take n $ reverse $ sortOn snd $ + mapMaybe go $ S.toList candidates + where + proportionfree keysize inrepo u (RepoSize reposize) (MaxSize maxsize) + | maxsize > 0 = Just + ( u + , fromIntegral freespacesanskey / fromIntegral maxsize + :: Double + ) + | otherwise = Nothing + where + freespacesanskey = maxsize - reposize + + if inrepo then keysize else 0 + {- Adds a limit to skip files not using a specified key-value backend. -} addInBackend :: String -> Annex () addInBackend = addLimit . limitInBackend limitInBackend :: MkLimit Annex limitInBackend name = Right $ MatchFiles - { matchAction = const $ checkKey check + { matchAction = const $ const $ checkKey check , matchNeedsFileName = False , matchNeedsFileContent = False , matchNeedsKey = True , matchNeedsLocationLog = False + , matchNeedsLiveRepoSize = False , matchDesc = "inbackend" =? name } where @@ -576,11 +769,12 @@ limitSecureHash :: MatchFiles Annex limitSecureHash = MatchFiles - { matchAction = const $ checkKey isCryptographicallySecureKey + { matchAction = const $ const $ checkKey isCryptographicallySecureKey , matchNeedsFileName = False , matchNeedsFileContent = False , matchNeedsKey = True , matchNeedsLocationLog = False + , matchNeedsLiveRepoSize = False , matchDesc = matchDescSimple "securehash" } @@ -595,13 +789,14 @@ limitSize lb desc vs s = case readSize dataUnits s of Nothing -> Left "bad size" Just sz -> Right $ MatchFiles - { matchAction = go sz + { matchAction = const $ go sz , matchNeedsFileName = case lb of LimitAnnexFiles -> False LimitDiskFiles -> True , matchNeedsFileContent = False , matchNeedsKey = False , matchNeedsLocationLog = False + , matchNeedsLiveRepoSize = False , matchDesc = desc =? s } where @@ -627,11 +822,12 @@ limitMetaData s = case parseMetaDataMatcher s of Left e -> Left e Right (f, matching) -> Right $ MatchFiles - { matchAction = const $ checkKey (check f matching) + { matchAction = const $ const $ checkKey (check f matching) , matchNeedsFileName = False , matchNeedsFileContent = False , matchNeedsKey = True , matchNeedsLocationLog = False + , matchNeedsLiveRepoSize = False , matchDesc = "metadata" =? s } where @@ -643,11 +839,12 @@ addAccessedWithin duration = do now <- liftIO getPOSIXTime addLimit $ Right $ MatchFiles - { matchAction = const $ checkKey $ check now + { matchAction = const $ const $ checkKey $ check now , matchNeedsFileName = False , matchNeedsFileContent = False , matchNeedsKey = False , matchNeedsLocationLog = False + , matchNeedsLiveRepoSize = False , matchDesc = "accessedwithin" =? fromDuration duration } where diff --git a/Limit/Wanted.hs b/Limit/Wanted.hs --- a/Limit/Wanted.hs +++ b/Limit/Wanted.hs @@ -16,23 +16,23 @@ addWantGet :: Annex () addWantGet = addPreferredContentLimit "want-get" $ - checkWant $ wantGet False Nothing + checkWant $ wantGet NoLiveUpdate False Nothing addWantGetBy :: String -> Annex () addWantGetBy name = do u <- Remote.nameToUUID name addPreferredContentLimit "want-get-by" $ checkWant $ \af -> - wantGetBy False Nothing af u + wantGetBy NoLiveUpdate False Nothing af u addWantDrop :: Annex () addWantDrop = addPreferredContentLimit "want-drop" $ checkWant $ \af -> - wantDrop False Nothing Nothing af (Just []) + wantDrop NoLiveUpdate False Nothing Nothing af (Just []) addWantDropBy :: String -> Annex () addWantDropBy name = do u <- Remote.nameToUUID name addPreferredContentLimit "want-drop-by" $ checkWant $ \af -> - wantDrop False (Just u) Nothing af (Just []) + wantDrop NoLiveUpdate False (Just u) Nothing af (Just []) addPreferredContentLimit :: String -> (MatchInfo -> Annex Bool) -> Annex () addPreferredContentLimit desc a = do @@ -40,12 +40,14 @@ nfc <- introspectPreferredRequiredContent matchNeedsFileContent Nothing nk <- introspectPreferredRequiredContent matchNeedsKey Nothing nl <- introspectPreferredRequiredContent matchNeedsLocationLog Nothing + lsz <- introspectPreferredRequiredContent matchNeedsLiveRepoSize Nothing addLimit $ Right $ MatchFiles - { matchAction = const a + { matchAction = const $ const a , matchNeedsFileName = nfn , matchNeedsFileContent = nfc , matchNeedsKey = nk , matchNeedsLocationLog = nl + , matchNeedsLiveRepoSize = lsz , matchDesc = matchDescSimple desc } diff --git a/Logs.hs b/Logs.hs --- a/Logs.hs +++ b/Logs.hs @@ -100,6 +100,7 @@ [ exportLog , proxyLog , clusterLog + , maxSizeLog ] {- Other top-level logs. -} @@ -162,6 +163,9 @@ clusterLog :: RawFilePath clusterLog = "cluster.log" +maxSizeLog :: RawFilePath +maxSizeLog = "maxsize.log" + {- This is not a log file, it's where exported treeishes get grafted into - the git-annex branch. -} exportTreeGraftPoint :: RawFilePath @@ -175,7 +179,10 @@ {- The pathname of the location log file for a given key. -} locationLogFile :: GitConfig -> Key -> RawFilePath locationLogFile config key = - branchHashDir config key P. keyFile key <> ".log" + branchHashDir config key P. keyFile key <> locationLogExt + +locationLogExt :: S.ByteString +locationLogExt = ".log" {- The filename of the url log for a given key. -} urlLogFile :: GitConfig -> Key -> RawFilePath diff --git a/Logs/ContentIdentifier.hs b/Logs/ContentIdentifier.hs --- a/Logs/ContentIdentifier.hs +++ b/Logs/ContentIdentifier.hs @@ -32,10 +32,11 @@ recordContentIdentifier (RemoteStateHandle u) cid k = do c <- currentVectorClock config <- Annex.getGitConfig - Annex.Branch.maybeChange + void $ Annex.Branch.maybeChange (Annex.Branch.RegardingUUID [u]) (remoteContentIdentifierLogFile config k) (addcid c . parseLog) + noop where addcid c v | cid `elem` l = Nothing -- no change needed diff --git a/Logs/Group.hs b/Logs/Group.hs --- a/Logs/Group.hs +++ b/Logs/Group.hs @@ -1,6 +1,6 @@ {- git-annex group log - - - Copyright 2012, 2019 Joey Hess + - Copyright 2012-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -29,6 +29,7 @@ import Logs.UUIDBased import Types.Group import Types.StandardGroups +import Annex.Balanced {- Returns the groups of a given repo UUID. -} lookupGroups :: UUID -> Annex (S.Set Group) @@ -82,7 +83,7 @@ return m makeGroupMap :: M.Map UUID (S.Set Group) -> GroupMap -makeGroupMap byuuid = GroupMap byuuid bygroup +makeGroupMap byuuid = GroupMap byuuid bygroup (M.map balancedPicker bygroup) where bygroup = M.fromListWith S.union $ concatMap explode $ M.toList byuuid diff --git a/Logs/Location.hs b/Logs/Location.hs --- a/Logs/Location.hs +++ b/Logs/Location.hs @@ -24,7 +24,6 @@ loggedPreviousLocations, loggedLocationsHistorical, loggedLocationsRef, - parseLoggedLocations, isKnownKey, checkDead, setDead, @@ -35,17 +34,22 @@ loggedKeysFor', overLocationLogs, overLocationLogs', + overLocationLogsJournal, + parseLoggedLocations, + parseLoggedLocationsWithoutClusters, ) where import Annex.Common import qualified Annex.Branch +import Annex.Branch (FileContents) +import Annex.RepoSize.LiveUpdate import Logs import Logs.Presence import Types.Cluster import Annex.UUID import Annex.CatFile import Annex.VectorClock -import Git.Types (RefDate, Ref) +import Git.Types (RefDate, Ref, Sha) import qualified Annex import Data.Time.Clock @@ -54,17 +58,17 @@ import qualified Data.Set as S {- Log a change in the presence of a key's value in current repository. -} -logStatus :: Key -> LogStatus -> Annex () -logStatus key s = do +logStatus :: LiveUpdate -> Key -> LogStatus -> Annex () +logStatus lu key s = do u <- getUUID - logChange key u s + logChange lu key u s {- Run an action that gets the content of a key, and update the log - when it succeeds. -} -logStatusAfter :: Key -> Annex Bool -> Annex Bool -logStatusAfter key a = ifM a +logStatusAfter :: LiveUpdate -> Key -> Annex Bool -> Annex Bool +logStatusAfter lu key a = ifM a ( do - logStatus key InfoPresent + logStatus lu key InfoPresent return True , return False ) @@ -75,17 +79,18 @@ - logged to contain a key, loading the log will include the cluster's - UUID. -} -logChange :: Key -> UUID -> LogStatus -> Annex () -logChange key u@(UUID _) s +logChange :: LiveUpdate -> Key -> UUID -> LogStatus -> Annex () +logChange lu key u@(UUID _) s | isClusterUUID u = noop | otherwise = do config <- Annex.getGitConfig - maybeAddLog + void $ maybeAddLog (Annex.Branch.RegardingUUID [u]) (locationLogFile config key) s (LogInfo (fromUUID u)) -logChange _ NoUUID _ = noop + (updateRepoSize lu u key s) +logChange _ _ NoUUID _ = noop {- Returns a list of repository UUIDs that, according to the log, have - the value of a key. -} @@ -106,9 +111,16 @@ loggedLocationsRef :: Ref -> Annex [UUID] loggedLocationsRef ref = map (toUUID . fromLogInfo) . getLog <$> catObject ref -{- Parses the content of a log file and gets the locations in it. -} +{- Parses the content of a log file and gets the locations in it. + - + - Adds the UUIDs of any clusters whose nodes are in the list. + -} parseLoggedLocations :: Clusters -> L.ByteString -> [UUID] -parseLoggedLocations clusters l = addClusterUUIDs clusters $ +parseLoggedLocations clusters = + addClusterUUIDs clusters . parseLoggedLocationsWithoutClusters + +parseLoggedLocationsWithoutClusters :: L.ByteString -> [UUID] +parseLoggedLocationsWithoutClusters l = map (toUUID . fromLogInfo . info) (filterPresent (parseLog l)) @@ -119,7 +131,6 @@ clusters <- getClusters return $ addClusterUUIDs clusters locs --- Add UUIDs of any clusters whose nodes are in the list. addClusterUUIDs :: Clusters -> [UUID] -> [UUID] addClusterUUIDs clusters locs | M.null clustermap = locs @@ -161,14 +172,15 @@ ls <- compactLog <$> readLog logfile mapM_ (go logfile) (filter (\l -> status l == InfoMissing) ls) where - go logfile l = + go logfile l = do let u = toUUID (fromLogInfo (info l)) c = case date l of VectorClock v -> CandidateVectorClock $ v + realToFrac (picosecondsToDiffTime 1) Unknown -> CandidateVectorClock 0 - in addLog' (Annex.Branch.RegardingUUID [u]) logfile InfoDead + addLog' (Annex.Branch.RegardingUUID [u]) logfile InfoDead (info l) c + updateRepoSize NoLiveUpdate u key InfoDead data Unchecked a = Unchecked (Annex (Maybe a)) @@ -219,35 +231,109 @@ return there {- This is much faster than loggedKeys. -} -overLocationLogs :: v -> (Key -> [UUID] -> v -> Annex v) -> Annex v -overLocationLogs v = overLocationLogs' v (flip const) +overLocationLogs + :: Bool + -> Bool + -> v + -> (Key -> [UUID] -> v -> Annex v) + -> Annex (Annex.Branch.UnmergedBranches (v, Sha)) +overLocationLogs ignorejournal noclusters v = + overLocationLogs' ignorejournal noclusters v (flip const) overLocationLogs' - :: v - -> (Annex (Maybe (Key, RawFilePath, Maybe L.ByteString)) -> Annex v -> Annex v) + :: Bool + -> Bool + -> v + -> (Annex (FileContents Key Bool) -> Annex v -> Annex v) -> (Key -> [UUID] -> v -> Annex v) - -> Annex v -overLocationLogs' iv discarder keyaction = do + -> Annex (Annex.Branch.UnmergedBranches (v, Sha)) +overLocationLogs' ignorejournal noclusters iv discarder keyaction = do + mclusters <- if noclusters then pure Nothing else Just <$> getClusters + overLocationLogsHelper + (Annex.Branch.overBranchFileContents ignorejournal) + (\locparser _ _ content -> pure (locparser (fst <$> content))) + True + iv + discarder + keyaction + mclusters + +type LocChanges = + ( S.Set UUID + -- ^ locations that are in the journal, but not in the + -- git-annex branch + , S.Set UUID + -- ^ locations that are in the git-annex branch, + -- but have been removed in the journal + ) + +{- Like overLocationLogs, but only adds changes in journalled files + - compared with what was logged in the git-annex branch at the specified + - commit sha. -} +overLocationLogsJournal + :: v + -> Sha + -> (Key -> LocChanges -> v -> Annex v) + -> Maybe Clusters + -> Annex v +overLocationLogsJournal v branchsha keyaction mclusters = + overLocationLogsHelper + (Annex.Branch.overJournalFileContents handlestale) + changedlocs + False + -- ^ do not precache journalled content, which may be stale + v (flip const) keyaction + mclusters + where + handlestale _ journalcontent = return (journalcontent, Just True) + + changedlocs locparser _key logf (Just (journalcontent, isstale)) = do + branchcontent <- Annex.Branch.getRef branchsha logf + let branchlocs = S.fromList $ locparser $ Just branchcontent + let journallocs = S.fromList $ locparser $ Just $ case isstale of + Just True -> Annex.Branch.combineStaleJournalWithBranch + branchcontent journalcontent + _ -> journalcontent + return + ( S.difference journallocs branchlocs + , S.difference branchlocs journallocs + ) + changedlocs _ _ _ Nothing = pure (S.empty, S.empty) + +overLocationLogsHelper + :: ((RawFilePath -> Maybe Key) -> (Annex (FileContents Key b) -> Annex v) -> Annex a) + -> ((Maybe L.ByteString -> [UUID]) -> Key -> RawFilePath -> Maybe (L.ByteString, Maybe b) -> Annex u) + -> Bool + -> v + -> (Annex (FileContents Key b) -> Annex v -> Annex v) + -> (Key -> u -> v -> Annex v) + -> (Maybe Clusters) + -> Annex a +overLocationLogsHelper runner locparserrunner canprecache iv discarder keyaction mclusters = do config <- Annex.getGitConfig - clusters <- getClusters - + + let locparser = maybe + parseLoggedLocationsWithoutClusters + parseLoggedLocations + mclusters + let locparser' = maybe [] locparser let getk = locationLogFileKey config let go v reader = reader >>= \case Just (k, f, content) -> discarder reader $ do -- precache to make checkDead fast, and also to -- make any accesses done in keyaction fast. - maybe noop (Annex.Branch.precache f) content + when canprecache $ + maybe noop (Annex.Branch.precache f . fst) content ifM (checkDead k) ( go v reader , do - !v' <- keyaction k (maybe [] (parseLoggedLocations clusters) content) v + !locs <- locparserrunner locparser' k f content + !v' <- keyaction k locs v go v' reader ) 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 allu keys. (Set annex.merge-annex-branches to false to ignore the unmerged git-annex branches.)" + runner getk (go iv) -- Cannot import Logs.Cluster due to a cycle. -- Annex.clusters gets populated when starting up git-annex. diff --git a/Logs/MaxSize.hs b/Logs/MaxSize.hs new file mode 100644 --- /dev/null +++ b/Logs/MaxSize.hs @@ -0,0 +1,48 @@ +{- git-annex maxsize log + - + - Copyright 2024 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Logs.MaxSize ( + MaxSize(..), + getMaxSizes, + recordMaxSize, +) where + +import qualified Annex +import Annex.Common +import Logs +import Logs.UUIDBased +import Logs.MapLog +import qualified Annex.Branch + +import qualified Data.Map as M +import Data.ByteString.Builder +import qualified Data.Attoparsec.ByteString as A + +getMaxSizes :: Annex (M.Map UUID MaxSize) +getMaxSizes = maybe loadMaxSizes return =<< Annex.getState Annex.maxsizes + +loadMaxSizes :: Annex (M.Map UUID MaxSize) +loadMaxSizes = do + maxsizes <- M.map value . fromMapLog . parseLogNew parseMaxSize + <$> Annex.Branch.get maxSizeLog + Annex.changeState $ \s -> s { Annex.maxsizes = Just maxsizes } + return maxsizes + +recordMaxSize :: UUID -> MaxSize -> Annex () +recordMaxSize uuid maxsize = do + c <- currentVectorClock + Annex.Branch.change (Annex.Branch.RegardingUUID [uuid]) maxSizeLog $ + (buildLogNew buildMaxSize) + . changeLog c uuid maxsize + . parseLogNew parseMaxSize + +buildMaxSize :: MaxSize -> Builder +buildMaxSize (MaxSize n) = byteString (encodeBS (show n)) + +parseMaxSize :: A.Parser MaxSize +parseMaxSize = maybe (fail "maxsize parse failed") (pure . MaxSize) + . readish . decodeBS =<< A.takeByteString diff --git a/Logs/PreferredContent.hs b/Logs/PreferredContent.hs --- a/Logs/PreferredContent.hs +++ b/Logs/PreferredContent.hs @@ -48,19 +48,19 @@ {- 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 :: LiveUpdate -> Maybe UUID -> AssumeNotPresent -> Maybe Key -> AssociatedFile -> Bool -> Annex Bool isPreferredContent = checkMap preferredContentMap -isRequiredContent :: Maybe UUID -> AssumeNotPresent -> Maybe Key -> AssociatedFile -> Bool -> Annex Bool +isRequiredContent :: LiveUpdate -> Maybe UUID -> AssumeNotPresent -> Maybe Key -> AssociatedFile -> Bool -> Annex Bool isRequiredContent = checkMap requiredContentMap -checkMap :: Annex (FileMatcherMap Annex) -> Maybe UUID -> AssumeNotPresent -> Maybe Key -> AssociatedFile -> Bool -> Annex Bool -checkMap getmap mu notpresent mkey afile d = do +checkMap :: Annex (FileMatcherMap Annex) -> LiveUpdate -> Maybe UUID -> AssumeNotPresent -> Maybe Key -> AssociatedFile -> Bool -> Annex Bool +checkMap getmap lu mu notpresent mkey afile d = do u <- maybe getUUID return mu m <- getmap case M.lookup u m of Nothing -> return d - Just matcher -> checkMatcher matcher mkey afile notpresent (return d) (return d) + Just matcher -> checkMatcher matcher mkey afile lu notpresent (return d) (return d) {- Checks if the preferred or required content for the specified repository - (or the current repository if none is specified) contains any terms diff --git a/Logs/Presence.hs b/Logs/Presence.hs --- a/Logs/Presence.hs +++ b/Logs/Presence.hs @@ -6,7 +6,7 @@ - A line of the log will look like: "date N INFO" - Where N=1 when the INFO is present, 0 otherwise. - - - Copyright 2010-2022 Joey Hess + - Copyright 2010-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -20,6 +20,7 @@ presentLogInfo, notPresentLogInfo, historicalLogInfo, + parseLogInfo, ) where import Logs.Presence.Pure as X @@ -28,6 +29,8 @@ import qualified Annex.Branch import Git.Types (RefDate) +import qualified Data.ByteString.Lazy as L + {- Adds to the log, removing any LogLines that are obsoleted. -} addLog :: Annex.Branch.RegardingUUID -> RawFilePath -> LogStatus -> LogInfo -> Annex () addLog ru file logstatus loginfo = @@ -46,16 +49,20 @@ {- When a LogLine already exists with the same status and info, but an - older timestamp, that LogLine is preserved, rather than updating the log - with a newer timestamp. + - + - When the log was changed, the onchange action is run (with the journal + - still locked to prevent any concurrent changes) and True is returned. -} -maybeAddLog :: Annex.Branch.RegardingUUID -> RawFilePath -> LogStatus -> LogInfo -> Annex () -maybeAddLog ru file logstatus loginfo = do +maybeAddLog :: Annex.Branch.RegardingUUID -> RawFilePath -> LogStatus -> LogInfo -> Annex () -> Annex Bool +maybeAddLog ru file logstatus loginfo onchange = do c <- currentVectorClock - Annex.Branch.maybeChange ru file $ \b -> + let f = \b -> let old = parseLog b line = genLine logstatus loginfo c old in do m <- insertNewStatus line $ logMap old return $ buildLog $ mapLog m + Annex.Branch.maybeChange ru file f onchange genLine :: LogStatus -> LogInfo -> CandidateVectorClock -> [LogLine] -> LogLine genLine logstatus loginfo c old = LogLine c' logstatus loginfo @@ -82,5 +89,8 @@ - The date is formatted as shown in gitrevisions man page. -} historicalLogInfo :: RefDate -> RawFilePath -> Annex [LogInfo] -historicalLogInfo refdate file = map info . filterPresent . parseLog +historicalLogInfo refdate file = parseLogInfo <$> Annex.Branch.getHistorical refdate file + +parseLogInfo :: L.ByteString -> [LogInfo] +parseLogInfo = map info . filterPresent . parseLog diff --git a/Logs/Web.hs b/Logs/Web.hs --- a/Logs/Web.hs +++ b/Logs/Web.hs @@ -80,7 +80,7 @@ -- in the web. case snd (getDownloader url) of OtherDownloader -> return () - _ -> logChange key webUUID InfoPresent + _ -> logChange NoLiveUpdate key webUUID InfoPresent setUrlMissing :: Key -> URLString -> Annex () setUrlMissing key url = do @@ -94,7 +94,7 @@ -- for the key are web urls, the key must not be present -- in the web. when (isweb url && null (filter isweb $ filter (/= url) us)) $ - logChange key webUUID InfoMissing + logChange NoLiveUpdate key webUUID InfoMissing where isweb u = case snd (getDownloader u) of OtherDownloader -> False diff --git a/Messages.hs b/Messages.hs --- a/Messages.hs +++ b/Messages.hs @@ -5,7 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, CPP #-} +{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, BangPatterns, CPP #-} module Messages ( showStartMessage, @@ -54,6 +54,8 @@ prompt, mkPrompter, sanitizeTopLevelExceptionMessages, + countdownToMessage, + enableNormalOutput, ) where import Control.Concurrent @@ -86,9 +88,7 @@ where json = JSON.startActionItem command ai si showStartMessage (StartUsualMessages command ai si) = do - outputType <$> Annex.getState Annex.output >>= \case - QuietOutput -> Annex.setOutput NormalOutput - _ -> noop + enableNormalOutput showStartMessage (StartMessage command ai si) showStartMessage (StartNoMessage _) = noop showStartMessage (CustomOutput _) = @@ -364,3 +364,23 @@ go e = do hPutStrLn stderr $ safeOutput $ toplevelMsg (show e) exitWith $ ExitFailure 1 + +{- Used to only run an action that displays a message after the specified + - number of steps. This is useful when performing an action that can + - sometimes take a long time, but often does not. + -} +countdownToMessage :: Int -> Annex () -> Annex Int +countdownToMessage n showmsg + | n < 1 = return 0 + | n == 1 = do + showmsg + return 0 + | otherwise = do + let !n' = pred n + return n' + +enableNormalOutput :: Annex () +enableNormalOutput = + outputType <$> Annex.getState Annex.output >>= \case + QuietOutput -> Annex.setOutput NormalOutput + _ -> noop diff --git a/P2P/Annex.hs b/P2P/Annex.hs --- a/P2P/Annex.hs +++ b/P2P/Annex.hs @@ -80,7 +80,7 @@ iv <- startVerifyKeyContentIncrementally DefaultVerify k let runtransfer ti = Right <$> transfer download' k af Nothing (\p -> - logStatusAfter k $ getViaTmp rsp DefaultVerify k af Nothing $ \tmp -> + logStatusAfter NoLiveUpdate k $ getViaTmp rsp DefaultVerify k af Nothing $ \tmp -> storefile (fromRawFilePath tmp) o l getb iv validitycheck p ti) let fallback = return $ Left $ ProtoFailureMessage "transfer already in progress, or unable to take transfer lock" @@ -121,7 +121,7 @@ Right (Left e) -> return $ Left e Right (Right ok) -> runner (next ok) SetPresent k u next -> do - v <- tryNonAsync $ logChange k u InfoPresent + v <- tryNonAsync $ logChange NoLiveUpdate k u InfoPresent case v of Left e -> return $ Left $ ProtoFailureException e Right () -> runner next @@ -132,7 +132,7 @@ Right result -> runner (next result) RemoveContent k mts next -> do let cleanup = do - logStatus k InfoMissing + logStatus NoLiveUpdate k InfoMissing return True let checkts = case mts of Nothing -> return True diff --git a/P2P/Proxy.hs b/P2P/Proxy.hs --- a/P2P/Proxy.hs +++ b/P2P/Proxy.hs @@ -43,6 +43,7 @@ , remoteConnect :: Annex (Maybe (RunState, P2PConnection, ProtoCloser)) , remoteTMVar :: TMVar (RunState, P2PConnection, ProtoCloser) , remoteSideId :: RemoteSideId + , remoteLiveUpdate :: LiveUpdate } instance Show RemoteSide where @@ -54,6 +55,7 @@ <*> pure remoteconnect <*> liftIO (atomically newEmptyTMVar) <*> liftIO (RemoteSideId <$> newUnique) + <*> pure NoLiveUpdate runRemoteSide :: RemoteSide -> Proto a -> Annex (Either ProtoFailure a) runRemoteSide remoteside a = @@ -103,9 +105,9 @@ - all other actions that a proxy needs to do are provided - here. -} data ProxyMethods = ProxyMethods - { removedContent :: UUID -> Key -> Annex () + { removedContent :: LiveUpdate -> UUID -> Key -> Annex () -- ^ called when content is removed from a repository - , addedContent :: UUID -> Key -> Annex () + , addedContent :: LiveUpdate -> UUID -> Key -> Annex () -- ^ called when content is added to a repository } @@ -443,7 +445,7 @@ _ -> Nothing let v' = map join v let us = concatMap snd $ catMaybes v' - mapM_ (\u -> removedContent (proxyMethods proxyparams) u k) us + mapM_ (\u -> removedContent (proxyMethods proxyparams) NoLiveUpdate u k) us protoerrhandler requestcomplete $ client $ net $ sendMessage $ let nonplussed = all (== proxyUUID proxyparams) us @@ -511,13 +513,19 @@ requestcomplete () relayPUTRecord k remoteside SUCCESS = do - addedContent (proxyMethods proxyparams) (Remote.uuid (remote remoteside)) k + addedContent (proxyMethods proxyparams) + (remoteLiveUpdate remoteside) + (Remote.uuid (remote remoteside)) + k return $ Just [Remote.uuid (remote remoteside)] relayPUTRecord k remoteside (SUCCESS_PLUS us) = do - let us' = (Remote.uuid (remote remoteside)) : us - forM_ us' $ \u -> - addedContent (proxyMethods proxyparams) u k - return $ Just us' + addedContent (proxyMethods proxyparams) + (remoteLiveUpdate remoteside) + (Remote.uuid (remote remoteside)) + k + forM_ us $ \u -> + addedContent (proxyMethods proxyparams) NoLiveUpdate u k + return $ Just (Remote.uuid (remote remoteside) : us) relayPUTRecord _ _ _ = return Nothing diff --git a/Remote.hs b/Remote.hs --- a/Remote.hs +++ b/Remote.hs @@ -40,6 +40,7 @@ prettyPrintUUIDs, prettyPrintUUIDsDescs, prettyPrintUUIDsWith, + prettyPrintUUIDsWith', prettyListUUIDs, prettyUUID, remoteFromUUID, @@ -229,11 +230,25 @@ -> (v -> Maybe String) -> [(UUID, Maybe v)] -> Annex String -prettyPrintUUIDsWith optfield header descm showval uuidvals = do +prettyPrintUUIDsWith = prettyPrintUUIDsWith' True + +prettyPrintUUIDsWith' + :: ToJSON' v + => Bool + -> Maybe String + -> String + -> UUIDDescMap + -> (v -> Maybe String) + -> [(UUID, Maybe v)] + -> Annex String +prettyPrintUUIDsWith' indented optfield header descm showval uuidvals = do hereu <- getUUID maybeShowJSON $ JSONChunk [(header, V.fromList $ map (jsonify hereu) uuidvals)] - return $ unwords $ map (\u -> "\t" ++ prettify hereu u ++ "\n") uuidvals + return $ concatMap + (\u -> tabindent ++ prettify hereu u ++ "\n") + uuidvals where + tabindent = if indented then "\t" else "" finddescription u = fromUUIDDesc $ M.findWithDefault mempty u descm prettify hereu (u, optval) | not (null d) = addoptval $ fromUUID u ++ " -- " ++ d @@ -247,7 +262,7 @@ | otherwise = n addoptval s = case showval =<< optval of Nothing -> s - Just val -> val ++ ": " ++ s + Just val -> val ++ s jsonify hereu (u, optval) = object $ catMaybes [ Just ("uuid", toJSON' (fromUUID u :: String)) , Just ("description", toJSON' $ finddescription u) @@ -410,8 +425,8 @@ - in the local repo, not on the remote. The process of transferring the - key to the remote, or removing the key from it *may* log the change - on the remote, but this cannot always be relied on. -} -logStatus :: Remote -> Key -> LogStatus -> Annex () -logStatus remote key = logChange key (uuid remote) +logStatus :: LiveUpdate -> Remote -> Key -> LogStatus -> Annex () +logStatus lu remote key = logChange lu key (uuid remote) {- Orders remotes by cost, with ones with the lowest cost grouped together. -} byCost :: [Remote] -> [[Remote]] diff --git a/Remote/Adb.hs b/Remote/Adb.hs --- a/Remote/Adb.hs +++ b/Remote/Adb.hs @@ -91,7 +91,6 @@ { storeExport = storeExportM serial adir , retrieveExport = retrieveExportM serial adir , removeExport = removeExportM serial adir - , versionedExport = False , checkPresentExport = checkPresentExportM serial adir , removeExportDirectory = Just $ removeExportDirectoryM serial adir , renameExport = Just $ renameExportM serial adir diff --git a/Remote/Directory.hs b/Remote/Directory.hs --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -107,7 +107,6 @@ { storeExport = storeExportM dir cow , retrieveExport = retrieveExportM dir cow , removeExport = removeExportM dir - , versionedExport = False , checkPresentExport = checkPresentExportM dir -- Not needed because removeExportLocation -- auto-removes empty directories. diff --git a/Remote/External.hs b/Remote/External.hs --- a/Remote/External.hs +++ b/Remote/External.hs @@ -95,7 +95,6 @@ { storeExport = storeExportM external , retrieveExport = retrieveExportM external , removeExport = removeExportM external - , versionedExport = False , checkPresentExport = checkPresentExportM external , removeExportDirectory = Just $ removeExportDirectoryM external , renameExport = Just $ renameExportM external diff --git a/Remote/Git.hs b/Remote/Git.hs --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -84,6 +84,7 @@ , configParser = mkRemoteConfigParser [ optionalStringParser locationField (FieldDesc "url of git remote to remember with special remote") + , yesNoParser versioningField (Just False) HiddenField ] , setup = gitSetup , exportSupported = exportUnsupported @@ -229,7 +230,9 @@ , gitconfig = gc , readonly = Git.repoIsHttp r && not (isP2PHttp' gc) , appendonly = False - , untrustworthy = False + , untrustworthy = isJust (remoteAnnexProxiedBy gc) + && (exportTree c || importTree c) + && not (isVersioning c) , availability = repoAvail r , remotetype = remote , mkUnavailable = unavailable r u rc gc rs @@ -492,7 +495,7 @@ ifM (Annex.Content.inAnnex key) ( do let cleanup = do - logStatus key InfoMissing + logStatus NoLiveUpdate key InfoMissing return True Annex.Content.lockContentForRemoval key cleanup $ \lock -> ifM (liftIO $ checkSafeDropProofEndTime proof) @@ -506,7 +509,7 @@ unless proofunexpired safeDropProofExpired - storefanout = P2PHelper.storeFanout key InfoMissing (uuid r) . map fromB64UUID + storefanout = P2PHelper.storeFanout NoLiveUpdate key InfoMissing (uuid r) . map fromB64UUID lockKey :: Remote -> State -> Key -> (VerifiedCopy -> Annex r) -> Annex r lockKey r st key callback = do @@ -664,7 +667,7 @@ let checksuccess = liftIO checkio >>= \case Just err -> giveup err Nothing -> return True - logStatusAfter key $ Annex.Content.getViaTmp rsp verify key af (Just sz) $ \dest -> + logStatusAfter NoLiveUpdate key $ Annex.Content.getViaTmp rsp verify key af (Just sz) $ \dest -> metered (Just (combineMeterUpdate meterupdate p)) key bwlimit $ \_ p' -> copier object (fromRawFilePath dest) key p' checksuccess verify ) @@ -692,7 +695,7 @@ PutOffsetResultAlreadyHavePlus fanoutuuids -> storefanout fanoutuuids - storefanout = P2PHelper.storeFanout key InfoPresent (uuid r) . map fromB64UUID + storefanout = P2PHelper.storeFanout NoLiveUpdate key InfoPresent (uuid r) . map fromB64UUID fsckOnRemote :: Git.Repo -> [CommandParam] -> Annex (IO Bool) fsckOnRemote r params diff --git a/Remote/Helper/ExportImport.hs b/Remote/Helper/ExportImport.hs --- a/Remote/Helper/ExportImport.hs +++ b/Remote/Helper/ExportImport.hs @@ -1,25 +1,28 @@ {- Helper to make remotes support export and import (or not). - - - Copyright 2017-2019 Joey Hess + - Copyright 2017-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE FlexibleInstances, FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} module Remote.Helper.ExportImport where import Annex.Common +import qualified Annex import Types.Remote import Types.Key import Types.ProposedAccepted -import Annex.Verify import Remote.Helper.Encryptable (encryptionIsEnabled) import qualified Database.Export as Export import qualified Database.ContentIdentifier as ContentIdentifier import Annex.Export import Annex.LockFile import Annex.SpecialRemote.Config +import Annex.Verify +import Annex.Content import Git.Types (fromRef) import Logs.Export import Logs.ContentIdentifier (recordContentIdentifier) @@ -39,7 +42,6 @@ , retrieveExport = nope , checkPresentExport = \_ _ -> return False , removeExport = nope - , versionedExport = False , removeExportDirectory = nope , renameExport = Nothing } @@ -123,15 +125,17 @@ else importUnsupported } } + let annexobjects = isexport && annexObjects (config r) if not isexport && not isimport then return r' - else adjustExportImport' isexport isimport r' rs + else do + gc <- Annex.getGitConfig + adjustExportImport' isexport isimport annexobjects r' rs gc -adjustExportImport' :: Bool -> Bool -> Remote -> RemoteStateHandle -> Annex Remote -adjustExportImport' isexport isimport r rs = do +adjustExportImport' :: Bool -> Bool -> Bool -> Remote -> RemoteStateHandle -> GitConfig -> Annex Remote +adjustExportImport' isexport isimport annexobjects r rs gc = do dbv <- prepdbv ciddbv <- prepciddb - let versioned = versionedExport (exportActions r) return $ r { exportActions = if isexport then if isimport @@ -141,52 +145,55 @@ , importActions = if isimport then importActions r else importUnsupported - , storeKey = \k af p -> - -- Storing a key on an export could be implemented, - -- but it would perform unnecessary work + , storeKey = \k af o p -> + -- Storing a key to an export location could be + -- implemented, but it would perform unnecessary work -- when another repository has already stored the -- key, and the local repository does not know -- about it. To avoid unnecessary costs, don't do it. if thirdpartypopulated then giveup "remote is not populated by git-annex" else if isexport - then giveup "remote is configured with exporttree=yes; use `git-annex export` to store content on it" + then if annexobjects + then storeannexobject k o p + else giveup "remote is configured with exporttree=yes; use `git-annex export` to store content on it" else if isimport then giveup "remote is configured with importtree=yes and without exporttree=yes; cannot modify content stored on it" - else storeKey r k af p - , removeKey = \k -> - -- Removing a key from an export would need to - -- change the tree in the export log to not include + else storeKey r k af o p + , removeKey = \proof k -> + -- Removing a key from an export location would need + -- to change the tree in the export log to not include -- the file. Otherwise, conflicts when removing -- files would not be dealt with correctly. -- There does not seem to be a good use case for - -- removing a key from an export in any case. + -- removing a key from an exported tree in any case. if thirdpartypopulated then giveup "dropping content from this remote is not supported" else if isexport - then giveup "dropping content from an export is not supported; use `git annex export` to export a tree that lacks the files you want to remove" + then if annexobjects + then removeannexobject dbv k + else giveup "dropping content from an export is not supported; use `git annex export` to export a tree that lacks the files you want to remove" else if isimport then giveup "dropping content from this remote is not supported because it is configured with importtree=yes" - else removeKey r k + else removeKey r proof k , lockContent = if versioned then lockContent r else Nothing , retrieveKeyFile = \k af dest p vc -> - if isimport + if isimport || isexport then supportversionedretrieve k af dest p vc $ - retrieveKeyFileFromImport dbv ciddbv k af dest p - else if isexport - then supportversionedretrieve k af dest p vc $ - retrieveKeyFileFromExport dbv k af dest p - else retrieveKeyFile r k af dest p vc + supportretrieveannexobject dbv k af dest p $ + retrieveFromImportOrExport (tryexportlocs dbv k) ciddbv k af dest p + else retrieveKeyFile r k af dest p vc , retrieveKeyFileCheap = if versioned then retrieveKeyFileCheap r else Nothing , checkPresent = \k -> if versioned then checkPresent r k else if isimport - then anyM (checkPresentImport ciddbv k) - =<< getanyexportlocs dbv k + then checkpresentwith k $ + anyM (checkPresentImport ciddbv k) + =<< getanyexportlocs dbv k else if isexport -- Check if any of the files a key -- was exported to are present. This @@ -197,8 +204,9 @@ -- to it. Remotes that have such -- problems are made untrusted, -- so it's not worried about here. - then anyM (checkPresentExport (exportActions r) k) - =<< getanyexportlocs dbv k + then checkpresentwith k $ + anyM (checkPresentExport (exportActions r) k) + =<< getanyexportlocs dbv k else checkPresent r k -- checkPresent from an export is more expensive -- than otherwise, so not cheap. Also, this @@ -226,13 +234,21 @@ then do ts <- map fromRef . exportedTreeishes <$> getExport (uuid r) - return (is++[("exporttree", "yes"), ("exportedtree", unwords ts)]) + return $ is ++ catMaybes + [ Just ("exporttree", "yes") + , Just ("exportedtree", unwords ts) + , if annexobjects + then Just ("annexobjects", "yes") + else Nothing + ] else return is return $ if isimport && not thirdpartypopulated then (is'++[("importtree", "yes")]) else is' } where + versioned = isVersioning (config r) + thirdpartypopulated = thirdPartyPopulated (remotetype r) -- exportActions adjusted to use the equivalent import actions, @@ -313,7 +329,7 @@ , liftIO $ atomically (readTMVar dbv) ) - getexportinconflict (_, _, v) = v + isexportinconflict (_, _, v) = liftIO $ atomically $ readTVar v updateexportdb db exportinconflict = Export.updateExportTreeFromLog db >>= \case @@ -329,8 +345,8 @@ getexportlocs dbv k = do db <- getexportdb dbv - liftIO $ Export.getExportTree db k >>= \case - [] -> ifM (atomically $ readTVar $ getexportinconflict dbv) + liftIO (Export.getExportTree db k) >>= \case + [] -> ifM (isexportinconflict dbv) ( giveup "unknown export location, likely due to the export conflict" , return [] ) @@ -349,12 +365,16 @@ db <- getciddb ciddbv liftIO $ ContentIdentifier.getContentIdentifiers db rs k + retrieveFromImportOrExport getlocs ciddbv k af dest p + | isimport = retrieveFromImport getlocs ciddbv k af dest p + | otherwise = retrieveFromExport getlocs k af dest p + -- Keys can be retrieved using retrieveExport, but since that -- retrieves from a path in the remote that another writer could -- have replaced with content not of the requested key, the content -- has to be strongly verified. - retrieveKeyFileFromExport dbv k _af dest p = ifM (isVerifiable k) - ( tryexportlocs dbv k $ \loc -> + retrieveFromExport getlocs k _af dest p = ifM (isVerifiable k) + ( getlocs $ \loc -> retrieveExport (exportActions r) k loc dest p >>= return . \case UnVerified -> MustVerify IncompleteVerify iv -> MustFinishIncompleteVerify iv @@ -362,28 +382,87 @@ , giveup $ "exported content cannot be verified due to using the " ++ decodeBS (formatKeyVariety (fromKey keyVariety k)) ++ " backend" ) - retrieveKeyFileFromImport dbv ciddbv k af dest p = do + retrieveFromImport getlocs ciddbv k af dest p = do cids <- getkeycids ciddbv k if not (null cids) - then tryexportlocs dbv k $ \loc -> + then getlocs $ \loc -> snd <$> retrieveExportWithContentIdentifier (importActions r) loc cids dest (Left k) p -- In case a content identifier is somehow missing, -- try this instead. else if isexport - then retrieveKeyFileFromExport dbv k af dest p + then retrieveFromExport getlocs k af dest p else giveup "no content identifier is recorded, unable to retrieve" - - -- versionedExport remotes have a key/value store, so can use - -- the usual retrieveKeyFile, rather than an import/export - -- variant. However, fall back to that if retrieveKeyFile fails. - supportversionedretrieve k af dest p vc a - | versionedExport (exportActions r) = - retrieveKeyFile r k af dest p vc - `catchNonAsync` const a - | otherwise = a + checkpresentwith k a = ifM a + ( return True + , if annexobjects + then checkpresentannexobject k + else return False + ) + checkPresentImport ciddbv k loc = checkPresentExportWithContentIdentifier (importActions r) k loc =<< getkeycids ciddbv k + + annexobjectlocation k = exportAnnexObjectLocation gc k + + checkpresentannexobject k = + checkPresentExport (exportActions r) k (annexobjectlocation k) + + storeannexobject k o p = prepSendAnnex' k o >>= \case + Nothing -> giveup "content is not available" + Just (src, _, checkmodified) -> do + let loc = annexobjectlocation k + storeExport (exportActions r) src k loc p + checkmodified >>= \case + Nothing -> return () + Just err -> do + removeExport (exportActions r) k loc + giveup err + + removeannexobject dbv k = + getanyexportlocs dbv k >>= \case + [] -> ifM (isexportinconflict dbv) + ( do + warnExportImportConflict r + giveup "Cannot remove content from the remote until the conflict has been resolved." + , removeExport (exportActions r) k (annexobjectlocation k) + ) + _ -> giveup "This key is part of the exported tree, so can only be removed by exporting a tree that does not include it." + + retrieveannexobject k af dest p = + retrieveFromExport getlocs k af dest p + where + getlocs a = a (annexobjectlocation k) + + supportretrieveannexobject dbv k af dest p a + | annexobjects = tryNonAsync a >>= \case + Right res -> return res + Left err -> tryNonAsync (retrieveannexobject k af dest p) >>= \case + Right res -> return res + -- Both failed, so which exception to + -- throw? If there are known export + -- locations, throw the exception from + -- retrieving from the export locations. + -- If there are no known export locations, + -- throw the exception from retrieving from + -- the annexobjects location. + Left err' -> getanyexportlocs dbv k >>= \case + [] -> ifM (isexportinconflict dbv) + ( throwM err + , throwM err' + ) + _ -> throwM err + | otherwise = a + + -- versioned remotes have a key/value store which + -- the usual retrieveKeyFile can be used with, rather than + -- an import/export variant. However, fall back to that + -- if retrieveKeyFile fails. + supportversionedretrieve k af dest p vc a + | versioned = + retrieveKeyFile r k af dest p vc + `catchNonAsync` const a + | otherwise = a diff --git a/Remote/Helper/P2P.hs b/Remote/Helper/P2P.hs --- a/Remote/Helper/P2P.hs +++ b/Remote/Helper/P2P.hs @@ -43,15 +43,15 @@ metered (Just p) sizer bwlimit $ \_ p' -> runner (P2P.put k af p') >>= \case Just (Just fanoutuuids) -> - storeFanout k InfoPresent remoteuuid fanoutuuids + storeFanout NoLiveUpdate k InfoPresent remoteuuid fanoutuuids Just Nothing -> giveup "Transfer failed" Nothing -> remoteUnavail -storeFanout :: Key -> LogStatus -> UUID -> [UUID] -> Annex () -storeFanout k logstatus remoteuuid us = +storeFanout :: LiveUpdate -> Key -> LogStatus -> UUID -> [UUID] -> Annex () +storeFanout lu k logstatus remoteuuid us = forM_ us $ \u -> when (u /= remoteuuid) $ - logChange k u logstatus + logChange lu k u logstatus retrieve :: RemoteGitConfig -> (ProtoRunner (Bool, Verification)) -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification retrieve gc runner k af dest p verifyconfig = do @@ -66,10 +66,10 @@ remove :: UUID -> ProtoRunner (Either String Bool, Maybe [UUID]) -> Maybe SafeDropProof -> Key -> Annex () remove remoteuuid runner proof k = runner (P2P.remove proof k) >>= \case Just (Right True, alsoremoveduuids) -> - storeFanout k InfoMissing remoteuuid + storeFanout NoLiveUpdate k InfoMissing remoteuuid (fromMaybe [] alsoremoveduuids) Just (Right False, alsoremoveduuids) -> do - storeFanout k InfoMissing remoteuuid + storeFanout NoLiveUpdate k InfoMissing remoteuuid (fromMaybe [] alsoremoveduuids) giveup "removing content from remote failed" Just (Left err, _) -> do diff --git a/Remote/HttpAlso.hs b/Remote/HttpAlso.hs --- a/Remote/HttpAlso.hs +++ b/Remote/HttpAlso.hs @@ -79,7 +79,6 @@ { storeExport = cannotModify , retrieveExport = retriveExportHttpAlso url , removeExport = cannotModify - , versionedExport = False , checkPresentExport = checkPresentExportHttpAlso url , removeExportDirectory = Nothing , renameExport = cannotModify diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -103,7 +103,6 @@ { storeExport = storeExportM o , retrieveExport = retrieveExportM o , removeExport = removeExportM o - , versionedExport = False , checkPresentExport = checkPresentExportM o , removeExportDirectory = Just (removeExportDirectoryM o) , renameExport = Just $ renameExportM o diff --git a/Remote/S3.hs b/Remote/S3.hs --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -143,10 +143,7 @@ fileprefixField :: RemoteConfigField fileprefixField = Accepted "fileprefix" - -versioningField :: RemoteConfigField -versioningField = Accepted "versioning" - + publicField :: RemoteConfigField publicField = Accepted "public" @@ -224,7 +221,6 @@ { storeExport = storeExportS3 hdl this rs info magic , retrieveExport = retrieveExportS3 hdl this info , removeExport = removeExportS3 hdl this rs info - , versionedExport = versioning info , checkPresentExport = checkPresentExportS3 hdl this info -- S3 does not have directories. , removeExportDirectory = Nothing diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -101,7 +101,6 @@ , retrieveExport = retrieveExportDav hdl , checkPresentExport = checkPresentExportDav hdl this , removeExport = removeExportDav hdl - , versionedExport = False , removeExportDirectory = Just $ removeExportDirectoryDav hdl , renameExport = Just $ renameExportDav hdl diff --git a/Test.hs b/Test.hs --- a/Test.hs +++ b/Test.hs @@ -63,6 +63,7 @@ import qualified Annex.VariantFile import qualified Annex.View import qualified Annex.View.ViewedFile +import qualified Annex.Balanced import qualified Logs.View import qualified Command.TestRemote import qualified Utility.Path.Tests @@ -186,6 +187,7 @@ , testProperty "prop_view_roundtrips" Annex.View.prop_view_roundtrips , testProperty "prop_viewedFile_rountrips" Annex.View.ViewedFile.prop_viewedFile_roundtrips , testProperty "prop_standardGroups_parse" Logs.PreferredContent.prop_standardGroups_parse + , testProperty "prop_balanced_stable" Annex.Balanced.prop_balanced_stable ] ++ map (uncurry testProperty) combos where combos = concat diff --git a/Types/Export.hs b/Types/Export.hs --- a/Types/Export.hs +++ b/Types/Export.hs @@ -34,7 +34,7 @@ -- PINNED in memory which caused memory fragmentation and excessive memory -- use. newtype ExportLocation = ExportLocation S.ShortByteString - deriving (Show, Eq, Generic) + deriving (Show, Eq, Generic, Ord) instance NFData ExportLocation diff --git a/Types/FileMatcher.hs b/Types/FileMatcher.hs --- a/Types/FileMatcher.hs +++ b/Types/FileMatcher.hs @@ -11,6 +11,7 @@ import Types.Key (Key) import Types.Link (LinkType) import Types.Mime +import Types.RepoSize (LiveUpdate) import Utility.Matcher (Matcher, Token, MatchDesc) import Utility.FileSize import Utility.FileSystemEncoding @@ -85,7 +86,7 @@ type AssumeNotPresent = S.Set UUID data MatchFiles a = MatchFiles - { matchAction :: AssumeNotPresent -> MatchInfo -> a Bool + { matchAction :: LiveUpdate -> AssumeNotPresent -> MatchInfo -> a Bool , matchNeedsFileName :: Bool -- ^ does the matchAction need a filename in order to match? , matchNeedsFileContent :: Bool @@ -95,6 +96,8 @@ -- ^ does the matchAction look at information about the key? , matchNeedsLocationLog :: Bool -- ^ does the matchAction look at the location log? + , matchNeedsLiveRepoSize :: Bool + -- ^ does the matchAction need live repo size information? , matchDesc :: Bool -> MatchDesc -- ^ displayed to the user to describe whether it matched or not } diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -163,6 +163,7 @@ , annexAdviceNoSshCaching :: Bool , annexViewUnsetDirectory :: ViewUnset , annexClusters :: M.Map RemoteName ClusterUUID + , annexFullyBalancedThreshhold :: Double } extractGitConfig :: ConfigSource -> Git.Repo -> GitConfig @@ -296,6 +297,9 @@ M.mapMaybe (mkClusterUUID . toUUID) $ M.mapKeys removeclusterprefix $ M.filterWithKey isclusternamekey (config r) + , annexFullyBalancedThreshhold = + fromMaybe 0.9 $ (/ 100) <$> getmayberead + (annexConfig "fullybalancedthreshhold") } where getbool k d = fromMaybe d $ getmaybebool k diff --git a/Types/Group.hs b/Types/Group.hs --- a/Types/Group.hs +++ b/Types/Group.hs @@ -1,6 +1,6 @@ {- git-annex repo groups - - - Copyright 2012, 2019 Joey Hess + - Copyright 2012-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -15,6 +15,7 @@ import Types.UUID import Utility.FileSystemEncoding +import Annex.Balanced import qualified Data.Map as M import qualified Data.Set as S @@ -32,7 +33,8 @@ data GroupMap = GroupMap { groupsByUUID :: M.Map UUID (S.Set Group) , uuidsByGroup :: M.Map Group (S.Set UUID) + , balancedPickerByGroup :: M.Map Group BalancedPicker } emptyGroupMap :: GroupMap -emptyGroupMap = GroupMap M.empty M.empty +emptyGroupMap = GroupMap M.empty M.empty M.empty diff --git a/Types/Remote.hs b/Types/Remote.hs --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -278,11 +278,6 @@ -- Can throw exception if unable to access remote, or if remote -- refuses to remove the content. , removeExport :: Key -> ExportLocation -> a () - -- Set when the remote is versioned, so once a Key is stored - -- to an ExportLocation, a subsequent deletion of that - -- ExportLocation leaves the key still accessible to retrieveKeyFile - -- and checkPresent. - , versionedExport :: Bool -- Removes an exported directory. Typically the directory will be -- empty, but it could possibly contain files or other directories, -- and it's ok to delete those (but not required to). diff --git a/Types/RepoSize.hs b/Types/RepoSize.hs new file mode 100644 --- /dev/null +++ b/Types/RepoSize.hs @@ -0,0 +1,118 @@ +{- git-annex repo sizes types + - + - Copyright 2024 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables #-} + +module Types.RepoSize where + +import Types.UUID +import Types.Key +import Utility.PID + +import Control.Concurrent +import Database.Persist.Sql hiding (Key) +import Data.Unique +import Text.Read +import qualified Data.Text as T +import qualified Data.Set as S + +-- The current size of a repo. +newtype RepoSize = RepoSize { fromRepoSize :: Integer } + deriving (Show, Eq, Ord, Num) + +-- The maximum size of a repo. +newtype MaxSize = MaxSize { fromMaxSize :: Integer } + deriving (Show, Eq, Ord) + +-- An offset to the size of a repo. +newtype SizeOffset = SizeOffset { fromSizeChange :: Integer } + deriving (Show, Eq, Ord, Num) + +-- Used when an action is in progress that will change the current size of +-- a repository. +-- +-- This allows other concurrent changes to the same repository take +-- the changes to its size into account. If NoLiveUpdate is used, it +-- prevents that. +data LiveUpdate + = LiveUpdate + { liveUpdateNeeded :: MVar () + , liveUpdateStart :: MVar () + , liveUpdateReady :: MVar () + , liveUpdateDone :: MVar (Maybe (UUID, Key, SizeChange, MVar ())) + } + | NoLiveUpdate + +data SizeChange = AddingKey | RemovingKey + deriving (Show, Eq, Ord) + +instance PersistField SizeChange where + toPersistValue AddingKey = toPersistValue (1 :: Int) + toPersistValue RemovingKey = toPersistValue (-1 :: Int) + fromPersistValue b = fromPersistValue b >>= \case + (1 :: Int) -> Right AddingKey + -1 -> Right RemovingKey + v -> Left $ T.pack $ "bad serialized SizeChange "++ show v + +instance PersistFieldSql SizeChange where + sqlType _ = SqlInt32 + +data SizeChangeId = SizeChangeId + { sizeChangeUniqueId :: SizeChangeUniqueId + , sizeChangeProcessId :: SizeChangeProcessId + } + deriving (Show, Eq, Ord) + +-- A unique value for the current process. +newtype SizeChangeUniqueId = SizeChangeUniqueId Int + deriving (Show, Eq, Ord) + +-- A pid, using Integer for portability +newtype SizeChangeProcessId = SizeChangeProcessId Integer + deriving (Show, Eq, Ord) + +mkSizeChangeId :: PID -> IO SizeChangeId +mkSizeChangeId pid = do + u <- newUnique + return $ SizeChangeId + { sizeChangeUniqueId = + SizeChangeUniqueId $ hashUnique u + , sizeChangeProcessId = + SizeChangeProcessId $ fromIntegral pid + } + +instance PersistField SizeChangeUniqueId where + toPersistValue (SizeChangeUniqueId i) = toPersistValue (show i) + fromPersistValue b = fromPersistValue b >>= parse + where + parse s = maybe + (Left $ T.pack $ "bad serialized SizeChangeUniqueId " ++ show s) + Right + (SizeChangeUniqueId <$> readMaybe s) + +instance PersistFieldSql SizeChangeUniqueId where + sqlType _ = SqlString + +instance PersistField SizeChangeProcessId where + toPersistValue (SizeChangeProcessId i) = toPersistValue (show i) + fromPersistValue b = fromPersistValue b >>= parse + where + parse s = maybe + (Left $ T.pack $ "bad serialized SizeChangeProcessId " ++ show s) + Right + (SizeChangeProcessId <$> readMaybe s) + +instance PersistFieldSql SizeChangeProcessId where + sqlType _ = SqlString + +newtype StaleSizeChanger = StaleSizeChanger + { staleSizeChangerProcessId :: SizeChangeProcessId } + deriving (Show, Eq, Ord) + +isStaleSizeChangeId :: S.Set StaleSizeChanger -> SizeChangeId -> Bool +isStaleSizeChangeId s cid = + StaleSizeChanger (sizeChangeProcessId cid) `S.member` s diff --git a/Upgrade/V5.hs b/Upgrade/V5.hs --- a/Upgrade/V5.hs +++ b/Upgrade/V5.hs @@ -154,7 +154,7 @@ locs <- Direct.associatedFiles k unlessM (anyM (Direct.goodContent k) locs) $ do u <- getUUID - logChange k u InfoMissing + logChange NoLiveUpdate k u InfoMissing ) writepointer f k = liftIO $ do diff --git a/Utility/DataUnits.hs b/Utility/DataUnits.hs --- a/Utility/DataUnits.hs +++ b/Utility/DataUnits.hs @@ -1,6 +1,6 @@ {- data size display and parsing - - - Copyright 2011-2022 Joey Hess + - Copyright 2011-2024 Joey Hess - - License: BSD-2-clause - @@ -52,6 +52,7 @@ roughSize, roughSize', + preciseSize, compareSizes, readSize ) where @@ -144,7 +145,13 @@ roughSize units short i = copyright $ roughSize' units short 2 i roughSize' :: [Unit] -> Bool -> Int -> ByteSize -> String -roughSize' units short precision i +roughSize' units short = showSize units short . showImprecise + +preciseSize :: [Unit] -> Bool -> ByteSize -> String +preciseSize units short = showSize units short show + +showSize :: [Unit] -> Bool -> (Double -> String) -> ByteSize -> String +showSize units short showdouble i | i < 0 = '-' : findUnit units' (negate i) | otherwise = findUnit units' i where @@ -158,7 +165,7 @@ showUnit x (Unit size abbrev name) = s ++ " " ++ unit where v = (fromInteger x :: Double) / fromInteger size - s = showImprecise precision v + s = showdouble v unit | short = abbrev | s == "1" = name diff --git a/Utility/Hash.hs b/Utility/Hash.hs --- a/Utility/Hash.hs +++ b/Utility/Hash.hs @@ -1,11 +1,12 @@ {- Convenience wrapper around cryptonite's hashing. - - - Copyright 2013-2021 Joey Hess + - Copyright 2013-2024 Joey Hess - - License: BSD-2-clause -} {-# LANGUAGE BangPatterns, PackageImports #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE CPP #-} module Utility.Hash ( @@ -263,25 +264,26 @@ deriving (Eq) calcMac - :: Mac -- ^ MAC + :: (forall a. Digest a -> t) -- ^ applied to MAC'ed message + -> Mac -- ^ MAC -> S.ByteString -- ^ secret key -> S.ByteString -- ^ message - -> String -- ^ MAC'ed message, in hexadecimal -calcMac mac = case mac of + -> t +calcMac f mac = case mac of HmacSha1 -> use SHA1 HmacSha224 -> use SHA224 HmacSha256 -> use SHA256 HmacSha384 -> use SHA384 HmacSha512 -> use SHA512 where - use alg k m = show (hmacGetDigest (hmacWitnessAlg alg k m)) + use alg k m = f (hmacGetDigest (hmacWitnessAlg alg k m)) hmacWitnessAlg :: HashAlgorithm a => a -> S.ByteString -> S.ByteString -> HMAC a hmacWitnessAlg _ = hmac -- Check that all the MACs continue to produce the same. props_macs_stable :: [(String, Bool)] -props_macs_stable = map (\(desc, mac, result) -> (desc ++ " stable", calcMac mac key msg == result)) +props_macs_stable = map (\(desc, mac, result) -> (desc ++ " stable", calcMac show mac key msg == result)) [ ("HmacSha1", HmacSha1, "46b4ec586117154dacd49d664e5d63fdc88efb51") , ("HmacSha224", HmacSha224, "4c1f774863acb63b7f6e9daa9b5c543fa0d5eccf61e3ffc3698eacdd") , ("HmacSha256", HmacSha256, "f9320baf0249169e73850cd6156ded0106e2bb6ad8cab01b7bbbebe6d1065317") diff --git a/Utility/Verifiable.hs b/Utility/Verifiable.hs --- a/Utility/Verifiable.hs +++ b/Utility/Verifiable.hs @@ -37,7 +37,7 @@ verify v secret = v == mkVerifiable (verifiableVal v) secret calcDigest :: String -> Secret -> HMACDigest -calcDigest v secret = calcMac HmacSha1 secret (fromString v) +calcDigest v secret = calcMac show HmacSha1 secret (fromString v) prop_verifiable_sane :: TestableString -> TestableString -> Bool prop_verifiable_sane v ts = diff --git a/git-annex.cabal b/git-annex.cabal --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1,5 +1,5 @@ Name: git-annex -Version: 10.20240808 +Version: 10.20240831 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess @@ -519,6 +519,7 @@ Annex.AdjustedBranch.Merge Annex.AdjustedBranch.Name Annex.AutoMerge + Annex.Balanced Annex.BloomFilter Annex.Branch Annex.Branch.Transitions @@ -573,6 +574,8 @@ Annex.Queue Annex.ReplaceFile Annex.RemoteTrackingBranch + Annex.RepoSize + Annex.RepoSize.LiveUpdate Annex.SafeDropProof Annex.SpecialRemote Annex.SpecialRemote.Config @@ -691,6 +694,7 @@ Command.LookupKey Command.Map Command.MatchExpression + Command.MaxSize Command.Merge Command.MetaData Command.Migrate @@ -781,6 +785,8 @@ Database.Keys.SQL Database.Queue Database.RawFilePath + Database.RepoSize + Database.RepoSize.Handle Database.Types Database.Utility Git @@ -858,6 +864,7 @@ Logs.Line Logs.Location Logs.MapLog + Logs.MaxSize Logs.MetaData Logs.MetaData.Pure Logs.Migrate @@ -994,6 +1001,7 @@ Types.Remote Types.RemoteConfig Types.RemoteState + Types.RepoSize Types.RepoVersion Types.ScheduledActivity Types.StandardGroups