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]]