diff options
author | Igor Pashev <pashev.igor@gmail.com> | 2021-12-29 15:00:59 +0200 |
---|---|---|
committer | Igor Pashev <pashev.igor@gmail.com> | 2021-12-29 15:00:59 +0200 |
commit | b4361712899fd0183fea5513180cb383979616de (patch) | |
tree | 688ab7ee2ab3a8cd32b4e37b506099aec95388f7 /src/Text/Pandoc/Class/Sandbox.hs | |
parent | 726ad97faebe59e024d68d293e663c02bbe423c8 (diff) | |
parent | d960282b105a6469c760b4308a3b81da723b7256 (diff) | |
download | pandoc-b4361712899fd0183fea5513180cb383979616de.tar.gz |
Merge https://github.com/jgm/pandoc
Diffstat (limited to 'src/Text/Pandoc/Class/Sandbox.hs')
-rw-r--r-- | src/Text/Pandoc/Class/Sandbox.hs | 50 |
1 files changed, 50 insertions, 0 deletions
diff --git a/src/Text/Pandoc/Class/Sandbox.hs b/src/Text/Pandoc/Class/Sandbox.hs new file mode 100644 index 000000000..8bc0f1e77 --- /dev/null +++ b/src/Text/Pandoc/Class/Sandbox.hs @@ -0,0 +1,50 @@ +{- | +Module : Text.Pandoc.Class.Sandbox +Copyright : Copyright (C) 2021 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 files action = do + oldState <- getCommonState + tree <- liftIO $ foldM addToFileTree mempty files + case runPure (do putCommonState oldState + modifyPureState $ \ps -> ps{ stFiles = tree } + result <- action + st <- getCommonState + return (st, result)) of + Left e -> throwError e + Right (st, result) -> do + putCommonState st + let verbosity = stVerbosity st + -- emit warnings, since these are not printed in runPure + let newMessages = reverse $ take + (length (stLog st) - length (stLog oldState)) (stLog st) + mapM_ logOutput + (filter ((<= verbosity) . messageVerbosity) newMessages) + return result + |