git-annex 10.20240808 → 10.20240831
raw patch · 113 files changed
+2825/−655 lines, 113 files
Files
- Annex.hs +12/−1
- Annex/Balanced.hs +47/−0
- Annex/Branch.hs +110/−51
- Annex/Cluster.hs +11/−2
- Annex/Common.hs +1/−0
- Annex/Content.hs +1/−1
- Annex/Drop.hs +16/−11
- Annex/FileMatcher.hs +32/−23
- Annex/Import.hs +11/−10
- Annex/Ingest.hs +2/−2
- Annex/Locations.hs +31/−3
- Annex/LockFile.hs +15/−1
- Annex/Proxy.hs +88/−29
- Annex/RepoSize.hs +230/−0
- Annex/RepoSize/LiveUpdate.hs +189/−0
- Annex/SpecialRemote/Config.hs +14/−0
- Annex/Wanted.hs +10/−10
- Assistant/Threads/Committer.hs +2/−2
- Assistant/Threads/TransferScanner.hs +2/−2
- Assistant/Threads/Watcher.hs +1/−1
- Assistant/TransferQueue.hs +2/−2
- Assistant/TransferSlots.hs +2/−2
- Assistant/Unused.hs +1/−1
- Assistant/Upgrade.hs +1/−1
- CHANGELOG +32/−0
- CmdLine.hs +1/−1
- CmdLine/GitAnnex.hs +2/−0
- CmdLine/GitAnnex/Options.hs +6/−0
- CmdLine/GitRemoteAnnex.hs +3/−4
- CmdLine/Seek.hs +4/−1
- Command.hs +1/−0
- Command/Add.hs +2/−2
- Command/AddUnused.hs +1/−1
- Command/AddUrl.hs +4/−4
- Command/Copy.hs +18/−5
- Command/DiffDriver.hs +1/−1
- Command/Drop.hs +38/−35
- Command/DropKey.hs +1/−1
- Command/DropUnused.hs +4/−2
- Command/Export.hs +122/−52
- Command/Fsck.hs +4/−4
- Command/Get.hs +17/−15
- Command/Import.hs +1/−1
- Command/Info.hs +48/−15
- Command/Lock.hs +1/−1
- Command/LookupKey.hs +6/−4
- Command/MatchExpression.hs +1/−1
- Command/MaxSize.hs +137/−0
- Command/Migrate.hs +1/−1
- Command/Mirror.hs +4/−4
- Command/Move.hs +71/−66
- Command/Multicast.hs +1/−1
- Command/PostReceive.hs +70/−10
- Command/ReKey.hs +1/−1
- Command/RecvKey.hs +1/−1
- Command/RegisterUrl.hs +1/−1
- Command/Reinject.hs +1/−1
- Command/SetKey.hs +1/−1
- Command/SetPresentKey.hs +1/−1
- Command/Smudge.hs +2/−2
- Command/Sync.hs +38/−32
- Command/TestRemote.hs +3/−3
- Command/TransferKey.hs +2/−2
- Command/TransferKeys.hs +2/−2
- Command/Transferrer.hs +2/−2
- Command/UpdateCluster.hs +11/−4
- Command/UpdateProxy.hs +29/−4
- Command/Vicfg.hs +23/−1
- Command/Wanted.hs +1/−1
- Config.hs +13/−0
- Crypto.hs +1/−1
- Database/ImportFeed.hs +4/−4
- Database/Keys.hs +2/−10
- Database/Queue.hs +1/−0
- Database/RepoSize.hs +422/−0
- Database/RepoSize/Handle.hs +22/−0
- Git/CatFile.hs +12/−6
- Limit.hs +225/−28
- Limit/Wanted.hs +7/−5
- Logs.hs +8/−1
- Logs/ContentIdentifier.hs +2/−1
- Logs/Group.hs +3/−2
- Logs/Location.hs +116/−30
- Logs/MaxSize.hs +48/−0
- Logs/PreferredContent.hs +5/−5
- Logs/Presence.hs +15/−5
- Logs/Web.hs +2/−2
- Messages.hs +24/−4
- P2P/Annex.hs +3/−3
- P2P/Proxy.hs +16/−8
- Remote.hs +20/−5
- Remote/Adb.hs +0/−1
- Remote/Directory.hs +0/−1
- Remote/External.hs +0/−1
- Remote/Git.hs +8/−5
- Remote/Helper/ExportImport.hs +125/−46
- Remote/Helper/P2P.hs +6/−6
- Remote/HttpAlso.hs +0/−1
- Remote/Rsync.hs +0/−1
- Remote/S3.hs +1/−5
- Remote/WebDAV.hs +0/−1
- Test.hs +2/−0
- Types/Export.hs +1/−1
- Types/FileMatcher.hs +4/−1
- Types/GitConfig.hs +4/−0
- Types/Group.hs +4/−2
- Types/Remote.hs +0/−5
- Types/RepoSize.hs +118/−0
- Upgrade/V5.hs +1/−1
- Utility/DataUnits.hs +10/−3
- Utility/Hash.hs +8/−6
- Utility/Verifiable.hs +1/−1
- git-annex.cabal +9/−1
Annex.hs view
@@ -1,6 +1,6 @@ {- git-annex monad -- - Copyright 2010-2021 Joey Hess <id@joeyh.name>+ - Copyright 2010-2024 Joey Hess <id@joeyh.name> - - 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.
+ Annex/Balanced.hs view
@@ -0,0 +1,47 @@+{- Balancing between UUIDs+ -+ - Copyright 2024 Joey Hess <id@joeyh.name>+ -+ - 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"
Annex/Branch.hs view
@@ -1,6 +1,6 @@ {- management of the git-annex branch -- - Copyright 2011-2023 Joey Hess <id@joeyh.name>+ - Copyright 2011-2024 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -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 ([], [])
Annex/Cluster.hs view
@@ -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
Annex/Common.hs view
@@ -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
Annex/Content.hs view
@@ -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
Annex/Drop.hs view
@@ -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)
Annex/FileMatcher.hs view
@@ -1,6 +1,6 @@ {- git-annex file matching -- - Copyright 2012-2023 Joey Hess <id@joeyh.name>+ - Copyright 2012-2024 Joey Hess <id@joeyh.name> - - 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
Annex/Import.hs view
@@ -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)
Annex/Ingest.hs view
@@ -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
Annex/Locations.hs view
@@ -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. -}
Annex/LockFile.hs view
@@ -1,6 +1,6 @@ {- git-annex lock files. -- - Copyright 2012-2020 Joey Hess <id@joeyh.name>+ - Copyright 2012-2024 Joey Hess <id@joeyh.name> - - 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
Annex/Proxy.hs view
@@ -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 }
+ Annex/RepoSize.hs view
@@ -0,0 +1,230 @@+{- git-annex repo sizes+ -+ - Copyright 2024 Joey Hess <id@joeyh.name>+ -+ - 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
+ Annex/RepoSize/LiveUpdate.hs view
@@ -0,0 +1,189 @@+{- git-annex repo sizes, live updates+ -+ - Copyright 2024 Joey Hess <id@joeyh.name>+ -+ - 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
Annex/SpecialRemote/Config.hs view
@@ -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
Annex/Wanted.hs view
@@ -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
Assistant/Threads/Committer.hs view
@@ -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
Assistant/Threads/TransferScanner.hs view
@@ -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)
Assistant/Threads/Watcher.hs view
@@ -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
Assistant/TransferQueue.hs view
@@ -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
Assistant/TransferSlots.hs view
@@ -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
Assistant/Unused.hs view
@@ -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
Assistant/Upgrade.hs view
@@ -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.
CHANGELOG view
@@ -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 <id@joeyh.name> Sat, 31 Aug 2024 19:48:17 -0400+ git-annex (10.20240808) upstream; urgency=medium * Remove debug output (to stderr) accidentially included in
CmdLine.hs view
@@ -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
CmdLine/GitAnnex.hs view
@@ -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
CmdLine/GitAnnex/Options.hs view
@@ -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
CmdLine/GitRemoteAnnex.hs view
@@ -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),
CmdLine/Seek.hs view
@@ -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
Command.hs view
@@ -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
Command/Add.hs view
@@ -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
Command/AddUnused.hs view
@@ -32,7 +32,7 @@ (ActionItemTreeFile file) (SeekInput [show n]) $ next $ do- logStatus key InfoPresent+ logStatus NoLiveUpdate key InfoPresent addSymlink file key Nothing return True
Command/AddUrl.hs view
@@ -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 )
Command/Copy.hs view
@@ -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))
Command/DiffDriver.hs view
@@ -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)
Command/Drop.hs view
@@ -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'
Command/DropKey.hs view
@@ -55,5 +55,5 @@ cleanup :: Key -> CommandCleanup cleanup key = do- logStatus key InfoMissing+ logStatus NoLiveUpdate key InfoMissing return True
Command/DropUnused.hs view
@@ -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
Command/Export.hs view
@@ -1,6 +1,6 @@ {- git-annex command -- - Copyright 2017-2023 Joey Hess <id@joeyh.name>+ - Copyright 2017-2024 Joey Hess <id@joeyh.name> - - 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 )
Command/Fsck.hs view
@@ -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
Command/Get.hs view
@@ -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
Command/Import.hs view
@@ -256,7 +256,7 @@ , inodeCache = newcache } }- ifM (checkFileMatcher largematcher destfile)+ ifM (checkFileMatcher NoLiveUpdate largematcher destfile) ( ingestAdd' nullMeterUpdate (Just ld') (Just k) >>= maybe stop
Command/Info.hs view
@@ -1,16 +1,18 @@ {- git-annex command -- - Copyright 2011-2023 Joey Hess <id@joeyh.name>+ - Copyright 2011-2024 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -} -{-# 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
Command/Lock.hs view
@@ -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)"
Command/LookupKey.hs view
@@ -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
Command/MatchExpression.hs view
@@ -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
+ Command/MaxSize.hs view
@@ -0,0 +1,137 @@+{- git-annex command+ -+ - Copyright 2024 Joey Hess <id@joeyh.name>+ -+ - 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
Command/Migrate.hs view
@@ -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 )
Command/Mirror.hs view
@@ -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
Command/Move.hs view
@@ -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
Command/Multicast.hs view
@@ -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
Command/PostReceive.hs view
@@ -1,6 +1,6 @@ {- git-annex command -- - Copyright 2017 Joey Hess <id@joeyh.name>+ - Copyright 2017-2024 Joey Hess <id@joeyh.name> - - 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
Command/ReKey.hs view
@@ -149,6 +149,6 @@ return (MigrationRecord sha) ) whenM (inAnnex newkey) $- logStatus newkey InfoPresent+ logStatus NoLiveUpdate newkey InfoPresent a newkeyrec return True
Command/RecvKey.hs view
@@ -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
Command/RegisterUrl.hs view
@@ -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 ()
Command/Reinject.hs view
@@ -133,5 +133,5 @@ cleanup :: Key -> CommandCleanup cleanup key = do- logStatus key InfoPresent+ logStatus NoLiveUpdate key InfoPresent return True
Command/SetKey.hs view
@@ -48,5 +48,5 @@ cleanup :: Key -> CommandCleanup cleanup key = do- logStatus key InfoPresent+ logStatus NoLiveUpdate key InfoPresent return True
Command/SetPresentKey.hs view
@@ -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
Command/Smudge.hs view
@@ -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
Command/Sync.hs view
@@ -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)
Command/TestRemote.hs view
@@ -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)) ]
Command/TransferKey.hs view
@@ -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
Command/TransferKeys.hs view
@@ -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))
Command/Transferrer.hs view
@@ -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))
Command/UpdateCluster.hs view
@@ -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
Command/UpdateProxy.hs view
@@ -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
Command/Vicfg.hs view
@@ -1,6 +1,6 @@ {- git-annex command -- - Copyright 2012-2022 Joey Hess <id@joeyh.name>+ - Copyright 2012-2024 Joey Hess <id@joeyh.name> - - 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 ->
Command/Wanted.hs view
@@ -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)
Config.hs view
@@ -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)
Crypto.hs view
@@ -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
Database/ImportFeed.hs view
@@ -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
Database/Keys.hs view
@@ -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
Database/Queue.hs view
@@ -14,6 +14,7 @@ closeDbQueue, flushDbQueue, QueueSize,+ LastCommitTime, queueDb, ) where
+ Database/RepoSize.hs view
@@ -0,0 +1,422 @@+{- Sqlite database used to track the sizes of repositories.+ -+ - Copyright 2024 Joey Hess <id@joeyh.name>+ -:+ - 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
+ Database/RepoSize/Handle.hs view
@@ -0,0 +1,22 @@+{- Sqlite database used to track the sizes of repositories.+ -+ - Copyright 2024 Joey Hess <id@joeyh.name>+ -:+ - 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.
Git/CatFile.hs view
@@ -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
Limit.hs view
@@ -1,6 +1,6 @@ {- user-specified limits on files to act on -- - Copyright 2011-2023 Joey Hess <id@joeyh.name>+ - Copyright 2011-2024 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -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
Limit/Wanted.hs view
@@ -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 }
Logs.hs view
@@ -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
Logs/ContentIdentifier.hs view
@@ -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
Logs/Group.hs view
@@ -1,6 +1,6 @@ {- git-annex group log -- - Copyright 2012, 2019 Joey Hess <id@joeyh.name>+ - Copyright 2012-2024 Joey Hess <id@joeyh.name> - - 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
Logs/Location.hs view
@@ -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.
+ Logs/MaxSize.hs view
@@ -0,0 +1,48 @@+{- git-annex maxsize log+ -+ - Copyright 2024 Joey Hess <id@joeyh.name>+ -+ - 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
Logs/PreferredContent.hs view
@@ -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
Logs/Presence.hs view
@@ -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 <id@joeyh.name>+ - Copyright 2010-2024 Joey Hess <id@joeyh.name> - - 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
Logs/Web.hs view
@@ -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
Messages.hs view
@@ -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
P2P/Annex.hs view
@@ -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
P2P/Proxy.hs view
@@ -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
Remote.hs view
@@ -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]]
Remote/Adb.hs view
@@ -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
Remote/Directory.hs view
@@ -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.
Remote/External.hs view
@@ -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
Remote/Git.hs view
@@ -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
Remote/Helper/ExportImport.hs view
@@ -1,25 +1,28 @@ {- Helper to make remotes support export and import (or not). -- - Copyright 2017-2019 Joey Hess <id@joeyh.name>+ - Copyright 2017-2024 Joey Hess <id@joeyh.name> - - 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
Remote/Helper/P2P.hs view
@@ -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
Remote/HttpAlso.hs view
@@ -79,7 +79,6 @@ { storeExport = cannotModify , retrieveExport = retriveExportHttpAlso url , removeExport = cannotModify- , versionedExport = False , checkPresentExport = checkPresentExportHttpAlso url , removeExportDirectory = Nothing , renameExport = cannotModify
Remote/Rsync.hs view
@@ -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
Remote/S3.hs view
@@ -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
Remote/WebDAV.hs view
@@ -101,7 +101,6 @@ , retrieveExport = retrieveExportDav hdl , checkPresentExport = checkPresentExportDav hdl this , removeExport = removeExportDav hdl- , versionedExport = False , removeExportDirectory = Just $ removeExportDirectoryDav hdl , renameExport = Just $ renameExportDav hdl
Test.hs view
@@ -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
Types/Export.hs view
@@ -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
Types/FileMatcher.hs view
@@ -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 }
Types/GitConfig.hs view
@@ -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
Types/Group.hs view
@@ -1,6 +1,6 @@ {- git-annex repo groups -- - Copyright 2012, 2019 Joey Hess <id@joeyh.name>+ - Copyright 2012-2024 Joey Hess <id@joeyh.name> - - 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
Types/Remote.hs view
@@ -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).
+ Types/RepoSize.hs view
@@ -0,0 +1,118 @@+{- git-annex repo sizes types+ -+ - Copyright 2024 Joey Hess <id@joeyh.name>+ -+ - 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
Upgrade/V5.hs view
@@ -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
Utility/DataUnits.hs view
@@ -1,6 +1,6 @@ {- data size display and parsing -- - Copyright 2011-2022 Joey Hess <id@joeyh.name>+ - Copyright 2011-2024 Joey Hess <id@joeyh.name> - - 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
Utility/Hash.hs view
@@ -1,11 +1,12 @@ {- Convenience wrapper around cryptonite's hashing. -- - Copyright 2013-2021 Joey Hess <id@joeyh.name>+ - Copyright 2013-2024 Joey Hess <id@joeyh.name> - - 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")
Utility/Verifiable.hs view
@@ -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 =
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 10.20240808+Version: 10.20240831 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -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