diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,17 @@ # Changelog for settei-env +## 0.2.0.0 — 2026-07-19 + +- BREAKING: environment bindings are validated once at construction. `Bindings` is an + opaque validated collection built by `bindings` or `prefixedBindings`; `envSource` + and `readEnvSource` take `Bindings` and are total; `environmentSource` and + `readEnvironmentSource` provide the conventional `"environment"` label; + `bindingsList` inspects a validated collection. +- Add `renderEnvErrorText` and `renderEnvErrorsText` for stable, operator-readable, + value-free binding diagnostics. +- Add `mergeBindings`: combine validated `Bindings` collections with re-validation of + cross-collection conflicts, enabling derived and hand-written bindings to compose. + ## 0.1.0.0 — 2026-07-18 - Initial experimental release. diff --git a/settei-env.cabal b/settei-env.cabal --- a/settei-env.cabal +++ b/settei-env.cabal @@ -1,6 +1,6 @@ cabal-version: 3.8 name: settei-env -version: 0.1.0.0 +version: 0.2.0.0 synopsis: Environment sources for Settei description: Translate explicit environment-variable bindings into provenance-aware @@ -39,7 +39,7 @@ , base >=4.21 && <5 , containers >=0.6.8 && <0.8 , generic-lens >=2.2 && <2.4 - , settei ==0.1.0.0 + , settei ==0.2.0.0 , text >=2.1 && <2.2 test-suite settei-env-tests @@ -52,8 +52,8 @@ , base >=4.21 && <5 , containers >=0.6.8 && <0.8 , generic-lens >=2.2 && <2.4 - , settei ==0.1.0.0 - , settei-env ==0.1.0.0 + , settei ==0.2.0.0 + , settei-env ==0.2.0.0 , tasty >=1.5 && <1.6 , tasty-hunit >=0.10.2 && <0.11 , text >=2.1 && <2.2 diff --git a/src/Settei/Env.hs b/src/Settei/Env.hs --- a/src/Settei/Env.hs +++ b/src/Settei/Env.hs @@ -2,7 +2,8 @@ -- Module: Settei.Env -- Description: Explicit, pure environment-variable sources for Settei. module Settei.Env - ( EnvName (..), + ( Bindings, + EnvName (..), EnvSnapshot (..), EnvBinding, EnvError (..), @@ -11,11 +12,18 @@ bindingAnnotations, bindingKey, bindingName, + bindings, + bindingsList, envSnapshot, envSource, + environmentSource, fromKubernetesObject, + mergeBindings, prefixedBindings, readEnvSource, + readEnvironmentSource, + renderEnvErrorText, + renderEnvErrorsText, ) where @@ -28,7 +36,7 @@ import Settei.Prelude import System.Environment qualified as Environment --- | An environment-variable name. 'envSource' validates its portable spelling. +-- | An environment-variable name. 'bindings' validates its portable spelling. newtype EnvName = EnvName Text deriving stock (Generic, Eq, Ord, Show) @@ -53,6 +61,16 @@ | PrefixedNameCollision !EnvName !(NonEmpty Key) deriving stock (Generic, Eq, Show) +-- | A collection of bindings proven valid at construction. +-- +-- The constructor is private: 'bindings' and 'prefixedBindings' are the only ways to +-- obtain a value, so every 'Bindings' is free of invalid names, duplicate names, +-- duplicate target keys, and prefix-overlapping target keys. Binding lists are static +-- program data; resolve 'bindings' once at startup (or force it in a unit test) so an +-- invalid list is a fail-fast programming-error report, not a runtime branch. +newtype Bindings = Bindings [EnvBinding] + deriving stock (Eq) + -- | Construct one explicit binding with no caller annotations. binding :: EnvName -> Key -> EnvBinding binding name key = EnvBinding {name, key, annotations = Map.empty} @@ -76,6 +94,52 @@ bindingAnnotations :: EnvBinding -> Map Text Text bindingAnnotations value = value ^. #annotations +-- | Validate a static binding list once, yielding a collection usable with the total +-- source builders. +bindings :: [EnvBinding] -> Either (NonEmpty EnvError) Bindings +bindings values = + case NonEmpty.nonEmpty (bindingErrors values) of + Just errors -> Left errors + Nothing -> Right (Bindings values) + +-- | Inspect the validated bindings, for example to count or display them. +bindingsList :: Bindings -> [EnvBinding] +bindingsList (Bindings values) = values + +-- | Merge validated collections into one, re-validating cross-collection conflicts. +-- +-- Two individually valid collections can still collide with each other (a variable +-- name bound in both, or target keys that overlap across them), so merging returns +-- the same 'EnvError' vocabulary as 'bindings'. The empty list yields the valid empty +-- collection. Order is preserved: earlier collections contribute earlier bindings. +mergeBindings :: [Bindings] -> Either (NonEmpty EnvError) Bindings +mergeBindings = bindings . concatMap bindingsList + +-- | Render one binding-validation failure as a single operator-readable sentence. +-- +-- Only variable names and structural keys appear; environment values are never +-- retained by 'EnvError' and therefore cannot leak. +renderEnvErrorText :: EnvError -> Text +renderEnvErrorText = \case + InvalidEnvironmentName name -> + "environment binding " <> renderEnvName name <> ": invalid variable name" + DuplicateEnvironmentName name -> + "environment binding " <> renderEnvName name <> ": variable bound more than once" + DuplicateTargetKey key -> + "bindings target the same key " <> renderKey key <> " twice" + ConflictingTargetKeys lower higher -> + "bindings target overlapping keys " <> renderKey lower <> " and " <> renderKey higher + PrefixedNameCollision name keys -> + "environment binding " + <> renderEnvName name + <> ": normalized name collides for keys " + <> Text.intercalate ", " (fmap renderKey (NonEmpty.toList keys)) + +-- | Render every binding-validation failure, one line per problem, matching +-- 'Settei.Render.renderErrorsText' in shape and trailing newline. +renderEnvErrorsText :: NonEmpty EnvError -> Text +renderEnvErrorsText = Text.unlines . fmap renderEnvErrorText . NonEmpty.toList + -- | Build an injectable snapshot from textual name/value pairs. -- -- Repeated names use the final supplied value, matching the behavior of a map snapshot. @@ -86,22 +150,16 @@ -- | Translate explicitly bound variables from one snapshot into a Settei source. -- +-- Total: a 'Bindings' value is valid by construction, so no error branch exists. -- Missing variables are absent leaves. Values remain 'RawText'; target decoding and -- sensitivity handling stay in the core declaration and resolver. -envSource :: Text -> [EnvBinding] -> EnvSnapshot -> Either (NonEmpty EnvError) Source -envSource sourceLabel bindings (EnvSnapshot snapshot) = - case NonEmpty.nonEmpty (bindingErrors bindings) of - Just errors -> Left errors - Nothing -> - Right - ( annotateSourceAt - annotationsFor - (source sourceLabel EnvironmentSource root) - ) +envSource :: Text -> Bindings -> EnvSnapshot -> Source +envSource sourceLabel (Bindings values) (EnvSnapshot snapshot) = + annotateSourceAt annotationsFor (source sourceLabel EnvironmentSource root) where presentBindings = [ (bindingValue, rawValue) - | bindingValue <- bindings, + | bindingValue <- values, Just value <- [Map.lookup (bindingValue ^. #name) snapshot], let rawValue = RawText value ] @@ -120,35 +178,37 @@ ] annotationsFor key = Map.findWithDefault Map.empty key perKeyAnnotations +-- | 'envSource' with the conventional source label @"environment"@. +environmentSource :: Bindings -> EnvSnapshot -> Source +environmentSource = envSource "environment" + -- | Snapshot the process environment once and pass it through the pure translator. -readEnvSource :: Text -> [EnvBinding] -> IO (Either (NonEmpty EnvError) Source) -readEnvSource sourceLabel bindings = do - values <- Environment.getEnvironment +readEnvSource :: Text -> Bindings -> IO Source +readEnvSource sourceLabel validated = do + boundValues <- Environment.getEnvironment pure ( envSource sourceLabel - bindings - (envSnapshot [(Text.pack name, Text.pack value) | (name, value) <- values]) + validated + (envSnapshot [(Text.pack name, Text.pack value) | (name, value) <- boundValues]) ) +-- | 'readEnvSource' with the conventional source label @"environment"@. +readEnvironmentSource :: Bindings -> IO Source +readEnvironmentSource = readEnvSource "environment" + -- | Derive explicit bindings using @PREFIX_KEY_SEGMENTS@ names. -- -- Non-alphanumeric characters become underscores and letters become uppercase. Any -- collision introduced by that normalization is returned instead of being guessed away. -prefixedBindings :: Text -> [Key] -> Either (NonEmpty EnvError) [EnvBinding] +-- The successful result is already validated: pass it straight to 'envSource'. +prefixedBindings :: Text -> [Key] -> Either (NonEmpty EnvError) Bindings prefixedBindings prefix keys = case NonEmpty.nonEmpty errors of Just found -> Left found - Nothing -> Right generated + Nothing -> Right (Bindings generated) where generated = fmap (\key -> binding (prefixedName prefix key) key) keys - invalidErrors = - [ InvalidEnvironmentName name - | bindingValue <- generated, - let name = bindingValue ^. #name, - not (validEnvName name) - ] - duplicateKeyErrors = fmap DuplicateTargetKey (duplicates keys) groupedByName = Map.fromListWith (<>) @@ -160,23 +220,28 @@ | (name, targetKeys) <- Map.toAscList groupedByName, NonEmpty.length targetKeys > 1 ] - errors = invalidErrors <> duplicateKeyErrors <> collisionErrors <> overlapErrors keys + sharedErrors = filter (not . isDuplicateNameError) (bindingErrors generated) + errors = sharedErrors <> collisionErrors +isDuplicateNameError :: EnvError -> Bool +isDuplicateNameError (DuplicateEnvironmentName _) = True +isDuplicateNameError _ = False + -- | Attach a trusted Kubernetes object reference without querying a cluster. fromKubernetesObject :: KubernetesRef -> EnvBinding -> EnvBinding fromKubernetesObject reference bindingValue = annotateBinding (kubernetesAnnotations reference) bindingValue bindingErrors :: [EnvBinding] -> [EnvError] -bindingErrors bindings = +bindingErrors values = [ InvalidEnvironmentName name - | bindingValue <- bindings, + | bindingValue <- values, let name = bindingValue ^. #name, not (validEnvName name) ] - <> fmap DuplicateEnvironmentName (duplicates (fmap (^. #name) bindings)) - <> fmap DuplicateTargetKey (duplicates (fmap (^. #key) bindings)) - <> overlapErrors (fmap (^. #key) bindings) + <> fmap DuplicateEnvironmentName (duplicates (fmap (^. #name) values)) + <> fmap DuplicateTargetKey (duplicates (fmap (^. #key) values)) + <> overlapErrors (fmap (^. #key) values) overlapErrors :: [Key] -> [EnvError] overlapErrors keys = @@ -244,4 +309,7 @@ . go rest . maybe (RawObject Map.empty) id ) + -- 'Bindings' construction rejects prefix-overlapping target keys, so by the time this + -- fold runs, no path can descend through a previously written leaf. This branch is + -- unreachable by construction and exists only to satisfy exhaustiveness honestly. go _ _ = error "validated environment keys cannot overlap" diff --git a/test/Settei/EnvTest.hs b/test/Settei/EnvTest.hs --- a/test/Settei/EnvTest.hs +++ b/test/Settei/EnvTest.hs @@ -1,6 +1,8 @@ module Settei.EnvTest (tests) where +import Data.Either (isLeft, isRight) import Data.Generics.Labels () +import Data.List qualified as List import Data.List.NonEmpty qualified as NonEmpty import Data.Text qualified as Text import Settei @@ -13,7 +15,9 @@ tests = testGroup "Settei.Env" - [ testCase "explicit binding records variable origin" $ do + [ errorRenderingTests, + bindingMergingTests, + testCase "explicit binding records variable origin" $ do input <- expectSource [binding (EnvName "HASKELL_ENV") runtimeEnvironment] [("HASKELL_ENV", "Production")] case lookupSource runtimeEnvironment input of Right (Just found) -> do @@ -25,6 +29,8 @@ case lookupSource optionalValue input of Right Nothing -> pure () _ -> fail "expected the optional variable to remain absent", + testCase "invalid names are rejected at construction" $ + assertLeftContains isInvalidName (bindings [binding (EnvName "1BAD") runtimeEnvironment]), testCase "duplicate bindings are rejected" $ do let sameName = [ binding (EnvName "VALUE") runtimeEnvironment, @@ -34,25 +40,55 @@ [ binding (EnvName "ONE") runtimeEnvironment, binding (EnvName "TWO") runtimeEnvironment ] - assertLeftContains isDuplicateName (envSource "environment" sameName (envSnapshot [])) - assertLeftContains isDuplicateKey (envSource "environment" sameKey (envSnapshot [])), + assertLeftContains isDuplicateName (bindings sameName) + assertLeftContains isDuplicateKey (bindings sameKey), testCase "prefix collisions are rejected" $ do let keys = [validKey "service.http-port", validKey "service.http_port"] case prefixedBindings "MYAPP" keys of Left errors -> assertBool "expected a normalized-name collision" (any isPrefixCollision (NonEmpty.toList errors)) Right _ -> fail "expected the prefix helper to reject a collision", + testCase "prefixed bindings preserve their derived names" $ do + let keys = [validKey "service.host", validKey "service.port"] + validated <- either (fail . show) pure (prefixedBindings "MYAPP" keys) + fmap bindingName (bindingsList validated) + @?= [EnvName "MYAPP_SERVICE_HOST", EnvName "MYAPP_SERVICE_PORT"], testCase "overlapping target keys are rejected" $ do - let bindings = + let overlapping = [ binding (EnvName "SERVICE") (validKey "service"), binding (EnvName "PORT") (validKey "service.port") ] - assertLeftContains isConflict (envSource "environment" bindings (envSnapshot [])), + assertLeftContains isConflict (bindings overlapping), + testCase "constructed bindings never fail during source building" $ do + let pool = + [ binding (EnvName "POOL_A") (validKey "a"), + binding (EnvName "POOL_AB") (validKey "a.b"), + binding (EnvName "POOL_AC") (validKey "a.c"), + binding (EnvName "POOL_B") (validKey "b"), + binding (EnvName "POOL_BCD") (validKey "b.c.d"), + binding (EnvName "POOL_C") (validKey "c") + ] + snapshot = + envSnapshot [(name, "value") | EnvName name <- fmap bindingName pool] + outcomes = + [ (subset, bindings subset) + | subset <- List.subsequences pool + ] + assertBool "expected some subsets to fail construction" (any (isLeft . snd) outcomes) + assertBool "expected some subsets to construct" (any (isRight . snd) outcomes) + sequence_ + [ case lookupSource (bindingKey bound) (envSource "environment" validated snapshot) of + Right (Just _) -> pure () + _ -> fail "expected every bound key to be served by the total source" + | (subset, Right validated) <- outcomes, + bound <- subset + ], testCase "Secret annotation remains redacted" $ do let reference = kubernetesRef SecretObject (Just "payments") "payments-database" (Just "password") passwordBinding = fromKubernetesObject reference (binding (EnvName "DATABASE_PASSWORD") databasePassword) input <- expectSourceWith [passwordBinding] [("DATABASE_PASSWORD", secretSentinel)] - result <- expectResolution (resolve defaultResolveOptions [input] (required passwordSetting)) + let result = resolve defaultResolveOptions [input] (required passwordSetting) + _ <- expectResolution result let output = renderResolutionText (result ^. #report) assertBool "secret value reached the report" (not (secretSentinel `Text.isInfixOf` output)) assertBool "secret object metadata was omitted" ("payments-database" `Text.isInfixOf` output) @@ -61,23 +97,82 @@ let reference = kubernetesRef ConfigMapObject Nothing "service-network" (Just "host") hostBinding = fromKubernetesObject reference (binding (EnvName "SERVICE_HOST") serviceHost) input <- expectSourceWith [hostBinding] [("SERVICE_HOST", "api.internal")] - result <- expectResolution (resolve defaultResolveOptions [input] (required hostSetting)) + let result = resolve defaultResolveOptions [input] (required hostSetting) + _ <- expectResolution result let output = renderResolutionText (result ^. #report) assertBool "ConfigMap metadata was omitted" ("service-network" `Text.isInfixOf` output) assertBool "public value was omitted" ("api.internal" `Text.isInfixOf` output) ] +bindingMergingTests :: TestTree +bindingMergingTests = + testGroup + "merging validated bindings" + [ testCase "preserves disjoint collections in order" $ do + let firstValues = [binding (EnvName "SERVICE_HOST") serviceHost] + secondValues = [binding (EnvName "DATABASE_PASSWORD") databasePassword] + first <- expectBindings firstValues + second <- expectBindings secondValues + merged <- either (fail . show) pure (mergeBindings [first, second]) + assertBool + "merged bindings did not preserve collection order" + (bindingsList merged == firstValues <> secondValues), + testCase "rejects a cross-collection duplicate variable name" $ do + first <- expectBindings [binding (EnvName "SERVICE_VALUE") serviceHost] + second <- expectBindings [binding (EnvName "SERVICE_VALUE") databasePassword] + assertLeftContains isDuplicateName (mergeBindings [first, second]), + testCase "rejects cross-collection overlapping target keys" $ do + first <- expectBindings [binding (EnvName "SERVICE") (validKey "service")] + second <- expectBindings [binding (EnvName "SERVICE_PORT") (validKey "service.port")] + assertLeftContains isConflict (mergeBindings [first, second]), + testCase "accepts an empty collection list" $ do + merged <- either (fail . show) pure (mergeBindings []) + assertBool "empty merge produced bindings" (null (bindingsList merged)) + ] + +errorRenderingTests :: TestTree +errorRenderingTests = + testGroup + "error rendering" + [ testCase "invalid environment name" $ + renderEnvErrorText (InvalidEnvironmentName (EnvName "http port")) + @?= "environment binding http port: invalid variable name", + testCase "duplicate environment name" $ + renderEnvErrorText (DuplicateEnvironmentName (EnvName "HTTP_PORT")) + @?= "environment binding HTTP_PORT: variable bound more than once", + testCase "duplicate target key" $ + renderEnvErrorText (DuplicateTargetKey (validKey "http.port")) + @?= "bindings target the same key http.port twice", + testCase "conflicting target keys" $ + renderEnvErrorText + (ConflictingTargetKeys (validKey "http") (validKey "http.port")) + @?= "bindings target overlapping keys http and http.port", + testCase "prefixed name collision" $ + renderEnvErrorText + ( PrefixedNameCollision + (EnvName "MYAPP_SERVICE_HTTP_PORT") + (validKey "service.http-port" :| [validKey "service.http_port"]) + ) + @?= "environment binding MYAPP_SERVICE_HTTP_PORT: normalized name collides for keys service.http-port, service.http_port", + testCase "plural rendering is singular rendering plus a newline" $ do + let problem = InvalidEnvironmentName (EnvName "http port") + renderEnvErrorsText (NonEmpty.singleton problem) + @?= renderEnvErrorText problem <> "\n" + ] + expectSource :: [EnvBinding] -> [(Text, Text)] -> IO Source -expectSource bindings values = expectSourceWith bindings values +expectSource values snapshot = expectSourceWith values snapshot +expectBindings :: [EnvBinding] -> IO Bindings +expectBindings values = either (fail . show) pure (bindings values) + expectSourceWith :: [EnvBinding] -> [(Text, Text)] -> IO Source -expectSourceWith bindings values = - case envSource "environment" bindings (envSnapshot values) of - Left _ -> fail "expected a valid environment source" - Right value -> pure value +expectSourceWith values snapshot = do + validated <- expectBindings values + pure (envSource "environment" validated (envSnapshot snapshot)) -expectResolution :: Either (NonEmpty ConfigError) a -> IO a -expectResolution = \case +expectResolution :: ResolveResult a -> IO a +expectResolution result = case result ^. #answer of Left _ -> fail "expected successful resolution" Right value -> pure value @@ -89,6 +184,10 @@ isDuplicateName :: EnvError -> Bool isDuplicateName (DuplicateEnvironmentName _) = True isDuplicateName _ = False + +isInvalidName :: EnvError -> Bool +isInvalidName (InvalidEnvironmentName _) = True +isInvalidName _ = False isDuplicateKey :: EnvError -> Bool isDuplicateKey (DuplicateTargetKey _) = True