Added remote.name.annex-web-options config

Which is a per-remote version of the annex.web-options config.

Had to plumb RemoteGitConfig through to getUrlOptions. In cases where a
special remote does not use curl, there was no need to do that and I used
Nothing instead.

In the case of the addurl and importfeed commands, it seemed best to say
that running these commands is not using the web special remote per se,
so the config is not used for those commands.
This commit is contained in:
Joey Hess 2025-04-01 10:17:38 -04:00
parent 932fac7772
commit e81fd72018
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
19 changed files with 152 additions and 99 deletions

View file

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

View file

@ -74,7 +74,7 @@ youtubeDlNotAllowedMessage = unwords
-- <https://github.com/rg3/youtube-dl/issues/14864>)
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

View file

@ -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"

View file

@ -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|
<a href="#{url}">

View file

@ -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 <id@joeyh.name> Fri, 21 Mar 2025 12:27:11 -0400

View file

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

View file

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

View file

@ -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)

View file

@ -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 $

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

@ -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.

View file

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

View file

@ -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.<name>.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.