packages feed

git-annex 10.20260316 → 10.20260421

raw patch · 39 files changed

+865/−243 lines, 39 files

Files

Annex.hs view
@@ -188,6 +188,7 @@ 	, gitconfiginodecache :: Maybe InodeCache 	, backend :: Maybe (BackendA Annex) 	, remotes :: [Types.Remote.RemoteA Annex]+	, remotetypes :: [Types.Remote.RemoteTypeA Annex] 	, output :: MessageState 	, concurrency :: ConcurrencySetting 	, cpus :: Maybe Cpus@@ -247,6 +248,7 @@ 		, gitconfiginodecache = Nothing 		, backend = Nothing 		, remotes = []+		, remotetypes = [] 		, output = o 		, concurrency = ConcurrencyCmdLine NonConcurrent 		, cpus = Nothing
Annex/Branch.hs view
@@ -21,6 +21,8 @@ 	forceUpdate, 	updateTo, 	get,+	getLocal,+	getLocal', 	getHistorical, 	getRef, 	getUnmergedRefs,@@ -632,17 +634,6 @@ 			let l = jfs ++ pjfs ++ bfs 			return (Just (l, cleanup)) -{- Lists all files currently in the journal, but not files in the private- - journal. -}-journalledFiles :: Annex [OsPath]-journalledFiles = getJournalledFilesStale gitAnnexJournalDir--journalledFilesPrivate :: Annex [OsPath]-journalledFilesPrivate = ifM privateUUIDsKnown-	( getJournalledFilesStale gitAnnexPrivateJournalDir-	, return []-	)- {- Files in the branch, not including any from journalled changes,  - and without updating the branch. -} branchFiles :: Annex ([OsPath], IO Bool)@@ -1006,8 +997,6 @@ 	= UnmergedBranches t  	| NoUnmergedBranches t -type FileContents t b = Maybe (t, OsPath, Maybe (L.ByteString, Maybe b))- {- Runs an action on the content of selected files from the branch.  - This is much faster than reading the content of each file in turn,  - because it lets git cat-file stream content without blocking.@@ -1065,7 +1054,7 @@ 		Nothing 			| journalIgnorable st -> return Nothing 			| otherwise ->-				overJournalFileContents' buf (handlestale branchsha) select+				overJournalFileContents' buf False (handlestale branchsha) select 	res <- catObjectStreamLsTree l (select' . getTopFilePath . Git.LsTree.file) g go' 		`finally` liftIO (void cleanup) 	return (res, branchsha)@@ -1088,56 +1077,6 @@ combineStaleJournalWithBranch :: L.ByteString -> L.ByteString -> L.ByteString combineStaleJournalWithBranch branchcontent journalledcontent = 	branchcontent <> journalledcontent--{- Like overBranchFileContents but only reads the content of journalled- - files.- -}-overJournalFileContents-	:: (OsPath -> L.ByteString -> Annex (L.ByteString, Maybe b))-	-- ^ Called with the journalled file content when the journalled-	-- content may be stale or lack information committed to the-	-- git-annex branch.-	-> (OsPath -> Maybe v)-	-> (Annex (FileContents v b) -> Annex a)-	-> Annex a-overJournalFileContents handlestale select go = do-	buf <- liftIO newEmptyMVar-	go $ overJournalFileContents' buf handlestale select--overJournalFileContents'-	:: MVar ([OsPath], [OsPath])-	-> (OsPath -> L.ByteString -> Annex (L.ByteString, Maybe b))-	-> (OsPath -> Maybe a)-	-> Annex (FileContents a b)-overJournalFileContents' buf handlestale select =-	liftIO (tryTakeMVar buf) >>= \case-		Nothing -> do-			jfs <- journalledFiles-			pjfs <- journalledFilesPrivate-			drain jfs pjfs-		Just (jfs, pjfs) -> drain jfs pjfs-  where-	drain fs pfs = case getnext fs pfs of-		Just (v, f, fs', pfs') -> do-			liftIO $ putMVar buf (fs', pfs')-			content <- getJournalFileStale (GetPrivate True) f >>= \case-				NoJournalledContent -> return Nothing-				JournalledContent journalledcontent ->-					return (Just (journalledcontent, Nothing))-				PossiblyStaleJournalledContent journalledcontent ->-					Just <$> handlestale f journalledcontent-			return (Just (v, f, content))-		Nothing -> do-			liftIO $ putMVar buf ([], [])-			return Nothing-	-	getnext [] [] = Nothing-	getnext (f:fs) pfs = case select f of-		Nothing -> getnext fs pfs-		Just v -> Just (v, f, fs, pfs)-	getnext [] (pf:pfs) = case select pf of-		Nothing -> getnext [] pfs-		Just v -> Just (v, pf, [], pfs)  {- Check if the git-annex branch has been updated from the oldtree.  - If so, returns the tuple of the old and new trees. -}
+ Annex/DisableRemote.hs view
@@ -0,0 +1,201 @@+{- disable a remote+ -+ - Copyright 2026 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++{-# LANGUAGE OverloadedStrings #-}++module Annex.DisableRemote (disableRemote) where++import Git+import Annex.Common+import qualified Annex+import qualified Git.Remote.Remove+import qualified Git.Ref+import Types.Remote+import Annex.Journal+import qualified Annex.Branch+import Annex.Branch.Transitions+import Types.Transitions+import Logs+import Logs.Remote.Pure+import Logs.MapLog+import Logs.Transfer+import Types.Transfer+import qualified Database.Export+import qualified Database.Fsck+import qualified Database.RepoSize+import qualified Database.ContentIdentifier+import qualified Utility.OsString as OS++import Data.ByteString.Builder+import qualified Data.Map as M+import qualified Data.Set as S+import qualified Data.ByteString.Lazy as L++disableRemote :: Remote -> RemoteName -> [Remote] -> Annex ()+disableRemote r remotename remotelist = do+	let uniqueuuid = not $+		any (\r' -> uuid r' == uuid r && name r' /= name r) remotelist+	+	when uniqueuuid $+		-- If there are transfers to/from the remote still+		-- running, this fails. That's why it's run early.+		removeTransferLogs (uuid r)+		+	cleanPrivateJournal r uniqueuuid++	when uniqueuuid $ do+		-- Each uuid has its own export and fsck database,+		-- so always remove them, so long as this is the+		-- only remote using this uuid.+		Database.Export.removeDb (uuid r)+		Database.Fsck.removeDb (uuid r)+		-- These databases are updated from information+		-- in the git-annex branch, so there is no point in+		-- removing the uuid from them unless it's private.+		whenM (isPrivateUUID (uuid r)) $ do+			Database.RepoSize.removeUUID (uuid r)+			Database.ContentIdentifier.removeUUID (uuid r) True++		removeFsckState (uuid r)+		removeImportLog (uuid r)+		removeCredFiles (uuid r)+		removeRemoteLockFile (uuid r)+		removeRemoteStateFile (uuid r)+		+	inRepo $ Git.Remote.Remove.remove remotename+	removeRemoteTrackingBranches remotename++-- Remove any remote branches. +-- This is done because git remote remove only removes the configured+-- remote tracking branch, not other remote branches.+removeRemoteTrackingBranches :: String -> Annex ()+removeRemoteTrackingBranches remotename = do+	branches <- filter (\b -> branchprefix `isPrefixOf` fromRef b) +		. map snd+		<$> inRepo Git.Ref.list+	forM_ branches $ \b -> +		inRepo $ Git.Ref.delete' b+  where+	branchprefix = "refs/remotes/" ++ remotename ++ "/"++isPrivateUUID :: UUID -> Annex Bool+isPrivateUUID u = +	(\c -> u `S.member` annexPrivateRepos c)+		<$> Annex.getGitConfig++{- Remove a private remote's uuid from the private journal+ - entirely when it is the only remote using that uuid.+ -+ - And, when the remote is a sameas remote, its config is stored+ - under its config-uuid. Remove that from the private remote log.+ -}+cleanPrivateJournal :: Remote -> Bool -> Annex ()+cleanPrivateJournal r uniqueuuid+	| uniqueuuid == True = do+		whenM (isPrivateUUID (uuid r)) $ do+			gc <- Annex.getGitConfig+			let tc = filterBranch (\u -> u /= uuid r) gc+			let handlestale = \_ b -> return (b, Nothing)+			lockJournal $ \jl -> +				overPrivateJournalFileContents handlestale Just+					(go jl tc)+		removeconfiguuid+	| otherwise = removeconfiguuid+  where+	go jl tc getfilecontents = getfilecontents >>= \case+		Just (_, p, Just (b, _)) -> do+			cleaner jl tc p b+			go jl tc getfilecontents+		Just (_, _, Nothing) ->+			go jl tc getfilecontents+		Nothing -> return ()+			+	cleaner jl tc p b = case tc p b of+		PreserveFile -> return ()+		ChangeFile builder ->+			setlocaljournal jl (RegardingUUID [uuid r]) p builder+	+	removeconfiguuid = case remoteAnnexConfigUUID (gitconfig r) of+		Nothing -> return ()+		Just cu -> whenM (isPrivateUUID cu) $+			lockJournal $ \jl ->+				getJournalFile jl (GetPrivate True) remoteLog >>= \case+					JournalledContent b -> +						scrub jl cu b+					PossiblyStaleJournalledContent b -> +						scrub jl cu b+					NoJournalledContent ->+						return ()+	  where+		scrub jl cu b =+			setlocaljournal jl (RegardingUUID [cu]) remoteLog $+				buildRemoteConfigLog $ MapLog $ M.delete cu $+					fromMapLog $ parseRemoteConfigLog b++	setlocaljournal jl ru p builder =+		let b' = toLazyByteString builder+		in if L.null b'+			then deleteJournalFile jl ru p+			else do+				b'' <- Annex.Branch.getLocal' (GetPrivate False) p+				if b'' == b'+					then deleteJournalFile jl ru p+					else setJournalFile jl ru p builder++removeFsckState :: UUID -> Annex ()+removeFsckState u = do+	d <- fromRepo (gitAnnexFsckStateDir u)+	liftIO $ whenM (doesDirectoryExist d) $+		removeDirectoryRecursive d+	f <- fromRepo (gitAnnexFsckResultsLog u)+	liftIO $ removeWhenExistsWith removeFile f++removeImportLog :: UUID -> Annex ()+removeImportLog u = do+	f <- calcRepo' (gitAnnexImportLog u)+	liftIO $ removeWhenExistsWith removeFile f+	+removeTransferLogs :: UUID -> Annex ()+removeTransferLogs u = do+	-- getTransfers calls checkTransfer, which cleans up+	-- transfer log files for transfers that are no longer running.+	whenM (any foru <$> getTransfers) $+		error "Active trasfers, cannot disable the remote."+	forM_ [Upload, Download] $ \direction -> do+		d <- fromRepo $ gitAnnexTransferUUIDDirectionDir u direction+		liftIO $ void $ tryNonAsync $ removeDirectory d+		d' <- fromRepo $ gitAnnexFailedTransferDir u direction+		liftIO $ void $ tryNonAsync $ removeDirectory d'+	clearFailedTransfers u+  where+	foru (t, _) = transferUUID t == u++removeCredFiles :: UUID -> Annex ()+removeCredFiles u = do+	d <- fromRepo gitAnnexCredsDir+	liftIO $ whenM (doesDirectoryExist d) $ do+		mapM_ (removeWhenExistsWith removeFile)+			=<< filter foru <$> dirContents d+  where+	us = fromUUID u++	-- Remotes that use creds always include their UUID as part of the+	-- filename. However, some remotes (Remote.External) need more than+	-- one creds file, and add a "-foo" suffix to the UUID.+	foru p = +		let f = takeFileName p+		in f == us || (us <> literalOsPath "-") `OS.isPrefixOf` f++removeRemoteLockFile :: UUID -> Annex ()+removeRemoteLockFile u = do+	f <- fromRepo $ gitAnnexRemoteLockFile u+	liftIO $ removeWhenExistsWith removeFile f++removeRemoteStateFile :: UUID -> Annex ()+removeRemoteStateFile u = do+	f <- fromRepo $ gitAnnexRemoteStateFile u+	liftIO $ removeWhenExistsWith removeFile f
Annex/Journal.hs view
@@ -7,7 +7,7 @@  - All files in the journal must be a series of lines separated by  - newlines.  -- - Copyright 2011-2024 Joey Hess <id@joeyh.name>+ - Copyright 2011-2026 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -33,6 +33,7 @@ import qualified Data.ByteString as B import Data.ByteString.Builder import Data.Char+import Control.Concurrent.MVar  class Journalable t where 	writeJournalHandle :: Handle -> t -> IO ()@@ -101,6 +102,15 @@ 	-- exists 	mv `catchIO` (const (createAnnexDirectory jd >> mv)) +deleteJournalFile :: JournalLocked -> RegardingUUID -> OsPath -> Annex ()+deleteJournalFile _jl ru file = do+	st <- getState+	jd <- fromRepo =<< ifM (regardingPrivateUUID ru)+		( return (gitAnnexPrivateJournalDir st)+		, return (gitAnnexJournalDir st)+		)+	liftIO $ removeWhenExistsWith removeFile (jd </> journalFile file)+ newtype AppendableJournalFile = AppendableJournalFile (OsPath, OsPath)  {- If the journal file does not exist, it cannot be appended to, because@@ -293,3 +303,81 @@ lockJournal a = do 	lck <- fromRepo gitAnnexJournalLock 	withExclusiveLock lck $ a ProduceJournalLocked++{- Lists all files currently in the journal, but not files in the private+ - journal. -}+journalledFiles :: Annex [OsPath]+journalledFiles = getJournalledFilesStale gitAnnexJournalDir++journalledFilesPrivate :: Annex [OsPath]+journalledFilesPrivate = ifM privateUUIDsKnown+	( getJournalledFilesStale gitAnnexPrivateJournalDir+	, return []+	)++type FileContents t b = Maybe (t, OsPath, Maybe (L.ByteString, Maybe b))++{- Like overBranchFileContents but only reads the content of journalled+ - files.+ -}+overJournalFileContents+	:: (OsPath -> L.ByteString -> Annex (L.ByteString, Maybe b))+	-- ^ Called with the journalled file content when the journalled+	-- content may be stale or lack information committed to the+	-- git-annex branch.+	-> (OsPath -> Maybe v)+	-> (Annex (FileContents v b) -> Annex a)+	-> Annex a+overJournalFileContents handlestale select go = do+	buf <- liftIO newEmptyMVar+	go $ overJournalFileContents' buf False handlestale select++{- Like overJournalFileContents, but only over files that are in the+ - private journal. However, the file content still includes the public+ - content, concacenated with the private content. -}+overPrivateJournalFileContents+	:: (OsPath -> L.ByteString -> Annex (L.ByteString, Maybe b))+	-> (OsPath -> Maybe v)+	-> (Annex (FileContents v b) -> Annex a)+	-> Annex a+overPrivateJournalFileContents handlestale select go = do+	buf <- liftIO newEmptyMVar+	go $ overJournalFileContents' buf True handlestale select++overJournalFileContents'+	:: MVar ([OsPath], [OsPath])+	-> Bool+	-> (OsPath -> L.ByteString -> Annex (L.ByteString, Maybe b))+	-> (OsPath -> Maybe a)+	-> Annex (FileContents a b)+overJournalFileContents' buf onlyprivate handlestale select =+	liftIO (tryTakeMVar buf) >>= \case+		Nothing -> do+			jfs <- if onlyprivate+				then return []+				else journalledFiles+			pjfs <- journalledFilesPrivate+			drain jfs pjfs+		Just (jfs, pjfs) -> drain jfs pjfs+  where+	drain fs pfs = case getnext fs pfs of+		Just (v, f, fs', pfs') -> do+			liftIO $ putMVar buf (fs', pfs')+			content <- getJournalFileStale (GetPrivate True) f >>= \case+				NoJournalledContent -> return Nothing+				JournalledContent journalledcontent ->+					return (Just (journalledcontent, Nothing))+				PossiblyStaleJournalledContent journalledcontent ->+					Just <$> handlestale f journalledcontent+			return (Just (v, f, content))+		Nothing -> do+			liftIO $ putMVar buf ([], [])+			return Nothing+	+	getnext [] [] = Nothing+	getnext (f:fs) pfs = case select f of+		Nothing -> getnext fs pfs+		Just v -> Just (v, f, fs, pfs)+	getnext [] (pf:pfs) = case select pf of+		Nothing -> getnext [] pfs+		Just v -> Just (v, pf, [], pfs)
Annex/Locations.hs view
@@ -1,6 +1,6 @@ {- git-annex file locations  -- - Copyright 2010-2025 Joey Hess <id@joeyh.name>+ - Copyright 2010-2026 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -45,9 +45,11 @@ 	gitAnnexBadDir, 	gitAnnexBadLocation, 	gitAnnexUnusedLog,+	gitAnnexFsckDbUUIDDir, 	gitAnnexKeysDbDir, 	gitAnnexKeysDbLock,-	gitAnnexFsckState,+	gitAnnexFsckStateDir,+	gitAnnexFsckStateFile, 	gitAnnexFsckDbDir, 	gitAnnexFsckDbDirOld, 	gitAnnexFsckDbLock,@@ -68,6 +70,7 @@ 	gitAnnexMoveLog, 	gitAnnexMoveLock, 	gitAnnexExportDir,+	gitAnnexExportUUIDDir, 	gitAnnexExportDbDir, 	gitAnnexExportLock, 	gitAnnexExportUpdateLock,@@ -83,6 +86,10 @@ 	gitAnnexRepoSizeLiveDir, 	gitAnnexScheduleState, 	gitAnnexTransferDir,+	gitAnnexTransferDirectionDir,+	gitAnnexTransferUUIDDirectionDir,+	gitAnnexFailedTransferDir,+	gitAnnexFailedTransferFile, 	gitAnnexCredsDir, 	gitAnnexWebCertificate, 	gitAnnexWebPrivKey,@@ -110,7 +117,8 @@ 	gitAnnexTmpCfgFile, 	gitAnnexSshDir, 	gitAnnexP2PDir,-	gitAnnexRemotesDir,+	gitAnnexRemoteLockFile,+	gitAnnexRemoteStateFile, 	gitAnnexAssistantDefaultDir, 	gitAnnexSimDir, 	HashLevels(..),@@ -133,11 +141,14 @@ import Types.Difference import Types.BranchState import Types.Export+import Types.Direction+import Types.Transfer import qualified Git import qualified Git.Types as Git import Git.FilePath import Annex.DirHashes import Annex.Fixup+import qualified Utility.OsString as OS  {- When constructing a path that is usually relative to the  - .git directory, this can be used to relocate the path to@@ -410,24 +421,29 @@ gitAnnexKeysDbLock :: Git.Repo -> GitConfig -> OsPath gitAnnexKeysDbLock  r c = gitAnnexKeysDbDir r c <> literalOsPath ".lck" -{- .git/annex/fsck/uuid/ is used to store information about incremental- - fscks. -} gitAnnexFsckDir :: UUID -> Git.Repo -> Maybe GitConfig -> OsPath gitAnnexFsckDir u r mc = case annexDbDir =<< mc of 	Nothing -> go (gitAnnexDir r) 	Just d -> go d   where-	go d = d </> literalOsPath "fsck" </> fromUUID u+	go d = d </> literalOsPath "fsck" </> uuidFile u -{- used to store information about incremental fscks. -}-gitAnnexFsckState :: UUID -> Git.Repo -> OsPath-gitAnnexFsckState u r = -	gitAnnexFsckDir u r Nothing </> literalOsPath "state"+{- .git/annex/fsck/uuid/ is used to store state of incremental fscks. -}+gitAnnexFsckStateDir :: UUID -> Git.Repo -> OsPath+gitAnnexFsckStateDir u r = gitAnnexFsckDir u r Nothing +{- File that stores state of incremental fscks. -}+gitAnnexFsckStateFile :: UUID -> Git.Repo -> OsPath+gitAnnexFsckStateFile u r = gitAnnexFsckStateDir u r </> literalOsPath "state"++{- Per UUID directory containing database used to record fsck info. -}+gitAnnexFsckDbUUIDDir :: UUID -> Git.Repo -> GitConfig -> OsPath+gitAnnexFsckDbUUIDDir u r c = gitAnnexFsckDir u r (Just c)+ {- Directory containing database used to record fsck info. -} gitAnnexFsckDbDir :: UUID -> Git.Repo -> GitConfig -> OsPath-gitAnnexFsckDbDir u r c = -	gitAnnexFsckDir u r (Just c) </> literalOsPath "fsckdb"+gitAnnexFsckDbDir u r c =+	gitAnnexFsckDbUUIDDir u r c </> literalOsPath "fsckdb"  {- Directory containing old database used to record fsck info. -} gitAnnexFsckDbDirOld :: UUID -> Git.Repo -> GitConfig -> OsPath@@ -442,7 +458,7 @@ {- .git/annex/fsckresults/uuid is used to store results of git fscks -} gitAnnexFsckResultsLog :: UUID -> Git.Repo -> OsPath gitAnnexFsckResultsLog u r = -	gitAnnexDir r </> literalOsPath "fsckresults" </> fromUUID u+	gitAnnexDir r </> literalOsPath "fsckresults" </> uuidFile u  {- .git/annex/upgrade.log is used to record repository version upgrades. -} gitAnnexUpgradeLog :: Git.Repo -> OsPath@@ -507,10 +523,14 @@ gitAnnexExportDir r c = fromMaybe (gitAnnexDir r) (annexDbDir c) 	</> literalOsPath "export" +{- Per UUID export information directory. -}+gitAnnexExportUUIDDir :: UUID -> Git.Repo -> GitConfig -> OsPath+gitAnnexExportUUIDDir u r c = gitAnnexExportDir r c </> uuidFile u+ {- Directory containing database used to record export info. -} gitAnnexExportDbDir :: UUID -> Git.Repo -> GitConfig -> OsPath gitAnnexExportDbDir u r c = -	gitAnnexExportDir r c </> fromUUID u </> literalOsPath "exportdb"+	gitAnnexExportUUIDDir u r c </> literalOsPath "exportdb"  {- Lock file for export database. -} gitAnnexExportLock :: UUID -> Git.Repo -> GitConfig -> OsPath@@ -525,7 +545,7 @@  - remote, but were excluded by its preferred content settings. -} gitAnnexExportExcludeLog :: UUID -> Git.Repo -> OsPath gitAnnexExportExcludeLog u r = gitAnnexDir r -	</> literalOsPath "export.ex" </> fromUUID u+	</> literalOsPath "export.ex" </> uuidFile u  {- Directory containing database used to record remote content ids.  -@@ -550,7 +570,7 @@ {- File containing state about the last import done from a remote. -} gitAnnexImportLog :: UUID -> Git.Repo -> GitConfig -> OsPath gitAnnexImportLog u r c =-	gitAnnexImportDir r c </> fromUUID u </> literalOsPath "log"+	gitAnnexImportDir r c </> uuidFile u </> literalOsPath "log"  {- Directory containing database used by importfeed. -} gitAnnexImportFeedDbDir :: Git.Repo -> GitConfig -> OsPath@@ -615,6 +635,31 @@ gitAnnexTransferDir r = 	addTrailingPathSeparator $ gitAnnexDir r </> literalOsPath "transfer" +{- The directory holding transfer information files for a given Direction. -}+gitAnnexTransferDirectionDir :: Direction -> Git.Repo -> OsPath+gitAnnexTransferDirectionDir direction r = gitAnnexTransferDir r+	</> toOsPath (formatDirection direction)++{- The directory holding transfer information files for a given Direction+ - and UUID. -}+gitAnnexTransferUUIDDirectionDir :: UUID -> Direction -> Git.Repo -> OsPath+gitAnnexTransferUUIDDirectionDir u direction r =+	gitAnnexTransferDirectionDir direction r </> uuidFile u++{- The directory holding failed transfer information files for a given+ - Direction and UUID -}+gitAnnexFailedTransferDir :: UUID -> Direction -> Git.Repo -> OsPath+gitAnnexFailedTransferDir u direction r = gitAnnexTransferDir r+	</> literalOsPath "failed"+	</> toOsPath (formatDirection direction)+	</> uuidFile u++{- The transfer information file to use to record a failed Transfer -}+gitAnnexFailedTransferFile :: Transfer -> Git.Repo -> OsPath+gitAnnexFailedTransferFile (Transfer direction u kd) r = +	gitAnnexFailedTransferDir u direction r+		</> keyFile (mkKey (const kd))+ {- .git/annex/journal/ is used to journal changes made to the git-annex  - branch -} gitAnnexJournalDir :: BranchState -> Git.Repo -> OsPath@@ -716,11 +761,18 @@ gitAnnexP2PDir r = addTrailingPathSeparator $ 	gitAnnexDir r </> literalOsPath "p2p" -{- .git/annex/remotes/ is used for remote-specific state. -}-gitAnnexRemotesDir :: Git.Repo -> OsPath-gitAnnexRemotesDir r = addTrailingPathSeparator $-	gitAnnexDir r </> literalOsPath "remotes"+{- Remote-specific lock files stored in .git/annex/remotes/. -}+gitAnnexRemoteLockFile :: UUID -> Git.Repo -> OsPath+gitAnnexRemoteLockFile u r =+	gitAnnexDir r </> literalOsPath "remotes" +		</> uuidFile u <> literalOsPath ".lck" +{- Remote-specific state files stored in .git/annex/remotes/. -}+gitAnnexRemoteStateFile :: UUID -> Git.Repo -> OsPath+gitAnnexRemoteStateFile u r =+	gitAnnexDir r </> literalOsPath "remotes" +		</> uuidFile u <> literalOsPath ".state"+ {- This is the base directory name used by the assistant when making  - repositories, by default. -} gitAnnexAssistantDefaultDir :: OsPath@@ -834,3 +886,10 @@ keyPaths :: Key -> NE.NonEmpty OsPath keyPaths key = NE.map (\h -> keyPath key (h def)) dirHashes +{- Converts a UUID into a filename fragement without any directory.+ -+ - A UUID never contains '/', so to avoid any possible situation+ - where an attacker attempts path traversal by a UUID, it is filtered out.+ -}+uuidFile :: UUID -> OsPath+uuidFile u = OS.filter (/= unsafeFromChar '/') (fromUUID u)
Annex/LockFile.hs view
@@ -1,6 +1,6 @@ {- git-annex lock files.  -- - Copyright 2012-2024 Joey Hess <id@joeyh.name>+ - Copyright 2012-2026 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -15,8 +15,11 @@ 	withSharedLock, 	withExclusiveLock, 	takeExclusiveLock,+	takeSharedLock, 	tryExclusiveLock, 	trySharedLock,+	dropLock,+	LockHandle, ) where  import Annex.Common@@ -93,6 +96,19 @@ 	lock mode = lockExclusive (Just mode) #else 	lock _mode = liftIO . waitToLock . lockExclusive+#endif++{- Takes a shared lock, blocking until any exclusive lock is freed. -}+takeSharedLock :: OsPath -> Annex LockHandle+takeSharedLock lockfile = debugLocks $ do+	createAnnexDirectory $ takeDirectory lockfile+	mode <- annexFileMode+	lock mode lockfile+  where+#ifndef mingw32_HOST_OS+	lock mode = lockShared (Just mode)+#else+	lock _mode = liftIO . waitToLock . lockShared #endif  {- Tries to take an exclusive lock and run an action. If the lock is
Annex/RepoSize/LiveUpdate.hs view
@@ -15,7 +15,6 @@ import Annex.UUID import Types.FileMatcher import Annex.LockFile-import Annex.LockPool import qualified Database.RepoSize as Db import qualified Utility.Matcher as Matcher import Utility.PID
Annex/SpecialRemote.hs view
@@ -14,7 +14,7 @@  import Annex.Common import Annex.SpecialRemote.Config-import Types.Remote (RemoteConfig, SetupStage(..), typename, setup)+import Types.Remote (RemoteConfig, SetupStage(..), setup) import Types.GitConfig import Types.ProposedAccepted import Config@@ -44,22 +44,6 @@ 		. findByRemoteConfig (\c -> lookupName c == Just name) 		<$> Logs.Remote.remoteConfigMap -newConfig-	:: RemoteName-	-> Maybe (Sameas UUID)-	-> RemoteConfig-	-- ^ configuration provided by the user-	-> M.Map UUID RemoteConfig-	-- ^ configuration of other special remotes, to inherit from-	-- when sameas is used-	-> RemoteConfig-newConfig name sameas fromuser m = case sameas of-	Nothing -> M.insert nameField (Proposed name) fromuser-	Just (Sameas u) -> addSameasInherited m $ M.fromList-		[ (sameasNameField, Proposed name)-		, (sameasUUIDField, Proposed (fromUUID u))-		] `M.union` fromuser- specialRemoteMap :: Annex (M.Map UUID RemoteName) specialRemoteMap = do 	m <- Logs.Remote.remoteConfigMap@@ -74,17 +58,7 @@  {- find the remote type -} findType :: RemoteConfig -> Either String RemoteType-findType config = maybe unspecified (specified . fromProposedAccepted) $-	M.lookup typeField config-  where-	unspecified = Left "Specify the type of remote with type="-	specified s = case filter (findtype s) remoteTypes of-		[] -> Left $ "Unknown remote type " ++ s -			++ " (pick from: "-			++ intercalate " " (map typename remoteTypes)-			++ ")"-		(t:_) -> Right t-	findtype s i = typename i == s+findType = findType' remoteTypes  autoEnable :: Annex () autoEnable = do@@ -102,7 +76,7 @@ 					Left e -> warning (UnquotedString (show e)) 					Right (_c, _u) -> 						when (cu /= u) $-							setConfig (remoteAnnexConfig c "config-uuid") (fromUUID cu)+							setRemoteConfigUUID c cu 			_ -> return ()   where 	getenabledremotes = M.fromList
Annex/SpecialRemote/Config.hs view
@@ -1,6 +1,6 @@ {- git-annex special remote configuration  -- - Copyright 2019-2024 Joey Hess <id@joeyh.name>+ - Copyright 2019-2026 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -11,12 +11,13 @@ module Annex.SpecialRemote.Config where  import Common-import Types.Remote (configParser)+import Types.Remote (configParser, typename) import Types import Types.UUID import Types.ProposedAccepted import Types.RemoteConfig import Types.GitConfig+import Git.Types import Config.Cost  import qualified Data.Map as M@@ -332,3 +333,33 @@ 					Just (ValueDesc vd) -> 						" (expected " ++ vd ++ ")" 					Nothing -> ""++newConfig+	:: RemoteName+	-> Maybe (Sameas UUID)+	-> RemoteConfig+	-- ^ configuration provided by the user+	-> M.Map UUID RemoteConfig+	-- ^ configuration of other special remotes, to inherit from+	-- when sameas is used+	-> RemoteConfig+newConfig name sameas fromuser m = case sameas of+	Nothing -> M.insert nameField (Proposed name) fromuser+	Just (Sameas u) -> addSameasInherited m $ M.fromList+		[ (sameasNameField, Proposed name)+		, (sameasUUIDField, Proposed (fromUUID u))+		] `M.union` fromuser++findType' :: [RemoteType] -> RemoteConfig -> Either String RemoteType+findType' typelist rc = maybe unspecified (specified . fromProposedAccepted) $+	M.lookup typeField rc+  where+	unspecified = Left "Specify the type of remote with type="+	specified s = case filter (findtype s) typelist of+		[] -> Left $ "Unknown remote type " ++ s +			++ " (pick from: "+			++ intercalate " " (map typename typelist)+			++ ")"+		(t:_) -> Right t+	findtype s i = typename i == s+
Assistant/MakeRemote.hs view
@@ -112,7 +112,7 @@ 		Nothing -> 			configSet u c' 		Just (Annex.SpecialRemote.ConfigFrom cu) -> do-			setConfig (remoteAnnexConfig c' "config-uuid") (fromUUID cu)+			setRemoteConfigUUID c' cu 			configSet cu c' 	when setdesc $ 		whenM (isNothing . M.lookup u <$> uuidDescMap) $
Assistant/Threads/TransferScanner.hs view
@@ -85,7 +85,7 @@ {- This is a cheap scan for failed transfers involving a remote. -} failedTransferScan :: Remote -> Assistant () failedTransferScan r = do-	failed <- liftAnnex $ clearFailedTransfers (Remote.uuid r)+	failed <- liftAnnex $ tryClearFailedTransfers (Remote.uuid r) 	mapM_ retry failed   where 	retry (t, info)@@ -123,7 +123,7 @@  	let us = map Remote.uuid rs -	mapM_ (liftAnnex . clearFailedTransfers) us+	mapM_ (liftAnnex . tryClearFailedTransfers) us  	unwantedrs <- liftAnnex $ S.fromList 		<$> filterM inUnwantedGroup us
CHANGELOG view
@@ -1,3 +1,17 @@+git-annex (10.20260420) upstream; urgency=medium++  * disableremote: New command.+  * Fix annexUrl to inherit any password that is set in the remote url.+  * Add DELEGATE extension to the external special remote protocol.+  * Avoid dying of an exception when when stdout gets closed by eg head(1),+    and avoid a crash loop when stderr is closed and git-annex dies of an+    exception.+    Fixes reversion introduced in version 10.20230407.+  * Improve UUID sanitization.+  * Deal with breaking changes to test concurrency in tasty-1.5.4.++ -- Joey Hess <id@joeyh.name>  Tue, 21 Apr 2026 14:39:56 -0400+ git-annex (10.20260316) upstream; urgency=medium    * Added CHECKPRESENT-URL extension to the external special remote protocol.
CmdLine/GitAnnex.hs view
@@ -58,6 +58,7 @@ import qualified Command.EnableRemote import qualified Command.ConfigRemote import qualified Command.RenameRemote+import qualified Command.DisableRemote import qualified Command.EnableTor import qualified Command.Multicast import qualified Command.Expire@@ -173,6 +174,7 @@ 	, Command.EnableRemote.cmd 	, Command.ConfigRemote.cmd 	, Command.RenameRemote.cmd+	, Command.DisableRemote.cmd 	, Command.EnableTor.cmd 	, Command.Multicast.cmd 	, Command.Reinject.cmd
CmdLine/GitRemoteAnnex.hs view
@@ -604,15 +604,15 @@ 		Logs.Remote.configSet u c' 		setConfig (remoteConfig c' "url") (specialRemoteUrl cfg) 		case M.lookup (Accepted "config-uuid") (specialRemoteConfig cfg) of-			Just cu -> do-				setConfig (remoteAnnexConfig c' "config-uuid")-					(fromProposedAccepted cu)+			Just pcu -> do+				let cu = toUUID (fromProposedAccepted pcu)+				setRemoteConfigUUID c' cu 				-- This is not quite the same as what is 				-- usually stored to the git-annex branch 				-- for the config-uuid, but it will work. 				-- This change will never be committed to the 				-- git-annex branch.-				Logs.Remote.configSet (toUUID (fromProposedAccepted cu)) c'+				Logs.Remote.configSet cu c' 			Nothing -> noop 		remotesChanged 		getEnabledSpecialRemoteByName remotename >>= \case
+ Command/DisableRemote.hs view
@@ -0,0 +1,33 @@+{- git-annex command+ -+ - Copyright 2026 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module Command.DisableRemote where++import Command+import Remote+import Annex.DisableRemote++cmd :: Command+cmd = withAnnexOptions [jsonOptions] $+	command "disableremote" SectionSetup+		"stop using a remote"+		paramName+		(withParams seek)++seek :: CmdParams -> CommandSeek+seek = withWords (commandAction . start)++start :: [String] -> CommandStart+start (remotename:[]) = byName' remotename >>= \case+	Left err -> giveup err+	Right r -> starting "disableremote" ai si $ do+		disableRemote r remotename =<< remoteList+		next $ return True+  where+	ai = ActionItemOther (Just (UnquotedString remotename))+	si = SeekInput [remotename]+start _ = giveup "Specify the remote's name."
Command/EnableRemote.hs view
@@ -25,7 +25,6 @@ import Config.DynamicConfig import Types.GitConfig import Types.ProposedAccepted-import Git.Config  import qualified Data.Map as M @@ -133,7 +132,7 @@ 	case mcu of 		Nothing -> Logs.Remote.configSet u c 		Just (SpecialRemote.ConfigFrom cu) -> do-			setConfig (remoteAnnexConfig c "config-uuid") (fromUUID cu)+			setRemoteConfigUUID c cu 			Logs.Remote.configSet cu c 	Remote.byUUID u >>= \case 		Nothing -> noop@@ -143,7 +142,7 @@ 	when (withUrl o) $ 		Command.InitRemote.setAnnexUrl c 	unless (Remote.gitSyncableRemoteType t || withUrl o) $-		setConfig (remoteConfig c "skipFetchAll") (boolConfig True)+		setRemoteSkipFetchAll c True 	return True  unknownNameError :: String -> Annex a
Command/Fsck.hs view
@@ -702,7 +702,7 @@  -} recordStartTime :: UUID -> Annex () recordStartTime u = do-	f <- fromRepo (gitAnnexFsckState u)+	f <- fromRepo (gitAnnexFsckStateFile u) 	createAnnexDirectory $ parentDir f 	liftIO $ removeWhenExistsWith removeFile f 	liftIO $ F.withFile f WriteMode $ \h -> do@@ -719,12 +719,12 @@  resetStartTime :: UUID -> Annex () resetStartTime u = liftIO . removeWhenExistsWith removeFile-	=<< fromRepo (gitAnnexFsckState u)+	=<< fromRepo (gitAnnexFsckStateFile u)  {- Gets the incremental fsck start time. -} getStartTime :: UUID -> Annex (Maybe EpochTime) getStartTime u = do-	f <- fromRepo (gitAnnexFsckState u)+	f <- fromRepo (gitAnnexFsckStateFile u) 	liftIO $ catchDefaultIO Nothing $ do 		timestamp <- modificationTime <$> R.getFileStatus (fromOsPath f) 		let fromstatus = Just (realToFrac timestamp)
Command/InitRemote.hs view
@@ -20,7 +20,6 @@ import Types.GitConfig import Types.ProposedAccepted import Config-import Git.Config import Git.Types import Annex.Init @@ -107,7 +106,7 @@ perform :: RemoteType -> RemoteName -> R.RemoteConfig -> InitRemoteOptions -> CommandPerform perform t name c o = do 	when (privateRemote o) $-		setConfig (remoteAnnexConfig c "private") (boolConfig True)+		setRemotePrivate c True 	dummycfg <- liftIO dummyRemoteGitConfig 	let c' = M.delete uuidField c 	(c'', u) <- R.setup t R.Init (sameasu <|> uuidfromuser) name Nothing c' dummycfg@@ -132,12 +131,12 @@ 			Logs.Remote.configSet u c 		Just _ -> do 			cu <- liftIO genUUID-			setConfig (remoteAnnexConfig c "config-uuid") (fromUUID cu)+			setRemoteConfigUUID c cu 			Logs.Remote.configSet cu c 	when (withUrl o) $ 		setAnnexUrl c 	unless (Remote.gitSyncableRemoteType t || withUrl o) $-		setConfig (remoteConfig c "skipFetchAll") (boolConfig True)+		setRemoteSkipFetchAll c True 	return True  setAnnexUrl :: R.RemoteConfig -> Annex ()
Command/TestRemote.hs view
@@ -33,6 +33,7 @@ import Remote.Helper.Encryptable (encryptionField, highRandomQualityField) import qualified Utility.FileIO as F import Remote.List+import Test.Framework  import Test.Tasty import Test.Tasty.Runners@@ -108,7 +109,7 @@ 	st <- liftIO . newTVarIO =<< (,) 		<$> Annex.getState id 		<*> Annex.getRead id-	let tests = testGroup "Remote Tests" $ mkTestTrees+	let tests = inOrderTestGroup "Remote Tests" $ mkTestTrees 		(runTestCase st)  		drs 		(pure unavailr)@@ -222,9 +223,9 @@ 	-> (NE.NonEmpty (Described (Annex Key))) 	-> [TestTree] mkTestTrees runannex mkrs mkunavailr mkexportr mkks = concat $-	[ [ testGroup "unavailable remote" (testUnavailable runannex mkunavailr (getVal (NE.head mkks))) ]-	, [ testGroup (desc mkr mkk) (test runannex (getVal mkr) (getVal mkk)) | mkk <- NE.toList mkks, mkr <- mkrs ]-	, [ testGroup (descexport mkk1 mkk2) (testExportTree runannex mkexportr (getVal mkk1) (getVal mkk2)) | mkk1 <- take 2 (NE.toList mkks), mkk2 <- take 2 (reverse (NE.toList mkks)) ]+	[ [ inOrderTestGroup "unavailable remote" (testUnavailable runannex mkunavailr (getVal (NE.head mkks))) ]+	, [ inOrderTestGroup (desc mkr mkk) (test runannex (getVal mkr) (getVal mkk)) | mkk <- NE.toList mkks, mkr <- mkrs ]+	, [ inOrderTestGroup (descexport mkk1 mkk2) (testExportTree runannex mkexportr (getVal mkk1) (getVal mkk2)) | mkk1 <- take 2 (NE.toList mkks), mkk2 <- take 2 (reverse (NE.toList mkks)) ] 	]    where 	desc r k = intercalate "; " $ map unwords
Config.hs view
@@ -69,26 +69,35 @@ remoteCost' gc pc = maybe (getRemoteConfigValue costField pc) Just 	<$> liftIO (getDynamicConfig $ remoteAnnexCost gc) -setRemoteCost :: Git.Repo -> Cost -> Annex ()+setRemoteCost :: RemoteNameable r => r -> Cost -> Annex () setRemoteCost r c = setConfig (remoteAnnexConfig r "cost") (show c) -setRemoteAvailability :: Git.Repo -> Availability -> Annex ()+setRemoteAvailability :: RemoteNameable r => r -> Availability -> Annex () setRemoteAvailability r c = setConfig (remoteAnnexConfig r "availability") (show c) -setRemoteIgnore :: Git.Repo -> Bool -> Annex ()+setRemoteIgnore :: RemoteNameable r => r -> Bool -> Annex () setRemoteIgnore r b = setConfig (remoteAnnexConfig r "ignore") (Git.Config.boolConfig b) -unsetRemoteIgnore :: Git.Repo -> Annex ()+unsetRemoteIgnore :: RemoteNameable r => r -> Annex () unsetRemoteIgnore r = unsetConfig (remoteAnnexConfig r "ignore") -setRemoteIgnoreAuto :: Git.Repo -> Bool -> Annex ()+setRemoteIgnoreAuto :: RemoteNameable r => r -> Bool -> Annex () setRemoteIgnoreAuto r b = setConfig (remoteAnnexConfig r "ignore-auto") (Git.Config.boolConfig b) -unsetRemoteIgnoreAuto :: Git.Repo -> Annex ()+unsetRemoteIgnoreAuto :: RemoteNameable r => r -> Annex () unsetRemoteIgnoreAuto r = unsetConfig (remoteAnnexConfig r "ignore-auto") -setRemoteBare :: Git.Repo -> Bool -> Annex ()+setRemoteBare :: RemoteNameable r => r -> Bool -> Annex () setRemoteBare r b = setConfig (remoteAnnexConfig r "bare") (Git.Config.boolConfig b)++setRemoteConfigUUID :: RemoteNameable r => r -> UUID -> Annex ()+setRemoteConfigUUID r cu = setConfig (remoteAnnexConfig r "config-uuid") (fromUUID cu)++setRemotePrivate :: RemoteNameable r => r -> Bool -> Annex ()+setRemotePrivate r b = setConfig (remoteAnnexConfig r "private") (Git.Config.boolConfig b)++setRemoteSkipFetchAll :: RemoteNameable r => r -> Bool -> Annex ()+setRemoteSkipFetchAll r b = setConfig (remoteConfig r "skipFetchAll") (Git.Config.boolConfig b)  isBareRepo :: Annex Bool isBareRepo = fromRepo Git.repoIsLocalBare
Database/ContentIdentifier.hs view
@@ -29,6 +29,7 @@ 	updateFromLog, 	ContentIdentifiersId, 	AnnexBranchId,+	removeUUID, ) where  import Database.Types@@ -65,7 +66,7 @@ -- ContentIndentifiersKeyRemoteCidIndex speeds up queries like  -- getContentIdentifiers, but it is not used for -- getContentIdentifierKeys. ContentIndentifiersCidRemoteKeyIndex was--- addedto speed that up.+-- added to speed that up. share [mkPersist sqlSettings, mkMigrate "migrateContentIdentifier"] [persistLowerCase| ContentIdentifiers   remote UUID@@ -138,7 +139,10 @@ 		return $ map (contentIdentifiersKey . entityVal) l  recordAnnexBranchTree :: ContentIdentifierHandle -> Sha -> IO ()-recordAnnexBranchTree h s = queueDb h $ do+recordAnnexBranchTree h s = queueDb h $ recordAnnexBranchTree' s++recordAnnexBranchTree' :: Sha -> SqlPersistM ()+recordAnnexBranchTree' s = do 	deleteWhere ([] :: [Filter AnnexBranch]) 	void $ insertUnique_ $ AnnexBranch $ toSSha s @@ -175,3 +179,12 @@ 			liftIO $ forM_ l $ \(rs, cids) -> 				forM_ cids $ \cid -> 					recordContentIdentifier db rs cid k++removeUUID :: UUID -> Bool -> Annex ()+removeUUID u avoidinvalidate = do+	db <- openDb+	liftIO $ queueDb db $ do+		deleteWhere [ ContentIdentifiersRemote ==. u ]+		unless avoidinvalidate $+			recordAnnexBranchTree' emptyTree+	closeDb db
Database/Export.hs view
@@ -1,6 +1,6 @@ {- Sqlite database used for exports to special remotes.  -- - Copyright 2017-2019 Joey Hess <id@joeyh.name>+ - Copyright 2017-2026 Joey Hess <id@joeyh.name>  -:  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -18,6 +18,7 @@ 	ExportHandle, 	openDb, 	closeDb,+	removeDb, 	writeLockDbWhile, 	flushDbQueue, 	addExportedLocation,@@ -52,7 +53,6 @@ import Annex.Export import qualified Logs.Export as Log import Annex.LockFile-import Annex.LockPool import Git.Types import Git.Sha import Git.FilePath@@ -105,6 +105,17 @@ closeDb :: ExportHandle -> Annex () closeDb (ExportHandle h _) = liftIO $ H.closeDbQueue h +removeDb :: UUID -> Annex ()+removeDb u = writeLockDbWhile' u (const noop) noop $ do+	uuiddir <- calcRepo' (gitAnnexExportUUIDDir u)+	void $ liftIO $ whenM (doesDirectoryExist uuiddir) $+		removeDirectoryRecursive uuiddir+	updatelck <- calcRepo' (gitAnnexExportUpdateLock u)+	exlck <- calcRepo' (gitAnnexExportLock u)+	void $ liftIO $ tryNonAsync $ do+		removeWhenExistsWith removeFile updatelck+		removeWhenExistsWith removeFile exlck+ queueDb :: ExportHandle -> SqlPersistM () -> IO () queueDb (ExportHandle h _) = H.queueDb h checkcommit   where@@ -258,11 +269,7 @@  - from the git-annex branch export log.  -} writeLockDbWhile :: ExportHandle -> Annex a -> Annex a-writeLockDbWhile db@(ExportHandle _ u) a = do-	updatelck <- takeExclusiveLock =<< calcRepo' (gitAnnexExportUpdateLock u)-	exlck <- calcRepo' (gitAnnexExportLock u)-	withExclusiveLock exlck $ do-		bracket_ (setup updatelck) cleanup a+writeLockDbWhile db@(ExportHandle _ u) = writeLockDbWhile' u setup cleanup   where 	setup updatelck = do 		void $ updateExportTreeFromLog' db@@ -271,6 +278,13 @@ 		liftIO $ flushDbQueue db 		liftIO $ dropLock updatelck 	cleanup = liftIO $ flushDbQueue db++writeLockDbWhile' :: UUID -> (LockHandle -> Annex ()) -> Annex () -> Annex a -> Annex a+writeLockDbWhile' u setup cleanup a = do+	updatelck <- takeExclusiveLock =<< calcRepo' (gitAnnexExportUpdateLock u)+	exlck <- calcRepo' (gitAnnexExportLock u)+	withExclusiveLock exlck $ do+		bracket_ (setup updatelck) cleanup a  data ExportUpdateResult = ExportUpdateSuccess | ExportUpdateConflict 	deriving (Eq)
Database/Fsck.hs view
@@ -1,6 +1,6 @@ {- Sqlite database used for incremental fsck.   -- - Copyright 2015-2019 Joey Hess <id@joeyh.name>+ - Copyright 2015-2026 Joey Hess <id@joeyh.name>  -:  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -20,6 +20,7 @@ 	newPass, 	openDb, 	closeDb,+	removeDb, 	addDb, 	inDb, 	FsckedId,@@ -81,6 +82,16 @@ closeDb (FsckHandle h u) = do 	liftIO $ H.closeDbQueue h 	unlockFile =<< calcRepo' (gitAnnexFsckDbLock u)++removeDb :: UUID -> Annex ()+removeDb u = do+	lck <- calcRepo' (gitAnnexFsckDbLock u)+	withExclusiveLock lck $ do+		dir <- calcRepo' (gitAnnexFsckDbUUIDDir u)+		liftIO $ whenM (doesDirectoryExist dir) $+			removeDirectoryRecursive dir+		liftIO $ void $ tryNonAsync $+			removeWhenExistsWith removeFile lck  addDb :: FsckHandle -> Key -> IO () addDb (FsckHandle h _) k = H.queueDb h checkcommit $
Database/RepoSize.hs view
@@ -1,6 +1,6 @@ {- Sqlite database used to track the sizes of repositories.  -- - Copyright 2024 Joey Hess <id@joeyh.name>+ - Copyright 2024-2026 Joey Hess <id@joeyh.name>  -:  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -31,6 +31,7 @@ 	recordedRepoOffsets, 	liveRepoOffsets, 	setSizeChanges,+	removeUUID, ) where  import Annex.Common@@ -425,3 +426,22 @@ 			(fromMaybe [] $ M.lookup k livechangesbykey) 	competinglivechanges _ _ AddingKey _ = [] liveRepoOffsets (RepoSizeHandle Nothing _) _ = pure mempty++removeUUID :: UUID -> Annex ()+removeUUID u = do+	db <- openDb+	case db of+		RepoSizeHandle (Just h) _ -> liftIO $ H.commitDb h $ do+			l <- getRepoSizes'+			forM_ (map fst l) unsetRepoSize+			deleteWhere+				[ LiveSizeChangesRepo ==. u+				]+			deleteWhere+				[ SizeChangesRepo ==. u+				]+			deleteWhere+				[ RecentChangesRepo ==. u+				]+		_ -> noop+	closeDb db
Git.hs view
@@ -27,6 +27,7 @@ 	repoIsLocalUnknown, 	repoDescribe, 	repoLocation,+	repoLocationUserVisible, 	repoPath, 	repoWorkTree, 	localGitDir,@@ -38,7 +39,7 @@ 	relPath, ) where -import Network.URI (uriPath, uriScheme, uriQuery, uriFragment, unEscapeString)+import Network.URI (uriPath, uriScheme, uriQuery, uriFragment, uriToString, unEscapeString) #ifndef mingw32_HOST_OS import System.Posix.Files #endif@@ -53,21 +54,21 @@ {- User-visible description of a git repo. -} repoDescribe :: Repo -> String repoDescribe Repo { remoteName = Just name } = name-repoDescribe Repo { location = Url url } = show url-repoDescribe Repo { location = UnparseableUrl url } = url-repoDescribe Repo { location = Local { worktree = Just dir } } = fromOsPath dir-repoDescribe Repo { location = Local { gitdir = dir } } = fromOsPath dir-repoDescribe Repo { location = LocalUnknown dir } = fromOsPath dir-repoDescribe Repo { location = Unknown } = "UNKNOWN"+repoDescribe r = repoLocationUserVisible r  {- Location of the repo, either as a path or url. -} repoLocation :: Repo -> String-repoLocation Repo { location = Url url } = show url+repoLocation Repo { location = Url url } = uriToString id url "" repoLocation Repo { location = UnparseableUrl url } = url repoLocation Repo { location = Local { worktree = Just dir } } = fromOsPath dir repoLocation Repo { location = Local { gitdir = dir } } = fromOsPath dir repoLocation Repo { location = LocalUnknown dir } = fromOsPath dir-repoLocation Repo { location = Unknown } = giveup "unknown repoLocation"+repoLocation Repo { location = Unknown } = giveup "UNKNOWN"++{- Like repoLocation, but obscures any password in a repo url. -}+repoLocationUserVisible :: Repo -> String+repoLocationUserVisible Repo { location = Url url } = show url+repoLocationUserVisible r = repoLocation r  {- Path to a repository. For non-bare, this is the worktree, for bare,   - it's the gitdir, and for URL repositories, is the path on the remote
Logs/File.hs view
@@ -11,6 +11,7 @@ 	writeLogFile, 	withLogHandle, 	appendLogFile,+	appendLogFile', 	modifyLogFile, 	streamLogFile, 	streamLogFileUnsafe,@@ -57,12 +58,16 @@ -- | Appends a line to a log file, first locking it to prevent -- concurrent writers. appendLogFile :: OsPath -> OsPath -> L.ByteString -> Annex ()-appendLogFile f lck c = -	createDirWhenNeeded f $-		withExclusiveLock lck $ do-			liftIO $ F.withFile f AppendMode $-				\h -> L8.hPutStrLn h c-			setAnnexFilePerm f+appendLogFile f lck c = withExclusiveLock lck $ appendLogFile' f c++-- | An exclusive lock must be held while calling this+-- to prevent concurrent writes.+appendLogFile' :: OsPath -> L.ByteString -> Annex ()+appendLogFile' f c = +	createDirWhenNeeded f $ do+		liftIO $ F.withFile f AppendMode $+			\h -> L8.hPutStrLn h c+		setAnnexFilePerm f  -- | Modifies a log file. --
Logs/Transfer.hs view
@@ -1,6 +1,6 @@ {- git-annex transfer information files and lock files  -- - Copyright 2012-2024 Joey Hess <id@joeyh.name>+ - Copyright 2012-2026 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -158,7 +158,7 @@ 	return $ mapMaybe running $ zip transfers infos   where 	findfiles = liftIO . mapM (emptyWhenDoesNotExist . dirContentsRecursive)-		=<< mapM (fromRepo . transferDir) dirs+		=<< mapM (fromRepo . gitAnnexTransferDirectionDir) dirs 	running (t, Just i) = Just (t, i) 	running (_, Nothing) = Nothing @@ -185,22 +185,27 @@ 			(Just t, Just i) -> Just (t, i) 			_ -> Nothing 	findfiles = liftIO . mapM (emptyWhenDoesNotExist . dirContentsRecursive)-		=<< mapM (fromRepo . failedTransferDir u) [Download, Upload]+		=<< mapM (fromRepo . gitAnnexFailedTransferDir u) [Download, Upload] -clearFailedTransfers :: UUID -> Annex [(Transfer, TransferInfo)]+clearFailedTransfers :: UUID -> Annex () clearFailedTransfers u = do 	failed <- getFailedTransfers u 	mapM_ (removeFailedTransfer . fst) failed++tryClearFailedTransfers :: UUID -> Annex [(Transfer, TransferInfo)]+tryClearFailedTransfers u = do+	failed <- getFailedTransfers u+	mapM_ (tryIO . removeFailedTransfer . fst) failed 	return failed  removeFailedTransfer :: Transfer -> Annex () removeFailedTransfer t = do-	f <- fromRepo $ failedTransferFile t-	liftIO $ void $ tryIO $ removeFile f+	f <- fromRepo $ gitAnnexFailedTransferFile t+	liftIO $ removeWhenExistsWith removeFile f  recordFailedTransfer :: Transfer -> TransferInfo -> Annex () recordFailedTransfer t info = do-	failedtfile <- fromRepo $ failedTransferFile t+	failedtfile <- fromRepo $ gitAnnexFailedTransferFile t 	writeTransferInfoFile info failedtfile  {- The transfer information file and transfer lock file @@ -229,19 +234,12 @@ 		Upload -> (transferfile, uuidlockfile, Nothing) 		Download -> (transferfile, nouuidlockfile, Just uuidlockfile)   where-	td = transferDir direction r-	fu = OS.filter (/= unsafeFromChar '/') (fromUUID u)+	td = gitAnnexTransferUUIDDirectionDir u direction r 	kf = keyFile (mkKey (const kd)) 	lckkf = literalOsPath "lck." <> kf-	transferfile = td </> fu </> kf-	uuidlockfile = td </> fu </> lckkf-	nouuidlockfile = td </> literalOsPath "lck" </> lckkf--{- The transfer information file to use to record a failed Transfer -}-failedTransferFile :: Transfer -> Git.Repo -> OsPath-failedTransferFile (Transfer direction u kd) r = -	failedTransferDir u direction r-		</> keyFile (mkKey (const kd))+	transferfile = td </> kf+	uuidlockfile = td </> lckkf+	nouuidlockfile = gitAnnexTransferDirectionDir direction r </> literalOsPath "lck" </> lckkf  {- Parses a transfer information filename to a Transfer. -} parseTransferFile :: OsPath -> Maybe Transfer@@ -327,20 +325,6 @@ 	bytes = if numbits > 1 		then Just <$> readish =<< headMaybe (drop 1 bits) 		else pure Nothing -- not failure--{- The directory holding transfer information files for a given Direction. -}-transferDir :: Direction -> Git.Repo -> OsPath-transferDir direction r = -	gitAnnexTransferDir r-		</> toOsPath (formatDirection direction)--{- The directory holding failed transfer information files for a given- - Direction and UUID -}-failedTransferDir :: UUID -> Direction -> Git.Repo -> OsPath-failedTransferDir u direction r = gitAnnexTransferDir r-	</> literalOsPath "failed"-	</> toOsPath (formatDirection direction)-	</> OS.filter (/= unsafeFromChar '/') (fromUUID u)  prop_read_write_transferinfo :: TransferInfo -> Bool prop_read_write_transferinfo info
Messages.hs view
@@ -1,6 +1,6 @@ {- git-annex output messages  -- - Copyright 2010-2023 Joey Hess <id@joeyh.name>+ - Copyright 2010-2026 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -65,6 +65,9 @@ import System.Exit import qualified Control.Monad.Catch as M import Data.String+#ifndef mingw32_HOST_OS+import System.Posix.Signals+#endif  import Common import Types@@ -355,15 +358,23 @@ {- Catch all (non-async and not ExitCode) exceptions and display,   - sanitizing any control characters in the exceptions.  -- - Exits nonzero on exception, so should only be used at topmost level.+ - Should only be used at topmost level.  -} sanitizeTopLevelExceptionMessages :: IO a -> IO a-sanitizeTopLevelExceptionMessages a = a `catches`-	((M.Handler (\ (e :: ExitCode) -> throwM e)) : nonAsyncHandler go)+sanitizeTopLevelExceptionMessages a = do+#ifndef mingw32_HOST_OS+	-- By default ghc Ignores sigPIPE, and then does not display+	-- exceptions like <stdout>: hFlush: resource vanished (Broken pipe)+	--+	-- Since this would display such exceptions, instead restore the+	-- Default sigPIPE behavior, which is for the program to+	-- immediately exit.+	void $ installHandler sigPIPE Default Nothing+#endif+	a `catches`+		((M.Handler (\ (e :: ExitCode) -> throwM e)) : nonAsyncHandler go)   where-	go e = do-		hPutStrLn stderr $ safeOutput $ toplevelMsg (show e)-		exitWith $ ExitFailure 1+	go e = giveup $ show e  {- Used to only run an action that displays a message after the specified  - number of steps. This is useful when performing an action that can
Remote/Bup.hs view
@@ -334,11 +334,10 @@  - should run at a time; multiple readers may run if no writer is running. -} lockBup :: Bool -> Remote -> Annex a -> Annex a lockBup writer r a = do-	dir <- fromRepo gitAnnexRemotesDir+	lck <- fromRepo $ gitAnnexRemoteLockFile (uuid r)+	let dir = takeDirectory lck 	unlessM (liftIO $ doesDirectoryExist dir) $ 		createAnnexDirectory dir-	let remoteid = fromUUID (uuid r)-	let lck = dir </> remoteid <> literalOsPath ".lck" 	if writer 		then withExclusiveLock lck a 		else withSharedLock lck a
Remote/Directory.hs view
@@ -431,7 +431,7 @@ 				in ContentIdentifier (encodeBS (showInodeCache ic'))  importKeyM :: IgnoreInodes -> OsPath -> ExportLocation -> ContentIdentifier -> ByteSize -> MeterUpdate -> Annex (Maybe Key)-importKeyM ii dir loc cid sz p = do+importKeyM ii dir loc cid _sz p = do 	backend <- chooseBackend f 	k <- fst <$> genKey ks p backend 	currcid <- liftIO $ mkContentIdentifier ii absf
Remote/External.hs view
@@ -17,11 +17,14 @@ import Annex.Common import qualified Annex.ExternalAddonProcess as AddonProcess import Types.Remote+import Types.RemoteState import Types.Export import Types.CleanupActions import Types.UrlContents import Types.ProposedAccepted+import Types.GitConfig import qualified Git+import qualified Git.Construct import Config import Git.Config (boolConfig) import Annex.SpecialRemote.Config@@ -29,16 +32,22 @@ import Remote.Helper.ExportImport import Remote.Helper.ReadOnly import Utility.Metered+import Utility.Hash import Types.Transfer import Logs.PreferredContent.Raw import Logs.RemoteState import Logs.Web+import Logs.Remote+import Logs.File import Config.Cost import Annex.Content import Annex.Url import Annex.UUID import Annex.Verify+import Annex.DisableRemote+import Annex.LockFile import Creds+import qualified Utility.FileIO as F  import Control.Concurrent.STM import qualified Data.Map as M@@ -238,15 +247,19 @@  storeKeyM :: External -> Storer storeKeyM external = fileStorer $ \k f p ->-	either giveup return =<< go k p+	either giveup return =<< go k f p 		(\sk -> TRANSFER Upload sk (fromOsPath f))   where-	go k p mkreq = handleRequestKey external mkreq k (Just p) $ \resp ->+	go k f p mkreq = handleRequestKey external mkreq k (Just p) $ \resp -> 		case resp of 			TRANSFER_SUCCESS Upload k' | k == k' -> 				result (Right ()) 			TRANSFER_FAILURE Upload k' errmsg | k == k' -> 				result (Left (respErrorMessage "TRANSFER" errmsg))+			DELEGATE ps -> Just $ do+				delegate <- getDelegateRemote external ps+				storeKey delegate k (AssociatedFile Nothing) (Just f) p	+				return (Result (Right ())) 			_ -> Nothing  retrieveKeyFileM :: External -> RemoteGitConfig -> Retriever@@ -262,10 +275,16 @@ 					respErrorMessage "TRANSFER" errmsg 			TRANSFER_RETRIEVE_URL k' url 				| k == k' -> retrieveUrl' gc url dest k p+			DELEGATE ps -> Just $ do+				delegate <- getDelegateRemote external ps+				_ <- retrieveKeyFile delegate k+					(AssociatedFile Nothing) dest p+					NoVerify+				return (Result (Right ())) 			_ -> Nothing  removeKeyM :: External -> Remover-removeKeyM external _proof k = either giveup return =<< go+removeKeyM external proof k = either giveup return =<< go   where 	go = handleRequestKey external REMOVE k Nothing $ \resp -> 		case resp of@@ -274,6 +293,10 @@ 			REMOVE_FAILURE k' errmsg 				| k == k' -> result $ Left $ 					respErrorMessage "REMOVE" errmsg+			DELEGATE ps -> Just $ do+				delegate <- getDelegateRemote external ps+				_ <- removeKey delegate proof k+				return (Result (Right ())) 			_ -> Nothing  checkPresentM :: External -> RemoteGitConfig -> CheckPresent@@ -290,12 +313,20 @@ 					respErrorMessage "CHECKPRESENT" errmsg 			CHECKPRESENT_URL k' url 				| k == k' -> checkKeyUrl' gc k url+			DELEGATE ps -> Just $ do+				delegate <- getDelegateRemote external ps+				Result . Right <$> checkPresent delegate k 			_ -> Nothing  whereisKeyM :: External -> Key -> Annex [String] whereisKeyM external k = handleRequestKey external WHEREIS k Nothing $ \resp -> case resp of 	WHEREIS_SUCCESS s -> result [s] 	WHEREIS_FAILURE -> result []+	DELEGATE ps -> Just $ do+		delegate <- getDelegateRemote external ps+		case whereisKey delegate of+			Just a -> Result <$> a k+			Nothing -> return (Result []) 	UNSUPPORTED_REQUEST -> result [] 	_ -> Nothing @@ -306,6 +337,10 @@ 		TRANSFER_SUCCESS Upload k' | k == k' -> result $ Right () 		TRANSFER_FAILURE Upload k' errmsg | k == k' -> 			result $ Left $ respErrorMessage "TRANSFER" errmsg+		DELEGATE ps -> Just $ do+			delegate <- getDelegateRemote external ps+			_ <- storeExport (exportActions delegate) f k loc p+			return (Result (Right ())) 		UNSUPPORTED_REQUEST ->  			result $ Left "TRANSFEREXPORT not implemented by external special remote" 		_ -> Nothing@@ -324,6 +359,10 @@ 			| k == k' -> result $ Left $ respErrorMessage "TRANSFER" errmsg 		TRANSFER_RETRIEVE_URL k' url 			| k == k' -> retrieveUrl' gc url dest k p+		DELEGATE ps -> Just $ do+			delegate <- getDelegateRemote external ps+			_ <- retrieveExport (exportActions delegate) k loc dest p+			return (Result (Right ())) 		UNSUPPORTED_REQUEST -> 			result $ Left "TRANSFEREXPORT not implemented by external special remote" 		_ -> Nothing@@ -342,6 +381,9 @@ 				respErrorMessage "CHECKPRESENT" errmsg 		CHECKPRESENT_URL k' url 			| k == k' -> checkKeyUrl' gc k url+		DELEGATE ps -> Just $ do+			delegate <- getDelegateRemote external ps+			Result . Right <$> checkPresentExport (exportActions delegate) k loc 		UNSUPPORTED_REQUEST -> result $ 			Left "CHECKPRESENTEXPORT not implemented by external special remote" 		_ -> Nothing@@ -354,6 +396,10 @@ 			| k == k' -> result $ Right () 		REMOVE_FAILURE k' errmsg 			| k == k' -> result $ Left $ respErrorMessage "REMOVE" errmsg+		DELEGATE ps -> Just $ do+			delegate <- getDelegateRemote external ps+			_ <- removeExport (exportActions delegate) k loc+			return (Result (Right ())) 		UNSUPPORTED_REQUEST -> result $ 			Left $ "REMOVEEXPORT not implemented by external special remote" 		_ -> Nothing@@ -365,6 +411,12 @@ 		REMOVEEXPORTDIRECTORY_SUCCESS -> result $ Right () 		REMOVEEXPORTDIRECTORY_FAILURE -> result $ 			Left "failed to remove directory"+		DELEGATE ps -> Just $ do+			delegate <- getDelegateRemote external ps+			case removeExportDirectory (exportActions delegate) of+				Just a -> a dir+				Nothing -> return ()+			return (Result (Right ())) 		UNSUPPORTED_REQUEST -> result $ Right () 		_ -> Nothing 	req = REMOVEEXPORTDIRECTORY dir@@ -377,6 +429,11 @@ 			| k' == k -> result $ Right (Just ()) 		RENAMEEXPORT_FAILURE k'  			| k' == k -> result $ Left "failed to rename exported file"+		DELEGATE ps -> Just $ do+			delegate <- getDelegateRemote external ps+			case renameExport (exportActions delegate) of+				Just a -> Result . Right <$> a k src dest+				Nothing -> return $ Result $ Right Nothing 		UNSUPPORTED_REQUEST -> result (Right Nothing) 		_ -> Nothing 	req sk = RENAMEEXPORT sk dest@@ -742,9 +799,11 @@ 		giveup ("unable to use external special remote " ++ externalcmd)  stopExternal :: External -> Annex ()-stopExternal external = liftIO $ do-	l <- atomically $ swapTVar (externalState external) []-	mapM_ (flip externalShutdown False) l+stopExternal external = do+	liftIO $ do+		l <- atomically $ swapTVar (externalState external) []+		mapM_ (flip externalShutdown False) l+	removeEphemeralDelegates external  checkVersion :: ExternalState -> RemoteRequest -> Maybe (Annex ()) checkVersion st (VERSION v) = Just $@@ -964,3 +1023,123 @@ 	isproposed (Accepted _) = False 	isproposed (Proposed _) = True +getDelegateRemote :: External -> [String] -> Annex Remote+getDelegateRemote external ps = do+	rs <- Annex.getState Annex.remotes+	case filter (\r -> name r == delegatename) rs of+		(r:_) -> return r+		_ -> do+			lockfile <- fromRepo $ gitAnnexRemoteLockFile externalu+			r <- withExclusiveLock lockfile $ do+				r <- gendelegate+				when isephemeral $ do+					statefile <- fromRepo $ gitAnnexRemoteStateFile externalu+					appendLogFile' statefile (encodeBL delegatename)+				return r+			when isephemeral $+				registerephemeral r+			return r+  where+	registerephemeral r = do+		-- Take a shared lock of the state file to indicate the+		-- remote is in use.+		statefile <- fromRepo $ gitAnnexRemoteStateFile externalu+		let lckvar = externalEphemeralDelegateLock external+		liftIO (atomically (takeTMVar lckvar)) >>= \case+			Just lck -> liftIO $ atomically $+				putTMVar lckvar (Just lck)+			Nothing -> do+				lck <- takeSharedLock statefile+				liftIO $ atomically $+					putTMVar lckvar (Just lck)+		liftIO $ atomically $ do+			l <- takeTMVar (externalEphemeralDelegates external)+			putTMVar (externalEphemeralDelegates external) (r:l)++	externalu = case externalUUID external of+		Just u -> u+		Nothing -> error "internal"++	(ps', isephemeral) = checkephemeral ps [] False++	checkephemeral [] c b = (reverse c, b)+	checkephemeral (p:rest) c b+		| p == "ephemeral=yes" = checkephemeral rest c True+		| p == "ephemeral=no" = checkephemeral rest c False+		| otherwise = checkephemeral rest (p:c) b++	-- Hash the configuration of the delegate remote, so+	-- re-using the same configuration yields the same name.+	delegatename = concat+		[ fromMaybe "external" (externalRemoteName external)+		, "-delegate-"+		, show $ md5s $ encodeBS $ show ps+		]+	+	gendelegate = do+		c <- newConfig delegatename (Just (Sameas externalu))+			(keyValToConfig Proposed ps')+			<$> remoteConfigMap+		remotetypes <- Annex.getState Annex.remotetypes+		t <- either giveup return (findType' remotetypes c)+		dummycfg <- liftIO dummyRemoteGitConfig+		(c', u) <- setup t Init (Just externalu) delegatename Nothing c dummycfg+		+		setRemotePrivate c' True+		cu <- liftIO genUUID+		setRemoteConfigUUID c' cu+		Logs.Remote.configSet cu c'+		+		setRemoteSkipFetchAll c' True+		setRemoteIgnore c' True++		g <- liftIO $ Git.Construct.remoteNamed delegatename+			(pure Git.Construct.fromUnknown)+		gc <- Annex.getRemoteGitConfig g+		let rs = RemoteStateHandle cu+		r <- generate t g u c' gc rs >>= \case+			Nothing -> error "Failed to generate a delegate remote"+			Just r -> adjustExportImport r rs+		Annex.changeState $ \s -> s +			{ Annex.remotes = r : Annex.remotes s+			}+		return r++removeEphemeralDelegates :: External -> Annex ()+removeEphemeralDelegates external = do+	let lckvar = externalEphemeralDelegateLock external+	liftIO (atomically (takeTMVar lckvar)) >>= \case+		Just sharedlck -> do+			liftIO $ dropLock sharedlck+			case externalUUID external of+				Just externalu -> go externalu+				Nothing -> return ()+		Nothing -> return ()+	liftIO $ atomically $ putTMVar lckvar Nothing+  where+	go externalu = do+		statefile <- fromRepo $ gitAnnexRemoteStateFile externalu+		lockfile <- fromRepo $ gitAnnexRemoteLockFile externalu+		-- Only remove them when no other process has a shared+		-- lock of the state file. (And when no other process+		-- is also removing them.)+		void $ tryExclusiveLock statefile $+			withExclusiveLock lockfile $ do+				ds <- liftIO $ nub . map decodeBL . fileLines+					<$> F.readFile statefile+				rs <- Annex.getState Annex.remotes+				rs' <- liftIO $ atomically $ readTMVar (externalEphemeralDelegates external)+				let rs'' = rs'++rs+				forM_ ds $ \delegatename ->+					case filter (\r -> name r == delegatename) rs'' of+						(r:_) -> disable r delegatename rs''+						_ -> return ()+				writeLogFile statefile ""+	+	disable r delegatename rs = +		tryNonAsync (disableRemote r delegatename rs) >>= \case+			Right () -> return ()+			Left err -> do+				warning $ UnquotedString $ +					"Unable to remove ephemeral delegate remote " ++ delegatename ++ ": " ++ show err+				return ()
Remote/External/Types.hs view
@@ -55,6 +55,7 @@ import Utility.Url (URLString) import Utility.Url.Parse import qualified Utility.SimpleProtocol as Proto+import Annex.LockFile  import Control.Concurrent.STM import Network.URI@@ -74,6 +75,8 @@ 	, externalRemoteName :: Maybe RemoteName  	, externalRemoteStateHandle :: Maybe RemoteStateHandle 	, externalAsync :: TMVar ExternalAsync+	, externalEphemeralDelegateLock :: TMVar (Maybe LockHandle)+	, externalEphemeralDelegates :: TMVar [Remote] 	}  newExternal :: ExternalProgram -> Maybe UUID -> ParsedRemoteConfig -> Maybe RemoteGitConfig -> Maybe RemoteName -> Maybe RemoteStateHandle -> Annex External@@ -87,6 +90,8 @@ 	<*> pure rn 	<*> pure rs 	<*> atomically (newTMVar UncheckedExternalAsync)+	<*> atomically (newTMVar Nothing)+	<*> atomically (newTMVar [])  data ExternalProgram 	= ExternalType String@@ -117,6 +122,7 @@ 	, "UNAVAILABLERESPONSE" 	, "TRANSFER-RETRIEVE-URL" 	, "CHECKPRESENT-URL"+	, "DELEGATE" 	, asyncExtension 	] @@ -275,6 +281,7 @@ 	| REMOVEEXPORTDIRECTORY_FAILURE 	| RENAMEEXPORT_SUCCESS Key 	| RENAMEEXPORT_FAILURE Key+	| DELEGATE [String] 	| UNSUPPORTED_REQUEST 	deriving (Show) @@ -315,6 +322,7 @@ 	parseCommand "REMOVEEXPORTDIRECTORY-FAILURE" = Proto.parse0 REMOVEEXPORTDIRECTORY_FAILURE 	parseCommand "RENAMEEXPORT-SUCCESS" = Proto.parse1 RENAMEEXPORT_SUCCESS 	parseCommand "RENAMEEXPORT-FAILURE" = Proto.parse1 RENAMEEXPORT_FAILURE+	parseCommand "DELEGATE" = Proto.parseList DELEGATE 	parseCommand "UNSUPPORTED-REQUEST" = Proto.parse0 UNSUPPORTED_REQUEST 	parseCommand _ = Proto.parseFail
Remote/Helper/Git.hs view
@@ -81,7 +81,7 @@ 	let proxynames = map proxyname $ filter (not . iscluster) proxying 	let clusternames = map proxyname $ filter iscluster proxying 	return $ catMaybes-		[ Just ("repository location", Git.repoLocation repo)+		[ Just ("repository location", Git.repoLocationUserVisible repo) 		, Just ("last synced", lastsynctime) 		, Just ("proxied", proxied) 		, if isClusterUUID (Remote.uuid r)
Remote/Helper/Hooks.hs view
@@ -49,14 +49,13 @@  runHooks :: Remote -> Maybe String -> Maybe String -> Annex a -> Annex a runHooks r starthook stophook a = do-	dir <- fromRepo gitAnnexRemotesDir-	let lck = dir </> remoteid <> literalOsPath ".lck"+	lck <- fromRepo $ gitAnnexRemoteLockFile (uuid r)+	let dir = takeDirectory lck 	whenM (notElem lck . M.keys <$> getLockCache) $ do 		createAnnexDirectory dir 		firstrun lck 	a   where-	remoteid = fromUUID (uuid r) 	run Nothing = noop 	run (Just command) = void $ liftIO $ 		boolSystem "sh" [Param "-c", Param command]
Remote/List.hs view
@@ -82,7 +82,10 @@ remoteList' autoinit = do 	m <- remoteConfigMap 	rs <- concat <$> mapM (process m) remoteTypes-	Annex.changeState $ \s -> s { Annex.remotes = rs }+	Annex.changeState $ \s -> s+		{ Annex.remotes = rs+		, Annex.remotetypes = remoteTypes+		} 	return rs   where 	process m t = enumerate t autoinit
Remote/Rsync.hs view
@@ -106,7 +106,7 @@ 				, retrieveExport = retrieveExportM o 				, removeExport = removeExportM o 				, checkPresentExport = checkPresentExportM o-				, removeExportDirectory = Just (removeExportDirectoryM o)+				, removeExportDirectory = Nothing 				, renameExport = Just $ renameExportM o 				} 			, importActions = importUnsupported@@ -342,9 +342,6 @@ 	includes f = f : case upFrom f of 		Nothing -> [] 		Just f' -> includes f'--removeExportDirectoryM :: RsyncOpts -> ExportDirectory -> Annex ()-removeExportDirectoryM o ed = removeGeneric o []  renameExportM :: RsyncOpts -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe ()) renameExportM _ _ _ _ = return Nothing
Test.hs view
@@ -161,7 +161,7 @@ 		(repoTests d numparts)  properties :: TestTree-properties = localOption (QuickCheckTests 1000) $ testGroup "QuickCheck" $+properties = localOption (QuickCheckTests 1000) $ inOrderTestGroup "QuickCheck" $ 	[ testProperty "prop_quote_unquote_roundtrip" Git.Quote.prop_quote_unquote_roundtrip 	, testProperty "prop_encode_c_decode_c_roundtrip" Utility.Format.prop_encode_c_decode_c_roundtrip 	, testProperty "prop_isomorphic_key_encode" Key.prop_isomorphic_key_encode@@ -205,7 +205,7 @@ 		]  testRemotes :: TestTree-testRemotes = testGroup "Remote Tests" $+testRemotes = inOrderTestGroup "Remote Tests" $ 	-- These tests are failing in really strange ways on Windows, 	-- apparently not due to an actual problem with the remotes being 	-- tested, so are disabled there.@@ -235,7 +235,7 @@ testRemote :: Bool -> String -> (String -> IO ()) -> TestTree testRemote testvariants remotetype setupremote =  	withResource newEmptyTMVarIO (const noop) $ \getv -> -		testGroup ("testremote type " ++ remotetype) $ concat+		inOrderTestGroup ("testremote type " ++ remotetype) $ concat 			[ [testCase "init" (prep getv)] 			, go getv 			]@@ -280,7 +280,7 @@ {- These tests set up the test environment, but also test some basic parts  - of git-annex. They are always run before the repoTests. -} initTests :: TestTree-initTests = testGroup initTestsName+initTests = inOrderTestGroup initTestsName 	[ testCase "init" test_init 	, testCase "add" test_add 	]@@ -372,7 +372,7 @@ 	, testCase "enableremote encryption changes" test_enableremote_encryption_changes 	]   where-	mk l = testGroup groupname (initTests : map adddep l)+	mk l = inOrderTestGroup groupname (initTests : map adddep l) 	adddep = Test.Tasty.after AllSucceed (groupname ++ "." ++ initTestsName) 	groupname = "Repo Tests " ++ note 	sep l =
Test/Framework.hs view
@@ -1,13 +1,18 @@ {- git-annex test suite framework  -- - Copyright 2010-2024 Joey Hess <id@joeyh.name>+ - Copyright 2010-2026 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}  {-# LANGUAGE OverloadedStrings, CPP #-} -module Test.Framework where+module Test.Framework (+	module Test.Framework,+#if MIN_VERSION_tasty(1,5,4)+	inOrderTestGroup+#endif+) where  import Test.Tasty import Test.Tasty.Runners@@ -234,7 +239,7 @@  setuprepo :: FilePath -> IO FilePath setuprepo dir = do-	cleanup dir+	cleanupTestDir dir 	git "init" ["-q", dir] "git init" 	configrepo dir 	return dir@@ -253,7 +258,7 @@ -- clones are always done as local clones; we cannot test ssh clones clonerepo :: FilePath -> FilePath -> CloneRepoConfig -> IO FilePath clonerepo old new cfg = do-	cleanup new+	cleanupTestDir new 	let cloneparams = catMaybes 		[ Just "-q" 		, if bareClone cfg then Just "--bare" else Nothing@@ -346,8 +351,8 @@ removeDirectoryForCleanup :: FilePath -> IO () removeDirectoryForCleanup = removePathForcibly . toOsPath -cleanup :: FilePath -> IO ()-cleanup dir = whenM (doesDirectoryExist (toOsPath dir)) $ do+cleanupTestDir :: FilePath -> IO ()+cleanupTestDir dir = whenM (doesDirectoryExist (toOsPath dir)) $ do 	Command.Uninit.prepareRemoveAnnexDir' (toOsPath dir) 	-- This can fail if files in the directory are still open by a 	-- subprocess.@@ -891,7 +896,7 @@ 			(False, tastyOptionSet opts)  topLevelTestGroup :: [TestTree] -> TestTree-topLevelTestGroup = testGroup "Tests"+topLevelTestGroup = inOrderTestGroup "Tests"  initTestsName :: String initTestsName = "Init Tests"@@ -905,3 +910,8 @@ 	, rerunningTests [consoleTestReporter] 	] +-- Prior to tasty 1.5.4, testGroup ran in order.+#if ! MIN_VERSION_tasty(1,5,4)+inOrderTestGroup :: TestName -> [TestTree] -> TestTree+inOrderTestGroup = testGroup+#endif
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 10.20260316+Version: 10.20260421 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -523,6 +523,7 @@     Annex.Debug.Utility     Annex.Difference     Annex.DirHashes+    Annex.DisableRemote     Annex.Drop     Annex.Environment     Annex.Export@@ -640,6 +641,7 @@     Command.Dead     Command.Describe     Command.DiffDriver+    Command.DisableRemote     Command.Drop     Command.DropKey     Command.DropUnused