diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,35 @@ # Changelog for settei-optparse-applicative +## 0.3.0.0 — 2026-10-21 + +### Breaking Changes + +- `DiagnosticMode` gains `DeploymentContractText` and `DeploymentContractJson`; update + exhaustive matches. +- Require `prepareDiagnostic` before runtime acquisition. Export `DiagnosticPreparation` + with rejected, rendered, and runtime-token decisions; `RuntimeDiagnosticMode` stays abstract. +- `resolutionDiagnostic` and `validatedDiagnostic` consume the checked runtime token and + return `DiagnosticDecision` (`DiagnosticFailure`, `DiagnosticOutput`, + `DiagnosticContinue`). Only successful normal execution continues; check success now + checks resolution itself. Migrate with the `settei-upgrade` Seihou blueprint. + +### New Features + +- Add deployment contract diagnostic flags (`--deployment-contract`, + `--deployment-contract-json`) and the `contractDiagnostic` rendering selector. +- Add `validatedDiagnostic`: startup and all diagnostic modes consume one validated + answer. Check success follows application validation. JSON explain failure emits error + and resolution documents on separate stderr lines, including on base resolution failures. +- Missing contract support (`Nothing`) rejects both contract modes with fixed plain text + `deployment contract diagnostic is unavailable\n` before any runtime work. Partial + schema/contract selectors remain rendering utilities, never startup permission. + +### Other Changes + +- Preserve version-1 successful JSON, bare text-plus-JSON and validated two-JSON failure + formats, and application-owned warning, stream, and exit policy. +- The `settei` and `settei-env` pins move to `==0.3.0.0`. + ## 0.2.0.0 — 2026-07-19 - Breaking: replace `ExplainMode` and its parsers with `DiagnosticMode`, which also diff --git a/settei-optparse-applicative.cabal b/settei-optparse-applicative.cabal --- a/settei-optparse-applicative.cabal +++ b/settei-optparse-applicative.cabal @@ -1,62 +1,68 @@ -cabal-version: 3.8 -name: settei-optparse-applicative -version: 0.2.0.0 -synopsis: optparse-applicative sources for Settei +cabal-version: 3.8 +name: settei-optparse-applicative +version: 0.3.0.0 +synopsis: optparse-applicative sources for Settei description: Parse generic and named command-line overrides into provenance-aware Settei source fragments while preserving occurrence order. -homepage: https://github.com/shinzui/settei -bug-reports: https://github.com/shinzui/settei/issues -license: BSD-3-Clause -license-file: LICENSE -author: shinzui -maintainer: shinzui -category: Configuration -build-type: Simple -tested-with: GHC ==9.12.4 +homepage: https://github.com/shinzui/settei +bug-reports: https://github.com/shinzui/settei/issues +license: BSD-3-Clause +license-file: LICENSE +author: shinzui +maintainer: shinzui +category: Configuration +build-type: Simple +tested-with: ghc ==9.12.4 extra-doc-files: CHANGELOG.md +extra-source-files: + test/compile-fail/OldResolutionDispatch.hs + test/compile-fail/OldValidatedDispatch.hs + test/compile-pass/CheckedDispatch.hs source-repository head - type: git + type: git location: https://github.com/shinzui/settei.git common common - default-language: GHC2024 + default-language: GHC2024 default-extensions: DeriveAnyClass DuplicateRecordFields OverloadedLabels OverloadedStrings - ghc-options: -Wall -Wcompat + ghc-options: + -Wall + -Wcompat library - import: common - hs-source-dirs: src + import: common + hs-source-dirs: src exposed-modules: Settei.Optparse build-depends: - , base >=4.21 && <5 - , containers >=0.6.8 && <0.8 - , generic-lens >=2.2 && <2.4 - , optparse-applicative >=0.19 && <0.20 - , settei ==0.2.0.0 - , text >=2.1 && <2.2 + base >=4.21 && <5, + containers >=0.6.8 && <0.8, + generic-lens >=2.2 && <2.4, + optparse-applicative >=0.19 && <0.20, + settei ==0.3.0.0, + text >=2.1 && <2.2, test-suite settei-optparse-applicative-tests - import: common - type: exitcode-stdio-1.0 + import: common + type: exitcode-stdio-1.0 hs-source-dirs: test - main-is: Main.hs - other-modules: Settei.OptparseTest + main-is: Main.hs + other-modules: Settei.OptparseTest build-depends: - , base >=4.21 && <5 - , containers >=0.6.8 && <0.8 - , generic-lens >=2.2 && <2.4 - , optparse-applicative >=0.19 && <0.20 - , settei ==0.2.0.0 - , settei-env ==0.2.0.0 - , settei-optparse-applicative ==0.2.0.0 - , tasty >=1.5 && <1.6 - , tasty-hunit >=0.10.2 && <0.11 - , text >=2.1 && <2.2 + base >=4.21 && <5, + containers >=0.6.8 && <0.8, + generic-lens >=2.2 && <2.4, + optparse-applicative >=0.19 && <0.20, + settei ==0.3.0.0, + settei-env ==0.3.0.0, + settei-optparse-applicative ==0.3.0.0, + tasty >=1.5 && <1.6, + tasty-hunit >=0.10.2 && <0.11, + text >=2.1 && <2.2, diff --git a/src/Settei/Optparse.hs b/src/Settei/Optparse.hs --- a/src/Settei/Optparse.hs +++ b/src/Settei/Optparse.hs @@ -1,15 +1,28 @@ +{-# OPTIONS_GHC -Werror=incomplete-patterns #-} + -- | -- Module: Settei.Optparse -- Description: optparse-applicative parsers that produce ordered Settei sources. +-- +-- Applications with validators must consume 'validatedDiagnostic' after 'validate', +-- rather than calling 'resolutionDiagnostic' on the pre-validation result. Always +-- use 'prepareDiagnostic' before source acquisition. Only a successful +-- 'DiagnosticContinue' authorizes application startup. module Settei.Optparse ( CliOverride, DiagnosticMode (..), + DiagnosticDecision (..), + RuntimeDiagnosticMode, + DiagnosticPreparation (..), + prepareDiagnostic, + validatedDiagnostic, SetteiOptions (..), cliOverride, cliOverrideKey, cliOverrideSpelling, cliOverrideValue, cliSources, + contractDiagnostic, configPathOptions, configPathOptionsWith, diagnosticModeOptions, @@ -51,6 +64,8 @@ | CheckConfig | DescribeConfigText | DescribeConfigJson + | DeploymentContractText + | DeploymentContractJson deriving stock (Generic, Eq, Ord, Show) -- | Reusable configuration and diagnostic command-line options. @@ -143,23 +158,71 @@ Applicative.<|> Options.flag' CheckConfig (Options.long "check-config" <> Options.help "Validate configuration and exit") Applicative.<|> Options.flag' DescribeConfigText (Options.long "describe-config" <> Options.help "Print the static configuration schema") Applicative.<|> Options.flag' DescribeConfigJson (Options.long "describe-config-json" <> Options.help "Print the static configuration schema as JSON") + Applicative.<|> Options.flag' DeploymentContractText (Options.long "deployment-contract" <> Options.help "Print the deployment configuration contract") + Applicative.<|> Options.flag' DeploymentContractJson (Options.long "deployment-contract-json" <> Options.help "Print the deployment configuration contract as JSON") Applicative.<|> pure NoDiagnostic --- | Render a diagnostic that must not load configuration sources. +-- | Partial schema rendering selector. Nothing means unhandled, never permission +-- to start. Use 'prepareDiagnostic' for complete dispatch before runtime work. schemaDiagnostic :: DiagnosticMode -> Schema -> Maybe Text schemaDiagnostic mode schema = case mode of DescribeConfigText -> Just (renderSchemaText schema) DescribeConfigJson -> Just (renderSchemaJson schema <> "\n") _ -> Nothing --- | Render a diagnostic available after resolution. -resolutionDiagnostic :: DiagnosticMode -> ResolveResult a -> Maybe Text -resolutionDiagnostic mode result = case mode of - ExplainText -> Just (renderResolutionText (result ^. #report)) - ExplainJson -> Just (renderResolutionJson (result ^. #report) <> "\n") - CheckConfig -> Just "configuration valid\n" - _ -> Nothing +-- | Runtime-only permission returned by 'prepareDiagnostic'. Constructors are private; +-- there is deliberately no Generic or Read instance or unchecked conversion. +-- Use the token for the invocation that produced it; do not cache or reuse it. +data RuntimeDiagnosticMode + = RuntimeNormal + | RuntimeCheck + | RuntimeExplainText + | RuntimeExplainJson +-- | Complete dispatch before acquiring any runtime inputs. +data DiagnosticPreparation + = DiagnosticRejected !Text + | DiagnosticRendered !Text + | DiagnosticNeedsRuntime !RuntimeDiagnosticMode + +-- | Select the mode before inspecting schema or optional contract support. +-- Nothing declares unavailable contract support. Runtime permission authorizes input +-- acquisition and resolution; only 'DiagnosticContinue' authorizes startup. +prepareDiagnostic :: DiagnosticMode -> Schema -> Maybe (Either (NonEmpty ConfigError) DeploymentContract) -> DiagnosticPreparation +prepareDiagnostic mode schema contract = case mode of + NoDiagnostic -> DiagnosticNeedsRuntime RuntimeNormal + CheckConfig -> DiagnosticNeedsRuntime RuntimeCheck + ExplainText -> DiagnosticNeedsRuntime RuntimeExplainText + ExplainJson -> DiagnosticNeedsRuntime RuntimeExplainJson + DescribeConfigText -> DiagnosticRendered (renderSchemaText schema) + DescribeConfigJson -> DiagnosticRendered (renderSchemaJson schema <> "\n") + DeploymentContractText -> prepareContract renderContractText + DeploymentContractJson -> prepareContract ((<> "\n") . renderContractJson) + where + prepareContract render = case contract of + Nothing -> DiagnosticRejected "deployment contract diagnostic is unavailable\n" + Just (Left errors) -> DiagnosticRejected (renderErrorsText errors) + Just (Right value) -> DiagnosticRendered (render value) + +-- | Dispatch a checked runtime request after resolution. This checks resolution only; +-- applications with invariants must 'validate' and use 'validatedDiagnostic'. +-- Warnings remain on the result for application-owned stream and exit policy. +resolutionDiagnostic :: RuntimeDiagnosticMode -> ResolveResult a -> DiagnosticDecision a +resolutionDiagnostic mode result = case result ^. #answer of + Left errors -> DiagnosticFailure $ case mode of + RuntimeNormal -> renderErrorsText errors + RuntimeCheck -> renderErrorsText errors + RuntimeExplainText -> renderErrorsText errors <> explanationText + RuntimeExplainJson -> renderErrorsText errors <> explanationJson + Right value -> case mode of + RuntimeNormal -> DiagnosticContinue value + RuntimeCheck -> DiagnosticOutput "configuration valid\n" + RuntimeExplainText -> DiagnosticOutput explanationText + RuntimeExplainJson -> DiagnosticOutput explanationJson + where + explanationText = renderResolutionText (result ^. #report) + explanationJson = renderResolutionJson (result ^. #report) <> "\n" + -- | Parse the reusable Configuration and Diagnostics option groups. setteiOptions :: Parser SetteiOptions setteiOptions = assemble <$> configurationOptions <*> diagnosticOptions @@ -224,3 +287,39 @@ (\segment child -> RawObject (Map.singleton segment child)) value (NonEmpty.toList (keySegments key)) + +-- | Partial contract rendering selector. Nothing means unhandled, never permission +-- to start. Other modes never force the contract; use 'prepareDiagnostic' for dispatch. +contractDiagnostic :: DiagnosticMode -> Either (NonEmpty ConfigError) DeploymentContract -> Maybe (Either (NonEmpty ConfigError) Text) +contractDiagnostic mode contract = case mode of + DeploymentContractText -> Just (renderContractText <$> contract) + DeploymentContractJson -> Just ((<> "\n") . renderContractJson <$> contract) + _ -> Nothing + +-- | A complete runtime dispatch decision. No Show or Eq instance because +-- the continue case carries a typed value that may contain secrets. +data DiagnosticDecision a + = DiagnosticFailure !Text + | DiagnosticOutput !Text + | DiagnosticContinue a + deriving stock (Generic) + +-- | Share rejection, provenance, and validation outcomes across startup and modes. +-- Failures go to stderr with the application's resolution exit code; output goes to +-- stdout with exit zero. Continue starts the application with the validated value. +validatedDiagnostic :: RuntimeDiagnosticMode -> ValidatedResult a -> DiagnosticDecision a +validatedDiagnostic mode result = + case result ^. #answer of + Left errors -> DiagnosticFailure $ case mode of + RuntimeExplainText -> renderErrorsText errors <> explanationText + RuntimeExplainJson -> renderErrorsJson errors <> "\n" <> explanationJson + RuntimeNormal -> renderErrorsText errors + RuntimeCheck -> renderErrorsText errors + Right value -> case mode of + RuntimeExplainText -> DiagnosticOutput explanationText + RuntimeExplainJson -> DiagnosticOutput explanationJson + RuntimeCheck -> DiagnosticOutput "configuration valid\n" + RuntimeNormal -> DiagnosticContinue value + where + explanationText = renderResolutionText (result ^. #report) <> renderValidationText (result ^. #validation) + explanationJson = renderValidatedResolutionJson (result ^. #report) (result ^. #validation) <> "\n" diff --git a/test/Settei/OptparseTest.hs b/test/Settei/OptparseTest.hs --- a/test/Settei/OptparseTest.hs +++ b/test/Settei/OptparseTest.hs @@ -1,6 +1,7 @@ module Settei.OptparseTest (tests) where import Data.Generics.Labels () +import Data.IORef (modifyIORef', newIORef, readIORef) import Data.List.NonEmpty qualified as NonEmpty import Data.Map.Strict qualified as Map import Data.Text qualified as Text @@ -16,7 +17,28 @@ tests = testGroup "Settei.Optparse" - [ testCase "final repeated --set wins with shadow trace" $ do + [ preparationTests, + validationTests, + testCase "deployment contract modes parse and reject combinations" $ do + mapM_ + ( \(flag, mode) -> do + parsed <- expectParse diagnosticModeOptions [flag] + parsed @?= mode + mapM_ + (\other -> assertBool "combined diagnostics parsed" (Options.getParseResult (parse diagnosticModeOptions [flag, other]) == Nothing)) + ["--check-config", "--describe-config", "--explain-config-json", if flag == "--deployment-contract" then "--deployment-contract-json" else "--deployment-contract"] + ) + [("--deployment-contract", DeploymentContractText), ("--deployment-contract-json", DeploymentContractJson)], + testCase "contract diagnostic is lazy for unrelated modes and preserves failures" $ do + mapM_ + (\mode -> contractDiagnostic mode (error "contract forced") @?= Nothing) + [NoDiagnostic, CheckConfig, DescribeConfigText, DescribeConfigJson, ExplainText, ExplainJson] + let contract = deploymentContract emptyContractInputs (required portSetting) + errors = DefaultCycle (DefaultCycleProblem (RuleName "loop" :| [])) :| [] + contractDiagnostic DeploymentContractText contract @?= Just (renderContractText <$> contract) + contractDiagnostic DeploymentContractJson contract @?= Just ((<> "\n") . renderContractJson <$> contract) + contractDiagnostic DeploymentContractText (Left errors) @?= Just (Left errors), + testCase "final repeated --set wins with shadow trace" $ do overrides <- expectParse overrideOptions ["--set", "service.port=9000", "--set", "service.port=9001"] environment <- environmentPort 8000 let result = @@ -92,8 +114,12 @@ result = resolve defaultResolveOptions [portSource "test" BuiltInSource 8080] (required portSetting) assertBool "text schema diagnostic missing" (schemaDiagnostic DescribeConfigText schema /= Nothing) assertBool "JSON schema diagnostic missing" (schemaDiagnostic DescribeConfigJson schema /= Nothing) - resolutionDiagnostic CheckConfig result @?= Just "configuration valid\n" - resolutionDiagnostic NoDiagnostic result @?= Nothing, + case resolutionDiagnostic (runtime CheckConfig) result of + DiagnosticOutput output -> output @?= "configuration valid\n" + _ -> fail "expected successful check" + case resolutionDiagnostic (runtime NoDiagnostic) result of + DiagnosticContinue value -> value @?= 8080 + _ -> fail "expected startup permission", testCase "help groups configuration and diagnostics by intent" $ do let parserInfo = Options.info (setteiOptions Options.<**> Options.helper) Options.fullDesc case Options.execParserPure Options.defaultPrefs parserInfo ["--help"] of @@ -101,6 +127,9 @@ let (helpText, _) = Options.renderFailure failure "settei-example" assertBool "Configuration group missing" ("Configuration" `Text.isInfixOf` Text.pack helpText) assertBool "Diagnostics group missing" ("Diagnostics" `Text.isInfixOf` Text.pack helpText) + mapM_ + (\flag -> assertBool "contract flag missing from help" (flag `Text.isInfixOf` Text.pack helpText)) + ["--deployment-contract", "--deployment-contract-json"] _ -> fail "expected --help to produce parser help" ] @@ -156,3 +185,247 @@ secretSentinel :: Text secretSentinel = "never-render-this-cli-secret" + +validationTests :: TestTree +validationTests = + testGroup + "validated diagnostics" + [ testCase "check succeeds only after validation and startup gets the same value" $ do + case validatedDiagnostic (runtime CheckConfig) passingResult of + DiagnosticOutput output -> output @?= "configuration valid\n" + _ -> fail "check did not succeed" + case validatedDiagnostic (runtime NoDiagnostic) passingResult of + DiagnosticContinue value -> assertBool "typed value changed" (Right value == validationBase [] ^. #answer) + _ -> fail "startup did not continue", + testCase "all runtime modes reject a failing validated result" $ + mapM_ + ( \mode -> case validatedDiagnostic (runtime mode) failingResult of + DiagnosticFailure output -> do + assertBool "rule missing" ("pool-covers-workers" `Text.isInfixOf` output) + assertBool "key missing" ("service.poolSize" `Text.isInfixOf` output) + assertBool "check falsely succeeded" (not ("configuration valid" `Text.isInfixOf` output)) + safe output + _ -> fail "invalid configuration accepted" + ) + modes, + testCase "text success and failure include provenance and outcomes" $ do + case validatedDiagnostic (runtime ExplainText) passingResult of + DiagnosticOutput output -> do + assertBool "setting missing" ("service.workers = \"4\"" `Text.isInfixOf` output) + assertBool "outcome missing" ("invariant pool-covers-workers [passed]" `Text.isInfixOf` output) + safe output + _ -> fail "explain did not succeed" + case validatedDiagnostic (runtime ExplainText) failingResult of + DiagnosticFailure output -> do + assertBool "origin missing" ("from environment source validation fixture" `Text.isInfixOf` output) + assertBool "failed trace missing" ("[failed (1 violation)]" `Text.isInfixOf` output) + safe output + _ -> fail "explain did not fail", + testCase "JSON success is one line and failure is two versioned documents" $ do + case validatedDiagnostic (runtime ExplainJson) passingResult of + DiagnosticOutput output -> do + length (Text.lines output) @?= 1 + assertBool "resolution type missing" ("{\"schemaVersion\":1,\"type\":\"settei.resolution\"" `Text.isPrefixOf` output) + assertBool "invariant array missing" ("\"invariants\":[{\"rule\":\"pool-covers-workers\"" `Text.isInfixOf` output) + safe output + _ -> fail "explain did not succeed" + case validatedDiagnostic (runtime ExplainJson) failingResult of + DiagnosticFailure output -> case Text.lines output of + [errors, report] -> do + assertBool "error document missing" ("{\"schemaVersion\":1,\"type\":\"settei.errors\"" `Text.isPrefixOf` errors) + assertBool "invariant kind missing" ("\"kind\":\"invariant\"" `Text.isInfixOf` errors) + assertBool "origin missing" ("\"name\":\"validation fixture\",\"key\":\"service.poolSize\"" `Text.isInfixOf` report) + assertBool "failed outcome missing" ("\"status\":\"failed\"" `Text.isInfixOf` report) + safe output + _ -> fail "expected two JSON documents" + _ -> fail "explain did not fail", + testCase "missing and decode failures retain original evidence and not-run outcomes" $ + mapM_ + ( \base -> do + let result = validate validationRules base + assertBool "answer changed" (result ^. #answer == base ^. #answer) + result ^. #report @?= base ^. #report + result ^. #warnings @?= base ^. #warnings + fmap (^. #status) (validationOutcomes (result ^. #validation)) @?= [InvariantNotRun] + case validatedDiagnostic (runtime ExplainText) result of + DiagnosticFailure output -> do + assertBool "not-run trace missing" ("[not run]" `Text.isInfixOf` output) + safe output + _ -> fail "base error accepted" + case validatedDiagnostic (runtime ExplainJson) result of + DiagnosticFailure output -> length (Text.lines output) @?= 2 + _ -> fail "base JSON error accepted" + ) + [ resolve defaultResolveOptions [] validationConfig, + validationBase [("service.workers", RawText "broken")] + ], + testCase "nonempty warnings and provenance survive runtime dispatch" $ do + let base = validationBase [("unknown.setting", RawText "public")] + result = validate validationRules base + assertBool "warning fixture empty" (not (null (base ^. #warnings))) + result ^. #warnings @?= base ^. #warnings + result ^. #report @?= base ^. #report + mapM_ + ( \mode -> case validatedDiagnostic (runtime mode) result of + DiagnosticContinue value -> assertBool "value changed" (Right value == base ^. #answer) + DiagnosticOutput output -> safe output + DiagnosticFailure _ -> fail "valid result rejected" + ) + [NoDiagnostic, CheckConfig, ExplainText, ExplainJson] + ] + where + passingResult = validate validationRules (validationBase []) + failingResult = validate validationRules (validationBase [("service.poolSize", RawText "1")]) + modes = [NoDiagnostic, ExplainText, ExplainJson, CheckConfig] + safe output = assertBool "secret escaped into diagnostic" (not (any (`Text.isInfixOf` output) [validationSentinel, "SETTEI_VALIDATION_SECRET_29"])) + +validationSentinel :: Text +validationSentinel = "SETTEI_VALIDATION_SECRET_29\"\\\n秘密" + +validationConfig :: Config (Int, Int, Text) +validationConfig = + (,,) + <$> required (publicSetting (validKey "service.workers") "workers" boundedIntegralDecoder) + <*> required (publicSetting (validKey "service.poolSize") "pool" boundedIntegralDecoder) + <*> required (secretSetting (validKey "service.token") "token" textDecoder) + +validationRules :: Validators (Int, Int, Text) +validationRules = + either (error . Text.unpack . renderValidatorErrorsText) id $ + validators validationConfig [check (InvariantRule "pool-covers-workers") (fmap validKey ["service.poolSize", "service.workers"]) "pool must cover workers" (\(workers, pool, _) -> pool >= workers)] + +validationBase :: [(Text, RawValue)] -> ResolveResult (Int, Int, Text) +validationBase changes = resolve defaultResolveOptions [input] validationConfig + where + pairs = [("service.workers", RawText "4"), ("service.poolSize", RawText "8"), ("service.token", RawText validationSentinel)] + input = either (const (error "invalid fixture")) id (sourceFromPairs "validation fixture" EnvironmentSource [(validKey name, value) | (name, value) <- changes <> filter (\(name, _) -> name `notElem` fmap fst changes) pairs]) + +-- Test-only extraction; production consumers must handle all preparation decisions. +runtime :: DiagnosticMode -> RuntimeDiagnosticMode +runtime mode = case prepareDiagnostic mode (error "schema forced") (error "contract forced") of + DiagnosticNeedsRuntime token -> token + DiagnosticRendered _ -> error "expected runtime mode" + DiagnosticRejected _ -> error "expected runtime mode" + +allModes :: [DiagnosticMode] +allModes = [NoDiagnostic, CheckConfig, ExplainText, ExplainJson, DescribeConfigText, DescribeConfigJson, DeploymentContractText, DeploymentContractJson] + +-- An exhaustive, independent expectation ensures newly added constructors need tests. +isRuntime :: DiagnosticMode -> Bool +isRuntime = \case + NoDiagnostic -> True + CheckConfig -> True + ExplainText -> True + ExplainJson -> True + DescribeConfigText -> False + DescribeConfigJson -> False + DeploymentContractText -> False + DeploymentContractJson -> False + +-- Consumer-shaped public API boundary: input acquisition and startup are separate. +consumer :: DiagnosticMode -> Maybe (Either (NonEmpty ConfigError) DeploymentContract) -> IO (ResolveResult Int) -> IO () -> IO (Int, Text, Text) +consumer mode contract acquire startup = + case prepareDiagnostic mode (describe (required portSetting)) contract of + DiagnosticRejected message -> pure (4, "", message) + DiagnosticRendered output -> pure (0, output, "") + DiagnosticNeedsRuntime token -> do + result <- acquire + case resolutionDiagnostic token result of + DiagnosticFailure message -> pure (4, "", message) + DiagnosticOutput output -> pure (0, output, renderWarningsText (result ^. #warnings)) + DiagnosticContinue _ -> startup >> pure (0, "started\n", renderWarningsText (result ^. #warnings)) + +preparationTests :: TestTree +preparationTests = + testGroup + "complete dispatch" + [ testCase "all eight modes acquire once and start only successful normal execution" $ + mapM_ + ( \mode -> do + acquisitions <- newIORef (0 :: Int) + starts <- newIORef (0 :: Int) + let result = resolve defaultResolveOptions [portSource "fixture" BuiltInSource 8080] (required portSetting) + (code, output, errors) <- consumer mode supported (modifyIORef' acquisitions (+ 1) >> pure result) (modifyIORef' starts (+ 1)) + code @?= 0 + errors @?= "" + assertBool "empty output" (not (Text.null output)) + readIORef acquisitions >>= (@?= if isRuntime mode then 1 else 0) + readIORef starts >>= (@?= if mode == NoDiagnostic then 1 else 0) + ) + allModes, + testCase "parsed contract flags reject omitted support before acquisition or startup" $ + mapM_ + ( \flag -> do + mode <- expectParse diagnosticModeOptions [flag] + result <- consumer mode Nothing poison poison + result @?= (4, "", "deployment contract diagnostic is unavailable\n") + (code, output, errors) <- consumer mode supported poison poison + code @?= 0 + errors @?= "" + assertBool "contract missing" ("service.port" `Text.isInfixOf` output) + ) + ["--deployment-contract", "--deployment-contract-json"], + testCase "mode selection leaves unrelated schema and contract unevaluated" $ do + mapM_ + ( \mode -> case prepareDiagnostic mode poisonValue poisonValue of + DiagnosticNeedsRuntime _ -> pure () + _ -> fail "expected runtime permission" + ) + [NoDiagnostic, CheckConfig, ExplainText, ExplainJson] + mapM_ + ( \mode -> case prepareDiagnostic mode (describe (required portSetting)) poisonValue of + DiagnosticRendered output -> assertBool "schema missing" ("service.port" `Text.isInfixOf` output) + _ -> fail "expected schema" + ) + [DescribeConfigText, DescribeConfigJson] + mapM_ + ( \mode -> case prepareDiagnostic mode poisonValue supported of + DiagnosticRendered output -> assertBool "contract missing" ("service.port" `Text.isInfixOf` output) + _ -> fail "expected contract" + ) + [DeploymentContractText, DeploymentContractJson], + testCase "contract construction errors reject safely before runtime" $ + mapM_ + ( \mode -> do + let problems = DefaultCycle (DefaultCycleProblem (RuleName "loop" :| [])) :| [] + consumer mode (Just (Left problems)) poison poison >>= (@?= (4, "", renderErrorsText problems)) + ) + [DeploymentContractText, DeploymentContractJson], + testCase "bare runtime dispatch preserves errors, provenance, JSON, warnings and secrets" $ + mapM_ + ( \mode -> + mapM_ + ( \base -> do + let result = resolutionDiagnostic (runtime mode) base + case base ^. #answer of + Left problems -> case result of + DiagnosticFailure output -> do + let suffix = case mode of + ExplainText -> renderResolutionText (base ^. #report) + ExplainJson -> renderResolutionJson (base ^. #report) <> "\n" + _ -> "" + output @?= renderErrorsText problems <> suffix + assertBool "false success" (not ("configuration valid" `Text.isInfixOf` output)) + safe output + _ -> fail "resolution failure accepted" + Right _ -> case result of + DiagnosticContinue _ -> mode @?= NoDiagnostic + DiagnosticOutput output -> do + assertBool "bare JSON gained invariants" (not ("invariants" `Text.isInfixOf` output)) + safe output + DiagnosticFailure _ -> fail "resolution success rejected" + ) + [validationBase [], resolve defaultResolveOptions [] validationConfig, validationBase [("service.workers", RawText "broken")], validationBase [("unknown.setting", RawText "public")]] + ) + [NoDiagnostic, CheckConfig, ExplainText, ExplainJson], + testCase "normal failure never starts" $ do + let missing = resolve defaultResolveOptions [] (required portSetting) + (code, output, _) <- consumer NoDiagnostic supported (pure missing) poison + code @?= 4 + output @?= "" + ] + where + supported = Just (deploymentContract emptyContractInputs (required portSetting)) + poison = fail "runtime effect invoked" + poisonValue = error "unused static input forced" + safe output = assertBool "secret leaked" (not (any (`Text.isInfixOf` output) [validationSentinel, "SETTEI_VALIDATION_SECRET_29"])) diff --git a/test/compile-fail/OldResolutionDispatch.hs b/test/compile-fail/OldResolutionDispatch.hs new file mode 100644 --- /dev/null +++ b/test/compile-fail/OldResolutionDispatch.hs @@ -0,0 +1,7 @@ +module OldResolutionDispatch (oldDispatch) where + +import Settei +import Settei.Optparse + +oldDispatch :: ResolveResult a -> DiagnosticDecision a +oldDispatch = resolutionDiagnostic DeploymentContractJson diff --git a/test/compile-fail/OldValidatedDispatch.hs b/test/compile-fail/OldValidatedDispatch.hs new file mode 100644 --- /dev/null +++ b/test/compile-fail/OldValidatedDispatch.hs @@ -0,0 +1,7 @@ +module OldValidatedDispatch (oldDispatch) where + +import Settei +import Settei.Optparse + +oldDispatch :: ValidatedResult a -> DiagnosticDecision a +oldDispatch = validatedDiagnostic DescribeConfigJson diff --git a/test/compile-pass/CheckedDispatch.hs b/test/compile-pass/CheckedDispatch.hs new file mode 100644 --- /dev/null +++ b/test/compile-pass/CheckedDispatch.hs @@ -0,0 +1,19 @@ +module CheckedDispatch (dispatch) where + +import Data.List.NonEmpty (NonEmpty) +import Data.Text (Text) +import Settei +import Settei.Optparse + +-- The caller owns stream routing, exit policy, and warning reporting. +dispatch :: DiagnosticMode -> Schema -> Maybe (Either (NonEmpty ConfigError) DeploymentContract) -> IO (ResolveResult a) -> (a -> IO ()) -> IO (Either Text Text) +dispatch mode schema contract acquire startup = + case prepareDiagnostic mode schema contract of + DiagnosticRejected problems -> pure (Left problems) + DiagnosticRendered output -> pure (Right output) + DiagnosticNeedsRuntime runtimeMode -> do + result <- acquire + case resolutionDiagnostic runtimeMode result of + DiagnosticFailure problems -> pure (Left problems) + DiagnosticOutput output -> pure (Right output) + DiagnosticContinue config -> startup config >> pure (Right mempty)