log: add much more logging

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

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 :: (MonadIO m, MonadLogger m) => [String] -> m BL.ByteString
-exec = readProcessInterleaved_ . shell . mconcat
+exec args = do
+    logDebug ["Executing `", cs $ mconcat args, "`"]
+    readProcessInterleaved_ . shell $ mconcat args
 
-exec_ :: MonadIO m => [String] -> m ()
+exec_ :: (MonadIO m, MonadLogger m) => [String] -> m ()
-exec_ = (() <$) . exec
+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
 

src/Myriad/Docker.hs

@@ -58,8 +58,12 @@ buildAllImages :: Myriad ()
 buildAllImages = do
     config <- gview #config
     if config ^. #buildConcurrently
-        then forConcurrently_ (config ^. #languages) buildImage
+        then do
-        else forM_ (config ^. #languages) buildImage
+            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
+                Right _ -> pure Nothing
-                    logInfo ["Killed container ", cs cnt]
-                    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 :: ContainerName -> MVar Bool -> Myriad ()
-        timer doneRef = do
+        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
+            if done
-                writeMVar doneRef True
+                then do
-                killContainer $ lang ^. #name
+                    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]

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" }
+                        EvalErrored -> do
-                        EvalTimedOut -> throwError $ err504 { errBody = "Evaluation timed out" }
+                            logDebug ["Evaluation failed (500)"]
-                        EvalOk xs    -> pure . EvalResponse $ cs xs
+                            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