{-# LANGUAGE DeriveDataTypeable #-}
module MyInterpret
( simpleInterpret
, simpleTypeOf
, catchInterpreterErrors
)
where
import Language.Haskell.Interpreter
import Language.Haskell.Interpreter.Unsafe
import Prelude hiding (catch)
import Control.Concurrent
import Control.Exception
import Control.Monad
import Control.Monad.Error
import System.Posix.Signals
import Data.Typeable (Typeable)
import Data.List
import Data.Either
-- Scoped modules
defaultModules = [ "Prelude",
"Data.List"
]
data MyException = MyException String deriving (Show,Typeable)
instance Exception MyException
timeoutIO action = bracket
(do mainId <- myThreadId
installHandler sigXCPU (CatchOnce $ throwTo mainId $ MyException "Time limit exceeded.") Nothing
forkIO $ do
threadDelay (5 * 1000 * 1000)
-- Time's up. It's a good day to die.
throwTo mainId (MyException "Time limit exceeded")
{- why do we need that here?
- yield -- give the other thread a chance
putStrLn "Killing main thread..."
killThread mainId -- Die now, srsly.
error "Time expired"
-}
)
(killThread)
(\_ -> do
mainId <- myThreadId
mvar <- newEmptyMVar
forkIO $ (action >>= putMVar mvar) `catch`
(\e -> throwTo mainId (e::SomeException))
ret <- takeMVar mvar
evaluate (length ret) -- make sure exceptions are handled here
return ret
)
myInterpreter :: [String] -> [String] -> (String -> InterpreterT IO [a]) -> String -> IO [a]
myInterpreter mods imports todo exp = timeoutIO $ do
when (unsafe exp) $ throw (MyException "Indicators for unsafe computations found in exp")
eResult <- runInterpreter $ do
set [languageExtensions := []]
-- Not available in hint-3.2?
-- setOptimizations All
reset
if null mods
then do -- no need for temporary files I hope. Used by bff
set [installedModulesInScope := True ]
setImports defaultModules
else do -- Only these modules in scope. No Prelude either!
loadModules mods
set [installedModulesInScope := False ]
setImports imports
unsafeSetGhcOption "-fno-monomorphism-restriction"
unsafeSetGhcOption "-fno-warn-warnings-deprecations"
--liftIO $ putStrLn exp --this makes it impossible to run at www-ps.uni-bonn.de
ret <- todo exp
-- Hopefully removes temporary files
reset
return ret
case eResult of
Left exception -> throw exception
Right result -> return result
formatInterpreterError :: InterpreterError -> [Char]
formatInterpreterError (UnknownError s) = "Unknown Interpreter Error:\n" ++ s
formatInterpreterError (WontCompile es) = "Could not compile code:\n" ++ unlines (map errMsg es)
formatInterpreterError (NotAllowed s) = "Not allowed here " ++ s
formatInterpreterError (GhcException e) = "GHC Exception"
{- | 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"]
catchInterpreterErrors :: IO a -> IO (Either String a)
catchInterpreterErrors action =
flip catch (return . Left . formatInterpreterError) $
flip catch (\(MyException s) -> return (Left s)) $
flip catch (\(ErrorCall s) -> return (Left s)) $
Right `fmap` action
simpleInterpret :: [String] -> [String] -> String -> String -> IO String
simpleInterpret mods imports defs what =
myInterpreter mods imports eval $
"let \n" ++
unlines (map (replicate 12 ' '++) (lines defs)) ++
replicate 8 ' ' ++ "in " ++ what
simpleTypeOf :: [String] -> [String] -> String -> String -> IO String
simpleTypeOf mods imports defs what =
myInterpreter mods imports typeOf $
"let \n" ++
unlines (map (replicate 12 ' '++) (lines defs)) ++
replicate 8 ' ' ++ "in " ++ what