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

core: use concrete monads

Browse source
This commit is contained in:
1computer1 2020-06-16 22:08:26 -04:00
parent 4ea6c721c5
commit 57ea8696e7
3 changed files with 28 additions and 25 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
src/Myriad/Core.hs
View file

@ -10,7 +10,6 @@ module Myriad.Core
, DefaultLanguageConfig(..) , DefaultLanguageConfig(..)
, LanguageConfig(..) , LanguageConfig(..)
, MyriadT , MyriadT
, Myriadic
, runMyriadT , runMyriadT
, initEnv , initEnv
, exec , exec
@ -134,8 +133,6 @@ instance MonadBaseControl b m => MonadBaseControl b (MyriadT m) where
liftBaseWith = defaultLiftBaseWith liftBaseWith = defaultLiftBaseWith
restoreM = defaultRestoreM restoreM = defaultRestoreM
type Myriadic m = (MonadReader Env m, MonadLogger m, MonadLoggerIO m, MonadIO m, MonadBase IO m, MonadBaseControl IO m)
readConfig :: FilePath -> IO MyriadConfig readConfig :: FilePath -> IO MyriadConfig
readConfig f = do readConfig f = do
x <- BL.readFile f x <- BL.readFile f

32
src/Myriad/Docker.hs
View file

@ -26,7 +26,9 @@ import System.Process.Typed
import Myriad.Core import Myriad.Core
buildImage :: Myriadic m => LanguageConfig -> m () type Myriad = MyriadT IO
buildImage :: LanguageConfig -> Myriad ()
buildImage lang@LanguageConfig { name, concurrent } = do buildImage lang@LanguageConfig { name, concurrent } = do
Env { config = MyriadConfig { prepareContainers }, languagesDir } <- ask Env { config = MyriadConfig { prepareContainers }, languagesDir } <- ask
logInfo ["Building image ", cs $ imageName lang] logInfo ["Building image ", cs $ imageName lang]
@ -35,7 +37,7 @@ buildImage lang@LanguageConfig { name, concurrent } = do
logInfo ["Built image ", cs $ imageName lang] logInfo ["Built image ", cs $ imageName lang]
when_ prepareContainers $ setupContainer lang when_ prepareContainers $ setupContainer lang
where where
setupQSems :: Myriadic m => m () setupQSems :: Myriad ()
setupQSems = do setupQSems = do
Env { config = MyriadConfig { defaultLanguage }, 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 csem <- newQSem 1 -- We only want one container to be set up at a time
@ -43,35 +45,35 @@ buildImage lang@LanguageConfig { name, concurrent } = do
mapMVar containerSems $ M.insert name csem mapMVar containerSems $ M.insert name csem
mapMVar evalSems $ M.insert name esem mapMVar evalSems $ M.insert name esem
buildAllImages :: Myriadic m => m () buildAllImages :: Myriad ()
buildAllImages = do buildAllImages = do
MyriadConfig { languages, buildConcurrently } <- asks config MyriadConfig { languages, buildConcurrently } <- asks config
if buildConcurrently if buildConcurrently
then forConcurrently_ languages buildImage then forConcurrently_ languages buildImage
else forM_ languages buildImage else forM_ languages buildImage
startCleanup :: Myriadic m => m () startCleanup :: Myriad ()
startCleanup = do startCleanup = do
MyriadConfig { cleanupInterval } <- asks config MyriadConfig { cleanupInterval } <- asks config
when_ (cleanupInterval > 0) do when_ (cleanupInterval > 0) do
let t = fromIntegral cleanupInterval * 60000000 let t = fromIntegral cleanupInterval * 60000000
fork $ timer t fork $ timer t
where where
timer :: Int -> Myriadic m => m () timer :: Int -> Myriad ()
timer t = forever do timer t = forever do
threadDelay t threadDelay t
n <- killContainers n <- killContainers
logInfo ["Cleaned up ", cs $ show n, " containers"] logInfo ["Cleaned up ", cs $ show n, " containers"]
timer t timer t
setupContainer :: Myriadic m => LanguageConfig -> m ContainerName setupContainer :: LanguageConfig -> Myriad ContainerName
setupContainer lang@LanguageConfig { name, memory, cpus } = do setupContainer lang@LanguageConfig { name, memory, cpus } = do
cnts <- asks containers >>= readMVar cnts <- asks containers >>= readMVar
case cnts M.!? name of case cnts M.!? name of
Nothing -> setup Nothing -> setup
Just cnt -> pure cnt Just cnt -> pure cnt
where where
setup :: Myriadic m => m ContainerName setup :: Myriad ContainerName
setup = do setup = do
Env { config = MyriadConfig { defaultLanguage }, containers = ref } <- ask Env { config = MyriadConfig { defaultLanguage }, containers = ref } <- ask
cnt <- newContainerName lang cnt <- newContainerName lang
@ -97,7 +99,7 @@ setupContainer lang@LanguageConfig { name, memory, cpus } = do
logInfo ["Started container ", cs cnt] logInfo ["Started container ", cs cnt]
pure cnt pure cnt
killContainer :: Myriadic m => Language -> m Bool killContainer :: Language -> Myriad Bool
killContainer lang = do killContainer lang = do
containers <- asks containers >>= readMVar containers <- asks containers >>= readMVar
case containers M.!? lang of case containers M.!? lang of
@ -110,7 +112,7 @@ killContainer lang = 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 :: Myriadic m => ContainerName -> m (Maybe SomeException) kill :: ContainerName -> Myriad (Maybe SomeException)
kill cnt = do kill cnt = do
ref <- asks containers ref <- asks containers
mapMVar ref $ M.delete lang mapMVar ref $ M.delete lang
@ -121,13 +123,13 @@ killContainer lang = do
logInfo ["Killed container ", cs cnt] logInfo ["Killed container ", cs cnt]
pure Nothing pure Nothing
killContainers :: Myriadic m => m [ContainerName] killContainers :: Myriad [ContainerName]
killContainers = do killContainers = do
containers <- asks containers >>= readMVar containers <- asks 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 :: Myriadic m => LanguageConfig -> Int -> String -> m EvalResult evalCode :: LanguageConfig -> Int -> String -> Myriad EvalResult
evalCode lang@LanguageConfig { name, timeout, retries } numRetries code = withContainer \cnt -> do 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. 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.
@ -157,7 +159,7 @@ evalCode lang@LanguageConfig { name, timeout, retries } numRetries code = withCo
writeMVar doneRef True writeMVar doneRef True
pure x pure x
where where
withContainer :: Myriadic m => (ContainerName -> m a) -> m a withContainer :: (ContainerName -> Myriad a) -> Myriad a
withContainer f = do withContainer f = do
Env { containerSems, evalSems } <- ask Env { containerSems, evalSems } <- ask
csem <- (M.! name) <$> readMVar containerSems csem <- (M.! name) <$> readMVar containerSems
@ -166,7 +168,7 @@ evalCode lang@LanguageConfig { name, timeout, retries } numRetries code = withCo
cnt <- bracket_ (waitQSem csem) (signalQSem csem) $ setupContainer lang cnt <- bracket_ (waitQSem csem) (signalQSem csem) $ setupContainer lang
f cnt f cnt
timer :: Myriadic m => MVar Bool -> m () timer :: MVar Bool -> Myriad ()
timer doneRef = do timer doneRef = do
Env { config = MyriadConfig { defaultLanguage } } <- ask Env { config = MyriadConfig { defaultLanguage } } <- ask
threadDelay $ (fromIntegral $ fromMaybe (defTimeout defaultLanguage) timeout) * 1000000 threadDelay $ (fromIntegral $ fromMaybe (defTimeout defaultLanguage) timeout) * 1000000
@ -175,7 +177,7 @@ evalCode lang@LanguageConfig { name, timeout, retries } numRetries code = withCo
writeMVar doneRef True writeMVar doneRef True
killContainer name killContainer name
eval :: Myriadic m => ContainerName -> Snowflake -> m EvalResult eval :: ContainerName -> Snowflake -> Myriad EvalResult
eval cnt snowflake = do eval cnt snowflake = do
logInfo ["Running code in container ", cs cnt, ", evaluation ", cs $ show snowflake, ":\n", cs code] logInfo ["Running code in container ", cs cnt, ", evaluation ", cs $ show snowflake, ":\n", cs code]
exec_ ["docker exec ", cs cnt, " mkdir eval/", show snowflake] exec_ ["docker exec ", cs cnt, " mkdir eval/", show snowflake]
@ -188,7 +190,7 @@ evalCode lang@LanguageConfig { name, timeout, retries } numRetries code = withCo
logInfo ["Ran code in container ", cs cnt, ", evaluation ", cs $ show snowflake] logInfo ["Ran code in container ", cs cnt, ", evaluation ", cs $ show snowflake]
pure $ EvalOk output pure $ EvalOk output
newContainerName :: Myriadic m => LanguageConfig -> m ContainerName newContainerName :: LanguageConfig -> Myriad ContainerName
newContainerName LanguageConfig { name } = do newContainerName LanguageConfig { name } = do
snowflakeGen <- asks snowflakeGen snowflakeGen <- asks snowflakeGen
snowflake <- liftIO $ nextSnowflake snowflakeGen snowflake <- liftIO $ nextSnowflake snowflakeGen

18
src/Myriad/Server.hs
View file

@ -21,6 +21,8 @@ import Servant
import Myriad.Core import Myriad.Core
import Myriad.Docker import Myriad.Docker
type Myriad = MyriadT Handler
data EvalRequest = EvalRequest { language :: T.Text, code :: String } deriving (Generic, FromJSON) data EvalRequest = EvalRequest { language :: T.Text, code :: String } deriving (Generic, FromJSON)
data EvalResponse = EvalResponse { result :: T.Text } deriving (Generic, ToJSON) data EvalResponse = EvalResponse { result :: T.Text } deriving (Generic, ToJSON)
@ -36,35 +38,37 @@ app = serve (Proxy @API) . server
server :: Env -> Server API server :: Env -> Server API
server env = hoistServer (Proxy @API) (runMyriadT env) serverT server env = hoistServer (Proxy @API) (runMyriadT env) serverT
serverT :: ServerT API (MyriadT Handler) serverT :: ServerT API Myriad
serverT = handleLanguages :<|> handleEval :<|> handleContainers :<|> handleCleanup serverT = handleLanguages :<|> handleEval :<|> handleContainers :<|> handleCleanup
where where
handleLanguages :: MyriadT Handler [T.Text] handleLanguages :: Myriad [T.Text]
handleLanguages = do handleLanguages = do
logInfo ["GET /languages"] logInfo ["GET /languages"]
MyriadConfig { languages } <- asks config MyriadConfig { languages } <- asks config
pure . map name $ languages pure . map name $ languages
handleEval :: EvalRequest -> MyriadT Handler EvalResponse handleEval :: EvalRequest -> Myriad EvalResponse
handleEval EvalRequest { language, code } = do handleEval EvalRequest { language, code } = do
logInfo ["POST /eval"] logInfo ["POST /eval"]
MyriadConfig { languages } <- asks config MyriadConfig { languages } <- asks config
case find (\x -> name x == language) languages of case find (\x -> name x == 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
res <- withAsync (evalCode cfg 0 $ cs code) wait env <- ask
res <- withAsync (liftIO . runMyriadT env . evalCode cfg 0 $ cs code) wait
case res of case res of
EvalErrored -> throwError $ err500 { errBody = "Evaluation failed" } EvalErrored -> throwError $ err500 { errBody = "Evaluation failed" }
EvalTimedOut -> throwError $ err504 { errBody = "Evaluation timed out" } EvalTimedOut -> throwError $ err504 { errBody = "Evaluation timed out" }
EvalOk xs -> pure . EvalResponse $ cs xs EvalOk xs -> pure . EvalResponse $ cs xs
handleContainers :: MyriadT Handler [T.Text] handleContainers :: Myriad [T.Text]
handleContainers = do handleContainers = do
logInfo ["GET /containers"] logInfo ["GET /containers"]
containers <- asks containers >>= readMVar containers <- asks containers >>= readMVar
pure . map cs $ M.elems containers pure . map cs $ M.elems containers
handleCleanup :: MyriadT Handler [T.Text] handleCleanup :: Myriad [T.Text]
handleCleanup = do handleCleanup = do
logInfo ["POST /cleanup"] logInfo ["POST /cleanup"]
map cs <$> killContainers env <- ask
liftIO $ map cs <$> runMyriadT env killContainers