settei-env 0.2.0.0 → 0.3.0.0
raw patch · 4 files changed
+399/−39 lines, 4 filesdep ~setteidep ~settei-envPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: settei, settei-env
API changes (from Hackage documentation)
+ Settei.Env: BoundTo :: !Key -> NameAcceptance
+ Settei.Env: ConsumedBy :: !Text -> NameAcceptance
+ Settei.Env: DuplicateSuppliedName :: !EnvName -> SuppliedNameError
+ Settei.Env: UnsupportedSuppliedName :: !EnvName -> SuppliedNameError
+ Settei.Env: acceptedBindings :: AcceptedNames -> Bindings
+ Settei.Env: acceptedNames :: Bindings -> [Allowance] -> Either (NonEmpty EnvError) AcceptedNames
+ Settei.Env: acceptedNamesList :: AcceptedNames -> [(EnvName, NameAcceptance)]
+ Settei.Env: allowance :: Text -> EnvName -> Allowance
+ Settei.Env: allowanceConsumer :: Allowance -> Text
+ Settei.Env: allowanceName :: Allowance -> EnvName
+ Settei.Env: checkSuppliedNames :: AcceptedNames -> [EnvName] -> Either (NonEmpty SuppliedNameError) ()
+ Settei.Env: checkedEnvSource :: Text -> AcceptedNames -> EnvSnapshot -> Either (NonEmpty SuppliedNameError) Source
+ Settei.Env: checkedEnvironmentSource :: AcceptedNames -> EnvSnapshot -> Either (NonEmpty SuppliedNameError) Source
+ Settei.Env: data AcceptedNames
+ Settei.Env: data Allowance
+ Settei.Env: data NameAcceptance
+ Settei.Env: data SuppliedNameError
+ Settei.Env: inputBindings :: Bindings -> [InputBinding]
+ Settei.Env: instance GHC.Classes.Eq Settei.Env.AcceptedNames
+ Settei.Env: instance GHC.Classes.Eq Settei.Env.Allowance
+ Settei.Env: instance GHC.Classes.Eq Settei.Env.NameAcceptance
+ Settei.Env: instance GHC.Classes.Eq Settei.Env.SuppliedNameError
+ Settei.Env: instance GHC.Internal.Generics.Generic Settei.Env.NameAcceptance
+ Settei.Env: instance GHC.Internal.Generics.Generic Settei.Env.SuppliedNameError
+ Settei.Env: instance GHC.Internal.Show.Show Settei.Env.NameAcceptance
+ Settei.Env: instance GHC.Internal.Show.Show Settei.Env.SuppliedNameError
+ Settei.Env: renderSuppliedNameErrorText :: SuppliedNameError -> Text
+ Settei.Env: renderSuppliedNameErrorsJson :: NonEmpty SuppliedNameError -> Text
+ Settei.Env: renderSuppliedNameErrorsText :: NonEmpty SuppliedNameError -> Text
+ Settei.Env: snapshotNames :: EnvSnapshot -> [EnvName]
Files
- CHANGELOG.md +16/−0
- settei-env.cabal +37/−35
- src/Settei/Env.hs +190/−3
- test/Settei/EnvTest.hs +156/−1
CHANGELOG.md view
@@ -1,5 +1,21 @@ # Changelog for settei-env +## 0.3.0.0 — 2026-10-21++### New Features++- Add supplied-name validation against bindings and external-consumer allowances+ (`acceptedNames`, `allowance`, `checkSuppliedNames`, `snapshotNames`), opt-in checked+ snapshot source builders (`checkedEnvSource`, `checkedEnvironmentSource`), and safe+ text and version-1 `settei.supplied-names` JSON diagnostics. Existing source builders+ remain permissive.+- Add `inputBindings` to export validated binding metadata without reading environment values.++### Other Changes++- Released in the shared 0.3.0.0 PVP major family release; the `settei` pin moves to+ `==0.3.0.0`. This package's own API changes are additive.+ ## 0.2.0.0 — 2026-07-19 - BREAKING: environment bindings are validated once at construction. `Bindings` is an
settei-env.cabal view
@@ -1,59 +1,61 @@-cabal-version: 3.8-name: settei-env-version: 0.2.0.0-synopsis: Environment sources for Settei+cabal-version: 3.8+name: settei-env+version: 0.3.0.0+synopsis: Environment sources for Settei description: Translate explicit environment-variable bindings into provenance-aware Settei sources without decoding application values. -homepage: https://github.com/shinzui/settei-bug-reports: https://github.com/shinzui/settei/issues-license: BSD-3-Clause-license-file: LICENSE-author: shinzui-maintainer: shinzui-category: Configuration-build-type: Simple-tested-with: GHC ==9.12.4+homepage: https://github.com/shinzui/settei+bug-reports: https://github.com/shinzui/settei/issues+license: BSD-3-Clause+license-file: LICENSE+author: shinzui+maintainer: shinzui+category: Configuration+build-type: Simple+tested-with: ghc ==9.12.4 extra-doc-files: CHANGELOG.md source-repository head- type: git+ type: git location: https://github.com/shinzui/settei.git common common- default-language: GHC2024+ default-language: GHC2024 default-extensions: DeriveAnyClass DuplicateRecordFields OverloadedLabels OverloadedStrings - ghc-options: -Wall -Wcompat+ ghc-options:+ -Wall+ -Wcompat library- import: common- hs-source-dirs: src+ import: common+ hs-source-dirs: src exposed-modules: Settei.Env build-depends:- , base >=4.21 && <5- , containers >=0.6.8 && <0.8- , generic-lens >=2.2 && <2.4- , settei ==0.2.0.0- , text >=2.1 && <2.2+ base >=4.21 && <5,+ containers >=0.6.8 && <0.8,+ generic-lens >=2.2 && <2.4,+ settei ==0.3.0.0,+ text >=2.1 && <2.2, test-suite settei-env-tests- import: common- type: exitcode-stdio-1.0+ import: common+ type: exitcode-stdio-1.0 hs-source-dirs: test- main-is: Main.hs- other-modules: Settei.EnvTest+ main-is: Main.hs+ other-modules: Settei.EnvTest build-depends:- , base >=4.21 && <5- , containers >=0.6.8 && <0.8- , generic-lens >=2.2 && <2.4- , 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+ base >=4.21 && <5,+ containers >=0.6.8 && <0.8,+ generic-lens >=2.2 && <2.4,+ settei ==0.3.0.0,+ settei-env ==0.3.0.0,+ tasty >=1.5 && <1.6,+ tasty-hunit >=0.10.2 && <0.11,+ text >=2.1 && <2.2,
src/Settei/Env.hs view
@@ -1,12 +1,22 @@ -- | -- Module: Settei.Env--- Description: Explicit, pure environment-variable sources for Settei.+-- Description: Explicit, pure environment sources and supplied-name validation. module Settei.Env- ( Bindings,+ ( AcceptedNames,+ Allowance,+ Bindings, EnvName (..), EnvSnapshot (..), EnvBinding, EnvError (..),+ NameAcceptance (..),+ SuppliedNameError (..),+ acceptedBindings,+ acceptedNames,+ acceptedNamesList,+ allowance,+ allowanceConsumer,+ allowanceName, annotateBinding, binding, bindingAnnotations,@@ -14,24 +24,34 @@ bindingName, bindings, bindingsList,+ checkSuppliedNames,+ checkedEnvSource,+ checkedEnvironmentSource, envSnapshot, envSource, environmentSource, fromKubernetesObject,+ inputBindings, mergeBindings, prefixedBindings, readEnvSource, readEnvironmentSource, renderEnvErrorText, renderEnvErrorsText,+ renderSuppliedNameErrorText,+ renderSuppliedNameErrorsJson,+ renderSuppliedNameErrorsText,+ snapshotNames, ) where -import Data.Char (isAsciiLower, isAsciiUpper, isDigit)+import Data.Char (isAsciiLower, isAsciiUpper, isDigit, ord) import Data.Generics.Labels () import Data.List.NonEmpty qualified as NonEmpty import Data.Map.Strict qualified as Map+import Data.Set qualified as Set import Data.Text qualified as Text+import Numeric (showHex) import Settei import Settei.Prelude import System.Environment qualified as Environment@@ -71,6 +91,146 @@ newtype Bindings = Bindings [EnvBinding] deriving stock (Eq) +-- | One variable consumed outside Settei, with a trusted consumer label.+-- Validated together with bindings by 'acceptedNames'.+data Allowance = Allowance !Text !EnvName+ deriving stock (Eq)++-- | Declare a consumer label and its variable name; no value is retained.+allowance :: Text -> EnvName -> Allowance+allowance = Allowance++-- | Inspect the trusted external-consumer label.+allowanceConsumer :: Allowance -> Text+allowanceConsumer (Allowance consumer _) = consumer++-- | Inspect the variable consumed outside Settei.+allowanceName :: Allowance -> EnvName+allowanceName (Allowance _ name) = name++-- | How a declared name is accepted.+data NameAcceptance = BoundTo !Key | ConsumedBy !Text+ deriving stock (Generic, Eq, Show)++-- | Bindings and external-consumer allowances validated together.+-- The private constructor and absence of Generic preserve the invariant.+data AcceptedNames = AcceptedNames !Bindings ![Allowance]+ deriving stock (Eq)++-- | Validate static allowances, rejecting invalid or repeated names (including+-- names already bound). Invalid names precede ascending duplicate-name errors.+acceptedNames :: Bindings -> [Allowance] -> Either (NonEmpty EnvError) AcceptedNames+acceptedNames validated allowances =+ case NonEmpty.nonEmpty errors of+ Just problems -> Left problems+ Nothing -> Right (AcceptedNames validated allowances)+ where+ names = fmap allowanceName allowances+ errors =+ [InvalidEnvironmentName name | name <- names, not (validEnvName name)]+ <> fmap DuplicateEnvironmentName (duplicates (fmap bindingName (bindingsList validated) <> names))++-- | Recover the original validated bindings for ordinary source translation.+acceptedBindings :: AcceptedNames -> Bindings+acceptedBindings (AcceptedNames validated _) = validated++-- | Bound names in binding order followed by allowances in declaration order.+acceptedNamesList :: AcceptedNames -> [(EnvName, NameAcceptance)]+acceptedNamesList (AcceptedNames validated allowances) =+ [(bindingName value, BoundTo (bindingKey value)) | value <- bindingsList validated]+ <> [(allowanceName value, ConsumedBy (allowanceConsumer value)) | value <- allowances]++-- | Runtime supplied-name failures retain original names only, never values.+data SuppliedNameError+ = UnsupportedSuppliedName !EnvName+ | DuplicateSuppliedName !EnvName+ deriving stock (Generic, Eq, Show)++-- | Check exactly the supplied collection. Absence is never an error.+-- Unsupported names are reported at their first occurrence; duplicates once at+-- their second occurrence. Diagnostic order follows encounter order.+checkSuppliedNames :: AcceptedNames -> [EnvName] -> Either (NonEmpty SuppliedNameError) ()+checkSuppliedNames accepted supplied =+ case NonEmpty.nonEmpty (go Set.empty Set.empty supplied) of+ Just problems -> Left problems+ Nothing -> Right ()+ where+ allowed = Set.fromList (fmap fst (acceptedNamesList accepted))+ go _ _ [] = []+ go seen reportedDuplicates (name : rest)+ | Set.member name reportedDuplicates = go seen reportedDuplicates rest+ | Set.member name seen = DuplicateSuppliedName name : go seen (Set.insert name reportedDuplicates) rest+ | otherwise =+ [UnsupportedSuppliedName name | Set.notMember name allowed]+ <> go (Set.insert name seen) reportedDuplicates rest++-- | Render a single safe physical line. Portable names are verbatim; other names+-- are quoted and escaped without changing the retained name or comparison.+renderSuppliedNameErrorText :: SuppliedNameError -> Text+renderSuppliedNameErrorText = \case+ UnsupportedSuppliedName name ->+ "supplied environment variable " <> displaySuppliedName name <> ": no binding or allowance accepts it"+ DuplicateSuppliedName name ->+ "supplied environment variable " <> displaySuppliedName name <> ": supplied more than once"++-- | One sentence and terminating newline per problem.+renderSuppliedNameErrorsText :: NonEmpty SuppliedNameError -> Text+renderSuppliedNameErrorsText = Text.unlines . fmap renderSuppliedNameErrorText . NonEmpty.toList++-- | One compact @settei.supplied-names@ schema-version-1 document, without a+-- trailing newline. JSON encodes the original names, independently of text display.+renderSuppliedNameErrorsJson :: NonEmpty SuppliedNameError -> Text+renderSuppliedNameErrorsJson errors =+ jsonObject+ [ ("schemaVersion", "1"),+ ("type", jsonString "settei.supplied-names"),+ ("errors", jsonArray (fmap renderError (NonEmpty.toList errors)))+ ]+ where+ renderError problem =+ let (kind, name) = case problem of+ UnsupportedSuppliedName value -> ("unsupported-supplied-name", value)+ DuplicateSuppliedName value -> ("duplicate-supplied-name", value)+ in jsonObject [("kind", jsonString kind), ("name", jsonString (renderEnvName name))]++displaySuppliedName :: EnvName -> Text+displaySuppliedName name+ | validEnvName name = renderEnvName name+ | otherwise = "\"" <> Text.concatMap escapeDisplayChar (renderEnvName name) <> "\""+ where+ escapeDisplayChar character+ | (character >= '\x7f' && character <= '\x9f') || character == '\x2028' || character == '\x2029' =+ "\\u" <> paddedHex (ord character)+ | otherwise = escapeJsonChar character++jsonObject :: [(Text, Text)] -> Text+jsonObject fields =+ "{" <> Text.intercalate "," [jsonString key <> ":" <> value | (key, value) <- fields] <> "}"++jsonArray :: [Text] -> Text+jsonArray values = "[" <> Text.intercalate "," values <> "]"++jsonString :: Text -> Text+jsonString value = "\"" <> Text.concatMap escapeJsonChar value <> "\""++escapeJsonChar :: Char -> Text+escapeJsonChar = \case+ '"' -> "\\\""+ '\\' -> "\\\\"+ '\b' -> "\\b"+ '\f' -> "\\f"+ '\n' -> "\\n"+ '\r' -> "\\r"+ '\t' -> "\\t"+ character+ | ord character < 0x20 -> "\\u" <> paddedHex (ord character)+ | otherwise -> Text.singleton character++paddedHex :: Int -> Text+paddedHex value =+ let rendered = Text.pack (showHex value "")+ in Text.replicate (4 - Text.length rendered) "0" <> rendered+ -- | Construct one explicit binding with no caller annotations. binding :: EnvName -> Key -> EnvBinding binding name key = EnvBinding {name, key, annotations = Map.empty}@@ -148,6 +308,22 @@ EnvSnapshot (Map.fromList [(EnvName name, value) | (name, value) <- values]) +-- | Snapshot keys in ascending order. A map has already collapsed duplicate+-- entries; check ordered deployment entries as a list before making a snapshot.+snapshotNames :: EnvSnapshot -> [EnvName]+snapshotNames (EnvSnapshot snapshot) = Map.keys snapshot++-- | Opt in to checking every name in an injected snapshot, then translate using+-- the ordinary source builder. This never reads the process environment itself.+checkedEnvSource :: Text -> AcceptedNames -> EnvSnapshot -> Either (NonEmpty SuppliedNameError) Source+checkedEnvSource label accepted snapshot = do+ checkSuppliedNames accepted (snapshotNames snapshot)+ pure (envSource label (acceptedBindings accepted) snapshot)++-- | 'checkedEnvSource' with the conventional @"environment"@ label.+checkedEnvironmentSource :: AcceptedNames -> EnvSnapshot -> Either (NonEmpty SuppliedNameError) Source+checkedEnvironmentSource = checkedEnvSource "environment"+ -- | Translate explicitly bound variables from one snapshot into a Settei source. -- -- Total: a 'Bindings' value is valid by construction, so no error branch exists.@@ -313,3 +489,14 @@ -- 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"++-- | Inspect validated bindings without reading any environment values.+-- Adapter-owned variable identity wins over caller annotations, as in envSource.+inputBindings :: Bindings -> [InputBinding]+inputBindings = fmap convert . bindingsList+ where+ convert bindingValue =+ let variable = renderEnvName (bindingName bindingValue)+ in annotateInputBinding+ (Map.singleton "environment.variable" variable <> bindingAnnotations bindingValue)+ (inputBinding EnvironmentVariable variable (bindingKey bindingValue))
test/Settei/EnvTest.hs view
@@ -4,6 +4,7 @@ import Data.Generics.Labels () import Data.List qualified as List import Data.List.NonEmpty qualified as NonEmpty+import Data.Map.Strict qualified as Map import Data.Text qualified as Text import Settei import Settei.Env@@ -15,8 +16,23 @@ tests = testGroup "Settei.Env"- [ errorRenderingTests,+ [ testCase "contract bindings preserve order and trusted annotations without values" $ do+ let reference = kubernetesRef SecretObject (Just "payments") "database" (Just "password")+ first = annotateBinding (mempty & at "environment.variable" ?~ "spoofed") (binding (EnvName "MODE") runtimeEnvironment)+ second = fromKubernetesObject reference (binding (EnvName "PASSWORD") databasePassword)+ validated <- either (fail . show) pure (bindings [first, second])+ let converted = inputBindings validated+ fmap inputBindingName converted @?= ["MODE", "PASSWORD"]+ fmap inputBindingKey converted @?= [runtimeEnvironment, databasePassword]+ fmap inputBindingChannel converted @?= [EnvironmentVariable, EnvironmentVariable]+ case converted of+ [firstConverted, secondConverted] -> do+ inputBindingAnnotations firstConverted ^. at "environment.variable" @?= Just "MODE"+ inputBindingAnnotations secondConverted ^. at "kubernetes.object-name" @?= Just "database"+ _ -> fail "expected two bindings",+ errorRenderingTests, bindingMergingTests,+ suppliedNameTests, testCase "explicit binding records variable origin" $ do input <- expectSource [binding (EnvName "HASKELL_ENV") runtimeEnvironment] [("HASKELL_ENV", "Production")] case lookupSource runtimeEnvironment input of@@ -102,6 +118,145 @@ 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)+ ]++suppliedNameTests :: TestTree+suppliedNameTests =+ testGroup+ "supplied name validation"+ [ testCase "accepts bound and allowed names and preserves declarations" $ do+ validated <-+ expectBindings+ [ binding (EnvName "ENVIRONMENT") runtimeEnvironment,+ binding (EnvName "DATABASE_URL") databasePassword,+ binding (EnvName "PORT") optionalValue+ ]+ let external = allowance "opentelemetry-sdk" (EnvName "OTEL_EXPORTER_OTLP_ENDPOINT")+ accepted <- either (fail . show) pure (acceptedNames validated [external])+ assertBool "bindings changed" (acceptedBindings accepted == validated)+ allowanceConsumer external @?= "opentelemetry-sdk"+ allowanceName external @?= EnvName "OTEL_EXPORTER_OTLP_ENDPOINT"+ acceptedNamesList accepted+ @?= [ (EnvName "ENVIRONMENT", BoundTo runtimeEnvironment),+ (EnvName "DATABASE_URL", BoundTo databasePassword),+ (EnvName "PORT", BoundTo optionalValue),+ (EnvName "OTEL_EXPORTER_OTLP_ENDPOINT", ConsumedBy "opentelemetry-sdk")+ ]+ checkSuppliedNames accepted (fmap EnvName ["ENVIRONMENT", "DATABASE_URL", "OTEL_EXPORTER_OTLP_ENDPOINT"]) @?= Right (),+ testCase "reports every unsupported name in supplied order deterministically" $ do+ accepted <- expectAccepted [binding (EnvName "ENVIRONMENT") runtimeEnvironment, binding (EnvName "DATABASE_URL") databasePassword] []+ let supplied = fmap EnvName ["HASKELL_ENV", "DATABASE_URL", "DB_URL"]+ result = checkSuppliedNames accepted supplied+ result @?= Left (UnsupportedSuppliedName (EnvName "HASKELL_ENV") :| [UnsupportedSuppliedName (EnvName "DB_URL")])+ checkSuppliedNames accepted supplied @?= result,+ testCase "empty collection accepts absent bindings" $ do+ accepted <- expectAccepted [binding (EnvName "ENVIRONMENT") runtimeEnvironment] []+ checkSuppliedNames accepted [] @?= Right (),+ testCase "reports duplicates once at their second encounter" $ do+ accepted <- expectAccepted [binding (EnvName "PORT") optionalValue] []+ checkSuppliedNames accepted (fmap EnvName ["PORT", "PORT", "PORT", "HOST", "HOST", "HOST"])+ @?= Left (DuplicateSuppliedName (EnvName "PORT") :| [UnsupportedSuppliedName (EnvName "HOST"), DuplicateSuppliedName (EnvName "HOST")]),+ testCase "allowance scope excludes unrelated inherited variables" $ do+ accepted <-+ expectAccepted+ [binding (EnvName "ENVIRONMENT") runtimeEnvironment]+ [allowance "opentelemetry-sdk" (EnvName "OTEL_EXPORTER_OTLP_ENDPOINT")]+ let snapshot = envSnapshot [("PATH", "bin"), ("HOME", "home"), ("KUBERNETES_SERVICE_HOST", "host"), ("ENVIRONMENT", "production")]+ checkSuppliedNames accepted (fmap EnvName ["ENVIRONMENT", "OTEL_EXPORTER_OTLP_ENDPOINT", "HASKELL_ENV"])+ @?= Left (UnsupportedSuppliedName (EnvName "HASKELL_ENV") :| [])+ snapshotNames snapshot @?= fmap EnvName ["ENVIRONMENT", "HOME", "KUBERNETES_SERVICE_HOST", "PATH"]+ assertBool "snapshot-wide check should be an explicit stricter choice" (isLeft (checkedEnvironmentSource accepted snapshot)),+ testCase "snapshot names are sorted and duplicates are already collapsed" $+ snapshotNames (envSnapshot [("Z", "first"), ("A", "a"), ("Z", "last")]) @?= fmap EnvName ["A", "Z"],+ testCase "validates allowance names and collisions together" $ do+ validated <- expectBindings [binding (EnvName "PORT") optionalValue]+ let declarations = fmap (allowance "external" . EnvName) ["1BAD", "PORT", "Z", "Z", "A", "A", "1BAD"]+ case acceptedNames validated declarations of+ Left errors ->+ NonEmpty.toList errors+ @?= [ InvalidEnvironmentName (EnvName "1BAD"),+ InvalidEnvironmentName (EnvName "1BAD"),+ DuplicateEnvironmentName (EnvName "1BAD"),+ DuplicateEnvironmentName (EnvName "A"),+ DuplicateEnvironmentName (EnvName "PORT"),+ DuplicateEnvironmentName (EnvName "Z")+ ]+ Right _ -> fail "invalid allowances accepted",+ testCase "strict path rejects HASKELL_ENV when ENVIRONMENT is bound" $ do+ accepted <- expectAccepted [binding (EnvName "ENVIRONMENT") runtimeEnvironment] []+ let declaration = required (publicSetting runtimeEnvironment "Runtime environment" (enumDecoder [("development", False), ("production", True)]))+ builtIn = source "built-in defaults" BuiltInSource (RawObject (Map.singleton "runtime" (RawObject (Map.singleton "environment" (RawText "development")))))+ typo = envSnapshot [("HASKELL_ENV", "production")]+ corrected = envSnapshot [("ENVIRONMENT", "production")]+ permissive = environmentSource (acceptedBindings accepted) corrected+ expectResolution (resolve defaultResolveOptions [builtIn, environmentSource (acceptedBindings accepted) typo] declaration) >>= (@?= False)+ case checkedEnvironmentSource accepted typo of+ Left errors -> errors @?= UnsupportedSuppliedName (EnvName "HASKELL_ENV") :| []+ Right _ -> fail "typo hidden by default"+ strictSource <- either (fail . show) pure (checkedEnvironmentSource accepted corrected)+ expectResolution (resolve defaultResolveOptions [builtIn, strictSource] declaration) >>= (@?= True)+ case (lookupSource runtimeEnvironment strictSource, lookupSource runtimeEnvironment permissive) of+ (Right (Just actual), Right (Just expected)) -> do+ candidateOrigin actual @?= candidateOrigin expected+ candidateOrigin actual ^. #annotations . at "environment.variable" @?= Just "ENVIRONMENT"+ _ -> fail "expected strict and permissive candidates"+ labeled <- either (fail . show) pure (checkedEnvSource "deployment" accepted corrected)+ case lookupSource runtimeEnvironment labeled of+ Right (Just found) -> candidateOrigin found ^. #name @?= "deployment"+ _ -> fail "expected custom source label",+ testCase "sentinels never reach supplied-name diagnostics" $ do+ accepted <- expectAccepted [binding (EnvName "ENVIRONMENT") runtimeEnvironment] []+ let unknownSentinel = "unknown-value-sentinel"+ case checkedEnvironmentSource accepted (envSnapshot [("ENVIRONMENT", secretSentinel), ("HASKELL_ENV", unknownSentinel)]) of+ Left errors -> do+ let outputs = [Text.pack (show errors), renderSuppliedNameErrorsText errors, renderSuppliedNameErrorsJson errors]+ sequence_ [assertBool "value leaked" (not (sentinel `Text.isInfixOf` output)) | output <- outputs, sentinel <- [secretSentinel, unknownSentinel]]+ Right _ -> fail "expected strict failure",+ testCase "successful strict source still redacts secrets" $ do+ accepted <- expectAccepted [binding (EnvName "DATABASE_PASSWORD") databasePassword] []+ input <- either (fail . show) pure (checkedEnvironmentSource accepted (envSnapshot [("DATABASE_PASSWORD", secretSentinel)]))+ let result = resolve defaultResolveOptions [input] (required passwordSetting)+ _ <- expectResolution result+ assertBool "secret leaked from strict source" (not (secretSentinel `Text.isInfixOf` renderResolutionText (result ^. #report))),+ suppliedNameRenderingTests+ ]++expectAccepted :: [EnvBinding] -> [Allowance] -> IO AcceptedNames+expectAccepted values allowances = do+ validated <- expectBindings values+ either (fail . show) pure (acceptedNames validated allowances)++suppliedNameRenderingTests :: TestTree+suppliedNameRenderingTests =+ testGroup+ "rendering"+ [ testCase "portable text and exact versioned JSON are stable" $ do+ let errors = UnsupportedSuppliedName (EnvName "HASKELL_ENV") :| [DuplicateSuppliedName (EnvName "PORT")]+ expected = "{\"schemaVersion\":1,\"type\":\"settei.supplied-names\",\"errors\":[{\"kind\":\"unsupported-supplied-name\",\"name\":\"HASKELL_ENV\"},{\"kind\":\"duplicate-supplied-name\",\"name\":\"PORT\"}]}"+ renderSuppliedNameErrorsText errors @?= "supplied environment variable HASKELL_ENV: no binding or allowance accepts it\nsupplied environment variable PORT: supplied more than once\n"+ renderSuppliedNameErrorsJson errors @?= expected+ renderSuppliedNameErrorsJson errors @?= renderSuppliedNameErrorsJson errors,+ testCase "hostile names retain spelling but escape text and JSON independently" $ do+ accepted <- expectAccepted [] []+ let name = EnvName "BAD\"\\\n\SOHNAME"+ problem = UnsupportedSuppliedName name+ duplicate = DuplicateSuppliedName name+ checkSuppliedNames accepted [name] @?= Left (problem :| [])+ renderSuppliedNameErrorText problem @?= "supplied environment variable \"BAD\\\"\\\\\\n\\u0001NAME\": no binding or allowance accepts it"+ renderSuppliedNameErrorText duplicate @?= "supplied environment variable \"BAD\\\"\\\\\\n\\u0001NAME\": supplied more than once"+ renderSuppliedNameErrorsText (problem :| [duplicate]) @?= Text.unlines [renderSuppliedNameErrorText problem, renderSuppliedNameErrorText duplicate]+ renderSuppliedNameErrorsJson (problem :| []) @?= "{\"schemaVersion\":1,\"type\":\"settei.supplied-names\",\"errors\":[{\"kind\":\"unsupported-supplied-name\",\"name\":\"BAD\\\"\\\\\\n\\u0001NAME\"}]}",+ testGroup+ "nonportable display names"+ [ testCase (show original) $ do+ let errors = UnsupportedSuppliedName (EnvName original) :| [DuplicateSuppliedName (EnvName original)]+ sentences = ["supplied environment variable " <> escaped <> ": " <> suffix | suffix <- ["no binding or allowance accepts it", "supplied more than once"]]+ fmap renderSuppliedNameErrorText (NonEmpty.toList errors) @?= sentences+ renderSuppliedNameErrorsText errors @?= Text.unlines sentences+ length (Text.lines (renderSuppliedNameErrorsText errors)) @?= 2+ | (original, escaped) <-+ [("", "\"\""), ("with space", "\"with space\""), ("\r", "\"\\r\""), ("\t", "\"\\t\""), ("\ESC", "\"\\u001b\""), ("\DEL", "\"\\u007f\""), ("\x85", "\"\\u0085\""), ("\x2028", "\"\\u2028\""), ("\x2029", "\"\\u2029\"")]+ ] ] bindingMergingTests :: TestTree