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

use optics labels

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 MultiParamTypeClasses
MultiWayIf MultiWayIf
NamedFieldPuns NamedFieldPuns
OverloadedLabels
OverloadedStrings OverloadedStrings
PatternSynonyms PatternSynonyms
TupleSections TupleSections
@ -55,6 +56,7 @@ common shared
, monad-control , monad-control
, monad-logger , monad-logger
, mtl , mtl
, optics
, servant , servant
, servant-server , servant-server
, snowflake , snowflake

5
src/Myriad.hs
View File

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

170
src/Myriad/Config.hs
View File

@ -1,3 +1,7 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}
module Myriad.Config module Myriad.Config
( LanguageName ( LanguageName
, Config(..) , Config(..)
@ -10,25 +14,89 @@ import Data.Maybe
import qualified Data.Text as T import qualified Data.Text as T
import Data.YAML import Data.YAML
import Optics
type LanguageName = T.Text type LanguageName = T.Text
data Config = Config data Language = Language
{ languages :: [Language] { _name :: LanguageName
, buildConcurrently :: Bool , _memory :: T.Text
, prepareContainers :: Bool , _cpus :: Double
, cleanupInterval :: Int , _timeout :: Int
, port :: Int , _concurrent :: Int
, _retries :: Int
} deriving (Show) } deriving (Show)
data Language = Language makeFieldLabelsWith classUnderscoreNoPrefixFields ''Language
{ name :: LanguageName
, memory :: T.Text data Config = Config
, cpus :: Double { _languages :: [Language]
, timeout :: Int , _buildConcurrently :: Bool
, concurrent :: Int , _prepareContainers :: Bool
, retries :: Int , _cleanupInterval :: Int
, _port :: Int
} deriving (Show) } 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 :: FilePath -> IO Config
readConfig = fmap fromRawConfig . readRawConfig readConfig = fmap fromRawConfig . readRawConfig
@ -42,72 +110,20 @@ readRawConfig f = do
fromRawConfig :: RawConfig -> Config fromRawConfig :: RawConfig -> Config
fromRawConfig r = fromRawConfig r =
Config Config
{ languages = map (fromRawLanguage $ rawDefaultLanguage r) $ rawLanguages r { _languages = map (fromRawLanguage (r ^. #defaultLanguage)) $ r ^. #languages
, buildConcurrently = rawBuildConcurrently r , _buildConcurrently = r ^. #buildConcurrently
, prepareContainers = rawPrepareContainers r , _prepareContainers = r ^. #prepareContainers
, cleanupInterval = rawCleanupInterval r , _cleanupInterval = r ^. #cleanupInterval
, port = rawPort r , _port = r ^. #port
} }
fromRawLanguage :: DefaultLanguage -> RawLanguage -> Language fromRawLanguage :: DefaultLanguage -> RawLanguage -> Language
fromRawLanguage d l = fromRawLanguage d r =
Language Language
{ name = rawName l { _name = r ^. #name
, memory = fromMaybe (defMemory d) (rawMemory l) , _memory = fromMaybe (d ^. #memory) (r ^. #memory)
, cpus = fromMaybe (defCpus d) (rawCpus l) , _cpus = fromMaybe (d ^. #cpus) (r ^. #cpus)
, timeout = fromMaybe (defTimeout d) (rawTimeout l) , _timeout = fromMaybe (d ^. #timeout) (r ^. #timeout)
, concurrent = fromMaybe (defConcurrent d) (rawConcurrent l) , _concurrent = fromMaybe (d ^. #concurrent) (r ^. #concurrent)
, retries = fromMaybe (defRetries d) (rawRetries l) , _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 #-} {-# LANGUAGE UndecidableInstances #-}
module Myriad.Core module Myriad.Core
@ -33,6 +34,8 @@ import Control.Concurrent.MVar.Lifted
import Control.Concurrent.QSem.Lifted import Control.Concurrent.QSem.Lifted
import System.Process.Typed import System.Process.Typed
import Optics
import Myriad.Config import Myriad.Config
type ContainerName = String type ContainerName = String
@ -40,14 +43,16 @@ type ContainerName = String
type ImageName = String type ImageName = String
data Env = Env data Env = Env
{ config :: Config { _config :: Config
, languagesDir :: FilePath , _languagesDir :: FilePath
, containers :: MVar (M.Map LanguageName ContainerName) , _containers :: MVar (M.Map LanguageName ContainerName)
, containerSems :: MVar (M.Map LanguageName QSem) , _containerSems :: MVar (M.Map LanguageName QSem)
, evalSems :: MVar (M.Map LanguageName QSem) , _evalSems :: MVar (M.Map LanguageName QSem)
, snowflakeGen :: SnowflakeGen , _snowflakeGen :: SnowflakeGen
} }
makeFieldLabelsWith classUnderscoreNoPrefixFields ''Env
newtype MyriadT m a = MyriadT { unMyriadT :: ReaderT Env (LoggingT m) a } newtype MyriadT m a = MyriadT { unMyriadT :: ReaderT Env (LoggingT m) a }
deriving newtype deriving newtype
( Functor ( Functor

88
src/Myriad/Docker.hs
View File

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