summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--conftrack.cabal4
-rw-r--r--src/Conftrack/Source/Env.hs66
-rw-r--r--src/Conftrack/Value.hs41
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-21 20:03:42 +0000