add an env variable source

3 files changed, 93 insertions, 18 deletions

diff --git a/conftrack.cabal b/conftrack.cabal
index 57be213..952aac6 100644
--- a/conftrack.cabal
+++ b/conftrack.cabal
@@ -24,6 +24,7 @@ library
                     , Conftrack.Source.Trivial
                     , Conftrack.Source.Aeson
                     , Conftrack.Source.Yaml
+                    , Conftrack.Source.Env
     -- other-modules:
     -- other-extensions:
     build-depends:    base ^>=4.18
@@ -35,9 +36,10 @@ library
                     , aeson >= 2.0
                     , yaml
                     , scientific
-                    , filepath >= 1.4.100
+                    , filepath ^>= 1.4.100
                     , file-io
                     , template-haskell
+                    , directory
     hs-source-dirs:   src
     default-language: GHC2021
 
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
diff --git a/src/Conftrack/Value.hs b/src/Conftrack/Value.hs
index 6fe8780..fef8f87 100644
--- a/src/Conftrack/Value.hs
+++ b/src/Conftrack/Value.hs
@@ -5,6 +5,7 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE StrictData #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
 
 module Conftrack.Value (key, Value(..), ConfigError(..), Key(..), ConfigValue(..), Origin(..), KeyPart, prefixedWith) where
 
@@ -22,6 +23,7 @@ import Language.Haskell.TH.Syntax (Lift(lift))
 data Value =
   ConfigString BS.ByteString
   | ConfigInteger Integer
+  | ConfigMaybeInteger BS.ByteString Integer
   | ConfigOther Text Text
   | ConfigBool Bool
   | ConfigNull
@@ -43,9 +45,6 @@ key = QuasiQuoter
   , quoteType = \_ -> fail "key quasi-quote cannot be used for types"
   , quoteDec = \_ -> fail "key quasi-quote cannot be used in declarations"}
 
-blub :: String -> Key
-blub = undefined
-
 
 prefixedWith :: Key -> [KeyPart] -> Key
 prefixedWith (Key key) prefix = Key (prependList prefix key)
@@ -63,17 +62,24 @@ class ConfigValue a where
 data Origin = Origin Key Text
   deriving Show
 
+withString :: (BS.ByteString -> Either ConfigError a) -> Value -> Either ConfigError a
+withString f (ConfigString a) = f a
+withString f (ConfigMaybeInteger a _) = f a
+withString _ val = Left (TypeMismatch "text" val)
+
+withInteger :: (Integer -> Either ConfigError a) -> Value -> Either ConfigError a
+withInteger f (ConfigInteger a) = f a
+withInteger f (ConfigMaybeInteger _ a) = f a
+withInteger _ val = Left (TypeMismatch "integer" val)
+
 instance ConfigValue Text where
-  fromConfig (ConfigString a) = Right (BS.decodeUtf8 a)
-  fromConfig val = Left (TypeMismatch "text" val)
+  fromConfig = withString (Right . BS.decodeUtf8)
 
 instance ConfigValue Integer where
-  fromConfig (ConfigInteger a) = Right a
-  fromConfig val = Left (TypeMismatch "integer" val)
+  fromConfig = withInteger Right
 
 instance ConfigValue Int where
-  fromConfig (ConfigInteger a) = Right (fromInteger a)
-  fromConfig val = Left (TypeMismatch "integer" val)
+  fromConfig = withInteger (Right . fromInteger)
 
 instance ConfigValue Bool where
   fromConfig (ConfigBool b) = Right b
@@ -84,15 +90,16 @@ instance ConfigValue a => ConfigValue (Maybe a) where
   fromConfig just = fmap Just (fromConfig just)
 
 instance ConfigValue OsPath where
-  fromConfig (ConfigString text) = case encodeUtf (T.unpack (BS.decodeUtf8 text)) of
-    Right path -> Right path
-    Left err -> Left (ParseError (T.pack $ show err))
-  fromConfig val = Left (TypeMismatch "path" val)
+  fromConfig = \case
+    (ConfigString text) -> stringToPath text
+    (ConfigMaybeInteger text _) -> stringToPath text
+    val -> Left (TypeMismatch "path" val)
+   where stringToPath text = case encodeUtf (T.unpack (BS.decodeUtf8 text)) of
+          Right path -> Right path
+          Left err -> Left (ParseError (T.pack $ show err))
 
 instance ConfigValue LB.ByteString where
-  fromConfig (ConfigString strict) = Right (LB.fromStrict strict)
-  fromConfig val = Left (TypeMismatch "string" val)
+  fromConfig = withString (Right . LB.fromStrict)
 
 instance ConfigValue BS.ByteString where
-  fromConfig (ConfigString string) = Right string
-  fromConfig val = Left (TypeMismatch "string" val)
+  fromConfig = withString Right