catch ClientError from withClientM

When getting from a P2P HTTP remote, prompt for credentials when required,
instead of failing.

This feels like it might be a bug in servant-client. withClientM's type
suggests it would not throw a ClientError. But it does in this case.
This commit is contained in:
Joey Hess 2024-08-07 11:24:34 -04:00
parent 43e1f590c9
commit 509b23fa00
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
3 changed files with 8 additions and 1 deletions

View file

@ -9,6 +9,7 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds, TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP #-}
module P2P.Http.Client (
@ -99,7 +100,7 @@ p2pHttpClientVersions allowedversion rmt fallback clientaction =
versions = filter allowedversion allProtocolVersions
go clientenv mcred credcached mauth (v:vs) = do
myuuid <- getUUID
res <- clientaction clientenv v
res <- catchclienterror $ clientaction clientenv v
(B64UUID (uuid rmt))
(B64UUID myuuid)
[]
@ -126,6 +127,8 @@ p2pHttpClientVersions allowedversion rmt fallback clientaction =
("git-annex HTTP API server returned an unexpected response: " ++ show clienterror)
go _ _ _ _ [] = return Nothing
catchclienterror a = a `catch` \(ex :: ClientError) -> pure (Left ex)
authrequired clientenv vs = do
cred <- prompt $
inRepo $ Git.getUrlCredential credentialbaseurl