diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/Mueval/Context.hs b/Mueval/Context.hs new file mode 100644 --- /dev/null +++ b/Mueval/Context.hs @@ -0,0 +1,86 @@ +module Mueval.Context (cleanModules, defaultModules) where + +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) + +{- | Modules which we should load by default. These are of course whitelisted. + Specifically, we want the Prelude because otherwise things are horribly + crippled; we want SimpleReflect so we can do neat things (for said neat + things, see + ); + and we want ShowQ and ShowFun to neuter IO stuff even more. -} +defaultModules :: [String] +defaultModules = ["Prelude", "ShowQ", "ShowFun", "SimpleReflect"] + +-- | Borrowed from Lambdabot, this is the whitelist of modules which should be +-- safe to import functions from. +safeModules :: [String] +safeModules = defaultModules ++ ["Control.Applicative", + "Control.Arrow", + "Control.Arrow.Operations", + "Control.Arrow.Transformer", + "Control.Arrow.Transformer.All", + "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.ByteString", + "Data.ByteString.Char8", + "Data.ByteString.Lazy", + "Data.ByteString.Lazy.Char8", + "Data.Char", + "Data.Complex", + "Data.Dynamic", + "Data.Either", + "Data.Eq", + "Data.Fixed", + "Data.Foldable", + "Data.Function", + "Data.Generics", + "Data.Generics", + "Data.Graph", + "Data.Int", + "Data.IntMap", + "Data.IntSet", + "Data.Ix", + "Data.List", + "Data.Map", + "Data.Maybe", + "Data.Monoid", + "Data.Number.BigFloat", + "Data.Number.CReal", + "Data.Number.Dif", + "Data.Number.Fixed", + "Data.Number.Interval", + "Data.Number.Natural", + "Data.Number.Symbolic", + "Data.Ord", + "Data.Ratio", + "Data.Sequence", + "Data.Set", + "Data.Traversable", + "Data.Tree", + "Data.Tuple", + "Data.Typeable", + "Data.Word", + "Math.OEIS", + "System.Random", + "Test.QuickCheck", + "Text.PrettyPrint.HughesPJ", + "Text.Printf"] diff --git a/Mueval/Interpreter.hs b/Mueval/Interpreter.hs new file mode 100644 --- /dev/null +++ b/Mueval/Interpreter.hs @@ -0,0 +1,32 @@ +-- TODO: suggest the convenience functions be put into Hint proper? +module Mueval.Interpreter (interpreterSession, printInterpreterError, ModuleName) where + +import Language.Haskell.Interpreter.GHC (eval, newSession, reset, setImports, + setUseLanguageExtensions, typeChecks, + typeOf, withSession, + Interpreter, InterpreterError, ModuleName) + +import Control.Monad.Trans (liftIO) +import System.Exit (exitWith, ExitCode(ExitFailure)) + +say :: String -> Interpreter () +say = liftIO . putStr . take 1024 + +printInterpreterError :: InterpreterError -> IO () +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." + +interpreterSession :: [ModuleName] -> String -> IO () +interpreterSession mds expr = newSession >>= (flip withSession) (interpreter mds expr) diff --git a/Mueval/ParseArgs.hs b/Mueval/ParseArgs.hs new file mode 100644 --- /dev/null +++ b/Mueval/ParseArgs.hs @@ -0,0 +1,39 @@ +module Mueval.ParseArgs (Options(..), interpreterOpts) where + +import System.Console.GetOpt + +import Mueval.Context (defaultModules) + +data Options = Options + { timeLimit :: Int + , modules :: [String] + , expression :: String + , user :: String + } deriving Show + +defaultOptions :: Options +defaultOptions = Options { expression = "" + , modules = defaultModules + , timeLimit = 5 + , user = "" } + +options :: [OptDescr (Options -> Options)] +options = [Option ['p'] ["password"] + (ReqArg (\u opts -> opts {user = u}) "PASS") + "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 ['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 ['e'] ["expression"] + (ReqArg (\e opts -> opts { expression = e}) "EXPR") + "The expression to be evaluated." ] + +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..." diff --git a/Mueval/Resources.hs b/Mueval/Resources.hs new file mode 100644 --- /dev/null +++ b/Mueval/Resources.hs @@ -0,0 +1,56 @@ +module Mueval.Resources (limitResources) where + +import Control.Monad (zipWithM_) +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, rlimits, and "cd". +limitResources :: IO () +limitResources = do setCurrentDirectory "/tmp" -- will at least mess up relative links + nice 19 -- Set our process priority way down + zipWithM_ (setResourceLimit) resources limits + +-- | Set all the available rlimits. +-- These values have been determined through trial-and-error +totalMemoryLimitSoft, totalMemoryLimitHard, stackSizeLimitSoft, stackSizeLimitHard, + openFilesLimitSoft, openFilesLimitHard, fileSizeLimitSoft, fileSizeLimitHard, dataSizeLimitSoft, + dataSizeLimitHard, cpuTimeLimitSoft, cpuTimeLimitHard, coreSizeLimitSoft, coreSizeLimitHard, zero :: ResourceLimit +totalMemoryLimitSoft = dataSizeLimitSoft +totalMemoryLimitHard = dataSizeLimitHard +-- These limits seem to be useless +stackSizeLimitSoft = zero +stackSizeLimitHard = zero +-- We allow one file to be opened, package.conf, because it is necessary. This +-- doesn't seem to be security problem because it'll be opened at the module +-- stage, before code ever evaluates. +openFilesLimitSoft = openFilesLimitHard +openFilesLimitHard = ResourceLimit 7 +fileSizeLimitSoft = fileSizeLimitHard +fileSizeLimitHard = zero +dataSizeLimitSoft = dataSizeLimitHard +dataSizeLimitHard = ResourceLimit $ 10^(8::Int) +-- These should not be identical, to give the XCPU handler time to trigger +cpuTimeLimitSoft = ResourceLimit 3 +cpuTimeLimitHard = ResourceLimit 4 +coreSizeLimitSoft = coreSizeLimitHard +coreSizeLimitHard = zero +zero = ResourceLimit 0 + +resources :: [Resource] +resources = [ResourceStackSize, + ResourceTotalMemory, + ResourceOpenFiles, + ResourceFileSize, + ResourceDataSize, + ResourceCoreFileSize, + ResourceCPUTime] +limits :: [ResourceLimits] +limits = [ (ResourceLimits stackSizeLimitSoft stackSizeLimitHard) + , (ResourceLimits totalMemoryLimitSoft totalMemoryLimitHard) + , (ResourceLimits openFilesLimitSoft openFilesLimitHard) + , (ResourceLimits fileSizeLimitSoft fileSizeLimitHard) + , (ResourceLimits dataSizeLimitSoft dataSizeLimitHard) + , (ResourceLimits coreSizeLimitSoft coreSizeLimitHard) + , (ResourceLimits cpuTimeLimitSoft cpuTimeLimitHard)] diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,5 @@ +#!/usr/bin/runhaskell + +import Distribution.Simple + +main = defaultMainWithHooks simpleUserHooks diff --git a/build.sh b/build.sh new file mode 100644 --- /dev/null +++ b/build.sh @@ -0,0 +1,7 @@ +#!/bin/sh +# Build +runhaskell Setup configure --user && runhaskell Setup build && runhaskell Setup install || exit +echo "\n...Single-threaded tests....\n" +./tests.sh +echo "\n...Rerun the tests with multiple threads...\n" +./tests.sh "+RTS -N4 -RTS" diff --git a/mueval.cabal b/mueval.cabal new file mode 100644 --- /dev/null +++ b/mueval.cabal @@ -0,0 +1,34 @@ +name: mueval +version: 0.2 + +license: BSD3 +license-file: LICENSE +author: Gwern +maintainer: Gwern + +category: Development, Language +synopsis: Safely evaluate Haskell expressions +description: Mueval is a Haskell interpreter. It + uses the GHC API to evaluate arbitrary Haskell + expressions. Importantly, mueval takes many precautions + to avoid 'evil' code. It uses resource limits, whitelisted modules, + special Show instances for IO, threads, changes of directory, and so + on to sandbox the Haskell code. (It is much like Lambdabot's famous + evaluation functionality.) + . + Mueval is POSIX-only. +build-type: Simple +Cabal-Version: >= 1.2 +Tested-with: GHC==6.8.2 + +Extra-source-files: build.sh, tests.sh + +Library + exposed-modules: Mueval.Context, Mueval.Interpreter, + Mueval.ParseArgs, Mueval.Resources + build-Depends: base, directory, mtl, unix, hint>0.2 + ghc-options: -Wall + +Executable mueval + main-is: mueval.hs + build-depends: base diff --git a/mueval.hs b/mueval.hs new file mode 100644 --- /dev/null +++ b/mueval.hs @@ -0,0 +1,52 @@ +-- 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. +module Main (main) where + +import Control.Concurrent (forkIO, myThreadId, threadDelay, throwTo, ThreadId) +import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar, MVar) +import Control.Exception (catchDyn, Exception(ErrorCall)) +import System.Environment (getArgs) +import System.IO (hSetBuffering, stdout, BufferMode(NoBuffering)) +import System.Posix.Signals (sigXCPU, installHandler, Handler(CatchOnce)) + +import qualified Mueval.Context (cleanModules) +import Mueval.Interpreter +import Mueval.ParseArgs +import qualified Mueval.Resources (limitResources) + +main :: IO () +main = do input <- getArgs + (a,_) <- interpreterOpts input + if (Mueval.Context.cleanModules $ modules a) then do + mvar <- newEmptyMVar + + Mueval.Resources.limitResources + myThreadId >>= watchDog a + + forkIO $ forkedMain (mvar) a (modules a) (expression a) + 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 + -- 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) + putMVar mvar "Done." + +-- | 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") + return () diff --git a/tests.sh b/tests.sh new file mode 100644 --- /dev/null +++ b/tests.sh @@ -0,0 +1,44 @@ +#!/bin/sh +# tests + +# Save typing +alias mu='mueval "$1"' + +# Test on valid expressions +echo "Test some valid expressions\n" +## Does anything work? +mu --expression '1*100+1' +## OK, let's try some simple math. +mu --module Control.Monad --expression '(1*100) +1+1' +## String processing +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\") : []" +## 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"]' +mu --module Data.List --module Data.Char --module Control.Monad --expression 'map toUpper "foobar"' +mu --module Data.List --timelimit 3 --expression 'tail $ take 50 $ repeat "foo"' +## This tests whether the SimpleReflect stuff is working. Output should be: "(f 1 (f 2 (f 3 (f 4 (f 5 z)))))\" +mu --expression 'foldr (\x y -> concat ["(f ",x," ",y,")"]) "z" (map show [1..5])' + +# Test on bad/evil expressions +echo "\nNow let's test various misbehaved expressions\n" +## test infinite loop +mu --expression 'let x = x in x' +mu --timelimit 3 --expression 'let x y = x 1 in x 1' +mu --expression 'let x = x + 1 in x' +## Similarly, but with a strict twist +mu --expression 'let f :: Int -> Int; f x = f $! (x+1) in f 0' +## test stack limits +mu --expression 'let x = 1 + x in x' +## Let's stress the time limits +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 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" +mu --expression "writeFile \"tmp.txt\" \"foo bar\"" +## Evil array code, should fail (but not with a segfault!) +mu --module Data.Array --expression "array (0::Int, maxBound) [(1000000,'x')]"