config: refactor config reading

myriad.cabal

@@ -79,6 +79,7 @@ library
   import: shared
   exposed-modules:
       Myriad
+      Myriad.Config
       Myriad.Core
       Myriad.Docker
       Myriad.Server

src/Myriad.hs

@@ -9,6 +9,7 @@ import Data.String.Conversions
 import Network.Wai.Handler.Warp
 
 import Myriad.Core
+import Myriad.Config
 import Myriad.Docker
 import Myriad.Server
 

src/Myriad/Config.hs

@@ -0,0 +1,113 @@
+module Myriad.Config
+    ( LanguageName
+    , Config(..)
+    , Language(..)
+    , readConfig
+    ) where
+
+import qualified Data.ByteString.Lazy as BL
+import Data.Maybe
+import qualified Data.Text as T
+import Data.YAML
+
+type LanguageName = T.Text
+
+data Config = Config
+    { languages :: [Language]
+    , buildConcurrently :: Bool
+    , prepareContainers :: Bool
+    , cleanupInterval :: Int
+    , port :: Int
+    } deriving (Show)
+
+data Language = Language
+    { name :: LanguageName
+    , memory :: T.Text
+    , cpus :: Double
+    , timeout :: Int
+    , concurrent :: Int
+    , retries :: Int
+    } deriving (Show)
+
+fromRawConfig :: RawConfig -> Config
+fromRawConfig (r@RawConfig { rawLanguages, rawDefaultLanguage }) =
+    Config
+        { languages = map f rawLanguages
+        , buildConcurrently = rawBuildConcurrently r
+        , prepareContainers = rawPrepareContainers r
+        , cleanupInterval = rawCleanupInterval r
+        , port = rawPort r
+        }
+    where
+        f :: RawLanguage -> Language
+        f l =
+            Language
+                { name = rawName l
+                , memory = fromMaybe (defMemory rawDefaultLanguage) (rawMemory l)
+                , cpus = fromMaybe (defCpus rawDefaultLanguage) (rawCpus l)
+                , timeout = fromMaybe (defTimeout rawDefaultLanguage) (rawTimeout l)
+                , concurrent = fromMaybe (defConcurrent rawDefaultLanguage) (rawConcurrent l)
+                , retries = fromMaybe (defRetries rawDefaultLanguage) (rawRetries l)
+                }
+
+data RawConfig = RawConfig
+    { rawLanguages :: [RawLanguage]
+    , rawDefaultLanguage :: DefaultLanguage
+    , rawBuildConcurrently :: Bool
+    , rawPrepareContainers :: Bool
+    , rawCleanupInterval :: Int
+    , rawPort :: Int
+    } deriving (Show)
+
+instance FromYAML RawConfig where
+    parseYAML = withMap "config" $ \m -> RawConfig
+        <$> m .: "languages"
+        <*> m .: "defaultLanguage"
+        <*> m .: "buildConcurrently"
+        <*> m .: "prepareContainers"
+        <*> m .: "cleanupInterval"
+        <*> m .: "port"
+
+data DefaultLanguage = DefaultLanguage
+    { defMemory :: T.Text
+    , defCpus :: Double
+    , defTimeout :: Int
+    , defConcurrent :: Int
+    , defRetries :: Int
+    } deriving (Show)
+
+instance FromYAML DefaultLanguage where
+    parseYAML = withMap "default language" $ \m -> DefaultLanguage
+        <$> m .: "memory"
+        <*> m .: "cpus"
+        <*> m .: "timeout"
+        <*> m .: "concurrent"
+        <*> m .: "retries"
+
+data RawLanguage = RawLanguage
+    { rawName :: LanguageName
+    , rawMemory :: Maybe T.Text
+    , rawCpus :: Maybe Double
+    , rawTimeout :: Maybe Int
+    , rawConcurrent :: Maybe Int
+    , rawRetries :: Maybe Int
+    } deriving (Show)
+
+instance FromYAML RawLanguage where
+    parseYAML = withMap "language" $ \m -> RawLanguage
+        <$> m .: "name"
+        <*> m .:? "memory"
+        <*> m .:? "cpus"
+        <*> m .:? "timeout"
+        <*> m .:? "concurrent"
+        <*> m .:? "retries"
+
+readConfig :: FilePath -> IO Config
+readConfig = fmap fromRawConfig . readRawConfig
+
+readRawConfig :: FilePath -> IO RawConfig
+readRawConfig f = do
+    x <- BL.readFile f
+    case decode1 x of
+        Left (pos, e) -> error $ prettyPosWithSource pos x e
+        Right y -> pure y

src/Myriad/Core.hs

@@ -6,9 +6,6 @@ module Myriad.Core
     , ImageName
     , EvalResult(..)
     , Env(..)
-    , MyriadConfig(..)
-    , DefaultLanguageConfig(..)
-    , LanguageConfig(..)
     , MyriadT
     , runMyriadT
     , initEnv
@@ -32,78 +29,30 @@ import qualified Data.ByteString.Lazy as BL
 import qualified Data.Map.Strict as M
 import Data.Snowflake
 import qualified Data.Text as T
-import Data.YAML
 
 import Control.Concurrent.MVar.Lifted
 import Control.Concurrent.QSem.Lifted
 import System.Process.Typed
 
-type Language = T.Text
+import Myriad.Config
+
 type ContainerName = String
+
 type ImageName = String
 
-data EvalResult = EvalOk BL.ByteString | EvalTimedOut | EvalErrored
-
 data Env = Env
-    { config :: MyriadConfig
+    { config :: Config
     , languagesDir :: FilePath
-    , containers :: MVar (M.Map Language ContainerName)
+    , containers :: MVar (M.Map LanguageName ContainerName)
-    , containerSems :: MVar (M.Map Language QSem)
+    , containerSems :: MVar (M.Map LanguageName QSem)
-    , evalSems :: MVar (M.Map Language QSem)
+    , evalSems :: MVar (M.Map LanguageName QSem)
     , snowflakeGen :: SnowflakeGen
     }
 
-data MyriadConfig = MyriadConfig
+data EvalResult
-    { languages :: [LanguageConfig]
+    = EvalOk BL.ByteString
-    , defaultLanguage :: DefaultLanguageConfig
+    | EvalTimedOut
-    , buildConcurrently :: Bool
+    | EvalErrored
-    , prepareContainers :: Bool
-    , cleanupInterval :: Int
-    , port :: Int
-    } deriving (Show)
-
-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 :: Maybe T.Text
-    , cpus :: Maybe Double
-    , timeout :: Maybe Int
-    , concurrent :: Maybe Int
-    , retries :: Maybe Int
-    } deriving (Show)
-
-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
@@ -133,13 +82,6 @@ instance MonadBaseControl b m => MonadBaseControl b (MyriadT m) where
     liftBaseWith = defaultLiftBaseWith
     restoreM = defaultRestoreM
 
-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 :: FilePath -> FilePath -> IO Env
 initEnv configPath languagesDir =
         Env

src/Myriad/Docker.hs

@@ -12,7 +12,6 @@ module Myriad.Docker
 import Control.Monad.Reader
 
 import qualified Data.Map.Strict as M
-import Data.Maybe
 import Data.Snowflake
 import Data.String.Conversions
 
@@ -25,12 +24,13 @@ import System.FilePath ((</>))
 import System.Process.Typed
 
 import Myriad.Core
+import Myriad.Config
 
 type Myriad = MyriadT IO
 
-buildImage :: LanguageConfig -> Myriad ()
+buildImage :: Language -> Myriad ()
-buildImage lang@LanguageConfig { name, concurrent } = do
+buildImage lang@Language { name, concurrent } = do
-    Env { config = MyriadConfig { prepareContainers }, languagesDir } <- ask
+    Env { config = Config { prepareContainers }, languagesDir } <- ask
     logInfo ["Building image ", cs $ imageName lang]
     exec_ ["docker build -t ", imageName lang, " ", cs languagesDir </> cs name]
     setupQSems
@@ -39,22 +39,22 @@ buildImage lang@LanguageConfig { name, concurrent } = do
     where
         setupQSems ::  Myriad ()
         setupQSems = do
-            Env { config = MyriadConfig { defaultLanguage }, containerSems, evalSems } <- ask
+            Env { containerSems, evalSems } <- ask
             csem <- newQSem 1 -- We only want one container to be set up at a time
-            esem <- newQSem . fromIntegral $ fromMaybe (defConcurrent defaultLanguage) concurrent
+            esem <- newQSem $ fromIntegral concurrent
             mapMVar containerSems $ M.insert name csem
             mapMVar evalSems $ M.insert name esem
 
 buildAllImages :: Myriad ()
 buildAllImages = do
-    MyriadConfig { languages, buildConcurrently } <- asks config
+    Config { languages, buildConcurrently } <- asks config
     if buildConcurrently
         then forConcurrently_ languages buildImage
         else forM_ languages buildImage
 
 startCleanup :: Myriad ()
 startCleanup = do
-    MyriadConfig { cleanupInterval } <- asks config
+    Config { cleanupInterval } <- asks config
     when_ (cleanupInterval > 0) do
         let t = fromIntegral cleanupInterval * 60000000
         fork $ timer t
@@ -66,8 +66,8 @@ startCleanup = do
             logInfo ["Cleaned up ", cs $ show n, " containers"]
             timer t
 
-setupContainer :: LanguageConfig -> Myriad ContainerName
+setupContainer :: Language -> Myriad ContainerName
-setupContainer lang@LanguageConfig { name, memory, cpus } = do
+setupContainer lang@Language { name, memory, cpus } = do
     cnts <- asks containers >>= readMVar
     case cnts M.!? name of
         Nothing  -> setup
@@ -75,18 +75,18 @@ setupContainer lang@LanguageConfig { name, memory, cpus } = do
     where
         setup :: Myriad ContainerName
         setup = do
-            Env { config = MyriadConfig { defaultLanguage }, containers = ref } <- ask
+            ref <- asks containers
             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="
-                , show $ fromMaybe (defCpus defaultLanguage) cpus
+                , show cpus
                 , " -m="
-                , cs $ fromMaybe (defMemory defaultLanguage) memory
+                , cs memory
                 , " --memory-swap="
-                , cs $ fromMaybe (defMemory defaultLanguage) memory
+                , cs memory
                 , " "
                 , imageName lang
                 , " /bin/sh"
@@ -99,7 +99,7 @@ setupContainer lang@LanguageConfig { name, memory, cpus } = do
             logInfo ["Started container ", cs cnt]
             pure cnt
 
-killContainer :: Language -> Myriad Bool
+killContainer :: LanguageName -> Myriad Bool
 killContainer lang = do
     containers <- asks containers >>= readMVar
     case containers M.!? lang of
@@ -129,11 +129,11 @@ killContainers = do
     xs <- forConcurrently (M.toList containers) \(k, v) -> (v,) <$> killContainer k
     pure . map fst $ filter snd xs
 
-evalCode :: LanguageConfig -> Int -> String -> Myriad EvalResult
+evalCode :: Language -> Int -> String -> Myriad EvalResult
-evalCode lang@LanguageConfig { name, timeout, retries } numRetries code = withContainer \cnt -> do
+evalCode lang@Language { 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.
-    Env { config = MyriadConfig { defaultLanguage }, snowflakeGen } <- ask
+    snowflakeGen <- asks snowflakeGen
     snowflake <- liftIO $ nextSnowflake snowflakeGen
     res <- try $ eval cnt snowflake
     case res of
@@ -148,7 +148,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 $ fromMaybe (defRetries defaultLanguage) retries)
+                    if numRetries < fromIntegral retries
                         then do
                             logError ["An exception occured in ", cs cnt, ", evaluation ", cs $ show snowflake, ", retrying:\n", cs $ show err]
                             evalCode lang (numRetries + 1) code
@@ -170,8 +170,7 @@ evalCode lang@LanguageConfig { name, timeout, retries } numRetries code = withCo
 
         timer :: MVar Bool -> Myriad ()
         timer doneRef = do
-            Env { config = MyriadConfig { defaultLanguage } } <- ask
+            threadDelay $ fromIntegral timeout * 1000000
-            threadDelay $ (fromIntegral $ fromMaybe (defTimeout defaultLanguage) timeout) * 1000000
             done <- readMVar doneRef
             unless_ done do
                 writeMVar doneRef True
@@ -190,14 +189,14 @@ evalCode lang@LanguageConfig { name, timeout, retries } numRetries code = withCo
             logInfo ["Ran code in container ", cs cnt, ", evaluation ", cs $ show snowflake]
             pure $ EvalOk output
 
-newContainerName :: LanguageConfig -> Myriad ContainerName
+newContainerName :: Language -> Myriad ContainerName
-newContainerName LanguageConfig { name } = do
+newContainerName Language { name } = do
     snowflakeGen <- asks snowflakeGen
     snowflake <- liftIO $ nextSnowflake snowflakeGen
     pure $ "comp_iler-" <> cs name <> "-" <> show snowflake
 
-imageName :: LanguageConfig -> ImageName
+imageName :: Language -> ImageName
-imageName LanguageConfig { name } = "1computer1/comp_iler:" <> cs name
+imageName Language { name } = "1computer1/comp_iler:" <> cs name
 
 when_ :: Applicative f => Bool -> f a -> f ()
 when_ p = when p . void 

src/Myriad/Server.hs

@@ -19,6 +19,7 @@ import Control.Concurrent.MVar.Lifted
 import Servant
 
 import Myriad.Core
+import Myriad.Config
 import Myriad.Docker
 
 type Myriad = MyriadT Handler
@@ -44,13 +45,13 @@ serverT = handleLanguages :<|> handleEval :<|> handleContainers :<|> handleClean
         handleLanguages :: Myriad [T.Text]
         handleLanguages = do
             logInfo ["GET /languages"]
-            MyriadConfig { languages } <- asks config
+            Config { languages } <- asks config
             pure . map name $ languages
 
         handleEval :: EvalRequest -> Myriad EvalResponse
         handleEval EvalRequest { language, code } = do
             logInfo ["POST /eval"]
-            MyriadConfig { languages } <- asks config
+            Config { languages } <- asks config
             case find (\x -> name x == language) languages of
                 Nothing  -> throwError $ err404 { errBody = "Language " <> cs language <> " was not found" }
                 Just cfg -> do