From 57ea8696e762c51c9cab89c8fb0d70442028c424 Mon Sep 17 00:00:00 2001 From: 1computer1 Date: Tue, 16 Jun 2020 22:08:26 -0400 Subject: [PATCH] core: use concrete monads --- src/Myriad/Core.hs | 3 --- src/Myriad/Docker.hs | 32 +++++++++++++++++--------------- src/Myriad/Server.hs | 18 +++++++++++------- 3 files changed, 28 insertions(+), 25 deletions(-) diff --git a/src/Myriad/Core.hs b/src/Myriad/Core.hs index d8c2566..bf7d190 100644 --- a/src/Myriad/Core.hs +++ b/src/Myriad/Core.hs @@ -10,7 +10,6 @@ module Myriad.Core , DefaultLanguageConfig(..) , LanguageConfig(..) , MyriadT - , Myriadic , runMyriadT , initEnv , exec @@ -134,8 +133,6 @@ instance MonadBaseControl b m => MonadBaseControl b (MyriadT m) where liftBaseWith = defaultLiftBaseWith restoreM = defaultRestoreM -type Myriadic m = (MonadReader Env m, MonadLogger m, MonadLoggerIO m, MonadIO m, MonadBase IO m, MonadBaseControl IO m) - readConfig :: FilePath -> IO MyriadConfig readConfig f = do x <- BL.readFile f diff --git a/src/Myriad/Docker.hs b/src/Myriad/Docker.hs index d544f0e..63653eb 100644 --- a/src/Myriad/Docker.hs +++ b/src/Myriad/Docker.hs @@ -26,7 +26,9 @@ import System.Process.Typed import Myriad.Core -buildImage :: Myriadic m => LanguageConfig -> m () +type Myriad = MyriadT IO + +buildImage :: LanguageConfig -> Myriad () buildImage lang@LanguageConfig { name, concurrent } = do Env { config = MyriadConfig { prepareContainers }, languagesDir } <- ask logInfo ["Building image ", cs $ imageName lang] @@ -35,7 +37,7 @@ buildImage lang@LanguageConfig { name, concurrent } = do logInfo ["Built image ", cs $ imageName lang] when_ prepareContainers $ setupContainer lang where - setupQSems :: Myriadic m => m () + setupQSems :: Myriad () setupQSems = do Env { config = MyriadConfig { defaultLanguage }, containerSems, evalSems } <- ask csem <- newQSem 1 -- We only want one container to be set up at a time @@ -43,35 +45,35 @@ buildImage lang@LanguageConfig { name, concurrent } = do mapMVar containerSems $ M.insert name csem mapMVar evalSems $ M.insert name esem -buildAllImages :: Myriadic m => m () +buildAllImages :: Myriad () buildAllImages = do MyriadConfig { languages, buildConcurrently } <- asks config if buildConcurrently then forConcurrently_ languages buildImage else forM_ languages buildImage -startCleanup :: Myriadic m => m () +startCleanup :: Myriad () startCleanup = do MyriadConfig { cleanupInterval } <- asks config when_ (cleanupInterval > 0) do let t = fromIntegral cleanupInterval * 60000000 fork $ timer t where - timer :: Int -> Myriadic m => m () + timer :: Int -> Myriad () timer t = forever do threadDelay t n <- killContainers logInfo ["Cleaned up ", cs $ show n, " containers"] timer t -setupContainer :: Myriadic m => LanguageConfig -> m ContainerName +setupContainer :: LanguageConfig -> Myriad 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 :: Myriadic m => m ContainerName + setup :: Myriad ContainerName setup = do Env { config = MyriadConfig { defaultLanguage }, containers = ref } <- ask cnt <- newContainerName lang @@ -97,7 +99,7 @@ setupContainer lang@LanguageConfig { name, memory, cpus } = do logInfo ["Started container ", cs cnt] pure cnt -killContainer :: Myriadic m => Language -> m Bool +killContainer :: Language -> Myriad Bool killContainer lang = do containers <- asks containers >>= readMVar case containers M.!? lang of @@ -110,7 +112,7 @@ killContainer lang = do logError ["An exception occured when killing ", cs cnt, ":\n", cs $ show err] pure False where - kill :: Myriadic m => ContainerName -> m (Maybe SomeException) + kill :: ContainerName -> Myriad (Maybe SomeException) kill cnt = do ref <- asks containers mapMVar ref $ M.delete lang @@ -121,13 +123,13 @@ killContainer lang = do logInfo ["Killed container ", cs cnt] pure Nothing -killContainers :: Myriadic m => m [ContainerName] +killContainers :: Myriad [ContainerName] killContainers = do containers <- asks containers >>= readMVar xs <- forConcurrently (M.toList containers) \(k, v) -> (v,) <$> killContainer k pure . map fst $ filter snd xs -evalCode :: Myriadic m => LanguageConfig -> Int -> String -> m EvalResult +evalCode :: LanguageConfig -> Int -> String -> Myriad 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. @@ -157,7 +159,7 @@ evalCode lang@LanguageConfig { name, timeout, retries } numRetries code = withCo writeMVar doneRef True pure x where - withContainer :: Myriadic m => (ContainerName -> m a) -> m a + withContainer :: (ContainerName -> Myriad a) -> Myriad a withContainer f = do Env { containerSems, evalSems } <- ask csem <- (M.! name) <$> readMVar containerSems @@ -166,7 +168,7 @@ evalCode lang@LanguageConfig { name, timeout, retries } numRetries code = withCo cnt <- bracket_ (waitQSem csem) (signalQSem csem) $ setupContainer lang f cnt - timer :: Myriadic m => MVar Bool -> m () + timer :: MVar Bool -> Myriad () timer doneRef = do Env { config = MyriadConfig { defaultLanguage } } <- ask threadDelay $ (fromIntegral $ fromMaybe (defTimeout defaultLanguage) timeout) * 1000000 @@ -175,7 +177,7 @@ evalCode lang@LanguageConfig { name, timeout, retries } numRetries code = withCo writeMVar doneRef True killContainer name - eval :: Myriadic m => ContainerName -> Snowflake -> m EvalResult + eval :: ContainerName -> Snowflake -> Myriad EvalResult eval cnt snowflake = do logInfo ["Running code in container ", cs cnt, ", evaluation ", cs $ show snowflake, ":\n", cs code] exec_ ["docker exec ", cs cnt, " mkdir eval/", show snowflake] @@ -188,7 +190,7 @@ evalCode lang@LanguageConfig { name, timeout, retries } numRetries code = withCo logInfo ["Ran code in container ", cs cnt, ", evaluation ", cs $ show snowflake] pure $ EvalOk output -newContainerName :: Myriadic m => LanguageConfig -> m ContainerName +newContainerName :: LanguageConfig -> Myriad ContainerName newContainerName LanguageConfig { name } = do snowflakeGen <- asks snowflakeGen snowflake <- liftIO $ nextSnowflake snowflakeGen diff --git a/src/Myriad/Server.hs b/src/Myriad/Server.hs index a6eaa3a..72a0fb2 100644 --- a/src/Myriad/Server.hs +++ b/src/Myriad/Server.hs @@ -21,6 +21,8 @@ import Servant import Myriad.Core import Myriad.Docker +type Myriad = MyriadT Handler + data EvalRequest = EvalRequest { language :: T.Text, code :: String } deriving (Generic, FromJSON) data EvalResponse = EvalResponse { result :: T.Text } deriving (Generic, ToJSON) @@ -36,35 +38,37 @@ app = serve (Proxy @API) . server server :: Env -> Server API server env = hoistServer (Proxy @API) (runMyriadT env) serverT -serverT :: ServerT API (MyriadT Handler) +serverT :: ServerT API Myriad serverT = handleLanguages :<|> handleEval :<|> handleContainers :<|> handleCleanup where - handleLanguages :: MyriadT Handler [T.Text] + handleLanguages :: Myriad [T.Text] handleLanguages = do logInfo ["GET /languages"] MyriadConfig { languages } <- asks config pure . map name $ languages - handleEval :: EvalRequest -> MyriadT Handler EvalResponse + handleEval :: EvalRequest -> Myriad 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 " <> cs language <> " was not found" } Just cfg -> do - res <- withAsync (evalCode cfg 0 $ cs code) wait + 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 - handleContainers :: MyriadT Handler [T.Text] + handleContainers :: Myriad [T.Text] handleContainers = do logInfo ["GET /containers"] containers <- asks containers >>= readMVar pure . map cs $ M.elems containers - handleCleanup :: MyriadT Handler [T.Text] + handleCleanup :: Myriad [T.Text] handleCleanup = do logInfo ["POST /cleanup"] - map cs <$> killContainers + env <- ask + liftIO $ map cs <$> runMyriadT env killContainers