packages feed

git-annex 10.20251114 → 10.20251215

raw patch · 30 files changed

+339/−93 lines, 30 files

Files

Annex/Balanced.hs view
@@ -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. -}
Annex/Content.hs view
@@ -1,6 +1,6 @@ {- git-annex file content managing  -- - Copyright 2010-2024 Joey Hess <id@joeyh.name>+ - Copyright 2010-2025 Joey Hess <id@joeyh.name>  -  - 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. -}
Assistant/Unused.hs view
@@ -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
Assistant/Upgrade.hs view
@@ -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
CHANGELOG view
@@ -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 <id@joeyh.name>  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
CmdLine/GitAnnex/Options.hs view
@@ -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"
CmdLine/GitRemoteAnnex.hs view
@@ -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
Command/Drop.hs view
@@ -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
Command/DropKey.hs view
@@ -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 	)
Command/Export.hs view
@@ -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  			)
Command/Move.hs view
@@ -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)
Command/P2PStdIO.hs view
@@ -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
Command/Recompute.hs view
@@ -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
Command/TestRemote.hs view
@@ -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]
Command/Uninit.hs view
@@ -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 		)
Limit.hs view
@@ -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)
Logs/Location.hs view
@@ -8,7 +8,7 @@  - Repositories record their UUID and the date when they --get or --drop  - a value.  - - - Copyright 2010-2024 Joey Hess <id@joeyh.name>+ - Copyright 2010-2025 Joey Hess <id@joeyh.name>  -  - 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]
P2P/Annex.hs view
@@ -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 						)
P2P/Http/Server.hs view
@@ -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
P2P/Http/State.hs view
@@ -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)
Remote/External.hs view
@@ -1,6 +1,6 @@ {- External special remote interface.  -- - Copyright 2013-2024 Joey Hess <id@joeyh.name>+ - Copyright 2013-2025 Joey Hess <id@joeyh.name>  -  - 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
Remote/External/Types.hs view
@@ -1,6 +1,6 @@ {- External special remote data types.  -- - Copyright 2013-2024 Joey Hess <id@joeyh.name>+ - Copyright 2013-2025 Joey Hess <id@joeyh.name>  -  - 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
Remote/Git.hs view
@@ -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 							)
Remote/Helper/Ssh.hs view
@@ -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.
Remote/P2P.hs view
@@ -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
Remote/S3.hs view
@@ -1,6 +1,6 @@ {- S3 remotes  -- - Copyright 2011-2024 Joey Hess <id@joeyh.name>+ - Copyright 2011-2025 Joey Hess <id@joeyh.name>  -  - 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
RemoteDaemon/Transport/P2PGeneric.hs view
@@ -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 ()
Types/GitConfig.hs view
@@ -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"
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 10.20251114+Version: 10.20251215 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>
stack.yaml view
@@ -13,3 +13,5 @@ packages: - '.' resolver: lts-24.2+extra-deps:+- aws-0.25.2