{-# 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,
namedOption,
overrideOptions,
overrideOptionsWith,
resolutionDiagnostic,
schemaDiagnostic,
setteiOptions,
)
where
import Control.Applicative qualified as Applicative
import Data.Generics.Labels ()
import Data.List.NonEmpty qualified as NonEmpty
import Data.Map.Strict qualified as Map
import Data.Text qualified as Text
import Options.Applicative (Mod, OptionFields, Parser)
import Options.Applicative qualified as Options
import Settei
import Settei.Prelude
-- | One parsed @--set KEY=VALUE@ override.
--
-- The constructor stays private because 'spelling' is safe origin text and must never
-- contain the raw value of a potentially secret setting.
data CliOverride = CliOverride
{ key :: !Key,
value :: !RawValue,
spelling :: !Text
}
deriving stock (Generic, Eq)
-- | Which configuration diagnostic, if any, an application should perform.
data DiagnosticMode
= NoDiagnostic
| ExplainText
| ExplainJson
| CheckConfig
| DescribeConfigText
| DescribeConfigJson
| DeploymentContractText
| DeploymentContractJson
deriving stock (Generic, Eq, Ord, Show)
-- | Reusable configuration and diagnostic command-line options.
data SetteiOptions = SetteiOptions
{ configPaths :: ![FilePath],
overrides :: ![CliOverride],
diagnosticMode :: !DiagnosticMode
}
deriving stock (Generic, Eq)
data ConfigurationOptions = ConfigurationOptions
{ configPaths :: ![FilePath],
overrides :: ![CliOverride]
}
deriving stock (Generic, Eq)
newtype DiagnosticOptions = DiagnosticOptions
{ diagnosticMode :: DiagnosticMode
}
deriving stock (Generic, Eq)
-- | Construct an override programmatically while keeping its origin spelling secret-safe.
cliOverride :: Key -> Text -> CliOverride
cliOverride key value =
CliOverride
{ key,
value = RawText value,
spelling = "--set " <> renderKey key
}
-- | Return the target key.
cliOverrideKey :: CliOverride -> Key
cliOverrideKey value = value ^. #key
-- | Return the raw text value for core decoding.
cliOverrideValue :: CliOverride -> RawValue
cliOverrideValue value = value ^. #value
-- | Return a safe spelling that names the option and key but omits its value.
cliOverrideSpelling :: CliOverride -> Text
cliOverrideSpelling value = value ^. #spelling
-- | Parse zero or more generic @--set KEY=VALUE@ overrides.
overrideOptions :: Parser [CliOverride]
overrideOptions =
overrideOptionsWith
( Options.long "set"
<> Options.metavar "KEY=VALUE"
<> Options.help "Override one configuration key"
)
-- | Parse generic overrides using caller-supplied option metadata.
overrideOptionsWith :: Mod OptionFields CliOverride -> Parser [CliOverride]
overrideOptionsWith modifiers = Applicative.many (Options.option overrideReader modifiers)
-- | Convert parsed overrides to low-to-high source fragments.
--
-- Each fragment has its own occurrence annotation, so repeated keys retain their full
-- shadow trace and the final list item wins under normal core resolution.
cliSources :: Text -> [CliOverride] -> [Source]
cliSources sourceLabel overrides =
zipWith (sourceForOverride sourceLabel) [1 :: Int ..] overrides
-- | Parse one optional named flag as a source fragment.
--
-- The supplied spelling should be safe display text such as @--port@. The caller controls
-- the target key and all optparse-applicative metadata.
namedOption :: Text -> Key -> Mod OptionFields Text -> Parser (Maybe Source)
namedOption spelling key modifiers =
fmap (namedSource spelling key) <$> Applicative.optional (Options.strOption modifiers)
-- | Parse zero or more @--config PATH@ occurrences without opening any file.
configPathOptions :: Parser [FilePath]
configPathOptions =
configPathOptionsWith
( Options.long "config"
<> Options.metavar "PATH"
<> Options.help "Read configuration from PATH"
)
-- | Parse config paths using caller-supplied option metadata.
configPathOptionsWith :: Mod OptionFields FilePath -> Parser [FilePath]
configPathOptionsWith modifiers = Applicative.many (Options.strOption modifiers)
-- | Parse the default mutually exclusive configuration diagnostic flags.
diagnosticModeOptions :: Parser DiagnosticMode
diagnosticModeOptions =
Options.flag' ExplainText (Options.long "explain-config" <> Options.help "Explain the resolved configuration as text")
Applicative.<|> Options.flag' ExplainJson (Options.long "explain-config-json" <> Options.help "Explain the resolved configuration as JSON")
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
-- | 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
-- | 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
where
assemble configuration diagnostics =
SetteiOptions
{ configPaths = configuration ^. #configPaths,
overrides = configuration ^. #overrides,
diagnosticMode = diagnostics ^. #diagnosticMode
}
configurationOptions :: Parser ConfigurationOptions
configurationOptions =
Options.parserOptionGroup
"Configuration"
(ConfigurationOptions <$> configPathOptions <*> overrideOptions)
diagnosticOptions :: Parser DiagnosticOptions
diagnosticOptions =
Options.parserOptionGroup
"Diagnostics"
(DiagnosticOptions <$> diagnosticModeOptions)
overrideReader :: Options.ReadM CliOverride
overrideReader = Options.eitherReader $ \input ->
let rendered = Text.pack input
(keyText, assignment) = Text.breakOn "=" rendered
in if Text.null assignment
then Left "expected KEY=VALUE"
else case parseKey keyText of
Left keyError -> Left ("invalid configuration key: " <> show keyError)
Right key -> Right (cliOverride key (Text.drop 1 assignment))
sourceForOverride :: Text -> Int -> CliOverride -> Source
sourceForOverride sourceLabel occurrence override =
annotateSource
( Map.fromList
[ ("command-line.option", "--set"),
("command-line.occurrence", Text.pack (show occurrence)),
("command-line.spelling", override ^. #spelling)
]
)
( source
(sourceLabel <> " --set #" <> Text.pack (show occurrence))
CommandLineSource
(rawValueAt (override ^. #key) (override ^. #value))
)
namedSource :: Text -> Key -> Text -> Source
namedSource spelling key value =
annotateSource
( Map.fromList
[ ("command-line.option", spelling),
("command-line.spelling", spelling)
]
)
(source spelling CommandLineSource (rawValueAt key (RawText value)))
rawValueAt :: Key -> RawValue -> RawValue
rawValueAt key value =
foldr
(\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"