finalizing lfs module
It may eventually move to its own package.
This commit is contained in:
Joey Hess
parent
435287db15
commit
bd6c508334
2 changed files with 52 additions and 14 deletions
433
Utility/GitLFS.hs
Normal file
433
Utility/GitLFS.hs
Normal file
|
|
@ -0,0 +1,433 @@
|
|||
{- 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.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE DeriveGeneric, FlexibleInstances, FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
|
||||
module Utility.GitLFS (
|
||||
-- * transfer requests
|
||||
TransferRequest(..),
|
||||
TransferAdapter(..),
|
||||
TransferRequestObject(..),
|
||||
startTransferRequest,
|
||||
-- * responses to transfer requests
|
||||
TransferResponse(..),
|
||||
TransferResponseOperation(..),
|
||||
IsTransferResponseOperation,
|
||||
DownloadOperation,
|
||||
UploadOperation,
|
||||
ParsedTransferResponse,
|
||||
parseTransferResponse,
|
||||
-- * making transfers
|
||||
downloadOperationRequest,
|
||||
uploadOperationRequests,
|
||||
-- * endpoint discovery
|
||||
Endpoint,
|
||||
guessEndpoint,
|
||||
HostUser,
|
||||
sshDiscoverEndpoint,
|
||||
-- * errors
|
||||
TransferResponseError(..),
|
||||
TransferResponseObjectError(..),
|
||||
-- * additional data types
|
||||
Url,
|
||||
SHA256,
|
||||
GitRef(..),
|
||||
NumSeconds,
|
||||
HTTPHeader,
|
||||
HTTPHeaderValue,
|
||||
) where
|
||||
|
||||
-- | 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 dedault, so be sure to add your own.
|
||||
|
||||
import Data.Aeson
|
||||
import Data.Aeson.Types
|
||||
import GHC.Generics
|
||||
import Network.HTTP.Client
|
||||
import System.Process
|
||||
import Control.Exception
|
||||
import Data.String
|
||||
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
|
||||
= EndpointURI URI.URI
|
||||
| EndpointDiscovered SshDiscoveryResponse
|
||||
deriving (Show)
|
||||
|
||||
-- | Discovers an LFS endpoint for a git remote using ssh.
|
||||
--
|
||||
-- May generate console output, including error messages from ssh or the
|
||||
-- remote server, and ssh password prompting.
|
||||
sshDiscoverEndpoint :: HostUser -> FilePath -> TransferRequestOperation -> IO (Maybe Endpoint)
|
||||
sshDiscoverEndpoint hostuser remotepath tro =
|
||||
(try (readProcess "ssh" ps "") :: IO (Either IOError String)) >>= \case
|
||||
Left _err -> return Nothing
|
||||
Right resp -> return $
|
||||
EndpointDiscovered <$> decode (fromString resp)
|
||||
where
|
||||
ps =
|
||||
[ hostuser
|
||||
, "git-lfs-authenticate"
|
||||
, remotepath
|
||||
, case tro of
|
||||
RequestDownload -> "download"
|
||||
RequestUpload -> "upload"
|
||||
]
|
||||
|
||||
-- | 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 :: Url -> Maybe Endpoint
|
||||
guessEndpoint remoteurl = do
|
||||
uri <- URI.parseURI (T.unpack remoteurl)
|
||||
let 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"
|
||||
let endpoint = EndpointURI $ uri
|
||||
{ URI.uriScheme = "https"
|
||||
, URI.uriPath = guessedpath
|
||||
}
|
||||
case URI.uriScheme uri of
|
||||
"https:" -> Just endpoint
|
||||
"http:" -> Just endpoint
|
||||
_ -> Nothing
|
||||
where
|
||||
droptrailing c = reverse . dropWhile (== c) . reverse
|
||||
|
||||
-- | 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
|
||||
|
||||
addLfsJsonHeaders :: Request -> Request
|
||||
addLfsJsonHeaders r = r
|
||||
{ requestHeaders =
|
||||
[ ("Accept", lfsjson)
|
||||
, ("Content-Type", lfsjson)
|
||||
]
|
||||
}
|
||||
where
|
||||
lfsjson = "application/vnd.git-lfs+json"
|
||||
|
||||
type ParsedTransferResponse op =
|
||||
Either (Either String TransferResponseError) (TransferResponse op)
|
||||
|
||||
-- | Parse the body of a response to a transfer request.
|
||||
parseTransferResponse
|
||||
:: IsTransferResponseOperation op
|
||||
=> L.ByteString
|
||||
-> ParsedTransferResponse op
|
||||
parseTransferResponse resp = case eitherDecode resp of
|
||||
-- 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 -> case eitherDecode resp of
|
||||
Right responseerror -> Left (Right responseerror)
|
||||
Left _ -> Left $ Left err
|
||||
Right tr -> Right tr
|
||||
|
||||
-- | Builds a http request to perform a download.
|
||||
downloadOperationRequest :: DownloadOperation -> Maybe Request
|
||||
downloadOperationRequest = operationParamsRequest . download
|
||||
|
||||
-- | Builds http request to perform an upload. The content to upload is
|
||||
-- provided in the RequestBody, along with its SHA256 and size.
|
||||
--
|
||||
-- If the LFS server requested verification, there will be a second
|
||||
-- Request that does that; it should be run only after the upload has
|
||||
-- succeeded.
|
||||
uploadOperationRequests :: UploadOperation -> RequestBody -> SHA256 -> Integer -> Maybe [Request]
|
||||
uploadOperationRequests op content 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 = r
|
||||
{ method = "PUT"
|
||||
, requestBody = content
|
||||
}
|
||||
mkverifyreq = mkverifyreq'
|
||||
<$> (operationParamsRequest =<< verify op)
|
||||
mkverifyreq' r = addLfsJsonHeaders $ r
|
||||
{ method = "POST"
|
||||
, requestBody = RequestBodyLBS $ encode $
|
||||
Verification oid size
|
||||
}
|
||||
|
||||
operationParamsRequest :: OperationParams -> Maybe Request
|
||||
operationParamsRequest ps = do
|
||||
r <- parseRequest (T.unpack (href ps))
|
||||
let headers = map convheader $ maybe [] M.toList (header ps)
|
||||
return $ r { requestHeaders = headers }
|
||||
where
|
||||
convheader (k, v) = (CI.mk (E.encodeUtf8 k), E.encodeUtf8 v)
|
||||
|
||||
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 (/= '_') }
|
||||
Loading…
Add table
Add a link
Reference in a new issue