packages feed

mueval 0.4 → 0.4.5

raw patch · 8 files changed

+127/−106 lines, 8 files

Files

+ Mueval/Concurrent.hs view
@@ -0,0 +1,45 @@+module Mueval.Concurrent where++import Control.Concurrent   (forkIO, killThread, myThreadId, threadDelay, throwTo, yield, ThreadId)+import System.Posix.Signals (sigXCPU, installHandler, Handler(CatchOnce))+import Control.Exception (catchDyn, Exception(ErrorCall))+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)+import System.IO (hSetBuffering, stdout, BufferMode(NoBuffering))++import Mueval.Interpreter+import Mueval.ParseArgs++-- | Fork off a thread which will sleep and kill off another thread at some point.+watchDog :: Int -> ThreadId -> IO ()+watchDog tout tid = do installHandler sigXCPU+                                          (CatchOnce+                                           $ throwTo tid $ ErrorCall "Time limit exceeded.") Nothing+                       forkIO $ do threadDelay (tout * 1000000)+                                   -- Time's up. It's a good day to die.+                                   throwTo tid (ErrorCall "Time limit exceeded")+                                   yield -- give the other thread a chance+                                   killThread tid -- Die now, srsly.+                                   error "Time expired"+                       return () -- Never reached. Either we error out in+                                 -- watchDog, or the evaluation thread finishes.++-- | Set a watchdog on this thread, and then evaluate.+forkedMain :: Options -> IO ()+forkedMain opts = do+  -- This *should* be redundant with the previous watchDog,+  -- but maybe not.+  mvar <- newEmptyMVar++  myThreadId >>= watchDog tout++  hSetBuffering stdout NoBuffering++  -- Our modules and expression are set up. Let's do stuff.+  forkIO (interpreterSession typeprint mdls expr `catchDyn` (printInterpreterError) >> putMVar mvar "Done.")++  takeMVar mvar -- block until ErrorCall, or forkedMain succeeds+  return ()+          where mdls = modules opts+                expr = expression opts+                tout = timeLimit opts+                typeprint = printType opts
Mueval/Context.hs view
@@ -1,4 +1,4 @@-module Mueval.Context (cleanModules, defaultModules, unsafed) where+module Mueval.Context (cleanModules, defaultModules, unsafe) where  import Data.List (elem, isInfixOf) @@ -7,8 +7,8 @@    and will return many false positives (eg. unsafed "id \"unsafed\"" -> True). But it    will at least catch naive and simplistic invocations of "unsafePerformIO",    "inlinePerformIO", and "unsafeCoerce". -}-unsafed :: String -> Bool-unsafed = \z -> any (`isInfixOf` z) ["unsafe", "inlinePerform", "liftIO", "Coerce", "Foreign",+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",
Mueval/Interpreter.hs view
@@ -1,22 +1,22 @@ -- TODO: suggest the convenience functions be put into Hint proper? module Mueval.Interpreter (interpreterSession, printInterpreterError, ModuleName) where +import Control.Monad.Trans (liftIO)+import qualified Control.Exception (catch)+ import Language.Haskell.Interpreter.GHC (eval, newSession, reset, setImports,                                          setOptimizations, setUseLanguageExtensions, setInstalledModsAreInScopeQualified,                                                          typeChecks, typeOf, withSession,                                          Interpreter, InterpreterError, ModuleName, Optimizations(All)) -import Control.Monad.Trans (liftIO)-import System.Exit (exitWith, ExitCode(ExitFailure))- import qualified Mueval.Resources (limitResources) + say :: String -> Interpreter () say = liftIO . putStr . take 1024  printInterpreterError :: InterpreterError -> IO ()-printInterpreterError e = do putStrLn $ take 1024 $ "Oops... " ++ (show e)-                             (exitWith $ ExitFailure 1)+printInterpreterError = error . take 1024 . ("Oops... " ++) . show  interpreter :: Bool -> [ModuleName] -> String -> Interpreter () interpreter prt modules expr = do@@ -36,7 +36,9 @@                                                else return ()                                               result <- eval expr                                               say $ show result ++ "\n"-                                    else error "Expression does not type check."+                                    else error "Expression did not type check."  interpreterSession :: Bool -> [ModuleName] -> String -> IO ()-interpreterSession prt mds expr = newSession >>= (flip withSession) (interpreter prt mds expr)+interpreterSession prt mds expr = Control.Exception.catch+                                  (newSession >>= (flip withSession) (interpreter prt mds expr))+                                  (\_ -> error "Expression did not compile.")
Mueval/ParseArgs.hs view
@@ -1,6 +1,7 @@-module Mueval.ParseArgs (Options(..), interpreterOpts) where+module Mueval.ParseArgs (Options(..), interpreterOpts, getOptions) where  import System.Console.GetOpt+import System.Environment (getArgs)  import Mueval.Context (defaultModules) @@ -42,3 +43,9 @@           (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.+getOptions :: IO Options+getOptions = do input <- getArgs+                (opts,_) <- interpreterOpts $ input+                return opts
+ main.hs view
@@ -0,0 +1,25 @@+-- TODO:+-- Need to add user switching. Perhaps using seteuid and setegid? See+-- <http://www.opengroup.org/onlinepubs/009695399/functions/seteuid.html> &+-- <http://www.opengroup.org/onlinepubs/009695399/functions/setegid.html>+module Main (main) where+++import qualified Mueval.Context (cleanModules, unsafe)+import Mueval.ParseArgs (getOptions, Options(..))+import Mueval.Concurrent++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."+
mueval.cabal view
@@ -1,5 +1,5 @@ name:                mueval-version:             0.4+version:             0.4.5  license:             BSD3 license-file:        LICENSE@@ -26,12 +26,12 @@ Extra-source-files:  build.sh, tests.sh  Library-        exposed-modules:     Mueval.Context, Mueval.Interpreter,+        exposed-modules:     Mueval.Concurrent, Mueval.Context, Mueval.Interpreter,                              Mueval.ParseArgs, Mueval.Resources         build-Depends:       base, directory, mtl, unix, hint>=0.2.3, show         ghc-options:         -Wall -static  Executable mueval-           main-is:       mueval.hs+           main-is:       main.hs            build-depends: base            ghc-options:   -Wall -threaded -static
− mueval.hs 
@@ -1,63 +0,0 @@--- TODO: Currently we usually exit successfully even when there was a--- problem. Need to sort out the exit code business.--- Need to add user switching. Perhaps using seteuid and setegid? See--- <http://www.opengroup.org/onlinepubs/009695399/functions/seteuid.html> &--- <http://www.opengroup.org/onlinepubs/009695399/functions/setegid.html>-module Main (main) where--import Control.Concurrent   (forkIO, killThread, myThreadId, threadDelay, throwTo, yield, 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, unsafed)-import Mueval.Interpreter-import Mueval.ParseArgs--main :: IO ()-main = do input <- getArgs-          (opts,_) <- interpreterOpts input-          if (Mueval.Context.cleanModules $ modules opts) then do-              if (not $ Mueval.Context.unsafed $ expression opts) then do-                                               mvar <- newEmptyMVar--                                               myThreadId >>= watchDog (timeLimit opts)--                                               forkIO $ forkedMain (mvar) opts-                                               takeMVar mvar -- block until a ErrorCall or the forkedMain succeeds--                                               return ()-               else error "Unsafe functions to use mentioned."-           else error "Unknown or untrusted module supplied! Aborting."---- Set a watchdog, and then evaluate.-forkedMain :: MVar [Char] -> Options -> IO ()-forkedMain mvar opts = do-  -- This *should* be redundant with the previous watchDog,-  -- but maybe not.--  myThreadId >>= watchDog tout--  hSetBuffering stdout NoBuffering--  -- Our modules and expression are set up. Let's do stuff.-  interpreterSession typeprint mdls expr `catchDyn` (printInterpreterError)-  putMVar mvar "Done."-          where mdls = modules opts-                expr = expression opts-                tout = timeLimit opts-                typeprint = printType opts---- | Fork off a thread which will sleep and kill off another thread at some point.-watchDog :: Int -> ThreadId -> IO ()-watchDog tout tid = do installHandler sigXCPU-                                          (CatchOnce-                                           $ throwTo tid $ ErrorCall "Time limit exceeded.") Nothing-                       forkIO $ do threadDelay (tout * 1000000)-                                   -- Time's up. It's a good day to die.-                                   throwTo tid (ErrorCall "Time limit exceeded")-                                   yield -- give the other thread a chance-                                   killThread tid -- Die now, srsly.-                       return ()
tests.sh view
@@ -2,48 +2,53 @@ # tests  # Save typing-alias mu='mueval "$@"'+m () { mueval --expression "$@"; }+# Redefine a failed command to be successful+mf () { m "$@" || return 0; } -# Test on valid expressions-echo "Test some valid expressions\n"+# Abort if any commands aren't successful+set -e+# Test on valid expressions. Note we conditionalize - all of these should return successfully.+echo "Test some valid expressions \n" ## Does anything work?-mu --expression '1*100+1'+m '1*100+1' ## OK, let's try some simple math.-mu --module Control.Monad --expression '(1*100) +1+1'+m '(1*100) +1+1' --module Control.Monad ## String processing-mu --expression "filter (\`notElem\` ['A'..'Z']) \"abcXsdzWEE\""+m "filter (\`notElem\` ['A'..'Z']) \"abcXsdzWEE\"" ## see whether we gave it enough resources to do reasonably long stuff-mu --expression "(last \"nebbish\") : (head $ reverse \"fooo bar baz booooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooreally long strong, you must confess, at least relative to the usual string, I suppose\") : []"-mu --expression 'let return a k = k a ; m >>= f = m . flip f ; foldM f z [] = return z ; foldM f z (x:xs) = f z x >>= \fzx -> foldM f fzx xs ; control e k = e (\a -> const (k a)) id in foldM (\p n -> if n == 0 then control (const $ return 0) else return (p * n)) 1 [-10..] id'+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' ## 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"'+m 'join [[1]]' --module Data.List --module Control.Monad --module Data.Char+m 'join ["baz"]' --module Data.List --module Data.Char --module Control.Monad+m 'map toUpper "foobar"' --module Data.List --module Data.Char --module Control.Monad+m 'tail $ take 50 $ repeat "foo"' --module Data.List --timelimit 3 ## 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])'+m '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 on bad or outright evil expressions+echo "\n Now 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'+mf 'let x = x in x'+mf 'let x y = x 1 in x 1' --timelimit 3+mf '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'+mf 'let f :: Int -> Int; f x = f $! (x+1) in f 0' ## test stack limits-mu --expression 'let x = 1 + x in x'+mf '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'+mf 'let {p x y f = f x y; f x = p x x} in f (f (f (f (f (f (f (f (f (f (f (f (f (f (f (f (f (f (f f)))))))))))))))))) f' ## Now let's test the module whitelisting-mu --module Data.List --module System.IO.Unsafe --module Control.Monad --expression 1+1-mu --module System.IO.Unsafe --expression "let foo = unsafePerformIO readFile \"/etc/passwd\" in foo"-mu --module Data.List --module Text.HTML.Download --expression "head [1..]"+mf 1+1 --module Data.List --module System.IO.Unsafe --module Control.Monad+mf "let foo = unsafePerformIO readFile \"/etc/passwd\" in foo" --module System.IO.Unsafe+mf "head [1..]" --module Data.List --module Text.HTML.Download ### Can we bypass the whitelisting by fully qualified module names?-mu --expression "Foreign.unsafePerformIO $ readFile \"/etc/passwd\""-mu --expression "Data.ByteString.Internal.inlinePerformIO $ readFile \"/etc/passwd\""+mf "Foreign.unsafePerformIO $ readFile \"/etc/passwd\""+mf "Data.ByteString.Internal.inlinePerformIO $ readFile \"/etc/passwd\"" ## 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\""+mf "let foo = readFile \"/etc/passwd\" >>= print in foo"+mf "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')]"+mf  "array (0::Int, maxBound) [(1000000,'x')]" --module Data.Array+echo "Done, apparently successfully"