From 1adc0ed9f7ef98480f441474353eb39293d988c7 Mon Sep 17 00:00:00 2001
From: hallgren <hallgren@chalmers.se>
Date: Tue, 25 Sep 2012 18:38:13 +0000
Subject: [PATCH] GF.Infra.SIO.hs: adding the SIO monad (where S = Shell or
 Safe)

The SIO monad is a restriction of the IO monad with two purposes:

+ Access to arbitrary IO operations can be turned off by setting the environment
  variable GF_RESTRICTED. There is a limited set of IO operations that are
  considered safe and always allowed.

+ It allows output to stdout to be captured. This can be used in gf -server
  mode, where output of GF shell commands is made part of HTTP responses
  returned to clients.
---
 src/compiler/GF/Infra/SIO.hs | 91 ++++++++++++++++++++++++++++++++++++
 1 file changed, 91 insertions(+)
 create mode 100644 src/compiler/GF/Infra/SIO.hs

diff --git a/src/compiler/GF/Infra/SIO.hs b/src/compiler/GF/Infra/SIO.hs
new file mode 100644
index 000000000..f8c554aca
--- /dev/null
+++ b/src/compiler/GF/Infra/SIO.hs
@@ -0,0 +1,91 @@
+-- | 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.
+module GF.Infra.SIO(
+       -- * The SIO monad
+       SIO,
+       -- * Running SIO operations
+       runSIO,hRunSIO,captureSIO,
+       -- * Unrestricted, safe operations
+       -- ** From the standard libraries
+       getCPUTime,getCurrentDirectory,getLibraryDirectory,
+       newStdGen,print,putStrLn,
+       -- ** Specific to GF
+       importGrammar,importSource,
+       putStrLnFlush,runInterruptibly,
+       -- * 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 (putStrLn,print)
+import Control.Monad(liftM)
+import System.IO(Handle,hPutStrLn,hFlush,stdout)
+import System.IO.Error(try)
+import System.Cmd(system)
+import System.Environment(getEnv)
+import Control.Concurrent.Chan(newChan,writeChan,getChanContents)
+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)
+
+-- * The SIO monad
+
+type PutStrLn = String -> IO ()
+newtype SIO a = SIO {unS::PutStrLn->IO a}
+
+instance Functor SIO where fmap = liftM
+
+instance Monad SIO where
+  return x = SIO (const (return x))
+  SIO m1 >>= xm2 = SIO $ \ h -> m1 h >>= \ x -> unS (xm2 x) h
+
+-- * Running SIO operations
+
+-- | Run normally
+runSIO           = hRunSIO stdout
+
+-- | Redirect 'stdout' to the given handle
+hRunSIO h sio    = unS sio (\s->hPutStrLn h s>>hFlush h)
+
+-- | Capture 'stdout'
+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) =<< 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
+
+putStrLn         = putStrLnFlush
+putStrLnFlush s  = SIO ($ s)
+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
+
+importGrammar pgf opts files = lift0 $ GF.importGrammar pgf opts files
+importSource  src opts files = lift0 $ GF.importSource src opts files
\ No newline at end of file