improved GitLFS api

This commit is contained in:
Joey Hess 2019-09-24 17:59:49 -04:00
parent 81610b5af0
commit bc1b9a2c0a
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
2 changed files with 76 additions and 76 deletions

View file

@ -31,9 +31,9 @@ module Utility.GitLFS (
downloadOperationRequest,
uploadOperationRequests,
-- * endpoint discovery
Endpoint(..),
URIEndpoint(..),
Endpoint,
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
= 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)
data Endpoint = Endpoint Request
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
--
-- Note that this will not include any authentication headers that may be
-- needed to access the endpoint.
guessEndpoint :: URI.URI -> Maybe URIEndpoint
guessEndpoint :: URI.URI -> Maybe Endpoint
guessEndpoint uri = case URI.uriScheme uri of
"https:" -> Just endpoint
"http:" -> Just endpoint
"https:" -> endpoint
"http:" -> endpoint
_ -> Nothing
where
endpoint = URIEndpoint uri' M.empty
uri' = uri
endpoint = mkEndpoint $ 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 (EndpointURI (URIEndpoint uri headers)) tr = do
r <- requestFromURI uri
return $ addLfsJsonHeaders $ r
-- 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
startTransferRequest :: Endpoint -> TransferRequest -> Request
startTransferRequest (Endpoint r) tr = r
{ method = "POST"
, requestBody = RequestBodyLBS (encode tr)
}
-- | "user@host" or just the hostname.
type HostUser = String