addurl, importfeed: Fix failure when annex.securehashesonly is set

The temporary URL key used for the download, before the real key is
generated, was blocked by annex.securehashesonly.

Fixed by passing the Backend that will be used for the final key into
runTransfer. When a Backend is provided, have preCheckSecureHashes
check that, rather than the key being transferred.

Sponsored-by: unqueued on Patreon

Annex/Ingest.hs

@@ -178,7 +178,7 @@ ingest' preferredbackend meterupdate (Just (LockedDown cfg source)) mk restage =
 		Nothing -> do
 			backend <- maybe
 				(chooseBackend $ keyFilename source)
-				(return . Just)
+				return
 				preferredbackend
 			fst <$> genKey source meterupdate backend
 		Just k -> return k

Annex/Transfer.hs

@@ -1,6 +1,6 @@
 {- git-annex transfers
  -
- - Copyright 2012-2021 Joey Hess <id@joeyh.name>
+ - Copyright 2012-2023 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -34,6 +34,7 @@ import Utility.ThreadScheduler
 import Annex.LockPool
 import Types.Key
 import qualified Types.Remote as Remote
+import qualified Types.Backend
 import Types.Concurrency
 import Annex.Concurrent
 import Types.WorkerPool
@@ -64,11 +65,11 @@ upload r key f d witness =
 -- Upload, not supporting canceling detected stalls
 upload' :: Observable v => UUID -> Key -> AssociatedFile -> Maybe StallDetection -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v
 upload' u key f sd d a _witness = guardHaveUUID u $ 
-	runTransfer (Transfer Upload u (fromKey id key)) f sd d a
+	runTransfer (Transfer Upload u (fromKey id key)) Nothing f sd d a
 
 alwaysUpload :: Observable v => UUID -> Key -> AssociatedFile -> Maybe StallDetection -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v
 alwaysUpload u key f sd d a _witness = guardHaveUUID u $ 
-	alwaysRunTransfer (Transfer Upload u (fromKey id key)) f sd d a
+	alwaysRunTransfer (Transfer Upload u (fromKey id key)) Nothing f sd d a
 
 -- Download, supporting canceling detected stalls.
 download :: Remote -> Key -> AssociatedFile -> RetryDecider -> NotifyWitness -> Annex Bool
@@ -87,7 +88,7 @@ download r key f d witness =
 -- Download, not supporting canceling detected stalls.
 download' :: Observable v => UUID -> Key -> AssociatedFile -> Maybe StallDetection -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v
 download' u key f sd d a _witness = guardHaveUUID u $
-	runTransfer (Transfer Download u (fromKey id key)) f sd d a
+	runTransfer (Transfer Download u (fromKey id key)) Nothing f sd d a
 
 guardHaveUUID :: Observable v => UUID -> Annex v -> Annex v
 guardHaveUUID u a
@@ -109,20 +110,20 @@ guardHaveUUID u a
  - Cannot cancel stalls, but when a likely stall is detected, 
  - suggests to the user that they enable stall detection handling.
  -}
-runTransfer :: Observable v => Transfer -> AssociatedFile -> Maybe StallDetection -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v
+runTransfer :: Observable v => Transfer -> Maybe Backend -> AssociatedFile -> Maybe StallDetection -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v
 runTransfer = runTransfer' False
 
 {- Like runTransfer, but ignores any existing transfer lock file for the
  - transfer, allowing re-running a transfer that is already in progress.
  -}
-alwaysRunTransfer :: Observable v => Transfer -> AssociatedFile -> Maybe StallDetection -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v
+alwaysRunTransfer :: Observable v => Transfer -> Maybe Backend -> AssociatedFile -> Maybe StallDetection -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v
 alwaysRunTransfer = runTransfer' True
 
-runTransfer' :: Observable v => Bool -> Transfer -> AssociatedFile -> Maybe StallDetection -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v
-runTransfer' ignorelock t afile stalldetection retrydecider transferaction =
+runTransfer' :: Observable v => Bool -> Transfer -> Maybe Backend -> AssociatedFile -> Maybe StallDetection -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v
+runTransfer' ignorelock t eventualbackend afile stalldetection retrydecider transferaction =
 	enteringStage (TransferStage (transferDirection t)) $
 		debugLocks $
-			preCheckSecureHashes (transferKey t) go
+			preCheckSecureHashes (transferKey t) eventualbackend go
   where
 	go = do
 		info <- liftIO $ startTransferInfo afile
@@ -244,7 +245,7 @@ runTransferrer
 	-> NotifyWitness
 	-> Annex Bool
 runTransferrer sd r k afile retrydecider direction _witness =
-	enteringStage (TransferStage direction) $ preCheckSecureHashes k $ do
+	enteringStage (TransferStage direction) $ preCheckSecureHashes k Nothing $ do
 		info <- liftIO $ startTransferInfo afile
 		go 0 info
   where
@@ -271,18 +272,25 @@ runTransferrer sd r k afile retrydecider direction _witness =
  - still contains content using an insecure hash, remotes will likewise
  - tend to be configured to reject it, so Upload is also prevented.
  -}
-preCheckSecureHashes :: Observable v => Key -> Annex v -> Annex v
-preCheckSecureHashes k a = ifM (isCryptographicallySecure k)
+preCheckSecureHashes :: Observable v => Key -> Maybe Backend -> Annex v -> Annex v
+preCheckSecureHashes k meventualbackend a = case meventualbackend of
+	Just eventualbackend -> go
+		(pure (Types.Backend.isCryptographicallySecure eventualbackend))
+		(Types.Backend.backendVariety eventualbackend)
+	Nothing -> go
+		(isCryptographicallySecure k)
+		(fromKey keyVariety k)
+  where
+	go checksecure variety = ifM checksecure
 		( a
 		, ifM (annexSecureHashesOnly <$> Annex.getGitConfig)
-		( do
-			warning $ "annex.securehashesonly blocked transfer of " ++ decodeBS (formatKeyVariety variety) ++ " key"
-			return observeFailure
+			( blocked variety
 			, a
 			)
 		)
-  where
-	variety = fromKey keyVariety k
+	blocked variety = do
+		warning $ "annex.securehashesonly blocked transfer of " ++ decodeBS (formatKeyVariety variety) ++ " key"
+		return observeFailure
 
 type NumRetries = Integer
 

Backend.hs

@@ -54,10 +54,8 @@ defaultBackend = maybe cache return =<< Annex.getState Annex.backend
 	lookupname = lookupBackendVariety . parseKeyVariety . encodeBS
 
 {- Generates a key for a file. -}
-genKey :: KeySource -> MeterUpdate -> Maybe Backend -> Annex (Key, Backend)
-genKey source meterupdate preferredbackend = do
-	b <- maybe defaultBackend return preferredbackend
-	case B.genKey b of
+genKey :: KeySource -> MeterUpdate -> Backend -> Annex (Key, Backend)
+genKey source meterupdate b = case B.genKey b of
 	Just a -> do
 		k <- a source meterupdate
 		return (k, b)
@@ -78,12 +76,16 @@ unknownBackendVarietyMessage v =
 {- Looks up the backend that should be used for a file.
  - That can be configured on a per-file basis in the gitattributes file,
  - or forced with --backend. -}
-chooseBackend :: RawFilePath -> Annex (Maybe Backend)
+chooseBackend :: RawFilePath -> Annex Backend
 chooseBackend f = Annex.getRead Annex.forcebackend >>= go
   where
-	go Nothing = maybeLookupBackendVariety . parseKeyVariety . encodeBS
+	go Nothing = do
+		mb <- maybeLookupBackendVariety . parseKeyVariety . encodeBS
 			=<< checkAttr "annex.backend" f
-	go (Just _) = Just <$> defaultBackend
+		case mb of
+			Just b -> return b
+			Nothing -> defaultBackend
+	go (Just _) = defaultBackend
 
 {- Looks up a backend by variety. May fail if unsupported or disabled. -}
 lookupBackendVariety :: KeyVariety -> Annex Backend
@@ -111,5 +113,5 @@ isStableKey k = maybe False (`B.isStableKey` k)
 	<$> maybeLookupBackendVariety (fromKey keyVariety k)
 
 isCryptographicallySecure :: Key -> Annex Bool
-isCryptographicallySecure k = maybe False (`B.isCryptographicallySecure` k)
+isCryptographicallySecure k = maybe False B.isCryptographicallySecure
 	<$> maybeLookupBackendVariety (fromKey keyVariety k)

CHANGELOG

@@ -8,6 +8,7 @@ git-annex (10.20230322) UNRELEASED; urgency=medium
   * view: Support annex.maxextensionlength when generating filenames for
     the view branch.
   * Windows: Support urls like "file:///c:/path"
+  * addurl, importfeed: Fix failure when annex.securehashesonly is set.
 
  -- Joey Hess <id@joeyh.name>  Thu, 23 Mar 2023 15:04:41 -0400
 

Command/AddUrl.hs

@@ -323,28 +323,28 @@ addUrlFile addunlockedmatcher o url urlinfo file =
 
 downloadWeb :: AddUnlockedMatcher -> DownloadOptions -> URLString -> Url.UrlInfo -> RawFilePath -> Annex (Maybe Key)
 downloadWeb addunlockedmatcher o url urlinfo file =
-	go =<< downloadWith' downloader urlkey webUUID url (AssociatedFile (Just file))
+	go =<< downloadWith' downloader urlkey webUUID url file
   where
 	urlkey = addSizeUrlKey urlinfo $ Backend.URL.fromUrl url Nothing
 	downloader f p = Url.withUrlOptions $ downloadUrl False urlkey p Nothing [url] f
 	go Nothing = return Nothing
-	go (Just tmp) = ifM (pure (not (rawOption o)) <&&> liftIO (isHtmlFile (fromRawFilePath tmp)))
-		( tryyoutubedl tmp
-		, normalfinish tmp
+	go (Just (tmp, backend)) = ifM (pure (not (rawOption o)) <&&> liftIO (isHtmlFile (fromRawFilePath tmp)))
+		( tryyoutubedl tmp backend
+		, normalfinish tmp backend
 		)
-	normalfinish tmp = checkCanAdd o file $ \canadd -> do
+	normalfinish tmp backend = checkCanAdd o file $ \canadd -> do
 		showDestinationFile (fromRawFilePath file)
 		createWorkTreeDirectory (parentDir file)
-		Just <$> finishDownloadWith canadd addunlockedmatcher tmp webUUID url file
+		Just <$> finishDownloadWith canadd addunlockedmatcher tmp backend webUUID url file
 	-- Ask youtube-dl what filename it will download first, 
 	-- so it's only used when the file contains embedded media.
-	tryyoutubedl tmp = youtubeDlFileNameHtmlOnly url >>= \case
+	tryyoutubedl tmp backend = youtubeDlFileNameHtmlOnly url >>= \case
 		Right mediafile -> 
 			let f = youtubeDlDestFile o file (toRawFilePath mediafile)
 			in lookupKey f >>= \case
 				Just k -> alreadyannexed (fromRawFilePath f) k
 				Nothing -> dl f
-		Left err -> checkRaw (Just err) o Nothing (normalfinish tmp)
+		Left err -> checkRaw (Just err) o Nothing (normalfinish tmp backend)
 	  where
 		dl dest = withTmpWorkDir mediakey $ \workdir -> do
 			let cleanuptmp = pruneTmpWorkDirBefore tmp (liftIO . removeWhenExistsWith R.removeLink)
@@ -358,7 +358,7 @@ downloadWeb addunlockedmatcher o url urlinfo file =
 								showDestinationFile (fromRawFilePath dest)
 								addWorkTree canadd addunlockedmatcher webUUID mediaurl dest mediakey (Just (toRawFilePath mediafile))
 								return $ Just mediakey
-						Right Nothing -> checkRaw Nothing o Nothing (normalfinish tmp)
+						Right Nothing -> checkRaw Nothing o Nothing (normalfinish tmp backend)
 						Left msg -> do
 							cleanuptmp
 							warning msg
@@ -421,29 +421,31 @@ showDestinationFile file = do
  -}
 downloadWith :: CanAddFile -> AddUnlockedMatcher -> (FilePath -> MeterUpdate -> Annex Bool) -> Key -> UUID -> URLString -> RawFilePath -> Annex (Maybe Key)
 downloadWith canadd addunlockedmatcher downloader dummykey u url file =
-	go =<< downloadWith' downloader dummykey u url afile
+	go =<< downloadWith' downloader dummykey u url file
   where
-	afile = AssociatedFile (Just file)
 	go Nothing = return Nothing
-	go (Just tmp) = Just <$> finishDownloadWith canadd addunlockedmatcher tmp u url file
+	go (Just (tmp, backend)) = Just <$> finishDownloadWith canadd addunlockedmatcher tmp backend u url file
 
 {- Like downloadWith, but leaves the dummy key content in
  - the returned location. -}
-downloadWith' :: (FilePath -> MeterUpdate -> Annex Bool) -> Key -> UUID -> URLString -> AssociatedFile -> Annex (Maybe RawFilePath)
-downloadWith' downloader dummykey u url afile =
+downloadWith' :: (FilePath -> MeterUpdate -> Annex Bool) -> Key -> UUID -> URLString -> RawFilePath -> Annex (Maybe (RawFilePath, Backend))
+downloadWith' downloader dummykey u url file =
 	checkDiskSpaceToGet dummykey Nothing $ do
+		backend <- chooseBackend file
 		tmp <- fromRepo $ gitAnnexTmpObjectLocation dummykey
-		ok <- Transfer.notifyTransfer Transfer.Download url $
-			Transfer.download' u dummykey afile Nothing Transfer.stdRetry $ \p -> do
+		let t = (Transfer.Transfer Transfer.Download u (fromKey id dummykey))
+		ok <- Transfer.notifyTransfer Transfer.Download url $ \_w ->
+			Transfer.runTransfer t (Just backend) afile Nothing Transfer.stdRetry $ \p -> do
 				createAnnexDirectory (parentDir tmp)
 				downloader (fromRawFilePath tmp) p
 		if ok
-			then return (Just tmp)
+			then return (Just (tmp, backend))
 			else return Nothing
+  where
+	afile = AssociatedFile (Just file)
 
-finishDownloadWith :: CanAddFile -> AddUnlockedMatcher -> RawFilePath -> UUID -> URLString -> RawFilePath -> Annex Key
-finishDownloadWith canadd addunlockedmatcher tmp u url file = do
-	backend <- chooseBackend file
+finishDownloadWith :: CanAddFile -> AddUnlockedMatcher -> RawFilePath -> Backend -> UUID -> URLString -> RawFilePath -> Annex Key
+finishDownloadWith canadd addunlockedmatcher tmp backend u url file = do
 	let source = KeySource
 		{ keyFilename = file
 		, contentLocation = tmp

Command/CalcKey.hs

@@ -8,7 +8,7 @@
 module Command.CalcKey where
 
 import Command
-import Backend (genKey)
+import Backend (genKey, defaultBackend)
 import Types.KeySource
 import Utility.Metered
 
@@ -21,7 +21,7 @@ cmd = noCommit $ noMessages $ dontCheck repoExists $
 			(batchable run (pure ()))
 
 run :: () -> SeekInput -> String -> Annex Bool
-run _ _ file = tryNonAsync (genKey ks nullMeterUpdate Nothing) >>= \case
+run _ _ file = tryNonAsync (genKey ks nullMeterUpdate =<< defaultBackend) >>= \case
 	Right (k, _) -> do
 		liftIO $ putStrLn $ serializeKey k
 		return True

Command/Migrate.hs

@@ -56,8 +56,7 @@ start o si file key = do
 		Nothing -> stop
 		Just oldbackend -> do
 			exists <- inAnnex key
-			newbackend <- maybe defaultBackend return 
-				=<< chooseBackend file
+			newbackend <- chooseBackend file
 			if (newbackend /= oldbackend || upgradableKey oldbackend key || forced) && exists
 				then go False oldbackend newbackend
 				else if removeSize o && exists
@@ -116,7 +115,7 @@ perform onlyremovesize o file oldkey oldbackend newbackend = go =<< genkey (fast
 			, contentLocation = content
 			, inodeCache = Nothing
 			}
-		newkey <- fst <$> genKey source nullMeterUpdate (Just newbackend)
+		newkey <- fst <$> genKey source nullMeterUpdate newbackend
 		return $ Just (newkey, False)
 	genkey (Just fm) = fm oldkey newbackend afile >>= \case
 		Just newkey -> return (Just (newkey, True))

Command/Reinject.hs

@@ -63,7 +63,7 @@ startSrcDest _ = giveup "specify a src file and a dest file"
 startKnown :: FilePath -> CommandStart
 startKnown src = notAnnexed src' $
 	starting "reinject" ai si $ do
-		(key, _) <- genKey ks nullMeterUpdate Nothing
+		(key, _) <- genKey ks nullMeterUpdate =<< defaultBackend
 		ifM (isKnownKey key)
 			( perform src' key
 			, do

Command/SendKey.hs

@@ -49,7 +49,7 @@ fieldTransfer direction key a = do
 	let afile = AssociatedFile Nothing
 	ok <- maybe (a $ const noop)
 		-- Using noRetry here because we're the sender.
-		(\u -> runner (Transfer direction (toUUID u) (fromKey id key)) afile Nothing noRetry a)
+		(\u -> runner (Transfer direction (toUUID u) (fromKey id key)) Nothing afile Nothing noRetry a)
 		=<< Fields.getField Fields.remoteUUID
 	fastDebug "Command.SendKey" "transfer done"
 	liftIO $ exitBool ok

Remote/Git.hs

@@ -504,7 +504,7 @@ copyFromRemote'' repo r st@(State connpool _ _ _ _) key file dest meterupdate vc
 					Nothing -> return True
 				copier <- mkFileCopier hardlink st
 				(ok, v) <- runTransfer (Transfer Download u (fromKey id key))
-					file Nothing stdRetry $ \p ->
+					Nothing file Nothing stdRetry $ \p ->
 						metered (Just (combineMeterUpdate p meterupdate)) key bwlimit $ \_ p' -> 
 							copier object dest key p' checksuccess vc
 				if ok
@@ -567,7 +567,7 @@ copyToRemote' repo r st@(State connpool duc _ _ _) key file meterupdate
 		-- run copy from perspective of remote
 		res <- onLocalFast st $ ifM (Annex.Content.inAnnex key)
 			( return True
-			, runTransfer (Transfer Download u (fromKey id key)) file Nothing stdRetry $ \p -> do
+			, runTransfer (Transfer Download u (fromKey id key)) Nothing file Nothing stdRetry $ \p -> do
 				let verify = RemoteVerify r
 				copier <- mkFileCopier hardlink st
 				let rsp = RetrievalAllKeysSecure

doc/bugs/securehashesonly_conflicts_with_addurl.mdwn

@@ -13,3 +13,5 @@ addurl https://www.gutenberg.org/cache/epub/2591/pg2591-images.html (to www.gute
 (recording state in git...)
 % ls -l www.gutenberg.org_cache_epub_2591_pg2591-images.html
 www.gutenberg.org_cache_epub_2591_pg2591-images.html -> .git/annex/objects/gg/kG/URL--https&c%%www.gutenberg.org%cache%epub%2591%pg2591-images.html/URL--https&c%%www.gutenberg.org%cache%epub%2591%pg2591-images.html
+
+> [[fixed|done]] --[[Joey]]