Initial commit

.gitignore

@@ -0,0 +1,4 @@
+.stack-work/
+.vscode/
+logs/
+myriad.cabal

LICENSE

@@ -0,0 +1,19 @@
+Copyright 2019 1Computer1
+
+Permission is hereby granted, free of charge, to any person obtaining a copy of
+this software and associated documentation files (the "Software"), to deal in
+the Software without restriction, including without limitation the rights to
+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies
+of the Software, and to permit persons to whom the Software is furnished to do
+so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.

README.md

@@ -0,0 +1,38 @@
+# Myriad
+
+Arbitrary code execution server using Docker.  
+
+## Setup
+
+- Fill out `config.dhall`, read it for documentation and an example
+- Run `stack run`
+
+## Endpoints
+
+`GET /languages`  
+List of enabled languages.  
+Example response:  
+
+```json
+["haskell", "javascript"]
+```
+
+---
+
+`POST /eval`  
+Evaluate code.  
+JSON payload with `language` and `code` keys.  
+The `language` is as in the name of a subfolder in the `language` directory.  
+Example payload:  
+
+```json
+{ "language": "haskell", "code": "main = print (1 + 1)" }
+```
+
+Example response:  
+
+```json
+{ "result": "2\n" }
+```
+
+Errors with 404 if `language` is not found, `504` if evaluation timed out, or `500` if evaluation failed for other reasons.  

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

config.dhall

@@ -0,0 +1,39 @@
+let LanguageConfig : Type =
+    { name       : Text    -- Name of language as in languages folder
+    , memory     : Text    -- Maximum memory usage
+    , cpus       : Text    -- Maximum CPU usage
+    , timeout    : Natural -- Timeout for code evaluation in seconds
+    , concurrent : Natural -- Maximum number of concurrent evaluations
+    , retries    : Natural -- Maximum number of retries for unsure errors
+    }
+
+-- Creates the default configuration given a language name.
+-- For more customization, use the (//) operator e.g. cfg "haskell" // { timeout = 20 } or write the full record out.
+let cfg = \(name : Text) ->
+    { name       = name
+    , memory     = "256m"
+    , cpus       = "0.25"
+    , timeout    = 20
+    , concurrent = 10
+    , retries    = 2
+    }
+
+let Config : Type =
+    { languages         : List LanguageConfig -- List of languages to enable
+    , buildConcurrently : Bool                -- Whether to build images concurrently
+    , prepareContainers : Bool                -- Whether to setup all containers on startup
+    , cleanupInterval   : Natural             -- The interval in minutes to kill containers periodically
+    , port              : Integer             -- Port to run on
+    }
+
+-- Write your config here!
+let config : Config =
+    { languages =
+        [ cfg "javascript"
+        ]
+    , buildConcurrently = True
+    , prepareContainers = False
+    , cleanupInterval   = 30
+    , port              = 8081
+    }
+in config

languages/apl/Dockerfile

@@ -0,0 +1,4 @@
+FROM juergensauermann/gnu-apl
+LABEL author="1Computer1"
+
+COPY run.sh /var/run/

languages/apl/run.sh

@@ -0,0 +1,2 @@
+printf %s "$1" > program.apl
+apl --OFF -s -f program.apl || true

languages/bash/Dockerfile

@@ -0,0 +1,4 @@
+FROM bash
+LABEL author="1Computer1"
+
+COPY run.sh /var/run/

languages/bash/run.sh

@@ -0,0 +1,2 @@
+printf %s "$1" > program.sh
+bash program.sh || true

languages/brainfuck/Dockerfile

@@ -0,0 +1,12 @@
+FROM alpine AS build
+
+RUN apk update && apk add g++
+COPY bf.cpp .
+RUN g++ bf.cpp -o bf
+
+FROM alpine
+LABEL author="1Computer1"
+
+RUN apk update && apk add libstdc++
+COPY --from=build bf /usr/local/bin/
+COPY run.sh /var/run/

languages/brainfuck/bf.cpp

@@ -0,0 +1,119 @@
+#include <iostream>
+#include <vector>
+#include <string.h>
+#include <string>
+
+int main(int argc, char **argv) {
+    std::string ops;
+    if (argc == 1) {
+        std::string line;
+        while (std::getline(std::cin, line)) {
+            ops.append(line);
+        }
+
+        if (ops.empty()) {
+            std::cerr << "No input given";
+            return 1;
+        }
+    } else {
+        ops.assign(argv[1], strlen(argv[1]));
+    }
+
+    int len = ops.length();
+    std::vector<char> tape = { 0 };
+    int oix = 0;
+    int tix = 0;
+    while (oix < len) {
+        switch (ops[oix]) {
+            case '>':
+                tix++;
+                if (tix >= tape.size()) {
+                    tape.push_back(0);
+                }
+
+                oix++;
+                break;
+            case '<':
+                tix--;
+                if (tix < 0) {
+                    std::cerr << "Out of bounds";
+                    return 1;
+                }
+
+                oix++;
+                break;
+            case '+':
+                tape[tix]++;
+                oix++;
+                break;
+            case '-':
+                tape[tix]--;
+                oix++;
+                break;
+            case '.':
+                std::cout << tape[tix];
+                oix++;
+                break;
+            case ',':
+                std::cin >> tape[tix];
+                oix++;
+                break;
+            case '[':
+                if (tape[tix] == 0) {
+                    int ls = 0;
+                    int rs = 0;
+                    for (int i = oix; i < len; i++) {
+                        switch (ops[i]) {
+                            case '[':
+                                ls++;
+                                break;
+                            case ']':
+                                rs++;
+                                break;
+                            default:
+                                break;
+                        }
+
+                        if (ls == rs) {
+                            oix = i + 1;
+                            break;
+                        }
+                    }
+                } else {
+                    oix++;
+                }
+
+                break;
+            case ']':
+                if (tape[tix] != 0) {
+                    int ls = 0;
+                    int rs = 0;
+                    for (int i = oix; i >= 0; i--) {
+                        switch (ops[i]) {
+                            case '[':
+                                ls++;
+                                break;
+                            case ']':
+                                rs++;
+                                break;
+                            default:
+                                break;
+                        }
+
+                        if (ls == rs) {
+                            oix = i + 1;
+                            break;
+                        }
+                    }
+                } else {
+                    oix++;
+                }
+
+                break;
+            default:
+                oix++;
+        }
+    }
+
+    return 0;
+}

languages/brainfuck/run.sh

@@ -0,0 +1 @@
+printf %s "$1" | bf || true

languages/c/Dockerfile

@@ -0,0 +1,7 @@
+FROM alpine
+LABEL author="1Computer1"
+
+RUN apk update
+RUN apk add gcc libc-dev
+
+COPY run.sh /var/run/

languages/c/run.sh

@@ -0,0 +1,2 @@
+printf %s "$1" > program.c
+gcc program.c -o program && ./program || true

languages/clojure/Dockerfile

@@ -0,0 +1,4 @@
+FROM clojure:tools-deps-alpine
+LABEL author="1Computer1"
+
+COPY run.sh /var/run/

languages/clojure/run.sh

@@ -0,0 +1,2 @@
+printf %s "$1" > program.clj
+clojure program.clj || true

languages/cpp/Dockerfile

@@ -0,0 +1,7 @@
+FROM alpine
+LABEL author="1Computer1"
+
+RUN apk update
+RUN apk add g++
+
+COPY run.sh /var/run/

languages/cpp/run.sh

@@ -0,0 +1,2 @@
+printf %s "$1" > program.cpp
+g++ program.cpp -o program && ./program || true

languages/csharp/Dockerfile

@@ -0,0 +1,4 @@
+FROM mono
+LABEL author="1Computer1"
+
+COPY run.sh /var/run/

languages/csharp/run.sh

@@ -0,0 +1,2 @@
+printf %s "$1" > program.cs
+csc program.cs >/dev/null && mono program.exe || true

languages/elixir/Dockerfile

@@ -0,0 +1,4 @@
+FROM elixir:alpine
+LABEL author="1Computer1"
+
+COPY run.sh /var/run/

languages/elixir/run.sh

@@ -0,0 +1,2 @@
+printf %s "$1" > program.exs
+elixir program.exs || true

languages/fsharp/Dockerfile

@@ -0,0 +1,4 @@
+FROM fsharp
+LABEL author="1Computer1"
+
+COPY run.sh /var/run/

languages/fsharp/run.sh

@@ -0,0 +1,2 @@
+printf %s "$1" > program.fs
+fsharpc --optimize- program.fs >/dev/null && mono program.exe || true

languages/go/Dockerfile

@@ -0,0 +1,4 @@
+FROM golang:alpine
+LABEL author="1Computer1"
+
+COPY run.sh /var/run/

languages/go/run.sh

@@ -0,0 +1,3 @@
+export GOCACHE=/tmp/"$CODEDIR"/cache
+printf %s "$1" > program.go
+go run program.go || true

languages/haskell/Dockerfile

@@ -0,0 +1,15 @@
+FROM debian:stretch
+LABEL author="1Computer1"
+ENV LANG C.UTF-8
+
+RUN apt-get update && \
+    apt-get install -y --no-install-recommends gnupg dirmngr && \
+    echo 'deb http://downloads.haskell.org/debian stretch main' > /etc/apt/sources.list.d/ghc.list && \
+    apt-key adv --keyserver keyserver.ubuntu.com --recv-keys BA3CBA3FFE22B574 && \
+    apt-get update && \
+    apt-get install -y --no-install-recommends ghc-8.6.5
+
+ENV PATH /opt/ghc/8.6.5/bin:$PATH
+
+COPY .ghci $HOME/
+COPY run.sh /var/run/

languages/haskell/run.sh

@@ -0,0 +1,2 @@
+printf %s "$1" > program.hs
+ghc -e main program.hs || true

languages/java/Dockerfile

@@ -0,0 +1,4 @@
+FROM openjdk:13-alpine
+LABEL author="1Computer1"
+
+COPY run.sh /var/run/

languages/java/run.sh

@@ -0,0 +1,2 @@
+printf %s "$1" > Main.java
+javac Main.java && java Main || true

languages/javascript/Dockerfile

@@ -0,0 +1,4 @@
+FROM node:alpine
+LABEL author="1Computer1"
+
+COPY run.sh /var/run/

languages/javascript/run.sh

@@ -0,0 +1 @@
+printf %s "$1" | node -p || true

languages/julia/Dockerfile

@@ -0,0 +1,4 @@
+FROM julia
+LABEL author="1Computer1"
+
+COPY run.sh /var/run/

languages/julia/run.sh

@@ -0,0 +1 @@
+printf %s "$1" | julia

languages/lua/Dockerfile

@@ -0,0 +1,6 @@
+FROM alpine
+
+RUN apk update
+RUN apk add lua5.3
+
+COPY run.sh /var/run/

languages/lua/run.sh

@@ -0,0 +1,2 @@
+printf %s "$1" > program.lua
+lua5.3 program.lua || true

languages/ocaml/Dockerfile

@@ -0,0 +1,4 @@
+FROM frolvlad/alpine-ocaml
+LABEL author="1Computer1"
+
+COPY run.sh /var/run/

languages/ocaml/run.sh

@@ -0,0 +1,2 @@
+printf %s "$1" > program.ml
+ocamlopt -cclib --static -o program program.ml && ./program || true

languages/pascal/Dockerfile

@@ -0,0 +1,4 @@
+FROM frolvlad/alpine-fpc
+LABEL author="1Computer1"
+
+COPY run.sh /var/run/

languages/pascal/run.sh

@@ -0,0 +1,10 @@
+printf %s "$1" > program.pas
+
+# fpc does not use stderr, ld however does, capture both
+res="$(fpc program.pas 2>&1)"
+
+if [ $? -eq 0 ]; then
+    ./program || true
+else
+    printf %s "$res"
+fi

languages/perl/Dockerfile

@@ -0,0 +1,4 @@
+FROM perl:slim
+LABEL author="1Computer1"
+
+COPY run.sh /var/run/

languages/perl/run.sh

@@ -0,0 +1,2 @@
+printf %s "$1" > program.pl
+perl program.pl || true

languages/php/Dockerfile

@@ -0,0 +1,4 @@
+FROM php:alpine
+LABEL author="1Computer1"
+
+COPY run.sh /var/run/

languages/php/run.sh

@@ -0,0 +1,2 @@
+printf %s "$1" > program.php
+php program.php || true

languages/prolog/Dockerfile

@@ -0,0 +1,4 @@
+FROM swipl
+LABEL author="1Computer1"
+
+COPY run.sh /var/run/

languages/prolog/run.sh

@@ -0,0 +1,2 @@
+printf %s "$1" > program.pl
+swipl --quiet program.pl || true

languages/python/Dockerfile

@@ -0,0 +1,4 @@
+FROM python:3-alpine
+LABEL author="1Computer1"
+
+COPY run.sh /var/run/

languages/python/run.sh

@@ -0,0 +1,2 @@
+printf %s "$1" > program.py
+python program.py || true

languages/racket/Dockerfile

@@ -0,0 +1,4 @@
+FROM jackfirth/racket
+LABEL author="1Computer1"
+
+COPY run.sh /var/run/

languages/racket/run.sh

@@ -0,0 +1,2 @@
+printf %s "$1" > program.rkt
+racket program.rkt || true

languages/ruby/Dockerfile

@@ -0,0 +1,4 @@
+FROM ruby:alpine
+LABEL author="1Computer1"
+
+COPY run.sh /var/run/

languages/ruby/run.sh

@@ -0,0 +1,2 @@
+printf %s "$1" > program.rb
+ruby program.rb || true

languages/rust/Dockerfile

@@ -0,0 +1,4 @@
+FROM rust:slim
+LABEL author="1Computer1"
+
+COPY run.sh /var/run/

languages/rust/run.sh

@@ -0,0 +1,2 @@
+printf %s "$1" > program.rs
+rustc -C opt-level=0 --color never program.rs && ./program || true

package.yaml

@@ -0,0 +1,73 @@
+name:                myriad
+version:             0.1.0.0
+github:              "1computer1/myriad"
+license:             MIT
+author:              "1Computer1"
+maintainer:          "onecomputer00@gmail.com"
+copyright:           "2019 1Computer1"
+
+extra-source-files:
+- README.md
+
+synopsis:            Arbitrary code execution in Docker
+category:            Server
+description:         Please see the README
+
+dependencies:
+- aeson
+- async
+- base
+- bytestring
+- containers
+- dhall
+- lifted-base
+- lifted-async
+- monad-control
+- monad-logger
+- mtl
+- optparse-applicative
+- servant
+- servant-server
+- snowflake
+- stm
+- string-conversions
+- text
+- time
+- transformers
+- transformers-base
+- typed-process
+- wai
+- warp
+
+default-extensions:
+- BlockArguments
+- ConstraintKinds
+- DataKinds
+- DeriveFunctor
+- DeriveGeneric
+- FlexibleContexts
+- FunctionalDependencies
+- GADTs
+- LambdaCase
+- MultiParamTypeClasses
+- MultiWayIf
+- NamedFieldPuns
+- OverloadedStrings
+- PatternSynonyms
+- PolyKinds
+- RankNTypes
+- ScopedTypeVariables
+- TupleSections
+- TypeApplications
+- TypeOperators
+- TypeFamilies
+- ViewPatterns
+
+executable:
+  main: Main.hs
+  source-dirs: src
+  ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    - -Wall

src/Main.hs

@@ -0,0 +1,20 @@
+module Main where
+
+import Control.Monad.Logger
+
+import Network.Wai.Handler.Warp (run)
+
+import Myriad.Core
+import Myriad.Docker
+import Myriad.Server
+
+main :: IO ()
+main = do
+    env <- initEnv "./config.dhall"
+    runMyriadT env do
+        buildAllImages
+        startCleanup
+    runStdoutLoggingT do
+        logInfoN "Finished Docker-related setup"
+        logInfoN "Starting server"
+    run (fromIntegral . port . config $ env) $ app env

src/Myriad/Core.hs

@@ -0,0 +1,82 @@
+module Myriad.Core
+    ( Language
+    , ContainerName
+    , ImageName
+    , EvalResult(..)
+    , Env(..)
+    , MyriadConfig(..)
+    , LanguageConfig(..)
+    , MyriadT
+    , MonadWithIO
+    , runMyriadT
+    , initEnv
+    ) where
+
+import Control.Monad.Base
+import Control.Monad.Logger
+import Control.Monad.Reader
+import Control.Monad.Trans.Control
+
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.Map.Strict as M
+import qualified Data.Text as T
+import Dhall
+import GHC.Generics (Generic)
+
+import Control.Concurrent.QSem
+import Data.IORef.Lifted
+import Data.Snowflake
+
+type Language = T.Text
+type ContainerName = String
+type ImageName = String
+
+data EvalResult = EvalOk BL.ByteString | EvalTimedOut | EvalErrored
+
+data Env = Env
+    { config :: MyriadConfig
+    , containers :: IORef (M.Map Language ContainerName)
+    , containerSems :: IORef (M.Map Language QSem)
+    , evalSems :: IORef (M.Map Language QSem)
+    , snowflakeGen :: SnowflakeGen
+    }
+
+data MyriadConfig = MyriadConfig
+    { languages :: [LanguageConfig]
+    , buildConcurrently :: Bool
+    , prepareContainers :: Bool
+    , cleanupInterval :: Natural
+    , port :: Integer
+    } deriving (Show, Generic)
+
+instance Interpret MyriadConfig
+
+data LanguageConfig = LanguageConfig
+    { name :: Language
+    , memory :: T.Text
+    , cpus :: T.Text
+    , timeout :: Natural
+    , concurrent :: Natural
+    , retries :: Natural
+    } deriving (Show, Generic)
+
+instance Interpret LanguageConfig
+
+type MyriadT m = ReaderT Env (LoggingT m)
+
+type MonadWithIO m = (MonadIO m, MonadBase IO m, MonadBaseControl IO m)
+
+readConfig :: T.Text -> IO MyriadConfig
+readConfig path = input auto path
+
+initEnv :: T.Text -> IO Env
+initEnv path =
+        Env
+    <$> readConfig path
+    <*> newIORef M.empty
+    <*> newIORef M.empty
+    <*> newIORef M.empty
+    <*> newSnowflakeGen defaultConfig 0
+
+runMyriadT :: MonadIO m => Env -> MyriadT m a -> m a
+runMyriadT env f = runStdoutLoggingT $ runReaderT f env

src/Myriad/Docker.hs

@@ -0,0 +1,185 @@
+module Myriad.Docker
+    ( EvalResult(..)
+    , buildImage
+    , buildAllImages
+    , startCleanup
+    , setupContainer
+    , killContainer
+    , killAllContainers
+    , killContainerMaybe
+    , killAllContainersMaybe
+    , evalCode
+    ) where
+
+import Control.Monad.Logger
+import Control.Monad.Reader
+
+import qualified Data.Map.Strict as M
+
+import Control.Concurrent.Lifted (fork, threadDelay)
+import Control.Concurrent.Async.Lifted
+import Control.Concurrent.QSem.Lifted
+import Control.Exception.Lifted
+import Data.IORef.Lifted
+import Data.Snowflake
+import System.Process.Typed
+
+import Myriad.Core
+import Myriad.Util
+
+exec :: MonadWithIO m => String -> MyriadT m ()
+exec = runProcess_ . shell
+
+buildImage :: MonadWithIO m => LanguageConfig -> MyriadT m ()
+buildImage lang@LanguageConfig { name, concurrent } = do
+    logInfoN $ mconcat ["Building image ", cvs $ imageName lang]
+    let cmd = mconcat ["docker build -t ", imageName lang, " ./languages/", cvs name]
+    runProcess_ . setStdout nullStream $ shell cmd
+    logInfoN $ mconcat ["Built image ", cvs $ imageName lang]
+    Env { config = MyriadConfig { prepareContainers }, containerSems, evalSems } <- ask
+    csem <- newQSem 1 -- We only want one container to be set up at a time
+    esem <- newQSem $ fromIntegral concurrent
+    modifyIORef' containerSems $ M.insert name csem
+    modifyIORef' evalSems $ M.insert name esem
+    when_ prepareContainers $ setupContainer lang
+
+buildAllImages :: MonadWithIO m => MyriadT m ()
+buildAllImages = do
+    MyriadConfig { languages, buildConcurrently } <- asks config
+    if buildConcurrently
+        then forConcurrently_ languages buildImage
+        else forM_ languages buildImage
+
+startCleanup :: MonadWithIO m => MyriadT m ()
+startCleanup = do
+    MyriadConfig { cleanupInterval } <- asks config
+    when_ (cleanupInterval > 0) do
+        let t = fromIntegral cleanupInterval * 60000000
+        fork $ timer t
+    where
+        timer :: MonadWithIO m => Int -> MyriadT m ()
+        timer t = forever do
+            threadDelay t
+            n <- killAllContainersMaybe
+            logInfoN $ mconcat ["Cleaned up ", cvs $ show n, " containers"]
+            timer t
+
+setupContainer :: MonadWithIO m => LanguageConfig -> MyriadT m ContainerName
+setupContainer lang@LanguageConfig { name, memory, cpus } = do
+    ref <- asks containers
+    cnts <- readIORef ref
+    case cnts M.!? name of
+        Just x  -> pure x
+        Nothing -> do
+            cnt <- newContainerName lang
+            let cmd = mconcat
+                    [ "docker run --rm --name="
+                    , cvs cnt
+                    -- User 1000 will be for setting up the environment
+                    , " -u1000:1000 -w/tmp/ -dt --net=none --cpus="
+                    , cvs cpus
+                    , " -m="
+                    , cvs memory
+                    , " --memory-swap="
+                    , cvs memory
+                    , " "
+                    , imageName lang
+                    , " /bin/sh"
+                    ]
+            runProcess_ . setStdout nullStream $ shell cmd
+            -- The `eval` directory is where all the eval work is done
+            -- 711 so that users can't traverse into other people's code
+            exec $ mconcat ["docker exec ", cnt, " mkdir eval"]
+            exec $ mconcat ["docker exec ", cnt, " chmod 711 eval"]
+            modifyIORef' ref $ M.insert name cnt
+            logInfoN $ mconcat ["Started container ", cvs cnt]
+            pure cnt
+
+killContainer :: MonadWithIO m => Language -> MyriadT m ()
+killContainer lang = do
+    ref <- asks containers
+    containers <- readIORef ref
+    case containers M.!? lang of
+        Nothing  -> pure ()
+        Just cnt -> do
+            modifyIORef' ref $ M.delete lang
+            let cmd = mconcat ["docker kill ", cnt]
+            runProcess_ . setStderr nullStream . setStdout nullStream $ shell cmd
+            logInfoN $ mconcat ["Killed container ", cvs cnt]
+
+killContainerMaybe :: MonadWithIO m => Language -> MyriadT m Bool
+killContainerMaybe lang = do
+    containers <- asks containers >>= readIORef
+    case containers M.!? lang of
+        Nothing  -> pure False
+        Just cnt -> do
+            res :: Either SomeException () <- try $ killContainer lang
+            case res of
+                Left err -> do
+                    logErrorN $ mconcat ["An exception occured when killing ", cvs cnt, ":\n", cvs $ show err]
+                    pure False
+                Right _  -> pure True
+
+killAllContainers :: MonadWithIO m => MyriadT m ()
+killAllContainers = do
+    containers <- asks containers >>= readIORef
+    forConcurrently_ (M.keys containers) $ killContainer
+
+killAllContainersMaybe :: MonadWithIO m => MyriadT m Int
+killAllContainersMaybe = do
+    containers <- asks containers >>= readIORef
+    xs <- forConcurrently (M.keys containers) $ killContainerMaybe
+    pure . length $ filter id xs
+
+evalCode :: MonadWithIO m => LanguageConfig -> Int -> String -> MyriadT m EvalResult
+evalCode lang@LanguageConfig { name, timeout, retries } numRetries code = do
+    Env { containerSems, evalSems } <- ask
+    csem <- (M.! name) <$> readIORef containerSems
+    esem <- (M.! name) <$> readIORef evalSems
+    bracket_ (waitQSem esem) (signalQSem esem) $ do
+        cnt <- bracket_ (waitQSem csem) (signalQSem csem) $ setupContainer lang
+        doneRef <- newIORef 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.
+        res <- try $ eval cnt
+        case res of
+            Left (SomeException err) -> do
+                void $ killContainerMaybe name
+                done <- readIORef doneRef
+                if done
+                    -- If we find the eval is done from an exception, then it was timed out.
+                    then do
+                        logInfoN $ mconcat ["Code timed out in container ", cvs cnt]
+                        pure EvalTimedOut
+                    -- Otherwise, the container was killed from another eval, so we should retry.
+                    else do
+                        writeIORef doneRef True
+                        if numRetries < fromIntegral retries
+                            then evalCode lang (numRetries + 1) code
+                            else do
+                                logErrorN $ mconcat ["An exception occured when evaluating in ", cvs cnt, ":\n", cvs $ show err]
+                                pure EvalErrored
+            Right x -> do
+                writeIORef doneRef True
+                pure x
+    where
+        timer :: MonadWithIO m => IORef Bool -> MyriadT m ()
+        timer doneRef = do
+            threadDelay $ fromIntegral timeout * 1000000
+            done <- readIORef doneRef
+            unless_ done do
+                writeIORef doneRef True
+                killContainerMaybe name
+
+        eval :: MonadWithIO m => ContainerName -> MyriadT m EvalResult
+        eval cnt = do
+            logInfoN $ mconcat ["Running code in container ", cvs cnt, ":\n", cvs code]
+            snowflakeGen <- asks snowflakeGen
+            snowflake <- liftIO $ nextSnowflake snowflakeGen
+            exec $ mconcat ["docker exec ", cvs cnt, " mkdir eval/", show snowflake]
+            exec $ mconcat ["docker exec ", cvs 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 $ mconcat ["docker exec ", cnt, " rm -rf eval/", show snowflake]
+            logInfoN $ mconcat ["Ran code in container ", cvs cnt]
+            pure $ EvalOk output

src/Myriad/Server.hs

@@ -0,0 +1,57 @@
+{-# 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

src/Myriad/Util.hs

@@ -0,0 +1,33 @@
+module Myriad.Util
+    ( newContainerName
+    , imageName
+    , cvs
+    , when_
+    , unless_
+    ) where
+
+import Control.Monad.Reader
+
+import Data.Snowflake
+import Data.String.Conversions
+
+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 

stack.yaml

@@ -0,0 +1,4 @@
+resolver: lts-13.27
+
+packages:
+- .

stack.yaml.lock

@@ -0,0 +1,12 @@
+# This file was autogenerated by Stack.
+# You should not edit this file by hand.
+# For more information, please see the documentation at:
+#   https://docs.haskellstack.org/en/stable/lock_files
+
+packages: []
+snapshots:
+- completed:
+    size: 500539
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/13/27.yaml
+    sha256: 690db832392afe55733b4c7023fd29b1b1c660ee42f1fb505b86b07394ca994e
+  original: lts-13.27