config: refactor config reading
This commit is contained in:
1computer1
parent
57ea8696e7
commit
3a10e3e72c
|
|
@ -79,6 +79,7 @@ library
|
|||
import: shared
|
||||
exposed-modules:
|
||||
Myriad
|
||||
Myriad.Config
|
||||
Myriad.Core
|
||||
Myriad.Docker
|
||||
Myriad.Server
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue