switch from dhall to yaml

src/Myriad.hs

@@ -5,7 +5,6 @@ module Myriad
 import Control.Monad.Logger (runStdoutLoggingT)
 
 import Data.String.Conversions
-import qualified Data.Text as T
 
 import Network.Wai.Handler.Warp
 
@@ -13,9 +12,9 @@ import Myriad.Core
 import Myriad.Docker
 import Myriad.Server
 
-runMyriadServer :: T.Text -> T.Text -> IO ()
-runMyriadServer configInput languagesDir = do
-    env <- initEnv configInput languagesDir
+runMyriadServer :: FilePath -> FilePath -> IO ()
+runMyriadServer configPath languagesDir = do
+    env <- initEnv configPath languagesDir
     runMyriadT env do
         buildAllImages
         startCleanup

src/Myriad/Core.hs

@@ -7,6 +7,7 @@ module Myriad.Core
     , EvalResult(..)
     , Env(..)
     , MyriadConfig(..)
+    , DefaultLanguageConfig(..)
     , LanguageConfig(..)
     , MyriadT
     , Myriadic
@@ -32,7 +33,7 @@ import qualified Data.ByteString.Lazy as BL
 import qualified Data.Map.Strict as M
 import Data.Snowflake
 import qualified Data.Text as T
-import Dhall
+import Data.YAML
 
 import Control.Concurrent.MVar.Lifted
 import Control.Concurrent.QSem.Lifted
@@ -46,7 +47,7 @@ data EvalResult = EvalOk BL.ByteString | EvalTimedOut | EvalErrored
 
 data Env = Env
     { config :: MyriadConfig
-    , languagesDir :: T.Text
+    , languagesDir :: FilePath
     , containers :: MVar (M.Map Language ContainerName)
     , containerSems :: MVar (M.Map Language QSem)
     , evalSems :: MVar (M.Map Language QSem)
@@ -55,24 +56,55 @@ data Env = Env
 
 data MyriadConfig = MyriadConfig
     { languages :: [LanguageConfig]
+    , defaultLanguage :: DefaultLanguageConfig
     , buildConcurrently :: Bool
     , prepareContainers :: Bool
-    , cleanupInterval :: Natural
-    , port :: Natural
-    } deriving (Show, Generic)
+    , cleanupInterval :: Int
+    , port :: Int
+    } deriving (Show)
 
-instance FromDhall MyriadConfig
+instance FromYAML MyriadConfig where
+    parseYAML = withMap "config" $ \m -> MyriadConfig
+        <$> m .: "languages"
+        <*> m .: "defaultLanguage"
+        <*> m .: "buildConcurrently"
+        <*> m .: "prepareContainers"
+        <*> m .: "cleanupInterval"
+        <*> m .: "port"
+
+data DefaultLanguageConfig = DefaultLanguageConfig
+    { defMemory :: T.Text
+    , defCpus :: Double
+    , defTimeout :: Int
+    , defConcurrent :: Int
+    , defRetries :: Int
+    } deriving (Show)
+
+instance FromYAML DefaultLanguageConfig where
+    parseYAML = withMap "default language" $ \m -> DefaultLanguageConfig
+        <$> m .: "memory"
+        <*> m .: "cpus"
+        <*> m .: "timeout"
+        <*> m .: "concurrent"
+        <*> m .: "retries"
 
 data LanguageConfig = LanguageConfig
     { name :: Language
-    , memory :: T.Text
-    , cpus :: T.Text
-    , timeout :: Natural
-    , concurrent :: Natural
-    , retries :: Natural
-    } deriving (Show, Generic)
+    , memory :: Maybe T.Text
+    , cpus :: Maybe Double
+    , timeout :: Maybe Int
+    , concurrent :: Maybe Int
+    , retries :: Maybe Int
+    } deriving (Show)
 
-instance FromDhall LanguageConfig
+instance FromYAML LanguageConfig where
+    parseYAML = withMap "language" $ \m -> LanguageConfig
+        <$> m .: "name"
+        <*> m .:? "memory"
+        <*> m .:? "cpus"
+        <*> m .:? "timeout"
+        <*> m .:? "concurrent"
+        <*> m .:? "retries"
 
 newtype MyriadT m a = MyriadT { unMyriadT :: ReaderT Env (LoggingT m) a }
     deriving newtype
@@ -104,13 +136,17 @@ instance MonadBaseControl b m => MonadBaseControl b (MyriadT m) where
 
 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
+readConfig :: FilePath -> IO MyriadConfig
+readConfig f = do
+    x <- BL.readFile f
+    case decode1 x of
+        Left (pos, e) -> error $ prettyPosWithSource pos x e
+        Right y -> pure y
 
-initEnv :: T.Text -> T.Text -> IO Env
-initEnv configInput languagesDir =
+initEnv :: FilePath -> FilePath -> IO Env
+initEnv configPath languagesDir =
         Env
-    <$> readConfig configInput
+    <$> readConfig configPath
     <*> pure languagesDir
     <*> newMVar M.empty
     <*> newMVar M.empty

src/Myriad/Docker.hs

@@ -12,6 +12,7 @@ module Myriad.Docker
 import Control.Monad.Reader
 
 import qualified Data.Map.Strict as M
+import Data.Maybe
 import Data.Snowflake
 import Data.String.Conversions
 
@@ -36,9 +37,9 @@ buildImage lang@LanguageConfig { name, concurrent } = do
     where
         setupQSems :: Myriadic m => m ()
         setupQSems = do
-            Env { containerSems, evalSems } <- ask
+            Env { config = MyriadConfig { defaultLanguage }, containerSems, evalSems } <- ask
             csem <- newQSem 1 -- We only want one container to be set up at a time
-            esem <- newQSem $ fromIntegral concurrent
+            esem <- newQSem . fromIntegral $ fromMaybe (defConcurrent defaultLanguage) concurrent
             mapMVar containerSems $ M.insert name csem
             mapMVar evalSems $ M.insert name esem
 
@@ -72,18 +73,18 @@ setupContainer lang@LanguageConfig { name, memory, cpus } = do
     where
         setup :: Myriadic m => m ContainerName
         setup = do
-            ref <- asks containers
+            Env { config = MyriadConfig { defaultLanguage }, containers = ref } <- ask
             cnt <- newContainerName lang
             exec_
                 [ "docker run --rm --name="
                 , cs cnt
                 -- User 1000 will be for setting up the environment
                 , " -u1000:1000 -w/tmp/ -dt --net=none --cpus="
-                , cs cpus
+                , show $ fromMaybe (defCpus defaultLanguage) cpus
                 , " -m="
-                , cs memory
+                , cs $ fromMaybe (defMemory defaultLanguage) memory
                 , " --memory-swap="
-                , cs memory
+                , cs $ fromMaybe (defMemory defaultLanguage) memory
                 , " "
                 , imageName lang
                 , " /bin/sh"
@@ -130,7 +131,7 @@ 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.
-    snowflakeGen <- asks snowflakeGen
+    Env { config = MyriadConfig { defaultLanguage }, snowflakeGen } <- ask
     snowflake <- liftIO $ nextSnowflake snowflakeGen
     res <- try $ eval cnt snowflake
     case res of
@@ -145,7 +146,7 @@ evalCode lang@LanguageConfig { name, timeout, retries } numRetries code = withCo
                 -- Otherwise, the container was killed from another eval, so we should retry.
                 else do
                     writeMVar doneRef True
-                    if numRetries < fromIntegral retries
+                    if numRetries < (fromIntegral $ fromMaybe (defRetries defaultLanguage) retries)
                         then do
                             logError ["An exception occured in ", cs cnt, ", evaluation ", cs $ show snowflake, ", retrying:\n", cs $ show err]
                             evalCode lang (numRetries + 1) code
@@ -167,7 +168,8 @@ evalCode lang@LanguageConfig { name, timeout, retries } numRetries code = withCo
 
         timer :: Myriadic m => MVar Bool -> m ()
         timer doneRef = do
-            threadDelay $ fromIntegral timeout * 1000000
+            Env { config = MyriadConfig { defaultLanguage } } <- ask
+            threadDelay $ (fromIntegral $ fromMaybe (defTimeout defaultLanguage) timeout) * 1000000
             done <- readMVar doneRef
             unless_ done do
                 writeMVar doneRef True