From 24ae4b291c22694d517211be3183974bfcbbc8cd Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 27 Mar 2023 15:10:46 -0400 Subject: [PATCH] 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 | 2 +- Annex/Transfer.hs | 50 +++++++++++-------- Backend.hs | 30 +++++------ CHANGELOG | 1 + Command/AddUrl.hs | 42 ++++++++-------- Command/CalcKey.hs | 4 +- Command/Migrate.hs | 5 +- Command/Reinject.hs | 2 +- Command/SendKey.hs | 2 +- Remote/Git.hs | 4 +- ...ecurehashesonly_conflicts_with_addurl.mdwn | 2 + 11 files changed, 79 insertions(+), 65 deletions(-) diff --git a/Annex/Ingest.hs b/Annex/Ingest.hs index 1dcbb2f6a6..e7e5ec3f32 100644 --- a/Annex/Ingest.hs +++ b/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 diff --git a/Annex/Transfer.hs b/Annex/Transfer.hs index 5ead81b655..22801a9619 100644 --- a/Annex/Transfer.hs +++ b/Annex/Transfer.hs @@ -1,6 +1,6 @@ {- git-annex transfers - - - Copyright 2012-2021 Joey Hess + - Copyright 2012-2023 Joey Hess - - 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) - ( a - , ifM (annexSecureHashesOnly <$> Annex.getGitConfig) - ( do - warning $ "annex.securehashesonly blocked transfer of " ++ decodeBS (formatKeyVariety variety) ++ " key" - return observeFailure - , a - ) - ) +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 - variety = fromKey keyVariety k + go checksecure variety = ifM checksecure + ( a + , ifM (annexSecureHashesOnly <$> Annex.getGitConfig) + ( blocked variety + , a + ) + ) + blocked variety = do + warning $ "annex.securehashesonly blocked transfer of " ++ decodeBS (formatKeyVariety variety) ++ " key" + return observeFailure type NumRetries = Integer diff --git a/Backend.hs b/Backend.hs index d3eb9414dd..ba5c6f3650 100644 --- a/Backend.hs +++ b/Backend.hs @@ -54,15 +54,13 @@ 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 - Just a -> do - k <- a source meterupdate - return (k, b) - Nothing -> giveup $ "Cannot generate a key for backend " ++ - decodeBS (formatKeyVariety (B.backendVariety b)) +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) + Nothing -> giveup $ "Cannot generate a key for backend " ++ + decodeBS (formatKeyVariety (B.backendVariety b)) getBackend :: FilePath -> Key -> Annex (Maybe Backend) getBackend file k = maybeLookupBackendVariety (fromKey keyVariety k) >>= \case @@ -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 - =<< checkAttr "annex.backend" f - go (Just _) = Just <$> defaultBackend + go Nothing = do + mb <- maybeLookupBackendVariety . parseKeyVariety . encodeBS + =<< checkAttr "annex.backend" f + 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) diff --git a/CHANGELOG b/CHANGELOG index a38d297c5c..bc5022724c 100644 --- a/CHANGELOG +++ b/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 Thu, 23 Mar 2023 15:04:41 -0400 diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs index 836854d1b3..a65522d1ac 100644 --- a/Command/AddUrl.hs +++ b/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 diff --git a/Command/CalcKey.hs b/Command/CalcKey.hs index b44a2df0cf..4003f8ce43 100644 --- a/Command/CalcKey.hs +++ b/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 diff --git a/Command/Migrate.hs b/Command/Migrate.hs index 0f25b9dac1..f4fb632353 100644 --- a/Command/Migrate.hs +++ b/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)) diff --git a/Command/Reinject.hs b/Command/Reinject.hs index 54492e235b..e5e514c0fe 100644 --- a/Command/Reinject.hs +++ b/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 diff --git a/Command/SendKey.hs b/Command/SendKey.hs index 5a8778bf23..bcc24c72af 100644 --- a/Command/SendKey.hs +++ b/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 diff --git a/Remote/Git.hs b/Remote/Git.hs index afe73cb25e..37b4df4360 100644 --- a/Remote/Git.hs +++ b/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 diff --git a/doc/bugs/securehashesonly_conflicts_with_addurl.mdwn b/doc/bugs/securehashesonly_conflicts_with_addurl.mdwn index d98d545bae..39953a6dae 100644 --- a/doc/bugs/securehashesonly_conflicts_with_addurl.mdwn +++ b/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]]