make storeKey throw exceptions

When storing content on remote fails, always display a reason why.

Since the Storer used by special remotes already did, this mostly affects
git remotes, but not entirely. For example, if git-lfs failed to connect to
the endpoint, it used to silently return False.
This commit is contained in:
Joey Hess 2020-05-13 14:03:00 -04:00
parent b50ee9cd0c
commit c1cd402081
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
34 changed files with 214 additions and 197 deletions

View file

@ -440,18 +440,15 @@ mkDownloadRequest rs k = case (extractKeySha256 k, extractKeySize k) of
store :: RemoteStateHandle -> TVar LFSHandle -> Storer
store rs h = fileStorer $ \k src p -> getLFSEndpoint LFS.RequestUpload h >>= \case
Nothing -> return False
Just endpoint -> flip catchNonAsync failederr $ do
Nothing -> giveup "unable to connect to git-lfs endpoint"
Just endpoint -> do
(req, sha256, size) <- mkUploadRequest rs k src
sendTransferRequest req endpoint >>= \case
Left err -> do
warning err
return False
Right resp -> do
body <- liftIO $ httpBodyStorer src p
forM_ (LFS.objects resp) $
send body sha256 size
return True
Left err -> giveup err
where
send body sha256 size tro
| LFS.resp_oid tro /= sha256 || LFS.resp_size tro /= size =
@ -466,9 +463,6 @@ store rs h = fileStorer $ \k src p -> getLFSEndpoint LFS.RequestUpload h >>= \ca
Just [] -> noop -- server already has it
Just reqs -> forM_ reqs $
makeSmallAPIRequest . setRequestCheckStatus
failederr e = do
warning (show e)
return False
retrieve :: RemoteStateHandle -> TVar LFSHandle -> Retriever
retrieve rs h = fileRetriever $ \dest k p -> getLFSEndpoint LFS.RequestDownload h >>= \case