-- | 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,
#ifdef C_RUNTIME
       readPGF2,
#endif
       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 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 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)
#ifdef C_RUNTIME
import qualified PGF2
#endif
import qualified Control.Monad.Fail as Fail

-- * The SIO monad

type PutStr = String -> IO ()
newtype SIO a = SIO {SIO a -> PutStr -> IO a
unS::PutStr->IO a}

instance Functor SIO where fmap :: (a -> b) -> SIO a -> SIO b
fmap = (a -> b) -> SIO a -> SIO b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Applicative SIO where
  pure :: a -> SIO a
pure = a -> SIO a
forall (m :: * -> *) a. Monad m => a -> m a
return
  <*> :: SIO (a -> b) -> SIO a -> SIO b
(<*>) = SIO (a -> b) -> SIO a -> SIO b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad SIO where
  return :: a -> SIO a
return a
x = (PutStr -> IO a) -> SIO a
forall a. (PutStr -> IO a) -> SIO a
SIO (IO a -> PutStr -> IO a
forall a b. a -> b -> a
const (a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x))
  SIO PutStr -> IO a
m1 >>= :: SIO a -> (a -> SIO b) -> SIO b
>>= a -> SIO b
xm2 = (PutStr -> IO b) -> SIO b
forall a. (PutStr -> IO a) -> SIO a
SIO ((PutStr -> IO b) -> SIO b) -> (PutStr -> IO b) -> SIO b
forall a b. (a -> b) -> a -> b
$ \ PutStr
h -> PutStr -> IO a
m1 PutStr
h IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ a
x -> SIO b -> PutStr -> IO b
forall a. SIO a -> PutStr -> IO a
unS (a -> SIO b
xm2 a
x) PutStr
h

instance Fail.MonadFail SIO where
  fail :: String -> SIO a
fail = IO a -> SIO a
forall a. IO a -> SIO a
lift0 (IO a -> SIO a) -> (String -> IO a) -> String -> SIO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail

instance Output SIO where
  ePutStr :: String -> SIO ()
ePutStr = IO () -> SIO ()
forall a. IO a -> SIO a
lift0 (IO () -> SIO ()) -> PutStr -> String -> SIO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PutStr
forall (m :: * -> *). Output m => String -> m ()
ePutStr
  ePutStrLn :: String -> SIO ()
ePutStrLn = IO () -> SIO ()
forall a. IO a -> SIO a
lift0 (IO () -> SIO ()) -> PutStr -> String -> SIO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PutStr
forall (m :: * -> *). Output m => String -> m ()
ePutStrLn
  putStrLnE :: String -> SIO ()
putStrLnE = String -> SIO ()
putStrLnFlush
  putStrE :: String -> SIO ()
putStrE = String -> SIO ()
putStr

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 :: SIO a -> SIO a
liftSIO = SIO a -> SIO a
forall a. a -> a
id

instance (MonadTrans t,Monad m,MonadSIO m) => MonadSIO (t m) where
  liftSIO :: SIO a -> t m a
liftSIO = m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> t m a) -> (SIO a -> m a) -> SIO a -> t m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SIO a -> m a
forall (m :: * -> *) a. MonadSIO m => SIO a -> m a
liftSIO

-- * Running SIO operations

-- | Run normally
runSIO :: SIO a -> IO a
runSIO           = Handle -> SIO a -> IO a
forall a. Handle -> SIO a -> IO a
hRunSIO Handle
stdout

-- | Redirect 'stdout' to the given handle
hRunSIO :: Handle -> SIO a -> IO a
hRunSIO Handle
h SIO a
sio    = SIO a -> PutStr -> IO a
forall a. SIO a -> PutStr -> IO a
unS SIO a
sio (\String
s->Handle -> PutStr
hPutStr Handle
h String
sIO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>Handle -> IO ()
hFlush Handle
h)

-- | Capture 'stdout'
captureSIO :: SIO a -> IO (String,a)
captureSIO :: SIO a -> IO (String, a)
captureSIO SIO a
sio   = do Chan (Maybe String)
ch <- IO (Chan (Maybe String))
forall a. IO (Chan a)
newChan
                      a
result <- SIO a -> PutStr -> IO a
forall a. SIO a -> PutStr -> IO a
unS SIO a
sio (Chan (Maybe String) -> Maybe String -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan (Maybe String)
ch (Maybe String -> IO ()) -> (String -> Maybe String) -> PutStr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String
forall a. a -> Maybe a
Just)
                      Chan (Maybe String) -> Maybe String -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan (Maybe String)
ch Maybe String
forall a. Maybe a
Nothing
                      String
output <- ([Maybe String] -> String) -> IO [Maybe String] -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe String] -> String
forall a. [Maybe [a]] -> [a]
takeJust (Chan (Maybe String) -> IO [Maybe String]
forall a. Chan a -> IO [a]
getChanContents Chan (Maybe String)
ch)
                      (String, a) -> IO (String, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
output,a
result)
                   where
                     takeJust :: [Maybe [a]] -> [a]
takeJust (Just [a]
xs:[Maybe [a]]
ys) = [a]
xs[a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++[Maybe [a]] -> [a]
takeJust [Maybe [a]]
ys
                     takeJust [Maybe [a]]
_ = []

-- * Restricted accesss to arbitrary (potentially unsafe) IO operations

restricted :: IO a -> SIO a
restricted IO a
io    = (PutStr -> IO a) -> SIO a
forall a. (PutStr -> IO a) -> SIO a
SIO (IO a -> PutStr -> IO a
forall a b. a -> b -> a
const (IO a -> IO a
forall b. IO b -> IO b
restrictedIO IO a
io))
restrictedSystem :: String -> SIO ExitCode
restrictedSystem = IO ExitCode -> SIO ExitCode
forall a. IO a -> SIO a
restricted (IO ExitCode -> SIO ExitCode)
-> (String -> IO ExitCode) -> String -> SIO ExitCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ExitCode
system

restrictedIO :: IO b -> IO b
restrictedIO IO b
io =
    (IOError -> IO b)
-> (String -> IO b) -> Either IOError String -> IO b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (IO b -> IOError -> IO b
forall a b. a -> b -> a
const IO b
io) (IO b -> String -> IO b
forall a b. a -> b -> a
const (IO b -> String -> IO b) -> IO b -> String -> IO b
forall a b. (a -> b) -> a -> b
$ String -> IO b
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
message) (Either IOError String -> IO b)
-> IO (Either IOError String) -> IO b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO String -> IO (Either IOError String)
forall a. IO a -> IO (Either IOError a)
try (String -> IO String
getEnv String
"GF_RESTRICTED")
  where
    message :: String
message =
      String
"This operation is not allowed when GF is running in restricted mode."

-- * Unrestricted, safe IO operations

lift0 :: IO a -> SIO a
lift0 IO a
io         = (PutStr -> IO a) -> SIO a
forall a. (PutStr -> IO a) -> SIO a
SIO ((PutStr -> IO a) -> SIO a) -> (PutStr -> IO a) -> SIO a
forall a b. (a -> b) -> a -> b
$ IO a -> PutStr -> IO a
forall a b. a -> b -> a
const IO a
io
lift1 :: (IO a -> IO a) -> SIO a -> SIO a
lift1 IO a -> IO a
f SIO a
io       = (PutStr -> IO a) -> SIO a
forall a. (PutStr -> IO a) -> SIO a
SIO ((PutStr -> IO a) -> SIO a) -> (PutStr -> IO a) -> SIO a
forall a b. (a -> b) -> a -> b
$ IO a -> IO a
f (IO a -> IO a) -> (PutStr -> IO a) -> PutStr -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SIO a -> PutStr -> IO a
forall a. SIO a -> PutStr -> IO a
unS SIO a
io

putStr :: String -> SIO ()
putStr           = String -> SIO ()
putStrFlush
putStrFlush :: String -> SIO ()
putStrFlush String
s    = (PutStr -> IO ()) -> SIO ()
forall a. (PutStr -> IO a) -> SIO a
SIO (PutStr -> PutStr
forall a b. (a -> b) -> a -> b
$ String
s)
putStrLn :: String -> SIO ()
putStrLn         = String -> SIO ()
putStrLnFlush
putStrLnFlush :: String -> SIO ()
putStrLnFlush String
s  = String -> SIO ()
putStr String
s SIO () -> SIO () -> SIO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> SIO ()
putStrFlush String
"\n"
print :: a -> SIO ()
print a
x          = String -> SIO ()
putStrLn (a -> String
forall a. Show a => a -> String
show a
x)

getCPUTime :: SIO Integer
getCPUTime           = IO Integer -> SIO Integer
forall a. IO a -> SIO a
lift0   IO Integer
IO.getCPUTime
getCurrentDirectory :: SIO String
getCurrentDirectory  = IO String -> SIO String
forall a. IO a -> SIO a
lift0   IO String
IO.getCurrentDirectory
getLibraryDirectory :: Options -> SIO [String]
getLibraryDirectory  = IO [String] -> SIO [String]
forall a. IO a -> SIO a
lift0 (IO [String] -> SIO [String])
-> (Options -> IO [String]) -> Options -> SIO [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> IO [String]
forall (io :: * -> *). MonadIO io => Options -> io [String]
IO.getLibraryDirectory
newStdGen :: SIO StdGen
newStdGen            = IO StdGen -> SIO StdGen
forall a. IO a -> SIO a
lift0   IO StdGen
forall (m :: * -> *). MonadIO m => m StdGen
IO.newStdGen
runInterruptibly :: SIO a -> SIO (Either SomeException a)
runInterruptibly     = (IO a -> IO (Either SomeException a))
-> SIO a -> SIO (Either SomeException a)
forall a a. (IO a -> IO a) -> SIO a -> SIO a
lift1   IO a -> IO (Either SomeException a)
forall a. IO a -> IO (Either SomeException a)
IO.runInterruptibly
lazySIO :: SIO a -> SIO a
lazySIO              = (IO a -> IO a) -> SIO a -> SIO a
forall a a. (IO a -> IO a) -> SIO a -> SIO a
lift1   IO a -> IO a
forall b. IO b -> IO b
lazyIO

importGrammar :: PGF -> Options -> [String] -> SIO PGF
importGrammar PGF
pgf Options
opts [String]
files = IO PGF -> SIO PGF
forall a. IO a -> SIO a
lift0 (IO PGF -> SIO PGF) -> IO PGF -> SIO PGF
forall a b. (a -> b) -> a -> b
$ PGF -> Options -> [String] -> IO PGF
GF.importGrammar PGF
pgf Options
opts [String]
files
importSource :: Options -> [String] -> SIO SourceGrammar
importSource      Options
opts [String]
files = IO SourceGrammar -> SIO SourceGrammar
forall a. IO a -> SIO a
lift0 (IO SourceGrammar -> SIO SourceGrammar)
-> IO SourceGrammar -> SIO SourceGrammar
forall a b. (a -> b) -> a -> b
$ Options -> [String] -> IO SourceGrammar
GF.importSource      Options
opts [String]
files

#ifdef C_RUNTIME
readPGF2 = lift0 . PGF2.readPGF
#endif