From a55e0ce93d6a567e76c5a932a304c1c07fab0087 Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Mon, 7 Feb 2022 20:44:06 +0100
Subject: server: simple toml config

---
 server/Main.hs   |  5 ++---
 server/Server.hs | 51 +++++++++++++++++++++++++++++++++++++--------------
 2 files changed, 39 insertions(+), 17 deletions(-)

(limited to 'server')

diff --git a/server/Main.hs b/server/Main.hs
index ecaf6b7..0fbc4b4 100644
--- a/server/Main.hs
+++ b/server/Main.hs
@@ -71,7 +71,6 @@ app config =
 
 main :: IO ()
 main = do
+  config' <- loadConfig "./config.toml"
   state <- newMVar defaultState
-  let config = Config "/tmp" 8080 "main.json" "./config.json"
-  config' <- loadConfig config
-  run (port config) (app config' state)
+  run (port config') (app config' state)
diff --git a/server/Server.hs b/server/Server.hs
index 93bfb30..a5a820a 100644
--- a/server/Server.hs
+++ b/server/Server.hs
@@ -1,12 +1,16 @@
-{-# LANGUAGE DataKinds           #-}
-{-# LANGUAGE DeriveAnyClass      #-}
-{-# LANGUAGE DeriveGeneric       #-}
-{-# LANGUAGE KindSignatures      #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TemplateHaskell     #-}
-{-# LANGUAGE TypeApplications    #-}
-{-# LANGUAGE TypeFamilies        #-}
-{-# LANGUAGE TypeOperators       #-}
+{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE DeriveAnyClass             #-}
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE KindSignatures             #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE TemplateHaskell            #-}
+{-# LANGUAGE TypeApplications           #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE TypeOperators              #-}
 
 module Server (loadConfig, Config(..), RemoteRef(..), State, registry, jobs, JobStatus(..),
                     setJobStatus,defaultState,setRegistry) where
@@ -23,6 +27,10 @@ import           GHC.Generics         (Generic)
 import           Lens.Micro           (over)
 import           Lens.Micro.TH
 import           LintConfig           (LintConfig')
+import           System.Exit.Compat   (exitFailure)
+import           Toml                 (TomlCodec)
+import qualified Toml
+import           Toml.Codec           ((.=))
 
 
 -- | a reference in a remote git repository
@@ -36,14 +44,21 @@ type family ConfigRes (b :: Bool) a where
   ConfigRes False a = FilePath
 
 -- | the server's configuration
-data Config l = Config
+data Config (loaded :: Bool) = Config
   { tmpdir     :: FilePath
   -- ^ dir to clone git things in
   , port       :: Int
   -- ^ port to bind to
   , entrypoint :: FilePath
-  , lintconfig :: ConfigRes l LintConfig'
-  }
+  , lintconfig :: ConfigRes loaded LintConfig'
+  } deriving Generic
+
+configCodec :: TomlCodec (Config False)
+configCodec = Config
+    <$> Toml.string "tmpdir" .= tmpdir
+    <*> Toml.int "port" .= port
+    <*> Toml.string "entrypoint" .= entrypoint
+    <*> Toml.string "lintconfig" .= lintconfig
 
 data JobStatus =
   Pending | Linted DirResult | Failed Text
@@ -59,9 +74,17 @@ makeLenses ''State
 defaultState :: State
 defaultState = State mempty mempty
 
+loadConfig :: FilePath -> IO (Config True)
+loadConfig path = do
+  res <- Toml.decodeFileEither configCodec path
+  case res of
+    Right config -> loadConfig' config
+    Left err -> do
+      print err
+      exitFailure
 
-loadConfig :: Config False -> IO (Config True)
-loadConfig config = do
+loadConfig' :: Config False -> IO (Config True)
+loadConfig' config = do
   loaded <- LB.readFile (lintconfig config) >>= \res ->
       case eitherDecode res :: Either String LintConfig' of
         Left err   -> error $ "config file invalid: " <> err
-- 
cgit v1.2.3