git-lfs: Added support for http basic auth

CHANGELOG

@@ -2,6 +2,7 @@ git-annex (7.20190913) UNRELEASED; urgency=medium
 
   * Added --mimetype and --mimeencoding file matching options.
   * Added --unlocked and --locked file matching options.
+  * git-lfs: Added support for http basic auth.
   * git-lfs: Only do endpoint discovery once when concurrency is enabled.
 
  -- Joey Hess <id@joeyh.name>  Thu, 19 Sep 2019 11:11:19 -0400

Remote/GitLFS.hs

@@ -17,6 +17,7 @@ import qualified Git
 import qualified Git.Types as Git
 import qualified Git.Url
 import qualified Git.GCrypt
+import qualified Git.Credential as Git
 import Config
 import Config.Cost
 import Remote.Helper.Special
@@ -29,6 +30,7 @@ import Annex.UUID
 import Crypto
 import Backend.Hash
 import Utility.Hash
+import Utility.Base64
 import Utility.SshHost
 import Logs.RemoteState
 import qualified Utility.GitLFS as LFS
@@ -178,23 +180,17 @@ discoverLFSEndpoint :: LFS.TransferRequestOperation -> LFSHandle -> Annex (Maybe
 discoverLFSEndpoint tro h
 	| Git.repoIsSsh r = gossh
 	| Git.repoIsHttp r = gohttp
-	| otherwise = do
+	| otherwise = unsupportedurischeme
-		warning "git-lfs endpoint has unsupported URI scheme"
-		return Nothing
   where
   	r = remoteRepo h
 	lfsrepouri = case Git.location r of
 		Git.Url u -> u
 		_ -> giveup $ "unsupported git-lfs remote location " ++ Git.repoLocation r
-	gohttp = case tro of
+	
-		LFS.RequestDownload -> return $ LFS.guessEndpoint lfsrepouri
+	unsupportedurischeme = do
-		LFS.RequestUpload -> do
+		warning "git-lfs endpoint has unsupported URI scheme"
-			-- git-lfs does support storing over http,
-			-- but it would need prompting for http basic
-			-- authentication each time git-annex discovered
-			-- the endpoint.
-			warning "Storing content in git-lfs currently needs a ssh repository url, not http."
 		return Nothing
+	
 	gossh = case mkSshHost <$> Git.Url.hostuser r of
 		Nothing -> do
 			warning "Unable to parse ssh url for git-lfs remote."
@@ -228,6 +224,53 @@ discoverLFSEndpoint tro h
 						return Nothing
 					Just endpoint -> return (Just endpoint)
 	
+	-- The endpoint may or may not need http basic authentication,
+	-- which involves using git-credential to prompt for the password.
+	--
+	-- To determine if it does, make a download or upload request to
+	-- it, not including any objects in the request, and see if
+	-- the server requests authentication.
+	gohttp = case LFS.guessEndpoint lfsrepouri of
+		Nothing -> unsupportedurischeme
+		Just endpoint@(LFS.URIEndpoint uri _) ->
+			case LFS.startTransferRequest (LFS.EndpointURI endpoint) transfernothing of
+				Nothing -> unsupportedurischeme
+				Just testreq -> flip catchNonAsync (const (returnendpoint endpoint)) $ do
+					resp <- makeSmallAPIRequest testreq
+					if needauth (responseStatus resp)
+						then do
+							cred <- prompt $ do
+								showOutput
+								inRepo $ Git.getUrlCredential (show uri)
+							let endpoint' = addbasicauth cred endpoint
+							case LFS.startTransferRequest (LFS.EndpointURI endpoint') transfernothing of
+								Nothing -> unsupportedurischeme
+								Just testreq' -> flip catchNonAsync (const (returnendpoint endpoint')) $ do
+									resp' <- makeSmallAPIRequest testreq'
+									inRepo $ if needauth (responseStatus resp')
+										then Git.rejectUrlCredential cred
+										else Git.approveUrlCredential cred
+									returnendpoint endpoint'
+						else returnendpoint endpoint
+	  where
+	  	transfernothing = LFS.TransferRequest
+			{ LFS.req_operation = tro
+			, LFS.req_transfers = [LFS.Basic]
+			, LFS.req_ref = Nothing
+			, LFS.req_objects = []
+			}
+		returnendpoint = return . Just . LFS.EndpointURI
+
+		needauth status = status == unauthorized401
+
+		addbasicauth cred endpoint@(LFS.URIEndpoint uri httpheaders) =
+			case (Git.credentialUsername cred, Git.credentialPassword cred) of
+				(Just u, Just p) -> LFS.URIEndpoint uri $
+					M.insert (T.pack "Authorization") (T.pack (authheader u p)) httpheaders
+				_ -> endpoint
+		  where
+			authheader u p = "Basic " ++ toB64 (u ++ ":" ++ p)
+
 -- The endpoint is cached for later use.
 getLFSEndpoint :: LFS.TransferRequestOperation -> TVar LFSHandle -> Annex (Maybe LFS.Endpoint)
 getLFSEndpoint tro hv = do

Utility/GitLFS.hs

@@ -31,7 +31,8 @@ module Utility.GitLFS (
 	downloadOperationRequest,
 	uploadOperationRequests,
 	-- * endpoint discovery
-	Endpoint,
+	Endpoint(..),
+	URIEndpoint(..),
 	guessEndpoint,
 	HostUser,
 	sshDiscoverEndpointCommand,
@@ -63,6 +64,7 @@ import Data.Aeson.Types
 import GHC.Generics
 import Network.HTTP.Client
 import Data.List
+import Data.Maybe
 import qualified Data.Map as M
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as E
@@ -279,10 +281,14 @@ type SHA256 = T.Text
 
 -- | The endpoint of a git-lfs server.
 data Endpoint
-	= EndpointURI URI.URI
+	= EndpointURI URIEndpoint
 	| EndpointDiscovered SshDiscoveryResponse
 	deriving (Show)
 
+-- | An endpoint that uses a URI, typically http or https.
+data URIEndpoint = URIEndpoint URI.URI (M.Map HTTPHeader HTTPHeaderValue)
+	deriving (Show)
+
 -- | Command to run via ssh with to discover an endpoint. The FilePath is
 -- the location of the git repository on the ssh server.
 --
@@ -305,13 +311,17 @@ parseSshDiscoverEndpointResponse resp = EndpointDiscovered <$> decode resp
 -- | Guesses the LFS endpoint from the http url of a git remote.
 --
 -- https://github.com/git-lfs/git-lfs/blob/master/docs/api/server-discovery.md
-guessEndpoint :: URI.URI -> Maybe Endpoint
+--
+-- Note that this will not include any authentication headers that may be
+-- needed to access the endpoint.
+guessEndpoint :: URI.URI -> Maybe URIEndpoint
 guessEndpoint uri = case URI.uriScheme uri of
 	"https:" -> Just endpoint
 	"http:" -> Just endpoint
 	_ -> Nothing
   where
-	endpoint = EndpointURI $ uri
+	endpoint = URIEndpoint uri' M.empty
+	uri' = uri
 		-- force https because the git-lfs protocol uses http
 		-- basic auth tokens, which should not be exposed
 		{ URI.uriScheme = "https:"
@@ -330,7 +340,7 @@ guessEndpoint uri = case URI.uriScheme uri of
 -- | Makes a Request that will start the process of making a transfer to or
 -- from the LFS endpoint.
 startTransferRequest :: Endpoint -> TransferRequest -> Maybe Request
-startTransferRequest (EndpointURI uri) tr = do
+startTransferRequest (EndpointURI (URIEndpoint uri headers)) tr = do
 	r <- requestFromURI uri
 	return $ addLfsJsonHeaders $ r
 		-- Since this uses the LFS batch API, it adds /objects/batch
@@ -338,14 +348,14 @@ startTransferRequest (EndpointURI uri) tr = do
 		{ path = path r <> "/objects/batch"
 		, method = "POST"
 		, requestBody = RequestBodyLBS (encode tr)
+		, requestHeaders = requestHeaders r ++ headers'
 		}
-startTransferRequest (EndpointDiscovered sr) tr = do
-	uri <- URI.parseURI (T.unpack (endpoint_href sr))
-	req <- startTransferRequest (EndpointURI uri) tr
-	let headers = map convheader $ maybe [] M.toList $ endpoint_header sr
-	return $ req { requestHeaders = requestHeaders req ++ headers }
   where
 	convheader (k, v) = (CI.mk (E.encodeUtf8 k), E.encodeUtf8 v)
+	headers' = map convheader (M.toList headers)
+startTransferRequest (EndpointDiscovered sr) tr = do
+	uri <- URI.parseURI (T.unpack (endpoint_href sr))
+	startTransferRequest (EndpointURI (URIEndpoint uri (fromMaybe M.empty (endpoint_header sr)))) tr
 
 -- | "user@host" or just the hostname.
 type HostUser = String

doc/tips/storing_data_in_git-lfs.mdwn

@@ -24,11 +24,8 @@ because the protocol does not support deletion.
 A git-lfs special remote also functions as a regular git remote. You can
 use things like `git push` and `git pull` with it.
 
-To enable an existing git-lgs remote in another clone of the repository,
+To enable an existing git-lfs remote in another clone of the repository,
 you'll need to provide an url to it again. It's ok to provide a different
 url as long as it points to the same git-lfs repository.
 
 	git annex enableremote lfs url=https://github.com/yourname/yourrepo.git
-
-Note that http urls currently only allow read access to the git-lfs
-repository.

doc/todo/git-lfs_http_authentication.mdwn

@@ -7,3 +7,6 @@ when accessing that repository over http.
 `git credential` provides a way to reuse git's authentication system,
 and would be more appropriate to use here than git-annex's own creds
 system for special remotes. --[[Joey]]
+
+> [[done]] --[[Joey]]
+