1 files changed, 66 insertions, 0 deletions
diff --git a/src/Conftrack/Source/Env.hs b/src/Conftrack/Source/Env.hs
new file mode 100644
index 0000000..ea62c3d
--- /dev/null
+++ b/src/Conftrack/Source/Env.hs
@@ -0,0 +1,66 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE ImpredicativeTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE LambdaCase #-}
+
+module Conftrack.Source.Env (EnvSource(..), mkEnvSource) where
+
+import Conftrack.Value (Key (..), ConfigError(..), Value (..))
+import Conftrack.Source (ConfigSource (..), SomeSource (SomeSource))
+
+import Prelude hiding (readFile)
+import Data.Text (Text)
+import System.OsString (OsString, decodeUtf, encodeUtf)
+import System.Directory.Internal (lookupEnvOs)
+import Control.Monad.Trans (MonadIO (liftIO))
+import Text.Read (readMaybe)
+import Control.Monad.State (modify)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as BE
+import Data.Functor ((<&>))
+import qualified Data.List.NonEmpty as NonEmpty
+import Data.Maybe (fromJust)
+import Data.Function ((&))
+
+data EnvSource = EnvSource
+  { envSourceModifier :: Key -> OsString
+  , envSourceDescription :: Text
+  }
+
+mkEnvSource :: Text -> SomeSource
+mkEnvSource prefix = SomeSource (source, [])
+  where source = EnvSource
+          { envSourceModifier = \(Key parts) ->
+              prefix <> "_" <> T.intercalate "_" (NonEmpty.toList parts)
+              & T.toUpper
+              & T.unpack
+              & encodeUtf
+              & fromJust
+          , envSourceDescription = "Environment variable "
+          }
+
+instance Show EnvSource where
+  show EnvSource{..} =
+    "EnvSource { envSourceDescription = " <> show envSourceDescription <> "}"
+
+instance ConfigSource EnvSource where
+  type SourceState EnvSource = [Key]
+
+  fetchValue key EnvSource{..} =
+    liftIO (lookupEnvOs envVarName) >>= \case
+      Nothing -> pure $ Left (NotPresent key)
+      Just osstr -> do
+        modify (key :)
+        str <- liftIO $ decodeUtf osstr
+        let value = case readMaybe str of
+              Just num -> ConfigMaybeInteger (BE.encodeUtf8 $ T.pack str) num
+              Nothing -> ConfigString (BE.encodeUtf8 $ T.pack str)
+        envNameText <- decodeUtf envVarName <&> T.pack
+        pure $ Right (value, envSourceDescription <> envNameText)
+      where envVarName = envSourceModifier key
+
+  leftovers _ = pure Nothing