mueval-0.3: mueval.hs

-- TODO: Currently we usually exit successfully even when there was a
-- problem. Need to sort out the exit code business.
-- Need to add user switching. Perhaps using seteuid and setegid? See
-- <http://www.opengroup.org/onlinepubs/009695399/functions/seteuid.html> &
-- <http://www.opengroup.org/onlinepubs/009695399/functions/setegid.html>
module Main (main) where

import Control.Concurrent   (forkIO, killThread, myThreadId, threadDelay, throwTo, yield, ThreadId)
import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar, MVar)
import Control.Exception (catchDyn, Exception(ErrorCall))
import System.Environment (getArgs)
import System.IO (hSetBuffering, stdout, BufferMode(NoBuffering))
import System.Posix.Signals (sigXCPU, installHandler, Handler(CatchOnce))

import qualified Mueval.Context (cleanModules)
import Mueval.Interpreter
import Mueval.ParseArgs
import qualified Mueval.Resources (limitResources)

main :: IO ()
main = do input <- getArgs
          (opts,_) <- interpreterOpts input
          if (Mueval.Context.cleanModules $ modules opts) then do
              mvar <- newEmptyMVar

              Mueval.Resources.limitResources
              myThreadId >>= watchDog (timeLimit opts)

              forkIO $ forkedMain (mvar) opts
              takeMVar mvar -- block until a ErrorCall or the forkedMain succeeds

              return ()
           else error "Unknown or untrusted module supplied! Aborting."

-- Set a watchdog, and then evaluate.
forkedMain :: MVar [Char] -> Options -> IO ()
forkedMain mvar opts = do
  -- This *should* be redundant with the previous watchDog,
  -- but maybe not.

  myThreadId >>= watchDog tout

  hSetBuffering stdout NoBuffering

  -- Our modules and expression are set up. Let's do stuff.
  interpreterSession typeprint mdls expr `catchDyn` (printInterpreterError)
  putMVar mvar "Done."
          where mdls = modules opts
                expr = expression opts
                tout = timeLimit opts
                typeprint = printType opts

-- | Fork off a thread which will sleep and kill off another thread at some point.
watchDog :: Int -> ThreadId -> IO ()
watchDog tout tid = do installHandler sigXCPU
                                          (CatchOnce
                                           $ throwTo tid $ ErrorCall "Time limit exceeded.") Nothing
                       forkIO $ do threadDelay (tout * 1000000)
                                   -- Time's up. It's a good day to die.
                                   throwTo tid (ErrorCall "Time limit exceeded")
                                   yield -- give the other thread a chance
                                   killThread tid -- Die now, srsly.
                       return ()