mueval-0.2: mueval.hs

-- TODO: Currently we usually exit successfully even when there was a
-- problem. Need to sort out the exit code business.
-- A possible feature: importing by default ShowQ and ShowFun. Lambdabot seems to find them worthwhile.
module Main (main) where

import Control.Concurrent   (forkIO, myThreadId, threadDelay, throwTo, 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
          (a,_) <- interpreterOpts input
          if (Mueval.Context.cleanModules $ modules a) then do
              mvar <- newEmptyMVar

              Mueval.Resources.limitResources
              myThreadId >>= watchDog a

              forkIO $ forkedMain (mvar) a (modules a) (expression a)
              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 -> [ModuleName] -> String -> IO ()
forkedMain mvar tout mdls expr = 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 mdls expr `catchDyn` (printInterpreterError)
  putMVar mvar "Done."

-- | Fork off a thread which will sleep and kill off another thread at some point.
watchDog :: Options -> ThreadId -> IO ()
watchDog tout tid = do installHandler sigXCPU (CatchOnce $ throwTo tid $
                                                         ErrorCall "Time limit exceeded by handler") Nothing
                       forkIO $ threadDelay (timeLimit tout * 1000000) >>
                                           throwTo tid (ErrorCall "Time limit exceeded")
                       return ()