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

log: add much more logging

This commit is contained in:
1computer1 2020-06-17 00:29:25 -04:00
parent 2597c80f3d
commit 3082f9b35e
4 changed files with 80 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/Myriad.hs
View File

@ -22,6 +22,6 @@ runMyriadServer configPath languagesDir = do
startCleanup
logInfo ["Finished Docker-related setup"]
let myriadPort = fromIntegral $ env ^. #config % #port
onReady = runStdoutLoggingT $ logInfo ["Server started on port ", cs $ show myriadPort, "!"]
onReady = runStdoutLoggingT $ logInfo ["Server started on http://localhost:", cs $ show myriadPort]
settings = setPort myriadPort . setBeforeMainLoop onReady $ defaultSettings
runSettings settings $ app env

21
src/Myriad/Core.hs
View File

@ -12,6 +12,8 @@ module Myriad.Core
, exec
, exec_
, logInfo
, logDebug
, logWarn
, logError
, mapMVar
, writeMVar
@ -19,7 +21,7 @@ module Myriad.Core
import Control.Monad.Base
import Control.Monad.Except
import Control.Monad.Logger hiding (logError, logInfo)
import Control.Monad.Logger hiding (logError, logDebug, logWarn, logInfo)
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Trans.Control
@ -28,6 +30,7 @@ import Control.Monad.Writer
import qualified Data.ByteString.Lazy as BL
import qualified Data.Map.Strict as M
import Data.Snowflake
import Data.String.Conversions
import qualified Data.Text as T
import Control.Concurrent.MVar.Lifted
@ -94,15 +97,23 @@ initEnv configPath languagesDir =
runMyriadT :: MonadIO m => Env -> MyriadT m a -> m a
runMyriadT env = runStdoutLoggingT . flip runReaderT env . unMyriadT
exec :: MonadIO m => [String] -> m BL.ByteString
exec = readProcessInterleaved_ . shell . mconcat
exec :: (MonadIO m, MonadLogger m) => [String] -> m BL.ByteString
exec args = do
logDebug ["Executing `", cs $ mconcat args, "`"]
readProcessInterleaved_ . shell $ mconcat args
exec_ :: MonadIO m => [String] -> m ()
exec_ = (() <$) . exec
exec_ :: (MonadIO m, MonadLogger m) => [String] -> m ()
exec_ = void . exec
logInfo :: MonadLogger m => [T.Text] -> m ()
logInfo = logInfoN . mconcat
logDebug :: MonadLogger m => [T.Text] -> m ()
logDebug = logDebugN . mconcat
logWarn :: MonadLogger m => [T.Text] -> m ()
logWarn = logWarnN . mconcat
logError :: MonadLogger m => [T.Text] -> m ()
logError = logErrorN . mconcat

71
src/Myriad/Docker.hs
View File

@ -58,8 +58,12 @@ buildAllImages :: Myriad ()
buildAllImages = do
config <- gview #config
if config ^. #buildConcurrently
then forConcurrently_ (config ^. #languages) buildImage
else forM_ (config ^. #languages) buildImage
then do
logInfo ["Building all images concurrently"]
forConcurrently_ (config ^. #languages) buildImage
else do
logInfo ["Building all images sequentially"]
forM_ (config ^. #languages) buildImage
startCleanup :: Myriad ()
startCleanup = do
@ -71,8 +75,9 @@ startCleanup = do
timer :: Int -> Myriad ()
timer t = forever $ do
threadDelay t
logInfo ["Starting cleanup of containers"]
n <- killContainers
logInfo ["Cleaned up ", cs $ show n, " containers"]
logInfo ["Cleaned up ", cs $ show n, " containers, next in ", cs $ show t, " seconds"]
timer t
setupContainer :: Language -> Myriad ContainerName
@ -86,6 +91,7 @@ setupContainer lang = do
setup = do
ref <- gview #containers
cnt <- newContainerName lang
logInfo ["Setting up new container ", cs cnt]
exec_
[ "docker run --rm --name="
, cs cnt
@ -105,7 +111,7 @@ setupContainer lang = do
exec_ ["docker exec ", cnt, " mkdir eval"]
exec_ ["docker exec ", cnt, " chmod 711 eval"]
mapMVar ref $ M.insert (lang ^. #name) cnt
logInfo ["Started container ", cs cnt]
logInfo ["Started new container ", cs cnt]
pure cnt
killContainer :: LanguageName -> Myriad Bool
@ -114,9 +120,12 @@ killContainer lang = do
case containers M.!? lang of
Nothing -> pure False
Just cnt -> do
logInfo ["Killing container ", cs cnt]
res <- kill cnt
case res of
Nothing -> pure True
Nothing -> do
logInfo ["Killed container ", cs cnt]
pure True
Just err -> do
logError ["An exception occured when killing ", cs cnt, ":\n", cs $ show err]
pure False
@ -128,20 +137,20 @@ killContainer lang = do
res <- try $ exec_ ["docker kill ", cnt]
case res of
Left err -> pure $ Just err
Right _ -> do
logInfo ["Killed container ", cs cnt]
pure Nothing
Right _ -> pure Nothing
killContainers :: Myriad [ContainerName]
killContainers = do
containers <- gview #containers >>= readMVar
logInfo ["Starting killing of containers"]
xs <- forConcurrently (M.toList containers) $ \(k, v) -> (v,) <$> killContainer k
logInfo ["Finished killing of containers"]
pure . map fst $ filter snd xs
evalCode :: Language -> Int -> String -> Myriad EvalResult
evalCode lang 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.
void . fork $ timer cnt doneRef -- `race` could not have been used here since some evals can't be cancelled.
snowflakeGen <- gview #snowflakeGen
snowflake <- liftIO $ nextSnowflake snowflakeGen
res <- try $ eval cnt snowflake
@ -152,17 +161,31 @@ evalCode lang numRetries code = withContainer $ \cnt -> do
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 ", cs cnt, ", evaluation ", cs $ show snowflake]
logInfo ["Code timed out in container ", cs cnt, ", evaluation ", cs $ show snowflake]
pure EvalTimedOut
-- Otherwise, the container was killed from another eval, so we should retry.
else do
writeMVar doneRef True
if numRetries < fromIntegral (lang ^. #retries)
then do
logError ["An exception occured in ", cs cnt, ", evaluation ", cs $ show snowflake, ", retrying:\n", cs $ show err]
logInfo
[ "An exception occured in "
, cs cnt
, ", evaluation "
, cs $ show snowflake
, "retrying:\n"
, cs $ show err
]
evalCode lang (numRetries + 1) code
else do
logError ["An exception occured in ", cs cnt, ", evaluation ", cs $ show snowflake, ":\n", cs $ show err]
logInfo
[ "An exception occured in "
, cs cnt
, ", evaluation "
, cs $ show snowflake
, ":\n"
, cs $ show err
]
pure EvalErrored
Right x -> do
writeMVar doneRef True
@ -177,13 +200,18 @@ evalCode lang numRetries code = withContainer $ \cnt -> do
cnt <- bracket_ (waitQSem csem) (signalQSem csem) $ setupContainer lang
f cnt
timer :: MVar Bool -> Myriad ()
timer doneRef = do
timer :: ContainerName -> MVar Bool -> Myriad ()
timer cnt doneRef = do
logDebug ["Starting timeout of ", cs . show $ lang ^. #timeout, " seconds for container ", cs cnt]
threadDelay $ fromIntegral (lang ^. #timeout) * 1000000
done <- readMVar doneRef
unless done . void $ do
writeMVar doneRef True
killContainer $ lang ^. #name
if done
then do
logDebug ["Finished timeout for container ", cs cnt, ", but container already done"]
else do
logDebug ["Finished timeout for container ", cs cnt, " and killing it"]
writeMVar doneRef True
void . killContainer $ lang ^. #name
eval :: ContainerName -> Snowflake -> Myriad EvalResult
eval cnt snowflake = do
@ -191,8 +219,15 @@ evalCode lang numRetries code = withContainer $ \cnt -> do
exec_ ["docker exec ", cs cnt, " mkdir eval/", show snowflake]
exec_ ["docker exec ", cs cnt, " chmod 777 eval/", show snowflake]
-- User 1001 will be used for the actual execution so that they can't access `eval` itself
let cmd = concat ["docker exec -i -u1001:1001 -w/tmp/eval/", show snowflake, " ", cnt, " /bin/sh /var/run/run.sh | head -c 4K"]
let cmd = mconcat
[ "docker exec -i -u1001:1001 -w/tmp/eval/"
, show snowflake
, " "
, cnt
, " /bin/sh /var/run/run.sh | head -c 4K"
]
pr = setStdin (byteStringInput $ cs code) $ shell cmd
logDebug ["Executing with stdin `", cs cmd, "`"]
output <- readProcessInterleaved_ pr
exec_ ["docker exec ", cnt, " rm -rf eval/", show snowflake]
logInfo ["Ran code in container ", cs cnt, ", evaluation ", cs $ show snowflake]

14
src/Myriad/Server.hs
View File

@ -58,14 +58,20 @@ serverT = handleLanguages :<|> handleEval :<|> handleContainers :<|> handleClean
logInfo ["POST /eval"]
languages <- gview $ #config % #languages
case find (\x -> x ^. #name == language) languages of
Nothing -> throwError $ err404 { errBody = "Language " <> cs language <> " was not found" }
Nothing -> do
logDebug ["Language ", cs language , " was not found (404)"]
throwError $ err404 { errBody = "Language " <> cs language <> " was not found" }
Just cfg -> do
env <- ask
res <- withAsync (liftIO . runMyriadT env . evalCode cfg 0 $ cs code) wait
case res of
EvalErrored -> throwError $ err500 { errBody = "Evaluation failed" }
EvalTimedOut -> throwError $ err504 { errBody = "Evaluation timed out" }
EvalOk xs -> pure . EvalResponse $ cs xs
EvalErrored -> do
logDebug ["Evaluation failed (500)"]
throwError $ err500 { errBody = "Evaluation failed" }
EvalTimedOut -> do
logDebug ["Evaluation timed out (504)"]
throwError $ err504 { errBody = "Evaluation timed out" }
EvalOk xs -> pure . EvalResponse $ cs xs
handleContainers :: Myriad [T.Text]
handleContainers = do