From 4ea6c721c54fb1c32908df4e1d3c026aa19845f3 Mon Sep 17 00:00:00 2001 From: 1computer1 Date: Tue, 16 Jun 2020 22:02:12 -0400 Subject: [PATCH] switch from dhall to yaml --- .gitignore | 2 +- app/Main.hs | 17 +++++------ config.example.dhall | 39 ------------------------ config.example.yaml | 15 +++++++++ myriad.cabal | 4 +-- src/Myriad.hs | 7 ++--- src/Myriad/Core.hs | 72 +++++++++++++++++++++++++++++++++----------- src/Myriad/Docker.hs | 20 ++++++------ 8 files changed, 93 insertions(+), 83 deletions(-) delete mode 100644 config.example.dhall create mode 100644 config.example.yaml diff --git a/.gitignore b/.gitignore index 38634ba..9e822b4 100644 --- a/.gitignore +++ b/.gitignore @@ -10,4 +10,4 @@ stack.yaml.lock hie.yaml # other -config.dhall +config.yaml diff --git a/app/Main.hs b/app/Main.hs index 30b6d76..3a98586 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,14 +1,11 @@ module Main where -import qualified Data.Text as T - import Options.Applicative - import Myriad data Args = Args - { configInput :: T.Text - , languagesDir :: T.Text + { configPath :: FilePath + , languagesDir :: FilePath } parseArgs :: IO Args @@ -18,9 +15,9 @@ parseArgs = execParser $ info (helper <*> args) (fullDesc <> progDesc "Run the M <$> option str (mconcat [ long "config" , short 'c' - , help "Set the Dhall configuration" - , metavar "DHALL" - , value "./config.dhall" + , help "Set the myriad configuration" + , metavar "PATH" + , value "./config.yaml" , showDefault ]) <*> option str (mconcat @@ -34,5 +31,5 @@ parseArgs = execParser $ info (helper <*> args) (fullDesc <> progDesc "Run the M main :: IO () main = do - Args { configInput, languagesDir } <- parseArgs - runMyriadServer configInput languagesDir + Args { configPath, languagesDir } <- parseArgs + runMyriadServer configPath languagesDir diff --git a/config.example.dhall b/config.example.dhall deleted file mode 100644 index 9e990eb..0000000 --- a/config.example.dhall +++ /dev/null @@ -1,39 +0,0 @@ -let LanguageConfig : Type = - { name : Text -- Name of language as in languages folder - , memory : Text -- Maximum memory usage - , cpus : Text -- Maximum CPU usage - , timeout : Natural -- Timeout for code evaluation in seconds - , concurrent : Natural -- Maximum number of concurrent evaluations - , retries : Natural -- Maximum number of retries for unsure errors - } - --- Creates the default configuration given a language name. --- For more customization, use the (//) operator e.g. cfg "haskell" // { timeout = 20 } or write the full record out. -let cfg = \(name : Text) -> - { name = name - , memory = "256m" - , cpus = "0.25" - , timeout = 20 - , concurrent = 10 - , retries = 2 - } - -let Config : Type = - { languages : List LanguageConfig -- List of languages to enable - , buildConcurrently : Bool -- Whether to build images concurrently - , prepareContainers : Bool -- Whether to setup all containers on startup - , cleanupInterval : Natural -- The interval in minutes to kill containers periodically - , port : Natural -- Port to run on - } - --- Write your config here! -let config : Config = - { languages = - [ cfg "javascript" - ] - , buildConcurrently = True - , prepareContainers = False - , cleanupInterval = 30 - , port = 8081 - } -in config diff --git a/config.example.yaml b/config.example.yaml new file mode 100644 index 0000000..5ddc58a --- /dev/null +++ b/config.example.yaml @@ -0,0 +1,15 @@ +languages: + - name: haskell + - name: javascript + +defaultLanguage: + memory: 256m + cpus: 0.25 + timeout: 20 + concurrent: 10 + retries: 2 + +buildConcurrently: true +prepareContainers: false +cleanupInterval: 30 +port: 8081 diff --git a/myriad.cabal b/myriad.cabal index 0e78cf8..f7ad286 100644 --- a/myriad.cabal +++ b/myriad.cabal @@ -56,8 +56,8 @@ common shared , base >= 4.13 && < 5 , bytestring , containers - , dhall == 1.30.* , filepath + , HsYAML >= 0.2 , lifted-async , lifted-base , monad-control @@ -90,7 +90,7 @@ library src ghc-options: -Wall -executable myriad-exe +executable myriad import: shared main-is: Main.hs other-modules: diff --git a/src/Myriad.hs b/src/Myriad.hs index 06ea630..376e551 100644 --- a/src/Myriad.hs +++ b/src/Myriad.hs @@ -5,7 +5,6 @@ module Myriad import Control.Monad.Logger (runStdoutLoggingT) import Data.String.Conversions -import qualified Data.Text as T import Network.Wai.Handler.Warp @@ -13,9 +12,9 @@ import Myriad.Core import Myriad.Docker import Myriad.Server -runMyriadServer :: T.Text -> T.Text -> IO () -runMyriadServer configInput languagesDir = do - env <- initEnv configInput languagesDir +runMyriadServer :: FilePath -> FilePath -> IO () +runMyriadServer configPath languagesDir = do + env <- initEnv configPath languagesDir runMyriadT env do buildAllImages startCleanup diff --git a/src/Myriad/Core.hs b/src/Myriad/Core.hs index ccd6211..d8c2566 100644 --- a/src/Myriad/Core.hs +++ b/src/Myriad/Core.hs @@ -7,6 +7,7 @@ module Myriad.Core , EvalResult(..) , Env(..) , MyriadConfig(..) + , DefaultLanguageConfig(..) , LanguageConfig(..) , MyriadT , Myriadic @@ -32,7 +33,7 @@ import qualified Data.ByteString.Lazy as BL import qualified Data.Map.Strict as M import Data.Snowflake import qualified Data.Text as T -import Dhall +import Data.YAML import Control.Concurrent.MVar.Lifted import Control.Concurrent.QSem.Lifted @@ -46,7 +47,7 @@ data EvalResult = EvalOk BL.ByteString | EvalTimedOut | EvalErrored data Env = Env { config :: MyriadConfig - , languagesDir :: T.Text + , languagesDir :: FilePath , containers :: MVar (M.Map Language ContainerName) , containerSems :: MVar (M.Map Language QSem) , evalSems :: MVar (M.Map Language QSem) @@ -55,24 +56,55 @@ data Env = Env data MyriadConfig = MyriadConfig { languages :: [LanguageConfig] + , defaultLanguage :: DefaultLanguageConfig , buildConcurrently :: Bool , prepareContainers :: Bool - , cleanupInterval :: Natural - , port :: Natural - } deriving (Show, Generic) + , cleanupInterval :: Int + , port :: Int + } deriving (Show) -instance FromDhall MyriadConfig +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 :: T.Text - , cpus :: T.Text - , timeout :: Natural - , concurrent :: Natural - , retries :: Natural - } deriving (Show, Generic) + , memory :: Maybe T.Text + , cpus :: Maybe Double + , timeout :: Maybe Int + , concurrent :: Maybe Int + , retries :: Maybe Int + } deriving (Show) -instance FromDhall LanguageConfig +instance FromYAML LanguageConfig where + parseYAML = withMap "language" $ \m -> LanguageConfig + <$> m .: "name" + <*> m .:? "memory" + <*> m .:? "cpus" + <*> m .:? "timeout" + <*> m .:? "concurrent" + <*> m .:? "retries" newtype MyriadT m a = MyriadT { unMyriadT :: ReaderT Env (LoggingT m) a } deriving newtype @@ -104,13 +136,17 @@ instance MonadBaseControl b m => MonadBaseControl b (MyriadT m) where type Myriadic m = (MonadReader Env m, MonadLogger m, MonadLoggerIO m, MonadIO m, MonadBase IO m, MonadBaseControl IO m) -readConfig :: T.Text -> IO MyriadConfig -readConfig = input auto +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 :: T.Text -> T.Text -> IO Env -initEnv configInput languagesDir = +initEnv :: FilePath -> FilePath -> IO Env +initEnv configPath languagesDir = Env - <$> readConfig configInput + <$> readConfig configPath <*> pure languagesDir <*> newMVar M.empty <*> newMVar M.empty diff --git a/src/Myriad/Docker.hs b/src/Myriad/Docker.hs index 85250ff..d544f0e 100644 --- a/src/Myriad/Docker.hs +++ b/src/Myriad/Docker.hs @@ -12,6 +12,7 @@ module Myriad.Docker import Control.Monad.Reader import qualified Data.Map.Strict as M +import Data.Maybe import Data.Snowflake import Data.String.Conversions @@ -36,9 +37,9 @@ buildImage lang@LanguageConfig { name, concurrent } = do where setupQSems :: Myriadic m => m () setupQSems = do - Env { containerSems, evalSems } <- ask + Env { config = MyriadConfig { defaultLanguage }, containerSems, evalSems } <- ask csem <- newQSem 1 -- We only want one container to be set up at a time - esem <- newQSem $ fromIntegral concurrent + esem <- newQSem . fromIntegral $ fromMaybe (defConcurrent defaultLanguage) concurrent mapMVar containerSems $ M.insert name csem mapMVar evalSems $ M.insert name esem @@ -72,18 +73,18 @@ setupContainer lang@LanguageConfig { name, memory, cpus } = do where setup :: Myriadic m => m ContainerName setup = do - ref <- asks containers + Env { config = MyriadConfig { defaultLanguage }, containers = ref } <- ask 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=" - , cs cpus + , show $ fromMaybe (defCpus defaultLanguage) cpus , " -m=" - , cs memory + , cs $ fromMaybe (defMemory defaultLanguage) memory , " --memory-swap=" - , cs memory + , cs $ fromMaybe (defMemory defaultLanguage) memory , " " , imageName lang , " /bin/sh" @@ -130,7 +131,7 @@ evalCode :: Myriadic m => LanguageConfig -> Int -> String -> m 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. - snowflakeGen <- asks snowflakeGen + Env { config = MyriadConfig { defaultLanguage }, snowflakeGen } <- ask snowflake <- liftIO $ nextSnowflake snowflakeGen res <- try $ eval cnt snowflake case res of @@ -145,7 +146,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 retries + if numRetries < (fromIntegral $ fromMaybe (defRetries defaultLanguage) retries) then do logError ["An exception occured in ", cs cnt, ", evaluation ", cs $ show snowflake, ", retrying:\n", cs $ show err] evalCode lang (numRetries + 1) code @@ -167,7 +168,8 @@ evalCode lang@LanguageConfig { name, timeout, retries } numRetries code = withCo timer :: Myriadic m => MVar Bool -> m () timer doneRef = do - threadDelay $ fromIntegral timeout * 1000000 + Env { config = MyriadConfig { defaultLanguage } } <- ask + threadDelay $ (fromIntegral $ fromMaybe (defTimeout defaultLanguage) timeout) * 1000000 done <- readMVar doneRef unless_ done do writeMVar doneRef True