diff --git a/Annex/Content.hs b/Annex/Content.hs index 7c57cf5040..9615513669 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -780,13 +780,12 @@ saveState nocommit = doSideAction $ do {- Downloads content from any of a list of urls, displaying a progress - meter. -} -downloadUrl :: Key -> MeterUpdate -> [Url.URLString] -> FilePath -> Annex Bool -downloadUrl k p urls file = +downloadUrl :: Key -> MeterUpdate -> [Url.URLString] -> FilePath -> Url.UrlOptions -> Annex Bool +downloadUrl k p urls file uo = -- Poll the file to handle configurations where an external -- download command is used. meteredFile file (Just p) k $ - Url.withUrlOptions $ \uo -> - anyM (\u -> Url.download p u file uo) urls + anyM (\u -> Url.download p u file uo) urls {- Copies a key's content, when present, to a temp file. - This is used to speed up some rsyncs. -} diff --git a/Annex/Url.hs b/Annex/Url.hs index bcc6a747f5..08c3e3bf70 100644 --- a/Annex/Url.hs +++ b/Annex/Url.hs @@ -1,13 +1,14 @@ {- Url downloading, with git-annex user agent and configured http - headers, security restrictions, etc. - - - Copyright 2013-2019 Joey Hess + - Copyright 2013-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} module Annex.Url ( withUrlOptions, + withUrlOptionsPromptingCreds, getUrlOptions, getUserAgent, ipAddressesUnlimited, @@ -34,6 +35,7 @@ import qualified Utility.Url as U import Utility.IPAddress import Utility.HttpManagerRestricted import Utility.Metered +import Git.Credential import qualified BuildInfo import Network.Socket @@ -64,6 +66,7 @@ getUrlOptions = Annex.getState Annex.urloptions >>= \case <*> pure urldownloader <*> pure manager <*> (annexAllowedUrlSchemes <$> Annex.getGitConfig) + <*> pure U.noBasicAuth headers = annexHttpHeadersCommand <$> Annex.getGitConfig >>= \case Just cmd -> lines <$> liftIO (readProcess "sh" ["-c", cmd]) @@ -124,6 +127,21 @@ ipAddressesUnlimited = withUrlOptions :: (U.UrlOptions -> Annex a) -> Annex a withUrlOptions a = a =<< getUrlOptions +-- When downloading an url, if authentication is needed, uses +-- git-credential to prompt for username and password. +withUrlOptionsPromptingCreds :: (U.UrlOptions -> Annex a) -> Annex a +withUrlOptionsPromptingCreds a = do + g <- Annex.gitRepo + uo <- getUrlOptions + a $ uo + { U.getBasicAuth = getBasicAuthFromCredential g + -- Can't download with curl and handle basic auth, + -- so avoid using curl. + , U.urlDownloader = case U.urlDownloader uo of + U.DownloadWithCurl _ -> U.DownloadWithConduit $ U.DownloadWithCurlRestricted mempty + v -> v + } + checkBoth :: U.URLString -> Maybe Integer -> U.UrlOptions -> Annex Bool checkBoth url expected_size uo = liftIO (U.checkBoth url expected_size uo) >>= \case diff --git a/CHANGELOG b/CHANGELOG index b80dcfe833..c36aec2821 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -17,6 +17,8 @@ git-annex (7.20191231) UNRELEASED; urgency=medium programs that use GETCONFIG/SETCONFIG are recommended to implement it. * init: Avoid an ugly error message when http remote has no git-annex uuid configured. + * Support git remotes that need http basic auth to be accessed, + using git credential to get the password. -- Joey Hess Wed, 01 Jan 2020 12:51:40 -0400 diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs index 4fb03f6b04..f728eb175e 100644 --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -261,7 +261,7 @@ downloadWeb addunlockedmatcher o url urlinfo file = go =<< downloadWith' downloader urlkey webUUID url (AssociatedFile (Just (toRawFilePath file))) where urlkey = addSizeUrlKey urlinfo $ Backend.URL.fromUrl url Nothing - downloader f p = downloadUrl urlkey p [url] f + downloader f p = Url.withUrlOptions $ downloadUrl urlkey p [url] f go Nothing = return Nothing -- If we downloaded a html file, try to use youtube-dl to -- extract embedded media. diff --git a/Git/Credential.hs b/Git/Credential.hs index 5de95d1a37..9465d27963 100644 --- a/Git/Credential.hs +++ b/Git/Credential.hs @@ -1,6 +1,6 @@ {- git credential interface - - - Copyright 2019 Joey Hess + - Copyright 2019-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -22,6 +22,23 @@ credentialUsername = M.lookup "username" . fromCredential credentialPassword :: Credential -> Maybe String credentialPassword = M.lookup "password" . fromCredential +credentialBasicAuth :: Credential -> Maybe BasicAuth +credentialBasicAuth cred = BasicAuth + <$> credentialUsername cred + <*> credentialPassword cred + +getBasicAuthFromCredential :: Repo -> GetBasicAuth +getBasicAuthFromCredential r u = do + c <- getUrlCredential u r + case credentialBasicAuth c of + Just ba -> return $ Just (ba, signalsuccess c) + Nothing -> do + signalsuccess c False + return Nothing + where + signalsuccess c True = approveUrlCredential c r + signalsuccess c False = rejectUrlCredential c r + -- | This may prompt the user for login information, or get cached login -- information. getUrlCredential :: URLString -> Repo -> IO Credential diff --git a/Remote/External.hs b/Remote/External.hs index cf3676ccec..750e6ed773 100644 --- a/Remote/External.hs +++ b/Remote/External.hs @@ -747,7 +747,7 @@ checkUrlM external url = retrieveUrl :: Retriever retrieveUrl = fileRetriever $ \f k p -> do us <- getWebUrls k - unlessM (downloadUrl k p us f) $ + unlessM (withUrlOptions $ downloadUrl k p us f) $ giveup "failed to download content" checkKeyUrl :: Git.Repo -> CheckPresent diff --git a/Remote/Git.hs b/Remote/Git.hs index eb66215ab7..ea07c0e4c4 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -276,7 +276,7 @@ tryGitConfigRead autoinit r warning $ "Unable to parse git config from " ++ configloc return $ Left l - geturlconfig = Url.withUrlOptions $ \uo -> do + geturlconfig = Url.withUrlOptionsPromptingCreds $ \uo -> do v <- withTmpFile "git-annex.tmp" $ \tmpfile h -> do liftIO $ hClose h let url = Git.repoLocation r ++ "/config" @@ -382,7 +382,7 @@ inAnnex' repo rmt (State connpool duc _ _) key checkhttp = do showChecking repo gc <- Annex.getGitConfig - ifM (Url.withUrlOptions $ \uo -> anyM (\u -> Url.checkBoth u (fromKey keySize key) uo) (keyUrls gc repo rmt key)) + ifM (Url.withUrlOptionsPromptingCreds $ \uo -> anyM (\u -> Url.checkBoth u (fromKey keySize key) uo) (keyUrls gc repo rmt key)) ( return True , giveup "not found" ) @@ -514,7 +514,8 @@ copyFromRemote'' :: Git.Repo -> Bool -> Remote -> State -> Key -> AssociatedFile copyFromRemote'' repo forcersync r st@(State connpool _ _ _) key file dest meterupdate | Git.repoIsHttp repo = unVerified $ do gc <- Annex.getGitConfig - Annex.Content.downloadUrl key meterupdate (keyUrls gc repo r key) dest + Url.withUrlOptionsPromptingCreds $ + Annex.Content.downloadUrl key meterupdate (keyUrls gc repo r key) dest | not $ Git.repoIsUrl repo = guardUsable repo (unVerified (return False)) $ do params <- Ssh.rsyncParams r Download u <- getUUID diff --git a/Remote/GitLFS.hs b/Remote/GitLFS.hs index f400d0dd9e..2f91d1c77a 100644 --- a/Remote/GitLFS.hs +++ b/Remote/GitLFS.hs @@ -37,6 +37,7 @@ import Crypto import Backend.Hash import Utility.Hash import Utility.SshHost +import Utility.Url import Logs.Remote import Logs.RemoteState import qualified Utility.GitLFS as LFS @@ -283,7 +284,7 @@ discoverLFSEndpoint tro h if needauth (responseStatus resp) then do cred <- prompt $ inRepo $ Git.getUrlCredential (show lfsrepouri) - let endpoint' = addbasicauth cred endpoint + let endpoint' = addbasicauth (Git.credentialBasicAuth cred) endpoint let testreq' = LFS.startTransferRequest endpoint' transfernothing flip catchNonAsync (const (returnendpoint endpoint')) $ do resp' <- makeSmallAPIRequest testreq' @@ -303,12 +304,10 @@ discoverLFSEndpoint tro h needauth status = status == unauthorized401 - addbasicauth cred endpoint = - case (Git.credentialUsername cred, Git.credentialPassword cred) of - (Just u, Just p) -> - LFS.modifyEndpointRequest endpoint $ - applyBasicAuth (encodeBS u) (encodeBS p) - _ -> endpoint + addbasicauth (Just ba) endpoint = + LFS.modifyEndpointRequest endpoint $ + applyBasicAuth' ba + addbasicauth Nothing endpoint = endpoint -- The endpoint is cached for later use. getLFSEndpoint :: LFS.TransferRequestOperation -> TVar LFSHandle -> Annex (Maybe LFS.Endpoint) diff --git a/Remote/S3.hs b/Remote/S3.hs index 8e925a3f91..ff5484464d 100644 --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -387,7 +387,7 @@ retrieve hv r rs c info = fileRetriever $ \f k p -> withS3Handle hv $ \case Left failreason -> do warning failreason giveup "cannot download content" - Right us -> unlessM (downloadUrl k p us f) $ + Right us -> unlessM (withUrlOptions $ downloadUrl k p us f) $ giveup "failed to download content" retrieveHelper :: S3Info -> S3Handle -> (Either S3.Object S3VersionID) -> FilePath -> MeterUpdate -> Annex () diff --git a/Remote/Web.hs b/Remote/Web.hs index 1df743ed3a..a2c0cb6407 100644 --- a/Remote/Web.hs +++ b/Remote/Web.hs @@ -90,7 +90,7 @@ downloadKey key _af dest p = unVerified $ get =<< getWebUrls key YoutubeDownloader -> do showOutput youtubeDlTo key u' dest - _ -> downloadUrl key p [u'] dest + _ -> Url.withUrlOptions $ downloadUrl key p [u'] dest downloadKeyCheap :: Key -> AssociatedFile -> FilePath -> Annex Bool downloadKeyCheap _ _ _ = return False diff --git a/Utility/Url.hs b/Utility/Url.hs index 2aa4e6a589..37fb705351 100644 --- a/Utility/Url.hs +++ b/Utility/Url.hs @@ -1,6 +1,6 @@ {- Url downloading. - - - Copyright 2011-2019 Joey Hess + - Copyright 2011-2020 Joey Hess - - License: BSD-2-clause -} @@ -8,6 +8,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE BangPatterns #-} module Utility.Url ( newManager, @@ -35,6 +36,10 @@ module Utility.Url ( parseURIRelaxed, matchStatusCodeException, matchHttpExceptionContent, + BasicAuth(..), + GetBasicAuth, + noBasicAuth, + applyBasicAuth', ) where import Common @@ -84,6 +89,7 @@ data UrlOptions = UrlOptions , applyRequest :: Request -> Request , httpManager :: Manager , allowedSchemes :: S.Set Scheme + , getBasicAuth :: GetBasicAuth } data UrlDownloader @@ -101,10 +107,11 @@ defUrlOptions = UrlOptions <*> pure id <*> newManager tlsManagerSettings <*> pure (S.fromList $ map mkScheme ["http", "https", "ftp"]) + <*> pure noBasicAuth -mkUrlOptions :: Maybe UserAgent -> Headers -> UrlDownloader -> Manager -> S.Set Scheme -> UrlOptions -mkUrlOptions defuseragent reqheaders urldownloader manager = - UrlOptions useragent reqheaders urldownloader applyrequest manager +mkUrlOptions :: Maybe UserAgent -> Headers -> UrlDownloader -> Manager -> S.Set Scheme -> GetBasicAuth -> UrlOptions +mkUrlOptions defuseragent reqheaders urldownloader manager getbasicauth = + UrlOptions useragent reqheaders urldownloader applyrequest manager getbasicauth where applyrequest = \r -> r { requestHeaders = requestHeaders r ++ addedheaders } addedheaders = uaheader ++ otherheaders @@ -197,14 +204,14 @@ getUrlInfo url uo = case parseURIRelaxed url of Nothing -> return (Right dne) where go :: URI -> IO (Either String UrlInfo) - go u = case (urlDownloader uo, parseUrlRequest (show u)) of + go u = case (urlDownloader uo, parseRequest (show u)) of (DownloadWithConduit (DownloadWithCurlRestricted r), Just req) -> catchJust -- When http redirects to a protocol which -- conduit does not support, it will throw -- a StatusCodeException with found302 -- and a Response with the redir Location. (matchStatusCodeException (== found302)) - (Right <$> existsconduit req) + (Right <$> existsconduit req uo) (followredir r) `catchNonAsync` (const $ return $ Right dne) (DownloadWithConduit (DownloadWithCurlRestricted r), Nothing) @@ -243,18 +250,28 @@ getUrlInfo url uo = case parseURIRelaxed url of extractfilename = contentDispositionFilename . B8.toString <=< lookup hContentDisposition . responseHeaders - existsconduit req = do + existsconduit req uo' = do let req' = headRequest (applyRequest uo req) debugM "url" (show req') - runResourceT $ do + join $ runResourceT $ do resp <- http req' (httpManager uo) -- forces processing the response while -- within the runResourceT liftIO $ if responseStatus resp == ok200 - then found - (extractlen resp) - (extractfilename resp) - else return dne + then do + let !len = extractlen resp + let !fn = extractfilename resp + return $ found len fn + else if responseStatus resp == unauthorized401 + then return $ getBasicAuth uo' (show (getUri req)) >>= \case + Nothing -> return dne + Just (ba, signalsuccess) -> do + ui <- existsconduit + (applyBasicAuth' ba req) + (uo' { getBasicAuth = noBasicAuth }) + signalsuccess (urlExists ui) + return ui + else return $ return dne existscurl u curlparams = do output <- catchDefaultIO "" $ @@ -284,6 +301,7 @@ getUrlInfo url uo = case parseURIRelaxed url of sz <- getFileSize' f stat found (Just sz) Nothing Nothing -> return dne + followredir r (HttpExceptionRequest _ (StatusCodeException resp _)) = case headMaybe $ map decodeBS $ getResponseHeader hLocation resp of Just url' -> case parseURIRelaxed url' of @@ -334,7 +352,7 @@ download' nocurlerror meterupdate url file uo = where go = case parseURIRelaxed url of Just u -> checkPolicy uo u $ - case (urlDownloader uo, parseUrlRequest (show u)) of + case (urlDownloader uo, parseRequest (show u)) of (DownloadWithConduit (DownloadWithCurlRestricted r), Just req) -> catchJust (matchStatusCodeException (== found302)) (downloadConduit meterupdate req file uo >> return (Right ())) @@ -416,12 +434,18 @@ downloadConduit :: MeterUpdate -> Request -> FilePath -> UrlOptions -> IO () downloadConduit meterupdate req file uo = catchMaybeIO (getFileSize file) >>= \case Just sz | sz > 0 -> resumedownload sz - _ -> runResourceT $ do + _ -> join $ runResourceT $ do liftIO $ debugM "url" (show req') resp <- http req' (httpManager uo) if responseStatus resp == ok200 - then store zeroBytesProcessed WriteMode resp - else respfailure resp + then do + store zeroBytesProcessed WriteMode resp + return (return ()) + else if responseStatus resp == unauthorized401 + then return $ getBasicAuth uo (show (getUri req')) >>= \case + Nothing -> respfailure resp + Just ba -> retryauthed ba + else return $ respfailure resp where req' = applyRequest uo $ req -- Override http-client's default decompression of gzip @@ -440,15 +464,23 @@ downloadConduit meterupdate req file uo = dl (const noop) where - dl = runResourceT $ do + dl = join $ runResourceT $ do let req'' = req' { requestHeaders = resumeFromHeader sz : requestHeaders req } liftIO $ debugM "url" (show req'') resp <- http req'' (httpManager uo) if responseStatus resp == partialContent206 - then store (toBytesProcessed sz) AppendMode resp + then do + store (toBytesProcessed sz) AppendMode resp + return (return ()) else if responseStatus resp == ok200 - then store zeroBytesProcessed WriteMode resp - else respfailure resp + then do + store zeroBytesProcessed WriteMode resp + return (return ()) + else if responseStatus resp == unauthorized401 + then return $ getBasicAuth uo (show (getUri req'')) >>= \case + Nothing -> respfailure resp + Just ba -> retryauthed ba + else return $ respfailure resp alreadydownloaded sz s h = s == requestedRangeNotSatisfiable416 && case lookup hContentRange h of @@ -469,6 +501,18 @@ downloadConduit meterupdate req file uo = respfailure = giveup . B8.toString . statusMessage . responseStatus + retryauthed (ba, signalsuccess) = do + r <- tryNonAsync $ downloadConduit + meterupdate + (applyBasicAuth' ba req) + file + (uo { getBasicAuth = noBasicAuth }) + case r of + Right () -> signalsuccess True + Left e -> do + signalsuccess False + throwM e + {- Sinks a Response's body to a file. The file can either be opened in - WriteMode or AppendMode. Updates the meter as data is received. - @@ -502,7 +546,7 @@ downloadPartial url uo n = case parseURIRelaxed url of Nothing -> return Nothing Just u -> go u `catchNonAsync` const (return Nothing) where - go u = case parseUrlRequest (show u) of + go u = case parseRequest (show u) of Nothing -> return Nothing Just req -> do let req' = applyRequest uo req @@ -517,9 +561,6 @@ parseURIRelaxed :: URLString -> Maybe URI parseURIRelaxed s = maybe (parseURIRelaxed' s) Just $ parseURI $ escapeURIString isAllowedInURI s -parseUrlRequest :: URLString -> Maybe Request -parseUrlRequest = parseUrlThrow - {- Some characters like '[' are allowed in eg, the address of - an uri, but cannot appear unescaped further along in the uri. - This handles that, expensively, by successively escaping each character @@ -628,3 +669,22 @@ curlRestrictedParams r u defport ps = case uriAuthority u of , Param "--max-redirs", Param "0" ] bracketaddr a = "[" ++ a ++ "]" + +data BasicAuth = BasicAuth + { basicAuthUser :: String + , basicAuthPassword :: String + } + +-- Note that this is only used when using conduit, not curl. +-- +-- The returned IO action is run after trying to use the BasicAuth, +-- indicating if the password worked. +type GetBasicAuth = URLString -> IO (Maybe (BasicAuth, Bool -> IO ())) + +noBasicAuth :: GetBasicAuth +noBasicAuth = const $ pure Nothing + +applyBasicAuth' :: BasicAuth -> Request -> Request +applyBasicAuth' ba = applyBasicAuth + (encodeBS (basicAuthUser ba)) + (encodeBS (basicAuthPassword ba)) diff --git a/doc/bugs/leaks_git_config_error_message_upon_inability_to_read_downloaded___34__config__34___file.mdwn b/doc/bugs/leaks_git_config_error_message_upon_inability_to_read_downloaded___34__config__34___file.mdwn index 63c691cd6e..9457d4b8bf 100644 --- a/doc/bugs/leaks_git_config_error_message_upon_inability_to_read_downloaded___34__config__34___file.mdwn +++ b/doc/bugs/leaks_git_config_error_message_upon_inability_to_read_downloaded___34__config__34___file.mdwn @@ -145,3 +145,6 @@ git annex 7.20190819+git2-g908476a9b-1~ndall+1 and the same with bleeding edge 7 [[!meta author=yoh]] [[!tag projects/dandi]] +> [[done]]; the error message is improved and also git remotes that need +> http basic auth to access will get password from `git credential`. +> --[[Joey]]