mueval 0.2.1 → 0.3
raw patch · 7 files changed
+60/−37 lines, 7 filesdep ~hint
Dependency ranges changed: hint
Files
- Mueval/Interpreter.hs +19/−15
- Mueval/ParseArgs.hs +7/−2
- Mueval/Resources.hs +1/−1
- build.sh +1/−1
- mueval.cabal +4/−3
- mueval.hs +25/−14
- tests.sh +3/−1
Mueval/Interpreter.hs view
@@ -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)
Mueval/ParseArgs.hs view
@@ -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 =
Mueval/Resources.hs view
@@ -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
build.sh view
@@ -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
mueval.cabal view
@@ -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
mueval.hs view
@@ -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+-- <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, 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 ()
tests.sh view
@@ -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"