diff --git a/package.yaml b/package.yaml index dd5aace..fc55a70 100644 --- a/package.yaml +++ b/package.yaml @@ -42,11 +42,14 @@ default-extensions: - BlockArguments - ConstraintKinds - DataKinds +- DerivingStrategies - DeriveFunctor - DeriveGeneric - FlexibleContexts +- FlexibleInstances - FunctionalDependencies - GADTs +- GeneralizedNewtypeDeriving - LambdaCase - MultiParamTypeClasses - MultiWayIf @@ -56,6 +59,7 @@ default-extensions: - PolyKinds - RankNTypes - ScopedTypeVariables +- StandaloneDeriving - TupleSections - TypeApplications - TypeOperators diff --git a/src/Main.hs b/src/Main.hs index fa72674..53826f1 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,7 +1,5 @@ module Main where -import Control.Monad.Logger - import qualified Data.Text as T import Options.Applicative @@ -32,7 +30,6 @@ main = do runMyriadT env do buildAllImages startCleanup - runStdoutLoggingT do - logInfoN "Finished Docker-related setup" - logInfoN "Starting server" + logInfo ["Finished Docker-related setup"] + logInfo ["Starting server"] run (fromIntegral . port . config $ env) $ app env diff --git a/src/Myriad/Core.hs b/src/Myriad/Core.hs index fff4ec5..6b2d57e 100644 --- a/src/Myriad/Core.hs +++ b/src/Myriad/Core.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE UndecidableInstances #-} + module Myriad.Core ( Language , ContainerName @@ -7,26 +9,37 @@ module Myriad.Core , MyriadConfig(..) , LanguageConfig(..) , MyriadT - , MonadWithIO - , MyriadIO + , Myriad + , Myriadic , runMyriadT , initEnv + , exec + , exec_ + , logInfo + , logError + , mapMVar + , writeMVar ) where import Control.Monad.Base -import Control.Monad.Logger +import Control.Monad.Except +import Control.Monad.Logger hiding (logError, logInfo) import Control.Monad.Reader +import Control.Monad.State import Control.Monad.Trans.Control +import Control.Monad.Writer import qualified Data.ByteString.Lazy as BL +import Data.Functor.Identity import qualified Data.Map.Strict as M +import Data.Snowflake import qualified Data.Text as T import Dhall import GHC.Generics (Generic) -import Control.Concurrent.MVar -import Control.Concurrent.QSem -import Data.Snowflake +import Control.Concurrent.MVar.Lifted +import Control.Concurrent.QSem.Lifted +import System.Process.Typed type Language = T.Text type ContainerName = String @@ -63,11 +76,37 @@ data LanguageConfig = LanguageConfig instance Interpret LanguageConfig -type MyriadT m = ReaderT Env (LoggingT m) +newtype MyriadT m a = MyriadT { unMyriadT :: ReaderT Env (LoggingT m) a } + deriving newtype + ( Functor + , Applicative + , Monad + , MonadReader Env + , MonadLogger + , MonadLoggerIO + , MonadIO + , MonadError e + , MonadState s + , MonadWriter w + , MonadBase b + ) -type MonadWithIO m = (MonadIO m, MonadBase IO m, MonadBaseControl IO m) +instance MonadTrans MyriadT where + lift = MyriadT . lift . lift -type MyriadIO a = forall m. MonadWithIO m => MyriadT m a +instance MonadTransControl MyriadT where + type StT MyriadT a = a + liftWith = defaultLiftWith2 MyriadT unMyriadT + restoreT = defaultRestoreT2 MyriadT + +instance MonadBaseControl b m => MonadBaseControl b (MyriadT m) where + type StM (MyriadT m) a = ComposeSt MyriadT m a + liftBaseWith = defaultLiftBaseWith + restoreM = defaultRestoreM + +type Myriad = MyriadT Identity + +type Myriadic m = (MonadReader Env m, MonadLogger m, MonadLoggerIO m, MonadIO m, MonadBase IO m, MonadBaseControl IO m) readConfig :: T.Text -> IO MyriadConfig readConfig = input auto @@ -82,4 +121,22 @@ initEnv configInput = <*> newSnowflakeGen defaultConfig 0 runMyriadT :: MonadIO m => Env -> MyriadT m a -> m a -runMyriadT env f = runStdoutLoggingT $ runReaderT f env +runMyriadT env = runStdoutLoggingT . flip runReaderT env . unMyriadT + +exec :: MonadIO m => [String] -> m BL.ByteString +exec = readProcessInterleaved_ . shell . mconcat + +exec_ :: MonadIO m => [String] -> m () +exec_ = void . exec + +logInfo :: MonadLogger m => [T.Text] -> m () +logInfo = logInfoN . mconcat + +logError :: MonadLogger m => [T.Text] -> m () +logError = logErrorN . mconcat + +mapMVar :: (MonadBase IO m, MonadBaseControl IO m) => MVar a -> (a -> a) -> m () +mapMVar var f = modifyMVar_ var (pure . f) + +writeMVar :: (MonadBase IO m, MonadBaseControl IO m) => MVar a -> a -> m () +writeMVar var x = mapMVar var $ const x diff --git a/src/Myriad/Docker.hs b/src/Myriad/Docker.hs index 11bd8a2..ff4d5fc 100644 --- a/src/Myriad/Docker.hs +++ b/src/Myriad/Docker.hs @@ -13,6 +13,7 @@ import Control.Monad.Reader import qualified Data.Map.Strict as M import Data.Snowflake +import Data.String.Conversions import Control.Concurrent.Async.Lifted import Control.Concurrent.Lifted (fork, threadDelay) @@ -22,18 +23,17 @@ import Control.Exception.Lifted import System.Process.Typed import Myriad.Core -import Myriad.Util -buildImage :: LanguageConfig -> MyriadIO () +buildImage :: Myriadic m => LanguageConfig -> m () buildImage lang@LanguageConfig { name, concurrent } = do - logInfo ["Building image ", cvs $ imageName lang] - exec_ ["docker build -t ", imageName lang, " ./languages/", cvs name] + logInfo ["Building image ", cs $ imageName lang] + exec_ ["docker build -t ", imageName lang, " ./languages/", cs name] setupQSems - logInfo ["Built image ", cvs $ imageName lang] + logInfo ["Built image ", cs $ imageName lang] MyriadConfig { prepareContainers } <- asks config when_ prepareContainers $ setupContainer lang where - setupQSems :: MyriadIO () + setupQSems :: Myriadic m => m () setupQSems = do Env { containerSems, evalSems } <- ask csem <- newQSem 1 -- We only want one container to be set up at a time @@ -41,48 +41,48 @@ buildImage lang@LanguageConfig { name, concurrent } = do mapMVar containerSems $ M.insert name csem mapMVar evalSems $ M.insert name esem -buildAllImages :: MyriadIO () +buildAllImages :: Myriadic m => m () buildAllImages = do MyriadConfig { languages, buildConcurrently } <- asks config if buildConcurrently then forConcurrently_ languages buildImage else forM_ languages buildImage -startCleanup :: MyriadIO () +startCleanup :: Myriadic m => m () startCleanup = do MyriadConfig { cleanupInterval } <- asks config when_ (cleanupInterval > 0) do let t = fromIntegral cleanupInterval * 60000000 fork $ timer t where - timer :: Int -> MyriadIO () + timer :: Int -> Myriadic m => m () timer t = forever do threadDelay t n <- killContainers - logInfo ["Cleaned up ", cvs $ show n, " containers"] + logInfo ["Cleaned up ", cs $ show n, " containers"] timer t -setupContainer :: LanguageConfig -> MyriadIO ContainerName +setupContainer :: Myriadic m => LanguageConfig -> m ContainerName setupContainer lang@LanguageConfig { name, memory, cpus } = do cnts <- asks containers >>= readMVar case cnts M.!? name of Nothing -> setup Just cnt -> pure cnt where - setup :: MyriadIO ContainerName + setup :: Myriadic m => m ContainerName setup = do ref <- asks containers cnt <- newContainerName lang exec_ [ "docker run --rm --name=" - , cvs cnt + , cs cnt -- User 1000 will be for setting up the environment , " -u1000:1000 -w/tmp/ -dt --net=none --cpus=" - , cvs cpus + , cs cpus , " -m=" - , cvs memory + , cs memory , " --memory-swap=" - , cvs memory + , cs memory , " " , imageName lang , " /bin/sh" @@ -92,10 +92,10 @@ setupContainer lang@LanguageConfig { name, memory, cpus } = do exec_ ["docker exec ", cnt, " mkdir eval"] exec_ ["docker exec ", cnt, " chmod 711 eval"] mapMVar ref $ M.insert name cnt - logInfo ["Started container ", cvs cnt] + logInfo ["Started container ", cs cnt] pure cnt -killContainer :: Language -> MyriadIO Bool +killContainer :: Myriadic m => Language -> m Bool killContainer lang = do containers <- asks containers >>= readMVar case containers M.!? lang of @@ -105,10 +105,10 @@ killContainer lang = do case res of Nothing -> pure True Just err -> do - logError ["An exception occured when killing ", cvs cnt, ":\n", cvs $ show err] + logError ["An exception occured when killing ", cs cnt, ":\n", cs $ show err] pure False where - kill :: ContainerName -> MyriadIO (Maybe SomeException) + kill :: Myriadic m => ContainerName -> m (Maybe SomeException) kill cnt = do ref <- asks containers mapMVar ref $ M.delete lang @@ -116,16 +116,16 @@ killContainer lang = do case res of Left err -> pure $ Just err Right _ -> do - logInfo ["Killed container ", cvs cnt] + logInfo ["Killed container ", cs cnt] pure Nothing -killContainers :: MyriadIO [ContainerName] +killContainers :: Myriadic m => m [ContainerName] killContainers = do containers <- asks containers >>= readMVar xs <- forConcurrently (M.toList containers) \(k, v) -> (v,) <$> killContainer k pure . map fst $ filter snd xs -evalCode :: LanguageConfig -> Int -> String -> MyriadIO EvalResult +evalCode :: Myriadic m => LanguageConfig -> Int -> String -> m EvalResult 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. @@ -139,23 +139,23 @@ evalCode lang@LanguageConfig { name, timeout, retries } numRetries code = withCo 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] + logError ["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 retries then do - logError ["An exception occured in ", cvs cnt, ", evaluation ", cvs $ show snowflake, ", retrying:\n", cvs $ show err] + logError ["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 ", cvs cnt, ", evaluation ", cvs $ show snowflake, ":\n", cvs $ show err] + logError ["An exception occured in ", cs cnt, ", evaluation ", cs $ show snowflake, ":\n", cs $ show err] pure EvalErrored Right x -> do writeMVar doneRef True pure x where - withContainer :: (ContainerName -> MyriadIO a) -> MyriadIO a + withContainer :: Myriadic m => (ContainerName -> m a) -> m a withContainer f = do Env { containerSems, evalSems } <- ask csem <- (M.! name) <$> readMVar containerSems @@ -164,7 +164,7 @@ evalCode lang@LanguageConfig { name, timeout, retries } numRetries code = withCo cnt <- bracket_ (waitQSem csem) (signalQSem csem) $ setupContainer lang f cnt - timer :: MVar Bool -> MyriadIO () + timer :: Myriadic m => MVar Bool -> m () timer doneRef = do threadDelay $ fromIntegral timeout * 1000000 done <- readMVar doneRef @@ -172,14 +172,29 @@ evalCode lang@LanguageConfig { name, timeout, retries } numRetries code = withCo writeMVar doneRef True killContainer name - eval :: ContainerName -> Snowflake -> MyriadIO EvalResult + eval :: Myriadic m => ContainerName -> Snowflake -> m 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] + logInfo ["Running code in container ", cs cnt, ", evaluation ", cs $ show snowflake, ":\n", cs code] + 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 args = ["exec", "-u1001:1001", "-w/tmp/eval/" <> show snowflake, cnt, "/bin/sh", "/var/run/run.sh", code] output <- readProcessInterleaved_ $ proc "docker" args exec_ ["docker exec ", cnt, " rm -rf eval/", show snowflake] - logInfo ["Ran code in container ", cvs cnt, ", evaluation ", cvs $ show snowflake] + logInfo ["Ran code in container ", cs cnt, ", evaluation ", cs $ show snowflake] pure $ EvalOk output + +newContainerName :: Myriadic m => LanguageConfig -> m ContainerName +newContainerName LanguageConfig { name } = do + snowflakeGen <- asks snowflakeGen + snowflake <- liftIO $ nextSnowflake snowflakeGen + pure $ "comp_iler-" <> cs name <> "-" <> show snowflake + +imageName :: LanguageConfig -> ImageName +imageName LanguageConfig { name } = "1computer1/comp_iler:" <> cs name + +when_ :: Applicative f => Bool -> f a -> f () +when_ p = when p . void + +unless_ :: Applicative f => Bool -> f a -> f () +unless_ p = unless p . void diff --git a/src/Myriad/Server.hs b/src/Myriad/Server.hs index 25f7906..a6eaa3a 100644 --- a/src/Myriad/Server.hs +++ b/src/Myriad/Server.hs @@ -10,6 +10,7 @@ import Control.Monad.Reader import Data.Aeson import Data.List (find) import qualified Data.Map as M +import Data.String.Conversions import qualified Data.Text as T import GHC.Generics @@ -19,7 +20,6 @@ import Servant import Myriad.Core import Myriad.Docker -import Myriad.Util data EvalRequest = EvalRequest { language :: T.Text, code :: String } deriving (Generic, FromJSON) data EvalResponse = EvalResponse { result :: T.Text } deriving (Generic, ToJSON) @@ -36,35 +36,35 @@ app = serve (Proxy @API) . server server :: Env -> Server API server env = hoistServer (Proxy @API) (runMyriadT env) serverT -serverT :: forall m. (MonadWithIO m, MonadError ServantErr m) => ServerT API (MyriadT m) +serverT :: ServerT API (MyriadT Handler) serverT = handleLanguages :<|> handleEval :<|> handleContainers :<|> handleCleanup where - handleLanguages :: MyriadT m [T.Text] + handleLanguages :: MyriadT Handler [T.Text] handleLanguages = do logInfo ["GET /languages"] MyriadConfig { languages } <- asks config pure . map name $ languages - handleEval :: EvalRequest -> MyriadT m EvalResponse + handleEval :: EvalRequest -> MyriadT Handler EvalResponse handleEval EvalRequest { language, code } = do 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" } + Nothing -> throwError $ err404 { errBody = "Language " <> cs language <> " was not found" } Just cfg -> do - res <- withAsync (evalCode cfg 0 $ cvs code) wait + res <- withAsync (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 $ cvs xs + EvalOk xs -> pure . EvalResponse $ cs xs - handleContainers :: MyriadT m [T.Text] + handleContainers :: MyriadT Handler [T.Text] handleContainers = do logInfo ["GET /containers"] containers <- asks containers >>= readMVar - pure . map cvs $ M.elems containers + pure . map cs $ M.elems containers - handleCleanup :: MyriadT m [T.Text] + handleCleanup :: MyriadT Handler [T.Text] handleCleanup = do logInfo ["POST /cleanup"] - map cvs <$> killContainers + map cs <$> killContainers diff --git a/src/Myriad/Util.hs b/src/Myriad/Util.hs deleted file mode 100644 index 3c55147..0000000 --- a/src/Myriad/Util.hs +++ /dev/null @@ -1,63 +0,0 @@ -module Myriad.Util - ( newContainerName - , imageName - , 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 - -newContainerName :: MonadIO m => LanguageConfig -> MyriadT m ContainerName -newContainerName LanguageConfig { name } = do - snowflakeGen <- asks snowflakeGen - snowflake <- liftIO $ nextSnowflake snowflakeGen - pure $ "comp_iler-" <> convertString name <> "-" <> show snowflake - -imageName :: LanguageConfig -> ImageName -imageName LanguageConfig { name } = "1computer1/comp_iler:" <> convertString name - --- Shorthand because laziness -cvs :: ConvertibleStrings a b => a -> b -cvs = convertString - -when_ :: Applicative f => Bool -> f a -> f () -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