diff --git a/Mueval/ArgsParse.hs b/Mueval/ArgsParse.hs new file mode 100644 --- /dev/null +++ b/Mueval/ArgsParse.hs @@ -0,0 +1,78 @@ +module Mueval.ArgsParse (Options(..), interpreterOpts, getOptions) where + +import Control.Monad (liftM) +import System.Console.GetOpt +import System.Environment (getArgs) + +import qualified Codec.Binary.UTF8.String as Codec (decodeString) + +import Mueval.Context (defaultModules) + +-- | See the results of --help for information on what each option means. +data Options = Options + { timeLimit :: Int + , modules :: [String] + , expression :: String + , loadFile :: String + , user :: String + , printType :: Bool + , extensions :: Bool + , noimports :: Bool + , rlimits :: Bool + } deriving Show + +defaultOptions :: Options +defaultOptions = Options { expression = "" + , modules = defaultModules + , timeLimit = 5 + , user = "" + , loadFile = "" + , printType = False + , extensions = False + , 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") + "Time limit for compilation and evaluation", + + 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") + "A module we should import functions from for evaluation. (Can be given multiple times.)", + 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"] + (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"] + (ReqArg (\e opts -> opts { expression = e}) "EXPRESSION") + "The expression to be evaluated.", + 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"] + (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] -> IO (Options, [String]) +interpreterOpts argv = + case getOpt Permute options argv of + (o,n,[]) -> return (foldl (flip id) defaultOptions o, n) + (_,_,er) -> ioError $ userError (concat er ++ usageInfo header options) + where header = "Usage: mueval [OPTION...] --expression EXPRESSION..." + +-- | Just give us the end result options; this handles I/O and parsing for +-- us. Bonus points for handling UTF. +getOptions :: IO Options +getOptions = do input <- liftM (map Codec.decodeString) getArgs + (opts,_) <- interpreterOpts $ input + return opts diff --git a/Mueval/Concurrent.hs b/Mueval/Concurrent.hs deleted file mode 100644 --- a/Mueval/Concurrent.hs +++ /dev/null @@ -1,54 +0,0 @@ -module Mueval.Concurrent where - -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.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar, MVar) -import System.IO (hSetBuffering, stdout, BufferMode(NoBuffering)) - -import Mueval.Interpreter -import Mueval.ParseArgs - --- | Fork off a thread which will sleep and then kill off the specified thread. -watchDog :: Int -> ThreadId -> IO () -watchDog tout tid = do installHandler sigXCPU - (CatchOnce - $ throwTo tid $ ErrorCall "Time limit exceeded.") Nothing - forkIO $ do threadDelay (tout * 500000) - -- 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. - error "Time expired" - return () -- Never reached. Either we error out in - -- watchDog, or the evaluation thread finishes. - --- | A basic blocking operation. -block :: (t -> MVar a -> IO t1) -> t -> IO a -block f opts = do mvar <- newEmptyMVar - f opts mvar - takeMVar mvar -- block until ErrorCall, or forkedMain succeeds - --- | Using MVars, block on forkedMain' until it finishes. -forkedMain :: Options -> IO () -forkedMain opts = block forkedMain' opts >> return () - --- | Set a 'watchDog' on this thread, and then continue on with whatever. -forkedMain' :: Options -> MVar [Char] -> IO ThreadId -forkedMain' opts mvar = do mainId <- myThreadId - watchDog tout mainId - hSetBuffering stdout NoBuffering - - -- Our modules and expression are set up. Let's do stuff. - forkIO $ (interpreterSession typeprint extend mdls fls expr - >> putMVar mvar "Done.") - `catch` throwTo mainId -- 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 diff --git a/Mueval/Context.hs b/Mueval/Context.hs --- a/Mueval/Context.hs +++ b/Mueval/Context.hs @@ -1,7 +1,15 @@ -module Mueval.Context (cleanModules, defaultModules, unsafe) where +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 @@ -9,12 +17,50 @@ will at least catch naive and simplistic invocations of "unsafePerformIO", "inlinePerformIO", and "unsafeCoerce". -} unsafe :: String -> Bool -unsafe = \z -> any (`isInfixOf` z) ["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"] +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 + +{- +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) + + -- | Return false if any of the listed modules cannot be found in the whitelist. cleanModules :: [String] -> Bool cleanModules = and . map (`elem` safeModules) @@ -106,3 +152,59 @@ "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 + [] + []) diff --git a/Mueval/Interpreter.hs b/Mueval/Interpreter.hs --- a/Mueval/Interpreter.hs +++ b/Mueval/Interpreter.hs @@ -1,57 +1,31 @@ -- TODO: suggest the convenience functions be put into Hint proper? module Mueval.Interpreter where -import Control.Monad (when) -import qualified Control.Exception as E (bracket,catchDyn) +import Control.Monad (liftM) +import Control.Monad (when, (<=<)) import Control.Monad.Trans (liftIO) +import Data.List (isInfixOf) import System.Directory (copyFile, makeRelativeToCurrentDirectory, removeFile) -import System.FilePath.Posix (takeFileName) import System.Exit (exitFailure) +import System.FilePath.Posix (takeFileName) +import qualified Control.Exception as E (bracket,catchDyn,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 qualified Mueval.Resources (limitResources) import qualified Codec.Binary.UTF8.String as Codec (decodeString) import qualified System.IO.UTF8 as UTF (putStrLn) -import qualified Mueval.Resources (limitResources) - --- | From inside the Interpreter monad, print the String (presumably the result --- of interpreting something), but only print the first 1024 characters to avoid --- flooding. Lambdabot has a similar limit. -say :: String -> Interpreter () -say = liftIO . sayIO - -sayIO :: String -> IO () -sayIO = UTF.putStrLn . Codec.decodeString . take 1024 - --- | Oh no, something has gone wrong. If it's a compilation error prettyprint --- the first 1024 chars of it and throw an ExitExcetion --- otherwise rethrow the exception in String form. -printInterpreterError :: InterpreterError -> IO () -printInterpreterError (WontCompile errors) = - -- if we get a compilation error we print it directly to avoid "mueval: .." - -- maybe it should go to stderr? - do sayIO $ concatMap (dropLinePosition . errMsg) errors - exitFailure - where - -- each error starts with the line position, which is uninteresting - dropLinePosition = unlines . tail . lines --- other exceptions indicate some problem in mueval or the environment, --- so we rethrow them for debugging purpouses -printInterpreterError other = error (show other) - - {- | 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 functions, typecheck (and optionally print it), set resource limits for this thread, and do some error handling. -} -interpreter :: Bool -> Bool -> Maybe [ModuleName] -> String -> String -> Interpreter () -interpreter prt exts modules lfl expr = do +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 @@ -66,7 +40,7 @@ when doload (liftIO $ mvload lfl) - liftIO Mueval.Resources.limitResources + liftIO $ Mueval.Resources.limitResources rlimits when doload $ do let lfl' = takeFileName lfl @@ -81,11 +55,11 @@ Just ms -> setImports ms when prt $ say expr - -- we don't check if the expression typechecks - -- this way we get an InterpreterError we can display + -- we don't check if the expression typechecks + -- this way we get an "InterpreterError" we can display when prt $ say =<< typeOf expr - result <- eval expr + result <- eval expr say $ result @@ -93,22 +67,74 @@ -- error-handling. The arguments are simply passed on. 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 printing is done deeper in -- the stack. -interpreterSession prt exts mds lfl expr = E.bracket newSession cleanTmpFile $ \session -> - withSession session (interpreter prt exts mds lfl expr) +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 + where cleanTmpFile _ = case lfl of "" -> return () l -> do canonfile <- makeRelativeToCurrentDirectory l removeFile $ "/tmp/" ++ takeFileName canonfile - + mvload :: FilePath -> IO () mvload lfl = do canonfile <- (makeRelativeToCurrentDirectory lfl) liftIO $ copyFile canonfile ("/tmp/" ++ (takeFileName canonfile)) + +--------------------------------- +-- Handling and outputting results + +-- | From inside the Interpreter monad, print the String (presumably the result +-- of interpreting something), but only print the first 1024 characters to avoid +-- flooding. Lambdabot has a similar limit. +say :: String -> Interpreter () +say = liftIO . sayIO + +sayIO :: String -> IO () +sayIO = UTF.putStrLn . Codec.decodeString <=< (fmap (take 1024)) . liftM analyzeResult . forceString . take 1024 + +-- | Oh no, something has gone wrong. If it's a compilation error pretty print +-- the first 1024 chars of it and throw an "ExitException" +-- otherwise rethrow the exception in String form. +printInterpreterError :: InterpreterError -> IO () +printInterpreterError (WontCompile errors) = + -- if we get a compilation error we print it directly to avoid \"mueval: ...\" + -- maybe it should go to stderr? + do sayIO $ concatMap (dropLinePosition . errMsg) errors + exitFailure + where + -- each error starts with the line position, which is uninteresting + dropLinePosition = unlines . tail . lines +-- 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: " + +-- | 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 diff --git a/Mueval/Parallel.hs b/Mueval/Parallel.hs new file mode 100644 --- /dev/null +++ b/Mueval/Parallel.hs @@ -0,0 +1,55 @@ +module Mueval.Parallel where + +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.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar, MVar) +import System.IO (hSetBuffering, stdout, BufferMode(NoBuffering)) + +import Mueval.Interpreter +import Mueval.ArgsParse + +-- | Fork off a thread which will sleep and then kill off the specified thread. +watchDog :: Int -> ThreadId -> IO () +watchDog tout tid = do installHandler sigXCPU + (CatchOnce + $ throwTo tid $ ErrorCall "Time limit exceeded.") Nothing + forkIO $ do threadDelay (tout * 500000) + -- 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. + error "Time expired" + return () -- Never reached. Either we error out in + -- watchDog, or the evaluation thread finishes. + +-- | A basic blocking operation. +block :: (t -> MVar a -> IO t1) -> t -> IO a +block f opts = do mvar <- newEmptyMVar + f opts mvar + takeMVar mvar -- block until ErrorCall, or forkedMain succeeds + +-- | Using MVars, block on forkedMain' until it finishes. +forkedMain :: Options -> IO () +forkedMain opts = block forkedMain' opts >> return () + +-- | Set a 'watchDog' on this thread, and then continue on with whatever. +forkedMain' :: Options -> MVar [Char] -> IO ThreadId +forkedMain' opts mvar = do mainId <- myThreadId + watchDog tout mainId + hSetBuffering stdout NoBuffering + + -- Our modules and expression are set up. Let's do stuff. + forkIO $ (interpreterSession typeprint extend rls mdls fls expr + >> putMVar mvar "Done.") + `catch` throwTo mainId -- 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 diff --git a/Mueval/ParseArgs.hs b/Mueval/ParseArgs.hs deleted file mode 100644 --- a/Mueval/ParseArgs.hs +++ /dev/null @@ -1,73 +0,0 @@ -module Mueval.ParseArgs (Options(..), interpreterOpts, getOptions) where - -import Control.Monad (liftM) -import System.Console.GetOpt -import System.Environment (getArgs) - -import qualified Codec.Binary.UTF8.String as Codec (decodeString) - -import Mueval.Context (defaultModules) - --- | See the results of --help for information on what each option means. -data Options = Options - { timeLimit :: Int - , modules :: [String] - , expression :: String - , loadFile :: String - , user :: String - , printType :: Bool - , extensions :: Bool - , noimports :: Bool - } deriving Show - -defaultOptions :: Options -defaultOptions = Options { expression = "" - , modules = defaultModules - , timeLimit = 5 - , user = "" - , loadFile = "" - , printType = False - , extensions = False - , noimports = 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") - "Time limit for compilation and evaluation", - - 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") - "A module we should import functions from for evaluation. (Can be given multiple times.)", - 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"] - (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"] - (ReqArg (\e opts -> opts { expression = e}) "EXPRESSION") - "The expression to be evaluated.", - 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." ] - -interpreterOpts :: [String] -> IO (Options, [String]) -interpreterOpts argv = - case getOpt Permute options argv of - (o,n,[]) -> return (foldl (flip id) defaultOptions o, n) - (_,_,er) -> ioError $ userError (concat er ++ usageInfo header options) - where header = "Usage: mueval [OPTION...] --expression EXPRESSION..." - --- | Just give us the end result options; this handles I/O and parsing for --- us. Bonus points for handling UTF. -getOptions :: IO Options -getOptions = do input <- liftM (map Codec.decodeString) getArgs - (opts,_) <- interpreterOpts $ input - return opts diff --git a/Mueval/Resources.hs b/Mueval/Resources.hs --- a/Mueval/Resources.hs +++ b/Mueval/Resources.hs @@ -1,37 +1,40 @@ module Mueval.Resources (limitResources) where +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". -limitResources :: IO () -limitResources = do setCurrentDirectory "/tmp" -- will at least mess up relative links - nice 19 -- Set our process priority way down - mapM_ (uncurry setResourceLimit) limits +-- 'nice', the rlimit bindings, and "setCurrentDirectory". +-- 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) -- | Set all the available rlimits. -- These values have been determined through trial-and-error -stackSizeLimitSoft, stackSizeLimitHard, - dataSizeLimitSoft, +stackSizeLimitSoft, stackSizeLimitHard, totalMemoryLimitSoft, totalMemoryLimitHard, + dataSizeLimitSoft, openFilesLimitSoft, openFilesLimitHard, fileSizeLimitSoft, fileSizeLimitHard, dataSizeLimitHard, cpuTimeLimitSoft, cpuTimeLimitHard, coreSizeLimitSoft, coreSizeLimitHard, zero :: ResourceLimit --- totalMemoryLimitSoft = dataSizeLimitSoft --- totalMemoryLimitHard = dataSizeLimitHard +totalMemoryLimitSoft = dataSizeLimitSoft +totalMemoryLimitHard = dataSizeLimitHard -- These limits seem to be useless? stackSizeLimitSoft = zero stackSizeLimitHard = zero -- We allow a few files to be opened, such as package.conf, because they are necessary. This -- doesn't seem to be security problem because it'll be opened at the module -- stage, before code ever evaluates. I hope. --- openFilesLimitSoft = openFilesLimitHard --- openFilesLimitHard = ResourceLimit 7 +openFilesLimitSoft = openFilesLimitHard +openFilesLimitHard = ResourceLimit 7 -- TODO: It would be nice to set these to zero, but right now Hint gets around the -- insecurity of the GHC API by writing stuff out to a file in /tmp, so we need -- to allow our compiled binary to do file I/O... :( But at least we can still limit -- how much we write out! --- fileSizeLimitSoft = fileSizeLimitHard --- fileSizeLimitHard = ResourceLimit 590 +fileSizeLimitSoft = fileSizeLimitHard +fileSizeLimitHard = ResourceLimit 10800 dataSizeLimitSoft = dataSizeLimitHard dataSizeLimitHard = ResourceLimit $ 6^(12::Int) -- These should not be identical, to give the XCPU handler time to trigger @@ -39,13 +42,15 @@ cpuTimeLimitHard = ResourceLimit 5 coreSizeLimitSoft = coreSizeLimitHard coreSizeLimitHard = zero + +-- convenience zero = ResourceLimit 0 limits :: [(Resource, ResourceLimits)] limits = [ (ResourceStackSize, ResourceLimits stackSizeLimitSoft stackSizeLimitHard) --- , (ResourceTotalMemory, ResourceLimits totalMemoryLimitSoft totalMemoryLimitHard) --- , (ResourceOpenFiles, ResourceLimits openFilesLimitSoft openFilesLimitHard) --- , (ResourceFileSize, ResourceLimits fileSizeLimitSoft fileSizeLimitHard) + , (ResourceTotalMemory, ResourceLimits totalMemoryLimitSoft totalMemoryLimitHard) + , (ResourceOpenFiles, ResourceLimits openFilesLimitSoft openFilesLimitHard) + , (ResourceFileSize, ResourceLimits fileSizeLimitSoft fileSizeLimitHard) , (ResourceDataSize, ResourceLimits dataSizeLimitSoft dataSizeLimitHard) , (ResourceCoreFileSize, ResourceLimits coreSizeLimitSoft coreSizeLimitHard) , (ResourceCPUTime, ResourceLimits cpuTimeLimitSoft cpuTimeLimitHard)] diff --git a/README b/README --- a/README +++ b/README @@ -53,6 +53,13 @@ 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. If you can successfully build &install Mueval, but running it on expressions leads to errors, please send me an email at . Include in the email all the output you see if you run the informal test suite: +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. +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 . 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 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. diff --git a/build.sh b/build.sh --- a/build.sh +++ b/build.sh @@ -1,7 +1,14 @@ #!/bin/sh +# Abort if any commands aren't successful +set -e # Build -(runhaskell Setup configure --user && runhaskell Setup build && 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 && echo "\n...Rerun the tests with multiple threads...\n" && -sh tests.sh +RTS -N4 -RTS +sh tests.sh +RTS -N4 -RTS && +echo "\n...Rerun tests with resource limits enabled...\n" && +sh tests.sh --rlimits && +echo "\n...Done, apparently everything worked!" diff --git a/main.hs b/main.hs --- a/main.hs +++ b/main.hs @@ -4,10 +4,9 @@ -- module Main (main) where - +import Mueval.Parallel +import Mueval.ArgsParse (getOptions, Options(..)) import qualified Mueval.Context (cleanModules, unsafe) -import Mueval.ParseArgs (getOptions, Options(..)) -import Mueval.Concurrent main :: IO () main = do opts <- getOptions diff --git a/mueval.cabal b/mueval.cabal --- a/mueval.cabal +++ b/mueval.cabal @@ -1,5 +1,5 @@ name: mueval -version: 0.6.3 +version: 0.6.4 license: BSD3 license-file: LICENSE @@ -29,9 +29,10 @@ extra-source-files: build.sh, tests.sh library - exposed-modules: Mueval.Concurrent, Mueval.Context, Mueval.Interpreter, - Mueval.ParseArgs, Mueval.Resources - build-depends: base, directory, mtl, filepath, unix, hint>=0.2.4, show>=0.3, utf8-string + 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 ghc-options: -Wall -static -O2 executable mueval diff --git a/tests.sh b/tests.sh --- a/tests.sh +++ b/tests.sh @@ -10,8 +10,8 @@ echo "Test some valid expressions \n" ## Does anything work? m 'True' -## TODO: Test comments -# m 'True -- testing' +## Test comments +m 'True -- testing' m 'True {- Testing -}' ## OK, let's try some simple math. m '1*100+1' @@ -21,6 +21,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' +## Single module +m '()' --module=Prelude ## Test whether we can import multiple modules m 'join [[1]]' --module Data.List --module Control.Monad --module Data.Char m 'join ["baz"]' --module Data.List --module Data.Char --module Control.Monad