{-# 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
  , readStdinStrict
  , extractMedia
  , writeMedia
 ) 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(..))
import qualified Network.TLS as TLS
import qualified Network.TLS.Extra as TLS
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 (URI(..), parseURI, unEscapeString)
import System.Directory (createDirectoryIfMissing)
import System.Environment (getEnv)
import System.FilePath ((</>), takeDirectory, normalise)
import qualified System.FilePath.Posix as Posix
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, MediaItem(..), lookupMedia, mediaItems)
import Text.Pandoc.Walk (walk)
import qualified Control.Exception as E
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
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
import Data.Default (def)
import System.X509 (getSystemCertificateStore)
#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 :: forall (m :: * -> *) a.
(PandocMonad m, MonadIO m) =>
(String -> IO a) -> String -> m a
liftIOError String -> IO a
f String
u = do
  Either IOError a
res <- IO (Either IOError a) -> m (Either IOError a)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOError a) -> m (Either IOError a))
-> IO (Either IOError a) -> m (Either IOError a)
forall a b. (a -> b) -> a -> b
$ IO a -> IO (Either IOError a)
forall a. IO a -> IO (Either IOError a)
tryIOError (IO a -> IO (Either IOError a)) -> IO a -> IO (Either IOError a)
forall a b. (a -> b) -> a -> b
$ String -> IO a
f String
u
  case Either IOError a
res of
         Left IOError
e  -> PandocError -> m a
forall a. PandocError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError -> m a) -> PandocError -> m a
forall a b. (a -> b) -> a -> b
$ Text -> IOError -> PandocError
PandocIOError (String -> Text
pack String
u) IOError
e
         Right a
r -> a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r

-- | Show potential IO errors to the user continuing execution anyway
logIOError :: (PandocMonad m, MonadIO m) => IO () -> m ()
logIOError :: forall (m :: * -> *). (PandocMonad m, MonadIO m) => IO () -> m ()
logIOError IO ()
f = do
  Either IOError ()
res <- IO (Either IOError ()) -> m (Either IOError ())
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOError ()) -> m (Either IOError ()))
-> IO (Either IOError ()) -> m (Either IOError ())
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Either IOError ())
forall a. IO a -> IO (Either IOError a)
tryIOError IO ()
f
  case Either IOError ()
res of
    Left IOError
e -> LogMessage -> m ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (LogMessage -> m ()) -> LogMessage -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> LogMessage
IgnoredIOError (Text -> LogMessage) -> Text -> LogMessage
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ IOError -> String
forall e. Exception e => e -> String
E.displayException IOError
e
    Right ()
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Lookup an environment variable in the programs environment.
lookupEnv :: MonadIO m => Text -> m (Maybe Text)
lookupEnv :: forall (m :: * -> *). MonadIO m => Text -> m (Maybe Text)
lookupEnv = (Maybe String -> Maybe Text) -> m (Maybe String) -> m (Maybe Text)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String -> Text) -> Maybe String -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Text
pack) (m (Maybe String) -> m (Maybe Text))
-> (Text -> m (Maybe String)) -> Text -> m (Maybe Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Maybe String) -> m (Maybe String)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> m (Maybe String))
-> (Text -> IO (Maybe String)) -> Text -> m (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO (Maybe String)
Env.lookupEnv (String -> IO (Maybe String))
-> (Text -> String) -> Text -> IO (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack

-- | Get the current (UTC) time.
getCurrentTime :: MonadIO m => m UTCTime
getCurrentTime :: forall (m :: * -> *). MonadIO m => m UTCTime
getCurrentTime = IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
Data.Time.getCurrentTime

-- | Get the locale's time zone.
getCurrentTimeZone :: MonadIO m => m TimeZone
getCurrentTimeZone :: forall (m :: * -> *). MonadIO m => m TimeZone
getCurrentTimeZone = IO TimeZone -> m TimeZone
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO TimeZone
Data.Time.LocalTime.getCurrentTimeZone

-- | Return a new generator for random numbers.
newStdGen :: MonadIO m => m StdGen
newStdGen :: forall (m :: * -> *). MonadIO m => m StdGen
newStdGen = IO StdGen -> m StdGen
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO StdGen
forall (m :: * -> *). MonadIO m => m StdGen
System.Random.newStdGen

-- | Return a new unique integer.
newUniqueHash :: MonadIO m => m Int
newUniqueHash :: forall (m :: * -> *). MonadIO m => m Int
newUniqueHash = Unique -> Int
hashUnique (Unique -> Int) -> m Unique -> m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Unique -> m Unique
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Unique
Data.Unique.newUnique

openURL :: (PandocMonad m, MonadIO m) => Text -> m (B.ByteString, Maybe MimeType)
openURL :: forall (m :: * -> *).
(PandocMonad m, MonadIO m) =>
Text -> m (ByteString, Maybe Text)
openURL Text
u
 | Just (URI{ uriScheme :: URI -> String
uriScheme = String
"data:",
              uriPath :: URI -> String
uriPath = String
upath }) <- String -> Maybe URI
parseURI (Text -> String
T.unpack Text
u) = do
     let (String
mimespec, String
rest) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
',') (String -> (String, String)) -> String -> (String, String)
forall a b. (a -> b) -> a -> b
$ String -> String
unEscapeString String
upath
     let contents :: ByteString
contents = String -> ByteString
UTF8.fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1 String
rest
     case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
';') ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' ') String
mimespec) of
       (String
mime, String
";base64") ->
         (ByteString, Maybe Text) -> m (ByteString, Maybe Text)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> ByteString
decodeLenient ByteString
contents, Text -> Maybe Text
forall a. a -> Maybe a
Just (String -> Text
T.pack String
mime))
       (String
mime, String
_) ->
         (ByteString, Maybe Text) -> m (ByteString, Maybe Text)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
contents, Text -> Maybe Text
forall a. a -> Maybe a
Just (String -> Text
T.pack String
mime))
 | Bool
otherwise = do
     let toReqHeader :: (Text, Text) -> (HeaderName, ByteString)
toReqHeader (Text
n, Text
v) = (ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
CI.mk (Text -> ByteString
UTF8.fromText Text
n), Text -> ByteString
UTF8.fromText Text
v)
     [(HeaderName, ByteString)]
customHeaders <- ((Text, Text) -> (HeaderName, ByteString))
-> [(Text, Text)] -> [(HeaderName, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Text) -> (HeaderName, ByteString)
toReqHeader ([(Text, Text)] -> [(HeaderName, ByteString)])
-> m [(Text, Text)] -> m [(HeaderName, ByteString)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CommonState -> [(Text, Text)]) -> m [(Text, Text)]
forall a. (CommonState -> a) -> m a
forall (m :: * -> *) a. PandocMonad m => (CommonState -> a) -> m a
getsCommonState CommonState -> [(Text, Text)]
stRequestHeaders
     Bool
disableCertificateValidation <- (CommonState -> Bool) -> m Bool
forall a. (CommonState -> a) -> m a
forall (m :: * -> *) a. PandocMonad m => (CommonState -> a) -> m a
getsCommonState CommonState -> Bool
stNoCheckCertificate
     LogMessage -> m ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (LogMessage -> m ()) -> LogMessage -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> LogMessage
Fetching Text
u
     Either HttpException (ByteString, Maybe Text)
res <- IO (Either HttpException (ByteString, Maybe Text))
-> m (Either HttpException (ByteString, Maybe Text))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either HttpException (ByteString, Maybe Text))
 -> m (Either HttpException (ByteString, Maybe Text)))
-> IO (Either HttpException (ByteString, Maybe Text))
-> m (Either HttpException (ByteString, Maybe Text))
forall a b. (a -> b) -> a -> b
$ IO (ByteString, Maybe Text)
-> IO (Either HttpException (ByteString, Maybe Text))
forall e a. Exception e => IO a -> IO (Either e a)
E.try (IO (ByteString, Maybe Text)
 -> IO (Either HttpException (ByteString, Maybe Text)))
-> IO (ByteString, Maybe Text)
-> IO (Either HttpException (ByteString, Maybe Text))
forall a b. (a -> b) -> a -> b
$ IO (ByteString, Maybe Text) -> IO (ByteString, Maybe Text)
forall a. IO a -> IO a
withSocketsDo (IO (ByteString, Maybe Text) -> IO (ByteString, Maybe Text))
-> IO (ByteString, Maybe Text) -> IO (ByteString, Maybe Text)
forall a b. (a -> b) -> a -> b
$ do
       Either IOError String
proxy <- IO String -> IO (Either IOError String)
forall a. IO a -> IO (Either IOError a)
tryIOError (String -> IO String
getEnv String
"http_proxy")
       let addProxy' :: Request -> m Request
addProxy' Request
x = case Either IOError String
proxy of
                            Left IOError
_ -> Request -> m Request
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Request
x
                            Right String
pr -> String -> m Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest String
pr m Request -> (Request -> m Request) -> m Request
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Request
r ->
                                Request -> m Request
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Int -> Request -> Request
addProxy (Request -> ByteString
host Request
r) (Request -> Int
port Request
r) Request
x)
       Request
req <- String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest (Text -> String
unpack Text
u) IO Request -> (Request -> IO Request) -> IO Request
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Request -> IO Request
forall {m :: * -> *}. MonadThrow m => Request -> m Request
addProxy'
       let req' :: Request
req' = Request
req{requestHeaders = customHeaders ++ requestHeaders req}
       CertificateStore
certificateStore <- IO CertificateStore
getSystemCertificateStore
       let tlsSettings :: TLSSettings
tlsSettings = ClientParams -> TLSSettings
TLSSettings (ClientParams -> TLSSettings) -> ClientParams -> TLSSettings
forall a b. (a -> b) -> a -> b
$
              (String -> ByteString -> ClientParams
TLS.defaultParamsClient (ByteString -> String
forall a. Show a => a -> String
show (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
host Request
req')
                                       (String -> ByteString
B8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ Request -> Int
port Request
req'))
                 { TLS.clientSupported = def{ TLS.supportedCiphers =
                                              TLS.ciphersuite_default
                                            , TLS.supportedExtendedMainSecret =
                                               TLS.AllowEMS }
                 , TLS.clientShared = def
                     { TLS.sharedCAStore = certificateStore
                     , TLS.sharedValidationCache =
                         if disableCertificateValidation
                            then TLS.ValidationCache
                                  (\ServiceID
_ Fingerprint
_ Certificate
_ -> ValidationCacheResult -> IO ValidationCacheResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ValidationCacheResult
TLS.ValidationCachePass)
                                  (\ServiceID
_ Fingerprint
_ Certificate
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
                            else def
                     }
                 }
       let tlsManagerSettings :: ManagerSettings
tlsManagerSettings = TLSSettings -> Maybe SockSettings -> ManagerSettings
mkManagerSettings TLSSettings
tlsSettings  Maybe SockSettings
forall a. Maybe a
Nothing
       Response ByteString
resp <- ManagerSettings -> IO Manager
newManager ManagerSettings
tlsManagerSettings IO Manager
-> (Manager -> IO (Response ByteString))
-> IO (Response ByteString)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Request -> Manager -> IO (Response ByteString)
httpLbs Request
req'
       (ByteString, Maybe Text) -> IO (ByteString, Maybe Text)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([ByteString] -> ByteString
B.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
toChunks (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall a b. (a -> b) -> a -> b
$ Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
resp,
               ByteString -> Text
UTF8.toText (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hContentType (Response ByteString -> [(HeaderName, ByteString)]
forall body. Response body -> [(HeaderName, ByteString)]
responseHeaders Response ByteString
resp))

     case Either HttpException (ByteString, Maybe Text)
res of
          Right (ByteString, Maybe Text)
r -> (ByteString, Maybe Text) -> m (ByteString, Maybe Text)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString, Maybe Text)
r
          Left HttpException
e  -> PandocError -> m (ByteString, Maybe Text)
forall a. PandocError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError -> m (ByteString, Maybe Text))
-> PandocError -> m (ByteString, Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> HttpException -> PandocError
PandocHttpError Text
u HttpException
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 :: forall (m :: * -> *).
(PandocMonad m, MonadIO m) =>
String -> m ByteString
readFileLazy String
s = (String -> IO ByteString) -> String -> m ByteString
forall (m :: * -> *) a.
(PandocMonad m, MonadIO m) =>
(String -> IO a) -> String -> m a
liftIOError String -> IO ByteString
BL.readFile String
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 :: forall (m :: * -> *).
(PandocMonad m, MonadIO m) =>
String -> m ByteString
readFileStrict String
s = (String -> IO ByteString) -> String -> m ByteString
forall (m :: * -> *) a.
(PandocMonad m, MonadIO m) =>
(String -> IO a) -> String -> m a
liftIOError String -> IO ByteString
B.readFile String
s

-- | Read the strict ByteString contents from stdin, raising
-- an error on failure.
readStdinStrict :: (PandocMonad m, MonadIO m) => m B.ByteString
readStdinStrict :: forall (m :: * -> *). (PandocMonad m, MonadIO m) => m ByteString
readStdinStrict = (String -> IO ByteString) -> String -> m ByteString
forall (m :: * -> *) a.
(PandocMonad m, MonadIO m) =>
(String -> IO a) -> String -> m a
liftIOError (IO ByteString -> String -> IO ByteString
forall a b. a -> b -> a
const IO ByteString
B.getContents) String
"stdin"

-- | 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 :: forall (m :: * -> *).
(PandocMonad m, MonadIO m) =>
String -> m [String]
glob = (String -> IO [String]) -> String -> m [String]
forall (m :: * -> *) a.
(PandocMonad m, MonadIO m) =>
(String -> IO a) -> String -> m a
liftIOError String -> IO [String]
System.FilePath.Glob.glob

-- | Returns True if file exists.
fileExists :: (PandocMonad m, MonadIO m) => FilePath -> m Bool
fileExists :: forall (m :: * -> *).
(PandocMonad m, MonadIO m) =>
String -> m Bool
fileExists = (String -> IO Bool) -> String -> m Bool
forall (m :: * -> *) a.
(PandocMonad m, MonadIO m) =>
(String -> IO a) -> String -> m a
liftIOError String -> IO Bool
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 :: forall (m :: * -> *).
(PandocMonad m, MonadIO m) =>
String -> m String
getDataFileName = (String -> IO String) -> String -> m String
forall (m :: * -> *) a.
(PandocMonad m, MonadIO m) =>
(String -> IO a) -> String -> m a
liftIOError String -> IO String
Paths.getDataFileName
#endif

-- | Return the modification time of a file.
getModificationTime :: (PandocMonad m, MonadIO m) => FilePath -> m UTCTime
getModificationTime :: forall (m :: * -> *).
(PandocMonad m, MonadIO m) =>
String -> m UTCTime
getModificationTime = (String -> IO UTCTime) -> String -> m UTCTime
forall (m :: * -> *) a.
(PandocMonad m, MonadIO m) =>
(String -> IO a) -> String -> m a
liftIOError String -> IO UTCTime
System.Directory.getModificationTime

-- | Output a log message.
logOutput :: (PandocMonad m, MonadIO m) => LogMessage -> m ()
logOutput :: forall (m :: * -> *).
(PandocMonad m, MonadIO m) =>
LogMessage -> m ()
logOutput LogMessage
msg = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  Handle -> Text -> IO ()
UTF8.hPutStr Handle
stderr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
      Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Verbosity -> String
forall a. Show a => a -> String
show (LogMessage -> Verbosity
messageVerbosity LogMessage
msg)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"] "
  [Text] -> IO ()
alertIndent ([Text] -> IO ()) -> [Text] -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.lines (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ LogMessage -> Text
showLogMessage LogMessage
msg

-- | Prints the list of lines to @stderr@, indenting every but the first
-- line by two spaces.
alertIndent :: [Text] -> IO ()
alertIndent :: [Text] -> IO ()
alertIndent [] = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
alertIndent (Text
l:[Text]
ls) = do
  Handle -> Text -> IO ()
UTF8.hPutStrLn Handle
stderr Text
l
  (Text -> IO ()) -> [Text] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Text -> IO ()
go [Text]
ls
  where go :: Text -> IO ()
go Text
l' = do Handle -> Text -> IO ()
UTF8.hPutStr Handle
stderr Text
"  "
                   Handle -> Text -> IO ()
UTF8.hPutStrLn Handle
stderr Text
l'

-- | Extract media from the mediabag into a directory.
extractMedia :: (PandocMonad m, MonadIO m) => FilePath -> Pandoc -> m Pandoc
extractMedia :: forall (m :: * -> *).
(PandocMonad m, MonadIO m) =>
String -> Pandoc -> m Pandoc
extractMedia String
dir Pandoc
d = do
  MediaBag
media <- m MediaBag
forall (m :: * -> *). PandocMonad m => m MediaBag
getMediaBag
  let items :: [(String, Text, ByteString)]
items = MediaBag -> [(String, Text, ByteString)]
mediaItems MediaBag
media
  if [(String, Text, ByteString)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(String, Text, ByteString)]
items
    then Pandoc -> m Pandoc
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Pandoc
d
    else do
      ((String, Text, ByteString) -> m ())
-> [(String, Text, ByteString)] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> (String, Text, ByteString) -> m ()
forall (m :: * -> *).
(PandocMonad m, MonadIO m) =>
String -> (String, Text, ByteString) -> m ()
writeMedia String
dir) [(String, Text, ByteString)]
items
      Pandoc -> m Pandoc
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pandoc -> m Pandoc) -> Pandoc -> m Pandoc
forall a b. (a -> b) -> a -> b
$ (Inline -> Inline) -> Pandoc -> Pandoc
forall a b. Walkable a b => (a -> a) -> b -> b
walk (String -> MediaBag -> Inline -> Inline
adjustImagePath String
dir MediaBag
media) Pandoc
d

-- | Write the contents of a media bag to a path.
-- If the path contains URI escape sequences (percent-encoding),
-- these are resolved.
writeMedia :: (PandocMonad m, MonadIO m)
           => FilePath
           -> (FilePath, MimeType, BL.ByteString)
           -> m ()
writeMedia :: forall (m :: * -> *).
(PandocMonad m, MonadIO m) =>
String -> (String, Text, ByteString) -> m ()
writeMedia String
dir (String
fp, Text
_mt, ByteString
bs) = do
  -- we normalize to get proper path separators for the platform
  -- we unescape URI encoding, but given how insertMedia
  -- is written, we shouldn't have any % in a canonical media name...
  let fullpath :: String
fullpath = String -> String
normalise (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
dir String -> String -> String
</> String -> String
unEscapeString String
fp
  (String -> IO ()) -> String -> m ()
forall (m :: * -> *) a.
(PandocMonad m, MonadIO m) =>
(String -> IO a) -> String -> m a
liftIOError (Bool -> String -> IO ()
createDirectoryIfMissing Bool
True) (String -> String
takeDirectory String
fullpath)
  LogMessage -> m ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (LogMessage -> m ()) -> LogMessage -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> LogMessage
Extracting (String -> Text
T.pack String
fullpath)
  IO () -> m ()
forall (m :: * -> *). (PandocMonad m, MonadIO m) => IO () -> m ()
logIOError (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
BL.writeFile String
fullpath ByteString
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 -> MediaBag -> Inline -> Inline
adjustImagePath :: String -> MediaBag -> Inline -> Inline
adjustImagePath String
dir MediaBag
mediabag (Image Attr
attr [Inline]
lab (Text
src, Text
tit)) =
  case String -> MediaBag -> Maybe MediaItem
lookupMedia (Text -> String
T.unpack Text
src) MediaBag
mediabag of
    Maybe MediaItem
Nothing -> Attr -> [Inline] -> (Text, Text) -> Inline
Image Attr
attr [Inline]
lab (Text
src, Text
tit)
    Just MediaItem
item ->
      let fullpath :: String
fullpath = String
dir String -> String -> String
Posix.</> MediaItem -> String
mediaPath MediaItem
item
      in  Attr -> [Inline] -> (Text, Text) -> Inline
Image Attr
attr [Inline]
lab (String -> Text
T.pack String
fullpath, Text
tit)
adjustImagePath String
_ MediaBag
_ Inline
x = Inline
x