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

Restructure project

This commit is contained in:
1computer1 2019-07-18 07:40:29 -04:00
parent 176a78b557
commit 348054a994
6 changed files with 132 additions and 122 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
package.yaml
View File

@ -42,11 +42,14 @@ default-extensions:
- BlockArguments
- ConstraintKinds
- DataKinds
- DerivingStrategies
- DeriveFunctor
- DeriveGeneric
- FlexibleContexts
- FlexibleInstances
- FunctionalDependencies
- GADTs
- GeneralizedNewtypeDeriving
- LambdaCase
- MultiParamTypeClasses
- MultiWayIf
@ -56,6 +59,7 @@ default-extensions:
- PolyKinds
- RankNTypes
- ScopedTypeVariables
- StandaloneDeriving
- TupleSections
- TypeApplications
- TypeOperators

7
src/Main.hs
View File

@ -1,7 +1,5 @@
module Main where
import Control.Monad.Logger
import qualified Data.Text as T
import Options.Applicative
@ -32,7 +30,6 @@ main = do
runMyriadT env do
buildAllImages
startCleanup
runStdoutLoggingT do
logInfoN "Finished Docker-related setup"
logInfoN "Starting server"
logInfo ["Finished Docker-related setup"]
logInfo ["Starting server"]
run (fromIntegral . port . config $ env) $ app env

77
src/Myriad/Core.hs
View File

@ -1,3 +1,5 @@
{-# LANGUAGE UndecidableInstances #-}
module Myriad.Core
( Language
, ContainerName
@ -7,26 +9,37 @@ module Myriad.Core
, MyriadConfig(..)
, LanguageConfig(..)
, MyriadT
, MonadWithIO
, MyriadIO
, Myriad
, Myriadic
, runMyriadT
, initEnv
, exec
, exec_
, logInfo
, logError
, mapMVar
, writeMVar
) where
import Control.Monad.Base
import Control.Monad.Logger
import Control.Monad.Except
import Control.Monad.Logger hiding (logError, logInfo)
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Trans.Control
import Control.Monad.Writer
import qualified Data.ByteString.Lazy as BL
import Data.Functor.Identity
import qualified Data.Map.Strict as M
import Data.Snowflake
import qualified Data.Text as T
import Dhall
import GHC.Generics (Generic)
import Control.Concurrent.MVar
import Control.Concurrent.QSem
import Data.Snowflake
import Control.Concurrent.MVar.Lifted
import Control.Concurrent.QSem.Lifted
import System.Process.Typed
type Language = T.Text
type ContainerName = String
@ -63,11 +76,37 @@ data LanguageConfig = LanguageConfig
instance Interpret LanguageConfig
type MyriadT m = ReaderT Env (LoggingT m)
newtype MyriadT m a = MyriadT { unMyriadT :: ReaderT Env (LoggingT m) a }
deriving newtype
( Functor
, Applicative
, Monad
, MonadReader Env
, MonadLogger
, MonadLoggerIO
, MonadIO
, MonadError e
, MonadState s
, MonadWriter w
, MonadBase b
)
type MonadWithIO m = (MonadIO m, MonadBase IO m, MonadBaseControl IO m)
instance MonadTrans MyriadT where
lift = MyriadT . lift . lift
type MyriadIO a = forall m. MonadWithIO m => MyriadT m a
instance MonadTransControl MyriadT where
type StT MyriadT a = a
liftWith = defaultLiftWith2 MyriadT unMyriadT
restoreT = defaultRestoreT2 MyriadT
instance MonadBaseControl b m => MonadBaseControl b (MyriadT m) where
type StM (MyriadT m) a = ComposeSt MyriadT m a
liftBaseWith = defaultLiftBaseWith
restoreM = defaultRestoreM
type Myriad = MyriadT Identity
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
@ -82,4 +121,22 @@ initEnv configInput =
<*> newSnowflakeGen defaultConfig 0
runMyriadT :: MonadIO m => Env -> MyriadT m a -> m a
runMyriadT env f = runStdoutLoggingT $ runReaderT f env
runMyriadT env = runStdoutLoggingT . flip runReaderT env . unMyriadT
exec :: MonadIO m => [String] -> m BL.ByteString
exec = readProcessInterleaved_ . shell . mconcat
exec_ :: MonadIO m => [String] -> m ()
exec_ = void . exec
logInfo :: MonadLogger m => [T.Text] -> m ()
logInfo = logInfoN . mconcat
logError :: MonadLogger m => [T.Text] -> m ()
logError = logErrorN . mconcat
mapMVar :: (MonadBase IO m, MonadBaseControl IO m) => MVar a -> (a -> a) -> m ()
mapMVar var f = modifyMVar_ var (pure . f)
writeMVar :: (MonadBase IO m, MonadBaseControl IO m) => MVar a -> a -> m ()
writeMVar var x = mapMVar var $ const x

81
src/Myriad/Docker.hs
View File

@ -13,6 +13,7 @@ import Control.Monad.Reader
import qualified Data.Map.Strict as M
import Data.Snowflake
import Data.String.Conversions
import Control.Concurrent.Async.Lifted
import Control.Concurrent.Lifted (fork, threadDelay)
@ -22,18 +23,17 @@ import Control.Exception.Lifted
import System.Process.Typed
import Myriad.Core
import Myriad.Util
buildImage :: LanguageConfig -> MyriadIO ()
buildImage :: Myriadic m => LanguageConfig -> m ()
buildImage lang@LanguageConfig { name, concurrent } = do
logInfo ["Building image ", cvs $ imageName lang]
exec_ ["docker build -t ", imageName lang, " ./languages/", cvs name]
logInfo ["Building image ", cs $ imageName lang]
exec_ ["docker build -t ", imageName lang, " ./languages/", cs name]
setupQSems
logInfo ["Built image ", cvs $ imageName lang]
logInfo ["Built image ", cs $ imageName lang]
MyriadConfig { prepareContainers } <- asks config
when_ prepareContainers $ setupContainer lang
where
setupQSems :: MyriadIO ()
setupQSems :: Myriadic m => m ()
setupQSems = do
Env { containerSems, evalSems } <- ask
csem <- newQSem 1 -- We only want one container to be set up at a time
@ -41,48 +41,48 @@ buildImage lang@LanguageConfig { name, concurrent } = do
mapMVar containerSems $ M.insert name csem
mapMVar evalSems $ M.insert name esem
buildAllImages :: MyriadIO ()
buildAllImages :: Myriadic m => m ()
buildAllImages = do
MyriadConfig { languages, buildConcurrently } <- asks config
if buildConcurrently
then forConcurrently_ languages buildImage
else forM_ languages buildImage
startCleanup :: MyriadIO ()
startCleanup :: Myriadic m => m ()
startCleanup = do
MyriadConfig { cleanupInterval } <- asks config
when_ (cleanupInterval > 0) do
let t = fromIntegral cleanupInterval * 60000000
fork $ timer t
where
timer :: Int -> MyriadIO ()
timer :: Int -> Myriadic m => m ()
timer t = forever do
threadDelay t
n <- killContainers
logInfo ["Cleaned up ", cvs $ show n, " containers"]
logInfo ["Cleaned up ", cs $ show n, " containers"]
timer t
setupContainer :: LanguageConfig -> MyriadIO ContainerName
setupContainer :: Myriadic m => LanguageConfig -> m ContainerName
setupContainer lang@LanguageConfig { name, memory, cpus } = do
cnts <- asks containers >>= readMVar
case cnts M.!? name of
Nothing -> setup
Just cnt -> pure cnt
where
setup :: MyriadIO ContainerName
setup :: Myriadic m => m ContainerName
setup = do
ref <- asks containers
cnt <- newContainerName lang
exec_
[ "docker run --rm --name="
, cvs cnt
, cs cnt
-- User 1000 will be for setting up the environment
, " -u1000:1000 -w/tmp/ -dt --net=none --cpus="
, cvs cpus
, cs cpus
, " -m="
, cvs memory
, cs memory
, " --memory-swap="
, cvs memory
, cs memory
, " "
, imageName lang
, " /bin/sh"
@ -92,10 +92,10 @@ setupContainer lang@LanguageConfig { name, memory, cpus } = do
exec_ ["docker exec ", cnt, " mkdir eval"]
exec_ ["docker exec ", cnt, " chmod 711 eval"]
mapMVar ref $ M.insert name cnt
logInfo ["Started container ", cvs cnt]
logInfo ["Started container ", cs cnt]
pure cnt
killContainer :: Language -> MyriadIO Bool
killContainer :: Myriadic m => Language -> m Bool
killContainer lang = do
containers <- asks containers >>= readMVar
case containers M.!? lang of
@ -105,10 +105,10 @@ killContainer lang = do
case res of
Nothing -> pure True
Just err -> do
logError ["An exception occured when killing ", cvs cnt, ":\n", cvs $ show err]
logError ["An exception occured when killing ", cs cnt, ":\n", cs $ show err]
pure False
where
kill :: ContainerName -> MyriadIO (Maybe SomeException)
kill :: Myriadic m => ContainerName -> m (Maybe SomeException)
kill cnt = do
ref <- asks containers
mapMVar ref $ M.delete lang
@ -116,16 +116,16 @@ killContainer lang = do
case res of
Left err -> pure $ Just err
Right _ -> do
logInfo ["Killed container ", cvs cnt]
logInfo ["Killed container ", cs cnt]
pure Nothing
killContainers :: MyriadIO [ContainerName]
killContainers :: Myriadic m => m [ContainerName]
killContainers = do
containers <- asks containers >>= readMVar
xs <- forConcurrently (M.toList containers) \(k, v) -> (v,) <$> killContainer k
pure . map fst $ filter snd xs
evalCode :: LanguageConfig -> Int -> String -> MyriadIO EvalResult
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.
@ -139,23 +139,23 @@ evalCode lang@LanguageConfig { name, timeout, retries } numRetries code = withCo
if done
-- If we find the eval is done from an exception, then it was timed out.
then do
logError ["Code timed out in container ", cvs cnt, ", evaluation ", cvs $ show snowflake]
logError ["Code timed out in container ", cs cnt, ", evaluation ", cs $ show snowflake]
pure EvalTimedOut
-- Otherwise, the container was killed from another eval, so we should retry.
else do
writeMVar doneRef True
if numRetries < fromIntegral retries
then do
logError ["An exception occured in ", cvs cnt, ", evaluation ", cvs $ show snowflake, ", retrying:\n", cvs $ show err]
logError ["An exception occured in ", cs cnt, ", evaluation ", cs $ show snowflake, ", retrying:\n", cs $ show err]
evalCode lang (numRetries + 1) code
else do
logError ["An exception occured in ", cvs cnt, ", evaluation ", cvs $ show snowflake, ":\n", cvs $ show err]
logError ["An exception occured in ", cs cnt, ", evaluation ", cs $ show snowflake, ":\n", cs $ show err]
pure EvalErrored
Right x -> do
writeMVar doneRef True
pure x
where
withContainer :: (ContainerName -> MyriadIO a) -> MyriadIO a
withContainer :: Myriadic m => (ContainerName -> m a) -> m a
withContainer f = do
Env { containerSems, evalSems } <- ask
csem <- (M.! name) <$> readMVar containerSems
@ -164,7 +164,7 @@ evalCode lang@LanguageConfig { name, timeout, retries } numRetries code = withCo
cnt <- bracket_ (waitQSem csem) (signalQSem csem) $ setupContainer lang
f cnt
timer :: MVar Bool -> MyriadIO ()
timer :: Myriadic m => MVar Bool -> m ()
timer doneRef = do
threadDelay $ fromIntegral timeout * 1000000
done <- readMVar doneRef
@ -172,14 +172,29 @@ evalCode lang@LanguageConfig { name, timeout, retries } numRetries code = withCo
writeMVar doneRef True
killContainer name
eval :: ContainerName -> Snowflake -> MyriadIO EvalResult
eval :: Myriadic m => ContainerName -> Snowflake -> m EvalResult
eval cnt snowflake = do
logInfo ["Running code in container ", cvs cnt, ", evaluation ", cvs $ show snowflake, ":\n", cvs code]
exec_ ["docker exec ", cvs cnt, " mkdir eval/", show snowflake]
exec_ ["docker exec ", cvs cnt, " chmod 777 eval/", show snowflake]
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, " chmod 777 eval/", show snowflake]
-- User 1001 will be used for the actual execution so that they can't access `eval` itself
let args = ["exec", "-u1001:1001", "-w/tmp/eval/" <> show snowflake, cnt, "/bin/sh", "/var/run/run.sh", code]
output <- readProcessInterleaved_ $ proc "docker" args
exec_ ["docker exec ", cnt, " rm -rf eval/", show snowflake]
logInfo ["Ran code in container ", cvs cnt, ", evaluation ", cvs $ show snowflake]
logInfo ["Ran code in container ", cs cnt, ", evaluation ", cs $ show snowflake]
pure $ EvalOk output
newContainerName :: Myriadic m => LanguageConfig -> m ContainerName
newContainerName LanguageConfig { name } = do
snowflakeGen <- asks snowflakeGen
snowflake <- liftIO $ nextSnowflake snowflakeGen
pure $ "comp_iler-" <> cs name <> "-" <> show snowflake
imageName :: LanguageConfig -> ImageName
imageName LanguageConfig { name } = "1computer1/comp_iler:" <> cs name
when_ :: Applicative f => Bool -> f a -> f ()
when_ p = when p . void
unless_ :: Applicative f => Bool -> f a -> f ()
unless_ p = unless p . void

22
src/Myriad/Server.hs
View File

@ -10,6 +10,7 @@ import Control.Monad.Reader
import Data.Aeson
import Data.List (find)
import qualified Data.Map as M
import Data.String.Conversions
import qualified Data.Text as T
import GHC.Generics
@ -19,7 +20,6 @@ import Servant
import Myriad.Core
import Myriad.Docker
import Myriad.Util
data EvalRequest = EvalRequest { language :: T.Text, code :: String } deriving (Generic, FromJSON)
data EvalResponse = EvalResponse { result :: T.Text } deriving (Generic, ToJSON)
@ -36,35 +36,35 @@ app = serve (Proxy @API) . server
server :: Env -> Server API
server env = hoistServer (Proxy @API) (runMyriadT env) serverT
serverT :: forall m. (MonadWithIO m, MonadError ServantErr m) => ServerT API (MyriadT m)
serverT :: ServerT API (MyriadT Handler)
serverT = handleLanguages :<|> handleEval :<|> handleContainers :<|> handleCleanup
where
handleLanguages :: MyriadT m [T.Text]
handleLanguages :: MyriadT Handler [T.Text]
handleLanguages = do
logInfo ["GET /languages"]
MyriadConfig { languages } <- asks config
pure . map name $ languages
handleEval :: EvalRequest -> MyriadT m EvalResponse
handleEval :: EvalRequest -> MyriadT Handler EvalResponse
handleEval EvalRequest { language, code } = do
logInfo ["POST /eval"]
MyriadConfig { languages } <- asks config
case find (\x -> name x == language) languages of
Nothing -> throwError $ err404 { errBody = "Language " <> cvs language <> " was not found" }
Nothing -> throwError $ err404 { errBody = "Language " <> cs language <> " was not found" }
Just cfg -> do
res <- withAsync (evalCode cfg 0 $ cvs code) wait
res <- withAsync (evalCode cfg 0 $ cs code) wait
case res of
EvalErrored -> throwError $ err500 { errBody = "Evaluation failed" }
EvalTimedOut -> throwError $ err504 { errBody = "Evaluation timed out" }
EvalOk xs -> pure . EvalResponse $ cvs xs
EvalOk xs -> pure . EvalResponse $ cs xs
handleContainers :: MyriadT m [T.Text]
handleContainers :: MyriadT Handler [T.Text]
handleContainers = do
logInfo ["GET /containers"]
containers <- asks containers >>= readMVar
pure . map cvs $ M.elems containers
pure . map cs $ M.elems containers
handleCleanup :: MyriadT m [T.Text]
handleCleanup :: MyriadT Handler [T.Text]
handleCleanup = do
logInfo ["POST /cleanup"]
map cvs <$> killContainers
map cs <$> killContainers

63
src/Myriad/Util.hs
View File

@ -1,63 +0,0 @@
module Myriad.Util
( newContainerName
, imageName
, cvs
, when_
, unless_
, exec
, exec_
, logInfo
, logError
, mapMVar
, writeMVar
) where
import qualified Control.Monad.Logger as L
import Control.Monad.Reader
import qualified Data.ByteString.Lazy as BL
import Data.Snowflake
import Data.String.Conversions
import qualified Data.Text as T
import Control.Concurrent.MVar.Lifted
import System.Process.Typed
import Myriad.Core
newContainerName :: MonadIO m => LanguageConfig -> MyriadT m ContainerName
newContainerName LanguageConfig { name } = do
snowflakeGen <- asks snowflakeGen
snowflake <- liftIO $ nextSnowflake snowflakeGen
pure $ "comp_iler-" <> convertString name <> "-" <> show snowflake
imageName :: LanguageConfig -> ImageName
imageName LanguageConfig { name } = "1computer1/comp_iler:" <> convertString name
-- Shorthand because laziness
cvs :: ConvertibleStrings a b => a -> b
cvs = convertString
when_ :: Applicative f => Bool -> f a -> f ()
when_ p = when p . void
unless_ :: Applicative f => Bool -> f a -> f ()
unless_ p = unless p . void
exec :: [String] -> MyriadIO BL.ByteString
exec = readProcessInterleaved_ . shell . mconcat
exec_ :: [String] -> MyriadIO ()
exec_ = void . exec
logInfo :: [T.Text] -> MyriadIO ()
logInfo = L.logInfoN . mconcat
logError :: [T.Text] -> MyriadIO ()
logError = L.logErrorN . mconcat
mapMVar :: MVar a -> (a -> a) -> MyriadIO ()
mapMVar var f = modifyMVar_ var (pure . f)
writeMVar :: MVar a -> a -> MyriadIO ()
writeMVar var x = mapMVar var $ const x