git-lfs 1.0.0 → 1.1.0

raw patch · 3 files changed

+64/−41 lines, 3 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG +8/−0
• Network/GitLFS.hs +55/−40
• git-lfs.cabal +1/−1

@@ -1,3 +1,11 @@+haskell-git-lfs (1.1.0) unstable; urgency=medium++  * Added modifyEndpointRequest, which can be used to make an Endpoint use+    http basic authentication.+  * startTransferRequest no longer generates a Maybe Request. (API change)++ -- Joey Hess <id@joeyh.name>  Tue, 24 Sep 2019 18:17:54 -0400+ haskell-git-lfs (1.0.0) unstable; urgency=medium    * Initial release.

@@ -1,15 +1,13 @@-{-# LANGUAGE DeriveGeneric, FlexibleInstances, FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE LambdaCase #-}+{- git-lfs API+ - + - https://github.com/git-lfs/git-lfs/blob/master/docs/api+ -+ - Copyright 2019 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -} --- |--- Copyright: 2019 Joey Hess <id@joeyh.name>--- License: GNU AGPL version 3 or higher------ git-lfs protocol--- https://github.com/git-lfs/git-lfs/blob/master/docs/api------ This implementation of the git-lfs protocol uses http Request and Response,+-- | This implementation of the git-lfs API uses http Request and Response, -- but leaves actually connecting up the http client to the user. -- -- You'll want to use a Manager that supports https, since the protocol@@ -17,8 +15,12 @@ -- -- Some LFS servers, notably Github's, may require a User-Agent header -- in some of the requests, in order to allow eg, uploads. No such header--- is added by dedault, so be sure to add your own.	+-- is added by default, so be sure to add your own. +{-# LANGUAGE DeriveGeneric, FlexibleInstances, FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}+ module Network.GitLFS ( 	-- * Transfer requests 	TransferRequest(..),@@ -44,7 +46,7 @@ 	-- * Endpoint discovery 	Endpoint, 	guessEndpoint,-	HostUser,+	modifyEndpointRequest, 	sshDiscoverEndpointCommand, 	parseSshDiscoverEndpointResponse, @@ -281,9 +283,7 @@ type SHA256 = T.Text  -- | The endpoint of a git-lfs server.-data Endpoint-	= EndpointURI URI.URI-	| EndpointDiscovered SshDiscoveryResponse+data Endpoint = Endpoint Request 	deriving (Show)  -- | Command to run via ssh with to discover an endpoint. The FilePath is@@ -301,20 +301,41 @@ 		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 guessEndpoint uri = case URI.uriScheme uri of-	"https:" -> Just endpoint-	"http:" -> Just endpoint+	"https:" -> endpoint+	"http:" -> endpoint 	_ -> Nothing   where-	endpoint = EndpointURI $ uri+	endpoint = mkEndpoint $ uri 		-- force https because the git-lfs protocol uses http 		-- basic auth tokens, which should not be exposed 		{ URI.uriScheme = "https:"@@ -330,28 +351,22 @@ 	 	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 uri) 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)-		}-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)---- | "user@host" or just the hostname.-type HostUser = String+startTransferRequest :: Endpoint -> TransferRequest -> Request+startTransferRequest (Endpoint r) tr = r+	{ method = "POST"+	, requestBody = RequestBodyLBS (encode tr)+	}  addLfsJsonHeaders :: Request -> Request addLfsJsonHeaders r = r

@@ -1,5 +1,5 @@ Name: git-lfs-Version: 1.0.0+Version: 1.1.0 Cabal-Version: >= 1.8 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>