git-annex 10.20240531 → 10.20240701

raw patch · 94 files changed

+3078/−550 lines, 94 files

Files

• Annex.hs +6/−0
• Annex/Action.hs +0/−36
• Annex/Branch.hs +43/−22
• Annex/Cluster.hs +170/−0
• Annex/Content.hs +20/−7
• Annex/Drop.hs +1/−1
• Annex/Init.hs +18/−13
• Annex/NumCopies.hs +83/−23
• Annex/Proxy.hs +211/−0
• Annex/Startup.hs +67/−0
• Annex/Transfer.hs +3/−3
• Annex/UUID.hs +6/−2
• Assistant/MakeRepo.hs +2/−1
• Assistant/Upgrade.hs +0/−1
• CHANGELOG +24/−0
• CmdLine.hs +1/−0
• CmdLine/Action.hs +1/−1
• CmdLine/GitAnnex.hs +8/−0
• CmdLine/GitAnnex/Options.hs +35/−11
• CmdLine/GitAnnexShell.hs +86/−13
• CmdLine/GitAnnexShell/Checks.hs +10/−1
• CmdLine/GitRemoteAnnex.hs +2/−1
• CmdLine/GitRemoteTorAnnex.hs +1/−1
• Command.hs +6/−1
• Command/Assistant.hs +2/−1
• Command/ConfigList.hs +2/−1
• Command/Dead.hs +1/−1
• Command/Describe.hs +2/−2
• Command/Drop.hs +2/−2
• Command/EnableTor.hs +7/−9
• Command/Export.hs +1/−1
• Command/ExtendCluster.hs +58/−0
• Command/Fsck.hs +1/−1
• Command/Get.hs +2/−1
• Command/Group.hs +2/−2
• Command/Import.hs +1/−1
• Command/Info.hs +1/−1
• Command/Init.hs +2/−1
• Command/InitCluster.hs +50/−0
• Command/Move.hs +7/−6
• Command/P2P.hs +1/−1
• Command/P2PStdIO.hs +74/−8
• Command/Reinit.hs +2/−1
• Command/Semitrust.hs +2/−1
• Command/SendKey.hs +1/−1
• Command/TestRemote.hs +2/−2
• Command/TransferKey.hs +7/−7
• Command/TransferKeys.hs +8/−8
• Command/Transferrer.hs +11/−11
• Command/Trust.hs +2/−1
• Command/Ungroup.hs +2/−1
• Command/Untrust.hs +2/−1
• Command/Unused.hs +1/−0
• Command/UpdateCluster.hs +84/−0
• Command/UpdateProxy.hs +96/−0
• Command/Upgrade.hs +2/−1
• Command/Wanted.hs +2/−1
• Command/Whereis.hs +2/−1
• Git/Branch.hs +15/−5
• Git/Remote.hs +5/−1
• Git/Types.hs +3/−0
• Limit.hs +3/−2
• Logs.hs +8/−0
• Logs/Cluster.hs +41/−0
• Logs/Cluster/Basic.hs +91/−0
• Logs/Export.hs +6/−7
• Logs/Location.hs +46/−15
• Logs/Proxy.hs +88/−0
• P2P/Annex.hs +3/−3
• P2P/IO.hs +110/−50
• P2P/Protocol.hs +146/−53
• P2P/Proxy.hs +586/−0
• Remote.hs +9/−5
• Remote/BitTorrent.hs +2/−2
• Remote/Git.hs +159/−26
• Remote/Helper/Git.hs +27/−4
• Remote/Helper/Hooks.hs +2/−2
• Remote/Helper/P2P.hs +36/−12
• Remote/Helper/ReadOnly.hs +2/−2
• Remote/Helper/Special.hs +4/−4
• Remote/Helper/Ssh.hs +71/−62
• Remote/List.hs +1/−1
• Remote/P2P.hs +3/−3
• Remote/Tahoe.hs +2/−2
• Remote/Web.hs +2/−2
• RemoteDaemon/Transport/Tor.hs +4/−4
• Types/Cluster.hs +84/−0
• Types/Command.hs +1/−0
• Types/GitConfig.hs +240/−63
• Types/Remote.hs +1/−1
• Types/Transfer.hs +6/−0
• Utility/LockFile/Windows.hs +6/−3
• Utility/SimpleProtocol.hs +6/−1
• git-annex.cabal +13/−1

@@ -74,6 +74,7 @@ import Types.RemoteConfig import Types.TransferrerPool import Types.VectorClock+import Types.Cluster import Annex.VectorClock.Utility import Annex.Debug.Utility import qualified Database.Keys.Handle as Keys@@ -194,6 +195,7 @@ 	, preferredcontentmap :: Maybe (FileMatcherMap Annex) 	, requiredcontentmap :: Maybe (FileMatcherMap Annex) 	, remoteconfigmap :: Maybe (M.Map UUID RemoteConfig)+	, clusters :: Maybe Clusters 	, forcetrust :: TrustMap 	, trustmap :: Maybe TrustMap 	, groupmap :: Maybe GroupMap@@ -213,6 +215,7 @@ 	, urloptions :: Maybe UrlOptions 	, insmudgecleanfilter :: Bool 	, getvectorclock :: IO CandidateVectorClock+	, proxyremote :: Maybe (Either ClusterUUID (Types.Remote.RemoteA Annex)) 	}  newAnnexState :: GitConfig -> Git.Repo -> IO AnnexState@@ -247,6 +250,7 @@ 		, preferredcontentmap = Nothing 		, requiredcontentmap = Nothing 		, remoteconfigmap = Nothing+		, clusters = Nothing 		, forcetrust = M.empty 		, trustmap = Nothing 		, groupmap = Nothing@@ -266,6 +270,7 @@ 		, urloptions = Nothing 		, insmudgecleanfilter = False 		, getvectorclock = vc+		, proxyremote = Nothing 		}  {- Makes an Annex state object for the specified git repo.@@ -423,6 +428,7 @@ 		{ repo = r' 		, gitconfig = gitconfigadjuster $ 			extractGitConfig FromGitConfig r'+		, gitremotes = Nothing 		}  {- Gets the RemoteGitConfig from a remote, given the Git.Repo for that

@@ -5,12 +5,9 @@  - Licensed under the GNU AGPL version 3 or higher.  -} -{-# LANGUAGE CPP #-}- module Annex.Action ( 	action, 	verifiedAction,-	startup, 	quiesce, 	stopCoProcesses, ) where@@ -27,11 +24,6 @@ import Annex.TransferrerPool import qualified Database.Keys -#ifndef mingw32_HOST_OS-import Control.Concurrent.STM-import System.Posix.Signals-#endif- {- Runs an action that may throw exceptions, catching and displaying them. -} action :: Annex () -> Annex Bool action a = tryNonAsync a >>= \case@@ -46,34 +38,6 @@ 	Left e -> do 		warning (UnquotedString (show e)) 		return (False, UnVerified)---{- Actions to perform each time ran. -}-startup :: Annex ()-startup = do-#ifndef mingw32_HOST_OS-	av <- Annex.getRead Annex.signalactions-	let propagate sig = liftIO $ installhandleronce sig av-	propagate sigINT-	propagate sigQUIT-	propagate sigTERM-	propagate sigTSTP-	propagate sigCONT-	propagate sigHUP-	-- sigWINCH is not propagated; it should not be needed,-	-- and the concurrent-output library installs its own signal-	-- handler for it.-	-- sigSTOP and sigKILL cannot be caught, so will not be propagated.-  where-	installhandleronce sig av = void $-		installHandler sig (CatchOnce (gotsignal sig av)) Nothing-	gotsignal sig av = do-		mapM_ (\a -> a (fromIntegral sig)) =<< atomically (readTVar av)-		raiseSignal sig-		installhandleronce sig av-#else-       return ()-#endif  {- Rn all cleanup actions, save all state, stop all long-running child  - processes.

@@ -818,12 +818,18 @@ 		if neednewlocalbranch 			then do 				cmode <- annexCommitMode <$> Annex.getGitConfig-				committedref <- inRepo $ Git.Branch.commitAlways cmode message fullname transitionedrefs-				setIndexSha committedref+				-- Creating a new empty branch must happen+				-- atomically, so if this is interrupted,+				-- it will not leave the new branch created+				-- but without exports grafted in.+				c <- inRepo $ Git.Branch.commitShaAlways+					cmode message transitionedrefs+				void $ regraftexports c 			else do 				ref <- getBranch-				commitIndex jl ref message (nub $ fullname:transitionedrefs)-	regraftexports+				ref' <- regraftexports ref+				commitIndex jl ref' message+					(nub $ fullname:transitionedrefs)   where 	message 		| neednewlocalbranch && null transitionedrefs = "new branch for transition " ++ tdesc@@ -872,13 +878,25 @@ 					apply rest file content'  	-- Trees mentioned in export.log were grafted into the old-	-- git-annex branch to make sure they remain available. Re-graft-	-- the trees into the new branch.-	regraftexports = do+	-- git-annex branch to make sure they remain available.+	-- Re-graft the trees.+	regraftexports parent = do 		l <- exportedTreeishes . M.elems . parseExportLogMap 			<$> getStaged exportLog-		forM_ l $ \t ->-			rememberTreeishLocked t (asTopFilePath exportTreeGraftPoint) jl+		c <- regraft l parent+		inRepo $ Git.Branch.update' fullname c+		setIndexSha c+		return c+	  where+		regraft [] c = pure c+		regraft (et:ets) c =+			-- Verify that the tree object exists.+			catObjectDetails et >>= \case+				Just _ ->+					prepRememberTreeish et graftpoint c+						>>= regraft ets+				Nothing -> regraft ets c+		graftpoint = asTopFilePath exportTreeGraftPoint  checkBranchDifferences :: Git.Ref -> Annex () checkBranchDifferences ref = do@@ -935,26 +953,29 @@  - Returns the sha of the git commit made to the git-annex branch.  -} rememberTreeish :: Git.Ref -> TopFilePath -> Annex Git.Sha-rememberTreeish treeish graftpoint = lockJournal $-	rememberTreeishLocked treeish graftpoint-rememberTreeishLocked :: Git.Ref -> TopFilePath -> JournalLocked -> Annex Git.Sha-rememberTreeishLocked treeish graftpoint jl = do+rememberTreeish treeish graftpoint = lockJournal $ \jl -> do 	branchref <- getBranch 	updateIndex jl branchref+	c <- prepRememberTreeish treeish graftpoint branchref+	inRepo $ Git.Branch.update' fullname c+	-- The tree in c is the same as the tree in branchref,+	-- and the index was updated to that above, so it's safe to+	-- say that the index contains c.+	setIndexSha c+	return c++{- Create a series of commits that graft a tree onto the parent commit,+ - and then remove it. -}+prepRememberTreeish :: Git.Ref -> TopFilePath -> Git.Ref -> Annex Git.Sha+prepRememberTreeish treeish graftpoint parent = do 	origtree <- fromMaybe (giveup "unable to determine git-annex branch tree") <$>-		inRepo (Git.Ref.tree branchref)+		inRepo (Git.Ref.tree parent) 	addedt <- inRepo $ Git.Tree.graftTree treeish graftpoint origtree 	cmode <- annexCommitMode <$> Annex.getGitConfig 	c <- inRepo $ Git.Branch.commitTree cmode-		["graft"] [branchref] addedt-	c' <- inRepo $ Git.Branch.commitTree cmode+		["graft"] [parent] addedt+	inRepo $ Git.Branch.commitTree cmode 		["graft cleanup"] [c] origtree-	inRepo $ Git.Branch.update' fullname c'-	-- The tree in c' is the same as the tree in branchref,-	-- and the index was updated to that above, so it's safe to-	-- say that the index contains c'.-	setIndexSha c'-	return c'  {- Runs an action on the content of selected files from the branch.  - This is much faster than reading the content of each file in turn,

@@ -0,0 +1,170 @@+{- clusters+ -+ - Copyright 2024 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++{-# LANGUAGE RankNTypes, OverloadedStrings #-}++module Annex.Cluster where++import Annex.Common+import qualified Annex+import Types.Cluster+import Logs.Cluster+import P2P.Proxy+import P2P.Protocol+import P2P.IO+import Annex.Proxy+import Annex.UUID+import Logs.Location+import Logs.PreferredContent+import Types.Command+import Remote.List+import qualified Remote+import qualified Types.Remote as Remote++import qualified Data.Map as M+import qualified Data.Set as S+import System.Random++{- Proxy to a cluster. -}+proxyCluster +	:: ClusterUUID+	-> CommandPerform+	-> ServerMode+	-> ClientSide+	-> (forall a. Annex () -> ((a -> CommandPerform) -> Annex (Either ProtoFailure a) -> CommandPerform))+	-> CommandPerform+proxyCluster clusteruuid proxydone servermode clientside protoerrhandler = do+	getClientProtocolVersion (fromClusterUUID clusteruuid) clientside+		withclientversion (protoerrhandler noop)+  where+	proxymethods = ProxyMethods+		{ removedContent = \u k -> logChange k u InfoMissing+		, addedContent = \u k -> logChange k u InfoPresent+		}+	+	withclientversion (Just (clientmaxversion, othermsg)) = do+		-- The protocol versions supported by the nodes are not+		-- known at this point, and would be too expensive to+		-- determine. Instead, pick the newest protocol version+		-- that we and the client both speak. The proxy code+		-- checks protocol versions when operating on multiple+		-- nodes, and allows nodes to have different protocol+		-- versions.+		let protocolversion = min maxProtocolVersion clientmaxversion+		sendClientProtocolVersion clientside othermsg protocolversion+			(getclientbypass protocolversion) (protoerrhandler noop)+	withclientversion Nothing = proxydone++	getclientbypass protocolversion othermsg =+		getClientBypass clientside protocolversion othermsg+			(withclientbypass protocolversion) (protoerrhandler noop)++	withclientbypass protocolversion (bypassuuids, othermsg) = do+		(selectnode, closenodes) <- clusterProxySelector clusteruuid+			protocolversion bypassuuids+		concurrencyconfig <- getConcurrencyConfig+		proxy proxydone proxymethods servermode clientside +			(fromClusterUUID clusteruuid)+			selectnode concurrencyconfig protocolversion+			othermsg (protoerrhandler closenodes)++clusterProxySelector :: ClusterUUID -> ProtocolVersion -> Bypass -> Annex (ProxySelector, Annex ())+clusterProxySelector clusteruuid protocolversion (Bypass bypass) = do+	nodeuuids <- (fromMaybe S.empty . M.lookup clusteruuid . clusterUUIDs)+		<$> getClusters+	myclusters <- annexClusters <$> Annex.getGitConfig+	allremotes <- concat . Remote.byCost <$> remoteList+	hereu <- getUUID+	let bypass' = S.insert hereu bypass+	let clusterremotes = filter (isnode bypass' allremotes nodeuuids myclusters) allremotes+	fastDebug "Annex.Cluster" $ unwords+		[ "cluster gateway at", fromUUID hereu+		, "connecting to", show (map Remote.name clusterremotes)+		, "bypass", show (S.toList bypass)+		]+	nodes <- mapM (proxyRemoteSide protocolversion (Bypass bypass')) clusterremotes+	let closenodes = mapM_ closeRemoteSide nodes+	let proxyselector = ProxySelector+		{ proxyCHECKPRESENT = nodecontaining nodes+		, proxyGET = nodecontaining nodes+		-- The key is sent to multiple nodes at the same time,+		-- skipping nodes where it's known/expected to already be+		-- present to avoid needing to connect to those, and+		-- skipping nodes where it's not preferred content.+		, proxyPUT = \af k -> do+			locs <- S.fromList <$> loggedLocations k+			let l = filter (flip S.notMember locs . Remote.uuid . remote) nodes+			l' <- filterM (\n -> isPreferredContent (Just (Remote.uuid (remote n))) mempty (Just k) af True) l+			-- PUT to no nodes doesn't work, so fall+			-- back to all nodes.+			return $ nonempty [l', l] nodes+		-- Remove the key from every node that contains it.+		-- But, since it's possible the location log for some nodes+		-- could be out of date, actually try to remove from every+		-- node.+		, proxyREMOVE = const (pure nodes)+		-- Content is not locked on the cluster as a whole,+		-- instead it can be locked on individual nodes that are+		-- proxied to the client.+		, proxyLOCKCONTENT = const (pure Nothing)+		, proxyUNLOCKCONTENT = pure Nothing+		}+	return (proxyselector, closenodes)+  where+	-- Nodes of the cluster have remote.name.annex-cluster-node+	-- containing its name. +	--+	-- Or, a node can be the cluster proxied by another gateway.+	isnode bypass' rs nodeuuids myclusters r = +		case remoteAnnexClusterNode (Remote.gitconfig r) of+			Just names+				| any (isclustername myclusters) names ->+					flip S.member nodeuuids $ +						ClusterNodeUUID $ Remote.uuid r+				| otherwise -> False+			Nothing -> isclusterviagateway bypass' rs r+	+	-- Is this remote the same cluster, proxied via another gateway?+	--+	-- Must avoid bypassed gateways to prevent cycles.+	isclusterviagateway bypass' rs r = +		case mkClusterUUID (Remote.uuid r) of+			Just cu | cu == clusteruuid ->+				case remoteAnnexProxiedBy (Remote.gitconfig r) of+					Just proxyuuid | proxyuuid `S.notMember` bypass' ->+						not $ null $+							filter isclustergateway $+							filter (\p -> Remote.uuid p == proxyuuid) rs+					_ -> False+			_ -> False+	+	isclustergateway r = any (== clusteruuid) $ +		remoteAnnexClusterGateway $ Remote.gitconfig r++	isclustername myclusters name = +		M.lookup name myclusters == Just clusteruuid+	+	nodecontaining nodes k = do+		locs <- S.fromList <$> loggedLocations k+		case filter (flip S.member locs . Remote.uuid . remote) nodes of+			[] -> return Nothing+			(node:[]) -> return (Just node)+			(node:rest) ->+				-- The list of nodes is ordered by cost.+				-- Use any of the ones with equally low+				-- cost.+				let lowestcost = Remote.cost (remote node)+				    samecost = node : takeWhile (\n -> Remote.cost (remote n) == lowestcost) rest+				in do+					n <- liftIO $ getStdRandom $+						randomR (0, length samecost - 1)+					return (Just (samecost !! n))+		+	nonempty (l:ls) fallback+		| null l = nonempty ls fallback+		| otherwise = l+	nonempty [] fallback = fallback

@@ -552,8 +552,8 @@  - If this happens, runs the rollback action and throws an exception.  - The rollback action should remove the data that was transferred.  -}-sendAnnex :: Key -> Annex () -> (FilePath -> FileSize -> Annex a) -> Annex a-sendAnnex key rollback sendobject = go =<< prepSendAnnex' key+sendAnnex :: Key -> Maybe FilePath -> Annex () -> (FilePath -> FileSize -> Annex a) -> Annex a+sendAnnex key o rollback sendobject = go =<< prepSendAnnex' key o   where 	go (Just (f, sz, check)) = do 		r <- sendobject f sz@@ -575,10 +575,10 @@  - Annex monad of the remote that is receiving the object, rather than  - the sender. So it cannot rely on Annex state.  -}-prepSendAnnex :: Key -> Annex (Maybe (FilePath, FileSize, Annex Bool))-prepSendAnnex key = withObjectLoc key $ \f -> do+prepSendAnnex :: Key -> Maybe FilePath -> Annex (Maybe (FilePath, FileSize, Annex Bool))+prepSendAnnex key Nothing = withObjectLoc key $ \f -> do 	let retval c cs = return $ Just -		(fromRawFilePath f+		( fromRawFilePath f 		, inodeCacheFileSize c 		, sameInodeCache f cs 		)@@ -601,9 +601,22 @@ 				, return Nothing 				) 			Nothing -> return Nothing+-- If the provided object file is the annex object file, handle as above.+prepSendAnnex key (Just o) = withObjectLoc key $ \aof ->+	let o' = toRawFilePath o+	in if aof == o'+		then prepSendAnnex key Nothing+		else do+			withTSDelta (liftIO . genInodeCache o') >>= \case+				Nothing -> return Nothing+				Just c -> return $ Just+					( o+					, inodeCacheFileSize c+					, sameInodeCache o' [c]+					) -prepSendAnnex' :: Key -> Annex (Maybe (FilePath, FileSize, Annex (Maybe String)))-prepSendAnnex' key = prepSendAnnex key >>= \case+prepSendAnnex' :: Key -> Maybe FilePath -> Annex (Maybe (FilePath, FileSize, Annex (Maybe String)))+prepSendAnnex' key o = prepSendAnnex key o >>= \case 	Just (f, sz, checksuccess) ->  		let checksuccess' = ifM checksuccess 			( return Nothing

@@ -58,7 +58,7 @@ 	getcopies fs = do 		(untrusted, have) <- trustPartition UnTrusted locs 		(numcopies, mincopies) <- getSafestNumMinCopies' afile key fs-		return (length have, numcopies, mincopies, S.fromList untrusted)+		return (numCopiesCount have, numcopies, mincopies, S.fromList untrusted)  	{- Check that we have enough copies still to drop the content. 	 - When the remote being dropped from is untrusted, it was not

@@ -103,8 +103,8 @@ 		Right username -> [username, at, hostname, ":", reldir] 		Left _ -> [hostname, ":", reldir] -initialize :: Maybe String -> Maybe RepoVersion -> Annex ()-initialize mdescription mversion = checkInitializeAllowed $ \initallowed -> do+initialize :: Annex () -> Maybe String -> Maybe RepoVersion -> Annex ()+initialize startupannex mdescription mversion = checkInitializeAllowed $ \initallowed -> do 	{- Has to come before any commits are made as the shared 	 - clone heuristic expects no local objects. -} 	sharedclone <- checkSharedClone@@ -114,14 +114,14 @@ 	ensureCommit $ Annex.Branch.create  	prepUUID-	initialize' mversion initallowed+	initialize' startupannex mversion initallowed 	 	initSharedClone sharedclone 	 	u <- getUUID 	when (u == NoUUID) $ 		giveup "Failed to read annex.uuid from git config after setting it. This should never happen. Please file a bug report."-	+ 	{- Avoid overwriting existing description with a default 	 - description. -} 	whenM (pure (isJust mdescription) <||> not . M.member u <$> uuidDescMapRaw) $@@ -129,8 +129,8 @@  -- Everything except for uuid setup, shared clone setup, and initial -- description.-initialize' :: Maybe RepoVersion -> InitializeAllowed -> Annex ()-initialize' mversion _initallowed = do+initialize' :: Annex () -> Maybe RepoVersion -> InitializeAllowed -> Annex ()+initialize' startupannex mversion _initallowed = do 	checkLockSupport 	checkFifoSupport 	checkCrippledFileSystem@@ -162,6 +162,10 @@ 	createInodeSentinalFile False 	fixupUnusualReposAfterInit +	-- This is usually run at Annex startup, but when git-annex was+	-- not already initialized, it will not yet have run.+	startupannex+ uninitialize :: Annex () uninitialize = do 	-- Remove hooks that are written when initializing.@@ -203,12 +207,12 @@  -  - Checks repository version and handles upgrades too.  -}-ensureInitialized :: Annex [Remote] -> Annex ()-ensureInitialized remotelist = getInitializedVersion >>= maybe needsinit checkUpgrade+ensureInitialized :: Annex () -> Annex [Remote] -> Annex ()+ensureInitialized startupannex remotelist = getInitializedVersion >>= maybe needsinit checkUpgrade   where 	needsinit = ifM autoInitializeAllowed 		( do-			tryNonAsync (initialize Nothing Nothing) >>= \case+			tryNonAsync (initialize startupannex Nothing Nothing) >>= \case 				Right () -> noop 				Left e -> giveup $ show e ++ "\n" ++ 					"git-annex: automatic initialization failed due to above problems"@@ -256,15 +260,16 @@  -  - Checks repository version and handles upgrades too.  -}-autoInitialize :: Annex [Remote] -> Annex ()+autoInitialize :: Annex () -> Annex [Remote] -> Annex () autoInitialize = autoInitialize' autoInitializeAllowed -autoInitialize' :: Annex Bool -> Annex [Remote] -> Annex ()-autoInitialize' check remotelist = getInitializedVersion >>= maybe needsinit checkUpgrade+autoInitialize' :: Annex Bool -> Annex () -> Annex [Remote] -> Annex ()+autoInitialize' check startupannex remotelist =+	getInitializedVersion >>= maybe needsinit checkUpgrade   where 	needsinit = 		whenM (initializeAllowed <&&> check) $ do-			initialize Nothing Nothing+			initialize startupannex Nothing Nothing 			autoEnableSpecialRemotes remotelist  {- Checks if a repository is initialized. Does not check version for upgrade. -}

@@ -1,6 +1,6 @@ {- git-annex numcopies configuration and checking  -- - Copyright 2014-2021 Joey Hess <id@joeyh.name>+ - Copyright 2014-2024 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -20,6 +20,8 @@ 	defaultNumCopies, 	numCopiesCheck, 	numCopiesCheck',+	numCopiesCheck'',+	numCopiesCount, 	verifyEnoughCopiesToDrop, 	verifiableCopies, 	UnVerifiedCopy(..),@@ -30,6 +32,7 @@ import Types.NumCopies import Logs.NumCopies import Logs.Trust+import Logs.Cluster import Annex.CheckAttr import qualified Remote import qualified Types.Remote as Remote@@ -39,8 +42,10 @@ import qualified Database.Keys  import Control.Exception-import qualified Control.Monad.Catch as M+import qualified Control.Monad.Catch as MC import Data.Typeable+import qualified Data.Set as S+import qualified Data.Map as M  defaultNumCopies :: NumCopies defaultNumCopies = configuredNumCopies 1@@ -197,13 +202,25 @@  numCopiesCheck' :: RawFilePath -> (Int -> Int -> v) -> [UUID] -> Annex v numCopiesCheck' file vs have = do-	needed <- fromNumCopies . fst <$> getFileNumMinCopies file-	let nhave = length have+	needed <- fst <$> getFileNumMinCopies file+	let nhave = numCopiesCount have 	explain (ActionItemTreeFile file) $ Just $ UnquotedString $ 		"has " ++ show nhave ++ " " ++ pluralCopies nhave ++  		", and the configured annex.numcopies is " ++ show needed-	return $ nhave `vs` needed+	return $ numCopiesCheck'' have vs needed +numCopiesCheck'' :: [UUID] -> (Int -> Int -> v) -> NumCopies -> v+numCopiesCheck'' have vs needed =+	let nhave = numCopiesCount have+	in nhave `vs` fromNumCopies needed++{- When a key is logged as present in a node of the cluster,+ - the cluster's UUID will also be in the list, but is not a+ - distinct copy.+ -}+numCopiesCount :: [UUID] -> Int+numCopiesCount = length . filter (not . isClusterUUID)+ data UnVerifiedCopy = UnVerifiedRemote Remote | UnVerifiedHere 	deriving (Ord, Eq) @@ -214,6 +231,7 @@ verifyEnoughCopiesToDrop 	:: String -- message to print when there are no known locations 	-> Key+	-> Maybe UUID -- repo dropping from 	-> Maybe ContentRemovalLock 	-> NumCopies 	-> MinCopies@@ -223,14 +241,14 @@ 	-> (SafeDropProof -> Annex a) -- action to perform the drop 	-> Annex a -- action to perform when unable to drop 	-> Annex a-verifyEnoughCopiesToDrop nolocmsg key removallock neednum needmin skip preverified tocheck dropaction nodropaction = +verifyEnoughCopiesToDrop nolocmsg key dropfrom removallock neednum needmin skip preverified tocheck dropaction nodropaction =  	helper [] [] preverified (nub tocheck) []   where 	helper bad missing have [] lockunsupported = 		liftIO (mkSafeDropProof neednum needmin have removallock) >>= \case 			Right proof -> dropaction proof 			Left stillhave -> do-				notEnoughCopies key neednum needmin stillhave (skip++missing) bad nolocmsg lockunsupported+				notEnoughCopies key dropfrom neednum needmin stillhave (skip++missing) bad nolocmsg lockunsupported 				nodropaction 	helper bad missing have (c:cs) lockunsupported 		| isSafeDrop neednum needmin have removallock =@@ -239,12 +257,17 @@ 				Left stillhave -> helper bad missing stillhave (c:cs) lockunsupported 		| otherwise = case c of 			UnVerifiedHere -> lockContentShared key contverified-			UnVerifiedRemote r -> checkremote r contverified $-				let lockunsupported' = r : lockunsupported-				in Remote.hasKey r key >>= \case-					Right True  -> helper bad missing (mkVerifiedCopy RecentlyVerifiedCopy r : have) cs lockunsupported'-					Left _      -> helper (r:bad) missing have cs lockunsupported'-					Right False -> helper bad (Remote.uuid r:missing) have cs lockunsupported'+			UnVerifiedRemote r+				-- Skip cluster uuids because locking is+				-- not supported with them, instead will+				-- lock individual nodes.+				| isClusterUUID (Remote.uuid r) -> helper bad missing have cs lockunsupported+				| otherwise -> checkremote r contverified $+					let lockunsupported' = r : lockunsupported+					in Remote.hasKey r key >>= \case+						Right True  -> helper bad missing (mkVerifiedCopy RecentlyVerifiedCopy r : have) cs lockunsupported'+						Left _      -> helper (r:bad) missing have cs lockunsupported'+						Right False -> helper bad (Remote.uuid r:missing) have cs lockunsupported' 		  where 			contverified vc = helper bad missing (vc : have) cs lockunsupported @@ -264,11 +287,11 @@ 			-- of exceptions by using DropException. 			let a = lockcontent key $ \v ->  				cont v `catchNonAsync` (throw . DropException)-			a `M.catches`-				[ M.Handler (\ (e :: AsyncException) -> throwM e)-				, M.Handler (\ (e :: SomeAsyncException) -> throwM e)-				, M.Handler (\ (DropException e') -> throwM e')-				, M.Handler (\ (_e :: SomeException) -> fallback)+			a `MC.catches`+				[ MC.Handler (\ (e :: AsyncException) -> throwM e)+				, MC.Handler (\ (e :: SomeAsyncException) -> throwM e)+				, MC.Handler (\ (DropException e') -> throwM e')+				, MC.Handler (\ (_e :: SomeException) -> fallback) 				] 		Nothing -> fallback @@ -277,8 +300,8 @@  instance Exception DropException -notEnoughCopies :: Key -> NumCopies -> MinCopies -> [VerifiedCopy] -> [UUID] -> [Remote] -> String -> [Remote] -> Annex ()-notEnoughCopies key neednum needmin have skip bad nolocmsg lockunsupported = do+notEnoughCopies :: Key -> Maybe UUID -> NumCopies -> MinCopies -> [VerifiedCopy] -> [UUID] -> [Remote] -> String -> [Remote] -> Annex ()+notEnoughCopies key dropfrom neednum needmin have skip bad nolocmsg lockunsupported = do 	showNote "unsafe" 	if length have < fromNumCopies neednum 		then showLongNote $ UnquotedString $@@ -297,7 +320,29 @@ 					++ Remote.listRemoteNames lockunsupported  	Remote.showTriedRemotes bad-	Remote.showLocations True key (map toUUID have++skip) nolocmsg+	-- When dropping from a cluster, don't suggest making the nodes of+	-- the cluster available+	clusternodes <- case mkClusterUUID =<< dropfrom of+		Nothing -> pure []+		Just cu -> do+			clusters <- getClusters+			pure $ maybe [] (map fromClusterNodeUUID . S.toList) $+				M.lookup cu (clusterUUIDs clusters)+	let excludeset = S.fromList $ map toUUID have++skip++clusternodes+	-- Don't suggest making a cluster available when dropping from its+	-- node.+	let exclude u+		| u `S.member` excludeset = pure True+		| otherwise = case (dropfrom, mkClusterUUID u) of+			(Just dropfrom', Just cu) -> do+				clusters <- getClusters+				pure $ case M.lookup cu (clusterUUIDs clusters) of+					Just nodes -> +						ClusterNodeUUID dropfrom' +							`S.member` nodes+					Nothing -> False+			_ -> pure False+	Remote.showLocations True key exclude nolocmsg  pluralCopies :: Int -> String pluralCopies 1 = "copy"@@ -312,17 +357,27 @@  - The return lists also exclude any repositories that are untrusted,  - since those should not be used for verification.  -+ - When dropping from a cluster UUID, its nodes are excluded.+ -+ - Cluster UUIDs are also excluded since locking a key on a cluster+ - is done by locking on individual nodes.+ -  - The UnVerifiedCopy list is cost ordered.  - The VerifiedCopy list contains repositories that are trusted to  - contain the key.  -} verifiableCopies :: Key -> [UUID] -> Annex ([UnVerifiedCopy], [VerifiedCopy]) verifiableCopies key exclude = do-	locs <- Remote.keyLocations key+	locs <- filter (not . isClusterUUID) <$> Remote.keyLocations key 	(remotes, trusteduuids) <- Remote.remoteLocations (Remote.IncludeIgnored False) locs 		=<< trustGet Trusted+	clusternodes <- if any isClusterUUID exclude+		then do+			clusters <- getClusters+			pure $ concatMap (getclusternodes clusters) exclude+		else pure [] 	untrusteduuids <- trustGet UnTrusted-	let exclude' = exclude ++ untrusteduuids+	let exclude' = exclude ++ untrusteduuids ++ clusternodes 	let remotes' = Remote.remotesWithoutUUID remotes (exclude' ++ trusteduuids) 	let verified = map (mkVerifiedCopy TrustedCopy) $ 		filter (`notElem` exclude') trusteduuids@@ -331,3 +386,8 @@ 		then [UnVerifiedHere] 		else [] 	return (herec ++ map UnVerifiedRemote remotes', verified)+  where+	getclusternodes clusters u = case mkClusterUUID u of+		Just cu -> maybe [] (map fromClusterNodeUUID . S.toList) $+			M.lookup cu (clusterUUIDs clusters)+		Nothing -> []

@@ -0,0 +1,211 @@+{- proxying+ -+ - Copyright 2024 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module Annex.Proxy where++import Annex.Common+import P2P.Proxy+import P2P.Protocol+import P2P.IO+import qualified Remote+import qualified Types.Remote as Remote+import qualified Remote.Git+import Remote.Helper.Ssh (openP2PShellConnection', closeP2PShellConnection)+import Annex.Content+import Annex.Concurrent+import Annex.Tmp+import Utility.Tmp.Dir+import Utility.Metered++import Control.Concurrent.STM+import Control.Concurrent.Async+import qualified Data.ByteString.Lazy as L+import qualified System.FilePath.ByteString as P++proxyRemoteSide :: ProtocolVersion -> Bypass -> Remote -> Annex RemoteSide+proxyRemoteSide clientmaxversion bypass r+	| Remote.remotetype r == Remote.Git.remote = +		proxyGitRemoteSide clientmaxversion bypass r+	| otherwise =+		proxySpecialRemoteSide clientmaxversion r++proxyGitRemoteSide :: ProtocolVersion -> Bypass -> Remote -> Annex RemoteSide+proxyGitRemoteSide clientmaxversion bypass r = mkRemoteSide r $+	openP2PShellConnection' r clientmaxversion bypass >>= \case+		Just conn@(OpenConnection (remoterunst, remoteconn, _)) ->+			return $ Just +				( remoterunst+				, remoteconn+				, void $ liftIO $ closeP2PShellConnection conn+				)+		_  -> return Nothing++proxySpecialRemoteSide :: ProtocolVersion -> Remote -> Annex RemoteSide+proxySpecialRemoteSide clientmaxversion r = mkRemoteSide r $ do+	let protoversion = min clientmaxversion maxProtocolVersion+	remoterunst <- Serving (Remote.uuid r) Nothing <$>+		liftIO (newTVarIO protoversion)+	ihdl <- liftIO newEmptyTMVarIO+	ohdl <- liftIO newEmptyTMVarIO+	iwaitv <- liftIO newEmptyTMVarIO+	owaitv <- liftIO newEmptyTMVarIO+	endv <- liftIO newEmptyTMVarIO+	worker <- liftIO . async =<< forkState+		(proxySpecialRemote protoversion r ihdl ohdl owaitv endv)+	let remoteconn = P2PConnection+		{ connRepo = Nothing+		, connCheckAuth = const False+		, connIhdl = P2PHandleTMVar ihdl iwaitv+		, connOhdl = P2PHandleTMVar ohdl owaitv+		, connIdent = ConnIdent (Just (Remote.name r))+		}+	let closeremoteconn = do+		liftIO $ atomically $ putTMVar endv ()+		join $ liftIO (wait worker)+	return $ Just+		( remoterunst+		, remoteconn+		, closeremoteconn+		)++-- Proxy for the special remote, speaking the P2P protocol.+proxySpecialRemote+	:: ProtocolVersion+	-> Remote+	-> TMVar (Either L.ByteString Message)+	-> TMVar (Either L.ByteString Message)+	-> TMVar ()+	-> TMVar ()+	-> Annex ()+proxySpecialRemote protoversion r ihdl ohdl owaitv endv = go+  where+	go :: Annex ()+	go = liftIO receivemessage >>= \case+		Just (CHECKPRESENT k) -> do+			tryNonAsync (Remote.checkPresent r k) >>= \case+				Right True -> liftIO $ sendmessage SUCCESS+				Right False -> liftIO $ sendmessage FAILURE+				Left err -> liftIO $ propagateerror err+			go+		Just (LOCKCONTENT _) -> do+			-- Special remotes do not support locking content.+			liftIO $ sendmessage FAILURE+			go+		Just (REMOVE k) -> do+			tryNonAsync (Remote.removeKey r k) >>= \case+				Right () -> liftIO $ sendmessage SUCCESS+				Left err -> liftIO $ propagateerror err+			go+		Just (PUT (ProtoAssociatedFile af) k) -> do+			proxyput af k+			go+		Just (GET offset (ProtoAssociatedFile af) k) -> do+			proxyget offset af k+			go+		Just (BYPASS _) -> go+		Just (CONNECT _) -> +			-- Not supported and the protocol ends here.+			liftIO $ sendmessage $ CONNECTDONE (ExitFailure 1)	+		Just NOTIFYCHANGE -> do+			liftIO $ sendmessage $+				ERROR "NOTIFYCHANGE unsupported for a special remote"+			go+		Just _ -> giveup "protocol error M"+		Nothing -> return ()++	getnextmessageorend = +		liftIO $ atomically $ +			(Right <$> takeTMVar ohdl)+				`orElse`+			(Left <$> readTMVar endv)++	receivemessage = getnextmessageorend >>= \case+		Right (Right m) -> return (Just m)+		Right (Left _b) -> giveup "unexpected ByteString received from P2P MVar"+		Left () -> return Nothing+	+	receivebytestring = atomically (takeTMVar ohdl) >>= \case+		Left b -> return b+		Right _m -> giveup "did not receive ByteString from P2P MVar"++	sendmessage m = atomically $ putTMVar ihdl (Right m)+	+	sendbytestring b = atomically $ putTMVar ihdl (Left b)++	propagateerror err = sendmessage $ ERROR $+		"proxied special remote reports: " ++ show err++	-- Not using gitAnnexTmpObjectLocation because there might be+	-- several concurrent GET and PUTs of the same key being proxied+	-- from this special remote or others, and each needs to happen+	-- independently. Also, this key is not getting added into the+	-- local annex objects.+	withproxytmpfile k a = withOtherTmp $ \othertmpdir ->+		withTmpDirIn (fromRawFilePath othertmpdir) "proxy" $ \tmpdir ->+			a (toRawFilePath tmpdir P.</> keyFile k)+			+	proxyput af k = do+		liftIO $ sendmessage $ PUT_FROM (Offset 0)+		withproxytmpfile k $ \tmpfile -> do+			let store = tryNonAsync (Remote.storeKey r k af (Just (decodeBS tmpfile)) nullMeterUpdate) >>= \case+				Right () -> liftIO $ sendmessage SUCCESS+				Left err -> liftIO $ propagateerror err+			liftIO receivemessage >>= \case+				Just (DATA (Len _)) -> do+					b <- liftIO receivebytestring+					liftIO $ L.writeFile (fromRawFilePath tmpfile) b+					-- Signal that the whole bytestring+					-- has been received.+					liftIO $ atomically $ putTMVar owaitv ()+					if protoversion > ProtocolVersion 1+						then liftIO receivemessage >>= \case+							Just (VALIDITY Valid) ->+								store+							Just (VALIDITY Invalid) ->+								return ()+							_ -> giveup "protocol error N"+						else store+				_ -> giveup "protocol error O"++	proxyget offset af k = withproxytmpfile k $ \tmpfile -> do+		-- Don't verify the content from the remote,+		-- because the client will do its own verification.+		let vc = Remote.NoVerify+		tryNonAsync (Remote.retrieveKeyFile r k af (fromRawFilePath tmpfile) nullMeterUpdate vc) >>= \case+			Right v ->+				ifM (verifyKeyContentPostRetrieval Remote.RetrievalVerifiableKeysSecure vc v k tmpfile)+					( liftIO $ senddata offset tmpfile+					, liftIO $ sendmessage $+						ERROR "verification of content failed"+					)+			Left err -> liftIO $ propagateerror err+	+	senddata (Offset offset) f = do+		size <- fromIntegral <$> getFileSize f+		let n = max 0 (size - offset)+		sendmessage $ DATA (Len n)+		withBinaryFile (fromRawFilePath f) ReadMode $ \h -> do+			hSeek h AbsoluteSeek offset+			sendbs =<< L.hGetContents h+			-- Important to keep the handle open until+			-- the client responds. The bytestring+			-- could still be lazily streaming out to+			-- the client.+			waitclientresponse+	  where+		sendbs bs = do+			sendbytestring bs+			when (protoversion > ProtocolVersion 0) $+				sendmessage (VALIDITY Valid)+			+		waitclientresponse = +			receivemessage >>= \case+				Just SUCCESS -> return ()+				Just FAILURE -> return ()+				Just _ -> giveup "protocol error P"+				Nothing -> return ()+						

@@ -0,0 +1,67 @@+{- git-annex startup+ -+ - Copyright 2010-2024 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++{-# LANGUAGE CPP #-}++module Annex.Startup where++import Annex.Common+import qualified Annex+import Logs.Cluster++#ifndef mingw32_HOST_OS+import Control.Concurrent.STM+import System.Posix.Signals+#endif++{- Run when starting up the main git-annex program. -}+startup :: Annex ()+startup = do+	startupSignals+	gc <- Annex.getGitConfig+	when (isinitialized gc)+		startupAnnex+  where+	isinitialized gc = annexUUID gc /= NoUUID+		&& isJust (annexVersion gc)++{- Run when starting up the main git-annex program when+ - git-annex has already been initialized.+ - Alternatively, run after initialization.+ -}+startupAnnex :: Annex ()+startupAnnex = doQuietAction $+	-- Logs.Location needs clusters to be loaded before it is used,+	-- in order for a cluster to be treated as the location of keys+	-- that are located in any of its nodes.+	void loadClusters++startupSignals :: Annex ()+startupSignals = do+#ifndef mingw32_HOST_OS+	av <- Annex.getRead Annex.signalactions+	let propagate sig = liftIO $ installhandleronce sig av+	propagate sigINT+	propagate sigQUIT+	propagate sigTERM+	propagate sigTSTP+	propagate sigCONT+	propagate sigHUP+	-- sigWINCH is not propagated; it should not be needed,+	-- and the concurrent-output library installs its own signal+	-- handler for it.+	-- sigSTOP and sigKILL cannot be caught, so will not be propagated.+  where+	installhandleronce sig av = void $+		installHandler sig (CatchOnce (gotsignal sig av)) Nothing+	gotsignal sig av = do+		mapM_ (\a -> a (fromIntegral sig)) =<< atomically (readTVar av)+		raiseSignal sig+		installhandleronce sig av+#else+       return ()+#endif

@@ -55,13 +55,13 @@  -- Upload, supporting canceling detected stalls. upload :: Remote -> Key -> AssociatedFile -> RetryDecider -> NotifyWitness -> Annex Bool-upload r key f d witness = +upload r key af d witness =  	case getStallDetection Upload r of 		Nothing -> go (Just ProbeStallDetection) 		Just StallDetectionDisabled -> go Nothing-		Just sd -> runTransferrer sd r key f d Upload witness+		Just sd -> runTransferrer sd r key af d Upload witness   where- 	go sd = upload' (Remote.uuid r) key f sd d (action . Remote.storeKey r key f) witness+ 	go sd = upload' (Remote.uuid r) key af sd d (action . Remote.storeKey r key af Nothing) witness  -- Upload, not supporting canceling detected stalls upload' :: Observable v => UUID -> Key -> AssociatedFile -> Maybe StallDetection -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v

@@ -6,7 +6,7 @@  - UUIDs of remotes are cached in git config, using keys named  - remote.<name>.annex-uuid  -- - Copyright 2010-2016 Joey Hess <id@joeyh.name>+ - Copyright 2010-2024 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -15,6 +15,7 @@  module Annex.UUID ( 	configkeyUUID,+	configRepoUUID, 	getUUID, 	getRepoUUID, 	getUncachedUUID,@@ -47,6 +48,9 @@ configkeyUUID :: ConfigKey configkeyUUID = annexConfig "uuid" +configRepoUUID :: Git.Repo -> ConfigKey+configRepoUUID r = remoteAnnexConfig r "uuid"+ {- Generates a random UUID, that does not include the MAC address. -} genUUID :: IO UUID genUUID = toUUID <$> U4.nextRandom@@ -82,7 +86,7 @@ 	updatecache u = do 		g <- gitRepo 		when (g /= r) $ storeUUIDIn cachekey u-	cachekey = remoteAnnexConfig r "uuid"+	cachekey = configRepoUUID r  removeRepoUUID :: Annex () removeRepoUUID = do

@@ -19,6 +19,7 @@ import Annex.UUID import Annex.AdjustedBranch import Annex.Action+import Annex.Startup import Types.StandardGroups import Logs.PreferredContent import qualified Annex.Branch@@ -85,7 +86,7 @@  initRepo' :: Maybe String -> Maybe StandardGroup -> Annex () initRepo' desc mgroup = unlessM isInitialized $ do-	initialize desc Nothing+	initialize startupAnnex desc Nothing 	u <- getUUID 	maybe noop (defaultStandardGroup u) mgroup 	{- Ensure branch gets committed right away so it is

@@ -19,7 +19,6 @@ import Types.Distribution import Types.Transfer import Logs.Web-import Logs.Presence import Logs.Location import Annex.Content import Annex.UUID

@@ -1,3 +1,27 @@+git-annex (10.20240701) upstream; urgency=medium++  * git-annex remotes can now act as proxies that provide access to+    their remotes. Configure this with remote.name.annex-proxy+    and the git-annex update proxy command.+  * Clusters are now supported. These are collections of nodes that can+    be accessed as a single entity, accessed by one or more gateway+    repositories.+  * Added git-annex initcluster, updatecluster, and extendcluster commands.+  * Fix a bug where interrupting git-annex while it is updating the+    git-annex branch for an export could later lead to git fsck+    complaining about missing tree objects.+  * Tab completion of options like --from now includes special remotes,+    as well as proxied remotes and clusters.+  * Tab completion of many commands like info and trust now includes+    remotes.+  * P2P protocol version 2.+  * Fix Windows build with Win32 2.13.4++    Thanks, Oleg Tolmatcev+  * When --debugfilter or annex.debugfilter is set, avoid propigating+    debug output from git-annex-shell, since it cannot be filtered.++ -- Joey Hess <id@joeyh.name>  Mon, 01 Jul 2024 15:11:48 -0400+ git-annex (10.20240531) upstream; urgency=medium    * git-remote-annex: New program which allows pushing a git repo to a

@@ -23,6 +23,7 @@ import qualified Git import qualified Git.AutoCorrect import qualified Git.Config+import Annex.Startup import Annex.Action import Annex.Environment import Command

@@ -149,7 +149,7 @@ 				showEndMessage startmsg False 				return False 	-{- Waits for all worker threads to finish and merges their AnnexStates+{- Waits for all worker thrneads to finish and merges their AnnexStates  - back into the current Annex's state.  -} finishCommandActions :: Annex ()

@@ -124,6 +124,10 @@ import qualified Command.FilterProcess import qualified Command.Restage import qualified Command.Undo+import qualified Command.InitCluster+import qualified Command.UpdateCluster+import qualified Command.ExtendCluster+import qualified Command.UpdateProxy import qualified Command.Version import qualified Command.RemoteDaemon #ifdef WITH_ASSISTANT@@ -247,6 +251,10 @@ 	, Command.FilterProcess.cmd 	, Command.Restage.cmd 	, Command.Undo.cmd+	, Command.InitCluster.cmd+	, Command.UpdateCluster.cmd+	, Command.ExtendCluster.cmd+	, Command.UpdateProxy.cmd 	, Command.Version.cmd 	, Command.RemoteDaemon.cmd #ifdef WITH_ASSISTANT

@@ -1,6 +1,6 @@ {- git-annex command-line option parsing  -- - 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.  -}@@ -40,6 +40,7 @@ import Utility.HumanTime import Utility.DataUnits import Annex.Concurrent+import Remote.List  -- Options that are accepted by all git-annex sub-commands, -- although not always used.@@ -108,9 +109,12 @@  {- Parser that accepts all non-option params. -} cmdParams :: CmdParamsDesc -> Parser CmdParams-cmdParams paramdesc = many $ argument str+cmdParams paramdesc = cmdParamsWithCompleter paramdesc completeFiles++cmdParamsWithCompleter :: String -> Mod ArgumentFields String -> Parser CmdParams+cmdParamsWithCompleter paramdesc completers = many $ argument str 	( metavar paramdesc-	<> action "file"+	<> completers 	)  parseAutoOption :: Parser Bool@@ -569,14 +573,34 @@ 		)  completeRemotes :: HasCompleter f => Mod f a-completeRemotes = completer $ mkCompleter $ \input -> do-	r <- maybe (pure Nothing) (Just <$$> Git.Config.read)-		=<< Git.Construct.fromCwd-	return $ filter (input `isPrefixOf`) $-		mapMaybe remoteKeyToRemoteName $-			filter isRemoteUrlKey $-				maybe [] (M.keys . config) r-		+completeRemotes = completer $ mkCompleter $ \input ->+	Git.Construct.fromCwd >>= \case+		Nothing -> return []+		Just g -> completeRemotes' g input++completeRemotes' :: Repo -> [Char] -> IO [[Char]]+completeRemotes' g input = do+	g' <- Git.Config.read g+	state <- Annex.new g'+	Annex.eval state $ do+		Annex.setOutput QuietOutput+		gc <- Annex.getGitConfig+		if isinitialized gc+			then do+				rs <- remoteList+				matches $ map Remote.name rs+			else matches $+				mapMaybe remoteKeyToRemoteName $+					filter isRemoteUrlKey $ +						M.keys $ config g+  where+	isinitialized gc = annexUUID gc /= NoUUID && isJust (annexVersion gc)+	matches = return . filter (input `isPrefixOf`)+ completeBackends :: HasCompleter f => Mod f a completeBackends = completeWith $ 	map (decodeBS . formatKeyVariety . Backend.backendVariety) Backend.builtinList++completeFiles :: HasCompleter f => Mod f a+completeFiles = action "file"+

@@ -1,6 +1,6 @@ {- git-annex-shell main program  -- - 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.  -}@@ -8,6 +8,7 @@ module CmdLine.GitAnnexShell where  import Annex.Common+import qualified Annex import qualified Git.Construct import qualified Git.Config import CmdLine@@ -19,6 +20,11 @@ import Remote.GCrypt (getGCryptUUID) import P2P.Protocol (ServerMode(..)) import Git.Types+import qualified Types.Remote as R+import Logs.Proxy+import Logs.Cluster+import Logs.UUID+import Remote  import qualified Command.ConfigList import qualified Command.NotifyChanges@@ -30,6 +36,7 @@ import qualified Command.DropKey  import qualified Data.Map as M+import qualified Data.Set as S  cmdsMap :: M.Map ServerMode [Command] cmdsMap = M.fromList $ map mk@@ -39,20 +46,22 @@ 	]   where 	readonlycmds = map addAnnexOptions-		[ Command.ConfigList.cmd+		[ notProxyable Command.ConfigList.cmd 		, gitAnnexShellCheck Command.NotifyChanges.cmd 		-- p2pstdio checks the environment variables to-		-- determine the security policy to use+		-- determine the security policy to use, so is safe to+		-- include in the readonly list even though it is not+		-- always readonly 		, gitAnnexShellCheck Command.P2PStdIO.cmd-		, gitAnnexShellCheck Command.InAnnex.cmd-		, gitAnnexShellCheck Command.SendKey.cmd+		, notProxyable (gitAnnexShellCheck Command.InAnnex.cmd)+		, notProxyable (gitAnnexShellCheck Command.SendKey.cmd) 		] 	appendcmds = readonlycmds ++ map addAnnexOptions-		[ gitAnnexShellCheck Command.RecvKey.cmd+		[ notProxyable (gitAnnexShellCheck Command.RecvKey.cmd) 		] 	allcmds = appendcmds ++ map addAnnexOptions-		[ gitAnnexShellCheck Command.DropKey.cmd-		, Command.GCryptSetup.cmd+		[ notProxyable (gitAnnexShellCheck Command.DropKey.cmd)+		, notProxyable Command.GCryptSetup.cmd 		]  	mk (s, l) = (s, map (adddirparam . noMessages) l)@@ -77,17 +86,23 @@   where 	checkUUID expected = getUUID >>= check 	  where-		check u | u == toUUID expected = noop 		check NoUUID = checkGCryptUUID expected-		check u = unexpectedUUID expected u+		check u +			| u == toUUID expected = noop+			| otherwise = +				unlessM (checkProxy (toUUID expected) u) $+					unexpectedUUID expected u+	 	checkGCryptUUID expected = check =<< getGCryptUUID True =<< gitRepo 	  where 		check (Just u) | u == toUUID expected = noop 		check Nothing = unexpected expected "uninitialized repository" 		check (Just u) = unexpectedUUID expected u+	 	unexpectedUUID expected u = unexpected expected $ "UUID " ++ fromUUID u 	unexpected expected s = giveup $ 		"expected repository UUID " ++ expected ++ " but found " ++ s+				  run :: [String] -> IO () run [] = failure@@ -104,6 +119,11 @@ 	| cmd `elem` builtins = failure 	| otherwise = external c +failure :: IO ()+failure = giveup $ "bad parameters\n\n" ++ usage h cmdsList+  where+	h = "git-annex-shell [-c] command [parameters ...] [option ...]"+ builtins :: [String] builtins = map cmdname cmdsList @@ -165,7 +185,60 @@ 	| field == fieldName autoInit = fieldCheck autoInit val 	| otherwise = False -failure :: IO ()-failure = giveup $ "bad parameters\n\n" ++ usage h cmdsList+{- Check if this repository can proxy for a specified remote uuid,+ - and if so enable proxying for it. -}+checkProxy :: UUID -> UUID -> Annex Bool+checkProxy remoteuuid ouruuid = M.lookup ouruuid <$> getProxies >>= \case+	Nothing -> return False+	-- This repository has (or had) proxying enabled. So it's+	-- ok to display error messages that talk about proxies.+	Just proxies ->+		case filter (\p -> proxyRemoteUUID p == remoteuuid) (S.toList proxies) of+			[] -> notconfigured+			ps -> case mkClusterUUID remoteuuid of+				Just cu -> proxyforcluster cu+				Nothing -> proxyfor ps   where-	h = "git-annex-shell [-c] command [parameters ...] [option ...]"+	-- This repository may have multiple remotes that access the same+	-- repository. Proxy for the lowest cost one that is configured to+	-- be used as a proxy.+	proxyfor ps = do+		rs <- concat . byCost <$> remoteList+		myclusters <- annexClusters <$> Annex.getGitConfig+		let sameuuid r = uuid r == remoteuuid+		let samename r p = name r == proxyRemoteName p+		case headMaybe (filter (\r -> sameuuid r && proxyisconfigured rs myclusters r && any (samename r) ps) rs) of+			Nothing -> notconfigured+			Just r -> do+				Annex.changeState $ \st ->+					st { Annex.proxyremote = Just (Right r) }+				return True+	+	-- Only proxy for a remote when the git configuration+	-- allows it. This is important to prevent changes to +	-- the git-annex branch making git-annex-shell unexpectedly+	-- proxy for remotes.+	proxyisconfigured rs myclusters r+		| remoteAnnexProxy (R.gitconfig r) = True+		-- Proxy for remotes that are configured as cluster nodes.+		| any (`M.member` myclusters) (fromMaybe [] $ remoteAnnexClusterNode $ R.gitconfig r) = True+		-- Proxy for a remote when it is proxied by another remote+		-- which is itself configured as a cluster gateway.+		| otherwise = case remoteAnnexProxiedBy (R.gitconfig r) of+			Just proxyuuid -> not $ null $ +				concatMap (remoteAnnexClusterGateway . R.gitconfig) $+					filter (\p -> R.uuid p == proxyuuid) rs+			Nothing -> False++	proxyforcluster cu = do+		clusters <- getClusters+		if M.member cu (clusterUUIDs clusters)+			then do+				Annex.changeState $ \st ->+					st { Annex.proxyremote = Just (Left cu) }+				return True+			else notconfigured++	notconfigured = M.lookup remoteuuid <$> uuidDescMap >>= \case+		Just desc -> giveup $ "not configured to proxy for repository " ++ fromUUIDDesc desc+		Nothing -> return False

@@ -1,6 +1,6 @@ {- git-annex-shell checks  -- - Copyright 2012 Joey Hess <id@joeyh.name>+ - Copyright 2012-2024 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -82,3 +82,12 @@   where 	okforshell = unlessM (isInitialized <||> isJust . gcryptId <$> Annex.getGitConfig) $ 		giveup "Not a git-annex or gcrypt repository."++{- Used for Commands that don't support proxying. -}+notProxyable :: Command -> Command+notProxyable c = addCheck GitAnnexShellNotProxyable checkok c+  where+	checkok = Annex.getState Annex.proxyremote >>= \case+		Nothing -> return ()+		Just _ -> giveup $ "Cannot proxy " ++ cmdname c ++ " command."+

@@ -30,6 +30,7 @@ import qualified Remote.External import Remote.Helper.Encryptable (parseEncryptionMethod) import Annex.Transfer+import Annex.Startup import Backend.GitRemoteAnnex import Config import Types.Key@@ -1173,7 +1174,7 @@ 						inRepo $ Git.Branch.delete Annex.Branch.fullname 	ifM (Annex.Branch.hasSibling <&&> nonbuggygitversion) 		( do-			autoInitialize' (pure True) remoteList+			autoInitialize' (pure True) startupAnnex remoteList 			differences <- allDifferences <$> recordedDifferences 			when (differences /= mempty) $ 				deletebundleobjects

@@ -58,7 +58,7 @@ 			<$> loadP2PRemoteAuthToken (TorAnnex address port) 		myuuid <- getUUID 		g <- Annex.gitRepo-		conn <- liftIO $ connectPeer g (TorAnnex address port)+		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

@@ -23,6 +23,7 @@ import Options.Applicative as ReExported hiding (command) import qualified Git import Annex.Init+import Annex.Startup import Utility.Daemon import Types.Transfer import Types.ActionItem as ReExported@@ -39,6 +40,10 @@ withParams :: (CmdParams -> v) -> CmdParamsDesc -> Parser v withParams mkseek paramdesc = mkseek <$> cmdParams paramdesc +withParams' :: (CmdParams -> v) -> Mod ArgumentFields String -> String -> Parser v+withParams' mkseek completers paramdesc = mkseek+	<$> cmdParamsWithCompleter paramdesc completers+ {- Uses the supplied option parser, which yields a deferred parse,  - and calls finishParse on the result before passing it to the  - CommandSeek constructor. -}@@ -125,7 +130,7 @@ commonChecks = [repoExists]  repoExists :: CommandCheck-repoExists = CommandCheck RepoExists (ensureInitialized remoteList)+repoExists = CommandCheck RepoExists (ensureInitialized startupAnnex remoteList)  notBareRepo :: Command -> Command notBareRepo = addCheck CheckNotBareRepo checkNotBareRepo

@@ -17,6 +17,7 @@ import Utility.HumanTime import Assistant.Install import Remote.List+import Annex.Startup  import Control.Concurrent.Async @@ -63,7 +64,7 @@ 		stop 	| otherwise = do 		liftIO ensureInstalled-		ensureInitialized remoteList+		ensureInitialized startupAnnex remoteList 		Command.Watch.start True (daemonOptions o) (startDelayOption o)  startNoRepo :: AssistantOptions -> IO ()

@@ -16,6 +16,7 @@ import Remote.GCrypt (coreGCryptId) import qualified CmdLine.GitAnnexShell.Fields as Fields import CmdLine.GitAnnexShell.Checks+import Annex.Startup  cmd :: Command cmd = noCommit $ dontCheck repoExists $@@ -47,7 +48,7 @@ 		else ifM (Annex.Branch.hasSibling <||> (isJust <$> Fields.getField Fields.autoInit)) 			( do 				liftIO checkNotReadOnly-				initialize Nothing Nothing+				initialize startupAnnex Nothing Nothing 				getUUID 			, return NoUUID 			)

@@ -22,7 +22,7 @@ data DeadOptions = DeadRemotes [RemoteName] | DeadKeys [Key]  optParser :: CmdParamsDesc -> Parser DeadOptions-optParser desc = (DeadRemotes <$> cmdParams desc)+optParser desc = (DeadRemotes <$> cmdParamsWithCompleter desc completeRemotes) 	<|> (DeadKeys <$> many (option (str >>= parseKey) 		( long "key" <> metavar paramKey 		<> help "keys whose content has been irretrievably lost"

@@ -14,8 +14,8 @@ cmd :: Command cmd = command "describe" SectionSetup 	"change description of a repository"-	(paramPair paramRemote paramDesc)-	(withParams seek)+	(paramPair paramRepository paramDesc)+	(withParams' seek completeRemotes)  seek :: CmdParams -> CommandSeek seek = withWords (commandAction . start)

@@ -205,7 +205,7 @@ 	ifM (Annex.getRead Annex.force) 		( dropaction Nothing 		, ifM (checkRequiredContent pcc dropfrom key afile)-			( verifyEnoughCopiesToDrop nolocmsg key +			( verifyEnoughCopiesToDrop nolocmsg key (Just dropfrom) 				contentlock numcopies mincopies 				skip preverified check 					(dropaction . Just)@@ -253,7 +253,7 @@ 			uuid <- getUUID 			let remoteuuid = fromMaybe uuid $ Remote.uuid <$> mremote 			locs' <- trustExclude UnTrusted $ filter (/= remoteuuid) locs-			if length locs' >= fromNumCopies numcopies+			if numCopiesCheck'' locs' (>=) numcopies 				then a numcopies mincopies 				else stop 		| otherwise = a numcopies mincopies

@@ -105,11 +105,10 @@  	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."-	check n addrs@(addr:_) = do-		g <- Annex.gitRepo+	check n addrs@(addr:_) = 		-- Connect but don't bother trying to auth, 		-- we just want to know if the tor circuit works.-		liftIO (tryNonAsync $ connectPeer g addr) >>= \case+		liftIO (tryNonAsync $ connectPeer Nothing addr) >>= \case 			Left e -> do 				warning $ UnquotedString $ "Unable to connect to hidden service. It may not yet have propagated to the Tor network. (" ++ show e ++ ") Will retry.." 				liftIO $ threadDelaySeconds (Seconds 2)@@ -123,22 +122,21 @@ 	-- service's socket, start a listener. This is only run during the 	-- check, and it refuses all auth attempts. 	startlistener = do-		r <- Annex.gitRepo 		u <- getUUID 		msock <- torSocketFile 		case msock of 			Just sockfile -> ifM (liftIO $ haslistener sockfile) 				( liftIO $ async $ return ()-				, liftIO $ async $ runlistener sockfile u r+				, liftIO $ async $ runlistener sockfile u 				) 			Nothing -> giveup "Could not find socket file in Tor configuration!" 	-	runlistener sockfile u r = serveUnixSocket sockfile $ \h -> do+	runlistener sockfile u = serveUnixSocket sockfile $ \h -> do 		let conn = P2PConnection-			{ connRepo = r+			{ connRepo = Nothing 			, connCheckAuth = const False-			, connIhdl = h-			, connOhdl = h+			, connIhdl = P2PHandle h+			, connOhdl = P2PHandle h 			, connIdent = ConnIdent Nothing 			} 		runst <- mkRunState Client

@@ -304,7 +304,7 @@ 				alwaysUpload (uuid r) ek af Nothing stdRetry $ \pm -> do 					let rollback = void $ 						performUnexport r db [ek] loc-					sendAnnex ek rollback $ \f _sz ->+					sendAnnex ek Nothing rollback $ \f _sz -> 						Remote.action $ 							storer f ek loc pm 			, do

@@ -0,0 +1,58 @@+{- git-annex command+ -+ - Copyright 2024 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++{-# LANGUAGE OverloadedStrings #-}++module Command.ExtendCluster where++import Command+import qualified Annex+import Types.Cluster+import Config+import Types.GitConfig+import qualified Remote+import qualified Command.UpdateCluster++import qualified Data.Map as M++cmd :: Command+cmd = command "extendcluster" SectionSetup "add an gateway to a cluster"+	(paramPair paramRemote paramName) (withParams seek)++seek :: CmdParams -> CommandSeek+seek (remotename:clustername:[]) = Remote.byName (Just clusterremotename) >>= \case+	Just clusterremote -> Remote.byName (Just remotename) >>= \case+		Just gatewayremote -> +			case mkClusterUUID (Remote.uuid clusterremote) of+				Just cu -> do+					commandAction $ start cu clustername gatewayremote+					Command.UpdateCluster.seek []+				Nothing -> giveup $ clusterremotename +					++ " is not a cluster remote."+		Nothing -> giveup $ "No remote named " ++ remotename ++ " exists."+	Nothing -> giveup $ "Expected to find a cluster remote named " +		++ clusterremotename+		++ " that is accessed via " ++ remotename+		++ ", but there is no such remote. Perhaps you need to"+		++ "git fetch from " ++ remotename +		++ ", or git-annex updatecluster needs to be run there?"+  where+	clusterremotename = remotename ++ "-" ++ clustername+seek _ = giveup "Expected two parameters, gateway and clustername."++start :: ClusterUUID -> String -> Remote -> CommandStart+start cu clustername gatewayremote = starting "extendcluster" ai si $ do+	myclusters <- annexClusters <$> Annex.getGitConfig+	let setcus f = setConfig f (fromUUID (fromClusterUUID cu))+	unless (M.member clustername myclusters) $ do+		setcus $ annexConfig ("cluster." <> encodeBS clustername)+	setcus $ remoteAnnexConfig gatewayremote $ +		remoteGitConfigKey ClusterGatewayField+	next $ return True+  where+	ai = ActionItemOther (Just (UnquotedString clustername))+	si = SeekInput [clustername]

@@ -573,7 +573,7 @@ 	locs <- loggedLocations key 	(untrustedlocations, otherlocations) <- trustPartition UnTrusted locs 	(deadlocations, safelocations) <- trustPartition DeadTrusted otherlocations-	let present = length safelocations+	let present = numCopiesCount safelocations 	if present < fromNumCopies numcopies 		then ifM (checkDead key) 			( do

@@ -108,7 +108,8 @@ 				Remote.showTriedRemotes remotes 				showlocs (map Remote.uuid remotes) 				return False-	showlocs exclude = Remote.showLocations False key exclude+	showlocs exclude = Remote.showLocations False key+		(\u -> pure (u `elem` exclude)) 		"No other repository is known to contain the file." 	-- This check is to avoid an ugly message if a remote is a 	-- drive that is not mounted.

@@ -20,7 +20,7 @@  cmd :: Command cmd = noMessages $ command "group" SectionSetup "add a repository to a group"-	(paramPair paramRemote paramDesc) (seek <$$> optParser)+	(paramPair paramRepository paramDesc) (seek <$$> optParser)  data GroupOptions = GroupOptions 	{ cmdparams :: CmdParams@@ -29,7 +29,7 @@  optParser :: CmdParamsDesc -> Parser GroupOptions optParser desc = GroupOptions-	<$> cmdParams desc+	<$> cmdParamsWithCompleter desc completeRemotes 	<*> switch 		( long "list" 		<> help "list all currently defined groups"

@@ -319,7 +319,7 @@ 	(needcopies, mincopies) <- getFileNumMinCopies destfile  	(tocheck, preverified) <- verifiableCopies key []-	verifyEnoughCopiesToDrop [] key Nothing needcopies mincopies [] preverified tocheck+	verifyEnoughCopiesToDrop [] key Nothing Nothing needcopies mincopies [] preverified tocheck 		(const yes) no  seekRemote :: Remote -> Branch -> Maybe TopFilePath -> Bool -> CheckGitIgnore -> [String] -> CommandSeek

@@ -116,7 +116,7 @@  optParser :: CmdParamsDesc -> Parser InfoOptions optParser desc = InfoOptions-	<$> cmdParams desc+	<$> cmdParamsWithCompleter desc (completeFiles <> completeRemotes) 	<*> switch 		( long "bytes" 		<> help "display file sizes in bytes"

@@ -12,6 +12,7 @@ import Command import Annex.Init import Annex.Version+import Annex.Startup import Types.RepoVersion import qualified Annex.SpecialRemote @@ -77,7 +78,7 @@ 			Just v | v /= wantversion -> 				giveup $ "This repository is already a initialized with version " ++ show (fromRepoVersion v) ++ ", not changing to requested version." 			_ -> noop-	initialize+	initialize startupAnnex 		(if null (initDesc os) then Nothing else Just (initDesc os)) 		(initVersion os) 	unless (noAutoEnable os)

@@ -0,0 +1,50 @@+{- git-annex command+ -+ - Copyright 2024 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++{-# LANGUAGE OverloadedStrings #-}++module Command.InitCluster where++import Command+import qualified Annex+import Types.Cluster+import Logs.UUID+import Config+import Annex.UUID+import Git.Types+import Git.Remote (isLegalName)++import qualified Data.Map as M++cmd :: Command+cmd = command "initcluster" SectionSetup "initialize a new cluster"+	(paramPair paramName paramDesc) (withParams seek)++seek :: CmdParams -> CommandSeek+seek (clustername:desc:[]) = commandAction $+	start clustername (toUUIDDesc desc)+seek (clustername:[]) = commandAction $+	start clustername $ toUUIDDesc ("cluster " ++ clustername)+seek _ = giveup "Expected two parameters, name and description."++start :: RemoteName -> UUIDDesc -> CommandStart+start clustername desc = starting "initcluster" ai si $ do+	unless (isLegalName clustername) $+		giveup "That cluster name is not a valid git remote name."++	myclusters <- annexClusters <$> Annex.getGitConfig+	unless (M.member clustername myclusters) $ do+		cu <- fromMaybe (giveup "unable to generate a cluster UUID") +			<$> genClusterUUID <$> liftIO genUUID+		setConfig (annexConfig ("cluster." <> encodeBS clustername))+			(fromUUID (fromClusterUUID cu))+		describeUUID (fromClusterUUID cu) desc++	next $ return True+  where+	ai = ActionItemOther (Just (UnquotedString clustername))+	si = SeekInput [clustername]

@@ -1,6 +1,6 @@ {- git-annex command  -- - 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.  -}@@ -16,11 +16,11 @@ import qualified Remote import Annex.UUID import Annex.Transfer-import Logs.Presence import Logs.Trust import Logs.File import Logs.Location import Annex.NumCopies+import Types.Cluster  import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy as L@@ -194,7 +194,7 @@ 				DropCheckNumCopies -> do 					(numcopies, mincopies) <- getSafestNumMinCopies afile key 					(tocheck, verified) <- verifiableCopies key [srcuuid]-					verifyEnoughCopiesToDrop "" key (Just contentlock)+					verifyEnoughCopiesToDrop "" key (Just srcuuid) (Just contentlock) 						 numcopies mincopies [srcuuid] verified 						 (UnVerifiedRemote dest : tocheck) 						 (drophere setpresentremote contentlock . showproof)@@ -300,7 +300,7 @@ 		DropCheckNumCopies -> do 			(numcopies, mincopies) <- getSafestNumMinCopies afile key 			(tocheck, verified) <- verifiableCopies key [Remote.uuid src]-			verifyEnoughCopiesToDrop "" key Nothing numcopies mincopies [Remote.uuid src] verified+			verifyEnoughCopiesToDrop "" key (Just (Remote.uuid src)) Nothing numcopies mincopies [Remote.uuid src] verified 				(adjusttocheck tocheck) (dropremote . showproof) faileddropremote 		DropWorse -> faileddropremote   where@@ -503,7 +503,8 @@  - On the other hand, when the destination repository did not start  - with a copy of a file, it can be dropped from the source without  - making numcopies worse, so the move is allowed even if numcopies- - is not met.+ - is not met. (However, when the source is a cluster, dropping from it + - drops from all nodes, and so numcopies must be checked.)  -  - Similarly, a file can move from an untrusted repository to another  - untrusted repository, even if that is the only copy of the file.@@ -520,7 +521,7 @@ willDropMakeItWorse :: UUID -> UUID -> DestStartedWithCopy -> Key -> AssociatedFile -> Annex DropCheck willDropMakeItWorse srcuuid destuuid (DestStartedWithCopy deststartedwithcopy _) key afile = 	ifM (Command.Drop.checkRequiredContent (Command.Drop.PreferredContentChecked False) srcuuid key afile)-		( if deststartedwithcopy+		( if deststartedwithcopy || isClusterUUID srcuuid 			then unlessforced DropCheckNumCopies 			else ifM checktrustlevel 				( return DropAllowed

@@ -291,7 +291,7 @@ setupLink :: RemoteName -> P2PAddressAuth -> Annex LinkResult setupLink remotename (P2PAddressAuth addr authtoken) = do 	g <- Annex.gitRepo-	cv <- liftIO $ tryNonAsync $ connectPeer g addr+	cv <- liftIO $ tryNonAsync $ connectPeer (Just g) addr 	case cv of 		Left e -> return $ ConnectionError $ "Unable to connect with peer. Please check that the peer is connected to the network, and try again. ("  ++ show e ++ ")" 		Right conn -> do

@@ -1,6 +1,6 @@ {- git-annex command  -- - Copyright 2018 Joey Hess <id@joeyh.name>+ - Copyright 2018-2024 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -10,10 +10,16 @@ import Command import P2P.IO import P2P.Annex+import P2P.Proxy import qualified P2P.Protocol as P2P import qualified Annex+import Annex.Proxy import Annex.UUID import qualified CmdLine.GitAnnexShell.Checks as Checks+import Logs.Location+import Logs.Cluster+import Annex.Cluster+import qualified Remote  import System.IO.Error @@ -35,16 +41,76 @@ 			(True, _) -> P2P.ServeReadOnly 			(False, True) -> P2P.ServeAppendOnly 			(False, False) -> P2P.ServeReadWrite+	Annex.getState Annex.proxyremote >>= \case+		Nothing ->+			performLocal theiruuid servermode+		Just (Right r) ->+			performProxy theiruuid servermode r+		Just (Left clusteruuid) -> +			performProxyCluster theiruuid clusteruuid servermode++performLocal :: UUID -> P2P.ServerMode -> CommandPerform+performLocal theiruuid servermode = do 	myuuid <- getUUID-	conn <- stdioP2PConnection <$> Annex.gitRepo+	let conn = stdioP2PConnection Nothing 	let server = do 		P2P.net $ P2P.sendMessage (P2P.AUTH_SUCCESS myuuid) 		P2P.serveAuthed servermode myuuid 	runst <- liftIO $ mkRunState $ Serving theiruuid Nothing-	runFullProto runst conn server >>= \case-		Right () -> done-		-- Avoid displaying an error when the client hung up on us.-		Left (ProtoFailureIOError e) | isEOFError e -> done-		Left e -> giveup (describeProtoFailure e)+	p2pErrHandler noop (const p2pDone) (runFullProto runst conn server)++performProxy :: UUID -> P2P.ServerMode -> Remote -> CommandPerform+performProxy clientuuid servermode r = do+	clientside <- proxyClientSide clientuuid+	getClientProtocolVersion (Remote.uuid r) clientside +		(withclientversion clientside)+		(p2pErrHandler noop)   where-	done = next $ return True+	withclientversion clientside (Just (clientmaxversion, othermsg)) = do+		remoteside <- proxyRemoteSide clientmaxversion mempty r+		protocolversion <- either (const (min P2P.maxProtocolVersion clientmaxversion)) id+			<$> runRemoteSide remoteside +				(P2P.net P2P.getProtocolVersion)+		concurrencyconfig <- noConcurrencyConfig+		let closer = do+			closeRemoteSide remoteside+			p2pDone+		let errhandler = p2pErrHandler (closeRemoteSide remoteside)+		let runproxy othermsg' = proxy closer proxymethods+			servermode clientside+			(Remote.uuid r)+			(singleProxySelector remoteside)+			concurrencyconfig+			protocolversion othermsg' errhandler+		sendClientProtocolVersion clientside othermsg protocolversion+			runproxy errhandler+	withclientversion _ Nothing = p2pDone+	+	proxymethods = ProxyMethods+		{ removedContent = \u k -> logChange k u InfoMissing+		, addedContent = \u k -> logChange k u InfoPresent+		}++performProxyCluster :: UUID -> ClusterUUID -> P2P.ServerMode -> CommandPerform+performProxyCluster clientuuid clusteruuid servermode = do+	clientside <- proxyClientSide clientuuid+	proxyCluster clusteruuid p2pDone servermode clientside p2pErrHandler++proxyClientSide :: UUID -> Annex ClientSide+proxyClientSide clientuuid = do+	clientrunst <- liftIO (mkRunState $ Serving clientuuid Nothing)+	ClientSide clientrunst <$> liftIO (stdioP2PConnectionDupped Nothing)++p2pErrHandler :: Annex () -> (a -> CommandPerform) -> Annex (Either ProtoFailure a) -> CommandPerform+p2pErrHandler closeconn cont a = a >>= \case+	-- Avoid displaying an error when the client hung up on us.+	Left (ProtoFailureIOError e) | isEOFError e -> do+		closeconn+		p2pDone+	Left e -> do+		closeconn+		giveup (describeProtoFailure e)+	Right v -> cont v++p2pDone :: CommandPerform+p2pDone = next $ return True

@@ -10,6 +10,7 @@ import Command import Annex.Init import Annex.UUID+import Annex.Startup import qualified Remote import qualified Annex.SpecialRemote 	@@ -36,6 +37,6 @@ 		then return $ toUUID s 		else Remote.nameToUUID s 	storeUUID u-	checkInitializeAllowed $ initialize' Nothing+	checkInitializeAllowed $ initialize' startupAnnex Nothing 	Annex.SpecialRemote.autoEnable 	next $ return True

@@ -15,7 +15,8 @@ cmd = withAnnexOptions [jsonOptions] $ 	command "semitrust" SectionSetup  		"return repository to default trust level"-		(paramRepeating paramRepository) (withParams seek)+		(paramRepeating paramRepository)+		(withParams' seek completeRemotes)  seek :: CmdParams -> CommandSeek seek = trustCommand "semitrust" SemiTrusted

@@ -32,7 +32,7 @@ 		<$> getField "RsyncOptions" 	ifM (inAnnex key) 		( fieldTransfer Upload key $ \_p ->-			sendAnnex key rollback $ \f _sz -> +			sendAnnex key Nothing rollback $ \f _sz ->  				liftIO $ rsyncServerSend (map Param opts) f 		, do 			warning "requested key is not present"

@@ -302,7 +302,7 @@ 		tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) (fromRawFilePath dest) nullMeterUpdate (RemoteVerify r)) >>= \case 			Right v -> return (True, v) 			Left _ -> return (False, UnVerified)-	store r k = Remote.storeKey r k (AssociatedFile Nothing) nullMeterUpdate+	store r k = Remote.storeKey r k (AssociatedFile Nothing) Nothing nullMeterUpdate 	remove r k = Remote.removeKey r k  testExportTree :: RunAnnex -> Annex (Maybe Remote) -> Annex Key -> Annex Key -> [TestTree]@@ -368,7 +368,7 @@ 	[ check isLeft "removeKey" $ \r k -> 		Remote.removeKey r k 	, check isLeft "storeKey" $ \r k -> -		Remote.storeKey r k (AssociatedFile Nothing) nullMeterUpdate+		Remote.storeKey r k (AssociatedFile Nothing) Nothing nullMeterUpdate 	, check (`notElem` [Right True, Right False]) "checkPresent" $ \r k -> 		Remote.checkPresent r k 	, check (== Right False) "retrieveKeyFile" $ \r k ->

@@ -50,9 +50,9 @@ 	FromRemote src -> fromPerform key (fileOption o) =<< getParsed src  toPerform :: Key -> AssociatedFile -> Remote -> CommandPerform-toPerform key file remote = go Upload file $-	upload' (uuid remote) key file Nothing stdRetry $ \p -> do-		tryNonAsync (Remote.storeKey remote key file p) >>= \case+toPerform key af remote = go Upload af $+	upload' (uuid remote) key af Nothing stdRetry $ \p -> do+		tryNonAsync (Remote.storeKey remote key af Nothing p) >>= \case 			Right () -> do 				Remote.logStatus remote key InfoPresent 				return True@@ -61,10 +61,10 @@ 				return False  fromPerform :: Key -> AssociatedFile -> Remote -> CommandPerform-fromPerform key file remote = go Upload file $-	download' (uuid remote) key file Nothing stdRetry $ \p ->-		logStatusAfter key $ getViaTmp (retrievalSecurityPolicy remote) vc key file Nothing $ \t ->-			tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p vc) >>= \case+fromPerform key af remote = go Upload af $+	download' (uuid remote) key af Nothing stdRetry $ \p ->+		logStatusAfter key $ getViaTmp (retrievalSecurityPolicy remote) vc key af Nothing $ \t ->+			tryNonAsync (Remote.retrieveKeyFile remote key af (fromRawFilePath t) p vc) >>= \case 				Right v -> return (True, v)	 				Left e -> do 					warning (UnquotedString (show e))

@@ -38,20 +38,20 @@ 	runRequests readh writeh runner 	stop   where-	runner (TransferRequest direction remote key file)-		| direction == Upload = notifyTransfer direction file $-			upload' (Remote.uuid remote) key file Nothing stdRetry $ \p -> do-				tryNonAsync (Remote.storeKey remote key file p) >>= \case+	runner (TransferRequest direction remote key af)+		| direction == Upload = notifyTransfer direction af $+			upload' (Remote.uuid remote) key af Nothing stdRetry $ \p -> do+				tryNonAsync (Remote.storeKey remote key af Nothing p) >>= \case 					Left e -> do 						warning (UnquotedString (show e)) 						return False 					Right () -> do 						Remote.logStatus remote key InfoPresent 						return True-		| otherwise = notifyTransfer direction file $-			download' (Remote.uuid remote) key file Nothing stdRetry $ \p ->-				logStatusAfter key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file Nothing $ \t -> do-					r <- tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p (RemoteVerify remote)) >>= \case+		| otherwise = notifyTransfer direction af $+			download' (Remote.uuid remote) key af Nothing stdRetry $ \p ->+				logStatusAfter key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key af Nothing $ \t -> do+					r <- tryNonAsync (Remote.retrieveKeyFile remote key af (fromRawFilePath t) p (RemoteVerify remote)) >>= \case 						Left e -> do 							warning (UnquotedString (show e)) 							return (False, UnVerified)

@@ -42,27 +42,27 @@ 	runRequests readh writeh runner 	stop   where-	runner (UploadRequest _ key (TransferAssociatedFile file)) remote =+	runner (UploadRequest _ key (TransferAssociatedFile af)) remote = 		-- This is called by eg, Annex.Transfer.upload, 		-- so caller is responsible for doing notification, 		-- and for retrying, and updating location log, 		-- and stall canceling.-		upload' (Remote.uuid remote) key file Nothing noRetry-			(Remote.action . Remote.storeKey remote key file)+		upload' (Remote.uuid remote) key af Nothing noRetry+			(Remote.action . Remote.storeKey remote key af Nothing) 			noNotification-	runner (DownloadRequest _ key (TransferAssociatedFile file)) remote =+	runner (DownloadRequest _ key (TransferAssociatedFile af)) remote = 		-- This is called by eg, Annex.Transfer.download 		-- so caller is responsible for doing notification 		-- and for retrying, and updating location log, 		-- and stall canceling.-		let go p = getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file Nothing $ \t -> do-			Remote.verifiedAction (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p (RemoteVerify remote))-		in download' (Remote.uuid remote) key file Nothing noRetry go +		let go p = getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key af Nothing $ \t -> do+			Remote.verifiedAction (Remote.retrieveKeyFile remote key af (fromRawFilePath t) p (RemoteVerify remote))+		in download' (Remote.uuid remote) key af Nothing noRetry go  			noNotification-	runner (AssistantUploadRequest _ key (TransferAssociatedFile file)) remote =-		notifyTransfer Upload file $-			upload' (Remote.uuid remote) key file Nothing stdRetry $ \p -> do-				tryNonAsync (Remote.storeKey remote key file p) >>= \case+	runner (AssistantUploadRequest _ key (TransferAssociatedFile af)) remote =+		notifyTransfer Upload af $+			upload' (Remote.uuid remote) key af Nothing stdRetry $ \p -> do+				tryNonAsync (Remote.storeKey remote key af Nothing p) >>= \case 					Left e -> do 						warning (UnquotedString (show e)) 						return False

@@ -19,7 +19,8 @@ cmd :: Command cmd = withAnnexOptions [jsonOptions] $ 	command "trust" SectionSetup "trust a repository"-		(paramRepeating paramRepository) (withParams seek)+		(paramRepeating paramRepository)+		(withParams' seek completeRemotes)  seek :: CmdParams -> CommandSeek seek = trustCommand "trust" Trusted

@@ -16,7 +16,8 @@  cmd :: Command cmd = command "ungroup" SectionSetup "remove a repository from a group"-	(paramPair paramRemote paramDesc) (withParams seek)+	(paramPair paramRemote paramDesc)+		(withParams' seek completeRemotes)  seek :: CmdParams -> CommandSeek seek = withWords (commandAction . start)

@@ -14,7 +14,8 @@ cmd :: Command cmd = withAnnexOptions [jsonOptions] $ 	command "untrust" SectionSetup "do not trust a repository"-		(paramRepeating paramRepository) (withParams seek)+		(paramRepeating paramRepository)+		(withParams' seek completeRemotes)  seek :: CmdParams -> CommandSeek seek = trustCommand "untrust" UnTrusted

@@ -56,6 +56,7 @@ optParser _ = UnusedOptions 	<$> optional (strOption 		( long "from" <> short 'f' <> metavar paramRemote+		<> completeRemotes 		<> help "remote to check for unused content" 		)) 	<*> optional (option (eitherReader parseRefSpec)

@@ -0,0 +1,84 @@+{- git-annex command+ -+ - Copyright 2024 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++{-# LANGUAGE OverloadedStrings #-}++module Command.UpdateCluster where++import Command+import qualified Annex+import Types.Cluster+import Logs.Cluster+import qualified Remote as R+import qualified Types.Remote as R+import qualified Command.UpdateProxy+import Utility.SafeOutput++import qualified Data.Map as M+import qualified Data.Set as S++cmd :: Command+cmd = noMessages $ command "updatecluster" SectionSetup +	"update records of cluster nodes"+	paramNothing (withParams seek)++seek :: CmdParams -> CommandSeek+seek = withNothing $ do+	commandAction start+	commandAction Command.UpdateProxy.start++start :: CommandStart+start = startingCustomOutput (ActionItemOther Nothing) $ do+	rs <- R.remoteList+	let getnode r = do+		clusternames <- remoteAnnexClusterNode (R.gitconfig r)+		return $ M.fromList $ zip clusternames (repeat (S.singleton r))+	let myclusternodes = M.unionsWith S.union (mapMaybe getnode rs)+	myclusters <- annexClusters <$> Annex.getGitConfig+	recordedclusters <- getClusters+	descs <- R.uuidDescriptions+	+	-- Update the cluster log to list the currently configured nodes+	-- of each configured cluster.+	forM_ (M.toList myclusters) $ \(clustername, cu) -> do+		let mynodesremotes = fromMaybe mempty $+			M.lookup clustername myclusternodes+		let mynodes = S.map (ClusterNodeUUID . R.uuid) mynodesremotes+		let recordednodes = fromMaybe mempty $ M.lookup cu $+			clusterUUIDs recordedclusters+		proxiednodes <- findProxiedClusterNodes recordednodes +		let allnodes = S.union mynodes proxiednodes+		if recordednodes == allnodes+			then liftIO $ putStrLn $ safeOutput $+				"No cluster node changes for cluster: " ++ clustername+			else do+				describechanges descs clustername recordednodes allnodes mynodesremotes+				recordCluster cu allnodes++	next $ return True+  where+	describechanges descs clustername oldnodes allnodes mynodesremotes = do+		forM_ (S.toList mynodesremotes) $ \r ->+			unless (S.member (ClusterNodeUUID (R.uuid r)) oldnodes) $+				liftIO $ putStrLn $ safeOutput $+					"Added node " ++ R.name r ++ " to cluster: " ++ clustername+		forM_ (S.toList oldnodes) $ \n ->+			unless (S.member n allnodes) $ do+				let desc = maybe (fromUUID (fromClusterNodeUUID n)) fromUUIDDesc $+					M.lookup (fromClusterNodeUUID n) descs+				liftIO $ putStrLn $ safeOutput $+					"Removed node " ++ desc ++ " from cluster: " ++ clustername++-- Finds nodes that are proxied by other cluster gateways.+findProxiedClusterNodes :: S.Set ClusterNodeUUID -> Annex (S.Set ClusterNodeUUID)+findProxiedClusterNodes recordednodes =+	(S.fromList . map asclusternode . filter isproxynode) <$> R.remoteList+  where+	isproxynode r = +		asclusternode r `S.member` recordednodes+			&& isJust (remoteAnnexProxiedBy (R.gitconfig r))+	asclusternode = ClusterNodeUUID . R.uuid

@@ -0,0 +1,96 @@+{- git-annex command+ -+ - Copyright 2024 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module Command.UpdateProxy where++import Command+import qualified Annex+import Logs.Proxy+import Logs.Cluster+import Annex.UUID+import qualified Remote as R+import qualified Types.Remote as R+import Utility.SafeOutput++import qualified Data.Map as M+import qualified Data.Set as S++cmd :: Command+cmd = noMessages $ command "updateproxy" SectionSetup +	"update records with proxy configuration"+	paramNothing (withParams seek)++seek :: CmdParams -> CommandSeek+seek = withNothing (commandAction start)++start :: CommandStart+start = startingCustomOutput (ActionItemOther Nothing) $ do+	rs <- R.remoteList+	let remoteproxies = S.fromList $ map mkproxy $+		filter (isproxy . R.gitconfig) rs+	clusterproxies <- getClusterProxies remoteproxies+	let proxies = S.union remoteproxies clusterproxies+	u <- getUUID+	oldproxies <- fromMaybe mempty . M.lookup u <$> getProxies+	if oldproxies == proxies+		then liftIO $ putStrLn "No proxy changes to record."+		else do+			describechanges oldproxies proxies+			recordProxies proxies+	next $ return True+  where+	describechanges oldproxies proxies =+		forM_ (S.toList $ S.union oldproxies proxies) $ \p ->+			case (S.member p oldproxies, S.member p proxies) of+				(False, True) -> liftIO $+					putStrLn $ safeOutput $+						"Started proxying for " ++ proxyRemoteName p+				(True, False) -> liftIO $+					putStrLn $ safeOutput $+						"Stopped proxying for " ++ proxyRemoteName p+				_ -> noop+	+	isproxy c = remoteAnnexProxy c || not (null (remoteAnnexClusterNode c))+	+	mkproxy r = Proxy (R.uuid r) (R.name r)++-- Automatically proxy nodes of any cluster this repository is configured+-- to serve as a gateway for. Also proxy other cluster nodes that are+-- themselves proxied via other remotes.+getClusterProxies :: S.Set Proxy -> Annex (S.Set Proxy)+getClusterProxies remoteproxies = do+	myclusters <- (map mkclusterproxy . M.toList . annexClusters)+		<$> Annex.getGitConfig+	remoteproxiednodes <- findRemoteProxiedClusterNodes+	let myproxieduuids = S.map proxyRemoteUUID remoteproxies +		<> S.fromList (map proxyRemoteUUID myclusters)+	-- filter out nodes we proxy for from the remote proxied nodes+	-- to avoid cycles+	let remoteproxiednodes' = filter+		(\n -> proxyRemoteUUID n `S.notMember` myproxieduuids)+		remoteproxiednodes+	return (S.fromList (myclusters ++ remoteproxiednodes'))+  where+	mkclusterproxy (remotename, cu) = +		Proxy (fromClusterUUID cu) remotename++findRemoteProxiedClusterNodes :: Annex [Proxy]+findRemoteProxiedClusterNodes = do+	myclusters <- (S.fromList . M.elems . annexClusters)+		<$> Annex.getGitConfig+	clusternodes <- clusterNodeUUIDs <$> getClusters+	let isproxiedclusternode r+		| isJust (remoteAnnexProxiedBy (R.gitconfig r)) =+			case M.lookup (ClusterNodeUUID (R.uuid r)) clusternodes of+				Nothing -> False+				Just s -> not $ S.null $ +					S.intersection s myclusters+		| otherwise = False+	(map asproxy . filter isproxiedclusternode)+		<$> R.remoteList+  where+	asproxy r = Proxy (R.uuid r) (R.name r)

@@ -11,6 +11,7 @@ import Upgrade import Annex.Version import Annex.Init+import Annex.Startup  cmd :: Command cmd = dontCheck@@ -46,6 +47,6 @@ start _ = 	starting "upgrade" (ActionItemOther Nothing) (SeekInput []) $ do 		whenM (isNothing <$> getVersion) $ do-			initialize Nothing Nothing+			initialize startupAnnex Nothing Nothing 		r <- upgrade False latestVersion 		next $ return r

@@ -27,7 +27,8 @@ 	-> (UUID -> PreferredContentExpression -> Annex ()) 	-> Command cmd' name desc getter setter = noMessages $ -	command name SectionSetup desc pdesc (withParams seek)+	command name SectionSetup desc pdesc+		(withParams' seek completeRemotes)   where 	pdesc = paramPair paramRemote (paramOptional paramExpression) 

@@ -15,6 +15,7 @@ import Logs.Web import Remote.Web (getWebUrls) import Annex.UUID+import Annex.NumCopies import qualified Utility.Format import qualified Command.Find @@ -86,7 +87,7 @@ 	(untrustedlocations, safelocations) <- trustPartition UnTrusted locations 	case formatOption o of 		Nothing -> do-			let num = length safelocations+			let num = numCopiesCount safelocations 			showNote $ UnquotedString $ show num ++ " " ++ copiesplural num 			pp <- ppwhereis "whereis" safelocations urls 			unless (null safelocations) $

@@ -178,13 +178,19 @@  - in any way, or output a summary.  -} commit :: CommitMode -> Bool -> String -> Branch -> [Ref] -> Repo -> IO (Maybe Sha)-commit commitmode allowempty message branch parentrefs repo = do-	tree <- writeTree repo-	ifM (cancommit tree)-		( do-			sha <- commitTree commitmode [message] parentrefs tree repo+commit commitmode allowempty message branch parentrefs repo =+	commitSha commitmode allowempty message parentrefs repo >>= \case+		Just sha -> do 			update' branch sha repo 			return $ Just sha+		Nothing -> return Nothing++{- Same as commit but without updating any branch. -}+commitSha :: CommitMode -> Bool -> String -> [Ref] -> Repo -> IO (Maybe Sha)+commitSha commitmode allowempty message parentrefs repo = do+	tree <- writeTree repo+	ifM (cancommit tree)+		( Just <$> commitTree commitmode [message] parentrefs tree repo 		, return Nothing 		)   where@@ -197,6 +203,10 @@ commitAlways :: CommitMode -> String -> Branch -> [Ref] -> Repo -> IO Sha commitAlways commitmode message branch parentrefs repo = fromJust 	<$> commit commitmode True message branch parentrefs repo++commitShaAlways :: CommitMode -> String -> [Ref] -> Repo -> IO Sha+commitShaAlways commitmode message parentrefs repo = fromJust+	<$> commitSha commitmode True message parentrefs repo  -- Throws exception if the index is locked, with an error message output by -- git on stderr.

@@ -65,9 +65,13 @@ 	{- Only alphanumerics, and a few common bits of punctuation common 	 - in hostnames. -} 	legal '_' = True+	legal '-' = True 	legal '.' = True 	legal c = isAlphaNum c-	++isLegalName :: String -> Bool+isLegalName s = s == makeLegalName s+ data RemoteLocation = RemoteUrl String | RemotePath FilePath 	deriving (Eq, Show) 

@@ -84,6 +84,9 @@ fromConfigKey :: ConfigKey -> String fromConfigKey (ConfigKey s) = decodeBS s +fromConfigKey' :: ConfigKey -> S.ByteString+fromConfigKey' (ConfigKey s) = s+ instance Show ConfigKey where 	show = fromConfigKey 

@@ -408,7 +408,7 @@ 	go' n good notpresent key = do 		us <- filter (`S.notMember` notpresent) 			<$> (filterM good =<< Remote.keyLocations key)-		return $ length us >= n+		return $ numCopiesCount us >= n 	checktrust checker u = checker <$> lookupTrust u 	checkgroup g u = S.member g <$> lookupGroups u 	parsetrustspec s@@ -442,7 +442,8 @@ 				MatchingUserInfo {} -> approxNumCopies 		us <- filter (`S.notMember` notpresent) 			<$> (trustExclude UnTrusted =<< Remote.keyLocations key)-		return $ fromNumCopies numcopies - length us >= needed+		let vs nhave numcopies' = numcopies' - nhave >= needed+		return $ numCopiesCheck'' us vs numcopies 	approxNumCopies = fromMaybe defaultNumCopies <$> getGlobalNumCopies  {- Match keys that are unused.

@@ -98,6 +98,8 @@ topLevelNewUUIDBasedLogs :: [RawFilePath] topLevelNewUUIDBasedLogs = 	[ exportLog+	, proxyLog+	, clusterLog 	]  {- Other top-level logs. -}@@ -153,6 +155,12 @@  exportLog :: RawFilePath exportLog = "export.log"++proxyLog :: RawFilePath+proxyLog = "proxy.log"++clusterLog :: RawFilePath+clusterLog = "cluster.log"  {- This is not a log file, it's where exported treeishes get grafted into  - the git-annex branch. -}

@@ -0,0 +1,41 @@+{- git-annex cluster log+ -+ - Copyright 2024 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++{-# LANGUAGE OverloadedStrings, TupleSections #-}++module Logs.Cluster (+	module Types.Cluster,+	getClusters,+	loadClusters,+	recordCluster,+) where++import qualified Annex+import Annex.Common+import Types.Cluster+import Logs.Cluster.Basic+import Logs.Trust++import qualified Data.Map as M+import qualified Data.Set as S++getClusters :: Annex Clusters+getClusters = maybe loadClusters return	=<< Annex.getState Annex.clusters++{- Loads the clusters and caches it for later.+ -+ - This takes care of removing dead nodes from clusters,+ - to avoid inserting the cluster uuid into the location+ - log when only dead nodes contain the content of a key.+ -}+loadClusters :: Annex Clusters+loadClusters = do+	dead <- (S.fromList . map ClusterNodeUUID)+		<$> trustGet DeadTrusted+	clusters <- getClustersWith (M.map (`S.difference` dead))+	Annex.changeState $ \s -> s { Annex.clusters = Just clusters }+	return clusters

@@ -0,0 +1,91 @@+{- git-annex cluster log, basics+ -+ - Copyright 2024 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++{-# LANGUAGE OverloadedStrings, TupleSections #-}++module Logs.Cluster.Basic (+	module Types.Cluster,+	getClustersWith,+	recordCluster,	+) where++import qualified Annex+import Annex.Common+import qualified Annex.Branch+import Types.Cluster+import Logs+import Logs.UUIDBased+import Logs.MapLog++import qualified Data.Set as S+import qualified Data.Map as M+import Data.ByteString.Builder+import qualified Data.Attoparsec.ByteString as A+import qualified Data.Attoparsec.ByteString.Char8 as A8+import qualified Data.ByteString.Lazy as L++{- Gets the clusters. Note that this includes any dead nodes,+ - unless a function is provided to remove them.+ -}+getClustersWith+	:: (M.Map ClusterUUID (S.Set ClusterNodeUUID)+		-> M.Map ClusterUUID (S.Set ClusterNodeUUID))+	-> Annex Clusters+getClustersWith removedeadnodes = do+	m <- removedeadnodes +		. convclusteruuids +		. M.map value +		. fromMapLog +		. parseClusterLog+		<$> Annex.Branch.get clusterLog+	return $ Clusters+		{ clusterUUIDs = m+		, clusterNodeUUIDs = M.foldlWithKey inverter mempty m+		}+  where+	convclusteruuids :: M.Map UUID (S.Set ClusterNodeUUID) -> M.Map ClusterUUID (S.Set ClusterNodeUUID)+	convclusteruuids = M.fromList +		. mapMaybe (\(mk, v) -> (, v) <$> mk)+		. M.toList . M.mapKeys mkClusterUUID+	inverter m k v = M.unionWith (<>) m +		(M.fromList (map (, S.singleton k) (S.toList v)))++recordCluster :: ClusterUUID -> S.Set ClusterNodeUUID -> Annex ()+recordCluster clusteruuid nodeuuids = do+	-- If a private UUID has been configured as a cluster node, +	-- avoid leaking it into the git-annex log.+	privateuuids <- annexPrivateRepos <$> Annex.getGitConfig+	let nodeuuids' = S.filter+		(\(ClusterNodeUUID n) -> S.notMember n privateuuids)+		nodeuuids+	+	c <- currentVectorClock+	Annex.Branch.change (Annex.Branch.RegardingUUID [fromClusterUUID clusteruuid]) clusterLog $+		(buildLogNew buildClusterNodeList)+			. changeLog c (fromClusterUUID clusteruuid) nodeuuids'+			. parseClusterLog++buildClusterNodeList :: S.Set ClusterNodeUUID -> Builder+buildClusterNodeList = assemble +	. map (buildUUID . fromClusterNodeUUID) +	. S.toList+  where+	assemble [] = mempty+	assemble (x:[]) = x+	assemble (x:y:l) = x <> " " <> assemble (y:l)++parseClusterLog :: L.ByteString -> Log (S.Set ClusterNodeUUID)+parseClusterLog = parseLogNew parseClusterNodeList++parseClusterNodeList :: A.Parser (S.Set ClusterNodeUUID)+parseClusterNodeList = S.fromList <$> many parseword+  where+	parseword = parsenode+		<* ((const () <$> A8.char ' ') <|> A.endOfInput)+	parsenode = ClusterNodeUUID+		<$> (toUUID <$> A8.takeWhile1 (/= ' '))+

@@ -22,9 +22,6 @@ 	getExportExcluded, ) where -import qualified Data.Map as M-import qualified Data.ByteString as B- import Annex.Common import qualified Annex.Branch import qualified Git@@ -38,6 +35,8 @@ import qualified Git.Tree import Annex.UUID +import qualified Data.Map as M+import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Data.Either import Data.Char@@ -66,19 +65,19 @@ 		. parseExportLogMap 		<$> Annex.Branch.get exportLog 	let new = updateIncompleteExportedTreeish old (nub (newtree:incompleteExportedTreeishes [old]))+	rememberExportTreeish newtree 	Annex.Branch.change 		(Annex.Branch.RegardingUUID [remoteuuid, u]) 		exportLog 		(buildExportLog . changeMapLog c ep new . parseExportLog)-	recordExportTreeish newtree  -- Graft a tree ref into the git-annex branch. This is done -- to ensure that it's available later, when getting exported files -- from the remote. Since that could happen in another clone of the -- repository, the tree has to be kept available, even if it -- doesn't end up being merged into the master branch.-recordExportTreeish :: Git.Ref -> Annex ()-recordExportTreeish t = void $+rememberExportTreeish :: Git.Ref -> Annex ()+rememberExportTreeish t = void $ 	Annex.Branch.rememberTreeish t (asTopFilePath exportTreeGraftPoint)  -- | Record that an export to a special remote is under way.@@ -112,7 +111,7 @@ recordExport :: UUID -> Git.Ref -> ExportChange -> Annex () recordExport remoteuuid tree ec = do 	when (oldTreeish ec /= [tree]) $-		recordExportTreeish tree+		rememberExportTreeish tree 	recordExportUnderway remoteuuid ec  logExportExcluded :: UUID -> ((Git.Tree.TreeItem -> IO ()) -> Annex a) -> Annex a

@@ -8,7 +8,7 @@  - Repositories record their UUID and the date when they --get or --drop  - a value.  - - - 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.  -}@@ -41,6 +41,7 @@ import qualified Annex.Branch import Logs import Logs.Presence+import Types.Cluster import Annex.UUID import Annex.CatFile import Annex.VectorClock@@ -49,6 +50,8 @@  import Data.Time.Clock import qualified Data.ByteString.Lazy as L+import qualified Data.Map as M+import qualified Data.Set as S  {- Log a change in the presence of a key's value in current repository. -} logStatus :: Key -> LogStatus -> Annex ()@@ -66,15 +69,22 @@ 	, return False 	) -{- Log a change in the presence of a key's value in a repository. -}+{- Log a change in the presence of a key's value in a repository.+ -+ - Cluster UUIDs are not logged. Instead, when a node of a cluster is+ - logged to contain a key, loading the log will include the cluster's+ - UUID.+ -} logChange :: Key -> UUID -> LogStatus -> Annex ()-logChange key u@(UUID _) s = do-	config <- Annex.getGitConfig-	maybeAddLog-		(Annex.Branch.RegardingUUID [u])-		(locationLogFile config key)-		s-		(LogInfo (fromUUID u))+logChange key u@(UUID _) s+	| isClusterUUID u = noop+	| otherwise = do+		config <- Annex.getGitConfig+		maybeAddLog+			(Annex.Branch.RegardingUUID [u])+			(locationLogFile config key)+			s+			(LogInfo (fromUUID u)) logChange _ NoUUID _ = noop  {- Returns a list of repository UUIDs that, according to the log, have@@ -97,15 +107,30 @@ loggedLocationsRef ref = map (toUUID . fromLogInfo) . getLog <$> catObject ref  {- Parses the content of a log file and gets the locations in it. -}-parseLoggedLocations :: L.ByteString -> [UUID]-parseLoggedLocations l = map (toUUID . fromLogInfo . info)-	(filterPresent (parseLog l))+parseLoggedLocations :: Clusters -> L.ByteString -> [UUID]+parseLoggedLocations clusters l = addClusterUUIDs clusters $+	map (toUUID . fromLogInfo . info)+		(filterPresent (parseLog l))  getLoggedLocations :: (RawFilePath -> Annex [LogInfo]) -> Key -> Annex [UUID] getLoggedLocations getter key = do 	config <- Annex.getGitConfig-	map (toUUID . fromLogInfo) <$> getter (locationLogFile config key)+	locs <- map (toUUID . fromLogInfo) <$> getter (locationLogFile config key)+	clusters <- getClusters+	return $ addClusterUUIDs clusters locs +-- Add UUIDs of any clusters whose nodes are in the list.+addClusterUUIDs :: Clusters -> [UUID] -> [UUID]+addClusterUUIDs clusters locs+	| M.null clustermap = locs+	-- ^ optimisation for common case of no clusters+	| otherwise = clusterlocs ++ locs+  where+	clustermap = clusterNodeUUIDs clusters+	clusterlocs = map fromClusterUUID $ S.toList $ +		S.unions $ mapMaybe findclusters locs+	findclusters u = M.lookup (ClusterNodeUUID u) clustermap+ {- Is there a location log for the key? True even for keys with no  - remaining locations. -} isKnownKey :: Key -> Annex Bool@@ -204,6 +229,7 @@         -> Annex v overLocationLogs' iv discarder keyaction = do 	config <- Annex.getGitConfig+	clusters <- getClusters 		 	let getk = locationLogFileKey config 	let go v reader = reader >>= \case@@ -214,11 +240,16 @@ 			ifM (checkDead k) 				( go v reader 				, do-					!v' <- keyaction k (maybe [] parseLoggedLocations content) v+					!v' <- keyaction k (maybe [] (parseLoggedLocations clusters) content) v 					go v' reader 				) 		Nothing -> return v  	Annex.Branch.overBranchFileContents getk (go iv) >>= \case 		Just r -> return r-		Nothing -> giveup "This repository is read-only, and there are unmerged git-annex branches, which prevents operating on all keys. (Set annex.merge-annex-branches to false to ignore the unmerged git-annex branches.)"+		Nothing -> giveup "This repository is read-only, and there are unmerged git-annex branches, which prevents operating on allu keys. (Set annex.merge-annex-branches to false to ignore the unmerged git-annex branches.)"++-- Cannot import Logs.Cluster due to a cycle.+-- Annex.clusters gets populated when starting up git-annex.+getClusters :: Annex Clusters+getClusters = fromMaybe noClusters <$> Annex.getState Annex.clusters

@@ -0,0 +1,88 @@+{- git-annex proxy log+ -+ - Copyright 2024 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++{-# LANGUAGE OverloadedStrings #-}++module Logs.Proxy (+	Proxy(..),+	getProxies,+	recordProxies,+) where++import qualified Annex+import Annex.Common+import qualified Annex.Branch+import qualified Git.Remote+import Git.Types+import Logs+import Logs.UUIDBased+import Logs.MapLog+import Annex.UUID++import qualified Data.Set as S+import qualified Data.Map as M+import Data.ByteString.Builder+import qualified Data.Attoparsec.ByteString as A+import qualified Data.Attoparsec.ByteString.Char8 as A8+import qualified Data.ByteString.Lazy as L++data Proxy = Proxy+	{ proxyRemoteUUID :: UUID+	, proxyRemoteName :: RemoteName+	} deriving (Show, Eq, Ord)++getProxies :: Annex (M.Map UUID (S.Set Proxy))+getProxies = M.map (validateProxies . value) . fromMapLog . parseProxyLog+	<$> Annex.Branch.get proxyLog++recordProxies :: S.Set Proxy -> Annex ()+recordProxies proxies = do+	-- If a private UUID has been configured as a proxy, avoid leaking+	-- it into the git-annex log.+	privateuuids <- annexPrivateRepos <$> Annex.getGitConfig+	let proxies' = S.filter+		(\p -> S.notMember (proxyRemoteUUID p) privateuuids) proxies+	+	c <- currentVectorClock+	u <- getUUID+	Annex.Branch.change (Annex.Branch.RegardingUUID [u]) proxyLog $+		(buildLogNew buildProxyList)+			. changeLog c u proxies'+			. parseProxyLog++buildProxyList :: S.Set Proxy -> Builder+buildProxyList = assemble . map fmt . S.toList+  where+	fmt p = buildUUID (proxyRemoteUUID p)+		<> colon+		<> byteString (encodeBS (proxyRemoteName p))+	colon = charUtf8 ':'+	+	assemble [] = mempty+	assemble (x:[]) = x+	assemble (x:y:l) = x <> " " <> assemble (y:l)++parseProxyLog :: L.ByteString -> Log (S.Set Proxy)+parseProxyLog = parseLogNew parseProxyList++parseProxyList :: A.Parser (S.Set Proxy)+parseProxyList = S.fromList <$> many parseword+  where+	parseword = parseproxy+		<* ((const () <$> A8.char ' ') <|> A.endOfInput)+	parseproxy = Proxy+		<$> (toUUID <$> A8.takeWhile1 (/= colon))+		<* (const () <$> A8.char colon)+		<*> (decodeBS <$> A8.takeWhile1 (/= ' '))+	colon = ':'++-- Filter out any proxies that have a name that is not allowed as a git+-- remote name. This avoids any security problems with eg escape+-- characters in names, and ensures the name can be used anywhere a usual+-- git remote name can be used without causing issues.+validateProxies :: S.Set Proxy -> S.Set Proxy+validateProxies = S.filter $ Git.Remote.isLegalName . proxyRemoteName

@@ -51,7 +51,7 @@ 		let getsize = liftIO . catchMaybeIO . getFileSize 		size <- inAnnex' isJust Nothing getsize k 		runner (next (Len <$> size))-	ReadContent k af o sender next -> do+	ReadContent k af o offset sender next -> do 		let proceed c = do 			r <- tryNonAsync c 			case r of@@ -62,12 +62,12 @@ 		-- run for any other reason, the sender action still must 		-- be run, so is given empty and Invalid data. 		let fallback = runner (sender mempty (return Invalid))-		v <- tryNonAsync $ prepSendAnnex k+		v <- tryNonAsync $ prepSendAnnex k o 		case v of 			Right (Just (f, _sz, checkchanged)) -> proceed $ do 				-- alwaysUpload to allow multiple uploads of the same key. 				let runtransfer ti = transfer alwaysUpload k af Nothing $ \p ->-					sinkfile f o checkchanged sender p ti+					sinkfile f offset checkchanged sender p ti 				checktransfer runtransfer fallback  			Right Nothing -> proceed fallback 			Left e -> return $ Left $ ProtoFailureException e

@@ -1,6 +1,6 @@ {- P2P protocol, IO implementation  -- - Copyright 2016-2018 Joey Hess <id@joeyh.name>+ - Copyright 2016-2024 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -11,10 +11,12 @@ 	( RunProto 	, RunState(..) 	, mkRunState+	, P2PHandle(..) 	, P2PConnection(..) 	, ConnIdent(..) 	, ClosableConnection(..) 	, stdioP2PConnection+	, stdioP2PConnectionDupped 	, connectPeer 	, closeConnection 	, serveUnixSocket@@ -74,11 +76,15 @@ 	tvar <- newTVarIO defaultProtocolVersion 	return (mk tvar) +data P2PHandle+	= P2PHandle Handle+	| P2PHandleTMVar (TMVar (Either L.ByteString Message)) (TMVar ())+ data P2PConnection = P2PConnection-	{ connRepo :: Repo+	{ connRepo :: Maybe Repo 	, connCheckAuth :: (AuthToken -> Bool)-	, connIhdl :: Handle-	, connOhdl :: Handle+	, connIhdl :: P2PHandle+	, connOhdl :: P2PHandle 	, connIdent :: ConnIdent 	} @@ -90,31 +96,48 @@ 	| ClosedConnection  -- P2PConnection using stdio.-stdioP2PConnection :: Git.Repo -> P2PConnection+stdioP2PConnection :: Maybe Git.Repo -> P2PConnection stdioP2PConnection g = P2PConnection 	{ connRepo = g 	, connCheckAuth = const False-	, connIhdl = stdin-	, connOhdl = stdout+	, connIhdl = P2PHandle stdin+	, connOhdl = P2PHandle stdout 	, connIdent = ConnIdent Nothing 	} +-- P2PConnection using stdio, but with the handles first duplicated,+-- to avoid anything that might output to stdio (eg a program run by a+-- special remote) from interfering with the connection.+stdioP2PConnectionDupped :: Maybe Git.Repo -> IO P2PConnection+stdioP2PConnectionDupped g = do+	(readh, writeh) <- dupIoHandles+	return $ P2PConnection+		{ connRepo = g+		, connCheckAuth = const False+		, connIhdl = P2PHandle readh+		, connOhdl = P2PHandle writeh+		, connIdent = ConnIdent Nothing+		}+ -- Opens a connection to a peer. Does not authenticate with it.-connectPeer :: Git.Repo -> P2PAddress -> IO P2PConnection+connectPeer :: Maybe Git.Repo -> P2PAddress -> IO P2PConnection connectPeer g (TorAnnex onionaddress onionport) = do 	h <- setupHandle =<< connectHiddenService onionaddress onionport 	return $ P2PConnection 		{ connRepo = g 		, connCheckAuth = const False-		, connIhdl = h-		, connOhdl = h+		, connIhdl = P2PHandle h+		, connOhdl = P2PHandle h 		, connIdent = ConnIdent Nothing 		}  closeConnection :: P2PConnection -> IO () closeConnection conn = do-	hClose (connIhdl conn)-	hClose (connOhdl conn)+	closehandle (connIhdl conn)+	closehandle (connOhdl conn)+  where+	closehandle (P2PHandle h) = hClose h+	closehandle (P2PHandleTMVar _ _) = return ()  -- Serves the protocol on a unix socket. --@@ -154,8 +177,7 @@ -- Purposefully incomplete interpreter of Proto. -- -- This only runs Net actions. No Local actions will be run--- (those need the Annex monad) -- if the interpreter reaches any,--- it returns Nothing.+-- (those need the Annex monad). runNetProto :: RunState -> P2PConnection -> Proto a -> IO (Either ProtoFailure a) runNetProto runst conn = go   where@@ -165,6 +187,11 @@ 	go (Free (Local _)) = return $ Left $ 		ProtoFailureMessage "unexpected annex operation attempted" +data P2PTMVarException = P2PTMVarException String+	deriving (Show)++instance Exception P2PTMVarException+ -- Interpreter of the Net part of Proto. -- -- An interpreter of Proto has to be provided, to handle the rest of Proto@@ -172,40 +199,71 @@ runNet :: (MonadIO m, MonadMask m) => RunState -> P2PConnection -> RunProto m -> NetF (Proto a) -> m (Either ProtoFailure a) runNet runst conn runner f = case f of 	SendMessage m next -> do-		v <- liftIO $ tryNonAsync $ do-			let l = unwords (formatMessage m)+		v <- liftIO $ do 			debugMessage conn "P2P >" m-			hPutStrLn (connOhdl conn) l-			hFlush (connOhdl conn)+			case connOhdl conn of+				P2PHandle h -> tryNonAsync $ do+					hPutStrLn h $ unwords (formatMessage m)+					hFlush h+				P2PHandleTMVar mv _ ->+					ifM (atomically (tryPutTMVar mv (Right m)))+						( return $ Right ()+						, return $ Left $ toException $+							P2PTMVarException "TMVar left full"+						) 		case v of 			Left e -> return $ Left $ ProtoFailureException e 			Right () -> runner next-	ReceiveMessage next -> do-		v <- liftIO $ tryIOError $ getProtocolLine (connIhdl conn)-		case v of-			Left e -> return $ Left $ ProtoFailureIOError e-			Right Nothing -> return $ Left $-				ProtoFailureMessage "protocol error"-			Right (Just l) -> case parseMessage l of-				Just m -> do-					liftIO $ debugMessage conn "P2P <" m-					runner (next (Just m))-				Nothing -> runner (next Nothing)-	SendBytes len b p next -> do-		v <- liftIO $ tryNonAsync $ do-			ok <- sendExactly len b (connOhdl conn) p-			hFlush (connOhdl conn)-			return ok-		case v of-			Right True -> runner next-			Right False -> return $ Left $-				ProtoFailureMessage "short data write"-			Left e -> return $ Left $ ProtoFailureException e-	ReceiveBytes len p next -> do-		v <- liftIO $ tryNonAsync $ receiveExactly len (connIhdl conn) p-		case v of-			Left e -> return $ Left $ ProtoFailureException e-			Right b -> runner (next b)+	ReceiveMessage next ->+		let protoerr = return $ Left $+			ProtoFailureMessage "protocol error 1"+		    gotmessage m = do+			liftIO $ debugMessage conn "P2P <" m+			runner (next (Just m))+		in case connIhdl conn of+			P2PHandle h -> do+				v <- liftIO $ tryIOError $ getProtocolLine h+				case v of+					Left e -> return $ Left $ ProtoFailureIOError e+					Right Nothing -> protoerr+					Right (Just l) -> case parseMessage l of+						Just m -> gotmessage m+						Nothing -> runner (next Nothing)+			P2PHandleTMVar mv _ -> +				liftIO (atomically (takeTMVar mv)) >>= \case+					Right m -> gotmessage m+					Left _b -> protoerr+	SendBytes len b p next ->+		case connOhdl conn of+			P2PHandle h -> do+				v <- liftIO $ tryNonAsync $ do+					ok <- sendExactly len b h p+					hFlush h+					return ok+				case v of+					Right True -> runner next+					Right False -> return $ Left $+						ProtoFailureMessage "short data write"+					Left e -> return $ Left $ ProtoFailureException e+			P2PHandleTMVar mv waitv -> do+				liftIO $ atomically $ putTMVar mv (Left b)+				-- Wait for the whole bytestring to be+				-- processed. Necessary due to lazyiness.+				liftIO $ atomically $ takeTMVar waitv+				runner next+	ReceiveBytes len p next ->+		case connIhdl conn of+			P2PHandle h -> do+				v <- liftIO $ tryNonAsync $ receiveExactly len h p+				case v of+					Right b -> runner (next b)+					Left e -> return $ Left $+						ProtoFailureException e+			P2PHandleTMVar mv _ ->+				liftIO (atomically (takeTMVar mv)) >>= \case+					Left b -> runner (next b)+					Right _ -> return $ Left $+						ProtoFailureMessage "protocol error 2" 	CheckAuthToken _u t next -> do 		let authed = connCheckAuth conn t 		runner (next authed)@@ -286,19 +344,21 @@ 	go (v, _, _) = relayHelper runner v  runRelayService :: P2PConnection -> RunProto IO -> Service -> IO (Either ProtoFailure ())-runRelayService conn runner service =-	withCreateProcess serviceproc' go+runRelayService conn runner service = case connRepo conn of+	Just repo -> withCreateProcess (serviceproc' repo) go 		`catchNonAsync` (return . Left . ProtoFailureException)+	Nothing -> return $ Left $ ProtoFailureMessage+		"relaying to git not supported on this connection"   where 	cmd = case service of 		UploadPack -> "upload-pack" 		ReceivePack -> "receive-pack" 	-	serviceproc = gitCreateProcess+	serviceproc repo = gitCreateProcess 		[ Param cmd-		, File (fromRawFilePath (repoPath (connRepo conn)))-		] (connRepo conn)-	serviceproc' = serviceproc +		, File (fromRawFilePath (repoPath repo))+		] repo+	serviceproc' repo = (serviceproc repo) 		{ std_out = CreatePipe 		, std_in = CreatePipe 		}

@@ -2,13 +2,14 @@  -  - See doc/design/p2p_protocol.mdwn  -- - Copyright 2016-2021 Joey Hess <id@joeyh.name>+ - Copyright 2016-2024 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}  {-# LANGUAGE DeriveFunctor, TemplateHaskell, FlexibleContexts #-} {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, RankNTypes #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  module P2P.Protocol where@@ -37,6 +38,7 @@ import qualified System.FilePath.ByteString as P import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L+import qualified Data.Set as S import Data.Char import Control.Applicative import Prelude@@ -54,7 +56,7 @@ defaultProtocolVersion = ProtocolVersion 0  maxProtocolVersion :: ProtocolVersion-maxProtocolVersion = ProtocolVersion 1+maxProtocolVersion = ProtocolVersion 2  newtype ProtoAssociatedFile = ProtoAssociatedFile AssociatedFile 	deriving (Show)@@ -65,6 +67,9 @@  data Validity = Valid | Invalid 	deriving (Show)+	+newtype Bypass = Bypass (S.Set UUID)+	deriving (Show, Monoid, Semigroup)  -- | Messages in the protocol. The peer that makes the connection -- always initiates requests, and the other peer makes responses to them.@@ -85,8 +90,12 @@ 	| PUT ProtoAssociatedFile Key 	| PUT_FROM Offset 	| ALREADY_HAVE+	| ALREADY_HAVE_PLUS [UUID] 	| SUCCESS+	| SUCCESS_PLUS [UUID] 	| FAILURE+	| FAILURE_PLUS [UUID]+	| BYPASS Bypass 	| DATA Len -- followed by bytes of data 	| VALIDITY Validity 	| ERROR String@@ -109,8 +118,12 @@ 	formatMessage (PUT af key) = ["PUT", Proto.serialize af, Proto.serialize key] 	formatMessage (PUT_FROM offset) = ["PUT-FROM", Proto.serialize offset] 	formatMessage ALREADY_HAVE = ["ALREADY-HAVE"]+	formatMessage (ALREADY_HAVE_PLUS uuids) = ("ALREADY-HAVE-PLUS":map Proto.serialize uuids) 	formatMessage SUCCESS = ["SUCCESS"]+	formatMessage (SUCCESS_PLUS uuids) = ("SUCCESS-PLUS":map Proto.serialize uuids) 	formatMessage FAILURE = ["FAILURE"]+	formatMessage (FAILURE_PLUS uuids) = ("FAILURE-PLUS":map Proto.serialize uuids)+	formatMessage (BYPASS (Bypass uuids)) = ("BYPASS":map Proto.serialize (S.toList uuids)) 	formatMessage (VALIDITY Valid) = ["VALID"] 	formatMessage (VALIDITY Invalid) = ["INVALID"] 	formatMessage (DATA len) = ["DATA", Proto.serialize len]@@ -133,8 +146,12 @@ 	parseCommand "PUT" = Proto.parse2 PUT 	parseCommand "PUT-FROM" = Proto.parse1 PUT_FROM 	parseCommand "ALREADY-HAVE" = Proto.parse0 ALREADY_HAVE+	parseCommand "ALREADY-HAVE-PLUS" = Proto.parseList ALREADY_HAVE_PLUS 	parseCommand "SUCCESS" = Proto.parse0 SUCCESS+	parseCommand "SUCCESS-PLUS" = Proto.parseList SUCCESS_PLUS 	parseCommand "FAILURE" = Proto.parse0 FAILURE+	parseCommand "FAILURE-PLUS" = Proto.parseList FAILURE_PLUS+	parseCommand "BYPASS" = Proto.parseList (BYPASS . Bypass . S.fromList) 	parseCommand "DATA" = Proto.parse1 DATA 	parseCommand "ERROR" = Proto.parse1 ERROR 	parseCommand "VALID" = Proto.parse0 (VALIDITY Valid)@@ -164,12 +181,15 @@ -- its serialization cannot contain any whitespace. This is handled -- by replacing whitespace with '%' (and '%' with '%%') ----- When deserializing an AssociatedFile from a peer, it's sanitized,--- to avoid any unusual characters that might cause problems when it's--- displayed to the user.+-- When deserializing an AssociatedFile from a peer, that escaping is+-- reversed. Unfortunately, an input tab will be deescaped to a space+-- though. And it's sanitized, to avoid any control characters that might+-- cause problems when it's displayed to the user. ----- These mungings are ok, because a ProtoAssociatedFile is only ever displayed--- to the user and does not need to match a file on disk.+-- These mungings are ok, because a ProtoAssociatedFile is normally+-- only displayed to the user and so does not need to match a file on disk.+-- It may also be used in checking preferred content, which is very+-- unlikely to care about spaces vs tabs or control characters. instance Proto.Serializable ProtoAssociatedFile where 	serialize (ProtoAssociatedFile (AssociatedFile Nothing)) = "" 	serialize (ProtoAssociatedFile (AssociatedFile (Just af))) = @@ -244,7 +264,7 @@ 	| ContentSize Key (Maybe Len -> c) 	-- ^ Gets size of the content of a key, when the full content is 	-- present.-	| ReadContent Key AssociatedFile Offset (L.ByteString -> Proto Validity -> Proto Bool) (Bool -> c)+	| ReadContent Key AssociatedFile (Maybe FilePath) Offset (L.ByteString -> Proto Validity -> Proto (Maybe [UUID])) (Maybe [UUID] -> c) 	-- ^ Reads the content of a key and sends it to the callback. 	-- Must run the callback, or terminate the protocol connection. 	--@@ -324,10 +344,19 @@ 		Just (ERROR _) -> return () 		_ -> net $ sendMessage (ERROR "expected VERSION") -checkPresent :: Key -> Proto Bool+sendBypass :: Bypass -> Proto ()+sendBypass bypass@(Bypass s)+	| S.null s = return ()+	| otherwise = do+		ver <- net getProtocolVersion+		if ver >= ProtocolVersion 2+			then net $ sendMessage (BYPASS bypass)+			else return ()++checkPresent :: Key -> Proto (Either String Bool) checkPresent key = do 	net $ sendMessage (CHECKPRESENT key)-	checkSuccess+	checkSuccess'  {- Locks content to prevent it from being dropped, while running an action.  -@@ -349,10 +378,10 @@ 	cleanup True = runproto () $ net $ sendMessage UNLOCKCONTENT 	cleanup False = return () -remove :: Key -> Proto Bool+remove :: Key -> Proto (Either String Bool, Maybe [UUID]) remove key = do 	net $ sendMessage (REMOVE key)-	checkSuccess+	checkSuccessFailurePlus  get :: FilePath -> Key -> Maybe IncrementalVerifier -> AssociatedFile -> Meter -> MeterUpdate -> Proto (Bool, Verification) get dest key iv af m p = @@ -362,16 +391,17 @@ 	sizer = fileSize dest 	storer = storeContentTo dest iv -put :: Key -> AssociatedFile -> MeterUpdate -> Proto Bool+put :: Key -> AssociatedFile -> MeterUpdate -> Proto (Maybe [UUID]) put key af p = do 	net $ sendMessage (PUT (ProtoAssociatedFile af) key) 	r <- net receiveMessage 	case r of-		Just (PUT_FROM offset) -> sendContent key af offset p-		Just ALREADY_HAVE -> return True+		Just (PUT_FROM offset) -> sendContent key af Nothing offset p+		Just ALREADY_HAVE -> return (Just [])+		Just (ALREADY_HAVE_PLUS uuids) -> return (Just uuids) 		_ -> do 			net $ sendMessage (ERROR "expected PUT_FROM or ALREADY_HAVE")-			return False+			return Nothing  data ServerHandler a 	= ServerGot a@@ -440,8 +470,6 @@ serveAuthed :: ServerMode -> UUID -> Proto () serveAuthed servermode myuuid = void $ serverLoop handler   where-	readonlyerror = net $ sendMessage (ERROR "this repository is read-only; write access denied")-	appendonlyerror = net $ sendMessage (ERROR "this repository is append-only; removal denied") 	handler (VERSION theirversion) = do 		let v = min theirversion maxProtocolVersion 		net $ setProtocolVersion v@@ -459,45 +487,42 @@ 	handler (CHECKPRESENT key) = do 		sendSuccess =<< local (checkContentPresent key) 		return ServerContinue-	handler (REMOVE key) = case servermode of-		ServeReadWrite -> do-			sendSuccess =<< local (removeContent key)-			return ServerContinue-		ServeAppendOnly -> do-			appendonlyerror-			return ServerContinue-		ServeReadOnly -> do-			readonlyerror-			return ServerContinue-	handler (PUT (ProtoAssociatedFile af) key) = case servermode of-		ServeReadWrite -> handleput af key-		ServeAppendOnly -> handleput af key-		ServeReadOnly -> do-			readonlyerror-			return ServerContinue+	handler (REMOVE key) =+		checkREMOVEServerMode servermode $ \case+			Nothing -> do+				sendSuccess =<< local (removeContent key)+				return ServerContinue			+			Just notallowed -> do+				notallowed+				return ServerContinue+	handler (PUT (ProtoAssociatedFile af) key) =+		checkPUTServerMode servermode $ \case+			Nothing -> handleput af key+			Just notallowed -> do+				notallowed+				return ServerContinue 	handler (GET offset (ProtoAssociatedFile af) key) = do-		void $ sendContent key af offset nullMeterUpdate+		void $ sendContent key af Nothing offset nullMeterUpdate 		-- setPresent not called because the peer may have 		-- requested the data but not permanently stored it. 		return ServerContinue 	handler (CONNECT service) = do-		let goahead = net $ relayService service-		case (servermode, service) of-			(ServeReadWrite, _) -> goahead-			(ServeAppendOnly, UploadPack) -> goahead-			-- git protocol could be used to overwrite-			-- refs or something, so don't allow-			(ServeAppendOnly, ReceivePack) -> readonlyerror-			(ServeReadOnly, UploadPack) -> goahead-			(ServeReadOnly, ReceivePack) -> readonlyerror 		-- After connecting to git, there may be unconsumed data 		-- from the git processes hanging around (even if they 		-- exited successfully), so stop serving this connection.-		return $ ServerGot ()+		let endit = return $ ServerGot ()+		checkCONNECTServerMode service servermode $ \case+			Nothing -> do+				net $ relayService service+				endit+			Just notallowed -> do+				notallowed+				endit 	handler NOTIFYCHANGE = do 		refs <- local waitRefChange 		net $ sendMessage (CHANGED refs) 		return ServerContinue+	handler (BYPASS _) = return ServerContinue 	handler _ = return ServerUnexpected  	handleput af key = do@@ -512,14 +537,47 @@ 					local $ setPresent key myuuid 		return ServerContinue -sendContent :: Key -> AssociatedFile -> Offset -> MeterUpdate -> Proto Bool-sendContent key af offset@(Offset n) p = go =<< local (contentSize key)+sendReadOnlyError :: Proto ()+sendReadOnlyError = net $ sendMessage $+	ERROR "this repository is read-only; write access denied"++sendAppendOnlyError :: Proto ()+sendAppendOnlyError = net $ sendMessage $+	ERROR "this repository is append-only; removal denied"+			+checkPUTServerMode :: Monad m => ServerMode -> (Maybe (Proto ()) -> m a) -> m a+checkPUTServerMode servermode a =+	case servermode of+		ServeReadWrite -> a Nothing+		ServeAppendOnly -> a Nothing+		ServeReadOnly -> a (Just sendReadOnlyError)++checkREMOVEServerMode :: Monad m => ServerMode -> (Maybe (Proto ()) -> m a) -> m a+checkREMOVEServerMode servermode a =+	case servermode of+		ServeReadWrite -> a Nothing+		ServeAppendOnly -> a (Just sendAppendOnlyError)+		ServeReadOnly -> a (Just sendReadOnlyError)++checkCONNECTServerMode :: Monad m => Service -> ServerMode -> (Maybe (Proto ()) -> m a) -> m a+checkCONNECTServerMode service servermode a =+	case (servermode, service) of+		(ServeReadWrite, _) -> a Nothing+		(ServeAppendOnly, UploadPack) -> a Nothing+		-- git protocol could be used to overwrite+		-- refs or something, so don't allow+		(ServeAppendOnly, ReceivePack) -> a (Just sendReadOnlyError)+		(ServeReadOnly, UploadPack) -> a Nothing+		(ServeReadOnly, ReceivePack) -> a (Just sendReadOnlyError)++sendContent :: Key -> AssociatedFile -> Maybe FilePath -> Offset -> MeterUpdate -> Proto (Maybe [UUID])+sendContent key af o offset@(Offset n) p = go =<< local (contentSize key)   where 	go (Just (Len totallen)) = do 		let len = totallen - n 		if len <= 0 			then sender (Len 0) L.empty (return Valid)-			else local $ readContent key af offset $+			else local $ readContent key af o offset $ 				sender (Len len) 	-- Content not available to send. Indicate this by sending 	-- empty data and indlicate it's invalid.@@ -531,7 +589,7 @@ 		ver <- net getProtocolVersion 		when (ver >= ProtocolVersion 1) $ 			net . sendMessage . VALIDITY =<< validitycheck-		checkSuccess+		checkSuccessPlus  receiveContent 	:: Observable t@@ -565,20 +623,54 @@ 				validitycheck 			sendSuccess (observeBool v) 			return v+		Just (ERROR _err) ->+			return observeFailure 		_ -> do 			net $ sendMessage (ERROR "expected DATA") 			return observeFailure  checkSuccess :: Proto Bool-checkSuccess = do+checkSuccess = either (const False) id <$> checkSuccess'++checkSuccess' :: Proto (Either String Bool)+checkSuccess' = do 	ack <- net receiveMessage 	case ack of-		Just SUCCESS -> return True-		Just FAILURE -> return False+		Just SUCCESS -> return (Right True)+		Just FAILURE -> return (Right False)+		Just (ERROR err) -> return (Left err) 		_ -> do 			net $ sendMessage (ERROR "expected SUCCESS or FAILURE")-			return False+			return (Right False) +checkSuccessPlus :: Proto (Maybe [UUID])+checkSuccessPlus =+	checkSuccessFailurePlus >>= return . \case+		(Right True, v) -> v+		(Right False, _) -> Nothing+		(Left _, _) -> Nothing++checkSuccessFailurePlus :: Proto (Either String Bool, Maybe [UUID])+checkSuccessFailurePlus = do+	ver <- net getProtocolVersion+	if ver >= ProtocolVersion 2+		then do+			ack <- net receiveMessage+			case ack of+				Just SUCCESS -> return (Right True, Just [])+				Just (SUCCESS_PLUS l) -> return (Right True, Just l)+				Just FAILURE -> return (Right False, Nothing)+				Just (FAILURE_PLUS l) -> return (Right False, Just l)+				Just (ERROR err) -> return (Left err, Nothing)+				_ -> do+					net $ sendMessage (ERROR "expected SUCCESS or SUCCESS-PLUS or FAILURE or FAILURE-PLUS")+					return (Right False, Nothing)+		else do+			ok <- checkSuccess+			if ok+				then return (Right True, Just [])+				else return (Right False, Nothing)+ sendSuccess :: Bool -> Proto () sendSuccess True = net $ sendMessage SUCCESS sendSuccess False = net $ sendMessage FAILURE@@ -621,3 +713,4 @@ 	sendMessage (DATA len) 	sendBytes len b nullMeterUpdate relayToPeer (RelayFromPeer _) = return ()+

@@ -0,0 +1,586 @@+{- P2P protocol proxying+ -+ - Copyright 2024 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++{-# LANGUAGE RankNTypes, FlexibleContexts, ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns #-}++module P2P.Proxy where++import Annex.Common+import qualified Annex+import P2P.Protocol+import P2P.IO+import Utility.Metered+import Git.FilePath+import Types.Concurrency+import Annex.Concurrent+import qualified Remote++import Data.Either+import Control.Concurrent.STM+import Control.Concurrent.Async+import qualified Control.Concurrent.MSem as MSem+import qualified Data.ByteString.Lazy as L+import qualified Data.Set as S+import GHC.Conc++type ProtoCloser = Annex ()++data ClientSide = ClientSide RunState P2PConnection++data RemoteSide = RemoteSide+	{ remote :: Remote+	, remoteConnect :: Annex (Maybe (RunState, P2PConnection, ProtoCloser))+	, remoteTMVar :: TMVar (RunState, P2PConnection, ProtoCloser)+	}++mkRemoteSide :: Remote -> Annex (Maybe (RunState, P2PConnection, ProtoCloser)) -> Annex RemoteSide+mkRemoteSide r remoteconnect = RemoteSide+	<$> pure r+	<*> pure remoteconnect+	<*> liftIO (atomically newEmptyTMVar)++runRemoteSide :: RemoteSide -> Proto a -> Annex (Either ProtoFailure a)+runRemoteSide remoteside a = +	liftIO (atomically $ tryReadTMVar $ remoteTMVar remoteside) >>= \case+		Just (runst, conn, _closer) -> liftIO $ runNetProto runst conn a+		Nothing -> remoteConnect remoteside >>= \case+			Just (runst, conn, closer) -> do+				liftIO $ atomically $ putTMVar+					(remoteTMVar remoteside)+					(runst, conn, closer)+				liftIO $ runNetProto runst conn a+			Nothing -> giveup "Unable to connect to remote."++closeRemoteSide :: RemoteSide -> Annex ()+closeRemoteSide remoteside = +	liftIO (atomically $ tryTakeTMVar $ remoteTMVar remoteside) >>= \case+		Just (_, _, closer) -> closer+		Nothing -> return ()++{- Selects what remotes to proxy to for top-level P2P protocol+ - actions.+ - -}+data ProxySelector = ProxySelector+	{ proxyCHECKPRESENT :: Key -> Annex (Maybe RemoteSide)+	, proxyLOCKCONTENT :: Key -> Annex (Maybe RemoteSide)+	, proxyUNLOCKCONTENT :: Annex (Maybe RemoteSide)+	, proxyREMOVE :: Key -> Annex [RemoteSide]+	-- ^ remove from all of these remotes+	, proxyGET :: Key -> Annex (Maybe RemoteSide)+	, proxyPUT :: AssociatedFile -> Key -> Annex [RemoteSide]+	-- ^ put to some/all of these remotes+	}++singleProxySelector :: RemoteSide -> ProxySelector+singleProxySelector r = ProxySelector+	{ proxyCHECKPRESENT = const (pure (Just r))+	, proxyLOCKCONTENT = const (pure (Just r))+	, proxyUNLOCKCONTENT = pure (Just r)+	, proxyREMOVE = const (pure [r])+	, proxyGET = const (pure (Just r))+	, proxyPUT = const (const (pure [r]))+	}++{- To keep this module limited to P2P protocol actions,+ - all other actions that a proxy needs to do are provided+ - here. -}+data ProxyMethods = ProxyMethods+	{ removedContent :: UUID -> Key -> Annex ()+	-- ^ called when content is removed from a repository+	, addedContent :: UUID -> Key -> Annex ()+	-- ^ called when content is added to a repository+	}++{- Type of function that takes a error handler, which is+ - used to handle a ProtoFailure when receiving a message+ - from the client or remote.+ -}+type ProtoErrorHandled r = +	(forall t. ((t -> Annex r) -> Annex (Either ProtoFailure t) -> Annex r)) -> Annex r++{- This is the first thing run when proxying with a client. + - The client has already authenticated. Most clients will send a+ - VERSION message, although version 0 clients will not and will send+ - some other message, which is returned to handle later.+ -+ - But before the client will send VERSION, it needs to see AUTH_SUCCESS.+ - So send that, although the connection with the remote is not actually+ - brought up yet.+ -}+getClientProtocolVersion +	:: UUID+	-> ClientSide+	-> (Maybe (ProtocolVersion, Maybe Message) -> Annex r)+	-> ProtoErrorHandled r+getClientProtocolVersion remoteuuid (ClientSide clientrunst clientconn) cont protoerrhandler =+	protoerrhandler cont $ client $ getClientProtocolVersion' remoteuuid+  where+	client = liftIO . runNetProto clientrunst clientconn++getClientProtocolVersion'+	:: UUID+	-> Proto (Maybe (ProtocolVersion, Maybe Message))+getClientProtocolVersion' remoteuuid = do+	net $ sendMessage (AUTH_SUCCESS remoteuuid)+	msg <- net receiveMessage+	case msg of+		Nothing -> return Nothing+		Just (VERSION v) -> +			-- If the client sends a newer version than we+			-- understand, reduce it; we need to parse the+			-- protocol too.+			let v' = min v maxProtocolVersion+			in return (Just (v', Nothing))+		Just othermsg -> return+			(Just (defaultProtocolVersion, Just othermsg))++{- Send negotiated protocol version to the client.+ - With a version 0 client, preserves the other protocol message+ - received in getClientProtocolVersion. -}+sendClientProtocolVersion+	:: ClientSide+	-> Maybe Message+	-> ProtocolVersion+	-> (Maybe Message -> Annex r)+	-> ProtoErrorHandled r+sendClientProtocolVersion (ClientSide clientrunst clientconn) othermsg protocolversion cont protoerrhandler = +	case othermsg of+		Nothing -> protoerrhandler (\() -> cont Nothing) $ +			client $ net $ sendMessage $ VERSION protocolversion+		Just _ -> cont othermsg+  where+	client = liftIO . runNetProto clientrunst clientconn++{- When speaking to a version 2 client, get the BYPASS message which may be+ - sent immediately after VERSION. Returns any other message to be handled+ - later. -}+getClientBypass+	:: ClientSide+	-> ProtocolVersion+	-> Maybe Message+	-> ((Bypass, Maybe Message) -> Annex r)+	-> ProtoErrorHandled r+getClientBypass (ClientSide clientrunst clientconn) (ProtocolVersion protocolversion) Nothing cont protoerrhandler+	| protocolversion < 2 = cont (Bypass S.empty, Nothing)+	| otherwise = protoerrhandler cont $+		client $ net receiveMessage >>= return . \case+			Just (BYPASS bypass) -> (bypass, Nothing)+			Just othermsg -> (Bypass S.empty, Just othermsg)+			Nothing -> (Bypass S.empty, Nothing)+  where+	client = liftIO . runNetProto clientrunst clientconn+getClientBypass _ _ (Just othermsg) cont _ =+	-- Pass along non-BYPASS message from version 0 client.+	cont (Bypass S.empty, (Just othermsg))++{- Proxy between the client and the remote. This picks up after+ - sendClientProtocolVersion.+ -}+proxy +	:: Annex r+	-> ProxyMethods+	-> ServerMode+	-> ClientSide+	-> UUID+	-> ProxySelector+	-> ConcurrencyConfig+	-> ProtocolVersion+	-- ^ Protocol version being spoken between the proxy and the+	-- client. When there are multiple remotes, some may speak an+	-- earlier version.+	-> Maybe Message+	-- ^ non-VERSION message that was received from the client when+	-- negotiating protocol version, and has not been responded to yet+	-> ProtoErrorHandled r+proxy proxydone proxymethods servermode (ClientSide clientrunst clientconn) remoteuuid proxyselector concurrencyconfig (ProtocolVersion protocolversion) othermsg protoerrhandler = do+	case othermsg of+		Nothing -> proxynextclientmessage ()+		Just message -> proxyclientmessage (Just message)+  where+	client = liftIO . runNetProto clientrunst clientconn++	proxynextclientmessage () = protoerrhandler proxyclientmessage $+		client (net receiveMessage)++	servermodechecker c a = c servermode $ \case+		Nothing -> a+		Just notallowed -> +			protoerrhandler proxynextclientmessage $+				client notallowed++	proxyclientmessage Nothing = proxydone+	proxyclientmessage (Just message) = case message of+		CHECKPRESENT k -> proxyCHECKPRESENT proxyselector k >>= \case+			Just remoteside -> +				proxyresponse remoteside message+					(const proxynextclientmessage)+			Nothing -> +				protoerrhandler proxynextclientmessage $+					client $ net $ sendMessage FAILURE+		LOCKCONTENT k -> proxyLOCKCONTENT proxyselector k >>= \case+			Just remoteside -> +				proxyresponse remoteside message +					(const proxynextclientmessage)+			Nothing ->+				protoerrhandler proxynextclientmessage $+					client $ net $ sendMessage FAILURE+		UNLOCKCONTENT -> proxyUNLOCKCONTENT proxyselector >>= \case+			Just remoteside ->+				proxynoresponse remoteside message+					proxynextclientmessage+			Nothing -> proxynextclientmessage ()+		REMOVE k -> do+			remotesides <- proxyREMOVE proxyselector k+			servermodechecker checkREMOVEServerMode $+				handleREMOVE remotesides k message+		GET _ _ k -> proxyGET proxyselector k >>= \case+			Just remoteside -> handleGET remoteside message+			Nothing -> +				protoerrhandler proxynextclientmessage $+					client $ net $ sendMessage $ +						ERROR "content not present"+		PUT paf k -> do+			af <- getassociatedfile paf+			remotesides <- proxyPUT proxyselector af k+			servermodechecker checkPUTServerMode $+				handlePUT remotesides k message+		BYPASS _ -> proxynextclientmessage ()+		-- These messages involve the git repository, not the+		-- annex. So they affect the git repository of the proxy,+		-- not the remote.+		CONNECT service -> +			servermodechecker (checkCONNECTServerMode service) $+				-- P2P protocol does not continue after+				-- relaying from git.+				protoerrhandler (\() -> proxydone) $+					client $ net $ relayService service +		NOTIFYCHANGE -> protoerr+		-- Messages that the client should only send after one of+		-- the messages above.+		SUCCESS -> protoerr+		SUCCESS_PLUS _ -> protoerr+		FAILURE -> protoerr+		FAILURE_PLUS _ -> protoerr+		DATA _ -> protoerr+		VALIDITY _ -> protoerr+		-- If the client errors out, give up.+		ERROR msg -> giveup $ "client error: " ++ msg+		-- Messages that only the server should send.+		CONNECTDONE _ -> protoerr+		CHANGED _ -> protoerr+		AUTH_SUCCESS _ -> protoerr+		AUTH_FAILURE -> protoerr+		PUT_FROM _ -> protoerr+		ALREADY_HAVE -> protoerr+		ALREADY_HAVE_PLUS _ -> protoerr+		-- Early messages that the client should not send now.+		AUTH _ _ -> protoerr+		VERSION _ -> protoerr++	-- Send a message to the remote, send its response back to the+	-- client, and pass it to the continuation.+	proxyresponse remoteside message a = +		getresponse (runRemoteSide remoteside) message $ \resp ->+			protoerrhandler (a resp) $+				client $ net $ sendMessage resp+	+	-- Send a message to the remote, that it will not respond to.+	proxynoresponse remoteside message a =+		protoerrhandler a $+			runRemoteSide remoteside $ net $ sendMessage message+	+	-- Send a message to the endpoint and get back its response.+	getresponse endpoint message handleresp =+		protoerrhandler (withresp handleresp) $ +			endpoint $ net $ do+				sendMessage message+				receiveMessage++	withresp a (Just resp) = a resp+	-- Whichever of the remote or client the message was read from +	-- hung up.+	withresp _ Nothing = proxydone++	-- Read a message from one party, send it to the other,+	-- and then pass the message to the continuation.+	relayonemessage from to cont =+		flip protoerrhandler (from $ net $ receiveMessage) $+			withresp $ \message ->+				protoerrhandler (cont message) $+					to $ net $ sendMessage message+	+	protoerr = do+		_ <- client $ net $ sendMessage (ERROR "protocol error X")+		giveup "protocol error M"+	+	handleREMOVE [] _ _ =+		-- When no places are provided to remove from,+		-- don't report a successful remote.+		protoerrhandler proxynextclientmessage $+			client $ net $ sendMessage FAILURE	+	handleREMOVE remotesides k message = do+		v <- forMC concurrencyconfig remotesides $ \r ->+			runRemoteSideOrSkipFailed r $ do+				net $ sendMessage message+				net receiveMessage >>= return . \case+					Just SUCCESS ->+						Just ((True, Nothing), [Remote.uuid (remote r)])+					Just (SUCCESS_PLUS us) -> +						Just ((True, Nothing), Remote.uuid (remote r):us)+					Just FAILURE ->+						Just ((False, Nothing), [])+					Just (FAILURE_PLUS us) ->+						Just ((False, Nothing), us)+					Just (ERROR err) ->+						Just ((False, Just err), [])+					_ -> Nothing+		let v' = map join v+		let us = concatMap snd $ catMaybes v'+		mapM_ (\u -> removedContent proxymethods u k) us+		protoerrhandler proxynextclientmessage $+			client $ net $ sendMessage $+				let nonplussed = all (== remoteuuid) us +					|| protocolversion < 2+				in if all (maybe False (fst . fst)) v'+					then if nonplussed+						then SUCCESS+						else SUCCESS_PLUS us+					else if nonplussed+						then case mapMaybe (snd . fst) (catMaybes v') of+							[] -> FAILURE+							(err:_) -> ERROR err+						else FAILURE_PLUS us++	handleGET remoteside message = getresponse (runRemoteSide remoteside) message $+		withDATA (relayGET remoteside) $ \case+			ERROR err -> protoerrhandler proxynextclientmessage $+				client $ net $ sendMessage (ERROR err)+			_ -> protoerr++	handlePUT (remoteside:[]) k message+		| Remote.uuid (remote remoteside) == remoteuuid =+			getresponse (runRemoteSide remoteside) message $ \resp -> case resp of+				ALREADY_HAVE -> protoerrhandler proxynextclientmessage $+					client $ net $ sendMessage resp+				ALREADY_HAVE_PLUS _ -> protoerrhandler proxynextclientmessage $+					client $ net $ sendMessage resp+				PUT_FROM _ -> +					getresponse client resp $ +						withDATA+							(relayPUT remoteside k)+							(const protoerr)+				_ -> protoerr+	handlePUT [] _ _ = +		protoerrhandler proxynextclientmessage $+			client $ net $ sendMessage ALREADY_HAVE+	handlePUT remotesides k message = +		handlePutMulti remotesides k message++	withDATA a _ message@(DATA len) = a len message+	withDATA _ a message = a message+	+	relayGET remoteside len = relayDATAStart client $+		relayDATACore len (runRemoteSide remoteside) client $+			relayDATAFinish (runRemoteSide remoteside) client $+				relayonemessage client (runRemoteSide remoteside) $+					const proxynextclientmessage+	+	relayPUT remoteside k len = relayDATAStart (runRemoteSide remoteside) $+		relayDATACore len client (runRemoteSide remoteside) $+			relayDATAFinish client (runRemoteSide remoteside) $+				relayonemessage (runRemoteSide remoteside) client finished+	  where+		finished resp () = do+			void $ relayPUTRecord k remoteside resp+			proxynextclientmessage ()++	relayPUTRecord k remoteside SUCCESS = do+		addedContent proxymethods (Remote.uuid (remote remoteside)) k+		return $ Just [Remote.uuid (remote remoteside)]+	relayPUTRecord k remoteside (SUCCESS_PLUS us) = do+		let us' = (Remote.uuid (remote remoteside)) : us+		forM_ us' $ \u ->+			addedContent proxymethods u k+		return $ Just us'+	relayPUTRecord _ _ _ =+		return Nothing++	handlePutMulti remotesides k message = do+		let initiate remoteside = do+			resp <- runRemoteSideOrSkipFailed remoteside $ net $ do+                                  sendMessage message+                                  receiveMessage+			case resp of+				Just (Just (PUT_FROM (Offset offset))) -> +					return $ Right $+						Right (remoteside, offset)+				Just (Just ALREADY_HAVE) -> +					return $ Right $ Left remoteside+				Just (Just _) -> protoerr+				Just Nothing -> return (Left ())+				Nothing -> return (Left ())+		let alreadyhave = \case+			Right (Left _) -> True+			_ -> False+		l <- forMC concurrencyconfig remotesides initiate+		if all alreadyhave l+			then if protocolversion < 2+				then protoerrhandler proxynextclientmessage $+					client $ net $ sendMessage ALREADY_HAVE+				else protoerrhandler proxynextclientmessage $+					client $ net $ sendMessage $ ALREADY_HAVE_PLUS $+						filter (/= remoteuuid) $+							map (Remote.uuid . remote) (lefts (rights l))+			else if null (rights l)+				-- no response from any remote+				then proxydone+				else do+					let l' = rights (rights l)+					let minoffset = minimum (map snd l')+					getresponse client (PUT_FROM (Offset minoffset)) $+						withDATA (relayPUTMulti minoffset l' k)+							(const protoerr)+	+	relayPUTMulti minoffset remotes k (Len datalen) _ = do+		let totallen = datalen + minoffset+		-- Tell each remote how much data to expect, depending+		-- on the remote's offset.+		rs <- forMC concurrencyconfig remotes $ \r@(remoteside, remoteoffset) ->+			runRemoteSideOrSkipFailed remoteside $ do+				net $ sendMessage $ DATA $ Len $+					totallen - remoteoffset+				return r+		protoerrhandler (send (catMaybes rs) minoffset) $+			client $ net $ receiveBytes (Len datalen) nullMeterUpdate+	  where+		chunksize = fromIntegral defaultChunkSize+		+	  	-- Stream the lazy bytestring out to the remotes in chunks.+		-- Only start sending to a remote once past its desired+		-- offset.+		send rs n b = do+			let (chunk, b') = L.splitAt chunksize b+			let chunklen = fromIntegral (L.length chunk)+			let !n' = n + chunklen+			rs' <- forMC concurrencyconfig rs $ \r@(remoteside, remoteoffset) ->+				if n >= remoteoffset+					then runRemoteSideOrSkipFailed remoteside $ do+						net $ sendBytes (Len chunklen) chunk nullMeterUpdate+						return r+					else if (n' > remoteoffset)+						then do+							let chunkoffset = remoteoffset - n+							let subchunklen = chunklen - chunkoffset+							let subchunk = L.drop (fromIntegral chunkoffset) chunk+							runRemoteSideOrSkipFailed remoteside $ do+								net $ sendBytes (Len subchunklen) subchunk nullMeterUpdate+								return r+						else return (Just r)+			if L.null b'+				then sent (catMaybes rs')+				else send (catMaybes rs') n' b'++		sent [] = proxydone+		sent rs = relayDATAFinishMulti k (map fst rs)+	+	runRemoteSideOrSkipFailed remoteside a = +		runRemoteSide remoteside a >>= \case+			Right v -> return (Just v)+			Left _ -> do+				-- This connection to the remote is+				-- unrecoverable at this point, so close it.+				closeRemoteSide remoteside+				return Nothing++	relayDATAStart x receive message =+		protoerrhandler (\() -> receive) $+			x $ net $ sendMessage message++	relayDATACore len x y a = protoerrhandler send $+			x $ net $ receiveBytes len nullMeterUpdate+	  where+		send b = protoerrhandler a $+			y $ net $ sendBytes len b nullMeterUpdate+	+	relayDATAFinish x y sendsuccessfailure ()+		| protocolversion == 0 = sendsuccessfailure+		-- Protocol version 1 has a VALID or+		-- INVALID message after the data.+		| otherwise = relayonemessage x y (\_ () -> sendsuccessfailure)++	relayDATAFinishMulti k rs+		| protocolversion == 0 = +			finish $ net receiveMessage+		| otherwise =+			flip protoerrhandler (client $ net $ receiveMessage) $+				withresp $ \message ->+					finish $ do+						-- Relay VALID or INVALID message+						-- only to remotes that support+						-- protocol version 1.+						net getProtocolVersion >>= \case+							ProtocolVersion 0 -> return ()+							_ -> net $ sendMessage message+						net receiveMessage			+	  where+		finish a = do+			storeduuids <- forMC concurrencyconfig rs $ \r -> +				runRemoteSideOrSkipFailed r a >>= \case+					Just (Just resp) ->+						relayPUTRecord k r resp+					_ -> return Nothing+			protoerrhandler proxynextclientmessage $+				client $ net $ sendMessage $+					case concat (catMaybes storeduuids) of+						[] -> FAILURE+						us+							| protocolversion < 2 -> SUCCESS+							| otherwise -> SUCCESS_PLUS us++	-- The associated file received from the P2P protocol+	-- is relative to the top of the git repository. But this process+	-- may be running with a different cwd.+	getassociatedfile (ProtoAssociatedFile (AssociatedFile (Just f))) =+		AssociatedFile . Just +			<$> fromRepo (fromTopFilePath (asTopFilePath f))+	getassociatedfile (ProtoAssociatedFile (AssociatedFile Nothing)) = +		return $ AssociatedFile Nothing++data ConcurrencyConfig = ConcurrencyConfig Int (MSem.MSem Int)++noConcurrencyConfig :: Annex ConcurrencyConfig+noConcurrencyConfig = liftIO $ ConcurrencyConfig 1 <$> MSem.new 1++getConcurrencyConfig :: Annex ConcurrencyConfig+getConcurrencyConfig = (annexJobs <$> Annex.getGitConfig) >>= \case+	NonConcurrent -> noConcurrencyConfig+	Concurrent n -> go n+	ConcurrentPerCpu -> go =<< liftIO getNumProcessors+  where+	go n = do+		c <- liftIO getNumCapabilities+		when (n > c) $+			liftIO $ setNumCapabilities n+		setConcurrency (ConcurrencyGitConfig (Concurrent n))+		msem <- liftIO $ MSem.new n+		return (ConcurrencyConfig n msem)++forMC :: ConcurrencyConfig -> [a] -> (a -> Annex b) -> Annex [b]+forMC _ (x:[]) a = do+	r <- a x+	return [r]+forMC (ConcurrencyConfig n msem) xs a+	| n < 2 = forM xs a+	| otherwise = do+		runners <- forM xs $ \x ->+			forkState $ bracketIO +				(MSem.wait msem)+				(const $ MSem.signal msem)+				(const $ a x)+		mapM id =<< liftIO (forConcurrently runners id)+

@@ -342,11 +342,12 @@  {- Displays known locations of a key and helps the user take action  - to make them accessible. -}-showLocations :: Bool -> Key -> [UUID] -> String -> Annex ()-showLocations separateuntrusted key exclude nolocmsg = do+showLocations :: Bool -> Key -> (UUID -> Annex Bool) -> String -> Annex ()+showLocations separateuntrusted key checkexclude nolocmsg = do 	u <- getUUID 	remotes <- remoteList 	uuids <- keyLocations key+	exclude <- filterM checkexclude uuids 	untrusteduuids <- if separateuntrusted 		then trustGet UnTrusted 		else pure []@@ -447,11 +448,14 @@   where 	checkclaim = maybe (pure False) (`id` url) . claimUrl -{- Is this a remote of a type we can sync with, or a special remote- - with an annex:: url configured? -}+{- Is this a remote of a type that git pull and push work with?+ - That includes special remotes with an annex:: url configured.+ - It does not include proxied remotes. -} gitSyncableRemote :: Remote -> Bool gitSyncableRemote r-	| gitSyncableRemoteType (remotetype r) = True+	| gitSyncableRemoteType (remotetype r) +		&& isJust (remoteUrl (gitconfig r)) =+			not (isJust (remoteAnnexProxiedBy (gitconfig r))) 	| otherwise = case remoteUrl (gitconfig r) of 		Just u | "annex::" `isPrefixOf` u -> True 		_ -> False

@@ -118,8 +118,8 @@ 		unless ok $ 			get [] -uploadKey :: Key -> AssociatedFile -> MeterUpdate -> Annex ()-uploadKey _ _ _ = giveup "upload to bittorrent not supported"+uploadKey :: Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex ()+uploadKey _ _ _ _ = giveup "upload to bittorrent not supported"  dropKey :: Key -> Annex () dropKey k = mapM_ (setUrlMissing k) =<< getBitTorrentUrls k

@@ -1,6 +1,6 @@ {- Standard git remotes.  -- - Copyright 2011-2023 Joey Hess <id@joeyh.name>+ - Copyright 2011-2024 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -25,7 +25,6 @@ import qualified Git.GCrypt import qualified Git.Types as Git import qualified Annex-import Logs.Presence import Annex.Transfer import Annex.CopyFile import Annex.Verify@@ -45,6 +44,8 @@ import Types.CleanupActions import qualified CmdLine.GitAnnexShell.Fields as Fields import Logs.Location+import Logs.Proxy+import Logs.Cluster.Basic import Utility.Metered import Utility.Env import Utility.Batch@@ -66,7 +67,8 @@  import Control.Concurrent import qualified Data.Map as M-import qualified Data.ByteString as S+import qualified Data.Set as S+import qualified Data.ByteString as B import qualified Utility.RawFilePath as R import Network.URI @@ -92,7 +94,13 @@ list autoinit = do 	c <- fromRepo Git.config 	rs <- mapM (tweakurl c) =<< Annex.getGitRemotes-	mapM (configRead autoinit) (filter (not . isGitRemoteAnnex) rs)+	rs' <- mapM (configRead autoinit) (filter (not . isGitRemoteAnnex) rs)+	proxies <- doQuietAction getProxies+	if proxies == mempty+		then return rs'+		else do+			proxied <- listProxied proxies rs'+			return (proxied++rs')   where 	annexurl r = remoteConfig r "annexurl" 	tweakurl c r = do@@ -168,6 +176,7 @@ 			Just r' -> return r' 		_ -> return r + gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen r u rc gc rs 	-- Remote.GitLFS may be used with a repo that is also encrypted@@ -178,10 +187,9 @@ 		Nothing -> do 			st <- mkState r u gc 			c <- parsedRemoteConfig remote rc-			go st c <$> remoteCost gc c defcst+			go st c <$> remoteCost gc c (defaultRepoCost r) 		Just addr -> Remote.P2P.chainGen addr r u rc gc rs   where-	defcst = if repoCheap r then cheapRemoteCost else expensiveRemoteCost 	go st c cst = Just new 	  where 		new = Remote @@ -221,6 +229,11 @@ 			, remoteStateHandle = rs 			} +defaultRepoCost :: Git.Repo -> Cost+defaultRepoCost r+	| repoCheap r = cheapRemoteCost+	| otherwise = expensiveRemoteCost+ unavailable :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) unavailable r = gen r'   where@@ -265,7 +278,7 @@ 		v <- liftIO $ Git.Config.fromPipe r cmd params st 		case v of 			Right (r', val, _err) -> do-				unless (isUUIDConfigured r' || S.null val || not mustincludeuuuid) $ do+				unless (isUUIDConfigured r' || val == mempty || not mustincludeuuuid) $ do 					warning $ UnquotedString $ "Failed to get annex.uuid configuration of repository " ++ Git.repoDescribe r 					warning $ UnquotedString $ "Instead, got: " ++ show val 					warning "This is unexpected; please check the network transport!"@@ -338,7 +351,7 @@ 	readlocalannexconfig = do 		let check = do 			Annex.BranchState.disableUpdate-			catchNonAsync (autoInitialize (pure [])) $ \e ->+			catchNonAsync (autoInitialize noop (pure [])) $ \e -> 				warning $ UnquotedString $ "Remote " ++ Git.repoDescribe r ++ 					": "  ++ show e 			Annex.getState Annex.repo@@ -442,7 +455,8 @@ 		, giveup "remote does not have expected annex.uuid value" 		) 	| Git.repoIsHttp repo = giveup "dropping from http remote not supported"-	| otherwise = P2PHelper.remove (Ssh.runProto r connpool (return False)) key+	| otherwise = P2PHelper.remove (uuid r) +		(Ssh.runProto r connpool (return (Right False, Nothing))) key  lockKey :: Remote -> State -> Key -> (VerifiedCopy -> Annex r) -> Annex r lockKey r st key callback = do@@ -464,7 +478,7 @@ 		) 	| Git.repoIsSsh repo = do 		showLocking r-		let withconn = Ssh.withP2PSshConnection r connpool failedlock+		let withconn = Ssh.withP2PShellConnection r connpool failedlock 		P2PHelper.lock withconn Ssh.runProtoConn (uuid r) key callback 	| otherwise = failedlock   where@@ -490,7 +504,7 @@ 		let bwlimit = remoteAnnexBwLimitDownload (gitconfig r) 			<|> remoteAnnexBwLimit (gitconfig r) 		-- run copy from perspective of remote-		onLocalFast st $ Annex.Content.prepSendAnnex' key >>= \case+		onLocalFast st $ Annex.Content.prepSendAnnex' key Nothing >>= \case 			Just (object, _sz, check) -> do 				let checksuccess = check >>= \case 					Just err -> giveup err@@ -529,22 +543,22 @@ #endif  {- Tries to copy a key's content to a remote's annex. -}-copyToRemote :: Remote -> State -> Key -> AssociatedFile -> MeterUpdate -> Annex ()-copyToRemote r st key file meterupdate = do+copyToRemote :: Remote -> State -> Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex ()+copyToRemote r st key af o meterupdate = do 	repo <- getRepo r-	copyToRemote' repo r st key file meterupdate+	copyToRemote' repo r st key af o meterupdate -copyToRemote' :: Git.Repo -> Remote -> State -> Key -> AssociatedFile -> MeterUpdate -> Annex ()-copyToRemote' repo r st@(State connpool duc _ _ _) key file meterupdate+copyToRemote' :: Git.Repo -> Remote -> State -> Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex ()+copyToRemote' repo r st@(State connpool duc _ _ _) key af o meterupdate 	| not $ Git.repoIsUrl repo = ifM duc 		( guardUsable repo (giveup "cannot access remote") $ commitOnCleanup repo r st $-			copylocal =<< Annex.Content.prepSendAnnex' key+			copylocal =<< Annex.Content.prepSendAnnex' key o 		, giveup "remote does not have expected annex.uuid value" 		) 	| Git.repoIsSsh repo =-		P2PHelper.store (gitconfig r)-			(Ssh.runProto r connpool (return False))-			key file meterupdate+		P2PHelper.store (uuid r) (gitconfig r)+			(Ssh.runProto r connpool (return Nothing))+			key af o meterupdate 		 	| otherwise = giveup "copying to non-ssh repo not supported"   where@@ -561,14 +575,14 @@ 		-- run copy from perspective of remote 		res <- onLocalFast st $ ifM (Annex.Content.inAnnex key) 			( return True-			, runTransfer (Transfer Download u (fromKey id key)) Nothing file Nothing stdRetry $ \p -> do+			, runTransfer (Transfer Download u (fromKey id key)) Nothing af Nothing stdRetry $ \p -> do 				let verify = RemoteVerify r 				copier <- mkFileCopier hardlink st 				let rsp = RetrievalAllKeysSecure 				let checksuccess = liftIO checkio >>= \case 					Just err -> giveup err 					Nothing -> return True-				logStatusAfter key $ Annex.Content.getViaTmp rsp verify key file (Just sz) $ \dest ->+				logStatusAfter key $ Annex.Content.getViaTmp rsp verify key af (Just sz) $ \dest -> 					metered (Just (combineMeterUpdate meterupdate p)) key bwlimit $ \_ p' ->  						copier object (fromRawFilePath dest) key p' checksuccess verify 			)@@ -594,7 +608,7 @@ 	s <- Annex.new r 	Annex.eval s $ do 		Annex.BranchState.disableUpdate-		ensureInitialized (pure [])+		ensureInitialized noop (pure []) 		a `finally` quiesce True  data LocalRemoteAnnex = LocalRemoteAnnex Git.Repo (MVar [(Annex.AnnexState, Annex.AnnexRead)])@@ -638,7 +652,7 @@ 	[] -> do 		liftIO $ putMVar mv [] 		v <- newLocal repo-		go (v, ensureInitialized (pure []) >> a)+		go (v, ensureInitialized noop (pure []) >> a) 	(v:rest) -> do 		liftIO $ putMVar mv rest 		go (v, a)@@ -725,7 +739,7 @@  - This returns False when the repository UUID is not as expected. -} type DeferredUUIDCheck = Annex Bool -data State = State Ssh.P2PSshConnectionPool DeferredUUIDCheck CopyCoWTried (Annex (Git.Repo, GitConfig)) LocalRemoteAnnex+data State = State Ssh.P2PShellConnectionPool DeferredUUIDCheck CopyCoWTried (Annex (Git.Repo, GitConfig)) LocalRemoteAnnex  getRepoFromState :: State -> Annex Git.Repo getRepoFromState (State _ _ _ a _) = fst <$> a@@ -738,7 +752,7 @@  mkState :: Git.Repo -> UUID -> RemoteGitConfig -> Annex State mkState r u gc = do-	pool <- Ssh.mkP2PSshConnectionPool+	pool <- Ssh.mkP2PShellConnectionPool 	copycowtried <- liftIO newCopyCoWTried 	lra <- mkLocalRemoteAnnex r 	(duc, getrepo) <- go@@ -772,3 +786,122 @@ 				)  			return (duc, getrepo)++listProxied :: M.Map UUID (S.Set Proxy) -> [Git.Repo] -> Annex [Git.Repo]+listProxied proxies rs = concat <$> mapM go rs+  where+	go r = do+		g <- Annex.gitRepo+		u <- getRepoUUID r+		gc <- Annex.getRemoteGitConfig r+		let cu = fromMaybe u $ remoteAnnexConfigUUID gc+		if not (canproxy gc r) || cu == NoUUID+			then pure []+			else case M.lookup cu proxies of+				Nothing -> pure []+				Just proxied -> catMaybes+					<$> mapM (mkproxied g r gc proxied)+						(S.toList proxied)+	+	proxiedremotename r p = do+		n <- Git.remoteName r+		pure $ n ++ "-" ++ proxyRemoteName p++	mkproxied g r gc proxied p = case proxiedremotename r p of+		Nothing -> pure Nothing+		Just proxyname -> mkproxied' g r gc proxied p proxyname+	+	-- The proxied remote is constructed by renaming the proxy remote,+	-- changing its uuid, and setting the proxied remote's inherited+	-- configs and uuid in Annex state.+	mkproxied' g r gc proxied p proxyname+		| any isconfig (M.keys (Git.config g)) = pure Nothing+		| otherwise = do+			clusters <- getClustersWith id+			-- Not using addGitConfigOverride for inherited+			-- configs, because child git processes do not+			-- need them to be provided with -c.+			Annex.adjustGitRepo (pure . annexconfigadjuster clusters)+			return $ Just $ renamedr+	  where+		renamedr = +			let c = adduuid configkeyUUID $+				Git.fullconfig r+			in r +				{ Git.remoteName = Just proxyname+				, Git.config = M.map Prelude.head c+				, Git.fullconfig = c+				}+		+		annexconfigadjuster clusters r' = +			let c = adduuid (configRepoUUID renamedr) $+				addurl $+				addproxiedby $+				adjustclusternode clusters $+				inheritconfigs $ Git.fullconfig r'+			in r'+				{ Git.config = M.map Prelude.head c+				, Git.fullconfig = c+				}++		adduuid ck = M.insert ck+			[Git.ConfigValue $ fromUUID $ proxyRemoteUUID p]++		addurl = M.insert (remoteConfig renamedr (remoteGitConfigKey UrlField))+			[Git.ConfigValue $ encodeBS $ Git.repoLocation r]+		+		addproxiedby = case remoteAnnexUUID gc of+			Just u -> addremoteannexfield ProxiedByField+				[Git.ConfigValue $ fromUUID u]+			Nothing -> id+		+		-- A node of a cluster that is being proxied along with+		-- that cluster does not need to be synced with+		-- by default, because syncing with the cluster will+		-- effectively sync with all of its nodes.+		--+		-- Also, give it a slightly higher cost than the+		-- cluster by default, to encourage using the cluster.+		adjustclusternode clusters =+			case M.lookup (ClusterNodeUUID (proxyRemoteUUID p)) (clusterNodeUUIDs clusters) of+				Just cs+					| any (\c -> S.member (fromClusterUUID c) proxieduuids) (S.toList cs) ->+						addremoteannexfield SyncField+							[Git.ConfigValue $ Git.Config.boolConfig' False]+						. addremoteannexfield CostField +							[Git.ConfigValue $ encodeBS $ show $ defaultRepoCost r + 0.1]+				_ -> id++		proxieduuids = S.map proxyRemoteUUID proxied++		addremoteannexfield f = M.insert+			(remoteAnnexConfig renamedr (remoteGitConfigKey f))++		inheritconfigs c = foldl' inheritconfig c proxyInheritedFields+		+		inheritconfig c k = case (M.lookup dest c, M.lookup src c) of+			(Nothing, Just v) -> M.insert dest v c+			_ -> c+		  where+			src = remoteAnnexConfig r k+			dest = remoteAnnexConfig renamedr k+		+		-- When the git config has anything set for a remote,+		-- avoid making a proxied remote with the same name.+		-- It is possible to set git configs of proxies, but it+		-- needs both the url and uuid config to be manually set.+		isconfig (Git.ConfigKey configkey) = +			proxyconfigprefix `B.isPrefixOf` configkey+		  where +			Git.ConfigKey proxyconfigprefix = remoteConfig proxyname mempty++	-- Git remotes that are gcrypt or git-lfs special remotes cannot+	-- proxy. Local git remotes cannot proxy either because+	-- git-annex-shell is not used to access a local git url.+	-- Proxing is also yet supported for remotes using P2P+	-- addresses.+	canproxy gc r+		| remoteAnnexGitLFS gc = False+		| Git.GCrypt.isEncrypted r = False+		| Git.repoIsLocal r || Git.repoIsLocalUnknown r = False+		| otherwise = isNothing (repoP2PAddress r)

@@ -1,6 +1,6 @@ {- Utilities for git remotes.  -- - Copyright 2011-2014 Joey Hess <id@joeyh.name>+ - Copyright 2011-2024 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -14,9 +14,13 @@ import qualified Types.Remote as Remote import qualified Utility.RawFilePath as R import qualified Git.Config+import Logs.Proxy+import Types.Cluster  import Data.Time.Clock.POSIX import System.PosixCompat.Files (modificationTime)+import qualified Data.Map as M+import qualified Data.Set as S  repoCheap :: Git.Repo -> Bool repoCheap = not . Git.repoIsUrl@@ -62,7 +66,26 @@ 		[] -> "never" 		_ -> show $ posixSecondsToUTCTime $ realToFrac $ maximum mtimes 	repo <- Remote.getRepo r-	return-		[ ("repository location", Git.repoLocation repo)-		, ("last synced", lastsynctime)+	let proxied = Git.Config.boolConfig $ isJust $+		remoteAnnexProxiedBy (Remote.gitconfig r)+	proxies <- getProxies+	let proxying = S.toList $ fromMaybe mempty $+		M.lookup (Remote.uuid r) proxies+	let iscluster = isClusterUUID . proxyRemoteUUID+	let proxyname p = Remote.name r ++ "-" ++ proxyRemoteName p+	let proxynames = map proxyname $ filter (not . iscluster) proxying+	let clusternames = map proxyname $ filter iscluster proxying+	return $ catMaybes+		[ Just ("repository location", Git.repoLocation repo)+		, Just ("last synced", lastsynctime)+		, Just ("proxied", proxied)+		, if isClusterUUID (Remote.uuid r)+			then Just ("cluster", Git.Config.boolConfig True)+			else Nothing+		, if null clusternames+			then Nothing+			else Just ("gateway to cluster", unwords clusternames)+		, if null proxynames+			then Nothing+			else Just ("proxying", unwords proxynames) 		]

@@ -34,8 +34,8 @@ addHooks' r starthook stophook = r'   where 	r' = r-		{ storeKey = \k f p -> -			wrapper $ storeKey r k f p+		{ storeKey = \k af o p -> +			wrapper $ storeKey r k af o p 		, retrieveKeyFile = \k f d p vc ->  			wrapper $ retrieveKeyFile r k f d p vc 		, retrieveKeyFileCheap = case retrieveKeyFileCheap r of

@@ -1,6 +1,6 @@ {- Helpers for remotes using the git-annex P2P protocol.  -- - Copyright 2016-2021 Joey Hess <id@joeyh.name>+ - Copyright 2016-2024 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -19,6 +19,8 @@ import Utility.Tuple import Types.NumCopies import Annex.Verify+import Logs.Location+import Utility.SafeOutput  import Control.Concurrent @@ -32,14 +34,20 @@ -- the pool when done. type WithConn a c = (ClosableConnection c -> Annex (ClosableConnection c, a)) -> Annex a -store :: RemoteGitConfig -> ProtoRunner Bool -> Key -> AssociatedFile -> MeterUpdate -> Annex ()-store gc runner k af p = do-	let sizer = KeySizer k (fmap (toRawFilePath . fst3) <$> prepSendAnnex k)+store :: UUID -> RemoteGitConfig -> ProtoRunner (Maybe [UUID]) -> Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex ()+store remoteuuid gc runner k af o p = do+	let sizer = KeySizer k (fmap (toRawFilePath . fst3) <$> prepSendAnnex k o) 	let bwlimit = remoteAnnexBwLimitUpload gc <|> remoteAnnexBwLimit gc 	metered (Just p) sizer bwlimit $ \_ p' -> 		runner (P2P.put k af p') >>= \case-			Just True -> return ()-			Just False -> giveup "Transfer failed"+			Just (Just fanoutuuids) -> do+				-- Storing on the remote can cause it+				-- to be stored on additional UUIDs, +				-- so record those.+				forM_ fanoutuuids $ \u ->+					when (u /= remoteuuid) $+						logChange k u InfoPresent+			Just Nothing -> giveup "Transfer failed" 			Nothing -> remoteUnavail  retrieve :: RemoteGitConfig -> (ProtoRunner (Bool, Verification)) -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification@@ -52,14 +60,30 @@ 			Just (False, _) -> giveup "Transfer failed" 			Nothing -> remoteUnavail -remove :: ProtoRunner Bool -> Key -> Annex ()-remove runner k = runner (P2P.remove k) >>= \case-	Just True -> return ()-	Just False -> giveup "removing content from remote failed"+remove :: UUID -> ProtoRunner (Either String Bool, Maybe [UUID]) -> Key -> Annex ()+remove remoteuuid runner k = runner (P2P.remove k) >>= \case+	Just (Right True, alsoremoveduuids) -> note alsoremoveduuids+	Just (Right False, alsoremoveduuids) -> do+		note alsoremoveduuids+		giveup "removing content from remote failed"+	Just (Left err, _) -> do+		giveup (safeOutput err) 	Nothing -> remoteUnavail+  where+	-- The remote reports removal from other UUIDs than its own,+	-- so record those.+	note alsoremoveduuids = +		forM_ (fromMaybe [] alsoremoveduuids) $ \u ->+			when (u /= remoteuuid) $+				logChange k u InfoMissing -checkpresent :: ProtoRunner Bool -> Key -> Annex Bool-checkpresent runner k = maybe remoteUnavail return =<< runner (P2P.checkPresent k)+checkpresent :: ProtoRunner (Either String Bool) -> Key -> Annex Bool+checkpresent runner k =+	runner (P2P.checkPresent k)+		>>= \case+			Nothing -> remoteUnavail+			Just (Right b) -> return b+			Just (Left err) -> giveup (safeOutput err)  lock :: WithConn a c -> ProtoConnRunner c -> UUID -> Key -> (VerifiedCopy -> Annex a) -> Annex a lock withconn connrunner u k callback = withconn $ \conn -> do

@@ -44,8 +44,8 @@ 		} 	| otherwise = r -readonlyStoreKey :: Key -> AssociatedFile -> MeterUpdate -> Annex ()-readonlyStoreKey _ _ _ = readonlyFail+readonlyStoreKey :: Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex ()+readonlyStoreKey _ _ _ _ = readonlyFail  readonlyRemoveKey :: Key -> Annex () readonlyRemoveKey _ = readonlyFail

@@ -134,8 +134,8 @@  - but they are never actually used (since specialRemote replaces them).  - Here are some dummy ones.  -}-storeKeyDummy :: Key -> AssociatedFile -> MeterUpdate -> Annex ()-storeKeyDummy _ _ _ = error "missing storeKey implementation"+storeKeyDummy :: Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex ()+storeKeyDummy _ _ _ _ = error "missing storeKey implementation" retrieveKeyFileDummy :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification retrieveKeyFileDummy _ _ _ _ _ = error "missing retrieveKeyFile implementation" removeKeyDummy :: Key -> Annex ()@@ -181,7 +181,7 @@ specialRemote' cfg c storer retriever remover checkpresent baser = encr   where 	encr = baser-		{ storeKey = \k _f p -> cip >>= storeKeyGen k p+		{ storeKey = \k _af o p -> cip >>= storeKeyGen k o p 		, retrieveKeyFile = \k _f d p vc -> cip >>= retrieveKeyFileGen k d p vc 		, retrieveKeyFileCheap = case retrieveKeyFileCheap baser of 			Nothing -> Nothing@@ -222,7 +222,7 @@ 	isencrypted = isEncrypted c  	-- chunk, then encrypt, then feed to the storer-	storeKeyGen k p enc = sendAnnex k rollback $ \src _sz ->+	storeKeyGen k o p enc = sendAnnex k o rollback $ \src _sz -> 		displayprogress uploadbwlimit p k (Just src) $ \p' -> 			storeChunks (uuid baser) chunkconfig enck k src p' 				enc encr storer checkpresent

@@ -1,6 +1,6 @@ {- git-annex remote access with ssh and git-annex-shell  -- - Copyright 2011-2022 Joey Hess <id@joeyh.name>+ - Copyright 2011-2024 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -21,6 +21,7 @@ import Utility.Metered import Utility.Rsync import Utility.SshHost+import Utility.Debug import Types.Remote import Types.Transfer import Config@@ -61,9 +62,10 @@ 	shellcmd = "git-annex-shell" 	getshellopts = do 		debugenabled <- Annex.getRead Annex.debugenabled-		let params' = if debugenabled-			then Param "--debug" : params-			else params+		debugselector <- Annex.getRead Annex.debugselector+		let params' = case (debugenabled, debugselector) of+			(True, NoDebugSelector) -> Param "--debug" : params+			_ -> params 		return (Param command : File (fromRawFilePath dir) : params') 	uuidcheck NoUUID = [] 	uuidcheck u@(UUID _) = ["--uuid", fromUUID u]@@ -178,70 +180,81 @@ 		| otherwise = remoteAnnexRsyncUploadOptions gc 	gc = gitconfig r --- A connection over ssh to git-annex shell speaking the P2P protocol.-type P2PSshConnection = P2P.ClosableConnection +-- A connection over ssh or locally to git-annex shell,+-- speaking the P2P protocol.+type P2PShellConnection = P2P.ClosableConnection  	(P2P.RunState, P2P.P2PConnection, ProcessHandle) -closeP2PSshConnection :: P2PSshConnection -> IO (P2PSshConnection, Maybe ExitCode)-closeP2PSshConnection P2P.ClosedConnection = return (P2P.ClosedConnection, Nothing)-closeP2PSshConnection (P2P.OpenConnection (_st, conn, pid)) =+closeP2PShellConnection :: P2PShellConnection -> IO (P2PShellConnection, Maybe ExitCode)+closeP2PShellConnection P2P.ClosedConnection = return (P2P.ClosedConnection, Nothing)+closeP2PShellConnection (P2P.OpenConnection (_st, conn, pid)) = 	-- mask async exceptions, avoid cleanup being interrupted 	uninterruptibleMask_ $ do 		P2P.closeConnection conn 		exitcode <- waitForProcess pid 		return (P2P.ClosedConnection, Just exitcode) --- Pool of connections over ssh to git-annex-shell p2pstdio.-type P2PSshConnectionPool = TVar (Maybe P2PSshConnectionPoolState)+-- Pool of connections to git-annex-shell p2pstdio.+type P2PShellConnectionPool = TVar (Maybe P2PShellConnectionPoolState) -data P2PSshConnectionPoolState-	= P2PSshConnections [P2PSshConnection]+data P2PShellConnectionPoolState+	= P2PShellConnections [P2PShellConnection] 	-- Remotes using an old version of git-annex-shell don't support P2P-	| P2PSshUnsupported+	| P2PShellUnsupported -mkP2PSshConnectionPool :: Annex P2PSshConnectionPool-mkP2PSshConnectionPool = liftIO $ newTVarIO Nothing+mkP2PShellConnectionPool :: Annex P2PShellConnectionPool+mkP2PShellConnectionPool = liftIO $ newTVarIO Nothing  -- Takes a connection from the pool, if any are available, otherwise -- tries to open a new one.-getP2PSshConnection :: Remote -> P2PSshConnectionPool -> Annex (Maybe P2PSshConnection)-getP2PSshConnection r connpool = getexistingconn >>= \case+getP2PShellConnection :: Remote -> P2PShellConnectionPool -> Annex (Maybe P2PShellConnection)+getP2PShellConnection r connpool = getexistingconn >>= \case 	Nothing -> return Nothing-	Just Nothing -> openP2PSshConnection r connpool+	Just Nothing -> openP2PShellConnection r connpool 	Just (Just c) -> return (Just c)   where 	getexistingconn = liftIO $ atomically $ readTVar connpool >>= \case-		Just P2PSshUnsupported -> return Nothing-		Just (P2PSshConnections (c:cs)) -> do-			writeTVar connpool (Just (P2PSshConnections cs))+		Just P2PShellUnsupported -> return Nothing+		Just (P2PShellConnections (c:cs)) -> do+			writeTVar connpool (Just (P2PShellConnections cs)) 			return (Just (Just c))-		Just (P2PSshConnections []) -> return (Just Nothing)+		Just (P2PShellConnections []) -> return (Just Nothing) 		Nothing -> return (Just Nothing)  -- Add a connection to the pool, unless it's closed.-storeP2PSshConnection :: P2PSshConnectionPool -> P2PSshConnection -> IO ()-storeP2PSshConnection _ P2P.ClosedConnection = return ()-storeP2PSshConnection connpool conn = atomically $ modifyTVar' connpool $ \case-	Just (P2PSshConnections cs) -> Just (P2PSshConnections (conn:cs))-	_ -> Just (P2PSshConnections [conn])+storeP2PShellConnection :: P2PShellConnectionPool -> P2PShellConnection -> IO ()+storeP2PShellConnection _ P2P.ClosedConnection = return ()+storeP2PShellConnection connpool conn = atomically $ modifyTVar' connpool $ \case+	Just (P2PShellConnections cs) -> Just (P2PShellConnections (conn:cs))+	_ -> Just (P2PShellConnections [conn]) --- Try to open a P2PSshConnection.+-- Try to open a P2PShellConnection. -- The new connection is not added to the pool, so it's available -- for the caller to use. -- If the remote does not support the P2P protocol, that's remembered in  -- the connection pool.-openP2PSshConnection :: Remote -> P2PSshConnectionPool -> Annex (Maybe P2PSshConnection)-openP2PSshConnection r connpool = do+openP2PShellConnection :: Remote -> P2PShellConnectionPool -> Annex (Maybe P2PShellConnection)+openP2PShellConnection r connpool =+	openP2PShellConnection' r P2P.maxProtocolVersion mempty >>= \case+		Just conn -> return (Just conn)+		Nothing -> do+			liftIO $ rememberunsupported+			return Nothing+  where+	rememberunsupported = atomically $+		modifyTVar' connpool $+			maybe (Just P2PShellUnsupported) Just++openP2PShellConnection' :: Remote -> P2P.ProtocolVersion -> P2P.Bypass -> Annex (Maybe P2PShellConnection)+openP2PShellConnection' r maxprotoversion bypass = do 	u <- getUUID 	let ps = [Param (fromUUID u)] 	repo <- getRepo r 	git_annex_shell ConsumeStdin repo "p2pstdio" ps [] >>= \case-		Nothing -> do-			liftIO $ rememberunsupported-			return Nothing-		Just (cmd, params) -> start cmd params =<< getRepo r+		Nothing -> return Nothing+		Just (cmd, params) -> start cmd params   where-	start cmd params repo = liftIO $ do+	start cmd params = liftIO $ do 		(Just from, Just to, Nothing, pid) <- createProcess $ 			(proc cmd (toCommand params)) 				{ std_in = CreatePipe@@ -249,50 +262,46 @@ 				} 		pidnum <- getPid pid 		let conn = P2P.P2PConnection-			{ P2P.connRepo = repo+			{ P2P.connRepo = Nothing 			, P2P.connCheckAuth = const False-			, P2P.connIhdl = to-			, P2P.connOhdl = from+			, P2P.connIhdl = P2P.P2PHandle to+			, P2P.connOhdl = P2P.P2PHandle from 			, P2P.connIdent = P2P.ConnIdent $-				Just $ "ssh connection " ++ show pidnum+				Just $ "git-annex-shell connection " ++ show pidnum 			} 		runst <- P2P.mkRunState P2P.Client 		let c = P2P.OpenConnection (runst, conn, pid) 		-- When the connection is successful, the remote 		-- will send an AUTH_SUCCESS with its uuid.-		let proto = P2P.postAuth $-			P2P.negotiateProtocolVersion P2P.maxProtocolVersion+		let proto = P2P.postAuth $ do+			P2P.negotiateProtocolVersion maxprotoversion+			P2P.sendBypass bypass 		tryNonAsync (P2P.runNetProto runst conn proto) >>= \case 			Right (Right (Just theiruuid)) | theiruuid == uuid r -> 				return $ Just c 			_ -> do-				(cclosed, exitcode) <- closeP2PSshConnection c+				(cclosed, exitcode) <- closeP2PShellConnection c 				-- ssh exits 255 when unable to connect to 				-- server. 				if exitcode == Just (ExitFailure 255) 					then return (Just cclosed)-					else do-						rememberunsupported-						return Nothing-	rememberunsupported = atomically $-		modifyTVar' connpool $-			maybe (Just P2PSshUnsupported) Just+					else return Nothing  -- Runs a P2P Proto action on a remote when it supports that, -- otherwise the fallback action.-runProto :: Remote -> P2PSshConnectionPool -> Annex a -> P2P.Proto a -> Annex (Maybe a)+runProto :: Remote -> P2PShellConnectionPool -> Annex a -> P2P.Proto a -> Annex (Maybe a) runProto r connpool onerr proto = Just <$>-	(getP2PSshConnection r connpool >>= maybe onerr go)+	(getP2PShellConnection r connpool >>= maybe onerr go)   where 	go c = do 		(c', v) <- runProtoConn proto c 		case v of 			Just res -> do-				liftIO $ storeP2PSshConnection connpool c'+				liftIO $ storeP2PShellConnection connpool c' 				return res 			Nothing -> onerr -runProtoConn :: P2P.Proto a -> P2PSshConnection -> Annex (P2PSshConnection, Maybe a)+runProtoConn :: P2P.Proto a -> P2PShellConnection -> Annex (P2PShellConnection, Maybe a) runProtoConn _ P2P.ClosedConnection = return (P2P.ClosedConnection, Nothing) runProtoConn a conn@(P2P.OpenConnection (runst, c, _)) = do 	P2P.runFullProto runst c a >>= \case@@ -301,24 +310,24 @@ 		-- usable, so close it. 		Left e -> do 			warning $ UnquotedString $ "Lost connection (" ++ P2P.describeProtoFailure e ++ ")"-			conn' <- fst <$> liftIO (closeP2PSshConnection conn)+			conn' <- fst <$> liftIO (closeP2PShellConnection conn) 			return (conn', Nothing) --- Allocates a P2P ssh connection from the pool, and runs the action with it,--- returning the connection to the pool once the action is done.+-- Allocates a P2P shell connection from the pool, and runs the action with+-- it, returning the connection to the pool once the action is done. -- -- If the remote does not support the P2P protocol, runs the fallback -- action instead.-withP2PSshConnection+withP2PShellConnection 	:: Remote-	-> P2PSshConnectionPool+	-> P2PShellConnectionPool 	-> Annex a-	-> (P2PSshConnection -> Annex (P2PSshConnection, a))+	-> (P2PShellConnection -> Annex (P2PShellConnection, a)) 	-> Annex a-withP2PSshConnection r connpool fallback a = bracketOnError get cache go+withP2PShellConnection r connpool fallback a = bracketOnError get cache go   where-	get = getP2PSshConnection r connpool-	cache (Just conn) = liftIO $ storeP2PSshConnection connpool conn+	get = getP2PShellConnection r connpool+	cache (Just conn) = liftIO $ storeP2PShellConnection connpool conn 	cache Nothing = return () 	go (Just conn) = do 		(conn', res) <- a conn

@@ -65,7 +65,7 @@ 	, Remote.External.remote 	] -{- Builds a list of all available Remotes.+{- Builds a list of all Remotes.  - Since doing so can be expensive, the list is cached. -} remoteList :: Annex [Remote] remoteList = do

@@ -57,11 +57,11 @@ 		{ uuid = u 		, cost = cst 		, name = Git.repoDescribe r-		, storeKey = store gc protorunner+		, storeKey = store u gc protorunner 		, retrieveKeyFile = retrieve gc protorunner 		, retrieveKeyFileCheap = Nothing 		, retrievalSecurityPolicy = RetrievalAllKeysSecure-		, removeKey = remove protorunner+		, removeKey = remove u protorunner 		, lockContent = Just $ lock withconn runProtoConn u  		, checkPresent = checkpresent protorunner 		, checkPresentCheap = False@@ -143,7 +143,7 @@ openConnection :: UUID -> P2PAddress -> Annex Connection openConnection u addr = do 	g <- Annex.gitRepo-	v <- liftIO $ tryNonAsync $ connectPeer g addr+	v <- liftIO $ tryNonAsync $ connectPeer (Just g) addr 	case v of 		Right conn -> do 			myuuid <- getUUID

@@ -138,8 +138,8 @@   where 	missingfurl = giveup "Set TAHOE_FURL to the introducer furl to use." -store :: RemoteStateHandle -> TahoeHandle -> Key -> AssociatedFile -> MeterUpdate -> Annex ()-store rs hdl k _f _p = sendAnnex k noop $ \src _sz ->+store :: RemoteStateHandle -> TahoeHandle -> Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex ()+store rs hdl k _af o _p = sendAnnex k o noop $ \src _sz -> 	parsePut <$> liftIO (readTahoe hdl "put" [File src]) >>= maybe 		(giveup "tahoe failed to store content") 		(\cap -> storeCapability rs k cap)

@@ -181,8 +181,8 @@ 					setEquivilantKey key ek 				return (Just Verified) -uploadKey :: Key -> AssociatedFile -> MeterUpdate -> Annex ()-uploadKey _ _ _ = giveup "upload to web not supported"+uploadKey :: Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex ()+uploadKey _ _ _ _ = giveup "upload to web not supported"  dropKey :: UrlIncludeExclude -> Key -> Annex () dropKey urlincludeexclude k = mapM_ (setUrlMissing k) =<< getWebUrls' urlincludeexclude k

@@ -111,10 +111,10 @@ 			-- when the allowed set is changed. 			allowed <- loadP2PAuthTokens 			let conn = P2PConnection-				{ connRepo = r+				{ connRepo = Just r 				, connCheckAuth = (`isAllowedAuthToken` allowed)-				, connIhdl = h-				, connOhdl = h+				, connIhdl = P2PHandle h+				, connOhdl = P2PHandle h 				, connIdent = ConnIdent $ Just "tor remotedaemon" 				} 			-- not really Client, but we don't know their uuid yet@@ -146,7 +146,7 @@ 		Nothing -> return () 		Just addr -> robustConnection 1 $ do 			g <- liftAnnex th Annex.gitRepo-			bracket (connectPeer g addr) closeConnection (go addr)+			bracket (connectPeer (Just g) addr) closeConnection (go addr)   where 	go addr conn = do 		myuuid <- liftAnnex th getUUID

@@ -0,0 +1,84 @@+{- git-annex cluster types+ -+ - Copyright 2024 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++{-# LANGUAGE CPP, OverloadedStrings #-}++module Types.Cluster (+	ClusterUUID,+	mkClusterUUID,+	genClusterUUID,+	fromClusterUUID,+	isClusterUUID,+	ClusterNodeUUID(..),+	Clusters(..),+	noClusters,+) where++import Types.UUID++import qualified Data.Set as S+import qualified Data.Map as M+import qualified Data.ByteString as B+import Data.Char++-- The UUID of a cluster as a whole.+--+-- Cluster UUIDs are specially constructed so that regular repository UUIDs+-- can never be used as a cluster UUID. This is ncessary for security.+-- They are a version 8 UUID with the first octet set to 'a' and the second+-- to 'c'.+newtype ClusterUUID = ClusterUUID UUID+	deriving (Show, Eq, Ord)++-- Smart constructor for a ClusterUUID. Only allows valid cluster UUIDs.+mkClusterUUID :: UUID -> Maybe ClusterUUID+mkClusterUUID u+	| isClusterUUID u = Just (ClusterUUID u)+	| otherwise = Nothing++-- Check if it is a valid cluster UUID.+isClusterUUID :: UUID -> Bool+isClusterUUID (UUID b) +	| B.take 2 b == "ac" = +#if MIN_VERSION_bytestring(0,11,0)+		B.indexMaybe b 14 == Just eight+#else+		B.length b > 14 && B.head (B.drop 14 b) == eight+#endif+  where+	eight = fromIntegral (ord '8')+isClusterUUID _ = False++{-# INLINE isClusterUUID #-}++-- Generates a ClusterUUID from any regular UUID (eg V4). +-- It is converted to a valid cluster UUID.+genClusterUUID :: UUID -> Maybe ClusterUUID+genClusterUUID (UUID b)+	| B.length b > 14 = Just $ ClusterUUID $ UUID $+		"ac" <> B.drop 2 (B.take 14 b) <> "8" <> B.drop 15 b+	| otherwise = Nothing+genClusterUUID NoUUID = Nothing++fromClusterUUID :: ClusterUUID -> UUID+fromClusterUUID (ClusterUUID u) = u++-- The UUID of a node in a cluster. The UUID can be either the UUID of a+-- repository, or of another cluster. +newtype ClusterNodeUUID = ClusterNodeUUID { fromClusterNodeUUID :: UUID }+	deriving (Show, Eq, Ord)++-- The same information is indexed two ways to allow fast lookups in either+-- direction.+data Clusters = Clusters+	{ clusterUUIDs :: M.Map ClusterUUID (S.Set ClusterNodeUUID)+	, clusterNodeUUIDs :: M.Map ClusterNodeUUID (S.Set ClusterUUID)+	}+	deriving (Show)++noClusters :: Clusters+noClusters = Clusters mempty mempty

@@ -142,4 +142,5 @@ 	| RepoExists 	| NoDaemonRunning 	| GitAnnexShellOk+	| GitAnnexShellNotProxyable 	deriving (Show, Ord, Eq)

@@ -22,6 +22,9 @@ 	RemoteNameable(..), 	remoteAnnexConfig, 	remoteConfig,+	RemoteGitConfigField(..),+	remoteGitConfigKey,+	proxyInheritedFields, ) where  import Common@@ -30,7 +33,7 @@ import qualified Git.Construct import Git.Types import Git.ConfigTypes-import Git.Remote (isRemoteKey, remoteKeyToRemoteName)+import Git.Remote (isRemoteKey, isLegalName, remoteKeyToRemoteName) import Git.Branch (CommitMode(..)) import Git.Quote (QuotePath(..)) import Utility.DataUnits@@ -44,6 +47,7 @@ import Types.RepoVersion import Types.StallDetection import Types.View+import Types.Cluster import Config.DynamicConfig import Utility.HumanTime import Utility.Gpg (GpgCmd, mkGpgCmd)@@ -154,6 +158,7 @@ 	, annexPrivateRepos :: S.Set UUID 	, annexAdviceNoSshCaching :: Bool 	, annexViewUnsetDirectory :: ViewUnset+	, annexClusters :: M.Map RemoteName ClusterUUID 	}  extractGitConfig :: ConfigSource -> Git.Repo -> GitConfig@@ -282,6 +287,10 @@ 	, annexAdviceNoSshCaching = getbool (annexConfig "advicenosshcaching") True 	, annexViewUnsetDirectory = ViewUnset $ fromMaybe "_" $ 		getmaybe (annexConfig "viewunsetdirectory")+	, annexClusters = +		M.mapMaybe (mkClusterUUID . toUUID) $+			M.mapKeys removeclusterprefix $+				M.filterWithKey isclusternamekey (config r) 	}   where 	getbool k d = fromMaybe d $ getmaybebool k@@ -306,6 +315,11 @@ 	 	hereuuid = maybe NoUUID toUUID $ getmaybe (annexConfig "uuid") +	clusterprefix = annexConfigPrefix <> "cluster."+	isclusternamekey k _ = clusterprefix `B.isPrefixOf` (fromConfigKey' k)+		&& isLegalName (removeclusterprefix k)+	removeclusterprefix k = drop (B.length clusterprefix) (fromConfigKey k)+ {- Merge a GitConfig that comes from git-config with one containing  - repository-global defaults. -} mergeGitConfig :: GitConfig -> GitConfig -> GitConfig@@ -372,9 +386,14 @@ 	, remoteAnnexBwLimitUpload :: Maybe BwRate 	, remoteAnnexBwLimitDownload :: Maybe BwRate 	, remoteAnnexAllowUnverifiedDownloads :: Bool+	, remoteAnnexUUID :: Maybe UUID 	, remoteAnnexConfigUUID :: Maybe UUID 	, remoteAnnexMaxGitBundles :: Int 	, remoteAnnexAllowEncryptedGitRepo :: Bool+	, remoteAnnexProxy :: Bool+	, remoteAnnexProxiedBy :: Maybe UUID+	, remoteAnnexClusterNode :: Maybe [RemoteName]+	, remoteAnnexClusterGateway :: [ClusterUUID] 	, remoteUrl :: Maybe String  	{- These settings are specific to particular types of remotes@@ -409,99 +428,254 @@ extractRemoteGitConfig :: Git.Repo -> RemoteName -> STM RemoteGitConfig extractRemoteGitConfig r remotename = do 	annexcost <- mkDynamicConfig readCommandRunner-		(notempty $ getmaybe "cost-command")-		(getmayberead "cost")+		(notempty $ getmaybe CostCommandField)+		(getmayberead CostField) 	annexignore <- mkDynamicConfig unsuccessfullCommandRunner-		(notempty $ getmaybe "ignore-command")-		(getbool "ignore" False)+		(notempty $ getmaybe IgnoreCommandField)+		(getbool IgnoreField False) 	annexsync <- mkDynamicConfig successfullCommandRunner-		(notempty $ getmaybe "sync-command")-		(getbool "sync" True)+		(notempty $ getmaybe SyncCommandField)+		(getbool SyncField True) 	return $ RemoteGitConfig 		{ remoteAnnexCost = annexcost 		, remoteAnnexIgnore = annexignore 		, remoteAnnexSync = annexsync-		, remoteAnnexPull = getbool "pull" True-		, remoteAnnexPush = getbool "push" True-		, remoteAnnexReadOnly = getbool "readonly" False-		, remoteAnnexCheckUUID = getbool "checkuuid" True-		, remoteAnnexVerify = getbool "verify" True+		, remoteAnnexPull = getbool PullField True+		, remoteAnnexPush = getbool PushField True+		, remoteAnnexReadOnly = getbool ReadOnlyField False+		, remoteAnnexCheckUUID = getbool CheckUUIDField True+		, remoteAnnexVerify = getbool VerifyField True 		, remoteAnnexTrackingBranch = Git.Ref . encodeBS <$>-			( notempty (getmaybe "tracking-branch")-			<|> notempty (getmaybe "export-tracking") -- old name+			( notempty (getmaybe TrackingBranchField)+			<|> notempty (getmaybe ExportTrackingField) -- old name 			)-		, remoteAnnexTrustLevel = notempty $ getmaybe "trustlevel"-		, remoteAnnexStartCommand = notempty $ getmaybe "start-command"-		, remoteAnnexStopCommand = notempty $ getmaybe "stop-command"+		, remoteAnnexTrustLevel = notempty $ getmaybe TrustLevelField+		, remoteAnnexStartCommand = notempty $ getmaybe StartCommandField+		, remoteAnnexStopCommand = notempty $ getmaybe StopCommandField 		, remoteAnnexSpeculatePresent = -			getbool "speculate-present" False-		, remoteAnnexBare = getmaybebool "bare"-		, remoteAnnexRetry = getmayberead "retry"-		, remoteAnnexForwardRetry = getmayberead "forward-retry"+			getbool SpeculatePresentField False+		, remoteAnnexBare = getmaybebool BareField+		, remoteAnnexRetry = getmayberead RetryField+		, remoteAnnexForwardRetry = getmayberead ForwardRetryField 		, remoteAnnexRetryDelay = Seconds-			<$> getmayberead "retrydelay"+			<$> getmayberead RetryDelayField 		, remoteAnnexStallDetection =-			readStallDetection =<< getmaybe "stalldetection"+			readStallDetection =<< getmaybe StallDetectionField 		, remoteAnnexStallDetectionUpload =-			readStallDetection =<< getmaybe "stalldetection-upload"+			readStallDetection =<< getmaybe StallDetectionUploadField 		, remoteAnnexStallDetectionDownload =-			readStallDetection =<< getmaybe "stalldetection-download"+			readStallDetection =<< getmaybe StallDetectionDownloadField 		, remoteAnnexBwLimit =-			readBwRatePerSecond =<< getmaybe "bwlimit"+			readBwRatePerSecond =<< getmaybe BWLimitField 		, remoteAnnexBwLimitUpload =-			readBwRatePerSecond =<< getmaybe "bwlimit-upload"+			readBwRatePerSecond =<< getmaybe BWLimitUploadField 		, remoteAnnexBwLimitDownload =-			readBwRatePerSecond =<< getmaybe "bwlimit-download"+			readBwRatePerSecond =<< getmaybe BWLimitDownloadField 		, remoteAnnexAllowUnverifiedDownloads = (== Just "ACKTHPPT") $-			getmaybe ("security-allow-unverified-downloads")+			getmaybe SecurityAllowUnverifiedDownloadsField+		, remoteAnnexUUID = toUUID <$> getmaybe UUIDField+		, remoteAnnexConfigUUID = toUUID <$> getmaybe ConfigUUIDField 		, remoteAnnexMaxGitBundles =-			fromMaybe 100 (getmayberead  "max-git-bundles")-		, remoteAnnexConfigUUID = toUUID <$> getmaybe "config-uuid"-		, remoteAnnexShell = getmaybe "shell"-		, remoteAnnexSshOptions = getoptions "ssh-options"-		, remoteAnnexRsyncOptions = getoptions "rsync-options"-		, remoteAnnexRsyncDownloadOptions = getoptions "rsync-download-options"-		, remoteAnnexRsyncUploadOptions = getoptions "rsync-upload-options"-		, remoteAnnexRsyncTransport = getoptions "rsync-transport"-		, remoteAnnexGnupgOptions = getoptions "gnupg-options"-		, remoteAnnexGnupgDecryptOptions = getoptions "gnupg-decrypt-options"-		, remoteAnnexSharedSOPCommand = SOPCmd <$>-			notempty (getmaybe "shared-sop-command")-		, remoteAnnexSharedSOPProfile = SOPProfile <$>-			notempty (getmaybe "shared-sop-profile")-		, remoteAnnexRsyncUrl = notempty $ getmaybe "rsyncurl"-		, remoteAnnexBupRepo = getmaybe "buprepo"-		, remoteAnnexBorgRepo = getmaybe "borgrepo"-		, remoteAnnexTahoe = getmaybe "tahoe"-		, remoteAnnexBupSplitOptions = getoptions "bup-split-options"-		, remoteAnnexDirectory = notempty $ getmaybe "directory"-		, remoteAnnexAndroidDirectory = notempty $ getmaybe "androiddirectory"-		, remoteAnnexAndroidSerial = notempty $ getmaybe "androidserial"-		, remoteAnnexGCrypt = notempty $ getmaybe "gcrypt"-		, remoteAnnexGitLFS = getbool "git-lfs" False-		, remoteAnnexDdarRepo = getmaybe "ddarrepo"-		, remoteAnnexHookType = notempty $ getmaybe "hooktype"-		, remoteAnnexExternalType = notempty $ getmaybe "externaltype"+			fromMaybe 100 (getmayberead MaxGitBundlesField) 		, remoteAnnexAllowEncryptedGitRepo = -			getbool "allow-encrypted-gitrepo" False+			getbool AllowEncryptedGitRepoField False+		, remoteAnnexProxy = getbool ProxyField False+		, remoteAnnexProxiedBy = toUUID <$> getmaybe ProxiedByField+		, remoteAnnexClusterNode = +			(filter isLegalName . words)+				<$> getmaybe ClusterNodeField+		, remoteAnnexClusterGateway = fromMaybe [] $+			(mapMaybe (mkClusterUUID . toUUID) . words)+				<$> getmaybe ClusterGatewayField 		, remoteUrl = -			case Git.Config.getMaybe (remoteConfig remotename "url") r of+			case Git.Config.getMaybe (remoteConfig remotename (remoteGitConfigKey UrlField)) r of 				Just (ConfigValue b) 					| B.null b -> Nothing 					| otherwise -> Just (decodeBS b) 				_ -> Nothing+		, remoteAnnexShell = getmaybe ShellField+		, remoteAnnexSshOptions = getoptions SshOptionsField+		, remoteAnnexRsyncOptions = getoptions RsyncOptionsField+		, remoteAnnexRsyncDownloadOptions = getoptions RsyncDownloadOptionsField+		, remoteAnnexRsyncUploadOptions = getoptions RsyncUploadOptionsField+		, remoteAnnexRsyncTransport = getoptions RsyncTransportField+		, remoteAnnexGnupgOptions = getoptions GnupgOptionsField+		, remoteAnnexGnupgDecryptOptions = getoptions GnupgDecryptOptionsField+		, remoteAnnexSharedSOPCommand = SOPCmd <$>+			notempty (getmaybe SharedSOPCommandField)+		, remoteAnnexSharedSOPProfile = SOPProfile <$>+			notempty (getmaybe SharedSOPProfileField)+		, remoteAnnexRsyncUrl = notempty $ getmaybe RsyncUrlField+		, remoteAnnexBupRepo = getmaybe BupRepoField+		, remoteAnnexBorgRepo = getmaybe BorgRepoField+		, remoteAnnexTahoe = getmaybe TahoeField+		, remoteAnnexBupSplitOptions = getoptions BupSplitOptionsField+		, remoteAnnexDirectory = notempty $ getmaybe DirectoryField+		, remoteAnnexAndroidDirectory = notempty $ getmaybe AndroidDirectoryField+		, remoteAnnexAndroidSerial = notempty $ getmaybe AndroidSerialField+		, remoteAnnexGCrypt = notempty $ getmaybe GCryptField+		, remoteAnnexGitLFS = getbool GitLFSField False+		, remoteAnnexDdarRepo = getmaybe DdarRepoField+		, remoteAnnexHookType = notempty $ getmaybe HookTypeField+		, remoteAnnexExternalType = notempty $ getmaybe ExternalTypeField 		}   where 	getbool k d = fromMaybe d $ getmaybebool k 	getmaybebool k = Git.Config.isTrueFalse' =<< getmaybe' k 	getmayberead k = readish =<< getmaybe k 	getmaybe = fmap fromConfigValue . getmaybe'-	getmaybe' k = -		Git.Config.getMaybe (remoteAnnexConfig remotename k) r-			<|>-		Git.Config.getMaybe (annexConfig k) r+	getmaybe' :: RemoteGitConfigField -> Maybe ConfigValue+	getmaybe' f =+		let k = remoteGitConfigKey f+		in Git.Config.getMaybe (remoteAnnexConfig remotename k) r+			<|> Git.Config.getMaybe (annexConfig k) r 	getoptions k = fromMaybe [] $ words <$> getmaybe k +data RemoteGitConfigField+	= CostField+	| CostCommandField+	| IgnoreField+	| IgnoreCommandField+	| SyncField+	| SyncCommandField+	| PullField+	| PushField+	| ReadOnlyField+	| CheckUUIDField+	| VerifyField+	| TrackingBranchField+	| ExportTrackingField+	| TrustLevelField+	| StartCommandField+	| StopCommandField+	| SpeculatePresentField+	| BareField+	| RetryField+	| ForwardRetryField+	| RetryDelayField+	| StallDetectionField+	| StallDetectionUploadField+	| StallDetectionDownloadField+	| BWLimitField+	| BWLimitUploadField+	| BWLimitDownloadField+	| UUIDField+	| ConfigUUIDField+	| SecurityAllowUnverifiedDownloadsField+	| MaxGitBundlesField+	| AllowEncryptedGitRepoField+	| ProxyField+	| ProxiedByField+	| ClusterNodeField+	| ClusterGatewayField+	| UrlField+	| ShellField+	| SshOptionsField+	| RsyncOptionsField+	| RsyncDownloadOptionsField+	| RsyncUploadOptionsField+	| RsyncTransportField+	| GnupgOptionsField+	| GnupgDecryptOptionsField+	| SharedSOPCommandField+	| SharedSOPProfileField+	| RsyncUrlField+	| BupRepoField+	| BorgRepoField+	| TahoeField+	| BupSplitOptionsField+	| DirectoryField+	| AndroidDirectoryField+	| AndroidSerialField+	| GCryptField+	| GitLFSField+	| DdarRepoField+	| HookTypeField+	| ExternalTypeField+	deriving (Enum, Bounded)++remoteGitConfigField :: RemoteGitConfigField -> (UnqualifiedConfigKey, ProxyInherited)+remoteGitConfigField = \case+	-- Hard to know the true cost of accessing eg a slow special+	-- remote via the proxy. The cost of the proxy is the best guess+	-- so do inherit it.+	CostField -> inherited "cost"+	CostCommandField -> inherited "cost-command"+	IgnoreField -> inherited "ignore"+	IgnoreCommandField -> inherited "ignore-command"+	SyncField -> inherited "sync"+	SyncCommandField -> inherited "sync-command"+	PullField -> inherited "pull"+	PushField -> inherited "push"+	ReadOnlyField -> inherited "readonly"+	CheckUUIDField -> uninherited "checkuuid"+	VerifyField -> inherited "verify"+	TrackingBranchField -> uninherited "tracking-branch"+	ExportTrackingField -> uninherited "export-tracking"+	TrustLevelField -> uninherited "trustlevel"+	StartCommandField -> uninherited "start-command"+	StopCommandField -> uninherited "stop-command"+	SpeculatePresentField -> inherited "speculate-present"+	BareField -> inherited "bare"+	RetryField -> inherited "retry"+	ForwardRetryField -> inherited "forward-retry"+	RetryDelayField -> inherited "retrydelay"+	StallDetectionField -> inherited "stalldetection"+	StallDetectionUploadField -> inherited "stalldetection-upload"+	StallDetectionDownloadField -> inherited "stalldetection-download"+	BWLimitField -> inherited "bwlimit"+	BWLimitUploadField -> inherited "bwlimit-upload"+	BWLimitDownloadField -> inherited "bwlimit-upload"+	UUIDField -> uninherited "uuid"+	ConfigUUIDField -> uninherited "config-uuid"+	SecurityAllowUnverifiedDownloadsField -> inherited "security-allow-unverified-downloads"+	MaxGitBundlesField -> inherited "max-git-bundles"+	AllowEncryptedGitRepoField -> inherited "allow-encrypted-gitrepo"+	-- Allow proxy chains.+	ProxyField -> inherited "proxy"+	ProxiedByField -> uninherited "proxied-by"+	ClusterNodeField -> uninherited "cluster-node"+	ClusterGatewayField -> uninherited "cluster-gateway"+	UrlField -> uninherited "url"+	ShellField -> inherited "shell"+	SshOptionsField -> inherited "ssh-options"+	RsyncOptionsField -> inherited "rsync-options"+	RsyncDownloadOptionsField -> inherited "rsync-download-options"+	RsyncUploadOptionsField -> inherited "rsync-upload-options"+	RsyncTransportField -> inherited "rsync-transport"+	GnupgOptionsField -> inherited "gnupg-options"+	GnupgDecryptOptionsField -> inherited "gnupg-decrypt-options"+	SharedSOPCommandField -> inherited "shared-sop-command"+	SharedSOPProfileField -> inherited "shared-sop-profile"+	RsyncUrlField -> uninherited "rsyncurl"+	BupRepoField -> uninherited "buprepo"+	BorgRepoField -> uninherited "borgrepo"+	TahoeField -> uninherited "tahoe"+	BupSplitOptionsField -> uninherited "bup-split-options"+	DirectoryField -> uninherited "directory"+	AndroidDirectoryField -> uninherited "androiddirectory"+	AndroidSerialField -> uninherited "androidserial"+	GCryptField -> uninherited "gcrypt"+	GitLFSField -> uninherited "git-lfs"+	DdarRepoField -> uninherited "ddarrepo"+	HookTypeField -> uninherited "hooktype"+	ExternalTypeField -> uninherited "externaltype"+  where+	inherited f = (f, ProxyInherited True)+	uninherited f = (f, ProxyInherited False)++newtype ProxyInherited = ProxyInherited Bool++-- All remote config fields that are inherited from a proxy.+proxyInheritedFields :: [UnqualifiedConfigKey]+proxyInheritedFields = +	map fst $+		filter (\(_, ProxyInherited p) -> p) $+			map remoteGitConfigField [minBound..maxBound]++remoteGitConfigKey :: RemoteGitConfigField -> UnqualifiedConfigKey+remoteGitConfigKey = fst . remoteGitConfigField+ notempty :: Maybe String -> Maybe String	 notempty Nothing = Nothing notempty (Just "") = Nothing@@ -513,9 +687,12 @@  type UnqualifiedConfigKey = B.ByteString +annexConfigPrefix :: B.ByteString+annexConfigPrefix = "annex."+ {- A global annex setting in git config. -} annexConfig :: UnqualifiedConfigKey -> ConfigKey-annexConfig key = ConfigKey ("annex." <> key)+annexConfig key = ConfigKey (annexConfigPrefix <> key)  class RemoteNameable r where 	getRemoteName :: r -> RemoteName

@@ -91,7 +91,7 @@ 	-- The key should not appear to be present on the remote until 	-- all of its contents have been transferred. 	-- Throws exception on failure.-	, storeKey :: Key -> AssociatedFile -> MeterUpdate -> a ()+	, storeKey :: Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> a () 	-- Retrieves a key's contents to a file. 	-- (The MeterUpdate does not need to be used if it writes 	-- sequentially to the file.)

@@ -89,6 +89,12 @@ 	observeBool Nothing = False 	observeFailure = Nothing +instance Observable (Either e (Maybe a)) where+	observeBool (Left _) = False+	observeBool (Right Nothing) = False+	observeBool (Right (Just _)) = True+	observeFailure = Right Nothing+ class Transferrable t where 	descTransfrerrable :: t -> Maybe String 

@@ -21,6 +21,9 @@  import Utility.Path.Windows import Utility.FileSystemEncoding+#if MIN_VERSION_Win32(2,13,4)+import Common (tryNonAsync)+#endif  type LockFile = RawFilePath @@ -59,9 +62,9 @@ openLock sharemode f = do 	f' <- convertToWindowsNativeNamespace f #if MIN_VERSION_Win32(2,13,4)-	r <- tryNonAsync $ createFile_NoRetry f' gENERIC_READ sharemode -		security_attributes oPEN_ALWAYS fILE_ATTRIBUTE_NORMAL-		(maybePtr Nothing)+	r <- tryNonAsync $ createFile_NoRetry (fromRawFilePath f') gENERIC_READ sharemode +		Nothing oPEN_ALWAYS fILE_ATTRIBUTE_NORMAL+		Nothing 	return $ case r of 		Left _ -> Nothing 		Right h -> Just h

@@ -1,6 +1,6 @@ {- Simple line-based protocols.  -- - Copyright 2013-2020 Joey Hess <id@joeyh.name>+ - Copyright 2013-2024 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}@@ -21,6 +21,7 @@ 	parse3, 	parse4, 	parse5,+	parseList, 	dupIoHandles, 	getProtocolLine, ) where@@ -110,6 +111,10 @@  splitWord :: String -> (String, String) splitWord = separate isSpace++{- Only safe to use when the serialization does not include whitespace. -}+parseList :: Serializable p => ([p] -> a) -> Parser a+parseList mk v = mk <$> mapM deserialize (words v)  {- When a program speaks a simple protocol over stdio, any other output  - to stdout (or anything that attempts to read from stdin)

@@ -1,5 +1,5 @@ Name: git-annex-Version: 10.20240531+Version: 10.20240701 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -508,6 +508,7 @@     Annex.ChangedRefs     Annex.CheckAttr     Annex.CheckIgnore+    Annex.Cluster     Annex.Common     Annex.Concurrent     Annex.Concurrent.Utility@@ -549,6 +550,7 @@     Annex.Path     Annex.Perms     Annex.PidLock+    Annex.Proxy     Annex.Queue     Annex.ReplaceFile     Annex.RemoteTrackingBranch@@ -556,6 +558,7 @@     Annex.SpecialRemote.Config     Annex.Ssh     Annex.StallDetection+    Annex.Startup     Annex.TaggedPush     Annex.Tmp     Annex.Transfer@@ -635,6 +638,7 @@     Command.EnableRemote     Command.EnableTor     Command.ExamineKey+    Command.ExtendCluster     Command.Expire     Command.Export     Command.FilterBranch@@ -658,6 +662,7 @@     Command.Indirect     Command.Info     Command.Init+    Command.InitCluster     Command.InitRemote     Command.Inprogress     Command.List@@ -720,6 +725,8 @@     Command.UnregisterUrl     Command.Untrust     Command.Unused+    Command.UpdateCluster+    Command.UpdateProxy     Command.Upgrade     Command.VAdd     Command.VCycle@@ -814,6 +821,8 @@     Logs.AdjustedBranchUpdate     Logs.Chunk     Logs.Chunk.Pure+    Logs.Cluster+    Logs.Cluster.Basic     Logs.Config     Logs.ContentIdentifier     Logs.ContentIdentifier.Pure@@ -838,6 +847,7 @@     Logs.PreferredContent.Raw     Logs.Presence     Logs.Presence.Pure+    Logs.Proxy     Logs.Remote     Logs.Remote.Pure     Logs.RemoteState@@ -868,6 +878,7 @@     P2P.Auth     P2P.IO     P2P.Protocol+    P2P.Proxy     Remote     Remote.Adb     Remote.BitTorrent@@ -930,6 +941,7 @@     Types.BranchState     Types.CatFileHandles     Types.CleanupActions+    Types.Cluster     Types.Command     Types.Concurrency     Types.Creds