Initial commit
This commit is contained in:
commit
93a4378475
62 changed files with 864 additions and 0 deletions
4
.gitignore
vendored
Normal file
4
.gitignore
vendored
Normal file
|
@ -0,0 +1,4 @@
|
|||
.stack-work/
|
||||
.vscode/
|
||||
logs/
|
||||
myriad.cabal
|
19
LICENSE
Normal file
19
LICENSE
Normal file
|
@ -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.
|
38
README.md
Normal file
38
README.md
Normal file
|
@ -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.
|
2
Setup.hs
Normal file
2
Setup.hs
Normal file
|
@ -0,0 +1,2 @@
|
|||
import Distribution.Simple
|
||||
main = defaultMain
|
39
config.dhall
Normal file
39
config.dhall
Normal file
|
@ -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
|
4
languages/apl/Dockerfile
Normal file
4
languages/apl/Dockerfile
Normal file
|
@ -0,0 +1,4 @@
|
|||
FROM juergensauermann/gnu-apl
|
||||
LABEL author="1Computer1"
|
||||
|
||||
COPY run.sh /var/run/
|
2
languages/apl/run.sh
Normal file
2
languages/apl/run.sh
Normal file
|
@ -0,0 +1,2 @@
|
|||
printf %s "$1" > program.apl
|
||||
apl --OFF -s -f program.apl || true
|
4
languages/bash/Dockerfile
Normal file
4
languages/bash/Dockerfile
Normal file
|
@ -0,0 +1,4 @@
|
|||
FROM bash
|
||||
LABEL author="1Computer1"
|
||||
|
||||
COPY run.sh /var/run/
|
2
languages/bash/run.sh
Normal file
2
languages/bash/run.sh
Normal file
|
@ -0,0 +1,2 @@
|
|||
printf %s "$1" > program.sh
|
||||
bash program.sh || true
|
12
languages/brainfuck/Dockerfile
Normal file
12
languages/brainfuck/Dockerfile
Normal file
|
@ -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/
|
119
languages/brainfuck/bf.cpp
Normal file
119
languages/brainfuck/bf.cpp
Normal file
|
@ -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;
|
||||
}
|
1
languages/brainfuck/run.sh
Normal file
1
languages/brainfuck/run.sh
Normal file
|
@ -0,0 +1 @@
|
|||
printf %s "$1" | bf || true
|
7
languages/c/Dockerfile
Normal file
7
languages/c/Dockerfile
Normal file
|
@ -0,0 +1,7 @@
|
|||
FROM alpine
|
||||
LABEL author="1Computer1"
|
||||
|
||||
RUN apk update
|
||||
RUN apk add gcc libc-dev
|
||||
|
||||
COPY run.sh /var/run/
|
2
languages/c/run.sh
Normal file
2
languages/c/run.sh
Normal file
|
@ -0,0 +1,2 @@
|
|||
printf %s "$1" > program.c
|
||||
gcc program.c -o program && ./program || true
|
4
languages/clojure/Dockerfile
Normal file
4
languages/clojure/Dockerfile
Normal file
|
@ -0,0 +1,4 @@
|
|||
FROM clojure:tools-deps-alpine
|
||||
LABEL author="1Computer1"
|
||||
|
||||
COPY run.sh /var/run/
|
2
languages/clojure/run.sh
Normal file
2
languages/clojure/run.sh
Normal file
|
@ -0,0 +1,2 @@
|
|||
printf %s "$1" > program.clj
|
||||
clojure program.clj || true
|
7
languages/cpp/Dockerfile
Normal file
7
languages/cpp/Dockerfile
Normal file
|
@ -0,0 +1,7 @@
|
|||
FROM alpine
|
||||
LABEL author="1Computer1"
|
||||
|
||||
RUN apk update
|
||||
RUN apk add g++
|
||||
|
||||
COPY run.sh /var/run/
|
2
languages/cpp/run.sh
Normal file
2
languages/cpp/run.sh
Normal file
|
@ -0,0 +1,2 @@
|
|||
printf %s "$1" > program.cpp
|
||||
g++ program.cpp -o program && ./program || true
|
4
languages/csharp/Dockerfile
Normal file
4
languages/csharp/Dockerfile
Normal file
|
@ -0,0 +1,4 @@
|
|||
FROM mono
|
||||
LABEL author="1Computer1"
|
||||
|
||||
COPY run.sh /var/run/
|
2
languages/csharp/run.sh
Normal file
2
languages/csharp/run.sh
Normal file
|
@ -0,0 +1,2 @@
|
|||
printf %s "$1" > program.cs
|
||||
csc program.cs >/dev/null && mono program.exe || true
|
4
languages/elixir/Dockerfile
Normal file
4
languages/elixir/Dockerfile
Normal file
|
@ -0,0 +1,4 @@
|
|||
FROM elixir:alpine
|
||||
LABEL author="1Computer1"
|
||||
|
||||
COPY run.sh /var/run/
|
2
languages/elixir/run.sh
Normal file
2
languages/elixir/run.sh
Normal file
|
@ -0,0 +1,2 @@
|
|||
printf %s "$1" > program.exs
|
||||
elixir program.exs || true
|
4
languages/fsharp/Dockerfile
Normal file
4
languages/fsharp/Dockerfile
Normal file
|
@ -0,0 +1,4 @@
|
|||
FROM fsharp
|
||||
LABEL author="1Computer1"
|
||||
|
||||
COPY run.sh /var/run/
|
2
languages/fsharp/run.sh
Normal file
2
languages/fsharp/run.sh
Normal file
|
@ -0,0 +1,2 @@
|
|||
printf %s "$1" > program.fs
|
||||
fsharpc --optimize- program.fs >/dev/null && mono program.exe || true
|
4
languages/go/Dockerfile
Normal file
4
languages/go/Dockerfile
Normal file
|
@ -0,0 +1,4 @@
|
|||
FROM golang:alpine
|
||||
LABEL author="1Computer1"
|
||||
|
||||
COPY run.sh /var/run/
|
3
languages/go/run.sh
Normal file
3
languages/go/run.sh
Normal file
|
@ -0,0 +1,3 @@
|
|||
export GOCACHE=/tmp/"$CODEDIR"/cache
|
||||
printf %s "$1" > program.go
|
||||
go run program.go || true
|
15
languages/haskell/Dockerfile
Normal file
15
languages/haskell/Dockerfile
Normal file
|
@ -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/
|
2
languages/haskell/run.sh
Normal file
2
languages/haskell/run.sh
Normal file
|
@ -0,0 +1,2 @@
|
|||
printf %s "$1" > program.hs
|
||||
ghc -e main program.hs || true
|
4
languages/java/Dockerfile
Normal file
4
languages/java/Dockerfile
Normal file
|
@ -0,0 +1,4 @@
|
|||
FROM openjdk:13-alpine
|
||||
LABEL author="1Computer1"
|
||||
|
||||
COPY run.sh /var/run/
|
2
languages/java/run.sh
Normal file
2
languages/java/run.sh
Normal file
|
@ -0,0 +1,2 @@
|
|||
printf %s "$1" > Main.java
|
||||
javac Main.java && java Main || true
|
4
languages/javascript/Dockerfile
Normal file
4
languages/javascript/Dockerfile
Normal file
|
@ -0,0 +1,4 @@
|
|||
FROM node:alpine
|
||||
LABEL author="1Computer1"
|
||||
|
||||
COPY run.sh /var/run/
|
1
languages/javascript/run.sh
Normal file
1
languages/javascript/run.sh
Normal file
|
@ -0,0 +1 @@
|
|||
printf %s "$1" | node -p || true
|
4
languages/julia/Dockerfile
Normal file
4
languages/julia/Dockerfile
Normal file
|
@ -0,0 +1,4 @@
|
|||
FROM julia
|
||||
LABEL author="1Computer1"
|
||||
|
||||
COPY run.sh /var/run/
|
1
languages/julia/run.sh
Normal file
1
languages/julia/run.sh
Normal file
|
@ -0,0 +1 @@
|
|||
printf %s "$1" | julia
|
6
languages/lua/Dockerfile
Normal file
6
languages/lua/Dockerfile
Normal file
|
@ -0,0 +1,6 @@
|
|||
FROM alpine
|
||||
|
||||
RUN apk update
|
||||
RUN apk add lua5.3
|
||||
|
||||
COPY run.sh /var/run/
|
2
languages/lua/run.sh
Normal file
2
languages/lua/run.sh
Normal file
|
@ -0,0 +1,2 @@
|
|||
printf %s "$1" > program.lua
|
||||
lua5.3 program.lua || true
|
4
languages/ocaml/Dockerfile
Normal file
4
languages/ocaml/Dockerfile
Normal file
|
@ -0,0 +1,4 @@
|
|||
FROM frolvlad/alpine-ocaml
|
||||
LABEL author="1Computer1"
|
||||
|
||||
COPY run.sh /var/run/
|
2
languages/ocaml/run.sh
Normal file
2
languages/ocaml/run.sh
Normal file
|
@ -0,0 +1,2 @@
|
|||
printf %s "$1" > program.ml
|
||||
ocamlopt -cclib --static -o program program.ml && ./program || true
|
4
languages/pascal/Dockerfile
Normal file
4
languages/pascal/Dockerfile
Normal file
|
@ -0,0 +1,4 @@
|
|||
FROM frolvlad/alpine-fpc
|
||||
LABEL author="1Computer1"
|
||||
|
||||
COPY run.sh /var/run/
|
10
languages/pascal/run.sh
Normal file
10
languages/pascal/run.sh
Normal file
|
@ -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
|
4
languages/perl/Dockerfile
Normal file
4
languages/perl/Dockerfile
Normal file
|
@ -0,0 +1,4 @@
|
|||
FROM perl:slim
|
||||
LABEL author="1Computer1"
|
||||
|
||||
COPY run.sh /var/run/
|
2
languages/perl/run.sh
Normal file
2
languages/perl/run.sh
Normal file
|
@ -0,0 +1,2 @@
|
|||
printf %s "$1" > program.pl
|
||||
perl program.pl || true
|
4
languages/php/Dockerfile
Normal file
4
languages/php/Dockerfile
Normal file
|
@ -0,0 +1,4 @@
|
|||
FROM php:alpine
|
||||
LABEL author="1Computer1"
|
||||
|
||||
COPY run.sh /var/run/
|
2
languages/php/run.sh
Normal file
2
languages/php/run.sh
Normal file
|
@ -0,0 +1,2 @@
|
|||
printf %s "$1" > program.php
|
||||
php program.php || true
|
4
languages/prolog/Dockerfile
Normal file
4
languages/prolog/Dockerfile
Normal file
|
@ -0,0 +1,4 @@
|
|||
FROM swipl
|
||||
LABEL author="1Computer1"
|
||||
|
||||
COPY run.sh /var/run/
|
2
languages/prolog/run.sh
Normal file
2
languages/prolog/run.sh
Normal file
|
@ -0,0 +1,2 @@
|
|||
printf %s "$1" > program.pl
|
||||
swipl --quiet program.pl || true
|
4
languages/python/Dockerfile
Normal file
4
languages/python/Dockerfile
Normal file
|
@ -0,0 +1,4 @@
|
|||
FROM python:3-alpine
|
||||
LABEL author="1Computer1"
|
||||
|
||||
COPY run.sh /var/run/
|
2
languages/python/run.sh
Normal file
2
languages/python/run.sh
Normal file
|
@ -0,0 +1,2 @@
|
|||
printf %s "$1" > program.py
|
||||
python program.py || true
|
4
languages/racket/Dockerfile
Normal file
4
languages/racket/Dockerfile
Normal file
|
@ -0,0 +1,4 @@
|
|||
FROM jackfirth/racket
|
||||
LABEL author="1Computer1"
|
||||
|
||||
COPY run.sh /var/run/
|
2
languages/racket/run.sh
Normal file
2
languages/racket/run.sh
Normal file
|
@ -0,0 +1,2 @@
|
|||
printf %s "$1" > program.rkt
|
||||
racket program.rkt || true
|
4
languages/ruby/Dockerfile
Normal file
4
languages/ruby/Dockerfile
Normal file
|
@ -0,0 +1,4 @@
|
|||
FROM ruby:alpine
|
||||
LABEL author="1Computer1"
|
||||
|
||||
COPY run.sh /var/run/
|
2
languages/ruby/run.sh
Normal file
2
languages/ruby/run.sh
Normal file
|
@ -0,0 +1,2 @@
|
|||
printf %s "$1" > program.rb
|
||||
ruby program.rb || true
|
4
languages/rust/Dockerfile
Normal file
4
languages/rust/Dockerfile
Normal file
|
@ -0,0 +1,4 @@
|
|||
FROM rust:slim
|
||||
LABEL author="1Computer1"
|
||||
|
||||
COPY run.sh /var/run/
|
2
languages/rust/run.sh
Normal file
2
languages/rust/run.sh
Normal file
|
@ -0,0 +1,2 @@
|
|||
printf %s "$1" > program.rs
|
||||
rustc -C opt-level=0 --color never program.rs && ./program || true
|
73
package.yaml
Normal file
73
package.yaml
Normal file
|
@ -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
|
20
src/Main.hs
Normal file
20
src/Main.hs
Normal file
|
@ -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
|
82
src/Myriad/Core.hs
Normal file
82
src/Myriad/Core.hs
Normal file
|
@ -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
|
185
src/Myriad/Docker.hs
Normal file
185
src/Myriad/Docker.hs
Normal file
|
@ -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
|
57
src/Myriad/Server.hs
Normal file
57
src/Myriad/Server.hs
Normal file
|
@ -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
|
33
src/Myriad/Util.hs
Normal file
33
src/Myriad/Util.hs
Normal file
|
@ -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
|
4
stack.yaml
Normal file
4
stack.yaml
Normal file
|
@ -0,0 +1,4 @@
|
|||
resolver: lts-13.27
|
||||
|
||||
packages:
|
||||
- .
|
12
stack.yaml.lock
Normal file
12
stack.yaml.lock
Normal file
|
@ -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
|
Loading…
Reference in a new issue