improved GitLFS api

Remote/GitLFS.hs

@@ -30,7 +30,6 @@ 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
@@ -232,26 +231,24 @@ discoverLFSEndpoint tro h
 	-- the server requests authentication.
 	gohttp = case LFS.guessEndpoint lfsrepouri of
 		Nothing -> unsupportedurischeme
-		Just endpoint@(LFS.URIEndpoint uri _) ->
+		Just endpoint -> do
-			case LFS.startTransferRequest (LFS.EndpointURI endpoint) transfernothing of
+			let testreq = LFS.startTransferRequest endpoint transfernothing
-				Nothing -> unsupportedurischeme
+			flip catchNonAsync (const (returnendpoint endpoint)) $ do
-				Just testreq -> flip catchNonAsync (const (returnendpoint endpoint)) $ do
+				resp <- makeSmallAPIRequest testreq
-					resp <- makeSmallAPIRequest testreq
+				if needauth (responseStatus resp)
-					if needauth (responseStatus resp)
+					then do
-						then do
+						cred <- prompt $ do
-							cred <- prompt $ do
+							showOutput
-								showOutput
+							inRepo $ Git.getUrlCredential (show lfsrepouri)
-								inRepo $ Git.getUrlCredential (show uri)
+						let endpoint' = addbasicauth cred endpoint
-							let endpoint' = addbasicauth cred endpoint
+						let testreq' = LFS.startTransferRequest endpoint' transfernothing
-							case LFS.startTransferRequest (LFS.EndpointURI endpoint') transfernothing of
+						flip catchNonAsync (const (returnendpoint endpoint')) $ do
-								Nothing -> unsupportedurischeme
+						resp' <- makeSmallAPIRequest testreq'
-								Just testreq' -> flip catchNonAsync (const (returnendpoint endpoint')) $ do
+						inRepo $ if needauth (responseStatus resp')
-									resp' <- makeSmallAPIRequest testreq'
+							then Git.rejectUrlCredential cred
-									inRepo $ if needauth (responseStatus resp')
+							else Git.approveUrlCredential cred
-										then Git.rejectUrlCredential cred
+						returnendpoint endpoint'
-										else Git.approveUrlCredential cred
+					else returnendpoint endpoint
-									returnendpoint endpoint'
-						else returnendpoint endpoint
 	  where
 	  	transfernothing = LFS.TransferRequest
 			{ LFS.req_operation = tro
@@ -259,17 +256,16 @@ discoverLFSEndpoint tro h
 			, LFS.req_ref = Nothing
 			, LFS.req_objects = []
 			}
-		returnendpoint = return . Just . LFS.EndpointURI
+		returnendpoint = return . Just
 
 		needauth status = status == unauthorized401
 
-		addbasicauth cred endpoint@(LFS.URIEndpoint uri httpheaders) =
+		addbasicauth cred endpoint =
 			case (Git.credentialUsername cred, Git.credentialPassword cred) of
-				(Just u, Just p) -> LFS.URIEndpoint uri $
+				(Just u, Just p) ->
-					M.insert (T.pack "Authorization") (T.pack (authheader u p)) httpheaders
+					LFS.modifyEndpointRequest endpoint $
+						applyBasicAuth (encodeBS u) (encodeBS p)
 				_ -> 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)
@@ -310,16 +306,14 @@ sendTransferRequest
 	=> LFS.TransferRequest
 	-> LFS.Endpoint
 	-> Annex (Either String (LFS.TransferResponse op))
-sendTransferRequest req endpoint = 
+sendTransferRequest req endpoint = do
-	case LFS.startTransferRequest endpoint req of
+	let httpreq = LFS.startTransferRequest endpoint req
-		Just httpreq -> do
+	httpresp <- makeSmallAPIRequest $ setRequestCheckStatus httpreq
-			httpresp <- makeSmallAPIRequest $ setRequestCheckStatus httpreq
+	return $ case LFS.parseTransferResponse (responseBody httpresp) of
-			return $ case LFS.parseTransferResponse (responseBody httpresp) of
+		LFS.ParsedTransferResponse resp -> Right resp
-				LFS.ParsedTransferResponse resp -> Right resp
+		LFS.ParsedTransferResponseError tro -> Left $
-				LFS.ParsedTransferResponseError tro -> Left $
+			T.unpack $ LFS.resperr_message tro
-					T.unpack $ LFS.resperr_message tro
+		LFS.ParseFailed err -> Left err
-				LFS.ParseFailed err -> Left err
-		Nothing -> return $ Left "unable to parse git-lfs endpoint url"
 
 extractKeySha256 :: Key -> Maybe LFS.SHA256
 extractKeySha256 k = case keyVariety k of
@@ -463,9 +457,8 @@ checkKey u h key = getLFSEndpoint LFS.RequestDownload h >>= \case
 		-- Unable to find enough information to request the key
 		-- from git-lfs, so it's not present there.
 		Nothing -> return False
-		Just (req, sha256, size) -> case LFS.startTransferRequest endpoint req of
+		Just (req, sha256, size) -> go sha256 size 
-			Nothing -> giveup "unable to parse git-lfs endpoint url"
+			=<< makeSmallAPIRequest (LFS.startTransferRequest endpoint req)
-			Just httpreq -> go sha256 size =<< makeSmallAPIRequest httpreq
   where
 	go sha256 size httpresp
 		| responseStatus httpresp == status200 = go' sha256 size $

Utility/GitLFS.hs

@@ -31,9 +31,9 @@ module Utility.GitLFS (
 	downloadOperationRequest,
 	uploadOperationRequests,
 	-- * endpoint discovery
-	Endpoint(..),
+	Endpoint,
-	URIEndpoint(..),
 	guessEndpoint,
+	modifyEndpointRequest,
 	HostUser,
 	sshDiscoverEndpointCommand,
 	parseSshDiscoverEndpointResponse,
@@ -64,7 +64,6 @@ 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
@@ -280,13 +279,7 @@ instance ToJSON GitRef
 type SHA256 = T.Text
 
 -- | The endpoint of a git-lfs server.
-data Endpoint
+data Endpoint = Endpoint Request
-	= 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
@@ -304,24 +297,41 @@ sshDiscoverEndpointCommand remotepath tro =
 		RequestUpload -> "upload"
 	]
 
+-- Internal smart constructor for an Endpoint.
+-- 
+-- Since this uses the LFS batch API, it adds /objects/batch
+-- to the endpoint url. It also adds the necessary headers to use JSON.
+mkEndpoint :: URI.URI -> Maybe Endpoint
+mkEndpoint uri = do
+	r <- requestFromURI uri
+	let r' = addLfsJsonHeaders $ r { path = path r <> "/objects/batch" }
+	return (Endpoint r')
+
 -- | Parse the json output when doing ssh endpoint discovery.
 parseSshDiscoverEndpointResponse :: L.ByteString -> Maybe Endpoint
-parseSshDiscoverEndpointResponse resp = EndpointDiscovered <$> decode resp
+parseSshDiscoverEndpointResponse resp = do
+	sr <- decode resp
+	uri <- URI.parseURI (T.unpack (endpoint_href sr))
+	endpoint <- mkEndpoint uri
+	return $ modifyEndpointRequest endpoint $ case endpoint_header sr of
+		Nothing -> id
+		Just headers ->
+			let headers' = map convheader (M.toList headers)
+			in \req -> req
+				{ requestHeaders = requestHeaders req ++ headers' }
+  where
+	convheader (k, v) = (CI.mk (E.encodeUtf8 k), E.encodeUtf8 v)
 
 -- | 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
+	"https:" -> endpoint
-	"http:" -> Just endpoint
+	"http:" -> endpoint
 	_ -> Nothing
   where
-	endpoint = URIEndpoint uri' M.empty
+	endpoint = mkEndpoint $ uri
-	uri' = uri
 		-- force https because the git-lfs protocol uses http
 		-- basic auth tokens, which should not be exposed
 		{ URI.uriScheme = "https:"
@@ -337,25 +347,22 @@ guessEndpoint uri = case URI.uriScheme uri of
 	
 	droptrailing c = reverse . dropWhile (== c) . reverse
 
+-- | When an Endpoint is used to generate a Request, this allows adjusting
+-- that Request.
+--
+-- This can be used to add http basic authentication to an Endpoint:
+--
+-- > modifyEndpointRequest (guessEndpoint u) (applyBasicAuth "user" "pass")
+modifyEndpointRequest :: Endpoint -> (Request -> Request) -> Endpoint
+modifyEndpointRequest (Endpoint r) f = Endpoint (f r)
+
 -- | Makes a Request that will start the process of making a transfer to or
 -- from the LFS endpoint.
-startTransferRequest :: Endpoint -> TransferRequest -> Maybe Request
+startTransferRequest :: Endpoint -> TransferRequest -> Request
-startTransferRequest (EndpointURI (URIEndpoint uri headers)) tr = do
+startTransferRequest (Endpoint r) tr = r
-	r <- requestFromURI uri
+	{ method = "POST"
-	return $ addLfsJsonHeaders $ r
+	, requestBody = RequestBodyLBS (encode tr)
-		-- Since this uses the LFS batch API, it adds /objects/batch
+	}
-		-- to the endpoint url.
-		{ path = path r <> "/objects/batch"
-		, method = "POST"
-		, requestBody = RequestBodyLBS (encode tr)
-		, requestHeaders = requestHeaders r ++ 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