{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# 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.Text (Text, pack, unpack)
import Data.Time (TimeZone, UTCTime)
import Data.Unique (hashUnique)
import Network.URI (unEscapeString)
import System.Directory (createDirectoryIfMissing)
import System.FilePath ((</>), takeDirectory, takeFileName, normalise, takeExtension)
import qualified System.FilePath.Posix as Posix
import System.IO (stderr)
import System.IO.Error
import System.Random (StdGen)
import Text.Pandoc.Class.IO.HTTP (openURL)
import Text.Pandoc.Class.PandocMonad
       (PandocMonad, 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.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 Codec.Archive.Zip
#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
  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

-- | 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
  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 ()

-- | 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

-- | 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 :: forall (m :: * -> *).
(PandocMonad m, MonadIO m) =>
String -> m String
getDataFileName = String -> m String
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
#else
getDataFileName = liftIOError 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.hPutStrLn 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 -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
      Text -> [Text] -> Text
T.intercalate (Text
"\n  ") (Text -> [Text]
T.lines (LogMessage -> Text
showLogMessage LogMessage
msg))

-- | Extract media from the mediabag into a directory (or a zip archive if the
-- path supplied ends in @.zip@.
extractMedia :: (PandocMonad m, MonadIO m) => FilePath -> Pandoc -> m Pandoc
extractMedia :: forall (m :: * -> *).
(PandocMonad m, MonadIO m) =>
String -> Pandoc -> m Pandoc
extractMedia String
path Pandoc
d = do
  media <- m MediaBag
forall (m :: * -> *). PandocMonad m => m MediaBag
getMediaBag
  let items = MediaBag -> [(String, Text, ByteString)]
mediaItems MediaBag
media
  let (dir, mbZip) = case takeExtension path of
                       String
".zip" -> (String -> String
takeDirectory String
path, String -> Maybe String
forall a. a -> Maybe a
Just (String -> String
takeFileName String
path))
                       String
_ -> (String
path, Maybe String
forall a. Maybe a
Nothing)
  if null items
    then return d
    else do
      let archive = ((String, Text, ByteString) -> Archive -> Archive)
-> Archive -> [(String, Text, ByteString)] -> Archive
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (String, Text, ByteString) -> Archive -> Archive
forall {b}. (String, b, ByteString) -> Archive -> Archive
addEntry Archive
emptyArchive [(String, Text, ByteString)]
items
      case mbZip of
        Just String
fname -> String -> (String, Text, ByteString) -> m ()
forall (m :: * -> *).
(PandocMonad m, MonadIO m) =>
String -> (String, Text, ByteString) -> m ()
writeMedia String
dir
                        (String
fname, Text
"application/zip", Archive -> ByteString
fromArchive Archive
archive)
        Maybe String
Nothing -> ((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
      return $ walk (adjustImagePath dir media) d
 where
  addEntry :: (String, b, ByteString) -> Archive -> Archive
addEntry (String
fp, b
_mime, ByteString
content) = Entry -> Archive -> Archive
addEntryToArchive (String -> Integer -> ByteString -> Entry
toEntry String
fp Integer
0 ByteString
content)

-- | 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