diff --git a/Mueval/Interpreter.hs b/Mueval/Interpreter.hs --- a/Mueval/Interpreter.hs +++ b/Mueval/Interpreter.hs @@ -2,9 +2,9 @@ module Mueval.Interpreter (interpreterSession, printInterpreterError, ModuleName) where import Language.Haskell.Interpreter.GHC (eval, newSession, reset, setImports, - setUseLanguageExtensions, typeChecks, + setOptimizations, setUseLanguageExtensions, typeChecks, typeOf, withSession, - Interpreter, InterpreterError, ModuleName) + Interpreter, InterpreterError, ModuleName, Optimizations(All)) import Control.Monad.Trans (liftIO) import System.Exit (exitWith, ExitCode(ExitFailure)) @@ -16,17 +16,21 @@ printInterpreterError e = do putStrLn $ take 1024 $ "Oops... " ++ (show e) (exitWith $ ExitFailure 1) -interpreter :: [ModuleName] -> String -> Interpreter () -interpreter modules expr = do setUseLanguageExtensions False -- Don't trust the extensions - reset -- Make sure nothing is available - setImports modules - checks <- typeChecks expr - if checks then do - say "Expression type: " - say =<< typeOf expr - result <- eval expr - say $ "\nresult: " ++ show result ++ "\n" - else error "Expression does not type check." +interpreter :: Bool -> [ModuleName] -> String -> Interpreter () +interpreter prt modules expr = do setUseLanguageExtensions False -- Don't trust the + -- extensions + setOptimizations All -- Maybe optimization will make + -- more programs terminate. + reset -- Make sure nothing is available + setImports modules + checks <- typeChecks expr + if checks then do + if prt then do say =<< typeOf expr + say "\n" + else return () + result <- eval expr + say $ show result ++ "\n" + else error "Expression does not type check." -interpreterSession :: [ModuleName] -> String -> IO () -interpreterSession mds expr = newSession >>= (flip withSession) (interpreter mds expr) +interpreterSession :: Bool -> [ModuleName] -> String -> IO () +interpreterSession prt mds expr = newSession >>= (flip withSession) (interpreter prt mds expr) diff --git a/Mueval/ParseArgs.hs b/Mueval/ParseArgs.hs --- a/Mueval/ParseArgs.hs +++ b/Mueval/ParseArgs.hs @@ -9,13 +9,15 @@ , modules :: [String] , expression :: String , user :: String + , printType :: Bool } deriving Show defaultOptions :: Options defaultOptions = Options { expression = "" , modules = defaultModules , timeLimit = 5 - , user = "" } + , user = "" + , printType = False } options :: [OptDescr (Options -> Options)] options = [Option ['p'] ["password"] @@ -29,7 +31,10 @@ "A module we should import functions from for evaluation. (Can be given multiple times.)", Option ['e'] ["expression"] (ReqArg (\e opts -> opts { expression = e}) "EXPR") - "The expression to be evaluated." ] + "The expression to be evaluated.", + Option ['p'] ["print-type"] + (NoArg (\opts -> opts { printType = True})) + "Whether to enable printing of inferred type." ] interpreterOpts :: [String] -> IO (Options, [String]) interpreterOpts argv = diff --git a/Mueval/Resources.hs b/Mueval/Resources.hs --- a/Mueval/Resources.hs +++ b/Mueval/Resources.hs @@ -30,7 +30,7 @@ fileSizeLimitSoft = fileSizeLimitHard fileSizeLimitHard = zero dataSizeLimitSoft = dataSizeLimitHard -dataSizeLimitHard = ResourceLimit $ 10^(8::Int) +dataSizeLimitHard = ResourceLimit $ 5^(12::Int) -- These should not be identical, to give the XCPU handler time to trigger cpuTimeLimitSoft = ResourceLimit 3 cpuTimeLimitHard = ResourceLimit 4 diff --git a/build.sh b/build.sh --- a/build.sh +++ b/build.sh @@ -4,4 +4,4 @@ echo "\n...Single-threaded tests....\n" ./tests.sh echo "\n...Rerun the tests with multiple threads...\n" -./tests.sh "+RTS -N4 -RTS" +./tests.sh +RTS -N4 -RTS --print-type diff --git a/mueval.cabal b/mueval.cabal --- a/mueval.cabal +++ b/mueval.cabal @@ -1,5 +1,5 @@ name: mueval -version: 0.2.1 +version: 0.3 license: BSD3 license-file: LICENSE @@ -26,9 +26,10 @@ Library exposed-modules: Mueval.Context, Mueval.Interpreter, Mueval.ParseArgs, Mueval.Resources - build-Depends: base, directory, mtl, unix, hint>0.2, show - ghc-options: -Wall + build-Depends: base, directory, mtl, unix, hint>=0.2.1, show + ghc-options: -Wall -static Executable mueval main-is: mueval.hs build-depends: base + ghc-options: -Wall -threaded -static diff --git a/mueval.hs b/mueval.hs --- a/mueval.hs +++ b/mueval.hs @@ -1,9 +1,11 @@ -- 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. +-- Need to add user switching. Perhaps using seteuid and setegid? See +-- & +-- module Main (main) where -import Control.Concurrent (forkIO, myThreadId, threadDelay, throwTo, ThreadId) +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) @@ -17,36 +19,45 @@ main :: IO () main = do input <- getArgs - (a,_) <- interpreterOpts input - if (Mueval.Context.cleanModules $ modules a) then do + (opts,_) <- interpreterOpts input + if (Mueval.Context.cleanModules $ modules opts) then do mvar <- newEmptyMVar Mueval.Resources.limitResources - myThreadId >>= watchDog a + myThreadId >>= watchDog (timeLimit opts) - forkIO $ forkedMain (mvar) a (modules a) (expression a) + 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 -> [ModuleName] -> String -> IO () -forkedMain mvar tout mdls expr = do +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 mdls expr `catchDyn` (printInterpreterError) + 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 :: 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") +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 () diff --git a/tests.sh b/tests.sh --- a/tests.sh +++ b/tests.sh @@ -2,7 +2,7 @@ # tests # Save typing -alias mu='mueval "$1"' +alias mu='mueval "$@"' # Test on valid expressions echo "Test some valid expressions\n" @@ -14,6 +14,7 @@ mu --expression "filter (\`notElem\` ['A'..'Z']) \"abcXsdzWEE\"" ## see whether we gave it enough resources to do reasonably long stuff mu --expression "(last \"nebbish\") : (head $ reverse \"fooo bar baz booooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooreally long strong, you must confess, at least relative to the usual string, I suppose\") : []" +mu --expression 'let return a k = k a ; m >>= f = m . flip f ; foldM f z [] = return z ; foldM f z (x:xs) = f z x >>= \fzx -> foldM f fzx xs ; control e k = e (\a -> const (k a)) id in foldM (\p n -> if n == 0 then control (const $ return 0) else return (p * n)) 1 [-10..] id' ## Test whether we can import multiple modules mu --module Data.List --module Control.Monad --module Data.Char --expression 'join [[1]]' mu --module Data.List --module Data.Char --module Control.Monad --expression 'join ["baz"]' @@ -36,6 +37,7 @@ mu --expression 'let {p x y f = f x y; f x = p x x} in f (f (f (f (f (f (f (f (f (f (f (f (f (f (f (f (f (f (f f)))))))))))))))))) f' ## Now let's test the module whitelisting mu --module Data.List --module System.IO.Unsafe --module Control.Monad --expression 1+1 +mu --module System.IO.Unsafe --expression "let foo = unsafePerformIO readFile \"/etc/passwd\" in foo" mu --module Data.List --module Text.HTML.Download --expression "head [1..]" ## We need a bunch of IO tests, but I guess this will do for now. mu --expression "let foo = readFile \"/etc/passwd\" >>= print in foo"