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:
parent
99536e3a0b
commit
890330f0fe
16 changed files with 161 additions and 121 deletions
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
13
Remote/S3.hs
13
Remote/S3.hs
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue