diff --git a/myriad.cabal b/myriad.cabal index 19f4372..1313384 100644 --- a/myriad.cabal +++ b/myriad.cabal @@ -36,6 +36,7 @@ common shared MultiParamTypeClasses MultiWayIf NamedFieldPuns + OverloadedLabels OverloadedStrings PatternSynonyms TupleSections @@ -55,6 +56,7 @@ common shared , monad-control , monad-logger , mtl + , optics , servant , servant-server , snowflake diff --git a/src/Myriad.hs b/src/Myriad.hs index dc7c156..01e335b 100644 --- a/src/Myriad.hs +++ b/src/Myriad.hs @@ -8,7 +8,8 @@ import Data.String.Conversions import Network.Wai.Handler.Warp -import Myriad.Config +import Optics + import Myriad.Core import Myriad.Docker import Myriad.Server @@ -20,7 +21,7 @@ runMyriadServer configPath languagesDir = do buildAllImages startCleanup logInfo ["Finished Docker-related setup"] - let myriadPort = fromIntegral . port $ config env + let myriadPort = fromIntegral $ env ^. #config % #port onReady = runStdoutLoggingT $ logInfo ["Server started on port ", cs $ show myriadPort, "!"] settings = setPort myriadPort . setBeforeMainLoop onReady $ defaultSettings runSettings settings $ app env diff --git a/src/Myriad/Config.hs b/src/Myriad/Config.hs index 9e92818..d71ffee 100644 --- a/src/Myriad/Config.hs +++ b/src/Myriad/Config.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} + module Myriad.Config ( LanguageName , Config(..) @@ -10,25 +14,89 @@ import Data.Maybe import qualified Data.Text as T import Data.YAML +import Optics + type LanguageName = T.Text -data Config = Config - { languages :: [Language] - , buildConcurrently :: Bool - , prepareContainers :: Bool - , cleanupInterval :: Int - , port :: Int +data Language = Language + { _name :: LanguageName + , _memory :: T.Text + , _cpus :: Double + , _timeout :: Int + , _concurrent :: Int + , _retries :: Int } deriving (Show) -data Language = Language - { name :: LanguageName - , memory :: T.Text - , cpus :: Double - , timeout :: Int - , concurrent :: Int - , retries :: Int +makeFieldLabelsWith classUnderscoreNoPrefixFields ''Language + +data Config = Config + { _languages :: [Language] + , _buildConcurrently :: Bool + , _prepareContainers :: Bool + , _cleanupInterval :: Int + , _port :: Int } deriving (Show) +makeFieldLabelsWith classUnderscoreNoPrefixFields ''Config + +data DefaultLanguage = DefaultLanguage + { _memory :: T.Text + , _cpus :: Double + , _timeout :: Int + , _concurrent :: Int + , _retries :: Int + } deriving (Show) + +makeFieldLabelsWith classUnderscoreNoPrefixFields ''DefaultLanguage + +instance FromYAML DefaultLanguage where + parseYAML = withMap "default language" $ \m -> DefaultLanguage + <$> m .: "memory" + <*> m .: "cpus" + <*> m .: "timeout" + <*> m .: "concurrent" + <*> m .: "retries" + +data RawLanguage = RawLanguage + { _name :: LanguageName + , _memory :: Maybe T.Text + , _cpus :: Maybe Double + , _timeout :: Maybe Int + , _concurrent :: Maybe Int + , _retries :: Maybe Int + } deriving (Show) + +makeFieldLabelsWith classUnderscoreNoPrefixFields ''RawLanguage + +instance FromYAML RawLanguage where + parseYAML = withMap "language" $ \m -> RawLanguage + <$> m .: "name" + <*> m .:? "memory" + <*> m .:? "cpus" + <*> m .:? "timeout" + <*> m .:? "concurrent" + <*> m .:? "retries" + +data RawConfig = RawConfig + { _languages :: [RawLanguage] + , _defaultLanguage :: DefaultLanguage + , _buildConcurrently :: Bool + , _prepareContainers :: Bool + , _cleanupInterval :: Int + , _port :: Int + } deriving (Show) + +makeFieldLabelsWith classUnderscoreNoPrefixFields ''RawConfig + +instance FromYAML RawConfig where + parseYAML = withMap "config" $ \m -> RawConfig + <$> m .: "languages" + <*> m .: "defaultLanguage" + <*> m .: "buildConcurrently" + <*> m .: "prepareContainers" + <*> m .: "cleanupInterval" + <*> m .: "port" + readConfig :: FilePath -> IO Config readConfig = fmap fromRawConfig . readRawConfig @@ -42,72 +110,20 @@ readRawConfig f = do fromRawConfig :: RawConfig -> Config fromRawConfig r = Config - { languages = map (fromRawLanguage $ rawDefaultLanguage r) $ rawLanguages r - , buildConcurrently = rawBuildConcurrently r - , prepareContainers = rawPrepareContainers r - , cleanupInterval = rawCleanupInterval r - , port = rawPort r + { _languages = map (fromRawLanguage (r ^. #defaultLanguage)) $ r ^. #languages + , _buildConcurrently = r ^. #buildConcurrently + , _prepareContainers = r ^. #prepareContainers + , _cleanupInterval = r ^. #cleanupInterval + , _port = r ^. #port } fromRawLanguage :: DefaultLanguage -> RawLanguage -> Language -fromRawLanguage d l = +fromRawLanguage d r = Language - { name = rawName l - , memory = fromMaybe (defMemory d) (rawMemory l) - , cpus = fromMaybe (defCpus d) (rawCpus l) - , timeout = fromMaybe (defTimeout d) (rawTimeout l) - , concurrent = fromMaybe (defConcurrent d) (rawConcurrent l) - , retries = fromMaybe (defRetries d) (rawRetries l) + { _name = r ^. #name + , _memory = fromMaybe (d ^. #memory) (r ^. #memory) + , _cpus = fromMaybe (d ^. #cpus) (r ^. #cpus) + , _timeout = fromMaybe (d ^. #timeout) (r ^. #timeout) + , _concurrent = fromMaybe (d ^. #concurrent) (r ^. #concurrent) + , _retries = fromMaybe (d ^. #retries) (r ^. #retries) } - -data RawConfig = RawConfig - { rawLanguages :: [RawLanguage] - , rawDefaultLanguage :: DefaultLanguage - , rawBuildConcurrently :: Bool - , rawPrepareContainers :: Bool - , rawCleanupInterval :: Int - , rawPort :: Int - } deriving (Show) - -instance FromYAML RawConfig where - parseYAML = withMap "config" $ \m -> RawConfig - <$> m .: "languages" - <*> m .: "defaultLanguage" - <*> m .: "buildConcurrently" - <*> m .: "prepareContainers" - <*> m .: "cleanupInterval" - <*> m .: "port" - -data DefaultLanguage = DefaultLanguage - { defMemory :: T.Text - , defCpus :: Double - , defTimeout :: Int - , defConcurrent :: Int - , defRetries :: Int - } deriving (Show) - -instance FromYAML DefaultLanguage where - parseYAML = withMap "default language" $ \m -> DefaultLanguage - <$> m .: "memory" - <*> m .: "cpus" - <*> m .: "timeout" - <*> m .: "concurrent" - <*> m .: "retries" - -data RawLanguage = RawLanguage - { rawName :: LanguageName - , rawMemory :: Maybe T.Text - , rawCpus :: Maybe Double - , rawTimeout :: Maybe Int - , rawConcurrent :: Maybe Int - , rawRetries :: Maybe Int - } deriving (Show) - -instance FromYAML RawLanguage where - parseYAML = withMap "language" $ \m -> RawLanguage - <$> m .: "name" - <*> m .:? "memory" - <*> m .:? "cpus" - <*> m .:? "timeout" - <*> m .:? "concurrent" - <*> m .:? "retries" diff --git a/src/Myriad/Core.hs b/src/Myriad/Core.hs index 5eae677..0015744 100644 --- a/src/Myriad/Core.hs +++ b/src/Myriad/Core.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} module Myriad.Core @@ -33,6 +34,8 @@ import Control.Concurrent.MVar.Lifted import Control.Concurrent.QSem.Lifted import System.Process.Typed +import Optics + import Myriad.Config type ContainerName = String @@ -40,14 +43,16 @@ type ContainerName = String type ImageName = String data Env = Env - { config :: Config - , languagesDir :: FilePath - , containers :: MVar (M.Map LanguageName ContainerName) - , containerSems :: MVar (M.Map LanguageName QSem) - , evalSems :: MVar (M.Map LanguageName QSem) - , snowflakeGen :: SnowflakeGen + { _config :: Config + , _languagesDir :: FilePath + , _containers :: MVar (M.Map LanguageName ContainerName) + , _containerSems :: MVar (M.Map LanguageName QSem) + , _evalSems :: MVar (M.Map LanguageName QSem) + , _snowflakeGen :: SnowflakeGen } +makeFieldLabelsWith classUnderscoreNoPrefixFields ''Env + newtype MyriadT m a = MyriadT { unMyriadT :: ReaderT Env (LoggingT m) a } deriving newtype ( Functor diff --git a/src/Myriad/Docker.hs b/src/Myriad/Docker.hs index 02795c2..3e2eb99 100644 --- a/src/Myriad/Docker.hs +++ b/src/Myriad/Docker.hs @@ -24,6 +24,8 @@ import Control.Exception.Lifted import System.FilePath (()) import System.Process.Typed +import Optics + import Myriad.Config import Myriad.Core @@ -36,34 +38,34 @@ data EvalResult deriving (Show) buildImage :: Language -> Myriad () -buildImage lang@Language { name, concurrent } = do - Env { config = Config { prepareContainers }, languagesDir } <- ask +buildImage lang = do + env <- ask logInfo ["Building image ", cs $ imageName lang] - exec_ ["docker build -t ", imageName lang, " ", cs languagesDir cs name] + exec_ ["docker build -t ", imageName lang, " ", cs (env ^. #languagesDir) cs (lang ^. #name)] setupQSems logInfo ["Built image ", cs $ imageName lang] - when prepareContainers . void $ setupContainer lang + when (env ^. #config % #prepareContainers) . void $ setupContainer lang where setupQSems :: Myriad () setupQSems = do - Env { containerSems, evalSems } <- ask + env <- ask csem <- newQSem 1 -- We only want one container to be set up at a time - esem <- newQSem $ fromIntegral concurrent - mapMVar containerSems $ M.insert name csem - mapMVar evalSems $ M.insert name esem + esem <- newQSem $ fromIntegral (lang ^. #concurrent) + mapMVar (env ^. #containerSems) $ M.insert (lang ^. #name) csem + mapMVar (env ^. #evalSems) $ M.insert (lang ^. #name) esem buildAllImages :: Myriad () buildAllImages = do - Config { languages, buildConcurrently } <- asks config - if buildConcurrently - then forConcurrently_ languages buildImage - else forM_ languages buildImage + config <- gview #config + if config ^. #buildConcurrently + then forConcurrently_ (config ^. #languages) buildImage + else forM_ (config ^. #languages) buildImage startCleanup :: Myriad () startCleanup = do - Config { cleanupInterval } <- asks config - when (cleanupInterval > 0) . void $ do - let t = fromIntegral cleanupInterval * 60000000 + config <- gview #config + when (config ^. #cleanupInterval > 0) . void $ do + let t = fromIntegral (config ^. #cleanupInterval) * 60000000 fork $ timer t where timer :: Int -> Myriad () @@ -74,26 +76,26 @@ startCleanup = do timer t setupContainer :: Language -> Myriad ContainerName -setupContainer lang@Language { name, memory, cpus } = do - cnts <- asks containers >>= readMVar - case cnts M.!? name of - Nothing -> setup +setupContainer lang = do + cnts <- gview #containers >>= readMVar + case cnts M.!? (lang ^. #name) of + Nothing -> setup Just cnt -> pure cnt where setup :: Myriad ContainerName setup = do - ref <- asks containers + ref <- gview #containers cnt <- newContainerName lang exec_ [ "docker run --rm --name=" , cs cnt -- User 1000 will be for setting up the environment , " -u1000:1000 -w/tmp/ -dt --net=none --cpus=" - , show cpus + , show $ lang ^. #cpus , " -m=" - , cs memory + , cs $ lang ^. #memory , " --memory-swap=" - , cs memory + , cs $ lang ^. #memory , " " , imageName lang , " /bin/sh" @@ -102,50 +104,50 @@ setupContainer lang@Language { name, memory, cpus } = do -- 711 so that users can't traverse into other people's code exec_ ["docker exec ", cnt, " mkdir eval"] exec_ ["docker exec ", cnt, " chmod 711 eval"] - mapMVar ref $ M.insert name cnt + mapMVar ref $ M.insert (lang ^. #name) cnt logInfo ["Started container ", cs cnt] pure cnt killContainer :: LanguageName -> Myriad Bool killContainer lang = do - containers <- asks containers >>= readMVar + containers <- gview #containers >>= readMVar case containers M.!? lang of - Nothing -> pure False + Nothing -> pure False Just cnt -> do res <- kill cnt case res of - Nothing -> pure True + Nothing -> pure True Just err -> do logError ["An exception occured when killing ", cs cnt, ":\n", cs $ show err] pure False where kill :: ContainerName -> Myriad (Maybe SomeException) kill cnt = do - ref <- asks containers + ref <- gview #containers mapMVar ref $ M.delete lang res <- try $ exec_ ["docker kill ", cnt] case res of Left err -> pure $ Just err - Right _ -> do + Right _ -> do logInfo ["Killed container ", cs cnt] pure Nothing killContainers :: Myriad [ContainerName] killContainers = do - containers <- asks containers >>= readMVar + containers <- gview #containers >>= readMVar xs <- forConcurrently (M.toList containers) $ \(k, v) -> (v,) <$> killContainer k pure . map fst $ filter snd xs evalCode :: Language -> Int -> String -> Myriad EvalResult -evalCode lang@Language { name, timeout, retries } numRetries code = withContainer $ \cnt -> do +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. - snowflakeGen <- asks snowflakeGen + snowflakeGen <- gview #snowflakeGen snowflake <- liftIO $ nextSnowflake snowflakeGen res <- try $ eval cnt snowflake case res of Left (SomeException err) -> do - void $ killContainer name + void . killContainer $ lang ^. #name done <- readMVar doneRef if done -- If we find the eval is done from an exception, then it was timed out. @@ -155,7 +157,7 @@ evalCode lang@Language { name, timeout, retries } numRetries code = withContaine -- Otherwise, the container was killed from another eval, so we should retry. else do writeMVar doneRef True - if numRetries < fromIntegral retries + if numRetries < fromIntegral (lang ^. #retries) then do logError ["An exception occured in ", cs cnt, ", evaluation ", cs $ show snowflake, ", retrying:\n", cs $ show err] evalCode lang (numRetries + 1) code @@ -168,20 +170,20 @@ evalCode lang@Language { name, timeout, retries } numRetries code = withContaine where withContainer :: (ContainerName -> Myriad a) -> Myriad a withContainer f = do - Env { containerSems, evalSems } <- ask - csem <- (M.! name) <$> readMVar containerSems - esem <- (M.! name) <$> readMVar evalSems + env <- ask + csem <- (M.! (lang ^. #name)) <$> readMVar (env ^. #containerSems) + esem <- (M.! (lang ^. #name)) <$> readMVar (env ^. #evalSems) bracket_ (waitQSem esem) (signalQSem esem) $ do cnt <- bracket_ (waitQSem csem) (signalQSem csem) $ setupContainer lang f cnt timer :: MVar Bool -> Myriad () timer doneRef = do - threadDelay $ fromIntegral timeout * 1000000 + threadDelay $ fromIntegral (lang ^. #timeout) * 1000000 done <- readMVar doneRef unless done . void $ do writeMVar doneRef True - killContainer name + killContainer $ lang ^. #name eval :: ContainerName -> Snowflake -> Myriad EvalResult eval cnt snowflake = do @@ -197,10 +199,10 @@ evalCode lang@Language { name, timeout, retries } numRetries code = withContaine pure $ EvalOk output newContainerName :: Language -> Myriad ContainerName -newContainerName Language { name } = do - snowflakeGen <- asks snowflakeGen +newContainerName lang = do + snowflakeGen <- gview #snowflakeGen snowflake <- liftIO $ nextSnowflake snowflakeGen - pure $ "comp_iler-" <> cs name <> "-" <> show snowflake + pure $ "comp_iler-" <> cs (lang ^. #name) <> "-" <> show snowflake imageName :: Language -> ImageName -imageName Language { name } = "1computer1/comp_iler:" <> cs name +imageName lang = "1computer1/comp_iler:" <> cs (lang ^. #name) diff --git a/src/Myriad/Server.hs b/src/Myriad/Server.hs index ddf09af..29d0c8a 100644 --- a/src/Myriad/Server.hs +++ b/src/Myriad/Server.hs @@ -16,7 +16,8 @@ import Control.Concurrent.Async.Lifted import Control.Concurrent.MVar.Lifted import Servant -import Myriad.Config +import Optics + import Myriad.Core import Myriad.Docker @@ -49,14 +50,14 @@ serverT = handleLanguages :<|> handleEval :<|> handleContainers :<|> handleClean handleLanguages :: Myriad [T.Text] handleLanguages = do logInfo ["GET /languages"] - Config { languages } <- asks config - pure . map name $ languages + languages <- gview $ #config % #languages + pure $ map (^. #name) languages handleEval :: EvalRequest -> Myriad EvalResponse handleEval EvalRequest { language, code } = do logInfo ["POST /eval"] - Config { languages } <- asks config - case find (\x -> name x == language) languages of + languages <- gview $ #config % #languages + case find (\x -> x ^. #name == language) languages of Nothing -> throwError $ err404 { errBody = "Language " <> cs language <> " was not found" } Just cfg -> do env <- ask @@ -69,7 +70,7 @@ serverT = handleLanguages :<|> handleEval :<|> handleContainers :<|> handleClean handleContainers :: Myriad [T.Text] handleContainers = do logInfo ["GET /containers"] - containers <- asks containers >>= readMVar + containers <- gview #containers >>= readMVar pure . map cs $ M.elems containers handleCleanup :: Myriad [T.Text]