blob: 918095eb14e7f869a3edbef7b22a9a04cbeb908f (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
|
{- |
Module : Text.Pandoc.Class.Sandbox
Copyright : Copyright (C) 2021-2024 John MacFarlane
License : GNU GPL, version 2 or above
Maintainer : John MacFarlane (<[email protected]>)
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
, sandboxWithFileTree
)
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
tree <- liftIO $ foldM addToFileTree mempty files
sandboxWithFileTree tree action
-- | 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 an ersatz file system which will be available for
-- reading.
sandboxWithFileTree :: (PandocMonad m, MonadIO m)
=> FileTree -> PandocPure a -> m a
sandboxWithFileTree tree action = do
oldState <- getCommonState
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
|
