SunRed
/
myriad
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

switch from dhall to yaml

This commit is contained in:
1computer1 2020-06-16 22:02:12 -04:00
parent bab91a0cca
commit 4ea6c721c5
8 changed files with 93 additions and 83 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitignore vendored
View File

@ -10,4 +10,4 @@ stack.yaml.lock
hie.yaml
# other
config.dhall
config.yaml

17
app/Main.hs
View File

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

39
config.example.dhall
View File

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

15
config.example.yaml Normal file
View File

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

4
myriad.cabal
View File

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

7
src/Myriad.hs
View File

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

72
src/Myriad/Core.hs
View File

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

20
src/Myriad/Docker.hs
View File

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