{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
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(..)
, 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 (tlsManagerSettings)
import Network.HTTP.Types.Header ( hContentType )
import Network.Socket (withSocketsDo)
import Network.URI (URI(..), parseURI, 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 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
runIO :: PandocIO a -> IO (Either PandocError a)
runIO :: PandocIO a -> IO (Either PandocError a)
runIO ma :: PandocIO a
ma = (StateT CommonState IO (Either PandocError a)
-> CommonState -> IO (Either PandocError a))
-> CommonState
-> StateT CommonState IO (Either PandocError a)
-> IO (Either PandocError a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT CommonState IO (Either PandocError a)
-> CommonState -> IO (Either PandocError a)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT CommonState
forall a. Default a => a
def (StateT CommonState IO (Either PandocError a)
-> IO (Either PandocError a))
-> StateT CommonState IO (Either PandocError a)
-> IO (Either PandocError a)
forall a b. (a -> b) -> a -> b
$ ExceptT PandocError (StateT CommonState IO) a
-> StateT CommonState IO (Either PandocError a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT PandocError (StateT CommonState IO) a
-> StateT CommonState IO (Either PandocError a))
-> ExceptT PandocError (StateT CommonState IO) a
-> StateT CommonState IO (Either PandocError a)
forall a b. (a -> b) -> a -> b
$ PandocIO a -> ExceptT PandocError (StateT CommonState IO) a
forall a.
PandocIO a -> ExceptT PandocError (StateT CommonState IO) a
unPandocIO PandocIO a
ma
runIOorExplode :: PandocIO a -> IO a
runIOorExplode :: PandocIO a -> IO a
runIOorExplode ma :: PandocIO a
ma = PandocIO a -> IO (Either PandocError a)
forall a. PandocIO a -> IO (Either PandocError a)
runIO PandocIO a
ma IO (Either PandocError a) -> (Either PandocError a -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either PandocError a -> IO a
forall a. Either PandocError a -> IO a
handleError
newtype PandocIO a = PandocIO {
PandocIO a -> ExceptT PandocError (StateT CommonState IO) a
unPandocIO :: ExceptT PandocError (StateT CommonState IO) a
} deriving ( Monad PandocIO
Monad PandocIO =>
(forall a. IO a -> PandocIO a) -> MonadIO PandocIO
IO a -> PandocIO a
forall a. IO a -> PandocIO a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> PandocIO a
$cliftIO :: forall a. IO a -> PandocIO a
$cp1MonadIO :: Monad PandocIO
MonadIO
, a -> PandocIO b -> PandocIO a
(a -> b) -> PandocIO a -> PandocIO b
(forall a b. (a -> b) -> PandocIO a -> PandocIO b)
-> (forall a b. a -> PandocIO b -> PandocIO a) -> Functor PandocIO
forall a b. a -> PandocIO b -> PandocIO a
forall a b. (a -> b) -> PandocIO a -> PandocIO b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> PandocIO b -> PandocIO a
$c<$ :: forall a b. a -> PandocIO b -> PandocIO a
fmap :: (a -> b) -> PandocIO a -> PandocIO b
$cfmap :: forall a b. (a -> b) -> PandocIO a -> PandocIO b
Functor
, Functor PandocIO
a -> PandocIO a
Functor PandocIO =>
(forall a. a -> PandocIO a)
-> (forall a b. PandocIO (a -> b) -> PandocIO a -> PandocIO b)
-> (forall a b c.
(a -> b -> c) -> PandocIO a -> PandocIO b -> PandocIO c)
-> (forall a b. PandocIO a -> PandocIO b -> PandocIO b)
-> (forall a b. PandocIO a -> PandocIO b -> PandocIO a)
-> Applicative PandocIO
PandocIO a -> PandocIO b -> PandocIO b
PandocIO a -> PandocIO b -> PandocIO a
PandocIO (a -> b) -> PandocIO a -> PandocIO b
(a -> b -> c) -> PandocIO a -> PandocIO b -> PandocIO c
forall a. a -> PandocIO a
forall a b. PandocIO a -> PandocIO b -> PandocIO a
forall a b. PandocIO a -> PandocIO b -> PandocIO b
forall a b. PandocIO (a -> b) -> PandocIO a -> PandocIO b
forall a b c.
(a -> b -> c) -> PandocIO a -> PandocIO b -> PandocIO c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: PandocIO a -> PandocIO b -> PandocIO a
$c<* :: forall a b. PandocIO a -> PandocIO b -> PandocIO a
*> :: PandocIO a -> PandocIO b -> PandocIO b
$c*> :: forall a b. PandocIO a -> PandocIO b -> PandocIO b
liftA2 :: (a -> b -> c) -> PandocIO a -> PandocIO b -> PandocIO c
$cliftA2 :: forall a b c.
(a -> b -> c) -> PandocIO a -> PandocIO b -> PandocIO c
<*> :: PandocIO (a -> b) -> PandocIO a -> PandocIO b
$c<*> :: forall a b. PandocIO (a -> b) -> PandocIO a -> PandocIO b
pure :: a -> PandocIO a
$cpure :: forall a. a -> PandocIO a
$cp1Applicative :: Functor PandocIO
Applicative
, Applicative PandocIO
a -> PandocIO a
Applicative PandocIO =>
(forall a b. PandocIO a -> (a -> PandocIO b) -> PandocIO b)
-> (forall a b. PandocIO a -> PandocIO b -> PandocIO b)
-> (forall a. a -> PandocIO a)
-> Monad PandocIO
PandocIO a -> (a -> PandocIO b) -> PandocIO b
PandocIO a -> PandocIO b -> PandocIO b
forall a. a -> PandocIO a
forall a b. PandocIO a -> PandocIO b -> PandocIO b
forall a b. PandocIO a -> (a -> PandocIO b) -> PandocIO b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> PandocIO a
$creturn :: forall a. a -> PandocIO a
>> :: PandocIO a -> PandocIO b -> PandocIO b
$c>> :: forall a b. PandocIO a -> PandocIO b -> PandocIO b
>>= :: PandocIO a -> (a -> PandocIO b) -> PandocIO b
$c>>= :: forall a b. PandocIO a -> (a -> PandocIO b) -> PandocIO b
$cp1Monad :: Applicative PandocIO
Monad
, MonadError PandocError
)
liftIOError :: (String -> IO a) -> String -> PandocIO a
liftIOError :: (String -> IO a) -> String -> PandocIO a
liftIOError f :: String -> IO a
f u :: String
u = do
Either IOError a
res <- IO (Either IOError a) -> PandocIO (Either IOError a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOError a) -> PandocIO (Either IOError a))
-> IO (Either IOError a) -> PandocIO (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 e :: IOError
e -> PandocError -> PandocIO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError -> PandocIO a) -> PandocError -> PandocIO a
forall a b. (a -> b) -> a -> b
$ Text -> IOError -> PandocError
PandocIOError (String -> Text
T.pack String
u) IOError
e
Right r :: a
r -> a -> PandocIO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r
logIOError :: IO () -> PandocIO ()
logIOError :: IO () -> PandocIO ()
logIOError f :: IO ()
f = do
Either IOError ()
res <- IO (Either IOError ()) -> PandocIO (Either IOError ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOError ()) -> PandocIO (Either IOError ()))
-> IO (Either IOError ()) -> PandocIO (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 e :: IOError
e -> LogMessage -> PandocIO ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (LogMessage -> PandocIO ()) -> LogMessage -> PandocIO ()
forall a b. (a -> b) -> a -> b
$ Text -> LogMessage
IgnoredIOError (Text -> LogMessage) -> Text -> LogMessage
forall a b. (a -> b) -> a -> b
$ String -> Text
T.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 _ -> () -> PandocIO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
instance PandocMonad PandocIO where
lookupEnv :: Text -> PandocIO (Maybe Text)
lookupEnv = (Maybe String -> Maybe Text)
-> PandocIO (Maybe String) -> PandocIO (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String -> Text) -> Maybe String -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Text
T.pack) (PandocIO (Maybe String) -> PandocIO (Maybe Text))
-> (Text -> PandocIO (Maybe String))
-> Text
-> PandocIO (Maybe Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Maybe String) -> PandocIO (Maybe String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> PandocIO (Maybe String))
-> (Text -> IO (Maybe String)) -> Text -> PandocIO (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO (Maybe String)
IO.lookupEnv (String -> IO (Maybe String))
-> (Text -> String) -> Text -> IO (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
getCurrentTime :: PandocIO UTCTime
getCurrentTime = IO UTCTime -> PandocIO UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
IO.getCurrentTime
getCurrentTimeZone :: PandocIO TimeZone
getCurrentTimeZone = IO TimeZone -> PandocIO TimeZone
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO TimeZone
IO.getCurrentTimeZone
newStdGen :: PandocIO StdGen
newStdGen = IO StdGen -> PandocIO StdGen
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO StdGen
IO.newStdGen
newUniqueHash :: PandocIO Int
newUniqueHash = Unique -> Int
hashUnique (Unique -> Int) -> PandocIO Unique -> PandocIO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Unique -> PandocIO Unique
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Unique
IO.newUnique
openURL :: Text -> PandocIO (ByteString, Maybe Text)
openURL u :: 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 (mime :: String
mime, rest :: 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
== ',') (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 1 String
rest
(ByteString, Maybe Text) -> PandocIO (ByteString, Maybe Text)
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))
| Bool
otherwise = do
let toReqHeader :: (Text, Text) -> (CI ByteString, ByteString)
toReqHeader (n :: Text
n, v :: Text
v) = (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk (Text -> ByteString
UTF8.fromText Text
n), Text -> ByteString
UTF8.fromText Text
v)
[(CI ByteString, ByteString)]
customHeaders <- ((Text, Text) -> (CI ByteString, ByteString))
-> [(Text, Text)] -> [(CI ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Text) -> (CI ByteString, ByteString)
toReqHeader ([(Text, Text)] -> [(CI ByteString, ByteString)])
-> PandocIO [(Text, Text)]
-> PandocIO [(CI ByteString, ByteString)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CommonState -> [(Text, Text)]) -> PandocIO [(Text, Text)]
forall (m :: * -> *) a. PandocMonad m => (CommonState -> a) -> m a
getsCommonState CommonState -> [(Text, Text)]
stRequestHeaders
LogMessage -> PandocIO ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (LogMessage -> PandocIO ()) -> LogMessage -> PandocIO ()
forall a b. (a -> b) -> a -> b
$ Text -> LogMessage
Fetching Text
u
Either HttpException (ByteString, Maybe Text)
res <- IO (Either HttpException (ByteString, Maybe Text))
-> PandocIO (Either HttpException (ByteString, Maybe Text))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either HttpException (ByteString, Maybe Text))
-> PandocIO (Either HttpException (ByteString, Maybe Text)))
-> IO (Either HttpException (ByteString, Maybe Text))
-> PandocIO (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
let parseReq :: String -> IO Request
parseReq = String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest
Either IOError String
proxy <- IO String -> IO (Either IOError String)
forall a. IO a -> IO (Either IOError a)
tryIOError (String -> IO String
getEnv "http_proxy")
let addProxy' :: Request -> IO Request
addProxy' x :: Request
x = case Either IOError String
proxy of
Left _ -> Request -> IO Request
forall (m :: * -> *) a. Monad m => a -> m a
return Request
x
Right pr :: String
pr -> String -> IO Request
parseReq String
pr IO Request -> (Request -> IO Request) -> IO Request
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \r :: Request
r ->
Request -> IO Request
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
parseReq (Text -> String
T.unpack Text
u) IO Request -> (Request -> IO Request) -> IO Request
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Request -> IO Request
addProxy'
let req' :: Request
req' = Request
req{requestHeaders :: [(CI ByteString, ByteString)]
requestHeaders = [(CI ByteString, ByteString)]
customHeaders [(CI ByteString, ByteString)]
-> [(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)]
forall a. [a] -> [a] -> [a]
++ Request -> [(CI ByteString, ByteString)]
requestHeaders Request
req}
Response ByteString
resp <- ManagerSettings -> IO Manager
newManager ManagerSettings
tlsManagerSettings IO Manager
-> (Manager -> IO (Response ByteString))
-> IO (Response ByteString)
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 (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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` CI ByteString -> [(CI ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup CI ByteString
hContentType (Response ByteString -> [(CI ByteString, ByteString)]
forall body. Response body -> [(CI ByteString, ByteString)]
responseHeaders Response ByteString
resp))
case Either HttpException (ByteString, Maybe Text)
res of
Right r :: (ByteString, Maybe Text)
r -> (ByteString, Maybe Text) -> PandocIO (ByteString, Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString, Maybe Text)
r
Left e :: HttpException
e -> PandocError -> PandocIO (ByteString, Maybe Text)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError -> PandocIO (ByteString, Maybe Text))
-> PandocError -> PandocIO (ByteString, Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> HttpException -> PandocError
PandocHttpError Text
u HttpException
e
readFileLazy :: String -> PandocIO ByteString
readFileLazy s :: String
s = (String -> IO ByteString) -> String -> PandocIO ByteString
forall a. (String -> IO a) -> String -> PandocIO a
liftIOError String -> IO ByteString
BL.readFile String
s
readFileStrict :: String -> PandocIO ByteString
readFileStrict s :: String
s = (String -> IO ByteString) -> String -> PandocIO ByteString
forall a. (String -> IO a) -> String -> PandocIO a
liftIOError String -> IO ByteString
B.readFile String
s
glob :: String -> PandocIO [String]
glob = (String -> IO [String]) -> String -> PandocIO [String]
forall a. (String -> IO a) -> String -> PandocIO a
liftIOError String -> IO [String]
IO.glob
fileExists :: String -> PandocIO Bool
fileExists = (String -> IO Bool) -> String -> PandocIO Bool
forall a. (String -> IO a) -> String -> PandocIO a
liftIOError String -> IO Bool
Directory.doesFileExist
#ifdef EMBED_DATA_FILES
getDataFileName = return
#else
getDataFileName :: String -> PandocIO String
getDataFileName = (String -> IO String) -> String -> PandocIO String
forall a. (String -> IO a) -> String -> PandocIO a
liftIOError String -> IO String
Paths.getDataFileName
#endif
getModificationTime :: String -> PandocIO UTCTime
getModificationTime = (String -> IO UTCTime) -> String -> PandocIO UTCTime
forall a. (String -> IO a) -> String -> PandocIO a
liftIOError String -> IO UTCTime
IO.getModificationTime
getCommonState :: PandocIO CommonState
getCommonState = ExceptT PandocError (StateT CommonState IO) CommonState
-> PandocIO CommonState
forall a.
ExceptT PandocError (StateT CommonState IO) a -> PandocIO a
PandocIO (ExceptT PandocError (StateT CommonState IO) CommonState
-> PandocIO CommonState)
-> ExceptT PandocError (StateT CommonState IO) CommonState
-> PandocIO CommonState
forall a b. (a -> b) -> a -> b
$ StateT CommonState IO CommonState
-> ExceptT PandocError (StateT CommonState IO) CommonState
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift StateT CommonState IO CommonState
forall s (m :: * -> *). MonadState s m => m s
get
putCommonState :: CommonState -> PandocIO ()
putCommonState x :: CommonState
x = ExceptT PandocError (StateT CommonState IO) () -> PandocIO ()
forall a.
ExceptT PandocError (StateT CommonState IO) a -> PandocIO a
PandocIO (ExceptT PandocError (StateT CommonState IO) () -> PandocIO ())
-> ExceptT PandocError (StateT CommonState IO) () -> PandocIO ()
forall a b. (a -> b) -> a -> b
$ StateT CommonState IO ()
-> ExceptT PandocError (StateT CommonState IO) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT CommonState IO ()
-> ExceptT PandocError (StateT CommonState IO) ())
-> StateT CommonState IO ()
-> ExceptT PandocError (StateT CommonState IO) ()
forall a b. (a -> b) -> a -> b
$ CommonState -> StateT CommonState IO ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put CommonState
x
logOutput :: LogMessage -> PandocIO ()
logOutput msg :: LogMessage
msg = IO () -> PandocIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PandocIO ()) -> IO () -> PandocIO ()
forall a b. (a -> b) -> a -> b
$ do
Handle -> String -> IO ()
UTF8.hPutStr Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Verbosity -> String
forall a. Show a => a -> String
show (LogMessage -> Verbosity
messageVerbosity LogMessage
msg) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "] "
[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
alertIndent :: [Text] -> IO ()
alertIndent :: [Text] -> IO ()
alertIndent [] = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
alertIndent (l :: Text
l:ls :: [Text]
ls) = do
Handle -> String -> IO ()
UTF8.hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack 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 l' :: Text
l' = do Handle -> String -> IO ()
UTF8.hPutStr Handle
stderr " "
Handle -> String -> IO ()
UTF8.hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
l'
extractMedia :: FilePath -> Pandoc -> PandocIO Pandoc
dir :: String
dir d :: Pandoc
d = do
MediaBag
media <- PandocIO MediaBag
forall (m :: * -> *). PandocMonad m => m MediaBag
getMediaBag
case [String
fp | (fp :: String
fp, _, _) <- MediaBag -> [(String, Text, Int)]
mediaDirectory MediaBag
media] of
[] -> Pandoc -> PandocIO Pandoc
forall (m :: * -> *) a. Monad m => a -> m a
return Pandoc
d
fps :: [String]
fps -> do
(String -> PandocIO ()) -> [String] -> PandocIO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> MediaBag -> String -> PandocIO ()
writeMedia String
dir MediaBag
media) [String]
fps
Pandoc -> PandocIO Pandoc
forall (m :: * -> *) a. Monad m => a -> m a
return (Pandoc -> PandocIO Pandoc) -> Pandoc -> PandocIO Pandoc
forall a b. (a -> b) -> a -> b
$ (Inline -> Inline) -> Pandoc -> Pandoc
forall a b. Walkable a b => (a -> a) -> b -> b
walk (String -> [String] -> Inline -> Inline
adjustImagePath String
dir [String]
fps) Pandoc
d
writeMedia :: FilePath -> MediaBag -> FilePath -> PandocIO ()
writeMedia :: String -> MediaBag -> String -> PandocIO ()
writeMedia dir :: String
dir mediabag :: MediaBag
mediabag subpath :: String
subpath = do
let fullpath :: String
fullpath = String
dir String -> String -> String
</> String -> String
unEscapeString (String -> String
normalise String
subpath)
let mbcontents :: Maybe (Text, ByteString)
mbcontents = String -> MediaBag -> Maybe (Text, ByteString)
lookupMedia String
subpath MediaBag
mediabag
case Maybe (Text, ByteString)
mbcontents of
Nothing -> PandocError -> PandocIO ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError -> PandocIO ()) -> PandocError -> PandocIO ()
forall a b. (a -> b) -> a -> b
$ Text -> PandocError
PandocResourceNotFound (Text -> PandocError) -> Text -> PandocError
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
subpath
Just (_, bs :: ByteString
bs) -> do
LogMessage -> PandocIO ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (LogMessage -> PandocIO ()) -> LogMessage -> PandocIO ()
forall a b. (a -> b) -> a -> b
$ Text -> LogMessage
Extracting (Text -> LogMessage) -> Text -> LogMessage
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
fullpath
(String -> IO ()) -> String -> PandocIO ()
forall a. (String -> IO a) -> String -> PandocIO a
liftIOError (Bool -> String -> IO ()
createDirectoryIfMissing Bool
True) (String -> String
takeDirectory String
fullpath)
IO () -> PandocIO ()
logIOError (IO () -> PandocIO ()) -> IO () -> PandocIO ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
BL.writeFile String
fullpath ByteString
bs
adjustImagePath :: FilePath -> [FilePath] -> Inline -> Inline
adjustImagePath :: String -> [String] -> Inline -> Inline
adjustImagePath dir :: String
dir paths :: [String]
paths (Image attr :: Attr
attr lab :: [Inline]
lab (src :: Text
src, tit :: Text
tit))
| Text -> String
T.unpack Text
src String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
paths = Attr -> [Inline] -> (Text, Text) -> Inline
Image Attr
attr [Inline]
lab (String -> Text
T.pack String
dir Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
src, Text
tit)
adjustImagePath _ _ x :: Inline
x = Inline
x