mueval 0.6.4 → 0.7.0
raw patch · 10 files changed
+207/−272 lines, 10 filesdep +Cabaldep +processdep −haskell-src-extsdep ~basedep ~hintnew-component:exe:mueval-core
Dependencies added: Cabal, process
Dependencies removed: haskell-src-exts
Dependency ranges changed: base, hint
Files
- Mueval/ArgsParse.hs +10/−10
- Mueval/Context.hs +65/−167
- Mueval/Interpreter.hs +69/−57
- Mueval/Parallel.hs +2/−2
- README +10/−4
- build.sh +1/−2
- main.hs +2/−14
- mueval.cabal +13/−8
- tests.sh +14/−8
- watchdog.hs +21/−0
Mueval/ArgsParse.hs view
@@ -33,33 +33,33 @@ , rlimits = False } options :: [OptDescr (Options -> Options)]-options = [Option ['p'] ["password"]+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"]+ Option "t" ["timelimit"] (ReqArg (\t opts -> opts { timeLimit = (read t :: Int) }) "TIME") "Time limit for compilation and evaluation", - Option ['l'] ["loadfile"]+ Option "l" ["loadfile"] (ReqArg (\e opts -> opts { loadFile = e}) "FILE") "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")+ Option "m" ["module"]+ (ReqArg (\m opts -> opts { modules = m:modules opts}) "MODULE") "A module we should import functions from for evaluation. (Can be given multiple times.)",- Option ['n'] ["noimports"]+ Option "n" ["noimports"] (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"]+ 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 ['e'] ["expression"]+ Option "e" ["expression"] (ReqArg (\e opts -> opts { expression = e}) "EXPRESSION") "The expression to be evaluated.",- Option ['i'] ["inferred-type"]+ Option "i" ["inferred-type"] (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"]+ Option "r" ["rlimits"] (NoArg (\opts -> opts { rlimits = True})) "Enable resource limits (using POSIX rlimits). Mueval does not by default since rlimits are broken on many systems." ]
Mueval/Context.hs view
@@ -1,69 +1,16 @@-module Mueval.Context (cleanModules, defaultModules, unsafe, checkNames) where--import Data.List (elem, isInfixOf)-import Language.Haskell.Exts.Syntax-import Language.Haskell.Exts (parseModule)-import Language.Haskell.Exts.Pretty (prettyPrint)-import Language.Haskell.Exts.Parser (ParseResult(..))--import Data.Set (fromList, member)-import Data.Typeable (typeOf)-import Data.Generics (listify)--{- | Return true if the String contains anywhere in it any keywords associated- with dangerous functions. Unfortunately, this blacklist leaks like a sieve- and will return many false positives (eg. 'unsafed "id \"unsafed\""' will- evaluate to True, even though the phrase \"unsafe\" appears only in a String). But it- will at least catch naive and simplistic invocations of "unsafePerformIO",- "inlinePerformIO", and "unsafeCoerce". -}-unsafe :: String -> Bool-unsafe = \z -> any (`isInfixOf` z) unsafeNames--unsafeNames :: [String]-unsafeNames = ["unsafe", "inlinePerform", "liftIO", "Coerce", "Foreign",- "Typeable", "Array", "IOBase", "Handle", "ByteString",- "Editline", "GLUT", "lock", "ObjectIO", "System.Time",- "OpenGL", "Control.Concurrent", "System.Posix",- "throw", "Dyn", "cache", "stdin", "stdout", "stderr"]----- | A Nothing indicates that the expression is well-formed and passes the--- blacklist; a Just "unsafe..." is exactly as it seems.-type Result = Maybe String---- | This type indicates that haskell-src-exts simply couldn't parse the Haskell fragment.-type ParseError = String+module Mueval.Context (+ cleanModules,+ defaultModules,+ qualifiedModules,+) where -{--ghci> let e = ((\(Right a)->a) . parseHsExp $ "let x = (unsafePerformIO(print())`seq`42) in x")-ghci> listify ((==typeOf(undefined::HsName)) . typeOf) e :: [HsName]-[HsIdent "x",HsIdent "unsafePerformIO",HsIdent "print",HsIdent "seq",HsIdent "x"]--}--- | Parse as Haskell expression and analyze for unsafe expressions. Compared to--- the primitive string munging of 'unsafe', this is the Right Thing.--- "Right Nothing" is the only safe result.--- FIXME: Experimental and probably doesn't work. Could use some clean up and--- better type-fu.-checkNames :: String -> Either ParseError Result-checkNames s = case parseHsExp s of- Left err -> Left err- Right expr -> Right . untilM isRascal . fmap showHsName . allHsNamesIn $ expr- where untilM :: (a -> Bool) -> [a] -> Maybe a- untilM _ [] = Nothing- untilM p (x:xs) = if p x- then Just x else untilM p xs- allHsNamesIn :: HsExp -> [HsName]- allHsNamesIn = listify ((== typeOf (undefined :: HsName)) . typeOf)- showHsName :: HsName -> String- showHsName (HsIdent a) = a- showHsName (HsSymbol a) = a- isRascal :: String -> Bool- isRascal = flip member (fromList unsafeNames)+import Data.List (elem) +----------------------------------------------------------------------------- -- | Return false if any of the listed modules cannot be found in the whitelist. cleanModules :: [String] -> Bool-cleanModules = and . map (`elem` safeModules)+cleanModules = and . map (`elem` defaultModules) {- | Modules which we should load by default. These are of course whitelisted. Specifically, we want the Prelude because otherwise things are horribly@@ -74,37 +21,45 @@ The rest should be safe to import without clashes, according to the Lambdabot sources. -} defaultModules :: [String]-defaultModules = ["Prelude", "ShowQ", "ShowFun", "SimpleReflect", "Data.Function",- "Control.Applicative",- "Control.Monad",- "Control.Monad.Cont",- "Control.Monad.Error",- "Control.Monad.Fix",- "Control.Monad.Identity",- "Control.Monad.Instances",- "Control.Monad.RWS",- "Control.Monad.Reader",- "Control.Monad.ST",- "Control.Monad.State",- "Control.Monad.State",- "Control.Monad.Writer",- "Control.Parallel",- "Control.Parallel.Strategies",- "Data.Array",- "Data.Bits",- "Data.Bool",- "Data.Char",- "Data.Complex",- "Data.Dynamic",- "Data.Either",- "Data.Eq",- "Data.Fixed",- "Data.Graph",- "Data.Int",- "Data.Ix",- "Data.List",- "Data.Maybe",- "Data.Monoid",+defaultModules = ["Prelude",+ "ShowQ",+ "ShowFun",+ "SimpleReflect",+ "Data.Function",+ "Control.Applicative",+ "Control.Arrow",+ "Control.Monad",+ "Control.Monad.Cont",+ "Control.Monad.Error",+ "Control.Monad.Fix",+ "Control.Monad.Identity",+ "Control.Monad.Instances",+ "Control.Monad.RWS",+ "Control.Monad.Reader",+ "Control.Monad.State",+ "Control.Monad.State",+ "Control.Monad.Writer",+ "Control.Parallel",+ "Control.Parallel.Strategies",+ "Data.Array",+ "Data.Bits",+ "Data.Bool",+ "Data.Char",+ "Data.Complex",+ "Data.Dynamic",+ "Data.Either",+ "Data.Eq",+ "Data.Fixed",+ "Data.Graph",+ "Data.Int",+ "Data.Ix",+ "Data.List",+ "Data.Maybe",+ "Data.Monoid",+{- -- Commented out because they are not necessarily available. If anyone misses+ -- them, perhaps we could look into forcing a dependency on them in the Cabal+ -- file. For now, we'll let them be optional.+ "Data.Number.BigFloat", "Data.Number.CReal", "Data.Number.Dif",@@ -112,13 +67,14 @@ "Data.Number.Interval", "Data.Number.Natural", "Data.Number.Symbolic",+ "Math.OEIS",+-} "Data.Ord", "Data.Ratio", "Data.Tree", "Data.Tuple", "Data.Typeable", "Data.Word",- "Math.OEIS", "System.Random", "Test.QuickCheck", "Text.PrettyPrint.HughesPJ",@@ -134,77 +90,19 @@ > mueval --module Data.Map -e "Prelude.map (+1) [1..100]" -}-safeModules :: [String]-safeModules = defaultModules ++ [- "Control.Arrow",- "Control.Arrow.Operations",- "Control.Arrow.Transformer",- "Control.Arrow.Transformer.All",- "Data.ByteString",- "Data.ByteString.Char8",- "Data.ByteString.Lazy",- "Data.ByteString.Lazy.Char8",- "Data.Foldable",- "Data.Generics",- "Data.IntMap",- "Data.IntSet",- "Data.Map",- "Data.Sequence",- "Data.Set",- "Data.Traversable"]--parseHsModule :: String -> Either String HsModule-parseHsModule s =- case parseModule s of- ParseOk m -> Right m- ParseFailed loc e ->- let line = srcLine loc - 1- in Left (unlines [show line,show loc,e])--parseHsDecls :: String -> Either String [HsDecl]-parseHsDecls s =- let s' = unlines [pprHsModule (emptyHsModule "Main"), s]- in case parseModule s' of- ParseOk m -> Right (moduleDecls m)- ParseFailed loc e ->- let line = srcLine loc - 1- in Left (unlines [show line,show loc,e])--parseHsExp :: String -> Either String HsExp-parseHsExp s =- case parseHsDecls ("main = ("++(filter (/='\n') s)++")") of- Left err -> Left err- Right xs ->- case [ e | HsPatBind _ _ (HsUnGuardedRhs e) _ <- xs] of- [] -> Left "invalid expression"- (e:_) -> Right e--parseHsPat :: String -> Either String HsPat-parseHsPat s =- case parseHsDecls ("(" ++ (filter (/='\n') s) ++ ")=()") of- Left err -> Left err- Right xs ->- case [ p | HsPatBind _ p _ _ <- xs] of- [] -> Left "invalid pattern"- (p:_) -> Right p--pprHsModule :: HsModule -> String-pprHsModule = prettyPrint--moduleDecls :: HsModule -> [HsDecl]-moduleDecls (HsModule _ _ _ _ x) = x--mkModule :: String -> Module-mkModule = Module--emptySrcLoc :: SrcLoc-emptySrcLoc = (SrcLoc [] 0 0)--emptyHsModule :: String -> HsModule-emptyHsModule n =- (HsModule- emptySrcLoc- (mkModule n)- Nothing- []- [])+qualifiedModules :: [(String, Maybe String)]+qualifiedModules = [+-- ("Control.Arrow.Transformer", Just "AT"),+-- ("Control.Arrow.Transformer.All", Just "AT"),+ ("Data.ByteString", Just "BS"),+ ("Data.ByteString.Char8", Just "BSC"),+ ("Data.ByteString.Lazy", Just "BSL"),+ ("Data.ByteString.Lazy.Char8", Just "BSLC"),+ ("Data.Foldable", Just "Data.Foldable"),+ ("Data.Generics", Just "Data.Generics"),+ ("Data.IntMap", Just "IM"),+ ("Data.IntSet", Just "IS"),+ ("Data.Map", Just "M"),+ ("Data.Sequence", Just "Data.Sequence"),+ ("Data.Set", Just "S"),+ ("Data.Traversable", Just "Data.Traversable") ]
Mueval/Interpreter.hs view
@@ -1,44 +1,41 @@+{-# LANGUAGE PatternGuards #-} -- TODO: suggest the convenience functions be put into Hint proper? module Mueval.Interpreter where -import Control.Monad (liftM)-import Control.Monad (when, (<=<))-import Control.Monad.Trans (liftIO)-import Data.List (isInfixOf)-import System.Directory (copyFile, makeRelativeToCurrentDirectory, removeFile)+import Control.Monad (when,mplus)+import System.Directory (copyFile, makeRelativeToCurrentDirectory) import System.Exit (exitFailure) import System.FilePath.Posix (takeFileName)-import qualified Control.Exception as E (bracket,catchDyn,evaluate,catch)+import qualified Control.OldException as E (evaluate,catch) -import Language.Haskell.Interpreter.GHC (eval, newSession, reset, setImports, loadModules,- setOptimizations, setUseLanguageExtensions, setInstalledModsAreInScopeQualified,- typeOf, withSession, setTopLevelModules,- Interpreter, InterpreterError(..),GhcError(..), ModuleName, Optimizations(All))+import Language.Haskell.Extension(Extension(ExtendedDefaultRules))+import Language.Haskell.Interpreter (eval, set, reset, setImportsQ, loadModules, liftIO,+ installedModulesInScope, languageExtensions,+ typeOf, setTopLevelModules, runInterpreter, glasgowExtensions,+ OptionVal(..), + Interpreter, InterpreterError(..),GhcError(..), ModuleName) import qualified Mueval.Resources (limitResources)-import qualified Codec.Binary.UTF8.String as Codec (decodeString)+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) {- | The actual calling of Hint functionality. The heart of this just calls- 'eval', but we do so much more - we disable Haskell extensions, turn on- optimizations, hide all packages, make sure one cannot call unimported+ 'eval', but we do so much more - we disable Haskell extensions, + hide all packages, make sure one cannot call unimported functions, typecheck (and optionally print it), set resource limits for this thread, and do some error handling. -} interpreter :: Bool -> Bool -> Bool -> Maybe [ModuleName] -> String -> String -> Interpreter () interpreter prt exts rlimits modules lfl expr = do- setUseLanguageExtensions exts -- False by default-- setOptimizations All -- Maybe optimization will make- -- more programs- -- terminate.+ when exts $ set [languageExtensions := (ExtendedDefaultRules:glasgowExtensions)] reset -- Make sure nothing is available- setInstalledModsAreInScopeQualified False+ set [installedModulesInScope := False] - let doload = if lfl == ""- then False else True+ let doload = lfl /= "" - when doload (liftIO $ mvload lfl)+ when doload $ liftIO (mvload lfl) liftIO $ Mueval.Resources.limitResources rlimits @@ -52,7 +49,8 @@ case modules of Nothing -> return ()- Just ms -> setImports ms+ Just ms -> do let unqualModules = zip ms (repeat Nothing)+ setImportsQ (unqualModules ++ Mueval.Context.qualifiedModules) when prt $ say expr -- we don't check if the expression typechecks@@ -70,23 +68,19 @@ -> 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.+ -- empty string is treated as no file. -> String -- ^ The string to be interpreted as a Haskell expression -> IO () -- ^ No real result, since printing is done deeper in- -- the stack.-interpreterSession prt exts rls mds lfl expr = E.bracket newSession cleanTmpFile $ \session ->- withSession session (interpreter prt exts rls mds lfl expr)- `E.catchDyn` printInterpreterError- where- cleanTmpFile _ = case lfl of- "" -> return ()- l -> do canonfile <- makeRelativeToCurrentDirectory l- removeFile $ "/tmp/" ++ takeFileName canonfile+ -- the stack.+interpreterSession prt exts rls mds lfl expr = do r <- runInterpreter (interpreter prt exts rls mds lfl expr)+ case r of + Left err -> printInterpreterError err+ Right () -> return () mvload :: FilePath -> IO ()-mvload lfl = do canonfile <- (makeRelativeToCurrentDirectory lfl)- liftIO $ copyFile canonfile ("/tmp/" ++ (takeFileName canonfile))+mvload lfl = do canonfile <- makeRelativeToCurrentDirectory lfl+ liftIO $ copyFile canonfile $ "/tmp/" ++ takeFileName canonfile --------------------------------- -- Handling and outputting results@@ -98,7 +92,9 @@ say = liftIO . sayIO sayIO :: String -> IO ()-sayIO = UTF.putStrLn . Codec.decodeString <=< (fmap (take 1024)) . liftM analyzeResult . forceString . take 1024+sayIO str = do (out,b) <- render 1024 str+ UTF.putStrLn out+ when b $ exitFailure -- | Oh no, something has gone wrong. If it's a compilation error pretty print -- the first 1024 chars of it and throw an "ExitException"@@ -111,30 +107,46 @@ exitFailure where -- each error starts with the line position, which is uninteresting- dropLinePosition = unlines . tail . lines+ dropLinePosition e+ | Just s <- parseErr e = s+ | otherwise = e -- if the parse fails we fallback on printing the whole error+ parseErr e = do s <- stripPrefix "<interactive>:" e+ skipSpaces =<<(skipNumber =<< skipNumber s)+ skip x (y:xs) | x == y = Just xs+ | otherwise = Nothing+ skip _ _ = Nothing+ skipNumber = skip ':' . dropWhile isDigit+ skipSpaces xs = let xs' = dropWhile (==' ') xs+ in skip '\n' xs' `mplus` return xs'+ -- other exceptions indicate some problem in Mueval or the environment, -- so we rethrow them for debugging purposes printInterpreterError other = error (show other) --- | Forces a string catching pure exceptions and displaying them like GHCi, ***--- Exception: ...-forceString :: String -> IO String-forceString str = do r <- fmap Right (E.evaluate (uncons str)) `E.catch` \e -> return $ Left (show e)- case r of- Left e -> return $ exceptionMsg ++ e- Right Nothing -> return []- Right (Just (x,xs)) -> fmap (x:) $ forceString xs- where uncons [] = Nothing- uncons (x:xs) = x `seq` Just (x,xs)- -- Constant exceptionMsg :: String-exceptionMsg = "*** Exception: "+exceptionMsg = "* Exception: " --- | Analyze the output (presumably from 'forceString') and error out if an--- exception was present.--- TODO: Come up with some cleaner way of working with forceString.-analyzeResult :: String -> String-analyzeResult str | exceptionMsg `isInfixOf` str = error str- | str == "" = ""- | otherwise = str+-- | renders the input String including its exceptions using @exceptionMsg@+render :: Int -- ^ max number of characters to include+ -> String -- ^ input+ -> IO (String, Bool) -- ^ ( output, @True@ if we found an exception )+render i xs =+ do (out,Any b) <- runWriterT $ render' i (toStream xs)+ return (out,b)+ where+ render' n _ | n <= 0 = return ""+ render' n s = render'' n =<< liftIO s++ render'' _ End = return ""+ render'' n (Cons x s) = fmap (x:) $ render' (n-1) s+ render'' n (Exception s) = do+ tell (Any True)+ fmap (take n exceptionMsg ++) $ render' (n - length exceptionMsg) s++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)+ 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, yield, ThreadId) import System.Posix.Signals (sigXCPU, installHandler, Handler(CatchOnce))-import Control.Exception (Exception(ErrorCall),catch)+import Control.OldException (Exception(ErrorCall),catch) import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar, MVar) import System.IO (hSetBuffering, stdout, BufferMode(NoBuffering)) @@ -15,7 +15,7 @@ watchDog tout tid = do installHandler sigXCPU (CatchOnce $ throwTo tid $ ErrorCall "Time limit exceeded.") Nothing- forkIO $ do threadDelay (tout * 500000)+ forkIO $ do threadDelay (tout * 700000) -- Time's up. It's a good day to die. throwTo tid (ErrorCall "Time limit exceeded") yield -- give the other thread a chance
README view
@@ -36,13 +36,13 @@ It's worth noting that definitions and module imports in the loaded *ARE NOT* fully checked like the expression is. The resource limits and timeouts still apply, but little else. So if you are dynamically adding functions and module imports, you *MUST* secure them yourself or accept the loss of security. Currently, all known 'evil' expressions cause Mueval to exit with an error (a non-zero exit code), so my advice is to do something like 'mueval --expression foo && echo "\n" >> L.hs && echo foo >> L.hs'. SUMMARY:-Anyway, it's my hope that this will be useful as an example or useful in itself for people endeavouring to fix the Lambdabot situation or just in safely running code period.+Anyway, it's my hope that this will be useful as an example or useful in itself for people endeavoring to fix the Lambdabot situation or just in safely running code period. GETTING: You can download Mueval at the usual place: <http://hackage.haskell.org/cgi-bin/hackage-scripts/package/mueval>. Mueval has a public darcs repository, at <http://code.haskell.org/mubot/> (in the mueval/ subdirectory). Contributions are of course welcomed. INSTALLING:-Mueval depends on a few of the standard libraries, which you should have installed already, and also on the 'Hint' library <http://hackage.haskell.org/cgi-bin/hackage-scripts/package/hint>; Hint is particularly essential as it is the very capable wrapper around the GHC API which Mueval uses. (Without Hint, this would've been even more painful to write). All of this is cabalized, so ideally installation will be as simple as:+Mueval depends on a few of the standard libraries, which you should have installed already, and also on the 'Hint' library <http://hackage.haskell.org/cgi-bin/hackage-scripts/package/hint>; Hint is particularly essential as it is the very capable wrapper around the GHC API which Mueval uses. (Without Hint, this would've been much more painful to write). All of this is cabalized, so ideally installation will be as simple as: sh$ cabal install mueval @@ -53,13 +53,19 @@ sh$ runhaskell Setup install BUGS:-Mueval uses a number of techniques for security; particularly problematic seem to be the resource limits, as they have to be specified manually & statically in the source code and so will probably be broken somewhere somewhen.+Mueval uses a number of techniques for security; particularly problematic seem to be the resource limits, as they have to be specified manually & statically in the source code and so will probably be broken somewhere somewhen. For this reason, they are not enabled by default. Experiment with --rlimits for hours of fun! +Mueval also simply cannot do qualified imports. This is due to limitations in the GHC API; see <http://hackage.haskell.org/trac/ghc/ticket/1895>. (Remember that CC'ing yourself is an implicit vote for the problem to be fixed!)++With darcs Hint and Mueval, compiling Mueval (or any Hint-using executable) with profiling support seems to lead to runtime crashes.++Finally, under 6.10.1, you must run Mueval with "+RTS -N2 -RTS" as otherwise the watchdog threads will not get run and DoS attacks are possible. (Compare 'mueval -e "let x = x + 1 in x"' against 'mueval -e "let x = x + 1 in x" +RTS -N2 -RTS'.)+ CONTRIBUTING: So, you've discovered a bug or other infelicity? If you can successfully build & install Mueval, but running it on expressions leads to errors, please send me an email at <gwern0@gmail.com>. Include in the email all the output you see if you run the informal test suite: sh$ sh tests.sh -If this script *does not* terminate with a success message, then there's something wrong. One of the properties Mueval strives to have is that on every bad expression, it errors out with an exit code of 1, and on every good expression, an exit code of 0.+If this script *does not* terminate with a success message, then there's probably something wrong. One of the properties Mueval strives to have is that on every bad expression, it errors out with an exit code of 1, and on every good expression, an exit code of 0. If you have a patch handy, 'darcs send' is the best way to contribute. As above, tests.sh should be happy, as should 'cabal check'; even better is if your email is GPG-signed, but that's not as important as test.sh passing.
build.sh view
@@ -2,8 +2,7 @@ # Abort if any commands aren't successful set -e # Build-(runhaskell Setup configure --user && runhaskell Setup build && runhaskell Setup haddock- && runhaskell Setup install || exit) &&+(runhaskell Setup configure --user && runhaskell Setup build && runhaskell Setup haddock && runhaskell Setup install || exit) && # Run the test suite with various options echo "\n...Single-threaded tests....\n" && sh tests.sh &&
main.hs view
@@ -5,20 +5,8 @@ module Main (main) where import Mueval.Parallel-import Mueval.ArgsParse (getOptions, Options(..))-import qualified Mueval.Context (cleanModules, unsafe)+import Mueval.ArgsParse (getOptions) main :: IO () main = do opts <- getOptions- doIfSafe opts forkedMain---- We don't keep this in one of the other modules, because it's policy; other--- similar programs may not care.-doIfSafe :: Options -> (Options -> t t1) -> t t1-doIfSafe opts f = if (Mueval.Context.cleanModules $- modules opts) then do- if (not $ Mueval.Context.unsafe $ expression opts) then- f opts- else error "Unsafe functions to use mentioned."- else error "Unknown or untrusted module supplied! Aborting."-+ forkedMain opts
mueval.cabal view
@@ -1,5 +1,5 @@ name: mueval-version: 0.6.4+version: 0.7.0 license: BSD3 license-file: LICENSE@@ -12,18 +12,18 @@ uses the GHC API to evaluate arbitrary Haskell expressions. Importantly, mueval takes many precautions to defang and avoid \"evil\" code. It uses resource limits, whitelisted modules,- special Show instances for IO, threads, changes of directory, and so+ special Show instances for IO, threads, processes, changes of directory, and so on to sandbox the Haskell code. . It is, in short, intended to be a standalone version of Lambdabot's famous evaluation functionality. For examples and explanations, please see the README file. .- Mueval is currently POSIX-only.+ Mueval is POSIX-only. homepage: http://code.haskell.org/mubot/ build-type: Simple cabal-version: >= 1.2-tested-with: GHC==6.8.2+tested-with: GHC==6.10.1 data-files: README extra-source-files: build.sh, tests.sh@@ -31,11 +31,16 @@ library exposed-modules: Mueval.Parallel, Mueval.Context, Mueval.Interpreter, Mueval.ArgsParse, Mueval.Resources- build-depends: base, containers, directory, mtl, filepath, unix,- hint>=0.2.4.1, show>=0.3, utf8-string, haskell-src-exts+ build-depends: base>=4, containers, directory, mtl, filepath, unix, process,+ hint>=0.3.0.0, show>=0.3, utf8-string, Cabal ghc-options: -Wall -static -O2 -executable mueval+executable mueval-core main-is: main.hs build-depends: base- ghc-options: -Wall -static -O2+ ghc-options: -Wall -static -threaded -O2++executable mueval+ main-is: watchdog.hs+ build-depends: base+ ghc-options: -Wall -static -threaded -O2
tests.sh view
@@ -2,8 +2,11 @@ # tests # Save typing-m () { mueval --inferred-type --expression "$@"; }+m () { echo "$@" && mueval --inferred-type --expression "$@"; } +# Test whether it's around+mueval &> /dev/null+ # Abort if any commands aren't successful set -e # Test on valid expressions. Note we conditionalize - all of these should return successfully.@@ -21,6 +24,8 @@ ## see whether we gave it enough resources to do reasonably long stuff m "(last \"nebbish\") : (head $ reverse \"fooo bar baz booooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooreally long strong, you must confess, at least relative to the usual string, I suppose\") : []" m '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'+# Silly "Hello World"+m 'let uncat3 [] = [] ; uncat3 xs = (let (ys, zs) = splitAt 3 xs in ys : uncat3 zs) ; getFrom x y = map (x !!) $ map (fromIntegral . ((\x -> fromIntegral $ foldl (.|.) (0::Word8) (zipWith (\c n -> if c then bit n else (0::Word8)) x [0..2])) :: [Bool] -> Int)) $ reverse . uncat3 . reverse . concat . map (((\x -> map (testBit x) [7,6..0]) :: Word8 -> [Bool]) . fromIntegral . ord) $ y in getFrom " HWdelor" "e\184-\235"' ## Single module m '()' --module=Prelude ## Test whether we can import multiple modules@@ -53,13 +58,16 @@ m 'sort [4,6,1,2,3]' m 'runIdentity $ mfix (return . (0:) . scanl (+) 1)' m 'fix ((1:).(1:).(zipWith (+) `ap` tail))'-m 'runST (return 0)'-m 'map return [1,2] :: [Either String Int]'+m "listArray (1,10) ['a'..]"+### Test Control.Arrow+m 'let f = (id *** id) in f (3, 4)'+### Test Control.Applicative+m "(foldr (liftA2 (||)) (const False) [isDigit, isAlpha]) '3'" ## Test defaulting of expressions m 'show []' -E m '(+1) <$> [1..3]' ## Now let's do file loading-echo "module TmpModule (foo, bar) where\nfoo x = x + 1 \nbar x = x + 2" > "TmpModule.hs"+echo "module TmpModule (foo, bar) where { foo x = x + 1; bar x = x + 2 }" > "TmpModule.hs" m '1+1' --loadfile="TmpModule.hs" m 'foo 1' --loadfile="TmpModule.hs" m 'bar 1' --loadfile="TmpModule.hs"@@ -68,6 +76,8 @@ ## Test the --noimports function ## TODO: more extensive tests of this m '()' --noimports+## Test qualified imports+m "M.map (+1) $ M.fromList [(1,2), (3,4)]" && echo "\nOK, all the valid expressions worked out well." && # Test on bad or outright evil expressions@@ -83,10 +93,6 @@ m 'let fix f = let x = f x in x in foldr (.) id (repeat read) $ fix show' || ## Let's stress the time limits m '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-m 1+1 --module Data.List --module System.IO.Unsafe --module Control.Monad ||-m "let foo = unsafePerformIO readFile \"/etc/passwd\" in foo" --module System.IO.Unsafe ||-m "head [1..]" --module Data.List --module Text.HTML.Download || m " runST (unsafeIOToST (readFile \"/etc/passwd\"))" || ### Can we bypass the whitelisting by fully qualified module names? m "Foreign.unsafePerformIO $ readFile \"/etc/passwd\"" ||
+ watchdog.hs view
@@ -0,0 +1,21 @@+-- | This implements a watchdog process. It calls mueval with all the+-- user-specified arguments, sleeps, and then if mueval is still running+-- kills it.+-- Even an out-of-control mueval will have trouble avoiding 'terminateProcess'.+-- Note that it's too difficult to parse the user arguments to get the timeout,+-- so we specify it as a constant which is a little more generous than the default.+module Main where++import System.Environment+import Control.Concurrent+import System.Process+import System.Exit++main :: IO ()+main = do args <- getArgs+ hdl <- runProcess "mueval-core" args Nothing Nothing Nothing Nothing Nothing+ threadDelay (7 * 700000)+ status <- getProcessExitCode hdl+ case status of + Nothing -> terminateProcess hdl >> exitWith (ExitFailure 1)+ Just a -> exitWith a