git-lfs: Added support for http basic auth
This commit is contained in:
parent
45e5cc63b5
commit
6ae0a44c64
5 changed files with 80 additions and 26 deletions
|
@ -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
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue