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

@ -367,20 +367,21 @@ store r rsyncopts k s p = do
store' :: Git.Repo -> Remote -> Remote.Rsync.RsyncOpts -> Storer
store' repo r rsyncopts
| not $ Git.repoIsUrl repo =
byteStorer $ \k b p -> guardUsable repo (return False) $ liftIO $ do
byteStorer $ \k b p -> guardUsable repo (giveup "cannot access remote") $ liftIO $ do
let tmpdir = Git.repoLocation repo </> "tmp" </> fromRawFilePath (keyFile k)
void $ tryIO $ createDirectoryUnder (Git.repoLocation repo) tmpdir
let tmpf = tmpdir </> fromRawFilePath (keyFile k)
meteredWriteFile p tmpf b
let destdir = parentDir $ gCryptLocation repo k
Remote.Directory.finalizeStoreGeneric (Git.repoLocation repo) tmpdir destdir
return True
| Git.repoIsSsh repo = if accessShell r
then fileStorer $ \k f p -> do
oh <- mkOutputHandler
Ssh.rsyncHelper oh (Just p)
ok <- Ssh.rsyncHelper oh (Just p)
=<< Ssh.rsyncParamsRemote False r Upload k f
(AssociatedFile Nothing)
unless ok $
giveup "rsync failed"
else fileStorer $ Remote.Rsync.store rsyncopts
| otherwise = unsupportedUrl