SunRed/myriad
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Clean up code

Browse source
This commit is contained in:
1computer1 2019-07-12 04:01:18 -04:00
parent 08a1f272c6
commit 176a78b557
3 changed files with 142 additions and 113 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

214
src/Myriad/Docker.hs
View file

@ -5,43 +5,41 @@ module Myriad.Docker
, startCleanup
, setupContainer
, killContainer
, killAllContainers
, killContainerMaybe
, killAllContainersMaybe
, killContainers
, evalCode
) where
import Control.Monad.Logger
import Control.Monad.Reader
import qualified Data.Map.Strict as M
import Data.Snowflake
import Control.Concurrent.Async.Lifted
import Control.Concurrent.Lifted (fork, threadDelay)
import Control.Concurrent.MVar.Lifted
import Control.Concurrent.QSem.Lifted
import Control.Exception.Lifted
import Data.Snowflake
import System.Process.Typed
import Myriad.Core
import Myriad.Util
exec :: String -> MyriadIO ()
exec = runProcess_ . shell
buildImage :: LanguageConfig -> MyriadIO ()
buildImage lang@LanguageConfig { name, concurrent } = do
logInfoN $ mconcat ["Building image ", cvs $ imageName lang]
let cmd = mconcat ["docker build -t ", imageName lang, " ./languages/", cvs name]
runProcess_ . setStdout nullStream $ shell cmd
logInfoN $ mconcat ["Built image ", cvs $ imageName lang]
Env { config = MyriadConfig { prepareContainers }, containerSems, evalSems } <- ask
csem <- newQSem 1 -- We only want one container to be set up at a time
esem <- newQSem $ fromIntegral concurrent
modifyMVar_ containerSems $ pure . M.insert name csem
modifyMVar_ evalSems $ pure . M.insert name esem
logInfo ["Building image ", cvs $ imageName lang]
exec_ ["docker build -t ", imageName lang, " ./languages/", cvs name]
setupQSems
logInfo ["Built image ", cvs $ imageName lang]
MyriadConfig { prepareContainers } <- asks config
when_ prepareContainers $ setupContainer lang
where
setupQSems :: MyriadIO ()
setupQSems = do
Env { containerSems, evalSems } <- ask
csem <- newQSem 1 -- We only want one container to be set up at a time
esem <- newQSem $ fromIntegral concurrent
mapMVar containerSems $ M.insert name csem
mapMVar evalSems $ M.insert name esem
buildAllImages :: MyriadIO ()
buildAllImages = do
@ -60,126 +58,128 @@ startCleanup = do
timer :: Int -> MyriadIO ()
timer t = forever do
threadDelay t
n <- killAllContainersMaybe
logInfoN $ mconcat ["Cleaned up ", cvs $ show n, " containers"]
n <- killContainers
logInfo ["Cleaned up ", cvs $ show n, " containers"]
timer t
setupContainer :: LanguageConfig -> MyriadIO ContainerName
setupContainer lang@LanguageConfig { name, memory, cpus } = do
ref <- asks containers
cnts <- readMVar ref
cnts <- asks containers >>= readMVar
case cnts M.!? name of
Just x -> pure x
Nothing -> do
Nothing -> setup
Just cnt -> pure cnt
where
setup :: MyriadIO ContainerName
setup = do
ref <- asks containers
cnt <- newContainerName lang
let cmd = mconcat
[ "docker run --rm --name="
, cvs cnt
-- User 1000 will be for setting up the environment
, " -u1000:1000 -w/tmp/ -dt --net=none --cpus="
, cvs cpus
, " -m="
, cvs memory
, " --memory-swap="
, cvs memory
, " "
, imageName lang
, " /bin/sh"
]
runProcess_ . setStdout nullStream $ shell cmd
exec_
[ "docker run --rm --name="
, cvs cnt
-- User 1000 will be for setting up the environment
, " -u1000:1000 -w/tmp/ -dt --net=none --cpus="
, cvs cpus
, " -m="
, cvs memory
, " --memory-swap="
, cvs memory
, " "
, imageName lang
, " /bin/sh"
]
-- The `eval` directory is where all the eval work is done
-- 711 so that users can't traverse into other people's code
exec $ mconcat ["docker exec ", cnt, " mkdir eval"]
exec $ mconcat ["docker exec ", cnt, " chmod 711 eval"]
modifyMVar_ ref $ pure . M.insert name cnt
logInfoN $ mconcat ["Started container ", cvs cnt]
exec_ ["docker exec ", cnt, " mkdir eval"]
exec_ ["docker exec ", cnt, " chmod 711 eval"]
mapMVar ref $ M.insert name cnt
logInfo ["Started container ", cvs cnt]
pure cnt
killContainer :: Language -> MyriadIO ()
killContainer :: Language -> MyriadIO Bool
killContainer lang = do
ref <- asks containers
containers <- readMVar ref
case containers M.!? lang of
Nothing -> pure ()
Just cnt -> do
modifyMVar_ ref $ pure . M.delete lang
let cmd = mconcat ["docker kill ", cnt]
runProcess_ . setStderr nullStream . setStdout nullStream $ shell cmd
logInfoN $ mconcat ["Killed container ", cvs cnt]
killContainerMaybe :: Language -> MyriadIO Bool
killContainerMaybe lang = do
containers <- asks containers >>= readMVar
case containers M.!? lang of
Nothing -> pure False
Just cnt -> do
res <- try @_ @SomeException $ killContainer lang
res <- kill cnt
case res of
Left err -> do
logErrorN $ mconcat ["An exception occured when killing ", cvs cnt, ":\n", cvs $ show err]
Nothing -> pure True
Just err -> do
logError ["An exception occured when killing ", cvs cnt, ":\n", cvs $ show err]
pure False
Right _ -> pure True
where
kill :: ContainerName -> MyriadIO (Maybe SomeException)
kill cnt = do
ref <- asks containers
mapMVar ref $ M.delete lang
res <- try $ exec_ ["docker kill ", cnt]
case res of
Left err -> pure $ Just err
Right _ -> do
logInfo ["Killed container ", cvs cnt]
pure Nothing
killAllContainers :: MyriadIO ()
killAllContainers = do
killContainers :: MyriadIO [ContainerName]
killContainers = do
containers <- asks containers >>= readMVar
forConcurrently_ (M.keys containers) $ killContainer
killAllContainersMaybe :: MyriadIO [ContainerName]
killAllContainersMaybe = do
containers <- asks containers >>= readMVar
xs <- forConcurrently (M.toList containers) \(k, v) -> (v,) <$> killContainerMaybe k
xs <- forConcurrently (M.toList containers) \(k, v) -> (v,) <$> killContainer k
pure . map fst $ filter snd xs
evalCode :: LanguageConfig -> Int -> String -> MyriadIO EvalResult
evalCode lang@LanguageConfig { name, timeout, retries } numRetries code = do
Env { containerSems, evalSems } <- ask
csem <- (M.! name) <$> readMVar containerSems
esem <- (M.! name) <$> readMVar evalSems
bracket_ (waitQSem esem) (signalQSem esem) $ do
cnt <- bracket_ (waitQSem csem) (signalQSem csem) $ setupContainer lang
doneRef <- newMVar False -- For keeping track of if the evaluation is done, i.e. succeeded or timed out.
void . fork $ timer doneRef -- `race` could not have been used here since some evals can't be cancelled.
res <- try $ eval cnt
case res of
Left (SomeException err) -> do
void $ killContainerMaybe name
done <- readMVar doneRef
if done
-- If we find the eval is done from an exception, then it was timed out.
then do
logInfoN $ mconcat ["Code timed out in container ", cvs cnt]
pure EvalTimedOut
-- Otherwise, the container was killed from another eval, so we should retry.
else do
modifyMVar_ doneRef $ pure . const True
if numRetries < fromIntegral retries
then evalCode lang (numRetries + 1) code
else do
logErrorN $ mconcat ["An exception occured when evaluating in ", cvs cnt, ":\n", cvs $ show err]
pure EvalErrored
Right x -> do
modifyMVar_ doneRef $ pure . const True
pure x
evalCode lang@LanguageConfig { name, timeout, retries } numRetries code = withContainer \cnt -> do
doneRef <- newMVar False -- For keeping track of if the evaluation is done, i.e. succeeded or timed out.
void . fork $ timer doneRef -- `race` could not have been used here since some evals can't be cancelled.
snowflakeGen <- asks snowflakeGen
snowflake <- liftIO $ nextSnowflake snowflakeGen
res <- try $ eval cnt snowflake
case res of
Left (SomeException err) -> do
void $ killContainer name
done <- readMVar doneRef
if done
-- If we find the eval is done from an exception, then it was timed out.
then do
logError ["Code timed out in container ", cvs cnt, ", evaluation ", cvs $ show snowflake]
pure EvalTimedOut
-- Otherwise, the container was killed from another eval, so we should retry.
else do
writeMVar doneRef True
if numRetries < fromIntegral retries
then do
logError ["An exception occured in ", cvs cnt, ", evaluation ", cvs $ show snowflake, ", retrying:\n", cvs $ show err]
evalCode lang (numRetries + 1) code
else do
logError ["An exception occured in ", cvs cnt, ", evaluation ", cvs $ show snowflake, ":\n", cvs $ show err]
pure EvalErrored
Right x -> do
writeMVar doneRef True
pure x
where
withContainer :: (ContainerName -> MyriadIO a) -> MyriadIO a
withContainer f = do
Env { containerSems, evalSems } <- ask
csem <- (M.! name) <$> readMVar containerSems
esem <- (M.! name) <$> readMVar evalSems
bracket_ (waitQSem esem) (signalQSem esem) do
cnt <- bracket_ (waitQSem csem) (signalQSem csem) $ setupContainer lang
f cnt
timer :: MVar Bool -> MyriadIO ()
timer doneRef = do
threadDelay $ fromIntegral timeout * 1000000
done <- readMVar doneRef
unless_ done do
modifyMVar_ doneRef $ pure . const True
killContainerMaybe name
writeMVar doneRef True
killContainer name
eval :: ContainerName -> MyriadIO EvalResult
eval cnt = do
logInfoN $ mconcat ["Running code in container ", cvs cnt, ":\n", cvs code]
snowflakeGen <- asks snowflakeGen
snowflake <- liftIO $ nextSnowflake snowflakeGen
exec $ mconcat ["docker exec ", cvs cnt, " mkdir eval/", show snowflake]
exec $ mconcat ["docker exec ", cvs cnt, " chmod 777 eval/", show snowflake]
eval :: ContainerName -> Snowflake -> MyriadIO EvalResult
eval cnt snowflake = do
logInfo ["Running code in container ", cvs cnt, ", evaluation ", cvs $ show snowflake, ":\n", cvs code]
exec_ ["docker exec ", cvs cnt, " mkdir eval/", show snowflake]
exec_ ["docker exec ", cvs cnt, " chmod 777 eval/", show snowflake]
-- User 1001 will be used for the actual execution so that they can't access `eval` itself
let args = ["exec", "-u1001:1001", "-w/tmp/eval/" <> show snowflake, cnt, "/bin/sh", "/var/run/run.sh", code]
output <- readProcessInterleaved_ $ proc "docker" args
exec $ mconcat ["docker exec ", cnt, " rm -rf eval/", show snowflake]
logInfoN $ mconcat ["Ran code in container ", cvs cnt]
exec_ ["docker exec ", cnt, " rm -rf eval/", show snowflake]
logInfo ["Ran code in container ", cvs cnt, ", evaluation ", cvs $ show snowflake]
pure $ EvalOk output

11
src/Myriad/Server.hs
View file

@ -5,7 +5,6 @@ module Myriad.Server
) where
import Control.Monad.Except
import Control.Monad.Logger
import Control.Monad.Reader
import Data.Aeson
@ -42,13 +41,13 @@ serverT = handleLanguages :<|> handleEval :<|> handleContainers :<|> handleClean
where
handleLanguages :: MyriadT m [T.Text]
handleLanguages = do
logInfoN $ mconcat ["GET /languages"]
logInfo ["GET /languages"]
MyriadConfig { languages } <- asks config
pure . map name $ languages
handleEval :: EvalRequest -> MyriadT m EvalResponse
handleEval EvalRequest { language, code } = do
logInfoN $ mconcat ["POST /eval"]
logInfo ["POST /eval"]
MyriadConfig { languages } <- asks config
case find (\x -> name x == language) languages of
Nothing -> throwError $ err404 { errBody = "Language " <> cvs language <> " was not found" }
@ -61,11 +60,11 @@ serverT = handleLanguages :<|> handleEval :<|> handleContainers :<|> handleClean
handleContainers :: MyriadT m [T.Text]
handleContainers = do
logInfoN $ mconcat ["GET /containers"]
logInfo ["GET /containers"]
containers <- asks containers >>= readMVar
pure . map cvs $ M.elems containers
handleCleanup :: MyriadT m [T.Text]
handleCleanup = do
logInfoN $ mconcat ["POST /cleanup"]
map cvs <$> killAllContainersMaybe
logInfo ["POST /cleanup"]
map cvs <$> killContainers

30
src/Myriad/Util.hs
View file

@ -4,12 +4,24 @@ module Myriad.Util
, cvs
, when_
, unless_
, exec
, exec_
, logInfo
, logError
, mapMVar
, writeMVar
) where
import qualified Control.Monad.Logger as L
import Control.Monad.Reader
import qualified Data.ByteString.Lazy as BL
import Data.Snowflake
import Data.String.Conversions
import qualified Data.Text as T
import Control.Concurrent.MVar.Lifted
import System.Process.Typed
import Myriad.Core
@ -31,3 +43,21 @@ when_ p = when p . void
unless_ :: Applicative f => Bool -> f a -> f ()
unless_ p = unless p . void
exec :: [String] -> MyriadIO BL.ByteString
exec = readProcessInterleaved_ . shell . mconcat
exec_ :: [String] -> MyriadIO ()
exec_ = void . exec
logInfo :: [T.Text] -> MyriadIO ()
logInfo = L.logInfoN . mconcat
logError :: [T.Text] -> MyriadIO ()
logError = L.logErrorN . mconcat
mapMVar :: MVar a -> (a -> a) -> MyriadIO ()
mapMVar var f = modifyMVar_ var (pure . f)
writeMVar :: MVar a -> a -> MyriadIO ()
writeMVar var x = mapMVar var $ const x