packages feed

git-annex 10.20221103 → 10.20221212

raw patch · 24 files changed

+300/−126 lines, 24 filesdep ~Win32

Dependency ranges changed: Win32

Files

Annex/Init.hs view
@@ -37,7 +37,6 @@ import Annex.Version import Annex.Difference import Annex.UUID-import Annex.WorkTree import Annex.Fixup import Annex.Path import Config@@ -102,8 +101,8 @@ 		Right username -> [username, at, hostname, ":", reldir] 		Left _ -> [hostname, ":", reldir] -initialize :: Bool -> Maybe String -> Maybe RepoVersion -> Annex ()-initialize autoinit mdescription mversion = checkInitializeAllowed $ \initallowed -> do+initialize :: Maybe String -> Maybe RepoVersion -> Annex ()+initialize mdescription mversion = checkInitializeAllowed $ \initallowed -> do 	{- Has to come before any commits are made as the shared 	 - clone heuristic expects no local objects. -} 	sharedclone <- checkSharedClone@@ -113,7 +112,7 @@ 	ensureCommit $ Annex.Branch.create  	prepUUID-	initialize' autoinit mversion initallowed+	initialize' mversion initallowed 	 	initSharedClone sharedclone 	@@ -125,8 +124,8 @@  -- Everything except for uuid setup, shared clone setup, and initial -- description.-initialize' :: Bool -> Maybe RepoVersion -> InitializeAllowed -> Annex ()-initialize' autoinit mversion _initallowed = do+initialize' :: Maybe RepoVersion -> InitializeAllowed -> Annex ()+initialize' mversion _initallowed = do 	checkLockSupport 	checkFifoSupport 	checkCrippledFileSystem@@ -143,8 +142,6 @@ 	unlessM isBareRepo $ do 		hookWrite postCheckoutHook 		hookWrite postMergeHook-		unless autoinit $-			scanAnnexedFiles  	AdjustedBranch.checkAdjustedClone >>= \case 		AdjustedBranch.InAdjustedClone -> return ()@@ -206,7 +203,7 @@   where 	needsinit = ifM autoInitializeAllowed 		( do-			tryNonAsync (initialize True Nothing Nothing) >>= \case+			tryNonAsync (initialize Nothing Nothing) >>= \case 				Right () -> noop 				Left e -> giveup $ show e ++ "\n" ++ 					"git-annex: automatic initialization failed due to above problems"@@ -259,7 +256,7 @@   where 	needsinit = 		whenM (initializeAllowed <&&> autoInitializeAllowed) $ do-			initialize True Nothing Nothing+			initialize Nothing Nothing 			autoEnableSpecialRemotes remotelist  {- Checks if a repository is initialized. Does not check version for ugrade. -}
Annex/Locations.hs view
@@ -50,6 +50,7 @@ 	gitAnnexSmudgeLog, 	gitAnnexSmudgeLock, 	gitAnnexRestageLog,+	gitAnnexRestageLogOld, 	gitAnnexRestageLock, 	gitAnnexMoveLog, 	gitAnnexMoveLock,@@ -384,6 +385,10 @@  - restaged in git -} gitAnnexRestageLog :: Git.Repo -> RawFilePath gitAnnexRestageLog r = gitAnnexDir r P.</> "restage.log"++{- .git/annex/restage.old is used while restaging files in git -}+gitAnnexRestageLogOld :: Git.Repo -> RawFilePath+gitAnnexRestageLogOld r = gitAnnexDir r P.</> "restage.old"  gitAnnexRestageLock :: Git.Repo -> RawFilePath gitAnnexRestageLock r = gitAnnexDir r P.</> "restage.lck"
Annex/YoutubeDl.hs view
@@ -249,8 +249,9 @@ 	return (opts ++ addopts)  youtubeDlCommand :: Annex String-youtubeDlCommand = fromMaybe "youtube-dl" . annexYoutubeDlCommand -	<$> Annex.getGitConfig+youtubeDlCommand = annexYoutubeDlCommand <$> Annex.getGitConfig >>= \case+	Just c -> pure c+	Nothing -> fromMaybe "yt-dlp" <$> liftIO (searchPath "youtube-dl")  supportedScheme :: UrlOptions -> URLString -> Bool supportedScheme uo url = case parseURIRelaxed url of@@ -264,8 +265,10 @@ 		_ -> allowedScheme uo u  {- Strategy: Look for chunks prefixed with \r, which look approximately- - like this:+ - like this for youtube-dl:  - "ESC[K[download]  26.6% of 60.22MiB at 254.69MiB/s ETA 00:00"+ - or for yt-dlp, like this:+ - "\r[download]   1.8% of    1.14GiB at    1.04MiB/s ETA 18:23"  - Look at the number before "% of " and the number and unit after,  - to determine the number of bytes.  -}@@ -291,8 +294,11 @@ 	calc percent total = round (percent * fromIntegral total / 100)  	parsepercent :: String -> Maybe Double-	parsepercent = readMaybe . reverse . takeWhile (not . isSpace) . reverse+	parsepercent = readMaybe +		. reverse . takeWhile (not . isSpace) . reverse+		. dropWhile isSpace  -	parsebytes = readSize units . takeWhile (not . isSpace)+	parsebytes = readSize units . takeWhile (not . isSpace) +		. dropWhile isSpace  	units = committeeUnits ++ storageUnits
Assistant/MakeRepo.hs view
@@ -85,7 +85,7 @@  initRepo' :: Maybe String -> Maybe StandardGroup -> Annex () initRepo' desc mgroup = unlessM isInitialized $ do-	initialize False desc Nothing+	initialize desc Nothing 	u <- getUUID 	maybe noop (defaultStandardGroup u) mgroup 	{- Ensure branch gets committed right away so it is
CHANGELOG view
@@ -1,3 +1,28 @@+git-annex (10.20221212) upstream; urgency=medium++  * Fix a hang that occasionally occurred during commands such as move,+    when operating on unlocked files. (A bug introduced in 10.20220927)+  * When youtube-dl is not available in PATH, use yt-dlp instead.+  * Support parsing yt-dpl output to display download progress.+  * init: Avoid scanning for annexed files, which can be lengthy in a+    large repository. Instead that scan is done on demand.+  * Sped up the initial scan for annexed files by 21%.+  * test: Add --test-debug option.+  * Support quettabyte and yottabyte.++ -- Joey Hess <id@joeyh.name>  Mon, 12 Dec 2022 12:20:06 -0400++git-annex (10.20221104) upstream; urgency=medium++  * export: Fix a bug that left a file on a special remote when+    two files with the same content were both deleted in the exported tree.+  * S3: Support signature=anonymous to access a S3 bucket anonymously.+    This can be used, for example, with importtree=yes to import from+    a public bucket.+    This feature needs git-annex to be built with aws-0.23.++ -- Joey Hess <id@joeyh.name>  Thu, 03 Nov 2022 14:07:31 -0400+ git-annex (10.20221103) upstream; urgency=medium    * Doubled the speed of git-annex drop when operating on many files,
Command/ConfigList.hs view
@@ -47,7 +47,7 @@ 		else ifM (Annex.Branch.hasSibling <||> (isJust <$> Fields.getField Fields.autoInit)) 			( do 				liftIO checkNotReadOnly-				initialize True Nothing Nothing+				initialize Nothing Nothing 				getUUID 			, return NoUUID 			)
Command/Export.hs view
@@ -149,23 +149,24 @@ 		[] -> updateExportTree db emptyTree new 		[oldtreesha] -> do 			diffmap <- mkDiffMap oldtreesha new db-			let seekdiffmap a = commandActions $ -				map a (M.toList diffmap)+			let seekdiffmap a = mapM_ a (M.toList diffmap) 			-- Rename old files to temp, or delete.-			seekdiffmap $ \(ek, (moldf, mnewf)) -> do-				case (moldf, mnewf) of-					(Just oldf, Just _newf) ->+			let deleteoldf = \ek oldf -> commandAction $+				startUnexport' r db oldf ek+			seekdiffmap $ \case+				(ek, (oldf:oldfs, _newf:_)) -> do+					commandAction $ 						startMoveToTempName r db oldf ek-					(Just oldf, Nothing) ->-						startUnexport' r db oldf ek-					_ -> stop+					forM_ oldfs (deleteoldf ek)+				(ek, (oldfs, [])) ->+					forM_ oldfs (deleteoldf ek)+				(_ek, ([], _)) -> noop 			waitForAllRunningCommandActions 			-- Rename from temp to new files.-			seekdiffmap $ \(ek, (moldf, mnewf)) ->-				case (moldf, mnewf) of-					(Just _oldf, Just newf) ->-						startMoveFromTempName r db ek newf-					_ -> stop+			seekdiffmap $ \case+				(ek, (_oldf:_, newf:_)) -> commandAction $+					startMoveFromTempName r db ek newf+				_ -> noop 			waitForAllRunningCommandActions 		ts -> do 			warning "Resolving export conflict.."@@ -204,7 +205,7 @@ 		void $ liftIO cleanup  -- Map of old and new filenames for each changed Key in a diff.-type DiffMap = M.Map Key (Maybe TopFilePath, Maybe TopFilePath)+type DiffMap = M.Map Key ([TopFilePath], [TopFilePath])  mkDiffMap :: Git.Ref -> Git.Ref -> ExportHandle -> Annex DiffMap mkDiffMap old new db = do@@ -213,14 +214,14 @@ 	void $ liftIO cleanup 	return diffmap   where-	combinedm (srca, dsta) (srcb, dstb) = (srca <|> srcb, dsta <|> dstb)+	combinedm (srca, dsta) (srcb, dstb) = (srca ++ srcb, dsta ++ dstb) 	mkdm i = do 		srcek <- getek (Git.DiffTree.srcsha i) 		dstek <- getek (Git.DiffTree.dstsha i) 		updateExportTree' db srcek dstek i 		return $ catMaybes-			[ (, (Just (Git.DiffTree.file i), Nothing)) <$> srcek-			, (, (Nothing, Just (Git.DiffTree.file i))) <$> dstek+			[ (, ([Git.DiffTree.file i], [])) <$> srcek+			, (, ([], [Git.DiffTree.file i])) <$> dstek 			] 	getek sha 		| sha `elem` nullShas = return Nothing
Command/Init.hs view
@@ -75,7 +75,7 @@ 			Just v | v /= wantversion -> 				giveup $ "This repository is already a initialized with version " ++ show (fromRepoVersion v) ++ ", not changing to requested version." 			_ -> noop-	initialize False+	initialize 		(if null (initDesc os) then Nothing else Just (initDesc os)) 		(initVersion os) 	unless (noAutoEnable os)
Command/Reinit.hs view
@@ -35,6 +35,6 @@ 		then return $ toUUID s 		else Remote.nameToUUID s 	storeUUID u-	checkInitializeAllowed $ initialize' False Nothing+	checkInitializeAllowed $ initialize' Nothing 	Annex.SpecialRemote.autoEnable 	next $ return True
Command/Upgrade.hs view
@@ -45,6 +45,6 @@ start _ = 	starting "upgrade" (ActionItemOther Nothing) (SeekInput []) $ do 		whenM (isNothing <$> getVersion) $ do-			initialize False Nothing Nothing+			initialize Nothing Nothing 		r <- upgrade False latestVersion 		next $ return r
Database/Keys.hs view
@@ -132,10 +132,10 @@ 		let db = dbdir P.</> "db" 		dbexists <- liftIO $ R.doesPathExist db 		case dbexists of-			True -> open db+			True -> open db False 			False -> do 				initDb db SQL.createTables-				open db+				open db True   where 	-- If permissions don't allow opening the database, and it's being 	-- opened for read, treat it as if it does not exist.@@ -143,9 +143,9 @@ 		| forwrite = throwM e 		| otherwise = return DbUnavailable 	-	open db = do+	open db dbisnew = do 		qh <- liftIO $ H.openDbQueue db SQL.containedTable-		tc <- reconcileStaged qh+		tc <- reconcileStaged dbisnew qh 		return $ DbOpen (qh, tc)  {- Closes the database if it was open. Any writes will be flushed to it.@@ -260,8 +260,8 @@  - So when using getAssociatedFiles, have to make sure the file still  - is an associated file.  -}-reconcileStaged :: H.DbQueue -> Annex DbTablesChanged-reconcileStaged qh = ifM (Git.Config.isBare <$> gitRepo)+reconcileStaged :: Bool -> H.DbQueue -> Annex DbTablesChanged+reconcileStaged dbisnew qh = ifM (Git.Config.isBare <$> gitRepo) 	( return mempty 	, do 		gitindex <- inRepo currentIndexFile@@ -384,7 +384,7 @@ 						Nothing -> return False 				send mdfeeder (Ref dstsha) $ \case 					Just key -> do-						liftIO $ SQL.addAssociatedFile key+						liftIO $ addassociatedfile key 							(asTopFilePath file) 							(SQL.WriteHandle qh) 						when (dstmode /= fmtTreeItemType TreeSymlink) $@@ -496,6 +496,18 @@ 	-- takes less than half a second, so that seems about right. 	largediff :: Int 	largediff = 1000++	-- When the database is known to have been newly created and empty+	-- before reconcileStaged started, it is more efficient to use +	-- newAssociatedFile. It's safe to use it here because this is run+	-- with a lock held that blocks any other process that opens the+	-- database, and when the database is newly created, there is no+	-- existing process that has it open already. And it's not possible+	-- for reconcileStaged to call this twice on the same filename with+	-- two different keys.+	addassociatedfile+		| dbisnew = SQL.newAssociatedFile+		| otherwise = SQL.addAssociatedFile  {- Normally the keys database is updated incrementally when opened,  - by reconcileStaged. Calling this explicitly allows running the
Database/Keys/SQL.hs view
@@ -1,6 +1,6 @@ {- Sqlite database of information about Keys  -- - 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.  -}@@ -73,8 +73,8 @@ queueDb :: SqlPersistM () -> WriteHandle -> IO () queueDb a (WriteHandle h) = H.queueDb h checkcommit a   where-	-- commit queue after 1000 changes-	checkcommit sz _lastcommittime = pure (sz > 1000)+	-- commit queue after 10000 changes+	checkcommit sz _lastcommittime = pure (sz > 10000)  -- Insert the associated file. -- When the file was associated with a different key before,@@ -85,6 +85,15 @@ 		(FileKeyIndex af k) 		(Associated k af) 		[AssociatedFile =. af, AssociatedKey =. k]+  where+	af = SFilePath (getTopFilePath f)++-- Faster than addAssociatedFile, but only safe to use when the file+-- was not associated with a different key before, as it does not delete+-- any old key.+newAssociatedFile :: Key -> TopFilePath -> WriteHandle -> IO ()+newAssociatedFile k f = queueDb $+	void $ insert $ Associated k af   where 	af = SFilePath (getTopFilePath f)
Logs/File.hs view
@@ -13,8 +13,10 @@ 	appendLogFile, 	modifyLogFile, 	streamLogFile,+	streamLogFileUnsafe, 	checkLogFile, 	calcLogFile,+	calcLogFileUnsafe, ) where  import Annex.Common@@ -98,7 +100,12 @@  -- | Folds a function over lines of a log file to calculate a value. calcLogFile :: RawFilePath -> RawFilePath -> t -> (L.ByteString -> t -> t) -> Annex t-calcLogFile f lck start update = withSharedLock lck $ bracket setup cleanup go+calcLogFile f lck start update =+	withSharedLock lck $ calcLogFileUnsafe f start update++-- | Unsafe version that does not do locking.+calcLogFileUnsafe :: RawFilePath -> t -> (L.ByteString -> t -> t) -> Annex t+calcLogFileUnsafe f start update = bracket setup cleanup go   where 	setup = liftIO $ tryWhenExists $ openFile f' ReadMode 	cleanup Nothing = noop@@ -125,7 +132,15 @@ -- is running. streamLogFile :: FilePath -> RawFilePath -> Annex () -> (String -> Annex ()) -> Annex () streamLogFile f lck finalizer processor = -	withExclusiveLock lck $ bracketOnError setup cleanup go+	withExclusiveLock lck $ do+		streamLogFileUnsafe f finalizer processor+		liftIO $ writeFile f ""+		setAnnexFilePerm (toRawFilePath f)++-- Unsafe version that does not do locking, and does not empty the file+-- at the end.+streamLogFileUnsafe :: FilePath -> Annex () -> (String -> Annex ()) -> Annex ()+streamLogFileUnsafe f finalizer processor = bracketOnError setup cleanup go   where 	setup = liftIO $ tryWhenExists $ openFile f ReadMode  	cleanup Nothing = noop@@ -135,8 +150,6 @@ 		mapM_ processor =<< liftIO (lines <$> hGetContents h) 		liftIO $ hClose h 		finalizer-		liftIO $ writeFile f ""-		setAnnexFilePerm (toRawFilePath f)  createDirWhenNeeded :: RawFilePath -> Annex () -> Annex () createDirWhenNeeded f a = a `catchNonAsync` \_e -> do
Logs/Restage.hs view
@@ -13,9 +13,11 @@ import Git.FilePath import Logs.File import Utility.InodeCache+import Annex.LockFile  import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L+import qualified Utility.RawFilePath as R  -- | Log a file whose pointer needs to be restaged in git. -- The content of the file may not be a pointer, if it is populated with@@ -27,31 +29,61 @@ 	lckf <- fromRepo gitAnnexRestageLock 	appendLogFile logf lckf $ L.fromStrict $ formatRestageLog f ic --- | Streams the content of the restage log, and then empties the log at--- the end.+-- | Streams the content of the restage log. ----- If the processor or finalizer is interrupted or throws an exception,--- the log file is left unchanged.+-- First, the content of the log file is moved to the restage.old file.+-- If that file already exists, the content is appended, otherwise it's+-- renamed to that. ----- Locking is used to prevent new items being added to the log while this--- is running.+-- The log file is kept locked during that, but the lock is then+-- released. The processor may do something that itself needs to take the+-- lock, so it's important that the lock not be held while running it.+--+-- The content of restage.old file is then streamed to the processor, +-- and then the finalizer is run, ending with emptying restage.old.+--+-- If the processor or finalizer is interrupted or throws an exception,+-- restage.old is left populated to be processed later. streamRestageLog :: Annex () -> (TopFilePath -> InodeCache -> Annex ()) -> Annex () streamRestageLog finalizer processor = do 	logf <- fromRepo gitAnnexRestageLog+	oldf <- fromRepo gitAnnexRestageLogOld+	let oldf' = fromRawFilePath oldf 	lckf <- fromRepo gitAnnexRestageLock-	streamLogFile (fromRawFilePath logf) lckf finalizer $ \l -> +	+	withExclusiveLock lckf $ liftIO $+		whenM (R.doesPathExist logf) $+			ifM (R.doesPathExist oldf)+				( do+					h <- openFile oldf' AppendMode+					hPutStr h =<< readFile (fromRawFilePath logf)+					hClose h+					liftIO $ removeWhenExistsWith R.removeLink logf+				, moveFile logf oldf+				)++	streamLogFileUnsafe oldf' finalizer $ \l ->  		case parseRestageLog l of 			Just (f, ic) -> processor f ic 			Nothing -> noop+	+	liftIO $ removeWhenExistsWith R.removeLink oldf +-- | Calculate over both the current restage log, and also over the old+-- one if it had started to be processed but did not get finished due+-- to an interruption. calcRestageLog :: t -> ((TopFilePath, InodeCache) -> t -> t) -> Annex t calcRestageLog start update = do 	logf <- fromRepo gitAnnexRestageLog+	oldf <- fromRepo gitAnnexRestageLogOld 	lckf <- fromRepo gitAnnexRestageLock-	calcLogFile logf lckf start $ \l v -> -		case parseRestageLog (decodeBL l) of-			Just pl -> update pl v-			Nothing -> v+	withSharedLock lckf $ do+		mid <- calcLogFileUnsafe logf start process+		calcLogFileUnsafe oldf mid process+  where+	process l v = case parseRestageLog (decodeBL l) of+		Just pl -> update pl v+		Nothing -> v  formatRestageLog :: TopFilePath -> InodeCache -> S.ByteString formatRestageLog f ic = encodeBS (showInodeCache ic) <> ":" <> getTopFilePath f
Remote/S3.hs view
@@ -1,6 +1,6 @@ {- S3 remotes  -- - 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.  -}@@ -156,7 +156,9 @@ signatureField :: RemoteConfigField signatureField = Accepted "signature" -newtype SignatureVersion = SignatureVersion Int+data SignatureVersion +	= SignatureVersion Int+	| Anonymous  signatureVersionParser :: RemoteConfigField -> FieldDesc -> RemoteConfigFieldParser signatureVersionParser f fd =@@ -165,10 +167,17 @@   where 	go "v2" = Just (SignatureVersion 2) 	go "v4" = Just (SignatureVersion 4)+	go "anonymous" = Just Anonymous 	go _ = Nothing  	defver = SignatureVersion 2 +isAnonymous :: ParsedRemoteConfig -> Bool+isAnonymous c = +	case getRemoteConfigValue signatureField c of+		Just Anonymous -> True+		_ -> False+ portField :: RemoteConfigField portField = Accepted "port" @@ -272,7 +281,9 @@ 		(c', encsetup) <- encryptionSetup (c `M.union` defaults) gc 		pc <- either giveup return . parseRemoteConfig c' 			=<< configParser remote c'-		c'' <- setRemoteCredPair ss encsetup pc gc (AWS.creds u) mcreds+		c'' <- if isAnonymous pc+			then pure c'+			else setRemoteCredPair ss encsetup pc gc (AWS.creds u) mcreds 		pc' <- either giveup return . parseRemoteConfig c'' 			=<< configParser remote c'' 		info <- extractS3Info pc'@@ -286,7 +297,9 @@ 		showNote "Internet Archive mode" 		pc <- either giveup return . parseRemoteConfig c 			=<< configParser remote c-		c' <- setRemoteCredPair ss noEncryptionUsed pc gc (AWS.creds u) mcreds+		c' <- if isAnonymous pc+			then pure c+			else setRemoteCredPair ss noEncryptionUsed pc gc (AWS.creds u) mcreds 		-- Ensure user enters a valid bucket name, since 		-- this determines the name of the archive.org item. 		let validbucket = replace " " "-" $ map toLower $@@ -402,19 +415,20 @@  - that is difficult. -} retrieve :: S3HandleVar -> Remote -> RemoteStateHandle -> ParsedRemoteConfig -> S3Info -> Retriever retrieve hv r rs c info = fileRetriever' $ \f k p iv -> withS3Handle hv $ \case-	(Just h) -> +	Right h ->  		eitherS3VersionID info rs c k (T.pack $ bucketObject info k) >>= \case 			Left failreason -> do 				warning failreason 				giveup "cannot download content" 			Right loc -> retrieveHelper info h loc (fromRawFilePath f) p iv-	Nothing ->+	Left S3HandleNeedCreds -> 		getPublicWebUrls' (uuid r) rs info c k >>= \case 			Left failreason -> do 				warning failreason 				giveup "cannot download content" 			Right us -> unlessM (withUrlOptions $ downloadUrl False k p iv us (fromRawFilePath f)) $ 				giveup "failed to download content"+	Left S3HandleAnonymousOldAws -> giveupS3HandleProblem S3HandleAnonymousOldAws (uuid r)  retrieveHelper :: S3Info -> S3Handle -> (Either S3.Object S3VersionID) -> FilePath -> MeterUpdate -> Maybe IncrementalVerifier -> Annex () retrieveHelper info h loc f p iv = retrieveHelper' h f p iv $@@ -449,12 +463,12 @@  checkKey :: S3HandleVar -> Remote -> RemoteStateHandle -> ParsedRemoteConfig -> S3Info -> CheckPresent checkKey hv r rs c info k = withS3Handle hv $ \case-	Just h -> eitherS3VersionID info rs c k (T.pack $ bucketObject info k) >>= \case+	Right h -> eitherS3VersionID info rs c k (T.pack $ bucketObject info k) >>= \case 		Left failreason -> do 			warning failreason 			giveup "cannot check content" 		Right loc -> checkKeyHelper info h loc-	Nothing ->+	Left S3HandleNeedCreds -> 		getPublicWebUrls' (uuid r) rs info c k >>= \case 			Left failreason -> do 				warning failreason@@ -463,6 +477,7 @@ 				let check u = withUrlOptions $  					Url.checkBoth u (fromKey keySize k) 				anyM check us+	Left S3HandleAnonymousOldAws -> giveupS3HandleProblem S3HandleAnonymousOldAws (uuid r)  checkKeyHelper :: S3Info -> S3Handle -> (Either S3.Object S3VersionID) -> Annex Bool checkKeyHelper info h loc = checkKeyHelper' info h o limit@@ -485,8 +500,8 @@  storeExportS3' :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Maybe Magic -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex (Maybe S3Etag, Maybe S3VersionID) storeExportS3' hv r rs info magic f k loc p = withS3Handle hv $ \case-	Just h -> go h-	Nothing -> giveup $ needS3Creds (uuid r)+	Right h -> go h+	Left pr -> giveupS3HandleProblem pr (uuid r)   where 	go h = do 		let o = T.pack $ bucketExportLocation info loc@@ -497,45 +512,44 @@ 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 iv-		Nothing -> case getPublicUrlMaker info of+		Right h -> retrieveHelper info h (Left (T.pack exportloc)) f p iv+		Left S3HandleNeedCreds -> case getPublicUrlMaker info of 			Just geturl -> either giveup return =<< 				Url.withUrlOptions 					(Url.download' p iv (geturl exportloc) f) 			Nothing -> giveup $ needS3Creds (uuid r)+		Left S3HandleAnonymousOldAws -> giveupS3HandleProblem S3HandleAnonymousOldAws (uuid r)   where 	exportloc = bucketExportLocation info loc  removeExportS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Key -> ExportLocation -> Annex () removeExportS3 hv r rs info k loc = withS3Handle hv $ \case-	Just h -> do+	Right h -> do 		checkVersioning info rs k 		liftIO $ runResourceT $ do 			S3.DeleteObjectResponse <- sendS3Handle h $ 				S3.DeleteObject (T.pack $ bucketExportLocation info loc) (bucket info) 			return ()-	Nothing -> giveup $ needS3Creds (uuid r)-  where+	Left p -> giveupS3HandleProblem p (uuid r)  checkPresentExportS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation -> Annex Bool checkPresentExportS3 hv r info k loc = withS3Handle hv $ \case-	Just h -> checkKeyHelper info h (Left (T.pack $ bucketExportLocation info loc))-	Nothing -> case getPublicUrlMaker info of+	Right h -> checkKeyHelper info h (Left (T.pack $ bucketExportLocation info loc))+	Left S3HandleNeedCreds -> case getPublicUrlMaker info of 		Just geturl -> withUrlOptions $ 			Url.checkBoth (geturl $ bucketExportLocation info loc) (fromKey keySize k)-		Nothing -> do-			warning $ needS3Creds (uuid r)-			giveup "No S3 credentials configured"+		Nothing -> giveupS3HandleProblem S3HandleNeedCreds (uuid r)+	Left S3HandleAnonymousOldAws -> giveupS3HandleProblem S3HandleAnonymousOldAws (uuid r)  -- S3 has no move primitive; copy and delete. renameExportS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe ()) renameExportS3 hv r rs info k src dest = Just <$> go   where 	go = withS3Handle hv $ \case-		Just h -> do+		Right h -> do 			checkVersioning info rs k 			go' h-		Nothing -> giveup $ needS3Creds (uuid r)+		Left p -> giveupS3HandleProblem p (uuid r) 	 	go' h = liftIO $ runResourceT $ do 		let co = S3.copyObject (bucket info) dstobject@@ -551,8 +565,8 @@ listImportableContentsS3 :: S3HandleVar -> Remote -> S3Info -> ParsedRemoteConfig -> Annex (Maybe (ImportableContentsChunkable Annex (ContentIdentifier, ByteSize))) listImportableContentsS3 hv r info c = 	withS3Handle hv $ \case-		Nothing -> giveup $ needS3Creds (uuid r)-		Just h -> Just <$> go h+		Right h -> Just <$> go h+		Left p -> giveupS3HandleProblem p (uuid r)   where 	go h = do 		ic <- liftIO $ runResourceT $ extractFromResourceT =<< startlist h@@ -665,7 +679,7 @@ 			return (k, v)   where 	go iv = withS3Handle hv $ \case-		Just h -> do+		Right h -> do 			rewritePreconditionException $ retrieveHelper' h dest p iv $ 				limitGetToContentIdentifier cid $ 					S3.getObject (bucket info) o@@ -677,7 +691,7 @@ 						setS3VersionID info rs k vid 				Left _ -> noop 			return k-		Nothing -> giveup $ needS3Creds (uuid r)+		Left pr -> giveupS3HandleProblem pr (uuid r) 	o = T.pack $ bucketExportLocation info loc retrieveExportWithContentIdentifierS3 _ _ _ _ _ [] _ _ _ = giveup "missing content identifier" @@ -726,12 +740,9 @@  checkPresentExportWithContentIdentifierS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation -> [ContentIdentifier] -> Annex Bool checkPresentExportWithContentIdentifierS3 hv r info _k loc knowncids =-	withS3Handle hv $ \case-		Just h -> flip anyM knowncids $+	withS3HandleOrFail (uuid r) hv $ \h ->+		flip anyM knowncids $ 			checkKeyHelper' info h o . limitHeadToContentIdentifier-		Nothing -> do-			warning $ needS3Creds (uuid r)-			giveup "No S3 credentials configured"   where 	o = T.pack $ bucketExportLocation info loc @@ -841,24 +852,43 @@ 	-> ResourceT IO a sendS3Handle h r = AWS.pureAws (hawscfg h) (hs3cfg h) (hmanager h) r -type S3HandleVar = TVar (Either (Annex (Maybe S3Handle)) (Maybe S3Handle))+type S3HandleVar = TVar (Either (Annex (Either S3HandleProblem S3Handle)) (Either S3HandleProblem S3Handle)) +data S3HandleProblem+	= S3HandleNeedCreds+	| S3HandleAnonymousOldAws++giveupS3HandleProblem :: S3HandleProblem -> UUID -> Annex a+giveupS3HandleProblem S3HandleNeedCreds u = do+	warning $ needS3Creds u+	giveup "No S3 credentials configured"+giveupS3HandleProblem S3HandleAnonymousOldAws _ =+	giveup "This S3 special remote is configured with signature=anonymous, but git-annex is buit with too old a version of the aws library to support that."+ {- Prepares a S3Handle for later use. Does not connect to S3 or do anything  - else expensive. -} mkS3HandleVar :: ParsedRemoteConfig -> RemoteGitConfig -> UUID -> Annex S3HandleVar-mkS3HandleVar c gc u = liftIO $ newTVarIO $ Left $ do-	mcreds <- getRemoteCredPair c gc (AWS.creds u)-	case mcreds of-		Just creds -> do-			awscreds <- liftIO $ genCredentials creds-			let awscfg = AWS.Configuration AWS.Timestamp awscreds debugMapper Nothing-			ou <- getUrlOptions-			return $ Just $ S3Handle (httpManager ou) awscfg s3cfg-		Nothing -> return Nothing+mkS3HandleVar c gc u = liftIO $ newTVarIO $ Left $+	if isAnonymous c+		then +#if MIN_VERSION_aws(0,23,0)+			go =<< liftIO AWS.anonymousCredentials+#else+			return (Left S3HandleAnonymousOldAws)+#endif+		else do+			mcreds <- getRemoteCredPair c gc (AWS.creds u)+			case mcreds of+				Just creds -> go =<< liftIO (genCredentials creds)+				Nothing -> return (Left S3HandleNeedCreds)   where 	s3cfg = s3Configuration c+	go awscreds = do+		let awscfg = AWS.Configuration AWS.Timestamp awscreds debugMapper Nothing+		ou <- getUrlOptions+		return $ Right $ S3Handle (httpManager ou) awscfg s3cfg -withS3Handle :: S3HandleVar -> (Maybe S3Handle -> Annex a) -> Annex a+withS3Handle :: S3HandleVar -> (Either S3HandleProblem S3Handle -> Annex a) -> Annex a withS3Handle hv a = liftIO (readTVarIO hv) >>= \case 	Right hdl -> a hdl 	Left mkhdl -> do@@ -868,10 +898,8 @@  withS3HandleOrFail :: UUID -> S3HandleVar -> (S3Handle -> Annex a) -> Annex a withS3HandleOrFail u hv a = withS3Handle hv $ \case-	Just hdl -> a hdl-	Nothing -> do-		warning $ needS3Creds u-		giveup "No S3 credentials configured"+	Right hdl -> a hdl+	Left p -> giveupS3HandleProblem p u  needS3Creds :: UUID -> String needS3Creds u = missingCredPairFor "S3" (AWS.creds u)
Test.hs view
@@ -92,7 +92,7 @@  optParser :: Parser TestOptions optParser = TestOptions-	<$> snd (tastyParser (tests 1 False True (TestOptions mempty False False Nothing mempty mempty)))+	<$> snd (tastyParser (tests 1 False True (TestOptions mempty False False Nothing mempty False mempty))) 	<*> switch 		( long "keep-failures" 		<> help "preserve repositories on test failure"@@ -111,6 +111,10 @@ 		<> help "run tests with a git config set" 		<> metavar "NAME=VALUE" 		))+	<*> switch+		( long "test-debug"+		<> help "show debug messages for commands run by test suite"+		) 	<*> cmdParams "non-options are for internal use only"   where 	parseconfigvalue s = case break (== '=') s of@@ -355,7 +359,15 @@ 	mk l = testGroup groupname (initTests : map adddep l) 	adddep = Test.Tasty.after AllSucceed (groupname ++ "." ++ initTestsName) 	groupname = "Repo Tests " ++ note-	sep = sep' (replicate numparts [])+	sep l = +		-- Avoid separating into parts that contain less than+		-- 5 tests each. Since the tests depend on the+		-- initTests, this avoids spending too much work running+		-- the initTests once per part.+		let numparts' = if length l `div` numparts > 5+			then numparts+			else length l `div` 5+		in sep' (replicate numparts' []) l 	sep' (p:ps) (l:ls) = sep' (ps++[l:p]) ls 	sep' ps [] = ps 	sep' [] _ = []
Test/Framework.hs view
@@ -65,11 +65,20 @@  -- Run a process. The output and stderr is captured, and is only -- displayed if the process does not return the expected value.+--+-- In debug mode, the output is allowed to pass through. 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)+	debug <- testDebug . testOptions <$> getTestMode+	if debug+		then do+			ret <- withCreateProcess p $ \_ _ _ pid ->+				waitForProcess pid+			(expectedret (ret == ExitSuccess)) @? (faildesc ++ " failed")+		else do+			(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.)@@ -98,7 +107,11 @@ 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) environ expectedret faildesc+	debug <- testDebug . testOptions <$> getTestMode+	let params' = if debug+		then "--debug":params+		else params+	testProcess pp (command:params') environ expectedret faildesc  {- Runs git-annex and returns its standard output. -} git_annex_output :: String -> [String] -> IO String@@ -736,7 +749,12 @@ 	-- 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+	--+	-- When there is a pattern, splitting into parts will cause+	-- extra work.+	numparts = if haspattern+		then 1+		else numjobs * 2  	worker rs nvar a = do 		(n, m) <- atomically $ do@@ -801,15 +819,16 @@ 					, exitFailure 					) 	-	tastyopts = case lookupOption (tastyOptionSet opts) of+	(haspattern, 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+			(True, setOption (TestPattern (Just (TP.Or p (TP.ERE initTestsName))))+				(tastyOptionSet opts))+		TestPattern Nothing ->+			(False, tastyOptionSet opts)  topLevelTestGroup :: [TestTree] -> TestTree topLevelTestGroup = testGroup "Tests"
Types/Test.hs view
@@ -19,6 +19,7 @@ 	, fakeSsh :: Bool 	, concurrentJobs :: Maybe Concurrency 	, testGitConfig :: [(ConfigKey, ConfigValue)]+	, testDebug :: Bool 	, internalData :: CmdParams 	}
Utility/DataUnits.hs view
@@ -73,7 +73,9 @@ {- Storage units are (stupidly) powers of ten. -} storageUnits :: [Unit] storageUnits =-	[ Unit (p 8) "YB" "yottabyte"+	[ Unit (p 10) "QB" "quettabyte"+	, Unit (p 9) "RB" "ronnabyte"+	, Unit (p 8) "YB" "yottabyte" 	, Unit (p 7) "ZB" "zettabyte" 	, Unit (p 6) "EB" "exabyte" 	, Unit (p 5) "PB" "petabyte"
Utility/LockFile/Windows.hs view
@@ -61,7 +61,7 @@ openLock :: ShareMode -> LockFile -> IO (Maybe LockHandle) openLock sharemode f = do 	f' <- convertToNativeNamespace f-#if MIN_VERSION_Win32(2,13,3)+#if MIN_VERSION_Win32(2,13,4) 	r <- tryNonAsync $ createFile_NoRetry f' gENERIC_READ sharemode  		security_attributes oPEN_ALWAYS fILE_ATTRIBUTE_NORMAL 		(maybePtr Nothing)
doc/git-annex-sync.mdwn view
@@ -175,7 +175,8 @@ * `--cleanup`    Removes the local and remote `synced/` branches, which were created-  and pushed by `git-annex sync`.+  and pushed by `git-annex sync`. This option prevents all other syncing+  activities.    This can come in handy when you've synced a change to remotes and now   want to reset your master branch back before that change. So you
doc/git-annex-test.mdwn view
@@ -44,6 +44,16 @@   One valid use of this is to change a git configuration to a value that   is planned to be the new default in a future version of git. +* `--test-debug`++  Normally output of commands run by the test suite is hidden, so even+  when annex.debug or --debug is enabled, it will not be displayed.+  This option makes the full output of commands run by the test suite be+  displayed. It also makes the test suite run git-annex with --debug.++  It's a good idea to use `-J1` in combinaton with this, otherwise+  the output of concurrent tests will be mixed together.+ # SEE ALSO  [[git-annex]](1)
doc/git-annex.mdwn view
@@ -1719,8 +1719,8 @@  * `annex.youtube-dl-options` -  Options to pass to youtube-dl when using it to find the url to download-  for a video.+  Options to pass to youtube-dl (or yt-dlp) when using it to find the url+  to download for a video.    Some options may break git-annex's integration with youtube-dl. For   example, the --output option could cause it to store files somewhere@@ -1730,7 +1730,8 @@  * `annex.youtube-dl-command` -  Command to run for youtube-dl. Default is "youtube-dl".+  Command to run for youtube-dl. Default is to use "youtube-dl" or +  if that is not available in the PATH, to use "yt-dlp".  * `annex.aria-torrent-options`
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 10.20221103+Version: 10.20221212 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -416,7 +416,7 @@    if (os(windows))     Build-Depends:-      Win32 ((>= 2.6.1.0 && < 2.12.0.0) || >= 2.13.3.1),+      Win32 ((>= 2.6.1.0 && < 2.12.0.0) || >= 2.13.4.0),       setenv,       process (>= 1.6.2.0),       silently (>= 1.2.5.1)