config: refactor config reading

This commit is contained in:
1computer1 2020-06-16 22:29:12 -04:00
parent 57ea8696e7
commit 3a10e3e72c
6 changed files with 153 additions and 96 deletions

View file

@ -79,6 +79,7 @@ library
import: shared
exposed-modules:
Myriad
Myriad.Config
Myriad.Core
Myriad.Docker
Myriad.Server

View file

@ -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

113
src/Myriad/Config.hs Normal file
View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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