Restructure project

package.yaml

@@ -42,11 +42,14 @@ default-extensions:
 - BlockArguments
 - ConstraintKinds
 - DataKinds
+- DerivingStrategies
 - DeriveFunctor
 - DeriveGeneric
 - FlexibleContexts
+- FlexibleInstances
 - FunctionalDependencies
 - GADTs
+- GeneralizedNewtypeDeriving
 - LambdaCase
 - MultiParamTypeClasses
 - MultiWayIf
@@ -56,6 +59,7 @@ default-extensions:
 - PolyKinds
 - RankNTypes
 - ScopedTypeVariables
+- StandaloneDeriving
 - TupleSections
 - TypeApplications
 - TypeOperators

src/Main.hs

@@ -1,7 +1,5 @@
 module Main where
 
-import Control.Monad.Logger
-
 import qualified Data.Text as T
 import Options.Applicative
 
@@ -32,7 +30,6 @@ main = do
     runMyriadT env do
         buildAllImages
         startCleanup
-    runStdoutLoggingT do
+        logInfo ["Finished Docker-related setup"]
-        logInfoN "Finished Docker-related setup"
+        logInfo ["Starting server"]
-        logInfoN "Starting server"
     run (fromIntegral . port . config $ env) $ app env

src/Myriad/Core.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE UndecidableInstances #-}
+
 module Myriad.Core
     ( Language
     , ContainerName
@@ -7,26 +9,37 @@ module Myriad.Core
     , MyriadConfig(..)
     , LanguageConfig(..)
     , MyriadT
-    , MonadWithIO
+    , Myriad
-    , MyriadIO
+    , Myriadic
     , runMyriadT
     , initEnv
+    , exec
+    , exec_
+    , logInfo
+    , logError
+    , mapMVar
+    , writeMVar
     ) where
 
 import Control.Monad.Base
-import Control.Monad.Logger
+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 GHC.Generics (Generic)
 
-import Control.Concurrent.MVar
+import Control.Concurrent.MVar.Lifted
-import Control.Concurrent.QSem
+import Control.Concurrent.QSem.Lifted
-import Data.Snowflake
+import System.Process.Typed
 
 type Language = T.Text
 type ContainerName = String
@@ -63,11 +76,37 @@ data LanguageConfig = LanguageConfig
 
 instance Interpret LanguageConfig
 
-type MyriadT m = ReaderT Env (LoggingT m)
+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
+        )
 
-type MonadWithIO m = (MonadIO m, MonadBase IO m, MonadBaseControl IO m)
+instance MonadTrans MyriadT where
+    lift = MyriadT . lift . lift 
 
-type MyriadIO a = forall m. MonadWithIO m => MyriadT m a
+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
@@ -82,4 +121,22 @@ initEnv configInput =
     <*> newSnowflakeGen defaultConfig 0
 
 runMyriadT :: MonadIO m => Env -> MyriadT m a -> m a
-runMyriadT env f = runStdoutLoggingT $ runReaderT f env
+runMyriadT env = runStdoutLoggingT . flip runReaderT env . unMyriadT
+
+exec :: MonadIO m => [String] -> m BL.ByteString
+exec = readProcessInterleaved_ . shell . mconcat
+
+exec_ :: MonadIO m => [String] -> m ()
+exec_ = void . 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

src/Myriad/Docker.hs

@@ -13,6 +13,7 @@ import Control.Monad.Reader
 
 import qualified Data.Map.Strict as M
 import Data.Snowflake
+import Data.String.Conversions
 
 import Control.Concurrent.Async.Lifted
 import Control.Concurrent.Lifted (fork, threadDelay)
@@ -22,18 +23,17 @@ import Control.Exception.Lifted
 import System.Process.Typed
 
 import Myriad.Core
-import Myriad.Util
 
-buildImage :: LanguageConfig -> MyriadIO ()
+buildImage :: Myriadic m => LanguageConfig -> m ()
 buildImage lang@LanguageConfig { name, concurrent } = do
-    logInfo ["Building image ", cvs $ imageName lang]
+    logInfo ["Building image ", cs $ imageName lang]
-    exec_ ["docker build -t ", imageName lang, " ./languages/", cvs name]
+    exec_ ["docker build -t ", imageName lang, " ./languages/", cs name]
     setupQSems
-    logInfo ["Built image ", cvs $ imageName lang]
+    logInfo ["Built image ", cs $ imageName lang]
     MyriadConfig { prepareContainers } <- asks config
     when_ prepareContainers $ setupContainer lang
     where
-        setupQSems :: MyriadIO ()
+        setupQSems :: Myriadic m => m ()
         setupQSems = do
             Env { containerSems, evalSems } <- ask
             csem <- newQSem 1 -- We only want one container to be set up at a time
@@ -41,48 +41,48 @@ buildImage lang@LanguageConfig { name, concurrent } = do
             mapMVar containerSems $ M.insert name csem
             mapMVar evalSems $ M.insert name esem
 
-buildAllImages :: MyriadIO ()
+buildAllImages :: Myriadic m => m ()
 buildAllImages = do
     MyriadConfig { languages, buildConcurrently } <- asks config
     if buildConcurrently
         then forConcurrently_ languages buildImage
         else forM_ languages buildImage
 
-startCleanup :: MyriadIO ()
+startCleanup :: Myriadic m => m ()
 startCleanup = do
     MyriadConfig { cleanupInterval } <- asks config
     when_ (cleanupInterval > 0) do
         let t = fromIntegral cleanupInterval * 60000000
         fork $ timer t
     where
-        timer :: Int -> MyriadIO ()
+        timer :: Int -> Myriadic m => m ()
         timer t = forever do
             threadDelay t
             n <- killContainers
-            logInfo ["Cleaned up ", cvs $ show n, " containers"]
+            logInfo ["Cleaned up ", cs $ show n, " containers"]
             timer t
 
-setupContainer :: LanguageConfig -> MyriadIO ContainerName
+setupContainer :: Myriadic m => LanguageConfig -> m ContainerName
 setupContainer lang@LanguageConfig { name, memory, cpus } = do
     cnts <- asks containers >>= readMVar
     case cnts M.!? name of
         Nothing  -> setup
         Just cnt -> pure cnt
     where
-        setup :: MyriadIO ContainerName
+        setup :: Myriadic m => m ContainerName
         setup = do
             ref <- asks containers
             cnt <- newContainerName lang
             exec_
                 [ "docker run --rm --name="
-                , cvs cnt
+                , cs cnt
                 -- User 1000 will be for setting up the environment
                 , " -u1000:1000 -w/tmp/ -dt --net=none --cpus="
-                , cvs cpus
+                , cs cpus
                 , " -m="
-                , cvs memory
+                , cs memory
                 , " --memory-swap="
-                , cvs memory
+                , cs memory
                 , " "
                 , imageName lang
                 , " /bin/sh"
@@ -92,10 +92,10 @@ setupContainer lang@LanguageConfig { name, memory, cpus } = do
             exec_ ["docker exec ", cnt, " mkdir eval"]
             exec_ ["docker exec ", cnt, " chmod 711 eval"]
             mapMVar ref $ M.insert name cnt
-            logInfo ["Started container ", cvs cnt]
+            logInfo ["Started container ", cs cnt]
             pure cnt
 
-killContainer :: Language -> MyriadIO Bool
+killContainer :: Myriadic m => Language -> m Bool
 killContainer lang = do
     containers <- asks containers >>= readMVar
     case containers M.!? lang of
@@ -105,10 +105,10 @@ killContainer lang = do
             case res of
                 Nothing  -> pure True
                 Just err -> do
-                    logError ["An exception occured when killing ", cvs cnt, ":\n", cvs $ show err]
+                    logError ["An exception occured when killing ", cs cnt, ":\n", cs $ show err]
                     pure False
     where
-        kill :: ContainerName -> MyriadIO (Maybe SomeException)
+        kill :: Myriadic m => ContainerName -> m (Maybe SomeException)
         kill cnt = do
             ref <- asks containers
             mapMVar ref $ M.delete lang
@@ -116,16 +116,16 @@ killContainer lang = do
             case res of
                 Left err -> pure $ Just err
                 Right _  -> do
-                    logInfo ["Killed container ", cvs cnt]
+                    logInfo ["Killed container ", cs cnt]
                     pure Nothing
 
-killContainers :: MyriadIO [ContainerName]
+killContainers :: Myriadic m => m [ContainerName]
 killContainers = do
     containers <- asks containers >>= readMVar
     xs <- forConcurrently (M.toList containers) \(k, v) -> (v,) <$> killContainer k
     pure . map fst $ filter snd xs
 
-evalCode :: LanguageConfig -> Int -> String -> MyriadIO EvalResult
+evalCode :: Myriadic m => LanguageConfig -> Int -> String -> m EvalResult
 evalCode lang@LanguageConfig { name, timeout, retries } numRetries code = withContainer \cnt -> do
     doneRef <- newMVar 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.
@@ -139,23 +139,23 @@ evalCode lang@LanguageConfig { name, timeout, retries } numRetries code = withCo
             if done
                 -- If we find the eval is done from an exception, then it was timed out.
                 then do
-                    logError ["Code timed out in container ", cvs cnt, ", evaluation ", cvs $ show snowflake]
+                    logError ["Code timed out in container ", cs cnt, ", evaluation ", cs $ show snowflake]
                     pure EvalTimedOut
                 -- Otherwise, the container was killed from another eval, so we should retry.
                 else do
                     writeMVar doneRef True
                     if numRetries < fromIntegral retries
                         then do
-                            logError ["An exception occured in ", cvs cnt, ", evaluation ", cvs $ show snowflake, ", retrying:\n", cvs $ show err]
+                            logError ["An exception occured in ", cs cnt, ", evaluation ", cs $ show snowflake, ", retrying:\n", cs $ show err]
                             evalCode lang (numRetries + 1) code
                         else do
-                            logError ["An exception occured in ", cvs cnt, ", evaluation ", cvs $ show snowflake, ":\n", cvs $ show err]
+                            logError ["An exception occured in ", cs cnt, ", evaluation ", cs $ show snowflake, ":\n", cs $ show err]
                             pure EvalErrored
         Right x -> do
             writeMVar doneRef True
             pure x
     where
-        withContainer :: (ContainerName -> MyriadIO a) -> MyriadIO a
+        withContainer :: Myriadic m => (ContainerName -> m a) -> m a
         withContainer f = do
             Env { containerSems, evalSems } <- ask
             csem <- (M.! name) <$> readMVar containerSems
@@ -164,7 +164,7 @@ evalCode lang@LanguageConfig { name, timeout, retries } numRetries code = withCo
                 cnt <- bracket_ (waitQSem csem) (signalQSem csem) $ setupContainer lang
                 f cnt
 
-        timer :: MVar Bool -> MyriadIO ()
+        timer :: Myriadic m => MVar Bool -> m ()
         timer doneRef = do
             threadDelay $ fromIntegral timeout * 1000000
             done <- readMVar doneRef
@@ -172,14 +172,29 @@ evalCode lang@LanguageConfig { name, timeout, retries } numRetries code = withCo
                 writeMVar doneRef True
                 killContainer name
 
-        eval :: ContainerName -> Snowflake -> MyriadIO EvalResult
+        eval :: Myriadic m => ContainerName -> Snowflake -> m EvalResult
         eval cnt snowflake = do
-            logInfo ["Running code in container ", cvs cnt, ", evaluation ", cvs $ show snowflake, ":\n", cvs code]
+            logInfo ["Running code in container ", cs cnt, ", evaluation ", cs $ show snowflake, ":\n", cs code]
-            exec_ ["docker exec ", cvs cnt, " mkdir eval/", show snowflake]
+            exec_ ["docker exec ", cs cnt, " mkdir eval/", show snowflake]
-            exec_ ["docker exec ", cvs cnt, " chmod 777 eval/", show snowflake]
+            exec_ ["docker exec ", cs 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_ ["docker exec ", cnt, " rm -rf eval/", show snowflake]
-            logInfo ["Ran code in container ", cvs cnt, ", evaluation ", cvs $ show snowflake]
+            logInfo ["Ran code in container ", cs cnt, ", evaluation ", cs $ show snowflake]
             pure $ EvalOk output
+
+newContainerName :: Myriadic m => LanguageConfig -> m ContainerName
+newContainerName LanguageConfig { name } = do
+    snowflakeGen <- asks snowflakeGen
+    snowflake <- liftIO $ nextSnowflake snowflakeGen
+    pure $ "comp_iler-" <> cs name <> "-" <> show snowflake
+
+imageName :: LanguageConfig -> ImageName
+imageName LanguageConfig { name } = "1computer1/comp_iler:" <> cs name
+
+when_ :: Applicative f => Bool -> f a -> f ()
+when_ p = when p . void 
+
+unless_ :: Applicative f => Bool -> f a -> f ()
+unless_ p = unless p . void 

src/Myriad/Server.hs

@@ -10,6 +10,7 @@ import Control.Monad.Reader
 import Data.Aeson
 import Data.List (find)
 import qualified Data.Map as M
+import Data.String.Conversions
 import qualified Data.Text as T
 import GHC.Generics
 
@@ -19,7 +20,6 @@ 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)
@@ -36,35 +36,35 @@ 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 :: ServerT API (MyriadT Handler)
 serverT = handleLanguages :<|> handleEval :<|> handleContainers :<|> handleCleanup
     where
-        handleLanguages :: MyriadT m [T.Text]
+        handleLanguages :: MyriadT Handler [T.Text]
         handleLanguages = do
             logInfo ["GET /languages"]
             MyriadConfig { languages } <- asks config
             pure . map name $ languages
 
-        handleEval :: EvalRequest -> MyriadT m EvalResponse
+        handleEval :: EvalRequest -> MyriadT Handler EvalResponse
         handleEval EvalRequest { language, code } = do
             logInfo ["POST /eval"]
             MyriadConfig { languages } <- asks config
             case find (\x -> name x == language) languages of
-                Nothing  -> throwError $ err404 { errBody = "Language " <> cvs language <> " was not found" }
+                Nothing  -> throwError $ err404 { errBody = "Language " <> cs language <> " was not found" }
                 Just cfg -> do
-                    res <- withAsync (evalCode cfg 0 $ cvs code) wait
+                    res <- withAsync (evalCode cfg 0 $ cs code) wait
                     case res of
                         EvalErrored  -> throwError $ err500 { errBody = "Evaluation failed" }
                         EvalTimedOut -> throwError $ err504 { errBody = "Evaluation timed out" }
-                        EvalOk xs    -> pure . EvalResponse $ cvs xs
+                        EvalOk xs    -> pure . EvalResponse $ cs xs
 
-        handleContainers :: MyriadT m [T.Text]
+        handleContainers :: MyriadT Handler [T.Text]
         handleContainers = do
             logInfo ["GET /containers"]
             containers <- asks containers >>= readMVar
-            pure . map cvs $ M.elems containers
+            pure . map cs $ M.elems containers
 
-        handleCleanup :: MyriadT m [T.Text]
+        handleCleanup :: MyriadT Handler [T.Text]
         handleCleanup = do
             logInfo ["POST /cleanup"]
-            map cvs <$> killContainers
+            map cs <$> killContainers

src/Myriad/Util.hs

@@ -1,63 +0,0 @@
-module Myriad.Util
-    ( newContainerName
-    , imageName
-    , cvs
-    , when_
-    , unless_
-    , exec
-    , exec_
-    , logInfo
-    , logError
-    , mapMVar
-    , writeMVar
-    ) where
-
-import qualified Control.Monad.Logger as L
-import Control.Monad.Reader
-
-import qualified Data.ByteString.Lazy as BL
-import Data.Snowflake
-import Data.String.Conversions
-import qualified Data.Text as T
-
-import Control.Concurrent.MVar.Lifted
-import System.Process.Typed
-
-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 
-
-exec :: [String] -> MyriadIO BL.ByteString
-exec = readProcessInterleaved_ . shell . mconcat
-
-exec_ :: [String] -> MyriadIO ()
-exec_ = void . exec
-
-logInfo :: [T.Text] -> MyriadIO ()
-logInfo = L.logInfoN . mconcat
-
-logError :: [T.Text] -> MyriadIO ()
-logError = L.logErrorN . mconcat
-
-mapMVar :: MVar a -> (a -> a) -> MyriadIO ()
-mapMVar var f = modifyMVar_ var (pure . f)
-
-writeMVar :: MVar a -> a -> MyriadIO ()
-writeMVar var x = mapMVar var $ const x