--- /dev/null
+{- 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.
+ -}
+
+-- | 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
+-- uses http basic auth.
+--
+-- 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 default, so be sure to add your own.
+
+{-# LANGUAGE DeriveGeneric, FlexibleInstances, FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
+
+-- This is a vendored copy of Network.GitLFS from the git-lfs package,
+-- and will be removed once that package is available in all build
+-- environments.
+module Utility.GitLFS (
+ -- * Transfer requests
+ TransferRequest(..),
+ TransferRequestOperation(..),
+ TransferAdapter(..),
+ TransferRequestObject(..),
+ startTransferRequest,
+
+ -- * Responses to transfer requests
+ TransferResponse(..),
+ TransferResponseOperation(..),
+ IsTransferResponseOperation,
+ DownloadOperation(..),
+ UploadOperation(..),
+ OperationParams(..),
+ ParsedTransferResponse(..),
+ parseTransferResponse,
+
+ -- * Making transfers
+ downloadOperationRequest,
+ uploadOperationRequests,
+ ServerSupportsChunks(..),
+
+ -- * Endpoint discovery
+ Endpoint,
+ guessEndpoint,
+ modifyEndpointRequest,
+ sshDiscoverEndpointCommand,
+ parseSshDiscoverEndpointResponse,
+
+ -- * Errors
+ TransferResponseError(..),
+ TransferResponseObjectError(..),
+
+ -- * Additional data types
+ Url,
+ SHA256,
+ GitRef(..),
+ NumSeconds,
+ HTTPHeader,
+ HTTPHeaderValue,
+) where
+
+import Data.Aeson
+import Data.Aeson.Types
+import GHC.Generics
+import Network.HTTP.Client
+import Data.List
+import qualified Data.Map as M
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as E
+import qualified Data.ByteString.Lazy as L
+import qualified Data.CaseInsensitive as CI
+import qualified Network.URI as URI
+
+data TransferRequest = TransferRequest
+ { req_operation :: TransferRequestOperation
+ , req_transfers :: [TransferAdapter]
+ , req_ref :: Maybe GitRef
+ , req_objects :: [TransferRequestObject]
+ }
+ deriving (Generic, Show)
+
+instance ToJSON TransferRequest where
+ toJSON = genericToJSON transferRequestOptions
+ toEncoding = genericToEncoding transferRequestOptions
+
+instance FromJSON TransferRequest where
+ parseJSON = genericParseJSON transferRequestOptions
+
+transferRequestOptions :: Options
+transferRequestOptions = stripFieldPrefix nonNullOptions
+
+data TransferRequestObject = TransferRequestObject
+ { req_oid :: SHA256
+ , req_size :: Integer
+ }
+ deriving (Generic, Show)
+
+instance ToJSON TransferRequestObject where
+ toJSON = genericToJSON transferRequestObjectOptions
+ toEncoding = genericToEncoding transferRequestObjectOptions
+
+instance FromJSON TransferRequestObject where
+ parseJSON = genericParseJSON transferRequestObjectOptions
+
+transferRequestObjectOptions :: Options
+transferRequestObjectOptions = stripFieldPrefix defaultOptions
+
+data TransferRequestOperation = RequestDownload | RequestUpload
+ deriving (Show)
+
+instance ToJSON TransferRequestOperation where
+ toJSON RequestDownload = "download"
+ toJSON RequestUpload = "upload"
+
+instance FromJSON TransferRequestOperation where
+ parseJSON (String "download") = pure RequestDownload
+ parseJSON (String "upload") = pure RequestUpload
+ parseJSON invalid = typeMismatch "TransferRequestOperation" invalid
+
+data TransferResponse op = TransferResponse
+ { transfer :: Maybe TransferAdapter
+ , objects :: [TransferResponseOperation op]
+ }
+ deriving (Generic, Show)
+
+instance IsTransferResponseOperation op => ToJSON (TransferResponse op) where
+ toJSON = genericToJSON nonNullOptions
+ toEncoding = genericToEncoding nonNullOptions
+
+instance IsTransferResponseOperation op => FromJSON (TransferResponse op)
+
+-- | This is an error with a TransferRequest as a whole. It's also possible
+-- for a TransferRequest to overall succeed, but fail for some
+-- objects; such failures use TransferResponseObjectError.
+data TransferResponseError = TransferResponseError
+ { resperr_message :: T.Text
+ , resperr_request_id :: Maybe T.Text
+ , resperr_documentation_url :: Maybe Url
+ }
+ deriving (Generic, Show)
+
+instance ToJSON TransferResponseError where
+ toJSON = genericToJSON transferResponseErrorOptions
+ toEncoding = genericToEncoding transferResponseErrorOptions
+
+instance FromJSON TransferResponseError where
+ parseJSON = genericParseJSON transferResponseErrorOptions
+
+transferResponseErrorOptions :: Options
+transferResponseErrorOptions = stripFieldPrefix nonNullOptions
+
+-- | An error with a single object within a TransferRequest.
+data TransferResponseObjectError = TransferResponseObjectError
+ { respobjerr_code :: Int
+ , respobjerr_message :: T.Text
+ }
+ deriving (Generic, Show)
+
+instance ToJSON TransferResponseObjectError where
+ toJSON = genericToJSON transferResponseObjectErrorOptions
+ toEncoding = genericToEncoding transferResponseObjectErrorOptions
+
+instance FromJSON TransferResponseObjectError where
+ parseJSON = genericParseJSON transferResponseObjectErrorOptions
+
+transferResponseObjectErrorOptions :: Options
+transferResponseObjectErrorOptions = stripFieldPrefix nonNullOptions
+
+data TransferAdapter = Basic
+ deriving (Show)
+
+instance ToJSON TransferAdapter where
+ toJSON Basic = "basic"
+
+instance FromJSON TransferAdapter where
+ parseJSON (String "basic") = pure Basic
+ parseJSON invalid = typeMismatch "basic" invalid
+
+data TransferResponseOperation op = TransferResponseOperation
+ { resp_oid :: SHA256
+ , resp_size :: Integer
+ , resp_authenticated :: Maybe Bool
+ , resp_actions :: Maybe op
+ , resp_error :: Maybe TransferResponseObjectError
+ }
+ deriving (Generic, Show)
+
+instance ToJSON op => ToJSON (TransferResponseOperation op) where
+ toJSON = genericToJSON transferResponseOperationOptions
+ toEncoding = genericToEncoding transferResponseOperationOptions
+
+instance FromJSON op => FromJSON (TransferResponseOperation op) where
+ parseJSON = genericParseJSON transferResponseOperationOptions
+
+transferResponseOperationOptions :: Options
+transferResponseOperationOptions = stripFieldPrefix nonNullOptions
+
+-- | Class of types that can be responses to a transfer request,
+-- that contain an operation to use to make the transfer.
+class (FromJSON op, ToJSON op) => IsTransferResponseOperation op
+
+data DownloadOperation = DownloadOperation
+ { download :: OperationParams }
+ deriving (Generic, Show)
+
+instance IsTransferResponseOperation DownloadOperation
+instance ToJSON DownloadOperation
+instance FromJSON DownloadOperation
+
+data UploadOperation = UploadOperation
+ { upload :: OperationParams
+ , verify :: Maybe OperationParams
+ }
+ deriving (Generic, Show)
+
+instance IsTransferResponseOperation UploadOperation
+
+instance ToJSON UploadOperation where
+ toJSON = genericToJSON nonNullOptions
+ toEncoding = genericToEncoding nonNullOptions
+
+instance FromJSON UploadOperation
+
+data OperationParams = OperationParams
+ { href :: Url
+ , header :: Maybe (M.Map HTTPHeader HTTPHeaderValue)
+ , expires_in :: Maybe NumSeconds
+ , expires_at :: Maybe T.Text
+ }
+ deriving (Generic, Show)
+
+instance ToJSON OperationParams where
+ toJSON = genericToJSON nonNullOptions
+ toEncoding = genericToEncoding nonNullOptions
+
+instance FromJSON OperationParams
+
+data Verification = Verification
+ { verification_oid :: SHA256
+ , verification_size :: Integer
+ }
+ deriving (Generic, Show)
+
+instance ToJSON Verification where
+ toJSON = genericToJSON verificationOptions
+ toEncoding = genericToEncoding verificationOptions
+
+instance FromJSON Verification where
+ parseJSON = genericParseJSON verificationOptions
+
+verificationOptions :: Options
+verificationOptions = stripFieldPrefix defaultOptions
+
+-- | Sent over ssh connection when using that to find the endpoint.
+data SshDiscoveryResponse = SshDiscoveryResponse
+ { endpoint_href :: Url
+ , endpoint_header :: Maybe (M.Map HTTPHeader HTTPHeaderValue)
+ , endpoint_expires_in :: Maybe NumSeconds
+ , endpoint_expires_at :: Maybe T.Text
+ } deriving (Generic, Show)
+
+instance ToJSON SshDiscoveryResponse where
+ toJSON = genericToJSON sshDiscoveryResponseOptions
+ toEncoding = genericToEncoding sshDiscoveryResponseOptions
+
+instance FromJSON SshDiscoveryResponse where
+ parseJSON = genericParseJSON sshDiscoveryResponseOptions
+
+sshDiscoveryResponseOptions :: Options
+sshDiscoveryResponseOptions = stripFieldPrefix nonNullOptions
+
+data GitRef = GitRef
+ { name :: T.Text }
+ deriving (Generic, Show)
+
+instance FromJSON GitRef
+instance ToJSON GitRef
+
+type SHA256 = T.Text
+
+-- | The endpoint of a git-lfs server.
+data Endpoint = Endpoint Request
+ 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.
+--
+-- Note that, when sshing to the server, you should take care that the
+-- hostname you pass to ssh is really a hostname and not something that ssh
+-- will parse an an option, such as -oProxyCommand=".
+sshDiscoverEndpointCommand :: FilePath -> TransferRequestOperation -> [String]
+sshDiscoverEndpointCommand remotepath tro =
+ [ "git-lfs-authenticate"
+ , remotepath
+ , case tro of
+ RequestDownload -> "download"
+ 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 = 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:" -> endpoint
+ "http:" -> endpoint
+ _ -> Nothing
+ where
+ endpoint = mkEndpoint $ uri
+ -- force https because the git-lfs protocol uses http
+ -- basic auth tokens, which should not be exposed
+ { URI.uriScheme = "https:"
+ , URI.uriPath = guessedpath
+ }
+
+ guessedpath
+ | ".git" `isSuffixOf` URI.uriPath uri =
+ URI.uriPath uri ++ "/info/lfs"
+ | ".git/" `isSuffixOf` URI.uriPath uri =
+ URI.uriPath uri ++ "info/lfs"
+ | otherwise = (droptrailing '/' (URI.uriPath uri)) ++ ".git/info/lfs"
+
+ 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 -> Request
+startTransferRequest (Endpoint r) tr = r
+ { method = "POST"
+ , requestBody = RequestBodyLBS (encode tr)
+ }
+
+addLfsJsonHeaders :: Request -> Request
+addLfsJsonHeaders r = r
+ { requestHeaders = requestHeaders r ++
+ [ ("Accept", lfsjson)
+ , ("Content-Type", lfsjson)
+ ]
+ }
+ where
+ lfsjson = "application/vnd.git-lfs+json"
+
+data ParsedTransferResponse op
+ = ParsedTransferResponse (TransferResponse op)
+ | ParsedTransferResponseError TransferResponseError
+ | ParseFailed String
+
+-- | Parse the body of a response to a transfer request.
+parseTransferResponse
+ :: IsTransferResponseOperation op
+ => L.ByteString
+ -> ParsedTransferResponse op
+parseTransferResponse resp = case eitherDecode resp of
+ Right tr -> ParsedTransferResponse tr
+ -- If unable to decode as a TransferResponse, try to decode
+ -- as a TransferResponseError instead, in case the LFS server
+ -- sent an error message.
+ Left err ->
+ either (const $ ParseFailed err) ParsedTransferResponseError $
+ eitherDecode resp
+
+-- | Builds a http request to perform a download.
+downloadOperationRequest :: DownloadOperation -> Maybe Request
+downloadOperationRequest = fmap fst . operationParamsRequest . download
+
+-- | Builds http request to perform an upload. The content to upload is
+-- provided, along with its SHA256 and size.
+--
+-- When the LFS server requested verification, there will be a second
+-- Request that does that; it should be run only after the upload has
+-- succeeded.
+--
+-- When the LFS server already contains the object, an empty list may be
+-- returned.
+uploadOperationRequests :: UploadOperation -> (ServerSupportsChunks -> RequestBody) -> SHA256 -> Integer -> Maybe [Request]
+uploadOperationRequests op mkcontent oid size =
+ case (mkdlreq, mkverifyreq) of
+ (Nothing, _) -> Nothing
+ (Just dlreq, Nothing) -> Just [dlreq]
+ (Just dlreq, Just verifyreq) -> Just [dlreq, verifyreq]
+ where
+ mkdlreq = mkdlreq'
+ <$> operationParamsRequest (upload op)
+ mkdlreq' (r, ssc) = r
+ { method = "PUT"
+ , requestBody = mkcontent ssc
+ }
+ mkverifyreq = mkverifyreq'
+ <$> (operationParamsRequest =<< verify op)
+ mkverifyreq' (r, _ssc) = addLfsJsonHeaders $ r
+ { method = "POST"
+ , requestBody = RequestBodyLBS $ encode $
+ Verification oid size
+ }
+
+-- | When the LFS server indicates that it supports Transfer-Encoding chunked,
+-- this will contain a true value, and the RequestBody provided to
+-- uploadOperationRequests may be created using RequestBodyStreamChunked.
+-- Otherwise, that should be avoided as the server may not support the
+-- chunked encoding.
+newtype ServerSupportsChunks = ServerSupportsChunks Bool
+
+operationParamsRequest :: OperationParams -> Maybe (Request, ServerSupportsChunks)
+operationParamsRequest ps = do
+ r <- parseRequest (T.unpack (href ps))
+ let headers = map convheader $ maybe [] M.toList (header ps)
+ let headers' = filter allowedheader headers
+ let ssc = ServerSupportsChunks $
+ any (== ("Transfer-Encoding", "chunked")) headers
+ return (r { requestHeaders = headers' }, ssc)
+ where
+ convheader (k, v) = (CI.mk (E.encodeUtf8 k), E.encodeUtf8 v)
+ -- requestHeaders is not allowed to set Transfer-Encoding or
+ -- Content-Length; copying those over blindly could request in a
+ -- malformed request.
+ allowedheader (k, _) = k /= "Transfer-Encoding"
+ && k /= "Content-Length"
+
+type Url = T.Text
+
+type NumSeconds = Integer
+
+type HTTPHeader = T.Text
+
+type HTTPHeaderValue = T.Text
+
+-- Prevent Nothing from serializing to null.
+nonNullOptions :: Options
+nonNullOptions = defaultOptions { omitNothingFields = True }
+
+-- Remove prefix from field names.
+stripFieldPrefix :: Options -> Options
+stripFieldPrefix o =
+ o { fieldLabelModifier = drop 1 . dropWhile (/= '_') }
projects / git-annex.git / commitdiff