diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,8 +1,46 @@ # Changelog for settei -## 0.1.0.0 — 2026-07-18 +## 0.2.0.0 — 2026-07-19 +- `Settei.Prelude` is now documented as internal to the settei package family and is + excluded from the PVP-stable public surface; adopters should import the documented + public modules instead. Its exports track the `lens` package and may change in any + release. +- Add a `Functor` instance for `Decoder`; a newtype-wrapping decoder is now + `SecretText <$> textDecoder`. +- Add decoder combinators `listDecoder`, `nonEmptyDecoder`, `parsedDecoder`, + `rationalDecoder`, and `doubleDecoder`, all preserving the secret-safe + failure contract (failures carry only the setting key and an expectation). +- `boundedIntegralDecoder` failures now state the accepted range, for example + `integer between -32768 and 32767`. +- Document `enumDecoder`'s case-sensitive matching. +- Add `whenConfig`, `whenEq`, and `fallbackTo` to `Settei.Config`. Each combinator + desugars to the existing `Functor` and `Selective` operations without changing the + inspectable declaration algebra. +- Add `publicShowSetting` and `withRenderer` to `Settei.Setting` for concise typed-default + rendering; secret settings continue to redact regardless of attached renderers. +- The text renderer's Kubernetes suffix appends `(modified TIME)` when an origin carries + the `kubernetes.file-modified` annotation. JSON output is unchanged because it already + emits the full annotation map. + +## 0.1.0.0 — 2026-07-19 + - Initial experimental release. - Add inspectable Applicative and Selective configuration declarations. - Add hierarchical resolution, ordered provenance, named defaults, secret-safe errors, static schemas, and versioned text and JSON reports. +- Merge duplicate setting sensitivities most-restrictively in schemas and reports, so a + key declared `Secret` anywhere cannot be weakened by a conflicting `Public` + declaration; add `redactReportedValue` as a one-way collapse of any retained display + representation to the redaction marker. +- Add the structured `SensitivityConflict` resolution error for mixed-sensitivity keys, + rendered in JSON with the additive `sensitivity-conflict` kind. +- Breaking: `resolve` now returns `ResolveResult` unconditionally. The typed outcome + moved to its `answer` field, while the provenance report and warnings are available + for every resolution attempt, including failures. +- Make repeated `annotateSource` calls merge source-wide annotations, with annotations + from later calls winning on name collisions. +- Add `sourceFromPairs`, `SourceConstructionError`, and + `sourceUnaddressableLeaves` for validated custom-source construction and inspection. +- Render exact terminating rational values as decimals in reports while retaining exact + fraction notation for non-terminating values. diff --git a/settei.cabal b/settei.cabal --- a/settei.cabal +++ b/settei.cabal @@ -1,6 +1,6 @@ cabal-version: 3.8 name: settei -version: 0.1.0.0 +version: 0.2.0.0 synopsis: Typed, layered, explainable configuration description: Settei provides an inspectable declaration language for typed configuration. diff --git a/src/Settei/Config.hs b/src/Settei/Config.hs --- a/src/Settei/Config.hs +++ b/src/Settei/Config.hs @@ -13,10 +13,7 @@ -- @ -- productionPassword :: Config (Maybe Text) -- productionPassword = --- select --- ((\environment -> if environment == "production" then Left () else Right Nothing) --- '<$>' required environmentSetting) --- ((\password _ -> Just password) '<$>' required passwordSetting) +-- whenEq (required environmentSetting) "production" (required passwordSetting) -- @ -- -- Inspection needs no environment variables or files: @@ -26,17 +23,31 @@ -- -- ["runtime.environment"] -- @ -- +-- For arbitrary selective branch shapes, use 'Control.Selective.select' directly; the +-- production-only declaration above desugars to: +-- +-- @ +-- select +-- ((\environment -> if environment == "production" then Left () else Right Nothing) +-- '<$>' required environmentSetting) +-- ((\password _ -> Just password) '<$>' required passwordSetting) +-- @ +-- -- 'Config' intentionally has no 'Monad' instance. Monadic binding could construct new -- keys from resolved values and would make complete static inspection impossible. module Settei.Config ( Config, describe, + fallbackTo, optional, required, + whenConfig, + whenEq, withDefault, ) where +import Control.Selective (select) import Settei.Default (Default) import Settei.Internal.Config ( Config, @@ -55,6 +66,48 @@ -- | Request a setting without failing when no source supplies it. optional :: Setting a -> Config (Maybe a) optional = optionalConfig + +-- | Evaluate a declaration only when a condition is 'True'. +-- +-- Desugars to 'Control.Selective.select'; no new syntax is introduced. Schema +-- footprint: every setting inside the condition keeps its presence (a 'required' +-- condition setting stays necessary); every setting inside the branch becomes +-- conditional; one 'Settei.Schema.Condition' row is recorded whose dependencies are the +-- condition's possible keys and whose activated settings are the branch's possible keys. +-- At resolution time a 'False' condition reports the branch's settings as not selected +-- rather than missing. +whenConfig :: Config Bool -> Config a -> Config (Maybe a) +whenConfig condition branch = + select + ((\flag -> if flag then Left () else Right Nothing) <$> condition) + ((\value () -> Just value) <$> branch) + +-- | Evaluate a declaration only when a scrutinee equals an expected value. +-- +-- @'whenEq' (required environmentSetting) Production (required passwordSetting)@ +-- requires the password only when the resolved environment is @Production@. Schema +-- footprint is identical to 'whenConfig': scrutinee settings keep their presence, +-- branch settings become conditional, and one 'Settei.Schema.Condition' row links them. +whenEq :: (Eq d) => Config d -> d -> Config a -> Config (Maybe a) +whenEq scrutinee expected = whenConfig ((== expected) <$> scrutinee) + +-- | Use the first declaration's value when present; otherwise evaluate the fallback. +-- +-- This is the key-migration idiom: +-- @optional newSetting `fallbackTo` required oldSetting@ reads a renamed key and +-- consults the old key only when no source supplies the new one. +-- +-- Desugars to 'Control.Selective.select'. Schema footprint: the primary declaration's +-- settings keep their presence; the fallback's settings become conditional; one +-- 'Settei.Schema.Condition' row records the primary's possible keys as dependencies and +-- the fallback's possible keys as activated settings. The alias is declaration-level, +-- not per-source: a value for the primary key in any source, however low its precedence, +-- suppresses the fallback entirely. +fallbackTo :: Config (Maybe a) -> Config a -> Config a +fallbackTo primary fallback = + select + (maybe (Left ()) Right <$> primary) + (const <$> fallback) -- | Request a setting, evaluating its named fallback only when no source supplies it. withDefault :: Setting a -> Default a -> Config a diff --git a/src/Settei/Error.hs b/src/Settei/Error.hs --- a/src/Settei/Error.hs +++ b/src/Settei/Error.hs @@ -9,6 +9,7 @@ DecodeProblem (..), MissingProblem (..), RawShape (..), + SensitivityConflictProblem (..), StructuralError (..), UnknownKeyProblem (..), ) @@ -69,6 +70,12 @@ } deriving stock (Generic, Eq, Show) +-- | One key was declared with both public and secret sensitivity. +data SensitivityConflictProblem = SensitivityConflictProblem + { key :: !Key + } + deriving stock (Generic, Eq, Show) + -- | A fatal resolver error. Every constructor is safe to render or show. data ConfigError = MissingRequired !MissingProblem @@ -77,6 +84,7 @@ | UnknownKeyError !UnknownKeyProblem | DefaultError !DefaultProblem | DefaultCycle !DefaultCycleProblem + | SensitivityConflict !SensitivityConflictProblem deriving stock (Generic, Eq, Show) -- | A non-fatal resolver diagnostic. diff --git a/src/Settei/Internal/Schema.hs b/src/Settei/Internal/Schema.hs --- a/src/Settei/Internal/Schema.hs +++ b/src/Settei/Internal/Schema.hs @@ -7,6 +7,7 @@ combineSchema, conditionalSchema, emptySchema, + mergeSensitivity, requestSchema, ) where @@ -17,7 +18,7 @@ import Settei.Key (Key) import Settei.Prelude import Settei.Setting - ( Sensitivity, + ( Sensitivity (..), Setting, settingDescription, settingKey, @@ -37,6 +38,7 @@ { key :: !Key, description :: !Text, sensitivity :: !Sensitivity, + declaredSensitivities :: !(Set Sensitivity), requirement :: !Requirement, presence :: !Presence } @@ -72,6 +74,7 @@ { key, description = settingDescription settingSpec, sensitivity = settingSensitivity settingSpec, + declaredSensitivities = Set.singleton (settingSensitivity settingSpec), requirement, presence = Necessary } @@ -102,10 +105,20 @@ mergeSetting :: SchemaSetting -> SchemaSetting -> SchemaSetting mergeSetting left right = left + & #sensitivity + .~ mergeSensitivity (left ^. #sensitivity) (right ^. #sensitivity) + & #declaredSensitivities + .~ Set.union (left ^. #declaredSensitivities) (right ^. #declaredSensitivities) & #requirement .~ mergeRequirement (left ^. #requirement) (right ^. #requirement) & #presence .~ mergePresence (left ^. #presence) (right ^. #presence) + +-- | Secret wins: a key declared secret anywhere is secret everywhere. +mergeSensitivity :: Sensitivity -> Sensitivity -> Sensitivity +mergeSensitivity Secret _ = Secret +mergeSensitivity _ Secret = Secret +mergeSensitivity Public Public = Public mergeRequirement :: Requirement -> Requirement -> Requirement mergeRequirement Required _ = Required diff --git a/src/Settei/Prelude.hs b/src/Settei/Prelude.hs --- a/src/Settei/Prelude.hs +++ b/src/Settei/Prelude.hs @@ -2,7 +2,19 @@ -- | -- Module: Settei.Prelude --- Description: Small shared project prelude and lens operator surface. +-- Description: Internal shared prelude for the settei package family. +-- +-- __Internal to the settei package family — not part of the PVP-stable API.__ +-- +-- This module exists so that the settei core, its sibling adapter packages, +-- and the reference applications share one import baseline. It re-exports +-- the full "Control.Lens" surface (hiding the lens @Setting@ type alias, +-- which collides with Settei's own 'Settei.Setting.Setting') together with +-- "Prelude" and a few common types. Because its exports track the @lens@ +-- package, they may change in any settei release, including patch releases. +-- Code outside this repository must not import this module; the supported +-- adoption surface is listed in the compatibility matrix +-- (@docs/compatibility.md@ in the source distribution). module Settei.Prelude ( module X, module Control.Lens, diff --git a/src/Settei/Provenance.hs b/src/Settei/Provenance.hs --- a/src/Settei/Provenance.hs +++ b/src/Settei/Provenance.hs @@ -8,6 +8,7 @@ candidateOrigin, candidateValue, derivedReportedValue, + redactReportedValue, renderReportedValue, reportedValue, visibleReportedValue, @@ -59,6 +60,10 @@ reportedValue Public = VisibleValue . renderRawValue reportedValue Secret = const RedactedValue +-- | Collapse any retained display representation to the redaction marker. +redactReportedValue :: ReportedValue -> ReportedValue +redactReportedValue _ = RedactedValue + -- | Render a retained value. A redacted value has no recovery path. renderReportedValue :: ReportedValue -> Text renderReportedValue (VisibleValue value) = value @@ -83,9 +88,12 @@ RawNumber value | Ratio.denominator value == 1 -> Text.pack (show (Ratio.numerator value)) | otherwise -> - Text.pack (show (Ratio.numerator value)) - <> "/" - <> Text.pack (show (Ratio.denominator value)) + case renderDecimal value of + Just decimal -> decimal + Nothing -> + Text.pack (show (Ratio.numerator value)) + <> "/" + <> Text.pack (show (Ratio.denominator value)) RawArray values -> "[" <> Text.intercalate ", " (fmap renderRawValue values) <> "]" RawObject values -> "{" @@ -95,6 +103,30 @@ | (key, value) <- Map.toAscList values ] <> "}" + +renderDecimal :: Rational -> Maybe Text +renderDecimal value = + let numerator = Ratio.numerator value + denominator = Ratio.denominator value + (twos, afterTwos) = countFactor 2 denominator + (fives, residual) = countFactor 5 afterTwos + in if residual /= 1 + then Nothing + else + let scale = max twos fives + scaled = abs numerator * (10 ^ scale) `quot` denominator + digits = Text.pack (show scaled) + padded = Text.replicate (max 0 (scale + 1 - Text.length digits)) "0" <> digits + (whole, fractional) = Text.splitAt (Text.length padded - scale) padded + sign = if numerator < 0 then "-" else "" + in Just (sign <> whole <> "." <> fractional) + +countFactor :: Integer -> Integer -> (Int, Integer) +countFactor factor = go 0 + where + go count remaining + | remaining `rem` factor == 0 = go (count + 1) (remaining `quot` factor) + | otherwise = (count, remaining) escapeText :: Text -> Text escapeText = diff --git a/src/Settei/Render.hs b/src/Settei/Render.hs --- a/src/Settei/Render.hs +++ b/src/Settei/Render.hs @@ -64,7 +64,7 @@ <> commaKeys (Set.toAscList (conditionSettings condition)) ] --- | Render one successful resolution, including skipped settings and branch decisions. +-- | Render one resolution attempt, including skipped settings and branch decisions. renderResolutionText :: ResolutionReport -> Text renderResolutionText report = Text.concat (fmap (renderNodeText report) (reportNodes report)) @@ -161,6 +161,10 @@ <> maybe "" (<> "/") (origin ^. #annotations . at "kubernetes.namespace") <> objectName <> maybe "" (" key " <>) (origin ^. #annotations . at "kubernetes.object-key") + <> maybe + "" + (\modified -> " (modified " <> modified <> ")") + (origin ^. #annotations . at "kubernetes.file-modified") _ -> "" -- | Render structured failures without access to rejected secret values. @@ -199,6 +203,9 @@ DefaultCycle problem -> "default cycle: " <> Text.intercalate " -> " (fmap renderRuleName (NonEmpty.toList (problem ^. #rules))) + SensitivityConflict problem -> + renderKey (problem ^. #key) + <> ": declared with both public and secret sensitivity; treated as secret" -- | Render non-fatal diagnostics in deterministic source and key order. renderWarningsText :: [ConfigWarning] -> Text @@ -237,7 +244,7 @@ ("settings", jsonKeyArray (Set.toAscList (conditionSettings condition))) ] --- | Render a successful resolution as versioned deterministic JSON. +-- | Render a resolution attempt as versioned deterministic JSON. renderResolutionJson :: ResolutionReport -> Text renderResolutionJson report = versionedJson @@ -340,6 +347,11 @@ jsonObject [ ("kind", jsonString "default-cycle"), ("rules", jsonArray (fmap (jsonString . renderRuleName) (NonEmpty.toList (problem ^. #rules)))) + ] + SensitivityConflict problem -> + jsonObject + [ ("kind", jsonString "sensitivity-conflict"), + ("key", jsonString (renderKey (problem ^. #key))) ] -- | Render warnings as a versioned deterministic JSON document. diff --git a/src/Settei/Report.hs b/src/Settei/Report.hs --- a/src/Settei/Report.hs +++ b/src/Settei/Report.hs @@ -54,7 +54,7 @@ } deriving stock (Generic, Eq, Show) --- | Complete, secret-safe trace for one successful resolution. +-- | Complete, secret-safe trace for one resolution attempt. data ResolutionReport = ResolutionReport { nodes :: !(Map Key ResolutionNode), branches :: ![BranchTrace] diff --git a/src/Settei/Resolve.hs b/src/Settei/Resolve.hs --- a/src/Settei/Resolve.hs +++ b/src/Settei/Resolve.hs @@ -15,6 +15,8 @@ import Data.Generics.Labels () import Data.List.NonEmpty qualified as NonEmpty import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe) +import Data.Set qualified as Set import Settei.Error import Settei.Internal.Config ( Config (..), @@ -24,7 +26,7 @@ describeConfig, renderRuleName, ) -import Settei.Internal.Schema (Schema) +import Settei.Internal.Schema (Schema, mergeSensitivity) import Settei.Key (Key, keySegments) import Settei.Origin (Origin (..), SourceKind (DerivedSource)) import Settei.Prelude @@ -34,6 +36,7 @@ candidateOrigin, candidateValue, derivedReportedValue, + redactReportedValue, reportedValue, visibleReportedValue, ) @@ -65,9 +68,11 @@ } deriving stock (Generic, Eq, Show) --- | The typed result plus its safe explanation and non-fatal diagnostics. +-- | The outcome of one resolution attempt. The provenance report and non-fatal +-- warnings are always present; the typed value or accumulated errors live in +-- 'answer'. data ResolveResult a = ResolveResult - { value :: !a, + { answer :: !(Either (NonEmpty ConfigError) a), report :: !ResolutionReport, warnings :: ![ConfigWarning] } @@ -81,29 +86,50 @@ -- -- Each request chooses its rightmost candidate and decodes it exactly once. Independent -- applicative errors accumulate in declaration order; selective branches evaluate only --- the branch selected by their resolved selector. -resolve :: ResolveOptions -> [Source] -> Config a -> Either (NonEmpty ConfigError) (ResolveResult a) +-- the branch selected by their resolved selector. The report and warnings are returned +-- on both success and failure. Validation failures that happen before evaluation return +-- a schema-shaped report of not-selected nodes with no branch traces; default-cycle +-- failures additionally return no warnings and do not inspect any source. +resolve :: ResolveOptions -> [Source] -> Config a -> ResolveResult a resolve options sources config = case NonEmpty.nonEmpty (validateDefaultCycles config) of - Just errors -> Left errors - Nothing -> resolveValidated + Just errors -> + ResolveResult + { answer = Left errors, + report = ResolutionReport {nodes = cycleSchemaNodes config, branches = []}, + warnings = [] + } + Nothing -> case NonEmpty.nonEmpty (validateSensitivityConflicts schemaSettings) of + Just errors -> preEvaluationFailure errors + Nothing -> resolveValidated where resolveValidated = case NonEmpty.nonEmpty structuralErrors of - Just errors -> Left errors + Just errors -> preEvaluationFailure errors Nothing -> - case appendErrors (evaluation ^. #answer) strictUnknownErrors of - Left errors -> Left (toNonEmpty errors) - Right value -> - Right - ResolveResult - { value, - report = ResolutionReport {nodes = completeNodes, branches = evaluation ^. #branches}, - warnings = unknownWarnings - } + ResolveResult + { answer = + case appendErrors (evaluation ^. #answer) strictUnknownErrors of + Left errors -> Left (toNonEmpty errors) + Right value -> Right value, + report = ResolutionReport {nodes = completeNodes, branches = evaluation ^. #branches}, + warnings = unknownWarnings + } + preEvaluationFailure errors = + ResolveResult + { answer = Left errors, + report = ResolutionReport {nodes = schemaOnlyNodes, branches = []}, + warnings = unknownWarnings + } schemaSettings = schemaPossible (describeEvaluation config) + schemaOnlyNodes = addNotSelected schemaSettings Map.empty + sensitivities = + Map.fromList + [ (schemaSettingKey schemaSetting, schemaSettingSensitivity schemaSetting) + | schemaSetting <- schemaSettings + ] structuralErrors = validateStructure schemaSettings sources - evaluation = evaluate sources config + evaluation = evaluate sensitivities sources config unknownProblems = findUnknownKeys schemaSettings sources unknownWarnings = case options ^. #unknownKeyPolicy of WarnUnknownKeys -> fmap UnknownKeyWarning unknownProblems @@ -113,6 +139,65 @@ RejectUnknownKeys -> errorsOnly (fmap UnknownKeyError unknownProblems) completeNodes = addNotSelected schemaSettings (evaluation ^. #nodes) +-- | Build the not-selected skeleton for a default-cycle failure without calling +-- 'describeEvaluation'. Static schema construction follows default dependencies and +-- therefore cannot terminate for the cyclic declaration this path is reporting. +cycleSchemaNodes :: Config a -> Map Key ResolutionNode +cycleSchemaNodes = Map.mapWithKey notSelectedNode . cycleSettings [] + where + cycleSettings :: [RuleName] -> Config b -> Map Key Sensitivity + cycleSettings active = \case + PureConfig _ -> Map.empty + MapConfig _ declaration -> cycleSettings active declaration + ApplyConfig function inputConfig -> + Map.unionWith + mergeSensitivity + (cycleSettings active function) + (cycleSettings active inputConfig) + RequestConfig request -> case request of + RequiredRequest settingSpec -> oneSetting settingSpec + OptionalRequest settingSpec -> oneSetting settingSpec + DefaultConfig settingSpec defaultSpec -> + Map.unionWith + mergeSensitivity + (oneSetting settingSpec) + (defaultSettings active defaultSpec) + SelectConfig selector branch -> + Map.unionWith + mergeSensitivity + (cycleSettings active selector) + (cycleSettings active branch) + + defaultSettings :: [RuleName] -> Default b -> Map Key Sensitivity + defaultSettings active defaultSpec + | rule `elem` active = Map.empty + | otherwise = case defaultSpec of + ConstantDefault _ _ _ -> Map.empty + DerivedDefault _ _ dependency _ -> cycleSettings (active <> [rule]) dependency + CaseDefault _ _ dependency _ _ -> cycleSettings (active <> [rule]) dependency + where + rule = defaultRule defaultSpec + + oneSetting settingSpec = + Map.singleton (settingKey settingSpec) (settingSensitivity settingSpec) + + notSelectedNode key sensitivity = + ResolutionNode + { key, + sensitivity, + outcome = NotSelected, + origin = Nothing, + shadowed = [], + derivation = Nothing + } + +validateSensitivityConflicts :: [SchemaSetting] -> [ConfigError] +validateSensitivityConflicts schemaSettings = + [ SensitivityConflict (SensitivityConflictProblem {key = schemaSettingKey schemaSetting}) + | schemaSetting <- schemaSettings, + Set.size (schemaSetting ^. #declaredSensitivities) > 1 + ] + validateStructure :: [SchemaSetting] -> [Source] -> [ConfigError] validateStructure schemaSettings sources = unique @@ -169,17 +254,19 @@ } deriving stock (Generic) -evaluate :: [Source] -> Config a -> Evaluation a -evaluate sources = \case +evaluate :: Map Key Sensitivity -> [Source] -> Config a -> Evaluation a +evaluate sensitivities sources = \case PureConfig value -> successful value - MapConfig mapValue config -> mapEvaluation mapValue (evaluate sources config) + MapConfig mapValue config -> mapEvaluation mapValue (evaluate sensitivities sources config) ApplyConfig function inputConfig -> - applyEvaluation (evaluate sources function) (evaluate sources inputConfig) - RequestConfig request -> evaluateRequest sources request + applyEvaluation + (evaluate sensitivities sources function) + (evaluate sensitivities sources inputConfig) + RequestConfig request -> evaluateRequest sensitivities sources request DefaultConfig settingSpec defaultSpec -> - evaluateDefaultRequest sources settingSpec defaultSpec + evaluateDefaultRequest sensitivities sources settingSpec defaultSpec SelectConfig selector branch -> - let selectorEvaluation = evaluate sources selector + let selectorEvaluation = evaluate sensitivities sources selector selectorKeys = Map.keys (selectorEvaluation ^. #nodes) branchKeys = fmap schemaSettingKey (schemaPossible (describeEvaluation branch)) in case selectorEvaluation ^. #answer of @@ -191,11 +278,15 @@ & #branches %~ (<> [BranchTrace {dependencies = selectorKeys, settings = branchKeys, selected = False}]) Right (Left input) -> - let branchEvaluation = evaluate sources branch + let branchEvaluation = evaluate sensitivities sources branch combined = mapEvaluation ($ input) branchEvaluation in Evaluation { answer = combined ^. #answer, - nodes = Map.union (selectorEvaluation ^. #nodes) (branchEvaluation ^. #nodes), + nodes = + Map.unionWith + mergeNodes + (selectorEvaluation ^. #nodes) + (branchEvaluation ^. #nodes), branches = selectorEvaluation ^. #branches <> branchEvaluation ^. #branches @@ -207,10 +298,10 @@ describeEvaluation :: Config a -> Schema describeEvaluation = describeConfig -evaluateRequest :: [Source] -> Request a -> Evaluation a -evaluateRequest sources = \case +evaluateRequest :: Map Key Sensitivity -> [Source] -> Request a -> Evaluation a +evaluateRequest sensitivities sources = \case RequiredRequest settingSpec -> - case evaluateSetting sources settingSpec of + case evaluateSetting sensitivities sources settingSpec of SettingAbsent node -> failed [MissingRequired (MissingProblem {key = settingKey settingSpec})] @@ -218,44 +309,57 @@ SettingFailed errors node -> failed errors (Map.singleton (settingKey settingSpec) node) SettingPresent value node -> withNode value node OptionalRequest settingSpec -> - case evaluateSetting sources settingSpec of + case evaluateSetting sensitivities sources settingSpec of SettingAbsent node -> withNode Nothing node SettingFailed errors node -> failed errors (Map.singleton (settingKey settingSpec) node) SettingPresent value node -> withNode (Just value) node -evaluateDefaultRequest :: [Source] -> Setting a -> Default a -> Evaluation a -evaluateDefaultRequest sources settingSpec defaultSpec = - case evaluateSetting sources settingSpec of +evaluateDefaultRequest :: Map Key Sensitivity -> [Source] -> Setting a -> Default a -> Evaluation a +evaluateDefaultRequest sensitivities sources settingSpec defaultSpec = + case evaluateSetting sensitivities sources settingSpec of SettingFailed errors node -> failed errors (Map.singleton (settingKey settingSpec) node) SettingPresent value node -> withNode value node - SettingAbsent _ -> evaluateFallback sources settingSpec defaultSpec + SettingAbsent _ -> evaluateFallback sensitivities sources settingSpec defaultSpec -evaluateFallback :: [Source] -> Setting a -> Default a -> Evaluation a -evaluateFallback sources settingSpec = \case +evaluateFallback :: Map Key Sensitivity -> [Source] -> Setting a -> Default a -> Evaluation a +evaluateFallback sensitivities sources settingSpec = \case ConstantDefault rule explanation value -> - derivedEvaluation settingSpec rule explanation [] value + derivedEvaluation sensitivities settingSpec rule explanation [] value DerivedDefault rule explanation dependency derive -> - let dependencyEvaluation = evaluate sources dependency + let dependencyEvaluation = evaluate sensitivities sources dependency in case dependencyEvaluation ^. #answer of Left errors -> evaluationFailure dependencyEvaluation errors Right dependencyValue -> derivedFromDependencies + sensitivities settingSpec rule explanation dependencyEvaluation (derive dependencyValue) CaseDefault rule explanation dependency choices fallback -> - let dependencyEvaluation = evaluate sources dependency + let dependencyEvaluation = evaluate sensitivities sources dependency in case dependencyEvaluation ^. #answer of Left errors -> evaluationFailure dependencyEvaluation errors Right dependencyValue -> case lookup dependencyValue (NonEmpty.toList choices) of Just value -> - derivedFromDependencies settingSpec rule explanation dependencyEvaluation value + derivedFromDependencies + sensitivities + settingSpec + rule + explanation + dependencyEvaluation + value Nothing -> case fallback of Just value -> - derivedFromDependencies settingSpec rule explanation dependencyEvaluation value + derivedFromDependencies + sensitivities + settingSpec + rule + explanation + dependencyEvaluation + value Nothing -> evaluationFailure dependencyEvaluation @@ -268,35 +372,36 @@ ] derivedFromDependencies :: + Map Key Sensitivity -> Setting a -> RuleName -> Text -> Evaluation d -> a -> Evaluation a -derivedFromDependencies settingSpec rule explanation dependencyEvaluation value = +derivedFromDependencies sensitivities settingSpec rule explanation dependencyEvaluation value = Evaluation { answer = Right value, nodes = dependencyEvaluation ^. #nodes & at (settingKey settingSpec) - ?~ derivedNode settingSpec rule explanation dependencyKeys value, + ?~ derivedNode sensitivities settingSpec rule explanation dependencyKeys value, branches = dependencyEvaluation ^. #branches } where dependencyKeys = Map.keys (dependencyEvaluation ^. #nodes) -derivedEvaluation :: Setting a -> RuleName -> Text -> [Key] -> a -> Evaluation a -derivedEvaluation settingSpec rule explanation dependencies value = - withNode value (derivedNode settingSpec rule explanation dependencies value) +derivedEvaluation :: Map Key Sensitivity -> Setting a -> RuleName -> Text -> [Key] -> a -> Evaluation a +derivedEvaluation sensitivities settingSpec rule explanation dependencies value = + withNode value (derivedNode sensitivities settingSpec rule explanation dependencies value) -derivedNode :: Setting a -> RuleName -> Text -> [Key] -> a -> ResolutionNode -derivedNode settingSpec rule explanation dependencies value = +derivedNode :: Map Key Sensitivity -> Setting a -> RuleName -> Text -> [Key] -> a -> ResolutionNode +derivedNode sensitivities settingSpec rule explanation dependencies value = ResolutionNode { key = settingKey settingSpec, - sensitivity = settingSensitivity settingSpec, - outcome = Resolved (defaultReportedValue settingSpec value), + sensitivity = effectiveSensitivity sensitivities settingSpec, + outcome = Resolved (defaultReportedValue sensitivities settingSpec value), origin = Just Origin @@ -310,9 +415,9 @@ derivation = Just Derivation {rule = renderRuleName rule, explanation, dependencies} } -defaultReportedValue :: Setting a -> a -> ReportedValue -defaultReportedValue settingSpec value = - case settingSensitivity settingSpec of +defaultReportedValue :: Map Key Sensitivity -> Setting a -> a -> ReportedValue +defaultReportedValue sensitivities settingSpec value = + case effectiveSensitivity sensitivities settingSpec of Secret -> derivedReportedValue Secret Public -> case settingValueRenderer settingSpec of Just renderValue -> visibleReportedValue (renderValue value) @@ -331,14 +436,14 @@ | SettingFailed ![ConfigError] !ResolutionNode | SettingPresent a !ResolutionNode -evaluateSetting :: [Source] -> Setting a -> SettingEvaluation a -evaluateSetting sources settingSpec = +evaluateSetting :: Map Key Sensitivity -> [Source] -> Setting a -> SettingEvaluation a +evaluateSetting sensitivities sources settingSpec = case collectCandidates (settingKey settingSpec) sources of Left structuralErrors -> SettingFailed (fmap StructuralConflict structuralErrors) - (missingNode settingSpec) - Right [] -> SettingAbsent (missingNode settingSpec) + (missingNode sensitivities settingSpec) + Right [] -> SettingAbsent (missingNode sensitivities settingSpec) Right candidates -> let winner = last candidates lower = init candidates @@ -346,8 +451,8 @@ node = ResolutionNode { key = settingKey settingSpec, - sensitivity = settingSensitivity settingSpec, - outcome = Resolved (reportedValue (settingSensitivity settingSpec) rawValue), + sensitivity, + outcome = Resolved (reportedValue sensitivity rawValue), origin = Just (candidateOrigin winner), shadowed = fmap candidateOrigin (reverse lower), derivation = Nothing @@ -360,12 +465,23 @@ { key = settingKey settingSpec, expected = decodeFailureExpected decodeFailure, origin = candidateOrigin winner, - rejected = reportedValue (settingSensitivity settingSpec) rawValue + rejected = reportedValue sensitivity rawValue } ] node Right value -> SettingPresent value node + where + sensitivity = effectiveSensitivity sensitivities settingSpec +effectiveSensitivity :: Map Key Sensitivity -> Setting a -> Sensitivity +effectiveSensitivity sensitivities settingSpec = + mergeSensitivity + (settingSensitivity settingSpec) + ( fromMaybe + (settingSensitivity settingSpec) + (Map.lookup (settingKey settingSpec) sensitivities) + ) + collectCandidates :: Key -> [Source] -> Either [StructuralError] [Candidate] collectCandidates key sources = case foldr collect ([], []) (fmap (lookupSource key) sources) of @@ -377,11 +493,11 @@ collect (Right (Just foundCandidate)) (errors, candidates) = (errors, foundCandidate : candidates) -missingNode :: Setting a -> ResolutionNode -missingNode settingSpec = +missingNode :: Map Key Sensitivity -> Setting a -> ResolutionNode +missingNode sensitivities settingSpec = ResolutionNode { key = settingKey settingSpec, - sensitivity = settingSensitivity settingSpec, + sensitivity = effectiveSensitivity sensitivities settingSpec, outcome = MissingValue, origin = Nothing, shadowed = [], @@ -409,9 +525,24 @@ applyEvaluation function inputConfig = Evaluation { answer = applyAnswer (function ^. #answer) (inputConfig ^. #answer), - nodes = Map.union (function ^. #nodes) (inputConfig ^. #nodes), + nodes = Map.unionWith mergeNodes (function ^. #nodes) (inputConfig ^. #nodes), branches = function ^. #branches <> inputConfig ^. #branches } + +mergeNodes :: ResolutionNode -> ResolutionNode -> ResolutionNode +mergeNodes left right + | left ^. #sensitivity == Secret || right ^. #sensitivity == Secret = + left + & #sensitivity + .~ Secret + & #outcome + %~ redactOutcome + | otherwise = left + +redactOutcome :: ResolutionOutcome -> ResolutionOutcome +redactOutcome = \case + Resolved value -> Resolved (redactReportedValue value) + outcome -> outcome applyAnswer :: Either [ConfigError] (a -> b) -> Either [ConfigError] a -> Either [ConfigError] b applyAnswer (Right function) (Right value) = Right (function value) diff --git a/src/Settei/Setting.hs b/src/Settei/Setting.hs --- a/src/Settei/Setting.hs +++ b/src/Settei/Setting.hs @@ -5,6 +5,7 @@ ( Sensitivity (..), Setting, decodeSetting, + publicShowSetting, publicSetting, publicSettingWithRenderer, secretSetting, @@ -12,10 +13,12 @@ settingKey, settingSensitivity, settingValueRenderer, + withRenderer, ) where import Data.Generics.Labels () +import Data.Text qualified as Text import Settei.Key (Key) import Settei.Prelude import Settei.Value (DecodeFailure, Decoder, RawValue, runDecoder) @@ -51,10 +54,27 @@ publicSettingWithRenderer key description decoder renderer = Setting {key, description, sensitivity = Public, decoder, renderer = Just renderer} +-- | Declare a public setting whose typed default values render via 'show'. +-- +-- Equivalent to 'publicSettingWithRenderer' with @Text.pack . show@. Best for primitive +-- and enum-like types; a derived 'Show' of a rich type may be ugly in reports but is +-- never unsafe, because renderers only affect display of typed defaults and secret +-- settings always redact regardless of any renderer. +publicShowSetting :: (Show a) => Key -> Text -> Decoder a -> Setting a +publicShowSetting key description decoder = + publicSettingWithRenderer key description decoder (Text.pack . show) + -- | Declare a setting whose resolved value must be redacted from reports. secretSetting :: Key -> Text -> Decoder a -> Setting a secretSetting key description decoder = Setting {key, description, sensitivity = Secret, decoder, renderer = Nothing} + +-- | Attach or replace the typed-default renderer of an existing setting. +-- +-- On a secret setting this is harmless: the stored renderer is ignored and reports keep +-- showing the redaction marker (see "Settei.Resolve"). +withRenderer :: (a -> Text) -> Setting a -> Setting a +withRenderer renderValue settingSpec = settingSpec & #renderer ?~ renderValue -- | Decode one raw candidate using the setting's validated key. decodeSetting :: Setting a -> RawValue -> Either DecodeFailure a diff --git a/src/Settei/Source.hs b/src/Settei/Source.hs --- a/src/Settei/Source.hs +++ b/src/Settei/Source.hs @@ -5,15 +5,18 @@ -- Description: Ordered, hierarchical configuration inputs. module Settei.Source ( Source, + SourceConstructionError (..), annotateSource, annotateSourceAt, locateSource, lookupSource, source, sourceAnnotations, + sourceFromPairs, sourceKind, sourceLeaves, sourceName, + sourceUnaddressableLeaves, ) where @@ -40,7 +43,21 @@ } deriving stock (Generic) +-- | Why a list of key/value pairs cannot form one addressable source tree. +data SourceConstructionError + = -- | The same key appears more than once. + DuplicateSourceKey !Key + | -- | One key is a structural prefix of another, so one leaf would sit + -- inside the object the other needs to traverse. + OverlappingSourceKeys !Key !Key + deriving stock (Generic, Eq, Show) + -- | Construct a source with no retained locations or annotations. +-- +-- This function performs no validation. Leaves below object keys that are empty or +-- contain dots cannot be addressed by 'lookupSource' and are silently absent from +-- 'sourceLeaves'. Prefer 'sourceFromPairs' for hand-built sources; this function is the +-- unvalidated escape hatch used by adapters that already guarantee valid trees. source :: Text -> SourceKind -> RawValue -> Source source name kind root = Source @@ -52,9 +69,46 @@ annotations = Map.empty } +-- | Build a source from validated keys, rejecting duplicates and prefix overlaps. +-- +-- Every leaf of the result is addressable by 'lookupSource' and enumerated by +-- 'sourceLeaves'. This is the recommended constructor for hand-built sources; 'source' +-- is the unvalidated escape hatch. +sourceFromPairs :: + Text -> + SourceKind -> + [(Key, RawValue)] -> + Either (NonEmpty SourceConstructionError) Source +sourceFromPairs name kind pairs = + case NonEmpty.nonEmpty constructionErrors of + Just errors -> Left errors + Nothing -> + Right + ( source + name + kind + (foldl (\rootValue (key, value) -> insertRawValue key value rootValue) (RawObject Map.empty) pairs) + ) + where + keys = fmap fst pairs + duplicateErrors = fmap DuplicateSourceKey (duplicates keys) + overlapErrors = + [ OverlappingSourceKeys lower higher + | (positionIndex, lower) <- zip [0 :: Int ..] keys, + higher <- drop (positionIndex + 1) keys, + lower /= higher, + isPrefixKey lower higher || isPrefixKey higher lower + ] + constructionErrors = duplicateErrors <> overlapErrors + -- | Attach adapter-specific descriptive metadata. It never changes precedence. +-- +-- Repeated calls merge: annotations from a later call win when the same annotation +-- name is already present, and entries under other names are retained. Per-key +-- annotations from 'annotateSourceAt' still take precedence over source-wide entries. annotateSource :: Map Text Text -> Source -> Source -annotateSource annotations sourceValue = sourceValue & #annotations .~ annotations +annotateSource annotations sourceValue = + sourceValue & #annotations %~ (annotations <>) -- | Attach descriptive metadata for individual keys. -- @@ -112,7 +166,11 @@ -- | Enumerate addressable leaves in key order for unknown-key diagnostics. -- --- Arrays and scalars are whole leaves. Empty objects contain no leaves. +-- Arrays and scalars are whole leaves. Empty objects contain no leaves. Sources created +-- through the unvalidated 'source' escape hatch may contain leaves below empty or dotted +-- object keys; those leaves cannot form a 'Key' and are silently absent here. Prefer +-- 'sourceFromPairs' for hand-built sources and use 'sourceUnaddressableLeaves' to inspect +-- an existing source. sourceLeaves :: Source -> [(Key, Candidate)] sourceLeaves sourceValue = go [] (sourceValue ^. #root) where @@ -126,6 +184,55 @@ Just segments -> case mkKey segments of Left _ -> [] Right key -> [(key, candidate rawValue (originFor key sourceValue))] + +-- | Return the raw segment paths of leaves that no 'Key' can address. +-- +-- A non-empty result means the source was built by hand with object keys that are empty +-- or contain dots; such leaves are invisible to 'lookupSource', 'sourceLeaves', and +-- unknown-key diagnostics. Only key paths are returned; raw values are never exposed +-- because they may be secret. A scalar at the root has an empty path and is excluded. +sourceUnaddressableLeaves :: Source -> [[Text]] +sourceUnaddressableLeaves sourceValue = go [] (sourceValue ^. #root) + where + go prefix = \case + RawObject object -> + concatMap + (\(segment, rawValue) -> go (prefix <> [segment]) rawValue) + (Map.toAscList object) + _ -> case NonEmpty.nonEmpty prefix of + Nothing -> [] + Just segments -> case mkKey segments of + Left _ -> [prefix] + Right _ -> [] + +duplicates :: (Ord a) => [a] -> [a] +duplicates values = + Map.keys (Map.filter (> (1 :: Int)) (Map.fromListWith (+) [(value, 1) | value <- values])) + +isPrefixKey :: Key -> Key -> Bool +isPrefixKey prefix candidateKey = + NonEmpty.toList (keySegments prefix) + `isListPrefixOf` NonEmpty.toList (keySegments candidateKey) + +isListPrefixOf :: (Eq a) => [a] -> [a] -> Bool +isListPrefixOf [] _ = True +isListPrefixOf _ [] = False +isListPrefixOf (left : leftRest) (right : rightRest) = + left == right && isListPrefixOf leftRest rightRest + +insertRawValue :: Key -> RawValue -> RawValue -> RawValue +insertRawValue key value = go (NonEmpty.toList (keySegments key)) + where + go [] _ = value + go (segment : rest) (RawObject object) = + RawObject + ( object + & at segment + %~ Just + . go rest + . maybe (RawObject Map.empty) id + ) + go _ _ = error "validated source keys cannot overlap" originFor :: Key -> Source -> Origin originFor key sourceValue = diff --git a/src/Settei/Value.hs b/src/Settei/Value.hs --- a/src/Settei/Value.hs +++ b/src/Settei/Value.hs @@ -7,10 +7,15 @@ Decoder, boolDecoder, boundedIntegralDecoder, + doubleDecoder, enumDecoder, decodeFailure, decodeFailureExpected, decoder, + listDecoder, + nonEmptyDecoder, + parsedDecoder, + rationalDecoder, renderDecodeFailure, runDecoder, textDecoder, @@ -52,6 +57,16 @@ } deriving stock (Generic) +-- | Mapping transforms only a successfully decoded result; failures pass +-- through unchanged. +-- +-- The instance is lawful: 'fmap' merely post-composes over the 'Either' +-- result of the wrapped function, so identity and composition follow +-- directly from the 'Functor' laws of @'Either' 'DecodeFailure'@ and of +-- functions. +instance Functor Decoder where + fmap f (Decoder run) = Decoder (\key raw -> fmap f (run key raw)) + -- | Construct a decoder whose failures carry only safe expectation metadata. decoder :: (Key -> RawValue -> Either DecodeFailure a) -> Decoder a decoder decode = Decoder {decode} @@ -84,17 +99,98 @@ _ -> failure key "boolean" _ -> failure key "boolean" +-- | Decode an array by applying the element decoder to every element. +-- +-- Elements are decoded left to right and the first failing element stops +-- decoding. An element failure keeps the owning setting key (arrays are +-- whole values at one key) and wraps the element's expectation as +-- @\"an array of \\"@; a non-array input fails with +-- @\"an array\"@. Failures carry only expectation text, never the +-- rejected raw value. +listDecoder :: Decoder a -> Decoder [a] +listDecoder elementDecoder = Decoder $ \key -> \case + RawArray values -> + traverse (runDecoder elementDecoder key) values + & _Left + . #expected + %~ ("an array of " <>) + _ -> failure key "an array" + +-- | Decode a non-empty array with the element decoder. +-- +-- An empty array -- and any non-array input -- fails with +-- @\"a non-empty array\"@; a failing element wraps its expectation as +-- @\"a non-empty array of \\"@. +nonEmptyDecoder :: Decoder a -> Decoder (NonEmpty a) +nonEmptyDecoder elementDecoder = Decoder $ \key -> \case + RawArray (firstValue : rest) -> + traverse (runDecoder elementDecoder key) (firstValue :| rest) + & _Left + . #expected + %~ ("a non-empty array of " <>) + _ -> failure key "a non-empty array" + +-- | Decode a text scalar through a caller-supplied parser. +-- +-- The first argument is the safe expectation description reported on any +-- failure, for example @\"an absolute URI\"@ or @\"a duration such as 30s\"@. +-- The parser's own error message is deliberately discarded: parser messages +-- routinely echo the offending input, and decode failures must never retain +-- the raw value. Non-text inputs fail with the same description. +parsedDecoder :: Text -> (Text -> Either Text a) -> Decoder a +parsedDecoder expected parse = Decoder $ \key -> \case + RawText value -> case parse value of + Right parsed -> Right parsed + Left _ -> failure key expected + _ -> failure key expected + +-- | Decode an exact rational number. +-- +-- Accepts a native number or, for environment-variable and command-line +-- friendliness, a textual number such as @\"2.5\"@, @\"-3\"@, or @\"1e-3\"@ +-- (mirroring how 'boundedIntegralDecoder' accepts textual integers). +-- Decimal text converts exactly; no rounding occurs. +rationalDecoder :: Decoder Rational +rationalDecoder = Decoder $ \key value -> + maybe (failure key "a number") Right (numberValue value) + +-- | Decode an IEEE double-precision number. +-- +-- Equivalent to @'fromRational' \<\$\> 'rationalDecoder'@: the exact source +-- value is rounded to the nearest representable 'Double'. That rounding is +-- acceptable for configuration values such as timeouts and ratios; use +-- 'rationalDecoder' or 'boundedIntegralDecoder' when exactness matters. +doubleDecoder :: Decoder Double +doubleDecoder = fromRational <$> rationalDecoder + -- | Decode a whole number that fits the requested bounded integral type. +-- +-- Accepts a native whole number or a textual integer. Failures state the +-- accepted range, for example @\"integer between -32768 and 32767\"@. boundedIntegralDecoder :: forall a. (Bounded a, Integral a) => Decoder a boundedIntegralDecoder = Decoder $ \key value -> case integralValue value of Just candidate - | candidate >= toInteger (minBound @a) - && candidate <= toInteger (maxBound @a) -> - Right (fromInteger candidate) - _ -> failure key "bounded integer" + | candidate >= lower && candidate <= upper -> Right (fromInteger candidate) + _ -> failure key expectedRange + where + lower = toInteger (minBound @a) + upper = toInteger (maxBound @a) + expectedRange = + "integer between " + <> Text.pack (show lower) + <> " and " + <> Text.pack (show upper) -- | Decode one of a finite set of exact text spellings. +-- +-- Matching is case-sensitive: @\"Production\"@ does not match a declared +-- @\"production\"@ choice. This is deliberate -- enumeration spellings are +-- part of an application's configuration vocabulary. Note the asymmetry +-- with 'boolDecoder', which case-folds its textual @true@/@false@ forms +-- for environment-variable convention; enumerations do not follow it. +-- Applications wanting case-insensitive enumerations can normalize input +-- via 'parsedDecoder'. enumDecoder :: [(Text, a)] -> Decoder a enumDecoder choices = Decoder $ \key -> \case RawText value -> @@ -122,6 +218,15 @@ RawNumber value | Ratio.denominator value == 1 -> Just (Ratio.numerator value) RawText value -> case TextRead.signed TextRead.decimal value of + Right (candidate, rest) + | Text.null rest -> Just candidate + _ -> Nothing + _ -> Nothing + +numberValue :: RawValue -> Maybe Rational +numberValue = \case + RawNumber value -> Just value + RawText value -> case TextRead.rational value of Right (candidate, rest) | Text.null rest -> Just candidate _ -> Nothing diff --git a/test/Settei/ConfigTest.hs b/test/Settei/ConfigTest.hs --- a/test/Settei/ConfigTest.hs +++ b/test/Settei/ConfigTest.hs @@ -4,12 +4,13 @@ import Data.Bifunctor (first) import Data.Map.Strict qualified as Map import Data.Set qualified as Set +import Data.Text qualified as Text import Settei import Settei.Internal.Config (Request (..), runConfig) import Settei.Prelude import Settei.Prototype.Free (freeNecessaryKeys, freePossibleKeys) import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (testCase, (@?=)) +import Test.Tasty.HUnit (assertBool, testCase, (@?=)) tests :: TestTree tests = @@ -30,6 +31,23 @@ conditionDependencies condition @?= Set.singleton environmentKey conditionSettings condition @?= Set.singleton passwordKey conditions -> fail ("expected one condition, found " <> show (length conditions)), + testCase "whenEq matches the raw selective schema" $ do + let schema = describe sugaredProductionOnly + schema @?= describe productionOnly + assertProductionSchema schema, + testCase "whenConfig preserves the conditional schema footprint" $ + assertProductionSchema (describe whenConfigProductionOnly), + testCase "fallbackTo makes only the fallback key conditional" $ do + let schema = describe endpointWithFallback + keySet (schemaPossible schema) + @?= Set.fromList [serviceEndpointKey, serviceUrlKey] + keySet (schemaNecessary schema) + @?= Set.singleton serviceEndpointKey + case schemaConditions schema of + [condition] -> do + conditionDependencies condition @?= Set.singleton serviceEndpointKey + conditionSettings condition @?= Set.singleton serviceUrlKey + conditions -> fail ("expected one condition, found " <> show (length conditions)), testCase "free-selective prototype agrees on possible effects" $ Set.fromList (freePossibleKeys environmentKey passwordKey) @?= Set.fromList [environmentKey, passwordKey], @@ -41,7 +59,35 @@ @?= Right Nothing, testCase "production requests its secret" $ runConfig (interpret productionValues) productionOnly + @?= Left (Missing passwordKey), + testCase "whenEq skips, requires, and returns its conditional value" $ do + runConfig (interpret developmentValues) sugaredProductionOnly + @?= Right Nothing + runConfig (interpret productionValues) sugaredProductionOnly @?= Left (Missing passwordKey) + runConfig (interpret productionWithPasswordValues) sugaredProductionOnly + @?= Right (Just "fleet-secret"), + testCase "fallbackTo prefers the primary and otherwise evaluates the fallback" $ do + runConfig (interpret primaryEndpointValues) endpointWithFallback + @?= Right "new.example" + runConfig (interpret fallbackEndpointValues) endpointWithFallback + @?= Right "old.example" + runConfig (interpret Map.empty) endpointWithFallback + @?= Left (Missing serviceUrlKey), + testCase "duplicate sensitivity is secret-biased in either applicative order" $ do + schemaSettingSensitivity (schemaEntry passwordKey (describe secretThenPublic)) + @?= Secret + schemaSettingSensitivity (schemaEntry passwordKey (describe publicThenSecret)) + @?= Secret + let rendered = renderSchemaText (describe publicThenSecret) + assertBool "schema did not mark the duplicate key secret" ("secret" `Text.isInfixOf` rendered) + assertBool "schema marked the duplicate key public" (not ("public" `Text.isInfixOf` rendered)), + testCase "duplicate sensitivity is secret-biased through a selective branch" $ + schemaSettingSensitivity (schemaEntry passwordKey (describe selectiveDuplicate)) + @?= Secret, + testCase "duplicate sensitivity is secret-biased through a default dependency" $ + schemaSettingSensitivity (schemaEntry passwordKey (describe defaultDuplicate)) + @?= Secret ] data RuntimeError @@ -57,6 +103,45 @@ <$> required environmentSetting productionBranch = (\password _ -> Just password) <$> required passwordSetting +sugaredProductionOnly :: Config (Maybe Text) +sugaredProductionOnly = + whenEq (required environmentSetting) "production" (required passwordSetting) + +whenConfigProductionOnly :: Config (Maybe Text) +whenConfigProductionOnly = + whenConfig + ((== "production") <$> required environmentSetting) + (required passwordSetting) + +endpointWithFallback :: Config Text +endpointWithFallback = + optional endpointSetting `fallbackTo` required urlSetting + +secretThenPublic :: Config (Text, Text) +secretThenPublic = + (,) <$> required passwordSetting <*> required publicPasswordSetting + +publicThenSecret :: Config (Text, Text) +publicThenSecret = + (,) <$> required publicPasswordSetting <*> required passwordSetting + +selectiveDuplicate :: Config Text +selectiveDuplicate = + select + (Left <$> required passwordSetting) + (const <$> required publicPasswordSetting) + +defaultDuplicate :: Config Text +defaultDuplicate = + withDefault + passwordSetting + ( derivedDefault + (RuleName "password-from-public-duplicate") + "Exercise duplicate sensitivity in a default dependency" + (required publicPasswordSetting) + id + ) + interpret :: Map Key RawValue -> Request a -> Either RuntimeError a interpret values = \case RequiredRequest settingSpec -> @@ -74,6 +159,19 @@ productionValues :: Map Key RawValue productionValues = Map.singleton environmentKey (RawText "production") +productionWithPasswordValues :: Map Key RawValue +productionWithPasswordValues = + Map.fromList + [ (environmentKey, RawText "production"), + (passwordKey, RawText "fleet-secret") + ] + +primaryEndpointValues :: Map Key RawValue +primaryEndpointValues = Map.singleton serviceEndpointKey (RawText "new.example") + +fallbackEndpointValues :: Map Key RawValue +fallbackEndpointValues = Map.singleton serviceUrlKey (RawText "old.example") + environmentSetting :: Setting Text environmentSetting = publicSetting environmentKey "Runtime environment" textDecoder @@ -82,14 +180,50 @@ passwordSetting = secretSetting passwordKey "Database password" textDecoder +publicPasswordSetting :: Setting Text +publicPasswordSetting = + publicSetting passwordKey "Metrics password label" textDecoder + +endpointSetting :: Setting Text +endpointSetting = + publicSetting serviceEndpointKey "Service endpoint" textDecoder + +urlSetting :: Setting Text +urlSetting = + publicSetting serviceUrlKey "Legacy service URL" textDecoder + environmentKey :: Key environmentKey = validKey "runtime.environment" passwordKey :: Key passwordKey = validKey "database.password" +serviceEndpointKey :: Key +serviceEndpointKey = validKey "service.endpoint" + +serviceUrlKey :: Key +serviceUrlKey = validKey "service.url" + validKey :: Text -> Key validKey value = either (error . show) id (parseKey value) keySet :: [SchemaSetting] -> Set Key keySet = Set.fromList . fmap schemaSettingKey + +assertProductionSchema :: Schema -> IO () +assertProductionSchema schema = do + keySet (schemaPossible schema) + @?= Set.fromList [environmentKey, passwordKey] + keySet (schemaNecessary schema) + @?= Set.singleton environmentKey + case schemaConditions schema of + [condition] -> do + conditionDependencies condition @?= Set.singleton environmentKey + conditionSettings condition @?= Set.singleton passwordKey + conditions -> fail ("expected one condition, found " <> show (length conditions)) + +schemaEntry :: Key -> Schema -> SchemaSetting +schemaEntry key schema = + case filter ((== key) . schemaSettingKey) (schemaPossible schema) of + [entry] -> entry + entries -> error ("expected one schema entry, found " <> show (length entries)) diff --git a/test/Settei/DefaultTest.hs b/test/Settei/DefaultTest.hs --- a/test/Settei/DefaultTest.hs +++ b/test/Settei/DefaultTest.hs @@ -16,16 +16,18 @@ testGroup "Settei.Default" [ testCase "constant default resolves without a source" $ do - result <- expectSuccess (resolve defaultResolveOptions [] constantPort) - result ^. #value @?= 8080 + let result = resolve defaultResolveOptions [] constantPort + value <- expectAnswer result + value @?= 8080 case result ^. #report . #nodes . at servicePort of Just node -> do fmap (^. #name) (node ^. #origin) @?= Just "built-in-port" fmap (^. #rule) (node ^. #derivation) @?= Just "built-in-port" Nothing -> fail "expected a derived port node", testCase "production port records its environment dependency" $ do - result <- expectSuccess (resolve defaultResolveOptions [environmentSource Production] casePort) - result ^. #value @?= 443 + let result = resolve defaultResolveOptions [environmentSource Production] casePort + value <- expectAnswer result + value @?= 443 case result ^. #report . #nodes . at servicePort of Just node -> case node ^. #derivation of Just derivation -> do @@ -37,8 +39,9 @@ Nothing -> fail "expected default derivation metadata" Nothing -> fail "expected the port report node", testCase "an explicit target overrides and skips its default dependencies" $ do - result <- expectSuccess (resolve defaultResolveOptions [portSource 9443] casePort) - result ^. #value @?= 9443 + let result = resolve defaultResolveOptions [portSource 9443] casePort + value <- expectAnswer result + value @?= 9443 case result ^. #report . #nodes . at runtimeEnvironment of Just node -> node ^. #outcome @?= NotSelected Nothing -> fail "expected the skipped dependency in the report" @@ -46,7 +49,7 @@ Just node -> node ^. #derivation @?= Nothing Nothing -> fail "expected the explicit port node", testCase "an unmatched case without fallback is structured" $ do - case resolve defaultResolveOptions [environmentSource Staging] casePort of + case (resolve defaultResolveOptions [environmentSource Staging] casePort) ^. #answer of Left errors -> case NonEmpty.toList errors of [DefaultError problem] -> do problem ^. #key @?= servicePort @@ -64,8 +67,9 @@ ((Development, 8080) :| []) (Just 9000) ) - result <- expectSuccess (resolve defaultResolveOptions [environmentSource Staging] withFallback) - result ^. #value @?= 9000, + let result = resolve defaultResolveOptions [environmentSource Staging] withFallback + value <- expectAnswer result + value @?= 9000, testCase "default dependencies remain conditional in the static schema" $ do let schema = describe casePort necessaryKeys = fmap schemaSettingKey (schemaNecessary schema) @@ -74,13 +78,19 @@ [portSchema] -> schemaSettingRequirement portSchema @?= Optional _ -> fail "expected one port schema entry", testCase "cyclic defaults fail before source evaluation" $ do - case resolve defaultResolveOptions [poisonSource] cyclicA of + let result = resolve defaultResolveOptions [poisonSource] cyclicA + case result ^. #answer of Left errors -> case NonEmpty.toList errors of [DefaultCycle problem] -> NonEmpty.toList (problem ^. #rules) @?= [RuleName "cycle-a", RuleName "cycle-b", RuleName "cycle-a"] _ -> fail "expected one default cycle" Right _ -> fail "expected cyclic defaults to fail" + fmap (^. #key) (reportNodes (result ^. #report)) @?= [cycleAKey, cycleBKey] + fmap (^. #outcome) (reportNodes (result ^. #report)) + @?= [NotSelected, NotSelected] + result ^. #report . #branches @?= [] + result ^. #warnings @?= [] ] data Environment = Development | Test | Staging | Production @@ -189,9 +199,9 @@ environmentText Staging = "staging" environmentText Production = "production" -expectSuccess :: Either (NonEmpty ConfigError) a -> IO a -expectSuccess = \case - Left _ -> fail "expected successful resolution" +expectAnswer :: ResolveResult a -> IO a +expectAnswer result = case result ^. #answer of + Left errors -> fail ("expected successful resolution: " <> show errors) Right value -> pure value servicePort :: Key diff --git a/test/Settei/RenderTest.hs b/test/Settei/RenderTest.hs --- a/test/Settei/RenderTest.hs +++ b/test/Settei/RenderTest.hs @@ -2,8 +2,11 @@ module Settei.RenderTest (tests) where +import Control.Selective (select) import Data.Generics.Labels () +import Data.List.NonEmpty qualified as NonEmpty import Data.Map.Strict qualified as Map +import Data.Ratio qualified as Ratio import Data.Text qualified as Text import Data.Text.IO qualified as TextIO import Settei @@ -23,12 +26,23 @@ assertGolden "test/golden/resolution.txt" (renderResolutionText snapshotReport), testCase "resolution JSON matches its versioned golden snapshot" $ assertGolden "test/golden/resolution.json" (renderResolutionJson snapshotReport), + testCase "failure resolution text matches its golden snapshot" $ do + _ <- expectFailure failureResolutionResult + assertGolden + "test/golden/failure-resolution.txt" + (renderResolutionText (failureResolutionResult ^. #report)), + testCase "failure resolution JSON matches its versioned golden snapshot" $ do + _ <- expectFailure failureResolutionResult + assertGolden + "test/golden/failure-resolution.json" + (renderResolutionJson (failureResolutionResult ^. #report)), testCase "error renderers match their golden snapshots" $ do errors <- expectFailure (resolve defaultResolveOptions [secretSource] (required secretBoolSetting)) assertGolden "test/golden/errors.txt" (renderErrorsText errors) assertGolden "test/golden/errors.json" (renderErrorsJson errors), testCase "warning renderers match their golden snapshots" $ do - result <- expectSuccess (resolve defaultResolveOptions [unknownSecretSource] (pure ())) + let result = resolve defaultResolveOptions [unknownSecretSource] (pure ()) + _ <- expectAnswer result assertGolden "test/golden/warnings.txt" (renderWarningsText (result ^. #warnings)) assertGolden "test/golden/warnings.json" (renderWarningsJson (result ^. #warnings)), testCase "renderers distinguish missing from not selected" $ do @@ -38,9 +52,119 @@ assertBool "text omitted the not-selected outcome" ("" `Text.isInfixOf` textOutput) assertBool "JSON omitted the missing outcome" ("\"outcome\":\"missing\"" `Text.isInfixOf` jsonOutput) assertBool "JSON omitted the not-selected outcome" ("\"outcome\":\"not-selected\"" `Text.isInfixOf` jsonOutput), - testCase "every supported output redacts marked secrets" redactionTest + testCase "terminating rationals render as exact decimals" $ do + renderNumber (1 Ratio.% 2) @?= "0.5" + renderNumber ((-3) Ratio.% 8) @?= "-0.375" + renderNumber (1 Ratio.% 1000) @?= "0.001" + renderNumber (25 Ratio.% 2) @?= "12.5", + testCase "non-terminating rationals retain exact fractions" $ do + renderNumber (1 Ratio.% 3) @?= "1/3" + renderNumber (7 Ratio.% 12) @?= "7/12", + testCase "arrays use decimal and fraction rendering recursively" $ + renderReportedValue + ( reportedValue + Public + (RawArray [RawNumber (1 Ratio.% 2), RawNumber (1 Ratio.% 3)]) + ) + @?= "[0.5, 1/3]", + testCase "sensitivity conflicts render as structured errors" $ do + let errors = SensitivityConflict (SensitivityConflictProblem {key = databasePassword}) :| [] + assertBool + "text omitted the conflict explanation" + ("database.password: declared with both public and secret sensitivity" `Text.isInfixOf` renderErrorsText errors) + assertBool + "JSON omitted the sensitivity-conflict kind" + ("\"kind\":\"sensitivity-conflict\"" `Text.isInfixOf` renderErrorsJson errors), + kubernetesRendererTests, + testCase "every supported output redacts marked secrets" redactionTest, + testCase "mixed-sensitivity declarations never expose their secret sentinel" $ + sensitivityConflictRedactionTest ] +kubernetesRendererTests :: TestTree +kubernetesRendererTests = + testGroup + "Kubernetes provenance" + [ testCase "text appends only the file modification time" $ do + let output = renderResolutionText (kubernetesReport freshKubernetesOrigin) + output + @?= Text.unlines + [ "service.host = \"api.internal\"", + " from kubernetes-mounted-directory source service-config from Kubernetes ConfigMap payments/service-config key host (modified 2026-07-19T15:20:08Z)" + ] + assertBool + "text rendered the mount-path annotation" + (not ("/etc/app-config" `Text.isInfixOf` output)) + assertBool + "text rendered the read-at annotation" + (not ("2026-07-19T15:21:00Z" `Text.isInfixOf` output)), + testCase "text without file-modified retains the old suffix exactly" $ do + let originWithoutModified = + freshKubernetesOrigin + & #annotations + %~ Map.delete "kubernetes.file-modified" + output = renderResolutionText (kubernetesReport originWithoutModified) + output + @?= Text.unlines + [ "service.host = \"api.internal\"", + " from kubernetes-mounted-directory source service-config from Kubernetes ConfigMap payments/service-config key host" + ] + assertBool "text unexpectedly added a modification suffix" (not ("(modified" `Text.isInfixOf` output)), + testCase "JSON retains every Kubernetes annotation" $ do + let output = renderResolutionJson (kubernetesReport freshKubernetesOrigin) + expectedEntries = + [ "\"kubernetes.file-modified\":\"2026-07-19T15:20:08Z\"", + "\"kubernetes.mount-path\":\"/etc/app-config\"", + "\"kubernetes.namespace\":\"payments\"", + "\"kubernetes.object-key\":\"host\"", + "\"kubernetes.object-kind\":\"ConfigMap\"", + "\"kubernetes.object-name\":\"service-config\"", + "\"kubernetes.read-at\":\"2026-07-19T15:21:00Z\"" + ] + assertBool + "JSON omitted a Kubernetes annotation" + (all (`Text.isInfixOf` output) expectedEntries) + ] + +kubernetesReport :: Origin -> ResolutionReport +kubernetesReport origin = + ResolutionReport + { nodes = + Map.singleton + serviceHost + ResolutionNode + { key = serviceHost, + sensitivity = Public, + outcome = Resolved (reportedValue Public (RawText "api.internal")), + origin = Just origin, + shadowed = [], + derivation = Nothing + }, + branches = [] + } + +freshKubernetesOrigin :: Origin +freshKubernetesOrigin = + Origin + { kind = CustomSource "kubernetes-mounted-directory", + name = "service-config", + key = serviceHost, + location = Nothing, + annotations = + Map.fromList + [ ("kubernetes.object-kind", "ConfigMap"), + ("kubernetes.namespace", "payments"), + ("kubernetes.object-name", "service-config"), + ("kubernetes.object-key", "host"), + ("kubernetes.mount-path", "/etc/app-config"), + ("kubernetes.file-modified", "2026-07-19T15:20:08Z"), + ("kubernetes.read-at", "2026-07-19T15:21:00Z") + ] + } + +renderNumber :: Rational -> Text +renderNumber = renderReportedValue . reportedValue Public . RawNumber + assertGolden :: FilePath -> Text -> IO () assertGolden path actual = do expected <- Text.stripEnd <$> TextIO.readFile path @@ -48,16 +172,22 @@ redactionTest :: IO () redactionTest = do - success <- expectSuccess (resolve defaultResolveOptions [secretSource] (required secretTextSetting)) - errors <- expectFailure (resolve defaultResolveOptions [secretSource] (required secretBoolSetting)) - warningResult <- expectSuccess (resolve defaultResolveOptions [unknownSecretSource] (pure ())) + let success = resolve defaultResolveOptions [secretSource] (required secretTextSetting) + failure = resolve defaultResolveOptions [secretSource] (required secretBoolSetting) + warningResult = resolve defaultResolveOptions [unknownSecretSource] (pure ()) + _ <- expectAnswer success + errors <- expectFailure failure + _ <- expectAnswer warningResult let report = success ^. #report + failureReport = failure ^. #report warnings = warningResult ^. #warnings outputs = [ renderSchemaText (describe (required secretTextSetting)), renderSchemaJson (describe (required secretTextSetting)), renderResolutionText report, renderResolutionJson report, + renderResolutionText failureReport, + renderResolutionJson failureReport, renderErrorsText errors, renderErrorsJson errors, renderWarningsText warnings, @@ -71,14 +201,59 @@ (all (not . Text.isInfixOf secretSentinel) outputs) assertBool "decode error did not show a redaction marker" $ "" `Text.isInfixOf` renderErrorsText errors + assertBool "failure report did not show a redaction marker" $ + "" `Text.isInfixOf` renderResolutionText failureReport -expectSuccess :: Either (NonEmpty ConfigError) a -> IO a -expectSuccess = \case - Left _ -> fail "expected successful resolution" +sensitivityConflictRedactionTest :: IO () +sensitivityConflictRedactionTest = do + let conflictResult = resolve defaultResolveOptions [conflictSource] conflictingConfig + case conflictResult ^. #answer of + Right _ -> fail "mixed-sensitivity declaration should fail" + Left errors -> do + assertBool + "resolution omitted the sensitivity conflict" + ( any + ( \case + SensitivityConflict problem -> problem ^. #key == databasePassword + _ -> False + ) + (NonEmpty.toList errors) + ) + let secretOnly = resolve defaultResolveOptions [conflictSource] (required secretTextSetting) + _ <- expectAnswer secretOnly + let schema = describe conflictingConfig + report = secretOnly ^. #report + conflictReport = conflictResult ^. #report + outputs = + [ renderSchemaText schema, + renderSchemaJson schema, + renderErrorsText errors, + renderErrorsJson errors, + renderResolutionText report, + renderResolutionJson report, + renderResolutionText conflictReport, + renderResolutionJson conflictReport, + Text.pack (show schema), + Text.pack (show errors), + Text.pack (show report) + ] + assertBool + "the conflict sentinel reached a schema, error, resolution, or Show output" + (all (not . Text.isInfixOf conflictSentinel) outputs) + assertBool + "the conflicted schema key was not marked secret" + ("database.password [required, necessary, secret]" `Text.isInfixOf` renderSchemaText schema) + where + conflictingConfig = + (,) <$> required secretTextSetting <*> required publicConflictSetting + +expectAnswer :: ResolveResult a -> IO a +expectAnswer result = case result ^. #answer of + Left errors -> fail ("expected successful resolution: " <> show errors) Right value -> pure value -expectFailure :: Either (NonEmpty ConfigError) a -> IO (NonEmpty ConfigError) -expectFailure = \case +expectFailure :: ResolveResult a -> IO (NonEmpty ConfigError) +expectFailure result = case result ^. #answer of Left errors -> pure errors Right _ -> fail "expected resolution to fail" @@ -171,6 +346,48 @@ ] } +failureResolutionResult :: ResolveResult (Text, Int, Maybe Text) +failureResolutionResult = + resolve defaultResolveOptions failureSources failureResolutionConfig + +failureResolutionConfig :: Config (Text, Int, Maybe Text) +failureResolutionConfig = + (,,) + <$> required hostSetting + <*> required portSetting + <*> productionPassword + +productionPassword :: Config (Maybe Text) +productionPassword = select selector branch + where + selector = + (\environment -> if environment == "production" then Left () else Right Nothing) + <$> required environmentSetting + branch = (\password _ -> Just password) <$> required passwordSetting + +failureSources :: [Source] +failureSources = + [ source + "built-in" + BuiltInSource + ( RawObject + ( Map.fromList + [ ("runtime", RawObject (Map.singleton "environment" (RawText "development"))), + ("service", RawObject (Map.singleton "port" (RawNumber 8080))) + ] + ) + ), + source + "command-line" + CommandLineSource + ( RawObject + ( Map.singleton + "service" + (RawObject (Map.singleton "port" (RawText "not-a-port"))) + ) + ) + ] + environmentOrigin :: Key -> Text -> Origin environmentOrigin key variable = Origin @@ -204,12 +421,24 @@ passwordSetting :: Setting Text passwordSetting = secretSetting databasePassword "Database password" textDecoder +hostSetting :: Setting Text +hostSetting = publicSetting serviceHost "Service host" textDecoder + +portSetting :: Setting Int +portSetting = publicSetting servicePort "Service port" boundedIntegralDecoder + +environmentSetting :: Setting Text +environmentSetting = publicSetting runtimeEnvironment "Runtime environment" textDecoder + secretTextSetting :: Setting Text secretTextSetting = secretSetting databasePassword "Database password" textDecoder secretBoolSetting :: Setting Bool secretBoolSetting = secretSetting databasePassword "Database password" boolDecoder +publicConflictSetting :: Setting Text +publicConflictSetting = publicSetting databasePassword "Metrics password label" textDecoder + secretSource :: Source secretSource = source @@ -222,6 +451,18 @@ ) ) +conflictSource :: Source +conflictSource = + source + "conflict-sentinel" + (CustomSource "test") + ( RawObject + ( Map.singleton + "database" + (RawObject (Map.singleton "password" (RawText conflictSentinel))) + ) + ) + unknownSecretSource :: Source unknownSecretSource = source @@ -232,8 +473,14 @@ secretSentinel :: Text secretSentinel = "S3cr3t-\"\\\n-[]{}-雪" +conflictSentinel :: Text +conflictSentinel = "CONFLICT-S3cr3t-\"\\\n-[]{}-雪" + databasePassword :: Key databasePassword = validKey "database.password" + +serviceHost :: Key +serviceHost = validKey "service.host" runtimeEnvironment :: Key runtimeEnvironment = validKey "runtime.environment" diff --git a/test/Settei/ResolveTest.hs b/test/Settei/ResolveTest.hs --- a/test/Settei/ResolveTest.hs +++ b/test/Settei/ResolveTest.hs @@ -7,7 +7,9 @@ import Data.List (permutations) import Data.List.NonEmpty qualified as NonEmpty import Data.Map.Strict qualified as Map +import Data.Text qualified as Text import Settei +import Settei.Internal.Schema (mergeSensitivity) import Settei.Prelude import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) @@ -17,8 +19,9 @@ testGroup "Settei.Resolve" [ testCase "rightmost source wins per leaf" $ do - result <- expectSuccess (resolve defaultResolveOptions layeredSources serviceConfig) - result ^. #value @?= ("file.example", 443) + let result = resolve defaultResolveOptions layeredSources serviceConfig + value <- expectAnswer result + value @?= ("file.example", 443) let nodes = result ^. #report . #nodes case nodes ^. at serviceHost of Just node -> do @@ -31,10 +34,12 @@ fmap (^. #name) (node ^. #shadowed) @?= ["built-in"] Nothing -> fail "expected port report node", testCase "reversing source order predictably reverses precedence" $ do - result <- expectSuccess (resolve defaultResolveOptions (reverse layeredSources) serviceConfig) - result ^. #value @?= ("built-in.example", 8080), + let result = resolve defaultResolveOptions (reverse layeredSources) serviceConfig + value <- expectAnswer result + value @?= ("built-in.example", 8080), testCase "shadowed origins are ordered from highest to lowest precedence" $ do - result <- expectSuccess (resolve defaultResolveOptions (fmap snd lawSources) (required portSetting)) + let result = resolve defaultResolveOptions (fmap snd lawSources) (required portSetting) + _ <- expectAnswer result case result ^. #report . #nodes . at servicePort of Just node -> fmap (^. #name) (node ^. #shadowed) @?= ["two", "one"] Nothing -> fail "expected the port resolution node", @@ -43,7 +48,7 @@ testCase "malformed winner does not fall back" $ do let lower = treeSource "lower" (RawNumber 8080) Map.empty higher = treeSource "higher" (RawText "not-a-port") Map.empty - case resolve defaultResolveOptions [lower, higher] (required portSetting) of + case (resolve defaultResolveOptions [lower, higher] (required portSetting)) ^. #answer of Left errors -> case NonEmpty.toList errors of [DecodeError problem] -> do problem ^. #key @?= servicePort @@ -53,8 +58,9 @@ testCase "arrays replace rather than concatenate" $ do let lower = arraySource "lower" ["one", "two"] higher = arraySource "higher" ["three"] - result <- expectSuccess (resolve defaultResolveOptions [lower, higher] (required hostsSetting)) - result ^. #value @?= ["three"], + let result = resolve defaultResolveOptions [lower, higher] (required hostsSetting) + value <- expectAnswer result + value @?= ["three"], testCase "unknown keys warn by default and can be promoted" $ do let values = RawObject @@ -65,27 +71,29 @@ ) input = source "document" (FileSource "memory") values declaration = required knownSetting - result <- expectSuccess (resolve defaultResolveOptions [input] declaration) + let result = resolve defaultResolveOptions [input] declaration + _ <- expectAnswer result length (result ^. #warnings) @?= 1 case result ^. #warnings of [UnknownKeyWarning problem] -> problem ^. #key @?= typoKey _ -> fail "expected one unknown-key warning" let strictOptions = ResolveOptions {unknownKeyPolicy = RejectUnknownKeys} - case resolve strictOptions [input] declaration of + case (resolve strictOptions [input] declaration) ^. #answer of Left errors -> case NonEmpty.toList errors of [UnknownKeyError problem] -> problem ^. #key @?= typoKey _ -> fail "expected one strict unknown-key error" Right _ -> fail "strict mode should reject the unknown key", testCase "independent applicative errors accumulate in declaration order" $ do - case resolve defaultResolveOptions [] serviceConfig of + case (resolve defaultResolveOptions [] serviceConfig) ^. #answer of Left errors -> fmap errorKey (NonEmpty.toList errors) @?= [serviceHost, servicePort] Right _ -> fail "expected both required settings to be missing", testCase "unselected selective branch is traced without errors" $ do let development = environmentSource "development" - result <- expectSuccess (resolve defaultResolveOptions [development] productionPassword) - result ^. #value @?= Nothing + let result = resolve defaultResolveOptions [development] productionPassword + value <- expectAnswer result + value @?= Nothing case result ^. #report . #nodes . at databasePassword of Just node -> node ^. #outcome @?= NotSelected Nothing -> fail "expected a not-selected password node" @@ -93,9 +101,132 @@ [branch] -> branch ^. #selected @?= False _ -> fail "expected one selective branch trace", testCase "selected selective branch reports its missing requirement" $ do - case resolve defaultResolveOptions [environmentSource "production"] productionPassword of + case (resolve defaultResolveOptions [environmentSource "production"] productionPassword) ^. #answer of Left errors -> fmap errorKey (NonEmpty.toList errors) @?= [databasePassword] Right _ -> fail "production should require a password", + testCase "whenEq reports an unselected branch in development" $ do + let result = + resolve defaultResolveOptions [environmentSource "development"] sugaredProductionPassword + value <- expectAnswer result + value @?= Nothing + case result ^. #report . #nodes . at databasePassword of + Just node -> node ^. #outcome @?= NotSelected + Nothing -> fail "expected a not-selected password node" + case result ^. #report . #branches of + [branch] -> do + branch ^. #dependencies @?= [runtimeEnvironment] + branch ^. #settings @?= [databasePassword] + branch ^. #selected @?= False + _ -> fail "expected one selective branch trace", + testCase "whenEq reports a selected missing branch in production" $ do + let result = + resolve defaultResolveOptions [environmentSource "production"] sugaredProductionPassword + case result ^. #answer of + Left errors -> fmap errorKey (NonEmpty.toList errors) @?= [databasePassword] + Right _ -> fail "production should require a password" + case result ^. #report . #nodes . at databasePassword of + Just node -> node ^. #outcome @?= MissingValue + Nothing -> fail "expected a missing password node" + case result ^. #report . #branches of + [branch] -> do + branch ^. #dependencies @?= [runtimeEnvironment] + branch ^. #settings @?= [databasePassword] + branch ^. #selected @?= True + _ -> fail "expected one selective branch trace", + testCase "fallbackTo suppresses the legacy key when the primary is present" $ do + let result = + resolve + defaultResolveOptions + [serviceTextSource "primary" "endpoint" "new.example"] + endpointWithFallback + value <- expectAnswer result + value @?= "new.example" + case result ^. #report . #nodes . at serviceUrl of + Just node -> node ^. #outcome @?= NotSelected + Nothing -> fail "expected a not-selected legacy URL node" + case result ^. #report . #branches of + [branch] -> do + branch ^. #dependencies @?= [serviceEndpoint] + branch ^. #settings @?= [serviceUrl] + branch ^. #selected @?= False + _ -> fail "expected one fallback branch trace", + testCase "fallbackTo evaluates the legacy key when the primary is absent" $ do + let result = + resolve + defaultResolveOptions + [serviceTextSource "legacy" "url" "old.example"] + endpointWithFallback + value <- expectAnswer result + value @?= "old.example" + case result ^. #report . #branches of + [branch] -> do + branch ^. #dependencies @?= [serviceEndpoint] + branch ^. #settings @?= [serviceUrl] + branch ^. #selected @?= True + _ -> fail "expected one fallback branch trace", + testCase "publicShowSetting renders a typed default" $ + expectDefaultDisplay + "8080" + (publicShowSetting servicePort "Service port" boundedIntegralDecoder), + testCase "a rendererless public setting keeps the derived marker" $ + expectDefaultDisplay + "" + (publicSetting servicePort "Service port" boundedIntegralDecoder), + testCase "withRenderer displays a public typed default" $ + expectDefaultDisplay + "8080" + ( withRenderer + (Text.pack . show) + (publicSetting servicePort "Service port" boundedIntegralDecoder) + ), + testCase "withRenderer cannot expose a secret typed default" $ + expectDefaultDisplay + "" + ( withRenderer + (Text.pack . show) + (secretSetting servicePort "Service port" boundedIntegralDecoder) + ), + testCase "failure report retains evaluated provenance" $ do + let input = treeSource "only-port" (RawNumber 8080) Map.empty + result = resolve defaultResolveOptions [input] serviceConfig + case result ^. #answer of + Left errors -> fmap errorKey (NonEmpty.toList errors) @?= [serviceHost] + Right _ -> fail "expected the missing host to fail" + case result ^. #report . #nodes . at servicePort of + Just node -> do + node ^. #outcome @?= Resolved (reportedValue Public (RawNumber 8080)) + fmap (^. #name) (node ^. #origin) @?= Just "only-port" + Nothing -> fail "expected the evaluated port node" + case result ^. #report . #nodes . at serviceHost of + Just node -> node ^. #outcome @?= MissingValue + Nothing -> fail "expected the missing host node", + testCase "decode failure keeps the rejected candidate's provenance" $ do + let lower = treeSource "lower" (RawNumber 8080) Map.empty + higher = treeSource "higher" (RawText "not-a-port") Map.empty + result = resolve defaultResolveOptions [lower, higher] (required portSetting) + case result ^. #answer of + Left errors -> case NonEmpty.toList errors of + [DecodeError problem] -> problem ^. #origin . #name @?= "higher" + _ -> fail "expected one decode error" + Right _ -> fail "expected the malformed winner to fail" + case result ^. #report . #nodes . at servicePort of + Just node -> do + node ^. #outcome @?= Resolved (reportedValue Public (RawText "not-a-port")) + fmap (^. #name) (node ^. #origin) @?= Just "higher" + fmap (^. #name) (node ^. #shadowed) @?= ["lower"] + Nothing -> fail "expected the rejected winner's report node", + testCase "failure report completes not-selected settings" $ do + let declaration = (,) <$> productionPassword <*> required knownSetting + result = resolve defaultResolveOptions [environmentSource "development"] declaration + case result ^. #answer of + Left errors -> fmap errorKey (NonEmpty.toList errors) @?= [knownKey] + Right _ -> fail "expected the unrelated required setting to fail" + case result ^. #report . #nodes . at databasePassword of + Just node -> node ^. #outcome @?= NotSelected + Nothing -> fail "expected the unselected password node" + case result ^. #report . #branches of + [branch] -> branch ^. #selected @?= False + _ -> fail "expected one unselected branch trace", testCase "structural conflicts are rejected even under an unselected branch" $ do let development = environmentSource "development" conflicting = @@ -103,20 +234,117 @@ "conflicting" (FileSource "memory") (RawObject (Map.singleton "database" (RawText "not-an-object"))) - case resolve defaultResolveOptions [development, conflicting] productionPassword of + case (resolve defaultResolveOptions [development, conflicting] productionPassword) ^. #answer of Left errors -> case NonEmpty.toList errors of [StructuralConflict structuralError] -> structuralError ^. #key @?= databasePassword _ -> fail "expected one structural conflict" + Right _ -> fail "source shape validation should fail", + testCase "structural exit still reports schema and warnings" $ do + let malformed = + source + "malformed" + (FileSource "memory") + ( RawObject + ( Map.fromList + [ ("database", RawText "not-an-object"), + ("typo", RawText "unused") + ] + ) + ) + result = + resolve + defaultResolveOptions + [environmentSource "development", malformed] + productionPassword + case result ^. #answer of + Left errors -> case NonEmpty.toList errors of + [StructuralConflict structuralError] -> + structuralError ^. #key @?= databasePassword + _ -> fail "expected one structural conflict" Right _ -> fail "source shape validation should fail" + fmap (^. #key) (reportNodes (result ^. #report)) + @?= [databasePassword, runtimeEnvironment] + fmap (^. #outcome) (reportNodes (result ^. #report)) + @?= [NotSelected, NotSelected] + fmap (^. #origin) (reportNodes (result ^. #report)) @?= [Nothing, Nothing] + result ^. #report . #branches @?= [] + any + ( \case + UnknownKeyWarning problem -> problem ^. #key == typoKey + ) + (result ^. #warnings) + @?= True, + testCase "warnings accompany failures and strict mode promotes them" $ do + let input = + source + "document" + (FileSource "memory") + (RawObject (Map.singleton "typo" (RawText "unused"))) + warned = resolve defaultResolveOptions [input] (required knownSetting) + case warned ^. #answer of + Left errors -> fmap errorKey (NonEmpty.toList errors) @?= [knownKey] + Right _ -> fail "expected the missing known setting to fail" + case warned ^. #warnings of + [UnknownKeyWarning problem] -> problem ^. #key @?= typoKey + _ -> fail "expected one warning alongside the failure" + let strictOptions = ResolveOptions {unknownKeyPolicy = RejectUnknownKeys} + rejected = resolve strictOptions [input] (required knownSetting) + case rejected ^. #answer of + Left errors -> fmap errorKey (NonEmpty.toList errors) @?= [knownKey, typoKey] + Right _ -> fail "strict mode should reject the unknown key" + rejected ^. #warnings @?= [], + testCase "conflicting sensitivity declarations fail with a structured error" $ do + assertSensitivityConflict secretThenPublic + assertSensitivityConflict publicThenSecret, + testCase "sensitivity conflicts include unselected selective branches" $ + assertSensitivityConflict selectiveSensitivityConflict, + testCase "sensitivity conflicts include default dependencies" $ + assertSensitivityConflict defaultSensitivityConflict, + testCase "effective sensitivity is secret-dominant at the schema seam" $ do + mergeSensitivity Public Public @?= Public + mergeSensitivity Public Secret @?= Secret + mergeSensitivity Secret Public @?= Secret + mergeSensitivity Secret Secret @?= Secret + schemaSettingSensitivity (schemaEntry databasePassword (describe secretThenPublic)) + @?= Secret + schemaSettingSensitivity (schemaEntry databasePassword (describe publicThenSecret)) + @?= Secret, + testCase "redactReportedValue collapses every retained representation" $ + mapM_ + (\value -> renderReportedValue (redactReportedValue value) @?= "") + [ visibleReportedValue "x", + derivedReportedValue Public, + reportedValue Secret (RawText "x") + ] ] +assertSensitivityConflict :: Config a -> IO () +assertSensitivityConflict declaration = do + let result = resolve defaultResolveOptions [passwordSource] declaration + case result ^. #answer of + Left errors -> case NonEmpty.toList errors of + [SensitivityConflict problem] -> problem ^. #key @?= databasePassword + _ -> fail "expected one sensitivity conflict" + Right _ -> fail "mixed-sensitivity declaration should fail" + case result ^. #report . #nodes . at databasePassword of + Just node -> do + node ^. #sensitivity @?= Secret + node ^. #outcome @?= NotSelected + node ^. #origin @?= Nothing + Nothing -> fail "expected a schema-only conflict report node" + +schemaEntry :: Key -> Schema -> SchemaSetting +schemaEntry key schema = + case filter ((== key) . schemaSettingKey) (schemaPossible schema) of + [entry] -> entry + entries -> error ("expected one schema entry, found " <> show (length entries)) + checkOrdering :: [(Int, Source)] -> IO () checkOrdering orderedSources = do - result <- - expectSuccess - (resolve defaultResolveOptions (fmap snd orderedSources) (required portSetting)) - result ^. #value @?= fst (last orderedSources) + let result = resolve defaultResolveOptions (fmap snd orderedSources) (required portSetting) + value <- expectAnswer result + value @?= fst (last orderedSources) lawSources :: [(Int, Source)] lawSources = @@ -125,11 +353,26 @@ (3003, treeSource "three" (RawNumber 3003) Map.empty) ] -expectSuccess :: Either (NonEmpty ConfigError) a -> IO a -expectSuccess = \case - Left _ -> fail "expected successful resolution" +expectAnswer :: ResolveResult a -> IO a +expectAnswer result = case result ^. #answer of + Left errors -> fail ("expected successful resolution: " <> show errors) Right value -> pure value +expectDefaultDisplay :: Text -> Setting Int -> IO () +expectDefaultDisplay expected settingSpec = do + let declaration = + withDefault + settingSpec + (constantDefault (RuleName "built-in-port") "Built-in service port" 8080) + result = resolve defaultResolveOptions [] declaration + value <- expectAnswer result + value @?= 8080 + case result ^. #report . #nodes . at servicePort of + Just node -> case node ^. #outcome of + Resolved reported -> renderReportedValue reported @?= expected + _ -> fail "expected a resolved default value" + Nothing -> fail "expected a derived service port node" + errorKey :: ConfigError -> Key errorKey = \case MissingRequired problem -> problem ^. #key @@ -138,6 +381,7 @@ UnknownKeyError problem -> problem ^. #key DefaultError problem -> problem ^. #key DefaultCycle _ -> error "a cycle has no single setting key" + SensitivityConflict problem -> problem ^. #key serviceConfig :: Config (Text, Int) serviceConfig = (,) <$> required hostSetting <*> required portSetting @@ -150,6 +394,39 @@ <$> required environmentSetting branch = (\password _ -> Just password) <$> required passwordSetting +sugaredProductionPassword :: Config (Maybe Text) +sugaredProductionPassword = + whenEq (required environmentSetting) "production" (required passwordSetting) + +endpointWithFallback :: Config Text +endpointWithFallback = + optional endpointSetting `fallbackTo` required urlSetting + +secretThenPublic :: Config (Text, Text) +secretThenPublic = + (,) <$> required passwordSetting <*> required publicPasswordSetting + +publicThenSecret :: Config (Text, Text) +publicThenSecret = + (,) <$> required publicPasswordSetting <*> required passwordSetting + +selectiveSensitivityConflict :: Config Text +selectiveSensitivityConflict = + select + ((\password -> Right password :: Either () Text) <$> required passwordSetting) + ((\publicValue () -> publicValue) <$> required publicPasswordSetting) + +defaultSensitivityConflict :: Config Text +defaultSensitivityConflict = + withDefault + passwordSetting + ( derivedDefault + (RuleName "password-from-public-duplicate") + "Exercise a sensitivity conflict in a default dependency" + (required publicPasswordSetting) + id + ) + hostSetting :: Setting Text hostSetting = publicSetting serviceHost "Service host" textDecoder @@ -168,6 +445,27 @@ passwordSetting :: Setting Text passwordSetting = secretSetting databasePassword "Database password" textDecoder +endpointSetting :: Setting Text +endpointSetting = publicSetting serviceEndpoint "Service endpoint" textDecoder + +urlSetting :: Setting Text +urlSetting = publicSetting serviceUrl "Legacy service URL" textDecoder + +publicPasswordSetting :: Setting Text +publicPasswordSetting = publicSetting databasePassword "Metrics password label" textDecoder + +passwordSource :: Source +passwordSource = + source + "password" + (CustomSource "test") + ( RawObject + ( Map.singleton + "database" + (RawObject (Map.singleton "password" (RawText "sensitive-value"))) + ) + ) + textArrayDecoder :: Decoder [Text] textArrayDecoder = decoder $ \key -> \case RawArray values -> traverse (decodeOne key) values @@ -222,6 +520,18 @@ ) ) +serviceTextSource :: Text -> Text -> Text -> Source +serviceTextSource name field value = + source + name + (CustomSource "test") + ( RawObject + ( Map.singleton + "service" + (RawObject (Map.singleton field (RawText value))) + ) + ) + serviceHost :: Key serviceHost = validKey "service.host" @@ -230,6 +540,12 @@ serviceHosts :: Key serviceHosts = validKey "service.hosts" + +serviceEndpoint :: Key +serviceEndpoint = validKey "service.endpoint" + +serviceUrl :: Key +serviceUrl = validKey "service.url" runtimeEnvironment :: Key runtimeEnvironment = validKey "runtime.environment" diff --git a/test/Settei/SourceTest.hs b/test/Settei/SourceTest.hs --- a/test/Settei/SourceTest.hs +++ b/test/Settei/SourceTest.hs @@ -39,6 +39,77 @@ testCase "leaf enumeration is ordered and treats arrays wholesale" $ fmap (renderKey . fst) (sourceLeaves sampleSource) @?= ["service.hosts", "service.port"], + testCase "source annotations compose across repeated calls" $ + sourceAnnotations + ( annotateSource + (Map.singleton "b" "2") + (annotateSource (Map.singleton "a" "1") sampleSource) + ) + @?= Map.fromList [("a", "1"), ("b", "2")], + testCase "later source annotations win on collision" $ + sourceAnnotations + ( annotateSource + (Map.singleton "a" "new") + (annotateSource (Map.singleton "a" "old") sampleSource) + ) + ^. at "a" + @?= Just "new", + testCase "candidate origins observe merged source annotations" $ do + let annotated = + annotateSource + (Map.singleton "b" "2") + (annotateSource (Map.singleton "a" "1") sampleSource) + case lookupSource servicePort annotated of + Right (Just found) -> + candidateOrigin found ^. #annotations + @?= Map.fromList [("a", "1"), ("b", "2")] + _ -> fail "expected the annotated source candidate", + testCase "validated source pairs build addressable sibling leaves" $ do + let serviceHost = validKey "service.host" + result = + sourceFromPairs + "custom" + BuiltInSource + [ (servicePort, RawNumber 8080), + (serviceHost, RawText "db") + ] + case result of + Left errors -> fail ("expected a valid source, got " <> show errors) + Right built -> do + fmap (renderKey . fst) (sourceLeaves built) + @?= ["service.host", "service.port"] + sourceUnaddressableLeaves built @?= [] + case (lookupSource servicePort built, lookupSource serviceHost built) of + (Right (Just port), Right (Just host)) -> do + assertBool "expected the inserted port" (candidateValue port == RawNumber 8080) + assertBool "expected the inserted host" (candidateValue host == RawText "db") + _ -> fail "expected both inserted candidates to be addressable", + testCase "validated source pairs reject duplicate keys" $ + ( sourceFromPairs + "custom" + BuiltInSource + [(servicePort, RawNumber 8080), (servicePort, RawNumber 9090)] + & either id (const (error "expected duplicate rejection")) + ) + @?= DuplicateSourceKey servicePort :| [], + testCase "validated source pairs reject prefix overlaps" $ + let service = validKey "service" + in ( sourceFromPairs + "custom" + BuiltInSource + [(service, RawText "scalar"), (servicePort, RawNumber 8080)] + & either id (const (error "expected overlap rejection")) + ) + @?= OverlappingSourceKeys service servicePort :| [], + testCase "unvalidated dotted leaves are visible to inspection" $ + let built = + source + "custom" + BuiltInSource + (RawObject (Map.singleton "a.b" (RawText "hidden"))) + in do + assertBool "expected no addressable leaves" (null (sourceLeaves built)) + sourceUnaddressableLeaves built @?= [["a.b"]], testCase "per-key annotations reach only their matching origins" $ do let annotated = annotateSourceAt diff --git a/test/Settei/ValueTest.hs b/test/Settei/ValueTest.hs --- a/test/Settei/ValueTest.hs +++ b/test/Settei/ValueTest.hs @@ -1,5 +1,7 @@ module Settei.ValueTest (tests) where +import Data.Int (Int16) +import Data.Ratio ((%)) import Data.Text qualified as Text import Settei import Settei.Prelude @@ -23,7 +25,69 @@ Left failureValue -> assertBool "rendered failure leaked the rejected secret" - (not (Text.isInfixOf "supersecret" (renderDecodeFailure failureValue))) + (not (Text.isInfixOf "supersecret" (renderDecodeFailure failureValue))), + testCase "fmap maps a successful decode" $ + runDecoder (Text.toUpper <$> textDecoder) exampleKey (RawText "hello") + @?= Right "HELLO", + testCase "fmap passes failures through unchanged" $ + case runDecoder (Text.toUpper <$> textDecoder) exampleKey (RawBool True) of + Right _ -> fail "expected decoding to fail" + Left failureValue -> decodeFailureExpected failureValue @?= "text", + testCase "listDecoder decodes arrays element-wise" $ + runDecoder (listDecoder textDecoder) exampleKey (RawArray [RawText "a", RawText "b"]) + @?= Right ["a", "b"], + testCase "listDecoder rejects non-arrays" $ + case runDecoder (listDecoder textDecoder) exampleKey (RawText "a") of + Right _ -> fail "expected decoding to fail" + Left failureValue -> decodeFailureExpected failureValue @?= "an array", + testCase "listDecoder wraps element expectations" $ + case runDecoder (listDecoder textDecoder) exampleKey (RawArray [RawText "a", RawBool True]) of + Right _ -> fail "expected decoding to fail" + Left failureValue -> decodeFailureExpected failureValue @?= "an array of text", + testCase "nonEmptyDecoder decodes non-empty arrays" $ + runDecoder (nonEmptyDecoder textDecoder) exampleKey (RawArray [RawText "a", RawText "b"]) + @?= Right ("a" :| ["b"]), + testCase "nonEmptyDecoder rejects empty arrays" $ + case runDecoder (nonEmptyDecoder textDecoder) exampleKey (RawArray []) of + Right _ -> fail "expected decoding to fail" + Left failureValue -> decodeFailureExpected failureValue @?= "a non-empty array", + testCase "parsedDecoder applies the parser" $ + runDecoder portFromText exampleKey (RawText "8080") @?= Right (8080 :: Int), + testCase "parsedDecoder reports only the caller's expectation" $ + case runDecoder portFromText exampleKey (RawText sentinel) of + Right _ -> fail "expected decoding to fail" + Left failureValue -> + decodeFailureExpected failureValue @?= "a port number", + testCase "parsedDecoder discards parser messages that echo input" $ + case runDecoder portFromText exampleKey (RawText sentinel) of + Right _ -> fail "expected decoding to fail" + Left failureValue -> + assertBool + "rendered failure leaked the parser input" + (not (Text.isInfixOf sentinel (renderDecodeFailure failureValue))), + testCase "listDecoder element failures never leak the value" $ + case runDecoder (listDecoder boolDecoder) exampleKey (RawArray [RawText sentinel]) of + Right _ -> fail "expected decoding to fail" + Left failureValue -> + assertBool + "rendered failure leaked the array element" + (not (Text.isInfixOf sentinel (renderDecodeFailure failureValue))), + testCase "rationalDecoder accepts numbers and numeric text" $ do + runDecoder rationalDecoder exampleKey (RawNumber (5 % 2)) @?= Right (5 % 2) + runDecoder rationalDecoder exampleKey (RawText "2.5") @?= Right (5 % 2) + runDecoder rationalDecoder exampleKey (RawText "-3") @?= Right (negate 3), + testCase "rationalDecoder rejects trailing garbage" $ + case runDecoder rationalDecoder exampleKey (RawText "1.5x") of + Right _ -> fail "expected decoding to fail" + Left failureValue -> decodeFailureExpected failureValue @?= "a number", + testCase "doubleDecoder rounds through the exact rational" $ do + runDecoder doubleDecoder exampleKey (RawText "2.5") @?= Right 2.5 + runDecoder doubleDecoder exampleKey (RawNumber (1 % 10)) @?= Right 0.1, + testCase "boundedIntegralDecoder reports its range" $ + case runDecoder (boundedIntegralDecoder :: Decoder Int16) exampleKey (RawNumber 100000) of + Right _ -> fail "expected decoding to fail" + Left failureValue -> + decodeFailureExpected failureValue @?= "integer between -32768 and 32767" ] data Environment = Development | Production @@ -50,6 +114,16 @@ exampleKey :: Key exampleKey = validKey "example.value" + +portFromText :: Decoder Int +portFromText = + parsedDecoder "a port number" $ \value -> + case runDecoder (boundedIntegralDecoder :: Decoder Int) exampleKey (RawText value) of + Right port -> Right port + Left _ -> Left ("could not parse port from input: " <> value) + +sentinel :: Text +sentinel = "s3cr3t\"\\\SOH!☃パス" validKey :: Text -> Key validKey value = either (error . show) id (parseKey value) diff --git a/test/golden/failure-resolution.json b/test/golden/failure-resolution.json new file mode 100644 --- /dev/null +++ b/test/golden/failure-resolution.json @@ -0,0 +1,1 @@ +{"schemaVersion":1,"type":"settei.resolution","nodes":[{"key":"database.password","sensitivity":"secret","outcome":"not-selected","value":null,"origin":null,"shadowed":[],"derivation":null},{"key":"runtime.environment","sensitivity":"public","outcome":"resolved","value":"\"development\"","origin":{"kind":"built-in","kindDetail":null,"name":"built-in","key":"runtime.environment","location":null,"annotations":{}},"shadowed":[],"derivation":null},{"key":"service.host","sensitivity":"public","outcome":"missing","value":null,"origin":null,"shadowed":[],"derivation":null},{"key":"service.port","sensitivity":"public","outcome":"resolved","value":"\"not-a-port\"","origin":{"kind":"command-line","kindDetail":null,"name":"command-line","key":"service.port","location":null,"annotations":{}},"shadowed":[{"kind":"built-in","kindDetail":null,"name":"built-in","key":"service.port","location":null,"annotations":{}}],"derivation":null}],"branches":[{"dependencies":["runtime.environment"],"settings":["database.password"],"selected":false}]} diff --git a/test/golden/failure-resolution.txt b/test/golden/failure-resolution.txt new file mode 100644 --- /dev/null +++ b/test/golden/failure-resolution.txt @@ -0,0 +1,8 @@ +database.password = +runtime.environment = "development" + from built-in source built-in +service.host = +service.port = "not-a-port" + from command-line option command-line + shadowed: built-in source built-in +branch 1 [not selected]: runtime.environment -> database.password