From 3a10e3e72c2d46f11ff95c06aa4ab1905f945466 Mon Sep 17 00:00:00 2001 From: 1computer1 Date: Tue, 16 Jun 2020 22:29:12 -0400 Subject: [PATCH] config: refactor config reading --- myriad.cabal | 1 + src/Myriad.hs | 1 + src/Myriad/Config.hs | 113 +++++++++++++++++++++++++++++++++++++++++++ src/Myriad/Core.hs | 80 +++++------------------------- src/Myriad/Docker.hs | 49 +++++++++---------- src/Myriad/Server.hs | 5 +- 6 files changed, 153 insertions(+), 96 deletions(-) create mode 100644 src/Myriad/Config.hs diff --git a/myriad.cabal b/myriad.cabal index f7ad286..55d7d4f 100644 --- a/myriad.cabal +++ b/myriad.cabal @@ -79,6 +79,7 @@ library import: shared exposed-modules: Myriad + Myriad.Config Myriad.Core Myriad.Docker Myriad.Server diff --git a/src/Myriad.hs b/src/Myriad.hs index 376e551..b93b782 100644 --- a/src/Myriad.hs +++ b/src/Myriad.hs @@ -9,6 +9,7 @@ import Data.String.Conversions import Network.Wai.Handler.Warp import Myriad.Core +import Myriad.Config import Myriad.Docker import Myriad.Server diff --git a/src/Myriad/Config.hs b/src/Myriad/Config.hs new file mode 100644 index 0000000..be4cc84 --- /dev/null +++ b/src/Myriad/Config.hs @@ -0,0 +1,113 @@ +module Myriad.Config + ( LanguageName + , Config(..) + , Language(..) + , readConfig + ) where + +import qualified Data.ByteString.Lazy as BL +import Data.Maybe +import qualified Data.Text as T +import Data.YAML + +type LanguageName = T.Text + +data Config = Config + { languages :: [Language] + , buildConcurrently :: Bool + , prepareContainers :: Bool + , cleanupInterval :: Int + , port :: Int + } deriving (Show) + +data Language = Language + { name :: LanguageName + , memory :: T.Text + , cpus :: Double + , timeout :: Int + , concurrent :: Int + , retries :: Int + } deriving (Show) + +fromRawConfig :: RawConfig -> Config +fromRawConfig (r@RawConfig { rawLanguages, rawDefaultLanguage }) = + Config + { languages = map f rawLanguages + , buildConcurrently = rawBuildConcurrently r + , prepareContainers = rawPrepareContainers r + , cleanupInterval = rawCleanupInterval r + , port = rawPort r + } + where + f :: RawLanguage -> Language + f l = + Language + { name = rawName l + , memory = fromMaybe (defMemory rawDefaultLanguage) (rawMemory l) + , cpus = fromMaybe (defCpus rawDefaultLanguage) (rawCpus l) + , timeout = fromMaybe (defTimeout rawDefaultLanguage) (rawTimeout l) + , concurrent = fromMaybe (defConcurrent rawDefaultLanguage) (rawConcurrent l) + , retries = fromMaybe (defRetries rawDefaultLanguage) (rawRetries l) + } + +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" + +readConfig :: FilePath -> IO Config +readConfig = fmap fromRawConfig . readRawConfig + +readRawConfig :: FilePath -> IO RawConfig +readRawConfig f = do + x <- BL.readFile f + case decode1 x of + Left (pos, e) -> error $ prettyPosWithSource pos x e + Right y -> pure y diff --git a/src/Myriad/Core.hs b/src/Myriad/Core.hs index bf7d190..9fea144 100644 --- a/src/Myriad/Core.hs +++ b/src/Myriad/Core.hs @@ -6,9 +6,6 @@ module Myriad.Core , ImageName , EvalResult(..) , Env(..) - , MyriadConfig(..) - , DefaultLanguageConfig(..) - , LanguageConfig(..) , MyriadT , runMyriadT , initEnv @@ -32,78 +29,30 @@ import qualified Data.ByteString.Lazy as BL import qualified Data.Map.Strict as M import Data.Snowflake import qualified Data.Text as T -import Data.YAML import Control.Concurrent.MVar.Lifted import Control.Concurrent.QSem.Lifted import System.Process.Typed -type Language = T.Text +import Myriad.Config + type ContainerName = String + type ImageName = String -data EvalResult = EvalOk BL.ByteString | EvalTimedOut | EvalErrored - data Env = Env - { config :: MyriadConfig + { config :: Config , languagesDir :: FilePath - , containers :: MVar (M.Map Language ContainerName) - , containerSems :: MVar (M.Map Language QSem) - , evalSems :: MVar (M.Map Language QSem) + , containers :: MVar (M.Map LanguageName ContainerName) + , containerSems :: MVar (M.Map LanguageName QSem) + , evalSems :: MVar (M.Map LanguageName QSem) , snowflakeGen :: SnowflakeGen } -data MyriadConfig = MyriadConfig - { languages :: [LanguageConfig] - , defaultLanguage :: DefaultLanguageConfig - , buildConcurrently :: Bool - , prepareContainers :: Bool - , cleanupInterval :: Int - , port :: Int - } deriving (Show) - -instance FromYAML MyriadConfig where - parseYAML = withMap "config" $ \m -> MyriadConfig - <$> m .: "languages" - <*> m .: "defaultLanguage" - <*> m .: "buildConcurrently" - <*> m .: "prepareContainers" - <*> m .: "cleanupInterval" - <*> m .: "port" - -data DefaultLanguageConfig = DefaultLanguageConfig - { defMemory :: T.Text - , defCpus :: Double - , defTimeout :: Int - , defConcurrent :: Int - , defRetries :: Int - } deriving (Show) - -instance FromYAML DefaultLanguageConfig where - parseYAML = withMap "default language" $ \m -> DefaultLanguageConfig - <$> m .: "memory" - <*> m .: "cpus" - <*> m .: "timeout" - <*> m .: "concurrent" - <*> m .: "retries" - -data LanguageConfig = LanguageConfig - { name :: Language - , memory :: Maybe T.Text - , cpus :: Maybe Double - , timeout :: Maybe Int - , concurrent :: Maybe Int - , retries :: Maybe Int - } deriving (Show) - -instance FromYAML LanguageConfig where - parseYAML = withMap "language" $ \m -> LanguageConfig - <$> m .: "name" - <*> m .:? "memory" - <*> m .:? "cpus" - <*> m .:? "timeout" - <*> m .:? "concurrent" - <*> m .:? "retries" +data EvalResult + = EvalOk BL.ByteString + | EvalTimedOut + | EvalErrored newtype MyriadT m a = MyriadT { unMyriadT :: ReaderT Env (LoggingT m) a } deriving newtype @@ -133,13 +82,6 @@ instance MonadBaseControl b m => MonadBaseControl b (MyriadT m) where liftBaseWith = defaultLiftBaseWith restoreM = defaultRestoreM -readConfig :: FilePath -> IO MyriadConfig -readConfig f = do - x <- BL.readFile f - case decode1 x of - Left (pos, e) -> error $ prettyPosWithSource pos x e - Right y -> pure y - initEnv :: FilePath -> FilePath -> IO Env initEnv configPath languagesDir = Env diff --git a/src/Myriad/Docker.hs b/src/Myriad/Docker.hs index 63653eb..33b3492 100644 --- a/src/Myriad/Docker.hs +++ b/src/Myriad/Docker.hs @@ -12,7 +12,6 @@ module Myriad.Docker import Control.Monad.Reader import qualified Data.Map.Strict as M -import Data.Maybe import Data.Snowflake import Data.String.Conversions @@ -25,12 +24,13 @@ import System.FilePath (()) import System.Process.Typed import Myriad.Core +import Myriad.Config type Myriad = MyriadT IO -buildImage :: LanguageConfig -> Myriad () -buildImage lang@LanguageConfig { name, concurrent } = do - Env { config = MyriadConfig { prepareContainers }, languagesDir } <- ask +buildImage :: Language -> Myriad () +buildImage lang@Language { name, concurrent } = do + Env { config = Config { prepareContainers }, languagesDir } <- ask logInfo ["Building image ", cs $ imageName lang] exec_ ["docker build -t ", imageName lang, " ", cs languagesDir cs name] setupQSems @@ -39,22 +39,22 @@ buildImage lang@LanguageConfig { name, concurrent } = do where setupQSems :: Myriad () setupQSems = do - Env { config = MyriadConfig { defaultLanguage }, containerSems, evalSems } <- ask + Env { containerSems, evalSems } <- ask csem <- newQSem 1 -- We only want one container to be set up at a time - esem <- newQSem . fromIntegral $ fromMaybe (defConcurrent defaultLanguage) concurrent + esem <- newQSem $ fromIntegral concurrent mapMVar containerSems $ M.insert name csem mapMVar evalSems $ M.insert name esem buildAllImages :: Myriad () buildAllImages = do - MyriadConfig { languages, buildConcurrently } <- asks config + Config { languages, buildConcurrently } <- asks config if buildConcurrently then forConcurrently_ languages buildImage else forM_ languages buildImage startCleanup :: Myriad () startCleanup = do - MyriadConfig { cleanupInterval } <- asks config + Config { cleanupInterval } <- asks config when_ (cleanupInterval > 0) do let t = fromIntegral cleanupInterval * 60000000 fork $ timer t @@ -66,8 +66,8 @@ startCleanup = do logInfo ["Cleaned up ", cs $ show n, " containers"] timer t -setupContainer :: LanguageConfig -> Myriad ContainerName -setupContainer lang@LanguageConfig { name, memory, cpus } = do +setupContainer :: Language -> Myriad ContainerName +setupContainer lang@Language { name, memory, cpus } = do cnts <- asks containers >>= readMVar case cnts M.!? name of Nothing -> setup @@ -75,18 +75,18 @@ setupContainer lang@LanguageConfig { name, memory, cpus } = do where setup :: Myriad ContainerName setup = do - Env { config = MyriadConfig { defaultLanguage }, containers = ref } <- ask + ref <- asks 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 $ fromMaybe (defCpus defaultLanguage) cpus + , show cpus , " -m=" - , cs $ fromMaybe (defMemory defaultLanguage) memory + , cs memory , " --memory-swap=" - , cs $ fromMaybe (defMemory defaultLanguage) memory + , cs memory , " " , imageName lang , " /bin/sh" @@ -99,7 +99,7 @@ setupContainer lang@LanguageConfig { name, memory, cpus } = do logInfo ["Started container ", cs cnt] pure cnt -killContainer :: Language -> Myriad Bool +killContainer :: LanguageName -> Myriad Bool killContainer lang = do containers <- asks containers >>= readMVar case containers M.!? lang of @@ -129,11 +129,11 @@ killContainers = do xs <- forConcurrently (M.toList containers) \(k, v) -> (v,) <$> killContainer k pure . map fst $ filter snd xs -evalCode :: LanguageConfig -> Int -> String -> Myriad EvalResult -evalCode lang@LanguageConfig { name, timeout, retries } numRetries code = withContainer \cnt -> do +evalCode :: Language -> Int -> String -> Myriad EvalResult +evalCode lang@Language { 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. - Env { config = MyriadConfig { defaultLanguage }, snowflakeGen } <- ask + snowflakeGen <- asks snowflakeGen snowflake <- liftIO $ nextSnowflake snowflakeGen res <- try $ eval cnt snowflake case res of @@ -148,7 +148,7 @@ evalCode lang@LanguageConfig { name, timeout, retries } numRetries code = withCo -- Otherwise, the container was killed from another eval, so we should retry. else do writeMVar doneRef True - if numRetries < (fromIntegral $ fromMaybe (defRetries defaultLanguage) retries) + if numRetries < fromIntegral retries then do logError ["An exception occured in ", cs cnt, ", evaluation ", cs $ show snowflake, ", retrying:\n", cs $ show err] evalCode lang (numRetries + 1) code @@ -170,8 +170,7 @@ evalCode lang@LanguageConfig { name, timeout, retries } numRetries code = withCo timer :: MVar Bool -> Myriad () timer doneRef = do - Env { config = MyriadConfig { defaultLanguage } } <- ask - threadDelay $ (fromIntegral $ fromMaybe (defTimeout defaultLanguage) timeout) * 1000000 + threadDelay $ fromIntegral timeout * 1000000 done <- readMVar doneRef unless_ done do writeMVar doneRef True @@ -190,14 +189,14 @@ evalCode lang@LanguageConfig { name, timeout, retries } numRetries code = withCo logInfo ["Ran code in container ", cs cnt, ", evaluation ", cs $ show snowflake] pure $ EvalOk output -newContainerName :: LanguageConfig -> Myriad ContainerName -newContainerName LanguageConfig { name } = do +newContainerName :: Language -> Myriad ContainerName +newContainerName Language { 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 +imageName :: Language -> ImageName +imageName Language { name } = "1computer1/comp_iler:" <> cs name when_ :: Applicative f => Bool -> f a -> f () when_ p = when p . void diff --git a/src/Myriad/Server.hs b/src/Myriad/Server.hs index 72a0fb2..1fb3151 100644 --- a/src/Myriad/Server.hs +++ b/src/Myriad/Server.hs @@ -19,6 +19,7 @@ import Control.Concurrent.MVar.Lifted import Servant import Myriad.Core +import Myriad.Config import Myriad.Docker type Myriad = MyriadT Handler @@ -44,13 +45,13 @@ serverT = handleLanguages :<|> handleEval :<|> handleContainers :<|> handleClean handleLanguages :: Myriad [T.Text] handleLanguages = do logInfo ["GET /languages"] - MyriadConfig { languages } <- asks config + Config { languages } <- asks config pure . map name $ languages handleEval :: EvalRequest -> Myriad EvalResponse handleEval EvalRequest { language, code } = do logInfo ["POST /eval"] - MyriadConfig { languages } <- asks config + Config { languages } <- asks config case find (\x -> name x == language) languages of Nothing -> throwError $ err404 { errBody = "Language " <> cs language <> " was not found" } Just cfg -> do