git-annex 10.20240430 → 10.20240531

raw patch · 66 files changed

+1843/−178 lines, 66 files

Files

• Annex/AdjustedBranch.hs +17/−9
• Annex/Branch.hs +2/−1
• Annex/Init.hs +8/−4
• Annex/Journal.hs +23/−18
• Annex/Locations.hs +12/−7
• Annex/RemoteTrackingBranch.hs +1/−1
• Annex/SpecialRemote/Config.hs +11/−5
• Annex/Ssh.hs +1/−1
• Annex/YoutubeDl.hs +1/−1
• Assistant/DaemonStatus.hs +1/−1
• Assistant/Threads/Cronner.hs +1/−1
• Assistant/Threads/NetWatcher.hs +2/−2
• Assistant/Upgrade.hs +1/−1
• Backend/GitRemoteAnnex.hs +120/−0
• Backend/Hash.hs +11/−13
• Backend/VURL.hs +5/−5
• Backend/Variety.hs +2/−0
• Build/DesktopFile.hs +1/−1
• CHANGELOG +21/−1
• CmdLine/GitRemoteAnnex.hs +1201/−0
• CmdLine/GitRemoteTorAnnex.hs +1/−1
• Command/EnableRemote.hs +33/−16
• Command/EnableTor.hs +1/−1
• Command/Fsck.hs +27/−20
• Command/Group.hs +37/−8
• Command/ImportFeed.hs +1/−1
• Command/InitRemote.hs +23/−2
• Command/Log.hs +3/−3
• Command/Migrate.hs +1/−1
• Command/SendKey.hs +1/−1
• Command/Sync.hs +3/−3
• Command/TestRemote.hs +3/−1
• Command/Unused.hs +4/−2
• Database/Handle.hs +1/−1
• Database/Keys.hs +1/−1
• Git.hs +1/−1
• Git/Branch.hs +9/−5
• Git/Bundle.hs +68/−0
• Git/Fsck.hs +1/−1
• Git/Ref.hs +34/−3
• Git/Remote.hs +7/−1
• Git/Version.hs +1/−1
• Logs.hs +1/−1
• Logs/EquivilantKeys.hs +1/−1
• Messages.hs +2/−2
• Remote.hs +11/−1
• Remote/Adb.hs +1/−1
• Remote/Directory.hs +1/−1
• Remote/Git.hs +4/−1
• Remote/Helper/Chunked.hs +1/−1
• Remote/Helper/Encryptable.hs +12/−7
• Remote/List.hs +15/−3
• Types/BranchState.hs +4/−1
• Types/Difference.hs +1/−0
• Types/GitConfig.hs +15/−1
• Types/GitRemoteAnnex.hs +45/−0
• Types/Key.hs +8/−1
• Types/RemoteConfig.hs +2/−0
• Types/StallDetection.hs +2/−2
• Utility/Gpg.hs +1/−1
• Utility/Matcher.hs +1/−1
• Utility/Path/AbsRel.hs +1/−1
• Utility/QuickCheck.hs +2/−2
• Utility/StatelessOpenPGP.hs +1/−1
• git-annex.cabal +5/−1
• git-annex.hs +3/−1

@@ -1,6 +1,6 @@ {- adjusted branch  -- - Copyright 2016-2023 Joey Hess <id@joeyh.name>+ - Copyright 2016-2024 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -68,9 +68,12 @@ import Config import Logs.View (is_branchView) import Logs.AdjustedBranchUpdate+import Utility.FileMode+import qualified Utility.RawFilePath as R  import Data.Time.Clock.POSIX import qualified Data.Map as M+import System.PosixCompat.Files (fileMode)  class AdjustTreeItem t where 	-- How to perform various adjustments to a TreeItem.@@ -155,8 +158,13 @@ adjustToPointer ti@(TreeItem f _m s) = catKey s >>= \case 	Just k -> do 		Database.Keys.addAssociatedFile k f-		Just . TreeItem f (fromTreeItemType TreeFile)-			<$> hashPointerFile k+		exe <- catchDefaultIO False $+			(isExecutable . fileMode) <$> +				(liftIO . R.getFileStatus+					=<< calcRepo (gitAnnexLocation k))+		let mode = fromTreeItemType $ +			if exe then TreeExecutable else TreeFile+		Just . TreeItem f mode <$> hashPointerFile k 	Nothing -> return (Just ti)  adjustToSymlink :: TreeItem -> Annex (Maybe TreeItem)@@ -173,7 +181,7 @@  -- This is a hidden branch ref, that's used as the basis for the AdjBranch, -- since pushes can overwrite the OrigBranch at any time. So, changes--- are propigated from the AdjBranch to the head of the BasisBranch.+-- are propagated from the AdjBranch to the head of the BasisBranch. newtype BasisBranch = BasisBranch Ref  -- The basis for refs/heads/adjusted/master(unlocked) is@@ -256,7 +264,7 @@ 	| not (adjustmentIsStable adj) = do 		(b, origheadfile, newheadfile) <- preventCommits $ \commitlck -> do 			-- Avoid losing any commits that the adjusted branch-			-- has that have not yet been propigated back to the+			-- has that have not yet been propagated back to the 			-- origbranch. 			_ <- propigateAdjustedCommits' True origbranch adj commitlck 			@@ -472,7 +480,7 @@ 	-- since that message is looked for later. 	-- After git-annex 10.20240227, it's possible to use 	-- commitTree instead of this, but this is being kept-	-- for some time, for compatability with older versions.+	-- for some time, for compatibility with older versions. 	mkcommit cmode = Git.Branch.commitTreeExactMessage cmode 		adjustedBranchCommitMessage parents treesha @@ -497,10 +505,10 @@ 			_ -> return Nothing  {- Check for any commits present on the adjusted branch that have not yet- - been propigated to the basis branch, and propagate them to the basis+ - been propagated to the basis branch, and propagate them to the basis  - branch and from there on to the orig branch.  -- - After propigating the commits back to the basis branch,+ - After propagating the commits back to the basis branch,  - rebase the adjusted branch on top of the updated basis branch.  -} propigateAdjustedCommits :: OrigBranch -> Adjustment -> Annex ()@@ -642,7 +650,7 @@  - checked out adjusted branch; the origin could have the two branches  - out of sync (eg, due to another branch having been pushed to the origin's  - origbranch), or due to a commit on its adjusted branch not having been- - propigated back to origbranch.+ - propagated back to origbranch.  -  - So, find the adjusting commit on the currently checked out adjusted  - branch, and use the parent of that commit as the basis, and set the

@@ -727,7 +727,8 @@ stageJournal jl commitindex = withIndex $ withOtherTmp $ \tmpdir -> do 	prepareModifyIndex jl 	g <- gitRepo-	let dir = gitAnnexJournalDir g+	st <- getState+	let dir = gitAnnexJournalDir st g 	(jlogf, jlogh) <- openjlog (fromRawFilePath tmpdir) 	withHashObjectHandle $ \h -> 		withJournalHandle gitAnnexJournalDir $ \jh ->

@@ -1,6 +1,6 @@ {- git-annex repository initialization  -- - 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.  -}@@ -12,6 +12,7 @@ 	checkInitializeAllowed, 	ensureInitialized, 	autoInitialize,+	autoInitialize', 	isInitialized, 	initialize, 	initialize',@@ -256,14 +257,17 @@  - Checks repository version and handles upgrades too.  -} autoInitialize :: Annex [Remote] -> Annex ()-autoInitialize remotelist = getInitializedVersion >>= maybe needsinit checkUpgrade+autoInitialize = autoInitialize' autoInitializeAllowed++autoInitialize' :: Annex Bool -> Annex [Remote] -> Annex ()+autoInitialize' check remotelist = getInitializedVersion >>= maybe needsinit checkUpgrade   where 	needsinit =-		whenM (initializeAllowed <&&> autoInitializeAllowed) $ do+		whenM (initializeAllowed <&&> check) $ do 			initialize Nothing Nothing 			autoEnableSpecialRemotes remotelist -{- Checks if a repository is initialized. Does not check version for ugrade. -}+{- Checks if a repository is initialized. Does not check version for upgrade. -} isInitialized :: Annex Bool isInitialized = maybe Annex.Branch.hasSibling (const $ return True) =<< getVersion 

@@ -7,7 +7,7 @@  - All files in the journal must be a series of lines separated by  - newlines.  -- - 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.  -}@@ -23,6 +23,8 @@ import Annex.Perms import Annex.Tmp import Annex.LockFile+import Annex.BranchState+import Types.BranchState import Utility.Directory.Stream import qualified Utility.RawFilePath as R @@ -82,9 +84,10 @@  -} setJournalFile :: Journalable content => JournalLocked -> RegardingUUID -> RawFilePath -> content -> Annex () setJournalFile _jl ru file content = withOtherTmp $ \tmp -> do+	st <- getState 	jd <- fromRepo =<< ifM (regardingPrivateUUID ru)-		( return gitAnnexPrivateJournalDir-		, return gitAnnexJournalDir+		( return (gitAnnexPrivateJournalDir st)+		, return (gitAnnexJournalDir st) 		) 	-- journal file is written atomically 	let jfile = journalFile file@@ -106,9 +109,10 @@  - branch. -} checkCanAppendJournalFile :: JournalLocked -> RegardingUUID -> RawFilePath -> Annex (Maybe AppendableJournalFile) checkCanAppendJournalFile _jl ru file = do+	st <- getState 	jd <- fromRepo =<< ifM (regardingPrivateUUID ru)-		( return gitAnnexPrivateJournalDir-		, return gitAnnexJournalDir+		( return (gitAnnexPrivateJournalDir st)+		, return (gitAnnexJournalDir st) 		) 	let jfile = jd P.</> journalFile file 	ifM (liftIO $ R.doesPathExist jfile)@@ -176,14 +180,12 @@  -} getJournalFileStale :: GetPrivate -> RawFilePath -> Annex JournalledContent getJournalFileStale (GetPrivate getprivate) file = do-	-- Optimisation to avoid a second MVar access. 	st <- Annex.getState id-	let g = Annex.repo st 	liftIO $ 		if getprivate && privateUUIDsKnown' st 		then do-			x <- getfrom (gitAnnexJournalDir g)-			getfrom (gitAnnexPrivateJournalDir g) >>= \case+			x <- getfrom (gitAnnexJournalDir (Annex.branchstate st) (Annex.repo st))+			getfrom (gitAnnexPrivateJournalDir (Annex.branchstate st) (Annex.repo st)) >>= \case 				Nothing -> return $ case x of 					Nothing -> NoJournalledContent 					Just b -> JournalledContent b@@ -193,7 +195,7 @@ 					-- happens in a merge of two 					-- git-annex branches. 					Just x' -> x' <> y-		else getfrom (gitAnnexJournalDir g) >>= return . \case+		else getfrom (gitAnnexJournalDir (Annex.branchstate st) (Annex.repo st)) >>= return . \case 			Nothing -> NoJournalledContent 			Just b -> JournalledContent b   where@@ -219,18 +221,20 @@ {- List of existing journal files in a journal directory, but without locking,  - may miss new ones just being added, or may have false positives if the  - journal is staged as it is run. -}-getJournalledFilesStale :: (Git.Repo -> RawFilePath) -> Annex [RawFilePath]+getJournalledFilesStale :: (BranchState -> Git.Repo -> RawFilePath) -> Annex [RawFilePath] getJournalledFilesStale getjournaldir = do-	g <- gitRepo-	fs <- liftIO $ catchDefaultIO [] $-		getDirectoryContents $ fromRawFilePath (getjournaldir g)+	st <- Annex.getState id+	let d = getjournaldir (Annex.branchstate st) (Annex.repo st)+	fs <- liftIO $ catchDefaultIO [] $ +		getDirectoryContents (fromRawFilePath d) 	return $ filter (`notElem` [".", ".."]) $ 		map (fileJournal . toRawFilePath) fs  {- Directory handle open on a journal directory. -}-withJournalHandle :: (Git.Repo -> RawFilePath) -> (DirectoryHandle -> IO a) -> Annex a+withJournalHandle :: (BranchState -> Git.Repo -> RawFilePath) -> (DirectoryHandle -> IO a) -> Annex a withJournalHandle getjournaldir a = do-	d <- fromRepo getjournaldir+	st <- Annex.getState id+	let d = getjournaldir (Annex.branchstate st) (Annex.repo st) 	bracket (opendir d) (liftIO . closeDirectory) (liftIO . a)   where 	-- avoid overhead of creating the journal directory when it already@@ -239,9 +243,10 @@ 		`catchIO` (const (createAnnexDirectory d >> opendir d))  {- Checks if there are changes in the journal. -}-journalDirty :: (Git.Repo -> RawFilePath) -> Annex Bool+journalDirty :: (BranchState -> Git.Repo -> RawFilePath) -> Annex Bool journalDirty getjournaldir = do-	d <- fromRawFilePath <$> fromRepo getjournaldir+	st <- getState+	d <- fromRawFilePath <$> fromRepo (getjournaldir st) 	liftIO $  		(not <$> isDirectoryEmpty d) 			`catchIO` (const $ doesDirectoryExist d)

@@ -118,6 +118,7 @@ import Types.UUID import Types.GitConfig import Types.Difference+import Types.BranchState import qualified Git import qualified Git.Types as Git import Git.FilePath@@ -131,7 +132,7 @@  - trailing path separator. Most code does not rely on that, but a few  - things do.   -- - Everything else should not end in a trailing path sepatator. + - Everything else should not end in a trailing path separator.   -  - Only functions (with names starting with "git") that build a path  - based on a git repository should return full path relative to the git@@ -528,15 +529,19 @@  {- .git/annex/journal/ is used to journal changes made to the git-annex  - branch -}-gitAnnexJournalDir :: Git.Repo -> RawFilePath-gitAnnexJournalDir r = -	P.addTrailingPathSeparator $ gitAnnexDir r P.</> "journal"+gitAnnexJournalDir :: BranchState -> Git.Repo -> RawFilePath+gitAnnexJournalDir st r = P.addTrailingPathSeparator $ +	case alternateJournal st of+		Nothing -> gitAnnexDir r P.</> "journal"+		Just d -> d  {- .git/annex/journal.private/ is used to journal changes regarding private  - repositories. -}-gitAnnexPrivateJournalDir :: Git.Repo -> RawFilePath-gitAnnexPrivateJournalDir r = -	P.addTrailingPathSeparator $ gitAnnexDir r P.</> "journal-private"+gitAnnexPrivateJournalDir :: BranchState -> Git.Repo -> RawFilePath+gitAnnexPrivateJournalDir st r = P.addTrailingPathSeparator $+	case alternateJournal st of+		Nothing -> gitAnnexDir r P.</> "journal-private"+		Just d -> d  {- Lock file for the journal. -} gitAnnexJournalLock :: Git.Repo -> RawFilePath

@@ -46,7 +46,7 @@  -  - The second parent of the merge commit is the past history of the  - RemoteTrackingBranch as imported from a remote. When importing a- - history of trees from a remote, commits can be sythesized from+ - history of trees from a remote, commits can be synthesized from  - them, but such commits won't have the same sha due to eg date differing.  - But since we know that the second parent consists entirely of such  - import commits, they can be reused when updating the

@@ -1,6 +1,6 @@ {- git-annex special remote configuration  -- - Copyright 2019-2023 Joey Hess <id@joeyh.name>+ - Copyright 2019-2024 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -107,17 +107,23 @@ 		(FieldDesc "name for the special remote") 	, optionalStringParser sameasNameField HiddenField 	, optionalStringParser sameasUUIDField HiddenField-	, optionalStringParser typeField-		(FieldDesc "type of special remote") 	, autoEnableFieldParser 	, costParser costField 		(FieldDesc "default cost of this special remote")+	, optionalStringParser preferreddirField+		(FieldDesc "directory whose content is preferred")+	] ++ essentialFieldParsers++{- Parsers for fields that are common to all special remotes, and are+ - also essential to include in eg, annex:: urls. -}+essentialFieldParsers :: [RemoteConfigFieldParser]+essentialFieldParsers =+	[ optionalStringParser typeField+		(FieldDesc "type of special remote") 	, yesNoParser exportTreeField (Just False) 		(FieldDesc "export trees of files to this remote") 	, yesNoParser importTreeField (Just False) 		(FieldDesc "import trees of files from this remote")-	, optionalStringParser preferreddirField-		(FieldDesc "directory whose content is preferred") 	]  autoEnableFieldParser :: RemoteConfigFieldParser

@@ -407,7 +407,7 @@ {- Enables ssh caching for git push/pull to a particular  - remote git repo. (Can safely be used on non-ssh remotes.)  -- - Also propigates any configured ssh-options.+ - Also propagates any configured ssh-options.  -  - Like inRepo, the action is run with the local git repo.  - But here it's a modified version, with gitEnv to set GIT_SSH=git-annex,

@@ -372,7 +372,7 @@ 				<$> B.readFile tmpfile 			return $ case partitionEithers v of 				((parserr:_), _) -> -					Left $ "yt-dlp json parse errror: " ++ parserr+					Left $ "yt-dlp json parse error: " ++ parserr 				([], r) -> Right r 		else return $ Left $ if null outerr 			then "yt-dlp failed"

@@ -64,7 +64,7 @@  	return $ \dstatus -> dstatus 		{ syncRemotes = syncable-		, syncGitRemotes = filter (Remote.gitSyncableRemoteType . Remote.remotetype) syncable+		, syncGitRemotes = filter Remote.gitSyncableRemote syncable 		, syncDataRemotes = dataremotes 		, exportRemotes = exportremotes 		, downloadRemotes = contentremotes

@@ -1,4 +1,4 @@-{- git-annex assistant sceduled jobs runner+{- git-annex assistant scheduled jobs runner  -  - Copyright 2013 Joey Hess <id@joeyh.name>  -

@@ -102,7 +102,7 @@ 	networkd = "org.freedesktop.network1" 	wicd = "org.wicd.daemon" -{- Listens for systemd-networkd connections and diconnections.+{- Listens for systemd-networkd connections and disconnections.  -  - Connection example (once fully connected):  - [Variant {"OperationalState": Variant "routable"}]@@ -128,7 +128,7 @@ 					else setconnected False 				Nothing -> noop -{- Listens for NetworkManager connections and diconnections.+{- Listens for NetworkManager connections and disconnections.  -  - Connection example (once fully connected):  - [Variant {"ActivatingConnection": Variant (ObjectPath "/"), "PrimaryConnection": Variant (ObjectPath "/org/freedesktop/NetworkManager/ActiveConnection/34"), "State": Variant 70}]

@@ -77,7 +77,7 @@  -  - Creates the destination directory where the upgrade will be installed  - early, in order to check if another upgrade has happened (or is- - happending). On failure, the directory is removed.+ - happening). On failure, the directory is removed.  -} startDistributionDownload :: GitAnnexDistribution -> Assistant () startDistributionDownload d = go =<< liftIO . newVersionLocation d =<< liftIO oldVersionLocation

@@ -0,0 +1,120 @@+{- Backends for git-remote-annex.+ -+ - GITBUNDLE keys store git bundles+ - GITMANIFEST keys store ordered lists of GITBUNDLE keys+ -+ - Copyright 2024 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++{-# LANGUAGE OverloadedStrings #-}++module Backend.GitRemoteAnnex (+	backends,+	genGitBundleKey,+	genManifestKey,+	genBackupManifestKey,+	isGitRemoteAnnexKey,+) where++import Annex.Common+import Types.Key+import Types.Backend+import Utility.Hash+import Utility.Metered+import qualified Backend.Hash as Hash++import qualified Data.ByteString.Short as S+import qualified Data.ByteString.Char8 as B8++backends :: [Backend]+backends = [gitbundle, gitmanifest]++gitbundle :: Backend+gitbundle = Backend+	{ backendVariety = GitBundleKey+	, genKey = Nothing+	-- ^ Not provided because these keys can only be generated by +	-- git-remote-annex.+	, verifyKeyContent = Just $ Hash.checkKeyChecksum sameCheckSum hash+	, verifyKeyContentIncrementally = Just (liftIO . incrementalVerifier)+	, canUpgradeKey = Nothing+	, fastMigrate = Nothing+	, isStableKey = const True+	, isCryptographicallySecure = Hash.cryptographicallySecure hash+	, isCryptographicallySecureKey = const $ pure $+		Hash.cryptographicallySecure hash+	}++gitmanifest :: Backend+gitmanifest = Backend+	{ backendVariety = GitManifestKey+	, genKey = Nothing+	, verifyKeyContent = Nothing+	, verifyKeyContentIncrementally = Nothing+	, canUpgradeKey = Nothing+	, fastMigrate = Nothing+	, isStableKey = const True+	, isCryptographicallySecure = False+	, isCryptographicallySecureKey = const $ pure False+	}++-- git bundle keys use the sha256 hash.+hash :: Hash.Hash+hash = Hash.SHA2Hash (HashSize 256)++incrementalVerifier :: Key -> IO IncrementalVerifier+incrementalVerifier = +	mkIncrementalVerifier sha2_256_context "checksum" . sameCheckSum++sameCheckSum :: Key -> String -> Bool+sameCheckSum key s = s == expected+  where+	-- The checksum comes after a UUID.+	expected = reverse $ takeWhile (/= '-') $ reverse $+		decodeBS $ S.fromShort $ fromKey keyName key++genGitBundleKey :: UUID -> RawFilePath -> MeterUpdate -> Annex Key+genGitBundleKey remoteuuid file meterupdate = do+	filesize <- liftIO $ getFileSize file+	s <- Hash.hashFile hash file meterupdate+	return $ mkKey $ \k -> k+		{ keyName = S.toShort $ fromUUID remoteuuid <> "-" <> encodeBS s+		, keyVariety = GitBundleKey+		, keySize = Just filesize+		}++genManifestKey :: UUID -> Key+genManifestKey = genManifestKey' Nothing++genBackupManifestKey :: UUID -> Key+genBackupManifestKey = genManifestKey' (Just ".bak")++genManifestKey' :: Maybe S.ShortByteString -> UUID -> Key+genManifestKey' extension u = mkKey $ \kd -> kd+	{ keyName = S.toShort (fromUUID u) <> +		fromMaybe mempty extension+	, keyVariety = GitManifestKey+	}++{- Is the key a manifest or bundle key that belongs to the special remote+ - with this uuid? -}+isGitRemoteAnnexKey :: UUID -> Key -> Bool+isGitRemoteAnnexKey u k = +	case fromKey keyVariety k of+		GitBundleKey -> sameuuid $ \b ->+			-- Remove the checksum that comes after the UUID.+			let b' = fst $ B8.spanEnd (/= '-') b+			in B8.take (B8.length b' - 1) b'+		GitManifestKey -> sameuuid $ \b ->+			-- Remove an optional extension after the UUID.+			-- (A UUID never contains '.')+			if '.' `B8.elem` b+				then+					let b' = fst $ B8.spanEnd (/= '.') b+					in B8.take (B8.length b' - 1) b'+				else b+		_ -> False+  where+	sameuuid f = fromUUID u == f (S.fromShort (fromKey keyName k))

@@ -1,6 +1,6 @@ {- git-annex hashing backends  -- - Copyright 2011-2021 Joey Hess <id@joeyh.name>+ - Copyright 2011-2024 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -12,6 +12,10 @@ 	testKeyBackend, 	keyHash, 	descChecksum,+	Hash(..),+	cryptographicallySecure,+	hashFile,+	checkKeyChecksum ) where  import Annex.Common@@ -22,7 +26,6 @@ import Types.KeySource import Utility.Hash import Utility.Metered-import qualified Utility.RawFilePath as R  import qualified Data.ByteString as S import qualified Data.ByteString.Short as S (toShort, fromShort)@@ -78,7 +81,7 @@ genBackend hash = Backend 	{ backendVariety = hashKeyVariety hash (HasExt False) 	, genKey = Just (keyValue hash)-	, verifyKeyContent = Just $ checkKeyChecksum hash+	, verifyKeyContent = Just $ checkKeyChecksum sameCheckSum hash 	, verifyKeyContentIncrementally = Just $ checkKeyChecksumIncremental hash 	, canUpgradeKey = Just needsUpgrade 	, fastMigrate = Just trivialMigrate@@ -123,16 +126,11 @@ 	keyValue hash source meterupdate 		>>= addE source (const $ hashKeyVariety hash (HasExt True)) -checkKeyChecksum :: Hash -> Key -> RawFilePath -> Annex Bool-checkKeyChecksum hash key file = catchIOErrorType HardwareFault hwfault $ do-	fast <- Annex.getRead Annex.fast-	exists <- liftIO $ R.doesPathExist file-	case (exists, fast) of-		(True, False) -> do-			showAction (UnquotedString descChecksum)-			sameCheckSum key -				<$> hashFile hash file nullMeterUpdate-		_ -> return True+checkKeyChecksum :: (Key -> String -> Bool) -> Hash -> Key -> RawFilePath -> Annex Bool+checkKeyChecksum issame hash key file = catchIOErrorType HardwareFault hwfault $ do+	showAction (UnquotedString descChecksum)+	issame key +		<$> hashFile hash file nullMeterUpdate   where 	hwfault e = do 		warning $ UnquotedString $ "hardware fault: " ++ show e

@@ -41,7 +41,7 @@ 						Nothing -> pure False 				anyM check eks 	, verifyKeyContentIncrementally = Just $ \k -> do-		-- Run incremental verifiers for each equivilant key together,+		-- Run incremental verifiers for each equivalent key together, 		-- and see if any of them succeed. 		eks <- equivkeys k 		let get = \ek -> getbackend ek >>= \case@@ -53,7 +53,7 @@ 		return $ IncrementalVerifier 			{ updateIncrementalVerifier = \s -> 				forM_ l $ flip updateIncrementalVerifier s-			-- If there are no equivilant keys recorded somehow,+			-- If there are no equivalent keys recorded somehow, 			-- or if none of them support incremental verification, 			-- this will return Nothing, which indicates that 			-- incremental verification was not able to be@@ -80,9 +80,9 @@ 	-- Not all keys using this backend are necessarily  	-- cryptographically secure. 	, isCryptographicallySecure = False-	-- A key is secure when all recorded equivilant keys are.+	-- A key is secure when all recorded equivalent keys are. 	-- If there are none recorded yet, it's secure because when-	-- downloaded, an equivilant key that is cryptographically secure+	-- downloaded, an equivalent key that is cryptographically secure 	-- will be constructed then. 	, isCryptographicallySecureKey = \k -> 		equivkeys k >>= \case@@ -95,7 +95,7 @@ 	}   where 	equivkeys k = filter allowedequiv <$> getEquivilantKeys k-	-- Don't allow using VURL keys as equivilant keys, because that+	-- Don't allow using VURL keys as equivalent keys, because that 	-- could let a crafted git-annex branch cause an infinite loop. 	allowedequiv ek = fromKey keyVariety ek /= VURLKey 	varietymap = makeVarietyMap regularBackendList

@@ -18,12 +18,14 @@ import qualified Backend.Hash import qualified Backend.WORM import qualified Backend.URL+import qualified Backend.GitRemoteAnnex  {- Regular backends. Does not include externals or VURL. -} regularBackendList :: [Backend] regularBackendList = Backend.Hash.backends  	++ Backend.WORM.backends  	++ Backend.URL.backends+	++ Backend.GitRemoteAnnex.backends  {- The default hashing backend. -} defaultHashBackend :: Backend

@@ -1,5 +1,5 @@ {- Generating and installing a desktop menu entry file and icon,- - and a desktop autostart file. (And OSX equivilants.)+ - and a desktop autostart file. (And OSX equivalents.)  -  - Copyright 2012 Joey Hess <id@joeyh.name>  -

@@ -1,3 +1,23 @@+git-annex (10.20240531) upstream; urgency=medium++  * git-remote-annex: New program which allows pushing a git repo to a+    git-annex special remote, and cloning from a special remote.+    (Based on Michael Hanke's git-remote-datalad-annex.)+  * initremote, enableremote: Added --with-url to enable using+    git-remote-annex.+  * When building an adjusted unlocked branch, make pointer files+    executable when the annex object file is executable.+  * group: Added --list option.+  * fsck: Fix recent reversion that made it say it was checksumming files+    whose content is not present.+  * Avoid the --fast option preventing checksumming in some cases it+    was not supposed to.+  * testremote: Really fsck downloaded objects.+  * Typo fixes.+    Thanks, Yaroslav Halchenko++ -- Joey Hess <id@joeyh.name>  Fri, 31 May 2024 12:32:29 -0400+ git-annex (10.20240430) upstream; urgency=medium    * Bug fix: While redundant concurrent transfers were already@@ -4576,7 +4596,7 @@     --clean-duplicates mode, verify that enough copies of its content still     exist.   * Improve integration with KDE's file manager to work with dolphin-    version 14.12.3 while still being compatable with 4.14.2.+    version 14.12.3 while still being compatible with 4.14.2.     Thanks, silvio.   * assistant: Added --autostop to complement --autostart.   * Work around wget bug #784348 which could cause it to clobber git-annex

@@ -0,0 +1,1201 @@+{- git-remote-annex program+ -+ - Copyright 2024 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++{-# LANGUAGE OverloadedStrings #-}++module CmdLine.GitRemoteAnnex where++import Annex.Common+import Types.GitRemoteAnnex+import qualified Annex+import qualified Remote+import qualified Git+import qualified Git.CurrentRepo+import qualified Git.Ref+import qualified Git.Branch+import qualified Git.Bundle+import qualified Git.Remote+import qualified Git.Remote.Remove+import qualified Git.Version+import qualified Annex.SpecialRemote as SpecialRemote+import qualified Annex.Branch+import qualified Annex.BranchState+import qualified Annex.Url as Url+import qualified Types.Remote as Remote+import qualified Logs.Remote+import qualified Remote.External+import Remote.Helper.Encryptable (parseEncryptionMethod)+import Annex.Transfer+import Backend.GitRemoteAnnex+import Config+import Types.Key+import Types.RemoteConfig+import Types.ProposedAccepted+import Types.Export+import Types.GitConfig+import Types.BranchState+import Types.Difference+import Types.Crypto+import Git.Types+import Logs.File+import Logs.Difference+import Annex.Init+import Annex.UUID+import Annex.Content+import Annex.Perms+import Annex.SpecialRemote.Config+import Remote.List+import Remote.List.Util+import Utility.Tmp+import Utility.Tmp.Dir+import Utility.Env+import Utility.Metered+import Utility.FileMode++import Network.URI+import Data.Either+import Data.Char+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8+import qualified Data.Map.Strict as M+import qualified System.FilePath.ByteString as P+import qualified Utility.RawFilePath as R+import qualified Data.Set as S++run :: [String] -> IO ()+run (remotename:url:[]) = do+	repo <- getRepo+	state <- Annex.new repo+	Annex.eval state $+		resolveSpecialRemoteWebUrl url >>= \case+			-- git strips the "annex::" prefix of the url+			-- when running this command, so add it back+			Nothing -> parseurl ("annex::" ++ url) pure+			Just url' -> parseurl url' checkAllowedFromSpecialRemoteWebUrl+  where+	parseurl u checkallowed =+		case parseSpecialRemoteNameUrl remotename u of+			Right src -> checkallowed src >>= run' u+			Left e -> giveup e+run (_remotename:[]) = giveup "remote url not configured"+run _ = giveup "expected remote name and url parameters"++run' :: String -> SpecialRemoteConfig -> Annex ()+run' url src = do+	sab <- startAnnexBranch+	whenM (Annex.getRead Annex.debugenabled) $+		enableDebugOutput+	-- Prevent any usual git-annex output to stdout, because+	-- the output of this command is being parsed by git.+	doQuietAction $+		withSpecialRemote src sab $ \rmt -> do+			reportFullUrl url rmt+			ls <- lines <$> liftIO getContents+			go rmt ls emptyState+  where+	go rmt (l:ls) st =+		let (c, v) = splitLine l+		in case c of+			"capabilities" -> capabilities >> go rmt ls st+			"list" -> case v of+				"" -> list st rmt False >>= go rmt ls+				"for-push" -> list st rmt True >>= go rmt ls+				_ -> protocolError l+			"fetch" -> fetch st rmt (l:ls)+				>>= \ls' -> go rmt ls' st+			"push" -> push st rmt (l:ls)+				>>= \(ls', st') -> go rmt ls' st'+			"" -> return ()+			_ -> protocolError l+	go _ [] _ = return ()++data State = State+	{ manifestCache :: Maybe Manifest+	, trackingRefs :: M.Map Ref Sha+	}++emptyState :: State+emptyState = State+	{ manifestCache = Nothing+	, trackingRefs = mempty+	}++protocolError :: String -> a+protocolError l = giveup $ "gitremote-helpers protocol error at " ++ show l++capabilities :: Annex ()+capabilities = do+	liftIO $ putStrLn "fetch"+	liftIO $ putStrLn "push"+	liftIO $ putStrLn ""+	liftIO $ hFlush stdout++list :: State -> Remote -> Bool -> Annex State+list st rmt forpush = do+	manifest <- if forpush+		then downloadManifestWhenPresent rmt+		else downloadManifestOrFail rmt+	l <- forM (inManifest manifest) $ \k -> do+		b <- downloadGitBundle rmt k+		heads <- inRepo $ Git.Bundle.listHeads b	+		-- Get all the objects from the bundle. This is done here+		-- so that the tracking refs can be updated with what is+		-- listed, and so what when a full repush is done, all+		-- objects are available to be pushed.+		when forpush $+			inRepo $ Git.Bundle.unbundle b+		-- The bundle may contain tracking refs, or regular refs,+		-- make sure we're operating on regular refs.+		return $ map (\(s, r) -> (fromTrackingRef rmt r, s)) heads+	+	-- Later refs replace earlier refs with the same name.+	let refmap = M.fromList $ concat l+	let reflist = M.toList refmap+	let trackingrefmap = M.mapKeys (toTrackingRef rmt) refmap++	-- When listing for a push, update the tracking refs to match what+	-- was listed. This is necessary in order for a full repush to know+	-- what to push.+	when forpush $+		updateTrackingRefs True rmt trackingrefmap++	-- Respond to git with a list of refs.+	liftIO $ do+		forM_ reflist $ \(ref, sha) ->+			B8.putStrLn $ fromRef' sha <> " " <> fromRef' ref+		-- Newline terminates list of refs.+		putStrLn ""+		hFlush stdout++	-- Remember the tracking refs and manifest.+	return $ st+		{ manifestCache = Just manifest+		, trackingRefs = trackingrefmap+		}++-- Any number of fetch commands can be sent by git, asking for specific+-- things. We fetch everything new at once, so find the end of the fetch+-- commands (which is supposed to be a blank line) before fetching. +fetch :: State -> Remote -> [String] -> Annex [String]+fetch st rmt (l:ls) = case splitLine l of+	("fetch", _) -> fetch st rmt ls+	("", _) -> do+		fetch' st rmt+		return ls+	_ -> do+		fetch' st rmt+		return (l:ls)+fetch st rmt [] = do+	fetch' st rmt+	return []++fetch' :: State -> Remote -> Annex ()+fetch' st rmt = do+	manifest <- maybe (downloadManifestOrFail rmt) pure (manifestCache st)+	forM_ (inManifest manifest) $ \k ->+		downloadGitBundle rmt k >>= inRepo . Git.Bundle.unbundle+	-- Newline indicates end of fetch.+	liftIO $ do+		putStrLn ""+		hFlush stdout++-- Note that the git bundles that are generated to push contain +-- tracking refs, rather than the actual refs that the user requested to+-- push. This is done because git bundle does not allow creating a bundle+-- that contains refs with different names than the ones in the git+-- repository. Consider eg, git push remote foo:bar, where the destination+-- ref is bar, but there may be no bar ref locally, or the bar ref may+-- be different than foo. If git bundle supported GIT_NAMESPACE, it would+-- be possible to generate a bundle that contains the specified refs.+push :: State -> Remote -> [String] -> Annex ([String], State)+push st rmt ls = do+	let (refspecs, ls') = collectRefSpecs ls+	(responses, trackingrefs) <- calc refspecs ([], trackingRefs st)+	updateTrackingRefs False rmt trackingrefs+	(ok, st') <- if M.null trackingrefs+		then pushEmpty st rmt+		else if any forcedPush refspecs+			then fullPush st rmt (M.keys trackingrefs)+			else incrementalPush st rmt+				(trackingRefs st) trackingrefs+	if ok+		then do+			sendresponses responses+			return (ls', st' { trackingRefs = trackingrefs })+		else do+			-- Restore the old tracking refs +			updateTrackingRefs True rmt (trackingRefs st)+			sendresponses $+				map (const "error push failed") refspecs+			return (ls', st')+  where+	calc+		:: [RefSpec]+		-> ([B.ByteString], M.Map Ref Sha)+		-> Annex ([B.ByteString], M.Map Ref Sha)+	calc [] (responses, trackingrefs) = +		return (reverse responses, trackingrefs)+	calc (r:rs) (responses, trackingrefs) =+		let tr = toTrackingRef rmt (dstRef r)+		    okresp m = pure +		    	( ("ok " <> fromRef' (dstRef r)):responses+			, m+			)+		    errresp msg = pure+		    	( ("error " <> fromRef' (dstRef r) <> " " <> msg):responses+			, trackingrefs+			)+		in calc rs =<< case srcRef r of+			Just srcref -> inRepo (Git.Ref.sha srcref) >>= \case+				Just sha+					| forcedPush r -> okresp $+						M.insert tr sha trackingrefs+					| otherwise -> ifM (isfastforward sha tr)+						( okresp $+							M.insert tr sha trackingrefs+						, errresp "non-fast-forward"+						)+				Nothing -> errresp "unknown ref"+			Nothing -> okresp $ M.delete tr trackingrefs+	+	-- Check if the push is a fast-forward that will not overwrite work+	-- in the ref currently stored in the remote. This seems redundant+	-- to git's own checking for non-fast-forwards. But unfortunately,+	-- before git push checks that, it actually tells us to push.+	-- That seems likely to be a bug in git, and this is a workaround.+	isfastforward newref tr = case M.lookup tr (trackingRefs st) of+		Just prevsha -> inRepo $ Git.Ref.isAncestor prevsha newref+		Nothing -> pure True+	+	-- Send responses followed by newline to indicate end of push.+	sendresponses responses = liftIO $ do+		mapM_ B8.putStrLn responses+		putStrLn ""+		hFlush stdout++-- Full push of the specified refs to the remote.+fullPush :: State -> Remote -> [Ref] -> Annex (Bool, State)+fullPush st rmt refs = guardPush st $ do+	oldmanifest <- maybe (downloadManifestWhenPresent rmt) pure+		(manifestCache st)+	fullPush' oldmanifest st rmt refs++fullPush' :: Manifest -> State -> Remote -> [Ref] -> Annex (Bool, State)+fullPush' oldmanifest st rmt refs = do+	let bs = map Git.Bundle.fullBundleSpec refs+	(bundlekey, uploadbundle) <- generateGitBundle rmt bs oldmanifest+	let manifest = mkManifest [bundlekey] $+		S.fromList (inManifest oldmanifest)+			`S.union`+		outManifest oldmanifest+	manifest' <- startPush rmt manifest+	uploadbundle+	uploadManifest rmt manifest'+	return (True, st { manifestCache = Nothing })++guardPush :: State -> Annex (Bool, State) -> Annex (Bool, State)+guardPush st a = catchNonAsync a $ \ex -> do+	liftIO $ hPutStrLn stderr $+		"Push failed (" ++ show ex ++ ")"+	return (False, st { manifestCache = Nothing })++-- Incremental push of only the refs that changed.+--+-- No refs were deleted (that causes a fullPush), but new refs may+-- have been added.+incrementalPush :: State -> Remote -> M.Map Ref Sha -> M.Map Ref Sha -> Annex (Bool, State)+incrementalPush st rmt oldtrackingrefs newtrackingrefs = guardPush st $ do+	oldmanifest <- maybe (downloadManifestWhenPresent rmt) pure (manifestCache st)+	if length (inManifest oldmanifest) + 1 > remoteAnnexMaxGitBundles (Remote.gitconfig rmt)+		then fullPush' oldmanifest st rmt (M.keys newtrackingrefs)+		else go oldmanifest+  where+	go oldmanifest = do+		bs <- calc [] (M.toList newtrackingrefs)+		(bundlekey, uploadbundle) <- generateGitBundle rmt bs oldmanifest+		let manifest = oldmanifest <> mkManifest [bundlekey] mempty+		manifest' <- startPush rmt manifest+		uploadbundle+		uploadManifest rmt manifest'+		return (True, st { manifestCache = Nothing })+	+	calc c [] = return (reverse c)+	calc c ((ref, sha):refs) = case M.lookup ref oldtrackingrefs of+		Just oldsha+			| oldsha == sha -> calc c refs -- unchanged+			| otherwise ->+				ifM (inRepo $ Git.Ref.isAncestor oldsha ref)+					( use $ checkprereq oldsha ref+					, use $ findotherprereq ref sha+					)+		Nothing -> use $ findotherprereq ref sha+	  where+		use a = do+			bs <- a+			calc (bs:c) refs+	+	-- Unfortunately, git bundle will let a prerequisite specified+	-- for one ref prevent it including another ref. For example,+	-- where x is a ref that points at A, and y is a ref that points at+	-- B (which has A as its parent), git bundle x A..y+	-- will omit including the x ref in the bundle at all.+	--+	-- But we need to include all (changed) refs that the user+	-- specified to push in the bundle. So, only include the sha+	-- as a prerequisite when it will not prevent including another+	-- changed ref in the bundle.+	checkprereq prereq ref =+		ifM (anyM shadows $ M.elems $ M.delete ref changedrefs)+			( pure $ Git.Bundle.fullBundleSpec ref+			, pure $ Git.Bundle.BundleSpec+				{ Git.Bundle.preRequisiteRef = Just prereq+				, Git.Bundle.includeRef = ref+				}+			)+	  where+		shadows s+			| s == prereq = pure True+			| otherwise = inRepo $ Git.Ref.isAncestor s prereq+		changedrefs = M.differenceWith+			(\a b -> if a == b then Nothing else Just a)+			newtrackingrefs oldtrackingrefs+	+	-- When the old tracking ref is not able to be used as a+	-- prerequisite, this to find some other ref that was previously+	-- pushed that can be used as a prerequisite instead. This can+	-- optimise the bundle size a bit in edge cases.+	--+	-- For example, a forced push of branch foo that resets it back+	-- several commits can use a previously pushed bar as a prerequisite+	-- if it's an ancestor of foo.+	findotherprereq ref sha = +		findotherprereq' ref sha (M.elems oldtrackingrefs)+	findotherprereq' ref _ [] = pure (Git.Bundle.fullBundleSpec ref)+	findotherprereq' ref sha (l:ls)+		| l == sha = findotherprereq' ref sha ls+		| otherwise = ifM (inRepo $ Git.Ref.isAncestor l ref)+			( checkprereq l ref	+			, findotherprereq' ref sha ls+			)++pushEmpty :: State -> Remote -> Annex (Bool, State)+pushEmpty st rmt = guardPush st $ do+	oldmanifest <- maybe (downloadManifestWhenPresent rmt) pure+		(manifestCache st)+	let manifest = mkManifest mempty $+		S.fromList (inManifest oldmanifest)+			`S.union`+		outManifest oldmanifest+	(manifest', manifestwriter) <- startPush' rmt manifest+	manifest'' <- dropOldKeys rmt manifest'+	manifestwriter manifest''+	uploadManifest rmt manifest''+	return (True, st { manifestCache = Nothing })++data RefSpec = RefSpec+	{ forcedPush :: Bool+	, srcRef :: Maybe Ref -- ^ Nothing when deleting a ref+	, dstRef :: Ref+	}+	deriving (Show)++-- Any number of push commands can be sent by git, specifying the refspecs+-- to push. They should be followed by a blank line.+collectRefSpecs :: [String] -> ([RefSpec], [String])+collectRefSpecs = go []+  where+	go c (l:ls) = case splitLine l of+		("push", refspec) -> go (parseRefSpec refspec:c) ls+		("", _) -> (c, ls)+		_ -> (c, (l:ls))+	go c [] = (c, [])++parseRefSpec :: String -> RefSpec+parseRefSpec ('+':s) = (parseRefSpec s) { forcedPush = True }+parseRefSpec s = +	let (src, cdst) = break (== ':') s+	    dst = if null cdst then cdst else drop 1 cdst+	    deletesrc = null src+	in RefSpec+		-- To delete a ref, have to do a force push of all+		-- remaining refs.+		{ forcedPush = deletesrc+		, srcRef = if deletesrc+			then Nothing+			else Just (Ref (encodeBS src))+		, dstRef = Ref (encodeBS dst)+		}++-- "foo bar" to ("foo", "bar")+-- "foo" to ("foo", "")+splitLine :: String -> (String, String)+splitLine l = +	let (c, sv) = break (== ' ') l+	    v = if null sv then sv else drop 1 sv+	in (c, v)++data SpecialRemoteConfig+	= SpecialRemoteConfig+		{ specialRemoteUUID :: UUID+		, specialRemoteConfig :: RemoteConfig+		, specialRemoteName :: Maybe RemoteName+		, specialRemoteUrl :: String+		}+	| ExistingSpecialRemote RemoteName+	deriving (Show)++-- The url for a special remote looks like+-- "annex::uuid?param=value&param=value..."+--+-- Also accept an url of "annex::", when a remote name is provided,+-- to use an already enabled special remote.+parseSpecialRemoteNameUrl :: String -> String -> Either String SpecialRemoteConfig+parseSpecialRemoteNameUrl remotename url+	| url == "annex::" && remotename /= url = Right $+		ExistingSpecialRemote remotename+	| "annex::" `isPrefixOf` remotename = parseSpecialRemoteUrl url Nothing+	| otherwise = parseSpecialRemoteUrl url (Just remotename)++parseSpecialRemoteUrl :: String -> Maybe RemoteName -> Either String SpecialRemoteConfig+parseSpecialRemoteUrl url remotename = case parseURI url of+	Nothing -> Left "URL parse failed"+	Just u -> case uriScheme u of+		"annex:" -> case uriPath u of+			"" -> Left "annex: URL did not include a UUID"+			(':':p)+				| null p -> Left "annex: URL did not include a UUID"+				| otherwise -> Right $ SpecialRemoteConfig+					{ specialRemoteUUID = toUUID p+					, specialRemoteConfig = parsequery u+					, specialRemoteName = remotename+					, specialRemoteUrl = url+				}+			_ -> Left "annex: URL malformed"+		_ -> Left "Not an annex: URL"+  where+	parsequery u = M.fromList $ +		map parsekv $ splitc '&' (drop 1 (uriQuery u))+	parsekv kv =+		let (k, sv) = break (== '=') kv+		    v = if null sv then sv else drop 1 sv+		in (Proposed (unEscapeString k), Proposed (unEscapeString v))++-- Handles an url that contains a http address, by downloading+-- the web page and using it as the full annex:: url.+-- The passed url has already had "annex::" stripped off.+resolveSpecialRemoteWebUrl :: String -> Annex (Maybe String)+resolveSpecialRemoteWebUrl url+	| "http://" `isPrefixOf` lcurl || "https://" `isPrefixOf` lcurl =+		Url.withUrlOptionsPromptingCreds $ \uo ->+			withTmpFile "git-remote-annex" $ \tmp h -> do+				liftIO $ hClose h+				Url.download' nullMeterUpdate Nothing url tmp uo >>= \case+					Left err -> giveup $ url ++ " " ++ err+					Right () -> liftIO $+						(headMaybe . lines)+							<$> readFileStrict tmp+	| otherwise = return Nothing+  where+	lcurl = map toLower url++-- Only some types of special remotes are allowed to come from+-- resolveSpecialRemoteWebUrl. Throws an error if this one is not.+checkAllowedFromSpecialRemoteWebUrl :: SpecialRemoteConfig -> Annex SpecialRemoteConfig+checkAllowedFromSpecialRemoteWebUrl src@(ExistingSpecialRemote {}) = pure src+checkAllowedFromSpecialRemoteWebUrl src@(SpecialRemoteConfig {}) =+	case M.lookup typeField (specialRemoteConfig src) of+		Nothing -> giveup "Web URL did not include a type field."+		Just t+			| t == Proposed "httpalso" -> return src+			| otherwise -> giveup "Web URL can only be used for a httpalso special remote."++getSpecialRemoteUrl :: Remote -> Annex (Maybe String)+getSpecialRemoteUrl rmt = do+	rcp <- Remote.configParser (Remote.remotetype rmt)+		(unparsedRemoteConfig (Remote.config rmt))+	return $ genSpecialRemoteUrl rmt rcp++genSpecialRemoteUrl :: Remote -> RemoteConfigParser -> Maybe String+genSpecialRemoteUrl rmt rcp+	-- Fields that are accepted by remoteConfigRestPassthrough+	-- are not necessary to include in the url, except perhaps for+	-- external special remotes. If an external special remote sets+	-- some such fields, cannot generate an url.+	| Remote.typename (Remote.remotetype rmt) == Remote.typename Remote.External.remote+		&& any (`notElem` knownfields) (M.keys c) = Nothing+	| otherwise = Just $ +		"annex::" ++ fromUUID (Remote.uuid rmt) ++ "?" +++			intercalate "&" (map configpair cs)+  where+	configpair (k, v) = conv k ++ "=" ++ conv v+	conv = escapeURIString isUnescapedInURIComponent+		. fromProposedAccepted+	+	cs = M.toList (M.filterWithKey (\k _ -> k `elem` safefields) c)+		++ case remoteAnnexConfigUUID (Remote.gitconfig rmt) of+			Nothing -> []+			Just cu -> [(Accepted "config-uuid", Accepted (fromUUID cu))]++	c = unparsedRemoteConfig $ Remote.config rmt+	+	-- Hidden fields are used for internal stuff like ciphers+	-- that should not be included in the url.+	safefields = map parserForField $ +		filter (\p -> fieldDesc p /= HiddenField) ps++	knownfields = map parserForField ps++	ps = SpecialRemote.essentialFieldParsers+		++ remoteConfigFieldParsers rcp++reportFullUrl :: String -> Remote -> Annex ()+reportFullUrl url rmt = +	when (url == "annex::") $+		getSpecialRemoteUrl rmt >>= \case+			Nothing -> noop+			Just fullurl -> +				liftIO $ hPutStrLn stderr $ +					"Full remote url: " ++ fullurl++-- Runs an action with a Remote as specified by the SpecialRemoteConfig.+withSpecialRemote :: SpecialRemoteConfig -> StartAnnexBranch -> (Remote -> Annex a) -> Annex a+withSpecialRemote (ExistingSpecialRemote remotename) sab a =+	getEnabledSpecialRemoteByName remotename >>=+		maybe (giveup $ "There is no special remote named " ++ remotename)+		(specialRemoteFromUrl sab . a)+withSpecialRemote cfg@(SpecialRemoteConfig {}) sab a = case specialRemoteName cfg of+	-- The name could be the name of an existing special remote,+	-- if so use it as long as its UUID matches the UUID from the url.+	Just remotename -> getEnabledSpecialRemoteByName remotename >>= \case+		Just rmt+			| Remote.uuid rmt == specialRemoteUUID cfg -> +				specialRemoteFromUrl sab (a rmt)+			| otherwise -> giveup $ "The uuid in the annex:: url does not match the uuid of the remote named " ++ remotename+		-- When cloning from an annex:: url,+		-- this is used to set up the origin remote.+		Nothing -> specialRemoteFromUrl sab +			(initremote remotename >>= a)+	Nothing -> specialRemoteFromUrl sab inittempremote+  where+	-- Initialize a new special remote with the provided configuration+	-- and name.+	initremote remotename = do+		let c = M.insert SpecialRemote.nameField (Proposed remotename) $+			M.delete (Accepted "config-uuid") $+			specialRemoteConfig cfg+		t <- either giveup return (SpecialRemote.findType c)+		dummycfg <- liftIO dummyRemoteGitConfig+		(c', u) <- Remote.setup t Remote.Init (Just (specialRemoteUUID cfg)) +			Nothing c dummycfg+			`onException` cleanupremote remotename+		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)+				-- 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'+			Nothing -> noop+		remotesChanged+		getEnabledSpecialRemoteByName remotename >>= \case+			Just rmt -> return rmt+			Nothing -> do+				cleanupremote remotename+				giveup "Unable to find special remote after setup."++	-- Temporarily initialize a special remote, and remove it after+	-- the action is run.+	inittempremote = +		let remotename = Git.Remote.makeLegalName $+			"annex-temp-" ++ fromUUID (specialRemoteUUID cfg)+		in bracket+			(initremote remotename)+			(const $ cleanupremote remotename)+			a+	+	cleanupremote remotename = do+		l <- inRepo Git.Remote.listRemotes+		when (remotename `elem` l) $+			inRepo $ Git.Remote.Remove.remove remotename++-- When a special remote has already been enabled, just use it.+getEnabledSpecialRemoteByName :: RemoteName -> Annex (Maybe Remote)+getEnabledSpecialRemoteByName remotename = +	Remote.byNameOnly remotename >>= \case+		Nothing -> return Nothing+		Just rmt+			-- If the git-annex branch is missing or does not+			-- have a remote config for this remote, but the+			-- git config has the remote, it can't be used.+			| unparsedRemoteConfig (Remote.config rmt) == mempty ->+				return Nothing+			| otherwise -> +				maybe (Just <$> importTreeWorkAround rmt) giveup+					(checkSpecialRemoteProblems rmt)++checkSpecialRemoteProblems :: Remote -> Maybe String+checkSpecialRemoteProblems rmt+	-- Avoid using special remotes that are thirdparty populated, +	-- because there is no way to push the git repository keys into one.+	| Remote.thirdPartyPopulated (Remote.remotetype rmt) =+		Just $ "Cannot use this thirdparty-populated special"+			++ " remote as a git remote."+	| parseEncryptionMethod (unparsedRemoteConfig (Remote.config rmt)) /= Right NoneEncryption+		&& not (remoteAnnexAllowEncryptedGitRepo (Remote.gitconfig rmt)) =+			Just $ "Using an encrypted special remote as a git"+				++ " remote makes it impossible to clone"+				++ " from it. If you will never need to"+				++ " clone from this remote, set: git config "+				++ decodeBS allowencryptedgitrepo ++ " true"+	| otherwise = Nothing+  where+	ConfigKey allowencryptedgitrepo = remoteAnnexConfig rmt "allow-encrypted-gitrepo"++-- Using importTree remotes needs the content identifier database to be+-- populated, but it is not when cloning, and cannot be updated when+-- pushing since git-annex branch updates by this program are prevented.+--+-- So, generate instead a version of the remote that uses exportTree actions,+-- which do not need content identifiers. Since Remote.Helper.exportImport+-- replaces the exportActions in exportActionsForImport with ones that use+-- import actions, have to instantiate a new remote with a modified config.+importTreeWorkAround :: Remote -> Annex Remote+importTreeWorkAround rmt+	| not (importTree (Remote.config rmt)) = pure rmt+	| not (exportTree (Remote.config rmt)) = giveup "Using special remotes with importtree=yes but without exporttree=yes as git remotes is not supported."+	| otherwise = do+		m <- Logs.Remote.remoteConfigMap+		r <- Remote.getRepo rmt+		remoteGen' adjustconfig m (Remote.remotetype rmt) r >>= \case+			Just rmt' -> return rmt'+			Nothing -> giveup "Failed to use importtree=yes remote."+  where+	adjustconfig = M.delete importTreeField++-- Downloads the Manifest when present in the remote. When not present,+-- returns an empty Manifest.+downloadManifestWhenPresent :: Remote -> Annex Manifest+downloadManifestWhenPresent rmt = fromMaybe mempty <$> downloadManifest rmt++-- Downloads the Manifest, or fails if the remote does not contain it.+downloadManifestOrFail :: Remote -> Annex Manifest+downloadManifestOrFail rmt =+	maybe (giveup "No git repository found in this remote.") return+		=<< downloadManifest rmt++-- Downloads the Manifest or Nothing if the remote does not contain a+-- manifest.+--+-- Throws errors if the remote cannot be accessed or the download fails,+-- or if the manifest file cannot be parsed.+downloadManifest :: Remote -> Annex (Maybe Manifest)+downloadManifest rmt = get mkmain >>= maybe (get mkbak) (pure . Just)+  where+	mkmain = genManifestKey (Remote.uuid rmt)+	mkbak = genBackupManifestKey (Remote.uuid rmt)++	get mk = getKeyExportLocations rmt mk >>= \case+		Nothing -> ifM (Remote.checkPresent rmt mk)+			( gettotmp $ \tmp ->+				Remote.retrieveKeyFile rmt mk+					(AssociatedFile Nothing) tmp+					nullMeterUpdate Remote.NoVerify+			, return Nothing+			)+		Just locs -> getexport mk locs++	-- Downloads to a temporary file, rather than using eg+	-- Annex.Transfer.download that would put it in the object+	-- directory. The content of manifests is not stable, and so+	-- it needs to re-download it fresh every time, and the object+	-- file should not be stored locally.+	gettotmp dl = withTmpFile "GITMANIFEST" $ \tmp tmph -> do+		liftIO $ hClose tmph+		_ <- dl tmp+		b <- liftIO (B.readFile tmp)+		case parseManifest b of+			Right m -> Just <$> verifyManifest rmt m+			Left err -> giveup err++	getexport _ [] = return Nothing+	getexport mk (loc:locs) =+		ifM (Remote.checkPresentExport (Remote.exportActions rmt) mk loc)+			( gettotmp $ \tmp -> +				Remote.retrieveExport (Remote.exportActions rmt)+					mk loc tmp nullMeterUpdate+			, getexport mk locs+			)++-- Uploads the Manifest to the remote.+--+-- Throws errors if the remote cannot be accessed or the upload fails.+--+-- The manifest key is first dropped from the remote, then the new+-- content is uploaded. This is necessary because the same key is used,+-- and behavior of remotes is undefined when sending a key that is+-- already present on the remote, but with different content.+--+-- So this may be interrupted and leave the manifest key not present.+-- To deal with that, there is a backup manifest key. This takes care+-- to ensure that one of the two keys will always exist.+uploadManifest :: Remote -> Manifest -> Annex ()+uploadManifest rmt manifest = do+	ok <- ifM (Remote.checkPresent rmt mkbak)+		( dropandput mkmain <&&> dropandput mkbak+		-- The backup manifest doesn't exist, so upload+		-- it first, and then the manifest second.+		-- This ensures that at no point are both deleted.+		, put mkbak <&&> dropandput mkmain+		)+	unless ok+		uploadfailed+  where+	mkmain = genManifestKey (Remote.uuid rmt)+	mkbak = genBackupManifestKey (Remote.uuid rmt)+	+	uploadfailed = giveup "Failed to upload manifest."++	dropandput mk = do+		dropKey' rmt mk+		put mk++	put mk = withTmpFile "GITMANIFEST" $ \tmp tmph -> do+		liftIO $ B8.hPut tmph (formatManifest manifest)+		liftIO $ hClose tmph+		-- Uploading needs the key to be in the annex objects+		-- directory, so put the manifest file there temporarily.+		-- Using linkOrCopy rather than moveAnnex to avoid updating+		-- InodeCache database. Also, works even when the repository+		-- is configured to require only cryptographically secure+		-- keys, which it is not.+		objfile <- calcRepo (gitAnnexLocation mk)+		modifyContentDir objfile $+			linkOrCopy mk (toRawFilePath tmp) objfile Nothing >>= \case+				-- Important to set the right perms even+				-- though the object is only present+				-- briefly, since sending objects may rely+				-- on or even copy file perms.+				Just _ -> do+					liftIO $ R.setFileMode objfile+						=<< defaultFileMode+					freezeContent objfile+				Nothing -> uploadfailed+		ok <- (uploadGitObject rmt mk >> pure True)+			`catchNonAsync` (const (pure False))+		-- Don't leave the manifest key in the annex objects+		-- directory.+		unlinkAnnex mk+		return ok++formatManifest :: Manifest -> B.ByteString+formatManifest manifest =+	B8.unlines $ +		map serializeKey' (inManifest manifest)+			<>+		map (\k -> "-" <> serializeKey' k)+			(S.toList (outManifest manifest))++parseManifest :: B.ByteString -> Either String Manifest+parseManifest b = +	let (outks, inks) = partitionEithers $ map parseline $ B8.lines b+	in case (checkvalid [] inks, checkvalid [] outks) of+		(Right inks', Right outks') -> +			Right $ mkManifest inks' (S.fromList outks')+		(Left err, _) -> Left err+		(_, Left err) -> Left err+  where+	parseline l+		| "-" `B.isPrefixOf` l = +			Left $ deserializeKey' $ B.drop 1 l+		| otherwise =+			Right $ deserializeKey' l+	+	checkvalid c [] = Right (reverse c)+	checkvalid c (Just k:ks) = case fromKey keyVariety k of+		GitBundleKey -> checkvalid (k:c) ks+		_ -> Left $ "Wrong type of key in manifest " ++ serializeKey k+	checkvalid _ (Nothing:_) =+		Left "Error parsing manifest"++{- A manifest file is cached here before it or the bundles listed in it+ - is uploaded to the special remote.+ - + - This prevents forgetting which bundles were uploaded when a push gets+ - interrupted before updating the manifest on the remote, or when a race+ - causes the uploaded manigest to be overwritten.+ -}+lastPushedManifestFile :: UUID -> Git.Repo -> RawFilePath+lastPushedManifestFile u r = gitAnnexDir r P.</> "git-remote-annex" +	P.</> fromUUID u P.</> "manifest"++{- Call before uploading anything. The returned manifest has added+ - to it any bundle keys that were in the lastPushedManifestFile+ - and that are not in the new manifest. -}+startPush :: Remote -> Manifest -> Annex Manifest+startPush rmt manifest = do+	(manifest', writer) <- startPush' rmt manifest+	writer manifest'+	return manifest'++startPush' :: Remote -> Manifest -> Annex (Manifest, Manifest -> Annex ())+startPush' rmt manifest = do+	f <- fromRepo (lastPushedManifestFile (Remote.uuid rmt))+	oldmanifest <- liftIO $ +		fromRight mempty . parseManifest+			<$> B.readFile (fromRawFilePath f)+				`catchNonAsync` (const (pure mempty))+	let oldmanifest' = mkManifest [] $+		S.fromList (inManifest oldmanifest)+			`S.union`+		outManifest oldmanifest+	let manifest' = manifest <> oldmanifest'+	let writer = writeLogFile f . decodeBS . formatManifest+	return (manifest', writer)++-- Drops the outManifest keys. Returns a version of the manifest with+-- any outManifest keys that were successfully dropped removed from it.+--+-- If interrupted at this stage, or if a drop fails, the key remains+-- in the outManifest, so the drop will be tried again later.+dropOldKeys :: Remote -> Manifest -> Annex Manifest+dropOldKeys rmt manifest =+	mkManifest (inManifest manifest) . S.fromList+		<$> filterM (not <$$> dropKey rmt)+			(S.toList (outManifest manifest))++-- When pushEmpty raced with another push, it could result in the manifest+-- listing bundles that it deleted. Such a manifest has to be treated the+-- same as an empty manifest. To detect that, this checks that all the+-- bundles listed in the manifest still exist on the remote.+verifyManifest :: Remote -> Manifest -> Annex Manifest+verifyManifest rmt manifest = +	ifM (allM (checkPresentGitBundle rmt) (inManifest manifest))+		( return manifest+		, return $ mkManifest [] $+			S.fromList (inManifest manifest)+				`S.union`+			outManifest manifest+		)++-- Downloads a git bundle to the annex objects directory, unless+-- the object file is already present. Returns the filename of the object+-- file.+--+-- Throws errors if the download fails, or the checksum does not verify.+--+-- This does not update the location log to indicate that the local+-- repository contains the git bundle object. Reasons not to include:+-- 1. When this is being used in a git clone, the repository will not have+--    a UUID yet.+-- 2. It would unncessarily bloat the git-annex branch, which would then+--    lead to more things needing to be pushed to the special remote,+--    and so more things pulled from it, etc.+-- 3. Git bundle objects are not usually transferred between repositories+--    except special remotes (although the user can if they want to).+downloadGitBundle :: Remote -> Key -> Annex FilePath+downloadGitBundle rmt k = getKeyExportLocations rmt k >>= \case+	Nothing -> dlwith $ +		download rmt k (AssociatedFile Nothing) stdRetry noNotification+	Just locs -> dlwith $+		anyM getexport locs+  where+	dlwith a = ifM a+		( decodeBS <$> calcRepo (gitAnnexLocation k)+		, giveup $ "Failed to download " ++ serializeKey k+		)++	getexport loc = catchNonAsync (getexport' loc) (const (pure False))+	getexport' loc =+		getViaTmp rsp vc k (AssociatedFile Nothing) Nothing $ \tmp -> do+			v <- Remote.retrieveExport (Remote.exportActions rmt)+				k loc (decodeBS tmp) nullMeterUpdate+			return (True, v)+	rsp = Remote.retrievalSecurityPolicy rmt+	vc = Remote.RemoteVerify rmt++-- Checks if a bundle is present. Throws errors if the remote cannot be+-- accessed.+checkPresentGitBundle :: Remote -> Key -> Annex Bool+checkPresentGitBundle rmt k = +	getKeyExportLocations rmt k >>= \case+		Nothing -> Remote.checkPresent rmt k+		Just locs -> anyM checkexport locs+  where+	checkexport = Remote.checkPresentExport (Remote.exportActions rmt) k++-- Uploads a bundle or manifest object from the annex objects directory+-- to the remote.+--+-- Throws errors if the upload fails.+--+-- This does not update the location log to indicate that the remote+-- contains the git object.+uploadGitObject :: Remote -> Key -> Annex ()+uploadGitObject rmt k = getKeyExportLocations rmt k >>= \case+	Just (loc:_) -> do+		objfile <- fromRawFilePath <$> calcRepo (gitAnnexLocation k)+		Remote.storeExport (Remote.exportActions rmt) objfile k loc nullMeterUpdate+	_ -> +		unlessM (upload rmt k (AssociatedFile Nothing) retry noNotification) $+			giveup $ "Failed to upload " ++ serializeKey k+  where+	retry = case fromKey keyVariety k of+		GitBundleKey -> stdRetry+		-- Manifest keys are not stable+		_ -> noRetry++-- Generates a git bundle, ingests it into the local objects directory, +-- and returns an action that uploads its key to the special remote.+--+-- If the key is already present in the provided manifest, avoids+-- ingesting or uploading it.+--+-- On failure, an exception is thrown, and nothing is added to the local+-- objects directory.+generateGitBundle+	:: Remote+	-> [Git.Bundle.BundleSpec]+	-> Manifest+	-> Annex (Key, Annex ())+generateGitBundle rmt bs manifest =+	withTmpFile "GITBUNDLE" $ \tmp tmph -> do+		liftIO $ hClose tmph+		inRepo $ Git.Bundle.create tmp bs+		bundlekey <- genGitBundleKey (Remote.uuid rmt)+			(toRawFilePath tmp) nullMeterUpdate+		if (bundlekey `notElem` inManifest manifest)+			then do+				unlessM (moveAnnex bundlekey (AssociatedFile Nothing) (toRawFilePath tmp)) $+					giveup "Unable to push"+				return (bundlekey, uploadaction bundlekey)+			else return (bundlekey, noop)+  where+	uploadaction bundlekey = +		uploadGitObject rmt bundlekey+			`onException` unlinkAnnex bundlekey++dropKey :: Remote -> Key -> Annex Bool+dropKey rmt k = tryNonAsync (dropKey' rmt k) >>= \case+	Right () -> return True+	Left ex -> do+		liftIO $ hPutStrLn stderr $+			"Failed to drop " +				++ serializeKey k +				++ " (" ++ show ex ++ ")"+		return False++dropKey' :: Remote -> Key -> Annex ()+dropKey' rmt k = getKeyExportLocations rmt k >>= \case+	Nothing -> Remote.removeKey rmt k+	Just locs -> forM_ locs $ \loc -> +		Remote.removeExport (Remote.exportActions rmt) k loc++getKeyExportLocations :: Remote -> Key -> Annex (Maybe [ExportLocation])+getKeyExportLocations rmt k = do+	cfg <- Annex.getGitConfig+	u <- getUUID+	return $ keyExportLocations rmt k cfg u++-- When the remote contains a tree, the git keys are stored+-- inside the .git/annex/objects/ directory in the remote.+--+-- The first ExportLocation in the returned list is the one that+-- is the same as the local repository would use. But it's possible+-- that one of the others in the list was used by another repository to+-- upload a git key.+keyExportLocations :: Remote -> Key -> GitConfig -> UUID -> Maybe [ExportLocation]+keyExportLocations rmt k cfg uuid+	| exportTree (Remote.config rmt) || importTree (Remote.config rmt) = +		Just $ map (\p -> mkExportLocation (".git" P.</> p)) $+			concatMap (`annexLocationsNonBare` k) cfgs+	| otherwise = Nothing+  where+	-- When git-annex has not been initialized yet (eg, when cloning), +	-- the Differences are unknown, so make a version of the GitConfig+	-- with and without the OneLevelObjectHash difference.+	cfgs+		| uuid /= NoUUID = [cfg]+		| hasDifference OneLevelObjectHash (annexDifferences cfg) =+			[ cfg+			, cfg { annexDifferences = mempty }+			]+		| otherwise =+			[ cfg+			, cfg +				{ annexDifferences = mkDifferences +					(S.singleton OneLevelObjectHash)+				}+			]++-- Tracking refs are used to remember the refs that are currently on the+-- remote. This is different from git's remote tracking branches, since it+-- needs to track all refs on the remote, not only the refs that the user+-- chooses to fetch.+--+-- For refs/heads/master, the tracking ref is+-- refs/namespaces/git-remote-annex/uuid/refs/heads/master,+-- using the uuid of the remote. See gitnamespaces(7).+trackingRefPrefix :: Remote -> B.ByteString+trackingRefPrefix rmt = "refs/namespaces/git-remote-annex/"+	<> fromUUID (Remote.uuid rmt) <> "/"++toTrackingRef :: Remote -> Ref -> Ref+toTrackingRef rmt (Ref r) = Ref $ trackingRefPrefix rmt <> r++-- If the ref is not a tracking ref, it is returned as-is.+fromTrackingRef :: Remote -> Ref -> Ref+fromTrackingRef rmt = Git.Ref.removeBase (decodeBS (trackingRefPrefix rmt))++-- Update the tracking refs to be those in the map.+-- When deleteold is set, any other tracking refs are deleted.+updateTrackingRefs :: Bool -> Remote -> M.Map Ref Sha -> Annex ()+updateTrackingRefs deleteold rmt new = do+	old <- inRepo $ Git.Ref.forEachRef +		[Param (decodeBS (trackingRefPrefix rmt))]++	-- Delete all tracking refs that are not in the map.+	when deleteold $+		forM_ (filter (\p -> M.notMember (fst p) new) old) $ \(s, r) ->+			inRepo $ Git.Ref.delete s r+	+	-- Update all changed tracking refs.+	let oldmap = M.fromList (map (\(s, r) -> (r, s)) old)+	forM_ (M.toList new) $ \(r, s) ->+		case M.lookup r oldmap of+			Just s' | s' == s -> noop+			_ -> inRepo $ Git.Branch.update' r s++-- git clone does not bother to set GIT_WORK_TREE when running this+-- program, and it does not run it inside the new git repo either.+-- GIT_DIR is set to the new git directory. So, have to override+-- the worktree to be the parent of the gitdir.+getRepo :: IO Repo+getRepo = getEnv "GIT_WORK_TREE" >>= \case+	Just _ -> Git.CurrentRepo.get+	Nothing -> fixup <$> Git.CurrentRepo.get+  where+	fixup r@(Repo { location = loc@(Local { worktree = Just _ }) }) =+		r { location = loc { worktree = Just (P.takeDirectory (gitdir loc)) } }+	fixup r = r++-- Records what the git-annex branch was at the beginning of this command.+data StartAnnexBranch+	= AnnexBranchExistedAlready Sha+	| AnnexBranchCreatedEmpty Sha++{- Run early in the command, gets the initial state of the git-annex+ - branch.+ -+ - If the branch does not exist yet, it's created here. This is done+ - because it's hard to avoid the branch being created by this command,+ - so tracking the sha of the created branch allows cleaning it up later.+ -}+startAnnexBranch :: Annex StartAnnexBranch+startAnnexBranch = ifM (null <$> Annex.Branch.siblingBranches)+	( AnnexBranchCreatedEmpty <$> Annex.Branch.getBranch+	, AnnexBranchExistedAlready <$> Annex.Branch.getBranch+	)++-- This runs an action that will set up a special remote that+-- was specified using an annex url.+--+-- Setting up a special remote needs to write its config to the git-annex+-- branch. And using a special remote may also write to the branch.+-- But in this case, writes to the git-annex branch need to be avoided,+-- so that cleanupInitialization can leave things in the right state.+--+-- So this prevents commits to the git-annex branch, and redirects all+-- journal writes to a temporary directory, so that all writes+-- to the git-annex branch by the action will be discarded.+specialRemoteFromUrl :: StartAnnexBranch -> Annex a -> Annex a+specialRemoteFromUrl sab a = withTmpDir "journal" $ \tmpdir -> do+	Annex.overrideGitConfig $ \c -> +		c { annexAlwaysCommit = False }+	Annex.BranchState.changeState $ \st -> +		st { alternateJournal = Just (toRawFilePath tmpdir) }+	a `finally` cleanupInitialization sab tmpdir++-- If the git-annex branch did not exist when this command started,+-- it was created empty by this command, and this command has avoided+-- making any other commits to it, writing any temporary annex branch+-- changes to thre alternateJournal, which can now be discarded. +-- +-- If nothing else has written to the branch while this command was running,+-- the branch will be deleted. That allows for the git-annex branch that is+-- fetched from the special remote to contain Differences, which would prevent+-- it from being merged with the git-annex branch created by this command.+--+-- If there is still not a sibling git-annex branch, this deletes all annex+-- objects for git bundles from the annex objects directory, and deletes+-- the annex objects directory. That is necessary to avoid the +-- Annex.Init.objectDirNotPresent check preventing a later initialization.+-- And if the later initialization includes Differences, the git bundle+-- objects downloaded by this process would be in the wrong locations.+--+-- When there is now a sibling git-annex branch, this handles+-- initialization. When the initialized git-annex branch has Differences,+-- the git bundle objects are in the wrong place, so have to be deleted.+--+-- Unfortunately, git 2.45.1 and related releases added a +-- "defense in depth" check that a freshly cloned repository+-- does not contain any hooks. Since initialization installs+-- hooks, have to work around that by not initializing, and +-- delete the git bundle objects.+cleanupInitialization :: StartAnnexBranch -> FilePath -> Annex ()+cleanupInitialization sab alternatejournaldir = void $ tryNonAsync $ do+	liftIO $ mapM_ removeFile =<< dirContents alternatejournaldir+	case sab of+		AnnexBranchExistedAlready _ -> noop+		AnnexBranchCreatedEmpty r ->+			whenM ((r ==) <$> Annex.Branch.getBranch) $ do+				indexfile <- fromRepo gitAnnexIndex+				liftIO $ removeWhenExistsWith R.removeLink indexfile+				-- When cloning failed and this is being+				-- run as an exception is thrown, HEAD will+				-- not be set to a valid value, which will+				-- prevent deleting the git-annex branch.+				-- But that's ok, git will delete the +				-- repository it failed to clone into.+				-- So skip deleting to avoid an ugly+				-- message.+				inRepo Git.Branch.currentUnsafe >>= \case+					Nothing -> return ()+					Just _ -> void $ tryNonAsync $+						inRepo $ Git.Branch.delete Annex.Branch.fullname+	ifM (Annex.Branch.hasSibling <&&> nonbuggygitversion)+		( do+			autoInitialize' (pure True) remoteList+			differences <- allDifferences <$> recordedDifferences+			when (differences /= mempty) $+				deletebundleobjects+		, deletebundleobjects+		)+  where+	deletebundleobjects = do+		annexobjectdir <- fromRepo gitAnnexObjectDir+		ks <- listKeys InAnnex+		forM_ ks $ \k -> case fromKey keyVariety k of+                	GitBundleKey -> lockContentForRemoval k noop removeAnnex+			_ -> noop+		void $ liftIO $ tryIO $ removeDirectory (decodeBS annexobjectdir)++	nonbuggygitversion = liftIO $+		flip notElem buggygitversions <$> Git.Version.installed+	buggygitversions = map Git.Version.normalize+		[ "2.45.1"+		, "2.44.1"+		, "2.43.4"+		, "2.42.2"+		, "2.41.1"+		, "2.40.2"+		, "2.39.4"+		]

@@ -25,7 +25,7 @@ 		"capabilities" -> putStrLn "connect" >> ready 		"connect git-upload-pack" -> go UploadPack 		"connect git-receive-pack" -> go ReceivePack-		l -> giveup $ "git-remote-helpers protocol error at " ++ show l+		l -> giveup $ "gitremote-helpers protocol error at " ++ show l   where 	(onionaddress, onionport) 		| '/' `elem` address = parseAddressPort $

@@ -1,6 +1,6 @@ {- git-annex command  -- - Copyright 2013-2023 Joey Hess <id@joeyh.name>+ - Copyright 2013-2024 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -19,6 +19,7 @@ import qualified Remote import qualified Types.Remote as Remote import qualified Remote.Git+import qualified Command.InitRemote import Logs.UUID import Annex.UUID import Config@@ -34,18 +35,32 @@ 	command "enableremote" SectionSetup 		"enables git-annex to use a remote" 		(paramPair paramName $ paramOptional $ paramRepeating paramParamValue)-		(withParams seek)+		(seek <$$> optParser) -seek :: CmdParams -> CommandSeek-seek = withWords (commandAction . start)+data EnableRemoteOptions = EnableRemoteOptions+	{ cmdparams :: CmdParams+	, withUrl :: Bool+	} -start :: [String] -> CommandStart-start [] = unknownNameError "Specify the remote to enable."-start (name:rest) = go =<< filter matchingname <$> Annex.getGitRemotes+optParser :: CmdParamsDesc -> Parser EnableRemoteOptions+optParser desc = EnableRemoteOptions+	<$> cmdParams desc+	<*> switch+		( long "with-url"+		<> short 'u'+		<> help "configure remote with an annex:: url"+		)++seek :: EnableRemoteOptions -> CommandSeek+seek o = withWords (commandAction . (start o)) (cmdparams o)++start :: EnableRemoteOptions -> [String] -> CommandStart+start _ [] = unknownNameError "Specify the remote to enable."+start o (name:rest) = go =<< filter matchingname <$> Annex.getGitRemotes   where 	matchingname r = Git.remoteName r == Just name 	go [] = deadLast name $ -		startSpecialRemote name (Logs.Remote.keyValToConfig Proposed rest)+		startSpecialRemote o name (Logs.Remote.keyValToConfig Proposed rest) 	go (r:_) 		| not (null rest) = go [] 		| otherwise = do@@ -69,8 +84,8 @@ 	ai = ActionItemOther (Just (UnquotedString name)) 	si = SeekInput [name] -startSpecialRemote :: Git.RemoteName -> Remote.RemoteConfig -> [(UUID, Remote.RemoteConfig, Maybe (SpecialRemote.ConfigFrom UUID))] -> CommandStart-startSpecialRemote = startSpecialRemote' "enableremote" performSpecialRemote+startSpecialRemote :: EnableRemoteOptions -> Git.RemoteName -> Remote.RemoteConfig -> [(UUID, Remote.RemoteConfig, Maybe (SpecialRemote.ConfigFrom UUID))] -> CommandStart+startSpecialRemote o = startSpecialRemote' "enableremote" (performSpecialRemote o)  type PerformSpecialRemote = RemoteType -> UUID -> R.RemoteConfig -> R.RemoteConfig -> RemoteGitConfig -> Maybe (SpecialRemote.ConfigFrom UUID) -> CommandPerform @@ -97,8 +112,8 @@ startSpecialRemote' _ _ _ _ _ = 	giveup "Multiple remotes have that name. Either use git-annex renameremote to rename them, or specify the uuid of the remote." -performSpecialRemote :: PerformSpecialRemote-performSpecialRemote t u oldc c gc mcu = do+performSpecialRemote :: EnableRemoteOptions -> PerformSpecialRemote+performSpecialRemote o t u oldc c gc mcu = do 	-- Avoid enabling a special remote if there is another remote 	-- with the same name. 	case SpecialRemote.lookupName c of@@ -110,10 +125,10 @@ 					giveup $ "Not overwriting currently configured git remote named \"" ++ name ++ "\"" 				_ -> noop 	(c', u') <- R.setup t (R.Enable oldc) (Just u) Nothing c gc-	next $ cleanupSpecialRemote t u' c' mcu+	next $ cleanupSpecialRemote o t u' c' mcu -cleanupSpecialRemote :: RemoteType -> UUID -> R.RemoteConfig -> Maybe (SpecialRemote.ConfigFrom UUID) -> CommandCleanup-cleanupSpecialRemote t u c mcu = do+cleanupSpecialRemote :: EnableRemoteOptions -> RemoteType -> UUID -> R.RemoteConfig -> Maybe (SpecialRemote.ConfigFrom UUID) -> CommandCleanup+cleanupSpecialRemote o t u c mcu = do 	case mcu of 		Nothing -> Logs.Remote.configSet u c 		Just (SpecialRemote.ConfigFrom cu) -> do@@ -124,7 +139,9 @@ 		Just r -> do 			repo <- R.getRepo r 			setRemoteIgnore repo False-	unless (Remote.gitSyncableRemoteType t) $+	when (withUrl o) $+		Command.InitRemote.setAnnexUrl c+	unless (Remote.gitSyncableRemoteType t || withUrl o) $ 		setConfig (remoteConfig c "skipFetchAll") (boolConfig True) 	return True 

@@ -111,7 +111,7 @@ 		-- we just want to know if the tor circuit works. 		liftIO (tryNonAsync $ connectPeer g addr) >>= \case 			Left e -> do-				warning $ UnquotedString $ "Unable to connect to hidden service. It may not yet have propigated to the Tor network. (" ++ show e ++ ") Will retry.."+				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) 				check (n-1) addrs 			Right conn -> do

@@ -38,6 +38,7 @@ import Git.FilePath import Utility.PID import Utility.InodeCache+import Utility.Metered import Annex.InodeSentinal import qualified Database.Keys import qualified Database.Fsck as FsckDb@@ -206,8 +207,7 @@ 			) 		, return Nothing 		)-	getfile' tmp = Remote.retrieveKeyFile remote key (AssociatedFile Nothing) (fromRawFilePath tmp) dummymeter (RemoteVerify remote)-	dummymeter _ = noop+	getfile' tmp = Remote.retrieveKeyFile remote key (AssociatedFile Nothing) (fromRawFilePath tmp) nullMeterUpdate (RemoteVerify remote) 	getcheap tmp = case Remote.retrieveKeyFileCheap remote of 		Just a -> isRight <$> tryNonAsync (a key afile (fromRawFilePath tmp)) 		Nothing -> return False@@ -504,16 +504,19 @@ checkBackend :: Key -> KeyStatus -> AssociatedFile -> Annex Bool checkBackend key keystatus afile = do 	content <- calcRepo (gitAnnexLocation key)-	ifM (pure (isKeyUnlockedThin keystatus) <&&> (not <$> isUnmodified key content))-		( nocheck-		, do-			mic <- withTSDelta (liftIO . genInodeCache content)-			ifM (checkBackendOr badContent key content ai)-				( do-					checkInodeCache key content mic ai-					return True-				, return False-				)+	ifM (liftIO $ R.doesPathExist content)+		( ifM (pure (isKeyUnlockedThin keystatus) <&&> (not <$> isUnmodified key content))+			( nocheck+			, do+				mic <- withTSDelta (liftIO . genInodeCache content)+				ifM (checkBackendOr badContent key content ai)+					( do+						checkInodeCache key content mic ai+						return True+					, return False+					)+			)+		, nocheck 		)   where 	nocheck = return True@@ -525,14 +528,18 @@ 	checkBackendOr (badContentRemote remote localcopy) key localcopy ai  checkBackendOr :: (Key -> Annex String) -> Key -> RawFilePath -> ActionItem -> Annex Bool-checkBackendOr bad key file ai = do-	ok <- verifyKeyContent' key file-	unless ok $ do-		msg <- bad key-		warning $ actionItemDesc ai-			<> ": Bad file content; "-			<> UnquotedString msg-	return ok+checkBackendOr bad key file ai =+	ifM (Annex.getRead Annex.fast)+		( return True+		, do+			ok <- verifyKeyContent' key file+			unless ok $ do+				msg <- bad key+				warning $ actionItemDesc ai+					<> ": Bad file content; "+					<> UnquotedString msg+			return ok+		)  {- Check, if there are InodeCaches recorded for a key, that one of them  - matches the object file. There are situations where the InodeCache

@@ -1,6 +1,6 @@ {- git-annex command  -- - Copyright 2012 Joey Hess <id@joeyh.name>+ - Copyright 2012-2024 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -9,19 +9,39 @@  import Command import qualified Remote-import Logs.Group import Types.Group+import Logs.Group+import Logs.UUID+import Logs.Trust import Utility.SafeOutput  import qualified Data.Set as S+import qualified Data.Map as M  cmd :: Command cmd = noMessages $ command "group" SectionSetup "add a repository to a group"-	(paramPair paramRemote paramDesc) (withParams seek)+	(paramPair paramRemote paramDesc) (seek <$$> optParser) -seek :: CmdParams -> CommandSeek-seek = withWords (commandAction . start)+data GroupOptions = GroupOptions+	{ cmdparams :: CmdParams+	, listOption :: Bool+	} +optParser :: CmdParamsDesc -> Parser GroupOptions+optParser desc = GroupOptions+	<$> cmdParams desc+	<*> switch+		( long "list"+		<> help "list all currently defined groups"+		)++seek :: GroupOptions -> CommandSeek+seek o+	| listOption o = if null (cmdparams o)+		then commandAction startList+		else giveup "Cannot combine --list with other options"+	| otherwise = commandAction $ start (cmdparams o)+ start :: [String] -> CommandStart start ps@(name:g:[]) = do 	u <- Remote.nameToUUID name@@ -33,12 +53,21 @@ start (name:[]) = do 	u <- Remote.nameToUUID name 	startingCustomOutput (ActionItemOther Nothing) $ do-		liftIO . putStrLn . safeOutput . unwords . map fmt . S.toList-			=<< lookupGroups u+		liftIO . listGroups =<< lookupGroups u 		next $ return True+start _ = giveup "Specify a repository and a group."++startList :: CommandStart+startList = startingCustomOutput (ActionItemOther Nothing) $ do+	us <- trustExclude DeadTrusted =<< M.keys <$> uuidDescMap+	gs <- foldl' S.union mempty <$> mapM lookupGroups us+	liftIO $ listGroups gs+	next $ return True++listGroups :: S.Set Group -> IO ()+listGroups = liftIO . putStrLn . safeOutput . unwords . map fmt . S.toList   where 	fmt (Group g) = decodeBS g-start _ = giveup "Specify a repository and a group."  setGroup :: UUID -> Group -> CommandPerform setGroup uuid g = do

@@ -573,7 +573,7 @@ 	, ("itemtitle", [youtube_title i]) 	, ("feedauthor", [youtube_playlist_uploader i]) 	, ("itemauthor", [youtube_playlist_uploader i])-	-- itemsummary omitted, no equivilant in yt-dlp data+	-- itemsummary omitted, no equivalent in yt-dlp data 	, ("itemdescription", [youtube_description i]) 	, ("itemrights", [youtube_license i]) 	, ("itemid", [youtube_url i])

@@ -1,6 +1,6 @@ {- git-annex command  -- - 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.  -}@@ -21,6 +21,7 @@ import Types.ProposedAccepted import Config import Git.Config+import Git.Types  import qualified Data.Map as M import qualified Data.Text as T@@ -35,6 +36,7 @@ data InitRemoteOptions = InitRemoteOptions 	{ cmdparams :: CmdParams 	, sameas :: Maybe (DeferredParse UUID)+	, withUrl :: Bool 	, whatElse :: Bool 	, privateRemote :: Bool 	}@@ -44,6 +46,11 @@ 	<$> cmdParams desc 	<*> optional parseSameasOption 	<*> switch+		( long "with-url"+		<> short 'u'+		<> help "configure remote with an annex:: url"+		)+	<*> switch 		( long "whatelse" 		<> short 'w' 		<> help "describe other configuration parameters for a special remote"@@ -125,10 +132,22 @@ 			cu <- liftIO genUUID 			setConfig (remoteAnnexConfig c "config-uuid") (fromUUID cu) 			Logs.Remote.configSet cu c-	unless (Remote.gitSyncableRemoteType t) $+	when (withUrl o) $+		setAnnexUrl c+	unless (Remote.gitSyncableRemoteType t || withUrl o) $ 		setConfig (remoteConfig c "skipFetchAll") (boolConfig True) 	return True +setAnnexUrl :: R.RemoteConfig -> Annex ()+setAnnexUrl c =+	getConfigMaybe (remoteConfig c "url") >>= \case+		Just (ConfigValue _) -> noop+		_ -> do+			setConfig (remoteConfig c "url") "annex::"+			setConfig (remoteConfig c "fetch") $+				"+refs/heads/*:refs/remotes/" +++				getRemoteName c ++ "/*"+ describeOtherParamsFor :: RemoteConfig -> RemoteType -> CommandPerform describeOtherParamsFor c t = do 	cp <- R.configParser t c@@ -138,6 +157,7 @@ 		( maybeAddJSONField "whatelse" $ M.fromList $ mkjson l 		, liftIO $ forM_ l $ \(p, fd, vd) -> case fd of 			HiddenField -> return ()+			DeprecatedField -> return () 			FieldDesc d -> do 				putStrLn p 				putStrLn ("\t" ++ d)@@ -152,6 +172,7 @@ 	mkjson = mapMaybe $ \(p, fd, vd) -> 		case fd of 			HiddenField -> Nothing+			DeprecatedField -> Nothing 			FieldDesc d -> Just  				( T.pack p 				, M.fromList

@@ -169,7 +169,7 @@  - same key. The method is to compare each value with the value  - after it in the list, which is the old version of the value.  -- - This ncessarily buffers the whole list, so does not stream.+ - This necessarily buffers the whole list, so does not stream.  - But, the number of location log changes for a single key tends to be  - fairly small.  -@@ -377,7 +377,7 @@ 	-- time across all git-annex repositories. 	-- 	-- This combines the new location log with what has been-	-- accumulated so far, which is equivilant to merging together+	-- accumulated so far, which is equivalent to merging together 	-- all git-annex branches at that point in time. 	update k sizemap locmap (oldlog, oldlocs) newlog =  		( updatesize (updatesize sizemap sz (S.toList addedlocs))@@ -490,7 +490,7 @@  		posminus a b = max 0 (a - b) -		-- A verison of sizemap where uuids that are currently dead+		-- A version of sizemap where uuids that are currently dead 		-- have 0 size. 		sizemap' = M.mapWithKey zerodead sizemap 		zerodead u v = case M.lookup u (simpleMap trustlog) of

@@ -200,7 +200,7 @@ 		firstM (\f -> (== Just newkey) <$> isAnnexLink f) $ 			map (\f -> simplifyPath (fromTopFilePath f g)) fs 	-	-- Always verify the content agains the newkey, even if+	-- Always verify the content against the newkey, even if 	-- annex.verify is unset. This is done to prent bad migration 	-- information maliciously injected into the git-annex branch 	-- from populating files with the wrong content.

@@ -40,7 +40,7 @@ 		)   where 	{- No need to do any rollback; when sendAnnex fails, a nonzero-	 - exit will be propigated, and the remote will know the transfer+	 - exit will be propagated, and the remote will know the transfer 	 - failed. -} 	rollback = noop 

@@ -267,8 +267,8 @@  	remotes <- syncRemotes (syncWith o) 	warnSyncContentTransition o remotes-	-- Remotes that are git repositories, not (necesarily) special remotes.-	let gitremotes = filter (Remote.gitSyncableRemoteType . Remote.remotetype) remotes+	-- Remotes that git can push to and pull from.+	let gitremotes = filter Remote.gitSyncableRemote remotes 	-- Remotes that contain annex object content. 	contentremotes <- filter (\r -> Remote.uuid r /= NoUUID) 		<$> filterM (not <$$> liftIO . getDynamicConfig . remoteAnnexIgnore . Remote.gitconfig) remotes@@ -978,7 +978,7 @@ seekExportContent o rs (mcurrbranch, madj) 	| null rs = return False 	| otherwise = do-		-- Propigate commits from the adjusted branch, so that+		-- Propagate commits from the adjusted branch, so that 		-- when the remoteAnnexTrackingBranch is set to the parent 		-- branch, it will be up-to-date. 		case (mcurrbranch, madj) of

@@ -295,7 +295,9 @@ 		Nothing -> return True 		Just b -> case Types.Backend.verifyKeyContent b of 			Nothing -> return True-			Just verifier -> verifier k (serializeKey' k)+			Just verifier -> do+				loc <- Annex.calcRepo (gitAnnexLocation k)+				verifier k loc 	get r k = logStatusAfter k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) Nothing $ \dest -> 		tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) (fromRawFilePath dest) nullMeterUpdate (RemoteVerify r)) >>= \case 			Right v -> return (True, v)

@@ -1,6 +1,6 @@ {- git-annex command  -- - 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.  -}@@ -34,6 +34,7 @@ import Annex.BloomFilter import qualified Database.Keys import Annex.InodeSentinal+import Backend.GitRemoteAnnex (isGitRemoteAnnexKey)  import qualified Data.Map as M import qualified Data.ByteString as S@@ -104,7 +105,8 @@ 		_ <- check "" (remoteUnusedMsg r remotename) (remoteunused u) 0 		next $ return True 	remoteunused u = loggedKeysFor u >>= \case-		Just ks -> excludeReferenced refspec ks+		Just ks -> filter (not . isGitRemoteAnnexKey u)+			<$> excludeReferenced refspec ks 		Nothing -> giveup "This repository is read-only."  check :: String -> ([(Int, Key)] -> String) -> Annex [Key] -> Int -> Annex Int

@@ -70,7 +70,7 @@  - changes to the database!  -  - Note that the action is not run by the calling thread, but by a- - worker thread. Exceptions are propigated to the calling thread.+ - worker thread. Exceptions are propagated to the calling thread.  -  - Only one action can be run at a time against a given DbHandle.  - If called concurrently in the same process, this will block until

@@ -491,7 +491,7 @@  	-- How large is large? Too large and there will be a long 	-- delay before the message is shown; too short and the message-	-- will clutter things up unncessarily. It's uncommon for 1000+	-- will clutter things up unnecessarily. It's uncommon for 1000 	-- files to change in the index, and processing that many files 	-- takes less than half a second, so that seems about right. 	largediff :: Int

@@ -167,7 +167,7 @@ 		p' <- relPathCwdToFile p 		return $ if B.null p' then "." else p' -{- Adusts the path to a local Repo using the provided function. -}+{- Adjusts the path to a local Repo using the provided function. -} adjustPath :: (RawFilePath -> IO RawFilePath) -> Repo -> IO Repo adjustPath f r@(Repo { location = l@(Local { gitdir = d, worktree = w }) }) = do 	d' <- f d

@@ -40,15 +40,19 @@  {- The current branch, which may not really exist yet. -} currentUnsafe :: Repo -> IO (Maybe Branch)-currentUnsafe r = parse . firstLine' <$> pipeReadStrict-	[ Param "symbolic-ref"-	, Param "-q"-	, Param $ fromRef Git.Ref.headRef-	] r+currentUnsafe r = withNullHandle $ \nullh ->+	parse . firstLine' <$> pipeReadStrict'+		(\p -> p { std_err = UseHandle nullh })+		ps r   where 	parse b 		| B.null b = Nothing 		| otherwise = Just $ Git.Ref b+	ps =+		[ Param "symbolic-ref"+		, Param "-q"+		, Param $ fromRef Git.Ref.headRef+		]  {- Checks if the second branch has any commits not present on the first  - branch. -}

@@ -0,0 +1,68 @@+{- git bundles+ -+ - Copyright 2024 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++{-# LANGUAGE OverloadedStrings #-}++module Git.Bundle where++import Common+import Git+import Git.Command++import Data.Char (ord)+import qualified Data.ByteString.Char8 as S8++listHeads :: FilePath -> Repo -> IO [(Sha, Ref)]+listHeads bundle repo = map gen . S8.lines <$>+	pipeReadStrict [Param "bundle", Param "list-heads", File bundle] repo+  where+	gen l = let (s, r) = separate' (== fromIntegral (ord ' ')) l+		in (Ref s, Ref r)++unbundle :: FilePath -> Repo -> IO ()+unbundle bundle = runQuiet [Param "bundle", Param "unbundle", File bundle]++-- Specifies what to include in the bundle.+data BundleSpec = BundleSpec+	{ preRequisiteRef :: Maybe Ref+	-- ^ Do not include this Ref, or any objects reachable from it+	-- in the bundle. This should be an ancestor of the includeRef.+	, includeRef :: Ref+	-- ^ Include this Ref and objects reachable from it in the bundle,+	-- unless filtered out by the preRequisiteRef of this BundleSpec+	-- or any other one that is included in the bundle.+	}+	deriving (Show)++-- Include the ref and all objects reachable from it in the bundle.+-- (Unless another BundleSpec is included that has a preRequisiteRef+-- that filters out the ref or other objects.)+fullBundleSpec :: Ref -> BundleSpec+fullBundleSpec r = BundleSpec+	{ preRequisiteRef = Nothing+	, includeRef = r+	}++create :: FilePath -> [BundleSpec] -> Repo -> IO ()+create bundle revs repo = pipeWrite+	[ Param "bundle"+	, Param "create"+	, Param "--quiet"+	, File bundle+	, Param "--stdin"+	] repo writer+  where+	writer h = do+		forM_ revs $ \bs ->+			case preRequisiteRef bs of+				Nothing -> S8.hPutStrLn h $+					fromRef' (includeRef bs)+				Just pr -> S8.hPutStrLn h $+					fromRef' pr+						<> ".." <>+					fromRef' (includeRef bs)+		hClose h

@@ -125,7 +125,7 @@ knownMissing FsckFailed = S.empty knownMissing (FsckFoundMissing s _) = s -{- Finds objects that are missing from the git repsitory, or are corrupt.+{- Finds objects that are missing from the git repository, or are corrupt.  -  - This does not use git cat-file --batch, because catting a corrupt  - object can cause it to crash, or to report incorrect size information.

@@ -1,6 +1,6 @@ {- git ref stuff  -- - Copyright 2011-2020 Joey Hess <id@joeyh.name>+ - Copyright 2011-2024 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -165,8 +165,18 @@ list :: Repo -> IO [(Sha, Ref)] list = matching' [] [] -{- Deletes a ref. This can delete refs that are not branches, - - which git branch --delete refuses to delete. -}+{- Lists refs using for-each-ref.  -}+forEachRef :: [CommandParam] -> Repo -> IO [(Sha, Branch)]+forEachRef ps repo = map gen . S8.lines <$>+	pipeReadStrict (Param "for-each-ref" : ps ++ [format]) repo+  where+	format = Param "--format=%(objectname) %(refname)"+	gen l = let (r, b) = separate' (== fromIntegral (ord ' ')) l+		in (Ref r, Ref b)++{- Deletes a ref when it contains the specified sha. + - This can delete refs that are not branches, which+ - git branch --delete refuses to delete. -} delete :: Sha -> Ref -> Repo -> IO () delete oldvalue ref = run 	[ Param "update-ref"@@ -175,6 +185,14 @@ 	, Param $ fromRef oldvalue 	] +{- Deletes a ref no matter what it contains. -}+delete' :: Ref -> Repo -> IO ()+delete' ref = run+	[ Param "update-ref"+	, Param "-d"+	, Param $ fromRef ref+	]+ {- Gets the sha of the tree a ref uses.   -  - The ref may be something like a branch name, and it could contain@@ -191,6 +209,19 @@ 		then ref 		-- de-reference commit objects to the tree 		else ref <> ":"++{- Check if the first ref is an ancestor of the second ref. + -+ - Note that if the two refs point to the same commit, it is considered+ - to be an ancestor of itself.+ -}+isAncestor :: Ref -> Ref -> Repo -> IO Bool+isAncestor r1 r2 = runBool+	[ Param "merge-base"+	, Param "--is-ancestor"+	, Param (fromRef r1)+	, Param (fromRef r2)+	]  {- Checks if a String is a legal git ref name.  -

@@ -1,6 +1,6 @@ {- git remote stuff  -- - Copyright 2012-2021 Joey Hess <id@joeyh.name>+ - Copyright 2012-2024 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -13,6 +13,7 @@ import Common import Git import Git.Types+import Git.Command  import Data.Char import qualified Data.Map as M@@ -22,6 +23,11 @@ #ifdef mingw32_HOST_OS import Git.FilePath #endif++{- Lists all currently existing git remotes. -}+listRemotes :: Repo -> IO [RemoteName]+listRemotes repo = map decodeBS . S8.lines+	<$> pipeReadStrict [Param "remote"] repo  {- Is a git config key one that specifies the url of a remote? -} isRemoteUrlKey :: ConfigKey -> Bool

@@ -29,4 +29,4 @@ older :: String -> IO Bool older n = do 	v <- installed-	return $ v < normalize n +	return $ v < normalize n

@@ -211,7 +211,7 @@ chunkLogExt :: S.ByteString chunkLogExt = ".log.cnk" -{- The filename of the equivilant keys log for a given key. -}+{- The filename of the equivalent keys log for a given key. -} equivilantKeysLogFile :: GitConfig -> Key -> RawFilePath equivilantKeysLogFile config key =  	(branchHashDir config key P.</> keyFile key)

@@ -1,4 +1,4 @@-{- Logs listing keys that are equivilant to a key.+{- Logs listing keys that are equivalent to a key.  -  - Copyright 2024 Joey Hess <id@joeyh.name>  -

@@ -267,7 +267,7 @@ 	hSetBuffering stderr LineBuffering #ifdef mingw32_HOST_OS 	{- Avoid outputting CR at end of line on Windows. git commands do-	 - not ouput CR there. -}+	 - not output CR there. -} 	hSetNewlineMode stdout noNewlineTranslation 	hSetNewlineMode stderr noNewlineTranslation #endif@@ -353,7 +353,7 @@ 				(const $ run a)  {- Catch all (non-async and not ExitCode) exceptions and display, - - santizing any control characters in the exceptions.+ - sanitizing any control characters in the exceptions.  -  - Exits nonzero on exception, so should only be used at topmost level.  -}

@@ -26,7 +26,6 @@ 	remoteTypes, 	remoteList, 	remoteList',-	gitSyncableRemoteType, 	remoteMap, 	remoteMap', 	uuidDescriptions,@@ -61,6 +60,8 @@ 	claimingUrl, 	claimingUrl', 	isExportSupported,+	gitSyncableRemote,+	gitSyncableRemoteType, ) where  import Data.Ord@@ -445,3 +446,12 @@ 	fromMaybe web <$> firstM checkclaim (filter remotefilter rs)   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? -}+gitSyncableRemote :: Remote -> Bool+gitSyncableRemote r+	| gitSyncableRemoteType (remotetype r) = True+	| otherwise = case remoteUrl (gitconfig r) of+		Just u | "annex::" `isPrefixOf` u -> True+		_ -> False

@@ -348,7 +348,7 @@ 	mk _ = Nothing  -- This does not guard against every possible race. As long as the adb--- connection is resonably fast, it's probably as good as+-- connection is reasonably fast, it's probably as good as -- git's handling of similar situations with files being modified while -- it's updating the working tree for a merge. retrieveExportWithContentIdentifierM :: AndroidSerial -> AndroidPath -> ExportLocation -> [ContentIdentifier] -> FilePath -> Either Key (Annex Key) -> MeterUpdate -> Annex (Key, Verification)

@@ -413,7 +413,7 @@  -- Since ignoreinodes can be changed by enableremote, and since previous -- versions of git-annex ignored inodes by default, treat two content--- idenfiers as the same if they differ only by one having the inode+-- identifiers as the same if they differ only by one having the inode -- ignored. guardSameContentIdentifiers :: a -> [ContentIdentifier] -> Maybe ContentIdentifier -> a guardSameContentIdentifiers _ _ Nothing = giveup "file not found"

@@ -92,7 +92,7 @@ list autoinit = do 	c <- fromRepo Git.config 	rs <- mapM (tweakurl c) =<< Annex.getGitRemotes-	mapM (configRead autoinit) rs+	mapM (configRead autoinit) (filter (not . isGitRemoteAnnex) rs)   where 	annexurl r = remoteConfig r "annexurl" 	tweakurl c r = do@@ -102,6 +102,9 @@ 			Just url -> inRepo $ \g -> 				Git.Construct.remoteNamed n $ 					Git.Construct.fromRemoteLocation (Git.fromConfigValue url) False g++isGitRemoteAnnex :: Git.Repo -> Bool+isGitRemoteAnnex r = "annex::" `isPrefixOf` Git.repoLocation r  {- Git remotes are normally set up using standard git commands, not  - git-annex initremote and enableremote.

@@ -58,7 +58,7 @@  chunkConfigParsers :: [RemoteConfigFieldParser] chunkConfigParsers =-	[ optionalStringParser chunksizeField HiddenField -- deprecated+	[ optionalStringParser chunksizeField DeprecatedField 	, optionalStringParser chunkField 		(FieldDesc "size of chunks (eg, 1MiB)") 	]

@@ -14,6 +14,7 @@ 	encryptionAlreadySetup, 	encryptionConfigParsers, 	parseEncryptionConfig,+	parseEncryptionMethod, 	remoteCipher, 	remoteCipher', 	embedCreds,@@ -85,7 +86,7 @@ encryptionFieldParser = RemoteConfigFieldParser 	{ parserForField = encryptionField 	, valueParser = \v c -> Just . RemoteConfigValue-		<$> parseEncryptionMethod (fmap fromProposedAccepted v) c+		<$> parseEncryptionMethod' v c 	, fieldDesc = FieldDesc "how to encrypt data stored in the special remote" 	, valueDesc = Just $ ValueDesc $ 		intercalate " or " (M.keys encryptionMethods)@@ -100,14 +101,18 @@ 	, ("sharedpubkey", SharedPubKeyEncryption) 	] -parseEncryptionMethod :: Maybe String -> RemoteConfig -> Either String EncryptionMethod-parseEncryptionMethod (Just s) _ = case M.lookup s encryptionMethods of-	Just em -> Right em-	Nothing -> Left badEncryptionMethod+parseEncryptionMethod :: RemoteConfig -> Either String EncryptionMethod+parseEncryptionMethod c = parseEncryptionMethod' (M.lookup encryptionField c) c++parseEncryptionMethod' :: Maybe (ProposedAccepted String) -> RemoteConfig -> Either String EncryptionMethod+parseEncryptionMethod' (Just s) _ =+	case M.lookup (fromProposedAccepted s) encryptionMethods of+		Just em -> Right em+		Nothing -> Left badEncryptionMethod -- Hybrid encryption is the default when a keyid is specified without -- an encryption field, or when there's a cipher already but no encryption -- field.-parseEncryptionMethod Nothing c+parseEncryptionMethod' Nothing c 	| M.member (Accepted "keyid") c || M.member cipherField c = Right HybridEncryption 	| otherwise = Left badEncryptionMethod @@ -162,7 +167,7 @@ 	maybe (genCipher pc gpgcmd) (updateCipher pc gpgcmd) (extractCipher pc)   where 	-- The type of encryption-	encryption = parseEncryptionMethod (fromProposedAccepted <$> M.lookup encryptionField c) c+	encryption = parseEncryptionMethod c 	-- Generate a new cipher, depending on the chosen encryption scheme 	genCipher pc gpgcmd = case encryption of 		Right NoneEncryption -> return (c, NoEncryption)

@@ -87,12 +87,20 @@  {- Generates a Remote. -} remoteGen :: M.Map UUID RemoteConfig -> RemoteType -> Git.Repo -> Annex (Maybe Remote)-remoteGen m t g = do+remoteGen = remoteGen' id++remoteGen'+	:: (RemoteConfig -> RemoteConfig)+	-> M.Map UUID RemoteConfig+	-> RemoteType+	-> Git.Repo+	-> Annex (Maybe Remote)+remoteGen' adjustconfig m t g = do 	u <- getRepoUUID g 	gc <- Annex.getRemoteGitConfig g 	let cu = fromMaybe u $ remoteAnnexConfigUUID gc 	let rs = RemoteStateHandle cu-	let c = fromMaybe M.empty $ M.lookup cu m+	let c = adjustconfig (fromMaybe M.empty $ M.lookup cu m) 	generate t g u c gc rs >>= \case 		Nothing -> return Nothing 		Just r -> Just <$> adjustExportImport (adjustReadOnly (addHooks r)) rs@@ -109,7 +117,11 @@ 			Remote.Git.configRead False r 		| otherwise = return r -{- Checks if a remote is syncable using git. -}+{- Types of remotes that are always syncable using git.+ -+ - This does not include special remotes that may or may not have an+ - annex:: url that allows using git-remote-annex with them.+ -} gitSyncableRemoteType :: RemoteType -> Bool gitSyncableRemoteType t = t `elem` 	[ Remote.Git.remote

@@ -36,7 +36,10 @@ 	-- process need to be noticed while the current process is running? 	-- (This makes the journal always be read, and avoids using the 	-- cache.)+	, alternateJournal :: Maybe RawFilePath+	-- ^ use this directory for all journals, rather than the+	-- gitAnnexJournalDir and gitAnnexPrivateJournalDir. 	}  startBranchState :: BranchState-startBranchState = BranchState False False False [] [] [] False+startBranchState = BranchState False False False [] [] [] False Nothing

@@ -17,6 +17,7 @@ 	differenceConfigVal, 	hasDifference, 	listDifferences,+	mkDifferences, ) where  import Utility.PartialPrelude

@@ -373,6 +373,9 @@ 	, remoteAnnexBwLimitDownload :: Maybe BwRate 	, remoteAnnexAllowUnverifiedDownloads :: Bool 	, remoteAnnexConfigUUID :: Maybe UUID+	, remoteAnnexMaxGitBundles :: Int+	, remoteAnnexAllowEncryptedGitRepo :: Bool+	, remoteUrl :: Maybe String  	{- These settings are specific to particular types of remotes 	 - including special remotes. -}@@ -430,7 +433,8 @@ 		, remoteAnnexTrustLevel = notempty $ getmaybe "trustlevel" 		, remoteAnnexStartCommand = notempty $ getmaybe "start-command" 		, remoteAnnexStopCommand = notempty $ getmaybe "stop-command"-		, remoteAnnexSpeculatePresent = getbool "speculate-present" False+		, remoteAnnexSpeculatePresent = +			getbool "speculate-present" False 		, remoteAnnexBare = getmaybebool "bare" 		, remoteAnnexRetry = getmayberead "retry" 		, remoteAnnexForwardRetry = getmayberead "forward-retry"@@ -450,6 +454,8 @@ 			readBwRatePerSecond =<< getmaybe "bwlimit-download" 		, remoteAnnexAllowUnverifiedDownloads = (== Just "ACKTHPPT") $ 			getmaybe ("security-allow-unverified-downloads")+		, remoteAnnexMaxGitBundles =+			fromMaybe 100 (getmayberead  "max-git-bundles") 		, remoteAnnexConfigUUID = toUUID <$> getmaybe "config-uuid" 		, remoteAnnexShell = getmaybe "shell" 		, remoteAnnexSshOptions = getoptions "ssh-options"@@ -476,6 +482,14 @@ 		, remoteAnnexDdarRepo = getmaybe "ddarrepo" 		, remoteAnnexHookType = notempty $ getmaybe "hooktype" 		, remoteAnnexExternalType = notempty $ getmaybe "externaltype"+		, remoteAnnexAllowEncryptedGitRepo = +			getbool "allow-encrypted-gitrepo" False+		, remoteUrl = +			case Git.Config.getMaybe (remoteConfig remotename "url") r of+				Just (ConfigValue b)+					| B.null b -> Nothing+					| otherwise -> Just (decodeBS b)+				_ -> Nothing 		}   where 	getbool k d = fromMaybe d $ getmaybebool k

@@ -0,0 +1,45 @@+{- git-remote-annex types+ -+ - Copyright 2024 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module Types.GitRemoteAnnex +	( Manifest+	, mkManifest+	, inManifest+	, outManifest+	) where++import Types.Key++import qualified Data.Semigroup as Sem+import qualified Data.Set as S++-- The manifest contains an ordered list of git bundle keys.+--+-- There is a second list of git bundle keys that are no longer+-- used and should be deleted. This list should never contain keys+-- that are in the first list.+data Manifest =+	Manifest +		{ inManifest :: [Key]+		, outManifest :: S.Set Key+		}+	deriving (Show)++-- Smart constructor for Manifest. Preserves outManifest invariant.+mkManifest+	:: [Key] -- ^ inManifest+	-> S.Set Key -- ^ outManifest+	-> Manifest+mkManifest inks outks = Manifest inks (S.filter (`notElem` inks) outks)++instance Monoid Manifest where+	mempty = Manifest mempty mempty++instance Sem.Semigroup Manifest where+	a <> b = mkManifest+		(inManifest a <> inManifest b)+		(S.union (outManifest a) (outManifest b))

@@ -60,7 +60,7 @@  instance NFData KeyData -{- Caching the seralization of a key is an optimization.+{- Caching the serialization of a key is an optimization.  -  - This constructor is not exported, and all smart constructors maintain  - the serialization.@@ -219,6 +219,8 @@ 	| WORMKey 	| URLKey 	| VURLKey+	| GitBundleKey+	| GitManifestKey 	-- A key that is handled by some external backend. 	| ExternalKey S.ByteString HasExt  	-- Some repositories may contain keys of other varieties,@@ -253,6 +255,8 @@ hasExt WORMKey = False hasExt URLKey = False hasExt VURLKey = False+hasExt GitBundleKey = False+hasExt GitManifestKey = False hasExt (ExternalKey _ (HasExt b)) = b hasExt (OtherKey s) = (snd <$> S8.unsnoc s) == Just 'E' @@ -282,6 +286,8 @@ 	WORMKey -> "WORM" 	URLKey -> "URL" 	VURLKey -> "VURL"+	GitBundleKey -> "GITBUNDLE"+	GitManifestKey -> "GITMANIFEST" 	ExternalKey s e -> adde e ("X" <> s) 	OtherKey s -> s   where@@ -347,6 +353,7 @@ parseKeyVariety "WORM"         = WORMKey parseKeyVariety "URL"          = URLKey parseKeyVariety "VURL"         = VURLKey+parseKeyVariety "GITBUNDLE"    = GitBundleKey parseKeyVariety b 	| "X" `S.isPrefixOf` b =  		let b' = S.tail b

@@ -51,6 +51,8 @@ data FieldDesc 	= FieldDesc String 	| HiddenField+	| DeprecatedField+	deriving (Eq)  newtype ValueDesc = ValueDesc String 

@@ -27,9 +27,9 @@  -- Parse eg, "0KiB/60s" ----- Also, it can be set to "true" (or other git config equivilants)+-- Also, it can be set to "true" (or other git config equivalents) -- to enable ProbeStallDetection. --- And "false" (and other git config equivilants) explicitly+-- And "false" (and other git config equivalents) explicitly -- disable stall detection. parseStallDetection :: String -> Either String StallDetection parseStallDetection s = case isTrueFalse s of

@@ -69,7 +69,7 @@ boolGpgCmd :: GpgCmd -> [CommandParam] -> IO Bool boolGpgCmd (GpgCmd cmd) = boolSystem cmd --- Generate an argument list to asymetrically encrypt to the given recipients.+-- Generate an argument list to asymmetrically encrypt to the given recipients. pkEncTo :: [String] -> [CommandParam] pkEncTo = concatMap (\r -> [Param "--recipient", Param r]) 

@@ -253,7 +253,7 @@ 	go (MatchedOpen:rest) = "(" : go rest 	go (MatchedClose:rest) = ")" : go rest -	-- Remove unncessary outermost parens+	-- Remove unnecessary outermost parens 	simplify True (MatchedOpen:rest) = case lastMaybe rest of 		Just MatchedClose -> simplify False (dropFromEnd 1 rest) 		_ -> simplify False rest

@@ -48,7 +48,7 @@  - already exists. -} absPath :: RawFilePath -> IO RawFilePath absPath file-	-- Avoid unncessarily getting the current directory when the path+	-- Avoid unnecessarily getting the current directory when the path 	-- is already absolute. absPathFrom uses simplifyPath 	-- so also used here for consistency. 	| isAbsolute file = return $ simplifyPath file

@@ -32,7 +32,7 @@  - characters, except for ones in surrogate plane. Converting a string that  - does contain other unicode characters to a ByteString using the  - filesystem encoding (see GHC.IO.Encoding) will throw an exception,- - so use this instead to avoid quickcheck tests breaking unncessarily.+ - so use this instead to avoid quickcheck tests breaking unnecessarily.  -}  newtype TestableString = TestableString 	{ fromTestableString :: String }@@ -46,7 +46,7 @@  -  - No real-world filename can be empty or contain a NUL. So code can  - well be written that assumes that and using this avoids quickcheck- - tests breaking unncessarily.+ - tests breaking unnecessarily.  -}  newtype TestableFilePath = TestableFilePath 	{ fromTestableFilePath :: FilePath }

@@ -58,7 +58,7 @@  - This is unfortunately needed because of an infelicity in the SOP  - standard, as documented in section 9.9 "Be Careful with Special  - Designators", when using "@FD:" and similar designators the SOP- - command may test for the presense of a file with the same name on the+ - command may test for the presence of a file with the same name on the  - filesystem, and fail with  AMBIGUOUS_INPUT.   -  - Since we don't want to need to deal with such random failure due to

@@ -1,5 +1,5 @@ Name: git-annex-Version: 10.20240430+Version: 10.20240531 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -580,6 +580,7 @@     Author     Backend     Backend.External+    Backend.GitRemoteAnnex     Backend.Hash     Backend.URL     Backend.Utilities@@ -606,6 +607,7 @@     CmdLine.GitAnnexShell.Fields     CmdLine.AnnexSetter     CmdLine.Option+    CmdLine.GitRemoteAnnex     CmdLine.GitRemoteTorAnnex     CmdLine.Seek     CmdLine.Usage@@ -758,6 +760,7 @@     Git.AutoCorrect     Git.Branch     Git.BuildVersion+    Git.Bundle     Git.CatFile     Git.CheckAttr     Git.CheckIgnore@@ -939,6 +942,7 @@     Types.Export     Types.FileMatcher     Types.GitConfig+    Types.GitRemoteAnnex     Types.Group     Types.Import     Types.IndexFiles

@@ -1,6 +1,6 @@ {- git-annex main program dispatch  -- - 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.  -}@@ -13,6 +13,7 @@  import qualified CmdLine.GitAnnex import qualified CmdLine.GitAnnexShell+import qualified CmdLine.GitRemoteAnnex import qualified CmdLine.GitRemoteTorAnnex import qualified Test import qualified Benchmark@@ -35,6 +36,7 @@   where 	run ps n = case takeFileName n of 		"git-annex-shell" -> CmdLine.GitAnnexShell.run ps+		"git-remote-annex" -> CmdLine.GitRemoteAnnex.run ps 		"git-remote-tor-annex" -> CmdLine.GitRemoteTorAnnex.run ps 		_  -> CmdLine.GitAnnex.run Test.optParser Test.runner Benchmark.mkGenerator ps