diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,6 @@ +# Changelog for settei-optparse-applicative + +## 0.1.0.0 — 2026-07-18 + +- Initial experimental release. +- Add ordered generic and named command-line overrides for optparse-applicative 0.19. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) 2026, shinzui +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/settei-optparse-applicative.cabal b/settei-optparse-applicative.cabal new file mode 100644 --- /dev/null +++ b/settei-optparse-applicative.cabal @@ -0,0 +1,62 @@ +cabal-version: 3.8 +name: settei-optparse-applicative +version: 0.1.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 +extra-doc-files: CHANGELOG.md + +source-repository head + type: git + location: https://github.com/shinzui/settei.git + +common common + default-language: GHC2024 + default-extensions: + DeriveAnyClass + DuplicateRecordFields + OverloadedLabels + OverloadedStrings + + ghc-options: -Wall -Wcompat + +library + import: common + hs-source-dirs: src + exposed-modules: Settei.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.1.0.0 + , text >=2.1 && <2.2 + +test-suite settei-optparse-applicative-tests + import: common + type: exitcode-stdio-1.0 + hs-source-dirs: test + 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.1.0.0 + , settei-env ==0.1.0.0 + , settei-optparse-applicative ==0.1.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 new file mode 100644 --- /dev/null +++ b/src/Settei/Optparse.hs @@ -0,0 +1,208 @@ +-- | +-- Module: Settei.Optparse +-- Description: optparse-applicative parsers that produce ordered Settei sources. +module Settei.Optparse + ( CliOverride, + ExplainMode (..), + SetteiOptions (..), + cliOverride, + cliOverrideKey, + cliOverrideSpelling, + cliOverrideValue, + cliSources, + configPathOptions, + configPathOptionsWith, + explainModeOptions, + explainModeOptionsWith, + namedOption, + overrideOptions, + overrideOptionsWith, + 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 (FlagFields, 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) + +-- | Whether an application should print a configuration explanation. +data ExplainMode = NoExplain | ExplainText | ExplainJson + deriving stock (Generic, Eq, Ord, Show) + +-- | Reusable configuration and diagnostic command-line options. +data SetteiOptions = SetteiOptions + { configPaths :: ![FilePath], + overrides :: ![CliOverride], + explainMode :: !ExplainMode + } + deriving stock (Generic, Eq) + +data ConfigurationOptions = ConfigurationOptions + { configPaths :: ![FilePath], + overrides :: ![CliOverride] + } + deriving stock (Generic, Eq) + +newtype DiagnosticOptions = DiagnosticOptions + { explainMode :: ExplainMode + } + 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 explanation flags. +explainModeOptions :: Parser ExplainMode +explainModeOptions = + explainModeOptionsWith + (Options.long "explain-config" <> Options.help "Explain the resolved configuration as text") + (Options.long "explain-config-json" <> Options.help "Explain the resolved configuration as JSON") + +-- | Parse caller-named mutually exclusive text and JSON explanation flags. +explainModeOptionsWith :: Mod FlagFields ExplainMode -> Mod FlagFields ExplainMode -> Parser ExplainMode +explainModeOptionsWith textModifiers jsonModifiers = + Options.flag' ExplainText textModifiers + Applicative.<|> Options.flag' ExplainJson jsonModifiers + Applicative.<|> pure NoExplain + +-- | 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, + explainMode = diagnostics ^. #explainMode + } + +configurationOptions :: Parser ConfigurationOptions +configurationOptions = + Options.parserOptionGroup + "Configuration" + (ConfigurationOptions <$> configPathOptions <*> overrideOptions) + +diagnosticOptions :: Parser DiagnosticOptions +diagnosticOptions = + Options.parserOptionGroup + "Diagnostics" + (DiagnosticOptions <$> explainModeOptions) + +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)) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,7 @@ +module Main (main) where + +import Settei.OptparseTest qualified +import Test.Tasty (defaultMain, testGroup) + +main :: IO () +main = defaultMain (testGroup "settei-optparse-applicative" [Settei.OptparseTest.tests]) diff --git a/test/Settei/OptparseTest.hs b/test/Settei/OptparseTest.hs new file mode 100644 --- /dev/null +++ b/test/Settei/OptparseTest.hs @@ -0,0 +1,144 @@ +module Settei.OptparseTest (tests) where + +import Data.Generics.Labels () +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import Data.Text qualified as Text +import Options.Applicative qualified as Options +import Settei +import Settei.Env +import Settei.Optparse +import Settei.Prelude +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "Settei.Optparse" + [ testCase "final repeated --set wins with shadow trace" $ do + overrides <- expectParse overrideOptions ["--set", "service.port=9000", "--set", "service.port=9001"] + environment <- environmentPort 8000 + result <- + expectResolution + ( resolve + defaultResolveOptions + ([portSource "built-in" BuiltInSource 6000, portSource "file" (FileSource "memory") 7000, environment] <> cliSources "arguments" overrides) + (required portSetting) + ) + result ^. #value @?= 9001 + case result ^. #report . #nodes . at servicePort of + Just node -> do + node ^. #origin . _Just . #annotations . at "command-line.occurrence" @?= Just "2" + fmap (^. #name) (node ^. #shadowed) + @?= ["arguments --set #1", "environment", "file", "built-in"] + Nothing -> fail "expected the resolved port node", + testCase "execParserPure rejects an invalid key" $ do + let parsed = parse overrideOptions ["--set", "service..port=9000"] + assertBool "invalid key unexpectedly parsed" (Options.getParseResult parsed == Nothing), + testCase "malformed final CLI value does not fall back" $ do + overrides <- expectParse overrideOptions ["--set", "service.port=9000", "--set", "service.port=broken"] + environment <- environmentPort 8000 + case resolve defaultResolveOptions (environment : cliSources "arguments" overrides) (required portSetting) of + Left errors -> case NonEmpty.toList errors of + [DecodeError problem] -> do + problem ^. #origin . #name @?= "arguments --set #2" + problem ^. #origin . #annotations . at "command-line.occurrence" @?= Just "2" + _ -> fail "expected one CLI decode error" + Right _ -> fail "expected the malformed final override to fail", + testCase "secret override spelling omits the value" $ do + overrides <- expectParse overrideOptions ["--set", "database.password=" <> Text.unpack secretSentinel] + result <- expectResolution (resolve defaultResolveOptions (cliSources "arguments" overrides) (required passwordSetting)) + let textOutput = renderResolutionText (result ^. #report) + jsonOutput = renderResolutionJson (result ^. #report) + assertBool "secret reached text output" (not (secretSentinel `Text.isInfixOf` textOutput)) + assertBool "secret reached JSON output" (not (secretSentinel `Text.isInfixOf` jsonOutput)) + case overrides of + [override] -> cliOverrideSpelling override @?= "--set database.password" + _ -> fail "expected one secret override", + testCase "named option produces an optional source fragment" $ do + input <- + expectParse + (namedOption "--port" servicePort (Options.long "port" <> Options.metavar "PORT")) + ["--port", "8080"] + case input of + Nothing -> fail "expected the named option source" + Just sourceValue -> do + result <- expectResolution (resolve defaultResolveOptions [sourceValue] (required portSetting)) + result ^. #value @?= 8080, + testCase "setteiOptions parses grouped paths, overrides, and diagnostics" $ do + parsed <- + expectParse + setteiOptions + [ "--config", + "base.yaml", + "--config", + "local.yaml", + "--set", + "service.port=8080", + "--explain-config-json" + ] + parsed ^. #configPaths @?= ["base.yaml", "local.yaml"] + length (parsed ^. #overrides) @?= 1 + parsed ^. #explainMode @?= ExplainJson, + testCase "explanation modes are mutually exclusive" $ do + let parsed = parse explainModeOptions ["--explain-config", "--explain-config-json"] + assertBool "both explanation modes unexpectedly parsed" (Options.getParseResult parsed == Nothing), + 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 + Options.Failure failure -> do + 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) + _ -> fail "expected --help to produce parser help" + ] + +parse :: Options.Parser a -> [String] -> Options.ParserResult a +parse parser arguments = + Options.execParserPure Options.defaultPrefs (Options.info parser Options.fullDesc) arguments + +expectParse :: Options.Parser a -> [String] -> IO a +expectParse parser arguments = + case Options.getParseResult (parse parser arguments) of + Nothing -> fail "expected command-line parsing to succeed" + Just value -> pure value + +expectResolution :: Either (NonEmpty ConfigError) a -> IO a +expectResolution = \case + Left _ -> fail "expected configuration resolution to succeed" + Right value -> pure value + +environmentPort :: Int -> IO Source +environmentPort value = + case envSource + "environment" + [binding (EnvName "SERVICE_PORT") servicePort] + (envSnapshot [("SERVICE_PORT", Text.pack (show value))]) of + Left _ -> fail "expected a valid environment source" + Right sourceValue -> pure sourceValue + +portSource :: Text -> SourceKind -> Int -> Source +portSource name kind value = + source + name + kind + (RawObject (Map.singleton "service" (RawObject (Map.singleton "port" (RawNumber (fromIntegral value)))))) + +portSetting :: Setting Int +portSetting = publicSetting servicePort "Service port" boundedIntegralDecoder + +passwordSetting :: Setting Text +passwordSetting = secretSetting databasePassword "Database password" textDecoder + +servicePort :: Key +servicePort = validKey "service.port" + +databasePassword :: Key +databasePassword = validKey "database.password" + +validKey :: Text -> Key +validKey value = either (error . show) id (parseKey value) + +secretSentinel :: Text +secretSentinel = "never-render-this-cli-secret"