58 lines
2.0 KiB
Haskell
58 lines
2.0 KiB
Haskell
{-# LANGUAGE DeriveAnyClass #-}
|
|
|
|
module Myriad.Server
|
|
( app
|
|
) where
|
|
|
|
import Control.Monad.Except
|
|
import Control.Monad.Logger
|
|
import Control.Monad.Reader
|
|
|
|
import Data.Aeson
|
|
import Data.List (find)
|
|
import qualified Data.Text as T
|
|
import GHC.Generics
|
|
|
|
import Control.Concurrent.Async.Lifted
|
|
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)
|
|
|
|
type API
|
|
= "languages" :> Get '[JSON] [T.Text]
|
|
:<|> "eval" :> ReqBody '[JSON] EvalRequest :> Post '[JSON] EvalResponse
|
|
|
|
app :: Env -> Application
|
|
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 = handleLanguages :<|> handleEval
|
|
where
|
|
handleLanguages :: MyriadT m [T.Text]
|
|
handleLanguages = do
|
|
logInfoN $ mconcat ["GET /languages"]
|
|
MyriadConfig { languages } <- asks config
|
|
pure . map name $ languages
|
|
|
|
handleEval :: EvalRequest -> MyriadT m EvalResponse
|
|
handleEval EvalRequest { language, code } = do
|
|
logInfoN $ mconcat ["POST /eval"]
|
|
env <- ask
|
|
let MyriadConfig { languages } = config env
|
|
case find (\x -> name x == language) languages of
|
|
Nothing -> throwError $ err404 { errBody = "Language " <> cvs language <> " was not found" }
|
|
Just cfg -> do
|
|
res <- withAsync (evalCode cfg 0 $ cvs code) wait
|
|
case res of
|
|
EvalErrored -> throwError $ err500 { errBody = "Evaluation failed" }
|
|
EvalTimedOut -> throwError $ err504 { errBody = "Evaluation timed out" }
|
|
EvalOk xs -> pure . EvalResponse $ cvs xs
|