switch from dhall to yaml

.gitignore

@@ -10,4 +10,4 @@ stack.yaml.lock
 hie.yaml
 
 # other
-config.dhall
+config.yaml

app/Main.hs

@@ -1,14 +1,11 @@
 module Main where
 
-import qualified Data.Text as T
-
 import Options.Applicative
-
 import Myriad
 
 data Args = Args
-    { configInput :: T.Text
+    { configPath :: FilePath
-    , languagesDir :: T.Text
+    , languagesDir :: FilePath
     }
 
 parseArgs :: IO Args
@@ -18,9 +15,9 @@ parseArgs = execParser $ info (helper <*> args) (fullDesc <> progDesc "Run the M
             <$> option str (mconcat
                 [ long "config"
                 , short 'c'
-                , help "Set the Dhall configuration"
+                , help "Set the myriad configuration"
-                , metavar "DHALL"
+                , metavar "PATH"
-                , value "./config.dhall"
+                , value "./config.yaml"
                 , showDefault
                 ])
             <*> option str (mconcat
@@ -34,5 +31,5 @@ parseArgs = execParser $ info (helper <*> args) (fullDesc <> progDesc "Run the M
 
 main :: IO ()
 main = do
-    Args { configInput, languagesDir } <- parseArgs
+    Args { configPath, languagesDir } <- parseArgs
-    runMyriadServer configInput languagesDir
+    runMyriadServer configPath languagesDir

config.example.dhall

@@ -1,39 +0,0 @@
-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              : Natural             -- Port to run on
-    }
-
--- Write your config here!
-let config : Config =
-    { languages =
-        [ cfg "javascript"
-        ]
-    , buildConcurrently = True
-    , prepareContainers = False
-    , cleanupInterval   = 30
-    , port              = 8081
-    }
-in config

config.example.yaml

@@ -0,0 +1,15 @@
+languages:
+    - name: haskell
+    - name: javascript
+
+defaultLanguage:
+    memory: 256m
+    cpus: 0.25
+    timeout: 20
+    concurrent: 10
+    retries: 2
+
+buildConcurrently: true
+prepareContainers: false
+cleanupInterval: 30
+port: 8081

myriad.cabal

@@ -56,8 +56,8 @@ common shared
     , base >= 4.13 && < 5
     , bytestring
     , containers
-    , dhall == 1.30.*
     , filepath
+    , HsYAML >= 0.2
     , lifted-async
     , lifted-base
     , monad-control
@@ -90,7 +90,7 @@ library
       src
   ghc-options: -Wall
 
-executable myriad-exe
+executable myriad
   import: shared
   main-is: Main.hs
   other-modules:

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 :: FilePath -> FilePath -> IO ()
-runMyriadServer configInput languagesDir = do
+runMyriadServer configPath languagesDir = do
-    env <- initEnv configInput languagesDir
+    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
+    , cleanupInterval :: Int
-    , port :: Natural
+    , port :: Int
-    } deriving (Show, Generic)
+    } 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
+    , memory :: Maybe T.Text
-    , cpus :: T.Text
+    , cpus :: Maybe Double
-    , timeout :: Natural
+    , timeout :: Maybe Int
-    , concurrent :: Natural
+    , concurrent :: Maybe Int
-    , retries :: Natural
+    , retries :: Maybe Int
-    } deriving (Show, Generic)
+    } 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 :: FilePath -> IO MyriadConfig
-readConfig = input auto
+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 :: FilePath -> FilePath -> IO Env
-initEnv configInput languagesDir =
+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