Added PandocHttpException, trap exceptions in fetching from URLs.

Closes #3646.

src/Text/Pandoc/App.hs

@@ -376,7 +376,7 @@ convertWithOpts opts = do
                                  then 0
                                  else optTabStop opts)
 
-      readSources :: (Functor m, MonadIO m) => [FilePath] -> m String
+      readSources :: [FilePath] -> PandocIO String
       readSources srcs = convertTabs . intercalate "\n" <$>
                             mapM readSource srcs
 
@@ -751,6 +751,11 @@ fillMedia sourceURL d = walkM handleImage d
                             "replacing image with description"
                   -- emit alt text
                   return $ Span ("",["image"],[]) lab
+                PandocHttpError u er -> do
+                  report $ CouldNotFetchResource u
+                            (show er ++ "\rReplacing image with description.")
+                  -- emit alt text
+                  return $ Span ("",["image"],[]) lab
                 _ -> throwError e)
         handleImage x = return x
 
@@ -800,7 +805,7 @@ applyFilters mbDatadir filters args d = do
   expandedFilters <- mapM (expandFilterPath mbDatadir) filters
   foldrM ($) d $ map (flip externalFilter args) expandedFilters
 
-readSource :: MonadIO m => FilePath -> m String
+readSource :: FilePath -> PandocIO String
 readSource "-" = liftIO UTF8.getContents
 readSource src = case parseURI src of
                       Just u | uriScheme u `elem` ["http:","https:"] ->
@@ -809,8 +814,12 @@ readSource src = case parseURI src of
                                  liftIO $ UTF8.readFile (uriPath u)
                       _       -> liftIO $ UTF8.readFile src
 
-readURI :: MonadIO m => FilePath -> m String
+readURI :: FilePath -> PandocIO String
-readURI src = liftIO $ (UTF8.toString . fst) <$> openURL src
+readURI src = do
+  res <- liftIO $ openURL src
+  case res of
+       Left e -> throwError $ PandocHttpError src e
+       Right (contents, _) -> return $ UTF8.toString contents
 
 readFile' :: MonadIO m => FilePath -> m B.ByteString
 readFile' "-" = liftIO B.getContents

src/Text/Pandoc/Class.hs

@@ -242,7 +242,10 @@ instance PandocMonad PandocIO where
   newUniqueHash = hashUnique <$> (liftIO IO.newUnique)
   openURL u = do
     report $ Fetching u
-    liftIOError IO.openURL u
+    res <- liftIO (IO.openURL u)
+    case res of
+         Right r -> return r
+         Left e  -> throwError $ PandocHttpError u e
   readFileLazy s = liftIOError BL.readFile s
   readFileStrict s = liftIOError B.readFile s
   readDataFile mfp fname = liftIOError (IO.readDataFile mfp) fname

src/Text/Pandoc/Error.hs

@@ -42,10 +42,12 @@ import Text.Parsec.Pos hiding (Line)
 import qualified Text.Pandoc.UTF8 as UTF8
 import System.Exit (exitWith, ExitCode(..))
 import System.IO (stderr)
+import Network.HTTP.Client (HttpException)
 
 type Input = String
 
 data PandocError = PandocIOError String IOError
+                 | PandocHttpError String HttpException
                  | PandocShouldNeverHappenError String
                  | PandocSomeError String
                  | PandocParseError String
@@ -70,6 +72,8 @@ handleError (Right r) = return r
 handleError (Left e) =
   case e of
     PandocIOError _ err' -> ioError err'
+    PandocHttpError u err' -> err 61 $
+      "Could not fetch " ++ u ++ "\n" ++ show err'
     PandocShouldNeverHappenError s -> err 62 s
     PandocSomeError s -> err 63 s
     PandocParseError s -> err 64 s

src/Text/Pandoc/Shared.hs

@@ -141,7 +141,8 @@ import Text.Pandoc.Data (dataFiles)
 import Paths_pandoc (getDataFileName)
 #endif
 import Network.HTTP.Client (httpLbs, responseBody, responseHeaders,
-                            Request(port,host,requestHeaders))
+                            Request(port,host,requestHeaders),
+                            HttpException)
 import Network.HTTP.Client (parseRequest)
 import Network.HTTP.Client (newManager)
 import Network.HTTP.Client.Internal (addProxy)
@@ -702,13 +703,13 @@ readDataFileUTF8 userDir fname =
   UTF8.toString `fmap` readDataFile userDir fname
 
 -- | Read from a URL and return raw data and maybe mime type.
-openURL :: String -> IO (BS.ByteString, Maybe MimeType)
+openURL :: String -> IO (Either HttpException (BS.ByteString, Maybe MimeType))
 openURL u
   | Just u'' <- stripPrefix "data:" u =
     let mime     = takeWhile (/=',') u''
         contents = B8.pack $ unEscapeString $ drop 1 $ dropWhile (/=',') u''
-    in  return (decodeLenient contents, Just mime)
+    in  return $ Right (decodeLenient contents, Just mime)
-  | otherwise = withSocketsDo $ do
+  | otherwise = E.try $ withSocketsDo $ do
      let parseReq = parseRequest
      (proxy :: Either IOError String) <-
         tryIOError $ getEnv "http_proxy"