From ac81f4a118cc7a067ff26d8f4fd30410cac07e3c Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Wed, 16 Feb 2022 00:14:41 +0100
Subject: … several hours of fighting with TOML later

WHO THOUGHT THIS SYNTAX WAS A GOOD IDEA??

(and who decided to write the least obvious combinator library to parse it?)
---
 server/Server.hs | 82 +++++++++++++++++++++++++++++++++++---------------------
 1 file changed, 52 insertions(+), 30 deletions(-)

(limited to 'server/Server.hs')

diff --git a/server/Server.hs b/server/Server.hs
index 8014053..bdfa77f 100644
--- a/server/Server.hs
+++ b/server/Server.hs
@@ -11,9 +11,11 @@
 {-# LANGUAGE TypeApplications           #-}
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE TypeOperators              #-}
+{-# LANGUAGE LambdaCase #-}
 
 module Server ( loadConfig
-              , Config(..)
+              , Org(..)
+              , Config, tmpdir, port, verbose, orgs
               , RemoteRef(..)
               , ServerState, registry, jobs, defaultState
               , JobStatus(..)
@@ -26,45 +28,68 @@ import           Universum
 
 import           CheckDir             (DirResult)
 import           Control.Concurrent   (modifyMVar_)
-import           Data.Aeson           (FromJSON, ToJSON (toJSON), eitherDecode,
-                                       (.=))
+import           Data.Aeson           (FromJSON, ToJSON (toJSON),
+                                       (.=), eitherDecodeFileStrict')
 import qualified Data.Aeson           as A
-import qualified Data.ByteString.Lazy as LB
 import qualified Data.Map             as M
 import           Data.UUID            (UUID)
+import Lens.Micro (traverseOf)
 import           Lens.Micro.TH
 import           LintConfig           (LintConfig')
-import           Toml                 (TomlCodec)
+import           Toml                 (TomlCodec, prettyTomlDecodeErrors)
 import qualified Toml                 as T
 
 -- | a reference in a remote git repository
 data RemoteRef = RemoteRef
   { repourl :: Text
   , reporef :: Text
-  } deriving (Generic, FromJSON, ToJSON, Eq, Ord)
+  } deriving (Generic, FromJSON, ToJSON, Eq, Ord, Show)
 
 type family ConfigRes (b :: Bool) a where
   ConfigRes True a = a
   ConfigRes False a = FilePath
 
+
+data Org (loaded :: Bool) = Org
+  { orgSlug :: Text
+  , orgLintconfig :: ConfigRes loaded LintConfig'
+  , orgEntrypoint :: FilePath
+  , orgRepos :: [RemoteRef]
+  }
+
+
 -- | the server's configuration
 data Config (loaded :: Bool) = Config
-  { tmpdir     :: FilePath
+  { _tmpdir     :: FilePath
   -- ^ dir to clone git things in
-  , port       :: Int
-  , verbose    :: Bool
+  , _port       :: Int
+  , _verbose    :: Bool
   -- ^ port to bind to
-  , entrypoint :: FilePath
-  , lintconfig :: ConfigRes loaded LintConfig'
+  , _orgs       :: [Org loaded]
   } deriving Generic
 
+makeLenses ''Config
+
+
+remoteCodec :: TomlCodec RemoteRef
+remoteCodec = RemoteRef
+  <$> T.text "url" T..= repourl
+  <*> T.text "ref" T..= reporef
+
+orgCodec :: TomlCodec (Org False)
+orgCodec = Org
+  <$> T.text "slug" T..= orgSlug
+  <*> T.string "lintconfig" T..= orgLintconfig
+  <*> T.string "entrypoint" T..= orgEntrypoint
+  <*> T.list remoteCodec "repo" T..= orgRepos
+
+
 configCodec :: TomlCodec (Config False)
 configCodec = Config
-    <$> T.string "tmpdir" T..= tmpdir
-    <*> T.int "port" T..= port
-    <*> T.bool "verbose" T..= verbose
-    <*> T.string "entrypoint" T..= entrypoint
-    <*> T.string "lintconfig" T..= lintconfig
+    <$> T.string "tmpdir" T..= _tmpdir
+    <*> T.int "port" T..= _port
+    <*> T.bool "verbose" T..= _verbose
+    <*> T.list orgCodec "org" T..= _orgs
 
 -- | a job status (of a specific uuid)
 data JobStatus =
@@ -81,6 +106,8 @@ makeLenses ''ServerState
 defaultState :: ServerState
 defaultState = ServerState mempty mempty
 
+-- | an info type wrapped around the server state, to carry serialisation instances.
+-- TODO: should probably not be defined here
 newtype AdminOverview =
   AdminOverview { unAdminOverview :: ServerState }
 
@@ -92,24 +119,19 @@ instance ToJSON AdminOverview where
                , "status" .= M.lookup ref (view jobs state)
                ]
 
-
-
 loadConfig :: FilePath -> IO (Config True)
 loadConfig path = do
   res <- T.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
-  loaded <- LB.readFile (lintconfig config) >>= \res ->
-      case eitherDecode res :: Either String LintConfig' of
-        Left err   -> error $ "config file invalid: " <> show err
-        Right file -> pure file
-  pure $ config { lintconfig = loaded }
+    Right config -> traverseOf orgs (mapM loadOrg) config
+    Left err -> error $ prettyTomlDecodeErrors err
+    where
+      loadOrg :: Org False -> IO (Org True)
+      loadOrg org = do
+        lintconfig <- eitherDecodeFileStrict' (orgLintconfig org) >>= \case
+          Right c -> pure c
+          Left err -> error $ show err
+        pure $ org { orgLintconfig = lintconfig }
 
 
 setJobStatus :: MVar ServerState -> RemoteRef -> JobStatus -> IO ()
-- 
cgit v1.2.3