Class: generalize PandocIO functions to MonadIO
This commit is contained in:
parent
fb54f3d679
commit
eceb8eaf47
3 changed files with 253 additions and 167 deletions
|
@ -571,6 +571,7 @@ library
|
|||
Text.Pandoc.App.Opt,
|
||||
Text.Pandoc.App.OutputSettings,
|
||||
Text.Pandoc.Class.CommonState,
|
||||
Text.Pandoc.Class.IO,
|
||||
Text.Pandoc.Class.PandocMonad,
|
||||
Text.Pandoc.Class.PandocIO,
|
||||
Text.Pandoc.Class.PandocPure,
|
||||
|
|
231
src/Text/Pandoc/Class/IO.hs
Normal file
231
src/Text/Pandoc/Class/IO.hs
Normal file
|
@ -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
|
|
@ -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
|
||||
lookupEnv = IO.lookupEnv
|
||||
getCurrentTime = IO.getCurrentTime
|
||||
getCurrentTimeZone = IO.getCurrentTimeZone
|
||||
newStdGen = IO.newStdGen
|
||||
newUniqueHash = IO.newUniqueHash
|
||||
|
||||
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))
|
||||
openURL = IO.openURL
|
||||
readFileLazy = IO.readFileLazy
|
||||
readFileStrict = IO.readFileStrict
|
||||
|
||||
case res of
|
||||
Right r -> return r
|
||||
Left e -> throwError $ PandocHttpError u e
|
||||
glob = IO.glob
|
||||
fileExists = IO.fileExists
|
||||
getDataFileName = IO.getDataFileName
|
||||
getModificationTime = IO.getModificationTime
|
||||
|
||||
readFileLazy s = liftIOError BL.readFile s
|
||||
readFileStrict s = liftIOError B.readFile s
|
||||
|
||||
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
|
||||
|
|
Loading…
Reference in a new issue