144 lines
3.6 KiB
Haskell
144 lines
3.6 KiB
Haskell
{-# LANGUAGE UndecidableInstances #-}
|
|
|
|
module Myriad.Core
|
|
( Language
|
|
, ContainerName
|
|
, ImageName
|
|
, EvalResult(..)
|
|
, Env(..)
|
|
, MyriadConfig(..)
|
|
, LanguageConfig(..)
|
|
, MyriadT
|
|
, Myriad
|
|
, Myriadic
|
|
, runMyriadT
|
|
, initEnv
|
|
, exec
|
|
, exec_
|
|
, logInfo
|
|
, logError
|
|
, mapMVar
|
|
, writeMVar
|
|
) where
|
|
|
|
import Control.Monad.Base
|
|
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 Control.Concurrent.MVar.Lifted
|
|
import Control.Concurrent.QSem.Lifted
|
|
import System.Process.Typed
|
|
|
|
type Language = T.Text
|
|
type ContainerName = String
|
|
type ImageName = String
|
|
|
|
data EvalResult = EvalOk BL.ByteString | EvalTimedOut | EvalErrored
|
|
|
|
data Env = Env
|
|
{ config :: MyriadConfig
|
|
, languagesDir :: T.Text
|
|
, containers :: MVar (M.Map Language ContainerName)
|
|
, containerSems :: MVar (M.Map Language QSem)
|
|
, evalSems :: MVar (M.Map Language QSem)
|
|
, snowflakeGen :: SnowflakeGen
|
|
}
|
|
|
|
data MyriadConfig = MyriadConfig
|
|
{ languages :: [LanguageConfig]
|
|
, buildConcurrently :: Bool
|
|
, prepareContainers :: Bool
|
|
, cleanupInterval :: Natural
|
|
, port :: Natural
|
|
} deriving (Show, Generic)
|
|
|
|
instance FromDhall MyriadConfig
|
|
|
|
data LanguageConfig = LanguageConfig
|
|
{ name :: Language
|
|
, memory :: T.Text
|
|
, cpus :: T.Text
|
|
, timeout :: Natural
|
|
, concurrent :: Natural
|
|
, retries :: Natural
|
|
} deriving (Show, Generic)
|
|
|
|
instance FromDhall LanguageConfig
|
|
|
|
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
|
|
)
|
|
|
|
instance MonadTrans MyriadT where
|
|
lift = MyriadT . lift . lift
|
|
|
|
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
|
|
|
|
initEnv :: T.Text -> T.Text -> IO Env
|
|
initEnv configInput languagesDir =
|
|
Env
|
|
<$> readConfig configInput
|
|
<*> pure languagesDir
|
|
<*> newMVar M.empty
|
|
<*> newMVar M.empty
|
|
<*> newMVar M.empty
|
|
<*> newSnowflakeGen defaultConfig 0
|
|
|
|
runMyriadT :: MonadIO m => Env -> MyriadT m a -> m a
|
|
runMyriadT env = runStdoutLoggingT . flip runReaderT env . unMyriadT
|
|
|
|
exec :: MonadIO m => [String] -> m BL.ByteString
|
|
exec = readProcessInterleaved_ . shell . mconcat
|
|
|
|
exec_ :: MonadIO m => [String] -> m ()
|
|
exec_ = (() <$) . 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
|