git-annex 10.20250721 → 10.20250828

raw patch · 59 files changed

+1144/−695 lines, 59 filesdep ~aws

Dependency ranges changed: aws

Files

• Annex/AdjustedBranch.hs +19/−33
• Annex/ExternalAddonProcess.hs +41/−21
• Annex/Locations.hs +6/−0
• Annex/Proxy.hs +1/−0
• Annex/SpecialRemote.hs +14/−6
• Annex/SpecialRemote/Config.hs +3/−0
• Annex/YoutubeDl.hs +54/−86
• Backend/External.hs +1/−1
• Build/Configure.hs +1/−1
• CHANGELOG +42/−0
• COPYRIGHT +1/−1
• CmdLine/GitRemoteP2PAnnex.hs +62/−0
• CmdLine/GitRemoteTorAnnex.hs +8/−45
• CmdLine/Multicall.hs +3/−1
• Command/AddUrl.hs +2/−3
• Command/Adjust.hs +1/−2
• Command/EnableTor.hs +9/−5
• Command/Info.hs +44/−29
• Command/P2P.hs +24/−2
• Command/Smudge.hs +1/−10
• Creds.hs +15/−8
• Git/BuildVersion.hs +0/−21
• Git/CatFile.hs +4/−9
• Git/Merge.hs +4/−11
• P2P/Address.hs +25/−8
• P2P/Auth.hs +12/−6
• P2P/Generic.hs +66/−0
• P2P/Http/State.hs +2/−2
• P2P/IO.hs +40/−11
• Remote/Adb.hs +2/−2
• Remote/Bup.hs +2/−2
• Remote/Ddar.hs +2/−2
• Remote/Directory.hs +2/−2
• Remote/External.hs +3/−3
• Remote/GCrypt.hs +2/−2
• Remote/GitLFS.hs +1/−1
• Remote/Glacier.hs +1/−1
• Remote/Helper/AWS.hs +33/−12
• Remote/Helper/Encryptable.hs +57/−14
• Remote/Helper/Ssh.hs +1/−0
• Remote/Hook.hs +2/−2
• Remote/HttpAlso.hs +2/−2
• Remote/Mask.hs +2/−2
• Remote/Rsync.hs +2/−2
• Remote/S3.hs +58/−47
• Remote/Tahoe.hs +46/−6
• Remote/WebDAV.hs +1/−1
• RemoteDaemon/Transport.hs +8/−3
• RemoteDaemon/Transport/P2PGeneric.hs +237/−0
• RemoteDaemon/Transport/Tor.hs +16/−145
• Test.hs +100/−68
• Test/Framework.hs +41/−12
• Types/Crypto.hs +2/−1
• Upgrade/V5.hs +1/−30
• Utility/AuthToken.hs +6/−1
• Utility/Tor.hs +1/−1
• git-annex.cabal +5/−3
• git-annex.hs +2/−0
• stack.yaml +1/−6

@@ -37,8 +37,6 @@ 	preventCommits, 	AdjustedClone(..), 	checkAdjustedClone,-	checkVersionSupported,-	isGitVersionSupported, ) where  import Annex.Common@@ -58,7 +56,6 @@ import Git.Index import Git.FilePath import qualified Git.LockFile-import qualified Git.Version import Annex.CatFile import Annex.Link import Annex.Content.Presence@@ -366,7 +363,6 @@ adjustToCrippledFileSystem :: Annex () adjustToCrippledFileSystem = do 	warning "Entering an adjusted branch where files are unlocked as this filesystem does not support locked files."-	checkVersionSupported 	whenM (isNothing <$> inRepo Git.Branch.current) $ 		commitForAdjustedBranch [] 	inRepo Git.Branch.current >>= \case@@ -524,15 +520,12 @@ propigateAdjustedCommits' warnwhendiverged origbranch adj _commitsprevented = 	inRepo (Git.Ref.sha basis) >>= \case 		Just origsha -> catCommit currbranch >>= \case-			Just currcommit ->-				newcommits >>= go origsha origsha False >>= \case-					Left e -> do-						warning (UnquotedString e)-						return (Nothing, return ())-					Right newparent -> return-						( Just newparent-						, rebase currcommit newparent-						)+			Just currcommit -> do+				newparent <- newcommits >>= go origsha origsha False+				return+					( Just newparent+					, rebase currcommit newparent+					) 			Nothing -> return (Nothing, return ()) 		Nothing -> do 			warning $ UnquotedString $ @@ -553,16 +546,14 @@ 					warning $ UnquotedString $  						"Original branch " ++ fromRef origbranch ++ " has diverged from current adjusted branch " ++ fromRef currbranch 			_ -> inRepo $ Git.Branch.update' origbranch parent-		return (Right parent)+		return parent 	go origsha parent pastadjcommit (sha:l) = catCommit sha >>= \case 		Just c 			| hasAdjustedBranchCommitMessage c -> 				go origsha parent True l-			| pastadjcommit ->-				reverseAdjustedCommit parent adj (sha, c) origbranch-					>>= \case-						Left e -> return (Left e)-						Right commit -> go origsha commit pastadjcommit l+			| pastadjcommit -> do+				commit <- reverseAdjustedCommit parent adj (sha, c) origbranch+				go origsha commit pastadjcommit l 		_ -> go origsha parent pastadjcommit l 	rebase currcommit newparent = do 		-- Reuse the current adjusted tree, and reparent it@@ -582,10 +573,9 @@  - The commit message, and the author and committer metadata are  - copied over from the basiscommit. However, any gpg signature  - will be lost, and any other headers are not copied either. -}-reverseAdjustedCommit :: Sha -> Adjustment -> (Sha, Commit) -> OrigBranch -> Annex (Either String Sha)+reverseAdjustedCommit :: Sha -> Adjustment -> (Sha, Commit) -> OrigBranch -> Annex Sha reverseAdjustedCommit commitparent adj (csha, basiscommit) origbranch-	| length (commitParent basiscommit) > 1 = return $-		Left $ "unable to propagate merge commit " ++ show csha ++ " back to " ++ show origbranch+	| length (commitParent basiscommit) > 1 = giveup mergeerror 	| otherwise = do 		cmode <- annexCommitMode <$> Annex.getGitConfig 		treesha <- reverseAdjustedTree commitparent adj csha@@ -595,7 +585,13 @@ 				Git.Branch.commitTree cmode 					[commitMessage basiscommit] 					[commitparent] treesha-		return (Right revadjcommit)+		return revadjcommit+  where+	mergeerror = "Unable to propagate merge commit " ++ fromRef csha +++		" back to " ++ fromRef origbranch +++		" from this adjusted branch." +++		" To fix this, reset back to before the merge commit, " +++		" and use: git-annex merge <branch>"  {- Adjusts the tree of the basis, changing only the files that the  - commit changed, and reverse adjusting those changes.@@ -673,13 +669,3 @@ 						setBasisBranch basis p 					_ -> giveup $ "Unable to clean up from clone of adjusted branch; perhaps you should check out " ++ Git.Ref.describe origbranch 			return InAdjustedClone--checkVersionSupported :: Annex ()-checkVersionSupported =-	unlessM (liftIO isGitVersionSupported) $-		giveup "Your version of git is too old; upgrade it to 2.2.0 or newer to use adjusted branches."---- git 2.2.0 needed for GIT_COMMON_DIR which is needed--- by updateAdjustedBranch to use withWorkTreeRelated.-isGitVersionSupported :: IO Bool-isGitVersionSupported = not <$> Git.Version.older "2.2.0"

@@ -33,25 +33,57 @@ 	= ProgramNotInstalled String 	| ProgramFailure String -startExternalAddonProcess :: String -> [CommandParam] -> ExternalAddonPID -> Annex (Either ExternalAddonStartError ExternalAddonProcess)-startExternalAddonProcess basecmd ps pid = do+externalAddonStartErr :: Maybe OsPath -> String -> IO ExternalAddonStartError+externalAddonStartErr (Just cmd) _ =+		return $ ProgramFailure $+			"Cannot run " ++ fromOsPath cmd ++ " -- Make sure it's executable and that its dependencies are installed."+externalAddonStartErr Nothing basecmd = do+		path <- intercalate ":" . map fromOsPath <$> getSearchPath+		return $ ProgramNotInstalled $+			"Cannot run " ++ basecmd ++ " -- It is not installed in PATH (" ++ path ++ ")"++startExternalAddonProcess+	:: (CreateProcess -> CreateProcess)+	-> String+	-> [CommandParam]+	-> IO (Either ExternalAddonStartError (String, (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)))+startExternalAddonProcess f basecmd ps = do+	cmdpath <- searchPath basecmd+	startExternalAddonProcess' cmdpath f basecmd ps++startExternalAddonProcess'+	:: Maybe OsPath+	-> (CreateProcess -> CreateProcess)+	-> String+	-> [CommandParam]+	-> IO (Either ExternalAddonStartError (String, (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)))+startExternalAddonProcess' cmdpath mkproc basecmd ps = do+	(cmd, cmdps) <- maybe (pure (basecmd, [])) findShellCommand cmdpath+	let p = mkproc (proc cmd (toCommand (cmdps ++ ps)))+	tryNonAsync (createProcess p) >>= \case+		Right v -> return (Right (cmd, v))+		Left _ -> Left <$> externalAddonStartErr cmdpath basecmd++-- | Starts an external addon process that speaks a protocol over stdio.+startExternalAddonProcessProtocol :: String -> [CommandParam] -> ExternalAddonPID -> Annex (Either ExternalAddonStartError ExternalAddonProcess)+startExternalAddonProcessProtocol basecmd ps pid = do 	errrelayer <- mkStderrRelayer 	g <- Annex.gitRepo 	cmdpath <- liftIO $ searchPath basecmd 	liftIO $ start errrelayer g cmdpath   where 	start errrelayer g cmdpath = do-		(cmd, cmdps) <- maybe (pure (basecmd, [])) findShellCommand cmdpath-		let basep = (proc cmd (toCommand (cmdps ++ ps)))+		environ <- propGitEnv g+		let mkproc = \p -> p 			{ std_in = CreatePipe 			, std_out = CreatePipe 			, std_err = CreatePipe+			, env = Just environ 			}-		p <- propgit g basep-		tryNonAsync (createProcess p) >>= \case-			Right v -> (Right <$> started cmd errrelayer v)-				`catchNonAsync` const (runerr cmdpath)-			Left _ -> runerr cmdpath+		startExternalAddonProcess' cmdpath mkproc basecmd ps >>= \case+			Right (cmd, v) -> (Right <$> started cmd errrelayer v)+				`catchNonAsync` const (Left <$> externalAddonStartErr cmdpath basecmd)+			Left err -> return (Left err) 	 	started cmd errrelayer pall@(Just hin, Just hout, Just herr, ph) = do 		stderrelay <- async $ errrelayer ph herr@@ -78,18 +110,6 @@ 			, externalProgram = cmd 			} 	started _ _ _ = giveup "internal"--	propgit g p = do-		environ <- propGitEnv g-		return $ p { env = Just environ }--	runerr (Just cmd) =-		return $ Left $ ProgramFailure $-			"Cannot run " ++ fromOsPath cmd ++ " -- Make sure it's executable and that its dependencies are installed."-	runerr Nothing = do-		path <- intercalate ":" . map fromOsPath <$> getSearchPath-		return $ Left $ ProgramNotInstalled $-			"Cannot run " ++ basecmd ++ " -- It is not installed in PATH (" ++ path ++ ")"  protocolDebug :: ExternalAddonProcess -> Bool -> String -> IO () protocolDebug external sendto line = debug "Annex.ExternalAddonProcess" $ unwords

@@ -110,6 +110,7 @@ 	gitAnnexUrlFile, 	gitAnnexTmpCfgFile, 	gitAnnexSshDir,+	gitAnnexP2PDir, 	gitAnnexRemotesDir, 	gitAnnexAssistantDefaultDir, 	gitAnnexSimDir,@@ -715,6 +716,11 @@ gitAnnexSshDir :: Git.Repo -> OsPath gitAnnexSshDir r = addTrailingPathSeparator $ 	gitAnnexDir r </> literalOsPath "ssh"++{- .git/annex/p2p/ is used for p2p network sockets -}+gitAnnexP2PDir :: Git.Repo -> OsPath+gitAnnexP2PDir r = addTrailingPathSeparator $+	gitAnnexDir r </> literalOsPath "p2p"  {- .git/annex/remotes/ is used for remote-specific state. -} gitAnnexRemotesDir :: Git.Repo -> OsPath

@@ -90,6 +90,7 @@ 		, connCheckAuth = const False 		, connIhdl = P2PHandleTMVar ihdl (Just iwaitv) iclosedv 		, connOhdl = P2PHandleTMVar ohdl (Just owaitv) oclosedv+		, connProcess = Nothing 		, connIdent = ConnIdent (Just (Remote.name r)) 		} 	let closeremoteconn = do

@@ -96,12 +96,7 @@ 			Just (Sameas u') -> u' 			Nothing -> cu 		case (lookupName c, findType c) of-			-- Avoid auto-enabling when the name contains a-			-- control character, because git does not avoid-			-- displaying control characters in the name of a-			-- remote, and an attacker could leverage-			-- autoenabling it as part of an attack.-			(Just name, Right t) | safeOutput name == name -> do+			(Just name, Right t) -> checkcanenable u name $ do 				showSideAction $ UnquotedString $ "Auto enabling special remote " ++ name 				dummycfg <- liftIO dummyRemoteGitConfig 				tryNonAsync (setup t (AutoEnable c) (Just u) Nothing c dummycfg) >>= \case@@ -117,6 +112,19 @@ 	getcu r = fromMaybe 		(Remote.uuid r) 		(remoteAnnexConfigUUID (Remote.gitconfig r))+	checkcanenable u name cont+		-- Avoid auto-enabling when the name contains a control+		-- character, because git does not avoid displaying control+		-- characters in the name of a remote, and an attacker could+		-- leverage autoenabling it as part of an attack.+		| safeOutput name /= name = return ()+		| otherwise = do+			rs <- remoteList' False+			case filter (\rmt -> Remote.name rmt == name) rs of+				(rmt:_) | Remote.uuid rmt /= u -> warning $ +					UnquotedString $ "Cannot auto enable special remote " +						++ name ++ " because there is another remote with the same name."+				_ -> cont  autoEnableable :: Annex (M.Map UUID RemoteConfig) autoEnableable = do

@@ -85,6 +85,9 @@ embedCredsField :: RemoteConfigField embedCredsField = Accepted "embedcreds" +onlyEncryptCredsField :: RemoteConfigField+onlyEncryptCredsField = Accepted "onlyencryptcreds"+ preferreddirField :: RemoteConfigField preferreddirField = Accepted "preferreddir" 

@@ -1,6 +1,6 @@-{- yt-dlp (and deprecated youtube-dl) integration for git-annex+{- yt-dlp integration for git-annex  -- - Copyright 2017-2024 Joey Hess <id@joeyh.name>+ - Copyright 2017-2025 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -41,7 +41,7 @@ import GHC.Generics import qualified Data.ByteString.Char8 as B8 --- youtube-dl can follow redirects to anywhere, including potentially+-- yt-dlp can follow redirects to anywhere, including potentially -- localhost or a private address. So, it's only allowed to download -- content if the user has allowed access to all addresses. youtubeDlAllowed :: Annex Bool@@ -52,26 +52,21 @@ 	[ "This url is supported by yt-dlp, but" 	, "yt-dlp could potentially access any address, and the" 	, "configuration of annex.security.allowed-ip-addresses"-	, "does not allow that. Not using yt-dlp (or youtube-dl)."+	, "does not allow that. Not using yt-dlp." 	] --- Runs youtube-dl in a work directory, to download a single media file+-- Runs yt-dlp in a work directory, to download a single media file -- from the url. Returns the path to the media file in the work directory. ----- Displays a progress meter as youtube-dl downloads.+-- Displays a progress meter as yt-dlp downloads. ----- If no file is downloaded, or the program is not installed,--- returns Right Nothing.+-- If no file is downloaded, returns Right Nothing. ----- youtube-dl can write to multiple files, either temporary files, or+-- yt-dlp can write to multiple files, either temporary files, or -- multiple videos found at the url, and git-annex needs only one file. -- So we need to find the destination file, and make sure there is not -- more than one. With yt-dlp use --print-to-file to make it record the --- file(s) it downloads. With youtube-dl, the best that can be done is--- to require that the work directory end up with only 1 file in it.--- (This can fail, but youtube-dl is deprecated, and they closed my--- issue requesting something like --print-to-file; --- <https://github.com/rg3/youtube-dl/issues/14864>)+-- file(s) it downloads. youtubeDl :: URLString -> OsPath -> MeterUpdate -> Annex (Either String (Maybe OsPath)) youtubeDl url workdir p = ifM ipAddressesUnlimited 	( withUrlOptions Nothing $ youtubeDl' url workdir p@@ -80,52 +75,48 @@  youtubeDl' :: URLString -> OsPath -> MeterUpdate -> UrlOptions -> Annex (Either String (Maybe OsPath)) youtubeDl' url workdir p uo-	| supportedScheme uo url = do-		cmd <- youtubeDlCommand-		ifM (liftIO $ inSearchPath cmd)-			( runcmd cmd >>= \case-				Right True -> downloadedfiles cmd >>= \case+	| supportedScheme uo url =+		ifM (liftIO $ inSearchPath youtubeDlCommand)+			( runcmd >>= \case+				Right True -> downloadedfiles >>= \case 					(f:[]) -> return $  						Right (Just (toOsPath f))-					[] -> return (nofiles cmd)-					fs -> return (toomanyfiles cmd fs)+					[] -> return nofiles+					fs -> return (toomanyfiles fs) 				Right False -> workdirfiles >>= \case 					[] -> return (Right Nothing)-					_ -> return (Left $ cmd ++ " download is incomplete. Run the command again to resume.")+					_ -> return (Left $ youtubeDlCommand ++ " download is incomplete. Run the command again to resume.") 				Left msg -> return (Left msg)-			, return (Right Nothing)+			, return (Left $ youtubeDlCommand ++ " is not installed.") 			) 	| otherwise = return (Right Nothing)   where-	nofiles cmd = Left $ cmd ++ " did not put any media in its work directory, perhaps it's been configured to store files somewhere else?"-	toomanyfiles cmd fs = Left $ cmd ++ " downloaded multiple media files; git-annex is only able to deal with one per url: " ++ show fs-	downloadedfiles cmd-		| isytdlp cmd = liftIO $ -			(nub . lines <$> readFile (fromOsPath filelistfile))-				`catchIO` (pure . const [])-		| otherwise = map fromOsPath <$> workdirfiles+	nofiles = Left $ youtubeDlCommand ++ " did not put any media in its work directory, perhaps it's been configured to store files somewhere else?"+	toomanyfiles fs = Left $ youtubeDlCommand ++ " downloaded multiple media files; git-annex is only able to deal with one per url: " ++ show fs+	downloadedfiles = liftIO $ +		(nub . lines <$> readFile (fromOsPath filelistfile))+			`catchIO` (pure . const []) 	workdirfiles = liftIO $ filter (/= filelistfile)  		<$> (filterM doesFileExist =<< dirContents workdir) 	filelistfile = workdir </> filelistfilebase 	filelistfilebase = literalOsPath "git-annex-file-list-file"-	isytdlp cmd = cmd == "yt-dlp"-	runcmd cmd = youtubeDlMaxSize workdir >>= \case+	runcmd = youtubeDlMaxSize workdir >>= \case 		Left msg -> return (Left msg) 		Right maxsize -> do-			opts <- youtubeDlOpts (dlopts cmd ++ maxsize)+			opts <- youtubeDlOpts (dlopts ++ maxsize) 			oh <- mkOutputHandlerQuiet-			-- The size is unknown to start. Once youtube-dl+			-- The size is unknown to start. Once yt-dlp 			-- outputs some progress, the meter will be updated 			-- with the size, which is why it's important the 			-- meter is passed into commandMeter' 			let unknownsize = Nothing :: Maybe FileSize 			ok <- metered (Just p) unknownsize Nothing $ \meter meterupdate -> 				liftIO $ commandMeter'-					(if isytdlp cmd then parseYtdlpProgress else parseYoutubeDlProgress)-					oh (Just meter) meterupdate cmd opts+					parseYtdlpProgress+					oh (Just meter) meterupdate youtubeDlCommand opts 					(\pr -> pr { cwd = Just (fromOsPath workdir) }) 			return (Right ok)-	dlopts cmd = +	dlopts =  		[ Param url 		-- To make it only download one file when given a 		-- page with a video and a playlist, download only the video.@@ -135,22 +126,17 @@ 		-- somewhat stable, but this is the only way to prevent 		-- it from downloading the whole playlist.) 		, Param "--playlist-items", Param "0"-		] ++-			if isytdlp cmd-				then-					-- Avoid warnings, which go to-					-- stderr and may mess up-					-- git-annex's display.-					[ Param "--no-warnings"-					, Param "--progress-template"-					, Param progressTemplate-					, Param "--print-to-file"-					, Param "after_move:filepath"-					, Param (fromOsPath filelistfilebase)-					]-				else []+		-- Avoid warnings, which go to stderr and may+		-- mess up git-annex's display.+		, Param "--no-warnings"+		, Param "--progress-template"+		, Param progressTemplate+		, Param "--print-to-file"+		, Param "after_move:filepath"+		, Param (fromOsPath filelistfilebase)+		] --- To honor annex.diskreserve, ask youtube-dl to not download too+-- To honor annex.diskreserve, ask yt-dlp to not download too -- large a media file. Factors in other downloads that are in progress, -- and any files in the workdir that it may have partially downloaded -- before.@@ -189,22 +175,22 @@ 				return Nothing 	return (fromMaybe False res) --- youtube-dl supports downloading urls that are not html pages,+-- yt-dlp supports downloading urls that are not html pages, -- but we don't want to use it for such urls, since they can be downloaded -- without it. So, this first downloads part of the content and checks --- if it's a html page; only then is youtube-dl used.+-- if it's a html page; only then is yt-dlp used. htmlOnly :: URLString -> a -> Annex a -> Annex a htmlOnly url fallback a = withUrlOptions Nothing $ \uo ->  	liftIO (downloadPartial url uo htmlPrefixLength) >>= \case 		Just bs | isHtmlBs bs -> a 		_ -> return fallback --- Check if youtube-dl supports downloading content from an url.+-- Check if yt-dlp supports downloading content from an url. youtubeDlSupported :: URLString -> Annex Bool youtubeDlSupported url = either (const False) id 	<$> withUrlOptions Nothing (youtubeDlCheck' url) --- Check if youtube-dl can find media in an url.+-- Check if yt-dlp can find media in an url. -- -- While this does not download anything, it checks youtubeDlAllowed -- for symmetry with youtubeDl; the check should not succeed if the@@ -219,11 +205,10 @@ youtubeDlCheck' url uo 	| supportedScheme uo url = catchMsgIO $ htmlOnly url False $ do 		opts <- youtubeDlOpts [ Param url, Param "--simulate" ]-		cmd <- youtubeDlCommand-		liftIO $ snd <$> processTranscript cmd (toCommand opts) Nothing+		liftIO $ snd <$> processTranscript youtubeDlCommand (toCommand opts) Nothing 	| otherwise = return (Right False) --- Ask youtube-dl for the filename of media in an url.+-- Ask yt-dlp for the filename of media in an url. -- -- (This is not always identical to the filename it uses when downloading.) youtubeDlFileName :: URLString -> Annex (Either String OsPath)@@ -246,10 +231,11 @@ 	| otherwise = return nomedia   where 	go = do-		-- Sometimes youtube-dl will fail with an ugly backtrace+		-- Sometimes yt-dlp will fail with an ugly backtrace 		-- (eg, http://bugs.debian.org/874321) 		-- so catch stderr as well as stdout to avoid the user-		-- seeing it. --no-warnings avoids warning messages that+		-- seeing it. +		-- --no-warnings avoids warning messages that 		-- are output to stdout. 		opts <- youtubeDlOpts 			[ Param url@@ -257,8 +243,7 @@ 			, Param "--no-warnings" 			, Param "--no-playlist" 			]-		cmd <- youtubeDlCommand-		let p = (proc cmd (toCommand opts))+		let p = (proc youtubeDlCommand (toCommand opts)) 			{ std_out = CreatePipe 			, std_err = CreatePipe 			}@@ -285,22 +270,17 @@ 	opts <- map Param . annexYoutubeDlOptions <$> Annex.getGitConfig 	return (opts ++ addopts) -youtubeDlCommand :: Annex String-youtubeDlCommand = annexYoutubeDlCommand <$> Annex.getGitConfig >>= \case-	Just c -> pure c-	Nothing -> ifM (liftIO $ inSearchPath "yt-dlp")-		( return "yt-dlp"-		, return "youtube-dl"-		)+youtubeDlCommand :: String+youtubeDlCommand = "yt-dlp"  supportedScheme :: UrlOptions -> URLString -> Bool supportedScheme uo url = case parseURIRelaxed url of 	Nothing -> False 	Just u -> case uriScheme u of-		-- avoid ugly message from youtube-dl about not supporting file:+		-- avoid ugly message from yt-dlp about not supporting file: 		"file:" -> False 		-- ftp indexes may look like html pages, and there's no point-		-- involving youtube-dl in a ftp download+		-- involving yt-dlp in a ftp download 		"ftp:" -> False 		_ -> allowedScheme uo u @@ -336,27 +316,15 @@ 					_ -> go (remainder++x) xs 			_ -> go (remainder++x) xs -{- youtube-dl is deprecated, parsing its progress was attempted before but- - was buggy and is no longer done. -}-parseYoutubeDlProgress :: ProgressParser-parseYoutubeDlProgress _ = (Nothing, Nothing, "")- {- List the items that yt-dlp can download from an url.  -   - Note that this does not check youtubeDlAllowed because it does not  - download content.  -} youtubePlaylist :: URLString -> Annex (Either String [YoutubePlaylistItem])-youtubePlaylist url = do-	cmd <- youtubeDlCommand-	if cmd == "yt-dlp"-		then liftIO $ youtubePlaylist' url cmd-		else return $ Left $ "Scraping needs yt-dlp, but git-annex has been configured to use " ++ cmd--youtubePlaylist' :: URLString -> String -> IO (Either String [YoutubePlaylistItem])-youtubePlaylist' url cmd = withTmpFile (literalOsPath "yt-dlp") $ \tmpfile h -> do+youtubePlaylist url = liftIO $ withTmpFile (literalOsPath "yt-dlp") $ \tmpfile h -> do 	hClose h-	(outerr, ok) <- processTranscript cmd+	(outerr, ok) <- processTranscript youtubeDlCommand 		[ "--simulate" 		, "--flat-playlist" 		-- Skip live videos in progress

@@ -215,7 +215,7 @@ -- using it. newExternalState :: ExternalBackendName -> HasExt -> ExternalAddonPID -> Annex ExternalState newExternalState ebname hasext pid = do-	st <- startExternalAddonProcess basecmd [] pid+	st <- startExternalAddonProcessProtocol basecmd [] pid 	st' <- case st of 		Left (ProgramNotInstalled msg) -> warnonce msg >> return st 		Left (ProgramFailure msg) -> warnonce msg >> return st

@@ -81,7 +81,7 @@ 	go (Just s) = return $ Config "gitversion" $ StringConfig s 	go Nothing = do 		v <- Git.Version.installed-		let oldestallowed = Git.Version.normalize "2.1"+		let oldestallowed = Git.Version.normalize "2.22" 		when (v < oldestallowed) $ 			error $ "installed git version " ++ show v ++ " is too old! (Need " ++ show oldestallowed ++ " or newer)" 		return $ Config "gitversion" $ StringConfig $ show v

@@ -1,3 +1,45 @@+git-annex (10.20250828) upstream; urgency=medium++  * p2p: Added --enable option, which can be used to enable P2P networks+    provided by external commands git-annex-p2p-<netname>+  * Added git-remote-p2p-annex, which allows git pull and push to+    P2P networks provided by commands git-annex-p2p-<netname>+  * S3: Default to signature=v4 when using an AWS endpoint, since some+    AWS regions need v4 and all support it. When host= is used to specify+    a different S3 host, the default remains signature=v2.+  * webapp: Support setting up S3 buckets in regions that need v4+    signatures.+  * S3: When initremote is given the name of a bucket that already exists,+    automatically set datacenter to the right value, rather than needing it+    to be explicitly set.+  * info: Added --show option to pick which parts of the info to calculate+    and display.+  * Improve behavior when there are special remotes configured with+    autoenable=yes with names that conflict with other remotes.+  * adjust: When another branch has been manually merged into the adjusted+    branch, re-adjusting errors out, rather than losing that merge commit.+  * sync: When another branch has been manually merged into an adjusted+    branch, error out rather than only displaying a warning.+  * initremote: New onlyencryptcreds=yes which can be used along with+    embedcreds=yes, to only encrypt the embedded creds, without encrypting+    the content of the special remote. Useful for exporttree/importtree+    remotes.+  * Don't allow the type of encryption of an existing special remote to be+    changed. Fixes reversion introduced in version 7.20191230.+  * tahoe: Support tahoe-lafs command versions newer than 1.16.+  * tahoe: Fix bug that made initremote require an encryption= parameter,+    despite git-annex encryption not being used with this special remote.+    Fixes reversion introduced in version 7.20191230.+  * Improved error message when yt-dlp is not installed and is needed to+    get a file from the web.+  * The annex.youtube-dl-command git config is no longer used, git-annex+    always runs the yt-dlp command, rather than the old youtube-dl command.+  * Removed support for git versions older than 2.22.+  * Bump aws build dependency to 0.24.1.+  * stack.yaml: Update to lts-24.2.++ -- Joey Hess <id@joeyh.name>  Fri, 29 Aug 2025 11:42:37 -0400+ git-annex (10.20250721) upstream; urgency=medium    * Improved workaround for git 2.50 bug, avoding an occasional test suite

@@ -10,7 +10,7 @@            © 2014 Sören Brunk License: AGPL-3+ -Files: doc/special_remotes/external/* +Files: doc/special_remotes/external/* doc/special_remotes/p2p/git-annex-p2p-unix-sockets Copyright: © 2013 Joey Hess <id@joeyh.name> License: GPL-3+ 

@@ -0,0 +1,62 @@+{- git-remote-p2p-annex program+ -+ - Copyright 2016-2025 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module CmdLine.GitRemoteP2PAnnex where++import Common+import qualified Annex+import qualified Git.CurrentRepo+import P2P.Protocol+import P2P.IO+import Utility.AuthToken+import Annex.UUID+import P2P.Address+import P2P.Auth+import Annex.Action++run :: [String] -> IO ()+run = runner mkaddress+  where+	mkaddress address = +		fromMaybe (error $ "unable to parse address: " ++ address) $+			unformatP2PAddress (p2pAnnexScheme ++ ":" ++ address)++runner :: (String -> P2PAddress) -> [String] -> IO ()+runner mkaddress (_remotename:saddress:[]) = forever $+	getLine >>= \case+		"capabilities" -> putStrLn "connect" >> ready+		"connect git-upload-pack" -> go UploadPack+		"connect git-receive-pack" -> go ReceivePack+		l -> giveup $ "gitremote-helpers protocol error at " ++ show l+  where+	address = mkaddress saddress+	go service = do+		ready+		connectService address service >>= \case+			Right exitcode -> exitWith exitcode+			Left e -> giveup $ describeProtoFailure e+	ready = do+		putStrLn ""+		hFlush stdout	+runner _ (_remotename:[]) = giveup "remote address not configured"+runner _ _ = giveup "expected remote name and address parameters"++connectService :: P2PAddress -> Service -> IO (Either ProtoFailure ExitCode)+connectService address service = do+	state <- Annex.new =<< Git.CurrentRepo.get+	Annex.eval state $ do+		authtoken <- fromMaybe nullAuthToken+			<$> loadP2PRemoteAuthToken address+		myuuid <- getUUID+		g <- Annex.gitRepo+		conn <- liftIO $ connectPeer (Just g) address+		runst <- liftIO $ mkRunState Client+		r <- liftIO $ runNetProto runst conn $ auth myuuid authtoken noop >>= \case+			Just _theiruuid -> connect service stdin stdout+			Nothing -> giveup $ "authentication failed, perhaps you need to set " ++ p2pAuthTokenEnv+		quiesce False+		return r

@@ -8,40 +8,19 @@ module CmdLine.GitRemoteTorAnnex where  import Common-import qualified Annex-import qualified Git.CurrentRepo-import P2P.Protocol-import P2P.IO import Utility.Tor-import Utility.AuthToken-import Annex.UUID import P2P.Address-import P2P.Auth-import Annex.Action+import CmdLine.GitRemoteP2PAnnex (runner)  run :: [String] -> IO ()-run (_remotename:address:[]) = forever $-	getLine >>= \case-		"capabilities" -> putStrLn "connect" >> ready-		"connect git-upload-pack" -> go UploadPack-		"connect git-receive-pack" -> go ReceivePack-		l -> giveup $ "gitremote-helpers protocol error at " ++ show l+run = runner mkaddress   where-	(onionaddress, onionport)-		| '/' `elem` address = parseAddressPort $-			reverse $ takeWhile (/= '/') $ reverse address-		| otherwise = parseAddressPort address-	go service = do-		ready-		connectService onionaddress onionport service >>= \case-			Right exitcode -> exitWith exitcode-			Left e -> giveup $ describeProtoFailure e-	ready = do-		putStrLn ""-		hFlush stdout-		-run (_remotename:[]) = giveup "remote address not configured"-run _ = giveup "expected remote name and address parameters"+ 	mkaddress address =+		let (onionaddress, onionport)+			| '/' `elem` address = parseAddressPort $+				reverse $ takeWhile (/= '/') $ reverse address+			| otherwise = parseAddressPort address+		in TorAnnex onionaddress onionport  parseAddressPort :: String -> (OnionAddress, OnionPort) parseAddressPort s = @@ -49,19 +28,3 @@ 	in case readish sp of 		Nothing -> giveup "onion address must include port number" 		Just p -> (OnionAddress a, p)--connectService :: OnionAddress -> OnionPort -> Service -> IO (Either ProtoFailure ExitCode)-connectService address port service = do-	state <- Annex.new =<< Git.CurrentRepo.get-	Annex.eval state $ do-		authtoken <- fromMaybe nullAuthToken-			<$> loadP2PRemoteAuthToken (TorAnnex address port)-		myuuid <- getUUID-		g <- Annex.gitRepo-		conn <- liftIO $ connectPeer (Just g) (TorAnnex address port)-		runst <- liftIO $ mkRunState Client-		r <- liftIO $ runNetProto runst conn $ auth myuuid authtoken noop >>= \case-			Just _theiruuid -> connect service stdin stdout-			Nothing -> giveup $ "authentication failed, perhaps you need to set " ++ p2pAuthTokenEnv-		quiesce False-		return r

@@ -1,6 +1,6 @@ {- git-annex multicall binary  -- - Copyright 2024 Joey Hess <id@joeyh.name>+ - Copyright 2024-2025 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -17,12 +17,14 @@ data OtherMultiCallCommand 	= GitAnnexShell 	| GitRemoteAnnex+	| GitRemoteP2PAnnex 	| GitRemoteTorAnnex  otherMulticallCommands :: M.Map String OtherMultiCallCommand otherMulticallCommands = M.fromList 	[ ("git-annex-shell", GitAnnexShell) 	, ("git-remote-annex", GitRemoteAnnex)+	, ("git-remote-p2p-annex", GitRemoteP2PAnnex) 	, ("git-remote-tor-annex", GitRemoteTorAnnex) 	] 

@@ -376,8 +376,7 @@ 	  where 		dl dest = withTmpWorkDir mediakey $ \workdir -> do 			let cleanuptmp = pruneTmpWorkDirBefore tmp (liftIO . removeWhenExistsWith removeFile)-			dlcmd <- youtubeDlCommand-			showNote ("using " <> UnquotedString dlcmd)+			showNote ("using " <> UnquotedString youtubeDlCommand) 			Transfer.notifyTransfer Transfer.Download url $ 				Transfer.download' webUUID mediakey (AssociatedFile Nothing) Nothing Transfer.noRetry $ \p -> do 					showDestinationFile dest@@ -393,7 +392,7 @@ 							return Nothing 						Right Nothing -> do 							cleanuptmp-							warning (UnquotedString dlcmd <> " did not download anything")+							warning (UnquotedString youtubeDlCommand <> " did not download anything") 							return Nothing 		mediaurl = setDownloader url YoutubeDownloader 		mediakey = Backend.URL.fromUrl mediaurl Nothing (verifiableOption o)

@@ -69,7 +69,6 @@ seek = commandAction . start  start :: Adjustment -> CommandStart-start adj = do-	checkVersionSupported+start adj =  	starting "adjust" (ActionItemOther Nothing) (SeekInput []) $ 		next $ enterAdjustedBranch adj

@@ -38,11 +38,11 @@ 		"uid" (withParams seek)  seek :: CmdParams -> CommandSeek-seek = withWords (commandAction . start)+seek = withWords (commandAction . start . Just)  -- This runs as root, so avoid making any commits or initializing -- git-annex, or doing other things that create root-owned files.-start :: [String] -> CommandStart+start :: Maybe [String] -> CommandStart #ifndef mingw32_HOST_OS start os = do #else@@ -53,9 +53,11 @@ 	let si = SeekInput [] 	curruserid <- liftIO getEffectiveUserID 	if curruserid == 0-		then case readish =<< headMaybe os of-			Nothing -> giveup "Need user-id parameter."-			Just userid -> go userid+		then case os of+			Just os' -> case readish =<< headMaybe os' of+				Nothing -> giveup "Need user-id parameter."+				Just userid -> go userid+			Nothing -> giveup "Cannot run this command as root." 		else starting "enable-tor" ai si $ do 			gitannex <- fromOsPath <$> liftIO programPath 			let ps = [Param (cmdname cmd), Param (show curruserid)]@@ -102,6 +104,7 @@ 	go _ = check (150 :: Int) =<< filter istoraddr <$> loadP2PAddresses 	 	istoraddr (TorAnnex _ _) = True+	istoraddr _ = False  	check 0 _ = giveup "Still unable to connect to hidden service. It might not yet be usable by others. Please check Tor's logs for details." 	check _ [] = giveup "Somehow didn't get an onion address."@@ -137,6 +140,7 @@ 			, connCheckAuth = const False 			, connIhdl = P2PHandle h 			, connOhdl = P2PHandle h+			, connProcess = Nothing 			, connIdent = ConnIdent Nothing 			} 		runst <- mkRunState Client

@@ -1,6 +1,6 @@ {- git-annex command  -- - 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.  -}@@ -55,7 +55,10 @@ import qualified Utility.RawFilePath as R  -- a named computation that produces a statistic-type Stat = StatState (Maybe (String, StatState String))+data Stat = Stat+	{ statDesc :: String+	, statComp :: StatState (Maybe (StatState String))+	}  -- data about a set of keys data KeyInfo = KeyInfo@@ -116,6 +119,7 @@ 	, batchOption :: BatchMode 	, autoenableOption :: Bool 	, deadrepositoriesOption :: Bool+	, showOption :: [String] 	}  optParser :: CmdParamsDesc -> Parser InfoOptions@@ -134,6 +138,10 @@ 		( long "dead-repositories" 		<> help "list repositories that have been marked as dead" 		)+	<*> many (strOption+		( long "show" <> metavar paramName+		<> help "limit info output"+		))  seek :: InfoOptions -> CommandSeek seek o = case batchOption o of@@ -158,7 +166,7 @@ 	u <- getUUID 	whenM ((==) DeadTrusted <$> lookupTrust u) $ 		earlyWarning "Warning: This repository is currently marked as dead."-	stats <- selStats global_fast_stats global_slow_stats+	stats <- selStats o global_fast_stats global_slow_stats 	showCustom "info" (SeekInput []) $ do 		evalStateT (mapM_ showStat stats) (emptyStatInfo o) 		return True@@ -211,7 +219,7 @@  dirInfo :: InfoOptions -> FilePath -> SeekInput -> Annex () dirInfo o dir si = showCustom (unwords ["info", dir]) si $ do-	stats <- selStats+	stats <- selStats o 		(tostats (dir_name:tree_fast_stats True)) 		(tostats tree_slow_stats) 	evalStateT (mapM_ showStat stats) =<< getDirStatInfo o dir@@ -226,7 +234,7 @@ 		Nothing -> noInfo t si 			"not a directory or an annexed file or a treeish or a remote or a uuid" 		Just i -> showCustom (unwords ["info", t]) si $ do-			stats <- selStats +			stats <- selStats o 				(tostats (tree_name:tree_fast_stats False))  				(tostats tree_slow_stats) 			evalStateT (mapM_ showStat stats) i@@ -247,7 +255,7 @@ remoteInfo o r si = showCustom (unwords ["info", Remote.name r]) si $ do 	i <- map (\(k, v) -> simpleStat k (pure v)) <$> Remote.getInfo r 	let u = Remote.uuid r-	l <- selStats +	l <- selStats o 		(uuid_fast_stats u ++ remote_fast_stats r ++ i) 		(uuid_slow_stats u) 	evalStateT (mapM_ showStat l) (emptyStatInfo o)@@ -255,16 +263,21 @@  uuidInfo :: InfoOptions -> UUID -> SeekInput -> Annex () uuidInfo o u si = showCustom (unwords ["info", fromUUID u]) si $ do-	l <- selStats (uuid_fast_stats u) (uuid_slow_stats u)+	l <- selStats o (uuid_fast_stats u) (uuid_slow_stats u) 	evalStateT (mapM_ showStat l) (emptyStatInfo o) 	return True -selStats :: [Stat] -> [Stat] -> Annex [Stat]-selStats fast_stats slow_stats = do-	fast <- Annex.getRead Annex.fast-	return $ if fast-		then fast_stats-		else fast_stats ++ slow_stats+selStats :: InfoOptions -> [Stat] -> [Stat] -> Annex [Stat]+selStats o fast_stats slow_stats+	| null (showOption o) = do+		fast <- Annex.getRead Annex.fast+		return $ if fast+			then fast_stats+			else fast_stats ++ slow_stats+	| otherwise = return $+		let wanted = S.fromList (showOption o)+		in filter (\s -> S.member (statDesc s) wanted)+			(fast_stats ++ slow_stats)  {- Order is significant. Less expensive operations, and operations  - that share data go together.@@ -337,14 +350,14 @@ 	]  stat :: String -> (String -> StatState String) -> Stat-stat desc a = return $ Just (desc, a desc)+stat desc a = Stat desc $ return $ Just $ a desc  -- The json simply contains the same string that is displayed. simpleStat :: String -> StatState String -> Stat simpleStat desc getval = stat desc $ json id getval -nostat :: Stat-nostat = return Nothing+nostat :: String -> Stat+nostat desc = Stat desc $ return Nothing  json :: ToJSON' j => (j -> String) -> StatState j -> String -> StatState String json fmt a desc = do@@ -356,10 +369,10 @@ nojson a _ = a  showStat :: Stat -> StatState ()-showStat s = maybe noop calc =<< s+showStat s = maybe noop calc =<< statComp s   where-	calc (desc, a) = do-		(lift . showHeader . encodeBS) desc+	calc a = do+		(lift . showHeader . encodeBS) (statDesc s) 		lift . showRaw . encodeBS =<< a  repo_list :: TrustLevel -> Stat@@ -557,15 +570,16 @@  reposizes_stats_tree :: Stat reposizes_stats_tree = reposizes_stats True "repositories containing these files"-	=<< cachedRepoData+	cachedRepoData  reposizes_stats_global :: Stat reposizes_stats_global = reposizes_stats False "annex sizes of repositories" -	. repoData =<< cachedAllRepoData+	(repoData <$> cachedAllRepoData) -reposizes_stats :: Bool -> String -> M.Map UUID KeyInfo -> Stat-reposizes_stats count desc m = stat desc $ nojson $ do+reposizes_stats :: Bool -> String -> StatState (M.Map UUID KeyInfo) -> Stat+reposizes_stats count desc getm = stat desc $ nojson $ do 	sizer <- mkSizer+	m <- getm 	let l = map (\(u, kd) -> (u, sizer storageUnits True (sizeKeys kd))) $ 		sortBy (flip (comparing (sizeKeys . snd))) $ 		M.toList m@@ -818,15 +832,16 @@ 			" unknown size"  staleSize :: String -> (Git.Repo -> OsPath) -> Stat-staleSize label dirspec = go =<< lift (dirKeys dirspec)+staleSize label dirspec = Stat label $ do+	keys <- lift $ dirKeys dirspec	+	onsize =<< sum <$> keysizes keys   where-	go [] = nostat-	go keys = onsize =<< sum <$> keysizes keys-	onsize 0 = nostat-	onsize size = stat label $-		json (++ aside "clean up with git-annex unused") $ do+	onsize 0 = return Nothing+	onsize size = return $ Just $+		let val = do 			sizer <- mkSizer 			return $ sizer storageUnits False size+		in json (++ aside "clean up with git-annex unused") val label 	keysizes keys = do 		dir <- lift $ fromRepo dirspec 		liftIO $ forM keys $ \k -> 

@@ -1,6 +1,6 @@ {- git-annex command  -- - Copyright 2016 Joey Hess <id@joeyh.name>+ - Copyright 2016-2025 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -13,6 +13,7 @@ import P2P.Address import P2P.Auth import P2P.IO+import P2P.Generic import qualified P2P.Protocol as P2P import Git.Types import qualified Git.Remote@@ -27,6 +28,7 @@ import Utility.SafeOutput import qualified Utility.FileIO as F import qualified Utility.MagicWormhole as Wormhole+import qualified Command.EnableTor as EnableTor  import Control.Concurrent.Async import qualified Data.Text as T@@ -40,10 +42,11 @@ 	= GenAddresses 	| LinkRemote 	| Pair+	| Enable P2PNetName  optParser :: CmdParamsDesc -> Parser (P2POpts, Maybe RemoteName) optParser _ = (,)-	<$> (pair <|> linkremote <|> genaddresses)+	<$> (pair <|> linkremote <|> genaddresses <|> enable) 	<*> optional name   where 	genaddresses = flag' GenAddresses@@ -58,6 +61,10 @@ 		( long "pair" 		<> help "pair with another repository" 		)+	enable = Enable . P2PNetName <$> strOption+                ( long "enable" <> metavar paramName+                <> help "enable using a P2P network"+                ) 	name = Git.Remote.makeLegalName <$> strOption 		( long "name" 		<> metavar paramName@@ -75,6 +82,8 @@ seek (Pair, Nothing) = commandAction $ do 	name <- unusedPeerRemoteName 	startPairing name =<< loadP2PAddresses+seek (Enable netname, _) = commandAction $+	enableNetwork netname  unusedPeerRemoteName :: Annex RemoteName unusedPeerRemoteName = go (1 :: Integer) =<< usednames@@ -316,3 +325,16 @@ 		return LinkSuccess 	go (Right Nothing) = return $ AuthenticationError "Unable to authenticate with peer. Please check the address and try again." 	go (Left e) = return $ AuthenticationError $ "Unable to authenticate with peer: " ++ describeProtoFailure e++enableNetwork :: P2PNetName -> CommandStart+enableNetwork netname@(P2PNetName name)+	| name == "tor" = EnableTor.start Nothing+	| otherwise = starting "p2p enable" ai si $ next $ do+		addrs <- liftIO $ getAddressGenericP2P netname+		when (null addrs) $+			giveup $ genericP2PCommand netname ++ " did not output any P2P addresses" +		mapM_ storeP2PAddress addrs+		return True+  where+	ai = ActionItemOther (Just (UnquotedString name))+	si = SeekInput []

@@ -19,7 +19,6 @@ import Logs.Smudge import Logs.Location import qualified Database.Keys-import qualified Git.BuildVersion import Git.FilePath import Git.Types import Git.HashObject@@ -97,15 +96,7 @@ 	Annex.BranchState.disableUpdate -- optimisation 	b <- liftIO $ L.hGetContents stdin 	let passthrough = liftIO $ L.hPut stdout b-	-- Before git 2.5, failing to consume all stdin here would-	-- cause a SIGPIPE and crash it.-	-- Newer git catches the signal and stops sending, which is-	-- much faster. (Also, git seems to forget to free memory-	-- when sending the file, so the less we let it send, the-	-- less memory it will waste.)-	let discardreststdin = if Git.BuildVersion.older "2.5"-		then L.length b `seq` return ()-		else liftIO $ hClose stdin+	let discardreststdin = liftIO $ hClose stdin 	let emitpointer = liftIO . S.hPut stdout . formatPointer 	clean' file (parseLinkTargetOrPointerLazy' b) 		passthrough

@@ -33,7 +33,7 @@ import Utility.FileMode import Crypto import Types.ProposedAccepted-import Remote.Helper.Encryptable (remoteCipher, remoteCipher', embedCreds, EncryptionIsSetup, extractCipher)+import Remote.Helper.Encryptable (remoteCipher, remoteCipher', CipherPurpose(..), embedCreds, EncryptionIsSetup, extractCipher) import Utility.Env (getEnv) import Utility.Base64 import qualified Utility.FileIO as F@@ -95,14 +95,19 @@   where 	localcache creds = writeCacheCredPair creds storage -	storeconfig creds key (Just cipher) = do+	storeconfig creds key (Just (CipherAllPurpose cipher)) = +		storeconfigcipher creds key cipher+	storeconfig creds key (Just (CipherOnlyCreds cipher)) = +		storeconfigcipher creds key cipher+	storeconfig creds key Nothing =+		storeconfig' key (Accepted (decodeBS $ toB64 $ encodeBS $ encodeCredPair creds))+	+	storeconfigcipher creds key cipher = do 		cmd <- gpgCmd <$> Annex.getGitConfig 		s <- liftIO $ encrypt cmd (pc, gc) cipher 			(feedBytes $ L8.pack $ encodeCredPair creds) 			(readBytesStrictly return) 		storeconfig' key (Accepted (decodeBS (toB64 s)))-	storeconfig creds key Nothing =-		storeconfig' key (Accepted (decodeBS $ toB64 $ encodeBS $ encodeCredPair creds)) 	 	storeconfig' key val = return $ pc 		{ parsedRemoteConfigMap = M.insert key (RemoteConfigValue val) (parsedRemoteConfigMap pc)@@ -127,14 +132,16 @@ 			<|> getRemoteConfigValue key c			 		case (getval, mcipher) of 			(Nothing, _) -> return Nothing-			(Just enccreds, Just (cipher, storablecipher)) ->-				fromenccreds (encodeBS enccreds) cipher storablecipher+			(Just enccreds, Just ((CipherAllPurpose cipher, storablecipher))) ->+				fromenccreds enccreds cipher storablecipher+			(Just enccreds, Just ((CipherOnlyCreds cipher, storablecipher))) ->+				fromenccreds enccreds cipher storablecipher 			(Just bcreds, Nothing) -> 				fromcreds $ decodeBS $ fromB64 $ encodeBS bcreds 	fromenccreds enccreds cipher storablecipher = do 		cmd <- gpgCmd <$> Annex.getGitConfig 		mcreds <- liftIO $ catchMaybeIO $ decrypt cmd (c, gc) cipher-			(feedBytes $ L8.fromStrict $ fromB64 enccreds)+			(feedBytes $ L8.fromStrict $ fromB64 $ encodeBS enccreds) 			(readBytesStrictly $ return . S8.unpack) 		case mcreds of 			Just creds -> fromcreds creds@@ -145,7 +152,7 @@ 				case storablecipher of 					SharedCipher {} -> showLongNote "gpg error above was caused by an old git-annex bug in credentials storage. Working around it.." 					_ -> giveup "*** Insecure credentials storage detected for this remote! See https://git-annex.branchable.com/upgrades/insecure_embedded_creds/"-				fromcreds $ decodeBS $ fromB64 enccreds+				fromcreds $ decodeBS $ fromB64 $ encodeBS enccreds 	fromcreds creds = case decodeCredPair creds of 		Just credpair -> do 			writeCacheCredPair credpair storage

@@ -1,21 +0,0 @@-{- git build version- -- - Copyright 2011 Joey Hess <id@joeyh.name>- -- - Licensed under the GNU AGPL version 3 or higher.- -}--module Git.BuildVersion where--import Git.Version-import qualified BuildInfo--{- Using the version it was configured for avoids running git to check its- - version, at the cost that upgrading git won't be noticed.- - This is only acceptable because it's rare that git's version influences- - code's behavior. -}-buildVersion :: GitVersion-buildVersion = normalize BuildInfo.gitversion--older :: String -> Bool-older n = buildVersion < normalize n 

@@ -54,7 +54,6 @@ import Git.HashObject import qualified Git.LsTree as LsTree import qualified Utility.CoProcess as CoProcess-import qualified Git.BuildVersion as BuildVersion import Utility.Tuple  data CatFileHandle = CatFileHandle @@ -403,14 +402,10 @@ withCatFileStream check repo reader = assertLocal repo $ 	bracketIO start stop $ \(c, hin, hout, _) -> reader c hin hout   where-	params = catMaybes-		[ Just $ Param "cat-file"-		, Just $ Param ("--batch" ++ (if check then "-check" else "") ++ "=" ++ batchFormat)-		-- This option makes it faster, but is not present in-		-- older versions of git.-		, if BuildVersion.older "2.4.3"-			then Nothing-			else Just $ Param "--buffer"+	params =+		[ Param "cat-file"+		, Param ("--batch" ++ (if check then "-check" else "") ++ "=" ++ batchFormat)+		, Param "--buffer" -- makes it faster 		]  	start = do

@@ -17,7 +17,6 @@ import Common import Git import Git.Command-import qualified Git.Version import Git.Branch (CommitMode(..))  data MergeConfig@@ -50,20 +49,14 @@  merge'' :: [CommandParam] -> [MergeConfig] -> Repo -> IO Bool merge'' ps mergeconfig r-	| MergeUnrelatedHistories `elem` mergeconfig = do-		up <- mergeUnrelatedHistoriesParam-		go (ps ++ maybeToList up)+	| MergeUnrelatedHistories `elem` mergeconfig =+		go (ps ++ [mergeUnrelatedHistoriesParam]) 	| otherwise = go ps   where 	go ps' = runBool ps' r -{- Git used to default to merging unrelated histories; newer versions need- - an option. -}-mergeUnrelatedHistoriesParam :: IO (Maybe CommandParam)-mergeUnrelatedHistoriesParam = ifM (Git.Version.older "2.9.0")-	( return Nothing-	, return (Just (Param "--allow-unrelated-histories"))-	)+mergeUnrelatedHistoriesParam :: CommandParam+mergeUnrelatedHistoriesParam = Param "--allow-unrelated-histories"  {- Stage the merge into the index, but do not commit it.-} stageMerge :: Ref -> [MergeConfig] -> Repo -> IO Bool

@@ -1,6 +1,6 @@ {- P2P protocol addresses  -- - Copyright 2016 Joey Hess <id@joeyh.name>+ - Copyright 2016-2025 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -25,9 +25,17 @@ -- -- This is enough information to connect to the peer, -- but not enough to authenticate with it.-data P2PAddress = TorAnnex OnionAddress OnionPort-	deriving (Eq, Show)+data P2PAddress+	= TorAnnex OnionAddress OnionPort+	| P2PAnnex P2PNetName UnderlyingP2PAddress+	deriving (Eq, Show, Ord) +newtype P2PNetName = P2PNetName String+	deriving (Eq, Show, Ord)++newtype UnderlyingP2PAddress = UnderlyingP2PAddress String+	deriving (Eq, Show, Ord)+ -- | A P2P address, with an AuthToken. -- -- This is enough information to connect to the peer, and authenticate with@@ -42,16 +50,25 @@ instance FormatP2PAddress P2PAddress where 	formatP2PAddress (TorAnnex (OnionAddress onionaddr) onionport) = 		torAnnexScheme ++ ":" ++ onionaddr ++ ":" ++ show onionport+	formatP2PAddress (P2PAnnex (P2PNetName netname) (UnderlyingP2PAddress address)) =+		p2pAnnexScheme ++ ":" ++ netname ++ ":" ++ address 	unformatP2PAddress s-		| (torAnnexScheme ++ ":") `isPrefixOf` s = do-			let s' = dropWhile (== ':') $ dropWhile (/= ':') s-			let (onionaddr, ps) = separate (== ':') s'-			onionport <- readish ps-			return (TorAnnex (OnionAddress onionaddr) onionport)+		| schemeprefixed torAnnexScheme = do+			onionport <- readish bs+			return (TorAnnex (OnionAddress as) onionport)+		| schemeprefixed p2pAnnexScheme =+			return (P2PAnnex (P2PNetName as) (UnderlyingP2PAddress bs)) 		| otherwise = Nothing+	  where+		schemeprefixed scheme = (scheme ++ ":") `isPrefixOf` s+		(as, bs) = separate (== ':') $+			dropWhile (== ':') $ dropWhile (/= ':') s  torAnnexScheme :: String torAnnexScheme = "tor-annex:"++p2pAnnexScheme :: String+p2pAnnexScheme = "p2p-annex:"  instance FormatP2PAddress P2PAddressAuth where 	formatP2PAddress (P2PAddressAuth addr authtoken) =

@@ -16,6 +16,8 @@ import Utility.Tor import Utility.Env +import Network.URI+import Data.Char import qualified Data.Text as T  -- | Load authtokens that are accepted by this repository for tor.@@ -55,7 +57,7 @@   where 	v = case addr of 		TorAnnex _ _ -> (t, Nothing)-		-- _ -> (t, Just addr)+		_ -> (t, Just addr) 	 	fmt (tok, Nothing) = T.unpack (fromAuthToken tok)   	fmt (tok, Just addr') = T.unpack (fromAuthToken tok) @@ -86,9 +88,13 @@ 	(T.unpack $ fromAuthToken t) 	(addressCredsFile addr) +-- | Unusual characters in the address are url encoded. addressCredsFile :: P2PAddress -> OsPath--- We can omit the port and just use the onion address for the creds file,--- because any given tor hidden service runs on a single port and has a--- unique onion address.-addressCredsFile (TorAnnex (OnionAddress onionaddr) _port) =-	toOsPath onionaddr+addressCredsFile addr = toOsPath $ escapeURIString isAlphaNum $ case addr of+	-- We can omit the port and just use the onion address for the+	-- creds file, because any given tor hidden service runs on a+	-- single port and has a unique onion address.+	TorAnnex (OnionAddress onionaddr) _port ->+		onionaddr+	P2PAnnex (P2PNetName netname) (UnderlyingP2PAddress address) ->+		netname ++ ":" ++ address

@@ -0,0 +1,66 @@+{- P2P protocol, generic transports.+ -+ - See doc/design/generic_p2p_transport.mdwn+ -+ - Copyright 2025 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module P2P.Generic where++import Common+import P2P.Address+import Annex.ExternalAddonProcess++genericP2PCommand :: P2PNetName -> String+genericP2PCommand (P2PNetName netname) = "git-annex-p2p-" ++ netname++connectGenericP2P :: P2PNetName -> UnderlyingP2PAddress -> IO (Handle, Handle, ProcessHandle)+connectGenericP2P netname (UnderlyingP2PAddress address) =+	startExternalAddonProcess+		(\p -> p +			{ std_in = CreatePipe+			, std_out = CreatePipe+			})+		(genericP2PCommand netname) [Param address]+		>>= \case+			Right (_, (Just hin, Just hout, Nothing, pid)) ->+				return (hin, hout, pid)+			Right _ -> giveup "internal"+			Left (ProgramNotInstalled msg) -> giveup msg+			Left (ProgramFailure msg) -> giveup msg++socketGenericP2P :: P2PNetName -> UnderlyingP2PAddress -> OsPath -> IO ProcessHandle+socketGenericP2P netname (UnderlyingP2PAddress address) socketfile = do+	startExternalAddonProcess id+		(genericP2PCommand netname) [Param address, File (fromOsPath socketfile)]+		>>= \case+			Right (_, (Nothing, Nothing, Nothing, pid)) ->+				return pid+			Right _ -> giveup "internal"+			Left (ProgramNotInstalled msg) -> giveup msg+			Left (ProgramFailure msg) -> giveup msg++getAddressGenericP2P :: P2PNetName -> IO [P2PAddress]+getAddressGenericP2P netname =+	startExternalAddonProcess+		(\p -> p { std_out = CreatePipe })+		(genericP2PCommand netname) [Param "address"]+		>>= \case+			Right (_, (Nothing, Just hin, Nothing, pid)) ->+				go [] hin pid+			Right _ -> giveup "internal"+			Left (ProgramNotInstalled msg) -> giveup msg+			Left (ProgramFailure msg) -> giveup msg+  where+	go addrs hin pid = hGetLineUntilExitOrEOF pid hin >>= \case+		Just l+			| not (null l) -> +				let addr = P2PAnnex netname (UnderlyingP2PAddress l)+				in go (addr:addrs) hin pid+			| otherwise -> go addrs hin pid+		Nothing -> do+			waitForProcess pid >>= \case+				ExitSuccess -> return addrs+				ExitFailure _ -> giveup $ genericP2PCommand netname ++ " failed"

@@ -406,10 +406,10 @@ 		(if connectionWaitVar connparams then Just wait2 else Nothing) 		closed2 	let clientconn = P2PConnection Nothing-		(const True) h2 h1+		(const True) h2 h1 Nothing 		(ConnIdent (Just n1)) 	let serverconn = P2PConnection Nothing-		(const True) h1 h2+		(const True) h1 h2 Nothing 		(ConnIdent (Just n2)) 	return (clientconn, serverconn) 

@@ -1,6 +1,6 @@ {- P2P protocol, IO implementation  -- - Copyright 2016-2024 Joey Hess <id@joeyh.name>+ - Copyright 2016-2025 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -20,7 +20,8 @@ 	, connectPeer 	, closeConnection 	, serveUnixSocket-	, setupHandle+	, serveUnixSocket'+	, listenUnixSocket 	, ProtoFailure(..) 	, describeProtoFailure 	, runNetProto@@ -31,6 +32,7 @@ import Common import P2P.Protocol import P2P.Address+import P2P.Generic import Git import Git.Command import Utility.AuthToken@@ -97,6 +99,7 @@ 	, connCheckAuth :: (AuthToken -> Bool) 	, connIhdl :: P2PHandle 	, connOhdl :: P2PHandle+	, connProcess :: Maybe ProcessHandle 	, connIdent :: ConnIdent 	} @@ -115,6 +118,7 @@ 	, connCheckAuth = const False 	, connIhdl = P2PHandle stdin 	, connOhdl = P2PHandle stdout+	, connProcess = Nothing 	, connIdent = ConnIdent Nothing 	} @@ -129,25 +133,41 @@ 		, connCheckAuth = const False 		, connIhdl = P2PHandle readh 		, connOhdl = P2PHandle writeh+		, connProcess = Nothing 		, connIdent = ConnIdent Nothing 		}  -- Opens a connection to a peer. Does not authenticate with it. connectPeer :: Maybe Git.Repo -> P2PAddress -> IO P2PConnection connectPeer g (TorAnnex onionaddress onionport) = do-	h <- setupHandle =<< connectHiddenService onionaddress onionport+	h <- setupHandleFromSocket =<< connectHiddenService onionaddress onionport 	return $ P2PConnection 		{ connRepo = g 		, connCheckAuth = const False 		, connIhdl = P2PHandle h 		, connOhdl = P2PHandle h+		, connProcess = Nothing 		, connIdent = ConnIdent Nothing 		}+connectPeer g (P2PAnnex netname address) = do+	(hin, hout, pid) <- connectGenericP2P netname address+	return $ P2PConnection+		{ connRepo = g+		, connCheckAuth = const False+		, connIhdl = P2PHandle hout+		, connOhdl = P2PHandle hin+		, connProcess = Just pid+		, connIdent = ConnIdent Nothing+		}  closeConnection :: P2PConnection -> IO () closeConnection conn = do-	closehandle (connIhdl conn)-	closehandle (connOhdl conn)+	-- hClose can fail if the handle is connected to a broken pipe+	void $ tryNonAsync $ closehandle (connIhdl conn)+	void $ tryNonAsync $ closehandle (connOhdl conn)+	case connProcess conn of+		Nothing -> noop+		Just ph -> void $ waitForProcess ph   where 	closehandle (P2PHandle h) = hClose h 	closehandle (P2PHandleTMVar _ _ closedv) = @@ -163,6 +183,17 @@ -- the callback. serveUnixSocket :: OsPath -> (Handle -> IO ()) -> IO () serveUnixSocket unixsocket serveconn = do+	sock <- listenUnixSocket unixsocket+	serveUnixSocket' sock serveconn++serveUnixSocket' :: S.Socket -> (Handle -> IO ()) -> IO ()+serveUnixSocket' soc serveconn =+	forever $ do+		(conn, _) <- S.accept soc+		setupHandleFromSocket conn >>= serveconn++listenUnixSocket :: OsPath -> IO S.Socket+listenUnixSocket unixsocket = do 	removeWhenExistsWith removeFile unixsocket 	soc <- S.socket S.AF_UNIX S.Stream S.defaultProtocol 	S.bind soc (S.SockAddrUnix (fromOsPath unixsocket))@@ -176,12 +207,10 @@ 	modifyFileMode unixsocket $ addModes 		[groupReadMode, groupWriteMode, otherReadMode, otherWriteMode] 	S.listen soc 2-	forever $ do-		(conn, _) <- S.accept soc-		setupHandle conn >>= serveconn+	return soc -setupHandle :: Socket -> IO Handle-setupHandle s = do+setupHandleFromSocket :: Socket -> IO Handle+setupHandleFromSocket s = do 	h <- socketToHandle s ReadWriteMode 	hSetBuffering h LineBuffering 	hSetBinaryMode h False@@ -320,7 +349,7 @@ 		]   where 	safem = case m of-		AUTH u _ -> AUTH u nullAuthToken+		AUTH u _ -> AUTH u displayAuthToken 		_ -> m 	ConnIdent mident = connIdent conn 

@@ -140,7 +140,7 @@ 		(remoteAnnexAndroidSerial gc)  adbSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)-adbSetup _ mu _ c gc = do+adbSetup ss mu _ c gc = do 	u <- maybe (liftIO genUUID) return mu  	-- verify configuration@@ -151,7 +151,7 @@ 	serial <- getserial =<< enumerateAdbConnected 	let c' = M.insert androidserialField (Proposed (fromAndroidSerial serial)) c -	(c'', _encsetup) <- encryptionSetup c' gc+	(c'', _encsetup) <- encryptionSetup ss c' gc  	ok <- adbShellBool serial 		[Param "mkdir", Param "-p", File (fromAndroidPath adir)]

@@ -124,13 +124,13 @@ 	buprepo = fromMaybe (giveup "missing buprepo") $ remoteAnnexBupRepo gc  bupSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)-bupSetup _ mu _ c gc = do+bupSetup ss mu _ c gc = do 	u <- maybe (liftIO genUUID) return mu  	-- verify configuration is sane 	let buprepo = maybe (giveup "Specify buprepo=") fromProposedAccepted $ 		M.lookup buprepoField c-	(c', _encsetup) <- encryptionSetup c gc+	(c', _encsetup) <- encryptionSetup ss c gc  	-- bup init will create the repository. 	-- (If the repository already exists, bup init again appears safe.)

@@ -115,13 +115,13 @@ 	ddarrepo = maybe (giveup "missing ddarrepo") (DdarRepo gc) (remoteAnnexDdarRepo gc)  ddarSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)-ddarSetup _ mu _ c gc = do+ddarSetup ss mu _ c gc = do 	u <- maybe (liftIO genUUID) return mu  	-- verify configuration is sane 	let ddarrepo = maybe (giveup "Specify ddarrepo=") fromProposedAccepted $ 		M.lookup ddarrepoField c-	(c', _encsetup) <- encryptionSetup c gc+	(c', _encsetup) <- encryptionSetup ss c gc  	-- The ddarrepo is stored in git config, as well as this repo's 	-- persistent state, so it can vary between hosts.

@@ -151,7 +151,7 @@ 		(remoteAnnexDirectory gc)  directorySetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)-directorySetup _ mu _ c gc = do+directorySetup ss mu _ c gc = do 	u <- maybe (liftIO genUUID) return mu 	-- verify configuration is sane 	let dir = maybe (giveup "Specify directory=") fromProposedAccepted $@@ -159,7 +159,7 @@ 	absdir <- liftIO $ absPath (toOsPath dir) 	liftIO $ unlessM (doesDirectoryExist absdir) $ 		giveup $ "Directory does not exist: " ++ fromOsPath absdir-	(c', _encsetup) <- encryptionSetup c gc+	(c', _encsetup) <- encryptionSetup ss c gc  	-- The directory is stored in git config, not in this remote's 	-- persistent state, so it can vary between hosts.

@@ -172,7 +172,7 @@ 				(remoteAnnexExternalType gc)  externalSetup :: Maybe ExternalProgram -> Maybe (String, String) -> SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)-externalSetup externalprogram setgitconfig _ mu _ c gc = do+externalSetup externalprogram setgitconfig ss mu _ c gc = do 	u <- maybe (liftIO genUUID) return mu 	pc <- either giveup return $ parseRemoteConfig c (lenientRemoteConfigParser externalprogram) 	let readonlyconfig = getRemoteConfigValue readonlyField pc == Just True@@ -180,7 +180,7 @@ 		then "readonly" 		else fromMaybe (giveup "Specify externaltype=") $ 			getRemoteConfigValue externaltypeField pc-	(c', _encsetup) <- encryptionSetup c gc+	(c', _encsetup) <- encryptionSetup ss c gc  	c'' <- if readonlyconfig 		then do@@ -673,7 +673,7 @@ 		n <- succ <$> readTVar (externalLastPid external) 		writeTVar (externalLastPid external) n 		return n-	AddonProcess.startExternalAddonProcess externalcmd externalparams pid >>= \case+	AddonProcess.startExternalAddonProcessProtocol externalcmd externalparams pid >>= \case 		Left (AddonProcess.ProgramFailure err) -> do 			unusable err 		Left (AddonProcess.ProgramNotInstalled err) ->

@@ -220,12 +220,12 @@ unsupportedUrl = giveup "unsupported repo url for gcrypt"  gCryptSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)-gCryptSetup _ mu _ c gc = go $ fromProposedAccepted <$> M.lookup gitRepoField c+gCryptSetup ss mu _ c gc = go $ fromProposedAccepted <$> M.lookup gitRepoField c   where 	remotename = fromJust (lookupName c) 	go Nothing = giveup "Specify gitrepo=" 	go (Just gitrepo) = do-		(c', _encsetup) <- encryptionSetup c gc+		(c', _encsetup) <- encryptionSetup ss c gc  		let url = Git.GCrypt.urlPrefix ++ gitrepo 		rs <- Annex.getGitRemotes

@@ -148,7 +148,7 @@ mySetup ss mu _ c gc = do 	u <- maybe (liftIO genUUID) return mu -	(c', _encsetup) <- encryptionSetup c gc+	(c', _encsetup) <- encryptionSetup ss c gc 	pc <- either giveup return . parseRemoteConfig c' =<< configParser remote c' 	let failinitunlessforced msg = case ss of 		Init -> unlessM (Annex.getRead Annex.force) (giveup msg)

@@ -124,7 +124,7 @@ 	glacierSetup' ss u mcreds c gc glacierSetup' :: SetupStage -> UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) glacierSetup' ss u mcreds c gc = do-	(c', encsetup) <- encryptionSetup (c `M.union` defaults) gc+	(c', encsetup) <- encryptionSetup ss (c `M.union` defaults) gc 	pc <- either giveup return . parseRemoteConfig c' 		=<< configParser remote c' 	c'' <- setRemoteCredPair ss encsetup pc gc (AWS.creds u) mcreds

@@ -1,6 +1,6 @@ {- Amazon Web Services common infrastructure.  -- - Copyright 2011-2014 Joey Hess <id@joeyh.name>+ - Copyright 2011-2025 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -40,7 +40,8 @@ regionMap = M.fromList . regionInfo  defaultRegion :: Service -> Region-defaultRegion = snd . fromMaybe (error "internal") . headMaybe . regionInfo+defaultRegion S3 = "US"+defaultRegion Glacier = "us-east-1"  data ServiceRegion = BothRegion Region | S3Region Region | GlacierRegion Region @@ -52,20 +53,40 @@ 	concatMap (\(t, l) -> map (t,) l) regions   where 	regions =-		[ ("US East (N. Virginia)", [S3Region "US", GlacierRegion "us-east-1"])-		, ("US West (Oregon)", [BothRegion "us-west-2"])+		-- Based on the list at https://docs.aws.amazon.com/general/latest/gr/s3.html+		[ ("US East (Ohio)", [S3Region "us-east-2"])+		, ("US East (N. Virginia)", [S3Region "US", GlacierRegion "us-east-1"]) 		, ("US West (N. California)", [BothRegion "us-west-1"])-		, ("EU (Ireland)", [S3Region "EU", GlacierRegion "eu-west-1"])+		, ("US West (Oregon)", [BothRegion "us-west-2"])+		, ("Africa (Cape Town)", [S3Region "af-south-1"])+		, ("Asia Pacific (Hong Kong)", [S3Region "ap-east-1"])+		, ("Asia Pacific (Hyderabad)", [S3Region "ap-south-2"])+		, ("Asia Pacific (Jakarta)", [S3Region "ap-southeast-3"])+		, ("Asia Pacific (Malaysia)", [S3Region "ap-southeast-5"])+		, ("Asia Pacific (Melbourne)", [S3Region "ap-southeast-4"])+		, ("Asia Pacific (Mumbai)", [S3Region "ap-south-1"])+		, ("Asia Pacific (Osaka)", [S3Region "ap-northeast-3"])+		, ("Asia Pacific (Seoul)", [S3Region "ap-northeast-2"]) 		, ("Asia Pacific (Singapore)", [S3Region "ap-southeast-1"])-		, ("Asia Pacific (Tokyo)", [BothRegion "ap-northeast-1"]) 		, ("Asia Pacific (Sydney)", [S3Region "ap-southeast-2"])+		, ("Asia Pacific (Taipei)", [S3Region "ap-east-2"])+		, ("Asia Pacific (Thailand)", [S3Region "ap-southeast-7"])+		, ("Asia Pacific (Tokyo)", [BothRegion "ap-northeast-1"])+		, ("Canada (Central)", [S3Region "ca-central-1"])+		, ("Canada West (Calgary)", [S3Region "ca-west-1"])+		, ("EU (Frankfurt)", [BothRegion "eu-central-1"])+		, ("EU (Ireland)", [S3Region "EU", GlacierRegion "eu-west-1"])+		, ("Europe (London)", [S3Region "eu-west-2"])+		, ("Europe (Milan)", [S3Region "eu-south-1"])+		, ("Europe (Paris)", [S3Region "eu-west-3"])+		, ("Europe (Spain)", [S3Region "eu-south-2"])+		, ("Europe (Stockholm)", [S3Region "eu-north-1"])+		, ("Europe (Zurich)", [S3Region "eu-central-2"])+		, ("Israel (Tel Aviv)", [S3Region "il-central-1"])+		, ("Mexico (Central)", [S3Region "mx-central-1"])+		, ("Middle East (Bahrain)", [S3Region "me-south-1"])+		, ("Middle East (UAE)", [S3Region "me-central-1"]) 		, ("South America (São Paulo)", [S3Region "sa-east-1"])-		-- These need signature V4 to be used, and currently v2 is-		-- the default, so to add these would need other changes.-		-- , ("EU (Frankfurt)", [BothRegion "eu-central-1"])-		-- , ("Asia Pacific (Seoul)", [S3Region "ap-northeast-2"])-		-- , ("Asia Pacific (Mumbai)", [S3Region "ap-south-1"])-		-- , ("US East (Ohio)", [S3Region "us-east-2"]) 		]  	fromServiceRegion (BothRegion s) = s

@@ -1,6 +1,6 @@ {- common functions for encryptable remotes  -- - Copyright 2011-2021 Joey Hess <id@joeyh.name>+ - Copyright 2011-2025 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -15,6 +15,7 @@ 	encryptionConfigParsers, 	parseEncryptionConfig, 	parseEncryptionMethod,+	CipherPurpose(..), 	remoteCipher, 	remoteCipher', 	embedCreds,@@ -63,6 +64,8 @@ 	, optionalStringParser pubkeysField HiddenField 	, yesNoParser embedCredsField Nothing 		(FieldDesc "embed credentials into git repository")+	, yesNoParser onlyEncryptCredsField Nothing+		(FieldDesc "only encrypt embedded credentials, not annexed files") 	, macFieldParser 	, optionalStringParser (Accepted "keyid") 		(FieldDesc "gpg key id")@@ -160,9 +163,14 @@  - an encryption key, or not encrypt. An encrypted cipher is created, or is  - updated to be accessible to an additional encryption key. Or the user  - could opt to use a shared cipher, which is stored unencrypted. -}-encryptionSetup :: RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, EncryptionIsSetup)-encryptionSetup c gc = do+encryptionSetup :: SetupStage -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, EncryptionIsSetup)+encryptionSetup setupstage c gc = do 	pc <- either giveup return $ parseEncryptionConfig c+	when (onlyEncryptCreds pc && encryption == Right SharedEncryption) $+		giveup "There is no security benefit to using onlyencryptcreds=yes with encryption=shared"+	when (onlyEncryptCreds pc && encryption == Right NoneEncryption) $+		giveup "There is no security benefit to using onlyencryptcreds=yes with encryption=none"+	checkallowedchange pc 	gpgcmd <- gpgCmd <$> Annex.getGitConfig 	maybe (genCipher pc gpgcmd) (updateCipher pc gpgcmd) (extractCipher pc)   where@@ -216,13 +224,33 @@ 		-- public-key encryption, hence we leave it on newer 		-- remotes (while being backward-compatible). 		(map Accepted ["keyid", "keyid+", "keyid-", "highRandomQuality"])+	moldpc = either (const Nothing) Just $ parseEncryptionConfig $+		case setupstage of+			Init -> mempty+			Enable oldc -> oldc+			AutoEnable oldc -> oldc+	checkallowedchange pc = case moldpc of+		Nothing -> return ()+		Just oldpc -> do+			case extractCipher oldpc of+				Nothing -> req NoneEncryption+				Just (EncryptedCipher _ Hybrid _) -> req HybridEncryption+				Just (EncryptedCipher _ PubKey _) -> req PubKeyEncryption+				Just (SharedCipher _) -> req SharedEncryption+				Just (SharedPubKeyCipher _ _) -> req SharedPubKeyEncryption+			when (onlyEncryptCreds oldpc /= onlyEncryptCreds pc) $+				giveup "Cannot change onlyencryptcreds of existing remotes."+	  where+		req v = when (encryption /= Right v) cannotchange -remoteCipher :: ParsedRemoteConfig -> RemoteGitConfig -> Annex (Maybe Cipher)-remoteCipher c gc = fmap fst <$> remoteCipher' c gc+data CipherPurpose t = CipherAllPurpose t | CipherOnlyCreds t  {- Gets encryption Cipher. The decrypted Ciphers are cached in the Annex  - state. -}-remoteCipher' :: ParsedRemoteConfig -> RemoteGitConfig -> Annex (Maybe (Cipher, StorableCipher))+remoteCipher :: ParsedRemoteConfig -> RemoteGitConfig -> Annex (Maybe (CipherPurpose Cipher))+remoteCipher c gc = fmap fst <$> remoteCipher' c gc++remoteCipher' :: ParsedRemoteConfig -> RemoteGitConfig -> Annex (Maybe (CipherPurpose Cipher, StorableCipher)) remoteCipher' c gc = case extractCipher c of 	Nothing -> return Nothing 	Just encipher -> do@@ -230,7 +258,7 @@ 		cachedciper <- liftIO $ atomically $  			M.lookup encipher <$> readTMVar cachev 		case cachedciper of-			Just cipher -> return $ Just (cipher, encipher)+			Just cipher -> return $ Just (purpose cipher, encipher) 			-- Not cached; decrypt it, making sure 			-- to only decrypt one at a time. Avoids 			-- prompting for decrypting the same thing twice@@ -245,7 +273,10 @@ 		cipher <- liftIO $ decryptCipher gpgcmd (c, gc) encipher 		liftIO $ atomically $ putTMVar cachev $ 			M.insert encipher cipher cache-		return $ Just (cipher, encipher)+		return $ Just (purpose cipher, encipher)+	purpose+		| onlyEncryptCreds c = CipherOnlyCreds+		| otherwise = CipherAllPurpose  {- Checks if the remote's config allows storing creds in the remote's config.  - @@ -262,11 +293,19 @@ 		(Just (_ :: String), Just (_ :: String)) -> True 		_ -> False -{- Gets encryption Cipher, and key encryptor. -}+onlyEncryptCreds :: ParsedRemoteConfig -> Bool+onlyEncryptCreds c = case getRemoteConfigValue onlyEncryptCredsField c of+	Just v -> v+	Nothing -> False++{- Gets key data encryption Cipher, and key encryptor. -} cipherKey :: ParsedRemoteConfig -> RemoteGitConfig -> Annex (Maybe (Cipher, EncKey))-cipherKey c gc = fmap make <$> remoteCipher c gc+cipherKey c gc = go <$> remoteCipher c gc   where-	make ciphertext = (ciphertext, encryptKey mac ciphertext)+	go (Just (CipherAllPurpose ciphertext)) = +		Just (ciphertext, encryptKey mac ciphertext)+	go (Just (CipherOnlyCreds _)) = Nothing+	go Nothing = Nothing 	mac = fromMaybe defaultMac $ getRemoteConfigValue macField c  {- Stores an StorableCipher in a remote's configuration. -}@@ -297,7 +336,7 @@ 	readkeys = KeyIds . splitc ','  isEncrypted :: ParsedRemoteConfig -> Bool-isEncrypted = isJust . extractCipher+isEncrypted c = isJust (extractCipher c) && not (onlyEncryptCreds c)  -- Check if encryption is enabled. This can be done before encryption -- is fully set up yet, so the cipher might not be present yet.@@ -305,12 +344,16 @@ encryptionIsEnabled c = case getRemoteConfigValue encryptionField c of 	Nothing -> False 	Just NoneEncryption -> False-	Just _ -> True+	Just _ -> not (onlyEncryptCreds c)  describeEncryption :: ParsedRemoteConfig -> String describeEncryption c = case extractCipher c of 	Nothing -> "none"-	Just cip -> nameCipher cip ++ " (" ++ describeCipher cip ++ ")"+	Just cip+		| onlyEncryptCreds c -> "creds only; " ++ desc cip+		| otherwise -> desc cip+  where+	desc cip = nameCipher cip ++ " (" ++ describeCipher cip ++ ")"  nameCipher :: StorableCipher -> String nameCipher (SharedCipher _) = "shared"

@@ -270,6 +270,7 @@ 			, P2P.connCheckAuth = const False 			, P2P.connIhdl = P2P.P2PHandle to 			, P2P.connOhdl = P2P.P2PHandle from+			, P2P.connProcess = Nothing 			, P2P.connIdent = P2P.ConnIdent $ 				Just $ "git-annex-shell connection " ++ show pidnum 			}

@@ -97,11 +97,11 @@ 	hooktype = fromMaybe (giveup "missing hooktype") $ remoteAnnexHookType gc  hookSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)-hookSetup _ mu _ c gc = do+hookSetup ss mu _ c gc = do 	u <- maybe (liftIO genUUID) return mu 	let hooktype = maybe (giveup "Specify hooktype=") fromProposedAccepted $ 		M.lookup hooktypeField c-	(c', _encsetup) <- encryptionSetup c gc+	(c', _encsetup) <- encryptionSetup ss c gc 	gitConfigSpecialRemote u c' [("hooktype", hooktype)] 	return (c', u) 

@@ -111,12 +111,12 @@ httpAlsoSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) httpAlsoSetup _ Nothing _ _ _ = 	giveup "Must use --sameas when initializing a httpalso remote."-httpAlsoSetup _ (Just u) _ c gc = do+httpAlsoSetup ss (Just u) _ c gc = do 	_url <- maybe (giveup "Specify url=") 		(return . fromProposedAccepted) 		(M.lookup urlField c) 	c' <- if isJust (M.lookup encryptionField c)-		then fst <$> encryptionSetup c gc+		then fst <$> encryptionSetup ss c gc 		else pure c 	gitConfigSpecialRemote u c' [("httpalso", "true")] 	return (c', u)

@@ -116,7 +116,7 @@ 	setupremote r = do 		let c' = M.insert remoteUUIDField 			(Proposed (fromUUID (uuid r) :: String)) c-		(c'', encsetup) <- encryptionSetup c' gc+		(c'', encsetup) <- encryptionSetup setupstage c' gc 		verifyencryptionok encsetup r 		 		u <- maybe (liftIO genUUID) return mu@@ -137,7 +137,7 @@ 				-- get autoenabled later, or need to be 				-- manually enabled. 				_ -> do-					(c', _) <- encryptionSetup c gc+					(c', _) <- encryptionSetup setupstage c gc 					u <- maybe (liftIO genUUID) return mu 					gitConfigSpecialRemote u c' [ ("mask", "true") ] 					return (c', u)

@@ -200,12 +200,12 @@ 	fromNull as xs = if null xs then as else xs  rsyncSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)-rsyncSetup _ mu _ c gc = do+rsyncSetup ss mu _ c gc = do 	u <- maybe (liftIO genUUID) return mu 	-- verify configuration is sane 	let url = maybe (giveup "Specify rsyncurl=") fromProposedAccepted $ 		M.lookup rsyncUrlField c-	(c', _encsetup) <- encryptionSetup c gc+	(c', _encsetup) <- encryptionSetup ss c gc  	-- The rsyncurl is stored in git config, not only in this remote's 	-- persistent state, so it can vary between hosts.

@@ -163,20 +163,19 @@  data SignatureVersion  	= SignatureVersion Int+	| DefaultSignatureVersion 	| Anonymous  signatureVersionParser :: RemoteConfigField -> FieldDesc -> RemoteConfigFieldParser signatureVersionParser f fd =-	genParser go f (Just defver) fd-		(Just (ValueDesc "v2 or v4"))+	genParser go f (Just DefaultSignatureVersion) fd+		(Just (ValueDesc "v2 or v4 or anonymous"))   where 	go "v2" = Just (SignatureVersion 2) 	go "v4" = Just (SignatureVersion 4) 	go "anonymous" = Just Anonymous 	go _ = Nothing -	defver = SignatureVersion 2- isAnonymous :: ParsedRemoteConfig -> Bool isAnonymous c =  	case getRemoteConfigValue signatureField c of@@ -194,15 +193,15 @@ 	c <- parsedRemoteConfig remote rc 	cst <- remoteCost gc c expensiveRemoteCost 	info <- extractS3Info c-	hdl <- mkS3HandleVar c gc u+	hdl <- mkS3HandleVar False c gc u 	magic <- liftIO initMagicMime 	return $ new c cst info hdl magic   where 	new c cst info hdl magic = Just $ specialRemote c 		(store hdl this info magic)-		(retrieve hdl this rs c info)+		(retrieve hdl rs c info) 		(remove hdl this info)-		(checkKey hdl this rs c info)+		(checkKey hdl rs c info) 		this 	  where 		this = Remote@@ -283,12 +282,22 @@ 		return (fullconfig, u)  	defaulthost = do-		(c', encsetup) <- encryptionSetup (c `M.union` defaults) gc+		(c', encsetup) <- encryptionSetup ss (c `M.union` defaults) gc 		pc <- either giveup return . parseRemoteConfig c' 			=<< configParser remote c' 		c'' <- if isAnonymous pc 			then pure c'-			else setRemoteCredPair ss encsetup pc gc (AWS.creds u) mcreds+			else do+				v <- setRemoteCredPair ss encsetup pc gc (AWS.creds u) mcreds+				if M.member datacenterField c || M.member regionField c+					then return v+					-- Check if a bucket with this name+					-- already exists, and if so, use+					-- that location, rather than the+					-- default datacenterField.+					else getBucketLocation pc gc u >>= return . \case+						Nothing -> v+						Just loc -> M.insert datacenterField (Proposed $ T.unpack loc) v 		pc' <- either giveup return . parseRemoteConfig c'' 			=<< configParser remote c'' 		info <- extractS3Info pc'@@ -323,7 +332,7 @@ 			=<< configParser remote archiveconfig 		info <- extractS3Info pc' 		checkexportimportsafe pc' info-		hdl <- mkS3HandleVar pc' gc u+		hdl <- mkS3HandleVar False pc' gc u 		withS3HandleOrFail u hdl $ 			writeUUIDFile pc' u info 		use archiveconfig pc' info@@ -414,8 +423,8 @@ {- 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 -> Remote -> RemoteStateHandle -> ParsedRemoteConfig -> S3Info -> Retriever-retrieve hv r rs c info = fileRetriever' $ \f k p iv -> withS3Handle hv $ \case+retrieve :: S3HandleVar -> RemoteStateHandle -> ParsedRemoteConfig -> S3Info -> Retriever+retrieve 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@@ -429,7 +438,6 @@ 				giveup "cannot download content" 			Right us -> unlessM (withUrlOptions Nothing $ downloadUrl False k p iv us f) $ 				giveup "failed to download content"-	Left S3HandleAnonymousOldAws -> giveupS3HandleProblem S3HandleAnonymousOldAws (uuid r)  retrieveHelper :: S3Info -> S3Handle -> (Either S3.Object S3VersionID) -> OsPath -> MeterUpdate -> Maybe IncrementalVerifier -> Annex () retrieveHelper info h loc f p iv = retrieveHelper' h f p iv $@@ -456,14 +464,14 @@ 	-- beyond a sanity check that the content is in fact present. 	| versioning info = Just $ \k callback -> do 		checkVersioning info rs k-		ifM (checkKey hv r rs c info k)+		ifM (checkKey hv rs c info k) 			( withVerifiedCopy LockedCopy (uuid r) (return (Right True)) callback 			, giveup $ "content seems to be missing from " ++ name r ++ " despite S3 versioning being enabled" 			) 	| otherwise = Nothing -checkKey :: S3HandleVar -> Remote -> RemoteStateHandle -> ParsedRemoteConfig -> S3Info -> CheckPresent-checkKey hv r rs c info k = withS3Handle hv $ \case+checkKey :: S3HandleVar -> RemoteStateHandle -> ParsedRemoteConfig -> S3Info -> CheckPresent+checkKey hv rs c info k = withS3Handle hv $ \case 	Right h -> eitherS3VersionID info rs c k (T.pack $ bucketObject info k) >>= \case 		Left failreason -> do 			warning (UnquotedString failreason)@@ -478,7 +486,6 @@ 				let check u = withUrlOptions Nothing $  					Url.checkBoth u (fromKey keySize k) 				anyM check us-	Left S3HandleAnonymousOldAws -> giveupS3HandleProblem S3HandleAnonymousOldAws (uuid r)  checkKeyHelper :: S3Info -> S3Handle -> (Either S3.Object S3VersionID) -> Annex Bool checkKeyHelper info h loc = checkKeyHelper' info h o limit@@ -519,7 +526,6 @@ 				withUrlOptions Nothing 					(Url.download' p iv (geturl exportloc) f) 			Nothing -> giveup $ needS3Creds (uuid r)-		Left S3HandleAnonymousOldAws -> giveupS3HandleProblem S3HandleAnonymousOldAws (uuid r)   where 	exportloc = bucketExportLocation info loc @@ -540,7 +546,6 @@ 		Just geturl -> withUrlOptions Nothing $ 			Url.checkBoth (geturl $ bucketExportLocation info loc) (fromKey keySize k) 		Nothing -> giveupS3HandleProblem S3HandleNeedCreds (uuid r)-	Left S3HandleAnonymousOldAws -> giveupS3HandleProblem S3HandleAnonymousOldAws (uuid r)  -- S3 has no move primitive; copy and delete. renameExportS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe ())@@ -776,6 +781,18 @@   where 	o = T.pack $ bucketExportLocation info loc +getBucketLocation :: ParsedRemoteConfig -> RemoteGitConfig -> UUID -> Annex (Maybe S3.LocationConstraint)+getBucketLocation c gc u = do+	info <- extractS3Info c+	let info' = info { region = Nothing, host = Nothing }+	-- Force anonymous access, because this API call does not work+	-- when used in an authenticated context.+	hdl <- mkS3HandleVar True c gc u+	withS3HandleOrFail u hdl $ \h -> do+		r <- liftIO $ tryNonAsync $ runResourceT $+			sendS3Handle h (S3.getBucketLocation $ bucket info')+		return $ either (const Nothing) (Just . S3.gblrLocationConstraint) r+ {- Generate the bucket if it does not already exist, including creating the  - UUID file within the bucket.  -@@ -787,7 +804,7 @@ genBucket c gc u = do 	showAction "checking bucket" 	info <- extractS3Info c-	hdl <- mkS3HandleVar c gc u+	hdl <- mkS3HandleVar False c gc u 	withS3HandleOrFail u hdl $ \h -> 		go info h =<< checkUUIDFile c u info h   where@@ -884,28 +901,19 @@  type S3HandleVar = TVar (Either (Annex (Either S3HandleProblem S3Handle)) (Either S3HandleProblem S3Handle)) -data S3HandleProblem-	= S3HandleNeedCreds-	| S3HandleAnonymousOldAws+data S3HandleProblem = S3HandleNeedCreds  giveupS3HandleProblem :: S3HandleProblem -> UUID -> Annex a giveupS3HandleProblem S3HandleNeedCreds u = do 	warning $ UnquotedString $ needS3Creds u 	giveup "No S3 credentials configured"-giveupS3HandleProblem S3HandleAnonymousOldAws _ =-	giveup "This S3 special remote is configured with signature=anonymous, but git-annex is built with too old a version of the aws library to support that."  {- Prepares a S3Handle for later use. Does not connect to S3 or do anything  - else expensive. -}-mkS3HandleVar :: ParsedRemoteConfig -> RemoteGitConfig -> UUID -> Annex S3HandleVar-mkS3HandleVar c gc u = liftIO $ newTVarIO $ Left $-	if isAnonymous c-		then -#if MIN_VERSION_aws(0,23,0)-			go =<< liftIO AWS.anonymousCredentials-#else-			return (Left S3HandleAnonymousOldAws)-#endif+mkS3HandleVar :: Bool -> ParsedRemoteConfig -> RemoteGitConfig -> UUID -> Annex S3HandleVar+mkS3HandleVar forceanonymous c gc u = liftIO $ newTVarIO $ Left $+	if forceanonymous || isAnonymous c+		then go =<< liftIO AWS.anonymousCredentials 		else do 			mcreds <- getRemoteCredPair c gc (AWS.creds u) 			case mcreds of@@ -984,18 +992,23 @@ 		Nothing 			| port == 443 -> AWS.HTTPS 			| otherwise -> AWS.HTTP-	cfg = case getRemoteConfigValue signatureField c of-		Just (SignatureVersion 4) -> -			(S3.s3v4 proto endpoint False S3.SignWithEffort)-#if MIN_VERSION_aws(0,24,0)-				{ S3.s3Region = r }-#endif-		_ -> (S3.s3 proto endpoint False)-#if MIN_VERSION_aws(0,24,0)-				{ S3.s3Region = r }+	cfg = if usev4 $ getRemoteConfigValue signatureField c+		then (S3.s3v4 proto endpoint False S3.SignWithEffort)+			{ S3.s3Region = r }+		else (S3.s3 proto endpoint False)+			{ S3.s3Region = r } 	+	-- Use signature v4 for all AWS hosts by default, but don't use it by+	-- default for other S3 hosts, which may not support it.+	usev4 (Just DefaultSignatureVersion)+		| h == AWS.s3DefaultHost = True+		| otherwise = False+	usev4 (Just (SignatureVersion 4)) = True+	usev4 (Just (SignatureVersion _)) = False+	usev4 (Just Anonymous) = False+	usev4 Nothing = False+ 	r = encodeBS <$> getRemoteConfigValue regionField c-#endif  data S3Info = S3Info 	{ bucket :: S3.Bucket@@ -1175,11 +1188,9 @@ s3Info c info = catMaybes 	[ Just ("bucket", fromMaybe "unknown" (getBucketName c)) 	, Just ("endpoint", decodeBS (S3.s3Endpoint s3c))-#if MIN_VERSION_aws(0,24,0) 	, case S3.s3Region s3c of 		Nothing -> Nothing 		Just r -> Just ("region", decodeBS r)-#endif 	, Just ("port", show (S3.s3Port s3c)) 	, Just ("protocol", map toLower (show (S3.s3Protocol s3c))) 	, Just ("storage class", showstorageclass (getStorageClass c))@@ -1372,7 +1383,7 @@   where 	enableversioning b = do 		showAction "checking bucket versioning"-		hdl <- mkS3HandleVar c gc u+		hdl <- mkS3HandleVar False c gc u 		let setversioning = S3.putBucketVersioning b S3.VersioningEnabled 		withS3HandleOrFail u hdl $ \h -> #if MIN_VERSION_aws(0,24,3)

@@ -13,7 +13,7 @@  -  - Tahoe has its own encryption, so git-annex's encryption is not used.  -- - Copyright 2014-2020 Joey Hess <id@joeyh.name>+ - Copyright 2014-2025 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -45,7 +45,10 @@ import Utility.Metered import Utility.Env import Utility.ThreadScheduler+import Utility.Process.Transcript +import Control.Concurrent+ {- The TMVar is left empty until tahoe has been verified to be running. -} data TahoeHandle = TahoeHandle TahoeConfigDir (TMVar ()) @@ -55,7 +58,7 @@ type Capability = String  remote :: RemoteType-remote = specialRemoteType $ RemoteType+remote = RemoteType 	{ typename = "tahoe" 	, enumerate = const (findSpecialRemotes "tahoe") 	, generate = gen@@ -144,7 +147,8 @@ 	missingfurl = giveup "Set TAHOE_FURL to the introducer furl to use."  store :: RemoteStateHandle -> TahoeHandle -> Key -> AssociatedFile -> Maybe OsPath -> MeterUpdate -> Annex ()-store rs hdl k _af o _p = sendAnnex k o noop $ \src _sz ->+store rs hdl k _af o _p = sendAnnex k o noop $ \src _sz -> do+	showOutput 	parsePut <$> liftIO (readTahoe hdl "put" [File (fromOsPath src)]) >>= maybe 		(giveup "tahoe failed to store content") 		(\cap -> storeCapability rs k cap)@@ -157,8 +161,10 @@ 	return Verified   where 	go Nothing = giveup "tahoe capability is not known"-	go (Just cap) = unlessM (liftIO $ requestTahoe hdl "get" [Param cap, File (fromOsPath d)]) $-		giveup "tahoe failed to reteieve content"+	go (Just cap) = do+		showOutput+		unlessM (liftIO $ requestTahoe hdl "get" [Param cap, File (fromOsPath d)]) $+			giveup "tahoe failed to retrieve content"  remove :: Maybe SafeDropProof -> Key -> Annex () remove _ _ = giveup "content cannot be removed from tahoe remote"@@ -233,8 +239,42 @@ convergenceFile configdir =  	configdir </> literalOsPath "private" </> literalOsPath "convergence" +{- tahoe run stays in the foreground, but behaves as a daemon, servicing+ - requests. Attempting to start a second tahoe run process will fail. So,+ - in order to support multiple git-annex processes, it is run in the+ - background, and left running on exit.+ -+ - It can take a while for tahoe to begin accepting connections.+ - This function waits for it to get ready.+ -} startTahoeDaemon :: TahoeConfigDir -> IO ()-startTahoeDaemon configdir = void $ boolTahoe configdir "start" []+startTahoeDaemon configdir = withNullHandle $ \nullh -> do+	let ps = tahoeParams configdir "run" [Param "--allow-stdin-close"]+	let p = (proc "tahoe" $ toCommand ps)+		{ std_in = UseHandle nullh+		, std_out = UseHandle nullh+		, std_err = UseHandle nullh+		}+	void $ forkIO $ void $ createProcess p+	waitready (5 :: Int)+	hClose nullh+  where+	waitready n+		| n <= 0 = giveup "The tahoe run process is not responding to requests. Waited 5 seconds for it to start."+		| otherwise = do+			-- Need something that will always succeed+			-- once the server has started and is accepting+			-- requests, and this seems to do the trick.+			let ps = tahoeParams configdir "check"+				[ Param "--raw", Param "URI:LIT:"]+			(_, ok) <- processTranscript "tahoe" +				(toCommand ps)+				Nothing+			if ok+				then return ()+				else do+					threadDelaySeconds (Seconds 1)+					waitready (pred n)  {- Ensures that tahoe has been started, before running an action  - that uses it. -}

@@ -134,7 +134,7 @@ 	url <- maybe (giveup "Specify url=") 		(return . fromProposedAccepted) 		(M.lookup urlField c)-	(c', encsetup) <- encryptionSetup c gc+	(c', encsetup) <- encryptionSetup ss c gc 	pc <- either giveup return . parseRemoteConfig c' =<< configParser remote c' 	creds <- maybe (getCreds pc gc u) (return . Just) mcreds 	case ss of

@@ -1,6 +1,6 @@ {- git-remote-daemon transports  -- - Copyright 2014 Joey Hess <id@joeyh.name>+ - Copyright 2014-2025 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -11,8 +11,9 @@ import qualified RemoteDaemon.Transport.Ssh import qualified RemoteDaemon.Transport.GCrypt import qualified RemoteDaemon.Transport.Tor+import qualified RemoteDaemon.Transport.P2PGeneric import qualified Git.GCrypt-import P2P.Address (torAnnexScheme)+import P2P.Address (torAnnexScheme, p2pAnnexScheme)  import qualified Data.Map as M @@ -24,7 +25,11 @@ 	[ ("ssh:", RemoteDaemon.Transport.Ssh.transport) 	, (Git.GCrypt.urlScheme, RemoteDaemon.Transport.GCrypt.transport) 	, (torAnnexScheme, RemoteDaemon.Transport.Tor.transport)+	, (p2pAnnexScheme, RemoteDaemon.Transport.P2PGeneric.transport) 	]  remoteServers :: [Server]-remoteServers = [RemoteDaemon.Transport.Tor.server]+remoteServers = +	[ RemoteDaemon.Transport.Tor.server+	, RemoteDaemon.Transport.P2PGeneric.server+	]

@@ -0,0 +1,237 @@+{- git-remote-daemon, generic P2P protocol transports+ -+ - Copyright 2016-2025 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++{-# LANGUAGE OverloadedStrings #-}++module RemoteDaemon.Transport.P2PGeneric (+	server,+	transport,+	serveConnections+) where++import qualified Annex+import Annex.Common+import Annex.Concurrent+import Annex.ChangedRefs+import Annex.Perms+import RemoteDaemon.Types+import RemoteDaemon.Common+import Utility.AuthToken+import Utility.Hash+import P2P.Protocol as P2P+import P2P.IO+import P2P.Annex+import P2P.Auth+import P2P.Address+import P2P.Generic+import Annex.UUID+import Git+import Git.Command+import qualified Utility.OsString as OS++import Control.Concurrent+import Control.Concurrent.STM+import Control.Concurrent.STM.TBMQueue+import Control.Concurrent.Async+import Network.Socket (Socket)+import qualified Data.Set as S++server :: Server+server ichan th@(TransportHandle (LocalRepo r) _ _) = go S.empty+  where+	go alreadystarted = do+		u <- liftAnnex th getUUID+		newaddrs <- filter (`S.notMember` alreadystarted) +			<$> liftAnnex th loadP2PAddresses+		started <- filterM (start u) newaddrs+		handlecontrol (S.fromList started <> alreadystarted)++	start _ (TorAnnex _ _) = pure False+	start u addr@(P2PAnnex netname@(P2PNetName netname') address) = do+		socketfile <- liftAnnex th $ getSocketFile netname address+		sock <- listenUnixSocket socketfile+		tryNonAsync (socketGenericP2P netname address socketfile) >>= \case+			Right _pid -> do+				debug' $ "listener started for P2P network " ++ netname'+				void $ async $ serveConnections+					(loadP2PAuthTokens addr)+					netname th u r sock+				return True+			Left err -> do+				liftAnnex th $ warning $+					"unable to start listener for P2P network "+						<> UnquotedString netname' +						<> ": " <> UnquotedString (show err)+				return False+	+	handlecontrol started = do+		msg <- atomically $ readTChan ichan+		case msg of+			-- On reload, the configuration may have changed to+			-- enable a P2P network. Start any new ones.+			RELOAD -> go started+			_ -> handlecontrol started++getSocketFile :: P2PNetName -> UnderlyingP2PAddress -> Annex OsPath+getSocketFile (P2PNetName netname) (UnderlyingP2PAddress address) = do+	d <- fromRepo gitAnnexP2PDir+	createAnnexDirectory d+	-- Since unix socket path length is limited, use a md5sum of+	-- the netname and address.+	let f = d </> toOsPath (show (md5 (encodeBL (netname ++ ":" ++ address))))+	-- Use whichever is shorter of the absolute or relative path.+	relf <- liftIO $ relPathCwdToFile f+	absf <- liftIO $ absPath f+	if OS.length absf > OS.length relf+		then return relf+		else return absf++serveConnections+	:: Annex AllowedAuthTokens+	-> P2PNetName+	-> TransportHandle+	-> UUID+	-> Repo+	-> Socket+	-> IO ()+serveConnections loadauthtokens (P2PNetName netname) th u r sock = do+	q <- newTBMQueueIO maxConnections+	replicateM_ maxConnections $+		forkIO $ forever $ +			serveClient loadauthtokens (P2PNetName netname) th u r q+	serveUnixSocket' sock $ \conn -> do+		ok <- atomically $ ifM (isFullTBMQueue q)+			( return False+			, do+				writeTBMQueue q conn+				return True+			)+		unless ok $ do+			hClose conn+			liftAnnex th $ warning $ +				"dropped P2P network " +					<> UnquotedString netname +					<> " connection, too busy"++-- How many clients to serve at a time, maximum per P2P network.+-- This is to avoid DOS attacks.+maxConnections :: Int+maxConnections = 100++serveClient+	:: Annex AllowedAuthTokens+	-> P2PNetName+	-> TransportHandle+	-> UUID+	-> Repo+	-> TBMQueue Handle+	-> IO ()+serveClient loadauthtokens (P2PNetName netname) th@(TransportHandle _ _ rd) u r q = bracket setup cleanup start+  where+	setup = do+		h <- atomically $ readTBMQueue q+		debug' $ "serving a " ++ netname ++ " connection"+		return h+	+	cleanup Nothing = return ()+	cleanup (Just h) = do+		debug' $ "done with " ++ netname ++ " connection"+		hClose h++	start Nothing = return ()+	start (Just h) = do+		-- Avoid doing any work in the liftAnnex, since only one+		-- can run at a time.+		st <- liftAnnex th dupState+		((), (st', _rd)) <- Annex.run (st, rd) $ do+			-- Load auth tokens for every connection, to notice+			-- when the allowed set is changed.+			allowed <- loadauthtokens+			let conn = P2PConnection+				{ connRepo = Just r+				, connCheckAuth = (`isAllowedAuthToken` allowed)+				, connIhdl = P2PHandle h+				, connOhdl = P2PHandle h+				, connProcess = Nothing+				, connIdent = ConnIdent $ Just $+					netname ++ " remotedaemon"+				}+			-- not really Client, but we don't know their uuid yet+			runstauth <- liftIO $ mkRunState Client+			v <- liftIO $ runNetProto runstauth conn $ P2P.serveAuth u+			case v of+				Right (Just theiruuid) -> authed conn theiruuid+				Right Nothing -> liftIO $ debug' $+					netname ++ " connection failed to authenticate"+				Left e -> liftIO $ debug' $+					netname ++ " connection error before authentication: " ++ describeProtoFailure e+		-- Merge the duplicated state back in.+		liftAnnex th $ mergeState st'+	+	authed conn theiruuid = +		bracket watchChangedRefs (liftIO . maybe noop stopWatchingChangedRefs) $ \crh -> do+			runst <- liftIO $ mkRunState (Serving theiruuid crh)+			v' <- runFullProto runst conn $+				P2P.serveAuthed P2P.ServeReadWrite u+			case v' of+				Right () -> return ()+				Left e -> liftIO $ debug' $ +					netname ++ " connection error: " ++ describeProtoFailure e++transport :: Transport+transport (RemoteRepo r gc) url@(RemoteURI uri) th ichan ochan =+	case unformatP2PAddress (show uri) of+		Nothing -> return ()+		Just addr -> robustConnection 1 $ do+			g <- liftAnnex th Annex.gitRepo+			bracket (connectPeer (Just g) addr) closeConnection (go addr)+  where+	go addr conn = do+		myuuid <- liftAnnex th getUUID+		authtoken <- fromMaybe nullAuthToken+			<$> liftAnnex th (loadP2PRemoteAuthToken addr)+		runst <- mkRunState Client+		res <- runNetProto runst conn $ P2P.auth myuuid authtoken noop+		case res of+			Right (Just theiruuid) -> do+				expecteduuid <- liftAnnex th $ getRepoUUID r+				if expecteduuid == theiruuid+					then do+						send (CONNECTED url)+						status <- handlecontrol+							`race` handlepeer runst conn+						send (DISCONNECTED url)+						return $ either id id status+					else return ConnectionStopping+			_ -> return ConnectionClosed+	+	send msg = atomically $ writeTChan ochan msg+	+	handlecontrol = do+		msg <- atomically $ readTChan ichan+		case msg of+			STOP -> return ConnectionStopping+			LOSTNET -> return ConnectionStopping+			_ -> handlecontrol++	handlepeer runst conn = do+		v <- runNetProto runst conn P2P.notifyChange+		case v of+			Right (Just (ChangedRefs shas)) -> do+				whenM (checkShouldFetch gc th shas) $+					fetch+				handlepeer runst conn+			_ -> return ConnectionClosed+	+	fetch = do+		send (SYNCING url)+		ok <- inLocalRepo th $+			runBool [Param "fetch", Param $ Git.repoDescribe r]+		send (DONESYNCING url ok)++debug' :: String -> IO ()+debug' = debug "RemoteDaemon.Transport.P2PGeneric"

@@ -1,38 +1,25 @@ {- git-remote-daemon, tor hidden service server and transport  -- - Copyright 2016 Joey Hess <id@joeyh.name>+ - Copyright 2016-2025 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}  {-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}  module RemoteDaemon.Transport.Tor (server, transport, torSocketFile) where -import Common-import qualified Annex-import Annex.Concurrent-import Annex.ChangedRefs+import Annex.Common import RemoteDaemon.Types import RemoteDaemon.Common-import Utility.AuthToken import Utility.Tor-import P2P.Protocol as P2P import P2P.IO-import P2P.Annex import P2P.Auth import P2P.Address import Annex.UUID-import Types.UUID-import Messages-import Git-import Git.Command-import Utility.Debug+import qualified RemoteDaemon.Transport.P2PGeneric as P2PGeneric -import Control.Concurrent import Control.Concurrent.STM-import Control.Concurrent.STM.TBMQueue import Control.Concurrent.Async #ifndef mingw32_HOST_OS import System.Posix.User@@ -48,30 +35,19 @@ 		u <- liftAnnex th getUUID 		msock <- liftAnnex th torSocketFile 		case msock of-			Nothing -> do-				debugTor "Tor hidden service not enabled"+			Nothing -> 				return False-			Just sock -> do-				void $ async $ startservice sock u+			Just socketfile -> do+				void $ async $ startservice socketfile u 				return True 	-	startservice sock u = do-		q <- newTBMQueueIO maxConnections-		replicateM_ maxConnections $-			forkIO $ forever $ serveClient th u r q+	startservice socketfile u = do+		sock <- listenUnixSocket socketfile+		P2PGeneric.serveConnections+			loadP2PAuthTokensTor+			(P2PNetName "tor")+			th u r sock -		debugTor "Tor hidden service running"-		serveUnixSocket sock $ \conn -> do-			ok <- atomically $ ifM (isFullTBMQueue q)-				( return False-				, do-					writeTBMQueue q conn-					return True-				)-			unless ok $ do-				hClose conn-				liftAnnex th $ warning "dropped Tor connection, too busy"-	 	handlecontrol servicerunning = do 		msg <- atomically $ readTChan ichan 		case msg of@@ -84,114 +60,12 @@ 			-- changes as tor takes care of all that. 			_ -> handlecontrol servicerunning --- How many clients to serve at a time, maximum. This is to avoid DOS attacks.-maxConnections :: Int-maxConnections = 100--serveClient :: TransportHandle -> UUID -> Repo -> TBMQueue Handle -> IO ()-serveClient th@(TransportHandle _ _ rd) u r q = bracket setup cleanup start-  where-	setup = do-		h <- atomically $ readTBMQueue q-		debugTor "serving a Tor connection"-		return h-	-	cleanup Nothing = return ()-	cleanup (Just h) = do-		debugTor "done with Tor connection"-		hClose h--	start Nothing = return ()-	start (Just h) = do-		-- Avoid doing any work in the liftAnnex, since only one-		-- can run at a time.-		st <- liftAnnex th dupState-		((), (st', _rd)) <- Annex.run (st, rd) $ do-			-- Load auth tokens for every connection, to notice-			-- when the allowed set is changed.-			allowed <- loadP2PAuthTokensTor-			let conn = P2PConnection-				{ connRepo = Just r-				, connCheckAuth = (`isAllowedAuthToken` allowed)-				, connIhdl = P2PHandle h-				, connOhdl = P2PHandle h-				, connIdent = ConnIdent $ Just "tor remotedaemon"-				}-			-- not really Client, but we don't know their uuid yet-			runstauth <- liftIO $ mkRunState Client-			v <- liftIO $ runNetProto runstauth conn $ P2P.serveAuth u-			case v of-				Right (Just theiruuid) -> authed conn theiruuid-				Right Nothing -> liftIO $ debugTor-					"Tor connection failed to authenticate"-				Left e -> liftIO $ debugTor $-					"Tor connection error before authentication: " ++ describeProtoFailure e-		-- Merge the duplicated state back in.-		liftAnnex th $ mergeState st'-	-	authed conn theiruuid = -		bracket watchChangedRefs (liftIO . maybe noop stopWatchingChangedRefs) $ \crh -> do-			runst <- liftIO $ mkRunState (Serving theiruuid crh)-			v' <- runFullProto runst conn $-				P2P.serveAuthed P2P.ServeReadWrite u-			case v' of-				Right () -> return ()-				Left e -> liftIO $ debugTor $ -					"Tor connection error: " ++ describeProtoFailure e---- Connect to peer's tor hidden service.+-- Connect to peer's tor hidden service. P2PGeneric can do this,+-- since it uses connectPeer which also supports tor. transport :: Transport-transport (RemoteRepo r gc) url@(RemoteURI uri) th ichan ochan =-	case unformatP2PAddress (show uri) of-		Nothing -> return ()-		Just addr -> robustConnection 1 $ do-			g <- liftAnnex th Annex.gitRepo-			bracket (connectPeer (Just g) addr) closeConnection (go addr)-  where-	go addr conn = do-		myuuid <- liftAnnex th getUUID-		authtoken <- fromMaybe nullAuthToken-			<$> liftAnnex th (loadP2PRemoteAuthToken addr)-		runst <- mkRunState Client-		res <- runNetProto runst conn $ P2P.auth myuuid authtoken noop-		case res of-			Right (Just theiruuid) -> do-				expecteduuid <- liftAnnex th $ getRepoUUID r-				if expecteduuid == theiruuid-					then do-						send (CONNECTED url)-						status <- handlecontrol-							`race` handlepeer runst conn-						send (DISCONNECTED url)-						return $ either id id status-					else return ConnectionStopping-			_ -> return ConnectionClosed-	-	send msg = atomically $ writeTChan ochan msg-	-	handlecontrol = do-		msg <- atomically $ readTChan ichan-		case msg of-			STOP -> return ConnectionStopping-			LOSTNET -> return ConnectionStopping-			_ -> handlecontrol--	handlepeer runst conn = do-		v <- runNetProto runst conn P2P.notifyChange-		case v of-			Right (Just (ChangedRefs shas)) -> do-				whenM (checkShouldFetch gc th shas) $-					fetch-				handlepeer runst conn-			_ -> return ConnectionClosed-	-	fetch = do-		send (SYNCING url)-		ok <- inLocalRepo th $-			runBool [Param "fetch", Param $ Git.repoDescribe r]-		send (DONESYNCING url ok)+transport = P2PGeneric.transport -torSocketFile :: Annex.Annex (Maybe OsPath)+torSocketFile :: Annex (Maybe OsPath) torSocketFile = do 	u <- getUUID 	let ident = fromUUID u@@ -201,6 +75,3 @@ 	let uid = 0 #endif 	liftIO $ getHiddenServiceSocketFile torAppName uid ident--debugTor :: String -> IO ()-debugTor = debug "RemoteDaemon.Transport.Tor"

@@ -90,7 +90,6 @@ import qualified Utility.StatelessOpenPGP import qualified Types.Remote #ifndef mingw32_HOST_OS-import qualified Utility.OsString as OS import qualified Remote.Helper.Encryptable import qualified Types.Crypto import qualified Utility.Gpg@@ -98,7 +97,7 @@  optParser :: Parser TestOptions optParser = TestOptions-	<$> snd (tastyParser (tests 1 False True (TestOptions mempty False False Nothing mempty False mempty)))+	<$> snd (tastyParser (tests 1 False defaulttos)) 	<*> switch 		( long "keep-failures" 		<> help "preserve repositories on test failure"@@ -129,18 +128,27 @@ 			( Git.Types.ConfigKey (encodeBS k) 			, Git.Types.ConfigValue (encodeBS (drop 1 v)) 			)+	defaulttos = TestOptions+		{ tastyOptionSet = mempty+		, keepFailuresOption = False+		, fakeSsh = False+		, concurrentJobs = Nothing+		, testGitConfig = mempty+		, testDebug = False+		, internalData = mempty+		}  runner :: TestOptions -> IO () runner opts = parallelTestRunner opts tests -tests :: Int -> Bool -> Bool -> TestOptions -> [TestTree]-tests numparts crippledfilesystem adjustedbranchok opts = +tests :: Int -> Bool -> TestOptions -> [TestTree]+tests numparts crippledfilesystem opts =  	properties  		: withTestMode remotetestmode testRemotes 		: concatMap mkrepotests testmodes   where 	testmodes = catMaybes-		[ canadjust ("v10 adjusted unlocked branch", (testMode opts (RepoVersion 10)) { adjustedUnlockedBranch = True })+		[ Just ("v10 adjusted unlocked branch", (testMode opts (RepoVersion 10)) { adjustedUnlockedBranch = True }) 		, unlesscrippled ("v10 unlocked", (testMode opts (RepoVersion 10)) { unlockedFiles = True }) 		, unlesscrippled ("v10 locked", testMode opts (RepoVersion 10)) 		]@@ -148,9 +156,6 @@ 	unlesscrippled v 		| crippledfilesystem = Nothing 		| otherwise = Just v-	canadjust v-		| adjustedbranchok = Just v-		| otherwise = Nothing 	mkrepotests (d, te) = map  		(\uts -> withTestMode te uts) 		(repoTests d numparts)@@ -364,6 +369,7 @@ 	, testCase "add subdirs" test_add_subdirs 	, testCase "addurl" test_addurl 	, testCase "repair" test_repair+	, testCase "enableremote encryption changes" test_enableremote_encryption_changes 	]   where 	mk l = testGroup groupname (initTests : map adddep l)@@ -1370,7 +1376,7 @@ test_conflict_resolution_adjusted_branch :: Assertion test_conflict_resolution_adjusted_branch = 	withtmpclonerepo $ \r1 ->-		withtmpclonerepo $ \r2 -> whenM (adjustedbranchsupported r2) $ do+		withtmpclonerepo $ \r2 -> do 			intopdir r1 $ do 				disconnectOrigin 				writecontent conflictor "conflictor1"@@ -1687,7 +1693,7 @@ test_adjusted_branch_merge_regression :: Assertion test_adjusted_branch_merge_regression = do 	withtmpclonerepo $ \r1 ->-		withtmpclonerepo $ \r2 -> whenM (adjustedbranchsupported r1) $ do+		withtmpclonerepo $ \r2 -> do 			pair r1 r2 			setup r1 			setup r2@@ -1715,7 +1721,7 @@  - a subtree to an existing tree lost files. -} test_adjusted_branch_subtree_regression :: Assertion test_adjusted_branch_subtree_regression = -	withtmpclonerepo $ \r -> whenM (adjustedbranchsupported r) $ do+	withtmpclonerepo $ \r -> do 		intopdir r $ do 			disconnectOrigin 			origbranch <- annexeval origBranch@@ -1910,64 +1916,44 @@ 	testscheme "hybrid" 	testscheme "pubkey"   where-	gpgcmd = Utility.Gpg.mkGpgCmd Nothing-	testscheme scheme = Utility.Tmp.Dir.withTmpDir (literalOsPath "gpgtmp") $ \gpgtmp -> do-		-- Use the system temp directory as gpg temp directory because -		-- it needs to be able to store the agent socket there,-		-- which can be problematic when testing some filesystems.-		absgpgtmp <- absPath gpgtmp-		res <- testscheme' scheme absgpgtmp-		-- gpg may still be running and would prevent-		-- removeDirectoryRecursive from succeeding, so-		-- force removal of the temp directory.-		liftIO $ removeDirectoryForCleanup (fromOsPath gpgtmp)-		return res-	testscheme' scheme absgpgtmp = intmpclonerepo $ do-		-- Since gpg uses a unix socket, which is limited to a-		-- short path, use whichever is shorter of absolute-		-- or relative path.-		relgpgtmp <- relPathCwdToFile absgpgtmp-		let gpgtmp = if OS.length relgpgtmp < OS.length absgpgtmp-			then relgpgtmp -			else absgpgtmp-		void $ Utility.Gpg.testHarness (fromOsPath gpgtmp) gpgcmd $ \environ -> do-			createDirectory (literalOsPath "dir")-			let initps =-				[ "foo"-				, "type=directory"-				, "encryption=" ++ scheme-				, "directory=dir"-				, "highRandomQuality=false"-				] ++ if scheme `elem` ["hybrid","pubkey"]-					then ["keyid=" ++ Utility.Gpg.testKeyId]-					else []-			git_annex' "initremote" initps (Just environ) "initremote"-			git_annex_shouldfail' "initremote" initps (Just environ) "initremote should not work when run twice in a row"-			git_annex' "enableremote" initps (Just environ) "enableremote"-			git_annex' "enableremote" initps (Just environ) "enableremote when run twice in a row"-			git_annex' "get" [annexedfile] (Just environ) "get of file"-			annexed_present annexedfile-			git_annex' "copy" [annexedfile, "--to", "foo"] (Just environ) "copy --to encrypted remote"-			(c,k) <- annexeval $ do-				uuid <- Remote.nameToUUID "foo"-				rs <- Logs.Remote.readRemoteLog-				Just k <- Annex.WorkTree.lookupKey (toOsPath annexedfile)-				return (fromJust $ M.lookup uuid rs, k)-			let key = if scheme `elem` ["hybrid","pubkey"]-					then Just $ Utility.Gpg.KeyIds [Utility.Gpg.testKeyId]-					else Nothing-			testEncryptedRemote environ scheme key c [k] @? "invalid crypto setup"+	testscheme scheme = intmpclonerepo $ test_with_gpg $ \gpgcmd environ -> do+		createDirectory (literalOsPath "dir")+		let initps =+			[ "foo"+			, "type=directory"+			, "encryption=" ++ scheme+			, "directory=dir"+			, "highRandomQuality=false"+			] ++ if scheme `elem` ["hybrid","pubkey"]+				then ["keyid=" ++ Utility.Gpg.testKeyId]+				else []+		git_annex' "initremote" initps (Just environ) "initremote"+		git_annex_shouldfail' "initremote" initps (Just environ) "initremote should not work when run twice in a row"+		git_annex' "enableremote" initps (Just environ) "enableremote"+		git_annex' "enableremote" initps (Just environ) "enableremote when run twice in a row"+		git_annex' "get" [annexedfile] (Just environ) "get of file"+		annexed_present annexedfile+		git_annex' "copy" [annexedfile, "--to", "foo"] (Just environ) "copy --to encrypted remote"+		(c,k) <- annexeval $ do+			uuid <- Remote.nameToUUID "foo"+			rs <- Logs.Remote.readRemoteLog+			Just k <- Annex.WorkTree.lookupKey (toOsPath annexedfile)+			return (fromJust $ M.lookup uuid rs, k)+		let key = if scheme `elem` ["hybrid","pubkey"]+			then Just $ Utility.Gpg.KeyIds [Utility.Gpg.testKeyId]+			else Nothing+		testEncryptedRemote gpgcmd environ scheme key c [k] @? "invalid crypto setup" 	-			annexed_present annexedfile-			git_annex' "drop" [annexedfile, "--numcopies=2"] (Just environ) "drop"-			annexed_notpresent annexedfile-			git_annex' "move" [annexedfile, "--from", "foo"] (Just environ) "move --from encrypted remote"-			annexed_present annexedfile-			git_annex_shouldfail' "drop" [annexedfile, "--numcopies=2"] (Just environ) "drop should not be allowed with numcopies=2"-			annexed_present annexedfile+		annexed_present annexedfile+		git_annex' "drop" [annexedfile, "--numcopies=2"] (Just environ) "drop"+		annexed_notpresent annexedfile+		git_annex' "move" [annexedfile, "--from", "foo"] (Just environ) "move --from encrypted remote"+		annexed_present annexedfile+		git_annex_shouldfail' "drop" [annexedfile, "--numcopies=2"] (Just environ) "drop should not be allowed with numcopies=2"+		annexed_present annexedfile 	{- Ensure the configuration complies with the encryption scheme, and 	 - that all keys are encrypted properly for the given directory remote. -}-	testEncryptedRemote environ scheme ks c keys = case Remote.Helper.Encryptable.extractCipher pc of+	testEncryptedRemote gpgcmd environ scheme ks c keys = case Remote.Helper.Encryptable.extractCipher pc of 		Just cip@Crypto.SharedCipher{} | scheme == "shared" && isNothing ks -> 			checkKeys cip Nothing 		Just cip@(Crypto.EncryptedCipher encipher v ks')@@ -2078,7 +2064,12 @@ 	removeWhenExistsWith removeFile (literalOsPath "import") 	writecontent "import" (content "newimport3") 	git_annex "add" ["import"] "add of import"-	commitchanges+	ifM onAdjustedBranch+		-- On an adjusted branch, sync fails when there is a merge+		-- commit in history.+		( git_annex_shouldfail "sync" commitchangesparams "sync"+		, commitchanges+		) 	git_annex "export" [origbranch, "--to", "foo"] "export after import conflict" 	dircontains "import" (content "newimport3")   where@@ -2090,7 +2081,8 @@ 	-- When on an adjusted branch, this updates the master branch 	-- to match it, which is necessary since the master branch is going 	-- to be exported.-	commitchanges = git_annex "sync" ["--no-pull", "--no-push", "--no-content"] "sync"+	commitchanges = git_annex "sync" commitchangesparams "sync"+	commitchangesparams = ["--no-pull", "--no-push", "--no-content"]  test_export_import_subdir :: Assertion test_export_import_subdir = intmpclonerepo $ do@@ -2180,3 +2172,43 @@ test_repair = intmpclonerepo $ 	-- Simply running repair used to fail on Windows. 	git_annex "repair" [] "repair"++test_enableremote_encryption_changes :: Assertion+test_enableremote_encryption_changes = intmpclonerepo $ do+	createDirectory (literalOsPath "dir")+	let dirparam="directory=dir"+	git_annex "initremote" ["foo", "type=directory", "encryption=none", dirparam] +		"initremote"+	git_annex_shouldfail "enableremote" ["foo", "encryption=shared", dirparam]+		"enableremote adding new encryption"+	git_annex "initremote" ["bar", "type=directory", "encryption=shared", dirparam] +		"initremote"+	git_annex "enableremote" ["bar", "encryption=shared", dirparam] +		"enableremote with same encryption"+	git_annex_shouldfail "enableremote" ["bar", "encryption=none", dirparam]+		"enableremote disabling encryption"+	git_annex_shouldfail "enableremote" ["bar", "onlyencryptcreds=yes", dirparam]+		"enableremote with onlyencryptcreds"+	git_annex_shouldfail "initremote" ["baz", "type=directory", "encryption=shared", "onlyencryptcreds=yes", dirparam]+		"initremote with onlyencryptcreds not allowed with shared encryption"+	git_annex_shouldfail "initremote" ["baz", "type=directory", "encryption=none", "onlyencryptcreds=yes", dirparam]+		"initremote with onlyencryptcreds not allowed with no encryption"+#ifndef mingw32_HOST_OS+	test_with_gpg $ \_gpgcmd environ -> do+		git_annex' "initremote"+			["baz"+			, "type=directory"+			, "encryption=hybrid"+			, "onlyencryptcreds=yes"+			, "highRandomQuality=false"+			, "keyid=" ++ Utility.Gpg.testKeyId+			, dirparam]+			(Just environ)+			"initremote with onlyencryptcreds and hybrid encryption"+		git_annex_shouldfail' "enableremote" ["baz", "onlyencryptcreds=no", dirparam]+			(Just environ)+			"enableremote disabling onlyencryptcreds"+		git_annex' "enableremote" ["baz", "onlyencryptcreds=yes", dirparam]+			(Just environ)+			"enableremote enabling already enabled onlyencryptcreds"+#endif

@@ -1,11 +1,11 @@ {- git-annex test suite framework  -- - Copyright 2010-2023 Joey Hess <id@joeyh.name>+ - Copyright 2010-2024 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -} -{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, CPP #-}  module Test.Framework where @@ -67,6 +67,9 @@ import qualified Utility.HumanTime import qualified Command.Uninit import qualified Utility.OsString as OS+#ifndef mingw32_HOST_OS+import qualified Utility.Gpg+#endif  -- Run a process. The output and stderr is captured, and is only -- displayed if the process does not return the expected value.@@ -229,9 +232,6 @@ 		Right v -> return v 		Left e -> throwM e -adjustedbranchsupported :: FilePath -> IO Bool-adjustedbranchsupported repo = intopdir repo $ Annex.AdjustedBranch.isGitVersionSupported- setuprepo :: FilePath -> IO FilePath setuprepo dir = do 	cleanup dir@@ -520,6 +520,33 @@ 	, git_annex "add" [f] faildesc 	) +#ifndef mingw32_HOST_OS+test_with_gpg :: (Utility.Gpg.GpgCmd -> [(String, String)] -> Assertion) -> Assertion+test_with_gpg a = Utility.Tmp.Dir.withTmpDir (literalOsPath "gpgtmp") $ \gpgtmp -> do+	-- Use the system temp directory as gpg temp directory because +	-- it needs to be able to store the agent socket there,+	-- which can be problematic when testing some filesystems.+	absgpgtmp <- absPath gpgtmp+	res <- go absgpgtmp+	-- gpg may still be running and would prevent+	-- removeDirectoryRecursive from succeeding, so+	-- force removal of the temp directory.+	liftIO $ removeDirectoryForCleanup (fromOsPath gpgtmp)+	return res+  where+	gpgcmd = Utility.Gpg.mkGpgCmd Nothing+	go absgpgtmp = do+		-- Since gpg uses a unix socket, which is limited to a+		-- short path, use whichever is shorter of absolute+		-- or relative path.+		relgpgtmp <- relPathCwdToFile absgpgtmp+		let gpgtmp = if OS.length relgpgtmp < OS.length absgpgtmp+			then relgpgtmp +			else absgpgtmp+		void $ Utility.Gpg.testHarness (fromOsPath gpgtmp) gpgcmd $ \environ ->+			a gpgcmd environ+#endif+ data TestMode = TestMode 	{ unlockedFiles :: Bool 	, adjustedUnlockedBranch :: Bool@@ -538,6 +565,9 @@ hasUnlockedFiles :: TestMode -> Bool hasUnlockedFiles m = unlockedFiles m || adjustedUnlockedBranch m +onAdjustedBranch :: IO Bool+onAdjustedBranch = adjustedUnlockedBranch <$> getTestMode+ withTestMode :: TestMode -> TestTree -> TestTree withTestMode testmode = withResource prepare release . const   where@@ -746,7 +776,7 @@  - leave open are closed before finalCleanup is run at the end. This  - prevents some failures to clean up after the test suite.  -}-parallelTestRunner :: TestOptions -> (Int -> Bool -> Bool -> TestOptions -> [TestTree]) -> IO ()+parallelTestRunner :: TestOptions -> (Int -> Bool -> TestOptions -> [TestTree]) -> IO () parallelTestRunner opts mkts = do 	numjobs <- case concurrentJobs opts of 		Just NonConcurrent -> pure 1@@ -755,7 +785,7 @@ 		Nothing -> getNumProcessors 	parallelTestRunner' numjobs opts mkts -parallelTestRunner' :: Int -> TestOptions -> (Int -> Bool -> Bool -> TestOptions -> [TestTree]) -> IO ()+parallelTestRunner' :: Int -> TestOptions -> (Int -> Bool -> TestOptions -> [TestTree]) -> IO () parallelTestRunner' numjobs opts mkts 	| fakeSsh opts = runFakeSsh (internalData opts) 	| otherwise = go =<< Utility.Env.getEnv subenv@@ -810,8 +840,7 @@ 			<$> Annex.Init.probeCrippledFileSystem' 				(toOsPath tmpdir) 				Nothing Nothing False-		adjustedbranchok <- Annex.AdjustedBranch.isGitVersionSupported-		let ts = mkts numparts crippledfilesystem adjustedbranchok opts+		let ts = mkts numparts crippledfilesystem opts 		let warnings = fst (tastyParser ts) 		unless (null warnings) $ do 			hPutStrLn stderr "warnings from tasty:"@@ -827,7 +856,7 @@ 			let subdir = fromOsPath $ toOsPath tmpdir </> toOsPath (show n) 			ensuredir subdir 			let p = (proc pp ps)-				{ env = Just ((subenv, show (n, crippledfilesystem, adjustedbranchok)):environ)+				{ env = Just ((subenv, show (n, crippledfilesystem)):environ) 				, cwd = Just subdir 				} 			(_, _, _, pid) <- createProcessConcurrent p@@ -839,8 +868,8 @@ 		return (length ts, exitcodes) 	go (Just subenvval) = case readish subenvval of 		Nothing -> error ("Bad " ++ subenv)-		Just (n, crippledfilesystem, adjustedbranchok) -> setTestEnv $ do-			let ts = mkts numparts crippledfilesystem adjustedbranchok opts+		Just (n, crippledfilesystem) -> setTestEnv $ do+			let ts = mkts numparts crippledfilesystem opts 			let t = topLevelTestGroup [ ts !! (n - 1) ] 			case tryIngredients ingredients tastyopts t of 				Nothing -> error "No tests found!?"

@@ -33,7 +33,7 @@ 	| PubKeyEncryption 	| SharedPubKeyEncryption 	| HybridEncryption-	deriving (Typeable, Eq)+	deriving (Typeable, Eq, Show)  -- A base-64 encoded random value used for encryption. -- XXX ideally, this would be a locked memory region@@ -44,6 +44,7 @@ 	| SharedCipher ByteString 	| SharedPubKeyCipher ByteString KeyIds 	deriving (Ord, Eq)+ data EncryptedCipherVariant = Hybrid | PubKey 	deriving (Ord, Eq) 

@@ -25,13 +25,11 @@ import qualified Git import qualified Git.LsFiles import qualified Git.Branch-import qualified Git.Version import Git.FilePath import Git.FileMode import Git.Config import Git.Ref import Utility.InodeCache-import Utility.DottedVersion import Annex.AdjustedBranch import qualified Utility.FileIO as F @@ -39,13 +37,7 @@ upgrade automatic = flip catchNonAsync onexception $ do 	unless automatic $ 		showAction "v5 to v6"-	ifM isDirect-		( do-			checkGitVersionForDirectUpgrade-			convertDirect-		, do-			checkGitVersionForIndirectUpgrade-		)+	whenM isDirect convertDirect 	scanAnnexedFiles 	configureSmudgeFilter 	-- Inode sentinal file was only used in direct mode and when@@ -59,27 +51,6 @@ 	onexception e = do 		warning $ UnquotedString $ "caught exception: " ++ show e 		return UpgradeFailed---- git before 2.22 would OOM running git status on a large file.------ Older versions of git that are patched (with--- commit 02156ab031e430bc45ce6984dfc712de9962dec8)--- can include "oomfix" in their version to indicate it.-gitWillOOM :: Annex Bool-gitWillOOM = liftIO $ do-	v <- Git.Version.installed-	return $ v < Git.Version.normalize "2.22" &&-		not ("oomfix" `isInfixOf` fromDottedVersion v)---- configureSmudgeFilter has to run git status, and direct mode files--- are unlocked, so avoid the upgrade failing half way through.-checkGitVersionForDirectUpgrade :: Annex ()-checkGitVersionForDirectUpgrade = whenM gitWillOOM $-	giveup "You must upgrade git to version 2.22 or newer in order to use this version of git-annex in this repository."--checkGitVersionForIndirectUpgrade :: Annex ()-checkGitVersionForIndirectUpgrade = whenM gitWillOOM $-	warning "Git is older than version 2.22 and so it has a memory leak that affects using unlocked files. Recommend you upgrade git before unlocking any files in your repository."  convertDirect :: Annex () convertDirect = do

@@ -1,6 +1,6 @@ {- authentication tokens  -- - Copyright 2016 Joey Hess <id@joeyh.name>+ - Copyright 2016-2025 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}@@ -12,6 +12,7 @@ 	toAuthToken, 	fromAuthToken, 	nullAuthToken,+	displayAuthToken, 	genAuthToken, 	AllowedAuthTokens, 	allowedAuthTokens,@@ -68,6 +69,10 @@ -- | The empty AuthToken, for those times when you don't want any security. nullAuthToken :: AuthToken nullAuthToken = AuthToken $ secureMemFromByteString $ TE.encodeUtf8 T.empty++-- | Display in place of a real AuthToken in protocol dumps.+displayAuthToken :: AuthToken+displayAuthToken = AuthToken $ secureMemFromByteString $ TE.encodeUtf8 $ T.pack "<AUTHTOKEN>"  -- | Generates an AuthToken of a specified length. This is done by -- generating a random bytestring, hashing it with sha2 512, and truncating

@@ -36,7 +36,7 @@ type OnionPort = Int  newtype OnionAddress = OnionAddress String-	deriving (Show, Eq)+	deriving (Show, Eq, Ord)  type OnionSocket = OsPath 

@@ -1,5 +1,5 @@ Name: git-annex-Version: 10.20250721+Version: 10.20250828 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -278,7 +278,7 @@    tasty-quickcheck,    tasty-rerun,    ansi-terminal >= 0.9,-   aws (>= 0.22.1),+   aws (>= 0.24.1),    DAV (>= 1.0),    network (>= 3.0.0.0),    network-bsd,@@ -649,6 +649,7 @@     CmdLine.AnnexSetter     CmdLine.Multicall     CmdLine.GitRemoteAnnex+    CmdLine.GitRemoteP2PAnnex     CmdLine.GitRemoteTorAnnex     CmdLine.Option     CmdLine.Seek@@ -812,7 +813,6 @@     Git     Git.AutoCorrect     Git.Branch-    Git.BuildVersion     Git.Bundle     Git.CatFile     Git.CheckAttr@@ -923,6 +923,7 @@     P2P.Address     P2P.Annex     P2P.Auth+    P2P.Generic     P2P.Http.Types     P2P.Http.Client     P2P.Http.Url@@ -978,6 +979,7 @@     RemoteDaemon.Core     RemoteDaemon.Transport     RemoteDaemon.Transport.GCrypt+    RemoteDaemon.Transport.P2PGeneric     RemoteDaemon.Transport.Tor     RemoteDaemon.Transport.Ssh     RemoteDaemon.Transport.Ssh.Types

@@ -16,6 +16,7 @@ import qualified CmdLine.GitAnnex import qualified CmdLine.GitAnnexShell import qualified CmdLine.GitRemoteAnnex+import qualified CmdLine.GitRemoteP2PAnnex import qualified CmdLine.GitRemoteTorAnnex import qualified Test import qualified Benchmark@@ -39,6 +40,7 @@ 	run ps n = case M.lookup (takeFileName n) otherMulticallCommands of 		Just GitAnnexShell -> CmdLine.GitAnnexShell.run ps 		Just GitRemoteAnnex -> CmdLine.GitRemoteAnnex.run ps+		Just GitRemoteP2PAnnex -> CmdLine.GitRemoteP2PAnnex.run ps 		Just GitRemoteTorAnnex -> CmdLine.GitRemoteTorAnnex.run ps 		Nothing -> CmdLine.GitAnnex.run 			Test.optParser

@@ -14,9 +14,4 @@     ospath: true packages: - '.'-resolver: nightly-2025-04-04-extra-deps:-- feed-1.3.2.1-allow-newer: true-allow-newer-deps:-- feed+resolver: lts-24.2