From 3082f9b35e01d1451f705433a8088bbe51e80eb6 Mon Sep 17 00:00:00 2001 From: 1computer1 Date: Wed, 17 Jun 2020 00:29:25 -0400 Subject: [PATCH] log: add much more logging --- src/Myriad.hs | 2 +- src/Myriad/Core.hs | 21 +++++++++---- src/Myriad/Docker.hs | 71 +++++++++++++++++++++++++++++++++----------- src/Myriad/Server.hs | 14 ++++++--- 4 files changed, 80 insertions(+), 28 deletions(-) diff --git a/src/Myriad.hs b/src/Myriad.hs index 01e335b..2e52dd4 100644 --- a/src/Myriad.hs +++ b/src/Myriad.hs @@ -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 diff --git a/src/Myriad/Core.hs b/src/Myriad/Core.hs index 0015744..38fd483 100644 --- a/src/Myriad/Core.hs +++ b/src/Myriad/Core.hs @@ -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 diff --git a/src/Myriad/Docker.hs b/src/Myriad/Docker.hs index 3e2eb99..1499573 100644 --- a/src/Myriad/Docker.hs +++ b/src/Myriad/Docker.hs @@ -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] diff --git a/src/Myriad/Server.hs b/src/Myriad/Server.hs index 29d0c8a..81c3290 100644 --- a/src/Myriad/Server.hs +++ b/src/Myriad/Server.hs @@ -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