make --json-error-messages capture url download errors

Convert Utility.Url to return Either String so the error message can be
displated in the annex monad and so captured.

(When curl is used, its errors are still not caught.)
This commit is contained in:
Joey Hess 2019-11-12 13:33:41 -04:00
parent 99536e3a0b
commit 890330f0fe
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
16 changed files with 161 additions and 121 deletions

View file

@ -206,7 +206,7 @@ downloadTorrentFile u = do
withTmpFileIn othertmp "torrent" $ \f h -> do
liftIO $ hClose h
ok <- Url.withUrlOptions $
liftIO . Url.download nullMeterUpdate u f
Url.download nullMeterUpdate u f
when ok $
liftIO $ renameFile f torrent
return ok

View file

@ -716,7 +716,7 @@ checkKeyUrl :: Git.Repo -> CheckPresent
checkKeyUrl r k = do
showChecking r
us <- getWebUrls k
anyM (\u -> withUrlOptions $ liftIO . checkBoth u (keySize k)) us
anyM (\u -> withUrlOptions $ checkBoth u (keySize k)) us
getWebUrls :: Key -> Annex [URLString]
getWebUrls key = filter supported <$> getUrls key

View file

@ -352,11 +352,10 @@ inAnnex' repo rmt (State connpool duc _ _) key
checkhttp = do
showChecking repo
gc <- Annex.getGitConfig
ifM (Url.withUrlOptions $ \uo -> liftIO $
anyM (\u -> Url.checkBoth u (keySize key) uo) (keyUrls gc repo rmt key))
( return True
, giveup "not found"
)
ifM (Url.withUrlOptions $ \uo -> anyM (\u -> Url.checkBoth u (keySize key) uo) (keyUrls gc repo rmt key))
( return True
, giveup "not found"
)
checkremote =
let fallback = Ssh.inAnnex repo key
in P2PHelper.checkpresent (Ssh.runProto rmt connpool (cantCheck rmt) fallback) key

View file

@ -58,11 +58,10 @@ import Logs.Web
import Logs.MetaData
import Types.MetaData
import Utility.Metered
import qualified Annex.Url as Url
import Utility.DataUnits
import Annex.Content
import Annex.Url (getUrlOptions, withUrlOptions)
import Utility.Url (checkBoth, UrlOptions(..))
import qualified Annex.Url as Url
import Annex.Url (getUrlOptions, withUrlOptions, UrlOptions(..))
import Utility.Env
type BucketName = String
@ -348,7 +347,7 @@ checkKey hv r rs c info k = withS3Handle hv $ \case
Right us -> do
showChecking r
let check u = withUrlOptions $
liftIO . checkBoth u (keySize k)
Url.checkBoth u (keySize k)
anyM check us
checkKeyHelper :: S3Info -> S3Handle -> (Either S3.Object S3VersionID) -> Annex Bool
@ -397,7 +396,7 @@ retrieveExportS3 hv r info _k loc f p =
warning $ needS3Creds (uuid r)
return False
Just geturl -> Url.withUrlOptions $
liftIO . Url.download p (geturl exportloc) f
Url.download p (geturl exportloc) f
exportloc = bucketExportLocation info loc
removeExportS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Key -> ExportLocation -> Annex Bool
@ -417,8 +416,8 @@ checkPresentExportS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation
checkPresentExportS3 hv r info k loc = withS3Handle hv $ \case
Just h -> checkKeyHelper info h (Left (T.pack $ bucketExportLocation info loc))
Nothing -> case getPublicUrlMaker info of
Just geturl -> withUrlOptions $ liftIO .
checkBoth (geturl $ bucketExportLocation info loc) (keySize k)
Just geturl -> withUrlOptions $
Url.checkBoth (geturl $ bucketExportLocation info loc) (keySize k)
Nothing -> do
warning $ needS3Creds (uuid r)
giveup "No S3 credentials configured"

View file

@ -116,9 +116,8 @@ checkKey' key us = firsthit us (Right False) $ \u -> do
showChecking u'
case downloader of
YoutubeDownloader -> youtubeDlCheck u'
_ -> do
Url.withUrlOptions $ liftIO . catchMsgIO .
Url.checkBoth u' (keySize key)
_ -> catchMsgIO $
Url.withUrlOptions $ Url.checkBoth u' (keySize key)
where
firsthit [] miss _ = return miss
firsthit (u:rest) _ a = do