support git remotes that need http basic auth

using git credential to get the password

One thing this doesn't do is wrap the password prompting inside the prompt
action. So with -J, the output can be a bit garbled.

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

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 <id@joeyh.name>
+ - Copyright 2013-2020 Joey Hess <id@joeyh.name>
  -
  - 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

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 <id@joeyh.name>  Wed, 01 Jan 2020 12:51:40 -0400
 

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.

Git/Credential.hs

@@ -1,6 +1,6 @@
 {- git credential interface
  -
- - Copyright 2019 Joey Hess <id@joeyh.name>
+ - Copyright 2019-2020 Joey Hess <id@joeyh.name>
  -
  - 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

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

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

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)

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

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

Utility/Url.hs

@@ -1,6 +1,6 @@
 {- Url downloading.
  -
- - Copyright 2011-2019 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2020 Joey Hess <id@joeyh.name>
  -
  - 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))

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