{- |
Module      : Text.Pandoc.Class.Sandbox
Copyright   : Copyright (C) 2021-2023 John MacFarlane
License     : GNU GPL, version 2 or above

Maintainer  : John MacFarlane (<jgm@berkeley.edu>)
Stability   : alpha
Portability : portable

This module provides a way to run PandocMonad actions in a sandbox
(pure context, with no IO allowed and access only to designated files).
-}

module Text.Pandoc.Class.Sandbox
  ( sandbox )
where

import Control.Monad (foldM)
import Control.Monad.Except (throwError)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Text.Pandoc.Class.PandocMonad
import Text.Pandoc.Class.PandocPure
import Text.Pandoc.Class.CommonState (CommonState(..))
import Text.Pandoc.Logging (messageVerbosity)

-- | Lift a PandocPure action into any instance of PandocMonad.
-- The main computation is done purely, but CommonState is preserved
-- continuously, and warnings are emitted after the action completes.
-- The parameter is a list of FilePaths which will be added to the
-- ersatz file system and be available for reading.
sandbox :: (PandocMonad m, MonadIO m) => [FilePath] -> PandocPure a -> m a
sandbox :: forall (m :: * -> *) a.
(PandocMonad m, MonadIO m) =>
[FilePath] -> PandocPure a -> m a
sandbox [FilePath]
files PandocPure a
action = do
  CommonState
oldState <- m CommonState
forall (m :: * -> *). PandocMonad m => m CommonState
getCommonState
  FileTree
tree <- IO FileTree -> m FileTree
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FileTree -> m FileTree) -> IO FileTree -> m FileTree
forall a b. (a -> b) -> a -> b
$ (FileTree -> FilePath -> IO FileTree)
-> FileTree -> [FilePath] -> IO FileTree
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM FileTree -> FilePath -> IO FileTree
addToFileTree FileTree
forall a. Monoid a => a
mempty [FilePath]
files
  case PandocPure (CommonState, a) -> Either PandocError (CommonState, a)
forall a. PandocPure a -> Either PandocError a
runPure (do CommonState -> PandocPure ()
forall (m :: * -> *). PandocMonad m => CommonState -> m ()
putCommonState CommonState
oldState
                   (PureState -> PureState) -> PandocPure ()
modifyPureState ((PureState -> PureState) -> PandocPure ())
-> (PureState -> PureState) -> PandocPure ()
forall a b. (a -> b) -> a -> b
$ \PureState
ps -> PureState
ps{ stFiles :: FileTree
stFiles = FileTree
tree }
                   a
result <- PandocPure a
action
                   CommonState
st <- PandocPure CommonState
forall (m :: * -> *). PandocMonad m => m CommonState
getCommonState
                   (CommonState, a) -> PandocPure (CommonState, a)
forall a. a -> PandocPure a
forall (m :: * -> *) a. Monad m => a -> m a
return (CommonState
st, a
result)) of
          Left PandocError
e -> PandocError -> m a
forall a. PandocError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError PandocError
e
          Right (CommonState
st, a
result) -> do
            CommonState -> m ()
forall (m :: * -> *). PandocMonad m => CommonState -> m ()
putCommonState CommonState
st
            let verbosity :: Verbosity
verbosity = CommonState -> Verbosity
stVerbosity CommonState
st
            -- emit warnings, since these are not printed in runPure
            let newMessages :: [LogMessage]
newMessages = [LogMessage] -> [LogMessage]
forall a. [a] -> [a]
reverse ([LogMessage] -> [LogMessage]) -> [LogMessage] -> [LogMessage]
forall a b. (a -> b) -> a -> b
$ Int -> [LogMessage] -> [LogMessage]
forall a. Int -> [a] -> [a]
take
                  ([LogMessage] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (CommonState -> [LogMessage]
stLog CommonState
st) Int -> Int -> Int
forall a. Num a => a -> a -> a
- [LogMessage] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (CommonState -> [LogMessage]
stLog CommonState
oldState)) (CommonState -> [LogMessage]
stLog CommonState
st)
            (LogMessage -> m ()) -> [LogMessage] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ LogMessage -> m ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
logOutput
              ((LogMessage -> Bool) -> [LogMessage] -> [LogMessage]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
<= Verbosity
verbosity) (Verbosity -> Bool)
-> (LogMessage -> Verbosity) -> LogMessage -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogMessage -> Verbosity
messageVerbosity) [LogMessage]
newMessages)
            a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result