diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,8 @@ +# Changelog for settei + +## 0.1.0.0 — 2026-07-18 + +- 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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) 2026, shinzui +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,13 @@ +# settei + +`settei` is the core package in the Settei family of typed, layered, explainable +configuration libraries for Haskell. It owns the inspectable declaration language, +hierarchical resolution semantics, provenance model, derived defaults, and secret-safe +text and JSON reports. + +Import `Settei` for the supported public entry point. Format and integration adapters are +published as separate `settei-*` packages so applications only depend on the parsers and +boundaries they use. + +The package family, guides, architecture records, and implementation plans live in the +[Settei repository](https://github.com/shinzui/settei). diff --git a/settei.cabal b/settei.cabal new file mode 100644 --- /dev/null +++ b/settei.cabal @@ -0,0 +1,111 @@ +cabal-version: 3.8 +name: settei +version: 0.1.0.0 +synopsis: Typed, layered, explainable configuration +description: + Settei provides an inspectable declaration language for typed configuration. + This core package owns resolution, provenance, defaults, schemas, and reporting; + sibling packages provide maintained source adapters. + +homepage: https://github.com/shinzui/settei +bug-reports: https://github.com/shinzui/settei/issues +license: BSD-3-Clause +license-file: LICENSE +author: shinzui +maintainer: shinzui +category: Configuration +build-type: Simple +tested-with: GHC ==9.12.4 +extra-doc-files: CHANGELOG.md +extra-source-files: + README.md + test/golden/*.json + test/golden/*.txt + +source-repository head + type: git + location: https://github.com/shinzui/settei.git + +common common + default-language: GHC2024 + default-extensions: + DeriveAnyClass + DuplicateRecordFields + OverloadedLabels + OverloadedStrings + + ghc-options: -Wall -Wcompat + +library + import: common + hs-source-dirs: src + exposed-modules: + Settei + Settei.Config + Settei.Default + Settei.Error + Settei.Key + Settei.Origin + Settei.Prelude + Settei.Provenance + Settei.Render + Settei.Report + Settei.Resolve + Settei.Schema + Settei.Setting + Settei.Source + Settei.Value + + other-modules: + Settei.Internal.Config + Settei.Internal.Schema + + build-depends: + , base >=4.21 && <5 + , containers >=0.6.8 && <0.8 + , generic-lens >=2.2 && <2.4 + , lens >=5.3 && <5.4 + , selective >=0.7 && <0.8 + , text >=2.1 && <2.2 + +test-suite settei-tests + import: common + type: exitcode-stdio-1.0 + hs-source-dirs: test src + main-is: Main.hs + other-modules: + Settei + Settei.Config + Settei.ConfigTest + Settei.Default + Settei.DefaultTest + Settei.Error + Settei.Internal.Config + Settei.Internal.Schema + Settei.Key + Settei.KeyTest + Settei.Origin + Settei.Prelude + Settei.Prototype.Free + Settei.Provenance + Settei.Render + Settei.RenderTest + Settei.Report + Settei.Resolve + Settei.ResolveTest + Settei.Schema + Settei.Setting + Settei.Source + Settei.SourceTest + Settei.Value + Settei.ValueTest + + build-depends: + , base >=4.21 && <5 + , containers >=0.6.8 && <0.8 + , generic-lens >=2.2 && <2.4 + , lens >=5.3 && <5.4 + , selective >=0.7 && <0.8 + , tasty >=1.5 && <1.6 + , tasty-hunit >=0.10.2 && <0.11 + , text >=2.1 && <2.2 diff --git a/src/Settei.hs b/src/Settei.hs new file mode 100644 --- /dev/null +++ b/src/Settei.hs @@ -0,0 +1,31 @@ +-- | Typed, inspectable configuration declarations. +module Settei + ( module Settei.Config, + module Settei.Default, + module Settei.Error, + module Settei.Key, + module Settei.Origin, + module Settei.Provenance, + module Settei.Render, + module Settei.Report, + module Settei.Resolve, + module Settei.Schema, + module Settei.Setting, + module Settei.Source, + module Settei.Value, + ) +where + +import Settei.Config +import Settei.Default +import Settei.Error +import Settei.Key +import Settei.Origin +import Settei.Provenance +import Settei.Render +import Settei.Report +import Settei.Resolve +import Settei.Schema +import Settei.Setting +import Settei.Source +import Settei.Value diff --git a/src/Settei/Config.hs b/src/Settei/Config.hs new file mode 100644 --- /dev/null +++ b/src/Settei/Config.hs @@ -0,0 +1,65 @@ +-- | +-- Module: Settei.Config +-- Description: Compose and inspect typed configuration declarations. +-- +-- A 'Config' describes configuration effects without reading a source. Independent +-- settings compose with 'Applicative'; runtime-dependent effects compose with +-- "Control.Selective". The latter preserves a static over-approximation while allowing +-- an interpreter to skip an unused branch. +-- +-- For example, a caller can declare a production-only password (assuming +-- @environmentSetting :: Setting Text@ and @passwordSetting :: Setting Text@): +-- +-- @ +-- productionPassword :: Config (Maybe Text) +-- productionPassword = +-- select +-- ((\environment -> if environment == "production" then Left () else Right Nothing) +-- '<$>' required environmentSetting) +-- ((\password _ -> Just password) '<$>' required passwordSetting) +-- @ +-- +-- Inspection needs no environment variables or files: +-- +-- @ +-- fmap (renderKey . schemaSettingKey) (schemaNecessary (describe productionPassword)) +-- -- ["runtime.environment"] +-- @ +-- +-- '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, + optional, + required, + withDefault, + ) +where + +import Settei.Default (Default) +import Settei.Internal.Config + ( Config, + describeConfig, + optionalConfig, + requiredConfig, + withDefaultConfig, + ) +import Settei.Schema (Schema) +import Settei.Setting (Setting) + +-- | Require one setting when this declaration path is evaluated. +required :: Setting a -> Config a +required = requiredConfig + +-- | Request a setting without failing when no source supplies it. +optional :: Setting a -> Config (Maybe a) +optional = optionalConfig + +-- | Request a setting, evaluating its named fallback only when no source supplies it. +withDefault :: Setting a -> Default a -> Config a +withDefault = withDefaultConfig + +-- | Inspect every possible request without reading configuration sources. +describe :: Config a -> Schema +describe = describeConfig diff --git a/src/Settei/Default.hs b/src/Settei/Default.hs new file mode 100644 --- /dev/null +++ b/src/Settei/Default.hs @@ -0,0 +1,45 @@ +-- | +-- Module: Settei.Default +-- Description: Named constant and dependency-aware fallback rules. +module Settei.Default + ( Default, + RuleName (..), + caseDefault, + constantDefault, + derivedDefault, + renderRuleName, + ) +where + +import Settei.Internal.Config + ( Config, + Default, + RuleName (..), + caseDefaultConfig, + constantDefaultConfig, + derivedDefaultConfig, + renderRuleName, + ) +import Settei.Prelude + +-- | A fallback value with a stable name and human-readable rationale. +constantDefault :: RuleName -> Text -> a -> Default a +constantDefault = constantDefaultConfig + +-- | A fallback derived from an explicit, statically inspectable declaration. +derivedDefault :: RuleName -> Text -> Config d -> (d -> a) -> Default a +derivedDefault = derivedDefaultConfig + +-- | A finite named derivation with an optional catch-all fallback. +-- +-- An unmatched value without a fallback becomes a structured resolver error; the +-- rejected dependency value is never retained in that error. +caseDefault :: + (Ord d, Show d) => + RuleName -> + Text -> + Config d -> + NonEmpty (d, a) -> + Maybe a -> + Default a +caseDefault = caseDefaultConfig diff --git a/src/Settei/Error.hs b/src/Settei/Error.hs new file mode 100644 --- /dev/null +++ b/src/Settei/Error.hs @@ -0,0 +1,85 @@ +-- | +-- Module: Settei.Error +-- Description: Structured, secret-safe configuration failures. +module Settei.Error + ( ConfigError (..), + ConfigWarning (..), + DefaultCycleProblem (..), + DefaultProblem (..), + DecodeProblem (..), + MissingProblem (..), + RawShape (..), + StructuralError (..), + UnknownKeyProblem (..), + ) +where + +import Settei.Default (RuleName) +import Settei.Key (Key) +import Settei.Origin (Origin) +import Settei.Prelude +import Settei.Provenance (ReportedValue) + +-- | The coarse shape that prevented traversal through a source tree. +data RawShape = NullShape | ScalarShape | ArrayShape + deriving stock (Generic, Eq, Ord, Show) + +-- | A declared key attempted to traverse through a non-object value. +data StructuralError = StructuralError + { key :: !Key, + blockedAt :: !Key, + origin :: !Origin, + shape :: !RawShape + } + deriving stock (Generic, Eq, Show) + +-- | A required setting that had no winning source candidate. +data MissingProblem = MissingProblem + { key :: !Key + } + deriving stock (Generic, Eq, Show) + +-- | A winning candidate that did not satisfy its setting decoder. +data DecodeProblem = DecodeProblem + { key :: !Key, + expected :: !Text, + origin :: !Origin, + rejected :: !ReportedValue + } + deriving stock (Generic, Eq, Show) + +-- | An addressable source leaf that no declaration recognizes. +data UnknownKeyProblem = UnknownKeyProblem + { key :: !Key, + origin :: !Origin + } + deriving stock (Generic, Eq, Show) + +-- | A named default failed without retaining its dependency value. +data DefaultProblem = DefaultProblem + { key :: !Key, + rule :: !RuleName, + message :: !Text + } + deriving stock (Generic, Eq, Show) + +-- | The ordered rule path that re-entered an active default. +data DefaultCycleProblem = DefaultCycleProblem + { rules :: !(NonEmpty RuleName) + } + deriving stock (Generic, Eq, Show) + +-- | A fatal resolver error. Every constructor is safe to render or show. +data ConfigError + = MissingRequired !MissingProblem + | DecodeError !DecodeProblem + | StructuralConflict !StructuralError + | UnknownKeyError !UnknownKeyProblem + | DefaultError !DefaultProblem + | DefaultCycle !DefaultCycleProblem + deriving stock (Generic, Eq, Show) + +-- | A non-fatal resolver diagnostic. +data ConfigWarning + = UnknownKeyWarning !UnknownKeyProblem + deriving stock (Generic, Eq, Show) diff --git a/src/Settei/Internal/Config.hs b/src/Settei/Internal/Config.hs new file mode 100644 --- /dev/null +++ b/src/Settei/Internal/Config.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Settei.Internal.Config + ( Config (..), + Default (..), + Request (..), + RuleName (..), + caseDefaultConfig, + constantDefaultConfig, + describeConfig, + derivedDefaultConfig, + optionalConfig, + renderRuleName, + requiredConfig, + runConfig, + withDefaultConfig, + ) +where + +import Control.Selective (Selective (..)) +import Data.List.NonEmpty qualified as NonEmpty +import Settei.Internal.Schema + ( Requirement (..), + Schema, + combineSchema, + conditionalSchema, + emptySchema, + requestSchema, + ) +import Settei.Prelude +import Settei.Setting (Setting) + +-- | A request made by the declaration language. +data Request a where + RequiredRequest :: !(Setting a) -> Request a + OptionalRequest :: !(Setting a) -> Request (Maybe a) + +-- | Stable identity for a default derivation rule. +newtype RuleName = RuleName Text + deriving stock (Generic, Eq, Ord, Show) + +-- | An inspectable fallback with explicit dependencies. +-- +-- Function-bearing constructors intentionally have no 'Show' instance. +data Default a where + ConstantDefault :: !RuleName -> !Text -> a -> Default a + DerivedDefault :: !RuleName -> !Text -> Config d -> (d -> a) -> Default a + CaseDefault :: + (Ord d, Show d) => + !RuleName -> + !Text -> + Config d -> + !(NonEmpty (d, a)) -> + !(Maybe a) -> + Default a + +-- | The private, typed syntax tree behind the public declaration language. +data Config a where + PureConfig :: a -> Config a + MapConfig :: (a -> b) -> Config a -> Config b + ApplyConfig :: Config (a -> b) -> Config a -> Config b + RequestConfig :: !(Request a) -> Config a + DefaultConfig :: !(Setting a) -> !(Default a) -> Config a + SelectConfig :: Config (Either a b) -> Config (a -> b) -> Config b + +instance Functor Config where + fmap = MapConfig + +instance Applicative Config where + pure = PureConfig + (<*>) = ApplyConfig + +instance Selective Config where + select = SelectConfig + +requiredConfig :: Setting a -> Config a +requiredConfig = RequestConfig . RequiredRequest + +optionalConfig :: Setting a -> Config (Maybe a) +optionalConfig = RequestConfig . OptionalRequest + +constantDefaultConfig :: RuleName -> Text -> a -> Default a +constantDefaultConfig = ConstantDefault + +derivedDefaultConfig :: RuleName -> Text -> Config d -> (d -> a) -> Default a +derivedDefaultConfig = DerivedDefault + +caseDefaultConfig :: + (Ord d, Show d) => + RuleName -> + Text -> + Config d -> + NonEmpty (d, a) -> + Maybe a -> + Default a +caseDefaultConfig = CaseDefault + +withDefaultConfig :: Setting a -> Default a -> Config a +withDefaultConfig = DefaultConfig + +-- | Render the stable textual identity of a default rule. +renderRuleName :: RuleName -> Text +renderRuleName (RuleName value) = value + +-- | Interpret a declaration. Selective branches evaluate only the chosen side. +runConfig :: (Monad m) => (forall x. Request x -> m x) -> Config a -> m a +runConfig interpret = \case + PureConfig value -> pure value + MapConfig mapValue config -> mapValue <$> runConfig interpret config + ApplyConfig function inputConfig -> + runConfig interpret function <*> runConfig interpret inputConfig + RequestConfig request -> interpret request + DefaultConfig settingSpec defaultSpec -> do + explicitValue <- interpret (OptionalRequest settingSpec) + case explicitValue of + Just value -> pure value + Nothing -> runDefault defaultSpec + SelectConfig selector branch -> do + decision <- runConfig interpret selector + case decision of + Right value -> pure value + Left value -> do + applyBranch <- runConfig interpret branch + pure (applyBranch value) + where + runDefault = \case + ConstantDefault _ _ value -> pure value + DerivedDefault _ _ dependency derive -> + derive <$> runConfig interpret dependency + CaseDefault _ _ dependency choices fallback -> do + dependencyValue <- runConfig interpret dependency + case lookup dependencyValue (NonEmpty.toList choices) of + Just value -> pure value + Nothing -> case fallback of + Just value -> pure value + Nothing -> error "Settei.Internal.Config.runConfig: unmatched case default" + +describeConfig :: Config a -> Schema +describeConfig = \case + PureConfig _ -> emptySchema + MapConfig _ config -> describeConfig config + ApplyConfig function inputConfig -> + combineSchema (describeConfig function) (describeConfig inputConfig) + RequestConfig request -> case request of + RequiredRequest settingSpec -> requestSchema Required settingSpec + OptionalRequest settingSpec -> requestSchema Optional settingSpec + DefaultConfig settingSpec defaultSpec -> + conditionalSchema + (requestSchema Optional settingSpec) + (describeDefault defaultSpec) + SelectConfig selector branch -> + conditionalSchema (describeConfig selector) (describeConfig branch) + +describeDefault :: Default a -> Schema +describeDefault = \case + ConstantDefault _ _ _ -> emptySchema + DerivedDefault _ _ dependency _ -> describeConfig dependency + CaseDefault _ _ dependency _ _ -> describeConfig dependency diff --git a/src/Settei/Internal/Schema.hs b/src/Settei/Internal/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Settei/Internal/Schema.hs @@ -0,0 +1,118 @@ +module Settei.Internal.Schema + ( Condition (..), + Presence (..), + Requirement (..), + Schema (..), + SchemaSetting (..), + combineSchema, + conditionalSchema, + emptySchema, + requestSchema, + ) +where + +import Data.Generics.Labels () +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Settei.Key (Key) +import Settei.Prelude +import Settei.Setting + ( Sensitivity, + Setting, + settingDescription, + settingKey, + settingSensitivity, + ) + +-- | Whether absence of a candidate is an error at runtime. +data Requirement = Required | Optional + deriving stock (Generic, Eq, Ord, Show) + +-- | Whether a declaration is evaluated on every execution path. +data Presence = Necessary | Conditional + deriving stock (Generic, Eq, Ord, Show) + +-- | Static metadata for one possible setting request. +data SchemaSetting = SchemaSetting + { key :: !Key, + description :: !Text, + sensitivity :: !Sensitivity, + requirement :: !Requirement, + presence :: !Presence + } + deriving stock (Generic, Eq, Show) + +-- | A conservative relationship introduced by a selective branch. +data Condition = Condition + { dependencies :: !(Set Key), + settings :: !(Set Key) + } + deriving stock (Generic, Eq, Show) + +-- | The complete static over-approximation of a configuration declaration. +data Schema = Schema + { settings :: !(Map Key SchemaSetting), + conditions :: ![Condition] + } + deriving stock (Generic, Eq, Show) + +emptySchema :: Schema +emptySchema = Schema {settings = Map.empty, conditions = []} + +requestSchema :: Requirement -> Setting a -> Schema +requestSchema requirement settingSpec = + Schema + { settings = Map.singleton key entry, + conditions = [] + } + where + key = settingKey settingSpec + entry = + SchemaSetting + { key, + description = settingDescription settingSpec, + sensitivity = settingSensitivity settingSpec, + requirement, + presence = Necessary + } + +combineSchema :: Schema -> Schema -> Schema +combineSchema left right = + Schema + { settings = + Map.unionWith mergeSetting (left ^. #settings) (right ^. #settings), + conditions = left ^. #conditions <> right ^. #conditions + } + +conditionalSchema :: Schema -> Schema -> Schema +conditionalSchema selector branch = + combined + & #conditions + %~ (<> newCondition) + where + branchSettings = branch ^. #settings & each . #presence .~ Conditional + branchKeys = Map.keysSet branchSettings + selectorKeys = Map.keysSet (selector ^. #settings) + conditionalBranch = branch & #settings .~ branchSettings + combined = combineSchema selector conditionalBranch + newCondition + | Set.null branchKeys = [] + | otherwise = [Condition {dependencies = selectorKeys, settings = branchKeys}] + +mergeSetting :: SchemaSetting -> SchemaSetting -> SchemaSetting +mergeSetting left right = + left + & #requirement + .~ mergeRequirement (left ^. #requirement) (right ^. #requirement) + & #presence + .~ mergePresence (left ^. #presence) (right ^. #presence) + +mergeRequirement :: Requirement -> Requirement -> Requirement +mergeRequirement Required _ = Required +mergeRequirement _ Required = Required +mergeRequirement Optional Optional = Optional + +mergePresence :: Presence -> Presence -> Presence +mergePresence Necessary _ = Necessary +mergePresence _ Necessary = Necessary +mergePresence Conditional Conditional = Conditional diff --git a/src/Settei/Key.hs b/src/Settei/Key.hs new file mode 100644 --- /dev/null +++ b/src/Settei/Key.hs @@ -0,0 +1,65 @@ +-- | +-- Module: Settei.Key +-- Description: Validated structural keys with canonical dotted rendering. +module Settei.Key + ( Key, + KeyError (..), + mkKey, + parseKey, + renderKey, + keySegments, + ) +where + +import Data.Generics.Labels () +import Data.List.NonEmpty qualified as NonEmpty +import Data.Text qualified as Text +import Settei.Prelude + +-- | A validated, hierarchical configuration key. +newtype Key = ValidatedKey + { segments :: NonEmpty Text + } + deriving stock (Generic, Eq, Ord, Show) + +-- | Why textual input could not be represented as a 'Key'. +data KeyError + = KeyIsEmpty + | KeySegmentIsEmpty + | KeySegmentContainsDot !Text + deriving stock (Generic, Eq, Show) + +-- | Validate structural key segments. +mkKey :: NonEmpty Text -> Either KeyError Key +mkKey value + | any Text.null segmentList = Left KeySegmentIsEmpty + | Just part <- findWithDot segmentList = Left (KeySegmentContainsDot part) + | otherwise = Right (ValidatedKey value) + where + segmentList = NonEmpty.toList value + findWithDot = find (Text.any (== '.')) + +-- | Parse dot-separated text into a non-empty structural key. +parseKey :: Text -> Either KeyError Key +parseKey value + | Text.null value = Left KeyIsEmpty + | otherwise = + maybe + (Left KeyIsEmpty) + mkKey + (NonEmpty.nonEmpty (Text.splitOn "." value)) + +-- | Render a key using its canonical dot-separated spelling. +renderKey :: Key -> Text +renderKey value = Text.intercalate "." (NonEmpty.toList (value ^. #segments)) + +-- | Return the structural segments of a key. +keySegments :: Key -> NonEmpty Text +keySegments value = value ^. #segments + +find :: (a -> Bool) -> [a] -> Maybe a +find predicate = \case + [] -> Nothing + value : rest + | predicate value -> Just value + | otherwise -> find predicate rest diff --git a/src/Settei/Origin.hs b/src/Settei/Origin.hs new file mode 100644 --- /dev/null +++ b/src/Settei/Origin.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +-- | +-- Module: Settei.Origin +-- Description: Adapter-neutral metadata describing where a candidate came from. +module Settei.Origin + ( KubernetesObjectKind (..), + KubernetesRef, + Origin (..), + SourceKind (..), + SourceLocation (..), + kubernetesAnnotations, + kubernetesRef, + kubernetesRefKey, + kubernetesRefKind, + kubernetesRefName, + kubernetesRefNamespace, + ) +where + +import Data.Generics.Labels () +import Data.Map.Strict qualified as Map +import Settei.Key (Key) +import Settei.Prelude + +-- | A format-independent category for a configuration source. +data SourceKind + = BuiltInSource + | FileSource !Text + | EnvironmentSource + | CommandLineSource + | DerivedSource + | CustomSource !Text + deriving stock (Generic, Eq, Ord, Show) + +-- | An optional source location retained by an adapter. +data SourceLocation = SourceLocation + { path :: !Text, + line :: !(Maybe Int), + column :: !(Maybe Int) + } + deriving stock (Generic, Eq, Ord, Show) + +-- | Structured provenance for one logical configuration key. +data Origin = Origin + { kind :: !SourceKind, + name :: !Text, + key :: !Key, + location :: !(Maybe SourceLocation), + annotations :: !(Map Text Text) + } + deriving stock (Generic, Eq, Show) + +-- | Kubernetes object categories shared by independent adapters. +data KubernetesObjectKind = ConfigMapObject | SecretObject + deriving stock (Generic, Eq, Ord, Show) + +-- | A cluster-independent Kubernetes object reference. +data KubernetesRef = KubernetesRef + { kind :: !KubernetesObjectKind, + namespace :: !(Maybe Text), + name :: !Text, + key :: !(Maybe Text) + } + deriving stock (Generic, Eq, Ord, Show) + +-- | Construct a reference without performing a cluster lookup. +kubernetesRef :: KubernetesObjectKind -> Maybe Text -> Text -> Maybe Text -> KubernetesRef +kubernetesRef kind namespace name key = KubernetesRef {kind, namespace, name, key} + +-- | Return the referenced Kubernetes object kind. +kubernetesRefKind :: KubernetesRef -> KubernetesObjectKind +kubernetesRefKind value = value ^. #kind + +-- | Return the optional Kubernetes namespace. +kubernetesRefNamespace :: KubernetesRef -> Maybe Text +kubernetesRefNamespace value = value ^. #namespace + +-- | Return the Kubernetes object name. +kubernetesRefName :: KubernetesRef -> Text +kubernetesRefName value = value ^. #name + +-- | Return the optional key within the Kubernetes object. +kubernetesRefKey :: KubernetesRef -> Maybe Text +kubernetesRefKey value = value ^. #key + +-- | Stable annotations understood across Kubernetes-aware adapters. +kubernetesAnnotations :: KubernetesRef -> Map Text Text +kubernetesAnnotations value = + Map.fromList + ( [ ("kubernetes.object-kind", renderObjectKind (value ^. #kind)), + ("kubernetes.object-name", value ^. #name) + ] + <> maybe [] (pure . ("kubernetes.namespace",)) (value ^. #namespace) + <> maybe [] (pure . ("kubernetes.object-key",)) (value ^. #key) + ) + +renderObjectKind :: KubernetesObjectKind -> Text +renderObjectKind ConfigMapObject = "ConfigMap" +renderObjectKind SecretObject = "Secret" diff --git a/src/Settei/Prelude.hs b/src/Settei/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Settei/Prelude.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE PackageImports #-} + +-- | +-- Module: Settei.Prelude +-- Description: Small shared project prelude and lens operator surface. +module Settei.Prelude + ( module X, + module Control.Lens, + ) +where + +import "base" Data.List.NonEmpty as X (NonEmpty (..)) +import "base" GHC.Generics as X (Generic) +import "containers" Data.Map.Strict as X (Map) +import "containers" Data.Set as X (Set) +import "lens" Control.Lens hiding (Setting) +import "text" Data.Text as X (Text) +import "base" Prelude as X diff --git a/src/Settei/Provenance.hs b/src/Settei/Provenance.hs new file mode 100644 --- /dev/null +++ b/src/Settei/Provenance.hs @@ -0,0 +1,105 @@ +-- | +-- Module: Settei.Provenance +-- Description: Raw candidates paired with their structured origin. +module Settei.Provenance + ( Candidate, + ReportedValue, + candidate, + candidateOrigin, + candidateValue, + derivedReportedValue, + renderReportedValue, + reportedValue, + visibleReportedValue, + ) +where + +import Data.Generics.Labels () +import Data.Map.Strict qualified as Map +import Data.Ratio qualified as Ratio +import Data.Text qualified as Text +import Settei.Origin (Origin) +import Settei.Prelude +import Settei.Setting (Sensitivity (..)) +import Settei.Value (RawValue (..)) + +-- | One source's value for one declared key. +-- +-- There is deliberately no 'Show' instance: the raw value may be secret. +data Candidate = Candidate + { value :: !RawValue, + origin :: !Origin + } + deriving stock (Generic, Eq) + +-- | Pair one raw source value with its exact origin. +candidate :: RawValue -> Origin -> Candidate +candidate value origin = Candidate {value, origin} + +-- | Return the candidate's raw value for core decoding. +candidateValue :: Candidate -> RawValue +candidateValue value = value ^. #value + +-- | Return the candidate's structured origin. +candidateOrigin :: Candidate -> Origin +candidateOrigin value = value ^. #origin + +-- | A value safe to retain in reports and structured errors. +-- +-- Constructors are private so reporting code can display a value but cannot unwrap a +-- supposedly redacted secret. +data ReportedValue + = VisibleValue !Text + | RedactedValue + | DerivedValue + deriving stock (Generic, Eq, Ord, Show) + +-- | Apply a setting's sensitivity before retaining any display representation. +reportedValue :: Sensitivity -> RawValue -> ReportedValue +reportedValue Public = VisibleValue . renderRawValue +reportedValue Secret = const RedactedValue + +-- | Render a retained value. A redacted value has no recovery path. +renderReportedValue :: ReportedValue -> Text +renderReportedValue (VisibleValue value) = value +renderReportedValue RedactedValue = "" +renderReportedValue DerivedValue = "" + +-- | Represent a typed default when no format-independent encoder exists. +derivedReportedValue :: Sensitivity -> ReportedValue +derivedReportedValue Public = DerivedValue +derivedReportedValue Secret = RedactedValue + +-- | Retain an already-rendered public value. +visibleReportedValue :: Text -> ReportedValue +visibleReportedValue = VisibleValue + +renderRawValue :: RawValue -> Text +renderRawValue = \case + RawNull -> "null" + RawText value -> "\"" <> escapeText value <> "\"" + RawBool True -> "true" + RawBool False -> "false" + 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)) + RawArray values -> "[" <> Text.intercalate ", " (fmap renderRawValue values) <> "]" + RawObject values -> + "{" + <> Text.intercalate + ", " + [ "\"" <> escapeText key <> "\": " <> renderRawValue value + | (key, value) <- Map.toAscList values + ] + <> "}" + +escapeText :: Text -> Text +escapeText = + Text.replace "\n" "\\n" + . Text.replace "\r" "\\r" + . Text.replace "\t" "\\t" + . Text.replace "\"" "\\\"" + . Text.replace "\\" "\\\\" diff --git a/src/Settei/Render.hs b/src/Settei/Render.hs new file mode 100644 --- /dev/null +++ b/src/Settei/Render.hs @@ -0,0 +1,461 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +-- | +-- Module: Settei.Render +-- Description: Deterministic text and versioned JSON presentation. +module Settei.Render + ( renderErrorsJson, + renderErrorsText, + renderResolutionJson, + renderResolutionText, + renderSchemaJson, + renderSchemaText, + renderWarningsJson, + renderWarningsText, + ) +where + +import Control.Applicative ((<|>)) +import Data.Char (ord) +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 Data.Text qualified as Text +import Numeric (showHex) +import Settei.Default (renderRuleName) +import Settei.Error +import Settei.Key (Key, renderKey) +import Settei.Origin +import Settei.Prelude +import Settei.Provenance (renderReportedValue) +import Settei.Report +import Settei.Schema +import Settei.Setting (Sensitivity (..)) + +-- | Render a static schema in stable key order. +renderSchemaText :: Schema -> Text +renderSchemaText schema = + Text.unlines + ( fmap renderSchemaSettingText (schemaPossible schema) + <> concatMap renderConditionText (zip [1 :: Int ..] (schemaConditions schema)) + ) + +renderSchemaSettingText :: SchemaSetting -> Text +renderSchemaSettingText schemaEntry = + renderKey (schemaSettingKey schemaEntry) + <> " [" + <> requirementText (schemaSettingRequirement schemaEntry) + <> ", " + <> presenceText (schemaSettingPresence schemaEntry) + <> ", " + <> sensitivityText (schemaSettingSensitivity schemaEntry) + <> "] " + <> schemaSettingDescription schemaEntry + +renderConditionText :: (Int, Condition) -> [Text] +renderConditionText (conditionNumber, condition) = + [ "condition " + <> Text.pack (show conditionNumber) + <> ": " + <> commaKeys (Set.toAscList (conditionDependencies condition)) + <> " -> " + <> commaKeys (Set.toAscList (conditionSettings condition)) + ] + +-- | Render one successful resolution, including skipped settings and branch decisions. +renderResolutionText :: ResolutionReport -> Text +renderResolutionText report = + Text.concat (fmap (renderNodeText report) (reportNodes report)) + <> Text.concat (fmap renderBranchText (zip [1 :: Int ..] (reportBranches report))) + +renderNodeText :: ResolutionReport -> ResolutionNode -> Text +renderNodeText report node = + renderKey (node ^. #key) + <> " = " + <> outcomeValueText (node ^. #outcome) + <> "\n" + <> maybe "" (renderOriginText " from ") (node ^. #origin) + <> maybe "" (renderDerivationText report) (node ^. #derivation) + <> Text.concat (fmap (renderOriginText " shadowed: ") (node ^. #shadowed)) + +renderDerivationText :: ResolutionReport -> Derivation -> Text +renderDerivationText report derivation = + Text.concat (fmap renderDependency (derivation ^. #dependencies)) + where + renderDependency key = + case report ^. #nodes . at key of + Nothing -> " because " <> renderKey key <> " = \n" + Just node -> + " because " + <> renderKey key + <> " = " + <> outcomeValueText (node ^. #outcome) + <> "\n" + <> maybe "" (renderOriginText " from ") (node ^. #origin) + +renderBranchText :: (Int, BranchTrace) -> Text +renderBranchText (branchNumber, branch) = + "branch " + <> Text.pack (show branchNumber) + <> " [" + <> (if branch ^. #selected then "selected" else "not selected") + <> "]: " + <> commaKeys (branch ^. #dependencies) + <> " -> " + <> commaKeys (branch ^. #settings) + <> "\n" + +renderOriginText :: Text -> Origin -> Text +renderOriginText prefix origin = prefix <> originDescription origin <> "\n" + +originDescription :: Origin -> Text +originDescription origin = + baseDescription <> dhallSuffix origin <> kubernetesSuffix origin + where + baseDescription = case origin ^. #kind of + BuiltInSource -> "built-in source " <> origin ^. #name + FileSource formatName -> "file source " <> origin ^. #name <> " (" <> formatName <> ")" + EnvironmentSource -> + maybe + ("environment source " <> origin ^. #name) + ("environment variable " <>) + (origin ^. #annotations . at "environment.variable") + CommandLineSource -> + "command-line option " + <> fromMaybe + (origin ^. #name) + ( origin ^. #annotations . at "command-line.spelling" + <|> origin ^. #annotations . at "command-line.option" + ) + <> maybe + "" + (" occurrence " <>) + (origin ^. #annotations . at "command-line.occurrence") + DerivedSource -> "default rule " <> origin ^. #name + CustomSource customKind -> customKind <> " source " <> origin ^. #name + +dhallSuffix :: Origin -> Text +dhallSuffix origin = case origin ^. #kind of + FileSource "Dhall" -> + case origin ^. #annotations . at "dhall.root" of + Nothing -> "" + Just root -> + " rooted at " + <> root + <> " evaluated with " + <> fromMaybe "0" (origin ^. #annotations . at "dhall.import-count") + <> " local imports; leaf-level import attribution unavailable after normalization" + _ -> "" + +kubernetesSuffix :: Origin -> Text +kubernetesSuffix origin = + case ( origin ^. #annotations . at "kubernetes.object-kind", + origin ^. #annotations . at "kubernetes.object-name" + ) of + (Just objectKind, Just objectName) -> + " from Kubernetes " + <> objectKind + <> " " + <> maybe "" (<> "/") (origin ^. #annotations . at "kubernetes.namespace") + <> objectName + <> maybe "" (" key " <>) (origin ^. #annotations . at "kubernetes.object-key") + _ -> "" + +-- | Render structured failures without access to rejected secret values. +renderErrorsText :: NonEmpty ConfigError -> Text +renderErrorsText = Text.unlines . fmap renderErrorText . NonEmpty.toList + +renderErrorText :: ConfigError -> Text +renderErrorText = \case + MissingRequired problem -> renderKey (problem ^. #key) <> ": required value is missing" + DecodeError problem -> + renderKey (problem ^. #key) + <> ": expected " + <> problem ^. #expected + <> " from " + <> originDescription (problem ^. #origin) + <> ", rejected " + <> renderReportedValue (problem ^. #rejected) + StructuralConflict problem -> + renderKey (problem ^. #key) + <> ": cannot traverse " + <> renderKey (problem ^. #blockedAt) + <> " through " + <> rawShapeText (problem ^. #shape) + <> " in " + <> originDescription (problem ^. #origin) + UnknownKeyError problem -> + renderKey (problem ^. #key) + <> ": unknown key in " + <> originDescription (problem ^. #origin) + DefaultError problem -> + renderKey (problem ^. #key) + <> ": default rule " + <> renderRuleName (problem ^. #rule) + <> " failed: " + <> problem ^. #message + DefaultCycle problem -> + "default cycle: " + <> Text.intercalate " -> " (fmap renderRuleName (NonEmpty.toList (problem ^. #rules))) + +-- | Render non-fatal diagnostics in deterministic source and key order. +renderWarningsText :: [ConfigWarning] -> Text +renderWarningsText = Text.unlines . fmap renderWarningText + +renderWarningText :: ConfigWarning -> Text +renderWarningText = \case + UnknownKeyWarning problem -> + renderKey (problem ^. #key) + <> ": unknown key in " + <> originDescription (problem ^. #origin) + +-- | Render a schema as versioned deterministic JSON. +renderSchemaJson :: Schema -> Text +renderSchemaJson schema = + versionedJson + "settei.schema" + [ ("settings", jsonArray (fmap schemaSettingJson (schemaPossible schema))), + ("conditions", jsonArray (fmap conditionJson (schemaConditions schema))) + ] + +schemaSettingJson :: SchemaSetting -> Text +schemaSettingJson schemaEntry = + jsonObject + [ ("key", jsonString (renderKey (schemaSettingKey schemaEntry))), + ("description", jsonString (schemaSettingDescription schemaEntry)), + ("sensitivity", jsonString (sensitivityText (schemaSettingSensitivity schemaEntry))), + ("requirement", jsonString (requirementText (schemaSettingRequirement schemaEntry))), + ("presence", jsonString (presenceText (schemaSettingPresence schemaEntry))) + ] + +conditionJson :: Condition -> Text +conditionJson condition = + jsonObject + [ ("dependencies", jsonKeyArray (Set.toAscList (conditionDependencies condition))), + ("settings", jsonKeyArray (Set.toAscList (conditionSettings condition))) + ] + +-- | Render a successful resolution as versioned deterministic JSON. +renderResolutionJson :: ResolutionReport -> Text +renderResolutionJson report = + versionedJson + "settei.resolution" + [ ("nodes", jsonArray (fmap resolutionNodeJson (reportNodes report))), + ("branches", jsonArray (fmap branchJson (reportBranches report))) + ] + +resolutionNodeJson :: ResolutionNode -> Text +resolutionNodeJson node = + jsonObject + [ ("key", jsonString (renderKey (node ^. #key))), + ("sensitivity", jsonString (sensitivityText (node ^. #sensitivity))), + ("outcome", jsonString (outcomeTag (node ^. #outcome))), + ("value", outcomeValueJson (node ^. #outcome)), + ("origin", maybe "null" originJson (node ^. #origin)), + ("shadowed", jsonArray (fmap originJson (node ^. #shadowed))), + ("derivation", maybe "null" derivationJson (node ^. #derivation)) + ] + +derivationJson :: Derivation -> Text +derivationJson derivation = + jsonObject + [ ("rule", jsonString (derivation ^. #rule)), + ("explanation", jsonString (derivation ^. #explanation)), + ("dependencies", jsonKeyArray (derivation ^. #dependencies)) + ] + +branchJson :: BranchTrace -> Text +branchJson branch = + jsonObject + [ ("dependencies", jsonKeyArray (branch ^. #dependencies)), + ("settings", jsonKeyArray (branch ^. #settings)), + ("selected", if branch ^. #selected then "true" else "false") + ] + +originJson :: Origin -> Text +originJson origin = + jsonObject + [ ("kind", jsonString (sourceKindTag (origin ^. #kind))), + ("kindDetail", maybe "null" jsonString (sourceKindDetail (origin ^. #kind))), + ("name", jsonString (origin ^. #name)), + ("key", jsonString (renderKey (origin ^. #key))), + ("location", maybe "null" locationJson (origin ^. #location)), + ("annotations", jsonTextMap (origin ^. #annotations)) + ] + +locationJson :: SourceLocation -> Text +locationJson location = + jsonObject + [ ("path", jsonString (location ^. #path)), + ("line", maybe "null" jsonInt (location ^. #line)), + ("column", maybe "null" jsonInt (location ^. #column)) + ] + +-- | Render failures as a versioned deterministic JSON document. +renderErrorsJson :: NonEmpty ConfigError -> Text +renderErrorsJson errors = + versionedJson + "settei.errors" + [("errors", jsonArray (fmap errorJson (NonEmpty.toList errors)))] + +errorJson :: ConfigError -> Text +errorJson = \case + MissingRequired problem -> + jsonObject + [ ("kind", jsonString "missing-required"), + ("key", jsonString (renderKey (problem ^. #key))) + ] + DecodeError problem -> + jsonObject + [ ("kind", jsonString "decode-error"), + ("key", jsonString (renderKey (problem ^. #key))), + ("expected", jsonString (problem ^. #expected)), + ("origin", originJson (problem ^. #origin)), + ("rejected", jsonString (renderReportedValue (problem ^. #rejected))) + ] + StructuralConflict problem -> + jsonObject + [ ("kind", jsonString "structural-conflict"), + ("key", jsonString (renderKey (problem ^. #key))), + ("blockedAt", jsonString (renderKey (problem ^. #blockedAt))), + ("shape", jsonString (rawShapeText (problem ^. #shape))), + ("origin", originJson (problem ^. #origin)) + ] + UnknownKeyError problem -> + jsonObject + [ ("kind", jsonString "unknown-key"), + ("key", jsonString (renderKey (problem ^. #key))), + ("origin", originJson (problem ^. #origin)) + ] + DefaultError problem -> + jsonObject + [ ("kind", jsonString "default-error"), + ("key", jsonString (renderKey (problem ^. #key))), + ("rule", jsonString (renderRuleName (problem ^. #rule))), + ("message", jsonString (problem ^. #message)) + ] + DefaultCycle problem -> + jsonObject + [ ("kind", jsonString "default-cycle"), + ("rules", jsonArray (fmap (jsonString . renderRuleName) (NonEmpty.toList (problem ^. #rules)))) + ] + +-- | Render warnings as a versioned deterministic JSON document. +renderWarningsJson :: [ConfigWarning] -> Text +renderWarningsJson warnings = + versionedJson + "settei.warnings" + [("warnings", jsonArray (fmap warningJson warnings))] + +warningJson :: ConfigWarning -> Text +warningJson = \case + UnknownKeyWarning problem -> + jsonObject + [ ("kind", jsonString "unknown-key"), + ("key", jsonString (renderKey (problem ^. #key))), + ("origin", originJson (problem ^. #origin)) + ] + +outcomeValueText :: ResolutionOutcome -> Text +outcomeValueText = \case + Resolved value -> renderReportedValue value + MissingValue -> "" + NotSelected -> "" + +outcomeTag :: ResolutionOutcome -> Text +outcomeTag = \case + Resolved _ -> "resolved" + MissingValue -> "missing" + NotSelected -> "not-selected" + +outcomeValueJson :: ResolutionOutcome -> Text +outcomeValueJson = \case + Resolved value -> jsonString (renderReportedValue value) + MissingValue -> "null" + NotSelected -> "null" + +requirementText :: Requirement -> Text +requirementText Required = "required" +requirementText Optional = "optional" + +presenceText :: Presence -> Text +presenceText Necessary = "necessary" +presenceText Conditional = "conditional" + +sensitivityText :: Sensitivity -> Text +sensitivityText Public = "public" +sensitivityText Secret = "secret" + +rawShapeText :: RawShape -> Text +rawShapeText NullShape = "null" +rawShapeText ScalarShape = "scalar" +rawShapeText ArrayShape = "array" + +sourceKindTag :: SourceKind -> Text +sourceKindTag BuiltInSource = "built-in" +sourceKindTag (FileSource _) = "file" +sourceKindTag EnvironmentSource = "environment" +sourceKindTag CommandLineSource = "command-line" +sourceKindTag DerivedSource = "derived" +sourceKindTag (CustomSource _) = "custom" + +sourceKindDetail :: SourceKind -> Maybe Text +sourceKindDetail (FileSource value) = Just value +sourceKindDetail (CustomSource value) = Just value +sourceKindDetail _ = Nothing + +commaKeys :: [Key] -> Text +commaKeys = Text.intercalate ", " . fmap renderKey + +jsonKeyArray :: [Key] -> Text +jsonKeyArray = jsonArray . fmap (jsonString . renderKey) + +jsonTextMap :: Map Text Text -> Text +jsonTextMap = + jsonObject . fmap (\(key, value) -> (key, jsonString value)) . Map.toAscList + +jsonInt :: Int -> Text +jsonInt = Text.pack . show + +versionedJson :: Text -> [(Text, Text)] -> Text +versionedJson documentType fields = + jsonObject + ( [ ("schemaVersion", "1"), + ("type", jsonString documentType) + ] + <> fields + ) + +jsonObject :: [(Text, Text)] -> Text +jsonObject fields = + "{" + <> Text.intercalate + "," + [jsonString key <> ":" <> value | (key, value) <- fields] + <> "}" + +jsonArray :: [Text] -> Text +jsonArray values = "[" <> Text.intercalate "," values <> "]" + +jsonString :: Text -> Text +jsonString value = "\"" <> Text.concatMap escapeJsonChar value <> "\"" + +escapeJsonChar :: Char -> Text +escapeJsonChar = \case + '"' -> "\\\"" + '\\' -> "\\\\" + '\b' -> "\\b" + '\f' -> "\\f" + '\n' -> "\\n" + '\r' -> "\\r" + '\t' -> "\\t" + character + | ord character < 0x20 -> "\\u" <> paddedHex (ord character) + | otherwise -> Text.singleton character + +paddedHex :: Int -> Text +paddedHex value = + let rendered = Text.pack (showHex value "") + in Text.replicate (4 - Text.length rendered) "0" <> rendered diff --git a/src/Settei/Report.hs b/src/Settei/Report.hs new file mode 100644 --- /dev/null +++ b/src/Settei/Report.hs @@ -0,0 +1,70 @@ +-- | +-- Module: Settei.Report +-- Description: Secret-safe data describing one resolution run. +module Settei.Report + ( BranchTrace (..), + Derivation (..), + ResolutionNode (..), + ResolutionOutcome (..), + ResolutionReport (..), + reportBranches, + reportNodes, + ) +where + +import Data.Generics.Labels () +import Data.Map.Strict qualified as Map +import Settei.Key (Key) +import Settei.Origin (Origin) +import Settei.Prelude +import Settei.Provenance (ReportedValue) +import Settei.Setting (Sensitivity) + +-- | What happened to a statically possible setting in this run. +data ResolutionOutcome + = Resolved !ReportedValue + | MissingValue + | NotSelected + deriving stock (Generic, Eq, Show) + +-- | A named default rule that produced a setting value. +data Derivation = Derivation + { rule :: !Text, + explanation :: !Text, + dependencies :: ![Key] + } + deriving stock (Generic, Eq, Show) + +-- | One evaluated or skipped setting, keyed independently in the report map. +data ResolutionNode = ResolutionNode + { key :: !Key, + sensitivity :: !Sensitivity, + outcome :: !ResolutionOutcome, + origin :: !(Maybe Origin), + shadowed :: ![Origin], + derivation :: !(Maybe Derivation) + } + deriving stock (Generic, Eq, Show) + +-- | Whether one selective branch was evaluated for this run. +data BranchTrace = BranchTrace + { dependencies :: ![Key], + settings :: ![Key], + selected :: !Bool + } + deriving stock (Generic, Eq, Show) + +-- | Complete, secret-safe trace for one successful resolution. +data ResolutionReport = ResolutionReport + { nodes :: !(Map Key ResolutionNode), + branches :: ![BranchTrace] + } + deriving stock (Generic, Eq, Show) + +-- | Return resolution nodes in stable key order. +reportNodes :: ResolutionReport -> [ResolutionNode] +reportNodes value = value ^. #nodes . to Map.elems + +-- | Return branch decisions in evaluation order. +reportBranches :: ResolutionReport -> [BranchTrace] +reportBranches value = value ^. #branches diff --git a/src/Settei/Resolve.hs b/src/Settei/Resolve.hs new file mode 100644 --- /dev/null +++ b/src/Settei/Resolve.hs @@ -0,0 +1,477 @@ +{-# LANGUAGE GADTs #-} + +-- | +-- Module: Settei.Resolve +-- Description: Deterministic interpretation of declarations against ordered sources. +module Settei.Resolve + ( ResolveOptions (..), + ResolveResult (..), + UnknownKeyPolicy (..), + defaultResolveOptions, + resolve, + ) +where + +import Data.Generics.Labels () +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import Settei.Error +import Settei.Internal.Config + ( Config (..), + Default (..), + Request (..), + RuleName, + describeConfig, + renderRuleName, + ) +import Settei.Internal.Schema (Schema) +import Settei.Key (Key, keySegments) +import Settei.Origin (Origin (..), SourceKind (DerivedSource)) +import Settei.Prelude +import Settei.Provenance + ( Candidate, + ReportedValue, + candidateOrigin, + candidateValue, + derivedReportedValue, + reportedValue, + visibleReportedValue, + ) +import Settei.Report +import Settei.Schema + ( SchemaSetting, + schemaPossible, + schemaSettingKey, + schemaSettingSensitivity, + ) +import Settei.Setting + ( Sensitivity (..), + Setting, + decodeSetting, + settingKey, + settingSensitivity, + settingValueRenderer, + ) +import Settei.Source (Source, lookupSource, sourceLeaves) +import Settei.Value (decodeFailureExpected) + +-- | How undeclared source leaves affect resolution. +data UnknownKeyPolicy = WarnUnknownKeys | RejectUnknownKeys + deriving stock (Generic, Eq, Ord, Show) + +-- | Resolver behavior independent of any source adapter. +data ResolveOptions = ResolveOptions + { unknownKeyPolicy :: !UnknownKeyPolicy + } + deriving stock (Generic, Eq, Show) + +-- | The typed result plus its safe explanation and non-fatal diagnostics. +data ResolveResult a = ResolveResult + { value :: !a, + report :: !ResolutionReport, + warnings :: ![ConfigWarning] + } + deriving stock (Generic) + +-- | Warn about unknown keys while retaining all other default resolver semantics. +defaultResolveOptions :: ResolveOptions +defaultResolveOptions = ResolveOptions {unknownKeyPolicy = WarnUnknownKeys} + +-- | Resolve sources ordered from lowest to highest precedence. +-- +-- 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) +resolve options sources config = + case NonEmpty.nonEmpty (validateDefaultCycles config) of + Just errors -> Left errors + Nothing -> resolveValidated + where + resolveValidated = + case NonEmpty.nonEmpty structuralErrors of + Just errors -> Left 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 + } + schemaSettings = schemaPossible (describeEvaluation config) + structuralErrors = validateStructure schemaSettings sources + evaluation = evaluate sources config + unknownProblems = findUnknownKeys schemaSettings sources + unknownWarnings = case options ^. #unknownKeyPolicy of + WarnUnknownKeys -> fmap UnknownKeyWarning unknownProblems + RejectUnknownKeys -> [] + strictUnknownErrors = case options ^. #unknownKeyPolicy of + WarnUnknownKeys -> Right () + RejectUnknownKeys -> errorsOnly (fmap UnknownKeyError unknownProblems) + completeNodes = addNotSelected schemaSettings (evaluation ^. #nodes) + +validateStructure :: [SchemaSetting] -> [Source] -> [ConfigError] +validateStructure schemaSettings sources = + unique + [ StructuralConflict structuralError + | schemaSetting <- schemaSettings, + sourceValue <- sources, + Left structuralError <- [lookupSource (schemaSettingKey schemaSetting) sourceValue] + ] + +unique :: (Eq a) => [a] -> [a] +unique = foldl appendIfNew [] + where + appendIfNew values value + | value `elem` values = values + | otherwise = values <> [value] + +validateDefaultCycles :: Config a -> [ConfigError] +validateDefaultCycles = go [] + where + go :: [RuleName] -> Config b -> [ConfigError] + go active = \case + PureConfig _ -> [] + MapConfig _ config -> go active config + ApplyConfig function inputConfig -> go active function <> go active inputConfig + RequestConfig _ -> [] + DefaultConfig _ defaultSpec -> validateDefault active defaultSpec + SelectConfig selector branch -> go active selector <> go active branch + + validateDefault :: [RuleName] -> Default b -> [ConfigError] + validateDefault active defaultSpec = + let rule = defaultRule defaultSpec + in if rule `elem` active + then [DefaultCycle (DefaultCycleProblem {rules = cycleRules rule active})] + else case defaultSpec of + ConstantDefault _ _ _ -> [] + DerivedDefault _ _ dependency _ -> go (active <> [rule]) dependency + CaseDefault _ _ dependency _ _ -> go (active <> [rule]) dependency + + cycleRules rule active = + case NonEmpty.nonEmpty (dropWhile (/= rule) active <> [rule]) of + Just rules -> rules + Nothing -> rule :| [] + +defaultRule :: Default a -> RuleName +defaultRule = \case + ConstantDefault rule _ _ -> rule + DerivedDefault rule _ _ _ -> rule + CaseDefault rule _ _ _ _ -> rule + +data Evaluation a = Evaluation + { answer :: !(Either [ConfigError] a), + nodes :: !(Map Key ResolutionNode), + branches :: ![BranchTrace] + } + deriving stock (Generic) + +evaluate :: [Source] -> Config a -> Evaluation a +evaluate sources = \case + PureConfig value -> successful value + MapConfig mapValue config -> mapEvaluation mapValue (evaluate sources config) + ApplyConfig function inputConfig -> + applyEvaluation (evaluate sources function) (evaluate sources inputConfig) + RequestConfig request -> evaluateRequest sources request + DefaultConfig settingSpec defaultSpec -> + evaluateDefaultRequest sources settingSpec defaultSpec + SelectConfig selector branch -> + let selectorEvaluation = evaluate sources selector + selectorKeys = Map.keys (selectorEvaluation ^. #nodes) + branchKeys = fmap schemaSettingKey (schemaPossible (describeEvaluation branch)) + in case selectorEvaluation ^. #answer of + Left errors -> selectorEvaluation & #answer .~ Left errors + Right (Right value) -> + selectorEvaluation + & #answer + .~ Right value + & #branches + %~ (<> [BranchTrace {dependencies = selectorKeys, settings = branchKeys, selected = False}]) + Right (Left input) -> + let branchEvaluation = evaluate sources branch + combined = mapEvaluation ($ input) branchEvaluation + in Evaluation + { answer = combined ^. #answer, + nodes = Map.union (selectorEvaluation ^. #nodes) (branchEvaluation ^. #nodes), + branches = + selectorEvaluation ^. #branches + <> branchEvaluation ^. #branches + <> [BranchTrace {dependencies = selectorKeys, settings = branchKeys, selected = True}] + } + +-- | Static inspection implemented locally to keep the raw constructors private from the +-- public resolver surface. +describeEvaluation :: Config a -> Schema +describeEvaluation = describeConfig + +evaluateRequest :: [Source] -> Request a -> Evaluation a +evaluateRequest sources = \case + RequiredRequest settingSpec -> + case evaluateSetting sources settingSpec of + SettingAbsent node -> + failed + [MissingRequired (MissingProblem {key = settingKey settingSpec})] + (Map.singleton (settingKey settingSpec) node) + SettingFailed errors node -> failed errors (Map.singleton (settingKey settingSpec) node) + SettingPresent value node -> withNode value node + OptionalRequest settingSpec -> + case evaluateSetting 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 + SettingFailed errors node -> failed errors (Map.singleton (settingKey settingSpec) node) + SettingPresent value node -> withNode value node + SettingAbsent _ -> evaluateFallback sources settingSpec defaultSpec + +evaluateFallback :: [Source] -> Setting a -> Default a -> Evaluation a +evaluateFallback sources settingSpec = \case + ConstantDefault rule explanation value -> + derivedEvaluation settingSpec rule explanation [] value + DerivedDefault rule explanation dependency derive -> + let dependencyEvaluation = evaluate sources dependency + in case dependencyEvaluation ^. #answer of + Left errors -> evaluationFailure dependencyEvaluation errors + Right dependencyValue -> + derivedFromDependencies + settingSpec + rule + explanation + dependencyEvaluation + (derive dependencyValue) + CaseDefault rule explanation dependency choices fallback -> + let dependencyEvaluation = evaluate 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 + Nothing -> case fallback of + Just value -> + derivedFromDependencies settingSpec rule explanation dependencyEvaluation value + Nothing -> + evaluationFailure + dependencyEvaluation + [ DefaultError + DefaultProblem + { key = settingKey settingSpec, + rule, + message = "no case matched and no fallback was declared" + } + ] + +derivedFromDependencies :: + Setting a -> + RuleName -> + Text -> + Evaluation d -> + a -> + Evaluation a +derivedFromDependencies settingSpec rule explanation dependencyEvaluation value = + Evaluation + { answer = Right value, + nodes = + dependencyEvaluation + ^. #nodes + & at (settingKey settingSpec) + ?~ derivedNode 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) + +derivedNode :: Setting a -> RuleName -> Text -> [Key] -> a -> ResolutionNode +derivedNode settingSpec rule explanation dependencies value = + ResolutionNode + { key = settingKey settingSpec, + sensitivity = settingSensitivity settingSpec, + outcome = Resolved (defaultReportedValue settingSpec value), + origin = + Just + Origin + { kind = DerivedSource, + name = renderRuleName rule, + key = settingKey settingSpec, + location = Nothing, + annotations = Map.singleton "settei.default-rule" (renderRuleName rule) + }, + shadowed = [], + derivation = Just Derivation {rule = renderRuleName rule, explanation, dependencies} + } + +defaultReportedValue :: Setting a -> a -> ReportedValue +defaultReportedValue settingSpec value = + case settingSensitivity settingSpec of + Secret -> derivedReportedValue Secret + Public -> case settingValueRenderer settingSpec of + Just renderValue -> visibleReportedValue (renderValue value) + Nothing -> derivedReportedValue Public + +evaluationFailure :: Evaluation d -> [ConfigError] -> Evaluation a +evaluationFailure dependencyEvaluation errors = + Evaluation + { answer = Left errors, + nodes = dependencyEvaluation ^. #nodes, + branches = dependencyEvaluation ^. #branches + } + +data SettingEvaluation a + = SettingAbsent !ResolutionNode + | SettingFailed ![ConfigError] !ResolutionNode + | SettingPresent a !ResolutionNode + +evaluateSetting :: [Source] -> Setting a -> SettingEvaluation a +evaluateSetting sources settingSpec = + case collectCandidates (settingKey settingSpec) sources of + Left structuralErrors -> + SettingFailed + (fmap StructuralConflict structuralErrors) + (missingNode settingSpec) + Right [] -> SettingAbsent (missingNode settingSpec) + Right candidates -> + let winner = last candidates + lower = init candidates + rawValue = candidateValue winner + node = + ResolutionNode + { key = settingKey settingSpec, + sensitivity = settingSensitivity settingSpec, + outcome = Resolved (reportedValue (settingSensitivity settingSpec) rawValue), + origin = Just (candidateOrigin winner), + shadowed = fmap candidateOrigin (reverse lower), + derivation = Nothing + } + in case decodeSetting settingSpec rawValue of + Left decodeFailure -> + SettingFailed + [ DecodeError + DecodeProblem + { key = settingKey settingSpec, + expected = decodeFailureExpected decodeFailure, + origin = candidateOrigin winner, + rejected = reportedValue (settingSensitivity settingSpec) rawValue + } + ] + node + Right value -> SettingPresent value node + +collectCandidates :: Key -> [Source] -> Either [StructuralError] [Candidate] +collectCandidates key sources = + case foldr collect ([], []) (fmap (lookupSource key) sources) of + ([], candidates) -> Right candidates + (errors, _) -> Left errors + where + collect (Left structuralError) (errors, candidates) = (structuralError : errors, candidates) + collect (Right Nothing) result = result + collect (Right (Just foundCandidate)) (errors, candidates) = + (errors, foundCandidate : candidates) + +missingNode :: Setting a -> ResolutionNode +missingNode settingSpec = + ResolutionNode + { key = settingKey settingSpec, + sensitivity = settingSensitivity settingSpec, + outcome = MissingValue, + origin = Nothing, + shadowed = [], + derivation = Nothing + } + +withNode :: a -> ResolutionNode -> Evaluation a +withNode value node = + Evaluation + { answer = Right value, + nodes = Map.singleton (node ^. #key) node, + branches = [] + } + +successful :: a -> Evaluation a +successful value = Evaluation {answer = Right value, nodes = Map.empty, branches = []} + +failed :: [ConfigError] -> Map Key ResolutionNode -> Evaluation a +failed errors nodes = Evaluation {answer = Left errors, nodes, branches = []} + +mapEvaluation :: (a -> b) -> Evaluation a -> Evaluation b +mapEvaluation mapValue evaluation = evaluation & #answer %~ fmap mapValue + +applyEvaluation :: Evaluation (a -> b) -> Evaluation a -> Evaluation b +applyEvaluation function inputConfig = + Evaluation + { answer = applyAnswer (function ^. #answer) (inputConfig ^. #answer), + nodes = Map.union (function ^. #nodes) (inputConfig ^. #nodes), + branches = function ^. #branches <> inputConfig ^. #branches + } + +applyAnswer :: Either [ConfigError] (a -> b) -> Either [ConfigError] a -> Either [ConfigError] b +applyAnswer (Right function) (Right value) = Right (function value) +applyAnswer (Left leftErrors) (Left rightErrors) = Left (leftErrors <> rightErrors) +applyAnswer (Left errors) _ = Left errors +applyAnswer _ (Left errors) = Left errors + +findUnknownKeys :: [SchemaSetting] -> [Source] -> [UnknownKeyProblem] +findUnknownKeys schemaSettings = concatMap unknownInSource + where + declared = fmap schemaSettingKey schemaSettings + unknownInSource source = + [ UnknownKeyProblem {key, origin = candidateOrigin foundCandidate} + | (key, foundCandidate) <- sourceLeaves source, + not (any (`declares` key) declared) + ] + +declares :: Key -> Key -> Bool +declares declared leaf = + NonEmpty.toList (keySegments declared) + `isPrefixOf` NonEmpty.toList (keySegments leaf) + +isPrefixOf :: (Eq a) => [a] -> [a] -> Bool +isPrefixOf [] _ = True +isPrefixOf _ [] = False +isPrefixOf (left : leftRest) (right : rightRest) = + left == right && isPrefixOf leftRest rightRest + +addNotSelected :: [SchemaSetting] -> Map Key ResolutionNode -> Map Key ResolutionNode +addNotSelected schemaSettings existingNodes = foldl addNode existingNodes schemaSettings + where + addNode nodes schemaSetting = + nodes + & at (schemaSettingKey schemaSetting) + %~ ( \case + Just node -> Just node + Nothing -> + Just + ResolutionNode + { key = schemaSettingKey schemaSetting, + sensitivity = schemaSettingSensitivity schemaSetting, + outcome = NotSelected, + origin = Nothing, + shadowed = [], + derivation = Nothing + } + ) + +errorsOnly :: [ConfigError] -> Either [ConfigError] () +errorsOnly [] = Right () +errorsOnly errors = Left errors + +appendErrors :: Either [ConfigError] a -> Either [ConfigError] () -> Either [ConfigError] a +appendErrors (Right value) (Right ()) = Right value +appendErrors (Left errors) (Right ()) = Left errors +appendErrors (Right _) (Left errors) = Left errors +appendErrors (Left leftErrors) (Left rightErrors) = Left (leftErrors <> rightErrors) + +toNonEmpty :: [ConfigError] -> NonEmpty ConfigError +toNonEmpty errors = + case NonEmpty.nonEmpty errors of + Just values -> values + Nothing -> error "Settei.Resolve: impossible empty error collection" diff --git a/src/Settei/Schema.hs b/src/Settei/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Settei/Schema.hs @@ -0,0 +1,78 @@ +-- | +-- Module: Settei.Schema +-- Description: Static setting and branch metadata returned by Settei.Config.describe. +-- +-- Possible settings occur somewhere in a declaration. Necessary settings are +-- conservatively known to run on every path. Required versus optional is separate: it +-- controls whether absence is an error when a request actually runs. +module Settei.Schema + ( Condition, + Presence (..), + Requirement (..), + Schema, + SchemaSetting, + conditionDependencies, + conditionSettings, + schemaConditions, + schemaNecessary, + schemaPossible, + schemaSettingDescription, + schemaSettingKey, + schemaSettingPresence, + schemaSettingRequirement, + schemaSettingSensitivity, + ) +where + +import Data.Generics.Labels () +import Data.Map.Strict qualified as Map +import Settei.Internal.Schema + ( Condition, + Presence (..), + Requirement (..), + Schema, + SchemaSetting, + ) +import Settei.Key (Key) +import Settei.Prelude +import Settei.Setting (Sensitivity) + +-- | Every setting that may be requested, in key order. +schemaPossible :: Schema -> [SchemaSetting] +schemaPossible schema = Map.elems (schema ^. #settings) + +-- | Settings evaluated on every execution path, in key order. +schemaNecessary :: Schema -> [SchemaSetting] +schemaNecessary = filter ((== Necessary) . schemaSettingPresence) . schemaPossible + +-- | The conservative selective relationships in declaration order. +schemaConditions :: Schema -> [Condition] +schemaConditions schema = schema ^. #conditions + +-- | Return a schema entry's validated key. +schemaSettingKey :: SchemaSetting -> Key +schemaSettingKey schemaEntry = schemaEntry ^. #key + +-- | Return a schema entry's human-readable purpose. +schemaSettingDescription :: SchemaSetting -> Text +schemaSettingDescription schemaEntry = schemaEntry ^. #description + +-- | Return whether reports must redact a schema entry's value. +schemaSettingSensitivity :: SchemaSetting -> Sensitivity +schemaSettingSensitivity schemaEntry = schemaEntry ^. #sensitivity + +-- | Return whether absence is an error when this request runs. +schemaSettingRequirement :: SchemaSetting -> Requirement +schemaSettingRequirement schemaEntry = schemaEntry ^. #requirement + +-- | Return whether this request is statically necessary or conditional. +schemaSettingPresence :: SchemaSetting -> Presence +schemaSettingPresence schemaEntry = schemaEntry ^. #presence + +-- | Return the selector keys on which a condition depends. +conditionDependencies :: Condition -> Set Key +conditionDependencies condition = condition ^. #dependencies + +-- | Return the setting keys activated by a condition. +conditionSettings :: Condition -> Set Key +conditionSettings condition = condition ^. #settings diff --git a/src/Settei/Setting.hs b/src/Settei/Setting.hs new file mode 100644 --- /dev/null +++ b/src/Settei/Setting.hs @@ -0,0 +1,78 @@ +-- | +-- Module: Settei.Setting +-- Description: Metadata and decoders for individual configuration settings. +module Settei.Setting + ( Sensitivity (..), + Setting, + decodeSetting, + publicSetting, + publicSettingWithRenderer, + secretSetting, + settingDescription, + settingKey, + settingSensitivity, + settingValueRenderer, + ) +where + +import Data.Generics.Labels () +import Settei.Key (Key) +import Settei.Prelude +import Settei.Value (DecodeFailure, Decoder, RawValue, runDecoder) + +-- | Whether reports may display a setting's resolved value. +data Sensitivity = Public | Secret + deriving stock (Generic, Eq, Ord, Show) + +-- | Metadata and decoding behavior for one logical setting. +-- +-- The constructor stays private so callers use the explicit public or secret smart +-- constructors. The type has no 'Show' instance because its decoder will receive raw +-- values that may be sensitive. +data Setting a = Setting + { key :: !Key, + description :: !Text, + sensitivity :: !Sensitivity, + decoder :: !(Decoder a), + renderer :: !(Maybe (a -> Text)) + } + deriving stock (Generic) + +-- | Declare a setting whose resolved value may appear in reports. +publicSetting :: Key -> Text -> Decoder a -> Setting a +publicSetting key description decoder = + Setting {key, description, sensitivity = Public, decoder, renderer = Nothing} + +-- | Declare a public setting with a renderer for typed default values. +-- +-- Source candidates render directly from 'RawValue'; this renderer is used only after a +-- typed constant or derived default has been evaluated. +publicSettingWithRenderer :: Key -> Text -> Decoder a -> (a -> Text) -> Setting a +publicSettingWithRenderer key description decoder renderer = + Setting {key, description, sensitivity = Public, decoder, renderer = Just renderer} + +-- | 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} + +-- | Decode one raw candidate using the setting's validated key. +decodeSetting :: Setting a -> RawValue -> Either DecodeFailure a +decodeSetting settingSpec = + runDecoder (settingSpec ^. #decoder) (settingSpec ^. #key) + +-- | Inspect the setting's key. +settingKey :: Setting a -> Key +settingKey settingSpec = settingSpec ^. #key + +-- | Inspect the setting's human-readable purpose. +settingDescription :: Setting a -> Text +settingDescription settingSpec = settingSpec ^. #description + +-- | Inspect whether the setting is public or secret. +settingSensitivity :: Setting a -> Sensitivity +settingSensitivity settingSpec = settingSpec ^. #sensitivity + +-- | Return the optional renderer for a public typed default. +settingValueRenderer :: Setting a -> Maybe (a -> Text) +settingValueRenderer settingSpec = settingSpec ^. #renderer diff --git a/src/Settei/Source.hs b/src/Settei/Source.hs new file mode 100644 --- /dev/null +++ b/src/Settei/Source.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +-- | +-- Module: Settei.Source +-- Description: Ordered, hierarchical configuration inputs. +module Settei.Source + ( Source, + annotateSource, + annotateSourceAt, + locateSource, + lookupSource, + source, + sourceAnnotations, + sourceKind, + sourceLeaves, + sourceName, + ) +where + +import Data.Generics.Labels () +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import Settei.Error (RawShape (..), StructuralError (..)) +import Settei.Key (Key, keySegments, mkKey) +import Settei.Origin (Origin (..), SourceKind, SourceLocation) +import Settei.Prelude +import Settei.Provenance (Candidate, candidate) +import Settei.Value (RawValue (..)) + +-- | A reusable source tree. Precedence is supplied by its position in @[Source]@. +-- +-- There is deliberately no 'Show' instance because 'root' may contain secrets. +data Source = Source + { name :: !Text, + kind :: !SourceKind, + root :: !RawValue, + locationAt :: !(Key -> Maybe SourceLocation), + annotationsAt :: !(Key -> Map Text Text), + annotations :: !(Map Text Text) + } + deriving stock (Generic) + +-- | Construct a source with no retained locations or annotations. +source :: Text -> SourceKind -> RawValue -> Source +source name kind root = + Source + { name, + kind, + root, + locationAt = const Nothing, + annotationsAt = const Map.empty, + annotations = Map.empty + } + +-- | Attach adapter-specific descriptive metadata. It never changes precedence. +annotateSource :: Map Text Text -> Source -> Source +annotateSource annotations sourceValue = sourceValue & #annotations .~ annotations + +-- | Attach descriptive metadata for individual keys. +-- +-- Later calls compose with earlier hooks. New per-key entries take precedence over +-- earlier per-key and source-wide entries with the same annotation name. +annotateSourceAt :: (Key -> Map Text Text) -> Source -> Source +annotateSourceAt additions sourceValue = + sourceValue + & #annotationsAt + %~ \existing key -> additions key <> existing key + +-- | Attach exact-key locations retained by an adapter parser. +locateSource :: (Key -> Maybe SourceLocation) -> Source -> Source +locateSource locationAt sourceValue = sourceValue & #locationAt .~ locationAt + +-- | Return a source's stable descriptive name. +sourceName :: Source -> Text +sourceName value = value ^. #name + +-- | Return a source's format-independent category. +sourceKind :: Source -> SourceKind +sourceKind value = value ^. #kind + +-- | Return descriptive annotations shared by every candidate from the source. +sourceAnnotations :: Source -> Map Text Text +sourceAnnotations value = value ^. #annotations + +-- | Look up one exact structural key. +-- +-- A scalar or array is a valid value at the final segment. Traversing through one is a +-- structural error; dotted textual prefix tricks are never used. +lookupSource :: Key -> Source -> Either StructuralError (Maybe Candidate) +lookupSource target sourceValue = + walk [] (NonEmpty.toList (keySegments target)) (sourceValue ^. #root) + where + walk _ [] rawValue = Right (Just (candidate rawValue (originFor target sourceValue))) + walk prefix (segment : rest) rawValue = case rawValue of + RawObject object -> + case Map.lookup segment object of + Nothing -> Right Nothing + Just child -> walk (prefix <> [segment]) rest child + RawNull -> Left (blocked prefix NullShape) + RawArray _ -> Left (blocked prefix ArrayShape) + RawText _ -> Left (blocked prefix ScalarShape) + RawBool _ -> Left (blocked prefix ScalarShape) + RawNumber _ -> Left (blocked prefix ScalarShape) + + blocked prefix shape = + StructuralError + { key = target, + blockedAt = prefixKey target prefix, + origin = originFor (prefixKey target prefix) sourceValue, + shape + } + +-- | Enumerate addressable leaves in key order for unknown-key diagnostics. +-- +-- Arrays and scalars are whole leaves. Empty objects contain no leaves. +sourceLeaves :: Source -> [(Key, Candidate)] +sourceLeaves sourceValue = go [] (sourceValue ^. #root) + where + go prefix = \case + RawObject object -> + concatMap + (\(segment, rawValue) -> go (prefix <> [segment]) rawValue) + (Map.toAscList object) + rawValue -> case NonEmpty.nonEmpty prefix of + Nothing -> [] + Just segments -> case mkKey segments of + Left _ -> [] + Right key -> [(key, candidate rawValue (originFor key sourceValue))] + +originFor :: Key -> Source -> Origin +originFor key sourceValue = + Origin + { kind = sourceValue ^. #kind, + name = sourceValue ^. #name, + key, + location = (sourceValue ^. #locationAt) key, + annotations = + (sourceValue ^. #annotationsAt) key + <> sourceValue ^. #annotations + } + +prefixKey :: Key -> [Text] -> Key +prefixKey target prefix = + case NonEmpty.nonEmpty prefix >>= either (const Nothing) Just . mkKey of + Just key -> key + Nothing -> target diff --git a/src/Settei/Value.hs b/src/Settei/Value.hs new file mode 100644 --- /dev/null +++ b/src/Settei/Value.hs @@ -0,0 +1,128 @@ +-- | +-- Module: Settei.Value +-- Description: Parser-neutral raw values and secret-safe typed decoders. +module Settei.Value + ( RawValue (..), + DecodeFailure, + Decoder, + boolDecoder, + boundedIntegralDecoder, + enumDecoder, + decodeFailure, + decodeFailureExpected, + decoder, + renderDecodeFailure, + runDecoder, + textDecoder, + ) +where + +import Data.Generics.Labels () +import Data.Ratio qualified as Ratio +import Data.Text qualified as Text +import Data.Text.Read qualified as TextRead +import Settei.Key (Key, renderKey) +import Settei.Prelude + +-- | The parser-neutral value tree produced by source adapters. +-- +-- 'RawValue' deliberately has no 'Show' instance: it may contain a secret before a +-- setting decoder has had a chance to redact it. +data RawValue + = RawNull + | RawText !Text + | RawBool !Bool + | RawNumber !Rational + | RawArray ![RawValue] + | RawObject !(Map Text RawValue) + deriving stock (Generic, Eq) + +-- | A secret-safe explanation of what a decoder expected. +-- +-- The rejected raw input is intentionally absent. +data DecodeFailure = DecodeFailure + { key :: !Key, + expected :: !Text + } + deriving stock (Generic, Eq, Show) + +-- | A reusable decoder that receives the owning setting key for safe errors. +newtype Decoder a = Decoder + { decode :: Key -> RawValue -> Either DecodeFailure a + } + deriving stock (Generic) + +-- | Construct a decoder whose failures carry only safe expectation metadata. +decoder :: (Key -> RawValue -> Either DecodeFailure a) -> Decoder a +decoder decode = Decoder {decode} + +-- | Construct a rejection without retaining the rejected raw value. +decodeFailure :: Key -> Text -> DecodeFailure +decodeFailure key expected = DecodeFailure {key, expected} + +-- | Inspect the safe expectation text for a failed decode. +decodeFailureExpected :: DecodeFailure -> Text +decodeFailureExpected value = value ^. #expected + +-- | Run a decoder for one setting key. +runDecoder :: Decoder a -> Key -> RawValue -> Either DecodeFailure a +runDecoder value = value ^. #decode + +-- | Decode a text scalar. +textDecoder :: Decoder Text +textDecoder = Decoder $ \key -> \case + RawText value -> Right value + _ -> failure key "text" + +-- | Decode a boolean scalar or an exact, case-insensitive textual boolean. +boolDecoder :: Decoder Bool +boolDecoder = Decoder $ \key -> \case + RawBool value -> Right value + RawText value -> case Text.toCaseFold value of + "true" -> Right True + "false" -> Right False + _ -> failure key "boolean" + _ -> failure key "boolean" + +-- | Decode a whole number that fits the requested bounded integral type. +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" + +-- | Decode one of a finite set of exact text spellings. +enumDecoder :: [(Text, a)] -> Decoder a +enumDecoder choices = Decoder $ \key -> \case + RawText value -> + maybe + (failure key expectedValues) + Right + (lookup value choices) + _ -> failure key expectedValues + where + names = fmap fst choices + expectedValues = case names of + [] -> "an allowed value" + _ -> "one of " <> Text.intercalate ", " names + +-- | Render a failure without including the rejected value. +renderDecodeFailure :: DecodeFailure -> Text +renderDecodeFailure value = + renderKey (value ^. #key) <> ": expected " <> value ^. #expected + +failure :: Key -> Text -> Either DecodeFailure a +failure key expected = Left DecodeFailure {key, expected} + +integralValue :: RawValue -> Maybe Integer +integralValue = \case + 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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,24 @@ +module Main (main) where + +import Settei.ConfigTest qualified as ConfigTest +import Settei.DefaultTest qualified as DefaultTest +import Settei.KeyTest qualified as KeyTest +import Settei.RenderTest qualified as RenderTest +import Settei.ResolveTest qualified as ResolveTest +import Settei.SourceTest qualified as SourceTest +import Settei.ValueTest qualified as ValueTest +import Test.Tasty (defaultMain, testGroup) + +main :: IO () +main = + defaultMain $ + testGroup + "Settei" + [ KeyTest.tests, + ValueTest.tests, + ConfigTest.tests, + SourceTest.tests, + ResolveTest.tests, + DefaultTest.tests, + RenderTest.tests + ] diff --git a/test/Settei/ConfigTest.hs b/test/Settei/ConfigTest.hs new file mode 100644 --- /dev/null +++ b/test/Settei/ConfigTest.hs @@ -0,0 +1,95 @@ +module Settei.ConfigTest (tests) where + +import Control.Selective (select) +import Data.Bifunctor (first) +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +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, (@?=)) + +tests :: TestTree +tests = + testGroup + "Settei.Config" + [ testCase "applicative settings are necessary" $ do + let schema = describe ((,) <$> required environmentSetting <*> required passwordSetting) + keySet (schemaNecessary schema) + @?= Set.fromList [environmentKey, passwordKey], + testCase "selective production secret is conditional" $ do + let schema = describe productionOnly + 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)), + testCase "free-selective prototype agrees on possible effects" $ + Set.fromList (freePossibleKeys environmentKey passwordKey) + @?= Set.fromList [environmentKey, passwordKey], + testCase "free-selective prototype agrees on necessary effects" $ + Set.fromList (freeNecessaryKeys environmentKey passwordKey) + @?= Set.singleton environmentKey, + testCase "development skips production secret" $ + runConfig (interpret developmentValues) productionOnly + @?= Right Nothing, + testCase "production requests its secret" $ + runConfig (interpret productionValues) productionOnly + @?= Left (Missing passwordKey) + ] + +data RuntimeError + = Missing !Key + | Decode !DecodeFailure + deriving stock (Generic, Eq, Show) + +productionOnly :: Config (Maybe Text) +productionOnly = select selector productionBranch + where + selector = + (\environment -> if environment == "production" then Left () else Right Nothing) + <$> required environmentSetting + productionBranch = (\password _ -> Just password) <$> required passwordSetting + +interpret :: Map Key RawValue -> Request a -> Either RuntimeError a +interpret values = \case + RequiredRequest settingSpec -> + case Map.lookup (settingKey settingSpec) values of + Nothing -> Left (Missing (settingKey settingSpec)) + Just rawValue -> first Decode (decodeSetting settingSpec rawValue) + OptionalRequest settingSpec -> + case Map.lookup (settingKey settingSpec) values of + Nothing -> Right Nothing + Just rawValue -> Just <$> first Decode (decodeSetting settingSpec rawValue) + +developmentValues :: Map Key RawValue +developmentValues = Map.singleton environmentKey (RawText "development") + +productionValues :: Map Key RawValue +productionValues = Map.singleton environmentKey (RawText "production") + +environmentSetting :: Setting Text +environmentSetting = + publicSetting environmentKey "Runtime environment" textDecoder + +passwordSetting :: Setting Text +passwordSetting = + secretSetting passwordKey "Database password" textDecoder + +environmentKey :: Key +environmentKey = validKey "runtime.environment" + +passwordKey :: Key +passwordKey = validKey "database.password" + +validKey :: Text -> Key +validKey value = either (error . show) id (parseKey value) + +keySet :: [SchemaSetting] -> Set Key +keySet = Set.fromList . fmap schemaSettingKey diff --git a/test/Settei/DefaultTest.hs b/test/Settei/DefaultTest.hs new file mode 100644 --- /dev/null +++ b/test/Settei/DefaultTest.hs @@ -0,0 +1,210 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +module Settei.DefaultTest (tests) where + +import Data.Generics.Labels () +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import Data.Text qualified as Text +import Settei +import Settei.Prelude +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "Settei.Default" + [ testCase "constant default resolves without a source" $ do + result <- expectSuccess (resolve defaultResolveOptions [] constantPort) + 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 + case result ^. #report . #nodes . at servicePort of + Just node -> case node ^. #derivation of + Just derivation -> do + derivation ^. #rule @?= "service-port-by-environment" + derivation ^. #dependencies @?= [runtimeEnvironment] + case node ^. #outcome of + Resolved displayValue -> renderReportedValue displayValue @?= "443" + _ -> fail "expected a resolved default value" + 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 + case result ^. #report . #nodes . at runtimeEnvironment of + Just node -> node ^. #outcome @?= NotSelected + Nothing -> fail "expected the skipped dependency in the report" + case result ^. #report . #nodes . at servicePort of + 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 + Left errors -> case NonEmpty.toList errors of + [DefaultError problem] -> do + problem ^. #key @?= servicePort + problem ^. #rule @?= RuleName "service-port-by-environment" + _ -> fail "expected one default error" + Right _ -> fail "expected the case default to fail", + testCase "a case fallback handles values outside the finite table" $ do + let withFallback = + withDefault + portSetting + ( caseDefault + (RuleName "port-with-fallback") + "Use a fallback outside known environments" + (required environmentSetting) + ((Development, 8080) :| []) + (Just 9000) + ) + result <- expectSuccess (resolve defaultResolveOptions [environmentSource Staging] withFallback) + result ^. #value @?= 9000, + testCase "default dependencies remain conditional in the static schema" $ do + let schema = describe casePort + necessaryKeys = fmap schemaSettingKey (schemaNecessary schema) + necessaryKeys @?= [servicePort] + case filter ((== servicePort) . schemaSettingKey) (schemaPossible schema) of + [portSchema] -> schemaSettingRequirement portSchema @?= Optional + _ -> fail "expected one port schema entry", + testCase "cyclic defaults fail before source evaluation" $ do + case resolve defaultResolveOptions [poisonSource] cyclicA 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" + ] + +data Environment = Development | Test | Staging | Production + deriving stock (Generic, Eq, Ord, Show) + +constantPort :: Config Int +constantPort = + withDefault + portSetting + (constantDefault (RuleName "built-in-port") "Built-in service port" 8080) + +casePort :: Config Int +casePort = + withDefault + portSetting + ( caseDefault + (RuleName "service-port-by-environment") + "Choose the conventional port for the runtime environment" + (required environmentSetting) + ((Development, 8080) :| [(Test, 8081), (Production, 443)]) + Nothing + ) + +cyclicA :: Config Text +cyclicA = + withDefault + cycleASetting + (derivedDefault (RuleName "cycle-a") "Depends on cycle B" cyclicB id) + +cyclicB :: Config Text +cyclicB = + withDefault + cycleBSetting + (derivedDefault (RuleName "cycle-b") "Depends on cycle A" cyclicA id) + +portSetting :: Setting Int +portSetting = + publicSettingWithRenderer + servicePort + "Service port" + boundedIntegralDecoder + (Text.pack . show) + +environmentSetting :: Setting Environment +environmentSetting = + publicSetting + runtimeEnvironment + "Runtime environment" + ( enumDecoder + [ ("development", Development), + ("test", Test), + ("staging", Staging), + ("production", Production) + ] + ) + +cycleASetting :: Setting Text +cycleASetting = publicSetting cycleAKey "Cycle A" textDecoder + +cycleBSetting :: Setting Text +cycleBSetting = publicSetting cycleBKey "Cycle B" textDecoder + +environmentSource :: Environment -> Source +environmentSource environment = + source + "environment" + EnvironmentSource + ( RawObject + ( Map.singleton + "runtime" + (RawObject (Map.singleton "environment" (RawText (environmentText environment)))) + ) + ) + +portSource :: Int -> Source +portSource value = + source + "command-line" + CommandLineSource + ( RawObject + ( Map.singleton + "service" + (RawObject (Map.singleton "port" (RawNumber (fromIntegral value)))) + ) + ) + +poisonSource :: Source +poisonSource = + locateSource + (const (error "a cyclic default attempted to inspect a source")) + ( source + "poison" + (CustomSource "test") + ( RawObject + ( Map.fromList + [ ("cycle-a", RawText "unused"), + ("cycle-b", RawText "unused") + ] + ) + ) + ) + +environmentText :: Environment -> Text +environmentText Development = "development" +environmentText Test = "test" +environmentText Staging = "staging" +environmentText Production = "production" + +expectSuccess :: Either (NonEmpty ConfigError) a -> IO a +expectSuccess = \case + Left _ -> fail "expected successful resolution" + Right value -> pure value + +servicePort :: Key +servicePort = validKey "service.port" + +runtimeEnvironment :: Key +runtimeEnvironment = validKey "runtime.environment" + +cycleAKey :: Key +cycleAKey = validKey "cycle-a" + +cycleBKey :: Key +cycleBKey = validKey "cycle-b" + +validKey :: Text -> Key +validKey value = either (error . show) id (parseKey value) diff --git a/test/Settei/KeyTest.hs b/test/Settei/KeyTest.hs new file mode 100644 --- /dev/null +++ b/test/Settei/KeyTest.hs @@ -0,0 +1,24 @@ +module Settei.KeyTest (tests) where + +import Settei.Key +import Settei.Prelude +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "Settei.Key" + [ testCase "dotted keys round-trip" $ do + (renderKey <$> parseKey "database.pool.size") + @?= Right "database.pool.size", + testCase "empty keys are rejected" $ + parseKey "" @?= Left KeyIsEmpty, + testCase "empty middle segments are rejected" $ + parseKey "database..size" @?= Left KeySegmentIsEmpty, + testCase "empty leading segments are rejected" $ + parseKey ".database" @?= Left KeySegmentIsEmpty, + testCase "structural segments cannot contain dots" $ + mkKey ("database.name" :| []) + @?= Left (KeySegmentContainsDot "database.name") + ] diff --git a/test/Settei/Prototype/Free.hs b/test/Settei/Prototype/Free.hs new file mode 100644 --- /dev/null +++ b/test/Settei/Prototype/Free.hs @@ -0,0 +1,38 @@ +module Settei.Prototype.Free + ( freeNecessaryKeys, + freePossibleKeys, + ) +where + +import Control.Selective (select) +import Control.Selective.Free + ( Select, + getEffects, + getNecessaryEffects, + liftSelect, + ) +import Settei.Key (Key) +import Settei.Prelude + +data Probe a = Probe !Key a + deriving stock (Generic) + +instance Functor Probe where + fmap mapValue (Probe key value) = Probe key (mapValue value) + +freePossibleKeys :: Key -> Key -> [Key] +freePossibleKeys environment password = + fmap probeKey (getEffects (prototype environment password)) + +freeNecessaryKeys :: Key -> Key -> [Key] +freeNecessaryKeys environment password = + fmap probeKey (getNecessaryEffects (prototype environment password)) + +prototype :: Key -> Key -> Select Probe () +prototype environment password = + select + (liftSelect (Probe environment (Left ()))) + (liftSelect (Probe password id)) + +probeKey :: Probe a -> Key +probeKey (Probe key _) = key diff --git a/test/Settei/RenderTest.hs b/test/Settei/RenderTest.hs new file mode 100644 --- /dev/null +++ b/test/Settei/RenderTest.hs @@ -0,0 +1,245 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +module Settei.RenderTest (tests) where + +import Data.Generics.Labels () +import Data.Map.Strict qualified as Map +import Data.Text qualified as Text +import Data.Text.IO qualified as TextIO +import Settei +import Settei.Prelude +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "Settei.Render" + [ testCase "schema text matches its golden snapshot" $ + assertGolden "test/golden/schema.txt" (renderSchemaText snapshotSchema), + testCase "schema JSON matches its versioned golden snapshot" $ + assertGolden "test/golden/schema.json" (renderSchemaJson snapshotSchema), + testCase "resolution text matches its golden snapshot" $ + assertGolden "test/golden/resolution.txt" (renderResolutionText snapshotReport), + testCase "resolution JSON matches its versioned golden snapshot" $ + assertGolden "test/golden/resolution.json" (renderResolutionJson snapshotReport), + 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 ())) + assertGolden "test/golden/warnings.txt" (renderWarningsText (result ^. #warnings)) + assertGolden "test/golden/warnings.json" (renderWarningsJson (result ^. #warnings)), + testCase "renderers distinguish missing from not selected" $ do + let textOutput = renderResolutionText absentReport + jsonOutput = renderResolutionJson absentReport + assertBool "text omitted the missing outcome" ("" `Text.isInfixOf` textOutput) + 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 + ] + +assertGolden :: FilePath -> Text -> IO () +assertGolden path actual = do + expected <- Text.stripEnd <$> TextIO.readFile path + Text.stripEnd actual @?= expected + +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 report = success ^. #report + warnings = warningResult ^. #warnings + outputs = + [ renderSchemaText (describe (required secretTextSetting)), + renderSchemaJson (describe (required secretTextSetting)), + renderResolutionText report, + renderResolutionJson report, + renderErrorsText errors, + renderErrorsJson errors, + renderWarningsText warnings, + renderWarningsJson warnings, + Text.pack (show report), + Text.pack (show errors), + Text.pack (show warnings) + ] + assertBool + "a secret sentinel reached a supported output" + (all (not . Text.isInfixOf secretSentinel) outputs) + assertBool "decode error did not show a redaction marker" $ + "" `Text.isInfixOf` renderErrorsText errors + +expectSuccess :: Either (NonEmpty ConfigError) a -> IO a +expectSuccess = \case + Left _ -> fail "expected successful resolution" + Right value -> pure value + +expectFailure :: Either (NonEmpty ConfigError) a -> IO (NonEmpty ConfigError) +expectFailure = \case + Left errors -> pure errors + Right _ -> fail "expected resolution to fail" + +snapshotSchema :: Schema +snapshotSchema = describe (required passwordSetting) + +snapshotReport :: ResolutionReport +snapshotReport = + ResolutionReport + { nodes = + Map.fromList + [ (databasePassword, passwordNode), + (runtimeEnvironment, environmentNode), + (servicePort, portNode) + ], + branches = [] + } + +passwordNode :: ResolutionNode +passwordNode = + ResolutionNode + { key = databasePassword, + sensitivity = Secret, + outcome = Resolved (reportedValue Secret (RawText secretSentinel)), + origin = Just (environmentOrigin databasePassword "DATABASE_PASSWORD"), + shadowed = [], + derivation = Nothing + } + +environmentNode :: ResolutionNode +environmentNode = + ResolutionNode + { key = runtimeEnvironment, + sensitivity = Public, + outcome = Resolved (reportedValue Public (RawText "Production")), + origin = Just (environmentOrigin runtimeEnvironment "HASKELL_ENV"), + shadowed = [], + derivation = Nothing + } + +portNode :: ResolutionNode +portNode = + ResolutionNode + { key = servicePort, + sensitivity = Public, + outcome = Resolved (visibleReportedValue "443"), + origin = Just defaultOrigin, + shadowed = [builtInOrigin], + derivation = + Just + Derivation + { rule = "service-port-by-environment", + explanation = "Choose the conventional production port", + dependencies = [runtimeEnvironment] + } + } + +absentReport :: ResolutionReport +absentReport = + ResolutionReport + { nodes = + Map.fromList + [ ( databasePassword, + ResolutionNode + { key = databasePassword, + sensitivity = Secret, + outcome = NotSelected, + origin = Nothing, + shadowed = [], + derivation = Nothing + } + ), + ( servicePort, + ResolutionNode + { key = servicePort, + sensitivity = Public, + outcome = MissingValue, + origin = Nothing, + shadowed = [], + derivation = Nothing + } + ) + ], + branches = + [ BranchTrace + { dependencies = [runtimeEnvironment], + settings = [databasePassword], + selected = False + } + ] + } + +environmentOrigin :: Key -> Text -> Origin +environmentOrigin key variable = + Origin + { kind = EnvironmentSource, + name = "environment", + key, + location = Nothing, + annotations = Map.singleton "environment.variable" variable + } + +defaultOrigin :: Origin +defaultOrigin = + Origin + { kind = DerivedSource, + name = "service-port-by-environment", + key = servicePort, + location = Nothing, + annotations = Map.singleton "settei.default-rule" "service-port-by-environment" + } + +builtInOrigin :: Origin +builtInOrigin = + Origin + { kind = BuiltInSource, + name = "built-in", + key = servicePort, + location = Nothing, + annotations = Map.empty + } + +passwordSetting :: Setting Text +passwordSetting = secretSetting databasePassword "Database password" textDecoder + +secretTextSetting :: Setting Text +secretTextSetting = secretSetting databasePassword "Database password" textDecoder + +secretBoolSetting :: Setting Bool +secretBoolSetting = secretSetting databasePassword "Database password" boolDecoder + +secretSource :: Source +secretSource = + source + "environment" + EnvironmentSource + ( RawObject + ( Map.singleton + "database" + (RawObject (Map.singleton "password" (RawText secretSentinel))) + ) + ) + +unknownSecretSource :: Source +unknownSecretSource = + source + "document" + (FileSource "memory") + (RawObject (Map.singleton "unknown" (RawText secretSentinel))) + +secretSentinel :: Text +secretSentinel = "S3cr3t-\"\\\n-[]{}-雪" + +databasePassword :: Key +databasePassword = validKey "database.password" + +runtimeEnvironment :: Key +runtimeEnvironment = validKey "runtime.environment" + +servicePort :: Key +servicePort = validKey "service.port" + +validKey :: Text -> Key +validKey value = either (error . show) id (parseKey value) diff --git a/test/Settei/ResolveTest.hs b/test/Settei/ResolveTest.hs new file mode 100644 --- /dev/null +++ b/test/Settei/ResolveTest.hs @@ -0,0 +1,247 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +module Settei.ResolveTest (tests) where + +import Control.Selective (select) +import Data.Generics.Labels () +import Data.List (permutations) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import Settei +import Settei.Prelude +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "Settei.Resolve" + [ testCase "rightmost source wins per leaf" $ do + result <- expectSuccess (resolve defaultResolveOptions layeredSources serviceConfig) + result ^. #value @?= ("file.example", 443) + let nodes = result ^. #report . #nodes + case nodes ^. at serviceHost of + Just node -> do + fmap (^. #name) (node ^. #origin) @?= Just "file" + fmap (^. #name) (node ^. #shadowed) @?= ["built-in"] + Nothing -> fail "expected host report node" + case nodes ^. at servicePort of + Just node -> do + fmap (^. #name) (node ^. #origin) @?= Just "environment" + 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), + testCase "shadowed origins are ordered from highest to lowest precedence" $ do + result <- expectSuccess (resolve defaultResolveOptions (fmap snd lawSources) (required portSetting)) + case result ^. #report . #nodes . at servicePort of + Just node -> fmap (^. #name) (node ^. #shadowed) @?= ["two", "one"] + Nothing -> fail "expected the port resolution node", + testCase "rightmost-wins law holds for every three-source ordering" $ + mapM_ checkOrdering (permutations lawSources), + 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 + Left errors -> case NonEmpty.toList errors of + [DecodeError problem] -> do + problem ^. #key @?= servicePort + problem ^. #origin . #name @?= "higher" + _ -> fail "expected one decode error" + Right _ -> fail "expected the malformed winner to fail", + 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"], + testCase "unknown keys warn by default and can be promoted" $ do + let values = + RawObject + ( Map.fromList + [ ("known", RawText "yes"), + ("typo", RawText "unused") + ] + ) + input = source "document" (FileSource "memory") values + declaration = required knownSetting + result <- expectSuccess (resolve defaultResolveOptions [input] declaration) + 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 + 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 + 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 + 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] -> 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 + Left errors -> fmap errorKey (NonEmpty.toList errors) @?= [databasePassword] + Right _ -> fail "production should require a password", + testCase "structural conflicts are rejected even under an unselected branch" $ do + let development = environmentSource "development" + conflicting = + source + "conflicting" + (FileSource "memory") + (RawObject (Map.singleton "database" (RawText "not-an-object"))) + case resolve defaultResolveOptions [development, conflicting] productionPassword 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" + ] + +checkOrdering :: [(Int, Source)] -> IO () +checkOrdering orderedSources = do + result <- + expectSuccess + (resolve defaultResolveOptions (fmap snd orderedSources) (required portSetting)) + result ^. #value @?= fst (last orderedSources) + +lawSources :: [(Int, Source)] +lawSources = + [ (1001, treeSource "one" (RawNumber 1001) Map.empty), + (2002, treeSource "two" (RawNumber 2002) Map.empty), + (3003, treeSource "three" (RawNumber 3003) Map.empty) + ] + +expectSuccess :: Either (NonEmpty ConfigError) a -> IO a +expectSuccess = \case + Left _ -> fail "expected successful resolution" + Right value -> pure value + +errorKey :: ConfigError -> Key +errorKey = \case + MissingRequired problem -> problem ^. #key + DecodeError problem -> problem ^. #key + StructuralConflict problem -> problem ^. #key + UnknownKeyError problem -> problem ^. #key + DefaultError problem -> problem ^. #key + DefaultCycle _ -> error "a cycle has no single setting key" + +serviceConfig :: Config (Text, Int) +serviceConfig = (,) <$> required hostSetting <*> required portSetting + +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 + +hostSetting :: Setting Text +hostSetting = publicSetting serviceHost "Service host" textDecoder + +portSetting :: Setting Int +portSetting = publicSetting servicePort "Service port" boundedIntegralDecoder + +hostsSetting :: Setting [Text] +hostsSetting = publicSetting serviceHosts "Service hosts" textArrayDecoder + +knownSetting :: Setting Text +knownSetting = publicSetting knownKey "Known value" textDecoder + +environmentSetting :: Setting Text +environmentSetting = publicSetting runtimeEnvironment "Runtime environment" textDecoder + +passwordSetting :: Setting Text +passwordSetting = secretSetting databasePassword "Database password" textDecoder + +textArrayDecoder :: Decoder [Text] +textArrayDecoder = decoder $ \key -> \case + RawArray values -> traverse (decodeOne key) values + _ -> Left (decodeFailure key "array of text") + where + decodeOne _ (RawText value) = Right value + decodeOne key _ = Left (decodeFailure key "array of text") + +layeredSources :: [Source] +layeredSources = + [ treeSource "built-in" (RawNumber 8080) (Map.singleton "host" (RawText "built-in.example")), + source + "file" + (FileSource "memory") + (RawObject (Map.singleton "service" (RawObject (Map.singleton "host" (RawText "file.example"))))), + treeSource "environment" (RawNumber 443) Map.empty + ] + +treeSource :: Text -> RawValue -> Map Text RawValue -> Source +treeSource name portValue extraServiceValues = + source + name + (CustomSource "test") + ( RawObject + ( Map.singleton + "service" + (RawObject (extraServiceValues & at "port" ?~ portValue)) + ) + ) + +arraySource :: Text -> [Text] -> Source +arraySource name values = + source + name + (CustomSource "test") + ( RawObject + ( Map.singleton + "service" + (RawObject (Map.singleton "hosts" (RawArray (fmap RawText values)))) + ) + ) + +environmentSource :: Text -> Source +environmentSource value = + source + "environment" + EnvironmentSource + ( RawObject + ( Map.singleton + "runtime" + (RawObject (Map.singleton "environment" (RawText value))) + ) + ) + +serviceHost :: Key +serviceHost = validKey "service.host" + +servicePort :: Key +servicePort = validKey "service.port" + +serviceHosts :: Key +serviceHosts = validKey "service.hosts" + +runtimeEnvironment :: Key +runtimeEnvironment = validKey "runtime.environment" + +databasePassword :: Key +databasePassword = validKey "database.password" + +knownKey :: Key +knownKey = validKey "known" + +typoKey :: Key +typoKey = validKey "typo" + +validKey :: Text -> Key +validKey value = either (error . show) id (parseKey value) diff --git a/test/Settei/SourceTest.hs b/test/Settei/SourceTest.hs new file mode 100644 --- /dev/null +++ b/test/Settei/SourceTest.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +module Settei.SourceTest (tests) where + +import Data.Generics.Labels () +import Data.Map.Strict qualified as Map +import Settei +import Settei.Prelude +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "Settei.Source" + [ testCase "hierarchical keys traverse objects by segment" $ do + let result = lookupSource servicePort sampleSource + case result of + Right (Just found) -> do + assertBool "expected the nested port" (candidateValue found == RawNumber 8080) + candidateOrigin found ^. #key @?= servicePort + _ -> fail "expected one candidate", + testCase "arrays are values at their exact declared key" $ do + let result = lookupSource serviceHosts sampleSource + case result of + Right (Just found) -> + assertBool + "expected the complete array" + (candidateValue found == RawArray [RawText "one", RawText "two"]) + _ -> fail "expected one array candidate", + testCase "traversal through a scalar is a structural error" $ do + let result = lookupSource servicePortChild sampleSource + case result of + Left structuralError -> do + structuralError ^. #key @?= servicePortChild + structuralError ^. #blockedAt @?= servicePort + structuralError ^. #shape @?= ScalarShape + _ -> fail "expected a structural error", + testCase "leaf enumeration is ordered and treats arrays wholesale" $ + fmap (renderKey . fst) (sourceLeaves sampleSource) + @?= ["service.hosts", "service.port"], + testCase "per-key annotations reach only their matching origins" $ do + let annotated = + annotateSourceAt + (\key -> if key == servicePort then Map.singleton "environment.variable" "PORT" else Map.empty) + sampleSource + case (lookupSource servicePort annotated, lookupSource serviceHosts annotated) of + (Right (Just port), Right (Just hosts)) -> do + port ^. to candidateOrigin . #annotations . at "environment.variable" @?= Just "PORT" + hosts ^. to candidateOrigin . #annotations . at "environment.variable" @?= Nothing + _ -> fail "expected both annotated source candidates" + ] + +sampleSource :: Source +sampleSource = + source + "built-in" + BuiltInSource + ( RawObject + ( Map.singleton + "service" + ( RawObject + ( Map.fromList + [ ("hosts", RawArray [RawText "one", RawText "two"]), + ("port", RawNumber 8080) + ] + ) + ) + ) + ) + +servicePort :: Key +servicePort = validKey "service.port" + +serviceHosts :: Key +serviceHosts = validKey "service.hosts" + +servicePortChild :: Key +servicePortChild = validKey "service.port.number" + +validKey :: Text -> Key +validKey value = either (error . show) id (parseKey value) diff --git a/test/Settei/ValueTest.hs b/test/Settei/ValueTest.hs new file mode 100644 --- /dev/null +++ b/test/Settei/ValueTest.hs @@ -0,0 +1,55 @@ +module Settei.ValueTest (tests) where + +import Data.Text qualified as Text +import Settei +import Settei.Prelude +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "Settei.Value" + [ testCase "text values decode" $ + decodeSetting publicText (RawText "hello") @?= Right "hello", + testCase "textual booleans decode case-insensitively" $ + decodeSetting publicBoolean (RawText "TRUE") @?= Right True, + testCase "bounded integral values decode" $ + decodeSetting publicInteger (RawText "42") @?= Right (42 :: Int), + testCase "explicit enumerations decode" $ + decodeSetting environment (RawText "production") @?= Right Production, + testCase "secret decoder failures omit rejected values" $ case decodeSetting secretText (RawText "supersecret") of + Right _ -> fail "expected decoding to fail" + Left failureValue -> + assertBool + "rendered failure leaked the rejected secret" + (not (Text.isInfixOf "supersecret" (renderDecodeFailure failureValue))) + ] + +data Environment = Development | Production + deriving stock (Generic, Eq, Show) + +publicText :: Setting Text +publicText = publicSetting exampleKey "Example text" textDecoder + +secretText :: Setting Bool +secretText = secretSetting exampleKey "Example secret" boolDecoder + +publicBoolean :: Setting Bool +publicBoolean = publicSetting exampleKey "Example boolean" boolDecoder + +publicInteger :: Setting Int +publicInteger = publicSetting exampleKey "Example integer" boundedIntegralDecoder + +environment :: Setting Environment +environment = + publicSetting + exampleKey + "Runtime environment" + (enumDecoder [("development", Development), ("production", Production)]) + +exampleKey :: Key +exampleKey = validKey "example.value" + +validKey :: Text -> Key +validKey value = either (error . show) id (parseKey value) diff --git a/test/golden/errors.json b/test/golden/errors.json new file mode 100644 --- /dev/null +++ b/test/golden/errors.json @@ -0,0 +1,1 @@ +{"schemaVersion":1,"type":"settei.errors","errors":[{"kind":"decode-error","key":"database.password","expected":"boolean","origin":{"kind":"environment","kindDetail":null,"name":"environment","key":"database.password","location":null,"annotations":{}},"rejected":""}]} diff --git a/test/golden/errors.txt b/test/golden/errors.txt new file mode 100644 --- /dev/null +++ b/test/golden/errors.txt @@ -0,0 +1,1 @@ +database.password: expected boolean from environment source environment, rejected diff --git a/test/golden/resolution.json b/test/golden/resolution.json new file mode 100644 --- /dev/null +++ b/test/golden/resolution.json @@ -0,0 +1,1 @@ +{"schemaVersion":1,"type":"settei.resolution","nodes":[{"key":"database.password","sensitivity":"secret","outcome":"resolved","value":"","origin":{"kind":"environment","kindDetail":null,"name":"environment","key":"database.password","location":null,"annotations":{"environment.variable":"DATABASE_PASSWORD"}},"shadowed":[],"derivation":null},{"key":"runtime.environment","sensitivity":"public","outcome":"resolved","value":"\"Production\"","origin":{"kind":"environment","kindDetail":null,"name":"environment","key":"runtime.environment","location":null,"annotations":{"environment.variable":"HASKELL_ENV"}},"shadowed":[],"derivation":null},{"key":"service.port","sensitivity":"public","outcome":"resolved","value":"443","origin":{"kind":"derived","kindDetail":null,"name":"service-port-by-environment","key":"service.port","location":null,"annotations":{"settei.default-rule":"service-port-by-environment"}},"shadowed":[{"kind":"built-in","kindDetail":null,"name":"built-in","key":"service.port","location":null,"annotations":{}}],"derivation":{"rule":"service-port-by-environment","explanation":"Choose the conventional production port","dependencies":["runtime.environment"]}}],"branches":[]} diff --git a/test/golden/resolution.txt b/test/golden/resolution.txt new file mode 100644 --- /dev/null +++ b/test/golden/resolution.txt @@ -0,0 +1,9 @@ +database.password = + from environment variable DATABASE_PASSWORD +runtime.environment = "Production" + from environment variable HASKELL_ENV +service.port = 443 + from default rule service-port-by-environment + because runtime.environment = "Production" + from environment variable HASKELL_ENV + shadowed: built-in source built-in diff --git a/test/golden/schema.json b/test/golden/schema.json new file mode 100644 --- /dev/null +++ b/test/golden/schema.json @@ -0,0 +1,1 @@ +{"schemaVersion":1,"type":"settei.schema","settings":[{"key":"database.password","description":"Database password","sensitivity":"secret","requirement":"required","presence":"necessary"}],"conditions":[]} diff --git a/test/golden/schema.txt b/test/golden/schema.txt new file mode 100644 --- /dev/null +++ b/test/golden/schema.txt @@ -0,0 +1,1 @@ +database.password [required, necessary, secret] Database password diff --git a/test/golden/warnings.json b/test/golden/warnings.json new file mode 100644 --- /dev/null +++ b/test/golden/warnings.json @@ -0,0 +1,1 @@ +{"schemaVersion":1,"type":"settei.warnings","warnings":[{"kind":"unknown-key","key":"unknown","origin":{"kind":"file","kindDetail":"memory","name":"document","key":"unknown","location":null,"annotations":{}}}]} diff --git a/test/golden/warnings.txt b/test/golden/warnings.txt new file mode 100644 --- /dev/null +++ b/test/golden/warnings.txt @@ -0,0 +1,1 @@ +unknown: unknown key in file source document (memory)