diff --git a/Annex/Balanced.hs b/Annex/Balanced.hs --- a/Annex/Balanced.hs +++ b/Annex/Balanced.hs @@ -12,7 +12,7 @@ import Utility.Hash import Data.Maybe -import Data.List +import qualified Data.List as L import Data.Bits (shiftL) import qualified Data.Set as S import qualified Data.ByteArray as BA @@ -33,7 +33,7 @@ combineduuids = mconcat (map fromUUID (S.toAscList s)) tointeger :: Digest a -> Integer - tointeger = foldl' (\i b -> (i `shiftL` 8) + fromIntegral b) 0 + tointeger = L.foldl' (\i b -> (i `shiftL` 8) + fromIntegral b) 0 . BA.unpack {- The selection for a given key never changes. -} diff --git a/Annex/Content.hs b/Annex/Content.hs --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -1,6 +1,6 @@ {- git-annex file content managing - - - Copyright 2010-2024 Joey Hess + - Copyright 2010-2025 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -47,6 +47,7 @@ listKeys', saveState, downloadUrl, + downloadUrl', preseedTmp, dirKeys, withObjectLoc, @@ -95,7 +96,7 @@ import Annex.AdjustedBranch (adjustedBranchRefresh) import Annex.DirHashes import Messages.Progress -import Types.Remote (RetrievalSecurityPolicy(..), VerifyConfigA(..)) +import Types.Remote (RetrievalSecurityPolicy(..), VerifyConfigA(..), name, storeKey, uuid) import Types.NumCopies import Types.Key import Types.Transfer @@ -652,14 +653,6 @@ liftIO $ removeWhenExistsWith removeFile dest failed -{- Removes the annex object file for a key. Lowlevel. -} -unlinkAnnex :: Key -> Annex () -unlinkAnnex key = do - obj <- calcRepo (gitAnnexLocation key) - modifyContentDir obj $ do - secureErase obj - liftIO $ removeWhenExistsWith removeFile obj - {- Runs an action to transfer an object's content. The action is also - passed the size of the object. - @@ -775,9 +768,19 @@ <=< catchMaybeIO $ tryWhenExists $ removeDirectory dir +{- Removes the annex object file for a key. Lowlevel, does not update + - pointer files. -} +unlinkAnnex :: Key -> Annex () +unlinkAnnex key = do + obj <- calcRepo (gitAnnexLocation key) + modifyContentDir obj $ do + secureErase obj + liftIO $ removeWhenExistsWith removeFile obj + {- Removes a key's file from .git/annex/objects/ -} -removeAnnex :: ContentRemovalLock -> Annex () -removeAnnex (ContentRemovalLock key) = withObjectLoc key $ \file -> +removeAnnex :: Annex [Remote] -> ContentRemovalLock -> Annex () +removeAnnex remotelist (ContentRemovalLock key) = withObjectLoc key $ \file -> do + putouttrash cleanObjectLoc key $ do secureErase file liftIO $ removeWhenExistsWith removeFile file @@ -798,6 +801,20 @@ -- removal process, so thaw it. , void $ tryIO $ thawContent file ) + + putouttrash = annexTrashbin <$> Annex.getGitConfig >>= \case + Nothing -> return () + Just trashbin -> do + rs <- remotelist + putouttrash' trashbin rs + + putouttrash' _ [] = giveup "annex.trashbin is set to the name of an unknown remote" + putouttrash' trashbin (r:rs) + | name r == trashbin = do + catchNonAsync (storeKey r key (AssociatedFile Nothing) Nothing nullMeterUpdate) + (\ex -> giveup $ "Failed to move to annex.trashbin remote; unable to drop " ++ show ex) + logChange NoLiveUpdate key (uuid r) InfoPresent + | otherwise = putouttrash' trashbin rs {- Moves a key out of .git/annex/objects/ into .git/annex/bad, and - returns the file it was moved to. -} @@ -881,13 +898,21 @@ - that failed. -} downloadUrl :: Bool -> Key -> MeterUpdate -> Maybe IncrementalVerifier -> [Url.URLString] -> OsPath -> Url.UrlOptions -> Annex Bool -downloadUrl listfailedurls k p iv urls file uo = +downloadUrl listfailedurls k p iv urls file uo = + downloadUrl' listfailedurls k p iv urls file uo >>= \case + Right r -> return r + Left e -> do + warning $ UnquotedString e + return False + +downloadUrl' :: Bool -> Key -> MeterUpdate -> Maybe IncrementalVerifier -> [Url.URLString] -> OsPath -> Url.UrlOptions -> Annex (Either String Bool) +downloadUrl' listfailedurls k p iv urls file uo = -- Poll the file to handle configurations where an external -- download command is used. meteredFile file (Just p) k (go urls []) where go (u:us) errs p' = Url.download' p' iv u file uo >>= \case - Right () -> return True + Right () -> return (Right True) Left err -> do -- If the incremental verifier was fed anything -- while the download that failed ran, it's unable @@ -899,14 +924,12 @@ _ -> noop Nothing -> noop go us ((u, err) : errs) p' - go [] [] _ = return False - go [] errs@((_, err):_) _ = do + go [] [] _ = return (Right False) + go [] errs@((_, err):_) _ = return $ Left $ if listfailedurls - then warning $ UnquotedString $ - unlines $ flip map errs $ \(u, err') -> - u ++ " " ++ err' - else warning $ UnquotedString err - return False + then unlines $ flip map errs $ \(u, err') -> + u ++ " " ++ err' + else err {- Copies a key's content, when present, to a temp file. - This is used to speed up some rsyncs. -} diff --git a/Assistant/Unused.hs b/Assistant/Unused.hs --- a/Assistant/Unused.hs +++ b/Assistant/Unused.hs @@ -20,6 +20,7 @@ import Utility.DiskFree import Utility.HumanTime import Utility.Tense +import Remote.List import Data.Time.Clock.POSIX import qualified Data.Text as T @@ -76,7 +77,7 @@ forM_ oldkeys $ \k -> do debug ["removing old unused key", serializeKey k] liftAnnex $ tryNonAsync $ do - lockContentForRemoval k noop removeAnnex + lockContentForRemoval k noop (removeAnnex remoteList) logStatus NoLiveUpdate k InfoMissing where boundary = durationToPOSIXTime <$> duration diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs --- a/Assistant/Upgrade.hs +++ b/Assistant/Upgrade.hs @@ -28,6 +28,7 @@ import Assistant.TransferQueue import Assistant.TransferSlots import Remote (remoteFromUUID) +import Remote.List import Annex.Path import Config.Files import Utility.ThreadScheduler @@ -102,7 +103,7 @@ , transferKeyData = fromKey id k } cleanup = liftAnnex $ do - lockContentForRemoval k noop removeAnnex + lockContentForRemoval k noop (removeAnnex remoteList) setUrlMissing k u logStatus NoLiveUpdate k InfoMissing diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,23 @@ +git-annex (10.20251215) upstream; urgency=medium + + * Added annex.trashbin configuration. + * Added --presentsince, --lackingsince, and --changedsince file + matching options. + * Added TRANSFER-RETRIEVE-URL extension to the external special remote + protocol. + * S3: Remote can be configured with an x-amz-tagging header. + (Needs aws-0.25) + * S3: Support Google Cloud Storage + (Needs aws-0.25.1) + * S3: Support restore=yes, when used with storageclass=DEEP_ARCHIVE and + similar. This is equivilant to the now deprecated Amazon Glacier. + (Needs aws-0.25.2) + * Add a build warning when the version of aws being built against is + too old to support all features. + * stack.yaml: Use aws-0.25.2. + + -- Joey Hess Mon, 15 Dec 2025 13:23:29 -0400 + git-annex (10.20251114) upstream; urgency=medium * p2p --pair: Fix to work with external P2P networks. @@ -6374,7 +6394,7 @@ * sync: Show a hint about receive.denyNonFastForwards when a push fails. * directory, webdav: Fix bug introduced in version 4.20131002 that caused the chunkcount file to not be written. Work around repositories - without such a file, so files can still be retreived from them. + without such a file, so files can still be retrieved from them. * assistant: Automatically repair damanged git repository, if it can be done without losing data. * assistant: Support repairing git remotes that are locally accessible diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs --- a/CmdLine/GitAnnex/Options.hs +++ b/CmdLine/GitAnnex/Options.hs @@ -381,6 +381,21 @@ <> help "match files accessed within a time interval" <> hidden ) + , annexOption (setAnnexState . Limit.addPresentSince) $ strOption + ( long "presentsince" <> metavar paramValue + <> help "matches files present in a repository throughout a time interval" + <> hidden + ) + , annexOption (setAnnexState . Limit.addLackingSince) $ strOption + ( long "lackingsince" <> metavar paramValue + <> help "matches files not present in a repository throughout a time interval" + <> hidden + ) + , annexOption (setAnnexState . Limit.addChangedSince) $ strOption + ( long "changedsince" <> metavar paramValue + <> help "matches files whose presence changed during a time interval" + <> hidden + ) , annexOption (setAnnexState . Limit.addMimeType) $ strOption ( long "mimetype" <> metavar paramGlob <> help "match files by mime type" diff --git a/CmdLine/GitRemoteAnnex.hs b/CmdLine/GitRemoteAnnex.hs --- a/CmdLine/GitRemoteAnnex.hs +++ b/CmdLine/GitRemoteAnnex.hs @@ -1201,7 +1201,7 @@ annexobjectdir <- fromRepo gitAnnexObjectDir ks <- listKeys InAnnex forM_ ks $ \k -> case fromKey keyVariety k of - GitBundleKey -> lockContentForRemoval k noop removeAnnex + GitBundleKey -> lockContentForRemoval k noop (removeAnnex remoteList) _ -> noop void $ liftIO $ tryIO $ removeDirectory annexobjectdir diff --git a/Command/Drop.hs b/Command/Drop.hs --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -20,6 +20,7 @@ import Annex.Content import Annex.Wanted import Annex.Notification +import Remote.List cmd :: Command cmd = withAnnexOptions [jobsOption, jsonOptions, annexedMatchingOptions] $ @@ -134,7 +135,7 @@ , "proof:" , show proof ] - removeAnnex contentlock + removeAnnex remoteList contentlock notifyDrop afile True next $ cleanupLocal lu key ud , do diff --git a/Command/DropKey.hs b/Command/DropKey.hs --- a/Command/DropKey.hs +++ b/Command/DropKey.hs @@ -11,6 +11,7 @@ import qualified Annex import Logs.Location import Annex.Content +import Remote.List cmd :: Command cmd = noCommit $ withAnnexOptions [jsonOptions] $ @@ -48,7 +49,7 @@ perform :: Key -> CommandPerform perform key = ifM (inAnnex key) ( lockContentForRemoval key (next $ cleanup key) $ \contentlock -> do - removeAnnex contentlock + removeAnnex remoteList contentlock next $ cleanup key , next $ return True ) diff --git a/Command/Export.hs b/Command/Export.hs --- a/Command/Export.hs +++ b/Command/Export.hs @@ -40,6 +40,7 @@ import Utility.Tmp import Utility.Metered import Utility.Matcher +import Remote.List import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L @@ -364,7 +365,7 @@ ( lockContentForRemoval ek (return False) $ \contentlock -> do showAction $ UnquotedString $ "to " ++ Remote.name r sendlocalannexobject - `finally` removeAnnex contentlock + `finally` removeAnnex remoteList contentlock , return False ) diff --git a/Command/Move.hs b/Command/Move.hs --- a/Command/Move.hs +++ b/Command/Move.hs @@ -14,6 +14,7 @@ import qualified Annex import Annex.Content import qualified Remote +import Remote.List import Annex.UUID import Annex.Transfer import Logs.Trust @@ -211,7 +212,7 @@ -- Drop content before updating location logs, -- in case disk space is very low this frees -- up space before writing data to disk. - removeAnnex contentlock + removeAnnex remoteList contentlock next $ do () <- setpresentremote Command.Drop.cleanupLocal lu key (Command.Drop.DroppingUnused False) diff --git a/Command/P2PStdIO.hs b/Command/P2PStdIO.hs --- a/Command/P2PStdIO.hs +++ b/Command/P2PStdIO.hs @@ -19,6 +19,7 @@ import Logs.Cluster import Annex.Cluster import qualified Remote +import Remote.List import System.IO.Error @@ -56,7 +57,7 @@ P2P.net $ P2P.sendMessage (P2P.AUTH_SUCCESS myuuid) P2P.serveAuthed servermode myuuid runst <- liftIO $ mkRunState $ Serving theiruuid Nothing - p2pErrHandler noop (const p2pDone) (runFullProto runst conn server) + p2pErrHandler noop (const p2pDone) (runFullProto runst remoteList conn server) performProxy :: UUID -> P2P.ServerMode -> Remote -> CommandPerform performProxy clientuuid servermode r = do diff --git a/Command/Recompute.hs b/Command/Recompute.hs --- a/Command/Recompute.hs +++ b/Command/Recompute.hs @@ -22,6 +22,7 @@ import Logs.Location import Command.AddComputed (Reproducible(..), parseReproducible, getInputContent, getInputContent', addComputed) import Backend (maybeLookupBackendVariety, unknownBackendVarietyMessage, chooseBackend) +import Remote.List import Types.Key import qualified Utility.RawFilePath as R @@ -190,7 +191,7 @@ -- the old version. v -> if recomputingvurl then do - lockContentForRemoval origkey noop removeAnnex + lockContentForRemoval origkey noop (removeAnnex remoteList) return (Just (Reproducible False)) else return v diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -33,6 +33,7 @@ import Remote.Helper.Encryptable (encryptionField, highRandomQualityField) import Git.Types import qualified Utility.FileIO as F +import Remote.List import Test.Tasty import Test.Tasty.Runners @@ -251,13 +252,13 @@ whenwritable r $ runBool (store r k) , check ("present " ++ show True) $ \r k -> present r k True , check "retrieveKeyFile" $ \r k -> do - lockContentForRemoval k noop removeAnnex + lockContentForRemoval k noop (removeAnnex remoteList) get r k , check "fsck downloaded object" fsck , check "retrieveKeyFile resume from 0" $ \r k -> do tmp <- prepTmp k liftIO $ F.writeFile' tmp mempty - lockContentForRemoval k noop removeAnnex + lockContentForRemoval k noop (removeAnnex remoteList) get r k , check "fsck downloaded object" fsck , check "retrieveKeyFile resume from 33%" $ \r k -> do @@ -267,14 +268,14 @@ sz <- hFileSize h L.hGet h $ fromInteger $ sz `div` 3 liftIO $ F.writeFile tmp partial - lockContentForRemoval k noop removeAnnex + lockContentForRemoval k noop (removeAnnex remoteList) get r k , check "fsck downloaded object" fsck , check "retrieveKeyFile resume from end" $ \r k -> do loc <- Annex.calcRepo (gitAnnexLocation k) tmp <- prepTmp k void $ liftIO $ copyFileExternal CopyAllMetaData loc tmp - lockContentForRemoval k noop removeAnnex + lockContentForRemoval k noop (removeAnnex remoteList) get r k , check "fsck downloaded object" fsck , check "removeKey when present" $ \r k -> @@ -401,7 +402,7 @@ | all Remote.readonly rs = return ok | otherwise = do forM_ rs $ \r -> forM_ ks (Remote.removeKey r Nothing) - forM_ ks $ \k -> lockContentForRemoval k noop removeAnnex + forM_ ks $ \k -> lockContentForRemoval k noop (removeAnnex remoteList) return ok chunkSizes :: Int -> Bool -> [Int] diff --git a/Command/Uninit.hs b/Command/Uninit.hs --- a/Command/Uninit.hs +++ b/Command/Uninit.hs @@ -22,6 +22,7 @@ import Annex.WorkTree import Utility.FileMode import qualified Utility.RawFilePath as R +import Remote.List import System.PosixCompat.Files (linkCount) import Control.Concurrent.STM @@ -154,7 +155,7 @@ go c [] = return c go c (k:ks) = ifM (inAnnexCheck k $ liftIO . enoughlinks) ( do - lockContentForRemoval k noop removeAnnex + lockContentForRemoval k noop (removeAnnex remoteList) go c ks , go (k:c) ks ) diff --git a/Limit.hs b/Limit.hs --- a/Limit.hs +++ b/Limit.hs @@ -910,6 +910,43 @@ return $ delta <= secs secs = fromIntegral (durationSeconds duration) +addPresentSince :: String -> Annex () +addPresentSince = limitLocationDuration "presentsince" + (\k t -> loggedLocationsUnchangedSince k t (== InfoPresent)) + +addLackingSince :: String -> Annex () +addLackingSince = limitLocationDuration "lackingsince" + (\k t -> loggedLocationsUnchangedSince k t (/= InfoPresent)) + +addChangedSince :: String -> Annex () +addChangedSince = limitLocationDuration "changedsince" + (\k t -> loggedLocationsChangedAfter k t (const True)) + +limitLocationDuration :: String -> (Key -> POSIXTime -> Annex [UUID]) -> String-> Annex () +limitLocationDuration desc getter s = do + u <- Remote.nameToUUID name + case parseDuration interval of + Left parseerr -> addLimit $ Left parseerr + Right duration -> + let check _notpresent key = do + now <- liftIO getPOSIXTime + let t = now - fromIntegral (durationSeconds duration) + us <- getter key t + return $ u `elem` us + in addLimit $ Right $ mkmatcher check + where + (name, interval) = separate (== ':') s + mkmatcher check = MatchFiles + { matchAction = const $ checkKey . check + , matchNeedsFileName = False + , matchNeedsFileContent = False + , matchNeedsKey = True + , matchNeedsLocationLog = True + , matchNeedsLiveRepoSize = False + , matchNegationUnstable = False + , matchDesc = desc =? s + } + lookupFileKey :: FileInfo -> Annex (Maybe Key) lookupFileKey fi = case matchKey fi of Just k -> return (Just k) diff --git a/Logs/Location.hs b/Logs/Location.hs --- a/Logs/Location.hs +++ b/Logs/Location.hs @@ -8,7 +8,7 @@ - Repositories record their UUID and the date when they --get or --drop - a value. - - - Copyright 2010-2024 Joey Hess + - Copyright 2010-2025 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -23,6 +23,8 @@ loggedLocations, loggedPreviousLocations, loggedLocationsHistorical, + loggedLocationsUnchangedSince, + loggedLocationsChangedAfter, loggedLocationsRef, isKnownKey, checkDead, @@ -53,6 +55,7 @@ import qualified Annex import Data.Time.Clock +import Data.Time.Clock.POSIX import qualified Data.ByteString.Lazy as L import qualified Data.Map as M import qualified Data.Set as S @@ -75,6 +78,9 @@ {- Log a change in the presence of a key's value in a repository. - + - If the provided LogStatus is the same as what is currently in the log, + - the log is not updated. + - - Cluster UUIDs are not logged. Instead, when a node of a cluster is - logged to contain a key, loading the log will include the cluster's - UUID. @@ -98,7 +104,7 @@ loggedLocations = getLoggedLocations presentLogInfo {- Returns a list of repository UUIDs that the location log indicates - - used to have the vale of a key, but no longer do. + - used to have the value of a key, but no longer do. -} loggedPreviousLocations :: Key -> Annex [UUID] loggedPreviousLocations = getLoggedLocations notPresentLogInfo @@ -106,6 +112,44 @@ {- Gets the location log on a particular date. -} loggedLocationsHistorical :: RefDate -> Key -> Annex [UUID] loggedLocationsHistorical = getLoggedLocations . historicalLogInfo + +{- Returns a list of repository UUIDs that the location log indicates + - have had a matching LogStatus for a key that has not changed + - since the given time. + - + - This assumes that logs were written with a properly set clock. + - + - Note that, while logChange avoids updating the log with the same + - LogStatus that is already in it, there are distributed situations + - where the log for a repository does get updated redundantly, + - setting the same LogStatus that was already logged. When that has + - happened, this will treat it as the LogStatus having changed at the + - last time it was written. + -} +loggedLocationsUnchangedSince :: Key -> POSIXTime -> (LogStatus -> Bool) -> Annex [UUID] +loggedLocationsUnchangedSince key time matchstatus = + loggedLocationsMatchingTime key (<= time) matchstatus + +{- Similar to loggedLocationsSince, but lists repository UUIDs that + - have had a matching LogStatus recorded after the given time. + -} +loggedLocationsChangedAfter :: Key -> POSIXTime -> (LogStatus -> Bool) -> Annex [UUID] +loggedLocationsChangedAfter key time matchstatus = + loggedLocationsMatchingTime key (> time) matchstatus + +loggedLocationsMatchingTime :: Key -> (POSIXTime -> Bool) -> (LogStatus -> Bool) -> Annex [UUID] +loggedLocationsMatchingTime key matchtime matchstatus = do + config <- Annex.getGitConfig + locs <- map (toUUID . fromLogInfo . info) + . filter (matchtime' . date) + . filter (matchstatus . status) + . compactLog + <$> readLog (locationLogFile config key) + clusters <- getClusters + return $ addClusterUUIDs clusters locs + where + matchtime' (VectorClock t) = matchtime t + matchtime' Unknown = False {- Gets the locations contained in a git ref. -} loggedLocationsRef :: Ref -> Annex [UUID] diff --git a/P2P/Annex.hs b/P2P/Annex.hs --- a/P2P/Annex.hs +++ b/P2P/Annex.hs @@ -32,16 +32,16 @@ import Data.Time.Clock.POSIX -- Full interpreter for Proto, that can receive and send objects. -runFullProto :: RunState -> P2PConnection -> Proto a -> Annex (Either ProtoFailure a) -runFullProto runst conn = go +runFullProto :: RunState -> Annex [Remote] -> P2PConnection -> Proto a -> Annex (Either ProtoFailure a) +runFullProto runst remotelist conn = go where go :: RunProto Annex go (Pure v) = return (Right v) go (Free (Net n)) = runNet runst conn go n - go (Free (Local l)) = runLocal runst go l + go (Free (Local l)) = runLocal runst remotelist go l -runLocal :: RunState -> RunProto Annex -> LocalF (Proto a) -> Annex (Either ProtoFailure a) -runLocal runst runner a = case a of +runLocal :: RunState -> Annex [Remote] -> RunProto Annex -> LocalF (Proto a) -> Annex (Either ProtoFailure a) +runLocal runst remotelist runner a = case a of TmpContentSize k next -> do tmp <- fromRepo $ gitAnnexTmpObjectLocation k size <- liftIO $ catchDefaultIO 0 $ getFileSize tmp @@ -145,7 +145,7 @@ ( lockContentForRemoval k cleanup $ \contentlock -> ifM checkts ( do - removeAnnex contentlock + removeAnnex remotelist contentlock cleanup , return False ) diff --git a/P2P/Http/Server.hs b/P2P/Http/Server.hs --- a/P2P/Http/Server.hs +++ b/P2P/Http/Server.hs @@ -31,6 +31,7 @@ import P2P.Annex import Annex.WorkerPool import Types.WorkerPool +import Remote.List import Types.Direction import Utility.Metered import Utility.STM @@ -137,7 +138,7 @@ return True let noothermessages = const Nothing enteringStage (TransferStage Upload) $ - runFullProto (clientRunState conn) (clientP2PConnection conn) $ + runFullProto (clientRunState conn) remoteList (clientP2PConnection conn) $ void $ receiveContent Nothing nullMeterUpdate sizer storer noothermessages getreq void $ liftIO $ forkIO $ waitfinal endv finalv conn annexworker @@ -403,7 +404,7 @@ -> IO (Either SomeException (Either ProtoFailure (Maybe [UUID]))) servePutAction (conn, st) (B64Key k) baf a = handleRequestAnnex st $ enteringStage (TransferStage Download) $ - runFullProto (clientRunState conn) (clientP2PConnection conn) $ + runFullProto (clientRunState conn) remoteList (clientP2PConnection conn) $ put' k af a where af = b64FilePathToAssociatedFile baf @@ -495,14 +496,14 @@ -- A thread takes the lock, and keeps running -- until unlock in order to keep the lock held. lockthread <- async $ handleRequestAnnex st $ do - lockres <- runFullProto (clientRunState conn) (clientP2PConnection conn) $ do + lockres <- runFullProto (clientRunState conn) remoteList (clientP2PConnection conn) $ do net $ sendMessage (LOCKCONTENT k) checkSuccess liftIO $ atomically $ putTMVar lockresv lockres case lockres of Right True -> do liftIO $ atomically $ takeTMVar unlockv - void $ runFullProto (clientRunState conn) (clientP2PConnection conn) $ do + void $ runFullProto (clientRunState conn) remoteList (clientP2PConnection conn) $ do net $ sendMessage UNLOCKCONTENT _ -> return () atomically (takeTMVar lockresv) >>= \case diff --git a/P2P/Http/State.hs b/P2P/Http/State.hs --- a/P2P/Http/State.hs +++ b/P2P/Http/State.hs @@ -39,6 +39,7 @@ import qualified P2P.Proxy as Proxy import qualified Types.Remote as Remote import Utility.STM +import Remote.List import Servant import qualified Data.Map.Strict as M @@ -416,7 +417,7 @@ localP2PConnectionPair connparams relv $ \serverrunst serverconn -> runner $ do liftIO $ atomically $ putTMVar ready () - void $ runFullProto serverrunst serverconn $ + void $ runFullProto serverrunst remoteList serverconn $ P2P.serveOneCommandAuthed (connectionServerMode connparams) (connectionServerUUID connparams) diff --git a/Remote/External.hs b/Remote/External.hs --- a/Remote/External.hs +++ b/Remote/External.hs @@ -1,6 +1,6 @@ {- External special remote interface. - - - Copyright 2013-2024 Joey Hess + - Copyright 2013-2025 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -93,7 +93,7 @@ let exportactions = if exportsupported then ExportActions { storeExport = storeExportM external - , retrieveExport = retrieveExportM external + , retrieveExport = retrieveExportM external gc , removeExport = removeExportM external , checkPresentExport = checkPresentExportM external , removeExportDirectory = Just $ removeExportDirectoryM external @@ -116,7 +116,7 @@ cheapexportsupported return $ Just $ specialRemote c (storeKeyM external) - (retrieveKeyFileM external) + (retrieveKeyFileM external gc) (removeKeyM external) (checkPresentM external) rmt @@ -248,17 +248,19 @@ result (Left (respErrorMessage "TRANSFER" errmsg)) _ -> Nothing -retrieveKeyFileM :: External -> Retriever -retrieveKeyFileM external = fileRetriever $ \d k p -> - either giveup return =<< watchFileSize d p (go d k) +retrieveKeyFileM :: External -> RemoteGitConfig -> Retriever +retrieveKeyFileM external gc = fileRetriever $ \dest k p -> + either giveup return =<< watchFileSize dest p (go dest k) where - go d k p = handleRequestKey external (\sk -> TRANSFER Download sk (fromOsPath d)) k (Just p) $ \resp -> + go dest k p = handleRequestKey external (\sk -> TRANSFER Download sk (fromOsPath dest)) k (Just p) $ \resp -> case resp of TRANSFER_SUCCESS Download k' | k == k' -> result $ Right () TRANSFER_FAILURE Download k' errmsg | k == k' -> result $ Left $ respErrorMessage "TRANSFER" errmsg + TRANSFER_RETRIEVE_URL k' url + | k == k' -> retrieveUrl' gc url dest k p _ -> Nothing removeKeyM :: External -> Remover @@ -306,8 +308,8 @@ _ -> Nothing req sk = TRANSFEREXPORT Upload sk (fromOsPath f) -retrieveExportM :: External -> Key -> ExportLocation -> OsPath -> MeterUpdate -> Annex Verification -retrieveExportM external k loc dest p = do +retrieveExportM :: External -> RemoteGitConfig -> Key -> ExportLocation -> OsPath -> MeterUpdate -> Annex Verification +retrieveExportM external gc k loc dest p = do verifyKeyContentIncrementally AlwaysVerify k $ \iv -> tailVerify iv dest $ either giveup return =<< go @@ -317,6 +319,8 @@ | k == k' -> result $ Right () TRANSFER_FAILURE Download k' errmsg | k == k' -> result $ Left $ respErrorMessage "TRANSFER" errmsg + TRANSFER_RETRIEVE_URL k' url + | k == k' -> retrieveUrl' gc url dest k p UNSUPPORTED_REQUEST -> result $ Left "TRANSFEREXPORT not implemented by external special remote" _ -> Nothing @@ -838,7 +842,18 @@ retrieveUrl gc = fileRetriever' $ \f k p iv -> do us <- getWebUrls k unlessM (withUrlOptions (Just gc) $ downloadUrl True k p iv us f) $ - giveup "failed to download content" + giveup downloadFailed + +retrieveUrl' :: RemoteGitConfig -> URLString -> OsPath -> Key -> MeterUpdate -> Maybe (Annex (ResponseHandlerResult (Either String ()))) +retrieveUrl' gc url dest k p = + Just $ withUrlOptions (Just gc) $ \uo -> + downloadUrl' False k p Nothing [url] dest uo >>= return . \case + Left msg -> Result (Left msg) + Right True -> Result (Right ()) + Right False -> Result (Left downloadFailed) + +downloadFailed :: String +downloadFailed = "failed to download content" checkKeyUrl :: RemoteGitConfig -> CheckPresent checkKeyUrl gc k = do diff --git a/Remote/External/Types.hs b/Remote/External/Types.hs --- a/Remote/External/Types.hs +++ b/Remote/External/Types.hs @@ -1,6 +1,6 @@ {- External special remote data types. - - - Copyright 2013-2024 Joey Hess + - Copyright 2013-2025 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -116,6 +116,7 @@ [ "INFO" , "GETGITREMOTENAME" , "UNAVAILABLERESPONSE" + , "TRANSFER-RETRIEVE-URL" , asyncExtension ] @@ -243,6 +244,7 @@ | PREPARE_FAILURE ErrorMsg | TRANSFER_SUCCESS Direction Key | TRANSFER_FAILURE Direction Key ErrorMsg + | TRANSFER_RETRIEVE_URL Key URLString | CHECKPRESENT_SUCCESS Key | CHECKPRESENT_FAILURE Key | CHECKPRESENT_UNKNOWN Key ErrorMsg @@ -281,6 +283,7 @@ parseCommand "PREPARE-FAILURE" = Proto.parse1 PREPARE_FAILURE parseCommand "TRANSFER-SUCCESS" = Proto.parse2 TRANSFER_SUCCESS parseCommand "TRANSFER-FAILURE" = Proto.parse3 TRANSFER_FAILURE + parseCommand "TRANSFER-RETRIEVE-URL" = Proto.parse2 TRANSFER_RETRIEVE_URL parseCommand "CHECKPRESENT-SUCCESS" = Proto.parse1 CHECKPRESENT_SUCCESS parseCommand "CHECKPRESENT-FAILURE" = Proto.parse1 CHECKPRESENT_FAILURE parseCommand "CHECKPRESENT-UNKNOWN" = Proto.parse2 CHECKPRESENT_UNKNOWN diff --git a/Remote/Git.hs b/Remote/Git.hs --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -516,7 +516,7 @@ Annex.Content.lockContentForRemoval key cleanup $ \lock -> ifM (liftIO $ checkSafeDropProofEndTime proof) ( do - Annex.Content.removeAnnex lock + Annex.Content.removeAnnex (Annex.getState Annex.remotes) lock cleanup , return False ) diff --git a/Remote/Helper/Ssh.hs b/Remote/Helper/Ssh.hs --- a/Remote/Helper/Ssh.hs +++ b/Remote/Helper/Ssh.hs @@ -309,7 +309,7 @@ runProtoConn :: P2P.Proto a -> P2PShellConnection -> Annex (P2PShellConnection, Maybe a) runProtoConn _ P2P.ClosedConnection = return (P2P.ClosedConnection, Nothing) runProtoConn a conn@(P2P.OpenConnection (runst, c, _)) = do - P2P.runFullProto runst c a >>= \case + P2P.runFullProto runst (Annex.getState Annex.remotes) c a >>= \case Right r -> return (conn, Just r) -- When runFullProto fails, the connection is no longer -- usable, so close it. diff --git a/Remote/P2P.hs b/Remote/P2P.hs --- a/Remote/P2P.hs +++ b/Remote/P2P.hs @@ -103,7 +103,7 @@ runProtoConn :: P2P.Proto a -> Connection -> Annex (Connection, Maybe a) runProtoConn _ ClosedConnection = return (ClosedConnection, Nothing) runProtoConn a c@(OpenConnection (runst, conn)) = do - v <- runFullProto runst conn a + v <- runFullProto runst (Annex.getState Annex.remotes) conn a -- When runFullProto fails, the connection is no longer usable, -- so close it. case v of diff --git a/Remote/S3.hs b/Remote/S3.hs --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -1,6 +1,6 @@ {- S3 remotes - - - Copyright 2011-2024 Joey Hess + - Copyright 2011-2025 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -12,6 +12,10 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE CPP #-} +#if ! MIN_VERSION_aws(0,25,2) +#warning Building with an old version of the aws library. Recommend updating to 0.25.2, which fixes bugs and is needed for some features. +#endif + module Remote.S3 (remote, iaHost, configIA, iaItemUrl) where import qualified Aws as AWS @@ -92,6 +96,8 @@ (FieldDesc "part size for multipart upload (eg 1GiB)") , optionalStringParser storageclassField (FieldDesc "storage class, eg STANDARD or STANDARD_IA or ONEZONE_IA") + , yesNoParser restoreField (Just False) + (FieldDesc "enable restore of files not currently accessible in the bucket") , optionalStringParser fileprefixField (FieldDesc "prefix to add to filenames in the bucket") , yesNoParser versioningField (Just False) @@ -108,6 +114,8 @@ (FieldDesc "for path-style requests, set to \"path\"") , signatureVersionParser signatureField (FieldDesc "S3 signature version") + , optionalStringParser taggingField + (FieldDesc "tagging header to add when storing on S3") , optionalStringParser mungekeysField HiddenField , optionalStringParser AWS.s3credsField HiddenField ] @@ -145,7 +153,10 @@ fileprefixField :: RemoteConfigField fileprefixField = Accepted "fileprefix" - + +restoreField :: RemoteConfigField +restoreField = Accepted "restore" + publicField :: RemoteConfigField publicField = Accepted "public" @@ -161,6 +172,9 @@ signatureField :: RemoteConfigField signatureField = Accepted "signature" +taggingField :: RemoteConfigField +taggingField = Accepted "x-amz-tagging" + data SignatureVersion = SignatureVersion Int | DefaultSignatureVersion @@ -199,7 +213,7 @@ where new c cst info hdl magic = Just $ specialRemote c (store hdl this info magic) - (retrieve hdl rs c info) + (retrieve gc hdl rs c info) (remove hdl this info) (checkKey hdl rs c info) this @@ -423,14 +437,14 @@ {- Implemented as a fileRetriever, that uses conduit to stream the chunks - out to the file. Would be better to implement a byteRetriever, but - that is difficult. -} -retrieve :: S3HandleVar -> RemoteStateHandle -> ParsedRemoteConfig -> S3Info -> Retriever -retrieve hv rs c info = fileRetriever' $ \f k p iv -> withS3Handle hv $ \case +retrieve :: RemoteGitConfig -> S3HandleVar -> RemoteStateHandle -> ParsedRemoteConfig -> S3Info -> Retriever +retrieve gc hv rs c info = fileRetriever' $ \f k p iv -> withS3Handle hv $ \case Right h -> eitherS3VersionID info rs c k (T.pack $ bucketObject info k) >>= \case Left failreason -> do warning (UnquotedString failreason) giveup "cannot download content" - Right loc -> retrieveHelper info h loc f p iv + Right loc -> retrieveHelper gc info h loc f p iv Left S3HandleNeedCreds -> getPublicWebUrls' rs info c k >>= \case Left failreason -> do @@ -439,17 +453,45 @@ Right us -> unlessM (withUrlOptions Nothing $ downloadUrl False k p iv us f) $ giveup "failed to download content" -retrieveHelper :: S3Info -> S3Handle -> (Either S3.Object S3VersionID) -> OsPath -> MeterUpdate -> Maybe IncrementalVerifier -> Annex () -retrieveHelper info h loc f p iv = retrieveHelper' h f p iv $ +retrieveHelper :: RemoteGitConfig -> S3Info -> S3Handle -> (Either S3.Object S3VersionID) -> OsPath -> MeterUpdate -> Maybe IncrementalVerifier -> Annex () +retrieveHelper gc info h loc f p iv = retrieveHelper' gc info h f p iv $ case loc of Left o -> S3.getObject (bucket info) o Right (S3VersionID o vid) -> (S3.getObject (bucket info) o) { S3.goVersionId = Just vid } -retrieveHelper' :: S3Handle -> OsPath -> MeterUpdate -> Maybe IncrementalVerifier -> S3.GetObject -> Annex () -retrieveHelper' h f p iv req = liftIO $ runResourceT $ do - S3.GetObjectResponse { S3.gorResponse = rsp } <- sendS3Handle h req +retrieveHelper' :: RemoteGitConfig -> S3Info -> S3Handle -> OsPath -> MeterUpdate -> Maybe IncrementalVerifier -> S3.GetObject -> Annex () +retrieveHelper' gc info h f p iv req = liftIO $ runResourceT $ do + S3.GetObjectResponse { S3.gorResponse = rsp } <- handlerestore $ + sendS3Handle h req Url.sinkResponseFile p iv zeroBytesProcessed f WriteMode rsp + where + needrestore st = restore info && statusCode st == 403 + handlerestore a = catchJust (Url.matchStatusCodeException needrestore) a $ \_ -> do +#if MIN_VERSION_aws(0,25,2) + let tier = case remoteAnnexS3RestoreTier gc of + Just "bulk" -> S3.RestoreObjectTierBulk + Just "expedited" -> S3.RestoreObjectTierExpedited + _ -> S3.RestoreObjectTierStandard + let days = case remoteAnnexS3RestoreDays gc of + Just n -> S3.RestoreObjectLifetimeDays n + Nothing -> S3.RestoreObjectLifetimeDays 1 + let restorereq = S3.restoreObject + (S3.goBucket req) + (S3.goObjectName req) + tier + days + restoreresp <- sendS3Handle h $ restorereq + { S3.roVersionId = S3.goVersionId req + } + case restoreresp of + S3.RestoreObjectAccepted -> giveup "Restore initiated, try again later." + S3.RestoreObjectAlreadyInProgress -> giveup "Restore in progress, try again later." + S3.RestoreObjectAlreadyRestored -> a +#else + case remoteAnnexS3RestoreTier gc of + _ -> giveup "git-annex is built with too old a version of the aws library to support restore=yes" +#endif remove :: S3HandleVar -> Remote -> S3Info -> Remover remove hv r info _proof k = withS3HandleOrFail (uuid r) hv $ \h -> do @@ -520,7 +562,7 @@ retrieveExportS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation -> OsPath -> MeterUpdate -> Annex Verification retrieveExportS3 hv r info k loc f p = verifyKeyContentIncrementally AlwaysVerify k $ \iv -> withS3Handle hv $ \case - Right h -> retrieveHelper info h (Left (T.pack exportloc)) f p iv + Right h -> retrieveHelper (gitconfig r) info h (Left (T.pack exportloc)) f p iv Left S3HandleNeedCreds -> case getPublicUrlMaker info of Just geturl -> either giveup return =<< withUrlOptions Nothing @@ -719,7 +761,7 @@ where go iv = withS3Handle hv $ \case Right h -> do - rewritePreconditionException $ retrieveHelper' h dest p iv $ + rewritePreconditionException $ retrieveHelper' (gitconfig r) info h dest p iv $ limitGetToContentIdentifier cid $ S3.getObject (bucket info) o k <- either return id gk @@ -810,21 +852,27 @@ where go _ _ (Right True) = noop go info h _ = do - r <- liftIO $ tryNonAsync $ runResourceT $ do - void $ sendS3Handle h (S3.getBucket $ bucket info) - return True - case r of + checkbucketexists info h >>= \case Right True -> noop - _ -> do - showAction $ UnquotedString $ "creating bucket in " ++ datacenter - void $ liftIO $ runResourceT $ sendS3Handle h $ - (S3.putBucket (bucket info)) - { S3.pbCannedAcl = acl info - , S3.pbLocationConstraint = locconstraint - , S3.pbXStorageClass = storageclass - } + Right False -> createbucket info h + Left err -> do + fastDebug "Remote.S3" ("createBucket threw exception: " ++ show err) + createbucket info h writeUUIDFile c u info h + + checkbucketexists info h = liftIO $ tryNonAsync $ runResourceT $ do + void $ sendS3Handle h (S3.getBucket $ bucket info) + return True + createbucket info h = do + showAction $ UnquotedString $ "creating bucket in " ++ datacenter + void $ liftIO $ runResourceT $ sendS3Handle h $ + (S3.putBucket (bucket info)) + { S3.pbCannedAcl = acl info + , S3.pbLocationConstraint = locconstraint + , S3.pbXStorageClass = storageclass + } + locconstraint = mkLocationConstraint $ T.pack datacenter datacenter = fromJust $ getRemoteConfigValue datacenterField c -- "NEARLINE" as a storage class when creating a bucket is a @@ -1017,9 +1065,11 @@ , bucketExportLocation :: ExportLocation -> BucketObject , bucketImportLocation :: BucketObject -> Maybe ImportLocation , metaHeaders :: [(T.Text, T.Text)] + , tagging :: [(T.Text, T.Text)] , partSize :: Maybe Integer , isIA :: Bool , versioning :: Bool + , restore :: Bool , publicACL :: Bool , publicurl :: Maybe URLString , host :: Maybe String @@ -1039,10 +1089,13 @@ , bucketExportLocation = getBucketExportLocation c , bucketImportLocation = getBucketImportLocation c , metaHeaders = getMetaHeaders c + , tagging = getTagging c , partSize = getPartSize c , isIA = configIA c , versioning = fromMaybe False $ getRemoteConfigValue versioningField c + , restore = fromMaybe False $ + getRemoteConfigValue restoreField c , publicACL = fromMaybe False $ getRemoteConfigValue publicField c , publicurl = getRemoteConfigValue publicurlField c @@ -1056,6 +1109,9 @@ , S3.poMetadata = metaHeaders info , S3.poAutoMakeBucket = isIA info , S3.poAcl = acl info +#if MIN_VERSION_aws(0,25,0) + , S3.poTagging = tagging info +#endif } acl :: S3Info -> Maybe S3.CannedAcl @@ -1082,6 +1138,14 @@ where metaprefixlen = length metaPrefix munge (k, v) = (T.pack $ drop metaprefixlen (fromProposedAccepted k), T.pack v) + +getTagging :: ParsedRemoteConfig -> [(T.Text, T.Text)] +getTagging c = case getRemoteConfigValue taggingField c of + Nothing -> [] + Just s -> map go $ parseQueryText (encodeBS s) + where + go (k, Just v) = (k, v) + go (k, Nothing) = (k, mempty) isMetaHeader :: RemoteConfigField -> Bool isMetaHeader h = metaPrefix `isPrefixOf` fromProposedAccepted h diff --git a/RemoteDaemon/Transport/P2PGeneric.hs b/RemoteDaemon/Transport/P2PGeneric.hs --- a/RemoteDaemon/Transport/P2PGeneric.hs +++ b/RemoteDaemon/Transport/P2PGeneric.hs @@ -32,6 +32,7 @@ import Git import Git.Command import qualified Utility.OsString as OS +import Remote.List import Control.Concurrent import Control.Concurrent.STM @@ -176,7 +177,7 @@ authed conn theiruuid = bracket watchChangedRefs (liftIO . maybe noop stopWatchingChangedRefs) $ \crh -> do runst <- liftIO $ mkRunState (Serving theiruuid crh) - v' <- runFullProto runst conn $ + v' <- runFullProto runst remoteList conn $ P2P.serveAuthed P2P.ServeReadWrite u case v' of Right () -> return () diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -158,6 +158,7 @@ , annexAdjustedBranchRefresh :: Integer , annexSupportUnlocked :: Bool , annexAssistantAllowUnlocked :: Bool + , annexTrashbin :: Maybe RemoteName , coreSymlinks :: Bool , coreSharedRepository :: SharedRepository , coreQuotePath :: QuotePath @@ -283,6 +284,7 @@ (getmayberead (annexConfig "adjustedbranchrefresh")) , annexSupportUnlocked = getbool (annexConfig "supportunlocked") True , annexAssistantAllowUnlocked = getbool (annexConfig "assistant.allowunlocked") False + , annexTrashbin = getmaybe "annex.trashbin" , coreSymlinks = getbool "core.symlinks" True , coreSharedRepository = getSharedRepository r , coreQuotePath = QuotePath (getbool "core.quotepath" True) @@ -439,6 +441,8 @@ , remoteAnnexTahoe :: Maybe FilePath , remoteAnnexBupSplitOptions :: [String] , remoteAnnexDirectory :: Maybe FilePath + , remoteAnnexS3RestoreTier :: Maybe String + , remoteAnnexS3RestoreDays :: Maybe Integer , remoteAnnexAndroidDirectory :: Maybe FilePath , remoteAnnexAndroidSerial :: Maybe String , remoteAnnexGCrypt :: Maybe String @@ -541,6 +545,8 @@ , remoteAnnexTahoe = getmaybe TahoeField , remoteAnnexBupSplitOptions = getoptions BupSplitOptionsField , remoteAnnexDirectory = notempty $ getmaybe DirectoryField + , remoteAnnexS3RestoreTier = notempty $ getmaybe S3RestoreTierField + , remoteAnnexS3RestoreDays = getmayberead S3RestoreDaysField , remoteAnnexAndroidDirectory = notempty $ getmaybe AndroidDirectoryField , remoteAnnexAndroidSerial = notempty $ getmaybe AndroidSerialField , remoteAnnexGCrypt = notempty $ getmaybe GCryptField @@ -625,6 +631,8 @@ | TahoeField | BupSplitOptionsField | DirectoryField + | S3RestoreTierField + | S3RestoreDaysField | AndroidDirectoryField | AndroidSerialField | GCryptField @@ -697,6 +705,8 @@ TahoeField -> uninherited True "tahoe" BupSplitOptionsField -> uninherited True "bup-split-options" DirectoryField -> uninherited True "directory" + S3RestoreTierField -> uninherited True "s3-restore-tier" + S3RestoreDaysField -> uninherited True "s3-restore-days" AndroidDirectoryField -> uninherited True "androiddirectory" AndroidSerialField -> uninherited True "androidserial" GCryptField -> uninherited True "gcrypt" diff --git a/git-annex.cabal b/git-annex.cabal --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1,5 +1,5 @@ Name: git-annex -Version: 10.20251114 +Version: 10.20251215 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -13,3 +13,5 @@ packages: - '.' resolver: lts-24.2 +extra-deps: +- aws-0.25.2