diff --git a/Lfs.hs b/Lfs.hs index 4e4e60ee51..fb10ea5455 100644 --- a/Lfs.hs +++ b/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