{- |
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 <- forall (m :: * -> *). PandocMonad m => m CommonState
getCommonState
  FileTree
tree <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM FileTree -> FilePath -> IO FileTree
addToFileTree forall a. Monoid a => a
mempty [FilePath]
files
  case forall a. PandocPure a -> Either PandocError a
runPure (do forall (m :: * -> *). PandocMonad m => CommonState -> m ()
putCommonState CommonState
oldState
                   (PureState -> PureState) -> PandocPure ()
modifyPureState forall a b. (a -> b) -> a -> b
$ \PureState
ps -> PureState
ps{ stFiles :: FileTree
stFiles = FileTree
tree }
                   a
result <- PandocPure a
action
                   CommonState
st <- forall (m :: * -> *). PandocMonad m => m CommonState
getCommonState
                   forall (m :: * -> *) a. Monad m => a -> m a
return (CommonState
st, a
result)) of
          Left PandocError
e -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError PandocError
e
          Right (CommonState
st, a
result) -> do
            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 = forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take
                  (forall (t :: * -> *) a. Foldable t => t a -> Int
length (CommonState -> [LogMessage]
stLog CommonState
st) forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length (CommonState -> [LogMessage]
stLog CommonState
oldState)) (CommonState -> [LogMessage]
stLog CommonState
st)
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
logOutput
              (forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Ord a => a -> a -> Bool
<= Verbosity
verbosity) forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogMessage -> Verbosity
messageVerbosity) [LogMessage]
newMessages)
            forall (m :: * -> *) a. Monad m => a -> m a
return a
result