add uploadRequests
This commit is contained in:
parent
b4d2fc6219
commit
9040fea09e
1 changed files with 60 additions and 50 deletions
110
Lfs.hs
110
Lfs.hs
|
@ -9,58 +9,8 @@ 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 Data.Maybe
|
||||
import Network.HTTP.Types
|
||||
import Network.HTTP.Client
|
||||
|
||||
-- | Adds necessary headers to a Request and makes it post the
|
||||
-- specified TransferRequest.
|
||||
--
|
||||
-- The input Request's url should be the discovered LFS endpoint.
|
||||
-- Since this uses the LFS batch API, it adds /objects/batch to the end of
|
||||
-- that url.
|
||||
transferRequest :: Request -> TransferRequest -> Request
|
||||
transferRequest r tr = r
|
||||
{ path = path r <> "/objects/batch"
|
||||
, requestHeaders =
|
||||
[ ("Accept", lfsjson)
|
||||
, ("Content-Type", lfsjson)
|
||||
]
|
||||
, method = "POST"
|
||||
, requestBody = RequestBodyLBS (encode tr)
|
||||
}
|
||||
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.
|
||||
parseResponseBody
|
||||
:: IsTransferResponseOperation op
|
||||
=> L.ByteString
|
||||
-> ParsedTransferResponse op
|
||||
parseResponseBody 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 resp -> Right resp
|
||||
|
||||
-- | Builds http requests that can be used to download the objects that
|
||||
-- were requested using a TransferRequest.
|
||||
downloadRequests :: TransferResponse DownloadOperation -> ([(TransferResponseOperation DownloadOperation, Maybe Request)])
|
||||
downloadRequests = map mkreq . objects
|
||||
where
|
||||
mkreq op = (op, mkreq' (download (resp_actions op)))
|
||||
mkreq' ps = do
|
||||
r <- parseRequest (T.unpack (href ps))
|
||||
let headers = map convheader $ maybe [] M.toList (header ps)
|
||||
return $ r { requestHeaders = headers }
|
||||
convheader (k, v) = (CI.mk (E.encodeUtf8 k), E.encodeUtf8 v)
|
||||
|
||||
data TransferRequest = TransferRequest
|
||||
{ req_operation :: TransferRequestOperation
|
||||
, req_transfers :: [TransferAdapter]
|
||||
|
@ -200,6 +150,66 @@ instance ToJSON GitRef
|
|||
|
||||
type SHA256 = T.Text
|
||||
|
||||
-- | Adds necessary headers to a Request and makes it post the
|
||||
-- specified TransferRequest.
|
||||
--
|
||||
-- The input Request's url should be the discovered LFS endpoint.
|
||||
-- Since this uses the LFS batch API, it adds /objects/batch to the end of
|
||||
-- that url.
|
||||
transferRequest :: Request -> TransferRequest -> Request
|
||||
transferRequest r tr = r
|
||||
{ path = path r <> "/objects/batch"
|
||||
, requestHeaders =
|
||||
[ ("Accept", lfsjson)
|
||||
, ("Content-Type", lfsjson)
|
||||
]
|
||||
, method = "POST"
|
||||
, requestBody = RequestBodyLBS (encode tr)
|
||||
}
|
||||
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.
|
||||
parseResponseBody
|
||||
:: IsTransferResponseOperation op
|
||||
=> L.ByteString
|
||||
-> ParsedTransferResponse op
|
||||
parseResponseBody 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 http requests that can be used to download the objects that
|
||||
-- were requested using a TransferRequest.
|
||||
downloadRequests :: TransferResponse DownloadOperation -> ([(TransferResponseOperation DownloadOperation, Maybe Request)])
|
||||
downloadRequests = transferRequests download
|
||||
|
||||
-- | Builds http requests that can be used to upload objects.
|
||||
--
|
||||
-- When the server already has an object, no request will be generated.
|
||||
--
|
||||
-- The requestBody is not set here. When making a request,
|
||||
-- the content of the object needs to be provided as the body.
|
||||
uploadRequests :: TransferResponse UploadOperation -> ([(TransferResponseOperation UploadOperation, Maybe Request)])
|
||||
uploadRequests = transferRequests upload
|
||||
|
||||
transferRequests :: (op -> OperationParams) -> TransferResponse op -> ([(TransferResponseOperation op, Maybe Request)])
|
||||
transferRequests getps = map mkreq . objects
|
||||
where
|
||||
mkreq op = (op, mkreq' (getps (resp_actions op)))
|
||||
mkreq' ps = do
|
||||
r <- parseRequest (T.unpack (href ps))
|
||||
let headers = map convheader $ maybe [] M.toList (header ps)
|
||||
return $ r { requestHeaders = headers }
|
||||
convheader (k, v) = (CI.mk (E.encodeUtf8 k), E.encodeUtf8 v)
|
||||
|
||||
type Url = T.Text
|
||||
|
||||
type NumSeconds = Integer
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue