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

use optics labels

Browse source
This commit is contained in:
1computer1 2020-06-16 23:56:01 -04:00
parent d23e8ab892
commit 2597c80f3d
6 changed files with 161 additions and 134 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
myriad.cabal
View file

@ -36,6 +36,7 @@ common shared
MultiParamTypeClasses
MultiWayIf
NamedFieldPuns
OverloadedLabels
OverloadedStrings
PatternSynonyms
TupleSections
@ -55,6 +56,7 @@ common shared
, monad-control
, monad-logger
, mtl
, optics
, servant
, servant-server
, snowflake

5
src/Myriad.hs
View file

@ -8,7 +8,8 @@ import Data.String.Conversions
import Network.Wai.Handler.Warp
import Myriad.Config
import Optics
import Myriad.Core
import Myriad.Docker
import Myriad.Server
@ -20,7 +21,7 @@ runMyriadServer configPath languagesDir = do
buildAllImages
startCleanup
logInfo ["Finished Docker-related setup"]
let myriadPort = fromIntegral . port $ config env
let myriadPort = fromIntegral $ env ^. #config % #port
onReady = runStdoutLoggingT $ logInfo ["Server started on port ", cs $ show myriadPort, "!"]
settings = setPort myriadPort . setBeforeMainLoop onReady $ defaultSettings
runSettings settings $ app env

170
src/Myriad/Config.hs
View file

@ -1,3 +1,7 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}
module Myriad.Config
( LanguageName
, Config(..)
@ -10,25 +14,89 @@ import Data.Maybe
import qualified Data.Text as T
import Data.YAML
import Optics
type LanguageName = T.Text
data Config = Config
{ languages :: [Language]
, buildConcurrently :: Bool
, prepareContainers :: Bool
, cleanupInterval :: Int
, port :: Int
data Language = Language
{ _name :: LanguageName
, _memory :: T.Text
, _cpus :: Double
, _timeout :: Int
, _concurrent :: Int
, _retries :: Int
} deriving (Show)
data Language = Language
{ name :: LanguageName
, memory :: T.Text
, cpus :: Double
, timeout :: Int
, concurrent :: Int
, retries :: Int
makeFieldLabelsWith classUnderscoreNoPrefixFields ''Language
data Config = Config
{ _languages :: [Language]
, _buildConcurrently :: Bool
, _prepareContainers :: Bool
, _cleanupInterval :: Int
, _port :: Int
} deriving (Show)
makeFieldLabelsWith classUnderscoreNoPrefixFields ''Config
data DefaultLanguage = DefaultLanguage
{ _memory :: T.Text
, _cpus :: Double
, _timeout :: Int
, _concurrent :: Int
, _retries :: Int
} deriving (Show)
makeFieldLabelsWith classUnderscoreNoPrefixFields ''DefaultLanguage
instance FromYAML DefaultLanguage where
parseYAML = withMap "default language" $ \m -> DefaultLanguage
<$> m .: "memory"
<*> m .: "cpus"
<*> m .: "timeout"
<*> m .: "concurrent"
<*> m .: "retries"
data RawLanguage = RawLanguage
{ _name :: LanguageName
, _memory :: Maybe T.Text
, _cpus :: Maybe Double
, _timeout :: Maybe Int
, _concurrent :: Maybe Int
, _retries :: Maybe Int
} deriving (Show)
makeFieldLabelsWith classUnderscoreNoPrefixFields ''RawLanguage
instance FromYAML RawLanguage where
parseYAML = withMap "language" $ \m -> RawLanguage
<$> m .: "name"
<*> m .:? "memory"
<*> m .:? "cpus"
<*> m .:? "timeout"
<*> m .:? "concurrent"
<*> m .:? "retries"
data RawConfig = RawConfig
{ _languages :: [RawLanguage]
, _defaultLanguage :: DefaultLanguage
, _buildConcurrently :: Bool
, _prepareContainers :: Bool
, _cleanupInterval :: Int
, _port :: Int
} deriving (Show)
makeFieldLabelsWith classUnderscoreNoPrefixFields ''RawConfig
instance FromYAML RawConfig where
parseYAML = withMap "config" $ \m -> RawConfig
<$> m .: "languages"
<*> m .: "defaultLanguage"
<*> m .: "buildConcurrently"
<*> m .: "prepareContainers"
<*> m .: "cleanupInterval"
<*> m .: "port"
readConfig :: FilePath -> IO Config
readConfig = fmap fromRawConfig . readRawConfig
@ -42,72 +110,20 @@ readRawConfig f = do
fromRawConfig :: RawConfig -> Config
fromRawConfig r =
Config
{ languages = map (fromRawLanguage $ rawDefaultLanguage r) $ rawLanguages r
, buildConcurrently = rawBuildConcurrently r
, prepareContainers = rawPrepareContainers r
, cleanupInterval = rawCleanupInterval r
, port = rawPort r
{ _languages = map (fromRawLanguage (r ^. #defaultLanguage)) $ r ^. #languages
, _buildConcurrently = r ^. #buildConcurrently
, _prepareContainers = r ^. #prepareContainers
, _cleanupInterval = r ^. #cleanupInterval
, _port = r ^. #port
}
fromRawLanguage :: DefaultLanguage -> RawLanguage -> Language
fromRawLanguage d l =
fromRawLanguage d r =
Language
{ name = rawName l
, memory = fromMaybe (defMemory d) (rawMemory l)
, cpus = fromMaybe (defCpus d) (rawCpus l)
, timeout = fromMaybe (defTimeout d) (rawTimeout l)
, concurrent = fromMaybe (defConcurrent d) (rawConcurrent l)
, retries = fromMaybe (defRetries d) (rawRetries l)
{ _name = r ^. #name
, _memory = fromMaybe (d ^. #memory) (r ^. #memory)
, _cpus = fromMaybe (d ^. #cpus) (r ^. #cpus)
, _timeout = fromMaybe (d ^. #timeout) (r ^. #timeout)
, _concurrent = fromMaybe (d ^. #concurrent) (r ^. #concurrent)
, _retries = fromMaybe (d ^. #retries) (r ^. #retries)
}
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"

17
src/Myriad/Core.hs
View file

@ -1,3 +1,4 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}
module Myriad.Core
@ -33,6 +34,8 @@ import Control.Concurrent.MVar.Lifted
import Control.Concurrent.QSem.Lifted
import System.Process.Typed
import Optics
import Myriad.Config
type ContainerName = String
@ -40,14 +43,16 @@ type ContainerName = String
type ImageName = String
data Env = Env
{ config :: Config
, languagesDir :: FilePath
, containers :: MVar (M.Map LanguageName ContainerName)
, containerSems :: MVar (M.Map LanguageName QSem)
, evalSems :: MVar (M.Map LanguageName QSem)
, snowflakeGen :: SnowflakeGen
{ _config :: Config
, _languagesDir :: FilePath
, _containers :: MVar (M.Map LanguageName ContainerName)
, _containerSems :: MVar (M.Map LanguageName QSem)
, _evalSems :: MVar (M.Map LanguageName QSem)
, _snowflakeGen :: SnowflakeGen
}
makeFieldLabelsWith classUnderscoreNoPrefixFields ''Env
newtype MyriadT m a = MyriadT { unMyriadT :: ReaderT Env (LoggingT m) a }
deriving newtype
( Functor

80
src/Myriad/Docker.hs
View file

@ -24,6 +24,8 @@ import Control.Exception.Lifted
import System.FilePath ((</>))
import System.Process.Typed
import Optics
import Myriad.Config
import Myriad.Core
@ -36,34 +38,34 @@ data EvalResult
deriving (Show)
buildImage :: Language -> Myriad ()
buildImage lang@Language { name, concurrent } = do
Env { config = Config { prepareContainers }, languagesDir } <- ask
buildImage lang = do
env <- ask
logInfo ["Building image ", cs $ imageName lang]
exec_ ["docker build -t ", imageName lang, " ", cs languagesDir </> cs name]
exec_ ["docker build -t ", imageName lang, " ", cs (env ^. #languagesDir) </> cs (lang ^. #name)]
setupQSems
logInfo ["Built image ", cs $ imageName lang]
when prepareContainers . void $ setupContainer lang
when (env ^. #config % #prepareContainers) . void $ setupContainer lang
where
setupQSems :: Myriad ()
setupQSems = do
Env { containerSems, evalSems } <- ask
env <- ask
csem <- newQSem 1 -- We only want one container to be set up at a time
esem <- newQSem $ fromIntegral concurrent
mapMVar containerSems $ M.insert name csem
mapMVar evalSems $ M.insert name esem
esem <- newQSem $ fromIntegral (lang ^. #concurrent)
mapMVar (env ^. #containerSems) $ M.insert (lang ^. #name) csem
mapMVar (env ^. #evalSems) $ M.insert (lang ^. #name) esem
buildAllImages :: Myriad ()
buildAllImages = do
Config { languages, buildConcurrently } <- asks config
if buildConcurrently
then forConcurrently_ languages buildImage
else forM_ languages buildImage
config <- gview #config
if config ^. #buildConcurrently
then forConcurrently_ (config ^. #languages) buildImage
else forM_ (config ^. #languages) buildImage
startCleanup :: Myriad ()
startCleanup = do
Config { cleanupInterval } <- asks config
when (cleanupInterval > 0) . void $ do
let t = fromIntegral cleanupInterval * 60000000
config <- gview #config
when (config ^. #cleanupInterval > 0) . void $ do
let t = fromIntegral (config ^. #cleanupInterval) * 60000000
fork $ timer t
where
timer :: Int -> Myriad ()
@ -74,26 +76,26 @@ startCleanup = do
timer t
setupContainer :: Language -> Myriad ContainerName
setupContainer lang@Language { name, memory, cpus } = do
cnts <- asks containers >>= readMVar
case cnts M.!? name of
setupContainer lang = do
cnts <- gview #containers >>= readMVar
case cnts M.!? (lang ^. #name) of
Nothing -> setup
Just cnt -> pure cnt
where
setup :: Myriad ContainerName
setup = do
ref <- asks containers
ref <- gview #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 cpus
, show $ lang ^. #cpus
, " -m="
, cs memory
, cs $ lang ^. #memory
, " --memory-swap="
, cs memory
, cs $ lang ^. #memory
, " "
, imageName lang
, " /bin/sh"
@ -102,13 +104,13 @@ setupContainer lang@Language { name, memory, cpus } = do
-- 711 so that users can't traverse into other people's code
exec_ ["docker exec ", cnt, " mkdir eval"]
exec_ ["docker exec ", cnt, " chmod 711 eval"]
mapMVar ref $ M.insert name cnt
mapMVar ref $ M.insert (lang ^. #name) cnt
logInfo ["Started container ", cs cnt]
pure cnt
killContainer :: LanguageName -> Myriad Bool
killContainer lang = do
containers <- asks containers >>= readMVar
containers <- gview #containers >>= readMVar
case containers M.!? lang of
Nothing -> pure False
Just cnt -> do
@ -121,7 +123,7 @@ killContainer lang = do
where
kill :: ContainerName -> Myriad (Maybe SomeException)
kill cnt = do
ref <- asks containers
ref <- gview #containers
mapMVar ref $ M.delete lang
res <- try $ exec_ ["docker kill ", cnt]
case res of
@ -132,20 +134,20 @@ killContainer lang = do
killContainers :: Myriad [ContainerName]
killContainers = do
containers <- asks containers >>= readMVar
containers <- gview #containers >>= readMVar
xs <- forConcurrently (M.toList containers) $ \(k, v) -> (v,) <$> killContainer k
pure . map fst $ filter snd xs
evalCode :: Language -> Int -> String -> Myriad EvalResult
evalCode lang@Language { name, timeout, retries } numRetries code = withContainer $ \cnt -> do
evalCode lang 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
snowflakeGen <- gview #snowflakeGen
snowflake <- liftIO $ nextSnowflake snowflakeGen
res <- try $ eval cnt snowflake
case res of
Left (SomeException err) -> do
void $ killContainer name
void . killContainer $ lang ^. #name
done <- readMVar doneRef
if done
-- If we find the eval is done from an exception, then it was timed out.
@ -155,7 +157,7 @@ evalCode lang@Language { name, timeout, retries } numRetries code = withContaine
-- Otherwise, the container was killed from another eval, so we should retry.
else do
writeMVar doneRef True
if numRetries < fromIntegral retries
if numRetries < fromIntegral (lang ^. #retries)
then do
logError ["An exception occured in ", cs cnt, ", evaluation ", cs $ show snowflake, ", retrying:\n", cs $ show err]
evalCode lang (numRetries + 1) code
@ -168,20 +170,20 @@ evalCode lang@Language { name, timeout, retries } numRetries code = withContaine
where
withContainer :: (ContainerName -> Myriad a) -> Myriad a
withContainer f = do
Env { containerSems, evalSems } <- ask
csem <- (M.! name) <$> readMVar containerSems
esem <- (M.! name) <$> readMVar evalSems
env <- ask
csem <- (M.! (lang ^. #name)) <$> readMVar (env ^. #containerSems)
esem <- (M.! (lang ^. #name)) <$> readMVar (env ^. #evalSems)
bracket_ (waitQSem esem) (signalQSem esem) $ do
cnt <- bracket_ (waitQSem csem) (signalQSem csem) $ setupContainer lang
f cnt
timer :: MVar Bool -> Myriad ()
timer doneRef = do
threadDelay $ fromIntegral timeout * 1000000
threadDelay $ fromIntegral (lang ^. #timeout) * 1000000
done <- readMVar doneRef
unless done . void $ do
writeMVar doneRef True
killContainer name
killContainer $ lang ^. #name
eval :: ContainerName -> Snowflake -> Myriad EvalResult
eval cnt snowflake = do
@ -197,10 +199,10 @@ evalCode lang@Language { name, timeout, retries } numRetries code = withContaine
pure $ EvalOk output
newContainerName :: Language -> Myriad ContainerName
newContainerName Language { name } = do
snowflakeGen <- asks snowflakeGen
newContainerName lang = do
snowflakeGen <- gview #snowflakeGen
snowflake <- liftIO $ nextSnowflake snowflakeGen
pure $ "comp_iler-" <> cs name <> "-" <> show snowflake
pure $ "comp_iler-" <> cs (lang ^. #name) <> "-" <> show snowflake
imageName :: Language -> ImageName
imageName Language { name } = "1computer1/comp_iler:" <> cs name
imageName lang = "1computer1/comp_iler:" <> cs (lang ^. #name)

13
src/Myriad/Server.hs
View file

@ -16,7 +16,8 @@ import Control.Concurrent.Async.Lifted
import Control.Concurrent.MVar.Lifted
import Servant
import Myriad.Config
import Optics
import Myriad.Core
import Myriad.Docker
@ -49,14 +50,14 @@ serverT = handleLanguages :<|> handleEval :<|> handleContainers :<|> handleClean
handleLanguages :: Myriad [T.Text]
handleLanguages = do
logInfo ["GET /languages"]
Config { languages } <- asks config
pure . map name $ languages
languages <- gview $ #config % #languages
pure $ map (^. #name) languages
handleEval :: EvalRequest -> Myriad EvalResponse
handleEval EvalRequest { language, code } = do
logInfo ["POST /eval"]
Config { languages } <- asks config
case find (\x -> name x == language) languages of
languages <- gview $ #config % #languages
case find (\x -> x ^. #name == language) languages of
Nothing -> throwError $ err404 { errBody = "Language " <> cs language <> " was not found" }
Just cfg -> do
env <- ask
@ -69,7 +70,7 @@ serverT = handleLanguages :<|> handleEval :<|> handleContainers :<|> handleClean
handleContainers :: Myriad [T.Text]
handleContainers = do
logInfo ["GET /containers"]
containers <- asks containers >>= readMVar
containers <- gview #containers >>= readMVar
pure . map cs $ M.elems containers
handleCleanup :: Myriad [T.Text]