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

@ -776,7 +776,7 @@ downloadUrl k p urls file =
-- download command is used. -- download command is used.
meteredFile file (Just p) k $ meteredFile file (Just p) k $
Url.withUrlOptions $ \uo -> Url.withUrlOptions $ \uo ->
liftIO $ anyM (\u -> Url.download p u file uo) urls anyM (\u -> Url.download p u file uo) urls
{- Copies a key's content, when present, to a temp file. {- Copies a key's content, when present, to a temp file.
- This is used to speed up some rsyncs. -} - This is used to speed up some rsyncs. -}

View file

@ -1,24 +1,39 @@
{- Url downloading, with git-annex user agent and configured http {- Url downloading, with git-annex user agent and configured http
- headers, security restrictions, etc. - headers, security restrictions, etc.
- -
- Copyright 2013-2018 Joey Hess <id@joeyh.name> - Copyright 2013-2019 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
module Annex.Url ( module Annex.Url (
module U,
withUrlOptions, withUrlOptions,
getUrlOptions, getUrlOptions,
getUserAgent, getUserAgent,
ipAddressesUnlimited, ipAddressesUnlimited,
checkBoth,
download,
exists,
getUrlInfo,
U.downloadQuiet,
U.URLString,
U.UrlOptions(..),
U.UrlInfo(..),
U.sinkResponseFile,
U.matchStatusCodeException,
U.downloadConduit,
U.downloadPartial,
U.parseURIRelaxed,
U.allowedScheme,
U.assumeUrlExists,
) where ) where
import Annex.Common import Annex.Common
import qualified Annex import qualified Annex
import Utility.Url as U import qualified Utility.Url as U
import Utility.IPAddress import Utility.IPAddress
import Utility.HttpManagerRestricted import Utility.HttpManagerRestricted
import Utility.Metered
import qualified BuildInfo import qualified BuildInfo
import Network.Socket import Network.Socket
@ -43,7 +58,7 @@ getUrlOptions = Annex.getState Annex.urloptions >>= \case
where where
mk = do mk = do
(urldownloader, manager) <- checkallowedaddr (urldownloader, manager) <- checkallowedaddr
mkUrlOptions U.mkUrlOptions
<$> (Just <$> getUserAgent) <$> (Just <$> getUserAgent)
<*> headers <*> headers
<*> pure urldownloader <*> pure urldownloader
@ -108,3 +123,27 @@ ipAddressesUnlimited =
withUrlOptions :: (U.UrlOptions -> Annex a) -> Annex a withUrlOptions :: (U.UrlOptions -> Annex a) -> Annex a
withUrlOptions a = a =<< getUrlOptions withUrlOptions a = a =<< getUrlOptions
checkBoth :: U.URLString -> Maybe Integer -> U.UrlOptions -> Annex Bool
checkBoth url expected_size uo =
liftIO (U.checkBoth url expected_size uo) >>= \case
Right r -> return r
Left err -> warning err >> return False
download :: MeterUpdate -> U.URLString -> FilePath -> U.UrlOptions -> Annex Bool
download meterupdate url file uo =
liftIO (U.download meterupdate url file uo) >>= \case
Right () -> return True
Left err -> warning err >> return False
exists :: U.URLString -> U.UrlOptions -> Annex Bool
exists url uo = liftIO (U.exists url uo) >>= \case
Right b -> return b
Left err -> warning err >> return False
getUrlInfo :: U.URLString -> U.UrlOptions -> Annex U.UrlInfo
getUrlInfo url uo = liftIO (U.getUrlInfo url uo) >>= \case
Right i -> return i
Left err -> do
warning err
return $ U.UrlInfo False Nothing Nothing

View file

@ -18,7 +18,6 @@ import Annex.Common
import qualified Annex import qualified Annex
import Annex.Content import Annex.Content
import Annex.Url import Annex.Url
import Utility.Url (URLString)
import Utility.DiskFree import Utility.DiskFree
import Utility.HtmlDetect import Utility.HtmlDetect
import Utility.Process.Transcript import Utility.Process.Transcript

View file

@ -95,7 +95,9 @@ newAssistantUrl repo = do
- warp-tls listens to http, in order to show an error page, so this works. - warp-tls listens to http, in order to show an error page, so this works.
-} -}
assistantListening :: URLString -> IO Bool assistantListening :: URLString -> IO Bool
assistantListening url = catchBoolIO $ exists url' =<< defUrlOptions assistantListening url = catchBoolIO $ do
uo <- defUrlOptions
(== Right True) <$> exists url' uo
where where
url' = case parseURI url of url' = case parseURI url of
Nothing -> url Nothing -> url

View file

@ -40,9 +40,10 @@ import Utility.Metered
import qualified Utility.Lsof as Lsof import qualified Utility.Lsof as Lsof
import qualified BuildInfo import qualified BuildInfo
import qualified Utility.Url as Url import qualified Utility.Url as Url
import qualified Annex.Url as Url import qualified Annex.Url as Url hiding (download)
import Utility.Tuple import Utility.Tuple
import Data.Either
import qualified Data.Map as M import qualified Data.Map as M
{- Upgrade without interaction in the webapp. -} {- Upgrade without interaction in the webapp. -}
@ -323,8 +324,8 @@ downloadDistributionInfo = do
liftIO $ withTmpDir "git-annex.tmp" $ \tmpdir -> do liftIO $ withTmpDir "git-annex.tmp" $ \tmpdir -> do
let infof = tmpdir </> "info" let infof = tmpdir </> "info"
let sigf = infof ++ ".sig" let sigf = infof ++ ".sig"
ifM (Url.download nullMeterUpdate distributionInfoUrl infof uo ifM (isRight <$> Url.download nullMeterUpdate distributionInfoUrl infof uo
<&&> Url.download nullMeterUpdate distributionInfoSigUrl sigf uo <&&> (isRight <$> Url.download nullMeterUpdate distributionInfoSigUrl sigf uo)
<&&> verifyDistributionSig gpgcmd sigf) <&&> verifyDistributionSig gpgcmd sigf)
( parseInfoFile <$> readFileStrict infof ( parseInfoFile <$> readFileStrict infof
, return Nothing , return Nothing

View file

@ -192,7 +192,7 @@ escapeHeader = escapeURIString (\c -> isUnescapedInURI c && c /= ' ')
getRepoInfo :: RemoteConfig -> Widget getRepoInfo :: RemoteConfig -> Widget
getRepoInfo c = do getRepoInfo c = do
uo <- liftAnnex Url.getUrlOptions uo <- liftAnnex Url.getUrlOptions
exists <- liftIO $ catchDefaultIO False $ Url.exists url uo exists <- liftAnnex $ catchDefaultIO False $ Url.exists url uo
[whamlet| [whamlet|
<a href="#{url}"> <a href="#{url}">
Internet Archive item Internet Archive item

View file

@ -1,6 +1,8 @@
git-annex (7.20191107) UNRELEASED; urgency=medium git-annex (7.20191107) UNRELEASED; urgency=medium
* Added annex.allowsign option. * Added annex.allowsign option.
* Make --json-error-messages capture more errors,
particularly url download errors.
-- Joey Hess <id@joeyh.name> Mon, 11 Nov 2019 15:59:47 -0400 -- Joey Hess <id@joeyh.name> Mon, 11 Nov 2019 15:59:47 -0400

View file

@ -197,8 +197,7 @@ startWeb o urlstring = go $ fromMaybe bad $ parseURI urlstring
pathmax <- liftIO $ fileNameLengthLimit "." pathmax <- liftIO $ fileNameLengthLimit "."
urlinfo <- if relaxedOption (downloadOptions o) urlinfo <- if relaxedOption (downloadOptions o)
then pure Url.assumeUrlExists then pure Url.assumeUrlExists
else Url.withUrlOptions $ else Url.withUrlOptions $ Url.getUrlInfo urlstring
liftIO . Url.getUrlInfo urlstring
file <- adjustFile o <$> case fileOption (downloadOptions o) of file <- adjustFile o <$> case fileOption (downloadOptions o) of
Just f -> pure f Just f -> pure f
Nothing -> case Url.urlSuggestedFile urlinfo of Nothing -> case Url.urlSuggestedFile urlinfo of

View file

@ -146,13 +146,12 @@ findDownloads u f = catMaybes $ map mk (feedItems f)
downloadFeed :: URLString -> Annex (Maybe String) downloadFeed :: URLString -> Annex (Maybe String)
downloadFeed url downloadFeed url
| Url.parseURIRelaxed url == Nothing = giveup "invalid feed url" | Url.parseURIRelaxed url == Nothing = giveup "invalid feed url"
| otherwise = Url.withUrlOptions $ \uo -> | otherwise = withTmpFile "feed" $ \f h -> do
liftIO $ withTmpFile "feed" $ \f h -> do liftIO $ hClose h
hClose h ifM (Url.withUrlOptions $ Url.download nullMeterUpdate url f)
ifM (Url.download nullMeterUpdate url f uo) ( Just <$> liftIO (readFileStrict f)
( Just <$> readFileStrict f , return Nothing
, return Nothing )
)
performDownload :: ImportFeedOptions -> Cache -> ToDownload -> Annex Bool performDownload :: ImportFeedOptions -> Cache -> ToDownload -> Annex Bool
performDownload opts cache todownload = case location todownload of performDownload opts cache todownload = case location todownload of
@ -164,7 +163,7 @@ performDownload opts cache todownload = case location todownload of
urlinfo <- if relaxedOption (downloadOptions opts) urlinfo <- if relaxedOption (downloadOptions opts)
then pure Url.assumeUrlExists then pure Url.assumeUrlExists
else Url.withUrlOptions $ else Url.withUrlOptions $
liftIO . Url.getUrlInfo url Url.getUrlInfo url
let dlopts = (downloadOptions opts) let dlopts = (downloadOptions opts)
-- force using the filename -- force using the filename
-- chosen here -- chosen here

View file

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

View file

@ -716,7 +716,7 @@ checkKeyUrl :: Git.Repo -> CheckPresent
checkKeyUrl r k = do checkKeyUrl r k = do
showChecking r showChecking r
us <- getWebUrls k 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 -> Annex [URLString]
getWebUrls key = filter supported <$> getUrls key getWebUrls key = filter supported <$> getUrls key

View file

@ -352,11 +352,10 @@ inAnnex' repo rmt (State connpool duc _ _) key
checkhttp = do checkhttp = do
showChecking repo showChecking repo
gc <- Annex.getGitConfig gc <- Annex.getGitConfig
ifM (Url.withUrlOptions $ \uo -> liftIO $ ifM (Url.withUrlOptions $ \uo -> anyM (\u -> Url.checkBoth u (keySize key) uo) (keyUrls gc repo rmt key))
anyM (\u -> Url.checkBoth u (keySize key) uo) (keyUrls gc repo rmt key)) ( return True
( return True , giveup "not found"
, giveup "not found" )
)
checkremote = checkremote =
let fallback = Ssh.inAnnex repo key let fallback = Ssh.inAnnex repo key
in P2PHelper.checkpresent (Ssh.runProto rmt connpool (cantCheck rmt) fallback) 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 Logs.MetaData
import Types.MetaData import Types.MetaData
import Utility.Metered import Utility.Metered
import qualified Annex.Url as Url
import Utility.DataUnits import Utility.DataUnits
import Annex.Content import Annex.Content
import Annex.Url (getUrlOptions, withUrlOptions) import qualified Annex.Url as Url
import Utility.Url (checkBoth, UrlOptions(..)) import Annex.Url (getUrlOptions, withUrlOptions, UrlOptions(..))
import Utility.Env import Utility.Env
type BucketName = String type BucketName = String
@ -348,7 +347,7 @@ checkKey hv r rs c info k = withS3Handle hv $ \case
Right us -> do Right us -> do
showChecking r showChecking r
let check u = withUrlOptions $ let check u = withUrlOptions $
liftIO . checkBoth u (keySize k) Url.checkBoth u (keySize k)
anyM check us anyM check us
checkKeyHelper :: S3Info -> S3Handle -> (Either S3.Object S3VersionID) -> Annex Bool 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) warning $ needS3Creds (uuid r)
return False return False
Just geturl -> Url.withUrlOptions $ Just geturl -> Url.withUrlOptions $
liftIO . Url.download p (geturl exportloc) f Url.download p (geturl exportloc) f
exportloc = bucketExportLocation info loc exportloc = bucketExportLocation info loc
removeExportS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Key -> ExportLocation -> Annex Bool 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 checkPresentExportS3 hv r info k loc = withS3Handle hv $ \case
Just h -> checkKeyHelper info h (Left (T.pack $ bucketExportLocation info loc)) Just h -> checkKeyHelper info h (Left (T.pack $ bucketExportLocation info loc))
Nothing -> case getPublicUrlMaker info of Nothing -> case getPublicUrlMaker info of
Just geturl -> withUrlOptions $ liftIO . Just geturl -> withUrlOptions $
checkBoth (geturl $ bucketExportLocation info loc) (keySize k) Url.checkBoth (geturl $ bucketExportLocation info loc) (keySize k)
Nothing -> do Nothing -> do
warning $ needS3Creds (uuid r) warning $ needS3Creds (uuid r)
giveup "No S3 credentials configured" giveup "No S3 credentials configured"

View file

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

View file

@ -138,22 +138,14 @@ curlParams uo ps = ps ++ uaparams ++ headerparams ++ addedparams ++ schemeparams
] ]
schemelist = map fromScheme $ S.toList $ allowedSchemes uo schemelist = map fromScheme $ S.toList $ allowedSchemes uo
checkPolicy :: UrlOptions -> URI -> a -> (String -> IO b) -> IO a -> IO a checkPolicy :: UrlOptions -> URI -> IO (Either String a) -> IO (Either String a)
checkPolicy uo u onerr displayerror a checkPolicy uo u a
| allowedScheme uo u = a | allowedScheme uo u = a
| otherwise = do | otherwise = return $ Left $
void $ displayerror $ "Configuration does not allow accessing " ++ show u
"Configuration does not allow accessing " ++ show u
return onerr
unsupportedUrlScheme :: URI -> (String -> IO a) -> IO a unsupportedUrlScheme :: URI -> String
unsupportedUrlScheme u displayerror = unsupportedUrlScheme u = "Unsupported url scheme " ++ show u
displayerror $ "Unsupported url scheme " ++ show u
warnError :: String -> IO ()
warnError msg = do
hPutStrLn stderr msg
hFlush stderr
allowedScheme :: UrlOptions -> URI -> Bool allowedScheme :: UrlOptions -> URI -> Bool
allowedScheme uo u = uscheme `S.member` allowedSchemes uo allowedScheme uo u = uscheme `S.member` allowedSchemes uo
@ -161,14 +153,18 @@ allowedScheme uo u = uscheme `S.member` allowedSchemes uo
uscheme = mkScheme $ takeWhile (/=':') (uriScheme u) uscheme = mkScheme $ takeWhile (/=':') (uriScheme u)
{- Checks that an url exists and could be successfully downloaded, {- Checks that an url exists and could be successfully downloaded,
- also checking that its size, if available, matches a specified size. -} - also checking that its size, if available, matches a specified size.
checkBoth :: URLString -> Maybe Integer -> UrlOptions -> IO Bool -
checkBoth url expected_size uo = do - The Left error is returned if policy does not allow accessing the url
v <- check url expected_size uo - or the url scheme is not supported.
return (fst v && snd v) -}
checkBoth :: URLString -> Maybe Integer -> UrlOptions -> IO (Either String Bool)
checkBoth url expected_size uo = fmap go <$> check url expected_size uo
where
go v = fst v && snd v
check :: URLString -> Maybe Integer -> UrlOptions -> IO (Bool, Bool) check :: URLString -> Maybe Integer -> UrlOptions -> IO (Either String (Bool, Bool))
check url expected_size uo = go <$> getUrlInfo url uo check url expected_size uo = fmap go <$> getUrlInfo url uo
where where
go (UrlInfo False _ _) = (False, False) go (UrlInfo False _ _) = (False, False)
go (UrlInfo True Nothing _) = (True, True) go (UrlInfo True Nothing _) = (True, True)
@ -176,8 +172,8 @@ check url expected_size uo = go <$> getUrlInfo url uo
Just _ -> (True, expected_size == s) Just _ -> (True, expected_size == s)
Nothing -> (True, True) Nothing -> (True, True)
exists :: URLString -> UrlOptions -> IO Bool exists :: URLString -> UrlOptions -> IO (Either String Bool)
exists url uo = urlExists <$> getUrlInfo url uo exists url uo = fmap urlExists <$> getUrlInfo url uo
data UrlInfo = UrlInfo data UrlInfo = UrlInfo
{ urlExists :: Bool { urlExists :: Bool
@ -190,32 +186,36 @@ assumeUrlExists :: UrlInfo
assumeUrlExists = UrlInfo True Nothing Nothing assumeUrlExists = UrlInfo True Nothing Nothing
{- Checks that an url exists and could be successfully downloaded, {- Checks that an url exists and could be successfully downloaded,
- also returning its size and suggested filename if available. -} - also returning its size and suggested filename if available.
getUrlInfo :: URLString -> UrlOptions -> IO UrlInfo -
- The Left error is returned if policy does not allow accessing the url
- or the url scheme is not supported.
-}
getUrlInfo :: URLString -> UrlOptions -> IO (Either String UrlInfo)
getUrlInfo url uo = case parseURIRelaxed url of getUrlInfo url uo = case parseURIRelaxed url of
Just u -> checkPolicy uo u dne warnError $ Just u -> checkPolicy uo u (go u)
case (urlDownloader uo, parseUrlRequest (show u)) of Nothing -> return (Right dne)
(DownloadWithConduit (DownloadWithCurlRestricted r), Just req) -> catchJust where
-- When http redirects to a protocol which go :: URI -> IO (Either String UrlInfo)
-- conduit does not support, it will throw go u = case (urlDownloader uo, parseUrlRequest (show u)) of
-- a StatusCodeException with found302 (DownloadWithConduit (DownloadWithCurlRestricted r), Just req) -> catchJust
-- and a Response with the redir Location. -- When http redirects to a protocol which
(matchStatusCodeException (== found302)) -- conduit does not support, it will throw
(existsconduit req) -- a StatusCodeException with found302
(followredir r) -- and a Response with the redir Location.
`catchNonAsync` (const $ return dne) (matchStatusCodeException (== found302))
(DownloadWithConduit (DownloadWithCurlRestricted r), Nothing) (Right <$> existsconduit req)
| isfileurl u -> existsfile u (followredir r)
| isftpurl u -> existscurlrestricted r u url ftpport `catchNonAsync` (const $ return $ Right dne)
`catchNonAsync` (const $ return dne) (DownloadWithConduit (DownloadWithCurlRestricted r), Nothing)
| otherwise -> do | isfileurl u -> Right <$> existsfile u
unsupportedUrlScheme u warnError | isftpurl u -> (Right <$> existscurlrestricted r u url ftpport)
return dne `catchNonAsync` (const $ return $ Right dne)
(DownloadWithCurl _, _) | otherwise -> return $ Left $ unsupportedUrlScheme u
| isfileurl u -> existsfile u (DownloadWithCurl _, _)
| otherwise -> existscurl u (basecurlparams url) | isfileurl u -> Right <$> existsfile u
Nothing -> return dne | otherwise -> Right <$> existscurl u (basecurlparams url)
where
dne = UrlInfo False Nothing Nothing dne = UrlInfo False Nothing Nothing
found sz f = return $ UrlInfo True sz f found sz f = return $ UrlInfo True sz f
@ -291,11 +291,11 @@ getUrlInfo url uo = case parseURIRelaxed url of
-- http to file redirect would not be secure, -- http to file redirect would not be secure,
-- and http-conduit follows http to http. -- and http-conduit follows http to http.
Just u' | isftpurl u' -> Just u' | isftpurl u' ->
checkPolicy uo u' dne warnError $ checkPolicy uo u' $ Right <$>
existscurlrestricted r u' url' ftpport existscurlrestricted r u' url' ftpport
_ -> return dne _ -> return (Right dne)
Nothing -> return dne Nothing -> return (Right dne)
followredir _ _ = return dne followredir _ _ = return (Right dne)
-- Parse eg: attachment; filename="fname.ext" -- Parse eg: attachment; filename="fname.ext"
-- per RFC 2616 -- per RFC 2616
@ -317,31 +317,32 @@ headRequest r = r
{- Download a perhaps large file, with auto-resume of incomplete downloads. {- Download a perhaps large file, with auto-resume of incomplete downloads.
- -
- Displays error message on stderr when download failed. - When the download fails, returns an error message.
-} -}
download :: MeterUpdate -> URLString -> FilePath -> UrlOptions -> IO Bool download :: MeterUpdate -> URLString -> FilePath -> UrlOptions -> IO (Either String ())
download = download' False download = download' False
{- Avoids displaying any error message. -} {- Avoids displaying any error message, including silencing curl errors. -}
downloadQuiet :: MeterUpdate -> URLString -> FilePath -> UrlOptions -> IO Bool downloadQuiet :: MeterUpdate -> URLString -> FilePath -> UrlOptions -> IO Bool
downloadQuiet = download' True downloadQuiet meterupdate url file uo = isRight
<$> download' True meterupdate url file uo
download' :: Bool -> MeterUpdate -> URLString -> FilePath -> UrlOptions -> IO Bool download' :: Bool -> MeterUpdate -> URLString -> FilePath -> UrlOptions -> IO (Either String ())
download' noerror meterupdate url file uo = download' nocurlerror meterupdate url file uo =
catchJust matchHttpException go showhttpexception catchJust matchHttpException go showhttpexception
`catchNonAsync` (dlfailed . show) `catchNonAsync` (dlfailed . show)
where where
go = case parseURIRelaxed url of go = case parseURIRelaxed url of
Just u -> checkPolicy uo u False dlfailed $ Just u -> checkPolicy uo u $
case (urlDownloader uo, parseUrlRequest (show u)) of case (urlDownloader uo, parseUrlRequest (show u)) of
(DownloadWithConduit (DownloadWithCurlRestricted r), Just req) -> catchJust (DownloadWithConduit (DownloadWithCurlRestricted r), Just req) -> catchJust
(matchStatusCodeException (== found302)) (matchStatusCodeException (== found302))
(downloadConduit meterupdate req file uo >> return True) (downloadConduit meterupdate req file uo >> return (Right ()))
(followredir r) (followredir r)
(DownloadWithConduit (DownloadWithCurlRestricted r), Nothing) (DownloadWithConduit (DownloadWithCurlRestricted r), Nothing)
| isfileurl u -> downloadfile u | isfileurl u -> downloadfile u
| isftpurl u -> downloadcurlrestricted r u url ftpport | isftpurl u -> downloadcurlrestricted r u url ftpport
| otherwise -> unsupportedUrlScheme u dlfailed | otherwise -> dlfailed $ unsupportedUrlScheme u
(DownloadWithCurl _, _) (DownloadWithCurl _, _)
| isfileurl u -> downloadfile u | isfileurl u -> downloadfile u
| otherwise -> downloadcurl url basecurlparams | otherwise -> downloadcurl url basecurlparams
@ -354,27 +355,20 @@ download' noerror meterupdate url file uo =
ftpport = 21 ftpport = 21
showhttpexception he = do showhttpexception he = dlfailed $ case he of
let msg = case he of HttpExceptionRequest _ (StatusCodeException r _) ->
HttpExceptionRequest _ (StatusCodeException r _) -> B8.toString $ statusMessage $ responseStatus r
B8.toString $ statusMessage $ responseStatus r HttpExceptionRequest _ (InternalException ie) ->
HttpExceptionRequest _ (InternalException ie) -> case fromException ie of
case fromException ie of Nothing -> show ie
Nothing -> show ie Just (ConnectionRestricted why) -> why
Just (ConnectionRestricted why) -> why HttpExceptionRequest _ other -> show other
HttpExceptionRequest _ other -> show other _ -> show he
_ -> show he
dlfailed msg
dlfailed msg
| noerror = return False
| otherwise = do
hPutStrLn stderr $ "download failed: " ++ msg
hFlush stderr
return False
dlfailed msg = return $ Left $ "download failed: " ++ msg
basecurlparams = curlParams uo basecurlparams = curlParams uo
[ if noerror [ if nocurlerror
then Param "-S" then Param "-S"
else Param "-sS" else Param "-sS"
, Param "-f" , Param "-f"
@ -387,7 +381,10 @@ download' noerror meterupdate url file uo =
-- if the url happens to be empty, so pre-create. -- if the url happens to be empty, so pre-create.
unlessM (doesFileExist file) $ unlessM (doesFileExist file) $
writeFile file "" writeFile file ""
boolSystem "curl" (curlparams ++ [Param "-o", File file, File rawurl]) ifM (boolSystem "curl" (curlparams ++ [Param "-o", File file, File rawurl]))
( return $ Right ()
, return $ Left "download failed"
)
downloadcurlrestricted r u rawurl defport = downloadcurlrestricted r u rawurl defport =
downloadcurl rawurl =<< curlRestrictedParams r u defport basecurlparams downloadcurl rawurl =<< curlRestrictedParams r u defport basecurlparams
@ -396,7 +393,7 @@ download' noerror meterupdate url file uo =
let src = unEscapeString (uriPath u) let src = unEscapeString (uriPath u)
withMeteredFile src meterupdate $ withMeteredFile src meterupdate $
L.writeFile file L.writeFile file
return True return $ Right ()
-- Conduit does not support ftp, so will throw an exception on a -- Conduit does not support ftp, so will throw an exception on a
-- redirect to a ftp url; fall back to curl. -- redirect to a ftp url; fall back to curl.
@ -404,7 +401,7 @@ download' noerror meterupdate url file uo =
case headMaybe $ map decodeBS $ getResponseHeader hLocation resp of case headMaybe $ map decodeBS $ getResponseHeader hLocation resp of
Just url' -> case parseURIRelaxed url' of Just url' -> case parseURIRelaxed url' of
Just u' | isftpurl u' -> Just u' | isftpurl u' ->
checkPolicy uo u' False dlfailed $ checkPolicy uo u' $
downloadcurlrestricted r u' url' ftpport downloadcurlrestricted r u' url' ftpport
_ -> throwIO ex _ -> throwIO ex
Nothing -> throwIO ex Nothing -> throwIO ex

View file

@ -22,3 +22,8 @@ If user convenience was something to strive for here, it should technically be p
[[!meta author=yoh]] [[!meta author=yoh]]
[[!tag projects/datalad]] [[!tag projects/datalad]]
> [[fixed|done]], and I also converted a number of other places
> where an error could leak through to stderr, although there are still
> some places where direct writes to stderr happen -- I'll probably never
> be able to guarantee --json-error-messages catches every possible stderr
> output. --[[Joey]]