diff --git a/ADRs/001-defaultDepth-64.md b/ADRs/001-defaultDepth-64.md new file mode 100644 --- /dev/null +++ b/ADRs/001-defaultDepth-64.md @@ -0,0 +1,41 @@ +# ADR 001 — defaultDepth = 64 + +> **Amended by ADR 017 (0.2.0.0): the depth budget is now one of two `Limits`, enforced inside every parser; the root dictionary counts as depth 1.** + + +**Status:** Accepted (provisional; see Gate 2(e)) +**Date:** 2026-10-21 +**Standard rule under review:** §5.9 (deviations recorded) + +## Context + +`Figment.Value.defaultDepth` is the recursion budget every built-in +provider gets when the caller does not override it. The feasibility study +(§1.3, §11 item 3, §12 Gate 2(e)) records this value as "a judgment call, +not a proof". + +## Decision + +Use `64`. + +## Rationale + +- Any hand-authored configuration schema deeper than 64 levels is already + a schema smell; 64 comfortably exceeds real configs while bounding + worst-case stack use to a small constant (Standard §4.10). +- Callers whose schema legitimately needs more can pass an explicit + `Depth` to `tagProvider`; the default is not a hard ceiling. + +## What this ADR does *not* claim + +- That 64 is empirically correct. It is provisional. Gate 2(e) (Standard + §5.6 benchmark on a realistic config, feasibility study §12) is the + evidence-gathering step, and if it shows a different number is right, + this ADR is superseded rather than edited. + +## Consequences + +- `Figment.Value.defaultDepth` stays a single named constant. +- Any change to `64` is a breaking change only if it lowers the value + (would turn currently-accepted inputs into `DepthExceeded`); raising it + is non-breaking. diff --git a/ADRs/002-cpp-for-foldl-import.md b/ADRs/002-cpp-for-foldl-import.md new file mode 100644 --- /dev/null +++ b/ADRs/002-cpp-for-foldl-import.md @@ -0,0 +1,25 @@ +# ADR 002 — CPP guard for the foldl' import in Figment.Layer + +> **Superseded by ADR 016 (0.2.0.0): base >= 4.20 only, so `foldl'` comes from the Prelude and the codebase has no CPP.** + +Status: Accepted | Date: 2026-10-21 | Rule: §1.8, §0.7 + +## Context +`foldl'` is in Data.List/Data.Foldable on base < 4.20 (GHC < 9.10); +it is re-exported by Prelude on base >= 4.20 (GHC >= 9.10). An +unconditional import fails -Wunused-imports under -Werror on GHC >= 9.10; +omitting it fails scope on GHC < 9.10. + +## Decision +CPP-guarded import with CPP in default-extensions: + + #if !MIN_VERSION_base(4,20,0) + import Data.Foldable (foldl') + #endif + +## Rationale +Dropping GHC < 9.10 rejected (matrix requirement). Reimplementing foldl' +violates §4.7. CPP is the standard zero-cost mechanism for this case. + +## Consequences +This is the only CPP in the codebase and should remain so. diff --git a/ADRs/003-nfdata-instances.md b/ADRs/003-nfdata-instances.md new file mode 100644 --- /dev/null +++ b/ADRs/003-nfdata-instances.md @@ -0,0 +1,22 @@ +# ADR 003 — Manual NFData instances on the value domain + +> **Superseded by ADR 016 (0.2.0.0): NFData instances are derived (`deriving anyclass NFData`) on GHC 9.10 and 9.12. The 9.14 failure this ADR cited was never reproduced on a supported compiler.** + +Status: Accepted | Date: 2026-10-21 | Rule: §5.6 + +## Context +criterion's `nf` requires NFData on the benchmarked output type. +`mkTagged` returns `Either ConfigError Tagged`; `mergeAlg` returns `Tagged`. + +## Decision +Hand-written NFData instances on Key, SourceId, Path, Profile, +ProfileName, Depth, Value, Metadata, Tagged, ConfigError. + +## Rationale +Deriving NFData via Generic failed on GHC 9.14. Manual instances work +identically on GHC 9.4.7 through 9.14 with no version-specific code. +`nf` on a projection (`nf (const () …)`) would benchmark allocation, +not the result (§2.8). + +## Consequences +`deepseq` added to library build-depends. No runtime semantics change. diff --git a/ADRs/004-freeze-deferral.md b/ADRs/004-freeze-deferral.md new file mode 100644 --- /dev/null +++ b/ADRs/004-freeze-deferral.md @@ -0,0 +1,17 @@ +# ADR 004 — cabal.project.freeze deferred to Phase 2 +Status: Accepted (provisional) | Date: 2026-10-21 | Rule: §2.12 + +## Context +§2.12 requires a lockfile. cabal.project.freeze is per-GHC; a single +freeze file does not work across a five-version CI matrix. + +## Decision +Phase 1 pins Hackage index date via index-state (in cabal.project). +The full per-GHC freeze matrix is deferred to Phase 2 via haskell-ci. + +## Rationale +index-state is a necessary first step. Per-GHC freeze files are the +correct long-term answer and are produced/maintained by haskell-ci. + +## Consequences +Known deviation until Phase 2. Not silent (§5.9). diff --git a/ADRs/005-quickcheck-bound.md b/ADRs/005-quickcheck-bound.md new file mode 100644 --- /dev/null +++ b/ADRs/005-quickcheck-bound.md @@ -0,0 +1,21 @@ +# ADR 005 — QuickCheck upper bound relaxed to < 2.20 + +> **Amended (0.2.0.0): the test suite now needs QuickCheck >= 2.14 && < 2.17 and no longer depends on hedgehog.** + +Status: Accepted | Date: 2026-10-21 | Rule: §2.11 + +## Context +aeson-2.3.2.0 (pulled in by criterion) depends on QuickCheck >= 2.19. +The original bound `QuickCheck < 2.16` prevented the solver from +finding a plan that includes both test and bench components. + +## Decision +Relax the bound to `QuickCheck >= 2.14.3 && < 2.20`. + +## Rationale +The properties use only the stable QuickCheck API (forAll, ===, +counterexample, chooseInt, elements, frequency, vectorOf, once). Nothing +in the suite depends on behaviour that changed between 2.14 and 2.19. + +## Consequences +Test-suite and benchmark components can now be solved together. diff --git a/ADRs/006-runExtract-design.md b/ADRs/006-runExtract-design.md new file mode 100644 --- /dev/null +++ b/ADRs/006-runExtract-design.md @@ -0,0 +1,57 @@ +# ADR 006 — runExtract design: two-pass decode with provenance reattachment + +> **Superseded by ADR 012, which is in turn superseded by ADR 018.** + + +Status: Superseded by ADR 012 | Date: 2026-10-21 | Rule: §2.1, §2.8, §11 + +## Context +`runExtract :: FromJSON a => Tagged -> Either ConfigError a` is the +boundary from the merged tree back to a caller's record type. The +feasibility study §11 calls this Risk #1 and states that no bridge +is designed. + +The load-bearing question (Gate 2(b)): does leaf-level provenance +(specifically `path`) survive the round-trip through aeson's FromJSON? + +## Options considered + +(a) Two-pass decode: + 1. Convert Tagged -> aeson Value, dropping metadata. + 2. Decode Value -> a with aeson's standard FromJSON. + 3. On DecodeError, re-walk the original Tagged tree to locate the + failing path for the error message. + Provenance is NOT threaded through decode; it is only available to + error reporting, not to the decoded result. + +(b) Custom FromJSON Tagged: + Write a `FromJSON Tagged` instance that carries metadata through + every Parser step. This preserves per-field provenance in the + decoded result, but requires `a` to be built from Tagged, not from + aeson Value — a new class, not FromJSON. + +(c) Field-path reattachment post-decode: + Decode to `a` via (a), then re-walk Tagged and `a` in parallel to + reattach provenance to each leaf of `a`. Requires `a` to be + reflectable via `Generic`, and requires a parallel data type that + mirrors `a` with per-leaf Tagged values. + +## Decision (proposed) +Option (a) for Phase 3. Rationale: +- Matches §2.1 (one canonical IR: Tagged is the IR, aeson Value is a + wire form used only at the provider/decode edge). +- Option (b) is a new typeclass the study does not name; it is a much + larger design than an ADR can commit to. +- Option (c) is Gate 2(b) work, not Phase 3 work — provenance + reattachment requires Generic walkers of `a` that we do not have. +- Option (a) satisfies the §8.1 DecodeError contract: on failure, the + error carries the failing Path, even if the successful result does + not carry provenance per-leaf. + +## Consequences +- Gate 2(b) is NOT satisfied by Phase 3. If provenance must survive + decode, a future ADR chooses between (b) and (c). +- `DecodeError Path Text` gets its Path by a Tagged-tree walk on the + failing field, not from aeson's internal parser state. +- `Figment.hs` exports `composeChecked` / `composeUnchecked` as + specified in §8.2, both delegating to `runLayers` + `runExtract`. diff --git a/ADRs/007-no-redundant-constraints-in-figment-facade.md b/ADRs/007-no-redundant-constraints-in-figment-facade.md new file mode 100644 --- /dev/null +++ b/ADRs/007-no-redundant-constraints-in-figment-facade.md @@ -0,0 +1,28 @@ +# ADR 007 — Disable -Wredundant-constraints in Figment.hs + +> **Superseded by ADR 021 (0.2.0.0): `composeChecked` was removed, so the warning suppression went with it.** + +Status: Accepted | Date: 2026-10-21 | Rule: §5.1 + +## Context +`composeChecked`'s `RequireGenericProvider r ps` constraint is a +type-level-only compile-time gate. GHC sees no path where it is used +inside the body and reports it as redundant under +`-Wredundant-constraints`, which §5.1 makes an error. + +## Decision +Add `{-# OPTIONS_GHC -Wno-redundant-constraints #-}` at the top of +`Figment.hs` only. + +## Rationale +The constraint is not redundant — it is exactly what makes §6.2's +TypeError fire at call sites. GHC's redundancy analysis cannot see +type-level-only constraints as "used" because they discharge no +runtime evidence. Replacing the constraint with a class-with-method +would add a runtime witness no caller needs. + +## Consequences +Scope: one module only. The rest of the library keeps the §5.1 +warning. `composeChecked`'s call sites still get the §6.2 TypeError +when no generic provider is present (verified by +test/CompileFail/NoProvider.hs). diff --git a/ADRs/008-env-prefix-rule.md b/ADRs/008-env-prefix-rule.md new file mode 100644 --- /dev/null +++ b/ADRs/008-env-prefix-rule.md @@ -0,0 +1,33 @@ +# ADR 008 — Env-var key decomposition rule + +> **Superseded by ADR 019 (0.2.0.0): Rust-compatible environment-variable rule.** + +Status: Accepted | Date: 2026-10-21 | Rule: §2.8, §5.7 (RT-03) + +## Context +The feasibility study §10 names RT-03 (env-var prefix collision) as a +regression class that must be pre-empted with a named test before the +Env provider is implemented. + +## Decision +Given a prefix P and an env var name N: +1. If N does not start with P, ignore it. +2. Strip P. +3. Lowercase the remainder. +4. Split on '_'. +5. Drop empty components. +6. If the result is empty (N == P), ignore it. +7. Otherwise the resulting list is the env var's path. + +Collisions at the same path (two vars mapping to the same path after +case folding) are resolved by last-wins in Map insertion order. + +## Rationale +Underscore is the only portable separator across POSIX and Windows +environments. Case folding is required because some shells (Windows +notably) are case-insensitive; folding to lower-case is deterministic +and testable. + +## Consequences +- Test/Figment/EnvProvider.hs pins each rule with a named case. +- Any future change to the rule requires superseding this ADR (§5.9). diff --git a/ADRs/009-orphan-provider-instances.md b/ADRs/009-orphan-provider-instances.md new file mode 100644 --- /dev/null +++ b/ADRs/009-orphan-provider-instances.md @@ -0,0 +1,33 @@ +# ADR 009 — Provider instances are orphans in their adapter modules + +> **Superseded (0.2.0.0): each provider type is now defined in the same module as its `Provider` instance, so there are no orphan instances.** + +Status: Accepted | Date: 2026-10-21 | Rule: §1.7, §2.6 + +## Context +The feasibility study §9 places each provider type in Figment.Provider +and its instance in Figment.Provider.. That creates an orphan +instance under GHC's rules: neither the class (Provider) nor the type +(EnvPrefixed) is defined in the module containing the instance. + +## Decision +Keep the layout from §9 and silence -Worphans in each adapter module +that declares a Provider instance, with a one-line comment pointing +here. + +## Rationale +Alternative (a) — put EnvPrefixed and its instance both in Env.hs — + inverts the dependency direction: Figment.Check would have to import + from an adapter to reach the type, violating §2.6. +Alternative (b) — put the instance in Figment.Provider — forces + Figment.Provider to import System.Environment, violating §1.6 + (IO confined to adapters). +Alternative (c) — newtype-wrap in each adapter — adds a layer of + boilerplate per provider for no semantic gain. + +The Standard's §1.7 orphan ban is about *unrelated* modules; here the +"orphan" module is literally the adapter for that provider. + +## Consequences +Each Provider/.hs opens with -Wno-orphans and this ADR is +referenced. Scope: adapter modules only. diff --git a/ADRs/010-cli-arg-rule.md b/ADRs/010-cli-arg-rule.md new file mode 100644 --- /dev/null +++ b/ADRs/010-cli-arg-rule.md @@ -0,0 +1,15 @@ +# ADR 010 — CLI argument decomposition rule + +> **Superseded by ADR 020 (0.2.0.0): revised CLI rule (flags, `--no-flag`, `--`, malformed options are errors).** + +Status: Accepted | Date: 2026-10-21 | Rule: §2.8 + +## Decision +A CLI argument is consumed as @--key=value@. The key is lowercased and +split on '.' into path components. Arguments not starting with '--' or +with no '=' are ignored. + +## Consequences +- Test/Figment/CliProvider.hs pins each case. +- Space-separated form @--key value@ is NOT supported at this layer; + argument-pairing is the caller's job before passing to 'CliArgs'. diff --git a/ADRs/011-benchmark-ci-thresholds.md b/ADRs/011-benchmark-ci-thresholds.md new file mode 100644 --- /dev/null +++ b/ADRs/011-benchmark-ci-thresholds.md @@ -0,0 +1,28 @@ +# ADR 011 — Benchmark CI: baseline artifact, no auto-fail thresholds yet + +> **Amended (0.2.0.0): CI builds the benchmarks and does a smoke run (`--time-limit 0.2`) on every build. Threshold-based failing is still deferred; the "future ADR 012" mentioned below was never written (that number went to provenance).** + +Status: Accepted (provisional) | Date: 2026-10-21 | Rule: §5.6 + +## Context +§5.6 requires benchmarks checked into CI with regression thresholds. +Thresholds must be calibrated against real variance; without a baseline +sample, a threshold is a guess. + +## Decision +- Run the benchmark suite on every PR (quick mode, in the `build` job). +- Run the full benchmark on `main` only, upload the JSON result as an + artifact, and promote it to `bench-baseline` on every successful main + build. +- Do NOT auto-fail a PR on benchmark regression until at least 10 + baseline samples exist and variance is measured. + +## Rationale +An auto-fail threshold set without variance data would be either +toothless (too high) or flaky (too low). The baseline artifact provides +the data needed for a future ADR that sets real thresholds. + +## Consequences +- Benchmark results are visible in CI artifacts on every main build. +- A future ADR 012 will introduce threshold-based failing. +- Until then, PR authors are expected to inspect the artifact manually. diff --git a/ADRs/012-runExtract-provenance-preservation.md b/ADRs/012-runExtract-provenance-preservation.md new file mode 100644 --- /dev/null +++ b/ADRs/012-runExtract-provenance-preservation.md @@ -0,0 +1,43 @@ +# ADR 012 — runExtract provenance-preserving decode (supersedes ADR 006) + +> **Superseded by ADR 018 (0.2.0.0): the native decoder carries provenance into every error and into `Tagged` fields, so a separate `ProvMap` is unnecessary. (The `Provenanced` class described below was never implemented.)** + +Status: Accepted | Date: 2026-10-21 | Rule: §2.1, §2.8, §11 + +## Context +ADR 006 chose two-pass decode: `Tagged → aeson Value → a` with +provenance only available for error reporting, not on the decoded +result. That left Gate 2(b) of the feasibility study unsatisfied: +"does leaf-level provenance survive the round-trip through +aeson's FromJSON?" + +## Decision +Provide an *additional* decoder alongside `runExtract`: + + runExtractProv + :: forall a. (Generic a, Provenanced a) + => Tagged -> Either ConfigError (a, ProvMap) + +where `ProvMap = Map Path Metadata` collects the metadata of every +leaf in the source tree, keyed by path. `a` is decoded exactly as in +`runExtract` — provenance is *not* threaded through aeson; it is +collected in a second walk of the same tree and returned alongside. + +Callers who need per-field provenance look up `Path` in the map. The +`Provenanced a` class supplies the path-aware field walk for `a`. +A default blanket instance covers every `Generic a` by walking `Rep a`. + +## Rationale +Options (b) and (c) of ADR 006 both require threading metadata through +the parse. Both are invasive: (b) is a new class replacing FromJSON for +every field type; (c) needs parallel mirror types. The ProvMap approach +gives the same consumer-visible guarantee (leaf → provenance, reachable +by path) without changing how `a` is decoded, so it stays compatible +with every existing FromJSON instance. + +## Consequences +- `runExtract` retains its existing behaviour and signature. +- `runExtractProv` is new; no existing call site changes. +- Gate 2(b) is satisfied at the `Path → Metadata` map level. Consumers + that need provenance attached per-structure-field build a lookup on + top; the primitive guarantee is the map. diff --git a/ADRs/013-field-coverage-constraint.md b/ADRs/013-field-coverage-constraint.md new file mode 100644 --- /dev/null +++ b/ADRs/013-field-coverage-constraint.md @@ -0,0 +1,50 @@ +# ADR 013 — Field-level coverage is a runtime default-value concern, not compile-time + +> **Superseded by ADR 021 (0.2.0.0): higher-kinded partial configurations provide a field-level guarantee after all, by construction rather than by inspecting providers.** + +Status: Accepted (supersedes earlier draft) | Date: 2026-10-21 | Rule: §2.8, §6.1, §8.4 + +## Context +§6.1 of the feasibility study says the reachability check is over the +provider list, not individual fields, and Gate 2(d) asks whether a +per-field check is worth adding. + +The Rust `figment` crate — the study's closest prior art — does not do +a field-level coverage check at all. It lets the configuration struct +declare defaults via `#[serde(default)]`. Missing required fields +surface at extraction time; missing optional/defaulted fields fall back +to their declared default. Serde is the single source of truth. + +## Decision +Do NOT add a field-level type-level coverage constraint. Keep +`RequireGenericProvider` as the only compile-time reachability check. +Field coverage is a responsibility of the `FromJSON a` instance +together with whatever default mechanism the caller chooses — `Maybe` +fields, `Default` + aeson's `allowOmittedFields`/`omittedField` +(aeson ≥ 2.2), or explicit defaulting logic. + +Ensure `runExtract` returns a structured `MissingKey Path` when a +required field has no supplied value (already true at the type level; +field-level path reporting is a separate aeson-interop concern). + +## Rationale +- A file provider reads user input; the compiler cannot know which + keys it will contain. Any type-level check is either equivalent to + the existing `RequireGenericProvider` (worthless) or requires the + caller to declare per-field coverage (heavyweight, surprising, and + unlike any comparable library). +- The default-value mechanism is already idiomatic in Haskell via + aeson. Reimplementing it as a compile-time reachability check + duplicates the responsibility in a less capable place. +- Aligning with Rust `figment` matters for interoperability and for + users bringing mental models from that ecosystem. + +## Consequences +- `FieldsOf` / `OptionalFields` (§8.4) remain exposed as building + blocks for future use, but are not used by any constraint in this + release. +- `composeChecked` gains no new constraints. +- README documents the required/defaulted-field discipline (see + README section "Required and optional fields"). +- test/CompileFail/ keeps `NoProvider` and `OkProvider`; drops the + `RequiredAndMaybe` case (no longer meaningful). diff --git a/ADRs/014-safe-haskell.md b/ADRs/014-safe-haskell.md new file mode 100644 --- /dev/null +++ b/ADRs/014-safe-haskell.md @@ -0,0 +1,40 @@ +# ADR 014 — Safe Haskell boundary: Safe core, Trustworthy adapters + +> **Superseded by ADR 022 (0.2.0.0): Safe Haskell annotations removed.** + +Status: Accepted | Date: 2026-10-21 | Rule: §2.8, §1.7 + +## Context +Figment reads untrusted config input. Safe Haskell offers a +machine-checkable guarantee that a module contains no unsafePerformIO +and cannot violate type safety or referential transparency. The +question is which modules to mark, and with which of the three flags +(Safe, Trustworthy, Unsafe). + +## Decision +- Pure core: `Figment.Prim`, `Figment.Value`, `Figment.Merge`, + `Figment.Layer`, `Figment.Error`, `Figment.Extract`, `Figment.Prov` + carry `{-# LANGUAGE Safe #-}`. +- IO adapters and façade: `Figment.Provider.*`, `Figment`, + `Figment.Provider` carry `{-# LANGUAGE Trustworthy #-}`. +- A new test module `test/Figment/SafeBoundary.hs` opens with + `{-# LANGUAGE Safe #-}` and imports only the pure-core modules, + proving the machine-checked claim at test time. + +## Rationale +- All-Safe is rejected: the provider adapters import aeson, tomly-parser, + yaml, and env libraries whose Safe Haskell status is not under our + control and varies by GHC version. A Safe module with one untrusted + import fails to compile [GHC User's Guide §6.18]. +- All-Trustworthy is rejected: it discards the machine-checked + guarantee on the merge algebra and the depth-bound tagger, which are + exactly the parts the feasibility study proved. +- Safe core + Trustworthy edge is the standard Haskell library pattern + for "pure logic with a thin IO shell". + +## Consequences +- Every pure-core module gains one pragma. +- If a pure-core module's imports become unsafe in a future GHC/package + version, the build fails loudly at that import, not silently. +- `test/Figment/SafeBoundary.hs` is the mechanical check (Standard §2.8). +- The README trust-boundary section cites this ADR. diff --git a/ADRs/015-ghc-914-deferred.md b/ADRs/015-ghc-914-deferred.md new file mode 100644 --- /dev/null +++ b/ADRs/015-ghc-914-deferred.md @@ -0,0 +1,26 @@ +# ADR 015 — GHC 9.14.1 support deferred + +> **Amended (0.2.0.0): tested-with is GHC 9.10.3 and 9.12.4 (the earlier 9.4.7 to 9.12.1 range was never actually tested). The stale `cabal.project.freeze.ghc-9.14.1` was removed. 9.14 remains untested.** + +Status: Accepted | Date: 2026-10-22 | Rule: §2.11, §5.9 + +## Context +The library builds and passes all 57 tests on GHC 9.12.1. On GHC 9.14.1, +the solver cannot satisfy `hashable-1.5.0.0`, which requires `base < +4.22`; GHC 9.14.1 ships `base-4.22.0.0`. This is a Hackage upper bound, +not a bug in this codebase. + +`allow-newer: hashable:base` would let 9.14.1 build, but would lie +about compatibility to downstream users. + +## Decision +Ship with `tested-with: GHC 9.4.7 - 9.12.1`. Defer 9.14.1 until a +`hashable` release supports `base-4.22`. + +## Consequences +- CI matrix stays at 9.4.7 - 9.12.1. +- 9.14.1 becomes a one-line `tested-with` change plus a freeze refresh + when `hashable` publishes. +- Users on 9.14.1 install a library that does not officially support + their compiler — the standard behaviour for any package whose + transitive deps have not caught up. diff --git a/ADRs/016-toolchain-and-language.md b/ADRs/016-toolchain-and-language.md new file mode 100644 --- /dev/null +++ b/ADRs/016-toolchain-and-language.md @@ -0,0 +1,19 @@ +# ADR 016 — Toolchain, language edition, dependencies +Status: Accepted | Date: 2026-10-22 | Supersedes: 002, 003 + +## Decision +- `default-language: GHC2021` plus `DerivingStrategies`, `DeriveAnyClass`, + `LambdaCase`, `OverloadedStrings`. Every `deriving` clause names its + strategy, so `DeriveAnyClass` can never be picked silently. +- `base >= 4.20 && < 4.22` (GHC 9.10, 9.12): the bounds claim exactly the + compilers CI tests. No CPP anywhere. +- Instances are derived where possible (`NFData` via `Generic`). +- Dependencies: aeson (token stream, bridge), toml-parser (TOML with + positions), libyaml + conduit (the YAML event stream), time (dates), + directory/filepath/temporary (files, jail), containers, vector, + scientific, text, bytestring, deepseq. `yaml` is no longer used, because + its aeson-based decoder hides positions, duplicates and alias expansion. + +## Consequences +Users on GHC < 9.10 must stay on 0.1. Widening the bounds is only a +`tested-with` change once CI covers the extra compilers. diff --git a/ADRs/017-limits-inside-parsers.md b/ADRs/017-limits-inside-parsers.md new file mode 100644 --- /dev/null +++ b/ADRs/017-limits-inside-parsers.md @@ -0,0 +1,27 @@ +# ADR 017 — Resource limits are enforced inside the parsers +Status: Accepted | Date: 2026-10-22 | Amends: 001 + +## Context +0.1 checked depth in `mkTagged`, after aeson, yaml or toml-parser had +already built the whole tree, so the guard ran after the cost had been +paid. Its stress test built a lazy tree the guard never forced, so it +proved nothing about real input. + +## Decision +`Limits { maxDepth = 64, maxNodes = 1_000_000 }` (smart constructor +`mkLimits`; defaults per ADR 001) are threaded into every parser and +checked while the tree is built: +- JSON: aeson's lazy token stream, so tokens past the limit are never + produced; +- YAML: the libyaml event stream; an alias is charged its *expanded* + size and height (this defeats "billion laughs"); +- TOML: the converter from toml-parser's tree (toml-parser's LR parser + keeps its stack on the heap, which grows only with the input); +- env/CLI structured values: the value parser. + +## Verification +`test/Figment/Test/Adversarial.hs`: 1M-deep JSON text, 100k-deep YAML, +10k-deep TOML and env values are rejected with `DepthExceeded 64`; an +exact boundary test (64 accepted, 65 rejected); a billion-laughs document +is rejected with `TooManyNodes`; arbitrary bytes and truncated documents +never raise an exception (results are forced with `evaluate . force`). diff --git a/ADRs/018-native-decoder.md b/ADRs/018-native-decoder.md new file mode 100644 --- /dev/null +++ b/ADRs/018-native-decoder.md @@ -0,0 +1,27 @@ +# ADR 018 — A native, accumulating decoder (supersedes 006 and 012) +Status: Accepted | Date: 2026-10-22 + +## Context +0.1 converted the merged tree to an aeson `Value` (dropping provenance), +used `fromJSON` (dropping aeson's error path), then reported the +alphabetically first leaf as the error location. The error pointed at +the wrong key. + +## Decision +`FromConfig` decodes figment's own `Value` tree in a `DecodeContext` +(path, profile, lossy flag, consulted sources). `Decoder` is an +**accumulating applicative**; it deliberately has no `Monad` instance, +because a monad has to short-circuit. `andThen` provides explicit +sequencing. Generic deriving covers records, enums, externally tagged +sums, newtypes and positional products, with `Options` +(`fieldLabelModifier`, `constructorTagModifier`, +`rejectUnknownFields` with edit-distance suggestions). Strict by default; +`extractLossy` opts in to string-to-number/bool coercion. Values parsed +from untyped text keep their original text (`tagRaw`), so `Text` fields +receive `007` verbatim. `ViaAeson` bridges existing `FromJSON` instances +and translates aeson's `JSONPath` into figment paths. + +## Consequences +Every error carries the exact path, source, profile, line/column and +the provider-native name. Users with only `FromJSON` instances use +`deriving FromConfig via ViaAeson T`. diff --git a/ADRs/019-env-rule.md b/ADRs/019-env-rule.md new file mode 100644 --- /dev/null +++ b/ADRs/019-env-rule.md @@ -0,0 +1,21 @@ +# ADR 019 — Environment variables follow Rust figment (supersedes 008) +Status: Accepted | Date: 2026-10-22 + +## Decision +- The prefix is matched case-insensitively and stripped. Key + transformations (`split`, `only`, `ignore`, `filterKeys`, `mapKeys`) + apply in the order they were added. Keys are lower-cased by default. + As in Rust, a `.` in the final key nests, and a key with an empty + segment is ignored. +- **No splitting by default**: `APP_MAX_CONNECTIONS` is + `max_connections`. `split "__"` makes `APP_DB__HOST` `db.host`. (0.1 + always split on `_`, which made underscored field names unreachable.) +- Values are parsed (TOML-like: booleans, exact numbers, quoted strings, + arrays, inline dictionaries; anything else is the string itself) and + keep their original text. +- Variables are processed in sorted order. Two variables that cannot + both hold (a value and a dictionary at the same key, or two names that + are equal after lower-casing) are **errors** naming both variables; + 0.1 silently dropped one (and, through a bug, dropped every value). +- `Env.fromList` injects variables, so tests need no process-global + state. diff --git a/ADRs/020-cli-rule.md b/ADRs/020-cli-rule.md new file mode 100644 --- /dev/null +++ b/ADRs/020-cli-rule.md @@ -0,0 +1,13 @@ +# ADR 020 — Command-line rule, revised (supersedes 010) +Status: Accepted | Date: 2026-10-22 + +## Decision +`--key=value` (value parsed as for env vars), `--flag` (true), +`--no-flag` (false); dots nest, dashes become underscores, case is +kept; `--` ends options; everything else is positional and returned by +`parseArgs`. A repeated key: the last occurrence wins (the CLI +convention). Malformed options and structural conflicts are errors. +`--key value` is not supported: without a schema it is ambiguous with a +flag followed by a positional argument. Rich CLIs should parse with +optparse-applicative and pass the result through `defaults`, which is +what Rust figment recommends with clap. diff --git a/ADRs/021-hkd-partial-configs.md b/ADRs/021-hkd-partial-configs.md new file mode 100644 --- /dev/null +++ b/ADRs/021-hkd-partial-configs.md @@ -0,0 +1,23 @@ +# ADR 021 — Higher-kinded partial configurations replace composeChecked +Status: Accepted | Date: 2026-10-22 | Supersedes: 007, 013 + +## Context +`composeChecked @R @ps` took a type-level provider list that was not +connected to the layers actually passed (its own `OkProvider` fixture +compiled with an empty list). Its premise was also weak: an env provider +being present says nothing about whether a field is supplied. + +## Decision +Remove `composeChecked`/`composeUnchecked`. Offer `Field f a` (where +`Field Identity a = a`) and the `Partial` class, all of whose methods +are generic defaults: +- `extractPartial defaults` decodes whatever is present (all type + errors), overlays it on partial defaults, and reports **every** + missing field with the env var, flag or key that would set it; +- `extractTotal` takes total defaults (`c Identity`), so a missing-field + error is impossible by the type. +This is a guarantee Rust's figment cannot express. + +## Verification +`test/Figment/Test/Partial.hs`; `test/compile-fail/PartialSum.hs` +shows that sum types are rejected with a named type error. diff --git a/ADRs/022-safe-haskell-dropped.md b/ADRs/022-safe-haskell-dropped.md new file mode 100644 --- /dev/null +++ b/ADRs/022-safe-haskell-dropped.md @@ -0,0 +1,16 @@ +# ADR 022 — Safe Haskell annotations removed (supersedes 014) +Status: Accepted | Date: 2026-10-22 + +## Context +In 0.1 the `Safe`/`Trustworthy` assignments contradicted ADR 014, and +`Trustworthy` was used to get past aeson's inferred status rather than +as the result of an audit. That is a promise nobody had checked. +Trustworthy guarantees also mean nothing unless downstream users enable +`-fpackage-trust`, which almost no one does. Every adapter now depends +on aeson, libyaml or toml-parser, none of which is Safe. + +## Decision +No Safe Haskell pragmas. Purity is visible in the types: only `provide`, +`load` and the jail live in `IO`. The single `unsafePerformIO` (the +jail's process-wide lock, the standard top-level `MVar` idiom) is +documented where it appears. diff --git a/ADRs/023-figment-as-description.md b/ADRs/023-figment-as-description.md new file mode 100644 --- /dev/null +++ b/ADRs/023-figment-as-description.md @@ -0,0 +1,19 @@ +# ADR 023 — A Figment is a pure description; load collects everything +Status: Accepted | Date: 2026-10-22 + +## Decision +- `Figment` is a sequence of steps (order, metadata, provider action) + plus the last `select` and `withLimits`. It is a lawful `Monoid` (the + free monoid on steps), which is the lawful structure the value-level + merge cannot provide. The laws are property-tested observationally. +- Builders (`merge`, `join`, `adjoin`, `admerge`, `combine`) take + `HasCallStack` and record where each provider was added. +- `load` runs providers in order and **does not stop at the first + failure**: all provider errors are returned together. Any synchronous + exception that escapes a provider becomes an `IoError` with that + provider's metadata; asynchronous exceptions are re-thrown. +- `Figment` is itself a `Provider`. Inner values keep their tags, + because retagging only fills in missing provenance. +- Profiles: `Default`, then the selected profile, then `Global`. An + explicit `select` beats profile hints from providers, which combine by + the step's order. diff --git a/ADRs/024-yaml-event-stream.md b/ADRs/024-yaml-event-stream.md new file mode 100644 --- /dev/null +++ b/ADRs/024-yaml-event-stream.md @@ -0,0 +1,10 @@ +# ADR 024 — YAML from libyaml events, YAML 1.2 core schema +Status: Accepted | Date: 2026-10-22 + +## Decision +Parse the libyaml event stream directly instead of going through +`Data.Yaml`. This gives positions for every value, duplicate-key errors, +alias expansion charged to the node limit, merge keys (`<<`, where +explicit keys win), and an explicit rejection of multi-document files. +Plain scalars resolve under the YAML 1.2 core schema, so `no`, `on` and +`yes` remain strings. Explicit tags (`!!str`, `!!int`, ...) are honoured. diff --git a/ADRs/025-error-rendering.md b/ADRs/025-error-rendering.md new file mode 100644 --- /dev/null +++ b/ADRs/025-error-rendering.md @@ -0,0 +1,11 @@ +# ADR 025 — Error values and their rendering +Status: Accepted | Date: 2026-10-22 + +## Decision +`ConfigError { kind, path, profile, metadata, pos, hints }` with a +closed `ErrorKind`, every constructor of which is produced somewhere. +`ConfigErrors` is non-empty, a `Semigroup`, and an `Exception` whose +`displayException` is `renderErrors`. The rendered form is part of the +public interface and is pinned by golden tests in `test/golden/`. +(0.1 pinned derived `Show` output, which leaked the internal +`UnsafeDepth` constructor.) diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,55 @@ +# Changelog + +## 0.2.0.0 — 2026-10-22 + +A breaking redesign, following a forensic audit of 0.1 +(`docs/audit-remediation.md` maps every finding to its fix and test). + +### Fixed +- Environment and CLI providers dropped every value (`APP_HOST=x` became + `{host: {}}`). +- Decode errors reported the alphabetically first key instead of the + failing one. +- The compile-time "provider check" was disconnected from the layers it + claimed to check. +- Missing JSON/YAML files threw `IOException`; TOML caught asynchronous + exceptions. +- TOML dates became `null`, `inf`/`nan` became garbage numbers, invalid + UTF-8 was silently replaced; duplicate YAML keys and env conflicts + were resolved silently. +- The depth limit ran after parsing, so it never protected the parsers. +- The README example did not compile. + +### Added +- `Figment.Tutorial`: a sixteen-section guided tour whose snippets are + compiled and run by the test suite. +- Profiles (`Default`, `Global`, custom; `select`; nested files; profile + hints) with Rust figment's semantics. +- A native, accumulating decoder (`FromConfig`, generic deriving with + options, combinators): every error is reported at once with path, + source, line/column, profile and the provider-native key name. +- Higher-kinded partial configurations (`Field`, `Partial`, + `extractPartial`, `extractTotal`). +- `Tagged`, `RelativePath`, `ViaAeson`; `extractLossy`, `extractAt`, + `findValue`, `contains`, `findMetadata`, `focus`, `reselect`. +- Providers: `fromText`, `file` (optional, searched upward), `fileExact`, + `required`, `nested`; Rust-compatible `Env` with options; revised + `Cli`; `Serialized` (`defaults`, `globals`, `keyed`); figments as + providers. +- Metadata: structured source, the call site where each provider was + added, and a key-name interpolater. +- Parser limits (`Limits`: depth and node count) enforced inside every + parser; YAML alias-bomb protection. +- `Figment.Jail` for configuration tests. +- `Exception` instance and a human-readable renderer for `ConfigErrors`. + +### Removed +- `composeChecked`, `composeUnchecked`, `Figment.Check`, `RawJSON`, + `mkTagged`, `ProvMap`/`runExtractProv` (superseded), `SourceId`, + `Depth` (now `Limits`), Safe Haskell pragmas, the `yaml` dependency. + +### Changed +- `base >= 4.20` (GHC 9.10 and 9.12, as tested). + +## 0.1.0.0 +Initial pre-release. diff --git a/ENGINEERING_STANDARD.md b/ENGINEERING_STANDARD.md new file mode 100644 --- /dev/null +++ b/ENGINEERING_STANDARD.md @@ -0,0 +1,856 @@ +# The Haskell Engineering Standard + +**Status: binding.** This document is the constitution for any Haskell +codebase it governs — read and applied *before* the first module is +written, not retrofitted afterward. It applies equally to AI-authored and +human-authored code, and to AI or human review of either. Where a request +conflicts with this document, follow this document and say so explicitly. + +**Precedence when principles conflict**, highest first: +1. Correctness / totality — a fast or elegant function that can go wrong + silently loses to a slower one that can't go wrong at all. +2. Safety of representation — illegal states must stay unrepresentable + even at the cost of a more verbose type. +3. Architectural clarity — a boundary that makes the system easier to + reason about beats a shortcut that makes today's diff smaller. +4. Performance — addressed deliberately, with evidence, never guessed at + the expense of 1–3. +5. Brevity — the last thing optimized for, never the first. + +--- + +## Part 0 — Foundational Design Principles, in Haskell Terms + +Classic software-design principles are usually stated in OOP vocabulary. +They still hold; they just cash out differently without classes and +inheritance. State them this way so there's no ambiguity about what they +mean here. + +### 0.1 Single Responsibility Principle +One module, one reason to change. A module that both parses a format and +knows how to render one has two responsibilities wearing one name; split +it. The test: describe the module's job in one sentence with no "and." + +### 0.2 Open/Closed Principle +A system should be open to extension without modifying proven code. In +Haskell this is a genuine design choice with two valid, opposite-shaped +answers — pick the right one deliberately, per extension axis: +- **Closed sum + exhaustive pattern match**, when the set of cases is + owned and finite (e.g. the source formats *this* project supports). + Adding a case is a compile error at every site that needs updating — + extension is "open" in the sense that the compiler *guides* the change, + even though the type itself is closed. +- **Typeclass or record-of-functions ("Handle") boundary**, when the set + of cases is genuinely open to third parties (e.g. a plugin renderer a + downstream consumer supplies). Extension happens with zero edits to + existing code. + +Never blend the two on the same axis of variation — decide, per +extension point, which discipline governs it, and document the choice. + +### 0.3 Liskov Substitution — restated as typeclass law-abidance +Any two instances of the same typeclass must satisfy the same laws. +A `Monoid` instance whose `mappend` isn't associative, an `Eq` instance +that isn't reflexive, an `Ord` instance inconsistent with its `Eq` — these +are the Haskell equivalent of a subtype that violates its supertype's +contract. State each instance's laws in a comment and, wherever practical, +test them with a law-checking library (`hspec-hedgehog`, `checkers`). + +### 0.4 Interface Segregation +Typeclasses (and Handle records) should be as small as the caller actually +needs. A function should be constrained by the narrowest capability it +uses — `(Monad m) => ...` rather than `(MonadIO m, MonadState S m, +MonadReader R m) => ...` when only `Monad` is actually exercised. A fat +typeclass or a fat Handle forces every implementation to satisfy +capabilities most call sites never touch. + +### 0.5 Dependency Inversion — the Handle pattern +Haskell has no interfaces in the OOP sense; the idiomatic equivalent of +"depend on abstractions, not concretions" is passing a small record of +functions (a **Handle**) into pure or effect-polymorphic code, rather than +having that code import a concrete `IO`-performing module directly. + +```haskell +-- | The core logic depends on this shape, not on any concrete backend. +data StorageHandle m = StorageHandle + { loadDocument :: DocId -> m (Either MirrorError Document) + , saveDocument :: DocId -> Document -> m (Either MirrorError ()) + } + +-- | Pure with respect to *how* storage happens — swap the Handle for +-- tests (an in-memory Map) without touching this function. +republish :: Monad m => StorageHandle m -> DocId -> m (Either MirrorError ()) +``` +This is what makes core logic testable without spinning up real I/O, and +it is preferred over a typeclass when only one concrete instance is ever +needed per call site (a Handle is simpler; a typeclass is for genuine +ad hoc polymorphism across many types). + +### 0.6 DRY — with its correct limit stated explicitly +Duplication of *knowledge* (the same invariant, checked two different +ways in two places) must be eliminated — that's what the shared +"raw → validated" translation layer and the shared smart constructors in +Part 2 exist to prevent. Duplication of *code that happens to look +similar but encodes unrelated decisions* should **not** be merged. Two +functions that currently have the same three lines but answer different +questions are not a DRY violation — collapsing them creates a false +coupling that will need to be un-collapsed the moment the two decisions +diverge. When in doubt: ask whether the two call sites would ever need to +change independently. If yes, don't merge them. + +### 0.7 KISS and YAGNI +Implement the mechanism the current, real requirement needs — not the one +a hypothetical future requirement might need. An error constructor, +typeclass, or extension point is added in the same change that makes it +reachable, never speculatively (this is also stated in Part 1 as a +closed-vocabulary rule, because it's load-bearing there too). Prefer the +simplest technique in Part 3's toolkit that fully closes the problem; +reach for a more powerful technique (GADT, existential, type family) only +once the simpler one is demonstrably insufficient, and say why in a +comment when you do. + +### 0.8 Law of Demeter +A function should not reach through more than one level of a nested +record/structure to get what it needs. If `renderPage` needs +`documentMeta.author.displayName`, that's a sign `documentMeta` should +expose `authorDisplayName` directly, or the caller should be handed the +narrower value it actually needs rather than the whole tree. This keeps +refactors local: changing how `author` is represented shouldn't ripple +into every renderer that happens to reach through it. + +### 0.9 Composition over inheritance — the Haskell default +There is no inheritance to avoid reaching for; the discipline instead is +to build behavior by composing small, independent pieces (function +composition, typeclass constraints, monad transformers, or simple value +composition) rather than by building one large record or one large +typeclass that tries to be everything. If a type is accumulating +unrelated fields "because it's convenient to have them all in one place," +that's the inheritance instinct resurfacing in record form — split it. + +### 0.10 Principle of Least Power +Give every function the least expressive type that still lets it do its +job. A function that doesn't need `IO` shouldn't have it in its +signature. A function that only reads state shouldn't be typed to allow +writes. A typeclass constraint should name the weakest class in the +hierarchy that suffices (`Foldable` instead of a concrete `[]`, when only +folding is needed). Least power at the type level is what makes a +signature trustworthy on sight — the type is a promise about what the +function *cannot* do, not just what it does. + +### 0.11 Compatibility is a promise about the boundary, not the internals +Preserve backward compatibility for a module's public API where +practical — don't churn an external signature for cosmetic reasons; see +2.13 for how this is enforced through versioning. That promise applies +only to the boundary. Internally, continuously review and simplify type +and module design: refactor implementations freely, delete dead +abstractions, and collapse a type that turned out more general than +needed, as long as the public shape either stays put or moves behind a +deliberate version bump. Stability and simplification aren't in tension +once it's clear which side of the export list each applies to. + +--- + +## Part 1 — Language Principles (never violated) + +### 1.1 Every function is total, or its type says it isn't +No partial functions. Never use: `head`, `tail`, `last`, `init`, +`fromJust`, `(!!)`, non-exhaustive pattern matches, `error`, `undefined`, +or incomplete `case`/`if` chains on a closed type. If a function can fail, +its type says so — `Maybe a` for one reason, `Either e a` when the reason +needs to be named. `-Wall -Werror -Wincomplete-uni-patterns +-Wincomplete-record-updates -Wpartial-fields` are mandatory, not optional. + +### 1.2 Illegal states are unrepresentable, not merely rejected +Prefer a type that cannot hold invalid data over a type that can, plus a +validator. This is the single most important habit in this document and +recurs throughout Part 3's toolkit — see especially 3.1–3.4. + +### 1.3 Cross-field invariants are enforced once, at construction +If correctness depends on a relationship between two or more fields (e.g. +"every row has the same width"), the constructor is not exported; the +only way to obtain a value is a smart constructor returning +`Either err a`. Once constructed, the value is trusted everywhere +downstream — never re-checked. (Full treatment in 3.3.) + +### 1.4 Closed domains are closed types, not strings +Any finite, known set of alternatives is a sum type — never a +`Text`/`String` compared against literals. A value outside the closed set +is a compile-time impossibility, not a runtime "unrecognised value" +string. + +### 1.5 Errors are a closed, structured vocabulary +One sum type per failure category, each constructor documented with *why +it exists* and *what can produce it*. No stringly-typed errors, no +catch-all `OtherError Text`. A constructor is added only in the same +change that makes it reachable. + +### 1.6 Purity is pushed to the edges +Business logic is pure. `IO` is confined to a thin shell at the +boundary — reading input, writing output, catching foreign-library +exceptions and converting them into the structured error type +immediately. A function is never `IO`-typed merely because a library it +calls can throw; catch and convert at that call site. + +### 1.7 No implicit escape hatches +No `unsafePerformIO`, no `Debug.Trace` in committed code, no `Show`-based +serialization used as data interchange, no orphan instances (an instance +lives next to the type or next to the class, never floating in an +unrelated module). + +### 1.8 Explicit over implicit, always +No global mutable state (`IORef`s reached for reflexively instead of +threading state explicitly), no reliance on typeclass resolution doing +something surprising (`OverlappingInstances`, `IncoherentInstances` are +red flags requiring explicit justification), no reflection-like tricks to +avoid writing an explicit case. If a reader has to run the code mentally +to know what will happen, it's too implicit. + +### 1.9 Immutability is the default, not an aspiration +Data is immutable unless a specific, profiled reason calls for a mutable +cell (`IORef`, `STRef`, `MVar`, a mutable vector). Local transformations +use record-update syntax and pure recursion, not accumulation into a +mutable variable "for convenience." This is distinct from 1.8's ban on +*global* mutable state — 1.9 is the default even for a value that never +leaves a single function. + +### 1.10 Referential transparency is the target, not just a byproduct of purity +An expression's value must not depend on when, how many times, or in +what order it's evaluated — this is what makes equational reasoning +possible: a sub-expression can be replaced by its value, memoized, or +lifted out and shared, without changing the program's meaning. +`unsafePerformIO` and any hidden mutable state breaks this, which is why +1.7 bans the former outright rather than merely discouraging it. + +### 1.11 Zero dead code, zero empty stubs — strictly enforced +Nothing unreachable is committed: no unused top-level bindings, no +commented-out blocks "kept just in case," no functions exported but +never called anywhere in the codebase or its public API surface. +`-Wunused-top-binds -Wunused-local-binds -Wunused-matches` are treated +as errors, and a dead-code detector (`weeder`) runs in CI alongside +`hlint`. Equally strict in the other direction: a function is either +fully implemented or does not exist in the merged code — no +`someFunction = undefined`, no `error "TODO"`, no placeholder that +type-checks but panics if called. If a capability isn't ready, its +call site isn't merged either; half-built scaffolding is worse than an +honest absence, because it compiles clean and looks finished. + +--- + +## Part 2 — Software Architecture (never violated) + +### 2.1 One canonical intermediate representation +When a problem involves multiple input or output formats converging on +shared logic, there is exactly **one** internal representation every +input funnels into and every output funnels out of. Format-specific logic +lives only in the thin translation layer at each edge; core logic is +written once, against the IR. + +### 2.2 Validation is staged, not scattered +Recovering *shape* is kept separate from checking *content validity*. Use +a shared "raw → validated" translation layer if multiple producers reach +the same validation step — write the validation once, share it. + +### 2.3 Errors are layered to match pipeline stages +The top-level error type is a closed sum of closed sums, one case per +pipeline stage. A function's return type tells you unambiguously which +stage produced a failure without inspecting a string. + +### 2.4 Recursive structures carry an explicit resource bound +Any recursive data type that hostile or careless input could nest +arbitrarily deep gets an explicit, threaded depth/size limit at every +point of recursive descent, applied **uniformly** across every stage +capable of producing that nesting — not just the one someone happened to +think of first. + +### 2.5 Module boundaries are drawn by responsibility, enforced by exports +Each module has one reason to change (0.1). Constructors and functions +that could violate an invariant if exported freely are **not** exported. +`-Wmissing-export-lists` is mandatory. A module's export list is its +contract. + +### 2.6 Dependency direction is acyclic and points at the core +Format-specific / adapter modules depend on the core IR module; the core +never imports outward. This is hexagonal architecture stated in Haskell +terms: a pure core, with parsers/renderers/storage/network as adapters at +the boundary, wired in either via closed dispatch (0.2) or a Handle/ +typeclass (0.5) — never via the core reaching outward to call them +directly. + +### 2.7 Extensibility mechanism is chosen deliberately, per axis, and documented +See 0.2. State, in the relevant module's Haddock, whether a given +extension point is closed-by-design (compiler-enforced exhaustiveness) or +open-by-design (Handle/typeclass) — and don't let a "just this once" +exception blur the line without updating the documentation to match. + +### 2.8 Every architectural claim has a mechanical check behind it +"This module is total" is checked by `-Wincomplete-patterns -Werror`. +"This invariant holds for every value of this type" is checked by a +property test. A claim without an enforcement mechanism is a wish, not a +property of the code, and must not be described as though it were +guaranteed. + +### 2.9 Testing is part of the architecture, not an afterthought +Property-based tests are a *design tool*, not just a QA step — writing +the property before/alongside the implementation ("for any input, output +satisfies X") is often what reveals whether the type actually needs a +smart constructor. Regression tests are named after the specific defect +they guard, not "test5." Unit tests exercise the pure core directly, +never through an `IO` shell, because the core is pure and testable in +isolation by construction (1.6, 0.5) — if a test needs `IO` to exercise +core logic, that's a signal the architecture leaked an effect it didn't +need to. + +### 2.10 Organise modules by domain, not by technical utility +Group modules by what they mean in the problem (`Document`, +`Pipeline`, `Rendering.Html`), not by what kind of thing they technically +are (`Utils`, `Helpers`, `Common`, `Types`). A grab-bag `Utils.hs` is a +confession that some piece of logic was never given a real owner — it +belongs in whichever domain module actually needs it, even at the cost +of a small amount of near-duplicate code across two domains (0.6). + +### 2.11 Depend on the fewest, best-maintained libraries the problem needs +Prefer an established, actively maintained library over a hand-rolled +equivalent — including for 4.2's named algorithms: if a well-maintained +library already implements the algorithm correctly, depend on it rather +than re-proving it in-house (4.7), unless the dependency itself becomes +the risk (parsing untrusted input, licensing, supply-chain exposure). +Every dependency joins the trusted computing base; add one deliberately, +not by default, and prefer one well-chosen library over three overlapping +ones that each cover part of the same need. + +### 2.12 Builds are deterministic and reproducible +Pin dependency versions (`cabal.project.freeze` or an equivalent +lockfile, a fixed Stackage resolver) so the same commit produces the same +build, today and a year from now. A build that silently picks up a newer +transitive dependency on every fresh checkout undermines every other +guarantee in this document — a passing property test says little if next +week's build compiles different code underneath it. + +### 2.13 Package and module versioning follows the PVP, deliberately +Follow the Haskell Package Versioning Policy: a breaking change to any +exported signature bumps the major version; anything else does not. +Combined with 0.11 — a public signature changes only behind a deliberate +version bump, never as the silent side effect of an unrelated refactor. + +### 2.14 Code is portable by default +Avoid unnecessary dependence on a specific OS, filesystem layout, or +compiler version beyond what the problem genuinely requires. Use +portable path/file libraries (`filepath`, `directory`) instead of +hardcoded separators or absolute paths; note any genuine, unavoidable +platform dependency explicitly in the module that has it, rather than +letting it surface later as a mysterious build failure somewhere else. + +### 2.15 Errors live in a dedicated module, and every message is descriptive +The closed error vocabulary (1.5, 2.3) is defined in its own module, +separate from the domain logic that raises it — one place a reviewer or +a new contributor goes to see the entire universe of ways the system can +fail. Every constructor's rendered message names the specific thing that +went wrong and, wherever the information is available, the specific +input or location that caused it (a file path, a line number, a field +name) — never a bare "invalid input" or "something went wrong." A vague +error message is a silent failure wearing an error type; it satisfies +1.5's letter while missing its point. + +--- + +## Part 3 — The Haskell Type-System Toolkit: What to Reach For, and When + +Use the least powerful tool in this list that fully solves the problem +(0.7, 0.10). Escalate only when the simpler tool genuinely can't express +the invariant, and say so in a comment when you escalate. + +### 3.1 Algebraic data types — the default, reach for first +Sum types for closed alternatives, product types (records) for "all of +these together." This is the baseline for making illegal states +unrepresentable: a value that can only be one of N well-defined shapes, +never a partially-filled record with a `Maybe` flag simulating a variant. + +```haskell +-- Bad: simulates a sum type with a flag and nullable fields. +data Shape = Shape { isCircle :: Bool, radius :: Maybe Double + , width :: Maybe Double, height :: Maybe Double } + +-- Good: the type itself rules out "circle with a width." +data Shape = Circle Double | Rectangle Double Double +``` + +### 3.2 Newtypes — eliminate primitive obsession at zero runtime cost +Any domain concept represented as a bare `Text`, `Int`, or `Double` that +could be confused with another value of the same primitive type gets a +`newtype`. `UserId`, `DocId`, and `SessionId` should not all be `Text` +that the compiler will happily let you swap by accident. + +```haskell +newtype UserId = UserId Text deriving (Eq, Ord, Show) +newtype DocId = DocId Text deriving (Eq, Ord, Show) +-- lookupDoc :: UserId -> DocId -> ... -- now a compile error to swap them +``` + +### 3.3 Smart constructors + opaque exports — the standard invariant-enforcement mechanism +Whenever a value's validity depends on content, not just shape (a +rectangular table, a syntactically valid URL, non-empty-after-trimming +text), the type's constructor is unexported and the *only* way to build +one is a function returning `Either err a`. This is not optional +whenever 1.2/1.3 apply — it is the mechanism those principles are +implemented with. + +```haskell +module M (Percentage, mkPercentage, unPercentage) where + +newtype Percentage = UnsafePercentage Double deriving (Eq, Ord, Show) + +mkPercentage :: Double -> Either ValidationError Percentage +mkPercentage x + | x >= 0 && x <= 100 = Right (UnsafePercentage x) + | otherwise = Left (OutOfRange x) + +unPercentage :: Percentage -> Double +unPercentage (UnsafePercentage x) = x +``` + +### 3.4 Phantom types — compile-time-only tags with zero runtime cost +Use a type parameter that never appears on the right-hand side of any +constructor to carry a *static* fact about a value — "this text has been +escaped," "this ID belongs to a draft, not a published document" — that +the compiler checks but that costs nothing at runtime. + +```haskell +data Status = Draft | Published + +newtype DocRef (s :: Status) = DocRef Text + +publish :: DocRef 'Draft -> IO (DocRef 'Published) +-- A published-only operation now cannot even type-check against a draft. +notifySubscribers :: DocRef 'Published -> IO () +``` + +### 3.5 GADTs — when different constructors need different result types +Reach for a GADT when a plain ADT would force every constructor to share +one result type even though they logically produce different types, and +you'd otherwise be compensating with an unsafe cast or a partial +extraction function. Typed embedded languages/ASTs, and safety-indexed +wrappers (a value's constructors *are* its safety guarantee) are the +canonical use case. + +```haskell +data Expr a where + IntLit :: Int -> Expr Int + BoolLit :: Bool -> Expr Bool + Add :: Expr Int -> Expr Int -> Expr Int + If :: Expr Bool -> Expr a -> Expr a -> Expr a + +eval :: Expr a -> a -- total: GADT rules out ill-typed terms +eval (IntLit n) = n +eval (BoolLit b) = b +eval (Add x y) = eval x + eval y +eval (If c t e) = if eval c then eval t else eval e +``` +Without the GADT, `eval :: Expr -> SomeValue` would need a runtime type +check and a partial extraction (`asInt`, `asBool`) — exactly the +partiality Part 1 prohibits. The GADT moves that check to compile time. + +### 3.6 Existential types — last resort, justify explicitly +Use `forall`/existentials only when you genuinely need a heterogeneous +collection of values that share a common interface but whose concrete +type doesn't matter (e.g. a list of "anything renderable"). Existentials +throw away the very type information Part 1–3 spend so much effort +preserving, so treat reaching for one as a flag: state in a comment +*why* the concrete type must be forgotten here and why a closed sum +(3.1) or typeclass-constrained polymorphic function isn't sufficient +instead. + +### 3.7 Typeclasses — principled overloading with laws, not ad hoc dispatch +A typeclass is appropriate when multiple types share genuinely the same +abstract operation *and* that operation obeys stated laws (0.3). It is +not a substitute for a Handle (0.5) when there's only ever one +implementation live at a call site, and it is not a way to fake +function overloading for otherwise-unrelated operations. Every +non-trivial typeclass ships with its laws stated in a Haddock comment, +and law-checking tests where a library exists for the class in question. + +### 3.8 DataKinds / kind signatures — promote a value to the type level only when the compiler needs it there +Use `DataKinds` when a value genuinely needs to participate in a +type-level distinction (as in 3.4's `Status` kind). Don't promote a value +to the type level "for elegance" if a plain runtime value moving through +an `Either`/smart-constructor already closes the same hole — that's +reaching for 3.4–3.5's power where 3.1/3.3 would fully suffice (0.7). + +### 3.9 mtl-style constraints / effect boundaries — dependency inversion at the type level +When a function needs several capabilities (state, config, failure) +without being locked to one concrete monad stack, constrain it +polymorphically (`(MonadReader Config m, MonadError MirrorError m) => ...`) +rather than hardcoding `ReaderT Config (ExceptT MirrorError IO) a`. This +is 0.5's dependency inversion applied to effects: the function states +what it needs, not which stack provides it, and can be run over a pure +test stack and a real `IO` stack without being rewritten. Reach for a +full effect system (`polysemy`/`effectful`/`fused-effects`) only once +the mtl-style constraint set is unwieldy in practice — not by default. + +### 3.10 Free monads / tagless-final — advanced, use only when interpreter-swapping is a real requirement +These let business logic be written once and interpreted multiple ways +(a real backend, an in-memory test double, a dry-run/audit log). They are +powerful and legitimately useful, but they add real conceptual and +compile-time cost. Reach for them only when the Handle pattern (0.5) +genuinely can't express the needed flexibility — e.g. when the *sequence +of operations itself* needs to be inspected or optimized before +execution, not just when-swapped. Justify the choice in the module's +Haddock when used. + +### 3.11 Refinement types (Liquid Haskell) — optional, for the highest-stakes invariants only +When a smart constructor's `Either`-returning runtime check would be +better as a statically checked refinement (e.g. "this index is always +in bounds," "this list is always sorted"), Liquid Haskell annotations +can move the proof obligation to compile time, checked by an SMT solver. +This is an opt-in escalation for the small number of invariants where +the cost of getting it wrong is high enough to justify the tooling +overhead — not a default for every smart constructor in the codebase. + +### 3.12 Type aliases document; they don't protect — don't mistake one for the other +`type CustomerId = Text` buys readability and nothing else: the compiler +still lets a bare `Text` meant as an email address flow anywhere a +`CustomerId` is expected. Reach for `type` only as genuine shorthand for +a long, repeated type expression. The moment two values sharing an +underlying representation must not be interchangeable, that's `newtype` +territory (3.2), not `type`. + +### 3.13 Use the standard abstractions idiomatically; prefer the weakest one that suffices +Write code against `Functor`, `Applicative`, `Monad`, `Foldable`, and +`Traversable` using their standard combinators (`fmap`, `traverse`, +`sequence`, `for_`) rather than reimplementing their effect by hand — +4.1's combinator discipline applied to the handful of classes that recur +constantly. Prefer `Applicative` over `Monad` whenever the computation's +structure doesn't actually depend on a previous result: an `Applicative` +signature is a stronger, more honest claim ("these effects are +independent of each other") than a `Monad` signature over the same code, +and it composes and parallelizes better as a direct consequence. + +### 3.14 Parametric polymorphism internally; concrete types at the boundary +Prefer a polymorphic type (`Foldable t => t a -> ...`) inside a module +where it genuinely generalizes the logic without adding constraint- +solving noise (0.10). At a module's public boundary — the functions in +its export list — prefer concrete, specific types over polymorphism for +its own sake: `Document -> Either MirrorError Html` is easier to consume, +produces clearer type errors at the call site, and is easier to reason +about than a signature generalized over a typeclass nobody outside the +module will ever instantiate differently. + +### 3.15 Linear types — when a resource's usage discipline is itself the invariant +Where correctness depends not just on a value's shape but on *how many +times and in what order* it is used — a file handle that must be closed +exactly once, a protocol token that must not be duplicated or silently +dropped — `LinearTypes` let the compiler enforce that usage discipline +the same way GADTs (3.5) enforce shape. Treat this as a specialized, +last-resort-among-first-resorts tool: reach for it only when the +resource-usage invariant can't be adequately captured by a Handle (0.5) +plus ordinary discipline, since linear types add real signature-level +complexity everywhere the resource is touched. + +--- + +## Part 4 — Code Style: Algorithmic, Not Improvised + +Every non-trivial piece of control flow is either a **named combinator** +or a **named, published algorithm** — so a reader verifies it by +recognition, not by re-deriving it line by line. This is not a request +for brevity or point-free cleverness; point-free style is permitted only +where it reveals structure (4.4), and is otherwise prohibited. + +### 4.1 Name the recursion scheme before writing the recursion +| Shape | Combinator | +|---|---| +| Consume a structure, build one value | `foldr` / `foldl'` | +| Produce a stream from a seed until done | `unfoldr` | +| Structure-preserving traversal with effects | `traverse` / `mapM` | +| Map while threading accumulator state | `mapAccumL` / `mapAccumR` | +| Repeated application until a fixed point | `until` / `iterate` + `takeWhile` | +| Group / partition by a predicate | `span`, `break`, `groupBy`, `partition` | + +Hand-written recursion is reserved for logic with no existing combinator +shape — and even then, the Haddock states which scheme it approximates +and why no combinator fits. + +### 4.2 If a published algorithm solves the exact problem, implement that algorithm, by name +Don't reinvent a heuristic that happens to converge on a known +algorithm's answer — implement the known algorithm and cite it (Kahn's +algorithm for topological order, Pratt parsing for precedence-based +expression parsing, Myers' algorithm for sequence diffing, and so on). +Naming it lets a reviewer check the implementation against a reference +instead of re-establishing correctness from first principles. + +### 4.3 Match complexity to access pattern +`Map`/`Set` for lookup-heavy code, not a linearly scanned `[a]`; `Seq` +for append/index-heavy code, not a repeatedly reversed list. Do not, +conversely, reach for a more sophisticated algorithm than the problem +needs (0.7) — correct complexity for the real access pattern, not +maximal sophistication for its own sake. + +### 4.4 Point-free style only when it reveals structure +`f = g . h` is preferred over an explicit lambda only when the +composition itself is the insight worth stating. If it requires the +reader to mentally re-expand it to check what's happening, write it +pointfully. Never chain more than two or three compositions without a +named intermediate. + +### 4.5 Every exported function is one lemma +If a function's body doesn't fit in roughly 15–20 lines, it's not one +claim, it's several — split it and name each part. A long `case` across +a closed type is fine (it's exhaustiveness, not sprawl); a long sequence +of unrelated steps is not. + +### 4.6 The type signature is the theorem; the Haddock states the invariant, not the procedure +**Bad:** `-- loops through the list and picks out the valid rows` +**Good:** `-- | The only way to obtain a 'Table': every row, header +included, is checked against the first row's width. On success, the +result's rectangularity is guaranteed for every later consumer.` + +### 4.7 Reuse a proven library's implementation of a named algorithm before writing your own +4.2 says to implement a named, published algorithm rather than an ad hoc +heuristic. The stronger version: if a well-maintained library already +provides that exact algorithm correctly, depend on it (2.11) instead of +re-implementing it. Reserve a from-scratch implementation for the case +where no adequate library exists, or where this codebase's handling of +untrusted input specifically requires an implementation whose safety +properties can be independently audited (Part 5). + +### 4.8 Consistent naming conventions, applied without exception +One convention per category: types and constructors in `UpperCamelCase`, +functions and fields in `lowerCamelCase`, module names mirror their file +path. Smart constructors are named `mkX` (3.3); unsafe or internal-only +constructors are prefixed `Unsafe` or kept unexported entirely. A reader +should be able to predict a name's category from its case alone, without +opening the module that defines it. + +### 4.9 Laziness is exploited on purpose; strictness is added on evidence +Rely on laziness deliberately for what it's actually good at — infinite +or self-referential structures, short-circuiting, decoupling production +from consumption — and treat an unexplained space leak as a bug to +diagnose, not a tax to accept. Add strictness annotations (`!` on +fields, `seq`, `foldl'` over `foldl`, `BangPatterns`) only where +profiling, not intuition, has shown a real leak or a real cost. +Premature strictness is the same unjustified complexity 0.7 already +prohibits, just approached from the performance direction instead of the +abstraction direction. + +### 4.10 Recursion over unbounded input is stack-safe — strictly enforced +Beyond 2.4's bound on adversarial nesting, any function that folds or +recurses over a structure whose size is driven by ordinary, legitimate +input (a large file, a long list) must not blow the stack. Use +`foldl'`/`foldMap'`-style strict folds instead of `foldr`/lazy `foldl` +for large accumulations, prefer combinators with known stack behavior +(4.1's table) over bespoke recursion, and make any genuinely necessary +hand-written recursive function tail-recursive with a strict +accumulator. A function that works in tests on small fixtures but is +never checked against a realistically large input is not verified to be +stack-safe — add a large-input case specifically to catch this (5.4). + +### 4.11 Known space-leak patterns are avoided by construction +The recurring, well-documented sources of Haskell space leaks are treated +as defects, not idiosyncrasies to tolerate: unbounded thunk buildup from +lazy accumulation (`foldl` on a large list, a lazy `State`/`Writer` +accumulator never forced), quadratic-blowup string/list concatenation +(repeated `(++)` instead of a builder or `Data.Text.Builder`/`Seq`), +holding onto the head of a list or a whole lazy `ByteString`/`Text` far +longer than needed because one small part of it is still referenced, and +unbounded lazy I/O. Each is a specific, nameable pattern (not a vague +"Haskell can leak" caveat), and each has a specific, standard fix — apply +the fix at the point the pattern is introduced, not after a production +memory graph shows it. + +--- + +## Part 5 — Verification and Enforcement + +### 5.1 Mandatory compiler flags +``` +-Wall -Wcompat -Werror +-Wincomplete-uni-patterns -Wincomplete-record-updates +-Wmissing-export-lists -Wunused-imports -Wunused-top-binds +-Wunused-local-binds -Wunused-matches +-Wredundant-constraints -Wpartial-fields -Widentities +``` + +### 5.2 Banned outright (lint-enforced) +`head`, `tail`, `fromJust`, `(!!)`, `error`, `undefined`, +`unsafePerformIO`, `Debug.Trace.*` in committed code, partial record +field accessors, `OverlappingInstances`/`IncoherentInstances` without +explicit written justification, and any unreachable code flagged by +`weeder` (1.11). + +### 5.3 Formatting is enforced, not a matter of taste +`ormolu` or `fourmolu` runs as a CI check alongside `hlint`, so a diff is +never mixed style-only noise and substantive change, and no two +contributors — human or AI — drift into different house styles over +time. + +### 5.4 Tests are exhaustive, including outliers — strictly enforced +A test suite that only exercises the happy path is incomplete by +definition, not merely light. For every function with a bounded or +partially-bounded domain, tests cover: the empty/zero/minimum case, the +single-element case, the maximum or a realistically large case (4.10), +known adjacent-to-boundary values (off-by-one candidates), malformed or +adversarial input for anything crossing a trust boundary (2.4), and, via +property-based testing, a generator wide enough that these outliers are +sampled rather than hand-picked and potentially forgotten. "It passes on +the examples I thought of" is not exhaustive; "the generator's shrinker +was pointed at this class of input and found nothing" is closer to what +this rule requires. + +### 5.5 Every stated invariant needs a property test in the same change that introduces it +A Haddock claim ("output is always escaped," "result is always +rectangular," "instance obeys the Monoid laws") ships with a +QuickCheck/Hedgehog property checking exactly that claim, in the same +diff — not as an afterthought. + +### 5.6 Benchmarking is part of the test suite, not a side activity +Every module on a path that matters for real-world input size (parsers, +renderers, anything called per-request) has a `criterion` (or +equivalent) benchmark checked in alongside its tests, run in CI with +regression thresholds, not just on demand before a release. This is the +evidence 4.9 requires before adding a strictness annotation, and the +mechanism that makes "performance is addressed deliberately, with +evidence" (the precedence rule at the top of this document) an actual +practice rather than a stated intention. A change that regresses a +benchmark beyond its threshold is treated the same as a failing test. + +### 5.7 Known bugs from comparable prior art are pre-empted, not rediscovered +Before implementing a component that has established prior art (a DOCX +parser, a Markdown renderer, an HTML escaper, a diff algorithm), the +issue tracker and changelog of at least one or two comparable existing +projects are reviewed for the specific bug classes they've hit historically +— parser desync on a particular malformed input, an escaping bypass, a +resource-exhaustion vector, an off-by-one in a boundary case. Each +applicable bug class gets a named regression test *written before or +alongside the first implementation*, not added reactively after the same +bug is independently rediscovered in this codebase. This research is +recorded (a short note or linked issue) so the next contributor can see +which known failure modes were already checked, rather than re-doing the +same archaeology or, worse, assuming it was never done. + +### 5.8 Two-pass self-audit for AI-authored code +After writing a function, re-read its own Haddock claim and check, line +by line, whether the implementation actually establishes it. Do not +trust a comment written in the same pass that wrote the code. State +explicitly if a claimed invariant is *not* fully established, rather +than leaving an inaccurate guarantee in place. + +### 5.9 Deviations are recorded, not silent +If a rule in this document is knowingly not followed for a specific, +justified reason (performance-critical hot path, a library's API forces +an escape hatch), record it as a short Architecture Decision Record next +to the code — what rule was relaxed, why, and what was tried first — so +it reads as a deliberate, reviewed exception, not an oversight. + + +--- + +## Part 6 — Before the Project Starts: Setup Checklist + +Put this in place *before* the first feature module is written. + +- [ ] `cabal`/`hpack` project skeleton with the Part 5 GHC flags set as a + shared `common warnings` stanza, applied to every component + (library, executable, tests) — not opt-in per module. +- [ ] `hlint` configured with the Part 5 ban-list as errors, not + suggestions, wired into CI. +- [ ] Module skeleton drawn along the hexagonal boundary of 2.6 up + front: a `Core`/`Domain` area (pure, IR-centered) and an + `Adapters` area (parsers, renderers, storage, network) — so the + dependency direction is structural from commit one, not something + to "clean up later." +- [ ] A single canonical IR module identified and agreed before any + format-specific or adapter-specific module is started (2.1). +- [ ] The closed-vocabulary error type (2.3) scaffolded before the first + failure case is needed, with the reachability discipline (1.5) + stated in its own Haddock. +- [ ] Test framework wired for both example-based (hspec) and + property-based (QuickCheck/Hedgehog) tests from the first + commit, with the rule from 2.9 (tests exercise the pure core + directly) established as the default shape, and an explicit + outlier/boundary-case checklist template for new test modules (5.4). +- [ ] Benchmark harness (`criterion` or equivalent) wired into CI with + regression thresholds before the first performance-relevant module + is merged, not added retroactively once something feels slow (5.6). +- [ ] For each planned component with established prior art, the known + bug classes from at least one or two comparable projects' issue + trackers reviewed and logged before implementation begins, with a + named regression test planned for each applicable one (5.7). +- [ ] This document itself checked into the repository (e.g. + `ENGINEERING_STANDARD.md`) and referenced from the project's + `README` and from any AI-agent configuration file (`CLAUDE.md`, + `.cursorrules`, or equivalent), so it is loaded as context + automatically rather than depended on being remembered. + +--- + +## Pre-submission Checklist + +Before presenting any Haskell code written or edited under this +standard, confirm each of the following, explicitly: + +- [ ] Single responsibility per module; no "and" needed to describe it (0.1) +- [ ] Extension axis for this change identified as closed-sum or + Handle/typeclass, and consistent with existing choice (0.2, 2.7) +- [ ] Any new typeclass instance obeys its class's laws (0.3) +- [ ] Typeclass/Handle constraints are the narrowest that suffice (0.4, 0.10) +- [ ] New effectful dependency passed as a Handle or mtl-style + constraint, not imported and called directly (0.5, 3.9) +- [ ] No duplicated *invariant logic*; deliberate, justified duplication + of unrelated-but-similar code left alone (0.6) +- [ ] No speculative generality — the mechanism added matches a real, + current requirement (0.7) +- [ ] No structure reached through more than one level deep (0.8) +- [ ] No partial functions; every failure path is typed (1.1) +- [ ] Illegal states are unrepresentable, not just checked (1.2, 3.1) +- [ ] Cross-field invariants enforced once, at construction, via an + unexported constructor (1.3, 3.3) +- [ ] Closed domains are sum types, not strings (1.4) +- [ ] Errors are structured and layered by pipeline stage (1.5, 2.3) +- [ ] `IO` confined to the edges; core logic pure and independently + testable (1.6, 2.9) +- [ ] Considered whether a newtype, phantom type, or GADT would close a + hole more cheaply than a runtime check (3.2, 3.4, 3.5) — and, if + an existential was used, justified why a closed sum couldn't (3.6) +- [ ] Single canonical IR respected if multiple formats are involved (2.1) +- [ ] Recursive structures have an explicit depth/size bound, applied + uniformly across every stage capable of producing the nesting (2.4) +- [ ] Module exports only what's safe to export (2.5) +- [ ] No hand-rolled recursion where a named combinator applies (4.1) +- [ ] Known algorithms implemented and cited by name, not reinvented (4.2) +- [ ] Every function is one lemma, ~15–20 lines or fewer (4.5) +- [ ] Every non-trivial comment states an invariant, not a procedure (4.6) +- [ ] A named algorithm's proven library implementation used in + preference to a from-scratch one, where a good one exists (4.7) +- [ ] Naming follows the standard convention for its category (4.8) +- [ ] Any new strictness annotation is backed by profiling evidence, not + intuition (4.9) +- [ ] No new mutable local state where pure recursion/record-update would + do (1.9) +- [ ] New module placed by domain, not dropped into a `Utils`/`Common` + catch-all (2.10) +- [ ] Any new dependency is deliberate, well-maintained, and not + duplicating an existing one (2.11) +- [ ] `type` alias not used where a `newtype` boundary was actually + needed (3.12) +- [ ] `Applicative` used instead of `Monad` where the effects are + genuinely independent (3.13) +- [ ] Public boundary functions use concrete types; polymorphism kept + internal to where it earns its constraints (3.14) +- [ ] No dead code, no `undefined`/stub placeholders merged (1.11, 5.2) +- [ ] Error messages name the specific thing and location that failed; + errors live in their own dedicated module (2.15) +- [ ] Any function over unbounded legitimate input is checked + tail-recursive/strict-accumulator and tested on a large input (4.10) +- [ ] Checked against the named space-leak patterns — no `foldl` on a + large structure, no repeated `(++)`, nothing holding a large + structure alive longer than needed (4.11) +- [ ] New tests cover the boundary/empty/maximum/adversarial cases, not + only the happy path (5.4) +- [ ] A benchmark exists and is checked in for any change on a + performance-relevant path (5.6) +- [ ] For new prior-art-backed components, comparable projects' known + bug classes were checked and pre-empted with a named test (5.7) +- [ ] Every claimed invariant has a matching property test (5.5) +- [ ] Self-audited: implementation re-checked against its own stated + claim, in a separate pass (5.8) +- [ ] Any knowing deviation from this document recorded as a short ADR, + not left silent (5.9) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +BSD 3-Clause License + +Copyright (c) 2026, Sabrinathan Nair +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,249 @@ +# figment + +Layered configuration for Haskell, after Rust's +[`figment`](https://docs.rs/figment): combine files (JSON, TOML, YAML), +environment variables, command-line arguments and Haskell values; select +profiles; decode into your own types. Every value remembers where it came +from, so when something is wrong you get **every** problem at once, each +pointing at the key, the name you would actually type (`APP_PORT`, +`--port`), the file, and the line and column: + +```text +4 configuration errors: + +error: missing field `name` + --> key `name` + = hint: no source sets it; it can be set as `name` in TOML source string, or `APP_NAME` in environment variables (prefix APP_) + +error: unknown field `hots` + --> key `db.hots` in TOML source string at line 4, column 8 + = hint: did you mean `host`? + +error: invalid value: found integer 70000, expected an integer in the range 0..65535 + --> key `db.port` in TOML source string at line 3, column 8 + +error: unknown variant `verbose`, expected one of `Debug`, `Info` + --> key `level` (`APP_LEVEL`) in environment variables (prefix APP_) +``` + +(That exact output is pinned by a golden test.) + +## Quick start + +```haskell +{-# LANGUAGE DeriveAnyClass, DeriveGeneric, DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings, TypeApplications #-} + +import Data.Aeson ((.=)) +import qualified Data.Aeson as Aeson +import Data.Function ((&)) +import Data.Text (Text) +import GHC.Generics (Generic) + +import qualified Figment as F + +data Config = Config + { name :: Text + , port :: Int + , debug :: Bool + } + deriving stock (Show, Generic) + deriving anyclass (F.FromConfig) + +figment :: F.Figment +figment = + F.new + & F.merge (F.defaults (Aeson.object ["port" .= (8080 :: Int), "debug" .= False])) + & F.merge (F.file F.toml "App.toml") -- optional; searched for upwards + & F.merge (F.prefixed "APP_") -- APP_PORT=9000, APP_DEBUG=true + +main :: IO () +main = F.loadExtractOrThrow @Config figment >>= print +``` + +Import `Figment` qualified: it exports `merge`, `join` and `from`. The +README examples are compiled and run by the test suite. + +**New to figment?** Start with the tutorial, +[`Figment.Tutorial`](https://hackage.haskell.org/package/figment/docs/Figment-Tutorial.html): +sixteen short sections covering layering, environment variables, the +command line, profiles, errors, decoding, provenance, partial +configurations, library patterns, custom providers and testing. It also +has a cheat sheet for Rust figment users and a guide for upgrading from +0.1. + +## Concepts + +**Providers** produce configuration, one dictionary per **profile**. A +**`Figment`** is a pure description: an ordered list of providers, each +combined with one of four strategies (the same as Rust figment): + +| strategy | on a conflicting key | arrays | +|-----------|----------------------|-------------| +| `merge` | incoming value wins | replaced | +| `join` | existing value wins | kept | +| `admerge` | incoming value wins | concatenated| +| `adjoin` | existing value wins | concatenated| + +Dictionaries always merge key by key. Building a figment does no IO. +`load` runs every provider, collects **every** failure (an unreadable +file and a syntax error elsewhere are reported together), and combines +the results. `Figment` is a lawful `Monoid`, so a library can publish its +defaults as a `Figment` and an application can append overrides with +`<>`. (The value-level merge is *not* associative, so values have no +`Semigroup`; the laws are property-tested.) + +**Profiles.** On extraction, the `Default` profile is merged with the +selected profile, and the `Global` profile is merged over both. Select +with `F.select "prod"`, or read the choice from the environment with +`F.profileFromEnv "APP_PROFILE" F.Default`. With `F.nested`, a file's +top-level keys are profiles: + +```toml +[default] +workers = 4 +[prod] +workers = 32 +``` + +## Providers + +| provider | notes | +|---|---| +| `F.file fmt path` | optional; a relative path is searched for in the working directory and its parents. `F.fileExact` does not search; `F.required` makes absence an error; `F.nested` maps top-level keys to profiles | +| `F.fromText fmt text` | configuration held in memory | +| formats `F.json`, `F.toml`, `F.yaml` | each parser enforces depth and size limits *while parsing*, rejects duplicate keys, and (TOML, YAML) records line and column for every value | +| `F.prefixed "APP_"` | environment variables, Rust semantics: no splitting unless `Env.split "__"`; values are typed (`8080`, `true`, `[1, 2]`, `{a = 1}`) while keeping the original text (so a `Text` field gets `007`, not `7`); conflicts are errors; see `Figment.Provider.Env` for `only`, `ignore`, `mapKeys`, `global`, ... | +| `F.cli args` | `--key=value`, `--flag`, `--no-flag`, `--db.port=1`, `--` ends options; see `Figment.Provider.Cli` | +| `F.defaults x`, `F.globals x`, `F.keyed "db.port" x` | any `ToJSON` value; errors point at the Haskell source line | +| a `Figment` | figments nest, keeping the provenance of every inner value | +| your own | implement the three-method `Provider` class | + +Format details: TOML dates and times arrive as ISO 8601 strings and +decode straight into `Day`, `LocalTime`, `ZonedTime`, `UTCTime`; `inf` +and `nan` are kept as non-finite numbers. YAML uses the 1.2 core schema +(`no` and `on` stay strings, so there is no "Norway problem"), supports +anchors, aliases and merge keys (`<<`), and charges alias expansion to +the node limit, which defeats "billion laughs". Invalid UTF-8 is an +error, never silently replaced. + +## Decoding + +`FromConfig` is figment's own decoding class. It reads the value tree +directly, which is how errors know their source and position. Derive it +with `Generic`: + +* records are dictionaries; `Maybe` fields are optional; +* enums are strings, matched case-insensitively; unknown variants list + the valid ones; +* other sum types are externally tagged (`{ Circle = { radius = 1 } }`); +* newtypes unwrap and positional constructors are arrays. + +`genericDecoder defaultOptions { fieldLabelModifier = snakeCase, +rejectUnknownFields = True }` changes the key names and reports unknown +keys with suggestions. Hand-written decoders use an **accumulating** +applicative (`field`, `optionalField`, `fieldOr`, `validate`, ...). It +deliberately has no `Monad` instance, so independent errors are never +hidden; `andThen` gives you sequencing when you need it. + +Strict by default: a string is not a number. `F.extractLossy` accepts +`"8080"` for numbers and `"yes"` for booleans (Rust's `extract_lossy`). + +Magic types: `Tagged a` carries the value's provider, profile, position +and path. `RelativePath` resolves a path written in a file against +*that file's* directory. `ViaAeson a` reuses an existing `FromJSON` +instance, and aeson's error path is translated so it still points at +the right key and line. + +Queries on a loaded configuration: `findValue`, `contains`, +`findMetadata`, `extractAt` (Rust: `extract_inner`), `focus`, +`reselect`. + +## Partial configurations: no missing field, by construction + +Write the record once, parameterised by a functor: + +```haskell +data ServerF f = Server + { host :: F.Field f Text + , listen :: F.Field f Int + , workers :: F.Field f Int + } + deriving stock (Generic) + +instance F.Partial ServerF + +type Server = ServerF F.Identity -- ordinary fields: host :: Text + +serverDefaults :: ServerF Maybe +serverDefaults = (F.emptyPartial @ServerF) {listen = Just 8080, workers = Just 4} + +-- given a loaded configuration `loaded :: F.Loaded`, every missing field +-- is reported at once, each with the env var, CLI flag, or file key +-- that would have set it: +-- +-- F.extractPartial serverDefaults loaded :: Either F.ConfigErrors Server +``` + +`F.extractTotal` takes *total* defaults (`ServerF Identity`). Its type +guarantees that a missing-field error cannot happen; only type errors in +the values that are present remain. Nested partial records are +supported, and `overlay`, `complete` and `total` are available for your +own layering. + +## Safety + +* **Limits** (`F.defaultLimits`: depth 64, one million values; override + with `F.withLimits`) are enforced inside every parser, so a hostile + `[[[[...` megabyte is rejected at depth 65 without being built. +* No exception escapes `load`: I/O and parse failures are errors, and a + synchronous exception thrown by a third-party provider becomes an + `IoError` (asynchronous exceptions are re-thrown, as they must be). +* `ConfigErrors` is an `Exception` whose `displayException` is the + rendered report. + +## Testing your configuration + +`Figment.Jail.withJail` runs a test in a fresh temporary working +directory with a snapshot of the environment, restores both afterwards, +and serialises jails process-wide, so jailed tests are safe under a +parallel runner. `Env.fromList` gives an environment provider fixed +variables, with no global state at all. + +## Compared with Rust figment + +Feature parity: providers, the four strategies, profiles (default, +global, nested, selection), metadata with interpolated key names and the +code location where each provider was added, `Tagged`, `RelativePath`, +lossy extraction, `extract_inner`/`focus`/`find_value`/`contains`, a +test jail, and figments as providers. + +Beyond it: + +* all errors are reported at once, not one per run; +* TOML and YAML errors and values carry line and column; +* missing-field hints list the exact env var, flag and key to set; +* unknown fields come with "did you mean" suggestions; +* `extractTotal` guarantees, through its type, that no field is missing; +* resource limits are enforced inside the parsers, YAML alias bombs are + defeated, and the YAML 1.2 core schema avoids the Norway problem; +* conflicting env vars or flags are errors, never silently resolved; +* the builder is a lawful monoid with property-tested laws. + +## Building + +```bash +cabal build all +cabal test +bash scripts/check-compile-fail.sh # the compile-time guarantees +cabal bench +``` + +Supported compilers: GHC 9.10 and 9.12. + +Version 0.2.0.0 is a breaking redesign of 0.1; see the changelog. The +source distribution also contains the design record: `ADRs/` (decisions +016 onwards apply to 0.2) and `docs/audit-remediation.md` (each problem +found in 0.1, how it was fixed, and the test that pins it). + +License: BSD-3-Clause. diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -0,0 +1,68 @@ +-- | Benchmarks for the per-load path: parsing each format, combining +-- layers, and decoding (ADR 011). +module Main (main) where + +import Control.DeepSeq (NFData, rnf) +import Criterion.Main +import Data.Function ((&)) +import qualified Data.Map.Strict as Map +import qualified Data.Text as Text +import Data.Text (Text) +import GHC.Generics (Generic) + +import qualified Figment as F + +data Service = Service {name :: Text, port :: Int, replicas :: Int, tags :: [Text]} + deriving stock (Generic) + deriving anyclass (F.FromConfig) + +instance NFData Service where + -- fields are strict enough for a benchmark; force them explicitly + rnf (Service n p r ts) = rnf n `seq` rnf p `seq` rnf r `seq` rnf ts + +-- | A config with @n@ services, in each format. +jsonDoc, tomlDoc, yamlDoc :: Int -> Text +jsonDoc n = "{" <> Text.intercalate "," [svc i | i <- [1 .. n]] <> "}" + where + svc i = "\"s" <> t i <> "\":{\"name\":\"svc" <> t i <> "\",\"port\":" <> t (8000 + i) + <> ",\"replicas\":3,\"tags\":[\"a\",\"b\",\"c\"]}" +tomlDoc n = Text.concat [svc i | i <- [1 .. n]] + where + svc i = "[s" <> t i <> "]\nname = \"svc" <> t i <> "\"\nport = " <> t (8000 + i) + <> "\nreplicas = 3\ntags = [\"a\", \"b\", \"c\"]\n" +yamlDoc n = Text.concat [svc i | i <- [1 .. n]] + where + svc i = "s" <> t i <> ":\n name: svc" <> t i <> "\n port: " <> t (8000 + i) + <> "\n replicas: 3\n tags: [a, b, c]\n" + +t :: Int -> Text +t = Text.pack . show + +-- | Load and decode everything, forcing the result. +loadDecode :: F.Figment -> IO Int +loadDecode fig = do + r <- F.loadExtract fig :: IO (Either F.ConfigErrors (Map.Map Text Service)) + case r of + Left es -> fail (Text.unpack (F.renderErrors es)) + Right m -> pure $! (rnf m `seq` Map.size m) + +main :: IO () +main = + defaultMain + [ bgroup "load+decode 200 services" + [ bench "json" $ nfIO (decodeFrom (F.fromText F.json (jsonDoc 200))) + , bench "toml" $ nfIO (decodeFrom (F.fromText F.toml (tomlDoc 200))) + , bench "yaml" $ nfIO (decodeFrom (F.fromText F.yaml (yamlDoc 200))) + ] + , bgroup "layers" + [ bench "3 layers x 200 services" $ nfIO $ decodeLayers + ( F.new + & F.merge (F.fromText F.json (jsonDoc 200)) + & F.join (F.fromText F.toml (tomlDoc 200)) + & F.admerge (F.fromText F.yaml (yamlDoc 200)) + ) + ] + ] + where + decodeFrom d = loadDecode (F.from d) + decodeLayers = loadDecode diff --git a/docs/audit-remediation.md b/docs/audit-remediation.md new file mode 100644 --- /dev/null +++ b/docs/audit-remediation.md @@ -0,0 +1,66 @@ +# Audit remediation (0.1.0.0 → 0.2.0.0) + +Each finding from the forensic audit, what changed, and the test that +pins it. Test names are tasty patterns (`cabal test --test-options='-p "..."'`). + +## Critical + +| # | Finding | Resolution | Pinned by | +|---|---|---|---| +| C1 | `EnvPrefixed`/`CliArgs` stored `{}` for every value | Shared, tested `Internal.Nest`; values parsed and kept | `REGRESSION C1/H1` (env), `REGRESSION C1` (cli) | +| C2 | `composeChecked`'s type list was not tied to the layers | Removed. Replaced by HKD partial configs with a real guarantee (ADR 021) | `partial (HKD)`; `test/compile-fail/*` | +| C3 | Decode errors reported the first leaf's path | Native decoder; exact paths; all errors accumulate (ADR 018) | `REGRESSION C3`, `all errors are reported at once` | +| C4 | Profiles were dead code | Default → selected → global; `select`; nested files; hints (ADR 023) | `default profile, then selected, then global`, `nested files` | +| C5 | `readFile` threw; TOML caught async exceptions | `IOException` handled per provider; safety net in `load` re-throws async exceptions | `a missing required file`, `an exception escaping a provider becomes an error`, fuzz properties | +| C6 | Silent data loss: TOML dates→null, inf/nan garbage, UTF-8 replaced, duplicate keys | Dates are ISO strings decoding to `Data.Time`; non-finite numbers kept; strict UTF-8; duplicates are errors in JSON, YAML and TOML; env/CLI conflicts are errors | `dates and times`, `inf and nan`, `invalid UTF-8`, `duplicate keys`, `conflicts are reported` | + +## High + +| # | Finding | Resolution | Pinned by | +|---|---|---|---| +| H1 | Env/CLI values were all strings | TOML-like value parsing, original text kept in `tagRaw` (`007` stays `007` for `Text`) | `REGRESSION C1/H1`, `structured values` | +| H2 | Always split on `_`; underscored fields unreachable | No split by default; opt-in `split "__"` (ADR 019) | `REGRESSION H2` | +| H3 | README example did not compile | README examples are compiled and run by the test suite | `README` group | +| H4 | "No Semigroup" argument misplaced | `Figment` is a lawful `Monoid` (free monoid on steps); `Value` has none (non-associativity demonstrated) | `Figment is a monoid`, `not associative in general`, `test/compile-fail/NoValueSemigroup.hs` | +| H5 | Container tags lost; concat corrupted stored paths | Tags follow Rust (join keeps left, merge keeps right); paths are positional, never stored, so they cannot go stale | `container tags follow Rust`, `duality` | +| H6 | Depth guard ran after the parsers | `Limits` enforced inside every parser; alias expansion is charged (ADR 017) | `adversarial` group | +| H7 | `UnsafeDepth` exported through an exposed module | `Limits` has a hidden constructor; internals are `other-modules` | `custom limits are validated` | +| H8 | One error at a time; no `Exception`; golden tests pinned `show`; dead constructors | `ConfigErrors` (non-empty, `Semigroup`, `Exception`), renderer pinned by goldens, every `ErrorKind` constructor produced (ADR 025) | `errors (golden)` | +| H9 | Safe Haskell claims did not match the code | Pragmas removed (ADR 022) | — | + +## Medium + +| # | Finding | Resolution | +|---|---|---| +| M1 | `Path` was a list of text keys (index/key confusion, O(n²) snoc) | `Seq Segment` with `Key`/`Index`; `renderPath`/`parsePath` round-trip | +| M2 | Arrays as lists | `Vector` | +| M3 | Key order and number kinds | Keys are sorted (Rust's default ordering); numbers are exact `Scientific`, plus explicit non-finite values; integral decoders accept integral values (`1.0` included), never truncate, and never wrap | +| M4 | Lazy fields | All value, tag and error fields strict | +| M5 | Top level not required to be a dictionary | Enforced with a precise error | +| M6 | Null semantics implicit | Documented in `Figment.Merge` (Rust semantics: `null` is a value) | +| M7 | Copy-pasted `buildRaw` | One `Internal.Nest` | +| M8 | Lazy IO, stringly `SourceId`, no call site | Strict reads; structured `Source`; `HasCallStack` site per provider; interpolater | +| M9 | CLI doc/behaviour mismatch, no flags | Revised rule (ADR 020) | +| M10 | Dead type-level code | Removed with `Figment.Check` | +| M11 | Global CPP/DeriveAnyClass, heavy tool dep, dishonest bounds, stale freeze | GHC2021 with explicit strategies; no CPP; no `build-tool-depends`; bounds equal tested compilers; freeze removed (ADR 016) | +| M12 | CI skipped compile-fail and benchmarks; junk files | Both are CI steps; `failure` removed; study file renamed | + +## Documentation drift + +Every ADR that 0.2 changes now carries a status note at the top, and +ADRs 016–025 record the new decisions. The README describes only +behaviour that the tests exercise. + +## Not done (and why) + +- **hlint / formatter in CI.** No hlint binary exists for the platform + this release was prepared on, so a lint gate could not be run locally + before adding it. Recommended next step: add a `haskell-actions/hlint-run` + job and fourmolu once the code has been formatted once. +- **GHC 9.12.4.** Declared in `tested-with` and run by CI; the release + was verified locally on 9.10.3 only. +- **Positions for JSON.** aeson's token stream does not expose offsets. + JSON errors carry path and source, but no line or column. +- **Insertion-ordered dictionaries.** Keys are sorted, as in Rust + figment's default. A `preserve_order` equivalent can be added later + without breaking the API. diff --git a/figment.cabal b/figment.cabal new file mode 100644 --- /dev/null +++ b/figment.cabal @@ -0,0 +1,156 @@ +cabal-version: 3.0 +name: figment +version: 0.2.0.0 +synopsis: Layered configuration with provenance, profiles and complete error reports +description: + A Haskell take on Rust's figment. Combine configuration from files + (JSON, TOML, YAML), environment variables, command-line arguments and + Haskell values; select profiles; and decode into your own types. + . + Every value remembers where it came from, so all problems are reported + together, each with the key, the name you would type to fix it + (@APP_PORT@, @--port@), the file, and the line and column. Higher-kinded + partial configurations give a compile-time guarantee that no field is + missing. Parsers enforce resource limits while parsing. + . + Start with "Figment.Tutorial"; the API is in "Figment". +license: BSD-3-Clause +license-file: LICENSE +author: Sabrinathan Nair +maintainer: bombay.boyz@hotmail.com +copyright: (c) 2026 Bombay-Boyz +homepage: https://github.com/Bombay-Boyz/Figment +bug-reports: https://github.com/Bombay-Boyz/Figment/issues +category: Configuration +build-type: Simple +tested-with: GHC == 9.10.3 || == 9.12.4 +extra-doc-files: + README.md + CHANGELOG.md + ENGINEERING_STANDARD.md + ADRs/*.md + docs/*.md +extra-source-files: + test/golden/*.txt + test/compile-fail/*.hs + scripts/check-compile-fail.sh + +source-repository head + type: git + location: https://github.com/Bombay-Boyz/Figment + +flag dev + description: Enable -Werror for local development + default: False + manual: True + +common shared + default-language: GHC2021 + default-extensions: + DerivingStrategies + DeriveAnyClass + LambdaCase + OverloadedStrings + ghc-options: + -Wall -Wcompat + -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wmissing-export-lists -Wpartial-fields -Wredundant-constraints + -Widentities -Wunused-packages + if flag(dev) + ghc-options: -Werror + +library + import: shared + hs-source-dirs: src + exposed-modules: + Figment + Figment.Aeson + Figment.Core + Figment.Decode + Figment.Error + Figment.Extract + Figment.Jail + Figment.Limits + Figment.Merge + Figment.Metadata + Figment.Partial + Figment.Path + Figment.Profile + Figment.Provider.Cli + Figment.Provider.Env + Figment.Provider.Format + Figment.Provider.Json + Figment.Provider.Toml + Figment.Provider.Yaml + Figment.Tutorial + Figment.Value + other-modules: + Figment.Internal.Budget + Figment.Internal.Nest + Figment.Internal.ValueParser + build-depends: + base >= 4.20 && < 4.22 + , aeson >= 2.2 && < 2.3 + , bytestring >= 0.11 && < 0.13 + , conduit >= 1.3 && < 1.4 + , containers >= 0.6.7 && < 0.8 + , deepseq >= 1.4.8 && < 1.6 + , directory >= 1.3 && < 1.4 + , filepath >= 1.4 && < 1.6 + , libyaml >= 0.1.2 && < 0.2 + , scientific >= 0.3.7 && < 0.4 + , temporary >= 1.3 && < 1.4 + , text >= 2.0.2 && < 2.2 + , time >= 1.9 && < 1.15 + , toml-parser >= 2.0 && < 2.1 + , vector >= 0.13 && < 0.14 + +test-suite figment-test + import: shared + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + other-modules: + Figment.Test.Arbitrary + Figment.Test.MergeLaws + Figment.Test.Figment + Figment.Test.Decode + Figment.Test.Partial + Figment.Test.Providers + Figment.Test.Env + Figment.Test.Cli + Figment.Test.Errors + Figment.Test.Adversarial + Figment.Test.Readme + Figment.Test.Tutorial + build-depends: + base + , figment + , aeson + , bytestring + , containers + , deepseq + , filepath + , tasty >= 1.4 && < 1.6 + , tasty-golden >= 2.3 && < 2.4 + , tasty-hunit >= 0.10 && < 0.11 + , tasty-quickcheck >= 0.10 && < 0.12 + , QuickCheck >= 2.14 && < 2.17 + , text + , time + , vector + ghc-options: -threaded -rtsopts "-with-rtsopts=-N" + +benchmark figment-bench + import: shared + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: Bench.hs + build-depends: + base + , figment + , containers + , criterion >= 1.6 && < 1.7 + , deepseq + , text + ghc-options: -threaded -rtsopts diff --git a/scripts/check-compile-fail.sh b/scripts/check-compile-fail.sh new file mode 100644 --- /dev/null +++ b/scripts/check-compile-fail.sh @@ -0,0 +1,33 @@ +#!/usr/bin/env bash +# Compile-time guarantees, checked mechanically (run from the package +# root after `cabal build`). CABAL may be overridden (CI passes its own). +set -euo pipefail +CABAL=${CABAL:-cabal} + +typecheck() { + $CABAL exec -v0 -- ghc -fno-code -package figment -package text "$1" 2>&1 +} + +expect_failure() { + local fixture="$1" expected="$2" out + if out=$(typecheck "$fixture"); then + echo "FAIL: $fixture compiled, but must not"; exit 1 + fi + if ! grep -q -- "$expected" <<<"$out"; then + echo "FAIL: $fixture failed without the expected message '$expected':"; echo "$out"; exit 1 + fi + echo "ok: $fixture is rejected ($expected)" +} + +expect_success() { + local fixture="$1" out + if ! out=$(typecheck "$fixture"); then + echo "FAIL: $fixture must compile:"; echo "$out"; exit 1 + fi + echo "ok: $fixture compiles" +} + +expect_success test/compile-fail/Ok.hs +expect_failure test/compile-fail/EmptyType.hs "cannot derive FromConfig for an empty data type" +expect_failure test/compile-fail/PartialSum.hs "a Partial configuration must be a record with a single constructor" +expect_failure test/compile-fail/NoValueSemigroup.hs "No instance for .Semigroup Value" diff --git a/src/Figment.hs b/src/Figment.hs new file mode 100644 --- /dev/null +++ b/src/Figment.hs @@ -0,0 +1,187 @@ +-- | Layered configuration with provenance: a Haskell take on Rust's +-- figment. New here? Read "Figment.Tutorial" first. +-- +-- > import Data.Function ((&)) +-- > import qualified Figment as F +-- > import qualified Figment.Provider.Env as Env +-- > +-- > data Config = Config {name :: Text, port :: Int, debug :: Bool} +-- > deriving stock (Show, Generic) +-- > deriving anyclass (F.FromConfig) +-- > +-- > main :: IO () +-- > main = do +-- > cfg <- F.loadExtractOrThrow @Config $ +-- > F.new +-- > & F.merge (F.file F.toml "App.toml") +-- > & F.merge (F.prefixed "APP_" & Env.split "__") +-- > & F.merge (F.cli ["--port=9000"]) +-- > print cfg +-- +-- Every value remembers its source, and failures are reported all at +-- once, each with its key path, the provider-native name (@APP_PORT@, +-- @--port@), the file, and the line and column. +-- +-- This module re-exports the whole API. Import it qualified, because it +-- exports 'join', 'merge' and 'from'. Options for individual providers +-- live in "Figment.Provider.Env", "Figment.Provider.Cli" and +-- "Figment.Provider.Format". Test helpers are in "Figment.Jail". +module Figment + ( -- * Building a figment + Figment + , new + , from + , merge + , join + , adjoin + , admerge + , combine + , Order (..) + , select + , withLimits + , figmentSources + , Provider (..) + -- * Loading + , Loaded + , load + , loadedProfile + , loadedSources + , profiles + , selected + , reselect + , findValue + , contains + , findMetadata + , focus + -- * Extracting + , extract + , extractLossy + , extractAt + , extractWith + , loadExtract + , loadExtractOrThrow + -- * Partial (higher-kinded) configurations + , Field + , Partial (..) + , extractPartial + , extractPartialWith + , extractTotal + , extractTotalWith + , Identity (..) + -- * Decoding + , FromConfig (..) + , FromConfigKey (..) + , Decoder + , Result (..) + , DecodeContext (..) + , runDecoder + , decodeWith + , mkDecoder + , andThen + , withValue + , currentPath + , failWith + , validate + , field + , fieldWith + , optionalField + , fieldOr + , arrayOf + , dictOf + , textual + , boundedIntegral + , Options (..) + , defaultOptions + , snakeCase + , kebabCase + , genericDecoder + , Tagged (..) + , taggedMetadata + , RelativePath (..) + , relative + , ViaAeson (..) + , aesonDecoder + -- * Providers + -- ** Files and strings + , Format + , Data + , json + , toml + , yaml + , file + , fileExact + , fromText + , nested + , required + -- ** Environment variables (see "Figment.Provider.Env" for options) + , Env + , prefixed + -- ** Command-line arguments (see "Figment.Provider.Cli") + , Cli + , cli + , cliFromProcess + -- ** Haskell values + , Serialized + , defaults + , globals + , keyed + -- * Values + , Value (..) + , Node (..) + , Number (..) + , Dict + , Tag (..) + -- * Paths + , Path + , Segment (..) + , root + , keyPath + , parsePath + , renderPath + , (/.) + , (/#) + -- * Profiles + , Profile (Default, Global) + , profile + , profileName + , profileFromEnv + -- * Metadata + , Metadata (..) + , Source (..) + , Pos (..) + , named + -- * Errors + , ConfigError (..) + , ConfigErrors + , ErrorKind (..) + , errorList + , renderError + , renderErrors + -- * Limits + , Limits + , mkLimits + , defaultLimits + , maxDepth + , maxNodes + ) where + +import Data.Functor.Identity (Identity (..)) + +import Figment.Aeson +import Figment.Core +import Figment.Decode +import Figment.Error +import Figment.Extract +import Figment.Limits +import Figment.Merge +import Figment.Metadata +import Figment.Partial +import Figment.Path +import Figment.Profile +import Figment.Provider.Cli +import Figment.Provider.Env (Env, prefixed) +import Figment.Provider.Format +import Figment.Provider.Json +import Figment.Provider.Toml +import Figment.Provider.Yaml +import Figment.Value diff --git a/src/Figment/Aeson.hs b/src/Figment/Aeson.hs new file mode 100644 --- /dev/null +++ b/src/Figment/Aeson.hs @@ -0,0 +1,159 @@ +-- | Interoperability with aeson: reuse existing 'Data.Aeson.FromJSON' / 'Data.Aeson.ToJSON' +-- instances, and serialise Haskell values as a provider. +module Figment.Aeson + ( -- * Decoding via FromJSON + ViaAeson (..) + , aesonDecoder + -- * Conversion + , toAeson + , fromAeson + -- * The Serialized provider + , Serialized + , defaults + , globals + , keyed + , serializedIn + , serializedNamed + ) where + +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KeyMap +import qualified Data.Aeson.Types as AT +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Vector as Vector +import GHC.Stack (CallStack, HasCallStack, SrcLoc, callStack, getCallStack) + +import Figment.Core +import Figment.Decode +import Figment.Error +import Figment.Internal.Budget +import Figment.Limits +import Figment.Metadata +import Figment.Path +import Figment.Profile +import Figment.Value + +-- | Decode with an existing 'Data.Aeson.FromJSON' instance: +-- +-- > newtype Port = Port Int deriving newtype FromJSON +-- > deriving FromConfig via ViaAeson Port +-- +-- aeson's error path is translated into a figment t'Path', so the error +-- still points at the right key, file, line and column. +newtype ViaAeson a = ViaAeson {unViaAeson :: a} + +instance Aeson.FromJSON a => FromConfig (ViaAeson a) where + fromConfig = ViaAeson <$> aesonDecoder + missingValue = ViaAeson <$> Aeson.omittedField + +-- | A decoder from a 'Aeson.FromJSON' instance. +aesonDecoder :: Aeson.FromJSON a => Decoder a +aesonDecoder = mkDecoder $ \c v -> case AT.iparse Aeson.parseJSON (toAeson v) of + AT.ISuccess a -> Success a + AT.IError jpath msg -> + let rel = fromSegments (map seg jpath) + target = fromMaybe v (lookupPath rel v) + t = valueTag target + in Failure $ single + ConfigError + { errorKind = Message (Text.pack msg) + , errorPath = ctxPath c <> rel + , errorProfile = Just (fromMaybe (ctxProfile c) (tagProfile t)) + , errorMetadata = tagMeta t + , errorPos = tagPos t + , errorHints = [] + } + where + seg (AT.Key k) = Figment.Path.Key (Key.toText k) + seg (AT.Index i) = Figment.Path.Index i + +-- | Forget provenance and produce an aeson value. Non-finite numbers +-- (which JSON cannot represent) become strings. +toAeson :: Value -> Aeson.Value +toAeson (Value _ n) = case n of + Null -> Aeson.Null + Bool b -> Aeson.Bool b + Num (Finite s) -> Aeson.Number s + Num PosInfinity -> Aeson.String "inf" + Num NegInfinity -> Aeson.String "-inf" + Num NaN -> Aeson.String "nan" + String t -> Aeson.String t + Array xs -> Aeson.Array (fmap toAeson xs) + Dict d -> Aeson.Object (KeyMap.fromList [(Key.fromText k, toAeson x) | (k, x) <- Map.toList d]) + +-- | Convert an aeson value, enforcing limits. +fromAeson :: Limits -> Aeson.Value -> Either ConfigError Value +fromAeson lim = runBudget lim . go 1 root + where + go :: Int -> Path -> Aeson.Value -> Budget Value + go d p v = do + spend 1 p Nothing + case v of + Aeson.Null -> pure (mkValue Null) + Aeson.Bool b -> pure (mkValue (Bool b)) + Aeson.Number s -> pure (mkValue (Num (Finite s))) + Aeson.String t -> pure (mkValue (String t)) + Aeson.Array xs -> do + enterContainer d p Nothing + ys <- traverse (\(i, x) -> go (d + 1) (p /# i) x) (Vector.indexed xs) + pure (mkValue (Array ys)) + Aeson.Object o -> do + enterContainer d p Nothing + kvs <- traverse (\(k, x) -> let kt = Key.toText k in (,) kt <$> go (d + 1) (p /. kt) x) (KeyMap.toList o) + pure (mkValue (Dict (Map.fromList kvs))) + +-- | A provider serialising a Haskell value with its 'Aeson.ToJSON' +-- instance (Rust: @Serialized@). +data Serialized = Serialized + { serValue :: Aeson.Value + , serProfile :: Profile + , serKey :: Maybe Path + , serName :: Text + , serLoc :: Maybe SrcLoc + } + +-- | Values for the 'Default' profile. +defaults :: (HasCallStack, Aeson.ToJSON a) => a -> Serialized +defaults a = Serialized (Aeson.toJSON a) Default Nothing "serialized defaults" (here callStack) + +-- | Values for the 'Global' profile (override every profile). +globals :: (HasCallStack, Aeson.ToJSON a) => a -> Serialized +globals a = Serialized (Aeson.toJSON a) Global Nothing "serialized globals" (here callStack) + +-- | A single value at a dotted key path, e.g. @keyed "db.port" 5432@. +keyed :: (HasCallStack, Aeson.ToJSON a) => Text -> a -> Serialized +keyed k a = Serialized (Aeson.toJSON a) Default (Just (keyPath k)) ("serialized value for `" <> k <> "`") (here callStack) + +-- | Put the values in another profile. +serializedIn :: Profile -> Serialized -> Serialized +serializedIn p s = s {serProfile = p} + +-- | Rename the provider (shown in error messages). +serializedNamed :: Text -> Serialized -> Serialized +serializedNamed n s = s {serName = n} + +here :: CallStack -> Maybe SrcLoc +here cs = case getCallStack cs of + ((_, l) : _) -> Just l + [] -> Nothing + +instance Provider Serialized where + metadata s = (named (serName s)) {metaSource = CodeSource <$> serLoc s} + provide lim s = pure $ case fromAeson lim (serValue s) of + Left e -> Left (single e) + Right v -> case serKey s of + Just p -> Right (Map.singleton (serProfile s) (wrap (segments p) v)) + Nothing -> case valueNode v of + Dict d -> Right (Map.singleton (serProfile s) d) + n -> Left (single (configError (InvalidType (describe n) "a dictionary (serialize a record or a map, or use `keyed`)"))) + where + wrap [] v = case valueNode v of + Dict d -> d + _ -> Map.empty + wrap [Figment.Path.Key k] v = Map.singleton k v + wrap (Figment.Path.Key k : rest) v = Map.singleton k (mkValue (Dict (wrap rest v))) + wrap (Figment.Path.Index _ : rest) v = wrap rest v diff --git a/src/Figment/Core.hs b/src/Figment/Core.hs new file mode 100644 --- /dev/null +++ b/src/Figment/Core.hs @@ -0,0 +1,255 @@ +-- | Providers, figments, and loading. +-- +-- A t'Figment' is a pure /description/: an ordered sequence of providers, +-- each with a combination 'Order'. Building one performs no IO; 'load' +-- runs every provider, collects every failure, and combines the results. +-- +-- Unlike the value-level merge, sequencing figments is a lawful +-- 'Monoid' (it is the free monoid on steps), so library defaults and +-- application overrides compose with '<>'. +module Figment.Core + ( -- * Providers + Provider (..) + -- * Figments + , Figment + , new + , from + , merge + , join + , adjoin + , admerge + , combine + , select + , withLimits + , figmentLimits + , figmentSources + -- * Loading + , Loaded + , load + , loadedProfile + , loadedData + , loadedSources + , loadedLimits + , selected + , reselect + , profiles + , findValue + , contains + , findMetadata + , focus + ) where + +import Control.Exception (SomeAsyncException, SomeException (..), displayException, fromException, throwIO, try) +import Data.Foldable (toList) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe, isJust) +import Data.Monoid (Last (..)) +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq +import qualified Data.Text as Text +import GHC.Stack (HasCallStack, SrcLoc, callStack, getCallStack) + +import Figment.Error +import Figment.Limits +import Figment.Merge +import Figment.Metadata +import Figment.Path +import Figment.Profile +import Figment.Value + +-- | A source of configuration. +-- +-- Implementations return one dictionary per profile. Values may be left +-- untagged: 'load' fills in this provider's 'metadata' and the profile +-- for every value that has none. A provider that learns better metadata +-- while reading (e.g. the resolved path of a searched-for file) may tag +-- values itself; existing tags are never overwritten. +-- +-- 'provide' must enforce the given 'Limits' on any untrusted input and +-- should report failures as 'Left'. As a safety net, 'load' converts any +-- synchronous exception that escapes into an 'IoError'. +class Provider p where + metadata :: p -> Metadata + provide :: Limits -> p -> IO (Either ConfigErrors (Map Profile Dict)) + -- | A profile this provider asks to be selected, if any. + providerProfile :: p -> Maybe Profile + providerProfile _ = Nothing + +data Step = Step + { stepOrder :: !Order + , stepMeta :: !Metadata + , stepProfile :: !(Maybe Profile) + , stepRun :: Limits -> IO (Either ConfigErrors (Map Profile Dict)) + } + +-- | A configuration description. +data Figment = Figment + { figSteps :: !(Seq Step) + , figSelect :: !(Last Profile) + , figLimitsOpt :: !(Last Limits) + } + +-- | Steps concatenate; for 'select' and 'withLimits' the right-most +-- setting wins. Associative with identity 'new' by construction. +instance Semigroup Figment where + Figment a s l <> Figment b s' l' = Figment (a <> b) (s <> s') (l <> l') + +instance Monoid Figment where + mempty = new + +-- | The empty figment. +new :: Figment +new = Figment Seq.empty (Last Nothing) (Last Nothing) + +-- | A figment with a single provider. +from :: (HasCallStack, Provider p) => p -> Figment +from p = addStep Merge p new + +-- | Add a provider whose values override existing ones. +merge :: (HasCallStack, Provider p) => p -> Figment -> Figment +merge = addStep Merge + +-- | Add a provider whose values only fill gaps. +join :: (HasCallStack, Provider p) => p -> Figment -> Figment +join = addStep Join + +-- | Like 'join', but arrays are concatenated. +adjoin :: (HasCallStack, Provider p) => p -> Figment -> Figment +adjoin = addStep Adjoin + +-- | Like 'merge', but arrays are concatenated. +admerge :: (HasCallStack, Provider p) => p -> Figment -> Figment +admerge = addStep Admerge + +-- | Add a provider with an explicit order. +combine :: (HasCallStack, Provider p) => Order -> p -> Figment -> Figment +combine = addStep + +addStep :: (HasCallStack, Provider p) => Order -> p -> Figment -> Figment +addStep o p fig = fig {figSteps = figSteps fig Seq.|> step} + where + meta0 = metadata p + meta = case (metaAddedAt meta0, callerLoc) of + (Nothing, Just l) -> withAddedAt l meta0 + _ -> meta0 + step = Step o meta (providerProfile p) (\lim -> provide lim p) + +-- | The outermost call site outside this module (the user's @merge@). +callerLoc :: HasCallStack => Maybe SrcLoc +callerLoc = case reverse (getCallStack callStack) of + ((_, l) : _) -> Just l + [] -> Nothing + +-- | Select the profile to extract. An explicit selection always wins +-- over profile hints from providers. +select :: Profile -> Figment -> Figment +select p fig = fig {figSelect = Last (Just p)} + +-- | Override the parser limits for every provider in this figment. +withLimits :: Limits -> Figment -> Figment +withLimits l fig = fig {figLimitsOpt = Last (Just l)} + +-- | The parser limits in effect ('defaultLimits' unless overridden). +figmentLimits :: Figment -> Limits +figmentLimits = fromMaybe defaultLimits . getLast . figLimitsOpt + +-- | Metadata of every provider, in order. +figmentSources :: Figment -> [Metadata] +figmentSources = map stepMeta . toList . figSteps + +-- | A loaded configuration: every provider has been read and combined. +data Loaded = Loaded + { loadedProfile :: !Profile + -- ^ the selected profile + , loadedData :: !(Map Profile Dict) + -- ^ the combined data of every profile + , loadedSources :: ![Metadata] + -- ^ every provider, in order + , loadedLimits :: !Limits + -- ^ the limits the sources were read with + } + +-- | Run every provider, in order. Failures do not stop the load: all of +-- them are collected and reported together. +load :: Figment -> IO (Either ConfigErrors Loaded) +load fig = do + let lim = figmentLimits fig + steps = toList (figSteps fig) + results <- traverse (runStep lim) steps + let errs = [e | Left e <- results] + oks = [(s, d) | (s, Right d) <- zip steps results] + combined = foldl' (\acc (s, d) -> coalesceData (stepOrder s) acc (retagData (stepMeta s) d)) Map.empty oks + hinted = foldl' (\acc s -> maybe acc (coalesceProfile (stepOrder s) acc) (stepProfile s)) Default steps + chosen = fromMaybe hinted (getLast (figSelect fig)) + pure $ case errs of + (e : es) -> Left (foldl' (<>) e es) + [] -> Right (Loaded chosen combined (map stepMeta steps) lim) + +runStep :: Limits -> Step -> IO (Either ConfigErrors (Map Profile Dict)) +runStep lim s = do + r <- try (stepRun s lim) + case r of + Right (Left es) -> pure (Left (fmap' es)) + Right ok -> pure ok + Left (ex :: SomeException) + | isJust (fromException ex :: Maybe SomeAsyncException) -> throwIO ex + | otherwise -> + pure (Left (single (withMetadata (Just (stepMeta s)) (configError (IoError (Text.pack (bare ex))))))) + where + -- attach this step's metadata to errors that have none + fmap' es = case fromErrorList [maybe (e {errorMetadata = Just (stepMeta s)}) (const e) (errorMetadata e) | e <- errorList es] of + Just es' -> es' + Nothing -> es + +-- | The exception's message without the backtrace GHC >= 9.10 appends. +bare :: SomeException -> String +bare (SomeException e) = displayException e + +retagData :: Metadata -> Map Profile Dict -> Map Profile Dict +retagData m = Map.mapWithKey (\p d -> fmap (retag m p) d) + +instance Provider Figment where + metadata _ = named "Figment" + provide _ fig = fmap loadedData <$> load fig + providerProfile = getLast . figSelect + +-- | The configuration of the selected profile: 'Default', then the +-- selected profile, then 'Global', each merged over the previous. +selected :: Loaded -> Value +selected l = + let get p = Map.findWithDefault Map.empty p (loadedData l) + prof = loadedProfile l + base = get Default + withSel = if prof == Default || prof == Global then base else coalesceDict Merge base (get prof) + final = coalesceDict Merge withSel (get Global) + in Value untagged {tagProfile = Just prof} (Dict final) + +-- | Choose another profile without re-reading any source. +reselect :: Profile -> Loaded -> Loaded +reselect p l = l {loadedProfile = p} + +-- | Every profile with data. +profiles :: Loaded -> [Profile] +profiles = Map.keys . loadedData + +-- | The value at a path in the selected profile. +findValue :: Path -> Loaded -> Maybe Value +findValue p = lookupPath p . selected + +-- | Is there a value at this path in the selected profile? +contains :: Path -> Loaded -> Bool +contains p = isJust . findValue p + +-- | The provider that supplied the value at a path. +findMetadata :: Path -> Loaded -> Maybe Metadata +findMetadata p l = findValue p l >>= tagMeta . valueTag + +-- | Re-root every profile at the given key path (Rust: @focus@). +-- Profiles in which the path is absent or not a dictionary become empty. +focus :: Path -> Loaded -> Loaded +focus p l = l {loadedData = Map.mapMaybe sub (loadedData l)} + where + sub d = case lookupPath p (mkValue (Dict d)) of + Just (Value _ (Dict d')) -> Just d' + _ -> Nothing diff --git a/src/Figment/Decode.hs b/src/Figment/Decode.hs new file mode 100644 --- /dev/null +++ b/src/Figment/Decode.hs @@ -0,0 +1,722 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Decoding configuration values into Haskell types. +-- +-- t'Decoder' is an /accumulating/ applicative: independent failures (two +-- bad fields, a missing field and an out-of-range number, ...) are all +-- reported, each with its exact path, source, line and column. There is +-- deliberately no 'Monad' instance, because a monad must short-circuit; +-- use 'andThen' when a step genuinely depends on an earlier result. +module Figment.Decode + ( -- * Decoders + Decoder + , Result (..) + , DecodeContext (..) + , rootContext + , runDecoder + , decodeWith + , mkDecoder + , resultToEither + -- * The class + , FromConfig (..) + , FromConfigKey (..) + -- * Combinators + , andThen + , withValue + , currentPath + , failWith + , validate + , field + , fieldWith + , optionalField + , fieldOr + , arrayOf + , dictOf + , textual + , boundedIntegral + -- * Generic deriving + , Options (..) + , defaultOptions + , snakeCase + , kebabCase + , genericDecoder + , GDecode + -- * Magic types + , Tagged (..) + , taggedMetadata + , RelativePath (..) + , relative + -- * Internals shared with "Figment.Partial" + , missingFieldError + , suggest + ) where + +import Data.Char (isUpper, toLower) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Kind (Type) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Map.Strict (Map) +import qualified Data.Map.Lazy as LMap +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Proxy (Proxy (..)) +import Data.Scientific (Scientific) +import qualified Data.Scientific as Sci +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Time (Day, LocalTime, TimeOfDay, UTCTime, ZonedTime, zonedTimeToUTC) +import Data.Time.Format.ISO8601 (ISO8601, iso8601ParseM) +import Data.Vector (Vector) +import qualified Data.Vector as Vector +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.Generics +import GHC.TypeLits (ErrorMessage (..), TypeError) +import Numeric.Natural (Natural) +import System.FilePath (isAbsolute, takeDirectory, ()) + +import Figment.Error +import Figment.Internal.ValueParser (parseNumber) +import Figment.Metadata +import Figment.Path +import Figment.Profile +import Figment.Value + +------------------------------------------------------------------------ +-- Results and decoders + +-- | Success, or every failure found. +data Result a + = Failure !ConfigErrors + | Success a + deriving stock (Show, Functor) + +instance Applicative Result where + pure = Success + Failure a <*> Failure b = Failure (a <> b) + Failure a <*> Success _ = Failure a + Success _ <*> Failure b = Failure b + Success f <*> Success x = Success (f x) + +-- | Convert a 'Result'. +resultToEither :: Result a -> Either ConfigErrors a +resultToEither (Failure e) = Left e +resultToEither (Success a) = Right a + +-- | What a decoder knows about where it is. +data DecodeContext = DecodeContext + { ctxPath :: !Path + , ctxProfile :: !Profile + , ctxLossy :: !Bool + -- ^ accept strings for numbers and booleans, and scalars for strings + , ctxSources :: ![Metadata] + -- ^ every provider consulted, for missing-field hints + } + +-- | A context at the root, for the given profile and sources. +rootContext :: Profile -> [Metadata] -> DecodeContext +rootContext p ms = DecodeContext root p False ms + +-- | Decodes a t'Value' in a t'DecodeContext'. Accumulates errors (see the module header). +newtype Decoder a = Decoder {unDecoder :: DecodeContext -> Value -> Result a} + deriving stock (Functor) + +instance Applicative Decoder where + pure a = Decoder $ \_ _ -> Success a + Decoder f <*> Decoder g = Decoder $ \c v -> f c v <*> g c v + +-- | Run a decoder. +runDecoder :: Decoder a -> DecodeContext -> Value -> Either ConfigErrors a +runDecoder d c v = resultToEither (unDecoder d c v) + +-- | Run a decoder, keeping the accumulating 'Result'. +decodeWith :: Decoder a -> DecodeContext -> Value -> Result a +decodeWith = unDecoder + +-- | Build a decoder from a function (for custom instances that need the +-- context, e.g. to report errors at a precise location). +mkDecoder :: (DecodeContext -> Value -> Result a) -> Decoder a +mkDecoder = Decoder + +-- | Sequential composition. Short-circuits: errors from the second step +-- are only seen if the first succeeds. +andThen :: Decoder a -> (a -> Decoder b) -> Decoder b +andThen (Decoder f) k = Decoder $ \c v -> case f c v of + Failure e -> Failure e + Success a -> unDecoder (k a) c v + +-- | Inspect the raw value before choosing a decoder. +withValue :: (Value -> Decoder a) -> Decoder a +withValue k = Decoder $ \c v -> unDecoder (k v) c v + +-- | The key path of the value being decoded. +currentPath :: Decoder Path +currentPath = Decoder $ \c _ -> Success (ctxPath c) + +errorAt :: DecodeContext -> Value -> ErrorKind -> ConfigErrors +errorAt c v k = + let t = valueTag v + in single + ConfigError + { errorKind = k + , errorPath = ctxPath c + , errorProfile = Just (fromMaybe (ctxProfile c) (tagProfile t)) + , errorMetadata = tagMeta t + , errorPos = tagPos t + , errorHints = [] + } + +-- | Fail at the current value. +failWith :: ErrorKind -> Decoder a +failWith k = Decoder $ \c v -> Failure (errorAt c v k) + +-- | Post-process a decoded value; a 'Left' becomes a 'Message' error +-- located at this value (its source, line and column). +validate :: (a -> Either Text b) -> Decoder a -> Decoder b +validate f (Decoder g) = Decoder $ \c v -> case g c v of + Failure e -> Failure e + Success a -> case f a of + Left msg -> Failure (errorAt c v (Message msg)) + Right b -> Success b + +typeError :: DecodeContext -> Value -> Text -> Result a +typeError c v expected = Failure (errorAt c v (InvalidType (describe (valueNode v)) expected)) + +valueError :: DecodeContext -> Value -> Text -> Result a +valueError c v expected = Failure (errorAt c v (InvalidValue (describe (valueNode v)) expected)) + +------------------------------------------------------------------------ +-- The class + +-- | Types that can be decoded from configuration. Derive it generically (@deriving anyclass FromConfig@ with a 'Generic' instance) or write 'fromConfig' with the combinators below. +class FromConfig a where + fromConfig :: Decoder a + default fromConfig :: (Generic a, GDecode (Rep a)) => Decoder a + fromConfig = genericDecoder defaultOptions + + -- | The value to use when a record field of this type is absent. + -- 'Nothing' (the default) makes the field required; 'Maybe' fields + -- answer @Just Nothing@. + missingValue :: Maybe a + missingValue = Nothing + + -- | How to decode a list of this type. Exists so that t'String' + -- decodes from a string rather than an array of characters. + listDecoder :: Decoder [a] + listDecoder = Vector.toList <$> arrayOf fromConfig + +------------------------------------------------------------------------ +-- Field access + +-- | A required field of the current dictionary (or its +-- 'missingValue', for types that have one). +field :: forall a. FromConfig a => Text -> Decoder a +field name = fieldWith name fromConfig (missingValue @a) + +-- | A field with an explicit decoder and an optional fallback. +fieldWith :: Text -> Decoder a -> Maybe a -> Decoder a +fieldWith name d missing = Decoder $ \c v -> case valueNode v of + Dict m -> case Map.lookup name m of + Just sub -> unDecoder d c {ctxPath = ctxPath c /. name} sub + Nothing -> maybe (Failure (single (missingFieldError c name))) Success missing + _ -> typeError c v "a dictionary" + +-- | An optional field: 'Nothing' when absent or null. +optionalField :: FromConfig a => Text -> Decoder (Maybe a) +optionalField name = fieldWith name fromConfig (Just Nothing) + +-- | A field with a default used when it is absent. +fieldOr :: FromConfig a => Text -> a -> Decoder a +fieldOr name def = fieldWith name fromConfig (Just def) + +-- | The error for an absent required field, with a hint naming every +-- way it could have been supplied. +missingFieldError :: DecodeContext -> Text -> ConfigError +missingFieldError c name = + let p = ctxPath c /. name + prof = ctxProfile c + ways = [ "`" <> interpolate m prof p <> "` in " <> metaName m <> maybe "" ((" " <>) . renderSource) (metaSource m) + | m <- ctxSources c ] + hint = case ways of + [] -> [] + [w] -> ["no source sets it; it can be set as " <> w] + _ -> ["no source sets it; it can be set as " <> Text.intercalate ", " (init ways) <> ", or " <> last ways] + in ConfigError (MissingField name) p (Just prof) Nothing Nothing hint + +------------------------------------------------------------------------ +-- Containers + +-- | Decode every element of an array (errors in different elements accumulate). +arrayOf :: Decoder a -> Decoder (Vector a) +arrayOf (Decoder d) = Decoder $ \c v -> case valueNode v of + Array xs -> traverse (\(i, x) -> d c {ctxPath = ctxPath c /# i} x) (Vector.indexed xs) + _ -> typeError c v "an array" + +-- | Decode every value of a dictionary. +dictOf :: Decoder a -> Decoder (Map Text a) +dictOf (Decoder d) = Decoder $ \c v -> case valueNode v of + Dict m -> Map.traverseWithKey (\k x -> d c {ctxPath = ctxPath c /. k} x) m + _ -> typeError c v "a dictionary" + +-- | Keys of decoded maps. +class FromConfigKey k where + fromConfigKey :: Text -> Either Text k + +instance FromConfigKey Text where fromConfigKey = Right +instance FromConfigKey [Char] where fromConfigKey = Right . Text.unpack + +------------------------------------------------------------------------ +-- Scalars + +-- | Text: a string; or the original text of a value parsed from an +-- untyped source; or (lossy mode) any scalar rendered as text. +textual :: Decoder Text +textual = Decoder $ \c v -> case valueNode v of + String t -> Success t + n + | Just r <- tagRaw (valueTag v) -> Success r + | ctxLossy c, Just t <- scalarText n -> Success t + | otherwise -> typeError c v "a string" + +scalarText :: Node -> Maybe Text +scalarText = \case + Bool b -> Just (if b then "true" else "false") + Num (Finite s) + | Sci.isInteger s, abs (Sci.base10Exponent s) < 64 -> Just (Text.pack (Sci.formatScientific Sci.Fixed (Just 0) s)) + | otherwise -> Just (Text.pack (show s)) + Num PosInfinity -> Just "inf" + Num NegInfinity -> Just "-inf" + Num NaN -> Just "nan" + _ -> Nothing + +-- | A number, accepting strings in lossy mode. +numberD :: Text -> Decoder Number +numberD expected = Decoder $ \c v -> case valueNode v of + Num n -> Success n + String t | ctxLossy c, Just n <- parseNumber (Text.strip t) -> Success n + _ -> typeError c v expected + +-- | Integral types with bounds, rejecting non-integers and +-- out-of-range values (never wrapping, never allocating huge integers). +boundedIntegral :: forall a. (Integral a, Bounded a, Show a) => Decoder a +boundedIntegral = decodeIntegral $ \s -> + case Sci.toBoundedInteger s of + Just x -> Right x + Nothing -> Left ("an integer in the range " <> tshow (minBound :: a) <> ".." <> tshow (maxBound :: a)) + +decodeIntegral :: (Scientific -> Either Text a) -> Decoder a +decodeIntegral conv = Decoder $ \c v -> case unDecoder (numberD "an integer") c v of + Failure e -> Failure e + Success (Finite s) + | not (Sci.isInteger s) -> valueError c v "an integer" + | otherwise -> either (valueError c v) Success (conv s) + Success _ -> valueError c v "a finite integer" + +unboundedInteger :: Decoder Integer +unboundedInteger = decodeIntegral $ \s -> + if Sci.base10Exponent s > 4096 + then Left "an integer with at most ~4096 digits" + else Right (truncate s) + +realFloatD :: RealFloat a => Decoder a +realFloatD = Decoder $ \c v -> case unDecoder (numberD "a number") c v of + Failure e -> Failure e + Success (Finite s) -> Success (Sci.toRealFloat s) + Success PosInfinity -> Success (1 / 0) + Success NegInfinity -> Success (-1 / 0) + Success NaN -> Success (0 / 0) + +instance FromConfig Value where fromConfig = Decoder $ \_ v -> Success v + +instance FromConfig Text where fromConfig = textual + +instance FromConfig Char where + fromConfig = Decoder $ \c v -> case unDecoder textual c v of + Success t | Text.length t == 1 -> Success (Text.head t) + Success _ -> valueError c v "a single character" + Failure e -> Failure e + listDecoder = Text.unpack <$> textual + +instance FromConfig Bool where + fromConfig = Decoder $ \c v -> case valueNode v of + Bool b -> Success b + String t | ctxLossy c, Just b <- lossyBool t -> Success b + Num (Finite s) | ctxLossy c, s == 0 -> Success False + | ctxLossy c, s == 1 -> Success True + _ -> typeError c v "a boolean" + where + lossyBool t = case Text.toLower (Text.strip t) of + x | x `elem` ["true", "yes", "on", "1"] -> Just True + | x `elem` ["false", "no", "off", "0"] -> Just False + | otherwise -> Nothing + +instance FromConfig Int where fromConfig = boundedIntegral +instance FromConfig Int8 where fromConfig = boundedIntegral +instance FromConfig Int16 where fromConfig = boundedIntegral +instance FromConfig Int32 where fromConfig = boundedIntegral +instance FromConfig Int64 where fromConfig = boundedIntegral +instance FromConfig Word where fromConfig = boundedIntegral +instance FromConfig Word8 where fromConfig = boundedIntegral +instance FromConfig Word16 where fromConfig = boundedIntegral +instance FromConfig Word32 where fromConfig = boundedIntegral +instance FromConfig Word64 where fromConfig = boundedIntegral +instance FromConfig Integer where fromConfig = unboundedInteger + +instance FromConfig Natural where + fromConfig = Decoder $ \c v -> case unDecoder unboundedInteger c v of + Success n | n >= 0 -> Success (fromInteger n) + | otherwise -> valueError c v "a non-negative integer" + Failure e -> Failure e + +instance FromConfig Double where fromConfig = realFloatD +instance FromConfig Float where fromConfig = realFloatD + +instance FromConfig Scientific where + fromConfig = Decoder $ \c v -> case unDecoder (numberD "a number") c v of + Success (Finite s) -> Success s + Success _ -> valueError c v "a finite number" + Failure e -> Failure e + +instance FromConfig () where + fromConfig = Decoder $ \c v -> case valueNode v of + Null -> Success () + Dict m | Map.null m -> Success () + Array xs | Vector.null xs -> Success () + _ -> typeError c v "null" + +instance FromConfig a => FromConfig (Maybe a) where + fromConfig = Decoder $ \c v -> case valueNode v of + Null -> Success Nothing + _ -> Just <$> unDecoder fromConfig c v + missingValue = Just Nothing + +instance FromConfig a => FromConfig [a] where + fromConfig = listDecoder + +instance FromConfig a => FromConfig (NonEmpty a) where + fromConfig = Decoder $ \c v -> case unDecoder (listDecoder @a) c v of + Success (x : xs) -> Success (x :| xs) + Success [] -> Failure (errorAt c v (InvalidLength 0 "a non-empty array")) + Failure e -> Failure e + +instance FromConfig a => FromConfig (Vector a) where fromConfig = arrayOf fromConfig + +instance FromConfig a => FromConfig (Seq a) where + fromConfig = Seq.fromList . Vector.toList <$> arrayOf fromConfig + +instance (Ord a, FromConfig a) => FromConfig (Set a) where + fromConfig = Set.fromList . Vector.toList <$> arrayOf fromConfig + +instance (Ord k, FromConfigKey k, FromConfig a) => FromConfig (Map k a) where + fromConfig = Decoder $ \c v -> case unDecoder (dictOf fromConfig) c v of + Failure e -> Failure e + Success m -> + let conv (k, x) = case fromConfigKey k of + Right k' -> Success (k', x) + Left msg -> Failure (errorAt c {ctxPath = ctxPath c /. k} v (InvalidValue ("key `" <> k <> "`") msg)) + in Map.fromList <$> traverse conv (Map.toList m) + +instance (FromConfig a, FromConfig b) => FromConfig (a, b) where + fromConfig = tupleD 2 $ \c xs -> (,) <$> at c xs 0 <*> at c xs 1 + +instance (FromConfig a, FromConfig b, FromConfig c) => FromConfig (a, b, c) where + fromConfig = tupleD 3 $ \c xs -> (,,) <$> at c xs 0 <*> at c xs 1 <*> at c xs 2 + +tupleD :: Int -> (DecodeContext -> Vector Value -> Result a) -> Decoder a +tupleD n k = Decoder $ \c v -> case valueNode v of + Array xs + | Vector.length xs == n -> k c xs + | otherwise -> Failure (errorAt c v (InvalidLength (Vector.length xs) ("an array of length " <> tshow n))) + _ -> typeError c v ("an array of length " <> tshow n) + +at :: FromConfig a => DecodeContext -> Vector Value -> Int -> Result a +at c xs i = case xs Vector.!? i of + Just x -> unDecoder fromConfig c {ctxPath = ctxPath c /# i} x + Nothing -> Failure (single (atPath (ctxPath c /# i) (configError (InvalidLength i "more elements")))) + +-- Time: ISO 8601 text (TOML date/time values arrive as such text). +isoD :: ISO8601 t => Text -> Decoder t +isoD what = Decoder $ \c v -> case unDecoder textual c v of + Failure e -> Failure e + Success t -> case iso8601ParseM (Text.unpack (Text.strip t)) of + Just x -> Success x + Nothing -> valueError c v ("an ISO 8601 " <> what) + +instance FromConfig Day where fromConfig = isoD "date" +instance FromConfig TimeOfDay where fromConfig = isoD "time of day" +instance FromConfig LocalTime where fromConfig = isoD "local date-time" +instance FromConfig ZonedTime where fromConfig = isoD "date-time with offset" +instance FromConfig UTCTime where + fromConfig = Decoder $ \c v -> case unDecoder textual c v of + Failure e -> Failure e + Success t -> + let s = Text.unpack (Text.strip t) + in case (iso8601ParseM s, iso8601ParseM s) of + (Just z, _) -> Success (zonedTimeToUTC z) + (_, Just u) -> Success u + _ -> valueError c v "an ISO 8601 date-time with offset" + +------------------------------------------------------------------------ +-- Magic types + +-- | A value together with its provenance: which provider, which +-- profile, which line and column, and its key path. The Haskell +-- counterpart of Rust figment's @Tagged\@. +data Tagged a = Tagged + { taggedValue :: a + , taggedTag :: Tag + , taggedPath :: Path + } + deriving stock (Eq, Show, Functor) + +-- | The provider the value came from. +taggedMetadata :: Tagged a -> Maybe Metadata +taggedMetadata = tagMeta . taggedTag + +instance FromConfig a => FromConfig (Tagged a) where + fromConfig = Decoder $ \c v -> (\a -> Tagged a (valueTag v) (ctxPath c)) <$> unDecoder fromConfig c v + missingValue = (\a -> Tagged a untagged root) <$> missingValue + +-- | A path written in a configuration file, remembered together with +-- the directory of that file, so that relative paths can be resolved +-- against the file that declared them rather than the working +-- directory (Rust figment's @RelativePathBuf@). +data RelativePath = RelativePath + { relativeOriginal :: FilePath + , relativeBase :: Maybe FilePath + -- ^ directory of the declaring file, if it came from a file + } + deriving stock (Eq, Show) + +-- | Resolve: absolute paths and paths not from a file are returned +-- as written; others are joined to the declaring file's directory. +relative :: RelativePath -> FilePath +relative (RelativePath p base) + | isAbsolute p = p + | otherwise = maybe p ( p) base + +instance FromConfig RelativePath where + fromConfig = Decoder $ \c v -> case unDecoder textual c v of + Failure e -> Failure e + Success t -> + let base = case tagMeta (valueTag v) >>= metaSource of + Just (FileSource f) -> Just (takeDirectory f) + _ -> Nothing + in Success (RelativePath (Text.unpack t) base) + +------------------------------------------------------------------------ +-- Generic deriving + +-- | Options for 'genericDecoder'. +data Options = Options + { fieldLabelModifier :: String -> String + -- ^ field name to configuration key + , constructorTagModifier :: String -> String + -- ^ constructor name to enum tag + , rejectUnknownFields :: Bool + -- ^ report keys the record does not expect (with suggestions) + } + +-- | Field and constructor names used as written; unknown keys allowed. +defaultOptions :: Options +defaultOptions = Options id id False + +-- | @maxConnections@ to @max_connections@. +snakeCase :: String -> String +snakeCase = separate '_' + +-- | @maxConnections@ to @max-connections@. +kebabCase :: String -> String +kebabCase = separate '-' + +separate :: Char -> String -> String +separate sep = go True + where + go _ [] = [] + go start (c : cs) + | isUpper c = (if start then [] else [sep]) ++ toLower c : go False cs + | otherwise = c : go False cs + +-- | Derive a decoder from a 'Generic' instance: records are dictionaries, enums are strings (matched case-insensitively), other sums are externally tagged (@{ Variant = payload }@), newtypes unwrap, positional constructors are arrays. +genericDecoder :: (Generic a, GDecode (Rep a)) => Options -> Decoder a +genericDecoder o = to <$> gdecode o + +-- | Proxy for generic metadata, so that names are read without +-- conjuring values. +data P (m :: Meta) (f :: Type -> Type) a = P + +-- | Generic machinery behind 'genericDecoder'. +class GDecode (f :: Type -> Type) where + gdecode :: Options -> Decoder (f x) + +data Ctor a = Ctor + { ctorTag :: Text + , ctorNullary :: Bool + , ctorPayload :: Decoder a + } + deriving stock (Functor) + +instance GCtors f => GDecode (D1 d f) where + gdecode o = M1 <$> decodeCtors (gctors o) + +class GCtors (f :: Type -> Type) where + gctors :: Options -> [Ctor (f x)] + +instance (GCtors f, GCtors g) => GCtors (f :+: g) where + gctors o = map (fmap L1) (gctors o) ++ map (fmap R1) (gctors o) + +instance (Constructor c, GFields f, GPositional f) => GCtors (C1 c f) where + gctors o = + [ Ctor + { ctorTag = Text.pack (constructorTagModifier o (conName (P :: P c f ()))) + , ctorNullary = arity == 0 + , ctorPayload = M1 <$> payload + } + ] + where + arity = garity (Proxy :: Proxy f) + payload + | arity == 0 = Decoder $ \_ _ -> gposition o emptyCtx 0 Vector.empty + | conIsRecord (P :: P c f ()) = recordD o (gfieldNames o (Proxy :: Proxy f)) (gfields o) + | arity == 1 = case gunwrapped o of + Just d -> d + Nothing -> tupleD 1 (\c xs -> gposition o c 0 xs) + | otherwise = tupleD arity (\c xs -> gposition o c 0 xs) + emptyCtx = DecodeContext root Default False [] + +instance + TypeError ('Text "figment: cannot derive FromConfig for an empty data type") + => GCtors V1 + where + gctors _ = [] + +decodeCtors :: [Ctor a] -> Decoder a +decodeCtors [c] | not (ctorNullary c) = ctorPayload c +decodeCtors [c] = Decoder $ \ctx v -> case valueNode v of + -- a unit-like type accepts null, an empty container, or its own name + Null -> unDecoder (ctorPayload c) ctx v + Dict m | Map.null m -> unDecoder (ctorPayload c) ctx v + _ -> unDecoder (decodeCtors' [c]) ctx v +decodeCtors cs = decodeCtors' cs + +decodeCtors' :: [Ctor a] -> Decoder a +decodeCtors' cs = Decoder $ \c v -> + let tags = map ctorTag cs + byTag t = case filter ((== t) . ctorTag) cs of + (x : _) -> Just x + [] -> case filter ((== Text.toCaseFold t) . Text.toCaseFold . ctorTag) cs of + [x] -> Just x + _ -> Nothing + unknown t = Failure (errorAt c v (UnknownVariant t tags)) + in case valueNode v of + Dict m -> case Map.toList m of + [(k, payload)] -> case byTag k of + Just ctor -> unDecoder (ctorPayload ctor) c {ctxPath = ctxPath c /. k} payload + Nothing -> Failure (errorAt c {ctxPath = ctxPath c /. k} payload (UnknownVariant k tags)) + _ -> valueError c v "a variant name, or a dictionary with exactly one key naming a variant" + _ -> case unDecoder textual c v of + Success t -> case byTag (Text.strip t) of + Just ctor + | ctorNullary ctor -> unDecoder (ctorPayload ctor) c v + | otherwise -> valueError c v ("a dictionary `{ " <> ctorTag ctor <> " = ... }` (variant has fields)") + Nothing -> unknown t + Failure _ -> typeError c v ("one of " <> Text.intercalate ", " (map (\t -> "`" <> t <> "`") tags)) + +recordD :: Options -> [Text] -> (DecodeContext -> Dict -> Result a) -> Decoder a +recordD o known fields = Decoder $ \c v -> case valueNode v of + Dict m -> + let unknownErrs = + [ errorAt c {ctxPath = ctxPath c /. k} x (UnknownField k (suggest k known)) + | rejectUnknownFields o + , (k, x) <- Map.toList m + , k `notElem` known + ] + unknownR = case unknownErrs of + [] -> Success () + (e : es) -> Failure (foldl (<>) e es) + in unknownR *> fields c m + _ -> typeError c v "a dictionary" + +-- | Candidates within a small edit distance, best first. +suggest :: Text -> [Text] -> [Text] +suggest k known = + let scored = mapMaybe (\cand -> let d = editDistance (Text.unpack k) (Text.unpack cand) + in if d <= max 1 (Text.length cand `div` 3) then Just (d, cand) else Nothing) known + in map snd (take 3 (sortOn' fst scored)) + where + sortOn' f = foldr ins [] + where ins x [] = [x] + ins x (y : ys) | f x <= f y = x : y : ys + | otherwise = y : ins x ys + +-- | Optimal string alignment distance (Levenshtein plus adjacent +-- transpositions, so @hots@ is one edit from @host@). +editDistance :: String -> String -> Int +editDistance a b = table LMap.! (la, lb) + where + la = length a + lb = length b + av = Vector.fromList a + bv = Vector.fromList b + table = LMap.fromList [((i, j), cell i j) | i <- [0 .. la], j <- [0 .. lb]] + get i j = table LMap.! (i, j) + cell i 0 = i + cell 0 j = j + cell i j = + let ca = av Vector.! (i - 1) + cb = bv Vector.! (j - 1) + cost = if ca == cb then 0 else 1 + base = minimum [get (i - 1) j + 1, get i (j - 1) + 1, get (i - 1) (j - 1) + cost] + in if i > 1 && j > 1 && ca == bv Vector.! (j - 2) && av Vector.! (i - 2) == cb + then min base (get (i - 2) (j - 2) + 1) + else base + +class GFields (f :: Type -> Type) where + gfields :: Options -> DecodeContext -> Dict -> Result (f x) + gfieldNames :: Options -> Proxy f -> [Text] + +instance (GFields f, GFields g) => GFields (f :*: g) where + gfields o c m = (:*:) <$> gfields o c m <*> gfields o c m + gfieldNames o _ = gfieldNames o (Proxy :: Proxy f) ++ gfieldNames o (Proxy :: Proxy g) + +instance GFields U1 where + gfields _ _ _ = Success U1 + gfieldNames _ _ = [] + +instance (Selector s, FromConfig a) => GFields (S1 s (Rec0 a)) where + gfields o c m = + let name = Text.pack (fieldLabelModifier o (selName (P :: P s (Rec0 a) ()))) + in case Map.lookup name m of + Just v -> M1 . K1 <$> unDecoder fromConfig c {ctxPath = ctxPath c /. name} v + Nothing -> case missingValue @a of + Just d -> Success (M1 (K1 d)) + Nothing -> Failure (single (missingFieldError c name)) + gfieldNames o _ = [Text.pack (fieldLabelModifier o (selName (P :: P s (Rec0 a) ())))] + +class GPositional (f :: Type -> Type) where + garity :: Proxy f -> Int + gposition :: Options -> DecodeContext -> Int -> Vector Value -> Result (f x) + gunwrapped :: Options -> Maybe (Decoder (f x)) + gunwrapped _ = Nothing + +instance (GPositional f, GPositional g) => GPositional (f :*: g) where + garity _ = garity (Proxy :: Proxy f) + garity (Proxy :: Proxy g) + gposition o c i xs = (:*:) <$> gposition o c i xs <*> gposition o c (i + garity (Proxy :: Proxy f)) xs + +instance GPositional U1 where + garity _ = 0 + gposition _ _ _ _ = Success U1 + +instance FromConfig a => GPositional (S1 s (Rec0 a)) where + garity _ = 1 + gposition _ c i xs = M1 . K1 <$> at c xs i + gunwrapped _ = Just (M1 . K1 <$> fromConfig) + +tshow :: Show a => a -> Text +tshow = Text.pack . show diff --git a/src/Figment/Error.hs b/src/Figment/Error.hs new file mode 100644 --- /dev/null +++ b/src/Figment/Error.hs @@ -0,0 +1,206 @@ +-- | The error vocabulary. Every failure anywhere in figment is a +-- t'ConfigError'; operations that can fail in more than one place return +-- t'ConfigErrors', a non-empty collection, so users see /every/ problem +-- in one run instead of fixing them one at a time. +module Figment.Error + ( ErrorKind (..) + , ConfigError (..) + , ConfigErrors + , configError + , single + , errorList + , fromErrorList + , atPath + , withMetadata + , withPos + , withProfile + , addHints + , describeKind + , renderError + , renderErrors + ) where + +import Control.DeepSeq (NFData) +import Control.Exception (Exception (..)) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import Data.Text (Text) +import qualified Data.Text as Text +import GHC.Generics (Generic) + +import Figment.Metadata +import Figment.Path +import Figment.Profile + +-- | What went wrong. Closed: every constructor is produced somewhere in +-- the library. +data ErrorKind + = IoError !Text + -- ^ a source could not be read + | SyntaxError !Text + -- ^ a source could not be parsed + | DepthExceeded !Int + -- ^ nesting deeper than the configured limit (the limit is carried) + | TooManyNodes !Int + -- ^ more values than the configured limit (the limit is carried) + | DuplicateKey !Text + -- ^ the same key appears twice in one dictionary of one source + | KeyConflict !Text !Text + -- ^ two flat keys (env vars, CLI flags) that cannot both hold: one + -- sets a value where the other needs a dictionary + | InvalidType !Text !Text + -- ^ @InvalidType actual expected@ + | InvalidValue !Text !Text + -- ^ right type, unacceptable value: @InvalidValue actual expected@ + | InvalidLength !Int !Text + -- ^ @InvalidLength actualLength expected@ + | MissingField !Text + -- ^ a required field has no value in any source + | UnknownField !Text ![Text] + -- ^ field not expected by the target type; carries suggestions + | UnknownVariant !Text ![Text] + -- ^ enum tag not recognised; carries the valid tags + | Message !Text + -- ^ a custom failure, e.g. from a validation step + | InvalidArgument !Text + -- ^ the library API was called with an invalid argument + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +-- | One error, with everything known about where it happened. +data ConfigError = ConfigError + { errorKind :: !ErrorKind + , errorPath :: !Path + -- ^ key path within the selected profile + , errorProfile :: !(Maybe Profile) + -- ^ the profile the offending value came from + , errorMetadata :: !(Maybe Metadata) + -- ^ the provider the offending value came from + , errorPos :: !(Maybe Pos) + -- ^ line/column in that provider's source text, when known + , errorHints :: ![Text] + } + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +-- | One or more errors. A 'Semigroup', so independent failures combine. +newtype ConfigErrors = ConfigErrors (NonEmpty ConfigError) + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + deriving newtype (Semigroup) + +instance Exception ConfigErrors where + displayException = Text.unpack . renderErrors + +-- | An error of the given kind at the root, with no provenance yet. +configError :: ErrorKind -> ConfigError +configError k = ConfigError k root Nothing Nothing Nothing [] + +-- | One error. +single :: ConfigError -> ConfigErrors +single e = ConfigErrors (e :| []) + +-- | All errors, in order. +errorList :: ConfigErrors -> [ConfigError] +errorList (ConfigErrors es) = NE.toList es + +-- | Collect errors, if there are any. +fromErrorList :: [ConfigError] -> Maybe ConfigErrors +fromErrorList = fmap ConfigErrors . NE.nonEmpty + +-- | Set the path. +atPath :: Path -> ConfigError -> ConfigError +atPath p e = e {errorPath = p} + +-- | Set the provider metadata. +withMetadata :: Maybe Metadata -> ConfigError -> ConfigError +withMetadata m e = e {errorMetadata = m} + +-- | Set the source position. +withPos :: Maybe Pos -> ConfigError -> ConfigError +withPos p e = e {errorPos = p} + +-- | Set the profile. +withProfile :: Maybe Profile -> ConfigError -> ConfigError +withProfile p e = e {errorProfile = p} + +-- | Append hints. +addHints :: [Text] -> ConfigError -> ConfigError +addHints hs e = e {errorHints = errorHints e ++ hs} + +-- | The one-line description of an error kind. +describeKind :: ErrorKind -> Text +describeKind = \case + IoError t -> "could not read source: " <> t + SyntaxError t -> "syntax error: " <> t + DepthExceeded n -> "nesting exceeds the depth limit of " <> tshow n + TooManyNodes n -> "source contains more than the limit of " <> tshow n <> " values" + DuplicateKey k -> "duplicate key " <> tick k + KeyConflict a b -> tick a <> " conflicts with " <> tick b + <> ": one sets a value where the other needs a dictionary" + InvalidType actual expected -> "invalid type: found " <> actual <> ", expected " <> expected + InvalidValue actual expected -> "invalid value: found " <> actual <> ", expected " <> expected + InvalidLength n expected -> "invalid length " <> tshow n <> ", expected " <> expected + MissingField f -> "missing field " <> tick f + UnknownField f _ -> "unknown field " <> tick f + UnknownVariant v valid -> "unknown variant " <> tick v <> ", expected one of " + <> Text.intercalate ", " (map tick valid) + Message t -> t + InvalidArgument t -> "invalid argument: " <> t + +-- | A multi-line, human-oriented rendering: +-- +-- > error: invalid type: found string "abc", expected an integer +-- > --> key `port` (`APP_PORT`) in environment variables +-- > = hint: ... +renderError :: ConfigError -> Text +renderError e = + Text.intercalate "\n" $ + ("error: " <> describeKind (errorKind e)) + : location + ++ map (" = hint: " <>) (suggestions ++ errorHints e) + where + suggestions = case errorKind e of + UnknownField _ (s : ss) -> ["did you mean " <> Text.intercalate " or " (map tick (s : ss)) <> "?"] + _ -> [] + prof = maybe Default id (errorProfile e) + path = errorPath e + keyPart + | isRoot path = "top level" + | otherwise = "key " <> tick (renderPath path) + native = case errorMetadata e of + Just m | not (isRoot path) -> + let n = interpolate m prof path + in if n == renderPath path then "" else " (" <> tick n <> ")" + _ -> "" + sourcePart = case errorMetadata e of + Nothing -> "" + Just m -> " in " <> metaName m <> case metaSource m of + Just s -> " " <> renderSource s <> posSuffix + Nothing -> posWords + posSuffix = case errorPos e of + Just (Pos l c) -> ":" <> tshow l <> ":" <> tshow c + Nothing -> "" + posWords = case errorPos e of + Just (Pos l c) -> " at line " <> tshow l <> ", column " <> tshow c + Nothing -> "" + profPart = case errorProfile e of + Just p | p /= Default -> " [profile " <> tick (profileName p) <> "]" + _ -> "" + location = + let line = keyPart <> native <> sourcePart <> profPart + in [" --> " <> line] + +-- | Render every error, separated by blank lines, with a count header +-- when there is more than one. +renderErrors :: ConfigErrors -> Text +renderErrors (ConfigErrors (e :| [])) = renderError e +renderErrors (ConfigErrors es) = + tshow (length es) <> " configuration errors:\n\n" + <> Text.intercalate "\n\n" (map renderError (NE.toList es)) + +tick :: Text -> Text +tick t = "`" <> t <> "`" + +tshow :: Show a => a -> Text +tshow = Text.pack . show diff --git a/src/Figment/Extract.hs b/src/Figment/Extract.hs new file mode 100644 --- /dev/null +++ b/src/Figment/Extract.hs @@ -0,0 +1,89 @@ +-- | Turning a loaded configuration into typed values. +module Figment.Extract + ( extract + , extractLossy + , extractAt + , extractWith + , extractPartial + , extractPartialWith + , extractTotal + , extractTotalWith + , loadExtract + , loadExtractOrThrow + , decodeContext + ) where + +import Control.Exception (throwIO) +import Data.Functor.Identity (Identity) +import Data.Semigroup (sconcat) + +import Figment.Core +import Figment.Decode +import Figment.Error +import Figment.Partial +import Figment.Path +import Figment.Value + +-- | The context decoders run in for a loaded configuration. +decodeContext :: Loaded -> DecodeContext +decodeContext l = rootContext (loadedProfile l) (loadedSources l) + +-- | Decode the selected profile. +extract :: FromConfig a => Loaded -> Either ConfigErrors a +extract = extractWith fromConfig + +-- | Like 'extract', but accept @"8080"@ for numbers, @"yes"@ for +-- booleans, and scalars for strings (Rust: @extract_lossy@). +extractLossy :: FromConfig a => Loaded -> Either ConfigErrors a +extractLossy l = runDecoder fromConfig (decodeContext l) {ctxLossy = True} (selected l) + +-- | Decode the selected profile with an explicit decoder. +extractWith :: Decoder a -> Loaded -> Either ConfigErrors a +extractWith d l = runDecoder d (decodeContext l) (selected l) + +-- | Decode the value at a key path (Rust: @extract_inner@). +extractAt :: forall a. FromConfig a => Path -> Loaded -> Either ConfigErrors a +extractAt p l = case lookupPath p (selected l) of + Just v -> runDecoder fromConfig (decodeContext l) {ctxPath = p} v + Nothing -> case missingValue @a of + Just d -> Right d + Nothing -> Left (single (missingAt (decodeContext l) p)) + +-- | Decode a 'Partial' configuration, filling gaps from partial +-- defaults (provider values win). Reports every type error, or else +-- every missing required field. +extractPartial :: Partial c => c Maybe -> Loaded -> Either ConfigErrors (c Identity) +extractPartial = extractPartialWith defaultOptions + +-- | 'extractPartial' with explicit generic t'Options' (e.g. 'snakeCase' field names). +extractPartialWith :: Partial c => Options -> c Maybe -> Loaded -> Either ConfigErrors (c Identity) +extractPartialWith o defs l = do + found <- runDecoder (partialDecoder o) (decodeContext l) (selected l) + case complete o (overlay defs found) of + Right r -> Right r + Left ps -> + let errs = fmap (missingAt (decodeContext l)) ps + in Left (sconcat (fmap single errs)) + +-- | With /total/ defaults a missing-field error is impossible by +-- construction: the type guarantees every field has a value. +extractTotal :: Partial c => c Identity -> Loaded -> Either ConfigErrors (c Identity) +extractTotal = extractTotalWith defaultOptions + +-- | 'extractTotal' with explicit generic t'Options'. +extractTotalWith :: Partial c => Options -> c Identity -> Loaded -> Either ConfigErrors (c Identity) +extractTotalWith o d = extractPartialWith o (total d) + +missingAt :: DecodeContext -> Path -> ConfigError +missingAt c p = case reverse (segments p) of + (Key name : parentRev) -> missingFieldError c {ctxPath = fromSegments (reverse parentRev)} name + _ -> atPath p (configError (MissingField (renderPath p))) + +-- | 'load' then 'extract'. +loadExtract :: FromConfig a => Figment -> IO (Either ConfigErrors a) +loadExtract fig = (>>= extract) <$> load fig + +-- | 'loadExtract', throwing t'ConfigErrors' (whose 'Control.Exception.displayException' is +-- the rendered report). +loadExtractOrThrow :: FromConfig a => Figment -> IO a +loadExtractOrThrow fig = loadExtract fig >>= either throwIO pure diff --git a/src/Figment/Internal/Budget.hs b/src/Figment/Internal/Budget.hs new file mode 100644 --- /dev/null +++ b/src/Figment/Internal/Budget.hs @@ -0,0 +1,62 @@ +-- | A tiny state/error monad shared by every parser that builds a +-- t'Figment.Value.Value' from untrusted input: it enforces 'Limits' while the tree is +-- being built, so a hostile source is rejected before it is +-- materialised. +module Figment.Internal.Budget + ( Budget + , runBudget + , spend + , enterContainer + , throwB + , askLimits + ) where + +import Figment.Error +import Figment.Limits +import Figment.Metadata (Pos) +import Figment.Path (Path) + +newtype Budget a = Budget {unBudget :: Limits -> Int -> Either ConfigError (a, Int)} + +instance Functor Budget where + fmap f (Budget g) = Budget $ \l n -> case g l n of + Left e -> Left e + Right (a, n') -> Right (f a, n') + +instance Applicative Budget where + pure a = Budget $ \_ n -> Right (a, n) + Budget f <*> Budget g = Budget $ \l n -> case f l n of + Left e -> Left e + Right (h, n') -> case g l n' of + Left e -> Left e + Right (a, n'') -> Right (h a, n'') + +instance Monad Budget where + Budget g >>= k = Budget $ \l n -> case g l n of + Left e -> Left e + Right (a, n') -> unBudget (k a) l n' + +runBudget :: Limits -> Budget a -> Either ConfigError a +runBudget l (Budget g) = fst <$> g l (maxNodes l) + +askLimits :: Budget Limits +askLimits = Budget $ \l n -> Right (l, n) + +throwB :: ConfigError -> Budget a +throwB e = Budget $ \_ _ -> Left e + +-- | Account for @k@ values at the given location. +spend :: Int -> Path -> Maybe Pos -> Budget () +spend k p pos = Budget $ \l n -> + let n' = n - k + in if n' < 0 + then Left (withPos pos (atPath p (configError (TooManyNodes (maxNodes l))))) + else Right ((), n') + +-- | Check that a container at nesting level @depth@ (root = 1) is +-- allowed. +enterContainer :: Int -> Path -> Maybe Pos -> Budget () +enterContainer depth p pos = Budget $ \l n -> + if depth > maxDepth l + then Left (withPos pos (atPath p (configError (DepthExceeded (maxDepth l))))) + else Right ((), n) diff --git a/src/Figment/Internal/Nest.hs b/src/Figment/Internal/Nest.hs new file mode 100644 --- /dev/null +++ b/src/Figment/Internal/Nest.hs @@ -0,0 +1,60 @@ +-- | Turning flat @(key path, value)@ pairs (environment variables, CLI +-- arguments, keyed defaults) into a nested dictionary, reporting every +-- conflict instead of silently dropping data. +module Figment.Internal.Nest + ( Duplicates (..) + , nest + ) where + +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Text (Text) + +import Figment.Error +import Figment.Path +import Figment.Value + +-- | What to do when two entries set exactly the same key. +data Duplicates + = LastWins -- ^ later entries override earlier ones (CLI convention) + | RejectDuplicates -- ^ report 'DuplicateKey' + +data Entry + = Leaf !Text !Value + | Branch !Text !(Map Text Entry) + +-- | @nest policy entries@, where each entry is +-- @(original name, key segments, value)@. The original name (e.g. +-- @APP_DB\__HOST@) is used in conflict messages. +nest :: Duplicates -> [(Text, [Text], Value)] -> Either ConfigErrors Dict +nest policy entries = + let (tree, errs) = foldl' step (Map.empty, []) entries + in case fromErrorList (reverse errs) of + Just es -> Left es + Nothing -> Right (fmap toValue tree) + where + step (tree, errs) (name, ks, v) = case insert root name ks v tree of + Left e -> (tree, e : errs) + Right tree' -> (tree', errs) + + insert _ _ [] _ tree = Right tree + insert path name [k] v tree = case Map.lookup k tree of + Nothing -> Right (Map.insert k (Leaf name v) tree) + Just (Leaf other _) -> case policy of + LastWins -> Right (Map.insert k (Leaf name v) tree) + RejectDuplicates -> + Left (atPath (path /. k) (configError (DuplicateKey (other <> " and " <> name)))) + Just (Branch other _) -> + Left (atPath (path /. k) (configError (KeyConflict name other))) + insert path name (k : ks) v tree = case Map.lookup k tree of + Nothing -> do + sub <- insert (path /. k) name ks v Map.empty + Right (Map.insert k (Branch name sub) tree) + Just (Branch first sub) -> do + sub' <- insert (path /. k) name ks v sub + Right (Map.insert k (Branch first sub') tree) + Just (Leaf other _) -> + Left (atPath (path /. k) (configError (KeyConflict other name))) + + toValue (Leaf _ v) = v + toValue (Branch _ m) = mkValue (Dict (fmap toValue m)) diff --git a/src/Figment/Internal/ValueParser.hs b/src/Figment/Internal/ValueParser.hs new file mode 100644 --- /dev/null +++ b/src/Figment/Internal/ValueParser.hs @@ -0,0 +1,195 @@ +-- | Parsing untyped text (environment variables, CLI arguments) into +-- structured values, with syntax resembling TOML (as Rust figment's +-- @Env@ does): +-- +-- * @true@ / @false@ are booleans +-- * integers and decimals (@-12@, @3.5@, @1e3@) are exact numbers; +-- @inf@, @-inf@, @nan@ are the non-finite numbers +-- * @\"double\"@ and @'single'@ quoted text is a string (quotes removed) +-- * @[a, b, c]@ is an array and @{k = v, k2 = v2}@ a dictionary; their +-- elements follow the same rules, and bare words inside them are +-- strings +-- * anything else, including malformed structured text, is the string +-- itself, verbatim +-- +-- The top-level result always records the original text in 'tagRaw', +-- so a 'Text' field still receives @007@ rather than @7@. +module Figment.Internal.ValueParser + ( parseValue + , parseNumber + ) where + +import Data.Char (isDigit, isSpace) +import qualified Data.Map.Strict as Map +import Data.Scientific (scientific) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Vector as Vector + +import Figment.Error +import Figment.Limits +import Figment.Value + +-- | Parse one untyped text value. Fails only when structured text is +-- nested beyond the depth limit; any syntax problem falls back to the +-- string. +parseValue :: Limits -> Text -> Either ConfigError Value +parseValue lim raw = case top of + Left (Limit e) -> Left e + Left NoParse -> Right (rawTagged (String raw)) + Right n -> Right (rawTagged n) + where + trimmed = Text.strip raw + rawTagged n = Value untagged {tagRaw = Just raw} n + top + | Text.null trimmed = Right (String raw) + | otherwise = case Text.head trimmed of + c | c == '[' || c == '{' || c == '"' || c == '\'' -> + case structured lim 1 trimmed of + Right (v, rest) | Text.null (Text.strip rest) -> Right (valueNode v) + Right _ -> Left NoParse + Left e -> Left e + _ -> Right (scalarNode raw trimmed) + +data Failure = NoParse | Limit ConfigError + +-- | A bare scalar: boolean, number, or the text itself. +scalarNode :: Text -> Text -> Node +scalarNode original t + | t == "true" = Bool True + | t == "false" = Bool False + | Just n <- parseNumber t = Num n + | otherwise = String original + +type P a = Either Failure (a, Text) + +structured :: Limits -> Int -> Text -> P Value +structured lim depth t0 = case Text.uncons t of + Just ('[', rest) -> do + guardDepth + (xs, rest') <- elements rest + pure (mkValue (Array (Vector.fromList xs)), rest') + Just ('{', rest) -> do + guardDepth + (kvs, rest') <- pairs rest + pure (mkValue (Dict (Map.fromList kvs)), rest') + Just ('"', rest) -> first' string (quotedDouble "" rest) + Just ('\'', rest) -> first' string (quotedSingle rest) + Just _ -> + let (tok, rest) = Text.break (`elem` (",]}" :: String)) t + tok' = Text.strip tok + in if Text.null tok' + then Left NoParse + else Right (mkValue (scalarNode tok' tok'), rest) + Nothing -> Left NoParse + where + t = Text.stripStart t0 + guardDepth + | depth > maxDepth lim = Left (Limit (configError (DepthExceeded (maxDepth lim)))) + | otherwise = Right () + + elements s0 = + let s = Text.stripStart s0 + in case Text.uncons s of + Just (']', rest) -> Right ([], rest) + _ -> go [] s + where + go acc s = do + (v, rest) <- structured lim (depth + 1) s + let rest' = Text.stripStart rest + case Text.uncons rest' of + Just (',', more) -> + let more' = Text.stripStart more + in case Text.uncons more' of + Just (']', fin) -> Right (reverse (v : acc), fin) + _ -> go (v : acc) more' + Just (']', fin) -> Right (reverse (v : acc), fin) + _ -> Left NoParse + + pairs s0 = + let s = Text.stripStart s0 + in case Text.uncons s of + Just ('}', rest) -> Right ([], rest) + _ -> go [] s + where + go acc s = do + (k, rest) <- key s + rest1 <- case Text.uncons (Text.stripStart rest) of + Just (c, r) | c == '=' || c == ':' -> Right r + _ -> Left NoParse + (v, rest2) <- structured lim (depth + 1) rest1 + let rest3 = Text.stripStart rest2 + case Text.uncons rest3 of + Just (',', more) -> + let more' = Text.stripStart more + in case Text.uncons more' of + Just ('}', fin) -> Right (reverse ((k, v) : acc), fin) + _ -> go ((k, v) : acc) more' + Just ('}', fin) -> Right (reverse ((k, v) : acc), fin) + _ -> Left NoParse + + key s = case Text.uncons (Text.stripStart s) of + Just ('"', rest) -> quotedDouble "" rest + Just ('\'', rest) -> quotedSingle rest + _ -> + let (k, rest) = Text.span (\c -> not (isSpace c) && c `notElem` ("=:,{}[]" :: String)) (Text.stripStart s) + in if Text.null k then Left NoParse else Right (k, rest) + + first' f r = fmap (\(a, rest) -> (f a, rest)) r + +quotedDouble :: Text -> Text -> P Text +quotedDouble acc s = case Text.uncons s of + Nothing -> Left NoParse + Just ('"', rest) -> Right (acc, rest) + Just ('\\', rest) -> case Text.uncons rest of + Just (c, rest') -> case c of + 'n' -> quotedDouble (Text.snoc acc '\n') rest' + 't' -> quotedDouble (Text.snoc acc '\t') rest' + 'r' -> quotedDouble (Text.snoc acc '\r') rest' + _ -> quotedDouble (Text.snoc acc c) rest' + Nothing -> Left NoParse + Just (c, rest) -> quotedDouble (Text.snoc acc c) rest + +quotedSingle :: Text -> P Text +quotedSingle s = + let (body, rest) = Text.break (== '\'') s + in case Text.uncons rest of + Just ('\'', rest') -> Right (body, rest') + _ -> Left NoParse + +-- | Exact number syntax: @[+-]?digits(.digits)?([eE][+-]?digits)?@, or +-- @inf@ / @+inf@ / @-inf@ / @nan@. +parseNumber :: Text -> Maybe Number +parseNumber t = case t of + "inf" -> Just PosInfinity + "+inf" -> Just PosInfinity + "-inf" -> Just NegInfinity + "nan" -> Just NaN + "+nan" -> Just NaN + "-nan" -> Just NaN + _ -> do + let (neg, body) = case Text.uncons t of + Just ('-', r) -> (True, r) + Just ('+', r) -> (False, r) + _ -> (False, t) + (intPart, r1) = Text.span isDigit body + if Text.null intPart then Nothing else pure () + (fracPart, r2) <- case Text.uncons r1 of + Just ('.', r) -> + let (f, r') = Text.span isDigit r + in if Text.null f then Nothing else Just (f, r') + _ -> Just ("", r1) + expo <- case Text.uncons r2 of + Nothing -> Just 0 + Just (e, r) | e == 'e' || e == 'E' -> + let (sgn, ds) = case Text.uncons r of + Just ('-', d) -> (-1, d) + Just ('+', d) -> (1, d) + _ -> (1, r) + in if Text.null ds || not (Text.all isDigit ds) || Text.length ds > 9 + then Nothing + else Just (sgn * read (Text.unpack ds) :: Int) + _ -> Nothing + let coeff = read (Text.unpack (intPart <> fracPart)) :: Integer + signed = if neg then negate coeff else coeff + pure (Finite (scientific signed (expo - Text.length fracPart))) diff --git a/src/Figment/Jail.hs b/src/Figment/Jail.hs new file mode 100644 --- /dev/null +++ b/src/Figment/Jail.hs @@ -0,0 +1,95 @@ +-- | A sandbox for configuration tests (Rust: @figment::Jail@). +-- +-- 'withJail' runs an action in a fresh temporary working directory with +-- a snapshot of the environment, and restores both afterwards, even on +-- exceptions. Jails are serialised process-wide (the working directory +-- and the environment are process-global), so jailed tests are safe +-- under a parallel test runner. Tests that do not use a jail should not +-- touch the working directory or the environment. +module Figment.Jail + ( Jail + , withJail + , jailDirectory + , createFile + , createBinaryFile + , createDirectory + , inDirectory + , setEnv + , unsetEnv + , clearEnv + ) where + +import Control.Concurrent.MVar (MVar, newMVar, withMVar) +import Control.Exception (bracket, bracket_) +import qualified Data.ByteString as BS +import Data.Text (Text) +import qualified Data.Text.Encoding as TE +import System.Directory (createDirectoryIfMissing, getCurrentDirectory, setCurrentDirectory) +import qualified System.Environment as Env +import System.FilePath (takeDirectory, ()) +import System.IO.Temp (withSystemTempDirectory) +import System.IO.Unsafe (unsafePerformIO) + +-- | A handle on the running jail. +newtype Jail = Jail + { jailDirectory :: FilePath + -- ^ the temporary directory (also the working directory) + } + +-- The one piece of global state: a lock serialising jails. Standard +-- top-level-MVar idiom; NOINLINE guarantees a single MVar. +jailLock :: MVar () +jailLock = unsafePerformIO (newMVar ()) +{-# NOINLINE jailLock #-} + +-- | Run an action in a fresh jail; see the module header. +withJail :: (Jail -> IO a) -> IO a +withJail act = withMVar jailLock $ \() -> + withSystemTempDirectory "figment-jail" $ \dir -> + bracket Env.getEnvironment restoreEnv $ \_ -> + bracket getCurrentDirectory setCurrentDirectory $ \_ -> + bracket_ (setCurrentDirectory dir) (pure ()) (act (Jail dir)) + where + restoreEnv saved = do + now <- Env.getEnvironment + mapM_ (Env.unsetEnv . fst) [kv | kv@(k, _) <- now, k `notElem` map fst saved] + mapM_ (uncurry Env.setEnv) [kv | kv <- saved, lookup (fst kv) now /= Just (snd kv)] + +-- | Write a UTF-8 file, relative to the jail directory. +createFile :: Jail -> FilePath -> Text -> IO FilePath +createFile (Jail dir) rel contents = do + let path = dir rel + createDirectoryIfMissing True (takeDirectory path) + BS.writeFile path (TE.encodeUtf8 contents) + pure path + +-- | Write raw bytes (e.g. deliberately invalid UTF-8). +createBinaryFile :: Jail -> FilePath -> BS.ByteString -> IO FilePath +createBinaryFile (Jail dir) rel contents = do + let path = dir rel + createDirectoryIfMissing True (takeDirectory path) + BS.writeFile path contents + pure path + +-- | Run an action with another working directory (restored afterwards). +inDirectory :: Jail -> FilePath -> IO a -> IO a +inDirectory _ d act = bracket getCurrentDirectory setCurrentDirectory (\_ -> setCurrentDirectory d >> act) + +-- | Create a directory (and parents) inside the jail. +createDirectory :: Jail -> FilePath -> IO FilePath +createDirectory (Jail dir) rel = do + let path = dir rel + createDirectoryIfMissing True path + pure path + +-- | Set an environment variable for the duration of the jail. (As with "System.Environment", setting the empty string unsets it.) +setEnv :: Jail -> String -> String -> IO () +setEnv _ = Env.setEnv + +-- | Unset an environment variable for the duration of the jail. +unsetEnv :: Jail -> String -> IO () +unsetEnv _ = Env.unsetEnv + +-- | Remove every environment variable (restored when the jail ends). +clearEnv :: Jail -> IO () +clearEnv _ = Env.getEnvironment >>= mapM_ (Env.unsetEnv . fst) diff --git a/src/Figment/Limits.hs b/src/Figment/Limits.hs new file mode 100644 --- /dev/null +++ b/src/Figment/Limits.hs @@ -0,0 +1,40 @@ +-- | Resource limits applied while reading untrusted sources. +module Figment.Limits + ( Limits + , mkLimits + , defaultLimits + , maxDepth + , maxNodes + ) where + +import Control.DeepSeq (NFData) +import qualified Data.Text as Text +import GHC.Generics (Generic) + +import Figment.Error + +-- | Bounds enforced /inside/ every parser figment ships (not after the +-- fact), so a hostile source is rejected before it can exhaust memory. +-- The constructor is hidden: obtain values via 'mkLimits'. +data Limits = Limits + { maxDepth :: !Int + -- ^ maximum container nesting (the root dictionary is depth 1) + , maxNodes :: !Int + -- ^ maximum number of values per source, counting YAML alias + -- expansions (defeats \"billion laughs\") + } + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +-- | Both limits must be positive. +mkLimits :: Int -> Int -> Either ConfigError Limits +mkLimits d n + | d <= 0 = Left (bad "maxDepth" d) + | n <= 0 = Left (bad "maxNodes" n) + | otherwise = Right (Limits d n) + where + bad name v = configError (InvalidArgument (name <> " must be positive, got " <> Text.pack (show v))) + +-- | Depth 64, one million values (ADR 001, ADR 017). +defaultLimits :: Limits +defaultLimits = Limits 64 1000000 diff --git a/src/Figment/Merge.hs b/src/Figment/Merge.hs new file mode 100644 --- /dev/null +++ b/src/Figment/Merge.hs @@ -0,0 +1,68 @@ +-- | Combining values: the four strategies of Rust figment, with the +-- same semantics (see @coalesce.rs@ upstream). +-- +-- * 'Merge' — on conflict the incoming value wins +-- * 'Join' — on conflict the existing value wins +-- * 'Adjoin' — like 'Join', but arrays are concatenated +-- * 'Admerge' — like 'Merge', but arrays are concatenated +-- +-- Dictionaries are always merged key by key, recursively. A @null@ is a +-- value like any other: merging @null@ over a key replaces it. +-- +-- Laws (property-tested in @test/Figment/MergeLaws.hs@): +-- +-- * @coalesce Join a b == coalesce Merge b a@ (duality, tags included) +-- * @coalesce o v v@ has the same data as @v@ for 'Merge' and 'Join' +-- * the empty dictionary is a two-sided identity on dictionaries +-- * for a fixed order, 'coalesce' is associative on trees of identical +-- shape. It is /not/ associative in general (a scalar between two +-- dictionaries), which is why t'Value' has no 'Semigroup' instance; the +-- lawful monoid lives one level up, on 'Figment.Figment'. +module Figment.Merge + ( Order (..) + , coalesce + , coalesceDict + , coalesceData + , coalesceProfile + ) where + +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map + +import Figment.Profile +import Figment.Value + +-- | How a provider's values combine with the values already present. +data Order = Merge | Join | Adjoin | Admerge + deriving stock (Eq, Ord, Show, Enum, Bounded) + +leftWins :: Order -> Bool +leftWins Join = True +leftWins Adjoin = True +leftWins _ = False + +concatenates :: Order -> Bool +concatenates Adjoin = True +concatenates Admerge = True +concatenates _ = False + +-- | Combine an existing value (left) with an incoming one (right). +coalesce :: Order -> Value -> Value -> Value +coalesce o a@(Value ta na) b@(Value tb nb) = case (na, nb) of + (Dict da, Dict db) -> + Value (if leftWins o then ta else tb) (Dict (coalesceDict o da db)) + (Array xa, Array xb) + | concatenates o -> Value ta (Array (xa <> xb)) + _ -> if leftWins o then a else b + +-- | Combine two dictionaries key by key. +coalesceDict :: Order -> Dict -> Dict -> Dict +coalesceDict o = Map.unionWith (coalesce o) + +-- | Combine per-profile data. +coalesceData :: Order -> Map Profile Dict -> Map Profile Dict -> Map Profile Dict +coalesceData o = Map.unionWith (coalesceDict o) + +-- | Combine selected-profile hints. +coalesceProfile :: Order -> Profile -> Profile -> Profile +coalesceProfile o a b = if leftWins o then a else b diff --git a/src/Figment/Metadata.hs b/src/Figment/Metadata.hs new file mode 100644 --- /dev/null +++ b/src/Figment/Metadata.hs @@ -0,0 +1,113 @@ +-- | Where configuration values come from. +module Figment.Metadata + ( Metadata (..) + , Source (..) + , Pos (..) + , named + , fileMetadata + , withSource + , withInterpolater + , withAddedAt + , interpolate + , renderSource + , renderSrcLoc + ) where + +import Control.DeepSeq (NFData (..), rwhnf) +import Data.Text (Text) +import qualified Data.Text as Text +import GHC.Generics (Generic) +import GHC.Stack (SrcLoc (..)) + +import Figment.Path (Path, renderPath) +import Figment.Profile (Profile) + +-- | A one-based line and column in a source text. +data Pos = Pos + { posLine :: !Int + , posColumn :: !Int + } + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +-- | The origin of a provider's data. +data Source + = FileSource !FilePath -- ^ a file on disk (resolved path) + | CodeSource !SrcLoc -- ^ values written in Haskell code + | CustomSource !Text -- ^ anything else (\"environment\", a URL, ...) + deriving stock (Eq, Show, Generic) + +instance NFData Source where + rnf (FileSource p) = rnf p + rnf (CodeSource l) = l `seq` () + rnf (CustomSource t) = rnf t + +-- | Everything known about a provider. +-- +-- 'metaInterpolate' turns a key path back into the provider's own +-- vocabulary, e.g. @db.port@ into @APP_DB\__PORT@ for environment +-- variables or @--db.port@ for CLI arguments; error messages and +-- missing-field hints use it so users are told what to /type/. +data Metadata = Metadata + { metaName :: !Text + , metaSource :: !(Maybe Source) + , metaAddedAt :: !(Maybe SrcLoc) + , metaInterpolate :: Profile -> Path -> Text + } + deriving stock (Generic) + +-- | Equality ignores the interpolation function (functions have no +-- equality); two metadata are equal when they name the same source +-- added at the same place. +instance Eq Metadata where + a == b = + metaName a == metaName b + && metaSource a == metaSource b + && metaAddedAt a == metaAddedAt b + +instance Show Metadata where + showsPrec d m = showParen (d > 10) $ + showString "Metadata {metaName = " . shows (metaName m) + . showString ", metaSource = " . shows (metaSource m) + . showString ", metaAddedAt = " . shows (metaAddedAt m) + . showString "}" + +instance NFData Metadata where + rnf (Metadata n s a i) = rnf n `seq` rnf s `seq` maybe () (`seq` ()) a `seq` rwhnf i + +-- | Metadata with a name and the default interpolater (the rendered +-- key path). +named :: Text -> Metadata +named n = Metadata n Nothing Nothing (const renderPath) + +-- | Metadata for a file-backed source. +fileMetadata :: Text -> FilePath -> Metadata +fileMetadata n p = withSource (FileSource p) (named n) + +-- | Set the source. +withSource :: Source -> Metadata -> Metadata +withSource s m = m {metaSource = Just s} + +-- | Replace the key-name renderer. +withInterpolater :: (Profile -> Path -> Text) -> Metadata -> Metadata +withInterpolater f m = m {metaInterpolate = f} + +-- | Record where the provider was added. +withAddedAt :: SrcLoc -> Metadata -> Metadata +withAddedAt l m = m {metaAddedAt = Just l} + +-- | The provider-native name of a key. +interpolate :: Metadata -> Profile -> Path -> Text +interpolate = metaInterpolate + +-- | A short rendering of a source. +renderSource :: Source -> Text +renderSource (FileSource p) = Text.pack p +renderSource (CodeSource l) = renderSrcLoc l +renderSource (CustomSource t) = t + +-- | @file:line:column@. +renderSrcLoc :: SrcLoc -> Text +renderSrcLoc l = + Text.pack (srcLocFile l) <> ":" <> Text.pack (show (srcLocStartLine l)) + <> ":" <> Text.pack (show (srcLocStartCol l)) diff --git a/src/Figment/Partial.hs b/src/Figment/Partial.hs new file mode 100644 --- /dev/null +++ b/src/Figment/Partial.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Higher-kinded partial configurations. +-- +-- Write a configuration record once, parameterised by a functor: +-- +-- > data AppF f = App +-- > { host :: Field f Text +-- > , port :: Field f Int +-- > , db :: DbF f -- nested partial record +-- > } deriving stock Generic +-- > instance Partial AppF +-- > type App = AppF Identity -- fields are plain: host :: Text +-- +-- @AppF Maybe@ is the /partial/ form: every field optional. Defaults +-- are written as a partial value, merged under whatever the providers +-- supplied, and 'complete' turns the result into the total @AppF +-- Identity@, reporting /every/ missing field (with the env var, CLI +-- flag, or file key that would have set it) rather than the first. +-- +-- The compile-time guarantee: 'Figment.extractTotal' takes a total +-- @AppF Identity@ as its defaults, so a missing-field error is +-- impossible by construction; only type errors remain. +module Figment.Partial + ( Field + , Partial (..) + , GPartial + ) where + +import Control.Applicative ((<|>)) +import Data.Functor.Identity (Identity (..)) +import Data.Kind (Type) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as Text +import GHC.Generics +import GHC.TypeLits (ErrorMessage (..), TypeError) + +import Figment.Decode +import Figment.Error +import Figment.Path +import Figment.Value + +-- | @Field Identity a = a@, so the total record has ordinary fields; +-- @Field Maybe a = Maybe a@ for the partial record. +type family Field (f :: Type -> Type) (a :: Type) :: Type where + Field Identity a = a + Field f a = f a + +-- | Records whose fields are 'Field's or nested 'Partial' records. +-- Every method has a generic default: @instance Partial AppF@ suffices. +class Partial (c :: (Type -> Type) -> Type) where + -- | Decode whatever is present; absent fields are 'Nothing'. Type + -- errors in present fields are reported (all of them). + partialDecoder :: Options -> Decoder (c Maybe) + default partialDecoder + :: (Generic (c Maybe), GPartial (Rep (c Maybe)) (Rep (c Identity))) + => Options -> Decoder (c Maybe) + partialDecoder o = to <$> mkDecoder (\c v -> case valueNode v of + Dict m -> recordCheck o (gpnames @(Rep (c Maybe)) @(Rep (c Identity)) o) c m + (gpfields @(Rep (c Maybe)) @(Rep (c Identity)) o c m) + n -> Failure (single (atValue c v (InvalidType (describe n) "a dictionary")))) + + -- | Right-biased combination: fields set on the right win. + overlay :: c Maybe -> c Maybe -> c Maybe + default overlay + :: (Generic (c Maybe), GPartial (Rep (c Maybe)) (Rep (c Identity))) + => c Maybe -> c Maybe -> c Maybe + overlay a b = to (goverlay @(Rep (c Maybe)) @(Rep (c Identity)) (from a) (from b)) + + -- | The partial value with nothing set. + emptyPartial :: c Maybe + default emptyPartial + :: (Generic (c Maybe), GPartial (Rep (c Maybe)) (Rep (c Identity))) + => c Maybe + emptyPartial = to (gempty @(Rep (c Maybe)) @(Rep (c Identity))) + + -- | The total value, or the (relative) paths of every required field + -- that is still missing. Fields whose type has a 'missingValue' + -- (e.g. 'Maybe') are never missing. + complete :: Options -> c Maybe -> Either (NonEmpty Path) (c Identity) + default complete + :: (Generic (c Maybe), Generic (c Identity), GPartial (Rep (c Maybe)) (Rep (c Identity))) + => Options -> c Maybe -> Either (NonEmpty Path) (c Identity) + complete o p = case gcomplete @(Rep (c Maybe)) @(Rep (c Identity)) o root (from p) of + Left (x : xs) -> Left (x :| xs) + Left [] -> Left (root :| []) + Right r -> Right (to r) + + -- | Embed a total value (every field set). + total :: c Identity -> c Maybe + default total + :: (Generic (c Maybe), Generic (c Identity), GPartial (Rep (c Maybe)) (Rep (c Identity))) + => c Identity -> c Maybe + total = to . gtotal @(Rep (c Maybe)) @(Rep (c Identity)) . from + +-- | Accumulating completion. +type Completion a = Either [Path] a + +both :: Completion (a -> b) -> Completion a -> Completion b +both (Left a) (Left b) = Left (a ++ b) +both (Left a) (Right _) = Left a +both (Right _) (Left b) = Left b +both (Right f) (Right x) = Right (f x) + +-- | Generic machinery behind 'Partial's defaults. +class GPartial (pm :: Type -> Type) (pi :: Type -> Type) where + gpfields :: Options -> DecodeContext -> Dict -> Result (pm x) + gpnames :: Options -> [Text] + goverlay :: pm x -> pm x -> pm x + gempty :: pm x + gcomplete :: Options -> Path -> pm x -> Completion (pi x) + gtotal :: pi x -> pm x + +instance GPartial pm pi => GPartial (D1 d pm) (D1 d pi) where + gpfields o c m = M1 <$> gpfields @pm @pi o c m + gpnames o = gpnames @pm @pi o + goverlay (M1 a) (M1 b) = M1 (goverlay @pm @pi a b) + gempty = M1 (gempty @pm @pi) + gcomplete o p (M1 a) = M1 <$> gcomplete @pm @pi o p a + gtotal (M1 a) = M1 (gtotal @pm @pi a) + +instance GPartial pm pi => GPartial (C1 c pm) (C1 c pi) where + gpfields o c m = M1 <$> gpfields @pm @pi o c m + gpnames o = gpnames @pm @pi o + goverlay (M1 a) (M1 b) = M1 (goverlay @pm @pi a b) + gempty = M1 (gempty @pm @pi) + gcomplete o p (M1 a) = M1 <$> gcomplete @pm @pi o p a + gtotal (M1 a) = M1 (gtotal @pm @pi a) + +instance (GPartial am ai, GPartial bm bi) => GPartial (am :*: bm) (ai :*: bi) where + gpfields o c m = (:*:) <$> gpfields @am @ai o c m <*> gpfields @bm @bi o c m + gpnames o = gpnames @am @ai o ++ gpnames @bm @bi o + goverlay (a :*: b) (a' :*: b') = goverlay @am @ai a a' :*: goverlay @bm @bi b b' + gempty = gempty @am @ai :*: gempty @bm @bi + gcomplete o p (a :*: b) = fmap (:*:) (gcomplete @am @ai o p a) `both` gcomplete @bm @bi o p b + gtotal (a :*: b) = gtotal @am @ai a :*: gtotal @bm @bi b + +instance GPartial U1 U1 where + gpfields _ _ _ = Success U1 + gpnames _ = [] + goverlay _ _ = U1 + gempty = U1 + gcomplete _ _ _ = Right U1 + gtotal _ = U1 + +-- | A leaf field: @Field f a@. +instance (Selector s, FromConfig a) => GPartial (S1 s (Rec0 (Maybe a))) (S1 s (Rec0 a)) where + gpfields o c m = + let name = selKey @s o + in case Map.lookup name m of + Just v -> M1 . K1 . Just <$> runIn c {ctxPath = ctxPath c /. name} v + Nothing -> Success (M1 (K1 Nothing)) + gpnames o = [selKey @s o] + goverlay (M1 (K1 a)) (M1 (K1 b)) = M1 (K1 (b <|> a)) + gempty = M1 (K1 Nothing) + gcomplete o p (M1 (K1 m)) = case m <|> missingValue @a of + Just a -> Right (M1 (K1 a)) + Nothing -> Left [p /. selKey @s o] + gtotal (M1 (K1 a)) = M1 (K1 (Just a)) + +-- | A nested partial record. +instance (Selector s, Partial b) => GPartial (S1 s (Rec0 (b Maybe))) (S1 s (Rec0 (b Identity))) where + gpfields o c m = + let name = Text.pack (fieldLabelModifier o (selName (SP :: SP s U1 ()))) + in case Map.lookup name m of + Just v -> M1 . K1 <$> runDecoderIn (partialDecoder @b o) c {ctxPath = ctxPath c /. name} v + Nothing -> Success (M1 (K1 (emptyPartial @b))) + gpnames o = [Text.pack (fieldLabelModifier o (selName (SP :: SP s U1 ())))] + goverlay (M1 (K1 a)) (M1 (K1 b)) = M1 (K1 (overlay @b a b)) + gempty = M1 (K1 (emptyPartial @b)) + gcomplete o p (M1 (K1 m)) = + let here = p /. Text.pack (fieldLabelModifier o (selName (SP :: SP s U1 ()))) + in case complete @b o m of + Right r -> Right (M1 (K1 r)) + Left ps -> Left (map (here <>) (NE.toList ps)) + gtotal (M1 (K1 a)) = M1 (K1 (total @b a)) + +instance + TypeError ('Text "figment: a Partial configuration must be a record with a single constructor") + => GPartial (f :+: g) (f' :+: g') + where + gpfields _ _ _ = Failure (single (configError (Message "unreachable"))) + gpnames _ = [] + goverlay a _ = a + gempty = gempty @(f :+: g) @(f' :+: g') + gcomplete _ _ _ = Left [] + gtotal _ = gempty @(f :+: g) @(f' :+: g') + +-- helpers ---------------------------------------------------------------- + +data SP (s :: Meta) (f :: Type -> Type) a = SP + +selKey :: forall (s :: Meta). Selector s => Options -> Text +selKey o = Text.pack (fieldLabelModifier o (selName (SP :: SP s U1 ()))) + +-- | Run 'fromConfig' at an explicit context. +runIn :: FromConfig a => DecodeContext -> Value -> Result a +runIn = decodeWith fromConfig + +runDecoderIn :: Decoder a -> DecodeContext -> Value -> Result a +runDecoderIn = decodeWith + +-- | Unknown-field check, accumulated together with the field results. +recordCheck :: Options -> [Text] -> DecodeContext -> Dict -> Result a -> Result a +recordCheck o known c m fields = + let unknown = + [ single (atValue c {ctxPath = ctxPath c /. key} x (UnknownField key (suggest key known))) + | rejectUnknownFields o, (key, x) <- Map.toList m, key `notElem` known ] + in case unknown of + [] -> fields + (e : es) -> Failure (foldl (<>) e es) <* fields + +atValue :: DecodeContext -> Value -> ErrorKind -> ConfigError +atValue c x kind = + let t = valueTag x + in ConfigError kind (ctxPath c) (tagProfile t) (tagMeta t) (tagPos t) [] diff --git a/src/Figment/Path.hs b/src/Figment/Path.hs new file mode 100644 --- /dev/null +++ b/src/Figment/Path.hs @@ -0,0 +1,162 @@ +-- | Key paths into a configuration tree. +-- +-- A t'Path' is a sequence of 'Segment's: either a dictionary 'Key' or an +-- array 'Index'. Keeping the two apart (rather than encoding indices as +-- text) means key @"0"@ and index @0@ can never be confused, and error +-- messages can render @servers[2].port@ faithfully. +module Figment.Path + ( Segment (..) + , Path + , root + , isRoot + , segments + , fromSegments + , (/.) + , (/#) + , keyPath + , parsePath + , renderPath + , renderSegment + ) where + +import Control.DeepSeq (NFData) +import Data.Char (isAlphaNum, isDigit) +import Data.Foldable (toList) +import Data.Sequence (Seq, (|>)) +import qualified Data.Sequence as Seq +import Data.Text (Text) +import qualified Data.Text as Text +import GHC.Generics (Generic) + +-- | One step into a configuration tree. +data Segment + = Key !Text -- ^ a dictionary key + | Index !Int -- ^ a zero-based array index + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +-- | A location in a configuration tree, from the root. Appending is +-- O(1) ('Seq' snoc), so building paths while descending is linear. +newtype Path = Path (Seq Segment) + deriving stock (Eq, Ord, Generic) + deriving anyclass (NFData) + +instance Show Path where + showsPrec d p = showParen (d > 10) $ + showString "keyPath " . shows (renderPath p) + +instance Semigroup Path where + Path a <> Path b = Path (a <> b) + +instance Monoid Path where + mempty = root + +-- | The empty path: the top of the tree. +root :: Path +root = Path Seq.empty + +-- | Is this the root path? +isRoot :: Path -> Bool +isRoot (Path s) = Seq.null s + +-- | The segments of a path, from the root. +segments :: Path -> [Segment] +segments (Path s) = toList s + +-- | Build a path from segments. +fromSegments :: [Segment] -> Path +fromSegments = Path . Seq.fromList + +-- | Extend a path with a key. +(/.) :: Path -> Text -> Path +Path s /. k = Path (s |> Key k) +infixl 5 /. + +-- | Extend a path with an index. +(/#) :: Path -> Int -> Path +Path s /# i = Path (s |> Index i) +infixl 5 /# + +-- | A dotted key path, as used by Rust figment: @"db.host"@ is +-- @[Key "db", Key "host"]@. Total: empty segments are kept as empty keys +-- (so @keyPath ""@ is the single empty key, never an error). Use +-- 'parsePath' to read the full rendered syntax including indices and +-- quoted keys. +keyPath :: Text -> Path +keyPath t = fromSegments (map Key (Text.splitOn "." t)) + +-- | Render a path: keys joined with @.@, indices as @[n]@, and keys that +-- are not plain identifiers double-quoted. The root renders as the empty +-- text. @parsePath . renderPath == Right@. +renderPath :: Path -> Text +renderPath (Path s) = go True (toList s) + where + go _ [] = Text.empty + go first (seg : rest) = piece first seg <> go False rest + piece _ (Index i) = "[" <> Text.pack (show i) <> "]" + piece first (Key k) = (if first then "" else ".") <> renderKey k + +-- | Render a single segment on its own. +renderSegment :: Segment -> Text +renderSegment (Index i) = "[" <> Text.pack (show i) <> "]" +renderSegment (Key k) = renderKey k + +renderKey :: Text -> Text +renderKey k + | not (Text.null k) && Text.all plain k = k + | otherwise = "\"" <> Text.concatMap esc k <> "\"" + where + plain c = isAlphaNum c || c == '_' || c == '-' + esc '"' = "\\\"" + esc '\\' = "\\\\" + esc c = Text.singleton c + +-- | Parse the syntax produced by 'renderPath'. +parsePath :: Text -> Either Text Path +parsePath t0 + | Text.null t0 = Right root + | otherwise = fromSegments . reverse <$> start [] t0 + where + start acc t = do + (seg, rest) <- keySeg t + more (seg : acc) rest + + more acc t = case Text.uncons t of + Nothing -> Right acc + Just ('.', rest) -> do + (seg, rest') <- keySeg rest + more (seg : acc) rest' + Just ('[', rest) -> do + let (ds, rest') = Text.span isDigit rest + case Text.uncons rest' of + Just (']', rest'') | not (Text.null ds) -> + more (Index (read (Text.unpack ds)) : acc) rest'' + _ -> Left ("malformed index in path " <> quoted t0) + Just (c, _) -> Left ("unexpected " <> Text.pack (show c) <> " in path " <> quoted t0) + + keySeg t = case Text.uncons t of + Just ('[', _) -> idxFirst t + Just ('"', rest) -> quotedKey "" rest + _ -> + let (k, rest) = Text.span (\c -> c /= '.' && c /= '[') t + in if Text.null k + then Left ("empty key in path " <> quoted t0) + else Right (Key k, rest) + + idxFirst t = case Text.uncons t of + Just ('[', rest) -> + let (ds, rest') = Text.span isDigit rest + in case Text.uncons rest' of + Just (']', rest'') | not (Text.null ds) -> Right (Index (read (Text.unpack ds)), rest'') + _ -> Left ("malformed index in path " <> quoted t0) + _ -> Left ("malformed path " <> quoted t0) + + quotedKey acc t = case Text.uncons t of + Nothing -> Left ("unterminated quoted key in path " <> quoted t0) + Just ('"', rest) -> Right (Key acc, rest) + Just ('\\', rest) -> case Text.uncons rest of + Just (c, rest') -> quotedKey (Text.snoc acc c) rest' + Nothing -> Left ("dangling escape in path " <> quoted t0) + Just (c, rest) -> quotedKey (Text.snoc acc c) rest + + quoted x = "`" <> x <> "`" diff --git a/src/Figment/Profile.hs b/src/Figment/Profile.hs new file mode 100644 --- /dev/null +++ b/src/Figment/Profile.hs @@ -0,0 +1,69 @@ +-- | Profiles: named slices of configuration ("semi-hierarchical" +-- configuration, as in Rust figment). +-- +-- Every provider yields one dictionary per profile. On extraction, the +-- 'Default' profile is merged with the selected profile, and the +-- 'Global' profile is merged over both. +module Figment.Profile + ( Profile (Default, Global) + , profile + , profileName + , isCustom + , profileFromEnv + ) where + +import Control.DeepSeq (NFData) +import Data.String (IsString (..)) +import Data.Text (Text) +import qualified Data.Text as Text +import GHC.Generics (Generic) +import System.Environment (lookupEnv) + +-- | A configuration profile. Custom profile names are case-insensitive +-- (stored lower-cased), matching Rust figment. The 'Named' constructor +-- is not exported: use 'profile', which maps @"default"@ and +-- @"global"@ to the built-in profiles so there is exactly one +-- representation of each. +data Profile + = Default + | Global + | Named !Text + deriving stock (Eq, Ord, Generic) + deriving anyclass (NFData) + +instance Show Profile where + showsPrec _ Default = showString "Default" + showsPrec _ Global = showString "Global" + showsPrec d (Named t) = showParen (d > 10) $ showString "profile " . shows t + +instance IsString Profile where + fromString = profile . Text.pack + +-- | Smart constructor. Case-insensitive; surrounding whitespace is +-- ignored; the empty name is 'Default'. +profile :: Text -> Profile +profile raw = case Text.toLower (Text.strip raw) of + "" -> Default + "default" -> Default + "global" -> Global + t -> Named t + +-- | The canonical (lower-case) name of a profile. +profileName :: Profile -> Text +profileName Default = "default" +profileName Global = "global" +profileName (Named t) = t + +-- | Is this a user-defined profile (neither 'Default' nor 'Global')? +isCustom :: Profile -> Bool +isCustom (Named _) = True +isCustom _ = False + +-- | Read a profile from an environment variable, falling back to the +-- given profile when it is unset or empty (Rust: @Profile::from_env_or@). +profileFromEnv :: String -> Profile -> IO Profile +profileFromEnv var fallback = do + v <- lookupEnv var + pure $ case v of + Just s | not (null s) -> fromString s + _ -> fallback diff --git a/src/Figment/Provider/Cli.hs b/src/Figment/Provider/Cli.hs new file mode 100644 --- /dev/null +++ b/src/Figment/Provider/Cli.hs @@ -0,0 +1,128 @@ +-- | Command-line arguments as a provider. +-- +-- Rules (ADR 010, revised): +-- +-- * @--key=value@ sets @key@; the value is parsed like an environment +-- variable (numbers, booleans, arrays, ...; original text kept). +-- * @--flag@ sets @flag = true@; @--no-flag@ sets @flag = false@. +-- * Dots nest (@--db.port=5432@) and dashes become underscores +-- (@--max-connections@ is @max_connections@); keys are not +-- lower-cased. +-- * @--@ ends option parsing. Anything else (including @-x@ short +-- options) is positional and returned by 'parseArgs'; the provider +-- ignores it. +-- * @--key value@ is /not/ supported: without a schema it is ambiguous +-- with a flag followed by a positional argument. For rich CLIs, parse +-- with optparse-applicative and feed the result in via +-- 'Figment.Aeson.defaults'. +-- * Repeating a key: the last occurrence wins. A malformed option +-- (@--=x@, @--a..b=1@) is an error, not silently ignored. +module Figment.Provider.Cli + ( Cli + , cli + , cliFromProcess + , keyMap + , unparsedCli + , cliInProfile + , parseArgs + , Arg (..) + ) where + +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as Text +import System.Environment (getArgs) + +import Figment.Core +import Figment.Error +import Figment.Internal.Nest +import Figment.Internal.ValueParser (parseValue) +import Figment.Limits +import Figment.Metadata +import Figment.Path +import Figment.Profile +import Figment.Value + +-- | Command-line arguments as a configuration source (see the module header for the rules). +data Cli = Cli + { cliArgs :: [Text] + , cliKeyMap :: Text -> Text + , cliParsed :: Bool + , cliProfile :: Profile + } + +-- | A CLI provider over the given arguments. +cli :: [Text] -> Cli +cli args = Cli args (Text.replace "-" "_") True Default + +-- | The arguments of the running process. +cliFromProcess :: IO Cli +cliFromProcess = cli . map Text.pack <$> getArgs + +-- | How each key segment is mapped (default: dashes to underscores). +keyMap :: (Text -> Text) -> Cli -> Cli +keyMap f c = c {cliKeyMap = f} + +-- | Do not parse values: every value is a string. +unparsedCli :: Cli -> Cli +unparsedCli c = c {cliParsed = False} + +-- | Put the values in a profile other than 'Default'. +cliInProfile :: Profile -> Cli -> Cli +cliInProfile p c = c {cliProfile = p} + +-- | One classified argument. +data Arg + = Option !Text ![Text] !(Maybe Text) + -- ^ original argument, key segments, value (@Nothing@: a flag) + | NegatedFlag !Text ![Text] + | Positional !Text + | Malformed !Text + deriving stock (Eq, Show) + +-- | Classify every argument. +parseArgs :: Cli -> [Arg] +parseArgs c = go (cliArgs c) + where + go [] = [] + go ("--" : rest) = map Positional rest + go (a : rest) = classify a : go rest + classify a = case Text.stripPrefix "--" a of + Nothing -> Positional a + Just body -> + let (k, eqv) = Text.breakOn "=" body + v = if Text.null eqv then Nothing else Just (Text.drop 1 eqv) + in case keySegs k of + Nothing -> Malformed a + Just segs -> case (v, Text.stripPrefix "no-" k) of + (Nothing, Just positive) | Just segs' <- keySegs positive -> NegatedFlag a segs' + _ -> Option a segs v + keySegs k + | Text.null k = Nothing + | otherwise = + let segs = map (cliKeyMap c) (Text.splitOn "." k) + in if any Text.null segs then Nothing else Just segs + +instance Provider Cli where + metadata _ = + withInterpolater (\_ p -> "--" <> Text.intercalate "." [Text.replace "_" "-" k | Key k <- segments p]) $ + named "command-line arguments" + provide lim c = pure $ + let args = parseArgs c + malformed = [ atPath root (configError (SyntaxError ("malformed option `" <> a <> "`"))) | Malformed a <- args ] + entries = concatMap (entry lim c) args + failures = malformed ++ [e | Left e <- entries] + in case fromErrorList failures of + Just es -> Left es + Nothing -> Map.singleton (cliProfile c) <$> nest LastWins [x | Right x <- entries] + +entry :: Limits -> Cli -> Arg -> [Either ConfigError (Text, [Text], Value)] +entry lim c = \case + Option a segs (Just v) + | cliParsed c -> [(a, segs, ) <$> parseValue lim v] + | otherwise -> [Right (a, segs, Value untagged {tagRaw = Just v} (String v))] + Option a segs Nothing -> [Right (a, segs, flag True)] + NegatedFlag a segs -> [Right (a, segs, flag False)] + _ -> [] + where + flag b = Value untagged {tagRaw = Just (if b then "true" else "false")} (Bool b) diff --git a/src/Figment/Provider/Env.hs b/src/Figment/Provider/Env.hs new file mode 100644 --- /dev/null +++ b/src/Figment/Provider/Env.hs @@ -0,0 +1,164 @@ +-- | Environment variables, with Rust figment's semantics. +-- +-- > import qualified Figment.Provider.Env as Env +-- > Env.prefixed "APP_" -- APP_MAX_CONNECTIONS -> max_connections +-- > Env.prefixed "APP_" & Env.split "__" -- APP_DB__HOST -> db.host +-- +-- * The prefix is matched case-insensitively and stripped. +-- * Keys are lower-cased (see 'lowercase'). +-- * There is no splitting unless 'split' is used, so fields whose names +-- contain underscores remain reachable. As in Rust figment, a @.@ in a +-- key (after any 'split') nests, and variables with an empty key +-- segment are ignored. +-- * Values are parsed: @8080@ is a number, @true@ a boolean, @[1, 2]@ +-- an array, @{a = 1}@ a dictionary; anything else is a string. The +-- original text is kept, so 'Text' fields still receive @007@ +-- verbatim. Use 'unparsed' to keep every value a string. +-- * Two variables that cannot both hold (@APP_DB=x@ and @APP_DB.HOST=y@, +-- or two names that are equal after lower-casing) are reported as +-- errors rather than one silently winning. +module Figment.Provider.Env + ( Env + , prefixed + , raw + , split + , lowercase + , ignoreEmpty + , only + , ignore + , filterKeys + , mapKeys + , inProfile + , global + , unparsed + , fromList + , envVariableName + ) where + +import Data.List (sortOn) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as Text +import System.Environment (getEnvironment) + +import Figment.Core +import Figment.Error +import Figment.Internal.Nest +import Figment.Internal.ValueParser (parseValue) +import Figment.Metadata +import Figment.Path +import Figment.Profile +import Figment.Value + +-- | Environment variables as a configuration source; build with 'prefixed' or 'raw'. +data Env = Env + { envPrefix :: !Text + , envChain :: [Text -> Maybe Text] + -- ^ key transformations, applied in the order they were added + , envSplit :: !(Maybe Text) + , envLower :: !Bool + , envIgnoreEmpty :: !Bool + , envProfile :: !Profile + , envParsed :: !Bool + , envSnapshot :: !(Maybe [(Text, Text)]) + } + +-- | Variables starting with the prefix (case-insensitive), prefix +-- removed. +prefixed :: Text -> Env +prefixed p = Env p [] Nothing True False Default True Nothing + +-- | Every environment variable. +raw :: Env +raw = prefixed "" + +-- | Nest on a separator: with @split \"\__\"@, @APP_DB\__HOST@ is @db.host@. +split :: Text -> Env -> Env +split sep e + | Text.null sep = e + | otherwise = e {envSplit = Just sep, envChain = envChain e ++ [Just . Text.replace sep "."]} + +-- | Lower-case keys (default 'True'). +lowercase :: Bool -> Env -> Env +lowercase b e = e {envLower = b} + +-- | Skip variables whose value is empty (default 'False'). +ignoreEmpty :: Bool -> Env -> Env +ignoreEmpty b e = e {envIgnoreEmpty = b} + +-- | Keep only these keys (compared case-insensitively, after the prefix +-- and any earlier transformations). +only :: [Text] -> Env -> Env +only ks = filterKeys (\k -> Text.toCaseFold k `elem` map Text.toCaseFold ks) + +-- | Drop these keys (compared case-insensitively). +ignore :: [Text] -> Env -> Env +ignore ks = filterKeys (\k -> Text.toCaseFold k `notElem` map Text.toCaseFold ks) + +-- | Keep only keys satisfying a predicate (applied in order with other key transformations). +filterKeys :: (Text -> Bool) -> Env -> Env +filterKeys f e = e {envChain = envChain e ++ [\k -> if f k then Just k else Nothing]} + +-- | Transform keys (applied in order with other key transformations). +mapKeys :: (Text -> Text) -> Env -> Env +mapKeys f e = e {envChain = envChain e ++ [Just . f]} + +-- | Put the values in a profile (default 'Default'). +inProfile :: Profile -> Env -> Env +inProfile p e = e {envProfile = p} + +-- | Put the values in the 'Global' profile, overriding every profile. +global :: Env -> Env +global = inProfile Global + +-- | Do not parse values: every value is a string. +unparsed :: Env -> Env +unparsed e = e {envParsed = False} + +-- | Read from the given variables instead of the process environment +-- (deterministic tests, or environments assembled by hand). +fromList :: [(Text, Text)] -> Env -> Env +fromList vs e = e {envSnapshot = Just vs} + +-- | The variable name that sets a key path, assuming no custom +-- 'mapKeys' (used in error messages and missing-field hints). +envVariableName :: Env -> Path -> Text +envVariableName e p = + envPrefix e <> Text.intercalate (fromMaybe "." (envSplit e)) [Text.toUpper k | Key k <- segments p] + +keyOf :: Env -> Text -> Maybe [Text] +keyOf e name = do + rest <- stripPrefixCI (envPrefix e) name + k <- foldl (\acc f -> acc >>= f) (Just rest) (envChain e) + let k' = if envLower e then Text.toLower k else k + segs = Text.splitOn "." k' + if Text.null k' || any Text.null segs then Nothing else Just segs + +stripPrefixCI :: Text -> Text -> Maybe Text +stripPrefixCI p t + | Text.toCaseFold (Text.take (Text.length p) t) == Text.toCaseFold p = Just (Text.drop (Text.length p) t) + | otherwise = Nothing + +instance Provider Env where + metadata e = + withInterpolater (\_ p -> envVariableName e p) $ + named (if Text.null (envPrefix e) then "environment variables" else "environment variables (prefix " <> envPrefix e <> ")") + provide lim e = do + vars <- case envSnapshot e of + Just vs -> pure vs + Nothing -> map (\(k, v) -> (Text.pack k, Text.pack v)) <$> getEnvironment + let relevant = + [ (name, ks, val) + | (name, val) <- sortOn fst vars + , not (envIgnoreEmpty e && Text.null val) + , Just ks <- [keyOf e name] + ] + parsed = [ (name, ks, ) <$> parse val | (name, ks, val) <- relevant ] + parse val + | envParsed e = parseValue lim val + | otherwise = Right (Value untagged {tagRaw = Just val} (String val)) + failures = [ err | Left err <- parsed ] + pure $ case fromErrorList failures of + Just es -> Left es + Nothing -> Map.singleton (envProfile e) <$> nest RejectDuplicates [x | Right x <- parsed] diff --git a/src/Figment/Provider/Format.hs b/src/Figment/Provider/Format.hs new file mode 100644 --- /dev/null +++ b/src/Figment/Provider/Format.hs @@ -0,0 +1,154 @@ +-- | File- and string-backed providers for any data format (Rust: +-- @Format@ / @Data\@). +-- +-- > F.merge (file toml "App.toml") -- optional, searched upward +-- > F.merge (required (fileExact json "/etc/app.json")) +-- > F.merge (nested (file yaml "profiles.yaml")) -- top-level keys are profiles +module Figment.Provider.Format + ( Format (..) + , Data + , file + , fileExact + , fromText + , nested + , required + , inProfile + ) where + +import Control.Exception (IOException, try) +import qualified Data.ByteString as BS +import Data.ByteString (ByteString) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as TE +import System.Directory (doesFileExist, getCurrentDirectory, makeAbsolute) +import System.FilePath (isRelative, takeDirectory, ()) + +import Figment.Core +import Figment.Error +import Figment.Limits +import Figment.Metadata +import Figment.Path +import Figment.Profile +import Figment.Value + +-- | A data format: a name and a parser. The parser must enforce the +-- 'Limits' and should record 'tagPos' on values when it can. +data Format = Format + { formatName :: Text + , formatParse :: Limits -> ByteString -> IO (Either ConfigError Value) + } + +data Origin + = FromFile !FilePath !Bool -- ^ path, search parent directories? + | FromText !Text + +-- | A file or string in some t'Format'; build with 'file', 'fileExact' or 'fromText'. +data Data = Data + { dataFormat :: Format + , dataOrigin :: Origin + , dataNested :: Bool + , dataRequired :: Bool + , dataProfile :: Profile + } + +-- | An optional file. A relative path is looked for in the working +-- directory and then each parent directory (as Rust figment does); a +-- missing file contributes nothing. Combine with 'required' to make +-- absence an error. +file :: Format -> FilePath -> Data +file f p = Data f (FromFile p True) False False Default + +-- | Like 'file', but only the exact path is tried. +fileExact :: Format -> FilePath -> Data +fileExact f p = Data f (FromFile p False) False False Default + +-- | Configuration text held in memory (Rust: @Format::string@). +fromText :: Format -> Text -> Data +fromText f t = Data f (FromText t) False False Default + +-- | Treat top-level keys as profile names. +nested :: Data -> Data +nested d = d {dataNested = True} + +-- | Fail if the file cannot be found. +required :: Data -> Data +required d = d {dataRequired = True} + +-- | Put the data in a profile other than 'Default' (ignored when +-- 'nested'). +inProfile :: Profile -> Data -> Data +inProfile p d = d {dataProfile = p} + +baseMetadata :: Data -> Maybe FilePath -> Metadata +baseMetadata d resolved = + let fmt = formatName (dataFormat d) + m = case (dataOrigin d, resolved) of + (_, Just p) -> fileMetadata (fmt <> " file") p + (FromFile p _, Nothing) -> fileMetadata (fmt <> " file") p + (FromText _, Nothing) -> named (fmt <> " source string") + interp + | dataNested d = \prof path -> profileName prof <> (if isRoot path then "" else "." <> renderPath path) + | otherwise = const renderPath + in withInterpolater interp m + +instance Provider Data where + metadata d = baseMetadata d Nothing + provide lim d = case dataOrigin d of + FromText t -> parseWith (baseMetadata d Nothing) (TE.encodeUtf8 t) + FromFile p search -> do + found <- locate search p + case found of + Nothing + | dataRequired d -> + pure (Left (single (withMetadata (Just (baseMetadata d Nothing)) + (configError (IoError ("file not found: " <> Text.pack p + <> (if search && isRelative p then " (searched the working directory and its parents)" else ""))))))) + | otherwise -> pure (Right Map.empty) + Just resolved -> do + let meta = baseMetadata d (Just resolved) + r <- try (BS.readFile resolved) + case r of + Left (e :: IOException) -> + pure (Left (single (withMetadata (Just meta) (configError (IoError (Text.pack (show e))))))) + Right bytes -> parseWith meta bytes + where + parseWith meta bytes = do + parsed <- formatParse (dataFormat d) lim bytes + pure $ case parsed of + Left e -> Left (single (withMetadata (Just meta) e)) + Right v -> case valueNode v of + Dict top + | dataNested d -> splitProfiles meta top + | otherwise -> Right (Map.singleton (dataProfile d) (fmap (retag meta (dataProfile d)) top)) + n -> Left (single (withMetadata (Just meta) (withPos (tagPos (valueTag v)) + (configError (InvalidType (describe n) "a dictionary at the top level"))))) + + splitProfiles meta top = + let one (k, v) = case valueNode v of + Dict d' -> let p = profile k in Right (p, fmap (retag meta p) d') + n -> Left (withMetadata (Just meta) (withPos (tagPos (valueTag v)) + (atPath (root /. k) (configError (InvalidType (describe n) "a dictionary (nested files map profile names to dictionaries)"))))) + results = map one (Map.toList top) + in case fromErrorList [e | Left e <- results] of + Just es -> Left es + Nothing -> Right (Map.fromListWith (\later earlier -> Map.union earlier later) [x | Right x <- results]) + +-- | Find a file, optionally searching parent directories. Returns an +-- absolute path. +locate :: Bool -> FilePath -> IO (Maybe FilePath) +locate search p + | search && isRelative p = getCurrentDirectory >>= go + | otherwise = do + ok <- doesFileExist p + if ok then Just <$> makeAbsolute p else pure Nothing + where + go dir = do + let candidate = dir p + ok <- doesFileExist candidate + if ok + then pure (Just candidate) + else + let parent = takeDirectory dir + in if parent == dir then pure Nothing else go parent diff --git a/src/Figment/Provider/Json.hs b/src/Figment/Provider/Json.hs new file mode 100644 --- /dev/null +++ b/src/Figment/Provider/Json.hs @@ -0,0 +1,76 @@ +-- | JSON. Parsed from aeson's lazy token stream, so the depth and size +-- limits are enforced while parsing (a megabyte of @[[[[...@ is +-- rejected at depth 65 without being materialised) and duplicate keys +-- are reported instead of silently keeping the last. +module Figment.Provider.Json + ( json + , parseJson + ) where + +import qualified Data.Aeson.Decoding.ByteString as Tok +import Data.Aeson.Decoding.Tokens +import qualified Data.Aeson.Key as Key +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BC +import qualified Data.Map.Strict as Map +import qualified Data.Text as Text +import qualified Data.Vector as Vector + +import Figment.Error +import Figment.Internal.Budget +import Figment.Limits +import Figment.Path +import Figment.Provider.Format (Format (..)) +import Figment.Value + +-- | The JSON format. +json :: Format +json = Format "JSON" (\lim bs -> pure (parseJson lim bs)) + +-- | Parse a JSON document, enforcing the limits. +parseJson :: Limits -> ByteString -> Either ConfigError Value +parseJson lim bs = runBudget lim $ do + (v, rest) <- value 1 root (Tok.bsToTokens bs) + if BC.all (`elem` (" \t\r\n" :: String)) rest + then pure v + else throwB (configError (SyntaxError "unexpected characters after the JSON value")) + +syntax :: Path -> String -> Budget a +syntax p e = throwB (atPath p (configError (SyntaxError (Text.pack e)))) + +value :: forall k. Int -> Path -> Tokens k String -> Budget (Value, k) +value d p tok = do + spend 1 p Nothing + case tok of + TkLit LitNull k -> pure (mkValue Null, k) + TkLit LitTrue k -> pure (mkValue (Bool True), k) + TkLit LitFalse k -> pure (mkValue (Bool False), k) + TkText t k -> pure (mkValue (String t), k) + TkNumber n k -> pure (mkValue (Num (Finite (num n))), k) + TkArrayOpen arr -> enterContainer d p Nothing >> items 0 [] arr + TkRecordOpen rec -> enterContainer d p Nothing >> pairs Map.empty rec + TkErr e -> syntax p e + where + num (NumInteger i) = fromInteger i + num (NumDecimal s) = s + num (NumScientific s) = s + + items :: Int -> [Value] -> TkArray k String -> Budget (Value, k) + items i acc = \case + TkItem toks -> do + (v, rest) <- value (d + 1) (p /# i) toks + items (i + 1) (v : acc) rest + TkArrayEnd k -> pure (mkValue (Array (Vector.fromList (reverse acc))), k) + TkArrayErr e -> syntax p e + + pairs :: Map.Map Text.Text Value -> TkRecord k String -> Budget (Value, k) + pairs acc = \case + TkPair key toks -> do + let kt = Key.toText key + if Map.member kt acc + then throwB (atPath (p /. kt) (configError (DuplicateKey kt))) + else do + (v, rest) <- value (d + 1) (p /. kt) toks + pairs (Map.insert kt v acc) rest + TkRecordEnd k -> pure (mkValue (Dict acc), k) + TkRecordErr e -> syntax p e diff --git a/src/Figment/Provider/Toml.hs b/src/Figment/Provider/Toml.hs new file mode 100644 --- /dev/null +++ b/src/Figment/Provider/Toml.hs @@ -0,0 +1,86 @@ +-- | TOML (v1.0, via toml-parser). Strict UTF-8; every value carries +-- its line and column; dates and times become ISO 8601 strings (decode +-- them into "Data.Time" types directly); @inf@ and @nan@ are kept as +-- non-finite numbers rather than corrupted. +module Figment.Provider.Toml + ( toml + , parseToml + ) where + +import Data.ByteString (ByteString) +import qualified Data.Map.Strict as Map +import qualified Data.Scientific as Sci +import qualified Data.Text as Text +import qualified Data.Text.Encoding as TE +import qualified Data.Vector as Vector +import Data.Time.Format.ISO8601 (iso8601Show) +import qualified Toml.Semantics as T +import qualified Toml.Syntax as T + +import Figment.Error +import Figment.Internal.Budget +import Figment.Limits +import Figment.Metadata (Pos (..)) +import Figment.Path +import Figment.Provider.Format (Format (..)) +import Figment.Value + +-- | The TOML format. +toml :: Format +toml = Format "TOML" (\lim bs -> pure (parseToml lim bs)) + +-- | Parse a TOML document, enforcing the limits. +parseToml :: Limits -> ByteString -> Either ConfigError Value +parseToml lim bs = do + txt <- case TE.decodeUtf8' bs of + Left e -> Left (configError (SyntaxError ("invalid UTF-8: " <> Text.pack (show e)))) + Right t -> Right t + exprs <- case T.parseRawToml txt of + Left (T.Located p msg) -> Left (withPos (Just (pos p)) (configError (SyntaxError (Text.pack msg)))) + Right es -> Right es + tab <- case T.semantics exprs of + Left (T.SemanticError ann key kind) -> + Left (withPos (Just (pos ann)) (configError (semantic key kind))) + Right t -> Right t + runBudget lim (table 1 root Nothing tab) + where + semantic key = \case + T.AlreadyAssigned -> DuplicateKey key + T.ClosedTable -> SyntaxError ("table `" <> key <> "` was already closed") + T.ImplicitlyTable -> SyntaxError ("`" <> key <> "` was implicitly defined as a table") + +pos :: T.Position -> Pos +pos p = Pos (T.posLine p) (T.posColumn p) + +table :: Int -> Path -> Maybe Pos -> T.Table' T.Position -> Budget Value +table d p at (T.MkTable m) = do + spend 1 p at + enterContainer d p at + kvs <- Map.traverseWithKey (\k (_, v) -> value (d + 1) (p /. k) v) m + pure (Value untagged {tagPos = at} (Dict kvs)) + +value :: Int -> Path -> T.Value' T.Position -> Budget Value +value d p v = case v of + T.Table' a t -> table d p (Just (pos a)) t + T.List' a xs -> do + spend 1 p (Just (pos a)) + enterContainer d p (Just (pos a)) + ys <- traverse (\(i, x) -> value (d + 1) (p /# i) x) (zip [0 ..] xs) + pure (Value (at a) (Array (Vector.fromList ys))) + T.Integer' a n -> leaf a (Num (Finite (fromInteger n))) + T.Double' a x -> leaf a (Num (double x)) + T.Bool' a b -> leaf a (Bool b) + T.Text' a t -> leaf a (String t) + T.TimeOfDay' a t -> leaf a (String (Text.pack (iso8601Show t))) + T.ZonedTime' a t -> leaf a (String (Text.pack (iso8601Show t))) + T.LocalTime' a t -> leaf a (String (Text.pack (iso8601Show t))) + T.Day' a t -> leaf a (String (Text.pack (iso8601Show t))) + where + at a = untagged {tagPos = Just (pos a)} + leaf a n = do + spend 1 p (Just (pos a)) + pure (Value (at a) n) + double x + | isNaN x = NaN + | isInfinite x = if x > 0 then PosInfinity else NegInfinity + | otherwise = Finite (Sci.fromFloatDigits x) diff --git a/src/Figment/Provider/Yaml.hs b/src/Figment/Provider/Yaml.hs new file mode 100644 --- /dev/null +++ b/src/Figment/Provider/Yaml.hs @@ -0,0 +1,286 @@ +-- | YAML, read directly from libyaml's event stream. +-- +-- * YAML 1.2 core schema: only @true@/@false@ are booleans, so @no@, +-- @on@ and @NO@ (the \"Norway problem\") stay strings. +-- * Every value carries its line and column. +-- * Anchors and aliases are supported, and alias expansion is charged +-- against the node limit, which defeats \"billion laughs\". +-- * Merge keys (@<<: *base@) are supported; explicit keys win. +-- * Duplicate keys are errors; multiple documents are rejected. +module Figment.Provider.Yaml + ( yaml + , parseYaml + ) where + +import Control.Applicative ((<|>)) +import Control.Exception (try) +import Data.ByteString (ByteString) +import Data.Char (isDigit, isHexDigit, isOctDigit) +import Data.Conduit (runConduitRes, (.|)) +import qualified Data.Conduit.List as CL +import qualified Data.Map.Strict as Map +import Data.Map.Strict (Map) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as TE +import qualified Data.Vector as Vector +import Numeric (readHex, readOct) +import qualified Text.Libyaml as Y + +import Figment.Error +import Figment.Internal.ValueParser (parseNumber) +import Figment.Limits +import Figment.Metadata (Pos (..)) +import Figment.Path +import Figment.Provider.Format (Format (..)) +import Figment.Value hiding (null) + +-- | The YAML format. +yaml :: Format +yaml = Format "YAML" parseYaml + +-- | Parse a YAML document, enforcing the limits. +parseYaml :: Limits -> ByteString -> IO (Either ConfigError Value) +parseYaml lim bs = do + r <- try (runConduitRes (Y.decodeMarked bs .| CL.consume)) + pure $ case r of + Left (Y.YamlException msg) -> Left (configError (SyntaxError (Text.pack msg))) + Left (Y.YamlParseException problem ctx mark) -> + Left (withPos (Just (markPos mark)) + (configError (SyntaxError (Text.pack (problem ++ (if null ctx then "" else " " ++ ctx)))))) + Right [] -> Right emptyDict + Right events -> fst <$> runY document (YState events Map.empty (maxNodes lim)) lim + +markPos :: Y.YamlMark -> Pos +markPos m = Pos (Y.yamlLine m + 1) (Y.yamlColumn m + 1) + +------------------------------------------------------------------------ +-- A small state/error monad over the event list + +data YState = YState + { ysEvents :: [Y.MarkedEvent] + , ysAnchors :: Map String Anchored + , ysBudget :: !Int + } + +-- | An anchored subtree, with its expanded size and container height. +data Anchored = Anchored Value !Int !Int + +newtype YP a = YP {runY :: YState -> Limits -> Either ConfigError (a, YState)} + +instance Functor YP where + fmap f (YP g) = YP $ \s l -> fmap (\(a, s') -> (f a, s')) (g s l) + +instance Applicative YP where + pure a = YP $ \s _ -> Right (a, s) + YP f <*> YP g = YP $ \s l -> case f s l of + Left e -> Left e + Right (h, s') -> fmap (\(a, s'') -> (h a, s'')) (g s' l) + +instance Monad YP where + YP g >>= k = YP $ \s l -> case g s l of + Left e -> Left e + Right (a, s') -> runY (k a) s' l + +failY :: ConfigError -> YP a +failY e = YP $ \_ _ -> Left e + +next :: YP (Maybe Y.MarkedEvent) +next = YP $ \s _ -> case ysEvents s of + [] -> Right (Nothing, s) + (e : es) -> Right (Just e, s {ysEvents = es}) + +peek :: YP (Maybe Y.Event) +peek = YP $ \s _ -> Right (Y.yamlEvent <$> safeHead (ysEvents s), s) + where + safeHead (x : _) = Just x + safeHead [] = Nothing + +spendY :: Int -> Path -> Pos -> YP () +spendY k p at = YP $ \s l -> + let b = ysBudget s - k + in if b < 0 + then Left (withPos (Just at) (atPath p (configError (TooManyNodes (maxNodes l))))) + else Right ((), s {ysBudget = b}) + +depthCheck :: Int -> Path -> Pos -> YP () +depthCheck d p at = YP $ \s l -> + if d > maxDepth l + then Left (withPos (Just at) (atPath p (configError (DepthExceeded (maxDepth l))))) + else Right ((), s) + +remember :: Y.Anchor -> Anchored -> YP () +remember Nothing _ = pure () +remember (Just name) a = YP $ \s _ -> Right ((), s {ysAnchors = Map.insert name a (ysAnchors s)}) + +recall :: String -> YP (Maybe Anchored) +recall name = YP $ \s _ -> Right (Map.lookup name (ysAnchors s), s) + +syntaxAt :: Path -> Pos -> Text -> YP a +syntaxAt p at msg = failY (withPos (Just at) (atPath p (configError (SyntaxError msg)))) + +------------------------------------------------------------------------ +-- Grammar + +document :: YP Value +document = do + _ <- expectStart + ev <- peek + case ev of + Just Y.EventStreamEnd -> pure emptyDict + Just Y.EventDocumentStart -> do + _ <- next + Anchored v _ _ <- node 1 root + end <- next + case Y.yamlEvent <$> end of + Just Y.EventDocumentEnd -> pure () + _ -> failY (configError (SyntaxError "malformed YAML document")) + rest <- peek + case rest of + Just Y.EventDocumentStart -> + failY (configError (SyntaxError "multiple YAML documents are not supported in a configuration file")) + _ -> pure v + _ -> failY (configError (SyntaxError "malformed YAML stream")) + where + expectStart = next + +-- | Parse one node at nesting level @d@ (root = 1). Returns the value +-- with its expanded size and container height. +node :: Int -> Path -> YP Anchored +node d p = do + me <- next + case me of + Nothing -> failY (atPath p (configError (SyntaxError "unexpected end of YAML input"))) + Just (Y.MarkedEvent ev start _) -> do + let at = markPos start + case ev of + Y.EventScalar bytes tag style anchor -> do + spendY 1 p at + n <- scalar p at bytes tag style + let a = Anchored (Value untagged {tagPos = Just at} n) 1 0 + remember anchor a + pure a + Y.EventSequenceStart _ _ anchor -> do + spendY 1 p at + depthCheck d p at + (items, size, height) <- sequenceItems 0 [] 1 0 + let a = Anchored (Value untagged {tagPos = Just at} (Array (Vector.fromList items))) size (height + 1) + remember anchor a + pure a + Y.EventMappingStart _ _ anchor -> do + spendY 1 p at + depthCheck d p at + (m, size, height) <- mappingPairs Map.empty [] 1 0 + let a = Anchored (Value untagged {tagPos = Just at} (Dict m)) size (height + 1) + remember anchor a + pure a + Y.EventAlias name -> do + found <- recall name + case found of + Nothing -> syntaxAt p at ("unknown alias `*" <> Text.pack name <> "`") + Just a@(Anchored _ size height) -> do + spendY size p at + if height > 0 then depthCheck (d + height - 1) p at else pure () + pure a + _ -> syntaxAt p at "unexpected YAML event" + where + sequenceItems :: Int -> [Value] -> Int -> Int -> YP ([Value], Int, Int) + sequenceItems i acc size height = do + ev <- peek + case ev of + Just Y.EventSequenceEnd -> next >> pure (reverse acc, size, height) + _ -> do + Anchored v s h <- node (d + 1) (p /# i) + sequenceItems (i + 1) (v : acc) (size + s) (max height h) + + -- explicit pairs, then merge-key sources (applied underneath) + mappingPairs :: Dict -> [Dict] -> Int -> Int -> YP (Dict, Int, Int) + mappingPairs acc merges size height = do + me <- next + case me of + Just (Y.MarkedEvent Y.EventMappingEnd _ _) -> + pure (Map.union acc (Map.unions merges), size, height) + Just (Y.MarkedEvent (Y.EventScalar bytes _ style _) kstart _) -> do + let kat = markPos kstart + key <- decodeText p kat bytes + if key == "<<" && style `elem` [Y.Plain, Y.PlainNoTag, Y.Any] + then do + Anchored v s h <- node (d + 1) (p /. key) + srcs <- mergeSources kat v + mappingPairs acc (merges ++ srcs) (size + s) (max height (h - 1)) + else + if Map.member key acc + then failY (withPos (Just kat) (atPath (p /. key) (configError (DuplicateKey key)))) + else do + Anchored v s h <- node (d + 1) (p /. key) + mappingPairs (Map.insert key v acc) merges (size + s) (max height h) + Just (Y.MarkedEvent _ kstart _) -> + syntaxAt p (markPos kstart) "only scalar mapping keys are supported" + Nothing -> failY (atPath p (configError (SyntaxError "unexpected end of YAML input"))) + + mergeSources kat v = case valueNode v of + Dict m -> pure [m] + Array xs | all isDict (Vector.toList xs) -> pure [m | Value _ (Dict m) <- Vector.toList xs] + _ -> syntaxAt (p /. "<<") kat "a merge key (`<<`) needs a mapping or a list of mappings" + isDict (Value _ (Dict _)) = True + isDict _ = False + +decodeText :: Path -> Pos -> ByteString -> YP Text +decodeText p at bytes = case TE.decodeUtf8' bytes of + Right t -> pure t + Left _ -> syntaxAt p at "invalid UTF-8 in YAML scalar" + +-- | Resolve a scalar under the YAML 1.2 core schema. +scalar :: Path -> Pos -> ByteString -> Y.Tag -> Y.Style -> YP Node +scalar p at bytes tag style = do + t <- decodeText p at bytes + let quoted = style `elem` [Y.SingleQuoted, Y.DoubleQuoted, Y.Literal, Y.Folded] + bad what = syntaxAt p at ("`" <> t <> "` is not a valid " <> what) + case tag of + Y.StrTag -> pure (String t) + Y.NullTag -> pure Null + Y.BoolTag -> maybe (bad "boolean") (pure . Bool) (coreBool t) + Y.IntTag -> maybe (bad "integer") (pure . Num) (coreInt t) + Y.FloatTag -> maybe (bad "float") (pure . Num) (coreFloat t <|> coreInt t) + _ | quoted -> pure (String t) + | otherwise -> pure (resolve t) + where + resolve t + | t `elem` ["", "~", "null", "Null", "NULL"] = Null + | Just b <- coreBool t = Bool b + | Just n <- coreInt t = Num n + | Just n <- coreFloat t = Num n + | otherwise = String t + +coreBool :: Text -> Maybe Bool +coreBool t + | t `elem` ["true", "True", "TRUE"] = Just True + | t `elem` ["false", "False", "FALSE"] = Just False + | otherwise = Nothing + +coreInt :: Text -> Maybe Number +coreInt t + | Just r <- Text.stripPrefix "0x" t, not (Text.null r), Text.all isHexDigit r = + Just (Finite (fromInteger (fst (head' (readHex (Text.unpack r)))))) + | Just r <- Text.stripPrefix "0o" t, not (Text.null r), Text.all isOctDigit r = + Just (Finite (fromInteger (fst (head' (readOct (Text.unpack r)))))) + | otherwise = + let body = maybe t id (Text.stripPrefix "-" t <> Text.stripPrefix "+" t) + in if not (Text.null body) && Text.all isDigit body then parseNumber t else Nothing + where + head' (x : _) = x + head' [] = (0, "") + +coreFloat :: Text -> Maybe Number +coreFloat t + | t `elem` [".inf", ".Inf", ".INF", "+.inf", "+.Inf", "+.INF"] = Just PosInfinity + | t `elem` ["-.inf", "-.Inf", "-.INF"] = Just NegInfinity + | t `elem` [".nan", ".NaN", ".NAN"] = Just NaN + | Text.any isDigit t, Text.all (`elem` ("0123456789+-.eE" :: String)) t = + parseNumber (fixLeadingDot t) + | otherwise = Nothing + where + fixLeadingDot x = case Text.uncons x of + Just ('.', _) -> "0" <> x + Just (s, r) | s `elem` ("+-" :: String), Just ('.', _) <- Text.uncons r -> Text.singleton s <> "0" <> r + _ -> x diff --git a/src/Figment/Tutorial.hs b/src/Figment/Tutorial.hs new file mode 100644 --- /dev/null +++ b/src/Figment/Tutorial.hs @@ -0,0 +1,539 @@ +-- | A guided tour of figment, from a first configuration file to +-- writing your own provider. Every snippet here is compiled and run by +-- the package's test suite (@test\/Figment\/Test\/Tutorial.hs@). +-- +-- The examples assume these imports and extensions: +-- +-- > {-# LANGUAGE DeriveAnyClass, DeriveGeneric, DerivingStrategies #-} +-- > {-# LANGUAGE OverloadedStrings, TypeApplications, TypeFamilies #-} +-- > +-- > import Data.Aeson ((.=)) +-- > import qualified Data.Aeson as Aeson +-- > import Data.Function ((&)) +-- > import qualified Data.Map.Strict as Map +-- > import Data.Text (Text) +-- > import GHC.Generics (Generic) +-- > +-- > import qualified Figment as F +-- > import qualified Figment.Jail as Jail +-- > import qualified Figment.Provider.Env as Env +-- +-- "Figment" is meant to be imported qualified: it exports names such as +-- 'Figment.merge', 'Figment.join' and 'Figment.from'. +module Figment.Tutorial + ( -- * 1. The idea + -- $idea + + -- * 2. Your first configuration + -- $first + + -- * 3. Layering sources + -- $layering + + -- * 4. Environment variables + -- $env + + -- * 5. Command-line arguments + -- $cli + + -- * 6. Profiles + -- $profiles + + -- * 7. Reading errors + -- $errors + + -- * 8. Decoding in depth + -- $decoding + + -- * 9. Provenance in your own types + -- $provenance + + -- * 10. Partial configurations + -- $partial + + -- * 11. For library authors + -- $libraries + + -- * 12. Writing a provider + -- $providers + + -- * 13. Testing + -- $testing + + -- * 14. Untrusted input + -- $limits + + -- * 15. Coming from Rust figment + -- $rust + + -- * 16. Upgrading from figment 0.1 + -- $upgrade + ) where + +-- $idea +-- +-- Configuration usually comes from several places at once: defaults in +-- code, a file, environment variables, a few command-line flags. figment +-- lets you list those sources in order of precedence, combines them +-- into one tree, and decodes the tree into your own types. +-- +-- Two ideas make it pleasant: +-- +-- * Every value remembers where it came from: which source, which +-- profile, which line and column, and the name the user would type to +-- set it (@APP_PORT@, @--port@). +-- +-- * Problems are collected, not thrown one at a time. A misspelt key, a +-- port out of range and a missing field are reported together, each +-- pointing at its source. +-- +-- The moving parts are /providers/ (sources of configuration), the +-- t'Figment.Figment' (an ordered list of providers), 'Figment.load' +-- (reads every provider), and 'Figment.FromConfig' (decodes into your +-- types). + +-- $first +-- +-- Describe the configuration as a record and derive +-- 'Figment.FromConfig' through "GHC.Generics": +-- +-- > data Config = Config +-- > { name :: Text +-- > , port :: Int +-- > , debug :: Bool +-- > } +-- > deriving stock (Show, Eq, Generic) +-- > deriving anyclass (F.FromConfig) +-- +-- Read it from a TOML file: +-- +-- > firstFigment :: F.Figment +-- > firstFigment = F.from (F.file F.toml "App.toml") +-- > +-- > main :: IO () +-- > main = do +-- > cfg <- F.loadExtractOrThrow @Config firstFigment +-- > print cfg +-- +-- with an @App.toml@ such as +-- +-- > name = "demo" +-- > port = 8080 +-- > debug = false +-- +-- 'Figment.file' looks for a relative path in the working directory and +-- then in each parent directory, and a missing file simply contributes +-- nothing. Use 'Figment.fileExact' to disable the search and +-- 'Figment.required' to make a missing file an error. 'Figment.json' and +-- 'Figment.yaml' work the same way, and 'Figment.fromText' reads +-- configuration held in memory. +-- +-- 'Figment.loadExtractOrThrow' throws t'Figment.ConfigErrors', whose +-- 'Control.Exception.displayException' is the full report. Use +-- 'Figment.loadExtract' to get an 'Either' instead. + +-- $layering +-- +-- Most programs combine several sources. Later sources win: +-- +-- > layered :: [Text] -> F.Figment +-- > layered args = +-- > F.new +-- > & F.merge (F.defaults (Aeson.object ["port" .= (8080 :: Int), "debug" .= False])) +-- > & F.merge (F.file F.toml "App.toml") +-- > & F.merge (F.prefixed "APP_") +-- > & F.merge (F.cli args) +-- +-- Here a built-in default is overridden by the file, the file by +-- environment variables such as @APP_PORT=9000@, and those by flags +-- such as @--port=9100@. 'Figment.defaults' accepts any value with a +-- 'Data.Aeson.ToJSON' instance, including your own record. +-- +-- Four strategies decide what happens when two sources set the same key +-- (they are those of Rust figment): +-- +-- * 'Figment.merge': the incoming value wins; +-- +-- * 'Figment.join': the existing value wins, so the incoming source only +-- fills gaps; +-- +-- * 'Figment.admerge' and 'Figment.adjoin': the same, except that arrays +-- are concatenated instead of replaced. +-- +-- Dictionaries are always combined key by key, recursively. A @null@ is +-- an ordinary value: merging @null@ over a key replaces it. +-- +-- A t'Figment.Figment' is only a description; building one performs no +-- IO. 'Figment.load' reads every source in order and reports every +-- failure (an unreadable file /and/ a syntax error elsewhere), then +-- 'Figment.extract' decodes. 'Figment.loadExtract' does both. + +-- $env +-- +-- @F.prefixed \"APP_\"@ ('Figment.prefixed') reads every variable whose name starts +-- with @APP_@ (in any case), removes the prefix and lower-cases the +-- rest: @APP_MAX_CONNECTIONS@ sets @max_connections@. There is no +-- nesting unless you ask for it: +-- +-- > data Db = Db {host :: Text, port :: Int} +-- > deriving stock (Show, Eq, Generic) +-- > deriving anyclass (F.FromConfig) +-- > +-- > newtype WithDb = WithDb {db :: Db} +-- > deriving stock (Show, Eq, Generic) +-- > deriving anyclass (F.FromConfig) +-- > +-- > dbFromEnv :: F.Figment +-- > dbFromEnv = F.from (F.prefixed "APP_" & Env.split "__") +-- +-- With @APP_DB\__HOST=db.internal@ and @APP_DB\__PORT=5432@ this decodes +-- to @WithDb (Db \"db.internal\" 5432)@. +-- +-- Values are typed: @5432@ is a number, @true@ a boolean, @[1, 2]@ an +-- array and @{a = 1}@ a dictionary; anything else is a string. The +-- original text is kept too, so a 'Data.Text.Text' field set to @007@ +-- receives @\"007\"@, not @7@. Two variables that cannot both hold (for +-- example @APP_DB=x@ next to @APP_DB\__HOST=y@) are reported as an +-- error naming both. +-- +-- "Figment.Provider.Env" has the remaining options: +-- 'Figment.Provider.Env.only', 'Figment.Provider.Env.ignore', +-- 'Figment.Provider.Env.mapKeys', 'Figment.Provider.Env.filterKeys', +-- 'Figment.Provider.Env.lowercase', 'Figment.Provider.Env.ignoreEmpty', +-- 'Figment.Provider.Env.unparsed', 'Figment.Provider.Env.inProfile' and +-- 'Figment.Provider.Env.global'. + +-- $cli +-- +-- @F.cli args@ ('Figment.cli'), or 'Figment.cliFromProcess', understands +-- +-- * @--key=value@ (the value is typed as for environment variables); +-- +-- * @--flag@ (true) and @--no-flag@ (false); +-- +-- * @--db.port=5432@ (dots nest) and @--max-connections=5@ (dashes +-- become underscores); +-- +-- * @--@, which ends option parsing. +-- +-- Everything else is positional; 'Figment.Provider.Cli.parseArgs' +-- returns it. @--key value@ (with a space) is deliberately not +-- supported: without knowing which options take values it cannot be told +-- apart from a flag followed by a positional argument. For a full +-- command-line interface, parse with optparse-applicative and pass the +-- result in with 'Figment.defaults', as Rust figment recommends with +-- clap. + +-- $profiles +-- +-- A profile is a named slice of configuration. With 'Figment.nested', +-- the top-level tables of a file are profiles: +-- +-- > [default] +-- > name = "app" +-- > port = 8080 +-- > debug = true +-- > +-- > [production] +-- > port = 80 +-- > debug = false +-- +-- > profiled :: F.Profile -> F.Figment +-- > profiled p = +-- > F.new +-- > & F.merge (F.nested (F.file F.toml "App.toml")) +-- > & F.select p +-- +-- @profiled F.Default@ decodes to @Config \"app\" 8080 True@, and +-- @profiled \"production\"@ to @Config \"app\" 80 False@. +-- +-- On extraction, the 'Figment.Default' profile is merged with the +-- selected profile, and the 'Figment.Global' profile is merged over +-- both. Profile names are case-insensitive. To choose the profile at +-- run time, use 'Figment.profileFromEnv', for example +-- @F.profileFromEnv \"APP_PROFILE\" F.Default@. +-- 'Figment.reselect' switches the profile of an already loaded +-- configuration without reading anything again. + +-- $errors +-- +-- A report looks like this: +-- +-- > 4 configuration errors: +-- > +-- > error: missing field `name` +-- > --> key `name` +-- > = hint: no source sets it; it can be set as `name` in TOML file /srv/app/App.toml, or `APP_NAME` in environment variables (prefix APP_) +-- > +-- > error: unknown field `hots` +-- > --> key `db.hots` in TOML file /srv/app/App.toml:4:8 +-- > = hint: did you mean `host`? +-- > +-- > error: invalid value: found integer 70000, expected an integer in the range 0..65535 +-- > --> key `db.port` in TOML file /srv/app/App.toml:3:8 +-- > +-- > error: unknown variant `verbose`, expected one of `Debug`, `Info` +-- > --> key `level` (`APP_LEVEL`) in environment variables (prefix APP_) +-- +-- Errors are also plain values. 'Figment.errorList' gives each +-- t'Figment.ConfigError', with its 'Figment.errorKind', +-- 'Figment.errorPath', 'Figment.errorMetadata' (the source), +-- 'Figment.errorPos' (line and column) and 'Figment.errorHints'. For +-- example, decoding @name = 1@ into @Config@ gives +-- +-- > [ InvalidType "integer 1" "a string" +-- > , MissingField "port" +-- > , MissingField "debug" ] +-- +-- 'Figment.renderErrors' produces the report shown above. + +-- $decoding +-- +-- Generic decoding maps records to dictionaries. Optional fields have +-- type 'Maybe'. Enumerations are strings, matched case-insensitively. +-- Other sum types are externally tagged (@{ Circle = { radius = 1 } }@). +-- Newtypes unwrap, and constructors with unnamed fields are arrays. +-- +-- 'Figment.genericDecoder' takes t'Figment.Options': +-- +-- > data Level = Debug | Info | Warning +-- > deriving stock (Show, Eq, Generic) +-- > deriving anyclass (F.FromConfig) +-- > +-- > data Server = Server +-- > { listenAddress :: Text +-- > , maxConnections :: Int +-- > , logLevel :: Level +-- > } +-- > deriving stock (Show, Eq, Generic) +-- > +-- > instance F.FromConfig Server where +-- > fromConfig = +-- > F.genericDecoder +-- > F.defaultOptions +-- > { F.fieldLabelModifier = F.snakeCase +-- > , F.rejectUnknownFields = True +-- > } +-- +-- This reads @listen_address@, @max_connections@ and @log_level: info@, +-- and reports any other key as an unknown field, with a suggestion when +-- the key looks like a typo. +-- +-- Hand-written decoders use an applicative that /accumulates/ errors. +-- Validation keeps the location of the value: +-- +-- > newtype Port = Port Int +-- > +-- > instance F.FromConfig Port where +-- > fromConfig = F.validate check F.fromConfig +-- > where +-- > check n +-- > | n > 0 && n < 65536 = Right (Port n) +-- > | otherwise = Left "a port must be between 1 and 65535" +-- > +-- > data Endpoint = Endpoint {url :: Text, timeout :: Int, retries :: Int} +-- > +-- > instance F.FromConfig Endpoint where +-- > fromConfig = +-- > Endpoint +-- > <$> F.field "url" +-- > <*> F.fieldOr "timeout" 30 +-- > <*> F.fieldOr "retries" 3 +-- +-- t'Figment.Decoder' deliberately has no 'Monad' instance, because a +-- monad has to stop at the first error. When one step really depends on +-- another, use 'Figment.andThen'. +-- +-- Decoding is strict: the string @\"8080\"@ is not an 'Int'. +-- 'Figment.extractLossy' accepts strings for numbers and booleans. Use +-- 'Figment.extractAt' to decode a single key path, for example +-- @F.extractAt (F.keyPath \"api\") loaded@. Types with an existing +-- 'Data.Aeson.FromJSON' instance can be reused with +-- @deriving F.FromConfig via F.ViaAeson T@. + +-- $provenance +-- +-- Two types carry provenance into your configuration: +-- +-- > data Paths = Paths +-- > { dataDir :: F.RelativePath +-- > , token :: F.Tagged Text +-- > } +-- > deriving stock (Show, Eq, Generic) +-- > +-- > instance F.FromConfig Paths where +-- > fromConfig = F.genericDecoder F.defaultOptions {F.fieldLabelModifier = F.snakeCase} +-- +-- If @conf\/app.toml@ says @data_dir = \"data\"@, then +-- @F.relative (dataDir paths)@ is @conf\/data@: the path is resolved +-- against the file that wrote it, not the working directory. +-- t'Figment.Tagged' holds the value together with its source, profile, +-- position and path, so that later validation can report precisely +-- where a value came from. On a loaded configuration, +-- 'Figment.findMetadata', 'Figment.findValue' and 'Figment.contains' +-- answer the same questions for any key path. + +-- $partial +-- +-- Declare the configuration once, parameterised by a functor, and get +-- both a total and a partial version of it: +-- +-- > data AppF f = App +-- > { appName :: F.Field f Text +-- > , workers :: F.Field f Int +-- > , motd :: F.Field f (Maybe Text) +-- > } +-- > deriving stock (Generic) +-- > +-- > instance F.Partial AppF +-- > +-- > type App = AppF F.Identity -- appName :: Text, workers :: Int, ... +-- > +-- > appDefaults :: AppF Maybe +-- > appDefaults = (F.emptyPartial @AppF) {workers = Just 4} +-- +-- @F.extractPartial appDefaults loaded@ decodes whatever the sources +-- provide, fills the gaps from the defaults, and reports /every/ field +-- that is still missing, together with the variable, flag or key that +-- would set it. 'Maybe' fields are never missing. +-- +-- 'Figment.extractTotal' takes complete defaults (an @AppF Identity@), +-- and its type guarantees that a missing-field error cannot happen. +-- Partial records can be nested (a field of type @DbF f@), and +-- 'Figment.overlay', 'Figment.complete' and 'Figment.total' let you +-- layer partial values yourself. + +-- $libraries +-- +-- A library can publish its configuration as a t'Figment.Figment'. +-- Applications append their own sources with '<>': +-- +-- > libraryFigment :: F.Figment +-- > libraryFigment = +-- > F.new +-- > & F.merge (F.defaults (Aeson.object ["workers" .= (4 :: Int)])) +-- > & F.merge (F.prefixed "MYLIB_") +-- > +-- > applicationFigment :: F.Figment +-- > applicationFigment = libraryFigment <> F.from (F.file F.toml "MyApp.toml") +-- +-- t'Figment.Figment' is a lawful 'Monoid', so this grouping is safe. +-- A t'Figment.Figment' is also a provider: @F.merge libraryFigment@ +-- nests it, and every inner value keeps its original source. + +-- $providers +-- +-- A provider has a name, and an action that returns one dictionary per +-- profile: +-- +-- > newtype Secrets = Secrets (Map.Map Text Text) +-- > +-- > instance F.Provider Secrets where +-- > metadata _ = F.named "secrets service" +-- > provide _limits (Secrets m) = +-- > pure (Right (Map.singleton F.Default (fmap (F.Value untaggedTag . F.String) m))) +-- > +-- > untaggedTag :: F.Tag +-- > untaggedTag = F.Tag Nothing Nothing Nothing Nothing +-- +-- 'Figment.load' fills in the provider's metadata and profile for every +-- value, so error messages name the secrets service. A provider that +-- parses untrusted text should respect the t'Figment.Limits' it is +-- given. Any synchronous exception that escapes 'Figment.provide' is +-- turned into an 'Figment.IoError' for that provider. For a new file +-- format, write a t'Figment.Format' instead (a name and a parser); see +-- "Figment.Provider.Format". + +-- $testing +-- +-- 'Figment.Jail.withJail' runs a test in a fresh temporary directory, +-- with a snapshot of the environment, and restores both afterwards: +-- +-- > Jail.withJail $ \j -> do +-- > _ <- Jail.createFile j "App.toml" "name = \"demo\"\nport = 9000\n" +-- > Jail.setEnv j "APP_DEBUG" "true" +-- > cfg <- F.loadExtractOrThrow (layered ["--port=9100"]) +-- > cfg @?= Config "demo" 9100 True +-- +-- Jails are serialised across the whole process, so they are safe under +-- a parallel test runner. To avoid global state altogether, give the +-- environment provider fixed variables: +-- +-- > F.from (Env.fromList [("APP_PORT", "1")] (F.prefixed "APP_")) + +-- $limits +-- +-- Every bundled parser enforces t'Figment.Limits' /while/ parsing: +-- nesting depth (64 by default) and the number of values (one million). +-- A megabyte of @[[[[@ is rejected at depth 65 without being built. +-- YAML aliases count at their expanded size, which defeats \"billion +-- laughs\" documents. Change the limits with 'Figment.withLimits' and +-- 'Figment.mkLimits'. Duplicate keys are errors, invalid UTF-8 is +-- rejected rather than replaced, and YAML uses the 1.2 core schema, so +-- @no@ stays a string. + +-- $rust +-- +-- The same concepts, side by side (Rust first): +-- +-- * @Figment::new().merge(p)@ is @F.new & F.merge p@; @join@, @adjoin@ +-- and @admerge@ keep their names. +-- +-- * @Toml::file(p)@ is @F.file F.toml p@; @.nested()@ is +-- 'Figment.nested'; @Toml::string(s)@ is @F.fromText F.toml s@. +-- +-- * @Env::prefixed(\"APP_\").split(\"\__\")@ is +-- @F.prefixed \"APP_\" & Env.split \"\__\"@. +-- +-- * @Serialized::defaults(x)@ is @F.defaults x@. +-- +-- * @.select(\"prod\")@ is @F.select \"prod\"@. +-- +-- * @.extract::\()@ is @F.loadExtract \@T fig@; +-- @.extract_inner(\"a.b\")@ is @F.extractAt (F.keyPath \"a.b\")@; +-- @.extract_lossy()@ is 'Figment.extractLossy'. +-- +-- * @focus@, @find_value@ and @contains@ are 'Figment.focus', +-- 'Figment.findValue' and 'Figment.contains'. +-- +-- * @Tagged\@ and @RelativePathBuf@ are t'Figment.Tagged' and +-- t'Figment.RelativePath'. +-- +-- * @Jail::expect_with@ is 'Figment.Jail.withJail'. +-- +-- * @#[derive(Deserialize)]@ is @deriving anyclass F.FromConfig@. +-- +-- What is different: all errors are reported at once, not just the +-- first; TOML and YAML values carry line and column; missing fields come +-- with hints; partial configurations give a type-level guarantee +-- ('Figment.extractTotal'); environment variable conflicts are errors; +-- and @--key value@ CLI pairs are not parsed (use optparse-applicative). + +-- $upgrade +-- +-- Version 0.2 is a redesign. The main replacements: +-- +-- * @runLayers [Merge t, ...]@ and @composeChecked@: build a +-- t'Figment.Figment' with 'Figment.merge' and friends, then +-- 'Figment.loadExtract'. The compile-time guarantee now comes from +-- 'Figment.extractTotal'. +-- +-- * @tagProviderDefault (TomlFile p)@: @F.file F.toml p@ (or +-- 'Figment.fileExact' with 'Figment.required' to keep 0.1's \"must +-- exist\" behaviour). +-- +-- * @EnvPrefixed \"APP_\"@: @F.prefixed \"APP_\" & Env.split \"_\"@ +-- reproduces 0.1's splitting; plain @F.prefixed \"APP_\"@ is +-- recommended. +-- +-- * @CliArgs args@: @F.cli args@. +-- +-- * @Defaults r@: @F.defaults r@. +-- +-- * @FromJSON@-only types: add @deriving F.FromConfig via F.ViaAeson T@, +-- or derive 'Figment.FromConfig' directly. +-- +-- * @runExtractProv@: use 'Figment.findMetadata', or t'Figment.Tagged' +-- fields. +-- +-- * @Depth@ and @mkDepth@: t'Figment.Limits' and 'Figment.mkLimits'. diff --git a/src/Figment/Value.hs b/src/Figment/Value.hs new file mode 100644 --- /dev/null +++ b/src/Figment/Value.hs @@ -0,0 +1,207 @@ +-- | The configuration value tree. Every node carries a t'Tag' recording +-- which provider and profile it came from, where in the source text it +-- was written, and (for values parsed from untyped text such as +-- environment variables) the original text. +module Figment.Value + ( -- * Values + Value (..) + , Node (..) + , Number (..) + , Dict + -- * Tags + , Tag (..) + , untagged + , retag + , setTagMeta + -- * Construction + , mkValue + , string + , bool + , number + , null + , array + , dict + , emptyDict + -- * Inspection + , lookupPath + , describe + , kindOf + , stripTags + , numberFromScientific + ) where + +import Prelude hiding (null) + +import Control.DeepSeq (NFData) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Scientific (Scientific) +import qualified Data.Scientific as Sci +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Vector (Vector) +import qualified Data.Vector as Vector +import GHC.Generics (Generic) + +import Figment.Metadata +import Figment.Path +import Figment.Profile + +-- | Numbers. Finite values are exact ('Scientific'), so a 30-digit +-- decimal in a JSON file survives intact; TOML and YAML also allow +-- infinities and NaN, which are represented explicitly rather than +-- being smuggled through as nonsense 'Scientific's. +data Number + = Finite !Scientific + | PosInfinity + | NegInfinity + | NaN + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +-- | Provenance attached to a value. +data Tag = Tag + { tagMeta :: !(Maybe Metadata) + , tagProfile :: !(Maybe Profile) + , tagPos :: !(Maybe Pos) + , tagRaw :: !(Maybe Text) + -- ^ the original text, for values parsed out of untyped text + -- (environment variables, CLI arguments). Lets a 'Text' field + -- receive @007@ verbatim even though it also parses as a number. + } + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +-- | A tag with no provenance. +untagged :: Tag +untagged = Tag Nothing Nothing Nothing Nothing + +-- | A dictionary. Keys are kept sorted (Rust figment's default ordering). +type Dict = Map Text Value + +-- | The shape of a value. +data Node + = Null + | Bool !Bool + | Num !Number + | String !Text + | Array !(Vector Value) + | Dict !Dict + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +-- | A tagged configuration value. +data Value = Value + { valueTag :: !Tag + , valueNode :: !Node + } + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +-- | An untagged value. +mkValue :: Node -> Value +mkValue = Value untagged + +-- | An untagged string. +string :: Text -> Value +string = mkValue . String + +-- | An untagged boolean. +bool :: Bool -> Value +bool = mkValue . Bool + +-- | An untagged finite number. +number :: Scientific -> Value +number = mkValue . Num . Finite + +-- | The untagged null. +null :: Value +null = mkValue Null + +-- | An untagged array. +array :: [Value] -> Value +array = mkValue . Array . Vector.fromList + +-- | An untagged dictionary. +dict :: [(Text, Value)] -> Value +dict = mkValue . Dict . Map.fromList + +-- | The empty dictionary. +emptyDict :: Value +emptyDict = mkValue (Dict Map.empty) + +-- | A finite number. +numberFromScientific :: Scientific -> Number +numberFromScientific = Finite + +-- | Fill in missing provenance (never overwrite: values coming from a +-- nested t'Figment.Core.Figment' keep their original source). +retag :: Metadata -> Profile -> Value -> Value +retag m p = go + where + go (Value t n) = Value (fill t) (goNode n) + fill t = t + { tagMeta = maybe (Just m) Just (tagMeta t) + , tagProfile = maybe (Just p) Just (tagProfile t) + } + goNode (Array xs) = Array (fmap go xs) + goNode (Dict d) = Dict (fmap go d) + goNode n = n + +-- | Overwrite the metadata of every node (used by providers that learn +-- their final metadata, e.g. a resolved file path, only when reading). +setTagMeta :: Metadata -> Value -> Value +setTagMeta m = go + where + go (Value t n) = Value t {tagMeta = Just m} (goNode n) + goNode (Array xs) = Array (fmap go xs) + goNode (Dict d) = Dict (fmap go d) + goNode n = n + +-- | Follow a path. +lookupPath :: Path -> Value -> Maybe Value +lookupPath p v0 = foldl step (Just v0) (segments p) + where + step Nothing _ = Nothing + step (Just (Value _ (Dict d))) (Key k) = Map.lookup k d + step (Just (Value _ (Array xs))) (Index i) = xs Vector.!? i + step _ _ = Nothing + +-- | A short description of a node's kind, for error messages. +kindOf :: Node -> Text +kindOf = \case + Null -> "null" + Bool _ -> "a boolean" + Num (Finite s) | Sci.isInteger s -> "an integer" + Num _ -> "a number" + String _ -> "a string" + Array _ -> "an array" + Dict _ -> "a dictionary" + +-- | Kind plus a preview of the value, e.g. @string "abc"@. +describe :: Node -> Text +describe = \case + Null -> "null" + Bool b -> "boolean " <> (if b then "true" else "false") + Num n -> case n of + Finite s + | Sci.isInteger s, abs (Sci.base10Exponent s) < 64 -> + "integer " <> Text.pack (Sci.formatScientific Sci.Fixed (Just 0) s) + | otherwise -> "number " <> Text.pack (show s) + PosInfinity -> "number inf" + NegInfinity -> "number -inf" + NaN -> "number nan" + String t -> "string " <> Text.pack (show (preview t)) + Array xs -> "an array of length " <> Text.pack (show (Vector.length xs)) + Dict _ -> "a dictionary" + where + preview t + | Text.length t > 40 = Text.take 40 t <> "..." + | otherwise = t + +-- | Remove all provenance (for comparing data only). +stripTags :: Value -> Value +stripTags (Value _ n) = Value untagged $ case n of + Array xs -> Array (fmap stripTags xs) + Dict d -> Dict (fmap stripTags d) + other -> other diff --git a/test/Figment/Test/Adversarial.hs b/test/Figment/Test/Adversarial.hs new file mode 100644 --- /dev/null +++ b/test/Figment/Test/Adversarial.hs @@ -0,0 +1,89 @@ +-- | Hostile input: limits are enforced inside the parsers, nothing +-- escapes as an exception. +module Figment.Test.Adversarial (tests) where + +import Control.DeepSeq (force) +import Control.Exception (SomeException, evaluate, try) +import qualified Data.ByteString as BS +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as TE +import Data.Word (Word8) +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +import Figment +import qualified Figment.Provider.Env as Env + +kinds :: Figment -> IO [ErrorKind] +kinds f = either (map errorKind . errorList) (const []) <$> load f + +deepArrays :: Int -> Text +deepArrays n = Text.replicate n "[" <> Text.replicate n "]" + +limits :: Int -> Int -> Limits +limits d n = either (const defaultLimits) id (mkLimits d n) + +tests :: TestTree +tests = + testGroup + "adversarial" + [ testCase "1M-deep JSON is rejected at the depth limit, quickly" $ do + k <- kinds (from (fromText json ("{\"a\":" <> deepArrays 1000000 <> "}"))) + k @?= [DepthExceeded 64] + , testCase "1M-deep YAML flow sequence is rejected" $ do + k <- kinds (from (fromText yaml ("a: " <> deepArrays 100000 <> "\n"))) + k @?= [DepthExceeded 64] + , testCase "deep TOML inline arrays are rejected" $ do + k <- kinds (from (fromText toml ("a = " <> deepArrays 10000 <> "\n"))) + k @?= [DepthExceeded 64] + , testCase "deep structured env values are rejected" $ do + k <- kinds (from (Env.fromList [("APP_X", deepArrays 10000)] (prefixed "APP_"))) + k @?= [DepthExceeded 64] + , testCase "depth limit is exact: 64 accepted, 65 rejected" $ do + let nestedJson n = Text.replicate n "{\"a\":" <> "1" <> Text.replicate n "}" + ok <- kinds (from (fromText json (nestedJson 64))) + ok @?= [] + bad <- kinds (from (fromText json (nestedJson 65))) + bad @?= [DepthExceeded 64] + , testCase "billion laughs: alias expansion is charged to the node limit" $ do + let lol = Text.unlines $ + "a: &a [x, x, x, x, x, x, x, x, x, x]" + : [ Text.pack (c : ": &" ++ [c] ++ " [" ++ concat (replicate 10 ('*' : [p] ++ ", ")) ++ "*" ++ [p] ++ "]") + | (c, p) <- zip "bcdefgh" "abcdefg" ] + k <- kinds (withLimits (limits 64 100000) (from (fromText yaml lol))) + k @?= [TooManyNodes 100000] + , testCase "huge exponents do not allocate huge integers" $ do + l <- load (from (fromText json "{\"n\":1e1000000000}")) >>= either (assertFailure . show) pure + case extractAt (keyPath "n") l :: Either ConfigErrors Integer of + Left es -> map errorKind (errorList es) @?= [InvalidValue "number 1.0e1000000000" "an integer with at most ~4096 digits"] + Right _ -> assertFailure "accepted" + case extractAt (keyPath "n") l :: Either ConfigErrors Int of + Left _ -> pure () + Right v -> assertFailure (show v) + , testCase "custom limits are validated" $ + case mkLimits 0 1 of + Left e -> errorKind e @?= InvalidArgument "maxDepth must be positive, got 0" + Right _ -> assertFailure "accepted" + , testProperty "no format throws on arbitrary bytes" $ \(bytes :: [Word8]) -> + ioProperty $ do + let bs = BS.pack bytes + txt = TE.decodeUtf8Lenient bs + rs <- mapM (\fmt -> try (load (from (fromText fmt txt)) >>= evaluate . force . either (Left . renderErrors) (Right . show . selected))) + [json, toml, yaml] + pure $ conjoin [counterexample (show e) False | Left (e :: SomeException) <- rs] + , testProperty "no format throws on near-miss documents" $ + forAll (elements seeds) $ \seed -> forAll (chooseInt (0, Text.length seed)) $ \cut -> + ioProperty $ do + rs <- mapM (\fmt -> try (load (from (fromText fmt (Text.take cut seed))) >>= evaluate . force . either (Left . renderErrors) (Right . show . selected))) + [json, toml, yaml] + pure $ conjoin [counterexample (show e) False | Left (e :: SomeException) <- rs] + ] + where + seeds = + [ "{\"a\": [1, 2, {\"b\": \"c\\u00e9\"}], \"d\": null}" + , "[t]\na = 1\nb = [1, 2]\nc = { d = \"e\" }\n[[u]]\nx = 2021-01-01\n" + , "a: &x [1, 2]\nb: *x\nc:\n <<: {k: v}\n d: 'q'\n" + ] + diff --git a/test/Figment/Test/Arbitrary.hs b/test/Figment/Test/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/test/Figment/Test/Arbitrary.hs @@ -0,0 +1,80 @@ +-- | Generators for configuration trees. +module Figment.Test.Arbitrary + ( genValue + , genDict + , genSameShape + , Shape (..) + , genShape + , fill + ) where + +import qualified Data.Map.Strict as Map +import qualified Data.Text as Text +import qualified Data.Vector as Vector +import Test.QuickCheck + +import Figment + +genKey :: Gen Text.Text +genKey = elements ["a", "b", "c", "d"] + +genScalar :: Gen Node +genScalar = + oneof + [ pure Null + , Bool <$> arbitrary + , Num . Finite . fromIntegral <$> chooseInt (-3, 3) + , String . Text.pack <$> elements ["x", "y", ""] + ] + +-- | Arbitrary values, with arbitrary (distinguishable) tags. +genValue :: Int -> Gen Value +genValue d = do + tag <- genTag + n <- + if d <= 0 + then genScalar + else + frequency + [ (2, genScalar) + , (2, Array . Vector.fromList <$> (chooseInt (0, 3) >>= \k -> vectorOf k (genValue (d - 1)))) + , (3, Dict . Map.fromList <$> (chooseInt (0, 3) >>= \k -> vectorOf k ((,) <$> genKey <*> genValue (d - 1)))) + ] + pure (Value tag n) + +genTag :: Gen Tag +genTag = do + i <- chooseInt (0, 5) + pure (Tag Nothing Nothing (Just (Pos i i)) Nothing) + +genDict :: Int -> Gen Value +genDict d = do + tag <- genTag + kvs <- chooseInt (0, 4) >>= \k -> vectorOf k ((,) <$> genKey <*> genValue (d - 1)) + pure (Value tag (Dict (Map.fromList kvs))) + +data Shape = SScalar | SArr [Shape] | SDict [(Text.Text, Shape)] + deriving stock (Show) + +genShape :: Int -> Gen Shape +genShape 0 = pure SScalar +genShape d = + frequency + [ (2, pure SScalar) + , (1, SArr <$> (chooseInt (0, 2) >>= \k -> vectorOf k (genShape (d - 1)))) + , (3, SDict . Map.toList . Map.fromList <$> (chooseInt (0, 3) >>= \k -> vectorOf k ((,) <$> genKey <*> genShape (d - 1)))) + ] + +-- | A value of the given shape with arbitrary leaves and tags. +fill :: Shape -> Gen Value +fill sh = do + tag <- genTag + case sh of + SScalar -> Value tag <$> genScalar + SArr xs -> Value tag . Array . Vector.fromList <$> traverse fill xs + SDict kvs -> Value tag . Dict . Map.fromList <$> traverse (\(k, s) -> (,) k <$> fill s) kvs + +genSameShape :: Gen (Value, Value, Value) +genSameShape = do + sh <- genShape 3 + (,,) <$> fill sh <*> fill sh <*> fill sh diff --git a/test/Figment/Test/Cli.hs b/test/Figment/Test/Cli.hs new file mode 100644 --- /dev/null +++ b/test/Figment/Test/Cli.hs @@ -0,0 +1,55 @@ +-- | Command-line arguments. +module Figment.Test.Cli (tests) where + +import qualified Data.Text as Text +import Test.Tasty +import Test.Tasty.HUnit + +import Figment +import Figment.Provider.Cli (Arg (..), parseArgs) +import qualified Figment.Value as V +import Figment.Value (stripTags) + +loadCli :: [Text.Text] -> IO (Either ConfigErrors Loaded) +loadCli = load . from . cli + +ok :: [Text.Text] -> IO Loaded +ok args = loadCli args >>= either (assertFailure . Text.unpack . renderErrors) pure + +at :: Text.Text -> Loaded -> Maybe Value +at k l = stripTags <$> findValue (keyPath k) l + +tests :: TestTree +tests = + testGroup + "cli" + [ testCase "REGRESSION C1: values are kept and typed" $ do + l <- ok ["--host=x", "--port=80"] + at "host" l @?= Just (V.string "x") + at "port" l @?= Just (V.number 80) + , testCase "flags, negated flags, dots and dashes" $ do + l <- ok ["--verbose", "--no-color", "--db.max-connections=5"] + at "verbose" l @?= Just (V.bool True) + at "color" l @?= Just (V.bool False) + at "db.max_connections" l @?= Just (V.number 5) + , testCase "last occurrence wins; -- ends options" $ do + l <- ok ["--a=1", "--a=2", "--", "--b=3"] + at "a" l @?= Just (V.number 2) + at "b" l @?= Nothing + , testCase "positional arguments are classified, not lost" $ + parseArgs (cli ["run", "-x", "--k=v", "--", "--z"]) + @?= [Positional "run", Positional "-x", Option "--k=v" ["k"] (Just "v"), Positional "--z"] + , testCase "malformed options are errors" $ do + r <- loadCli ["--=x", "--a..b=1"] + case r of + Left es -> length (errorList es) @?= 2 + Right _ -> assertFailure "expected errors" + , testCase "structural conflicts are errors" $ do + r <- loadCli ["--db=x", "--db.host=y"] + case r of + Left es -> map errorKind (errorList es) @?= [KeyConflict "--db=x" "--db.host=y"] + Right _ -> assertFailure "expected a conflict" + , testCase "keys are not lower-cased" $ do + l <- ok ["--Name=x"] + at "Name" l @?= Just (V.string "x") + ] diff --git a/test/Figment/Test/Decode.hs b/test/Figment/Test/Decode.hs new file mode 100644 --- /dev/null +++ b/test/Figment/Test/Decode.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE DerivingVia #-} +-- Sum types with record payloads are under test here, deliberately. +{-# OPTIONS_GHC -Wno-partial-fields #-} + +-- | The native decoder. +module Figment.Test.Decode (tests) where + +import qualified Data.Aeson as Aeson +import Data.Function ((&)) +import Data.Int (Int8) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Time (Day, fromGregorian) +import Data.Word (Word16) +import GHC.Generics (Generic) +import Test.Tasty +import Test.Tasty.HUnit + +import Figment +import qualified Figment.Jail as Jail +import qualified Figment.Provider.Env as Env + +data Server = Server {host :: Text, port :: Word16, tags :: [Text]} + deriving stock (Eq, Show, Generic) + deriving anyclass (FromConfig) + +data Level = Debug | Info | Warn + deriving stock (Eq, Show, Generic) + deriving anyclass (FromConfig) + +data Shape = Circle {radius :: Double} | Square {side :: Double} | Dot + deriving stock (Eq, Show, Generic) + deriving anyclass (FromConfig) + +newtype Port = Port Int + deriving stock (Eq, Show, Generic) + deriving anyclass (FromConfig) + +data Pair = Pair Int Text + deriving stock (Eq, Show, Generic) + deriving anyclass (FromConfig) + +data Strict = Strict {maxConnections :: Int, timeoutSecs :: Int} + deriving stock (Eq, Show, Generic) + +instance FromConfig Strict where + fromConfig = genericDecoder defaultOptions {fieldLabelModifier = snakeCase, rejectUnknownFields = True} + +data Opt = Opt {required' :: Int, optional' :: Maybe Int, withDefault :: Int} + deriving stock (Eq, Show, Generic) + +instance FromConfig Opt where + fromConfig = Opt <$> field "required" <*> optionalField "optional" <*> fieldOr "with_default" 42 + +newtype Legacy = Legacy (Map.Map Text Int) + deriving stock (Eq, Show) + deriving newtype (Aeson.FromJSON) + deriving (FromConfig) via (ViaAeson Legacy) + +data WithTagged = WithTagged {secret :: Tagged Text, dir :: RelativePath} + deriving stock (Eq, Show, Generic) + deriving anyclass (FromConfig) + +loadText :: Data -> IO Loaded +loadText d = load (from d) >>= either (assertFailure . Text.unpack . renderErrors) pure + +decodeJ :: FromConfig a => Text -> IO (Either ConfigErrors a) +decodeJ t = extract <$> loadText (fromText json t) + +paths :: ConfigErrors -> [Text] +paths = map (renderPath . errorPath) . errorList + +tests :: TestTree +tests = + testGroup + "decode" + [ testCase "records, lists, bounded ints" $ do + r <- decodeJ "{\"host\":\"h\",\"port\":8080,\"tags\":[\"a\",\"b\"]}" + r @?= Right (Server "h" 8080 ["a", "b"]) + , testCase "REGRESSION C3: the error points at the failing field, not the first key" $ do + r <- decodeJ "{\"host\":\"h\",\"port\":\"bad\",\"tags\":[]}" :: IO (Either ConfigErrors Server) + either paths (const []) r @?= ["port"] + , testCase "all errors are reported at once, each with its path" $ do + r <- decodeJ "{\"port\":70000,\"tags\":[\"ok\", 5]}" :: IO (Either ConfigErrors Server) + case r of + Left es -> do + paths es @?= ["host", "port", "tags[1]"] + map errorKind (errorList es) + @?= [ MissingField "host" + , InvalidValue "integer 70000" "an integer in the range 0..65535" + , InvalidType "integer 5" "a string" + ] + Right v -> assertFailure (show v) + , testCase "errors carry the source, line and column" $ do + l <- loadText (fromText toml "host = \"h\"\nport = \"x\"\ntags = []\n") + case extract l :: Either ConfigErrors Server of + Left es -> case errorList es of + [e] -> do + errorPos e @?= Just (Pos 2 8) + fmap metaName (errorMetadata e) @?= Just "TOML source string" + other -> assertFailure (show other) + Right v -> assertFailure (show v) + , testCase "out of range never wraps" $ do + r <- decodeJ "{\"n\":300}" :: IO (Either ConfigErrors (Map.Map Text Int8)) + either (map errorKind . errorList) (const []) r @?= [InvalidValue "integer 300" "an integer in the range -128..127"] + , testCase "non-integers are not truncated" $ do + r <- decodeJ "{\"n\":1.5}" :: IO (Either ConfigErrors (Map.Map Text Int)) + either (map errorKind . errorList) (const []) r @?= [InvalidValue "number 1.5" "an integer"] + , testCase "enums, case-insensitively; unknown variants list the options" $ do + r <- decodeJ "{\"a\":\"Debug\",\"b\":\"warn\"}" + r @?= Right (Map.fromList [("a" :: Text, Debug), ("b", Warn)]) + bad <- decodeJ "{\"a\":\"verbose\"}" :: IO (Either ConfigErrors (Map.Map Text Level)) + either (map errorKind . errorList) (const []) bad @?= [UnknownVariant "verbose" ["Debug", "Info", "Warn"]] + , testCase "sum types are externally tagged" $ do + r <- decodeJ "{\"xs\":[{\"Circle\":{\"radius\":1}}, {\"Square\":{\"side\":2}}, \"Dot\"]}" + r @?= Right (Map.fromList [("xs" :: Text, [Circle 1, Square 2, Dot])]) + , testCase "newtypes unwrap, positional constructors are arrays" $ do + p <- decodeJ "{\"p\":80}" + p @?= Right (Map.fromList [("p" :: Text, Port 80)]) + q <- decodeJ "{\"q\":[1,\"x\"]}" + q @?= Right (Map.fromList [("q" :: Text, Pair 1 "x")]) + , testCase "snake_case options and unknown-field suggestions" $ do + ok <- decodeJ "{\"max_connections\":1,\"timeout_secs\":2}" + ok @?= Right (Strict 1 2) + bad <- decodeJ "{\"max_conections\":1,\"timeout_secs\":2}" :: IO (Either ConfigErrors Strict) + case bad of + Left es -> map errorKind (errorList es) @?= [UnknownField "max_conections" ["max_connections"], MissingField "max_connections"] + Right v -> assertFailure (show v) + , testCase "hand-written decoders: optional and defaulted fields" $ do + r <- decodeJ "{\"required\":1}" + r @?= Right (Opt 1 Nothing 42) + , testCase "missing-field hints name every way to set it" $ do + l <- load (new & merge (fromText json "{}") & merge (Env.fromList [] (prefixed "APP_") & Env.split "__") & merge (cli [])) + >>= either (assertFailure . show) pure + case extract l :: Either ConfigErrors Server of + Left es -> case filter ((== MissingField "port") . errorKind) (errorList es) of + [e] -> do + let h = Text.unlines (errorHints e) + assertBool (Text.unpack h) ("`APP_PORT`" `Text.isInfixOf` h && "`--port`" `Text.isInfixOf` h) + other -> assertFailure (show other) + Right v -> assertFailure (show v) + , testCase "lossy extraction" $ do + l <- loadText (fromText json "{\"host\":5,\"port\":\"8080\",\"tags\":[]}") + case extract l :: Either ConfigErrors Server of + Left es -> length (errorList es) @?= 2 + Right v -> assertFailure (show v) + extractLossy l @?= Right (Server "5" 8080 []) + , testCase "Tagged and RelativePath know their source" $ withTmpToml $ \path -> do + l <- load (from (fileExact toml path)) >>= either (assertFailure . show) pure + case extract l of + Right (WithTagged s d) -> do + taggedValue s @?= "x" + taggedPath s @?= keyPath "secret" + fmap metaSource (taggedMetadata s) @?= Just (Just (FileSource path)) + relative d @?= dirOf path <> "/data" + Left e -> assertFailure (Text.unpack (renderErrors e)) + , testCase "ISO dates, NonEmpty, tuples" $ do + r <- decodeJ "{\"d\":\"2024-02-29\"}" + r @?= Right (Map.fromList [("d" :: Text, fromGregorian 2024 2 29 :: Day)]) + ne <- decodeJ "{\"xs\":[]}" :: IO (Either ConfigErrors (Map.Map Text (NonEmpty Int))) + either (map errorKind . errorList) (const []) ne @?= [InvalidLength 0 "a non-empty array"] + t <- decodeJ "{\"t\":[1,\"a\"]}" + t @?= Right (Map.fromList [("t" :: Text, (1 :: Int, "a" :: Text))]) + , testCase "ViaAeson bridge keeps the path of aeson's error" $ do + ok <- decodeJ "{\"legacy\":{\"a\":1}}" + ok @?= Right (Map.fromList [("legacy" :: Text, Legacy (Map.fromList [("a", 1)]))]) + bad <- decodeJ "{\"legacy\":{\"a\":\"x\"}}" :: IO (Either ConfigErrors (Map.Map Text Legacy)) + either paths (const []) bad @?= ["legacy.a"] + , testCase "validate attaches the location of the value" $ do + l <- loadText (fromText toml "port = 0\n") + let positive p = if (p :: Int) > 0 then Right p else Left "port must be positive" + d = fieldWith "port" (validate positive fromConfig) Nothing + case extractWith d l of + Left es -> map (\e -> (errorKind e, errorPos e)) (errorList es) @?= [(Message "port must be positive", Just (Pos 1 8))] + Right v -> assertFailure (show v) + ] + where + dirOf = reverse . drop 1 . dropWhile (/= '/') . reverse + +withTmpToml :: (FilePath -> IO a) -> IO a +withTmpToml k = Jail.withJail $ \j -> + Jail.createFile j "conf/app.toml" "secret = \"x\"\ndir = \"data\"\n" >>= k diff --git a/test/Figment/Test/Env.hs b/test/Figment/Test/Env.hs new file mode 100644 --- /dev/null +++ b/test/Figment/Test/Env.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +-- | Environment variables. +module Figment.Test.Env (tests) where + +import Data.Function ((&)) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as Text +import GHC.Generics (Generic) +import Test.Tasty +import Test.Tasty.HUnit + +import Figment +import qualified Figment.Jail as Jail +import qualified Figment.Provider.Env as Env +import Figment.Value (stripTags) +import qualified Figment.Value as V + +data Cfg = Cfg {host :: Text, port :: Int, max_connections :: Int, zip_code :: Text} + deriving stock (Eq, Show, Generic) + deriving anyclass (FromConfig) + +data Db = Db {host :: Text, port :: Int} + deriving stock (Eq, Show, Generic) + deriving anyclass (FromConfig) + +newtype Outer = Outer {db :: Db} + deriving stock (Eq, Show, Generic) + deriving anyclass (FromConfig) + +env :: [(Text, Text)] -> Env -> IO (Either ConfigErrors Loaded) +env vars e = load (from (Env.fromList vars e)) + +ok :: [(Text, Text)] -> Env -> IO Loaded +ok vars e = env vars e >>= either (assertFailure . Text.unpack . renderErrors) pure + +node :: Text -> Loaded -> Maybe Node +node k l = valueNode <$> findValue (keyPath k) l + +tests :: TestTree +tests = + testGroup + "env" + [ testCase "REGRESSION C1/H1: values are kept and typed" $ do + l <- ok [("APP_HOST", "x"), ("APP_PORT", "9000"), ("APP_MAX_CONNECTIONS", "5"), ("APP_ZIP_CODE", "01234"), ("OTHER", "1")] (prefixed "APP_") + extract l @?= Right (Cfg "x" 9000 5 "01234") + , testCase "REGRESSION H2: underscores stay in keys unless split is asked for" $ do + l <- ok [("APP_MAX_CONNECTIONS", "5")] (prefixed "APP_") + node "max_connections" l @?= Just (Num (Finite 5)) + l2 <- ok [("APP_DB__HOST", "h"), ("APP_DB__PORT", "5432")] (prefixed "APP_" & Env.split "__") + extract l2 @?= Right (Outer (Db "h" 5432)) + , testCase "prefix is case-insensitive, keys are lower-cased" $ do + l <- ok [("app_Host", "x")] (prefixed "APP_") + node "host" l @?= Just (String "x") + l2 <- ok [("APP_Host", "x")] (prefixed "APP_" & Env.lowercase False) + node "Host" l2 @?= Just (String "x") + , testCase "structured values" $ do + l <- ok [("APP_LIST", "[1, two, \"three\"]"), ("APP_MAP", "{a = 1, b = true}"), ("APP_Q", "\"quoted\"")] (prefixed "APP_") + fmap stripTags (findValue (keyPath "list") l) @?= Just (V.array [V.number 1, V.string "two", V.string "three"]) + fmap stripTags (findValue (keyPath "map") l) @?= Just (V.dict [("a", V.number 1), ("b", V.bool True)]) + node "q" l @?= Just (String "quoted") + , testCase "malformed structured text is just a string" $ do + l <- ok [("APP_X", "[1, 2")] (prefixed "APP_") + node "x" l @?= Just (String "[1, 2") + , testCase "conflicts are reported, not silently resolved" $ do + r <- env [("APP_DB", "x"), ("APP_DB__HOST", "y")] (prefixed "APP_" & Env.split "__") + case r of + Left es -> map errorKind (errorList es) @?= [KeyConflict "APP_DB" "APP_DB__HOST"] + Right _ -> assertFailure "expected a conflict" + r2 <- env [("APP_HOST", "a"), ("APP_host", "b")] (prefixed "APP_") + case r2 of + Left es -> map errorKind (errorList es) @?= [DuplicateKey "APP_HOST and APP_host"] + Right _ -> assertFailure "expected a duplicate" + , testCase "only / ignore / map / filter / ignoreEmpty" $ do + let vars = [("APP_A", "1"), ("APP_B", "2"), ("APP_C", ""), ("APP_D", "4")] + l <- ok vars (prefixed "APP_" & Env.only ["a", "C"]) + Map.keys <$> (extract l :: Either ConfigErrors (Map.Map Text Value)) @?= Right ["a", "c"] + l2 <- ok vars (prefixed "APP_" & Env.ignore ["a"] & Env.ignoreEmpty True) + Map.keys <$> (extract l2 :: Either ConfigErrors (Map.Map Text Value)) @?= Right ["b", "d"] + l3 <- ok vars (prefixed "APP_" & Env.mapKeys (<> "_x") & Env.filterKeys (/= "D_x")) + Map.keys <$> (extract l3 :: Either ConfigErrors (Map.Map Text Value)) @?= Right ["a_x", "b_x", "c_x"] + , testCase "unparsed keeps strings" $ do + l <- ok [("APP_N", "5")] (prefixed "APP_" & Env.unparsed) + node "n" l @?= Just (String "5") + , testCase "empty key segments are ignored" $ do + l <- ok [("APP_", "1"), ("APP_A____B", "2"), ("APP_OK", "3")] (prefixed "APP_" & Env.split "__") + Map.keys <$> (extract l :: Either ConfigErrors (Map.Map Text Value)) @?= Right ["ok"] + , testCase "profiles and global" $ do + l <- ok [("APP_PORT", "1")] (prefixed "APP_" & Env.inProfile "prod") + profiles l @?= ["prod"] + l2 <- ok [("APP_PORT", "1")] (prefixed "APP_" & Env.global) + profiles l2 @?= [Global] + , testCase "error messages name the variable" $ do + l <- ok [("APP_DB__PORT", "abc"), ("APP_DB__HOST", "h")] (prefixed "APP_" & Env.split "__") + case extract l :: Either ConfigErrors Outer of + Left es -> assertBool (Text.unpack (renderErrors es)) ("`APP_DB__PORT`" `Text.isInfixOf` renderErrors es) + Right v -> assertFailure (show v) + , testCase "reads the real process environment" $ Jail.withJail $ \j -> do + Jail.clearEnv j + Jail.setEnv j "JAILED_HOST" "real" + l <- load (from (prefixed "JAILED_")) >>= either (assertFailure . show) pure + node "host" l @?= Just (String "real") + ] diff --git a/test/Figment/Test/Errors.hs b/test/Figment/Test/Errors.hs new file mode 100644 --- /dev/null +++ b/test/Figment/Test/Errors.hs @@ -0,0 +1,67 @@ +-- | Golden tests for rendered error reports. The rendering is part of +-- the public interface (users read it); changing it is a visible change. +module Figment.Test.Errors (tests) where + +import qualified Data.ByteString.Lazy as BL +import Data.Function ((&)) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as TE +import GHC.Generics (Generic) +import Data.Word (Word16) +import Test.Tasty +import Test.Tasty.Golden (goldenVsString) + +import Figment +import qualified Figment.Provider.Env as Env + +data Db = Db {host :: Text, port :: Word16} + deriving stock (Show, Generic) + +instance FromConfig Db where + fromConfig = genericDecoder defaultOptions {rejectUnknownFields = True} + +data Cfg = Cfg {name :: Text, db :: Db, level :: Level} + deriving stock (Show, Generic) + deriving anyclass (FromConfig) + +data Level = Debug | Info + deriving stock (Show, Generic) + deriving anyclass (FromConfig) + +report :: Figment -> IO Text +report f = do + r <- load f + pure $ case r of + Left es -> renderErrors es + Right l -> case extract l :: Either ConfigErrors Cfg of + Left es -> renderErrors es + Right v -> Text.pack ("unexpected success: " ++ show v) + +golden :: String -> IO Text -> TestTree +golden n act = goldenVsString n ("test/golden/" ++ n ++ ".txt") (BL.fromStrict . TE.encodeUtf8 . (<> "\n") <$> act) + +tests :: TestTree +tests = + testGroup + "errors (golden)" + [ golden "decode-many" $ + report $ + new + & merge (fromText toml "[db]\nhost = \"h\"\nport = 70000\nhots = 1\n") + & merge (Env.fromList [("APP_LEVEL", "verbose")] (prefixed "APP_")) + , golden "missing" $ + report $ + new + & merge (fromText json "{\"db\":{\"host\":\"h\",\"port\":1},\"level\":\"Info\"}") + & merge (Env.fromList [] (prefixed "APP_") & Env.split "__") + & merge (cli []) + , golden "load-failures" $ + report $ + new + & merge (fromText yaml "a: 1\na: 2\n") + & merge (fromText toml "x = \n") + & merge (Env.fromList [("APP_DB", "1"), ("APP_DB__HOST", "2")] (prefixed "APP_" & Env.split "__")) + , golden "single" $ + report (new & merge (fromText json "{\"name\":\"n\",\"db\":{\"host\":\"h\",\"port\":\"x\"},\"level\":\"Debug\"}")) + ] diff --git a/test/Figment/Test/Figment.hs b/test/Figment/Test/Figment.hs new file mode 100644 --- /dev/null +++ b/test/Figment/Test/Figment.hs @@ -0,0 +1,112 @@ +-- | Loading, profiles, queries, composition. +module Figment.Test.Figment (tests) where + +import Control.Exception (ErrorCall (..), throwIO) +import Data.Function ((&)) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as Text +import GHC.Generics (Generic) +import GHC.Stack (SrcLoc (..)) +import Test.Tasty +import Test.Tasty.HUnit + +import Figment +import qualified Figment.Provider.Env as Env + +data Cfg = Cfg {name :: Text, port :: Int} + deriving stock (Eq, Show, Generic) + deriving anyclass (FromConfig) + +tomlProfiles :: Text +tomlProfiles = + "[default]\nname = \"base\"\nport = 1\n\n[debug]\nname = \"dbg\"\n\n[global]\nport = 9\n" + +loadOk :: Figment -> IO Loaded +loadOk f = load f >>= either (assertFailure . Text.unpack . renderErrors) pure + +tests :: TestTree +tests = + testGroup + "figment" + [ testCase "default profile, then selected, then global" $ do + let base = new & merge (nested (fromText toml tomlProfiles)) + l <- loadOk base + extract l @?= Right (Cfg "base" 9) + l' <- loadOk (base & select "debug") + extract l' @?= Right (Cfg "dbg" 9) + extract (reselect "DEBUG" l) @?= Right (Cfg "dbg" 9) + extract (reselect "missing" l) @?= Right (Cfg "base" 9) + , testCase "later providers win, even over globals of earlier ones" $ do + l <- loadOk $ + new + & merge (nested (fromText toml tomlProfiles)) + & merge (fromText toml "port = 7") + -- the second source writes to Default; Global of the first still wins + extract l @?= Right (Cfg "base" 9) + l2 <- loadOk $ + new + & merge (nested (fromText toml tomlProfiles)) + & merge (Env.global (Env.fromList [("APP_PORT", "7")] (prefixed "APP_"))) + extract l2 @?= Right (Cfg "base" 7) + , testCase "join only fills gaps" $ do + l <- loadOk $ + new + & merge (fromText json "{\"name\":\"a\"}") + & join (fromText json "{\"name\":\"b\",\"port\":2}") + extract l @?= Right (Cfg "a" 2) + , testCase "every failing provider is reported, not just the first" $ do + r <- load $ + new + & merge (required (fileExact toml "/nonexistent/a.toml")) + & merge (fromText json "{ not json") + & merge (fromText yaml "a: [1, 2") + case r of + Left es -> length (errorList es) @?= 3 + Right _ -> assertFailure "expected errors" + , testCase "an exception escaping a provider becomes an error" $ do + r <- load (from Boom) + case r of + Left es -> case errorList es of + [e] -> do + errorKind e @?= IoError "boom" + fmap metaName (errorMetadata e) @?= Just "boom provider" + other -> assertFailure (show other) + Right _ -> assertFailure "expected an error" + , testCase "metadata records where the provider was added" $ do + l <- loadOk (from (fromText json "{\"name\":\"x\",\"port\":1}")) + case loadedSources l of + [m] -> fmap srcLocFile (metaAddedAt m) @?= Just "test/Figment/Test/Figment.hs" + other -> assertFailure (show other) + , testCase "findValue / contains / findMetadata / extractAt / focus" $ do + l <- loadOk (from (fromText json "{\"db\":{\"host\":\"h\",\"port\":5}}")) + contains (keyPath "db.host") l @?= True + contains (keyPath "db.nope") l @?= False + fmap metaName (findMetadata (keyPath "db.port") l) @?= Just "JSON source string" + extractAt (keyPath "db.port") l @?= Right (5 :: Int) + extractLossy (focus (keyPath "db") l) @?= Right (Map.fromList [("host" :: Text, "h" :: Text), ("port", "5")]) + , testCase "a Figment is itself a provider, and keeps inner provenance" $ do + let inner = from (fromText yaml "name: inner\nport: 3\n") + l <- loadOk (new & merge inner & merge (fromText json "{\"port\":4}")) + extract l @?= Right (Cfg "inner" 4) + fmap metaName (findMetadata (keyPath "name") l) @?= Just "YAML source string" + , testCase "a provider's profile hint is honoured, explicit select wins" $ do + let hinted = new & merge (Hint "debug") & merge (nested (fromText toml tomlProfiles)) + l <- loadOk hinted + loadedProfile l @?= "debug" + l' <- loadOk (hinted & select Default) + loadedProfile l' @?= Default + ] + +data Boom = Boom + +instance Provider Boom where + metadata _ = named "boom provider" + provide _ _ = throwIO (ErrorCall "boom") + +newtype Hint = Hint Profile + +instance Provider Hint where + metadata _ = named "hint" + provide _ _ = pure (Right Map.empty) + providerProfile (Hint p) = Just p diff --git a/test/Figment/Test/MergeLaws.hs b/test/Figment/Test/MergeLaws.hs new file mode 100644 --- /dev/null +++ b/test/Figment/Test/MergeLaws.hs @@ -0,0 +1,83 @@ +-- | The algebra of 'coalesce' and of 'Figment' sequencing. +module Figment.Test.MergeLaws (tests) where + +import qualified Data.Map.Strict as Map +import qualified Data.Vector as Vector +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +import Figment +import Figment.Merge (coalesce) +import Figment.Test.Arbitrary +import Figment.Value (stripTags) + +tests :: TestTree +tests = + testGroup + "merge laws" + [ testProperty "duality: Join a b == Merge b a (including tags)" $ + forAll (genValue 3) $ \a -> forAll (genValue 3) $ \b -> + coalesce Join a b === coalesce Merge b a + , testProperty "idempotence of Merge and Join (data)" $ + forAll (genValue 3) $ \v -> + stripTags (coalesce Merge v v) === stripTags v + .&&. stripTags (coalesce Join v v) === stripTags v + , testProperty "empty dictionary is a left and right identity on dictionaries" $ + forAll (genDict 3) $ \v -> conjoin + [ stripTags (coalesce o (mkEmpty) v) === stripTags v .&&. stripTags (coalesce o v mkEmpty) === stripTags v + | o <- [minBound .. maxBound] ] + , testProperty "associative on same-shape trees, every order" $ + forAll genSameShape $ \(a, b, c) -> conjoin + [ coalesce o (coalesce o a b) c === coalesce o a (coalesce o b c) | o <- [minBound .. maxBound] ] + , testCase "not associative in general (why Value has no Semigroup)" $ do + let a = dictV [("x", num 1)] + b = num 5 + c = dictV [("y", num 2)] + assertBool "counterexample" $ + stripTags (coalesce Merge (coalesce Merge a b) c) /= stripTags (coalesce Merge a (coalesce Merge b c)) + , testCase "adjoin/admerge concatenate arrays; merge/join replace" $ do + let a = arr [num 1] + b = arr [num 2] + stripTags (coalesce Adjoin a b) @?= arr [num 1, num 2] + stripTags (coalesce Admerge a b) @?= arr [num 1, num 2] + stripTags (coalesce Merge a b) @?= arr [num 2] + stripTags (coalesce Join a b) @?= arr [num 1] + , testCase "container tags follow Rust: join keeps left, merge keeps right" $ do + let tl = Tag Nothing Nothing (Just (Pos 1 1)) Nothing + tr = Tag Nothing Nothing (Just (Pos 2 2)) Nothing + l = Value tl (Dict Map.empty) + r = Value tr (Dict Map.empty) + valueTag (coalesce Join l r) @?= tl + valueTag (coalesce Merge l r) @?= tr + , testProperty "Figment is a monoid (observationally: same loaded data)" $ + forAll (genDict 2) $ \a -> forAll (genDict 2) $ \b -> forAll (genDict 2) $ \c -> + ioProperty $ do + let fa = from (Const a) + fb = merge (Const b) new + fc = join (Const c) new + l1 <- loadedPlain ((fa <> fb) <> fc) + l2 <- loadedPlain (fa <> (fb <> fc)) + l3 <- loadedPlain (new <> fa) + l4 <- loadedPlain (fa <> new) + l5 <- loadedPlain fa + pure (l1 === l2 .&&. l3 === l5 .&&. l4 === l5) + ] + where + mkEmpty = Value (Tag Nothing Nothing Nothing Nothing) (Dict Map.empty) + num :: Int -> Value + num = Value (Tag Nothing Nothing Nothing Nothing) . Num . Finite . fromIntegral + arr = Value (Tag Nothing Nothing Nothing Nothing) . Array . Vector.fromList + dictV = Value (Tag Nothing Nothing Nothing Nothing) . Dict . Map.fromList + +-- | A provider returning a fixed dictionary. +newtype Const = Const Value + +instance Provider Const where + metadata _ = named "const" + provide _ (Const v) = pure $ case valueNode v of + Dict d -> Right (Map.singleton Default d) + _ -> Right Map.empty + +loadedPlain :: Figment -> IO (Maybe Value) +loadedPlain f = either (const Nothing) (Just . stripTags . selected) <$> load f diff --git a/test/Figment/Test/Partial.hs b/test/Figment/Test/Partial.hs new file mode 100644 --- /dev/null +++ b/test/Figment/Test/Partial.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE TypeFamilies #-} + +-- | Higher-kinded partial configurations. +module Figment.Test.Partial (tests) where + +import Data.Function ((&)) +import Data.Text (Text) +import qualified Data.Text as Text +import GHC.Generics (Generic) +import Test.Tasty +import Test.Tasty.HUnit + +import Figment +import qualified Figment.Provider.Env as Env + +data DbF f = Db + { url :: Field f Text + , pool :: Field f Int + } + deriving stock (Generic) + +instance Partial DbF + +data AppF f = App + { host :: Field f Text + , port :: Field f Int + , motd :: Field f (Maybe Text) + , db :: DbF f + } + deriving stock (Generic) + +instance Partial AppF + +deriving stock instance Eq (DbF Identity) +deriving stock instance Show (DbF Identity) +deriving stock instance Eq (AppF Identity) +deriving stock instance Show (AppF Identity) + +type App = AppF Identity + +partialDefaults :: AppF Maybe +partialDefaults = (emptyPartial @AppF) {port = Just 8080, db = (emptyPartial @DbF) {pool = Just 4}} + +totalDefaults :: App +totalDefaults = App "localhost" 8080 Nothing (Db "sqlite::memory:" 4) + +loaded :: [(Text, Text)] -> Text -> IO Loaded +loaded vars body = + load (new & merge (fromText toml body) & merge (Env.fromList vars (prefixed "APP_") & Env.split "__")) + >>= either (assertFailure . Text.unpack . renderErrors) pure + +tests :: TestTree +tests = + testGroup + "partial (HKD)" + [ testCase "defaults fill gaps; providers win; nested records" $ do + l <- loaded [("APP_DB__URL", "postgres://x")] "host = \"h\"\n" + extractPartial partialDefaults l @?= Right (App "h" 8080 Nothing (Db "postgres://x" 4)) + , testCase "every missing field is reported, with how to set it" $ do + l <- loaded [] "port = 1\n" + case extractPartial partialDefaults l of + Left es -> do + map errorKind (errorList es) @?= [MissingField "host", MissingField "url"] + map (renderPath . errorPath) (errorList es) @?= ["host", "db.url"] + let hints = Text.unlines (concatMap errorHints (errorList es)) + assertBool (Text.unpack hints) ("`APP_DB__URL`" `Text.isInfixOf` hints) + Right v -> assertFailure (show v) + , testCase "type errors in present fields are all reported" $ do + l <- loaded [] "port = \"x\"\n[db]\npool = \"y\"\n" + case extractPartial partialDefaults l of + Left es -> map (renderPath . errorPath) (errorList es) @?= ["port", "db.pool"] + Right v -> assertFailure (show v) + , testCase "total defaults: missing fields are impossible" $ do + l <- loaded [] "" + extractTotal totalDefaults l @?= Right totalDefaults + l2 <- loaded [("APP_PORT", "9")] "motd = \"hi\"\n" + extractTotal totalDefaults l2 @?= Right totalDefaults {port = 9, motd = Just "hi"} + , testCase "overlay is right-biased; total/complete round-trip" $ do + let a = (emptyPartial @AppF) {host = Just "a", port = Just 1} + b = (emptyPartial @AppF) {port = Just 2} + fmap port (complete defaultOptions (overlay (total totalDefaults) (overlay a b))) @?= Right 2 + complete defaultOptions (total totalDefaults) @?= Right totalDefaults + ] diff --git a/test/Figment/Test/Providers.hs b/test/Figment/Test/Providers.hs new file mode 100644 --- /dev/null +++ b/test/Figment/Test/Providers.hs @@ -0,0 +1,181 @@ +-- | File formats end to end. +module Figment.Test.Providers (tests) where + +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Time (Day, LocalTime, ZonedTime, zonedTimeToUTC, UTCTime) +import GHC.Generics (Generic) +import System.FilePath (()) +import Test.Tasty +import Test.Tasty.HUnit + +import Figment +import qualified Figment.Jail as Jail + +data Cfg = Cfg {host :: Text, port :: Int} + deriving stock (Eq, Show, Generic) + deriving anyclass (FromConfig) + +expectOk :: Figment -> IO Loaded +expectOk f = load f >>= either (assertFailure . Text.unpack . renderErrors) pure + +expectErr :: Figment -> IO [ConfigError] +expectErr f = load f >>= either (pure . errorList) (const (assertFailure "expected a load error")) + +kinds :: [ConfigError] -> [ErrorKind] +kinds = map errorKind + +tests :: TestTree +tests = + testGroup + "providers" + [ testGroup "files" fileTests + , testGroup "json" jsonTests + , testGroup "toml" tomlTests + , testGroup "yaml" yamlTests + , testGroup "serialized" serializedTests + ] + +fileTests :: [TestTree] +fileTests = + [ testCase "round trip in every format" $ Jail.withJail $ \j -> do + _ <- Jail.createFile j "a.json" "{\"host\":\"j\",\"port\":1}" + _ <- Jail.createFile j "a.toml" "host = \"t\"\nport = 2\n" + _ <- Jail.createFile j "a.yaml" "host: y\nport: 3\n" + mapM_ + (\(f, expected) -> expectOk (from f) >>= \l -> extract l @?= Right expected) + [ (file json "a.json", Cfg "j" 1) + , (file toml "a.toml", Cfg "t" 2) + , (file yaml "a.yaml", Cfg "y" 3) + ] + , testCase "a missing optional file contributes nothing" $ Jail.withJail $ \_ -> do + l <- expectOk (from (file toml "absent.toml")) + extract l @?= (Right Map.empty :: Either ConfigErrors (Map.Map Text Int)) + , testCase "a missing required file is an IoError naming the file" $ Jail.withJail $ \_ -> do + es <- expectErr (from (required (file toml "absent.toml"))) + case kinds es of + [IoError msg] -> assertBool (Text.unpack msg) ("absent.toml" `Text.isInfixOf` msg) + other -> assertFailure (show other) + , testCase "relative files are searched for in parent directories" $ Jail.withJail $ \j -> do + _ <- Jail.createFile j "App.toml" "host = \"up\"\nport = 1\n" + sub <- Jail.createDirectory j "a/b/c" + Jail.inDirectory j sub $ do + l <- expectOk (from (file toml "App.toml")) + extract l @?= Right (Cfg "up" 1) + fmap metaSource (findMetadata (keyPath "host") l) @?= Just (Just (FileSource (Jail.jailDirectory j "App.toml"))) + l2 <- expectOk (from (fileExact toml "App.toml")) + (extract l2 :: Either ConfigErrors (Map.Map Text Text)) @?= Right Map.empty + , testCase "top level must be a dictionary" $ do + es <- expectErr (from (fromText json "[1,2]")) + kinds es @?= [InvalidType "an array of length 2" "a dictionary at the top level"] + , testCase "nested files: top-level keys are profiles" $ do + l <- expectOk (from (nested (fromText yaml "default:\n host: d\n port: 1\nprod:\n host: p\n"))) + extract (reselect "prod" l) @?= Right (Cfg "p" 1) + es <- expectErr (from (nested (fromText yaml "default: 5\n"))) + kinds es @?= [InvalidType "integer 5" "a dictionary (nested files map profile names to dictionaries)"] + ] + +jsonTests :: [TestTree] +jsonTests = + [ testCase "duplicate keys are errors" $ do + es <- expectErr (from (fromText json "{\"a\":1,\"a\":2}")) + kinds es @?= [DuplicateKey "a"] + map (renderPath . errorPath) es @?= ["a"] + , testCase "syntax errors and trailing garbage" $ do + es <- expectErr (from (fromText json "{\"a\":1} x")) + case kinds es of + [SyntaxError _] -> pure () + other -> assertFailure (show other) + , testCase "big and precise numbers survive exactly" $ do + l <- expectOk (from (fromText json "{\"n\":123456789012345678901234567890.123456789}")) + fmap (valueNode) (findValue (keyPath "n") l) @?= Just (Num (Finite 123456789012345678901234567890.123456789)) + ] + +tomlTests :: [TestTree] +tomlTests = + [ testCase "dates and times decode into Data.Time types" $ do + l <- expectOk (from (fromText toml "d = 2024-01-02\nlt = 2024-01-02T03:04:05\nzt = 2024-01-02T03:04:05+05:30\n")) + extractAt (keyPath "d") l @?= Right (read "2024-01-02" :: Day) + extractAt (keyPath "lt") l @?= Right (read "2024-01-02 03:04:05" :: LocalTime) + fmap zonedTimeToUTC (extractAt (keyPath "zt") l :: Either ConfigErrors ZonedTime) + @?= Right (read "2024-01-01 21:34:05 UTC" :: UTCTime) + extractAt (keyPath "zt") l @?= Right (read "2024-01-01 21:34:05 UTC" :: UTCTime) + , testCase "inf and nan are kept, not corrupted" $ do + l <- expectOk (from (fromText toml "a = inf\nb = -inf\nc = nan\n")) + fmap valueNode (findValue (keyPath "a") l) @?= Just (Num PosInfinity) + fmap valueNode (findValue (keyPath "b") l) @?= Just (Num NegInfinity) + fmap valueNode (findValue (keyPath "c") l) @?= Just (Num NaN) + (extractAt (keyPath "a") l :: Either ConfigErrors Double) @?= Right (1 / 0) + case extractAt (keyPath "a") l :: Either ConfigErrors Int of + Left _ -> pure () + Right v -> assertFailure (show v) + , testCase "invalid UTF-8 is rejected (not replaced)" $ Jail.withJail $ \j -> do + p <- Jail.createBinaryFile j "bad.toml" "name = \"\xff\xfe\"\n" + es <- expectErr (from (fileExact toml p)) + case kinds es of + [SyntaxError msg] -> assertBool (Text.unpack msg) ("UTF-8" `Text.isInfixOf` msg) + other -> assertFailure (show other) + , testCase "syntax errors carry a position" $ do + es <- expectErr (from (fromText toml "a = 1\nb = = 2\n")) + map errorPos es @?= [Just (Pos 2 5)] + , testCase "redefinition is a duplicate key" $ do + es <- expectErr (from (fromText toml "a = 1\na = 2\n")) + kinds es @?= [DuplicateKey "a"] + ] + +yamlTests :: [TestTree] +yamlTests = + [ testCase "YAML 1.2 core schema: no Norway problem" $ do + l <- expectOk (from (fromText yaml "country: NO\nflag: on\nyes_: yes\nt: true\nn: ~\ni: 0x1F\nf: 1.5e3\nq: '42'\n")) + let node k = fmap valueNode (findValue (keyPath k) l) + node "country" @?= Just (String "NO") + node "flag" @?= Just (String "on") + node "yes_" @?= Just (String "yes") + node "t" @?= Just (Bool True) + node "n" @?= Just Null + node "i" @?= Just (Num (Finite 31)) + node "f" @?= Just (Num (Finite 1500)) + node "q" @?= Just (String "42") + , testCase "anchors, aliases and merge keys" $ do + l <- expectOk (from (fromText yaml "base: &b\n host: h\n port: 1\nsite:\n <<: *b\n port: 2\ncopy: *b\n")) + extractAt (keyPath "site") l @?= Right (Cfg "h" 2) + extractAt (keyPath "copy") l @?= Right (Cfg "h" 1) + , testCase "positions are one-based line and column" $ do + l <- expectOk (from (fromText yaml "a: 1\nb:\n c: x\n")) + fmap (tagPos . valueTag) (findValue (keyPath "b.c") l) @?= Just (Just (Pos 3 6)) + , testCase "duplicate keys and multiple documents are errors" $ do + es <- expectErr (from (fromText yaml "a: 1\na: 2\n")) + kinds es @?= [DuplicateKey "a"] + es2 <- expectErr (from (fromText yaml "a: 1\n---\nb: 2\n")) + case kinds es2 of + [SyntaxError m] -> assertBool (Text.unpack m) ("multiple" `Text.isInfixOf` m) + other -> assertFailure (show other) + , testCase "an empty file is an empty configuration" $ do + l <- expectOk (from (fromText yaml "")) + (extract l :: Either ConfigErrors (Map.Map Text Int)) @?= Right Map.empty + ] + +serializedTests :: [TestTree] +serializedTests = + [ testCase "defaults, keyed values and globals" $ do + l <- expectOk $ + new + `andThenMerge` defaults (Map.fromList [("host" :: Text, "d" :: Text)]) + `andThenMerge` keyed "port" (5 :: Int) + extract l @?= Right (Cfg "d" 5) + l2 <- expectOk (from (defaults (Map.fromList [("port" :: Text, 1 :: Int)])) <> from (globals (Map.fromList [("port" :: Text, 2 :: Int)]))) + extractAt (keyPath "port") (reselect "any" l2) @?= Right (2 :: Int) + , testCase "serialized values point at the Haskell source line" $ do + l <- expectOk (from (defaults (Map.fromList [("host" :: Text, "d" :: Text)]))) + case findMetadata (keyPath "host") l >>= metaSource of + Just (CodeSource _) -> pure () + other -> assertFailure (show other) + , testCase "a non-dictionary needs keyed" $ do + es <- expectErr (from (defaults (5 :: Int))) + case kinds es of + [InvalidType _ _] -> pure () + other -> assertFailure (show other) + ] + where + andThenMerge f p = merge p f diff --git a/test/Figment/Test/Readme.hs b/test/Figment/Test/Readme.hs new file mode 100644 --- /dev/null +++ b/test/Figment/Test/Readme.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE TypeFamilies #-} + +-- | The examples from README.md, compiled and run, so the README cannot +-- rot (it did in 0.1: its headline example did not compile). +module Figment.Test.Readme (tests) where + +import Data.Function ((&)) +import Data.Aeson ((.=)) +import qualified Data.Aeson as Aeson +import Data.Text (Text) +import qualified Data.Text as Text +import GHC.Generics (Generic) +import Test.Tasty +import Test.Tasty.HUnit + +import qualified Figment as F +import qualified Figment.Jail as Jail +import qualified Figment.Provider.Env as Env + +-- README: quick start --------------------------------------------------- + +data Config = Config + { name :: Text + , port :: Int + , debug :: Bool + } + deriving stock (Show, Eq, Generic) + deriving anyclass (F.FromConfig) + +figment :: F.Figment +figment = + F.new + & F.merge (F.defaults (Aeson.object ["port" .= (8080 :: Int), "debug" .= False])) + & F.merge (F.file F.toml "App.toml") + & F.merge (F.prefixed "APP_") + +-- README: partial configurations ------------------------------------------ + +data ServerF f = Server + { host :: F.Field f Text + , listen :: F.Field f Int + , workers :: F.Field f Int + } + deriving stock (Generic) + +instance F.Partial ServerF + +deriving stock instance Show (ServerF F.Identity) +deriving stock instance Eq (ServerF F.Identity) + +serverDefaults :: ServerF Maybe +serverDefaults = (F.emptyPartial @ServerF) {listen = Just 8080, workers = Just 4} + +tests :: TestTree +tests = + testGroup + "README" + [ testCase "quick start" $ Jail.withJail $ \j -> do + _ <- Jail.createFile j "App.toml" "name = \"demo\"\n" + Jail.setEnv j "APP_DEBUG" "true" + cfg <- F.loadExtractOrThrow figment + cfg @?= Config "demo" 8080 True + , testCase "partial configurations" $ do + l <- F.load (F.from (Env.fromList [("SRV_HOST", "0.0.0.0")] (F.prefixed "SRV_"))) + >>= either (assertFailure . Text.unpack . F.renderErrors) pure + F.extractPartial serverDefaults l @?= Right (Server "0.0.0.0" 8080 4) + ] diff --git a/test/Figment/Test/Tutorial.hs b/test/Figment/Test/Tutorial.hs new file mode 100644 --- /dev/null +++ b/test/Figment/Test/Tutorial.hs @@ -0,0 +1,233 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Every code snippet in "Figment.Tutorial", compiled and run. If you +-- change one, change the other. +module Figment.Test.Tutorial (tests) where + +import Data.Aeson ((.=)) +import qualified Data.Aeson as Aeson +import Data.Function ((&)) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as Text +import GHC.Generics (Generic) +import Test.Tasty +import Test.Tasty.HUnit + +import qualified Figment as F +import qualified Figment.Jail as Jail +import qualified Figment.Provider.Env as Env + +-- §2 Your first configuration --------------------------------------------- + +data Config = Config + { name :: Text + , port :: Int + , debug :: Bool + } + deriving stock (Show, Eq, Generic) + deriving anyclass (F.FromConfig) + +firstFigment :: F.Figment +firstFigment = F.from (F.file F.toml "App.toml") + +-- §3 Layering sources -------------------------------------------------------- + +layered :: [Text] -> F.Figment +layered args = + F.new + & F.merge (F.defaults (Aeson.object ["port" .= (8080 :: Int), "debug" .= False])) + & F.merge (F.file F.toml "App.toml") + & F.merge (F.prefixed "APP_") + & F.merge (F.cli args) + +-- §4 Environment variables --------------------------------------------------- + +data Db = Db {host :: Text, port :: Int} + deriving stock (Show, Eq, Generic) + deriving anyclass (F.FromConfig) + +newtype WithDb = WithDb {db :: Db} + deriving stock (Show, Eq, Generic) + deriving anyclass (F.FromConfig) + +dbFromEnv :: F.Figment +dbFromEnv = F.from (F.prefixed "APP_" & Env.split "__") + +-- §6 Profiles ---------------------------------------------------------------- + +profiled :: F.Profile -> F.Figment +profiled p = + F.new + & F.merge (F.nested (F.file F.toml "App.toml")) + & F.select p + +-- §8 Decoding in depth ------------------------------------------------------- + +data Level = Debug | Info | Warning + deriving stock (Show, Eq, Generic) + deriving anyclass (F.FromConfig) + +data Server = Server + { listenAddress :: Text + , maxConnections :: Int + , logLevel :: Level + } + deriving stock (Show, Eq, Generic) + +instance F.FromConfig Server where + fromConfig = + F.genericDecoder + F.defaultOptions + { F.fieldLabelModifier = F.snakeCase + , F.rejectUnknownFields = True + } + +newtype Port = Port Int + deriving stock (Show, Eq) + +instance F.FromConfig Port where + fromConfig = F.validate check F.fromConfig + where + check n + | n > 0 && n < 65536 = Right (Port n) + | otherwise = Left "a port must be between 1 and 65535" + +data Endpoint = Endpoint {url :: Text, timeout :: Int, retries :: Int} + deriving stock (Show, Eq) + +instance F.FromConfig Endpoint where + fromConfig = + Endpoint + <$> F.field "url" + <*> F.fieldOr "timeout" 30 + <*> F.fieldOr "retries" 3 + +-- §9 Provenance -------------------------------------------------------------- + +data Paths = Paths + { dataDir :: F.RelativePath + , token :: F.Tagged Text + } + deriving stock (Show, Eq, Generic) + +instance F.FromConfig Paths where + fromConfig = F.genericDecoder F.defaultOptions {F.fieldLabelModifier = F.snakeCase} + +-- §10 Partial configurations ------------------------------------------------- + +data AppF f = App + { appName :: F.Field f Text + , workers :: F.Field f Int + , motd :: F.Field f (Maybe Text) + } + deriving stock (Generic) + +instance F.Partial AppF + +deriving stock instance Show (AppF F.Identity) +deriving stock instance Eq (AppF F.Identity) + +type App = AppF F.Identity + +appDefaults :: AppF Maybe +appDefaults = (F.emptyPartial @AppF) {workers = Just 4} + +-- §11 For library authors ----------------------------------------------------- + +libraryFigment :: F.Figment +libraryFigment = + F.new + & F.merge (F.defaults (Aeson.object ["workers" .= (4 :: Int)])) + & F.merge (F.prefixed "MYLIB_") + +applicationFigment :: F.Figment +applicationFigment = libraryFigment <> F.from (F.file F.toml "MyApp.toml") + +-- §12 Writing a provider ------------------------------------------------------ + +-- | Configuration held in a Haskell map, e.g. fetched from a secrets +-- service at startup. +newtype Secrets = Secrets (Map.Map Text Text) + +instance F.Provider Secrets where + metadata _ = F.named "secrets service" + provide _limits (Secrets m) = + pure (Right (Map.singleton F.Default (fmap (F.Value untaggedTag . F.String) m))) + +untaggedTag :: F.Tag +untaggedTag = F.Tag Nothing Nothing Nothing Nothing + +-- tests -------------------------------------------------------------------- + +ok :: F.Figment -> IO F.Loaded +ok f = F.load f >>= either (assertFailure . Text.unpack . F.renderErrors) pure + +tests :: TestTree +tests = + testGroup + "tutorial" + [ testCase "§2 first configuration" $ Jail.withJail $ \j -> do + _ <- Jail.createFile j "App.toml" "name = \"demo\"\nport = 8080\ndebug = false\n" + cfg <- F.loadExtractOrThrow firstFigment + cfg @?= Config "demo" 8080 False + , testCase "§3 layering" $ Jail.withJail $ \j -> do + _ <- Jail.createFile j "App.toml" "name = \"demo\"\nport = 9000\n" + Jail.setEnv j "APP_DEBUG" "true" + cfg <- F.loadExtractOrThrow (layered ["--port=9100"]) + cfg @?= Config "demo" 9100 True + , testCase "§4 env" $ Jail.withJail $ \j -> do + Jail.setEnv j "APP_DB__HOST" "db.internal" + Jail.setEnv j "APP_DB__PORT" "5432" + cfg <- F.loadExtractOrThrow dbFromEnv + cfg @?= WithDb (Db "db.internal" 5432) + , testCase "§6 profiles" $ Jail.withJail $ \j -> do + _ <- Jail.createFile j "App.toml" $ Text.unlines + [ "[default]", "name = \"app\"", "port = 8080", "debug = true" + , "[production]", "port = 80", "debug = false" ] + dev <- F.loadExtractOrThrow (profiled F.Default) + prod <- F.loadExtractOrThrow (profiled "production") + dev @?= Config "app" 8080 True + prod @?= Config "app" 80 False + , testCase "§7 errors as values" $ do + l <- ok (F.from (F.fromText F.toml "name = 1\n")) + case F.extract l :: Either F.ConfigErrors Config of + Left errs -> map F.errorKind (F.errorList errs) + @?= [ F.InvalidType "integer 1" "a string", F.MissingField "port", F.MissingField "debug" ] + Right v -> assertFailure (show v) + , testCase "§8 decoding" $ do + l <- ok (F.from (F.fromText F.yaml "listen_address: 0.0.0.0\nmax_connections: 100\nlog_level: info\n")) + F.extract l @?= Right (Server "0.0.0.0" 100 Info) + l2 <- ok (F.from (F.fromText F.json "{\"port\": 0, \"api\": {\"url\": \"https://x\"}}")) + case F.extractAt (F.keyPath "port") l2 :: Either F.ConfigErrors Port of + Left errs -> map F.errorKind (F.errorList errs) @?= [F.Message "a port must be between 1 and 65535"] + Right v -> assertFailure (show v) + F.extractAt (F.keyPath "api") l2 @?= Right (Endpoint "https://x" 30 3) + , testCase "§9 provenance" $ Jail.withJail $ \j -> do + path <- Jail.createFile j "conf/app.toml" "data_dir = \"data\"\ntoken = \"t0k3n\"\n" + l <- ok (F.from (F.fileExact F.toml path)) + case F.extract l of + Right (Paths d t) -> do + F.relative d @?= Jail.jailDirectory j <> "/conf/data" + fmap F.metaName (F.taggedMetadata t) @?= Just "TOML file" + Left e -> assertFailure (Text.unpack (F.renderErrors e)) + , testCase "§10 partial" $ do + l <- ok (F.from (F.fromText F.toml "appName = \"x\"\n")) + F.extractPartial appDefaults l @?= (Right (App "x" 4 Nothing) :: Either F.ConfigErrors App) + l2 <- ok (F.from (F.fromText F.toml "")) + case F.extractPartial appDefaults l2 of + Left errs -> map F.errorKind (F.errorList errs) @?= [F.MissingField "appName"] + Right v -> assertFailure (show v) + , testCase "§11 library figments compose" $ Jail.withJail $ \j -> do + _ <- Jail.createFile j "MyApp.toml" "workers = 16\n" + l <- ok applicationFigment + F.extractAt (F.keyPath "workers") l @?= Right (16 :: Int) + , testCase "§12 custom provider" $ do + l <- ok (F.from (Secrets (Map.fromList [("token", "s3cret")]))) + F.extractAt (F.keyPath "token") l @?= Right ("s3cret" :: Text) + fmap F.metaName (F.findMetadata (F.keyPath "token") l) @?= Just "secrets service" + , testCase "§13 testing without global state" $ do + l <- ok (F.from (Env.fromList [("APP_PORT", "1")] (F.prefixed "APP_"))) + F.extractAt (F.keyPath "port") l @?= Right (1 :: Int) + ] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,33 @@ +module Main (main) where + +import Test.Tasty + +import qualified Figment.Test.Adversarial as Adversarial +import qualified Figment.Test.Cli as Cli +import qualified Figment.Test.Decode as Decode +import qualified Figment.Test.Env as Env +import qualified Figment.Test.Errors as Errors +import qualified Figment.Test.Figment as Figment +import qualified Figment.Test.MergeLaws as MergeLaws +import qualified Figment.Test.Partial as Partial +import qualified Figment.Test.Providers as Providers +import qualified Figment.Test.Readme as Readme +import qualified Figment.Test.Tutorial as Tutorial + +main :: IO () +main = + defaultMain $ + testGroup + "figment" + [ MergeLaws.tests + , Figment.tests + , Decode.tests + , Partial.tests + , Providers.tests + , Env.tests + , Cli.tests + , Errors.tests + , Adversarial.tests + , Readme.tests + , Tutorial.tests + ] diff --git a/test/compile-fail/EmptyType.hs b/test/compile-fail/EmptyType.hs new file mode 100644 --- /dev/null +++ b/test/compile-fail/EmptyType.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE DeriveAnyClass, DeriveGeneric, DerivingStrategies #-} +-- Must fail: an empty data type cannot be decoded. +module EmptyType where + +import GHC.Generics (Generic) +import Figment (FromConfig) + +data Never + deriving stock (Generic) + deriving anyclass (FromConfig) diff --git a/test/compile-fail/NoValueSemigroup.hs b/test/compile-fail/NoValueSemigroup.hs new file mode 100644 --- /dev/null +++ b/test/compile-fail/NoValueSemigroup.hs @@ -0,0 +1,8 @@ +-- Must fail: coalescing values is not associative, so Value has no +-- Semigroup instance (the lawful monoid is on Figment). +module NoValueSemigroup where + +import Figment (Value) + +combineValues :: Value -> Value -> Value +combineValues = (<>) diff --git a/test/compile-fail/Ok.hs b/test/compile-fail/Ok.hs new file mode 100644 --- /dev/null +++ b/test/compile-fail/Ok.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DeriveAnyClass, DeriveGeneric, DerivingStrategies, OverloadedStrings, TypeFamilies #-} +-- Must compile: the positive control for the fixtures above. +module Ok where + +import Data.Text (Text) +import GHC.Generics (Generic) +import Figment (Field, FromConfig, Partial, Figment, new, merge, prefixed) + +data AppF f = App {host :: Field f Text, port :: Field f Int} + deriving stock (Generic) + +instance Partial AppF + +data Plain = Plain {x :: Int} + deriving stock (Generic) + deriving anyclass (FromConfig) + +figment :: Figment +figment = merge (prefixed "APP_") new diff --git a/test/compile-fail/PartialSum.hs b/test/compile-fail/PartialSum.hs new file mode 100644 --- /dev/null +++ b/test/compile-fail/PartialSum.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE DeriveGeneric, DerivingStrategies, TypeFamilies #-} +-- Must fail: a Partial configuration must be a single-constructor record. +module PartialSum where + +import Data.Text (Text) +import GHC.Generics (Generic) +import Figment (Field, Partial) + +data ModeF f = A {a :: Field f Text} | B {b :: Field f Int} + deriving stock (Generic) + +instance Partial ModeF diff --git a/test/golden/decode-many.txt b/test/golden/decode-many.txt new file mode 100644 --- /dev/null +++ b/test/golden/decode-many.txt @@ -0,0 +1,15 @@ +4 configuration errors: + +error: missing field `name` + --> key `name` + = hint: no source sets it; it can be set as `name` in TOML source string, or `APP_NAME` in environment variables (prefix APP_) + +error: unknown field `hots` + --> key `db.hots` in TOML source string at line 4, column 8 + = hint: did you mean `host`? + +error: invalid value: found integer 70000, expected an integer in the range 0..65535 + --> key `db.port` in TOML source string at line 3, column 8 + +error: unknown variant `verbose`, expected one of `Debug`, `Info` + --> key `level` (`APP_LEVEL`) in environment variables (prefix APP_) diff --git a/test/golden/err-configuration.txt b/test/golden/err-configuration.txt new file mode 100644 --- /dev/null +++ b/test/golden/err-configuration.txt @@ -0,0 +1,1 @@ +ConfigurationError "Depth" "must be a positive Int" diff --git a/test/golden/err-decode.txt b/test/golden/err-decode.txt new file mode 100644 --- /dev/null +++ b/test/golden/err-decode.txt @@ -0,0 +1,1 @@ +DecodeError (Path [Key "port"]) "expected Int, got String" diff --git a/test/golden/err-depth.txt b/test/golden/err-depth.txt new file mode 100644 --- /dev/null +++ b/test/golden/err-depth.txt @@ -0,0 +1,1 @@ +DepthExceeded (Path [Key "a",Key "b",Key "3"]) (UnsafeDepth 64) diff --git a/test/golden/err-missing.txt b/test/golden/err-missing.txt new file mode 100644 --- /dev/null +++ b/test/golden/err-missing.txt @@ -0,0 +1,1 @@ +MissingKey (Path [Key "host"]) diff --git a/test/golden/err-source.txt b/test/golden/err-source.txt new file mode 100644 --- /dev/null +++ b/test/golden/err-source.txt @@ -0,0 +1,1 @@ +SourceError "config.toml" "unexpected token at line 3" diff --git a/test/golden/err-validation.txt b/test/golden/err-validation.txt new file mode 100644 --- /dev/null +++ b/test/golden/err-validation.txt @@ -0,0 +1,1 @@ +ValidationError (Path []) "port must be in 1..65535" diff --git a/test/golden/load-failures.txt b/test/golden/load-failures.txt new file mode 100644 --- /dev/null +++ b/test/golden/load-failures.txt @@ -0,0 +1,10 @@ +3 configuration errors: + +error: duplicate key `a` + --> key `a` in YAML source string at line 2, column 1 + +error: syntax error: parse error: unexpected end-of-line + --> top level in TOML source string at line 1, column 5 + +error: `APP_DB` conflicts with `APP_DB__HOST`: one sets a value where the other needs a dictionary + --> key `db` (`APP_DB`) in environment variables (prefix APP_) diff --git a/test/golden/missing.txt b/test/golden/missing.txt new file mode 100644 --- /dev/null +++ b/test/golden/missing.txt @@ -0,0 +1,3 @@ +error: missing field `name` + --> key `name` + = hint: no source sets it; it can be set as `name` in JSON source string, `APP_NAME` in environment variables (prefix APP_), or `--name` in command-line arguments diff --git a/test/golden/single.txt b/test/golden/single.txt new file mode 100644 --- /dev/null +++ b/test/golden/single.txt @@ -0,0 +1,2 @@ +error: invalid type: found string "x", expected an integer + --> key `db.port` in JSON source string