mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-19 09:49:33 -06:00
135 lines
4.6 KiB
Haskell
135 lines
4.6 KiB
Haskell
-- | Shell IO: a monad that can restrict acesss to arbitrary IO and has the
|
|
-- ability to capture output that normally would be sent to stdout.
|
|
{-# LANGUAGE CPP, FlexibleInstances, FlexibleContexts #-}
|
|
module GF.Infra.SIO(
|
|
-- * The SIO monad
|
|
SIO,MonadSIO(..),
|
|
-- * Running SIO operations
|
|
runSIO,hRunSIO,captureSIO,
|
|
-- * Unrestricted, safe operations
|
|
-- ** From the standard libraries
|
|
getCPUTime,getCurrentDirectory,getLibraryDirectory,
|
|
newStdGen,print,putStr,putStrLn,
|
|
-- ** Specific to GF
|
|
importGrammar,importSource,
|
|
putStrLnFlush,runInterruptibly,lazySIO,
|
|
-- * Restricted accesss to arbitrary (potentially unsafe) IO operations
|
|
-- | If the environment variable GF_RESTRICTED is defined, these
|
|
-- operations will fail. Otherwise, they will be executed normally.
|
|
-- Output to stdout will /not/ be captured or redirected.
|
|
restricted,restrictedSystem
|
|
) where
|
|
import Prelude hiding (putStr,putStrLn,print)
|
|
import Control.Applicative(Applicative(..))
|
|
import Control.Monad(liftM,ap)
|
|
import Control.Monad.Trans(MonadTrans(..))
|
|
import System.IO(hPutStr,hFlush,stdout)
|
|
import System.IO.Error(isUserError,ioeGetErrorString)
|
|
import GF.System.Catch(try)
|
|
import System.Process(system)
|
|
import System.Environment(getEnv)
|
|
import Control.Concurrent.Chan(newChan,writeChan,getChanContents)
|
|
import GF.Infra.Concurrency(lazyIO)
|
|
import GF.Infra.UseIO(Output(..))
|
|
import GF.Data.Operations(ErrorMonad(..))
|
|
import qualified System.CPUTime as IO(getCPUTime)
|
|
import qualified System.Directory as IO(getCurrentDirectory)
|
|
import qualified System.Random as IO(newStdGen)
|
|
import qualified GF.Infra.UseIO as IO(getLibraryDirectory)
|
|
import qualified GF.System.Signal as IO(runInterruptibly)
|
|
import qualified GF.Command.Importing as GF(importGrammar, importSource)
|
|
import qualified Control.Monad.Fail as Fail
|
|
import Control.Exception
|
|
|
|
-- * The SIO monad
|
|
|
|
type PutStr = String -> IO ()
|
|
newtype SIO a = SIO {unS::PutStr->IO a}
|
|
|
|
instance Functor SIO where fmap = liftM
|
|
|
|
instance Applicative SIO where
|
|
pure = return
|
|
(<*>) = ap
|
|
|
|
instance Monad SIO where
|
|
return x = SIO (const (return x))
|
|
SIO m1 >>= xm2 = SIO $ \ h -> m1 h >>= \ x -> unS (xm2 x) h
|
|
|
|
instance Fail.MonadFail SIO where
|
|
fail = lift0 . fail
|
|
|
|
instance Output SIO where
|
|
ePutStr = lift0 . ePutStr
|
|
ePutStrLn = lift0 . ePutStrLn
|
|
putStrLnE = putStrLnFlush
|
|
putStrE = putStr
|
|
|
|
instance ErrorMonad SIO where
|
|
raise = fail
|
|
handle m h = SIO $ \putStr ->
|
|
catch (unS m putStr) $
|
|
\e -> if isUserError e
|
|
then unS (h (ioeGetErrorString e)) putStr
|
|
else ioError e
|
|
|
|
class {- Monad m => -} MonadSIO m where liftSIO :: SIO a -> m a
|
|
-- ^ If the Monad m superclass is included, then the generic instance
|
|
-- for monad transformers below would require UndecidableInstances
|
|
|
|
instance MonadSIO SIO where liftSIO = id
|
|
|
|
instance (MonadTrans t,Monad m,MonadSIO m) => MonadSIO (t m) where
|
|
liftSIO = lift . liftSIO
|
|
|
|
-- * Running SIO operations
|
|
|
|
-- | Run normally
|
|
runSIO = hRunSIO stdout
|
|
|
|
-- | Redirect 'stdout' to the given handle
|
|
hRunSIO h sio = unS sio (\s->hPutStr h s>>hFlush h)
|
|
|
|
-- | Capture 'stdout'
|
|
captureSIO :: SIO a -> IO (String,a)
|
|
captureSIO sio = do ch <- newChan
|
|
result <- unS sio (writeChan ch . Just)
|
|
writeChan ch Nothing
|
|
output <- fmap takeJust (getChanContents ch)
|
|
return (output,result)
|
|
where
|
|
takeJust (Just xs:ys) = xs++takeJust ys
|
|
takeJust _ = []
|
|
|
|
-- * Restricted accesss to arbitrary (potentially unsafe) IO operations
|
|
|
|
restricted io = SIO (const (restrictedIO io))
|
|
restrictedSystem = restricted . system
|
|
|
|
restrictedIO io =
|
|
either (const io) (const $ fail message) =<< GF.System.Catch.try (getEnv "GF_RESTRICTED")
|
|
where
|
|
message =
|
|
"This operation is not allowed when GF is running in restricted mode."
|
|
|
|
-- * Unrestricted, safe IO operations
|
|
|
|
lift0 io = SIO $ const io
|
|
lift1 f io = SIO $ f . unS io
|
|
|
|
putStr = putStrFlush
|
|
putStrFlush s = SIO ($ s)
|
|
putStrLn = putStrLnFlush
|
|
putStrLnFlush s = putStr s >> putStrFlush "\n"
|
|
print x = putStrLn (show x)
|
|
|
|
getCPUTime = lift0 IO.getCPUTime
|
|
getCurrentDirectory = lift0 IO.getCurrentDirectory
|
|
getLibraryDirectory = lift0 . IO.getLibraryDirectory
|
|
newStdGen = lift0 IO.newStdGen
|
|
runInterruptibly = lift1 IO.runInterruptibly
|
|
lazySIO = lift1 lazyIO
|
|
|
|
importGrammar pgf opts files = lift0 $ GF.importGrammar pgf opts files
|
|
importSource opts files = lift0 $ GF.importSource opts files
|