mueval 0.7.1 → 0.8
raw patch · 10 files changed
+123/−88 lines, 10 filesdep +extensible-exceptionsdep ~basedep ~mtl
Dependencies added: extensible-exceptions
Dependency ranges changed: base, mtl
Files
- HCAR.tex +30/−0
- Mueval/ArgsParse.hs +16/−10
- Mueval/Context.hs +0/−1
- Mueval/Interpreter.hs +47/−47
- Mueval/Parallel.hs +10/−15
- Mueval/Resources.hs +3/−6
- main.hs +2/−2
- mueval.cabal +9/−5
- tests.sh +3/−0
- watchdog.hs +3/−2
+ HCAR.tex view
@@ -0,0 +1,30 @@+\begin{hcarentry}[updated]{mueval}+\label{mueval}+\report{Gwern Branwen}%11/08+\participants{Andrea Vezzosi, Daniel Gorin, Spencer Janssen}+\status{active development}+\makeheader++Mueval is a code evaluator for Haskell; it employs the GHC API (as provided by the Hint library~\cref{hint}). It uses a variety of techniques to evaluate arbitrary Haskell expressions safely \& securely. Since it was begun in June 2008, tremendous progress has been made; it is currently used in Lambdabot live in \#haskell). Mueval can also be called from the command-line.++Mueval features:+\begin{itemize}+\item A comprehensive test-suite of expressions which should and should not work+\item Defeats all known attacks+\item Optional resource limits and module imports+\item The ability to load in definitions from a specified file+\item Parses Haskell expressions with haskell-src-exts and tests against black- and white-lists+\item A process-level watchdog, to work around past and future GHC issues with thread-level watchdogs+\item Cabalized+\end{itemize}+We are currently working on the following:+\begin{itemize}+\item Refactoring modules to render Mueval more useful as a library+\item Removing the POSIX-only requirement+\end{itemize}++\FurtherReading+The source repository is available:+ \texttt{darcs get}+ \text{\url{http://code.haskell.org/mubot/}}+\end{hcarentry}
Mueval/ArgsParse.hs view
@@ -1,5 +1,6 @@ module Mueval.ArgsParse (Options(..), interpreterOpts, getOptions) where +import Control.Monad (liftM) import System.Console.GetOpt import qualified Codec.Binary.UTF8.String as Codec (decodeString)@@ -9,33 +10,35 @@ -- | See the results of --help for information on what each option means. data Options = Options { timeLimit :: Int- , modules :: [String]+ , modules :: Maybe [String] , expression :: String , loadFile :: String , user :: String , printType :: Bool , extensions :: Bool- , noimports :: Bool- , rlimits :: Bool+ , namedExtensions :: [String]+ , noImports :: Bool+ , rLimits :: Bool } deriving Show defaultOptions :: Options defaultOptions = Options { expression = ""- , modules = defaultModules+ , modules = Just defaultModules , timeLimit = 5 , user = "" , loadFile = "" , printType = False , extensions = False- , noimports = False- , rlimits = False }+ , namedExtensions = []+ , noImports = False+ , rLimits = False } options :: [OptDescr (Options -> Options)] options = [Option "p" ["password"] (ReqArg (\u opts -> opts {user = u}) "PASSWORD") "The password for the mubot account. If this is set, mueval will attempt to setuid to the mubot user. This is optional, as it requires the mubot user to be set up properly. (Currently a null-op.)", Option "t" ["timelimit"]- (ReqArg (\t opts -> opts { timeLimit = (read t :: Int) }) "TIME")+ (ReqArg (\t opts -> opts { timeLimit = read t :: Int }) "TIME") "Time limit for compilation and evaluation", Option "l" ["loadfile"]@@ -43,14 +46,17 @@ "A local file for Mueval to load, providing definitions. Contents are trusted! Do not put anything dubious in it!", Option "m" ["module"]- (ReqArg (\m opts -> opts { modules = m:modules opts}) "MODULE")+ (ReqArg (\m opts -> opts { modules = liftM (m:) (modules opts)}) "MODULE") "A module we should import functions from for evaluation. (Can be given multiple times.)", Option "n" ["noimports"]- (NoArg (\opts -> opts { noimports = True}))+ (NoArg (\opts -> opts { noImports = True})) "Whether to import any default modules, such as Prelude; this is useful if you are loading a file which, say, redefines Prelude operators.", Option "E" ["Extensions"] (NoArg (\opts -> opts { extensions = True})) "Whether to enable the Glasgow extensions to Haskell '98. Defaults to false, but enabling is useful for QuickCheck.",+ Option "X" ["extension"]+ (ReqArg (\e opts -> opts { namedExtensions = e : namedExtensions opts }) "EXTENSION")+ "Pass additional flags enabling extensions just like you would to ghc. Example: -XViewPatterns", Option "e" ["expression"] (ReqArg (\e opts -> opts { expression = e}) "EXPRESSION") "The expression to be evaluated.",@@ -58,7 +64,7 @@ (NoArg (\opts -> opts { printType = True})) "Whether to enable printing of inferred type and the expression (as Mueval sees it). Defaults to false.", Option "r" ["rlimits"]- (NoArg (\opts -> opts { rlimits = True}))+ (NoArg (\opts -> opts { rLimits = True})) "Enable resource limits (using POSIX rlimits). Mueval does not by default since rlimits are broken on many systems." ] interpreterOpts :: [String] -> (Options, [String])
Mueval/Context.hs view
@@ -4,7 +4,6 @@ qualifiedModules, ) where -import Data.List (elem) -----------------------------------------------------------------------------
Mueval/Interpreter.hs view
@@ -2,82 +2,81 @@ -- TODO: suggest the convenience functions be put into Hint proper? module Mueval.Interpreter where -import Control.Monad (when,mplus)-import System.Directory (copyFile, makeRelativeToCurrentDirectory)+import Control.Monad (guard,mplus,unless,when)+import Control.Monad.Trans (MonadIO)+import Control.Monad.Writer (Any(..),runWriterT,tell)+import Data.Char (isDigit)+import Data.List (stripPrefix)+import System.Directory (copyFile, makeRelativeToCurrentDirectory, setCurrentDirectory) import System.Exit (exitFailure) import System.FilePath.Posix (takeFileName)-import qualified Control.OldException as E (evaluate,catch)+import qualified Control.Exception.Extensible as E (evaluate,catch,SomeException(..))++import qualified System.IO.UTF8 as UTF (putStrLn)+ import Language.Haskell.Interpreter (eval, set, reset, setImportsQ, loadModules, liftIO, installedModulesInScope, languageExtensions, typeOf, setTopLevelModules, runInterpreter, glasgowExtensions,- OptionVal(..), Extension(ExtendedDefaultRules),- Interpreter, InterpreterError(..),GhcError(..), ModuleName)-import qualified Mueval.Resources (limitResources)-import qualified Mueval.Context (qualifiedModules)-import qualified System.IO.UTF8 as UTF (putStrLn)-import Control.Monad.Writer (Any(..),runWriterT,tell)-import Data.List (stripPrefix)-import Data.Char (isDigit)-import Control.Monad.Trans+ OptionVal(..), Interpreter,+ InterpreterError(..),GhcError(..)) +import Mueval.ArgsParse (Options(..))+import qualified Mueval.Resources as MR (limitResources) +import qualified Mueval.Context as MC (qualifiedModules)+ {- | The actual calling of Hint functionality. The heart of this just calls 'eval', but we do so much more - we disable Haskell extensions, hide all packages, make sure one cannot call unimported functions, typecheck, set resource limits for this thread, and do some error handling. -}-interpreter :: Bool -> Bool -> Maybe [ModuleName] -> String -> String -> Interpreter (String,String,String)-interpreter exts rlimits modules lfl expr = do- when exts $ set [languageExtensions := (ExtendedDefaultRules:glasgowExtensions)]+interpreter :: Options -> Interpreter (String,String,String)+interpreter Options { extensions = exts, namedExtensions = nexts,+ rLimits = rlimits,+ loadFile = load, expression = expr,+ modules = m } = do+ let lexts = (guard exts >> glasgowExtensions) ++ map read nexts+ unless (null lexts) $ set [languageExtensions := lexts] reset -- Make sure nothing is available set [installedModulesInScope := False] - let doload = lfl /= ""-- when doload $ liftIO (mvload lfl)-- liftIO $ Mueval.Resources.limitResources rlimits+ when (load /= "") $ do liftIO (mvload load)+ let lfl' = takeFileName load+ loadModules [lfl']+ -- We need to mangle the String to+ -- turn a filename into a module.+ setTopLevelModules [takeWhile (/='.') lfl'] - when doload $ do let lfl' = takeFileName lfl- loadModules [lfl']- -- We need to mangle the String to- -- turn a filename into a module.- setTopLevelModules [(takeWhile (/='.') lfl')]+ liftIO $ MR.limitResources rlimits - case modules of+ case m of Nothing -> return () Just ms -> do let unqualModules = zip ms (repeat Nothing)- setImportsQ (unqualModules ++ Mueval.Context.qualifiedModules)+ setImportsQ (unqualModules ++ MC.qualifiedModules) -- we don't check if the expression typechecks -- this way we get an "InterpreterError" we can display etype <- typeOf expr- result <- eval expr+ return (expr, etype, result) -- | Wrapper around 'interpreter'; supplies a fresh GHC API session and -- error-handling. The arguments are largely passed on, and the results lightly parsed.-interpreterSession :: Bool -- ^ Whether to print inferred type- -> Bool -- ^ Whether to use GHC extensions- -> Bool -- ^ Whether to use rlimits- -> Maybe [ModuleName] -- ^ A list of modules we wish to be visible- -> String -- ^ A local file from which to grab definitions; an- -- empty string is treated as no file.- -> String -- ^ The string to be interpreted as a Haskell expression- -> IO () -- ^ No real result, since we print no matter the result.-interpreterSession prt exts rls mds lfl expr = do r <- runInterpreter (interpreter exts rls mds lfl expr)- case r of - Left err -> printInterpreterError err- Right (e,et,val) -> do when prt $ (sayIO e >> sayIO et)- sayIO val+interpreterSession :: Options -> IO ()+interpreterSession opts = do r <- runInterpreter (interpreter opts)+ case r of + Left err -> printInterpreterError err+ Right (e,et,val) -> when (printType opts) (sayIO e >> sayIO et) >> sayIO val mvload :: FilePath -> IO () mvload lfl = do canonfile <- makeRelativeToCurrentDirectory lfl liftIO $ copyFile canonfile $ "/tmp/" ++ takeFileName canonfile+ setCurrentDirectory "/tmp" -- will at least mess up relative links --------------------------------- -- Handling and outputting results+-- TODO: this whole section is a hack -- | Print the String (presumably the result -- of interpreting something), but only print the first 1024 characters to avoid@@ -116,13 +115,13 @@ -- Constant exceptionMsg :: String-exceptionMsg = "* Exception: "+exceptionMsg = "*Exception: " -- | Renders the input String including its exceptions using @exceptionMsg@-render :: (Control.Monad.Trans.MonadIO m) =>- Int -> -- ^ max number of characters to include- String -> -- ^ input- m (String, Bool) -- ^ ( output, @True@ if we found an exception )+render :: (Control.Monad.Trans.MonadIO m)+ => Int -- ^ max number of characters to include+ -> String -- ^ input+ -> m (String, Bool) -- ^ ( output, @True@ if we found an exception ) render i xs = do (out,Any b) <- runWriterT $ render' i (toStream xs) return (out,b)@@ -139,6 +138,7 @@ data Stream = Cons Char (IO Stream) | Exception (IO Stream) | End toStream :: String -> IO Stream-toStream str = E.evaluate (uncons str) `E.catch` \e -> return $ Exception $ toStream (show e)+toStream str = E.evaluate (uncons str) `E.catch`+ \(E.SomeException e) -> return . Exception . toStream . show $ e where uncons [] = End uncons (x:xs) = x `seq` Cons x (toStream xs)
Mueval/Parallel.hs view
@@ -3,7 +3,7 @@ import Prelude hiding (catch) import Control.Concurrent (forkIO, killThread, myThreadId, threadDelay, throwTo, ThreadId) import System.Posix.Signals (sigXCPU, installHandler, Handler(CatchOnce))-import Control.OldException (Exception(ErrorCall),catch)+import Control.Exception.Extensible (ErrorCall(..),SomeException,catch) import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar, MVar) import System.IO (hSetBuffering, stdout, BufferMode(NoBuffering)) @@ -12,10 +12,11 @@ -- | Fork off a thread which will sleep and then kill off the specified thread. watchDog :: Int -> ThreadId -> IO ()-watchDog tout tid = do installHandler sigXCPU+watchDog tout tid = do _ <- installHandler sigXCPU (CatchOnce $ throwTo tid $ ErrorCall "Time limit exceeded.") Nothing- forkIO $ do threadDelay (tout * 700000)+ _ <- forkIO $ do+ threadDelay (tout * 700000) -- Time's up. It's a good day to die. throwTo tid (ErrorCall "Time limit exceeded") killThread tid -- Die now, srsly.@@ -26,7 +27,7 @@ -- | A basic blocking operation. block :: (t -> MVar a -> IO t1) -> t -> IO a block f opts = do mvar <- newEmptyMVar- f opts mvar+ _ <- f opts mvar takeMVar mvar -- block until ErrorCall, or forkedMain succeeds -- | Using MVars, block on forkedMain' until it finishes.@@ -36,19 +37,13 @@ -- | Set a 'watchDog' on this thread, and then continue on with whatever. forkedMain' :: Options -> MVar String -> IO ThreadId forkedMain' opts mvar = do mainId <- myThreadId- watchDog tout mainId+ watchDog (timeLimit opts) mainId hSetBuffering stdout NoBuffering -- Our modules and expression are set up. Let's do stuff.- forkIO $ (interpreterSession typeprint extend rls mdls fls expr+ forkIO $ (interpreterSession (checkImport opts) >> putMVar mvar "Done.")- `catch` throwTo mainId -- bounce exceptions to the main thread,+ `catch` \e -> throwTo mainId (e::SomeException)+ -- bounce exceptions to the main thread, -- so they are reliably printed out- where mdls = if impq then Nothing else Just (modules opts)- expr = expression opts- tout = timeLimit opts- typeprint = printType opts- extend = extensions opts- fls = loadFile opts- impq = noimports opts- rls = rlimits opts+ where checkImport x = if noImports x then x{modules=Nothing} else x
Mueval/Resources.hs view
@@ -3,16 +3,13 @@ import Control.Monad (when) import System.Posix.Process (nice) import System.Posix.Resource -- (Resource(..), ResourceLimits, setResourceLimit)-import System.Directory (setCurrentDirectory) -- | Pull together several methods of reducing priority and easy access to resources:--- 'nice', the rlimit bindings, and "setCurrentDirectory".+-- 'nice', and the rlimit bindings, -- If called with False, 'limitResources' will not use POSIX rlimits. limitResources :: Bool -> IO ()-limitResources rlimit = do setCurrentDirectory "/tmp" -- will at least mess up relative links- nice 19 -- Set our process priority way down- when rlimit- (mapM_ (uncurry setResourceLimit) limits)+limitResources rlimit = do nice 20 -- Set our process priority way down+ when rlimit $ mapM_ (uncurry setResourceLimit) limits -- | Set all the available rlimits. -- These values have been determined through trial-and-error
main.hs view
@@ -10,5 +10,5 @@ main :: IO () main = do args <- getArgs- let opts = getOptions args- forkedMain opts+ -- force parse errors in main's thread+ forkedMain $! getOptions args
mueval.cabal view
@@ -1,5 +1,5 @@ name: mueval-version: 0.7.1+version: 0.8 license: BSD3 license-file: LICENSE@@ -22,17 +22,17 @@ homepage: http://code.haskell.org/mubot/ build-type: Simple-cabal-version: >= 1.2+cabal-version: >= 1.6 tested-with: GHC==6.10.1 -data-files: README+data-files: README, HCAR.tex extra-source-files: build.sh, tests.sh library exposed-modules: Mueval.Parallel, Mueval.Context, Mueval.Interpreter, Mueval.ArgsParse, Mueval.Resources- build-depends: base>=4, containers, directory, mtl, filepath, unix, process,- hint>=0.3.1, show>=0.3, utf8-string, Cabal+ build-depends: base>=4 && < 5, containers, directory, mtl<1.2, filepath, unix, process,+ hint>=0.3.1, show>=0.3, utf8-string, Cabal, extensible-exceptions ghc-options: -Wall -static -O2 executable mueval-core@@ -44,3 +44,7 @@ main-is: watchdog.hs build-depends: base ghc-options: -Wall -static -threaded -O2++source-repository head+ type: darcs+ location: http://code.haskell.org/mubot/
tests.sh view
@@ -76,6 +76,9 @@ ## Test the --noimports function ## TODO: more extensive tests of this m '()' --noimports+## Test naming individual syntactic extensions+m "let f (id -> x) = x in f 1" -XViewPatterns+m "let f :: Int -> State Int (); f (id -> x) = put x in runState (f 1) 1" --module Control.Monad.State -XViewPatterns -XFlexibleContexts ## Test qualified imports m "M.map (+1) $ M.fromList [(1,2), (3,4)]" && echo "\nOK, all the valid expressions worked out well." &&
watchdog.hs view
@@ -14,10 +14,11 @@ main :: IO () main = do args <- getArgs hdl <- runProcess "mueval-core" args Nothing Nothing Nothing Nothing Nothing- forkIO (do threadDelay (7 * 700000)+ _ <- forkIO $ do+ threadDelay (7 * 700000) status <- getProcessExitCode hdl case status of Nothing -> terminateProcess hdl >> exitWith (ExitFailure 1)- Just a -> exitWith a)+ Just a -> exitWith a stat <- waitForProcess hdl exitWith stat