packages feed

git-annex 10.20220504 → 10.20220525

raw patch · 36 files changed

+605/−335 lines, 36 files

Files

Annex/Content.hs view
@@ -64,6 +64,7 @@ 	isKeyUnlockedThin, 	getKeyStatus, 	getKeyFileStatus,+	cleanObjectDirs, ) where  import System.IO.Unsafe (unsafeInterleaveIO)@@ -89,6 +90,7 @@ import Annex.InodeSentinal import Annex.ReplaceFile import Annex.AdjustedBranch (adjustedBranchRefresh)+import Annex.DirHashes import Messages.Progress import Types.Remote (RetrievalSecurityPolicy(..), VerifyConfigA(..)) import Types.NumCopies@@ -169,13 +171,13 @@ posixLocker :: (Maybe FileMode -> LockFile -> Annex (Maybe LockHandle)) -> LockFile -> Annex (Maybe LockHandle) posixLocker takelock lockfile = do 	mode <- annexFileMode-	modifyContent lockfile $+	modifyContentDirWhenExists lockfile $ 		takelock (Just mode) lockfile #else winLocker :: (LockFile -> IO (Maybe LockHandle)) -> ContentLocker winLocker takelock _ (Just lockfile) =  	let lck = do-		modifyContent lockfile $+		modifyContentDir lockfile $ 			void $ liftIO $ tryIO $ 				writeFile (fromRawFilePath lockfile) "" 		liftIO $ takelock lockfile@@ -262,7 +264,7 @@ 	cleanuplockfile lockfile = void $ tryNonAsync $ do 		thawContentDir lockfile 		liftIO $ removeWhenExistsWith R.removeLink lockfile-		liftIO $ cleanObjectDirs lockfile+		cleanObjectDirs lockfile  {- Runs an action, passing it the temp file to get,  - and if the action succeeds, verifies the file matches@@ -407,7 +409,7 @@   where 	storeobject dest = ifM (liftIO $ R.doesPathExist dest) 		( alreadyhave-		, adjustedBranchRefresh af $ modifyContent dest $ do+		, adjustedBranchRefresh af $ modifyContentDir dest $ do 			liftIO $ moveFile 				(fromRawFilePath src) 				(fromRawFilePath dest)@@ -452,7 +454,7 @@ linkToAnnex key src srcic = ifM (checkSecureHashes' key) 	( do 		dest <- calcRepo (gitAnnexLocation key)-		modifyContent dest $ linkAnnex To key src srcic dest Nothing+		modifyContentDir dest $ linkAnnex To key src srcic dest Nothing 	, return LinkAnnexFailed 	) @@ -528,7 +530,7 @@ unlinkAnnex :: Key -> Annex () unlinkAnnex key = do 	obj <- calcRepo (gitAnnexLocation key)-	modifyContent obj $ do+	modifyContentDir obj $ do 		secureErase obj 		liftIO $ removeWhenExistsWith R.removeLink obj @@ -607,16 +609,24 @@ 		void $ tryIO $ thawContent file 		 	cleaner-	liftIO $ cleanObjectDirs file+	cleanObjectDirs file -cleanObjectDirs :: RawFilePath -> IO ()-cleanObjectDirs = go (3 :: Int)+{- Given a filename inside the object directory, tries to remove the object+ - directory, as well as the object hash directories.+ - + - Does nothing if the object directory is not empty, and does not+ - throw an exception if it's unable to remove a directory. -}+cleanObjectDirs :: RawFilePath -> Annex ()+cleanObjectDirs f = do+	HashLevels n <- objectHashLevels <$> Annex.getGitConfig+	liftIO $ go f (succ n)   where-	go 0 _ = noop-	go n file = do+	go _ 0 = noop+	go file n = do 		let dir = parentDir file-		maybe noop (const $ go (n-1) dir)-			<=< catchMaybeIO $ removeDirectory (fromRawFilePath dir)+		maybe noop (const $ go dir (n-1))+			<=< catchMaybeIO $ tryWhenExists $+				removeDirectory (fromRawFilePath dir)  {- Removes a key's file from .git/annex/objects/ -} removeAnnex :: ContentRemovalLock -> Annex ()
Annex/Content/Presence.hs view
@@ -19,6 +19,7 @@ 	isUnmodified', 	isUnmodifiedCheap, 	withContentLockFile,+	contentLockFile, ) where  import Annex.Content.Presence.LowLevel@@ -112,7 +113,7 @@ 	 - remove the lock file to clean up after ourselves. -} 	checklock (Just lockfile) contentfile = 		ifM (liftIO $ doesFileExist (fromRawFilePath contentfile))-			( modifyContent lockfile $ liftIO $+			( modifyContentDir lockfile $ liftIO $ 				lockShared lockfile >>= \case 					Nothing -> return is_locked 					Just lockhandle -> do
Annex/CopyFile.hs view
@@ -1,6 +1,6 @@ {- Copying files.  -- - 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.  -}@@ -79,40 +79,47 @@  - (eg when isStableKey is false), and doing this avoids getting a  - corrupted file in such cases.  -}-fileCopier :: CopyCoWTried -> FilePath -> FilePath -> MeterUpdate -> Maybe IncrementalVerifier -> Annex CopyMethod+fileCopier :: CopyCoWTried -> FilePath -> FilePath -> MeterUpdate -> Maybe IncrementalVerifier -> IO CopyMethod #ifdef mingw32_HOST_OS fileCopier _ src dest meterupdate iv = docopy #else fileCopier copycowtried src dest meterupdate iv =-	ifM (liftIO $ tryCopyCoW copycowtried src dest meterupdate)+	ifM (tryCopyCoW copycowtried src dest meterupdate) 		( do-			liftIO $ maybe noop unableIncrementalVerifier iv+			maybe noop unableIncrementalVerifier iv 			return CopiedCoW 		, docopy 		) #endif   where-	dest' = toRawFilePath dest- 	docopy = do 		-- The file might have had the write bit removed, 		-- so make sure we can write to it.-		void $ liftIO $ tryIO $ allowWrite dest'--		liftIO $ withBinaryFile dest ReadWriteMode $ \hdest ->-			withBinaryFile src ReadMode $ \hsrc -> do-				sofar <- compareexisting hdest hsrc zeroBytesProcessed-				docopy' hdest hsrc sofar+		void $ tryIO $ allowWrite dest' +		withBinaryFile src ReadMode $ \hsrc ->+			fileContentCopier hsrc dest meterupdate iv+		 		-- Copy src mode and mtime.-		mode <- liftIO $ fileMode <$> getFileStatus src-		mtime <- liftIO $ utcTimeToPOSIXSeconds <$> getModificationTime src-		liftIO $ setFileMode dest mode-		liftIO $ touch dest' mtime False+		mode <- fileMode <$> getFileStatus src+		mtime <- utcTimeToPOSIXSeconds <$> getModificationTime src+		setFileMode dest mode+		touch dest' mtime False  		return Copied 	-	docopy' hdest hsrc sofar = do+	dest' = toRawFilePath dest++{- Copies content from a handle to a destination file. Does not+ - use copy-on-write, and does not copy file mode and mtime.+ -}+fileContentCopier :: Handle -> FilePath -> MeterUpdate -> Maybe IncrementalVerifier -> IO ()+fileContentCopier hsrc dest meterupdate iv =+	withBinaryFile dest ReadWriteMode $ \hdest -> do+		sofar <- compareexisting hdest zeroBytesProcessed+		docopy hdest sofar+  where+	docopy hdest sofar = do 		s <- S.hGet hsrc defaultChunkSize 		if s == S.empty 			then return ()@@ -121,12 +128,12 @@ 				S.hPut hdest s 				maybe noop (flip updateIncrementalVerifier s) iv 				meterupdate sofar'-				docopy' hdest hsrc sofar'+				docopy hdest sofar'  	-- Leaves hdest and hsrc seeked to wherever the two diverge, 	-- so typically hdest will be seeked to end, and hsrc to the same 	-- position.-	compareexisting hdest hsrc sofar = do+	compareexisting hdest sofar = do 		s <- S.hGet hdest defaultChunkSize 		if s == S.empty 			then return sofar@@ -137,7 +144,7 @@ 						maybe noop (flip updateIncrementalVerifier s) iv 						let sofar' = addBytesProcessed sofar (S.length s) 						meterupdate sofar'-						compareexisting hdest hsrc sofar'+						compareexisting hdest sofar' 					else do 						seekbefore hdest s 						seekbefore hsrc s'
Annex/Import.hs view
@@ -597,14 +597,14 @@ 		getcontent k = do 			let af = AssociatedFile (Just f) 			let downloader p' tmpfile = do-				k' <- Remote.retrieveExportWithContentIdentifier+				_ <- Remote.retrieveExportWithContentIdentifier 					ia loc cid (fromRawFilePath tmpfile)-					(pure k)+					(Left k) 					(combineMeterUpdate p' p)-				ok <- moveAnnex k' af tmpfile+				ok <- moveAnnex k af tmpfile 				when ok $ 					logStatus k InfoPresent-				return (Just (k', ok))+				return (Just (k, ok)) 			checkDiskSpaceToGet k Nothing $ 				notifyTransfer Download af $ 					download' (Remote.uuid remote) k af Nothing stdRetry $ \p' ->@@ -615,9 +615,9 @@ 	-- need to retrieve this file. 	doimportsmall cidmap db loc cid sz p = do 		let downloader tmpfile = do-			k <- Remote.retrieveExportWithContentIdentifier+			(k, _) <- Remote.retrieveExportWithContentIdentifier 				ia loc cid (fromRawFilePath tmpfile)-				(mkkey tmpfile)+				(Right (mkkey tmpfile)) 				p 			case keyGitSha k of 				Just sha -> do@@ -638,9 +638,9 @@ 	dodownload cidmap db (loc, (cid, sz)) f matcher = do 		let af = AssociatedFile (Just f) 		let downloader tmpfile p = do-			k <- Remote.retrieveExportWithContentIdentifier+			(k, _) <- Remote.retrieveExportWithContentIdentifier 				ia loc cid (fromRawFilePath tmpfile)-				(mkkey tmpfile)+				(Right (mkkey tmpfile)) 				p 			case keyGitSha k of 				Nothing -> do
Annex/Init.hs view
@@ -68,7 +68,7 @@ #endif  checkInitializeAllowed :: Annex a -> Annex a-checkInitializeAllowed a = noAnnexFileContent' >>= \case+checkInitializeAllowed a = guardSafeToUseRepo $ noAnnexFileContent' >>= \case 	Nothing -> a 	Just noannexmsg -> do 		warning "Initialization prevented by .noannex file (remove the file to override)"@@ -216,7 +216,7 @@ objectDirNotPresent = do 	d <- fromRawFilePath <$> fromRepo gitAnnexObjectDir 	exists <- liftIO $ doesDirectoryExist d-	when exists $+	when exists $ guardSafeToUseRepo $ 		giveup $ unwords $  			[ "This repository is not initialized for use" 			, "by git-annex, but " ++ d ++ " exists,"@@ -227,6 +227,21 @@ 			, "to initialize with a new uuid." 			] 	return (not exists)++guardSafeToUseRepo :: Annex a -> Annex a+guardSafeToUseRepo a = do+	repopath <- fromRepo Git.repoPath+	ifM (inRepo Git.Config.checkRepoConfigInaccessible)+		( giveup $ unlines $+			[ "Git refuses to operate in this repository,"+			, "probably because it is owned by someone else."+			, ""+			-- This mirrors git's wording.+			, "To add an exception for this directory, call:"+			, "\tgit config --global --add safe.directory " ++ fromRawFilePath repopath+			]+		, a+		)  {- Initialize if it can do so automatically. Avoids failing if it cannot.  -
Annex/Locations.hs view
@@ -16,6 +16,7 @@ 	objectDir, 	objectDir', 	gitAnnexLocation,+	gitAnnexLocation', 	gitAnnexLocationDepth, 	gitAnnexLink, 	gitAnnexLinkCanonical,@@ -172,14 +173,17 @@  - be stored.  -} gitAnnexLocation :: Key -> Git.Repo -> GitConfig -> IO RawFilePath-gitAnnexLocation key r config = gitAnnexLocation' key r config+gitAnnexLocation = gitAnnexLocation' R.doesPathExist++gitAnnexLocation' :: (RawFilePath -> IO Bool) -> Key -> Git.Repo -> GitConfig -> IO RawFilePath+gitAnnexLocation' checker key r config = gitAnnexLocation'' key r config 	(annexCrippledFileSystem config) 	(coreSymlinks config)-	R.doesPathExist+	checker 	(Git.localGitDir r) -gitAnnexLocation' :: Key -> Git.Repo -> GitConfig -> Bool -> Bool -> (RawFilePath -> IO Bool) -> RawFilePath -> IO RawFilePath-gitAnnexLocation' key r config crippled symlinkssupported checker gitdir+gitAnnexLocation'' :: Key -> Git.Repo -> GitConfig -> Bool -> Bool -> (RawFilePath -> IO Bool) -> RawFilePath -> IO RawFilePath+gitAnnexLocation'' key r config crippled symlinkssupported checker gitdir 	{- Bare repositories default to hashDirLower for new 	 - content, as it's more portable. But check all locations. -} 	| Git.repoIsLocalBare r = checkall annexLocationsBare@@ -207,7 +211,7 @@ 	currdir <- R.getCurrentDirectory 	let absfile = absNormPathUnix currdir file 	let gitdir = getgitdir currdir-	loc <- gitAnnexLocation' key r config False False (\_ -> return True) gitdir+	loc <- gitAnnexLocation'' key r config False False (\_ -> return True) gitdir 	toInternalGitPath <$> relPathDirToFile (parentDir absfile) loc   where 	getgitdir currdir
Annex/Perms.hs view
@@ -26,7 +26,8 @@ 	createContentDir, 	freezeContentDir, 	thawContentDir,-	modifyContent,+	modifyContentDir,+	modifyContentDirWhenExists, 	withShared, 	hasFreezeHook, 	hasThawHook,@@ -290,11 +291,20 @@ 	dir = parentDir dest  {- Creates the content directory for a file if it doesn't already exist,- - or thaws it if it does, then runs an action to modify the file, and- - finally, freezes the content directory. -}-modifyContent :: RawFilePath -> Annex a -> Annex a-modifyContent f a = do+ - or thaws it if it does, then runs an action to modify a file in the+ - directory, and finally, freezes the content directory. -}+modifyContentDir :: RawFilePath -> Annex a -> Annex a+modifyContentDir f a = do 	createContentDir f -- also thaws it+	v <- tryNonAsync a+	freezeContentDir f+	either throwM return v++{- Like modifyContentDir, but avoids creating the content directory if it+ - does not already exist. In that case, the action will probably fail. -}+modifyContentDirWhenExists :: RawFilePath -> Annex a -> Annex a+modifyContentDirWhenExists f a = do+	thawContentDir f 	v <- tryNonAsync a 	freezeContentDir f 	either throwM return v
Annex/Verify.hs view
@@ -1,6 +1,6 @@ {- verification  -- - Copyright 2010-2021 Joey Hess <id@joeyh.name>+ - Copyright 2010-2022 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -17,6 +17,7 @@ 	isVerifiable, 	startVerifyKeyContentIncrementally, 	finishVerifyKeyContentIncrementally,+	verifyKeyContentIncrementally, 	IncrementalVerifier(..), 	tailVerify, ) where@@ -34,6 +35,7 @@ import Types.Key  import Control.Concurrent.STM+import Control.Concurrent.Async import qualified Data.ByteString as S #if WITH_INOTIFY import qualified System.INotify as INotify@@ -79,15 +81,19 @@ 		( verify 		, return True 		)-	(_, MustVerify) -> verify 	(_, IncompleteVerify _) -> ifM (shouldVerify v) 		( verify 		, return True 		)+	(_, MustVerify) -> verify+	(_, MustFinishIncompleteVerify _) -> verify   where 	verify = enteringStage VerifyStage $ 		case verification of-			IncompleteVerify iv -> resumeVerifyKeyContent k f iv+			IncompleteVerify iv -> +				resumeVerifyKeyContent k f iv+			MustFinishIncompleteVerify iv -> +				resumeVerifyKeyContent k f iv 			_ -> verifyKeyContent k f  verifyKeyContent :: Key -> RawFilePath -> Annex Bool@@ -182,12 +188,17 @@ 		-- Incremental verification was not able to be done. 		Nothing -> return (True, UnVerified) --- | Reads the file as it grows, and feeds it to the incremental verifier.+verifyKeyContentIncrementally :: VerifyConfig -> Key -> (Maybe IncrementalVerifier -> Annex ()) -> Annex Verification+verifyKeyContentIncrementally verifyconfig k a = do+	miv <- startVerifyKeyContentIncrementally verifyconfig k+	a miv+	snd <$> finishVerifyKeyContentIncrementally miv++-- | Runs a writer action that retrieves to a file. In another thread,+-- reads the file as it grows, and feeds it to the incremental verifier. -- --- The TMVar must start out empty, and be filled once whatever is--- writing to the file finishes. Once the writer finishes, this returns--- quickly. It may not feed the entire content of the file to the--- incremental verifier.+-- Once the writer finishes, this returns quickly. It may not feed+-- the entire content of the file to the incremental verifier. -- -- The file does not need to exist yet when this is called. It will wait -- for the file to appear before opening it and starting verification.@@ -219,9 +230,19 @@ -- and if the disk is slow, the reader may never catch up to the writer, -- and the disk cache may never speed up reads. So this should only be -- used when there's not a better way to incrementally verify.-tailVerify :: IncrementalVerifier -> RawFilePath -> TMVar () -> IO ()+tailVerify :: Maybe IncrementalVerifier -> RawFilePath -> Annex a -> Annex a+tailVerify (Just iv) f writer = do+	finished <- liftIO newEmptyTMVarIO+	t <- liftIO $ async $ tailVerify' iv f finished+	let finishtail = do+		liftIO $ atomically $ putTMVar finished ()+		liftIO (wait t)+	writer `finally` finishtail+tailVerify Nothing _ writer = writer++tailVerify' :: IncrementalVerifier -> RawFilePath -> TMVar () -> IO () #if WITH_INOTIFY-tailVerify iv f finished = +tailVerify' iv f finished =  	tryNonAsync go >>= \case 		Right r -> return r 		Left _ -> unableIncrementalVerifier iv@@ -308,5 +329,5 @@  	chunk = 65536 #else-tailVerify iv _ _ = unableIncrementalVerifier iv+tailVerify' iv _ _ = unableIncrementalVerifier iv #endif
Annex/YoutubeDl.hs view
@@ -295,4 +295,4 @@  	parsebytes = readSize units . takeWhile (not . isSpace) -	units = memoryUnits ++ storageUnits+	units = committeeUnits ++ storageUnits
CHANGELOG view
@@ -1,3 +1,29 @@+git-annex (10.20220525) upstream; urgency=medium++  * Special remotes with importtree=yes or exporttree=yes are once again+    treated as untrusted, since files stored in them can be deleted or+    modified at any time.+    (Fixes a reversion in 8.20201129)+  * Added support for "megabit" and related bandwidth units+    in annex.stalldetection and everywhere else that git-annex parses+    data units. Note that the short form is "Mbit" not "Mb" because+    that differs from "MB" only in case, and git-annex parses units+    case-insensitively.+  * Special remotes using exporttree=yes and/or importtree=yes now+    checksum content while it is being retrieved, instead of in a separate+    pass at the end.+  * fsck: Fix situations where the annex object file is stored in a+    directory structure other than where annex symlinks point to.+  * Deal with git's recent changes to fix CVE-2022-24765, which prevent+    using git in a repository owned by someone else.+  * Improve an error message displayed in that situation.+  * Prevent git-annex init incorrectly reinitializing the repository in+    that situation.+  * test: When limiting tests to run with -p, work around tasty limitation+    by automatically including dependent tests.++ -- Joey Hess <id@joeyh.name>  Wed, 25 May 2022 13:44:46 -0400+ git-annex (10.20220504) upstream; urgency=medium    * Ignore annex.numcopies set to 0 in gitattributes or git config,
Command/Fix.hs view
@@ -78,7 +78,7 @@ 			error "unable to break hard link" 		thawContent tmp' 		Database.Keys.storeInodeCaches key [tmp']-		modifyContent obj $ freezeContent obj+		modifyContentDir obj $ freezeContent obj 	next $ return True  makeHardLink :: RawFilePath -> Key -> CommandPerform
Command/Fsck.hs view
@@ -1,6 +1,6 @@ {- git-annex command  -- - Copyright 2010-2021 Joey Hess <id@joeyh.name>+ - Copyright 2010-2022 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -16,9 +16,11 @@ import qualified Types.Backend import qualified Backend import Annex.Content+import Annex.Content.Presence import Annex.Content.Presence.LowLevel import Annex.Perms import Annex.Link+import Annex.Version import Logs.Location import Logs.Trust import Logs.Activity@@ -134,6 +136,7 @@ 	check 		-- order matters 		[ fixLink key file+		, fixObjectLocation key 		, verifyLocationLog key keystatus ai 		, verifyRequiredContent key ai 		, verifyAssociatedFiles key keystatus file@@ -242,6 +245,58 @@ 			liftIO $ R.removeLink file 			addAnnexLink want file 		| otherwise = noop++{- A repository that supports symlinks and is not bare may have in the past+ - been bare, or not supported symlinks. If so, the object may be located+ - in a directory other than the one where annex symlinks point to. Moves+ - the object in that case.+ -+ - Also if a repository has been converted to bare, or moved to a crippled+ - filesystem not supporting symlinks, the object file will be moved+ - to the other location.+ -}+fixObjectLocation :: Key -> Annex Bool+fixObjectLocation key = do+#ifdef mingw32_HOST_OS+	-- Windows does not allow locked files to be renamed, but annex+	-- links are also not used on Windows.+	return True+#else+	loc <- calcRepo (gitAnnexLocation key)+	idealloc <- calcRepo (gitAnnexLocation' (const (pure True)) key)+	if loc == idealloc+		then return True+		else ifM (liftIO $ R.doesPathExist loc)+			( moveobjdir loc idealloc+				`catchNonAsync` \_e -> return True+			, return True+			)+  where+	moveobjdir src dest = do+		let srcdir = parentDir src+		let destdir = parentDir dest+		showNote "normalizing object location"+		-- When the content file is moved, it will+		-- appear to other processes as if it has been removed.+		-- That should never happen to a process that has used+		-- lockContentShared, so avoid it by locking the content+		-- for removal, although it's not really being removed.+		lockContentForRemoval key (return True) $ \_lck -> do+			-- Thaw the content directory to allow renaming it.+			thawContentDir src+			createAnnexDirectory (parentDir destdir)+			liftIO $ renameDirectory+				(fromRawFilePath srcdir)+				(fromRawFilePath destdir)+			-- Since the directory was moved, lockContentForRemoval+			-- will not be able to remove the lock file it+			-- made. So, remove the lock file here.+			mlockfile <- contentLockFile key =<< getVersion+			liftIO $ maybe noop (removeWhenExistsWith R.removeLink) mlockfile+			freezeContentDir dest+			cleanObjectDirs src+			return True+#endif  {- Checks that the location log reflects the current status of the key,  - in this repository only. -}
Command/Info.hs view
@@ -422,7 +422,7 @@ 	-- Two bloom filters are used at the same time when running 	-- git-annex unused, so double the size of one. 	sizer <- mkSizer-	size <- sizer memoryUnits False . (* 2) . fromIntegral . fst <$>+	size <- sizer committeeUnits False . (* 2) . fromIntegral . fst <$> 		lift bloomBitsHashes  	return $ size ++ note
Command/Lock.hs view
@@ -77,13 +77,13 @@ 	breakhardlink obj = whenM (catchBoolIO $ (> 1) . linkCount <$> liftIO (R.getFileStatus obj)) $ do 		mfc <- withTSDelta (liftIO . genInodeCache file) 		unlessM (sameInodeCache obj (maybeToList mfc)) $ do-			modifyContent obj $ replaceGitAnnexDirFile (fromRawFilePath obj) $ \tmp -> do+			modifyContentDir obj $ replaceGitAnnexDirFile (fromRawFilePath obj) $ \tmp -> do 				unlessM (checkedCopyFile key obj (toRawFilePath tmp) Nothing) $ 					giveup "unable to lock file" 			Database.Keys.storeInodeCaches key [obj]  	-- Try to repopulate obj from an unmodified associated file.-	repopulate obj = modifyContent obj $ do+	repopulate obj = modifyContentDir obj $ do 		g <- Annex.gitRepo 		fs <- map (`fromTopFilePath` g) 			<$> Database.Keys.getAssociatedFiles key
Command/TestRemote.hs view
@@ -354,7 +354,7 @@ 		liftIO $ hClose h 		tryNonAsync (Remote.retrieveExport ea k testexportlocation tmp nullMeterUpdate) >>= \case 			Left _ -> return False-			Right () -> verifyKeyContentPostRetrieval RetrievalAllKeysSecure AlwaysVerify UnVerified k (toRawFilePath tmp)+			Right v -> verifyKeyContentPostRetrieval RetrievalAllKeysSecure AlwaysVerify v k (toRawFilePath tmp) 	checkpresentexport ea k = Remote.checkPresentExport ea k testexportlocation 	removeexport ea k = Remote.removeExport ea k testexportlocation 	removeexportdirectory ea = case Remote.removeExportDirectory ea of
Crypto.hs view
@@ -3,7 +3,7 @@  - Currently using gpg; could later be modified to support different  - crypto backends if neccessary.  -- - 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.  -}@@ -22,7 +22,8 @@ 	genSharedCipher, 	genSharedPubKeyCipher, 	updateCipherKeyIds,-	decryptCipher,		+	decryptCipher,+	decryptCipher', 	encryptKey, 	isEncKey, 	feedFile,@@ -147,10 +148,13 @@  {- Decrypting an EncryptedCipher is expensive; the Cipher should be cached. -} decryptCipher :: LensGpgEncParams c => Gpg.GpgCmd -> c -> StorableCipher -> IO Cipher-decryptCipher _ _ (SharedCipher t) = return $ Cipher t-decryptCipher _ _ (SharedPubKeyCipher t _) = return $ MacOnlyCipher t-decryptCipher cmd c (EncryptedCipher t variant _) =-	mkCipher <$> Gpg.pipeStrict cmd params t+decryptCipher cmd c cip = decryptCipher' cmd Nothing c cip++decryptCipher' :: LensGpgEncParams c => Gpg.GpgCmd -> Maybe [(String, String)] -> c -> StorableCipher -> IO Cipher+decryptCipher' _ _ _ (SharedCipher t) = return $ Cipher t+decryptCipher' _ _ _ (SharedPubKeyCipher t _) = return $ MacOnlyCipher t+decryptCipher' cmd environ c (EncryptedCipher t variant _) =+	mkCipher <$> Gpg.pipeStrict' cmd params environ t   where 	mkCipher = case variant of 		Hybrid -> Cipher
Git/Config.hs view
@@ -1,6 +1,6 @@ {- git repository configuration handling  -- - Copyright 2010-2020 Joey Hess <id@joeyh.name>+ - Copyright 2010-2022 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -22,6 +22,7 @@ import qualified Git.Command import qualified Git.Construct import Utility.UserInfo+import Utility.Process.Transcript  {- Returns a single git config setting, or a fallback value if not set. -} get :: ConfigKey -> ConfigValue -> Repo -> ConfigValue@@ -273,3 +274,19 @@ 	)   where 	ps = [Param "config", Param "--unset-all", Param (decodeBS k)]++{- git "fixed" CVE-2022-24765 by preventing git-config from+ - listing per-repo configs when the repo is not owned by+ - the current user. Detect if this fix is in effect for the+ - repo.+ -}+checkRepoConfigInaccessible :: Repo -> IO Bool+checkRepoConfigInaccessible r = do+	-- Cannot use gitCommandLine here because specifying --git-dir+	-- will bypass the git security check.+	let p = (proc "git" ["config", "--local", "--list"])+		{ cwd = Just (fromRawFilePath (repoPath r))+		, env = gitEnv r+		}+	(_out, ok) <- processTranscript' p Nothing+	return (not ok)
Remote/Adb.hs view
@@ -1,6 +1,6 @@ {- Remote on Android device accessed using adb.  -- - 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.  -}@@ -22,6 +22,7 @@ import Utility.Metered import Types.ProposedAccepted import Annex.SpecialRemote.Config+import Annex.Verify  import qualified Data.Map as M import qualified System.FilePath.Posix as Posix@@ -255,8 +256,11 @@   where 	dest = androidExportLocation adir loc -retrieveExportM :: AndroidSerial -> AndroidPath -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex ()-retrieveExportM serial adir _k loc dest _p = retrieve' serial src dest+retrieveExportM :: AndroidSerial -> AndroidPath -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Verification+retrieveExportM serial adir k loc dest _p = +	verifyKeyContentIncrementally AlwaysVerify k $ \iv ->+		tailVerify iv (toRawFilePath dest) $+			retrieve' serial src dest   where 	src = androidExportLocation adir loc @@ -334,15 +338,23 @@ -- connection is resonably 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 -> Annex Key -> MeterUpdate -> Annex Key-retrieveExportWithContentIdentifierM serial adir loc cid dest mkkey _p = do-	retrieve' serial src dest-	k <- mkkey-	currcid <- getExportContentIdentifier serial adir loc-	if currcid == Right (Just cid)-		then return k-		else giveup "the file on the android device has changed"+retrieveExportWithContentIdentifierM :: AndroidSerial -> AndroidPath -> ExportLocation -> ContentIdentifier -> FilePath -> Either Key (Annex Key) -> MeterUpdate -> Annex (Key, Verification)+retrieveExportWithContentIdentifierM serial adir loc cid dest gk _p = do+	case gk of+		Right mkkey -> do+			go+			k <- mkkey+			return (k, UnVerified)+		Left k -> do+			v <- verifyKeyContentIncrementally DefaultVerify k+				(\iv -> tailVerify iv (toRawFilePath dest) go)+			return (k, v)   where+	go = do+		retrieve' serial src dest+		currcid <- getExportContentIdentifier serial adir loc+		when (currcid /= Right (Just cid)) $+			giveup "the file on the android device has changed" 	src = androidExportLocation adir loc  storeExportWithContentIdentifierM :: AndroidSerial -> AndroidPath -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier
Remote/Borg.hs view
@@ -29,6 +29,7 @@ import Logs.Export import qualified Remote.Helper.ThirdPartyPopulated as ThirdPartyPopulated import Utility.Env+import Annex.Verify  import Data.Either import Text.Read@@ -370,10 +371,20 @@ 			, giveup $ "Unable to access borg repository " ++ locBorgRepo borgrepo 			) -retrieveExportWithContentIdentifierM :: BorgRepo -> ImportLocation -> ContentIdentifier -> FilePath -> Annex Key -> MeterUpdate -> Annex Key-retrieveExportWithContentIdentifierM borgrepo loc _ dest mkk _ = do+retrieveExportWithContentIdentifierM :: BorgRepo -> ImportLocation -> ContentIdentifier -> FilePath -> Either Key (Annex Key) -> MeterUpdate -> Annex (Key, Verification)+retrieveExportWithContentIdentifierM borgrepo loc _ dest gk _ = do 	showOutput-	prompt $ withOtherTmp $ \othertmp -> liftIO $ do+	case gk of+		Right mkkey -> do+			go+			k <- mkkey+			return (k, UnVerified)+		Left k -> do+			v <- verifyKeyContentIncrementally DefaultVerify k +				(\iv -> tailVerify iv (toRawFilePath dest) go)+			return (k, v)+  where+	go = prompt $ withOtherTmp $ \othertmp -> liftIO $ do 		-- borgrepo could be relative, and borg has to be run 		-- in the temp directory to get it to write there 		absborgrepo <- absBorgRepo borgrepo@@ -398,6 +409,5 @@ 		-- combine with </> 		moveFile (fromRawFilePath othertmp </> fromRawFilePath archivefile) dest 		removeDirectoryRecursive (fromRawFilePath othertmp)-	mkk-  where+ 	(archivename, archivefile) = extractImportLocation loc
Remote/Directory.hs view
@@ -36,6 +36,7 @@ import Annex.Content import Annex.Perms import Annex.UUID+import Annex.Verify import Backend import Types.KeySource import Types.ProposedAccepted@@ -197,9 +198,9 @@ 				(fromRawFilePath destdir) 			in byteStorer go k c m 		NoChunks ->-			let go _k src p = do+			let go _k src p = liftIO $ do 				void $ fileCopier cow src tmpf p Nothing-				liftIO $ finalizeStoreGeneric d tmpdir destdir+				finalizeStoreGeneric d tmpdir destdir 			in fileStorer go k c m 		_ ->  			let go _k b p = liftIO $ do@@ -241,7 +242,7 @@ retrieveKeyFileM d (LegacyChunks _) _ = Legacy.retrieve locations d retrieveKeyFileM d NoChunks cow = fileRetriever' $ \dest k p iv -> do 	src <- liftIO $ fromRawFilePath <$> getLocation d k-	void $ fileCopier cow src (fromRawFilePath dest) p iv+	void $ liftIO $ fileCopier cow src (fromRawFilePath dest) p iv retrieveKeyFileM d _ _ = byteRetriever $ \k sink -> 	sink =<< liftIO (L.readFile . fromRawFilePath =<< getLocation d k) @@ -314,10 +315,12 @@ 	viaTmp go (fromRawFilePath dest) ()   where 	dest = exportPath d loc-	go tmp () = void $ fileCopier cow src tmp p Nothing+	go tmp () = void $ liftIO $ fileCopier cow src tmp p Nothing -retrieveExportM :: RawFilePath -> CopyCoWTried -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex ()-retrieveExportM d cow _k loc dest p = void $ fileCopier cow src dest p Nothing+retrieveExportM :: RawFilePath -> CopyCoWTried -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Verification+retrieveExportM d cow k loc dest p = +	verifyKeyContentIncrementally AlwaysVerify k $ \iv -> +		void $ liftIO $ fileCopier cow src dest p iv   where 	src = fromRawFilePath $ exportPath d loc @@ -410,25 +413,31 @@ 		, inodeCache = Nothing 		} -retrieveExportWithContentIdentifierM :: IgnoreInodes -> RawFilePath -> CopyCoWTried -> ExportLocation -> ContentIdentifier -> FilePath -> Annex Key -> MeterUpdate -> Annex Key-retrieveExportWithContentIdentifierM ii dir cow loc cid dest mkkey p = -	precheck docopy+retrieveExportWithContentIdentifierM :: IgnoreInodes -> RawFilePath -> CopyCoWTried -> ExportLocation -> ContentIdentifier -> FilePath -> Either Key (Annex Key) -> MeterUpdate -> Annex (Key, Verification)+retrieveExportWithContentIdentifierM ii dir cow loc cid dest gk p =+	case gk of+		Right mkkey -> do+			go Nothing+			k <- mkkey+			return (k, UnVerified)+		Left k -> do+			v <- verifyKeyContentIncrementally DefaultVerify k go+			return (k, v)   where 	f = exportPath dir loc 	f' = fromRawFilePath f+	+	go iv = precheck (docopy iv) -	docopy = ifM (liftIO $ tryCopyCoW cow f' dest p)-		( do-			k <- mkkey-			postcheckcow (return k)-		, docopynoncow+	docopy iv = ifM (liftIO $ tryCopyCoW cow f' dest p)+		( postcheckcow (liftIO $ maybe noop unableIncrementalVerifier iv)+		, docopynoncow iv 		) -	docopynoncow = do+	docopynoncow iv = do #ifndef mingw32_HOST_OS 		let open = do-			-- Need a duplicate fd for the post check, since-			-- hGetContentsMetered closes its handle.+			-- Need a duplicate fd for the post check. 			fd <- openFd f' ReadOnly Nothing defaultFileFlags 			dupfd <- dup fd 			h <- fdToHandle fd@@ -442,12 +451,11 @@ 		let close = hClose 		bracketIO open close $ \h -> do #endif-			liftIO $ hGetContentsMetered h p >>= L.writeFile dest-			k <- mkkey+			liftIO $ fileContentCopier h dest p iv #ifndef mingw32_HOST_OS-			postchecknoncow dupfd (return k)+			postchecknoncow dupfd (return ()) #else-			postchecknoncow (return k)+			postchecknoncow (return ()) #endif 	 	-- Check before copy, to avoid expensive copy of wrong file@@ -497,7 +505,7 @@ 	liftIO $ createDirectoryUnder dir (toRawFilePath destdir) 	withTmpFileIn destdir template $ \tmpf tmph -> do 		liftIO $ hClose tmph-		void $ fileCopier cow src tmpf p Nothing+		void $ liftIO $ fileCopier cow src tmpf p Nothing 		let tmpf' = toRawFilePath tmpf 		resetAnnexFilePerm tmpf' 		liftIO (getFileStatus tmpf) >>= liftIO . mkContentIdentifier ii tmpf' >>= \case
Remote/External.hs view
@@ -1,6 +1,6 @@ {- External special remote interface.  -- - 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.  -}@@ -37,6 +37,7 @@ import Annex.Content import Annex.Url import Annex.UUID+import Annex.Verify import Creds  import Control.Concurrent.STM@@ -291,8 +292,11 @@ 		_ -> Nothing 	req sk = TRANSFEREXPORT Upload sk f -retrieveExportM :: External -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex ()-retrieveExportM external k loc d p = either giveup return =<< go+retrieveExportM :: External -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Verification+retrieveExportM external k loc dest p = do+	verifyKeyContentIncrementally AlwaysVerify k $ \iv ->+		tailVerify iv (toRawFilePath dest) $+			either giveup return =<< go   where 	go = handleRequestExport external loc req k (Just p) $ \resp -> case resp of 		TRANSFER_SUCCESS Download k'@@ -302,7 +306,7 @@ 		UNSUPPORTED_REQUEST -> 			result $ Left "TRANSFEREXPORT not implemented by external special remote" 		_ -> Nothing-	req sk = TRANSFEREXPORT Download sk d+	req sk = TRANSFEREXPORT Download sk dest  checkPresentExportM :: External -> Key -> ExportLocation -> Annex Bool checkPresentExportM external k loc = either giveup id <$> go
Remote/Git.hs view
@@ -491,14 +491,12 @@  copyFromRemote'' :: Git.Repo -> Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification copyFromRemote'' repo r st@(State connpool _ _ _ _) key file dest meterupdate vc-	| Git.repoIsHttp repo = do-		iv <- startVerifyKeyContentIncrementally vc key+	| Git.repoIsHttp repo = verifyKeyContentIncrementally vc key $ \iv -> do 		gc <- Annex.getGitConfig 		ok <- Url.withUrlOptionsPromptingCreds $ 			Annex.Content.downloadUrl False key meterupdate iv (keyUrls gc repo r key) dest 		unless ok $ 			giveup "failed to download content"-		snd <$> finishVerifyKeyContentIncrementally iv 	| not $ Git.repoIsUrl repo = guardUsable repo (giveup "cannot access remote") $ do 		u <- getUUID 		hardlink <- wantHardLink@@ -717,7 +715,7 @@   where 	copier src dest k p check verifyconfig = do 		iv <- startVerifyKeyContentIncrementally verifyconfig k-		fileCopier copycowtried src dest p iv >>= \case+		liftIO (fileCopier copycowtried src dest p iv) >>= \case 			Copied -> ifM check 				( finishVerifyKeyContentIncrementally iv 				, do
Remote/Helper/ExportImport.hs view
@@ -216,7 +216,7 @@ 		, untrustworthy = 			if versioned || thirdPartyPopulated (remotetype r) 				then untrustworthy r-				else False+				else True 		-- git-annex testremote cannot be used to test 		-- import/export since it stores keys. 		, mkUnavailable = return Nothing@@ -349,8 +349,10 @@ 	retrieveKeyFileFromExport dbv k _af dest p = ifM (isVerifiable k) 		( do 			l <- getfirstexportloc dbv k-			retrieveExport (exportActions r) k l dest p-			return MustVerify+			retrieveExport (exportActions r) k l dest p >>= return . \case+				UnVerified -> MustVerify+				IncompleteVerify iv -> MustFinishIncompleteVerify iv+				v -> v 		, giveup $ "exported content cannot be verified due to using the " ++ decodeBS (formatKeyVariety (fromKey keyVariety k)) ++ " backend" 		) 	@@ -358,8 +360,7 @@ 		getkeycids ciddbv k >>= \case 			(cid:_) -> do 				l <- getfirstexportloc dbv k-				void $ retrieveExportWithContentIdentifier (importActions r) l cid dest (pure k) p-				return UnVerified+				snd <$> retrieveExportWithContentIdentifier (importActions r) l cid dest (Left k) p 			-- In case a content identifier is somehow missing, 			-- try this instead. 			[] -> if isexport
Remote/Helper/Special.hs view
@@ -56,8 +56,6 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.Map as M-import Control.Concurrent.STM-import Control.Concurrent.Async  {- Special remotes don't have a configured url, so Git.Repo does not  - automatically generate remotes for them. This looks for a different@@ -117,17 +115,9 @@ -- the action writes to the file, but may not be updated with the entire -- content of the file. fileRetriever :: (RawFilePath -> Key -> MeterUpdate -> Annex ()) -> Retriever-fileRetriever a = fileRetriever' $ \f k m miv -> do+fileRetriever a = fileRetriever' $ \f k m miv ->  	let retrieve = a f k m-	case miv of-		Nothing -> retrieve-		Just iv -> do-			finished <- liftIO newEmptyTMVarIO-			t <- liftIO $ async $ tailVerify iv f finished-			let finishtail = do-				liftIO $ atomically $ putTMVar finished ()-				liftIO (wait t)-			retrieve `finally` finishtail+	in tailVerify miv f retrieve  {- A Retriever that writes the content of a Key to a provided file.  - The action is responsible for updating the progress meter and the
Remote/HttpAlso.hs view
@@ -116,13 +116,13 @@  downloadKey :: Maybe URLString -> LearnedLayout -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification downloadKey baseurl ll key _af dest p vc = do-	iv <- startVerifyKeyContentIncrementally vc key-	downloadAction dest p iv key (keyUrlAction baseurl ll key)-	snd <$> finishVerifyKeyContentIncrementally iv+	verifyKeyContentIncrementally vc key $ \iv ->+		downloadAction dest p iv key (keyUrlAction baseurl ll key) -retriveExportHttpAlso :: Maybe URLString -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex ()-retriveExportHttpAlso baseurl key loc dest p = -	downloadAction dest p Nothing key (exportLocationUrlAction baseurl loc)+retriveExportHttpAlso :: Maybe URLString -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Verification+retriveExportHttpAlso baseurl key loc dest p = do+	verifyKeyContentIncrementally AlwaysVerify key $ \iv ->+		downloadAction dest p iv key (exportLocationUrlAction baseurl loc)  downloadAction :: FilePath -> MeterUpdate -> Maybe IncrementalVerifier -> Key -> ((URLString -> Annex (Either String ())) -> Annex (Either String ())) -> Annex () downloadAction dest p iv key run =
Remote/Rsync.hs view
@@ -46,6 +46,7 @@ import Utility.Tmp.Dir import Utility.SshHost import Annex.SpecialRemote.Config+import Annex.Verify  import qualified Data.Map as M @@ -316,8 +317,11 @@ 	basedest = fromRawFilePath (fromExportLocation loc) 	populatedest = liftIO . createLinkOrCopy src -retrieveExportM :: RsyncOpts -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex ()-retrieveExportM o _k loc dest p = rsyncRetrieve o [rsyncurl] dest (Just p)+retrieveExportM :: RsyncOpts -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Verification+retrieveExportM o k loc dest p =+	verifyKeyContentIncrementally AlwaysVerify k $ \iv ->+		tailVerify iv (toRawFilePath dest) $+			rsyncRetrieve o [rsyncurl] dest (Just p)   where 	rsyncurl = mkRsyncUrl o (fromRawFilePath (fromExportLocation loc))
Remote/S3.hs view
@@ -60,13 +60,13 @@ import Types.ProposedAccepted import Types.NumCopies import Utility.Metered-import Utility.Hash (IncrementalVerifier) import Utility.DataUnits import Annex.Content import qualified Annex.Url as Url import Utility.Url (extractFromResourceT) import Annex.Url (getUrlOptions, withUrlOptions, UrlOptions(..)) import Utility.Env+import Annex.Verify  type BucketName = String type BucketObject = String@@ -495,14 +495,14 @@ 		setS3VersionID info rs k mvid 		return (metag, mvid) -retrieveExportS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex ()-retrieveExportS3 hv r info _k loc f p = do+retrieveExportS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Verification+retrieveExportS3 hv r info k loc f p = verifyKeyContentIncrementally AlwaysVerify k $ \iv -> 	withS3Handle hv $ \case-		Just h -> retrieveHelper info h (Left (T.pack exportloc)) f p Nothing+		Just h -> retrieveHelper info h (Left (T.pack exportloc)) f p iv 		Nothing -> case getPublicUrlMaker info of 			Just geturl -> either giveup return =<< 				Url.withUrlOptions-					(Url.download' p Nothing (geturl exportloc) f)+					(Url.download' p iv (geturl exportloc) f) 			Nothing -> giveup $ needS3Creds (uuid r)   where 	exportloc = bucketExportLocation info loc@@ -649,22 +649,31 @@ 		| otherwise = 			i : removemostrecent mtime rest -retrieveExportWithContentIdentifierS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> ExportLocation -> ContentIdentifier -> FilePath -> Annex Key -> MeterUpdate -> Annex Key-retrieveExportWithContentIdentifierS3 hv r rs info loc cid dest mkkey p = withS3Handle hv $ \case-	Just h -> do-		rewritePreconditionException $ retrieveHelper' h dest p Nothing $-			limitGetToContentIdentifier cid $-				S3.getObject (bucket info) o-		k <- mkkey-		case extractContentIdentifier cid o of-			Right vid -> do-				vids <- getS3VersionID rs k-				unless (vid `elem` map Just vids) $-					setS3VersionID info rs k vid-			Left _ -> noop-		return k-	Nothing -> giveup $ needS3Creds (uuid r)+retrieveExportWithContentIdentifierS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> ExportLocation -> ContentIdentifier -> FilePath -> Either Key (Annex Key) -> MeterUpdate -> Annex (Key, Verification)+retrieveExportWithContentIdentifierS3 hv r rs info loc cid dest gk p =+	case gk of+		Right _mkkey -> do+			k <- go Nothing+			return (k, UnVerified)+		Left k -> do+			v <- verifyKeyContentIncrementally DefaultVerify k +				(void . go)+			return (k, v)   where+	go iv = withS3Handle hv $ \case+		Just h -> do+			rewritePreconditionException $ retrieveHelper' h dest p iv $+				limitGetToContentIdentifier cid $+					S3.getObject (bucket info) o+			k <- either return id gk+			case extractContentIdentifier cid o of+				Right vid -> do+					vids <- getS3VersionID rs k+					unless (vid `elem` map Just vids) $+						setS3VersionID info rs k vid+				Left _ -> noop+			return k+		Nothing -> giveup $ needS3Creds (uuid r) 	o = T.pack $ bucketExportLocation info loc  {- Catch exception getObject returns when a precondition is not met,
Remote/WebDAV.hs view
@@ -40,7 +40,7 @@ import Creds import Utility.Metered import Utility.Url (URLString, matchStatusCodeException, matchHttpExceptionContent)-import Utility.Hash (IncrementalVerifier(..))+import Annex.Verify import Annex.UUID import Remote.WebDAV.DavLocation import Types.ProposedAccepted@@ -218,10 +218,11 @@ 		storeHelper dav (exportTmpLocation loc k) dest reqbody 	Left err -> giveup err -retrieveExportDav :: DavHandleVar -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex ()-retrieveExportDav hdl  _k loc d p = case exportLocation loc of-	Right src -> withDavHandle hdl $ \h -> runExport h $ \_dav ->-		retrieveHelper src d p Nothing+retrieveExportDav :: DavHandleVar -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Verification+retrieveExportDav hdl  k loc d p = case exportLocation loc of+	Right src -> verifyKeyContentIncrementally AlwaysVerify k  $ \iv ->+		withDavHandle hdl $ \h -> runExport h $ \_dav ->+			retrieveHelper src d p iv 	Left err -> giveup err  checkPresentExportDav :: DavHandleVar -> Remote -> Key -> ExportLocation -> Annex Bool
Test.hs view
@@ -252,7 +252,7 @@ {- These tests set up the test environment, but also test some basic parts  - of git-annex. They are always run before the repoTests. -} initTests :: TestTree-initTests = testGroup "Init Tests"+initTests = testGroup initTestsName 	[ testCase "init" test_init 	, testCase "add" test_add 	]@@ -339,7 +339,7 @@ 	]   where 	mk l = testGroup groupname (initTests : map adddep l)-	adddep = Test.Tasty.after AllSucceed (groupname ++ ".Init Tests")+	adddep = Test.Tasty.after AllSucceed (groupname ++ "." ++ initTestsName) 	groupname = "Repo Tests " ++ note 	sep = sep' (replicate numparts []) 	sep' (p:ps) (l:ls) = sep' (ps++[l:p]) ls@@ -1643,7 +1643,7 @@ 	git_annex "get" [] "get" 	annexed_present annexedfile 	-- any exit status is accepted; does abnormal exit-	git_annex' (const True) "uninit" [] "uninit"+	git_annex'' (const True) "uninit" [] Nothing "uninit" 	checkregularfile annexedfile 	doesDirectoryExist ".git" @? ".git vanished in uninit" @@ -1758,8 +1758,8 @@ 	borgdirparent <- fromRawFilePath <$> (absPath . toRawFilePath =<< tmprepodir) 	let borgdir = borgdirparent </> "borgrepo" 	intmpclonerepo $ do-		testProcess "borg" ["init", borgdir, "-e", "none"] (== True) "borg init"-		testProcess "borg" ["create", borgdir++"::backup1", "."] (== True) "borg create"+		testProcess "borg" ["init", borgdir, "-e", "none"] Nothing (== True) "borg init"+		testProcess "borg" ["create", borgdir++"::backup1", "."] Nothing (== True) "borg create"  		git_annex "initremote" (words $ "borg type=borg borgrepo="++borgdir) "initremote" 		git_annex "sync" ["borg"] "sync borg"@@ -1769,7 +1769,7 @@ 		annexed_present annexedfile 		git_annex_expectoutput "find" ["--in=borg"] [] 		-		testProcess "borg" ["create", borgdir++"::backup2", "."] (== True) "borg create"+		testProcess "borg" ["create", borgdir++"::backup2", "."] Nothing (== True) "borg create" 		git_annex "sync" ["borg"] "sync borg after getting file" 		git_annex_expectoutput "find" ["--in=borg"] [annexedfile] @@ -1808,9 +1808,7 @@ 		let gpgtmp = if length relgpgtmp < length absgpgtmp 			then relgpgtmp  			else absgpgtmp-		Utility.Gpg.testTestHarness gpgtmp gpgcmd-			@? "test harness self-test failed"-		void $ Utility.Gpg.testHarness gpgtmp gpgcmd $ do+		void $ Utility.Gpg.testHarness gpgtmp gpgcmd $ \environ -> do 			createDirectory "dir" 			let initps = 				[ "foo"@@ -1821,13 +1819,13 @@ 				] ++ if scheme `elem` ["hybrid","pubkey"] 					then ["keyid=" ++ Utility.Gpg.testKeyId] 					else []-			git_annex "initremote" initps "initremote"-			git_annex_shouldfail "initremote" initps "initremote should not work when run twice in a row"-			git_annex "enableremote" initps "enableremote"-			git_annex "enableremote" initps "enableremote when run twice in a row"-			git_annex "get" [annexedfile] "get of file"+			git_annex' "initremote" initps (Just environ) "initremote"+			git_annex_shouldfail' "initremote" initps (Just environ) "initremote should not work when run twice in a row"+			git_annex' "enableremote" initps (Just environ) "enableremote"+			git_annex' "enableremote" initps (Just environ) "enableremote when run twice in a row"+			git_annex' "get" [annexedfile] (Just environ) "get of file" 			annexed_present annexedfile-			git_annex "copy" [annexedfile, "--to", "foo"] "copy --to encrypted remote"+			git_annex' "copy" [annexedfile, "--to", "foo"] (Just environ) "copy --to encrypted remote" 			(c,k) <- annexeval $ do 				uuid <- Remote.nameToUUID "foo" 				rs <- Logs.Remote.readRemoteLog@@ -1836,18 +1834,18 @@ 			let key = if scheme `elem` ["hybrid","pubkey"] 					then Just $ Utility.Gpg.KeyIds [Utility.Gpg.testKeyId] 					else Nothing-			testEncryptedRemote scheme key c [k] @? "invalid crypto setup"+			testEncryptedRemote environ scheme key c [k] @? "invalid crypto setup" 	 			annexed_present annexedfile-			git_annex "drop" [annexedfile, "--numcopies=2"] "drop"+			git_annex' "drop" [annexedfile, "--numcopies=2"] (Just environ) "drop" 			annexed_notpresent annexedfile-			git_annex "move" [annexedfile, "--from", "foo"] "move --from encrypted remote"+			git_annex' "move" [annexedfile, "--from", "foo"] (Just environ) "move --from encrypted remote" 			annexed_present annexedfile-			git_annex_shouldfail "drop" [annexedfile, "--numcopies=2"] "drop should not be allowed with numcopies=2"+			git_annex_shouldfail' "drop" [annexedfile, "--numcopies=2"] (Just environ) "drop should not be allowed with numcopies=2" 			annexed_present annexedfile 	{- Ensure the configuration complies with the encryption scheme, and 	 - that all keys are encrypted properly for the given directory remote. -}-	testEncryptedRemote scheme ks c keys = case Remote.Helper.Encryptable.extractCipher pc of+	testEncryptedRemote environ scheme ks c keys = case Remote.Helper.Encryptable.extractCipher pc of 		Just cip@Crypto.SharedCipher{} | scheme == "shared" && isNothing ks -> 			checkKeys cip Nothing 		Just cip@(Crypto.EncryptedCipher encipher v ks')@@ -1860,18 +1858,18 @@ 		keysMatch (Utility.Gpg.KeyIds ks') = 			maybe False (\(Utility.Gpg.KeyIds ks2) -> 					sort (nub ks2) == sort (nub ks')) ks-		checkCipher encipher = Utility.Gpg.checkEncryptionStream gpgcmd encipher . Just+		checkCipher encipher = Utility.Gpg.checkEncryptionStream gpgcmd (Just environ) encipher . Just 		checkScheme Types.Crypto.Hybrid = scheme == "hybrid" 		checkScheme Types.Crypto.PubKey = scheme == "pubkey" 		checkKeys cip mvariant = do 			dummycfg <- Types.GitConfig.dummyRemoteGitConfig 			let encparams = (Types.Remote.ParsedRemoteConfig mempty mempty, dummycfg)-			cipher <- Crypto.decryptCipher gpgcmd encparams cip+			cipher <- Crypto.decryptCipher' gpgcmd (Just environ) encparams cip 			files <- filterM doesFileExist $ 				map ("dir" </>) $ concatMap (serializeKeys cipher) keys 			return (not $ null files) <&&> allM (checkFile mvariant) files 		checkFile mvariant filename =-			Utility.Gpg.checkEncryptionFile gpgcmd filename $+			Utility.Gpg.checkEncryptionFile gpgcmd (Just environ) filename $ 				if mvariant == Just Types.Crypto.PubKey then ks else Nothing 		serializeKeys cipher = map fromRawFilePath .  			Annex.Locations.keyPaths .
Test/Framework.hs view
@@ -12,10 +12,10 @@ import Test.Tasty import Test.Tasty.Runners import Test.Tasty.HUnit-import Test.Tasty.QuickCheck import Test.Tasty.Options import Test.Tasty.Ingredients.Rerun import Test.Tasty.Ingredients.ConsoleReporter+import qualified Test.Tasty.Patterns.Types as TP import Options.Applicative.Types import Control.Concurrent import Control.Concurrent.Async@@ -24,6 +24,7 @@ import System.Console.Concurrent import System.Console.ANSI import GHC.Conc+import System.IO.Unsafe (unsafePerformIO)  import Common import Types.Test@@ -64,32 +65,40 @@  -- Run a process. The output and stderr is captured, and is only -- displayed if the process does not return the expected value.-testProcess :: String -> [String] -> (Bool -> Bool) -> String -> Assertion-testProcess command params expectedret faildesc = do-	(transcript, ret) <- Utility.Process.Transcript.processTranscript command params Nothing+testProcess :: String -> [String] -> Maybe [(String, String)] -> (Bool -> Bool) -> String -> Assertion+testProcess command params environ expectedret faildesc = do+	let p = (proc command params) { env = environ }+	(transcript, ret) <- Utility.Process.Transcript.processTranscript' p Nothing 	(expectedret ret) @? (faildesc ++ " failed (transcript follows)\n" ++ transcript)  -- Run git. (Do not use to run git-annex as the one being tested -- may not be in path.) git :: String -> [String] -> String -> Assertion-git command params = testProcess "git" (command:params) (== True)+git command params = testProcess "git" (command:params) Nothing (== True)  -- For when git is expected to fail. git_shouldfail :: String -> [String] -> String -> Assertion-git_shouldfail command params = testProcess "git" (command:params) (== False)+git_shouldfail command params = testProcess "git" (command:params) Nothing (== False)  -- Run git-annex. git_annex :: String -> [String] -> String -> Assertion-git_annex = git_annex' (== True)+git_annex command params faildesc = git_annex' command params Nothing faildesc +-- Runs git-annex with some environment.+git_annex' :: String -> [String] -> Maybe [(String, String)] -> String -> Assertion+git_annex' = git_annex'' (== True)+ -- For when git-annex is expected to fail. git_annex_shouldfail :: String -> [String] -> String -> Assertion-git_annex_shouldfail = git_annex' (== False)+git_annex_shouldfail command params faildesc = git_annex_shouldfail' command params Nothing faildesc -git_annex' :: (Bool -> Bool) -> String -> [String] -> String -> Assertion-git_annex' expectedret command params faildesc = do+git_annex_shouldfail' :: String -> [String] -> Maybe [(String, String)] -> String -> Assertion+git_annex_shouldfail' = git_annex'' (== False)++git_annex'' :: (Bool -> Bool) -> String -> [String] -> Maybe [(String, String)] -> String -> Assertion+git_annex'' expectedret command params environ faildesc = do 	pp <- Annex.Path.programPath-	testProcess pp (command:params) expectedret faildesc+	testProcess pp (command:params) environ expectedret faildesc  {- Runs git-annex and returns its standard output. -} git_annex_output :: String -> [String] -> IO String@@ -252,14 +261,42 @@ 	e <- doesDirectoryExist d 	unless e $ 		createDirectory d-	-{- Prevent global git configs from affecting the test suite. -}-isolateGitConfig :: IO a -> IO a-isolateGitConfig a = Utility.Tmp.Dir.withTmpDir "testhome" $ \tmphome -> do++{- This is the only place in the test suite that can use setEnv.+ - Using it elsewhere can conflict with tasty's use of getEnv, which can+ - happen concurrently with a test case running, and would be a problem+ - since setEnv is not thread safe. This is run before tasty. -}+setTestEnv :: IO a -> IO a+setTestEnv a = Utility.Tmp.Dir.withTmpDir "testhome" $ \tmphome -> do 	tmphomeabs <- fromRawFilePath <$> absPath (toRawFilePath tmphome)+	{- Prevent global git configs from affecting the test suite. -} 	Utility.Env.Set.setEnv "HOME" tmphomeabs True 	Utility.Env.Set.setEnv "XDG_CONFIG_HOME" tmphomeabs True 	Utility.Env.Set.setEnv "GIT_CONFIG_NOSYSTEM" "1" True+	+	-- Ensure that the same git-annex binary that is running+	-- git-annex test is at the front of the PATH.+	p <- Utility.Env.getEnvDefault "PATH" ""+	pp <- Annex.Path.programPath+	Utility.Env.Set.setEnv "PATH" (takeDirectory pp ++ [searchPathSeparator] ++ p) True+	+	-- Avoid git complaining if it cannot determine the user's+	-- email address, or exploding if it doesn't know the user's name.+	Utility.Env.Set.setEnv "GIT_AUTHOR_EMAIL" "test@example.com" True+	Utility.Env.Set.setEnv "GIT_AUTHOR_NAME" "git-annex test" True+	Utility.Env.Set.setEnv "GIT_COMMITTER_EMAIL" "test@example.com" True+	Utility.Env.Set.setEnv "GIT_COMMITTER_NAME" "git-annex test" True+	-- force gpg into batch mode for the tests+	Utility.Env.Set.setEnv "GPG_BATCH" "1" True+	-- Make git and git-annex access ssh remotes on the local+	-- filesystem, without using ssh at all.+	Utility.Env.Set.setEnv "GIT_SSH_COMMAND" "git-annex test --fakessh --" True+	Utility.Env.Set.setEnv "GIT_ANNEX_USE_GIT_SSH" "1" True++	-- Record top directory.+	currdir <- getCurrentDirectory+	Utility.Env.Set.setEnv "TOPDIR" currdir True+	 	a  removeDirectoryForCleanup :: FilePath -> IO ()@@ -447,7 +484,7 @@ 	, adjustedUnlockedBranch :: Bool 	, annexVersion :: Types.RepoVersion.RepoVersion 	, keepFailures :: Bool-	} deriving (Read, Show)+	} deriving (Show)  testMode :: TestOptions -> Types.RepoVersion.RepoVersion -> TestMode testMode opts v = TestMode@@ -463,47 +500,32 @@ withTestMode :: TestMode -> TestTree -> TestTree withTestMode testmode = withResource prepare release . const   where-	prepare = do-		setTestMode testmode-		setmainrepodir =<< newmainrepodir+	prepare = setTestMode testmode 	release _ = noop +{- The current test mode is stored here while a test is running.+ -+ - Only one test can be running at a time by a process; running a+ - test also involves chdir into a test repository.+ -}+{-# NOINLINE currentTestMode #-}+currentTestMode :: TMVar TestMode+currentTestMode = unsafePerformIO newEmptyTMVarIO++currentMainRepoDir :: TMVar FilePath+currentMainRepoDir = unsafePerformIO newEmptyTMVarIO+ setTestMode :: TestMode -> IO () setTestMode testmode = do-	currdir <- getCurrentDirectory-	p <- Utility.Env.getEnvDefault "PATH" ""-	pp <- Annex.Path.programPath--	mapM_ (\(var, val) -> Utility.Env.Set.setEnv var val True)-		-- Ensure that the same git-annex binary that is running-		-- git-annex test is at the front of the PATH.-		[ ("PATH", takeDirectory pp ++ [searchPathSeparator] ++ p)-		, ("TOPDIR", currdir)-		-- Avoid git complaining if it cannot determine the user's-		-- email address, or exploding if it doesn't know the user's-		-- name.-		, ("GIT_AUTHOR_EMAIL", "test@example.com")-		, ("GIT_AUTHOR_NAME", "git-annex test")-		, ("GIT_COMMITTER_EMAIL", "test@example.com")-		, ("GIT_COMMITTER_NAME", "git-annex test")-		-- force gpg into batch mode for the tests-		, ("GPG_BATCH", "1")-		-- Make git and git-annex access ssh remotes on the local-		-- filesystem, without using ssh at all.-		, ("GIT_SSH_COMMAND", "git-annex test --fakessh --")-		, ("GIT_ANNEX_USE_GIT_SSH", "1")-		, ("TESTMODE", show testmode)-		]-				-runFakeSsh :: [String] -> IO ()-runFakeSsh ("-n":ps) = runFakeSsh ps-runFakeSsh (_host:cmd:[]) =-	withCreateProcess (shell cmd) $-		\_ _ _ pid -> exitWith =<< waitForProcess pid-runFakeSsh ps = error $ "fake ssh option parse error: " ++ show ps+	atomically $ do+		_ <- tryTakeTMVar currentTestMode+		putTMVar currentTestMode testmode+	setmainrepodir =<< newmainrepodir  getTestMode :: IO TestMode-getTestMode = Prelude.read <$> Utility.Env.getEnvDefault "TESTMODE" ""+getTestMode = atomically (tryReadTMVar currentTestMode) >>= \case+	Just tm -> return tm+	Nothing -> error "getTestMode without setTestMode"  setupTestMode :: IO () setupTestMode = do@@ -520,13 +542,16 @@ tmpdir :: String tmpdir = ".t" -mainrepodir :: IO FilePath-mainrepodir = Utility.Env.getEnvDefault "MAINREPODIR"-	(giveup "MAINREPODIR not set")- setmainrepodir :: FilePath -> IO ()-setmainrepodir d = Utility.Env.Set.setEnv "MAINREPODIR" d True+setmainrepodir mrd = atomically $ do+	_ <- tryTakeTMVar currentMainRepoDir+	putTMVar currentMainRepoDir mrd +mainrepodir :: IO FilePath+mainrepodir = atomically (tryReadTMVar currentMainRepoDir) >>= \case+	Just tm -> return tm+	Nothing -> error "mainrepodir without setmainrepodir"+ newmainrepodir :: IO FilePath newmainrepodir = go (0 :: Int)   where@@ -668,6 +693,13 @@ 	Utility.Process.Transcript.processTranscript 		"chmod" ["-R", "u+w", d] Nothing +runFakeSsh :: [String] -> IO ()+runFakeSsh ("-n":ps) = runFakeSsh ps+runFakeSsh (_host:cmd:[]) =+	withCreateProcess (shell cmd) $+		\_ _ _ pid -> exitWith =<< waitForProcess pid+runFakeSsh ps = error $ "fake ssh option parse error: " ++ show ps+ {- Tests each TestTree in parallel, and exits with succcess/failure.  -  - Tasty supports parallel tests, but this does not use it, because@@ -693,10 +725,12 @@ 	| otherwise = go =<< Utility.Env.getEnv subenv   where 	subenv = "GIT_ANNEX_TEST_SUBPROCESS"+ 	-- Make more parts than there are jobs, because some parts 	-- are larger, and this allows the smaller parts to be packed 	-- in more efficiently, speeding up the test suite overall. 	numparts = numjobs * 2+ 	worker rs nvar a = do 		(n, m) <- atomically $ do 			(n, m) <- readTVar nvar@@ -707,6 +741,7 @@ 			else do 				r <- a n 				worker (r:rs) nvar a+	 	go Nothing = withConcurrentOutput $ do 		ensuredir tmpdir 		crippledfilesystem <- fst <$> Annex.Init.probeCrippledFileSystem'@@ -722,7 +757,7 @@ 		args <- getArgs 		pp <- Annex.Path.programPath 		termcolor <- hSupportsANSIColor stdout-		let ps = if useColor (lookupOption (tastyOptionSet opts)) termcolor+		let ps = if useColor (lookupOption tastyopts) termcolor 			then "--color=always":args 			else "--color=never":args 		let runone n = do@@ -733,13 +768,7 @@ 				, cwd = Just subdir 				} 			(_, _, _, pid) <- createProcessConcurrent p-			ret <- waitForProcess pid-			-- Work around this strange issue-			-- https://github.com/UnkindPartition/tasty/issues/326-			-- when other workaround does not work.-			if ret == ExitFailure (-11)-				then runone n-				else return ret+			waitForProcess pid 		nvar <- newTVarIO (1, length ts) 		exitcodes <- forConcurrently [1..numjobs] $ \_ ->  			worker [] nvar runone@@ -755,25 +784,31 @@ 				exitFailure 	go (Just subenvval) = case readish subenvval of 		Nothing -> error ("Bad " ++ subenv)-		Just (n, crippledfilesystem, adjustedbranchok) -> isolateGitConfig $ do+		Just (n, crippledfilesystem, adjustedbranchok) -> setTestEnv $ do 			let ts = mkts numparts crippledfilesystem adjustedbranchok opts-			let t = topLevelTestGroup -				-- Work around this strange issue-				-- https://github.com/UnkindPartition/tasty/issues/326-				[ testGroup "Tasty" -					[ testProperty "tasty self-check" True-					]-				, ts !! (n - 1)-				]-			case tryIngredients ingredients (tastyOptionSet opts) t of+			let t = topLevelTestGroup [ ts !! (n - 1) ]+			case tryIngredients ingredients tastyopts t of 				Nothing -> error "No tests found!?" 				Just act -> ifM act 					( exitSuccess 					, exitFailure-							)+					)+	+	tastyopts = case lookupOption (tastyOptionSet opts) of+		-- Work around limitation of tasty; when tests to run+		-- are limited to a pattern, it does not include their+		-- dependencies. So, add another pattern including the+		-- init tests, which are a dependency of most tests.+		TestPattern (Just p) -> +			setOption (TestPattern (Just (TP.Or p (TP.ERE initTestsName))))+				(tastyOptionSet opts)+		TestPattern Nothing -> tastyOptionSet opts  topLevelTestGroup :: [TestTree] -> TestTree topLevelTestGroup = testGroup "Tests"++initTestsName :: String+initTestsName = "Init Tests"  tastyParser :: [TestTree] -> ([String], Parser Test.Tasty.Options.OptionSet) #if MIN_VERSION_tasty(1,3,0)
Types/Remote.hs view
@@ -208,12 +208,15 @@ 	-- again. The verification does not need to use a 	-- cryptographically secure hash, but the hash does need to 	-- have preimage resistance.-	| MustVerify-	-- ^ Content likely to have been altered during transfer,-	-- verify even if verification is normally disabled 	| IncompleteVerify IncrementalVerifier 	-- ^ Content was partially verified during transfer, but 	-- the verification is not complete.+	| MustVerify+	-- ^ Content likely to have been altered during transfer,+	-- verify even if verification is normally disabled+	| MustFinishIncompleteVerify IncrementalVerifier+	-- ^ Content likely to have been altered during transfer,+	-- finish verification even if verification is normally disabled.  unVerified :: Monad m => m a -> m (a, Verification) unVerified a = do@@ -262,7 +265,7 @@ 	-- (The MeterUpdate does not need to be used if it writes 	-- sequentially to the file.) 	-- Throws exception on failure.-	, retrieveExport :: Key -> ExportLocation -> FilePath -> MeterUpdate -> a ()+	, retrieveExport :: Key -> ExportLocation -> FilePath -> MeterUpdate -> a Verification 	-- Removes an exported file (succeeds if the contents are not present) 	-- Can throw exception if unable to access remote, or if remote 	-- refuses to remove the content.@@ -343,10 +346,11 @@ 		-> ContentIdentifier 		-- file to write content to 		-> FilePath-		-- callback that generates a key from the downloaded content-		-> a Key+		-- Either the key, or when it's not yet known, a callback+		-- that generates a key from the downloaded content.+		-> Either Key (a Key) 		-> MeterUpdate-		-> a Key+		-> a (Key, Verification) 	-- Exports content to an ExportLocation, and returns the 	-- ContentIdentifier corresponding to the content it stored. 	--
Upgrade/V5/Direct.hs view
@@ -97,7 +97,7 @@ removeAssociatedFiles :: Key -> Annex () removeAssociatedFiles key = do 	mapping <- calcRepo $ gitAnnexMapping key-	modifyContent mapping $+	modifyContentDir mapping $ 		liftIO $ removeWhenExistsWith R.removeLink mapping  {- Checks if a file in the tree, associated with a key, has not been modified.@@ -124,7 +124,7 @@ {- Removes an inode cache. -} removeInodeCache :: Key -> Annex () removeInodeCache key = withInodeCacheFile key $ \f ->-	modifyContent f $+	modifyContentDir f $ 		liftIO $ removeWhenExistsWith R.removeLink f  withInodeCacheFile :: Key -> (RawFilePath -> Annex a) -> Annex a
Utility/DataUnits.hs view
@@ -1,6 +1,6 @@ {- data size display and parsing  -- - Copyright 2011 Joey Hess <id@joeyh.name>+ - Copyright 2011-2022 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -@@ -22,13 +22,19 @@  -  - So, a committee was formed. And it arrived at a committee-like decision,  - which satisfied noone, confused everyone, and made the world an uglier- - place. As with all committees, this was meh.+ - place. As with all committees, this was meh. Or in this case, "mib".  -  - And the drive manufacturers happily continued selling drives that are  - increasingly smaller than you'd expect, if you don't count on your  - fingers. But that are increasingly too big for anyone to much notice.  - This caused me to need git-annex.  -+ - Meanwhile, over in telecommunications land, they were using entirely+ - different units that differ only in capitalization sometimes.+ - (At one point this convinced me that it was a good idea to buy an ISDN+ - line because 128 kb/s sounded really fast! But it was really only 128+ - kbit/s...)+ -  - Thus, I use units here that I loathe. Because if I didn't, people would  - be confused that their drives seem the wrong size, and other people would  - complain at me for not being standards compliant. And we call this@@ -38,7 +44,7 @@ module Utility.DataUnits ( 	dataUnits, 	storageUnits,-	memoryUnits,+	committeeUnits, 	bandwidthUnits, 	oldSchoolUnits, 	Unit(..),@@ -62,7 +68,7 @@ 	deriving (Ord, Show, Eq)  dataUnits :: [Unit]-dataUnits = storageUnits ++ memoryUnits+dataUnits = storageUnits ++ committeeUnits ++ bandwidthUnits  {- Storage units are (stupidly) powers of ten. -} storageUnits :: [Unit]@@ -75,15 +81,15 @@ 	, Unit (p 3) "GB" "gigabyte" 	, Unit (p 2) "MB" "megabyte" 	, Unit (p 1) "kB" "kilobyte" -- weird capitalization thanks to committe-	, Unit (p 0) "B" "byte"+	, Unit 1 "B" "byte" 	]   where 	p :: Integer -> Integer 	p n = 1000^n -{- Memory units are (stupidly named) powers of 2. -}-memoryUnits :: [Unit]-memoryUnits =+{- Committee units are (stupidly named) powers of 2. -}+committeeUnits :: [Unit]+committeeUnits = 	[ Unit (p 8) "YiB" "yobibyte" 	, Unit (p 7) "ZiB" "zebibyte" 	, Unit (p 6) "EiB" "exbibyte"@@ -92,19 +98,37 @@ 	, Unit (p 3) "GiB" "gibibyte" 	, Unit (p 2) "MiB" "mebibyte" 	, Unit (p 1) "KiB" "kibibyte"-	, Unit (p 0) "B" "byte"+	, Unit 1 "B" "byte" 	]   where 	p :: Integer -> Integer 	p n = 2^(n*10) -{- Bandwidth units are only measured in bits if you're some crazy telco. -}+{- Bandwidth units are (stupidly) measured in bits, not bytes, and are+ - (also stupidly) powers of ten. + -+ - While it's fairly common for "Mb", "Gb" etc to be used, that differs+ - from "MB", "GB", etc only in case, and readSize is case-insensitive.+ - So "Mbit", "Gbit" etc are used instead to avoid parsing ambiguity.+ -} bandwidthUnits :: [Unit]-bandwidthUnits = error "stop trying to rip people off"+bandwidthUnits =+	[ Unit (p 8) "Ybit" "yottabit"+	, Unit (p 7) "Zbit" "zettabit"+	, Unit (p 6) "Ebit" "exabit"+	, Unit (p 5) "Pbit" "petabit"+	, Unit (p 4) "Tbit" "terabit"+	, Unit (p 3) "Gbit" "gigabit"+	, Unit (p 2) "Mbit" "megabit"+	, Unit (p 1) "kbit" "kilobit" -- weird capitalization thanks to committe+	]+  where+	p :: Integer -> Integer+	p n = (1000^n) `div` 8  {- Do you yearn for the days when men were men and megabytes were megabytes? -} oldSchoolUnits :: [Unit]-oldSchoolUnits = zipWith (curry mingle) storageUnits memoryUnits+oldSchoolUnits = zipWith (curry mingle) storageUnits committeeUnits   where 	mingle (Unit _ a n, Unit s' _ _) = Unit s' a n
Utility/Gpg.hs view
@@ -1,6 +1,6 @@ {- gpg interface  -- - Copyright 2011 Joey Hess <id@joeyh.name>+ - Copyright 2011-2022 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}@@ -16,6 +16,7 @@ 	pkEncTo, 	stdEncryptionParams, 	pipeStrict,+	pipeStrict', 	feedRead, 	feedRead', 	findPubKeys,@@ -28,7 +29,6 @@ 	testKeyId, #ifndef mingw32_HOST_OS 	testHarness,-	testTestHarness, 	checkEncryptionFile, 	checkEncryptionStream, #endif@@ -40,7 +40,6 @@ import System.Posix.Types import System.Posix.IO import Utility.Env-import Utility.Env.Set import Utility.FileMode #else import Utility.Tmp@@ -110,10 +109,15 @@  {- Runs gpg with some params and returns its stdout, strictly. -} readStrict :: GpgCmd -> [CommandParam] -> IO String-readStrict (GpgCmd cmd) params = do+readStrict c p = readStrict' c p Nothing++readStrict' :: GpgCmd -> [CommandParam] -> Maybe [(String, String)] -> IO String+readStrict' (GpgCmd cmd) params environ = do 	params' <- stdParams params 	let p = (proc cmd params')-		{ std_out = CreatePipe }+		{ std_out = CreatePipe+		, env = environ+		} 	withCreateProcess p (go p)   where 	go p _ (Just hout) _ pid = do@@ -124,11 +128,15 @@ {- Runs gpg, piping an input value to it, and returning its stdout,  - strictly. -} pipeStrict :: GpgCmd -> [CommandParam] -> String -> IO String-pipeStrict (GpgCmd cmd) params input = do+pipeStrict c p i = pipeStrict' c p Nothing i++pipeStrict' :: GpgCmd -> [CommandParam] -> Maybe [(String, String)] -> String -> IO String+pipeStrict' (GpgCmd cmd) params environ input = do 	params' <- stdParams params 	let p = (proc cmd params') 		{ std_in = CreatePipe 		, std_out = CreatePipe+		, env = environ 		} 	withCreateProcess p (go p)   where@@ -208,11 +216,14 @@  - a key id, or a name; See the section 'HOW TO SPECIFY A USER ID' of  - GnuPG's manpage.) -} findPubKeys :: GpgCmd -> String -> IO KeyIds-findPubKeys cmd for+findPubKeys cmd = findPubKeys' cmd Nothing++findPubKeys' :: GpgCmd -> Maybe [(String, String)] -> String -> IO KeyIds+findPubKeys' cmd environ for 	-- pass forced subkey through as-is rather than 	-- looking up the master key. 	| isForcedSubKey for = return $ KeyIds [for]-	| otherwise = KeyIds . parse . lines <$> readStrict cmd params+	| otherwise = KeyIds . parse . lines <$> readStrict' cmd params environ   where 	params = [Param "--with-colons", Param "--list-public-keys", Param for] 	parse = mapMaybe (keyIdField . splitc ':')@@ -410,7 +421,7 @@  - perhaps related to the agent socket), the action is not run, and Nothing  - is returned.  -}-testHarness :: FilePath -> GpgCmd -> IO a -> IO (Maybe a)+testHarness :: FilePath -> GpgCmd -> ([(String, String)] -> IO a) -> IO (Maybe a) testHarness tmpdir cmd a = ifM (inSearchPath (unGpgCmd cmd)) 	( bracket (eitherToMaybe <$> tryNonAsync setup) cleanup go 	, return Nothing@@ -419,30 +430,30 @@ 	var = "GNUPGHOME"  	setup = do-		orig <- getEnv var 		subdir <- makenewdir (1 :: Integer)+		origenviron <- getEnvironment+		let environ = addEntry var subdir origenviron 		-- gpg is picky about permissions on its home dir 		liftIO $ void $ tryIO $ modifyFileMode (toRawFilePath subdir) $ 			removeModes $ otherGroupModes-		setEnv var subdir True 		-- For some reason, recent gpg needs a trustdb to be set up.-		_ <- pipeStrict cmd [Param "--trust-model", Param "auto", Param "--update-trustdb"] []-		_ <- pipeStrict cmd [Param "--import", Param "-q"] $ unlines+		_ <- pipeStrict' cmd [Param "--trust-model", Param "auto", Param "--update-trustdb"] (Just environ) []+		_ <- pipeStrict' cmd [Param "--import", Param "-q"] (Just environ) $ unlines 			[testSecretKey, testKey]-		return orig+		return environ 		-	cleanup (Just (Just v)) = stopgpgagent >> setEnv var v True-	cleanup (Just Nothing) = stopgpgagent >> unsetEnv var-	cleanup Nothing = stopgpgagent+	cleanup Nothing = return ()+	cleanup (Just environ) = stopgpgagent environ  	-- Recent versions of gpg automatically start gpg-agent, or perhaps 	-- other daemons. Stop them when done. This only affects 	-- daemons started for the GNUPGHOME that was used. 	-- Older gpg may not support this, so ignore failure.-	stopgpgagent = whenM (inSearchPath "gpgconf") $-		void $ boolSystem "gpgconf" [Param "--kill", Param "all"]+	stopgpgagent environ = whenM (inSearchPath "gpgconf") $+		void $ boolSystemEnv "gpgconf" [Param "--kill", Param "all"]+			(Just environ)  -	go (Just _) = Just <$> a+	go (Just environ) = Just <$> a environ 	go Nothing = return Nothing          makenewdir n = do@@ -451,24 +462,15 @@ 			createDirectory subdir 			return subdir -{- Tests the test harness. -}-testTestHarness :: FilePath -> GpgCmd -> IO Bool-testTestHarness tmpdir cmd =-	testHarness tmpdir cmd (findPubKeys cmd testKeyId) >>= \case-		Nothing -> do-			hPutStrLn stderr "unable to test gpg, setting up the test harness did not succeed"-			return True-		Just keys -> return $ KeyIds [testKeyId] == keys--checkEncryptionFile :: GpgCmd -> FilePath -> Maybe KeyIds -> IO Bool-checkEncryptionFile cmd filename keys =-	checkGpgPackets cmd keys =<< readStrict cmd params+checkEncryptionFile :: GpgCmd -> Maybe [(String, String)] -> FilePath -> Maybe KeyIds -> IO Bool+checkEncryptionFile cmd environ filename keys =+	checkGpgPackets cmd environ keys =<< readStrict' cmd params environ   where 	params = [Param "--list-packets", Param "--list-only", File filename] -checkEncryptionStream :: GpgCmd -> String -> Maybe KeyIds -> IO Bool-checkEncryptionStream cmd stream keys =-	checkGpgPackets cmd keys =<< pipeStrict cmd params stream+checkEncryptionStream :: GpgCmd -> Maybe [(String, String)] -> String -> Maybe KeyIds -> IO Bool+checkEncryptionStream cmd environ stream keys =+	checkGpgPackets cmd environ keys =<< pipeStrict' cmd params environ stream   where 	params = [Param "--list-packets", Param "--list-only"] @@ -476,8 +478,8 @@  - symmetrically encrypted (keys is Nothing), or encrypted to some  - public key(s).  - /!\ The key needs to be in the keyring! -}-checkGpgPackets :: GpgCmd -> Maybe KeyIds -> String -> IO Bool-checkGpgPackets cmd keys str = do+checkGpgPackets :: GpgCmd -> Maybe [(String, String)] -> Maybe KeyIds -> String -> IO Bool+checkGpgPackets cmd environ keys str = do 	let (asym,sym) = partition (pubkeyEncPacket `isPrefixOf`) $ 			filter (\l' -> pubkeyEncPacket `isPrefixOf` l' || 				symkeyEncPacket `isPrefixOf` l') $@@ -488,7 +490,7 @@ 		(Just (KeyIds ks), ls, []) -> do 			-- Find the master key associated with the 			-- encryption subkey.-			ks' <- concat <$> mapM (keyIds <$$> findPubKeys cmd)+			ks' <- concat <$> mapM (keyIds <$$> findPubKeys' cmd environ) 					[ k | k:"keyid":_ <- map (reverse . words) ls ] 			return $ sort (nub ks) == sort (nub ks') 		_ -> return False
Utility/Metered.hs view
@@ -491,14 +491,14 @@ 		, estimatedcompletion 		]   where-	amount = roughSize' memoryUnits True 2 new+	amount = roughSize' committeeUnits True 2 new 	percentamount = case mtotalsize of 		Just (TotalSize totalsize) -> 			let p = showPercentage 0 $ 				percentage totalsize (min new totalsize) 			in p ++ replicate (6 - length p) ' ' ++ amount 		Nothing -> amount-	rate = roughSize' memoryUnits True 0 bytespersecond ++ "/s"+	rate = roughSize' committeeUnits True 0 bytespersecond ++ "/s" 	bytespersecond 		| duration == 0 = fromIntegral transferred 		| otherwise = floor $ fromIntegral transferred / duration
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 10.20220504+Version: 10.20220525 Cabal-Version: >= 1.10 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>