git-lfs: Added support for http basic auth

This commit is contained in:
Joey Hess 2019-09-24 14:46:20 -04:00
parent 45e5cc63b5
commit 6ae0a44c64
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
5 changed files with 80 additions and 26 deletions

View file

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