diff --git a/Annex/Url.hs b/Annex/Url.hs index 795b4b7b97..1cc742f522 100644 --- a/Annex/Url.hs +++ b/Annex/Url.hs @@ -56,8 +56,8 @@ getUserAgent :: Annex U.UserAgent getUserAgent = Annex.getRead $ fromMaybe defaultUserAgent . Annex.useragent -getUrlOptions :: Annex U.UrlOptions -getUrlOptions = Annex.getState Annex.urloptions >>= \case +getUrlOptions :: Maybe RemoteGitConfig -> Annex U.UrlOptions +getUrlOptions mgc = Annex.getState Annex.urloptions >>= \case Just uo -> return uo Nothing -> do uo <- mk @@ -81,10 +81,15 @@ getUrlOptions = Annex.getState Annex.urloptions >>= \case >>= \case Just output -> pure (lines output) Nothing -> annexHttpHeaders <$> Annex.getGitConfig + + getweboptions = case mgc of + Just gc | not (null (remoteAnnexWebOptions gc)) -> + pure (remoteAnnexWebOptions gc) + _ -> annexWebOptions <$> Annex.getGitConfig checkallowedaddr = words . annexAllowedIPAddresses <$> Annex.getGitConfig >>= \case ["all"] -> do - curlopts <- map Param . annexWebOptions <$> Annex.getGitConfig + curlopts <- map Param <$> getweboptions allowedurlschemes <- annexAllowedUrlSchemes <$> Annex.getGitConfig let urldownloader = if null curlopts && not (any (`S.notMember` U.conduitUrlSchemes) allowedurlschemes) then U.DownloadWithConduit $ @@ -148,8 +153,8 @@ ipAddressesUnlimited :: Annex Bool ipAddressesUnlimited = ("all" == ) . annexAllowedIPAddresses <$> Annex.getGitConfig -withUrlOptions :: (U.UrlOptions -> Annex a) -> Annex a -withUrlOptions a = a =<< getUrlOptions +withUrlOptions :: Maybe RemoteGitConfig -> (U.UrlOptions -> Annex a) -> Annex a +withUrlOptions mgc a = a =<< getUrlOptions mgc -- When downloading an url, if authentication is needed, uses -- git-credential to prompt for username and password. @@ -157,10 +162,10 @@ withUrlOptions a = a =<< getUrlOptions -- Note that, when the downloader is curl, it will not use git-credential. -- If the user wants to, they can configure curl to use a netrc file that -- handles authentication. -withUrlOptionsPromptingCreds :: (U.UrlOptions -> Annex a) -> Annex a -withUrlOptionsPromptingCreds a = do +withUrlOptionsPromptingCreds :: Maybe RemoteGitConfig -> (U.UrlOptions -> Annex a) -> Annex a +withUrlOptionsPromptingCreds mgc a = do g <- Annex.gitRepo - uo <- getUrlOptions + uo <- getUrlOptions mgc prompter <- mkPrompter cc <- Annex.getRead Annex.gitcredentialcache a $ uo diff --git a/Annex/YoutubeDl.hs b/Annex/YoutubeDl.hs index 60245eec9d..722823b60b 100644 --- a/Annex/YoutubeDl.hs +++ b/Annex/YoutubeDl.hs @@ -74,7 +74,7 @@ youtubeDlNotAllowedMessage = unwords -- ) youtubeDl :: URLString -> OsPath -> MeterUpdate -> Annex (Either String (Maybe OsPath)) youtubeDl url workdir p = ifM ipAddressesUnlimited - ( withUrlOptions $ youtubeDl' url workdir p + ( withUrlOptions Nothing $ youtubeDl' url workdir p , return $ Left youtubeDlNotAllowedMessage ) @@ -194,7 +194,7 @@ youtubeDlTo key url dest p = do -- without it. So, this first downloads part of the content and checks -- if it's a html page; only then is youtube-dl used. htmlOnly :: URLString -> a -> Annex a -> Annex a -htmlOnly url fallback a = withUrlOptions $ \uo -> +htmlOnly url fallback a = withUrlOptions Nothing $ \uo -> liftIO (downloadPartial url uo htmlPrefixLength) >>= \case Just bs | isHtmlBs bs -> a _ -> return fallback @@ -202,7 +202,7 @@ htmlOnly url fallback a = withUrlOptions $ \uo -> -- Check if youtube-dl supports downloading content from an url. youtubeDlSupported :: URLString -> Annex Bool youtubeDlSupported url = either (const False) id - <$> withUrlOptions (youtubeDlCheck' url) + <$> withUrlOptions Nothing (youtubeDlCheck' url) -- Check if youtube-dl can find media in an url. -- @@ -211,7 +211,7 @@ youtubeDlSupported url = either (const False) id -- download won't succeed. youtubeDlCheck :: URLString -> Annex (Either String Bool) youtubeDlCheck url = ifM youtubeDlAllowed - ( withUrlOptions $ youtubeDlCheck' url + ( withUrlOptions Nothing $ youtubeDlCheck' url , return $ Left youtubeDlNotAllowedMessage ) @@ -227,7 +227,7 @@ youtubeDlCheck' url uo -- -- (This is not always identical to the filename it uses when downloading.) youtubeDlFileName :: URLString -> Annex (Either String OsPath) -youtubeDlFileName url = withUrlOptions go +youtubeDlFileName url = withUrlOptions Nothing go where go uo | supportedScheme uo url = flip catchIO (pure . Left . show) $ @@ -238,7 +238,7 @@ youtubeDlFileName url = withUrlOptions go -- Does not check if the url contains htmlOnly; use when that's already -- been verified. youtubeDlFileNameHtmlOnly :: URLString -> Annex (Either String OsPath) -youtubeDlFileNameHtmlOnly = withUrlOptions . youtubeDlFileNameHtmlOnly' +youtubeDlFileNameHtmlOnly = withUrlOptions Nothing . youtubeDlFileNameHtmlOnly' youtubeDlFileNameHtmlOnly' :: URLString -> UrlOptions -> Annex (Either String OsPath) youtubeDlFileNameHtmlOnly' url uo diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs index 9f82e4fdc6..ca6d5b3ada 100644 --- a/Assistant/Upgrade.hs +++ b/Assistant/Upgrade.hs @@ -324,7 +324,7 @@ usingDistribution = isJust <$> getEnv "GIT_ANNEX_STANDLONE_ENV" downloadDistributionInfo :: Assistant (Maybe GitAnnexDistribution) downloadDistributionInfo = do - uo <- liftAnnex Url.getUrlOptions + uo <- liftAnnex $ Url.getUrlOptions Nothing gpgcmd <- liftAnnex $ gpgCmd <$> Annex.getGitConfig liftIO $ withTmpDir (literalOsPath "git-annex.tmp") $ \tmpdir -> do let infof = tmpdir literalOsPath "info" diff --git a/Assistant/WebApp/Configurators/IA.hs b/Assistant/WebApp/Configurators/IA.hs index 1b2d05e6e2..3818ad7fbb 100644 --- a/Assistant/WebApp/Configurators/IA.hs +++ b/Assistant/WebApp/Configurators/IA.hs @@ -179,7 +179,7 @@ escapeHeader = escapeURIString (\c -> isUnescapedInURI c && c /= ' ') getRepoInfo :: RemoteConfig -> Widget getRepoInfo c = do - uo <- liftAnnex Url.getUrlOptions + uo <- liftAnnex $ Url.getUrlOptions Nothing urlexists <- liftAnnex $ catchDefaultIO False $ Url.exists url uo [whamlet| diff --git a/CHANGELOG b/CHANGELOG index b2ac6a0a44..44a0305bd3 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -7,6 +7,8 @@ git-annex (10.20250321) UNRELEASED; urgency=medium * fsck: Avoid complaining about required content of dead repositories. * drop: Avoid redundant object directory thawing. * httpalso: Windows url fix. + * Added remote.name.annex-web-options config, which is a per-remote + version of the annex.web-options config. -- Joey Hess Fri, 21 Mar 2025 12:27:11 -0400 diff --git a/CmdLine/GitRemoteAnnex.hs b/CmdLine/GitRemoteAnnex.hs index beacd137a3..d83be209ce 100644 --- a/CmdLine/GitRemoteAnnex.hs +++ b/CmdLine/GitRemoteAnnex.hs @@ -496,7 +496,7 @@ parseSpecialRemoteUrl url remotename = case parseURI url of resolveSpecialRemoteWebUrl :: String -> Annex (Maybe String) resolveSpecialRemoteWebUrl url | "http://" `isPrefixOf` lcurl || "https://" `isPrefixOf` lcurl = - Url.withUrlOptionsPromptingCreds $ \uo -> + Url.withUrlOptionsPromptingCreds Nothing $ \uo -> withTmpFile (literalOsPath "git-remote-annex") $ \tmp h -> do liftIO $ hClose h Url.download' nullMeterUpdate Nothing url tmp uo >>= \case diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs index d81628e6b8..ac825fc409 100644 --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -251,7 +251,7 @@ startWeb addunlockedmatcher o si urlstring = go $ fromMaybe bad $ parseURIPortab go url = startingAddUrl si urlstring o $ if relaxedOption (downloadOptions o) then go' url Url.assumeUrlExists - else Url.withUrlOptions (Url.getUrlInfo urlstring) >>= \case + else Url.withUrlOptions Nothing (Url.getUrlInfo urlstring) >>= \case Right urlinfo -> go' url urlinfo Left err -> do warning (UnquotedString err) @@ -352,7 +352,8 @@ downloadWeb addunlockedmatcher o url urlinfo file = go =<< downloadWith' downloader urlkey webUUID url file where urlkey = addSizeUrlKey urlinfo $ Backend.URL.fromUrl url Nothing (verifiableOption o) - downloader f p = Url.withUrlOptions $ downloadUrl False urlkey p Nothing [url] f + downloader f p = Url.withUrlOptions Nothing $ + downloadUrl False urlkey p Nothing [url] f go Nothing = return Nothing go (Just (tmp, backend)) = ifM (useYoutubeDl o <&&> liftIO (isHtmlFile tmp)) ( tryyoutubedl tmp backend diff --git a/Command/ImportFeed.hs b/Command/ImportFeed.hs index df1537fb65..613c9dd0f8 100644 --- a/Command/ImportFeed.hs +++ b/Command/ImportFeed.hs @@ -268,7 +268,7 @@ findDownloads u f = catMaybes $ map mk (feedItems f) downloadFeed :: URLString -> FilePath -> Annex Bool downloadFeed url f | Url.parseURIRelaxed url == Nothing = giveup "invalid feed url" - | otherwise = Url.withUrlOptions $ + | otherwise = Url.withUrlOptions Nothing $ Url.download nullMeterUpdate Nothing url (toOsPath f) startDownload :: AddUnlockedMatcher -> ImportFeedOptions -> Cache -> TMVar Bool -> ToDownload -> CommandStart @@ -367,7 +367,7 @@ downloadEnclosure addunlockedmatcher opts cache cv todownload url = let go urlinfo = Just . maybeToList <$> addUrlFile addunlockedmatcher dlopts url urlinfo f if relaxedOption (downloadOptions opts) then go Url.assumeUrlExists - else Url.withUrlOptions (Url.getUrlInfo url) >>= \case + else Url.withUrlOptions Nothing (Url.getUrlInfo url) >>= \case Right urlinfo -> go urlinfo Left err -> do warning (UnquotedString err) diff --git a/P2P/Http/Client.hs b/P2P/Http/Client.hs index bfaa14bc89..e71e69f28c 100644 --- a/P2P/Http/Client.hs +++ b/P2P/Http/Client.hs @@ -100,7 +100,7 @@ p2pHttpClientVersions' allowedversion rmt rmtrepo fallback clientaction = case p2pHttpBaseUrl <$> remoteAnnexP2PHttpUrl (gitconfig rmt) of Nothing -> error "internal" Just baseurl -> do - mgr <- httpManager <$> getUrlOptions + mgr <- httpManager <$> getUrlOptions Nothing let clientenv = mkClientEnv mgr baseurl ccv <- Annex.getRead Annex.gitcredentialcache Git.CredentialCache cc <- liftIO $ atomically $ diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs index 5b7a1d6c84..cf3f947c40 100644 --- a/Remote/BitTorrent.hs +++ b/Remote/BitTorrent.hs @@ -66,7 +66,7 @@ gen r _ rc gc rs = do , cost = cst , name = Git.repoDescribe r , storeKey = uploadKey - , retrieveKeyFile = downloadKey + , retrieveKeyFile = downloadKey gc -- Bittorrent downloads out of order, but downloadTorrentContent -- moves the downloaded file to the destination at the end. , retrieveKeyFileInOrder = pure True @@ -94,12 +94,12 @@ gen r _ rc gc rs = do , mkUnavailable = return Nothing , getInfo = return [] , claimUrl = Just (pure . isSupportedUrl) - , checkUrl = Just checkTorrentUrl + , checkUrl = Just (checkTorrentUrl gc) , remoteStateHandle = rs } -downloadKey :: Key -> AssociatedFile -> OsPath -> MeterUpdate -> VerifyConfig -> Annex Verification -downloadKey key _file dest p _ = do +downloadKey :: RemoteGitConfig -> Key -> AssociatedFile -> OsPath -> MeterUpdate -> VerifyConfig -> Annex Verification +downloadKey gc key _file dest p _ = do get . map (torrentUrlNum . fst . getDownloader) =<< getBitTorrentUrls key -- While bittorrent verifies the hash in the torrent file, -- the torrent file itself is downloaded without verification, @@ -112,7 +112,7 @@ downloadKey key _file dest p _ = do ok <- untilTrue urls $ \(u, filenum) -> do registerTorrentCleanup u checkDependencies - ifM (downloadTorrentFile u) + ifM (downloadTorrentFile gc u) ( downloadTorrentContent key u dest filenum p , return False ) @@ -151,11 +151,11 @@ isTorrentMagnetUrl u = "magnet:" `isPrefixOf` u && checkbt (parseURIPortable u) checkbt (Just uri) | "xt=urn:btih:" `isInfixOf` uriQuery uri = True checkbt _ = False -checkTorrentUrl :: URLString -> Annex UrlContents -checkTorrentUrl u = do +checkTorrentUrl :: RemoteGitConfig -> URLString -> Annex UrlContents +checkTorrentUrl gc u = do checkDependencies registerTorrentCleanup u - ifM (downloadTorrentFile u) + ifM (downloadTorrentFile gc u) ( torrentContents u , giveup "could not download torrent file" ) @@ -192,8 +192,8 @@ registerTorrentCleanup u = Annex.addCleanupAction (TorrentCleanup u) $ liftIO . removeWhenExistsWith removeFile =<< tmpTorrentFile u {- Downloads the torrent file. (Not its contents.) -} -downloadTorrentFile :: URLString -> Annex Bool -downloadTorrentFile u = do +downloadTorrentFile :: RemoteGitConfig -> URLString -> Annex Bool +downloadTorrentFile gc u = do torrent <- tmpTorrentFile u ifM (liftIO $ doesFileExist torrent) ( return True @@ -213,7 +213,7 @@ downloadTorrentFile u = do withTmpFileIn othertmp (literalOsPath "torrent") $ \f h -> do liftIO $ hClose h resetAnnexFilePerm f - ok <- Url.withUrlOptions $ + ok <- Url.withUrlOptions (Just gc) $ Url.download nullMeterUpdate Nothing u f when ok $ liftIO $ moveFile f torrent diff --git a/Remote/External.hs b/Remote/External.hs index 251ca666fe..2b26e32239 100644 --- a/Remote/External.hs +++ b/Remote/External.hs @@ -77,9 +77,9 @@ gen rt externalprogram r u rc gc rs exportUnsupported return $ Just $ specialRemote c readonlyStorer - retrieveUrl + (retrieveUrl gc) readonlyRemoveKey - checkKeyUrl + (checkKeyUrl gc) rmt | otherwise = do c <- parsedRemoteConfig remote rc @@ -834,16 +834,16 @@ checkUrlM external url = where mkmulti (u, s, f) = (u, s, toOsPath f) -retrieveUrl :: Retriever -retrieveUrl = fileRetriever' $ \f k p iv -> do +retrieveUrl :: RemoteGitConfig -> Retriever +retrieveUrl gc = fileRetriever' $ \f k p iv -> do us <- getWebUrls k - unlessM (withUrlOptions $ downloadUrl True k p iv us f) $ + unlessM (withUrlOptions (Just gc) $ downloadUrl True k p iv us f) $ giveup "failed to download content" -checkKeyUrl :: CheckPresent -checkKeyUrl k = do +checkKeyUrl :: RemoteGitConfig -> CheckPresent +checkKeyUrl gc k = do us <- getWebUrls k - anyM (\u -> withUrlOptions $ checkBoth u (fromKey keySize k)) us + anyM (\u -> withUrlOptions (Just gc) $ checkBoth u (fromKey keySize k)) us getWebUrls :: Key -> Annex [URLString] getWebUrls key = filter supported <$> getUrls key diff --git a/Remote/Git.hs b/Remote/Git.hs index cda705cb0e..1f8a02e7da 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -142,11 +142,11 @@ isGitRemoteAnnex r = "annex::" `isPrefixOf` Git.repoLocation r - etc. -} gitSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) -gitSetup Init mu _ c _ = do +gitSetup Init mu _ c gc = do let location = maybe (giveup "Specify location=url") fromProposedAccepted $ M.lookup locationField c r <- inRepo $ Git.Construct.fromRemoteLocation location False - r' <- tryGitConfigRead False r False + r' <- tryGitConfigRead gc False r False let u = getUncachedUUID r' if u == NoUUID then giveup "git repository does not have an annex uuid" @@ -187,10 +187,10 @@ configRead autoinit r = do case (repoCheap r, annexignore, hasuuid) of (_, True, _) -> return r (True, _, _) - | remoteAnnexCheckUUID gc -> tryGitConfigRead autoinit r hasuuid + | remoteAnnexCheckUUID gc -> tryGitConfigRead gc autoinit r hasuuid | otherwise -> return r (False, _, False) -> configSpecialGitRemotes r >>= \case - Nothing -> tryGitConfigRead autoinit r False + Nothing -> tryGitConfigRead gc autoinit r False Just r' -> return r' _ -> return r @@ -273,8 +273,8 @@ unavailable r u c gc = gen r' u c gc' {- Tries to read the config for a specified remote, updates state, and - returns the updated repo. -} -tryGitConfigRead :: Bool -> Git.Repo -> Bool -> Annex Git.Repo -tryGitConfigRead autoinit r hasuuid +tryGitConfigRead :: RemoteGitConfig -> Bool -> Git.Repo -> Bool -> Annex Git.Repo +tryGitConfigRead gc autoinit r hasuuid | haveconfig r = return r -- already read | Git.repoIsSsh r = storeUpdatedRemote $ do v <- Ssh.onRemote NoConsumeStdin r @@ -323,7 +323,7 @@ tryGitConfigRead autoinit r hasuuid warning $ UnquotedString $ "Unable to parse git config from " ++ configloc return $ Left exitcode - geturlconfig = Url.withUrlOptionsPromptingCreds $ \uo -> do + geturlconfig = Url.withUrlOptionsPromptingCreds (Just gc) $ \uo -> do let url = Git.repoLocation r ++ "/config" v <- withTmpFile (literalOsPath "git-annex.tmp") $ \tmpfile h -> do liftIO $ hClose h @@ -449,7 +449,7 @@ inAnnex' repo rmt st@(State connpool duc _ _ _) key checkp2phttp = p2pHttpClient rmt giveup (clientCheckPresent key) checkhttp = do gc <- Annex.getGitConfig - Url.withUrlOptionsPromptingCreds $ \uo -> + Url.withUrlOptionsPromptingCreds (Just (gitconfig rmt)) $ \uo -> anyM (\u -> Url.checkBoth u (fromKey keySize key) uo) (keyUrls gc repo rmt key) checkremote = P2PHelper.checkpresent (Ssh.runProto rmt connpool (cantCheck rmt)) key @@ -570,7 +570,7 @@ copyFromRemote'' repo r st@(State connpool _ _ _ _) key af dest meterupdate vc | isP2PHttp r = copyp2phttp | Git.repoIsHttp repo = verifyKeyContentIncrementally vc key $ \iv -> do gc <- Annex.getGitConfig - ok <- Url.withUrlOptionsPromptingCreds $ + ok <- Url.withUrlOptionsPromptingCreds (Just (gitconfig r)) $ Annex.Content.downloadUrl False key meterupdate iv (keyUrls gc repo r key) dest unless ok $ giveup "failed to download content" @@ -890,7 +890,7 @@ mkState r u gc = do rv <- liftIO newEmptyMVar let getrepo = ifM (liftIO $ isEmptyMVar rv) ( do - r' <- tryGitConfigRead False r True + r' <- tryGitConfigRead gc False r True let t = (r', extractGitConfig FromGitConfig r') void $ liftIO $ tryPutMVar rv t return t diff --git a/Remote/GitLFS.hs b/Remote/GitLFS.hs index d598ea5623..fde56b05ed 100644 --- a/Remote/GitLFS.hs +++ b/Remote/GitLFS.hs @@ -101,7 +101,7 @@ gen r u rc gc rs = do } return $ Just $ specialRemote' specialcfg c (store rs h) - (retrieve rs h) + (retrieve gc rs h) (remove h) (checkKey rs h) (this c cst h) @@ -367,7 +367,7 @@ getLFSEndpoint tro hv = do -- Not for use in downloading an object. makeSmallAPIRequest :: Request -> Annex (Response L.ByteString) makeSmallAPIRequest req = do - uo <- getUrlOptions + uo <- getUrlOptions Nothing let req' = applyRequest uo req fastDebug "Remote.GitLFS" (show req') resp <- liftIO $ httpLbs req' (httpManager uo) @@ -499,8 +499,8 @@ store rs h = fileStorer $ \k src p -> getLFSEndpoint LFS.RequestUpload h >>= \ca Just reqs -> forM_ reqs $ makeSmallAPIRequest . setRequestCheckStatus -retrieve :: RemoteStateHandle -> TVar LFSHandle -> Retriever -retrieve rs h = fileRetriever' $ \dest k p iv -> getLFSEndpoint LFS.RequestDownload h >>= \case +retrieve :: RemoteGitConfig -> RemoteStateHandle -> TVar LFSHandle -> Retriever +retrieve gc rs h = fileRetriever' $ \dest k p iv -> getLFSEndpoint LFS.RequestDownload h >>= \case Nothing -> giveup "unable to connect to git-lfs endpoint" Just endpoint -> mkDownloadRequest rs k >>= \case Nothing -> giveup "unable to download this object from git-lfs" @@ -520,7 +520,7 @@ retrieve rs h = fileRetriever' $ \dest k p iv -> getLFSEndpoint LFS.RequestDownl Just op -> case LFS.downloadOperationRequest op of Nothing -> giveup "unable to parse git-lfs server download url" Just req -> do - uo <- getUrlOptions + uo <- getUrlOptions (Just gc) liftIO $ downloadConduit p iv req dest uo -- Since git-lfs does not support removing content, nothing needs to be diff --git a/Remote/HttpAlso.hs b/Remote/HttpAlso.hs index d6ccf15c13..a7b38e2760 100644 --- a/Remote/HttpAlso.hs +++ b/Remote/HttpAlso.hs @@ -57,9 +57,9 @@ gen r u rc gc rs = do ll <- liftIO newLearnedLayout return $ Just $ specialRemote c cannotModify - (downloadKey url ll) + (downloadKey gc url ll) cannotModify - (checkKey url ll) + (checkKey gc url ll) (this url c cst) where this url c cst = Remote @@ -79,9 +79,9 @@ gen r u rc gc rs = do , checkPresentCheap = False , exportActions = ExportActions { storeExport = cannotModify - , retrieveExport = retriveExportHttpAlso url + , retrieveExport = retriveExportHttpAlso gc url , removeExport = cannotModify - , checkPresentExport = checkPresentExportHttpAlso url + , checkPresentExport = checkPresentExportHttpAlso gc url , removeExportDirectory = Nothing , renameExport = cannotModify } @@ -121,34 +121,35 @@ httpAlsoSetup _ (Just u) _ c gc = do gitConfigSpecialRemote u c' [("httpalso", "true")] return (c', u) -downloadKey :: Maybe URLString -> LearnedLayout -> Retriever -downloadKey baseurl ll = fileRetriever' $ \dest key p iv -> - downloadAction dest p iv (keyUrlAction baseurl ll key) +downloadKey :: RemoteGitConfig -> Maybe URLString -> LearnedLayout -> Retriever +downloadKey gc baseurl ll = fileRetriever' $ \dest key p iv -> + downloadAction gc dest p iv (keyUrlAction baseurl ll key) -retriveExportHttpAlso :: Maybe URLString -> Key -> ExportLocation -> OsPath -> MeterUpdate -> Annex Verification -retriveExportHttpAlso baseurl key loc dest p = do +retriveExportHttpAlso :: RemoteGitConfig -> Maybe URLString -> Key -> ExportLocation -> OsPath -> MeterUpdate -> Annex Verification +retriveExportHttpAlso gc baseurl key loc dest p = do verifyKeyContentIncrementally AlwaysVerify key $ \iv -> - downloadAction dest p iv (exportLocationUrlAction baseurl loc) + downloadAction gc dest p iv (exportLocationUrlAction baseurl loc) -downloadAction :: OsPath -> MeterUpdate -> Maybe IncrementalVerifier -> ((URLString -> Annex (Either String ())) -> Annex (Either String ())) -> Annex () -downloadAction dest p iv run = - Url.withUrlOptions $ \uo -> +downloadAction :: RemoteGitConfig -> OsPath -> MeterUpdate -> Maybe IncrementalVerifier -> ((URLString -> Annex (Either String ())) -> Annex (Either String ())) -> Annex () +downloadAction gc dest p iv run = + Url.withUrlOptions (Just gc) $ \uo -> run (\url -> Url.download' p iv url dest uo) >>= either giveup (const (return ())) -checkKey :: Maybe URLString -> LearnedLayout -> CheckPresent -checkKey baseurl ll key = - isRight <$> keyUrlAction baseurl ll key (checkKey' key) +checkKey :: RemoteGitConfig -> Maybe URLString -> LearnedLayout -> CheckPresent +checkKey gc baseurl ll key = + isRight <$> keyUrlAction baseurl ll key (checkKey' gc key) -checkKey' :: Key -> URLString -> Annex (Either String ()) -checkKey' key url = ifM (Url.withUrlOptions $ Url.checkBoth url (fromKey keySize key)) - ( return (Right ()) - , return (Left "content not found") - ) +checkKey' :: RemoteGitConfig -> Key -> URLString -> Annex (Either String ()) +checkKey' gc key url = + ifM (Url.withUrlOptions (Just gc) $ Url.checkBoth url (fromKey keySize key)) + ( return (Right ()) + , return (Left "content not found") + ) -checkPresentExportHttpAlso :: Maybe URLString -> Key -> ExportLocation -> Annex Bool -checkPresentExportHttpAlso baseurl key loc = - isRight <$> exportLocationUrlAction baseurl loc (checkKey' key) +checkPresentExportHttpAlso :: RemoteGitConfig -> Maybe URLString -> Key -> ExportLocation -> Annex Bool +checkPresentExportHttpAlso gc baseurl key loc = + isRight <$> exportLocationUrlAction baseurl loc (checkKey' gc key) type LearnedLayout = TVar (Maybe [Key -> URLString]) diff --git a/Remote/S3.hs b/Remote/S3.hs index df6f4e6c3c..4486a8e891 100644 --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -427,7 +427,7 @@ retrieve hv r rs c info = fileRetriever' $ \f k p iv -> withS3Handle hv $ \case Left failreason -> do warning (UnquotedString failreason) giveup "cannot download content" - Right us -> unlessM (withUrlOptions $ downloadUrl False k p iv us f) $ + Right us -> unlessM (withUrlOptions Nothing $ downloadUrl False k p iv us f) $ giveup "failed to download content" Left S3HandleAnonymousOldAws -> giveupS3HandleProblem S3HandleAnonymousOldAws (uuid r) @@ -475,7 +475,7 @@ checkKey hv r rs c info k = withS3Handle hv $ \case warning (UnquotedString failreason) giveup "cannot check content" Right us -> do - let check u = withUrlOptions $ + let check u = withUrlOptions Nothing $ Url.checkBoth u (fromKey keySize k) anyM check us Left S3HandleAnonymousOldAws -> giveupS3HandleProblem S3HandleAnonymousOldAws (uuid r) @@ -516,7 +516,7 @@ retrieveExportS3 hv r info k loc f p = verifyKeyContentIncrementally AlwaysVerif 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 + withUrlOptions Nothing (Url.download' p iv (geturl exportloc) f) Nothing -> giveup $ needS3Creds (uuid r) Left S3HandleAnonymousOldAws -> giveupS3HandleProblem S3HandleAnonymousOldAws (uuid r) @@ -537,7 +537,7 @@ checkPresentExportS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation checkPresentExportS3 hv r info k loc = withS3Handle hv $ \case Right h -> checkKeyHelper info h (Left (T.pack $ bucketExportLocation info loc)) Left S3HandleNeedCreds -> case getPublicUrlMaker info of - Just geturl -> withUrlOptions $ + Just geturl -> withUrlOptions Nothing $ Url.checkBoth (geturl $ bucketExportLocation info loc) (fromKey keySize k) Nothing -> giveupS3HandleProblem S3HandleNeedCreds (uuid r) Left S3HandleAnonymousOldAws -> giveupS3HandleProblem S3HandleAnonymousOldAws (uuid r) @@ -913,7 +913,7 @@ mkS3HandleVar c gc u = liftIO $ newTVarIO $ Left $ Nothing -> return (Left S3HandleNeedCreds) where go awscreds = do - ou <- getUrlOptions + ou <- getUrlOptions Nothing ua <- getUserAgent let awscfg = AWS.Configuration AWS.Timestamp awscreds debugMapper Nothing let s3cfg = s3Configuration (Just ua) c diff --git a/Remote/Web.hs b/Remote/Web.hs index a097782efe..9ff34e4054 100644 --- a/Remote/Web.hs +++ b/Remote/Web.hs @@ -75,7 +75,7 @@ gen r u rc gc rs = do , cost = cst , name = Git.repoDescribe r , storeKey = uploadKey - , retrieveKeyFile = downloadKey urlincludeexclude + , retrieveKeyFile = downloadKey gc urlincludeexclude , retrieveKeyFileInOrder = pure True , retrieveKeyFileCheap = Nothing -- HttpManagerRestricted is used here, so this is @@ -83,7 +83,7 @@ gen r u rc gc rs = do , retrievalSecurityPolicy = RetrievalAllKeysSecure , removeKey = dropKey urlincludeexclude , lockContent = Nothing - , checkPresent = checkKey urlincludeexclude + , checkPresent = checkKey gc urlincludeexclude , checkPresentCheap = False , exportActions = exportUnsupported , importActions = importUnsupported @@ -115,8 +115,8 @@ setupInstance _ mu _ c _ = do gitConfigSpecialRemote u c [("web", "true")] return (c, u) -downloadKey :: UrlIncludeExclude -> Key -> AssociatedFile -> OsPath -> MeterUpdate -> VerifyConfig -> Annex Verification -downloadKey urlincludeexclude key _af dest p vc = +downloadKey :: RemoteGitConfig -> UrlIncludeExclude -> Key -> AssociatedFile -> OsPath -> MeterUpdate -> VerifyConfig -> Annex Verification +downloadKey gc urlincludeexclude key _af dest p vc = go =<< getWebUrls' urlincludeexclude key where go [] = giveup "no known url" @@ -138,7 +138,7 @@ downloadKey urlincludeexclude key _af dest p vc = ) dl (us, ytus) = do iv <- startVerifyKeyContentIncrementally vc key - ifM (Url.withUrlOptions $ downloadUrl True key p iv (map fst us) dest) + ifM (Url.withUrlOptions (Just gc) $ downloadUrl True key p iv (map fst us) dest) ( finishVerifyKeyContentIncrementally iv >>= \case (True, v) -> postdl v (False, _) -> dl ([], ytus) @@ -177,19 +177,21 @@ uploadKey _ _ _ _ = giveup "upload to web not supported" dropKey :: UrlIncludeExclude -> Maybe SafeDropProof -> Key -> Annex () dropKey urlincludeexclude _proof k = mapM_ (setUrlMissing k) =<< getWebUrls' urlincludeexclude k -checkKey :: UrlIncludeExclude -> Key -> Annex Bool -checkKey urlincludeexclude key = do +checkKey :: RemoteGitConfig -> UrlIncludeExclude -> Key -> Annex Bool +checkKey gc urlincludeexclude key = do us <- getWebUrls' urlincludeexclude key if null us then return False - else either giveup return =<< checkKey' key us -checkKey' :: Key -> [URLString] -> Annex (Either String Bool) -checkKey' key us = firsthit us (Right False) $ \u -> do + else either giveup return =<< checkKey' gc key us + +checkKey' :: RemoteGitConfig -> Key -> [URLString] -> Annex (Either String Bool) +checkKey' gc key us = firsthit us (Right False) $ \u -> do let (u', downloader) = getDownloader u case downloader of YoutubeDownloader -> youtubeDlCheck u' _ -> catchMsgIO $ - Url.withUrlOptions $ Url.checkBoth u' (fromKey keySize key) + Url.withUrlOptions (Just gc) $ + Url.checkBoth u' (fromKey keySize key) where firsthit [] miss _ = return miss firsthit (u:rest) _ a = do diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs index eeae1a0c7e..bf4e9d8835 100644 --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -404,6 +404,7 @@ data RemoteGitConfig = RemoteGitConfig , remoteAnnexBwLimitUpload :: Maybe BwRate , remoteAnnexBwLimitDownload :: Maybe BwRate , remoteAnnexAllowUnverifiedDownloads :: Bool + , remoteAnnexWebOptions :: [String] , remoteAnnexUUID :: Maybe UUID , remoteAnnexConfigUUID :: Maybe UUID , remoteAnnexMaxGitBundles :: Int @@ -492,6 +493,7 @@ extractRemoteGitConfig r remotename = do readBwRatePerSecond =<< getmaybe BWLimitDownloadField , remoteAnnexAllowUnverifiedDownloads = (== Just "ACKTHPPT") $ getmaybe SecurityAllowUnverifiedDownloadsField + , remoteAnnexWebOptions = getwords WebOptionsField , remoteAnnexUUID = toUUID <$> getmaybe UUIDField , remoteAnnexConfigUUID = toUUID <$> getmaybe ConfigUUIDField , remoteAnnexMaxGitBundles = @@ -556,6 +558,7 @@ extractRemoteGitConfig r remotename = do | B.null b -> Nothing | otherwise -> Just (decodeBS b) _ -> Nothing + getwords k = fromMaybe [] $ words <$> getmaybe k data RemoteGitConfigField = CostField @@ -588,6 +591,7 @@ data RemoteGitConfigField | UUIDField | ConfigUUIDField | SecurityAllowUnverifiedDownloadsField + | WebOptionsField | MaxGitBundlesField | AllowEncryptedGitRepoField | ProxyField @@ -656,6 +660,7 @@ remoteGitConfigField = \case UUIDField -> uninherited True "uuid" ConfigUUIDField -> uninherited True "config-uuid" SecurityAllowUnverifiedDownloadsField -> inherited True "security-allow-unverified-downloads" + WebOptionsField -> inherited True "web-options" MaxGitBundlesField -> inherited True "max-git-bundles" AllowEncryptedGitRepoField -> inherited True "allow-encrypted-gitrepo" -- Allow proxy chains. diff --git a/doc/forum/Authentication_for_URL_downloads/comment_1_e5a146811b2ba94eeae424feba52a851._comment b/doc/forum/Authentication_for_URL_downloads/comment_1_e5a146811b2ba94eeae424feba52a851._comment new file mode 100644 index 0000000000..fa6eecb22f --- /dev/null +++ b/doc/forum/Authentication_for_URL_downloads/comment_1_e5a146811b2ba94eeae424feba52a851._comment @@ -0,0 +1,37 @@ +[[!comment format=mdwn + username="joey" + subject="""comment 1""" + date="2025-04-01T13:15:04Z" + content=""" +Well curl does have a --cookie option. But setting that would make all +downloads from the web special remote have the same cookies set. So +exposing them to any other web servers you also use with that remote. + +I think that generally, things involving authentication are a +good use case for writing a little external special remote of your own +that handles the particulars of a given service. Especially if you can +share it with others. [[doc/special_remotes/external/example.sh]] is a good +starting place for writing that. + +That said, this is also right on the line to something it might be possible +for git-annex to support better without you needing to do that work. It's +actually possible to initremote a second web special remote that is limited +to a single host and is used preferentially to the web special remote: + + git-annex initremote --sameas=web archiveorg type=web urlinclude='*archive.org/*' + git config remote.archiveorg.annex-cost 100 + +If `annex.web-options` had a per-remote config, like some other configs do, +but which it currently does not, you could then just set that to pass the +cookies to curl when using that archiveorg special remote: + + git config remote.archiveorg.annex-web-options "--cookie=whatever" + +Since that seems like a good idea, I've implemented it! Get it in the next +release or a daily build. + +PS, you'll also need to set this, which does have its own security +ramifications: + + git config annex.security.allowed-ip-addresses all +"""]] diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn index 03204045a6..8ab22b6a83 100644 --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -2067,18 +2067,18 @@ Remotes are configured using these settings in `.git/config`. Used by hook special remotes to record the type of the remote. -* `annex.web-options` +* `annex.web-options`, `remote..annex-web-options` Options to pass to curl when git-annex uses it to download urls (rather than the default built-in url downloader). For example, to force IPv4 only, set it to "-4". - Setting this option makes git-annex use curl, but only + Setting this makes git-annex use curl, but only when annex.security.allowed-ip-addresses is configured in a specific way. See its documentation. - Setting this option prevents git-annex from using git-credential + Setting this prevents git-annex from using git-credential for prompting for http passwords. Instead, you can include "--netrc" to make curl use your ~/.netrc file and record the passwords there.