git-annex 10.20220724 → 10.20220822

raw patch · 78 files changed

+588/−319 lines, 78 filesdep ~Win32

Dependency ranges changed: Win32

Files

• Annex.hs +7/−1
• Annex/AdjustedBranch/Merge.hs +3/−3
• Annex/Branch.hs +12/−7
• Annex/ChangedRefs.hs +1/−1
• Annex/Common.hs +1/−1
• Annex/Concurrent.hs +5/−1
• Annex/Content/PointerFile.hs +1/−1
• Annex/Content/Presence.hs +2/−2
• Annex/HashObject.hs +37/−18
• Annex/Import.hs +4/−2
• Annex/Init.hs +20/−2
• Annex/Journal.hs +3/−1
• Annex/Locations.hs +37/−30
• Annex/LockFile.hs +9/−13
• Annex/Perms.hs +7/−4
• Annex/Queue.hs +5/−3
• Annex/ReplaceFile.hs +1/−1
• Annex/Tmp.hs +2/−2
• Annex/Url.hs +4/−2
• Annex/Version.hs +2/−2
• Annex/Wanted.hs +2/−2
• Assistant/Threads/Merger.hs +1/−1
• Assistant/Threads/TransferScanner.hs +1/−1
• Assistant/TransferQueue.hs +1/−1
• Assistant/TransferSlots.hs +1/−1
• CHANGELOG +45/−14
• CmdLine/GitAnnex/Options.hs +19/−2
• CmdLine/Seek.hs +1/−1
• Command.hs +10/−1
• Command/Add.hs +42/−36
• Command/AddUrl.hs +2/−1
• Command/Copy.hs +1/−1
• Command/Find.hs +3/−1
• Command/Import.hs +1/−1
• Command/Move.hs +6/−3
• Command/Sync.hs +1/−1
• Config/Smudge.hs +1/−1
• Database/ContentIdentifier.hs +1/−1
• Database/Export.hs +9/−6
• Database/Fsck.hs +8/−6
• Database/Handle.hs +1/−1
• Database/Init.hs +6/−1
• Database/Keys.hs +13/−11
• Database/Keys/SQL.hs +1/−1
• Git/Repair.hs +1/−1
• Limit/Wanted.hs +15/−2
• Logs/File.hs +5/−6
• Logs/Smudge.hs +4/−2
• Logs/Upgrade.hs +3/−2
• Remote/Borg.hs +1/−1
• Remote/Bup.hs +43/−22
• Remote/Directory.hs +6/−6
• Remote/Directory/LegacyChunked.hs +1/−1
• Remote/GCrypt.hs +2/−2
• Remote/Git.hs +3/−4
• Remote/Helper/ExportImport.hs +7/−4
• Test.hs +3/−1
• Types/Command.hs +3/−0
• Types/GitConfig.hs +4/−0
• Types/Key.hs +1/−1
• Upgrade.hs +17/−8
• Upgrade/V7.hs +5/−6
• Upgrade/V9.hs +6/−4
• Utility/Directory/Create.hs +27/−24
• Utility/LockFile/Windows.hs +15/−5
• Utility/Process.hs +1/−0
• Utility/ResourcePool.hs +1/−1
• Utility/Url.hs +6/−2
• doc/git-annex-add.mdwn +4/−0
• doc/git-annex-adjust.mdwn +1/−1
• doc/git-annex-calckey.mdwn +1/−1
• doc/git-annex-filter-branch.mdwn +1/−1
• doc/git-annex-find.mdwn +0/−4
• doc/git-annex-import.mdwn +7/−1
• doc/git-annex-matching-options.mdwn +26/−4
• doc/git-annex.mdwn +26/−5
• git-annex.cabal +2/−2
• stack.yaml +0/−2

@@ -27,6 +27,7 @@ 	inRepo, 	fromRepo, 	calcRepo,+	calcRepo', 	getGitConfig, 	overrideGitConfig, 	changeGitRepo,@@ -175,7 +176,7 @@ 	, branchstate :: BranchState 	, repoqueue :: Maybe (Git.Queue.Queue Annex) 	, catfilehandles :: CatFileHandles-	, hashobjecthandle :: Maybe HashObjectHandle+	, hashobjecthandle :: Maybe (ResourcePool HashObjectHandle) 	, checkattrhandle :: Maybe (ResourcePool CheckAttrHandle) 	, checkignorehandle :: Maybe (ResourcePool CheckIgnoreHandle) 	, globalnumcopies :: Maybe NumCopies@@ -360,6 +361,11 @@ calcRepo a = do 	s <- getState id 	liftIO $ a (repo s) (gitconfig s)++calcRepo' :: (Git.Repo -> GitConfig -> a) -> Annex a+calcRepo' f = do+	s <- getState id+	pure $ f (repo s) (gitconfig s)  {- Gets the GitConfig settings. -} getGitConfig :: Annex GitConfig

@@ -54,7 +54,7 @@ 	nochangestomerge = return $ return True  	{- Since the adjusted branch changes files, merging tomerge-	 - directly into it would likely result in unncessary merge+	 - directly into it would likely result in unnecessary merge 	 - conflicts. To avoid those conflicts, instead merge tomerge into 	 - updatedorig. The result of the merge can the be 	 - adjusted to yield the final adjusted branch.@@ -87,7 +87,7 @@ 					whenM (doesFileExist src) $ do 						dest <- relPathDirToFile git_dir src' 						let dest' = toRawFilePath tmpgit P.</> dest-						createDirectoryUnder git_dir+						createDirectoryUnder [git_dir] 							(P.takeDirectory dest') 						void $ createLinkOrCopy src' dest' 				-- This reset makes git merge not care@@ -115,7 +115,7 @@ 		setup = do 			whenM (doesDirectoryExist d) $ 				removeDirectoryRecursive d-			createDirectoryUnder git_dir (toRawFilePath d)+			createDirectoryUnder [git_dir] (toRawFilePath d) 		cleanup _ = removeDirectoryRecursive d  	{- A merge commit has been made between the basisbranch and 

@@ -133,6 +133,11 @@ 		fromMaybe (error $ "failed to create " ++ fromRef name) 			<$> branchsha 	go False = withIndex' True $ do+		-- Create the index file. This is not necessary,+		-- except to avoid a bug in git that causes+		-- git write-tree to segfault when the index file does not+		-- exist.+		inRepo $ flip Git.UpdateIndex.streamUpdateIndex [] 		cmode <- annexCommitMode <$> Annex.getGitConfig 		cmessage <- createMessage 		inRepo $ Git.Branch.commitAlways cmode cmessage fullname []@@ -631,9 +636,9 @@ mergeIndex :: JournalLocked -> [Git.Ref] -> Annex () mergeIndex jl branches = do 	prepareModifyIndex jl-	hashhandle <- hashObjectHandle-	withCatFileHandle $ \ch ->-		inRepo $ \g -> Git.UnionMerge.mergeIndex hashhandle ch g branches+	withHashObjectHandle $ \hashhandle ->+		withCatFileHandle $ \ch ->+			inRepo $ \g -> Git.UnionMerge.mergeIndex hashhandle ch g branches  {- Removes any stale git lock file, to avoid git falling over when  - updating the index.@@ -709,10 +714,10 @@ 	g <- gitRepo 	let dir = gitAnnexJournalDir g 	(jlogf, jlogh) <- openjlog (fromRawFilePath tmpdir)-	h <- hashObjectHandle-	withJournalHandle gitAnnexJournalDir $ \jh ->-		Git.UpdateIndex.streamUpdateIndex g-			[genstream dir h jh jlogh]+	withHashObjectHandle $ \h ->+		withJournalHandle gitAnnexJournalDir $ \jh ->+			Git.UpdateIndex.streamUpdateIndex g+				[genstream dir h jh jlogh] 	commitindex 	liftIO $ cleanup (fromRawFilePath dir) jlogh jlogf   where

@@ -83,7 +83,7 @@ 	g <- gitRepo 	let gittop = Git.localGitDir g 	let refdir = gittop P.</> "refs"-	liftIO $ createDirectoryUnder gittop refdir+	liftIO $ createDirectoryUnder [gittop] refdir  	let notifyhook = Just $ notifyHook chan 	let hooks = mkWatchHooks

@@ -6,7 +6,7 @@ import Types as X import Key as X import Types.UUID as X-import Annex as X (gitRepo, inRepo, fromRepo, calcRepo)+import Annex as X (gitRepo, inRepo, fromRepo, calcRepo, calcRepo') import Annex.Locations as X import Annex.Debug as X (fastDebug, debug) import Messages as X

@@ -1,6 +1,6 @@ {- git-annex concurrent state  -- - Copyright 2015-2021 Joey Hess <id@joeyh.name>+ - Copyright 2015-2022 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -18,6 +18,7 @@ import Types.CatFileHandles import Annex.CatFile import Annex.CheckAttr+import Annex.HashObject import Annex.CheckIgnore  import qualified Data.Map as M@@ -47,14 +48,17 @@ 	fromnonconcurrent = do 		catFileStop 		checkAttrStop+		hashObjectStop 		checkIgnoreStop 		cfh <- liftIO catFileHandlesPool 		cah <- mkConcurrentCheckAttrHandle c+		hoh <- mkConcurrentHashObjectHandle c 		cih <- mkConcurrentCheckIgnoreHandle c 		Annex.changeState $ \s -> s 			{ Annex.concurrency = newc 			, Annex.catfilehandles = cfh 			, Annex.checkattrhandle = Just cah+			, Annex.hashobjecthandle = Just hoh 			, Annex.checkignorehandle = Just cih 			} 

@@ -62,7 +62,7 @@ 		let tmp' = toRawFilePath tmp 		liftIO $ writePointerFile tmp' key mode #if ! defined(mingw32_HOST_OS)-		-- Don't advance mtime; this avoids unncessary re-smudging+		-- Don't advance mtime; this avoids unnecessary re-smudging 		-- by git in some cases. 		liftIO $ maybe noop 			(\t -> touch tmp' t False)

@@ -137,7 +137,7 @@ withContentLockFile k a = do 	v <- getVersion 	if versionNeedsWritableContentFiles v-		then withSharedLock gitAnnexContentLockLock $ do+		then fromRepo gitAnnexContentLockLock >>= \lck -> withSharedLock lck $ do 			{- While the lock is held, check to see if the git 			 - config has changed, and reload it if so. This 			 - updates the annex.version after the v10 upgrade,@@ -156,7 +156,7 @@ 					reloadConfig 					getVersion 			go (v')-		else (go v)+		else go v   where 	go v = contentLockFile k v >>= a 

@@ -1,6 +1,6 @@-{- git hash-object interface, with handle automatically stored in the Annex monad+{- git hash-object interface  -- - Copyright 2016 Joey Hess <id@joeyh.name>+ - Copyright 2016-2022 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -8,40 +8,59 @@ module Annex.HashObject ( 	hashFile, 	hashBlob,-	hashObjectHandle, 	hashObjectStop,+	mkConcurrentHashObjectHandle,+	withHashObjectHandle, ) where  import Annex.Common import qualified Git.HashObject import qualified Annex import Git.Types--hashObjectHandle :: Annex Git.HashObject.HashObjectHandle-hashObjectHandle = maybe startup return =<< Annex.getState Annex.hashobjecthandle-  where-	startup = do-		h <- inRepo $ Git.HashObject.hashObjectStart True-		Annex.changeState $ \s -> s { Annex.hashobjecthandle = Just h }-		return h+import Utility.ResourcePool+import Types.Concurrency+import Annex.Concurrent.Utility  hashObjectStop :: Annex () hashObjectStop = maybe noop stop =<< Annex.getState Annex.hashobjecthandle   where-	stop h = do-		liftIO $ Git.HashObject.hashObjectStop h+	stop p = do+		liftIO $ freeResourcePool p Git.HashObject.hashObjectStop 		Annex.changeState $ \s -> s { Annex.hashobjecthandle = Nothing }-		return ()  hashFile :: RawFilePath -> Annex Sha-hashFile f = do-	h <- hashObjectHandle+hashFile f = withHashObjectHandle $ \h ->  	liftIO $ Git.HashObject.hashFile h f  {- Note that the content will be written to a temp file.  - So it may be faster to use Git.HashObject.hashObject for large  - blob contents. -} hashBlob :: Git.HashObject.HashableBlob b => b -> Annex Sha-hashBlob content = do-	h <- hashObjectHandle+hashBlob content = withHashObjectHandle $ \h -> 	liftIO $ Git.HashObject.hashBlob h content++withHashObjectHandle :: (Git.HashObject.HashObjectHandle -> Annex a) -> Annex a+withHashObjectHandle a =+	maybe mkpool go =<< Annex.getState Annex.hashobjecthandle+  where+	go p = withResourcePool p start a+	start = inRepo $ Git.HashObject.hashObjectStart True+	mkpool = do+		-- This only runs in non-concurrent code paths;+		-- a concurrent pool is set up earlier when needed.+		p <- mkResourcePoolNonConcurrent start+		Annex.changeState $ \s -> s { Annex.hashobjecthandle = Just p }+		go p++mkConcurrentHashObjectHandle :: Concurrency -> Annex (ResourcePool Git.HashObject.HashObjectHandle)+mkConcurrentHashObjectHandle c =+        Annex.getState Annex.hashobjecthandle >>= \case+                Just p@(ResourcePool {}) -> return p+                _ -> mkResourcePool =<< liftIO (maxHashObjects c)++{- git hash-object is typically CPU bound, and is not likely to be the main+ - bottleneck for any command. So limit to the number of CPU cores, maximum,+ - while respecting the -Jn value.+ -}+maxHashObjects :: Concurrency -> IO Int+maxHashObjects = concurrencyUpToCpus

@@ -412,8 +412,10 @@ 		| importcontent = a 		| otherwise = reuseVectorClockWhile a -	withciddb = withExclusiveLock gitAnnexContentIdentifierLock .-		bracket CIDDb.openDb CIDDb.closeDb+	withciddb a = do+		cidlck <- calcRepo' gitAnnexContentIdentifierLock+		withExclusiveLock cidlck $+			bracket CIDDb.openDb CIDDb.closeDb a  	run cidmap importing db = do 		largematcher <- largeFilesMatcher

@@ -1,6 +1,6 @@ {- git-annex repository initialization  -- - Copyright 2011-2021 Joey Hess <id@joeyh.name>+ - Copyright 2011-2022 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -27,6 +27,7 @@ import Git.Types (fromConfigValue) import Git.ConfigTypes (SharedRepository(..)) import qualified Annex.Branch+import qualified Database.Fsck import Logs.UUID import Logs.Trust.Basic import Logs.Config@@ -69,7 +70,9 @@  checkInitializeAllowed :: Annex a -> Annex a checkInitializeAllowed a = guardSafeToUseRepo $ noAnnexFileContent' >>= \case-	Nothing -> a+	Nothing -> do+		checkSqliteWorks+		a 	Just noannexmsg -> do 		warning "Initialization prevented by .noannex file (remove the file to override)" 		unless (null noannexmsg) $@@ -390,6 +393,21 @@ 	warning "Detected a filesystem without fifo support." 	warning "Disabling ssh connection caching." 	setConfig (annexConfig "sshcaching") (Git.Config.boolConfig False)++{- Sqlite needs the filesystem to support range locking. Some like CIFS+ - do not, which will cause sqlite to fail with ErrorBusy. -}+checkSqliteWorks :: Annex ()+checkSqliteWorks = do+	u <- getUUID+	tryNonAsync (Database.Fsck.openDb u >>= Database.Fsck.closeDb) >>= \case+		Right () -> return ()+		Left e -> do+			showLongNote $ "Detected a filesystem where Sqlite does not work."+			showLongNote $ "(" ++ show e ++ ")"+			showLongNote $ "To work around this problem, you can set annex.dbdir " +++				"to a directory on another filesystem."+			showLongNote $ "For example: git config annex.dbdir $HOME/cache/git-annex"+			giveup "Not initialized."  checkSharedClone :: Annex Bool checkSharedClone = inRepo Git.Objects.isSharedClone

@@ -281,4 +281,6 @@ {- Runs an action that modifies the journal, using locking to avoid  - contention with other git-annex processes. -} lockJournal :: (JournalLocked -> Annex a) -> Annex a-lockJournal a = withExclusiveLock gitAnnexJournalLock $ a ProduceJournalLocked+lockJournal a = do+	lck <- fromRepo gitAnnexJournalLock+	withExclusiveLock lck $ a ProduceJournalLocked

@@ -37,7 +37,7 @@ 	gitAnnexBadDir, 	gitAnnexBadLocation, 	gitAnnexUnusedLog,-	gitAnnexKeysDb,+	gitAnnexKeysDbDir, 	gitAnnexKeysDbLock, 	gitAnnexKeysDbIndexCache, 	gitAnnexFsckState,@@ -321,38 +321,42 @@ gitAnnexUnusedLog prefix r = gitAnnexDir r P.</> (prefix <> "unused")  {- .git/annex/keysdb/ contains a database of information about keys. -}-gitAnnexKeysDb :: Git.Repo -> RawFilePath-gitAnnexKeysDb r = gitAnnexDir r P.</> "keysdb"+gitAnnexKeysDbDir :: Git.Repo -> GitConfig -> RawFilePath+gitAnnexKeysDbDir r c = fromMaybe (gitAnnexDir r) (annexDbDir c) P.</> "keysdb"  {- Lock file for the keys database. -}-gitAnnexKeysDbLock :: Git.Repo -> RawFilePath-gitAnnexKeysDbLock r = gitAnnexKeysDb r <> ".lck"+gitAnnexKeysDbLock :: Git.Repo -> GitConfig -> RawFilePath+gitAnnexKeysDbLock r c = gitAnnexKeysDbDir r c <> ".lck"  {- Contains the stat of the last index file that was  - reconciled with the keys database. -}-gitAnnexKeysDbIndexCache :: Git.Repo -> RawFilePath-gitAnnexKeysDbIndexCache r = gitAnnexKeysDb r <> ".cache"+gitAnnexKeysDbIndexCache :: Git.Repo -> GitConfig -> RawFilePath+gitAnnexKeysDbIndexCache r c = gitAnnexKeysDbDir r c <> ".cache"  {- .git/annex/fsck/uuid/ is used to store information about incremental  - fscks. -}-gitAnnexFsckDir :: UUID -> Git.Repo -> RawFilePath-gitAnnexFsckDir u r = gitAnnexDir r P.</> "fsck" P.</> fromUUID u+gitAnnexFsckDir :: UUID -> Git.Repo -> Maybe GitConfig -> RawFilePath+gitAnnexFsckDir u r mc = case annexDbDir =<< mc of+	Nothing -> go (gitAnnexDir r)+	Just d -> go d+  where+	go d = d P.</> "fsck" P.</> fromUUID u  {- used to store information about incremental fscks. -} gitAnnexFsckState :: UUID -> Git.Repo -> RawFilePath-gitAnnexFsckState u r = gitAnnexFsckDir u r P.</> "state"+gitAnnexFsckState u r = gitAnnexFsckDir u r Nothing P.</> "state"  {- Directory containing database used to record fsck info. -}-gitAnnexFsckDbDir :: UUID -> Git.Repo -> RawFilePath-gitAnnexFsckDbDir u r = gitAnnexFsckDir u r P.</> "fsckdb"+gitAnnexFsckDbDir :: UUID -> Git.Repo -> GitConfig -> RawFilePath+gitAnnexFsckDbDir u r c = gitAnnexFsckDir u r (Just c) P.</> "fsckdb"  {- Directory containing old database used to record fsck info. -}-gitAnnexFsckDbDirOld :: UUID -> Git.Repo -> RawFilePath-gitAnnexFsckDbDirOld u r = gitAnnexFsckDir u r P.</> "db"+gitAnnexFsckDbDirOld :: UUID -> Git.Repo -> GitConfig -> RawFilePath+gitAnnexFsckDbDirOld u r c = gitAnnexFsckDir u r (Just c) P.</> "db"  {- Lock file for the fsck database. -}-gitAnnexFsckDbLock :: UUID -> Git.Repo -> RawFilePath-gitAnnexFsckDbLock u r = gitAnnexFsckDir u r P.</> "fsck.lck"+gitAnnexFsckDbLock :: UUID -> Git.Repo -> GitConfig -> RawFilePath+gitAnnexFsckDbLock u r c = gitAnnexFsckDir u r (Just c) P.</> "fsck.lck"  {- .git/annex/fsckresults/uuid is used to store results of git fscks -} gitAnnexFsckResultsLog :: UUID -> Git.Repo -> RawFilePath@@ -384,20 +388,22 @@  {- .git/annex/export/ is used to store information about  - exports to special remotes. -}-gitAnnexExportDir :: Git.Repo -> RawFilePath-gitAnnexExportDir r = gitAnnexDir r P.</> "export"+gitAnnexExportDir :: Git.Repo -> GitConfig -> RawFilePath+gitAnnexExportDir r c = fromMaybe (gitAnnexDir r) (annexDbDir c) P.</> "export"  {- Directory containing database used to record export info. -}-gitAnnexExportDbDir :: UUID -> Git.Repo -> RawFilePath-gitAnnexExportDbDir u r = gitAnnexExportDir r P.</> fromUUID u P.</> "exportdb"+gitAnnexExportDbDir :: UUID -> Git.Repo -> GitConfig -> RawFilePath+gitAnnexExportDbDir u r c = +	gitAnnexExportDir r c P.</> fromUUID u P.</> "exportdb" -{- Lock file for export state for a special remote. -}-gitAnnexExportLock :: UUID -> Git.Repo -> RawFilePath-gitAnnexExportLock u r = gitAnnexExportDbDir u r <> ".lck"+{- Lock file for export database. -}+gitAnnexExportLock :: UUID -> Git.Repo -> GitConfig -> RawFilePath+gitAnnexExportLock u r c = gitAnnexExportDbDir u r c <> ".lck" -{- Lock file for updating the export state for a special remote. -}-gitAnnexExportUpdateLock :: UUID -> Git.Repo -> RawFilePath-gitAnnexExportUpdateLock u r = gitAnnexExportDbDir u r <> ".upl"+{- Lock file for updating the export database with information from the+ - repository. -}+gitAnnexExportUpdateLock :: UUID -> Git.Repo -> GitConfig -> RawFilePath+gitAnnexExportUpdateLock u r c = gitAnnexExportDbDir u r c <> ".upl"  {- Log file used to keep track of files that were in the tree exported to a  - remote, but were excluded by its preferred content settings. -}@@ -409,12 +415,13 @@  - (This used to be "cid", but a problem with the database caused it to  - need to be rebuilt with a new name.)  -}-gitAnnexContentIdentifierDbDir :: Git.Repo -> RawFilePath-gitAnnexContentIdentifierDbDir r = gitAnnexDir r P.</> "cidsdb"+gitAnnexContentIdentifierDbDir :: Git.Repo -> GitConfig -> RawFilePath+gitAnnexContentIdentifierDbDir r c =+	fromMaybe (gitAnnexDir r) (annexDbDir c) P.</> "cidsdb"  {- Lock file for writing to the content id database. -}-gitAnnexContentIdentifierLock :: Git.Repo -> RawFilePath-gitAnnexContentIdentifierLock r = gitAnnexContentIdentifierDbDir r <> ".lck"+gitAnnexContentIdentifierLock :: Git.Repo -> GitConfig -> RawFilePath+gitAnnexContentIdentifierLock r c = gitAnnexContentIdentifierDbDir r c <> ".lck"  {- .git/annex/schedulestate is used to store information about when  - scheduled jobs were last run. -}

@@ -21,7 +21,6 @@ import Annex.Common import Annex import Types.LockCache-import qualified Git import Annex.Perms import Annex.LockPool @@ -63,9 +62,8 @@  {- Runs an action with a shared lock held. If an exclusive lock is held,  - blocks until it becomes free. -}-withSharedLock :: (Git.Repo -> RawFilePath) -> Annex a -> Annex a-withSharedLock getlockfile a = debugLocks $ do-	lockfile <- fromRepo getlockfile+withSharedLock :: RawFilePath -> Annex a -> Annex a+withSharedLock lockfile a = debugLocks $ do 	createAnnexDirectory $ P.takeDirectory lockfile 	mode <- annexFileMode 	bracket (lock mode lockfile) (liftIO . dropLock) (const a)@@ -78,16 +76,15 @@  {- Runs an action with an exclusive lock held. If the lock is already  - held, blocks until it becomes free. -}-withExclusiveLock :: (Git.Repo -> RawFilePath) -> Annex a -> Annex a-withExclusiveLock getlockfile a = bracket-	(takeExclusiveLock getlockfile)+withExclusiveLock :: RawFilePath -> Annex a -> Annex a+withExclusiveLock lockfile a = bracket+	(takeExclusiveLock lockfile) 	(liftIO . dropLock) 	(const a)  {- Takes an exclusive lock, blocking until it's free. -}-takeExclusiveLock :: (Git.Repo -> RawFilePath) -> Annex LockHandle-takeExclusiveLock getlockfile = debugLocks $ do-	lockfile <- fromRepo getlockfile+takeExclusiveLock :: RawFilePath -> Annex LockHandle+takeExclusiveLock lockfile = debugLocks $ do 	createAnnexDirectory $ P.takeDirectory lockfile 	mode <- annexFileMode 	lock mode lockfile@@ -100,9 +97,8 @@  {- Tries to take an exclusive lock and run an action. If the lock is  - already held, returns Nothing. -}-tryExclusiveLock :: (Git.Repo -> RawFilePath) -> Annex a -> Annex (Maybe a)-tryExclusiveLock getlockfile a = debugLocks $ do-	lockfile <- fromRepo getlockfile+tryExclusiveLock :: RawFilePath -> Annex a -> Annex (Maybe a)+tryExclusiveLock lockfile a = debugLocks $ do 	createAnnexDirectory $ P.takeDirectory lockfile 	mode <- annexFileMode 	bracket (lock mode lockfile) (liftIO . unlock) go

@@ -106,13 +106,16 @@ 	go _ = stdFileMode 	sharedmode = combineModes groupSharedModes -{- Creates a directory inside the gitAnnexDir, creating any parent- - directories up to and including the gitAnnexDir.+{- Creates a directory inside the gitAnnexDir (or possibly the dbdir), + - creating any parent directories up to and including the gitAnnexDir.  - Makes directories with appropriate permissions. -} createAnnexDirectory :: RawFilePath -> Annex () createAnnexDirectory dir = do 	top <- parentDir <$> fromRepo gitAnnexDir-	createDirectoryUnder' top dir createdir+	tops <- annexDbDir <$> Annex.getGitConfig >>= return . \case+		Nothing -> [top]+		Just dbdir -> [top, parentDir (parentDir dbdir)]+	createDirectoryUnder' tops dir createdir   where 	createdir p = do 		liftIO $ R.createDirectory p@@ -126,7 +129,7 @@ createWorkTreeDirectory :: RawFilePath -> Annex () createWorkTreeDirectory dir = do 	fromRepo repoWorkTree >>= liftIO . \case-		Just wt -> createDirectoryUnder wt dir+		Just wt -> createDirectoryUnder [wt] dir 		-- Should never happen, but let whatever tries to write 		-- to the directory be what throws an exception, as that 		-- will be clearer than an exception from here.

@@ -65,9 +65,11 @@  - git locking files. So, only one queue is allowed to flush at a time.  -} flush' :: Git.Queue.Queue Annex -> Annex (Git.Queue.Queue Annex)-flush' q = withExclusiveLock gitAnnexGitQueueLock $ do-	showStoringStateAction-	Git.Queue.flush q =<< gitRepo+flush' q = do+	lck <- fromRepo gitAnnexGitQueueLock+	withExclusiveLock lck $ do+		showStoringStateAction+		Git.Queue.flush q =<< gitRepo  {- Gets the size of the queue. -} size :: Annex Int

@@ -33,7 +33,7 @@ replaceGitDirFile :: FilePath -> (FilePath -> Annex a) -> Annex a replaceGitDirFile = replaceFile $ \dir -> do 	top <- fromRepo localGitDir-	liftIO $ createDirectoryUnder top dir+	liftIO $ createDirectoryUnder [top] dir  {- replaceFile on a worktree file. -} replaceWorkTreeFile :: FilePath -> (FilePath -> Annex a) -> Annex a

@@ -27,7 +27,7 @@ 	Annex.addCleanupAction OtherTmpCleanup cleanupOtherTmp 	tmpdir <- fromRepo gitAnnexTmpOtherDir 	tmplck <- fromRepo gitAnnexTmpOtherLock-	withSharedLock (const tmplck) $ do+	withSharedLock tmplck $ do 		void $ createAnnexDirectory tmpdir 		a tmpdir @@ -56,7 +56,7 @@ cleanupOtherTmp :: Annex () cleanupOtherTmp = do 	tmplck <- fromRepo gitAnnexTmpOtherLock-	void $ tryIO $ tryExclusiveLock (const tmplck) $ do+	void $ tryIO $ tryExclusiveLock tmplck $ do 		tmpdir <- fromRawFilePath <$> fromRepo gitAnnexTmpOtherDir 		void $ liftIO $ tryIO $ removeDirectoryRecursive tmpdir 		oldtmp <- fromRawFilePath <$> fromRepo gitAnnexTmpOtherDirOld

@@ -1,7 +1,7 @@ {- Url downloading, with git-annex user agent and configured http  - headers, security restrictions, etc.  -- - Copyright 2013-2020 Joey Hess <id@joeyh.name>+ - Copyright 2013-2022 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -43,6 +43,7 @@ import Network.HTTP.Client import Network.HTTP.Client.TLS import Text.Read+import qualified Data.Set as S  defaultUserAgent :: U.UserAgent defaultUserAgent = "git-annex/" ++ BuildInfo.packageversion@@ -78,7 +79,8 @@ 	checkallowedaddr = words . annexAllowedIPAddresses <$> Annex.getGitConfig >>= \case 		["all"] -> do 			curlopts <- map Param . annexWebOptions <$> Annex.getGitConfig-			let urldownloader = if null curlopts+			allowedurlschemes <- annexAllowedUrlSchemes <$> Annex.getGitConfig+			let urldownloader = if null curlopts && not (any (`S.member` U.conduitUrlSchemes) allowedurlschemes) 				then U.DownloadWithConduit $ 					U.DownloadWithCurlRestricted mempty 				else U.DownloadWithCurl curlopts

@@ -19,7 +19,7 @@ import qualified Data.Map as M  defaultVersion :: RepoVersion-defaultVersion = RepoVersion 8+defaultVersion = RepoVersion 10  latestVersion :: RepoVersion latestVersion = RepoVersion 10@@ -42,7 +42,7 @@ 	, (RepoVersion 6, defaultVersion) 	, (RepoVersion 7, defaultVersion) 	, (RepoVersion 8, defaultVersion)-	, (RepoVersion 9, latestVersion)+	, (RepoVersion 9, defaultVersion) 	]  versionField :: ConfigKey

@@ -22,8 +22,8 @@ wantGet d key file = isPreferredContent Nothing S.empty key file d  {- Check if a file is preferred content for a repository. -}-wantSend :: Bool -> Maybe Key -> AssociatedFile -> UUID -> Annex Bool-wantSend d key file to = isPreferredContent (Just to) S.empty key file d+wantGetBy :: Bool -> Maybe Key -> AssociatedFile -> UUID -> Annex Bool+wantGetBy d key file to = isPreferredContent (Just to) S.empty key file d  {- Check if a file is not preferred or required content, and can be  - dropped. When a UUID is provided, checks for that repository.

@@ -34,7 +34,7 @@ 	g <- liftAnnex gitRepo 	let gitd = Git.localGitDir g 	let dir = gitd P.</> "refs"-	liftIO $ createDirectoryUnder gitd dir+	liftIO $ createDirectoryUnder [gitd] dir 	let hook a = Just <$> asIO2 (runHandler a) 	changehook <- hook onChange 	errhook <- hook onErr

@@ -171,7 +171,7 @@ 			"expensive scan found too many copies of object" 			present key af (SeekInput []) [] callCommandAction 		ts <- if present-			then liftAnnex . filterM (wantSend True (Just key) af . Remote.uuid . fst)+			then liftAnnex . filterM (wantGetBy True (Just key) af . Remote.uuid . fst) 				=<< use syncDataRemotes (genTransfer Upload False) 			else ifM (liftAnnex $ wantGet True (Just key) af) 				( use downloadRemotes (genTransfer Download True) , return [] )

@@ -88,7 +88,7 @@ 		 - already have it. -} 		| otherwise = do 			s <- locs-			filterM (wantSend True (Just k) f . Remote.uuid) $+			filterM (wantGetBy True (Just k) f . Remote.uuid) $ 				filter (\r -> not (inset s r || Remote.readonly r)) 					(syncDataRemotes st) 	  where

@@ -212,7 +212,7 @@ 	| transferDirection t == Upload = case transferRemote info of 		Nothing -> return False 		Just r -> notinremote r-			<&&> wantSend True (Just key) file (Remote.uuid r)+			<&&> wantGetBy True (Just key) file (Remote.uuid r) 	| otherwise = return False   where 	key = transferKey t

@@ -1,3 +1,34 @@+git-annex (10.20220822) upstream; urgency=medium++  * v8 repositories now automatically upgrade to v9, which will in turn+    automatically upgrade to v10 in a year's time.+    To avoid this upgrade, you can set annex.autoupgraderepository to false.+  * Now uses v10 by default for new repositories.+  * Fix a regression in 10.20220624 that caused git-annex add to crash+    when there was an unstaged deletion.+  * Added new matching options --want-get-by and --want-drop-by.+  * Allow find --branch to be used in a bare repository, the same as+    the deprecated findref can be.+  * add --dry-run: New option. +  * import: Avoid following symbolic links inside directories being+    imported.+  * Work around bug in git 2.37 that causes a segfault+    when core.untrackedCache is set, which broke git-annex init.+  * Added annex.dbdir config which can be used to move sqlite databases+    to a different filesystem than the git-annex repo, when the repo is on+    a filesystem that sqlite does not work well in.+  * Use curl when annex.security.allowed-url-schemes includes an url+    scheme not supported by git-annex internally, as long as+    annex.security.allowed-ip-addresses is configured to allow using curl.+  * Improve output when storing to bup.+  * When bup split fails, display its stderr.+  * Avoid running multiple bup split processes concurrently, since+    bup is not concurrency safe.+  * Avoid starting an unnecessary number of git hash-object processes when +    concurrency is enabled.++ -- Joey Hess <id@joeyh.name>  Mon, 22 Aug 2022 11:56:06 -0400+ git-annex (10.20220724) upstream; urgency=medium    * filter-process: Fix a bug involving handling of empty files,@@ -379,7 +410,7 @@  git-annex (8.20210714) upstream; urgency=medium -  * assistant: Avoid unncessary git repository repair in a situation where+  * assistant: Avoid unnecessary git repository repair in a situation where     git fsck gets confused about a commit that is made while it's running.   * addurl: Avoid crashing when used on beegfs.   * --debug output goes to stderr again, not stdout.@@ -620,7 +651,7 @@     Thanks, Grond for the patch.   * Avoid crashing when there are remotes using unparseable urls.     Including the non-standard URI form that git-remote-gcrypt uses for rsync.-  * Directory special remotes with importtree=yes now avoid unncessary+  * Directory special remotes with importtree=yes now avoid unnecessary     hashing when inodes of files have changed, as happens whenever a FAT     filesystem gets remounted.   * Fix a bug that prevented git-annex init from working in a submodule.@@ -2327,7 +2358,7 @@     remotes, which used to cause eg, spin-up of removable drives.   * Added remote.<name>.annex-checkuuid config, which can be set to false     to disable the default checking of the uuid of remotes that point to-    directories. This can be useful to avoid unncessary drive spin-ups and+    directories. This can be useful to avoid unnecessary drive spin-ups and     automounting.   * git-annex.cabal: Add back custom-setup stanza, so cabal new-build works.   * git-annex.cabal: Removed the testsuite build flag; test suite is always@@ -2591,7 +2622,7 @@   * version: Added "dependency versions" line.   * Keys marked as dead are now skipped by --all.   * annex.backend is the new name for what was annex.backends, and takes-    a single key-value backend, rather than the unncessary and confusing+    a single key-value backend, rather than the unnecessary and confusing     list. The old option still works if set.   -- Joey Hess <id@joeyh.name>  Wed, 10 May 2017 15:05:22 -0400@@ -2869,7 +2900,7 @@   * S3: Support the special case endpoint needed for the cn-north-1 region.   * Webapp: Don't list the Frankfurt S3 region, as this (and some other new     regions) need V4 authorization which the aws library does not yet use.-  * reinject --known: Avoid second, unncessary checksum of file.+  * reinject --known: Avoid second, unnecessary checksum of file.   * OSX: Remove RPATHs from git-annex binary, which are not needed,     slow down startup, and break the OSX Sierra linker.   * webapp: Explicitly avoid checking for auth in static subsite@@ -2950,7 +2981,7 @@    * Rate limit console progress display updates to 10 per second.     Was updating as frequently as changes were reported, up to hundreds of-    times per second, which used unncessary bandwidth when running git-annex+    times per second, which used unnecessary bandwidth when running git-annex     over ssh etc.   * Make --json and --quiet work when used with -J.     Previously, -J override the other options.@@ -3607,7 +3638,7 @@   * copy --auto was checking the wrong repo's preferred content.     (--from was checking what --to should, and vice-versa.)     Fixed this bug, which was introduced in version 5.20150727.-  * Avoid unncessary write to the location log when a file is unlocked+  * Avoid unnecessary write to the location log when a file is unlocked     and then added back with unchanged content.   * S3: Fix support for using https.   * Avoid displaying network transport warning when a ssh remote@@ -4548,7 +4579,7 @@   * sync: Fix git sync with local git remotes even when they don't have an     annex.uuid set. (The assistant already did so.)   * Set gcrypt-publish-participants when setting up a gcrypt repository,-    to avoid unncessary passphrase prompts.+    to avoid unnecessary passphrase prompts.     This is a security/usability tradeoff. To avoid exposing the gpg key     ids who can decrypt the repository, users can unset     gcrypt-publish-participants.@@ -4570,7 +4601,7 @@   * Fix git version that supported --no-gpg-sign.   * Fix bug in automatic merge conflict resolution, when one side is an     annexed symlink, and the other side is a non-annexed symlink.-  * Really fix bug that caused the assistant to make many unncessary+  * Really fix bug that caused the assistant to make many unnecessary     empty merge commits.   -- Joey Hess <joeyh@debian.org>  Wed, 09 Jul 2014 15:28:03 -0400@@ -4578,7 +4609,7 @@ git-annex (5.20140707) unstable; urgency=medium    * assistant: Fix bug, introduced in last release, that caused the assistant-    to make many unncessary empty merge commits.+    to make many unnecessary empty merge commits.   * assistant: Fix one-way assistant->assistant sync in direct mode.   * Fix bug in annex.queuesize calculation that caused much more     queue flushing than necessary.@@ -4706,7 +4737,7 @@     connections.   * Improve handling of monthly/yearly scheduling.   * Avoid depending on shakespeare except for when building the webapp.-  * uninit: Avoid making unncessary copies of files.+  * uninit: Avoid making unnecessary copies of files.   * info: Allow use in a repository where annex.uuid is not set.   * reinit: New command that can initialize a new repository using     the configuration of a previously known repository.@@ -5541,7 +5572,7 @@   * importfeed can be used to import files from podcast feeds.   * webapp: When setting up a dedicated ssh key to access the annex     on a host, set IdentitiesOnly to prevent the ssh-agent from forcing-    use of a different ssh key. That could result in unncessary password+    use of a different ssh key. That could result in unnecessary password     prompts, or prevent git-annex-shell from being run on the remote host.   * webapp: Improve handling of remotes whose setup has stalled.   * Add status message to XMPP presence tag, to identify to others that@@ -5716,7 +5747,7 @@ git-annex (4.20130601) unstable; urgency=medium    * XMPP: Git push over xmpp made much more robust.-  * XMPP: Avoid redundant and unncessary pushes. Note that this breaks+  * XMPP: Avoid redundant and unnecessary pushes. Note that this breaks     compatibility with previous versions of git-annex, which will refuse     to accept any XMPP pushes from this version.   * XMPP: Send pings and use them to detect when contact with the server@@ -6034,7 +6065,7 @@     combines all their changes into a single commit.   * assistant: Fix ~/.ssh/git-annex-shell wrapper to work when the     ssh key does not force a command.-  * assistant: Be smarter about avoiding unncessary transfers.+  * assistant: Be smarter about avoiding unnecessary transfers.    * webapp: Work around bug in Warp's slowloris attack prevention code,     that caused regular browsers to stall when they reuse a connection

@@ -128,6 +128,12 @@ parseUUIDOption = DeferredParse 	. (Remote.nameToUUID) +parseDryRunOption :: Parser DryRun+parseDryRunOption = DryRun <$> switch+	( long "dry-run"+	<> help "don't make changes, but show what would be done"+	)+ -- | From or To a remote. data FromToOptions 	= FromRemote (DeferredParse Remote)@@ -288,12 +294,23 @@ 		) 	, annexFlag (setAnnexState Limit.Wanted.addWantGet) 		( long "want-get"-		<> help "match files the repository wants to get"+		<> help "match files the local repository wants to get" 		<> hidden 		)+	, annexOption (setAnnexState . Limit.Wanted.addWantGetBy) $ strOption+		( long "want-get-by" <> metavar paramRemote+		<> help "match files the specified repository wants to get"+		<> hidden+		<> completeRemotes+		) 	, annexFlag (setAnnexState Limit.Wanted.addWantDrop) 		( long "want-drop"-		<> help "match files the repository wants to drop"+		<> help "match files the local repository wants to drop"+		<> hidden+		)+	, annexOption (setAnnexState . Limit.Wanted.addWantDropBy) $ strOption+		( long "want-drop-by" <> metavar paramRemote+		<> help "match files the specified repository wants to drop" 		<> hidden 		) 	, annexOption (setAnnexState . Limit.addAccessedWithin) $

@@ -113,7 +113,7 @@ 		( map (\f ->  			let f' = toRawFilePath f 			in (f', P.makeRelative (P.takeDirectory (P.dropTrailingPathSeparator p')) f'))-			<$> dirContentsRecursiveSkipping (".git" `isSuffixOf`) True p+			<$> dirContentsRecursiveSkipping (".git" `isSuffixOf`) False p 		, return [(p', P.takeFileName p')] 		) 	  where

@@ -106,6 +106,12 @@ stopUnless :: Annex Bool -> Annex (Maybe a) -> Annex (Maybe a) stopUnless c a = ifM c ( a , stop ) +{- When doing a dry run, avoid actually performing the action, but pretend+ - that it succeeded. -}+skipWhenDryRun :: DryRun -> CommandPerform -> CommandPerform+skipWhenDryRun (DryRun False) a = a+skipWhenDryRun (DryRun True) _ = next $ return True+ {- When acting on a failed transfer, stops unless it was in the specified  - direction. -} checkFailedTransferDirection :: ActionItem -> Direction -> Annex (Maybe a) -> Annex (Maybe a)@@ -122,7 +128,10 @@ repoExists = CommandCheck 0 ensureInitialized  notBareRepo :: Command -> Command-notBareRepo = addCheck $ whenM (fromRepo Git.repoIsLocalBare) $+notBareRepo = addCheck checkNotBareRepo++checkNotBareRepo :: Annex ()+checkNotBareRepo = whenM (fromRepo Git.repoIsLocalBare) $ 	giveup "You cannot run this command in a bare repository."  noDaemonRunning :: Command -> Command

@@ -52,6 +52,7 @@ 	, updateOnly :: Bool 	, largeFilesOverride :: Maybe Bool 	, checkGitIgnoreOption :: CheckGitIgnore+	, dryRunOption :: DryRun 	}  optParser :: CmdParamsDesc -> Parser AddOptions@@ -65,6 +66,7 @@ 		) 	<*> (parseforcelarge <|> parseforcesmall) 	<*> checkGitIgnoreSwitch+	<*> parseDryRunOption   where 	parseforcelarge = flag Nothing (Just True) 		( long "force-large"@@ -86,21 +88,19 @@ 	addunlockedmatcher <- addUnlockedMatcher 	annexdotfiles <- getGitConfigVal annexDotFiles  	let gofile includingsmall (si, file) = case largeFilesOverride o of-		Nothing -> do-			s <- liftIO $ R.getSymbolicLinkStatus file-			ifM (pure (annexdotfiles || not (dotfile file))-				<&&> (checkFileMatcher largematcher file -				<||> Annex.getRead Annex.force))-				( start si file addunlockedmatcher-				, if includingsmall-					then ifM (annexAddSmallFiles <$> Annex.getGitConfig)-						( startSmall si file s-						, stop-						)-					else stop-				)-		Just True -> start si file addunlockedmatcher-		Just False -> startSmallOverridden si file+		Nothing -> ifM (pure (annexdotfiles || not (dotfile file))+			<&&> (checkFileMatcher largematcher file +			<||> Annex.getRead Annex.force))+			( start dr si file addunlockedmatcher+			, if includingsmall+				then ifM (annexAddSmallFiles <$> Annex.getGitConfig)+					( startSmall dr si file+					, stop+					)+				else stop+			)+		Just True -> start dr si file addunlockedmatcher+		Just False -> startSmallOverridden dr si file 	case batchOption o of 		Batch fmt 			| updateOnly o ->@@ -126,25 +126,29 @@ 			-- same as a modified unlocked file would get 			-- locked when added. 			go False withUnmodifiedUnlockedPointers+  where+	dr = dryRunOption o  {- Pass file off to git-add. -}-startSmall :: SeekInput -> RawFilePath -> FileStatus -> CommandStart-startSmall si file s =-	starting "add" (ActionItemTreeFile file) si $-		next $ addSmall file s+startSmall :: DryRun -> SeekInput -> RawFilePath -> CommandStart+startSmall dr si file =+	liftIO (catchMaybeIO $ R.getSymbolicLinkStatus file) >>= \case+		Just s -> +			starting "add" (ActionItemTreeFile file) si $+				addSmall dr file s+		Nothing -> stop -addSmall :: RawFilePath -> FileStatus -> Annex Bool-addSmall file s = do+addSmall :: DryRun -> RawFilePath -> FileStatus -> CommandPerform+addSmall dr file s = do 	showNote "non-large file; adding content to git repository"-	addFile Small file s+	skipWhenDryRun dr $ next $ addFile Small file s -startSmallOverridden :: SeekInput -> RawFilePath -> CommandStart-startSmallOverridden si file = +startSmallOverridden :: DryRun -> SeekInput -> RawFilePath -> CommandStart+startSmallOverridden dr si file =  	liftIO (catchMaybeIO $ R.getSymbolicLinkStatus file) >>= \case-		Just s -> starting "add" (ActionItemTreeFile file) si $ next $ do-			+		Just s -> starting "add" (ActionItemTreeFile file) si $ do 			showNote "adding content to git repository"-			addFile Small file s+			skipWhenDryRun dr $ next $ addFile Small file s 		Nothing -> stop  data SmallOrLarge = Small | Large@@ -188,8 +192,8 @@ 		isRegularFile a /= isRegularFile b || 		isSymbolicLink a /= isSymbolicLink b -start :: SeekInput -> RawFilePath -> AddUnlockedMatcher -> CommandStart-start si file addunlockedmatcher = +start :: DryRun -> SeekInput -> RawFilePath -> AddUnlockedMatcher -> CommandStart+start dr si file addunlockedmatcher =  	liftIO (catchMaybeIO $ R.getSymbolicLinkStatus file) >>= \case 		Nothing -> stop 		Just s@@ -200,16 +204,17 @@   where 	go s = ifAnnexed file (addpresent s) (add s) 	add s = starting "add" (ActionItemTreeFile file) si $-		if isSymbolicLink s-			then next $ addFile Small file s-			else perform file addunlockedmatcher+		skipWhenDryRun dr $+			if isSymbolicLink s+				then next $ addFile Small file s+				else perform file addunlockedmatcher 	addpresent s key 		| isSymbolicLink s = fixuplink key 		| otherwise = add s 	fixuplink key =  		starting "add" (ActionItemTreeFile file) si $ 			addingExistingLink file key $-				withOtherTmp $ \tmp -> do+				skipWhenDryRun dr $ withOtherTmp $ \tmp -> do 					let tmpf = tmp P.</> P.takeFileName file 					liftIO $ moveFile file tmpf 					ifM (isSymbolicLink <$> liftIO (R.getSymbolicLinkStatus tmpf))@@ -223,9 +228,10 @@ 						) 	fixuppointer s key = 		starting "add" (ActionItemTreeFile file) si $-			addingExistingLink file key $ do-				Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath file)-				next $ addFile Large file s+			addingExistingLink file key $+				skipWhenDryRun dr $ do+					Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath file)+					next $ addFile Large file s  perform :: RawFilePath -> AddUnlockedMatcher -> CommandPerform perform file addunlockedmatcher = withOtherTmp $ \tmpdir -> do

@@ -476,7 +476,8 @@ 					(fromRawFilePath file) 					(fromRawFilePath tmp) 				go-			else void $ Command.Add.addSmall file s+			else Command.Add.addSmall (DryRun False) file s+				>>= maybe noop void   where 	go = do 		maybeShowJSON $ JSONChunk [("key", serializeKey key)]

@@ -82,5 +82,5 @@ 		Right (FromRemote _) -> checkwantget 		Left ToHere -> checkwantget 			-	checkwantsend = wantSend False (Just key) (AssociatedFile (Just file))+	checkwantsend = wantGetBy False (Just key) (AssociatedFile (Just file)) 	checkwantget = wantGet False (Just key) (AssociatedFile (Just file))

@@ -21,7 +21,7 @@ import Utility.DataUnits  cmd :: Command-cmd = notBareRepo $ withAnnexOptions [annexedMatchingOptions] $ mkCommand $+cmd = withAnnexOptions [annexedMatchingOptions] $ mkCommand $ 	command "find" SectionQuery "lists available files" 		paramPaths (seek <$$> optParser) @@ -55,6 +55,8 @@  seek :: FindOptions -> CommandSeek seek o = do+	unless (isJust (keyOptions o)) $+		checkNotBareRepo 	islimited <- limited 	let seeker = AnnexedFileSeeker 		{ startAction = start o

@@ -248,7 +248,7 @@ 				>>= maybe 					stop 					(\addedk -> next $ Command.Add.cleanup addedk True)-			, next $ Command.Add.addSmall destfile s+			, Command.Add.addSmall (DryRun False) destfile s 			) 	notoverwriting why = do 		warning $ "not overwriting existing " ++ fromRawFilePath destfile ++ " " ++ why

@@ -375,12 +375,14 @@  	setup = do 		logf <- fromRepo gitAnnexMoveLog+		lckf <- fromRepo gitAnnexMoveLock 		-- Only log when there was no copy. 		unless deststartedwithcopy $-			appendLogFile logf gitAnnexMoveLock logline+			appendLogFile logf lckf logline 		return logf  	cleanup logf = do+		lck <- fromRepo gitAnnexMoveLock 		-- This buffers the log file content in memory. 		-- The log file length is limited to the number of 		-- concurrent jobs, times the number of times a move@@ -388,13 +390,14 @@ 		-- That could grow without bounds given enough time, 		-- so the log is also truncated to the most recent 		-- 100 items.-		modifyLogFile logf gitAnnexMoveLock+		modifyLogFile logf lck 			(filter (/= logline) . reverse . take 100 . reverse)  	go logf 		-- Only need to check log when there is a copy. 		| deststartedwithcopy = do-			wasnocopy <- checkLogFile (fromRawFilePath logf) gitAnnexMoveLock+			lck <- fromRepo gitAnnexMoveLock+			wasnocopy <- checkLogFile (fromRawFilePath logf) lck 				(== logline) 			if wasnocopy 				then go' logf False

@@ -855,7 +855,7 @@ 	wantput r 		| Remote.readonly r || remoteAnnexReadOnly (Remote.gitconfig r) = return False 		| isThirdPartyPopulated r = return False-		| otherwise = wantSend True (Just k) af (Remote.uuid r)+		| otherwise = wantGetBy True (Just k) af (Remote.uuid r) 	handleput lack inhere 		| inhere = catMaybes <$> 			( forM lack $ \r ->

@@ -41,7 +41,7 @@ 	gfs <- readattr gf 	gittop <- Git.localGitDir <$> gitRepo 	liftIO $ unless ("filter=annex" `isInfixOf` (lfs ++ gfs)) $ do-		createDirectoryUnder gittop (P.takeDirectory lf)+		createDirectoryUnder [gittop] (P.takeDirectory lf) 		writeFile (fromRawFilePath lf) (lfs ++ "\n" ++ unlines stdattr)   where 	readattr = liftIO . catchDefaultIO "" . readFileStrict . fromRawFilePath

@@ -78,7 +78,7 @@  -} openDb :: Annex ContentIdentifierHandle openDb = do-	dbdir <- fromRepo gitAnnexContentIdentifierDbDir+	dbdir <- calcRepo' gitAnnexContentIdentifierDbDir 	let db = dbdir P.</> "db" 	ifM (liftIO $ not <$> R.doesPathExist db) 		( initDb db $ void $ 

@@ -99,7 +99,7 @@  -} openDb :: UUID -> Annex ExportHandle openDb u = do-	dbdir <- fromRepo (gitAnnexExportDbDir u)+	dbdir <- calcRepo' (gitAnnexExportDbDir u) 	let db = dbdir P.</> "db" 	unlessM (liftIO $ R.doesPathExist db) $ do 		initDb db $ void $@@ -263,8 +263,9 @@  -} writeLockDbWhile :: ExportHandle -> Annex a -> Annex a writeLockDbWhile db@(ExportHandle _ u) a = do-	updatelck <- takeExclusiveLock (gitAnnexExportUpdateLock u)-	withExclusiveLock (gitAnnexExportLock u) $ do+	updatelck <- takeExclusiveLock =<< calcRepo' (gitAnnexExportUpdateLock u)+	exlck <- calcRepo' (gitAnnexExportLock u)+	withExclusiveLock exlck $ do 		bracket_ (setup updatelck) cleanup a   where 	setup updatelck = do@@ -285,15 +286,17 @@  - not. Either way, it will block until the update is complete.  -} updateExportTreeFromLog :: ExportHandle -> Annex ExportUpdateResult-updateExportTreeFromLog db@(ExportHandle _ u) =+updateExportTreeFromLog db@(ExportHandle _ u) = do 	-- If another process or thread is performing the update, 	-- this will block until it's done.-	withExclusiveLock (gitAnnexExportUpdateLock u) $ do+	exlck <- calcRepo' (gitAnnexExportUpdateLock u)+	withExclusiveLock exlck $ do+		lck <- calcRepo' (gitAnnexExportLock u) 		-- If the database is locked by something else, 		-- this will not run the update. But, in that case, 		-- writeLockDbWhile is running, and has already 		-- completed the update, so we don't need to do anything.-		mr <- tryExclusiveLock (gitAnnexExportLock u) $+		mr <- tryExclusiveLock lck $ 			updateExportTreeFromLog' db 		case mr of 			Just r -> return r

@@ -60,29 +60,31 @@  - or unknown behavior.  -} newPass :: UUID -> Annex Bool-newPass u = isJust <$> tryExclusiveLock (gitAnnexFsckDbLock u) go+newPass u = do+	lck <- calcRepo' (gitAnnexFsckDbLock u)+	isJust <$> tryExclusiveLock lck go   where 	go = do-		removedb =<< fromRepo (gitAnnexFsckDbDir u)-		removedb =<< fromRepo (gitAnnexFsckDbDirOld u)+		removedb =<< calcRepo' (gitAnnexFsckDbDir u)+		removedb =<< calcRepo' (gitAnnexFsckDbDirOld u) 	removedb = liftIO . void . tryIO . removeDirectoryRecursive . fromRawFilePath  {- Opens the database, creating it if it doesn't exist yet. -} openDb :: UUID -> Annex FsckHandle openDb u = do-	dbdir <- fromRepo (gitAnnexFsckDbDir u)+	dbdir <- calcRepo' (gitAnnexFsckDbDir u) 	let db = dbdir P.</> "db" 	unlessM (liftIO $ R.doesPathExist db) $ do 		initDb db $ void $ 			runMigrationSilent migrateFsck-	lockFileCached =<< fromRepo (gitAnnexFsckDbLock u)+	lockFileCached =<< calcRepo' (gitAnnexFsckDbLock u) 	h <- liftIO $ H.openDbQueue db "fscked" 	return $ FsckHandle h u  closeDb :: FsckHandle -> Annex () closeDb (FsckHandle h u) = do 	liftIO $ H.closeDbQueue h-	unlockFile =<< fromRepo (gitAnnexFsckDbLock u)+	unlockFile =<< calcRepo' (gitAnnexFsckDbLock u)  addDb :: FsckHandle -> Key -> IO () addDb (FsckHandle h _) k = H.queueDb h checkcommit $

@@ -123,7 +123,7 @@ 	newconn = do 		v <- tryNonAsync (runSqliteRobustly tablename db loop) 		case v of-			Left e -> hPutStrLn stderr $+			Left e -> giveup $ 				"sqlite worker thread crashed: " ++ show e 			Right cont -> cont 	

@@ -10,6 +10,7 @@ module Database.Init where  import Annex.Common+import qualified Annex import Annex.Perms import Utility.FileMode import Utility.Directory.Create@@ -34,9 +35,13 @@ 	let tmpdbdir = dbdir <> ".tmp" 	let tmpdb = tmpdbdir P.</> "db" 	let tdb = T.pack (fromRawFilePath tmpdb)+	gc <- Annex.getGitConfig 	top <- parentDir <$> fromRepo gitAnnexDir+	let tops = case annexDbDir gc of+		Just topdbdir -> [top, parentDir (parentDir topdbdir)]+		Nothing -> [top] 	liftIO $ do-		createDirectoryUnder top tmpdbdir+		createDirectoryUnder tops tmpdbdir 		runSqliteInfo (enableWAL tdb) migration 	setAnnexDirPerm tmpdbdir 	-- Work around sqlite bug that prevents it from honoring

@@ -118,15 +118,17 @@ openDb :: Bool -> DbState -> Annex DbState openDb _ st@(DbOpen _) = return st openDb False DbUnavailable = return DbUnavailable-openDb forwrite _ = catchPermissionDenied permerr $ withExclusiveLock gitAnnexKeysDbLock $ do-	dbdir <- fromRepo gitAnnexKeysDb-	let db = dbdir P.</> "db"-	dbexists <- liftIO $ R.doesPathExist db-	case dbexists of-		True -> open db-		False -> do-			initDb db SQL.createTables-			open db+openDb forwrite _ = do+	lck <- calcRepo' gitAnnexKeysDbLock+	catchPermissionDenied permerr $ withExclusiveLock lck $ do+		dbdir <- calcRepo' gitAnnexKeysDbDir+		let db = dbdir P.</> "db"+		dbexists <- liftIO $ R.doesPathExist db+		case dbexists of+			True -> open db+			False -> do+				initDb db SQL.createTables+				open db   where 	-- If permissions don't allow opening the database, and it's being 	-- opened for read, treat it as if it does not exist.@@ -224,7 +226,7 @@  - This is run with a lock held, so only one process can be running this at  - a time.  -- - To avoid unncessary work, the index file is statted, and if it's not+ - To avoid unnecessary work, the index file is statted, and if it's not  - changed since last time this was run, nothing is done.  -  - A tree is generated from the index, and the diff between that tree@@ -248,7 +250,7 @@ reconcileStaged :: H.DbQueue -> Annex () reconcileStaged qh = unlessM (Git.Config.isBare <$> gitRepo) $ do 	gitindex <- inRepo currentIndexFile-	indexcache <- fromRawFilePath <$> fromRepo gitAnnexKeysDbIndexCache+	indexcache <- fromRawFilePath <$> calcRepo' gitAnnexKeysDbIndexCache 	withTSDelta (liftIO . genInodeCache gitindex) >>= \case 		Just cur -> readindexcache indexcache >>= \case 			Nothing -> go cur indexcache =<< getindextree

@@ -140,7 +140,7 @@ 		| sentinalInodesChanged s = 			-- Note that this select is intentionally not 			-- indexed. Normally, the inodes have not changed,-			-- and it would be unncessary work to maintain+			-- and it would be unnecessary work to maintain 			-- indexes for the unusual case. 			[ ContentFilesize ==. inodeCacheToFileSize i 			, ContentMtime >=. tmin

@@ -269,7 +269,7 @@ 		let gitd = localGitDir r 		let dest = gitd P.</> fromRef' ref 		let dest' = fromRawFilePath dest-		createDirectoryUnder gitd (parentDir dest)+		createDirectoryUnder [gitd] (parentDir dest) 		unlessM (doesFileExist dest') $ 			writeFile dest' (fromRef sha) 

@@ -12,14 +12,27 @@ import Limit import Types.FileMatcher import Logs.PreferredContent+import qualified Remote  addWantGet :: Annex () addWantGet = addPreferredContentLimit $ 	checkWant $ wantGet False Nothing +addWantGetBy :: String -> Annex ()+addWantGetBy name = do+	u <- Remote.nameToUUID name+	addPreferredContentLimit $ checkWant $ \af ->+		wantGetBy False Nothing af u+ addWantDrop :: Annex ()-addWantDrop = addPreferredContentLimit $-	checkWant $ \af -> wantDrop False Nothing Nothing af (Just [])+addWantDrop = addPreferredContentLimit $ checkWant $ \af ->+	wantDrop False Nothing Nothing af (Just [])++addWantDropBy :: String -> Annex ()+addWantDropBy name = do+	u <- Remote.nameToUUID name+	addPreferredContentLimit $ checkWant $ \af ->+		wantDrop False (Just u) Nothing af (Just [])  addPreferredContentLimit :: (MatchInfo -> Annex Bool) -> Annex () addPreferredContentLimit a = do

@@ -1,6 +1,6 @@ {- git-annex log files  -- - Copyright 2018-2020 Joey Hess <id@joeyh.name>+ - Copyright 2018-2022 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -20,7 +20,6 @@ import Annex.Perms import Annex.LockFile import Annex.ReplaceFile-import qualified Git import Utility.Tmp  import qualified Data.ByteString.Lazy as L@@ -51,7 +50,7 @@  -- | Appends a line to a log file, first locking it to prevent -- concurrent writers.-appendLogFile :: RawFilePath -> (Git.Repo -> RawFilePath) -> L.ByteString -> Annex ()+appendLogFile :: RawFilePath -> RawFilePath -> L.ByteString -> Annex () appendLogFile f lck c =  	createDirWhenNeeded f $ 		withExclusiveLock lck $ do@@ -69,7 +68,7 @@ -- -- The file is locked to prevent concurrent writers, and it is written -- atomically.-modifyLogFile :: RawFilePath -> (Git.Repo -> RawFilePath) -> ([L.ByteString] -> [L.ByteString]) -> Annex ()+modifyLogFile :: RawFilePath -> RawFilePath -> ([L.ByteString] -> [L.ByteString]) -> Annex () modifyLogFile f lck modf = withExclusiveLock lck $ do 	ls <- liftIO $ fromMaybe [] 		<$> tryWhenExists (L8.lines <$> L.readFile f')@@ -89,7 +88,7 @@ -- action is concurrently modifying the file. It does not lock the file, -- for speed, but instead relies on the fact that a log file usually -- ends in a newline.-checkLogFile :: FilePath -> (Git.Repo -> RawFilePath) -> (L.ByteString -> Bool) -> Annex Bool+checkLogFile :: FilePath -> RawFilePath -> (L.ByteString -> Bool) -> Annex Bool checkLogFile f lck matchf = withExclusiveLock lck $ bracket setup cleanup go   where 	setup = liftIO $ tryWhenExists $ openFile f ReadMode@@ -123,7 +122,7 @@ --  -- Locking is used to prevent writes to to the log file while this -- is running.-streamLogFile :: FilePath -> (Git.Repo -> RawFilePath) -> (String -> Annex ()) -> Annex ()+streamLogFile :: FilePath -> RawFilePath -> (String -> Annex ()) -> Annex () streamLogFile f lck a = withExclusiveLock lck $ bracketOnError setup cleanup go   where 	setup = liftIO $ tryWhenExists $ openFile f ReadMode 

@@ -19,7 +19,8 @@ smudgeLog :: Key -> TopFilePath -> Annex () smudgeLog k f = do 	logf <- fromRepo gitAnnexSmudgeLog-	appendLogFile logf gitAnnexSmudgeLock $ L.fromStrict $+	lckf <- fromRepo gitAnnexSmudgeLock+	appendLogFile logf lckf $ L.fromStrict $ 		serializeKey' k <> " " <> getTopFilePath f  -- | Streams all smudged files, and then empties the log at the end.@@ -32,7 +33,8 @@ streamSmudged :: (Key -> TopFilePath -> Annex ()) -> Annex () streamSmudged a = do 	logf <- fromRepo gitAnnexSmudgeLog-	streamLogFile (fromRawFilePath logf) gitAnnexSmudgeLock $ \l -> +	lckf <- fromRepo gitAnnexSmudgeLock+	streamLogFile (fromRawFilePath logf) lckf $ \l ->  		case parse l of 			Nothing -> noop 			Just (k, f) -> a k f

@@ -24,8 +24,9 @@  writeUpgradeLog :: RepoVersion -> POSIXTime-> Annex () writeUpgradeLog v t = do-	logfile <- fromRepo gitAnnexUpgradeLog-	appendLogFile logfile gitAnnexUpgradeLock $ encodeBL $+	logf <- fromRepo gitAnnexUpgradeLog+	lckf <- fromRepo gitAnnexUpgradeLock+	appendLogFile logf lckf $ encodeBL $ 		show (fromRepoVersion v) ++ " " ++ show t  readUpgradeLog :: Annex [(RepoVersion, POSIXTime)]

@@ -223,7 +223,7 @@ 			    (reqsz, retsz) = case extra of 				" link to " -> (Nothing, fromMaybe sz . fromKey keySize) 				_ -> (Just sz, const sz)-			-- This does a little unncessary work to parse the +			-- This does a little unnecessary work to parse the  			-- key, which is then thrown away. But, it lets the 			-- file list be shrank down to only the ones that are 			-- importable keys, so avoids needing to buffer all

@@ -1,18 +1,20 @@ {- Using bup as a remote.  -- - Copyright 2011-2020 Joey Hess <id@joeyh.name>+ - Copyright 2011-2022 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -} -{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RankNTypes, OverloadedStrings #-}  module Remote.Bup (remote) where  import qualified Data.Map as M import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L+import qualified System.FilePath.ByteString as P import Data.ByteString.Lazy.UTF8 (fromString)+import Control.Concurrent.Async  import Annex.Common import qualified Annex@@ -34,6 +36,8 @@ import Utility.UserInfo import Annex.UUID import Annex.Ssh+import Annex.LockFile+import Annex.Perms import Utility.Metered import Types.ProposedAccepted @@ -109,7 +113,7 @@ 		} 	return $ Just $ specialRemote' specialcfg c 		(store this buprepo)-		(retrieve buprepo)+		(retrieve this buprepo) 		(remove buprepo) 		(checkKey bupr') 		this@@ -154,43 +158,47 @@ 		(os ++ [Param "-q", Param "-n", Param (bupRef k)] ++ src)  store :: Remote -> BupRepo -> Storer-store r buprepo = byteStorer $ \k b p -> do-	showOutput -- make way for bup output-	quiet <- commandProgressDisabled+store r buprepo = byteStorer $ \k b p -> lockBup True r $ do 	liftIO $ withNullHandle $ \nullh -> 		let params = bupSplitParams r buprepo k [] 		    cmd = (proc "bup" (toCommand params))-			{ std_in = CreatePipe }-		    cmd' = if quiet-			then cmd -				{ std_out = UseHandle nullh-				, std_err = UseHandle nullh-				}-			else cmd+			{ std_in = CreatePipe+			, std_out = UseHandle nullh+			, std_err = CreatePipe+			} 		    feeder = \h -> do 			meteredWrite p (S.hPut h) b 			hClose h-		in withCreateProcess cmd' (go feeder cmd')+		in withCreateProcess cmd (go feeder cmd)   where-	go feeder p (Just h) _ _ pid =-		forceSuccessProcess p pid-			`after`-		feeder h+	go feeder p (Just inh) _ (Just errh) pid = do+		-- bup split is noisy to stderr even with the -q+		-- option. But when bup fails, the stderr needs+		-- to be displayed.+		(feedresult, erroutput) <- tryNonAsync (feeder inh)+			`concurrently` hGetContentsStrict errh+		waitForProcess pid >>= \case+			ExitSuccess -> case feedresult of+				Right () -> return ()+				Left e -> throwM e+			ExitFailure n -> giveup $ +				showCmd p ++ " exited " ++ show n +++					" (stderr output: " ++ erroutput ++ ")" 	go _ _ _ _ _ _ = error "internal" -retrieve :: BupRepo -> Retriever-retrieve buprepo = byteRetriever $ \k sink -> do+retrieve :: Remote -> BupRepo -> Retriever+retrieve r buprepo = byteRetriever $ \k sink -> lockBup True r $ do 	let params = bupParams "join" buprepo [Param $ bupRef k] 	let p = (proc "bup" (toCommand params)) 		{ std_out = CreatePipe } 	bracketIO (createProcess p) cleanupProcess (go sink p)   where 	go sink p (_, Just h, _, pid) = do-		r <- sink =<< liftIO (L.hGetContents h)+		v <- sink =<< liftIO (L.hGetContents h) 		liftIO $ do 			hClose h 			forceSuccessProcess p pid-		return r+		return v 	go _ _ _ = error "internal"  {- Cannot revert having stored a key in bup, but at least the data for the@@ -317,3 +325,16 @@  bupLocal :: BupRepo -> Bool bupLocal = notElem ':'++{- Bup is not concurrency safe, so use a lock file. Only one writer process+ - should run at a time; multiple readers may run if no writer is running. -}+lockBup :: Bool -> Remote -> Annex a -> Annex a+lockBup writer r a = do+	dir <- fromRepo gitAnnexRemotesDir+	unlessM (liftIO $ doesDirectoryExist (fromRawFilePath dir)) $+		createAnnexDirectory dir+	let remoteid = fromUUID (uuid r)+	let lck = dir P.</> remoteid <> ".lck"+	if writer+		then withExclusiveLock lck a+		else withSharedLock lck a

@@ -182,7 +182,7 @@ storeKeyM d chunkconfig cow k c m =  	ifM (checkDiskSpaceDirectory d k) 		( do-			void $ liftIO $ tryIO $ createDirectoryUnder d tmpdir+			void $ liftIO $ tryIO $ createDirectoryUnder [d] tmpdir 			store 		, giveup "Not enough free disk space." 		)@@ -229,7 +229,7 @@ finalizeStoreGeneric :: RawFilePath -> RawFilePath -> RawFilePath -> IO () finalizeStoreGeneric d tmp dest = do 	removeDirGeneric (fromRawFilePath d) dest'-	createDirectoryUnder d (parentDir dest)+	createDirectoryUnder [d] (parentDir dest) 	renameDirectory (fromRawFilePath tmp) dest' 	-- may fail on some filesystems 	void $ tryIO $ do@@ -309,7 +309,7 @@  storeExportM :: RawFilePath -> CopyCoWTried -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex () storeExportM d cow src _k loc p = do-	liftIO $ createDirectoryUnder d (P.takeDirectory dest)+	liftIO $ createDirectoryUnder [d] (P.takeDirectory dest) 	-- Write via temp file so that checkPresentGeneric will not 	-- see it until it's fully stored. 	viaTmp go (fromRawFilePath dest) ()@@ -337,7 +337,7 @@  renameExportM :: RawFilePath -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe ()) renameExportM d _k oldloc newloc = liftIO $ do-	createDirectoryUnder d (P.takeDirectory dest)+	createDirectoryUnder [d] (P.takeDirectory dest) 	renameFile (fromRawFilePath src) (fromRawFilePath dest) 	removeExportLocation d oldloc 	return (Just ())@@ -363,7 +363,7 @@  listImportableContentsM :: IgnoreInodes -> RawFilePath -> Annex (Maybe (ImportableContentsChunkable Annex (ContentIdentifier, ByteSize))) listImportableContentsM ii dir = liftIO $ do-	l <- dirContentsRecursive (fromRawFilePath dir)+	l <- dirContentsRecursiveSkipping (const False) False (fromRawFilePath dir) 	l' <- mapM (go . toRawFilePath) l 	return $ Just $ ImportableContentsComplete $ 		ImportableContents (catMaybes l') []@@ -502,7 +502,7 @@  storeExportWithContentIdentifierM :: IgnoreInodes -> RawFilePath -> CopyCoWTried -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier storeExportWithContentIdentifierM ii dir cow src _k loc overwritablecids p = do-	liftIO $ createDirectoryUnder dir (toRawFilePath destdir)+	liftIO $ createDirectoryUnder [dir] (toRawFilePath destdir) 	withTmpFileIn destdir template $ \tmpf tmph -> do 		liftIO $ hClose tmph 		void $ liftIO $ fileCopier cow src tmpf p Nothing

@@ -79,7 +79,7 @@ storeHelper :: FilePath -> (RawFilePath -> RawFilePath -> IO ()) -> Key -> ([FilePath] -> IO [FilePath]) -> FilePath -> FilePath -> IO () storeHelper repotop finalizer key storer tmpdir destdir = do 	void $ liftIO $ tryIO $ createDirectoryUnder-		(toRawFilePath repotop)+		[toRawFilePath repotop] 		(toRawFilePath tmpdir) 	Legacy.storeChunks key tmpdir destdir storer recorder (legacyFinalizer finalizer)   where

@@ -355,7 +355,7 @@  -  - (For shared encryption, gcrypt's default behavior is used.)  -- - Also, sets gcrypt-publish-participants to avoid unncessary gpg+ - Also, sets gcrypt-publish-participants to avoid unnecessary gpg  - passphrase prompts.  -} setGcryptEncryption :: ParsedRemoteConfig -> String -> Annex ()@@ -388,7 +388,7 @@ 	| not $ Git.repoIsUrl repo =  		byteStorer $ \k b p -> guardUsable repo (giveup "cannot access remote") $ liftIO $ do 			let tmpdir = Git.repoPath repo P.</> "tmp" P.</> keyFile k-			void $ tryIO $ createDirectoryUnder (Git.repoPath repo) tmpdir+			void $ tryIO $ createDirectoryUnder [Git.repoPath repo] tmpdir 			let tmpf = tmpdir P.</> keyFile k 			meteredWriteFile p (fromRawFilePath tmpf) b 			let destdir = parentDir $ toRawFilePath $ gCryptLocation repo k

@@ -407,10 +407,9 @@   where 	checkhttp = do 		gc <- Annex.getGitConfig-		ifM (Url.withUrlOptionsPromptingCreds $ \uo -> anyM (\u -> Url.checkBoth u (fromKey keySize key) uo) (keyUrls gc repo rmt key))-			( return True-			, giveup "not found"-			)+		Url.withUrlOptionsPromptingCreds $ \uo -> +			anyM (\u -> Url.checkBoth u (fromKey keySize key) uo)+				(keyUrls gc repo rmt key) 	checkremote = P2PHelper.checkpresent (Ssh.runProto rmt connpool (cantCheck rmt)) key 	checklocal = ifM duc 		( guardUsable repo (cantCheck repo) $

@@ -143,7 +143,7 @@ 			else importUnsupported 		, storeKey = \k af p -> 			-- Storing a key on an export could be implemented,-			-- but it would perform unncessary work+			-- but it would perform unnecessary work 			-- when another repository has already stored the 			-- key, and the local repository does not know 			-- about it. To avoid unnecessary costs, don't do it.@@ -245,7 +245,8 @@ 			oldcids <- liftIO $ concat 				<$> mapM (ContentIdentifier.getContentIdentifiers db rs) oldks 			newcid <- storeExportWithContentIdentifier (importActions r) f k loc oldcids p-			withExclusiveLock gitAnnexContentIdentifierLock $ do+			cidlck <- calcRepo' gitAnnexContentIdentifierLock+			withExclusiveLock cidlck $ do 				liftIO $ ContentIdentifier.recordContentIdentifier db rs newcid k 				liftIO $ ContentIdentifier.flushDbQueue db 			recordContentIdentifier rs newcid k@@ -280,8 +281,10 @@ 				( do 					db <- ContentIdentifier.openDb 					ContentIdentifier.needsUpdateFromLog db >>= \case-						Just v -> withExclusiveLock gitAnnexContentIdentifierLock $-							ContentIdentifier.updateFromLog db v+						Just v -> do+							cidlck <- calcRepo' gitAnnexContentIdentifierLock +							withExclusiveLock cidlck $+								ContentIdentifier.updateFromLog db v 						Nothing -> noop 					liftIO $ atomically $ putTMVar dbtv db 					return db

@@ -399,6 +399,8 @@ 	createDirectory subdir 	Utility.MoveFile.moveFile (toRawFilePath annexedfile) (toRawFilePath subfile) 	git_annex "add" [subdir] "add of moved annexed file"+	git "mv" [sha1annexedfile, sha1annexedfile ++ ".renamed"] "git mv"+	git_annex "add" [] "add does not fail on deleted file after move"   where 	subdir = "subdir" 	subfile = subdir </> "file"@@ -817,7 +819,7 @@ 		Database.Keys.removeInodeCaches k 		Database.Keys.closeDb 		liftIO . removeWhenExistsWith R.removeLink-			=<< Annex.fromRepo Annex.Locations.gitAnnexKeysDbIndexCache+			=<< Annex.calcRepo' Annex.Locations.gitAnnexKeysDbIndexCache 	writecontent annexedfile "test_lock_force content" 	git_annex_shouldfail "lock" [annexedfile] "lock of modified file should not be allowed" 	git_annex "lock" ["--force", annexedfile] "lock --force of modified file"

@@ -133,3 +133,6 @@ descSection SectionPlumbing = "Plumbing commands" descSection SectionTesting = "Testing commands" descSection SectionAddOn = "Addon commands"++newtype DryRun = DryRun Bool+	deriving (Show)

@@ -53,6 +53,7 @@ import qualified Data.Set as S import qualified Data.Map as M import qualified Data.ByteString as B+import qualified System.FilePath.ByteString as P  -- | A configurable value, that may not be fully determined yet because -- the global git config has not yet been loaded.@@ -119,6 +120,7 @@ 	, annexVerify :: Bool 	, annexPidLock :: Bool 	, annexPidLockTimeout :: Seconds+	, annexDbDir :: Maybe RawFilePath 	, annexAddUnlocked :: GlobalConfigurable (Maybe String) 	, annexSecureHashesOnly :: Bool 	, annexRetry :: Maybe Integer@@ -212,6 +214,8 @@ 	, annexPidLock = getbool (annexConfig "pidlock") False 	, annexPidLockTimeout = Seconds $ fromMaybe 300 $ 		getmayberead (annexConfig "pidlocktimeout")+	, annexDbDir = (\d -> toRawFilePath d P.</> fromUUID hereuuid)+		<$> getmaybe (annexConfig "dbdir") 	, annexAddUnlocked = configurable Nothing $ 		fmap Just $ getmaybe (annexConfig "addunlocked") 	, annexSecureHashesOnly = getbool (annexConfig "securehashesonly") False

@@ -71,7 +71,7 @@ 	} deriving (Show, Generic)  instance Eq Key where-	-- comparing the serialization would be unncessary work+	-- comparing the serialization would be unnecessary work 	a == b = keyData a == keyData b  instance Ord Key where

@@ -39,7 +39,12 @@  needsUpgrade :: RepoVersion -> Annex (Maybe String) needsUpgrade v-	| v `elem` supportedVersions = ok+	| v `elem` supportedVersions = case M.lookup v autoUpgradeableVersions of+		Just newv | newv /= v -> ifM (annexAutoUpgradeRepository <$> Annex.getGitConfig)+			( runupgrade newv+			, ok+			)+		_ -> ok 	| otherwise = case M.lookup v autoUpgradeableVersions of 		Nothing 			| v `elem` upgradeableVersions ->@@ -47,10 +52,7 @@ 			| otherwise -> 				err "Upgrade git-annex." 		Just newv -> ifM (annexAutoUpgradeRepository <$> Annex.getGitConfig)-			( tryNonAsync (upgrade True newv) >>= \case-				Right True -> ok-				Right False -> err "Automatic upgrade failed!"-				Left ex -> err $ "Automatic upgrade exception! " ++ show ex+			( runupgrade newv 			, err "Automatic upgrade is disabled by annex.autoupgraderepository configuration. To upgrade this repository: git-annex upgrade" 			)   where@@ -63,14 +65,21 @@ 			, show (fromRepoVersion v) ++ "." 			, msg 			]+	 	ok = return Nothing +	runupgrade newv = tryNonAsync (upgrade True newv) >>= \case+		Right True -> ok+		Right False -> err "Automatic upgrade failed!"+		Left ex -> err $ "Automatic upgrade exception! " ++ show ex+ upgrade :: Bool -> RepoVersion -> Annex Bool upgrade automatic destversion = do-	(upgraded, newversion) <- go =<< getVersion-	when upgraded $+	startversion <- getVersion+	(ok, newversion) <- go startversion+	when (ok && newversion /= startversion) $ 		postupgrade newversion-	return upgraded+	return ok   where 	go (Just v) 		| v >= destversion = return (True, Just v)

@@ -37,17 +37,17 @@ 	-- The old content identifier database is deleted here, but the 	-- new database is not populated. It will be automatically 	-- populated from the git-annex branch the next time it is used.-	removeOldDb gitAnnexContentIdentifierDbDirOld+	removeOldDb . fromRawFilePath =<< fromRepo gitAnnexContentIdentifierDbDirOld 	liftIO . removeWhenExistsWith R.removeLink 		=<< fromRepo gitAnnexContentIdentifierLockOld  	-- The export databases are deleted here. The new databases 	-- will be populated by the next thing that needs them, the same 	-- way as they would be in a fresh clone.-	removeOldDb gitAnnexExportDir+	removeOldDb . fromRawFilePath =<< calcRepo' gitAnnexExportDir  	populateKeysDb-	removeOldDb gitAnnexKeysDbOld+	removeOldDb . fromRawFilePath =<< fromRepo gitAnnexKeysDbOld 	liftIO . removeWhenExistsWith R.removeLink 		=<< fromRepo gitAnnexKeysDbIndexCacheOld 	liftIO . removeWhenExistsWith R.removeLink@@ -72,9 +72,8 @@ gitAnnexContentIdentifierLockOld :: Git.Repo -> RawFilePath gitAnnexContentIdentifierLockOld r = gitAnnexContentIdentifierDbDirOld r <> ".lck" -removeOldDb :: (Git.Repo -> RawFilePath) -> Annex ()-removeOldDb getdb = do-	db <- fromRawFilePath <$> fromRepo getdb+removeOldDb :: FilePath -> Annex ()+removeOldDb db = 	whenM (liftIO $ doesDirectoryExist db) $ do 		v <- liftIO $ tryNonAsync $ #if MIN_VERSION_directory(1,2,7)

@@ -40,12 +40,13 @@ 	 - and it is not safe for such to still be running after 	 - this upgrade. -} 	oldprocessesdanger = timeOfUpgrade (RepoVersion 9) >>= \case-		Nothing -> pure True 		Just t -> do 			now <- liftIO getPOSIXTime-			if now - 365*24*60*60 > t+			if now < t + 365*24*60*60 				then return True-				else not <$> assistantrunning+				else assistantrunning+		-- Initialized at v9, so no old process danger exists.+		Nothing -> return False  	{- Skip upgrade when git-annex assistant (or watch) is running, 	 - because these are long-running daemons that could conceivably@@ -70,7 +71,8 @@ 	 	{- Take a lock to ensure that there are no other git-annex 	 - processes running that are using the old content locking method. -}-	withExclusiveLock gitAnnexContentLockLock $ do+	lck <- fromRepo gitAnnexContentLockLock+	withExclusiveLock lck $ do 		{- When core.sharedRepository is set, object files 		 - used to have their write bits set. That can now be 		 - removed, if the user the upgrade is running as has

@@ -31,10 +31,10 @@ import Utility.PartialPrelude  {- Like createDirectoryIfMissing True, but it will only create- - missing parent directories up to but not including the directory- - in the first parameter.+ - missing parent directories up to but not including a directory+ - from the first parameter.  -- - For example, createDirectoryUnder "/tmp/foo" "/tmp/foo/bar/baz"+ - For example, createDirectoryUnder ["/tmp/foo"] "/tmp/foo/bar/baz"  - will create /tmp/foo/bar if necessary, but if /tmp/foo does not exist,  - it will throw an exception.  -@@ -45,40 +45,43 @@  - FilePath (or the same as it), it will fail with an exception  - even if the second FilePath's parent directory already exists.  -- - Either or both of the FilePaths can be relative, or absolute.+ - The FilePaths can be relative, or absolute.   - They will be normalized as necessary.  -  - Note that, the second FilePath, if relative, is relative to the current- - working directory, not to the first FilePath.+ - working directory.  -}-createDirectoryUnder :: RawFilePath -> RawFilePath -> IO ()-createDirectoryUnder topdir dir =-	createDirectoryUnder' topdir dir R.createDirectory+createDirectoryUnder :: [RawFilePath] -> RawFilePath -> IO ()+createDirectoryUnder topdirs dir =+	createDirectoryUnder' topdirs dir R.createDirectory  createDirectoryUnder' 	:: (MonadIO m, MonadCatch m)-	=> RawFilePath+	=> [RawFilePath] 	-> RawFilePath 	-> (RawFilePath -> m ()) 	-> m ()-createDirectoryUnder' topdir dir0 mkdir = do-	p <- liftIO $ relPathDirToFile topdir dir0-	let dirs = P.splitDirectories p-	-- Catch cases where the dir is not beneath the topdir.+createDirectoryUnder' topdirs dir0 mkdir = do+	relps <- liftIO $ forM topdirs $ \topdir -> relPathDirToFile topdir dir0+	let relparts = map P.splitDirectories relps+	-- Catch cases where dir0 is not beneath a topdir. 	-- If the relative path between them starts with "..", 	-- it's not. And on Windows, if they are on different drives, 	-- the path will not be relative.-	if headMaybe dirs == Just ".." || P.isAbsolute p-		then liftIO $ ioError $ customerror userErrorType-			("createDirectoryFrom: not located in " ++ fromRawFilePath topdir)-		-- If dir0 is the same as the topdir, don't try to create-		-- it, but make sure it does exist.-		else if null dirs-			then liftIO $ unlessM (doesDirectoryExist (fromRawFilePath topdir)) $-				ioError $ customerror doesNotExistErrorType-					"createDirectoryFrom: does not exist"-			else createdirs $-				map (topdir P.</>) (reverse (scanl1 (P.</>) dirs))+	let notbeneath = \(_topdir, (relp, dirs)) -> +		headMaybe dirs /= Just ".." && not (P.isAbsolute relp)+	case filter notbeneath $ zip topdirs (zip relps relparts) of+		((topdir, (_relp, dirs)):_)+			-- If dir0 is the same as the topdir, don't try to+			-- create it, but make sure it does exist.+			| null dirs ->+				liftIO $ unlessM (doesDirectoryExist (fromRawFilePath topdir)) $+					ioError $ customerror doesNotExistErrorType $+						"createDirectoryFrom: " ++ fromRawFilePath topdir ++ " does not exist"+			| otherwise -> createdirs $+					map (topdir P.</>) (reverse (scanl1 (P.</>) dirs))+		_ -> liftIO $ ioError $ customerror userErrorType+			("createDirectoryFrom: not located in " ++ unwords (map fromRawFilePath topdirs))   where 	customerror t s = mkIOError t s Nothing (Just (fromRawFilePath dir0)) 

@@ -1,11 +1,11 @@ {- Windows lock files  -- - Copyright 2014,2021 Joey Hess <id@joeyh.name>+ - Copyright 2014,2022 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -} -{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, CPP #-}  module Utility.LockFile.Windows ( 	lockShared,@@ -48,11 +48,12 @@  -  - Will fail if the file is already open with an incompatible ShareMode.  - Note that this may happen if an unrelated process, such as a virus- - scanner, even looks at the file. See http://support.microsoft.com/kb/316609+ - scanner, even looks at the file. See Microsoft KnowledgeBase article 316609  -  - Note that createFile busy-waits to try to avoid failing when some other- - process briefly has a file open. But that would make checking locks- - much more expensive, so is not done here. Thus, the use of c_CreateFile.+ - process briefly has a file open. But that would make this busy-wait+ - whenever the file is actually locked, for a rather long period of time. + - Thus, the use of c_CreateFile.  -  - Also, passing Nothing for SECURITY_ATTRIBUTES ensures that the lock file  - is not inherited by any child process.@@ -60,12 +61,21 @@ openLock :: ShareMode -> LockFile -> IO (Maybe LockHandle) openLock sharemode f = do 	f' <- convertToNativeNamespace f+#if MIN_VERSION_Win32(2,13,3)+	r <- tryNonAsync $ createFile_NoRetry f' gENERIC_READ sharemode +		security_attributes oPEN_ALWAYS fILE_ATTRIBUTE_NORMAL+		(maybePtr Nothing)+	return $ case r of+		Left _ -> Nothing+		Right h -> Just h+#else 	h <- withTString (fromRawFilePath f') $ \c_f -> 		c_CreateFile c_f gENERIC_READ sharemode security_attributes 			oPEN_ALWAYS fILE_ATTRIBUTE_NORMAL (maybePtr Nothing) 	return $ if h == iNVALID_HANDLE_VALUE 		then Nothing 		else Just h+#endif   where 	security_attributes = maybePtr Nothing 

@@ -31,6 +31,7 @@ 	stdoutHandle, 	stderrHandle, 	processHandle,+	showCmd, 	devNull, ) where 

@@ -34,7 +34,7 @@ 		<*> newTVarIO []  {- When there will not be multiple threads that may - - may concurrently try to use it, using this is more+ - concurrently try to use it, using this is more  - efficient than mkResourcePool.  -} mkResourcePoolNonConcurrent :: (MonadMask m, MonadIO m) => m r -> m (ResourcePool r)

@@ -1,6 +1,6 @@ {- Url downloading.  -- - Copyright 2011-2021 Joey Hess <id@joeyh.name>+ - Copyright 2011-2022 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}@@ -40,6 +40,7 @@ 	noBasicAuth, 	applyBasicAuth', 	extractFromResourceT,+	conduitUrlSchemes, ) where  import Common@@ -111,9 +112,12 @@ 	<*> pure (DownloadWithConduit (DownloadWithCurlRestricted mempty)) 	<*> pure id 	<*> newManager tlsManagerSettings-	<*> pure (S.fromList $ map mkScheme ["http", "https", "ftp"])+	<*> pure conduitUrlSchemes 	<*> pure Nothing 	<*> pure noBasicAuth++conduitUrlSchemes :: S.Set Scheme+conduitUrlSchemes = S.fromList $ map mkScheme ["http", "https", "ftp"]  mkUrlOptions :: Maybe UserAgent -> Headers -> UrlDownloader -> Manager -> S.Set Scheme -> Maybe (URI -> String) -> GetBasicAuth -> UrlOptions mkUrlOptions defuseragent reqheaders urldownloader =

@@ -77,6 +77,10 @@   Like `git add --update`, this does not add new files, but any updates   to tracked files will be added to the index. +* `--dry-run`++  Output what would be done for each file, but avoid making any changes.+ * `--json`    Enable JSON output. This is intended to be parsed by programs that use

@@ -30,7 +30,7 @@ made by this command.  When in an adjusted branch, using `git merge otherbranch` is often not-ideal, because merging a non-adjusted branch may lead to unncessary+ideal, because merging a non-adjusted branch may lead to unnecessary merge conflicts, or add files in non-adjusted form. To avoid those problems, use `git annex merge otherbranch`. 

@@ -1,6 +1,6 @@ # NAME -git-annex calckey - calulate key for a file+git-annex calckey - calculate key for a file  # SYNOPSIS 

@@ -18,7 +18,7 @@ Other ways to avoid publishing information from a git-annex branch, or remove information from it include [[git-annex-forget]](1), the  `annex.private` git config, and the `--private` option to-[[git-annex-initremote](1). Those are much easier to use, but this+[[git-annex-initremote]](1). Those are much easier to use, but this provides full control for those who need it.  With no options, no information at all will be included from the git-annex

@@ -72,10 +72,6 @@   or otherwise doesn't meet the matching options, an empty line   will be output instead. -* `--batch-keys`--  This is like `--batch` but the lines read from stdin are parsed as keys.- * `-z`    Makes the `--batch` input be delimited by nulls instead of the usual

@@ -105,7 +105,8 @@  When run with a path, `git annex import` **moves** files from somewhere outside the git working copy, and adds them to the annex. In contrast to importing -from a special directory remote, imported files are **deleted from the given path**.+from a special directory remote, imported files are **deleted from the given+path**.  This is a legacy interface. It is still supported, but please consider switching to importing from a directory special remote instead, using the@@ -131,6 +132,11 @@ Several options can be used to adjust handling of duplicate files, see `--duplicate`, `--deduplicate`, `--skip-duplicates`, `--clean-duplicates`, and `--reinject-duplicates` documentation below.++symbolic links in the directory being imported are skipped to avoid+accidentially importing things outside the directory that import was ran+on. The directory that import is run on can, however inself be a symbolic+link, and that symbolic link will be followed.  # OPTIONS FOR IMPORTING FROM A DIRECTORY 

@@ -153,20 +153,42 @@  * `--want-get` -  Matches only when the preferred content settings for the repository+  Matches only when the preferred content settings for the local repository   make it want to get content. Note that this will match even when-  the content is already present, unless limited with e.g., `--not --in .`+  the content is already present, unless limited with e.g., `--not --in=here`  * `--want-drop` -  Matches only when the preferred content settings for the repository+  Matches only when the preferred content settings for the local repository   make it want to drop content. Note that this will match even when-  the content is not present, unless limited with e.g., `--in .`+  the content is not present, unless limited with e.g., `--not --in=here`    Things that this matches will not necessarily be dropped by   `git-annex drop --auto`. This does not check that there are enough copies   to drop. Also the same content may be used by a file that is not wanted   to be dropped.++* `--want-get-by=repository`++  Matches only when the preferred content settings for the specified +  repository make it want to get content. Note that this will match even when+  the content is already present in that repository, unless limited with e.g.,+  `--not --in=repository`++  The repository should be specified using the name of a configured remote,+  or the UUID or description of a repository. `--want-get-by=here`+  is the same as `--want-get`.++* `--want-drop-by=repository`++  Matches only when the preferred content settings for the specificed+  repository make it want to drop content. Note that this will match+  even when the content is not present, unless limited with e.g., +  `--not --in=repository`+ +  The repository should be specified using the name of a configured remote,+  or the UUID or description of a repository. `--want-drop-by=here`+  is the same as `--want-drop`.  * `--accessedwithin=interval` 

@@ -1181,13 +1181,18 @@  * `annex.autoupgraderepository` -  When an old git-annex repository version has become deprecated,+  When an old git-annex repository version is no longer supported,   git-annex will normally automatically upgrade the repository to-  the new version.+  the new version. It may also sometimes upgrade from an old repository+  version that is still supported but that is not as good as a later+  version.    If this is set to false, git-annex won't automatically upgrade the-  repository. Instead it will exit with an error message. You can run-  `git annex upgrade` yourself when you are ready to upgrade the+  repository. If the repository version is not supported, git-annex+  will instead exit with an error message. If it is still supported,+  git-annex will continue to work.++  You can run `git annex upgrade` yourself when you are ready to upgrade the   repository.  * `annex.crippledfilesystem`@@ -1223,6 +1228,19 @@   file system. This timeout prevents git-annex waiting forever in such a   situation. +* `annex.dbdir`++  The directory where git-annex should store its sqlite databases.+  The default location is inside `.git/annex/`. ++  Certian filesystems, such as cifs, may not support locking operations+  that sqlite needs, and setting this to a directory on another filesystem+  can work around such a problem.++  This can safely be set to the same directory in the configuration of+  multiple repositories; each repository will use a subdirectory for its+  sqlite database.+ * `annex.cachecreds`    When "true" (the default), git-annex will cache credentials used to@@ -1469,7 +1487,7 @@   Setting annex-checkuuid to false will prevent it from checking the uuid    at startup (although the uuid is still verified before making any   changes to the remote repository). This may be useful to set to prevent-  unncessary spin-up or automounting of a drive.+  unnecessary spin-up or automounting of a drive.  * `remote.<name>.annex-trustlevel` @@ -1726,6 +1744,9 @@   `git-annex addurl` a pointer to a private file located outside that   repository, possibly causing it to be copied into your repository   and transferred on to other remotes, exposing its content.++  Any url schemes supported by curl can be listed here, but you will+  also need to configure annex.allowed-ip-addresses to allow using curl.    Some special remotes support their own domain-specific URL   schemes; those are not affected by this configuration setting.

@@ -1,5 +1,5 @@ Name: git-annex-Version: 10.20220724+Version: 10.20220822 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -402,7 +402,7 @@    if (os(windows))     Build-Depends:-      Win32 (>= 2.6.1.0 && < 2.12.0.0),+      Win32 ((>= 2.6.1.0 && < 2.12.0.0) || >= 2.13.3.1),       setenv,       process (>= 1.6.2.0),       silently (>= 1.2.5.1)

@@ -26,5 +26,3 @@ - base64-bytestring-1.0.0.3 - bencode-0.6.1.1 - http-client-0.7.9-explicit-setup-deps:-  git-annex: true