From 92cb8a638820e779ba19f983af29e6224c32799f Mon Sep 17 00:00:00 2001
From: 1computer1 <mineox100@gmail.com>
Date: Thu, 11 Jul 2019 02:20:36 -0400
Subject: [PATCH] Add /containers and /cleanup endpoints

---
 README.md            |  6 ++++++
 src/Myriad/Docker.hs |  6 +++---
 src/Myriad/Server.hs | 14 +++++++++++++-
 3 files changed, 22 insertions(+), 4 deletions(-)

diff --git a/README.md b/README.md
index 7d637bd..2c9e07c 100644
--- a/README.md
+++ b/README.md
@@ -39,3 +39,9 @@ Example response:
 ```
 
 Errors with 404 if `language` is not found, `504` if evaluation timed out, or `500` if evaluation failed for other reasons.  
+
+### **GET** `/containers`
+List of containers being handled by Myriad.  
+
+### **POST** `/cleanup`
+Kill all containers, giving back the names of the containers killed.  
diff --git a/src/Myriad/Docker.hs b/src/Myriad/Docker.hs
index 48cec88..ef717ae 100644
--- a/src/Myriad/Docker.hs
+++ b/src/Myriad/Docker.hs
@@ -125,11 +125,11 @@ killAllContainers = do
     containers <- asks containers >>= readIORef
     forConcurrently_ (M.keys containers) $ killContainer
 
-killAllContainersMaybe :: MonadWithIO m => MyriadT m Int
+killAllContainersMaybe :: MonadWithIO m => MyriadT m [ContainerName]
 killAllContainersMaybe = do
     containers <- asks containers >>= readIORef
-    xs <- forConcurrently (M.keys containers) $ killContainerMaybe
-    pure . length $ filter id xs
+    xs <- forConcurrently (M.toList containers) \(k, v) -> (v,) <$> killContainerMaybe k
+    pure . map fst $ filter snd xs
 
 evalCode :: MonadWithIO m => LanguageConfig -> Int -> String -> MyriadT m EvalResult
 evalCode lang@LanguageConfig { name, timeout, retries } numRetries code = do
diff --git a/src/Myriad/Server.hs b/src/Myriad/Server.hs
index 95cce22..e3ee341 100644
--- a/src/Myriad/Server.hs
+++ b/src/Myriad/Server.hs
@@ -10,10 +10,12 @@ import Control.Monad.Reader
 
 import Data.Aeson
 import Data.List (find)
+import qualified Data.Map as M
 import qualified Data.Text as T
 import GHC.Generics
 
 import Control.Concurrent.Async.Lifted
+import Data.IORef.Lifted
 import Servant
 
 import Myriad.Core
@@ -26,6 +28,8 @@ data EvalResponse = EvalResponse { result :: T.Text } deriving (Generic, ToJSON)
 type API
     =    "languages" :> Get '[JSON] [T.Text]
     :<|> "eval" :> ReqBody '[JSON] EvalRequest :> Post '[JSON] EvalResponse
+    :<|> "containers" :> Get '[JSON] [T.Text]
+    :<|> "cleanup" :> Post '[JSON] [T.Text]
 
 app :: Env -> Application
 app = serve (Proxy @API) . server
@@ -34,7 +38,7 @@ 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
+serverT = handleLanguages :<|> handleEval :<|> handleContainers :<|> handleCleanup
     where
         handleLanguages :: MyriadT m [T.Text]
         handleLanguages = do
@@ -54,3 +58,11 @@ serverT = handleLanguages :<|> handleEval
                         EvalErrored  -> throwError $ err500 { errBody = "Evaluation failed" }
                         EvalTimedOut -> throwError $ err504 { errBody = "Evaluation timed out" }
                         EvalOk xs    -> pure . EvalResponse $ cvs xs
+
+        handleContainers :: MyriadT m [T.Text]
+        handleContainers = do
+            containers <- asks containers >>= readIORef
+            pure . map cvs $ M.elems containers
+
+        handleCleanup :: MyriadT m [T.Text]
+        handleCleanup = map cvs <$> killAllContainersMaybe