{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
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.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, extractURIData)
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
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
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 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
logIOError :: (PandocMonad m, MonadIO m) => IO () -> m ()
logIOError :: forall (m :: * -> *). (PandocMonad m, MonadIO m) => IO () -> m ()
logIOError IO ()
f = do
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 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 ()
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
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
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
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
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)
= (ByteString, Maybe Text) -> m (ByteString, Maybe Text)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((ByteString, Maybe Text) -> m (ByteString, Maybe Text))
-> (ByteString, Maybe Text) -> m (ByteString, Maybe Text)
forall a b. (a -> b) -> a -> b
$ String -> (ByteString, Maybe Text)
extractURIData String
upath
| 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)
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
disableCertificateValidation <- getsCommonState stNoCheckCertificate
report $ Fetching u
res <- liftIO $ E.try $ withSocketsDo $ do
proxy <- tryIOError (getEnv "http_proxy")
let 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)
req <- parseRequest (unpack u) >>= addProxy'
let req' = Request
req{requestHeaders = customHeaders ++ requestHeaders req}
certificateStore <- getSystemCertificateStore
let 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 = TLSSettings -> Maybe SockSettings -> ManagerSettings
mkManagerSettings TLSSettings
tlsSettings Maybe SockSettings
forall a. Maybe a
Nothing
resp <- newManager tlsManagerSettings >>= httpLbs req'
return (B.concat $ toChunks $ responseBody resp,
UTF8.toText `fmap` lookup hContentType (responseHeaders resp))
case 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
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
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
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"
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
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
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
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
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
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'
extractMedia :: (PandocMonad m, MonadIO m) => FilePath -> Pandoc -> m Pandoc
String
dir Pandoc
d = do
media <- m MediaBag
forall (m :: * -> *). PandocMonad m => m MediaBag
getMediaBag
let items = MediaBag -> [(String, Text, ByteString)]
mediaItems MediaBag
media
if null items
then return d
else do
mapM_ (writeMedia dir) items
return $ walk (adjustImagePath dir media) d
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
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
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