Class: generalize PandocIO functions to MonadIO

2 files changed, 252 insertions, 167 deletions

diff --git a/src/Text/Pandoc/Class/IO.hs b/src/Text/Pandoc/Class/IO.hs
new file mode 100644
index 000000000..c38a37844
--- /dev/null
+++ b/src/Text/Pandoc/Class/IO.hs
@@ -0,0 +1,231 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+{- |
+Module      : Text.Pandoc.Class.IO
+Copyright   : Copyright (C) 2016-2020 Jesse Rosenthal, John MacFarlane
+License     : GNU GPL, version 2 or above
+
+Maintainer  : Jesse Rosenthal <jrosenthal@jhu.edu>
+Stability   : alpha
+Portability : portable
+
+Default ways to perform @'PandocMonad'@ actions in a @'MonadIO'@ type.
+
+These functions are used to make the @'PandocIO'@ type an instance of
+@'PandocMonad'@, but can be reused for any other MonadIO-conforming
+types.
+-}
+module Text.Pandoc.Class.IO
+  ( fileExists
+  , getCurrentTime
+  , getCurrentTimeZone
+  , getDataFileName
+  , getModificationTime
+  , glob
+  , logOutput
+  , logIOError
+  , lookupEnv
+  , newStdGen
+  , newUniqueHash
+  , openURL
+  , readFileLazy
+  , readFileStrict
+  , extractMedia
+ ) where
+
+import Control.Monad.Except (throwError)
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Data.ByteString.Base64 (decodeLenient)
+import Data.ByteString.Lazy (toChunks)
+import Data.Text (Text, pack, unpack)
+import Data.Time (TimeZone, UTCTime)
+import Data.Unique (hashUnique)
+import Network.Connection (TLSSettings (TLSSettingsSimple))
+import Network.HTTP.Client
+       (httpLbs, responseBody, responseHeaders,
+        Request(port, host, requestHeaders), parseRequest, newManager)
+import Network.HTTP.Client.Internal (addProxy)
+import Network.HTTP.Client.TLS (mkManagerSettings)
+import Network.HTTP.Types.Header ( hContentType )
+import Network.Socket (withSocketsDo)
+import Network.URI (unEscapeString)
+import System.Directory (createDirectoryIfMissing)
+import System.Environment (getEnv)
+import System.FilePath ((</>), takeDirectory, normalise)
+import System.IO (stderr)
+import System.IO.Error
+import System.Random (StdGen)
+import Text.Pandoc.Class.CommonState (CommonState (..))
+import Text.Pandoc.Class.PandocMonad
+       (PandocMonad, getsCommonState, getMediaBag, report)
+import Text.Pandoc.Definition (Pandoc, Inline (Image))
+import Text.Pandoc.Error (PandocError (..))
+import Text.Pandoc.Logging (LogMessage (..), messageVerbosity, showLogMessage)
+import Text.Pandoc.MIME (MimeType)
+import Text.Pandoc.MediaBag (MediaBag, lookupMedia, mediaDirectory)
+import Text.Pandoc.Walk (walk)
+import qualified Control.Exception as E
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.CaseInsensitive as CI
+import qualified Data.Text as T
+import qualified Data.Time
+import qualified Data.Time.LocalTime
+import qualified Data.Unique
+import qualified System.Directory
+import qualified System.Environment as Env
+import qualified System.FilePath.Glob
+import qualified System.Random
+import qualified Text.Pandoc.UTF8 as UTF8
+#ifndef EMBED_DATA_FILES
+import qualified Paths_pandoc as Paths
+#endif
+
+-- | Utility function to lift IO errors into 'PandocError's.
+liftIOError :: (PandocMonad m, MonadIO m) => (String -> IO a) -> String -> m a
+liftIOError f u = do
+  res <- liftIO $ tryIOError $ f u
+  case res of
+         Left e  -> throwError $ PandocIOError (pack u) e
+         Right r -> return r
+
+-- | Show potential IO errors to the user continuing execution anyway
+logIOError :: (PandocMonad m, MonadIO m) => IO () -> m ()
+logIOError f = do
+  res <- liftIO $ tryIOError f
+  case res of
+    Left e -> report $ IgnoredIOError $ pack $ E.displayException e
+    Right _ -> pure ()
+
+-- | Lookup an environment variable in the programs environment.
+lookupEnv :: MonadIO m => Text -> m (Maybe Text)
+lookupEnv = fmap (fmap pack) . liftIO . Env.lookupEnv . unpack
+
+-- | Get the current (UTC) time.
+getCurrentTime :: MonadIO m => m UTCTime
+getCurrentTime = liftIO Data.Time.getCurrentTime
+
+-- | Get the locale's time zone.
+getCurrentTimeZone :: MonadIO m => m TimeZone
+getCurrentTimeZone = liftIO Data.Time.LocalTime.getCurrentTimeZone
+
+-- | Return a new generator for random numbers.
+newStdGen :: MonadIO m => m StdGen
+newStdGen = liftIO System.Random.newStdGen
+
+-- | Return a new unique integer.
+newUniqueHash :: MonadIO m => m Int
+newUniqueHash = hashUnique <$> liftIO Data.Unique.newUnique
+
+openURL :: (PandocMonad m, MonadIO m) => Text -> m (B.ByteString, Maybe MimeType)
+openURL u
+ | Just u'' <- T.stripPrefix "data:" u = do
+     let mime     = T.takeWhile (/=',') u''
+     let contents = UTF8.fromString $
+                     unEscapeString $ T.unpack $ T.drop 1 $ T.dropWhile (/=',') u''
+     return (decodeLenient contents, Just mime)
+ | otherwise = do
+     let toReqHeader (n, v) = (CI.mk (UTF8.fromText n), UTF8.fromText v)
+     customHeaders <- map toReqHeader <$> getsCommonState stRequestHeaders
+     disableCertificateValidation <- getsCommonState stNoCheckCertificate
+     report $ Fetching u
+     res <- liftIO $ E.try $ withSocketsDo $ do
+       let parseReq = parseRequest
+       proxy <- tryIOError (getEnv "http_proxy")
+       let addProxy' x = case proxy of
+                            Left _ -> return x
+                            Right pr -> parseReq pr >>= \r ->
+                                return (addProxy (host r) (port r) x)
+       req <- parseReq (unpack u) >>= addProxy'
+       let req' = req{requestHeaders = customHeaders ++ requestHeaders req}
+       let tlsSimple = TLSSettingsSimple disableCertificateValidation False False
+       let tlsManagerSettings = mkManagerSettings tlsSimple  Nothing
+       resp <- newManager tlsManagerSettings >>= httpLbs req'
+       return (B.concat $ toChunks $ responseBody resp,
+               UTF8.toText `fmap` lookup hContentType (responseHeaders resp))
+
+     case res of
+          Right r -> return r
+          Left e  -> throwError $ PandocHttpError u e
+
+-- | Read the lazy ByteString contents from a file path, raising an error on
+-- failure.
+readFileLazy :: (PandocMonad m, MonadIO m) => FilePath -> m BL.ByteString
+readFileLazy s = liftIOError BL.readFile s
+
+-- | Read the strict ByteString contents from a file path,
+-- raising an error on failure.
+readFileStrict :: (PandocMonad m, MonadIO m) => FilePath -> m B.ByteString
+readFileStrict s = liftIOError B.readFile s
+
+-- | Return a list of paths that match a glob, relative to the working
+-- directory. See 'System.FilePath.Glob' for the glob syntax.
+glob :: (PandocMonad m, MonadIO m) => String -> m [FilePath]
+glob = liftIOError System.FilePath.Glob.glob
+
+-- | Returns True if file exists.
+fileExists :: (PandocMonad m, MonadIO m) => FilePath -> m Bool
+fileExists = liftIOError System.Directory.doesFileExist
+
+-- | Returns the path of data file.
+getDataFileName :: (PandocMonad m, MonadIO m) => FilePath -> m FilePath
+#ifdef EMBED_DATA_FILES
+getDataFileName = return
+#else
+getDataFileName = liftIOError Paths.getDataFileName
+#endif
+
+-- | Return the modification time of a file.
+getModificationTime :: (PandocMonad m, MonadIO m) => FilePath -> m UTCTime
+getModificationTime = liftIOError System.Directory.getModificationTime
+
+-- | Output a log message.
+logOutput :: (PandocMonad m, MonadIO m) => LogMessage -> m ()
+logOutput msg = liftIO $ do
+  UTF8.hPutStr stderr $
+      "[" ++ show (messageVerbosity msg) ++ "] "
+  alertIndent $ T.lines $ showLogMessage msg
+
+-- | Prints the list of lines to @stderr@, indenting every but the first
+-- line by two spaces.
+alertIndent :: [Text] -> IO ()
+alertIndent [] = return ()
+alertIndent (l:ls) = do
+  UTF8.hPutStrLn stderr $ unpack l
+  mapM_ go ls
+  where go l' = do UTF8.hPutStr stderr "  "
+                   UTF8.hPutStrLn stderr $ unpack l'
+
+-- | Extract media from the mediabag into a directory.
+extractMedia :: (PandocMonad m, MonadIO m) => FilePath -> Pandoc -> m Pandoc
+extractMedia dir d = do
+  media <- getMediaBag
+  case [fp | (fp, _, _) <- mediaDirectory media] of
+    []  -> return d
+    fps -> do
+      mapM_ (writeMedia dir media) fps
+      return $ walk (adjustImagePath dir fps) d
+
+-- | Write the contents of a media bag to a path.
+writeMedia :: (PandocMonad m, MonadIO m)
+           => FilePath -> MediaBag -> FilePath
+           -> m ()
+writeMedia dir mediabag subpath = do
+  -- we join and split to convert a/b/c to a\b\c on Windows;
+  -- in zip containers all paths use /
+  let fullpath = dir </> unEscapeString (normalise subpath)
+  let mbcontents = lookupMedia subpath mediabag
+  case mbcontents of
+       Nothing -> throwError $ PandocResourceNotFound $ pack subpath
+       Just (_, bs) -> do
+         report $ Extracting $ pack fullpath
+         liftIOError (createDirectoryIfMissing True) (takeDirectory fullpath)
+         logIOError $ BL.writeFile fullpath bs
+
+-- | If the given Inline element is an image with a @src@ path equal to
+-- one in the list of @paths@, then prepends @dir@ to the image source;
+-- returns the element unchanged otherwise.
+adjustImagePath :: FilePath -> [FilePath] -> Inline -> Inline
+adjustImagePath dir paths (Image attr lab (src, tit))
+   | unpack src `elem` paths = Image attr lab (pack dir <> "/" <> src, tit)
+adjustImagePath _ _ x = x
diff --git a/src/Text/Pandoc/Class/PandocIO.hs b/src/Text/Pandoc/Class/PandocIO.hs
index ee6a041ba..63cb94155 100644
--- a/src/Text/Pandoc/Class/PandocIO.hs
+++ b/src/Text/Pandoc/Class/PandocIO.hs
@@ -1,7 +1,5 @@
-{-# LANGUAGE CPP #-}
 {-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE OverloadedStrings #-}
 {- |
 Module      : Text.Pandoc.Class.PandocIO
 Copyright   : Copyright (C) 2016-2020 Jesse Rosenthal, John MacFarlane
@@ -16,79 +14,21 @@ This module defines @'PandocIO'@, an IO-based instance of the
 using IO operators.
 -}
 module Text.Pandoc.Class.PandocIO
-  ( getPOSIXTime
-  , getZonedTime
-  , readFileFromDirs
-  , report
-  , setTrace
-  , setRequestHeader
-  , getLog
-  , setVerbosity
-  , getVerbosity
-  , getMediaBag
-  , setMediaBag
-  , insertMedia
-  , setUserDataDir
-  , getUserDataDir
-  , fetchItem
-  , getInputFiles
-  , setInputFiles
-  , getOutputFile
-  , setOutputFile
-  , setResourcePath
-  , getResourcePath
-  , PandocIO(..)
+  ( PandocIO(..)
   , runIO
   , runIOorExplode
   , extractMedia
  ) where
 
-import Control.Monad.Except
-import Control.Monad.State.Strict
-import Data.ByteString.Base64 (decodeLenient)
-import Data.ByteString.Lazy (toChunks)
-import Data.Default
-import Data.Text (Text)
-import Data.Unique (hashUnique)
-import Network.HTTP.Client
-       (httpLbs, responseBody, responseHeaders,
-        Request(port, host, requestHeaders), parseRequest, newManager)
-import Network.HTTP.Client.Internal (addProxy)
-import Network.HTTP.Client.TLS (mkManagerSettings)
-import Network.Connection (TLSSettings (..))
-import Network.HTTP.Types.Header ( hContentType )
-import Network.Socket (withSocketsDo)
-import Network.URI ( unEscapeString )
-import Prelude
-import System.Directory (createDirectoryIfMissing)
-import System.Environment (getEnv)
-import System.FilePath ((</>), takeDirectory, normalise)
-import System.IO (stderr)
-import System.IO.Error
+import Control.Monad.Except (ExceptT, MonadError, runExceptT)
+import Control.Monad.IO.Class (MonadIO)
+import Control.Monad.State (StateT, evalStateT, lift, get, put)
+import Data.Default (Default (def))
 import Text.Pandoc.Class.CommonState (CommonState (..))
 import Text.Pandoc.Class.PandocMonad
 import Text.Pandoc.Definition
 import Text.Pandoc.Error
-import Text.Pandoc.Logging
-import Text.Pandoc.MediaBag (MediaBag, lookupMedia, mediaDirectory)
-import Text.Pandoc.Walk (walk)
-import qualified Control.Exception as E
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Lazy as BL
-import qualified Data.CaseInsensitive as CI
-import qualified Data.Text as T
-import qualified Data.Time as IO (getCurrentTime)
-import qualified Data.Time.LocalTime as IO (getCurrentTimeZone)
-import qualified Data.Unique as IO (newUnique)
-import qualified System.Directory as Directory
-import qualified System.Directory as IO (getModificationTime)
-import qualified System.Environment as IO (lookupEnv)
-import qualified System.FilePath.Glob as IO (glob)
-import qualified System.Random as IO (newStdGen)
-import qualified Text.Pandoc.UTF8 as UTF8
-#ifndef EMBED_DATA_FILES
-import qualified Paths_pandoc as Paths
-#endif
+import qualified Text.Pandoc.Class.IO as IO
 
 -- | Evaluate a 'PandocIO' operation.
 runIO :: PandocIO a -> IO (Either PandocError a)
@@ -108,113 +48,27 @@ newtype PandocIO a = PandocIO {
              , MonadError PandocError
              )
 
--- | Utility function to lift IO errors into 'PandocError's.
-liftIOError :: (String -> IO a) -> String -> PandocIO a
-liftIOError f u = do
-  res <- liftIO $ tryIOError $ f u
-  case res of
-         Left e  -> throwError $ PandocIOError (T.pack u) e
-         Right r -> return r
-
--- | Show potential IO errors to the user continuing execution anyway
-logIOError :: IO () -> PandocIO ()
-logIOError f = do
-  res <- liftIO $ tryIOError f
-  case res of
-    Left e -> report $ IgnoredIOError $ T.pack $ E.displayException e
-    Right _ -> pure ()
-
 instance PandocMonad PandocIO where
-  lookupEnv = fmap (fmap T.pack) . liftIO . IO.lookupEnv . T.unpack
-  getCurrentTime = liftIO IO.getCurrentTime
-  getCurrentTimeZone = liftIO IO.getCurrentTimeZone
-  newStdGen = liftIO IO.newStdGen
-  newUniqueHash = hashUnique <$> liftIO IO.newUnique
-
-  openURL u
-   | Just u'' <- T.stripPrefix "data:" u = do
-       let mime     = T.takeWhile (/=',') u''
-       let contents = UTF8.fromString $
-                       unEscapeString $ T.unpack $ T.drop 1 $ T.dropWhile (/=',') u''
-       return (decodeLenient contents, Just mime)
-   | otherwise = do
-       let toReqHeader (n, v) = (CI.mk (UTF8.fromText n), UTF8.fromText v)
-       customHeaders <- map toReqHeader <$> getsCommonState stRequestHeaders
-       disableCertificateValidation <- getsCommonState stNoCheckCertificate
-       report $ Fetching u
-       res <- liftIO $ E.try $ withSocketsDo $ do
-         let parseReq = parseRequest
-         proxy <- tryIOError (getEnv "http_proxy")
-         let addProxy' x = case proxy of
-                              Left _ -> return x
-                              Right pr -> parseReq pr >>= \r ->
-                                  return (addProxy (host r) (port r) x)
-         req <- parseReq (T.unpack u) >>= addProxy'
-         let req' = req{requestHeaders = customHeaders ++ requestHeaders req}
-         resp <- newManager (mkManagerSettings  (TLSSettingsSimple disableCertificateValidation False False) Nothing) >>= httpLbs req'
-         return (B.concat $ toChunks $ responseBody resp,
-                 UTF8.toText `fmap` lookup hContentType (responseHeaders resp))
+  lookupEnv = IO.lookupEnv
+  getCurrentTime = IO.getCurrentTime
+  getCurrentTimeZone = IO.getCurrentTimeZone
+  newStdGen = IO.newStdGen
+  newUniqueHash = IO.newUniqueHash
 
-       case res of
-            Right r -> return r
-            Left e  -> throwError $ PandocHttpError u e
+  openURL = IO.openURL
+  readFileLazy = IO.readFileLazy
+  readFileStrict = IO.readFileStrict
 
-  readFileLazy s = liftIOError BL.readFile s
-  readFileStrict s = liftIOError B.readFile s
+  glob = IO.glob
+  fileExists = IO.fileExists
+  getDataFileName = IO.getDataFileName
+  getModificationTime = IO.getModificationTime
 
-  glob = liftIOError IO.glob
-  fileExists = liftIOError Directory.doesFileExist
-#ifdef EMBED_DATA_FILES
-  getDataFileName = return
-#else
-  getDataFileName = liftIOError Paths.getDataFileName
-#endif
-  getModificationTime = liftIOError IO.getModificationTime
   getCommonState = PandocIO $ lift get
-  putCommonState x = PandocIO $ lift $ put x
-  logOutput msg = liftIO $ do
-    UTF8.hPutStr stderr $
-        "[" ++ show (messageVerbosity msg) ++ "] "
-    alertIndent $ T.lines $ showLogMessage msg
+  putCommonState = PandocIO . lift . put
 
--- | Prints the list of lines to @stderr@, indenting every but the first
--- line by two spaces.
-alertIndent :: [Text] -> IO ()
-alertIndent [] = return ()
-alertIndent (l:ls) = do
-  UTF8.hPutStrLn stderr $ T.unpack l
-  mapM_ go ls
-  where go l' = do UTF8.hPutStr stderr "  "
-                   UTF8.hPutStrLn stderr $ T.unpack l'
+  logOutput = IO.logOutput
 
 -- | Extract media from the mediabag into a directory.
 extractMedia :: FilePath -> Pandoc -> PandocIO Pandoc
-extractMedia dir d = do
-  media <- getMediaBag
-  case [fp | (fp, _, _) <- mediaDirectory media] of
-        []  -> return d
-        fps -> do
-          mapM_ (writeMedia dir media) fps
-          return $ walk (adjustImagePath dir fps) d
-
--- | Write the contents of a media bag to a path.
-writeMedia :: FilePath -> MediaBag -> FilePath -> PandocIO ()
-writeMedia dir mediabag subpath = do
-  -- we join and split to convert a/b/c to a\b\c on Windows;
-  -- in zip containers all paths use /
-  let fullpath = dir </> unEscapeString (normalise subpath)
-  let mbcontents = lookupMedia subpath mediabag
-  case mbcontents of
-       Nothing -> throwError $ PandocResourceNotFound $ T.pack subpath
-       Just (_, bs) -> do
-         report $ Extracting $ T.pack fullpath
-         liftIOError (createDirectoryIfMissing True) (takeDirectory fullpath)
-         logIOError $ BL.writeFile fullpath bs
-
--- | If the given Inline element is an image with a @src@ path equal to
--- one in the list of @paths@, then prepends @dir@ to the image source;
--- returns the element unchanged otherwise.
-adjustImagePath :: FilePath -> [FilePath] -> Inline -> Inline
-adjustImagePath dir paths (Image attr lab (src, tit))
-   | T.unpack src `elem` paths = Image attr lab (T.pack dir <> "/" <> src, tit)
-adjustImagePath _ _ x = x
+extractMedia = IO.extractMedia