From d1446a8435a3cf06371eb6d4ebe25d6491612f4d Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Wed, 22 May 2024 00:04:30 +0200
Subject: a generic, multi-source config interface

---
 src/Conftrack.hs | 76 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 76 insertions(+)
 create mode 100644 src/Conftrack.hs

(limited to 'src/Conftrack.hs')

diff --git a/src/Conftrack.hs b/src/Conftrack.hs
new file mode 100644
index 0000000..3003115
--- /dev/null
+++ b/src/Conftrack.hs
@@ -0,0 +1,76 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE ImpredicativeTypes #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE LambdaCase #-}
+
+module Conftrack  where
+
+import Conftrack.Value (ConfigError(..), ConfigValue(..), Key, Origin(..))
+import Conftrack.Source (SomeSource (..), ConfigSource (..))
+
+import Prelude hiding (unzip)
+import Control.Monad.State (get, StateT (..), MonadState (..), gets)
+import Data.Functor ((<&>))
+import Control.Monad.Reader (MonadIO (liftIO))
+import Data.List.NonEmpty (NonEmpty, unzip)
+import qualified Data.List.NonEmpty as NonEmpty
+import Control.Monad (forM)
+import Data.Either (isRight)
+import Control.Monad.Trans.Except (ExceptT(..), runExceptT, throwE)
+import Control.Monad.Trans (lift)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Maybe (isJust)
+
+
+class Config a where
+  readConfig :: FetchMonad a
+
+type FetchMonad = StateT (NonEmpty SomeSource, [Origin], [Warning]) (ExceptT [ConfigError] IO)
+
+newtype Warning = Warning Text
+ deriving Show
+
+runFetchConfig :: Config a => NonEmpty SomeSource -> IO (Either [ConfigError] (a, [Origin], [Warning]))
+runFetchConfig sources = do
+  results <- runExceptT $ runStateT readConfig (sources, [], [])
+
+  case results of
+    Left a -> pure $ Left a
+    Right (result, (sources, origins, warnings)) -> do
+      unusedWarnings <- collectUnused sources
+      pure $ Right (result, origins, unusedWarnings <> warnings)
+
+readValue :: ConfigValue a => Key -> FetchMonad a
+readValue key = do
+  (sources, origins, warnings) <- get
+
+  -- TODO: this should short-curcuit here (so we have correct unused key sets)
+  stuff <- liftIO $ forM sources $ \(SomeSource (source, sourceState)) -> do
+    (eitherValue, newState) <- runStateT (fetchValue key source) sourceState
+    pure (eitherValue, SomeSource (source, newState))
+
+  let (maybeValues, states) = Data.List.NonEmpty.unzip stuff
+
+  let values = maybeValues <&> \case
+        Right (val, text) -> fromConfig val <&> (\val -> (val, Origin key text))
+        Left e -> Left e
+
+  val <- case fmap (\(Right a) -> a) $ NonEmpty.filter isRight values of
+    [] -> lift $ throwE [NotPresent]
+    val:_ -> pure val
+
+  put (states, snd val : origins, warnings)
+
+  pure (fst val)
+
+collectUnused :: NonEmpty SomeSource -> IO [Warning]
+collectUnused sources = do
+  forM sources (\(SomeSource (source, sourceState)) ->
+    runStateT (leftovers source) sourceState <&> fst)
+    <&> fmap (\(Just a) -> Warning $ "Unused Keys " <> T.pack (show a))
+        . NonEmpty.filter isJust
-- 
cgit v1.2.3