{-# 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 (decodeBase64Lenient)
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 (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.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 :: 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO (Either IOError a)
tryIOError forall a b. (a -> b) -> a -> b
$ String -> IO a
f String
u
  case Either IOError a
res of
         Left IOError
e  -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text -> IOError -> PandocError
PandocIOError (String -> Text
pack String
u) IOError
e
         Right a
r -> 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO (Either IOError a)
tryIOError IO ()
f
  case Either IOError ()
res of
    Left IOError
e -> forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report forall a b. (a -> b) -> a -> b
$ Text -> LogMessage
IgnoredIOError forall a b. (a -> b) -> a -> b
$ String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> String
E.displayException IOError
e
    Right ()
_ -> 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Text
pack) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO (Maybe String)
Env.lookupEnv 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 = 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 = 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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
mime, String
rest) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
',') forall a b. (a -> b) -> a -> b
$ String -> String
unEscapeString String
upath
     let contents :: ByteString
contents = String -> ByteString
UTF8.fromString forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop Int
1 String
rest
     forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> ByteString
decodeBase64Lenient ByteString
contents, 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) = (forall s. FoldCase s => s -> CI s
CI.mk (Text -> ByteString
UTF8.fromText Text
n), Text -> ByteString
UTF8.fromText Text
v)
     [(HeaderName, ByteString)]
customHeaders <- forall a b. (a -> b) -> [a] -> [b]
map (Text, Text) -> (HeaderName, ByteString)
toReqHeader forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. PandocMonad m => (CommonState -> a) -> m a
getsCommonState CommonState -> [(Text, Text)]
stRequestHeaders
     Bool
disableCertificateValidation <- forall (m :: * -> *) a. PandocMonad m => (CommonState -> a) -> m a
getsCommonState CommonState -> Bool
stNoCheckCertificate
     forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report forall a b. (a -> b) -> a -> b
$ Text -> LogMessage
Fetching Text
u
     Either HttpException (ByteString, Maybe Text)
res <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> IO (Either e a)
E.try forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO a
withSocketsDo forall a b. (a -> b) -> a -> b
$ do
       let parseReq :: String -> IO Request
parseReq = forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest
       Either IOError String
proxy <- forall a. IO a -> IO (Either IOError a)
tryIOError (String -> IO String
getEnv String
"http_proxy")
       let addProxy' :: Request -> IO Request
addProxy' Request
x = case Either IOError String
proxy of
                            Left IOError
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Request
x
                            Right String
pr -> String -> IO Request
parseReq String
pr forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Request
r ->
                                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
unpack Text
u) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Request -> IO Request
addProxy'
       let req' :: Request
req' = Request
req{requestHeaders :: [(HeaderName, ByteString)]
requestHeaders = [(HeaderName, ByteString)]
customHeaders forall a. [a] -> [a] -> [a]
++ Request -> [(HeaderName, ByteString)]
requestHeaders Request
req}
       let tlsSimple :: TLSSettings
tlsSimple = Bool -> Bool -> Bool -> TLSSettings
TLSSettingsSimple Bool
disableCertificateValidation Bool
False Bool
False
       let tlsManagerSettings :: ManagerSettings
tlsManagerSettings = TLSSettings -> Maybe SockSettings -> ManagerSettings
mkManagerSettings TLSSettings
tlsSimple  forall a. Maybe a
Nothing
       Response ByteString
resp <- ManagerSettings -> IO Manager
newManager ManagerSettings
tlsManagerSettings forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Request -> Manager -> IO (Response ByteString)
httpLbs Request
req'
       forall (m :: * -> *) a. Monad m => a -> m a
return ([ByteString] -> ByteString
B.concat forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
toChunks forall a b. (a -> b) -> a -> b
$ forall body. Response body -> body
responseBody Response ByteString
resp,
               ByteString -> Text
UTF8.toText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hContentType (forall body. Response body -> [(HeaderName, ByteString)]
responseHeaders Response ByteString
resp))

     case Either HttpException (ByteString, Maybe Text)
res of
          Right (ByteString, Maybe Text)
r -> forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString, Maybe Text)
r
          Left HttpException
e  -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError 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 = 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 = 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 = forall (m :: * -> *) a.
(PandocMonad m, MonadIO m) =>
(String -> IO a) -> String -> m a
liftIOError (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 = 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 = 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 = 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 = 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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  Handle -> Text -> IO ()
UTF8.hPutStr Handle
stderr forall a b. (a -> b) -> a -> b
$
      Text
"[" forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show (LogMessage -> Verbosity
messageVerbosity LogMessage
msg)) forall a. Semigroup a => a -> a -> a
<> Text
"] "
  [Text] -> IO ()
alertIndent forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.lines 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 [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
alertIndent (Text
l:[Text]
ls) = do
  Handle -> Text -> IO ()
UTF8.hPutStrLn Handle
stderr Text
l
  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 <- forall (m :: * -> *). PandocMonad m => m MediaBag
getMediaBag
  let items :: [(String, Text, ByteString)]
items = MediaBag -> [(String, Text, ByteString)]
mediaItems MediaBag
media
  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(String, Text, ByteString)]
items
    then forall (m :: * -> *) a. Monad m => a -> m a
return Pandoc
d
    else do
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *).
(PandocMonad m, MonadIO m) =>
String -> (String, Text, ByteString) -> m ()
writeMedia String
dir) [(String, Text, ByteString)]
items
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ String
dir String -> String -> String
</> String -> String
unEscapeString String
fp
  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)
  forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report forall a b. (a -> b) -> a -> b
$ Text -> LogMessage
Extracting (String -> Text
T.pack String
fullpath)
  forall (m :: * -> *). (PandocMonad m, MonadIO m) => IO () -> m ()
logIOError 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