diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,19 @@ # Changelog +## [0.13.0.0] - 2025-11-18 + +### Added + +* Capability support for settings. + +This is technically a breaking change, but if you don't use any `opt-env-conf` +internals, nothing should break for you. + +### Changed + +* Renamed `requireCapability` to `checkWithRequiredCapability`. +* Fixed that `showSettingABit` did not show every part of a setting. + ## [0.12.2.0] - 2025-11-18 ### Changed diff --git a/opt-env-conf.cabal b/opt-env-conf.cabal --- a/opt-env-conf.cabal +++ b/opt-env-conf.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: opt-env-conf -version: 0.12.2.0 +version: 0.13.0.0 synopsis: Settings parsing for Haskell: command-line arguments, environment variables, and configuration values. homepage: https://github.com/NorfairKing/opt-env-conf#readme bug-reports: https://github.com/NorfairKing/opt-env-conf/issues @@ -26,6 +26,7 @@ exposed-modules: OptEnvConf OptEnvConf.Args + OptEnvConf.Capability OptEnvConf.Casing OptEnvConf.Check OptEnvConf.Completer @@ -67,6 +68,7 @@ , text , validity , validity-containers + , validity-text default-language: Haskell2010 if !os(windows) build-depends: diff --git a/src/OptEnvConf.hs b/src/OptEnvConf.hs --- a/src/OptEnvConf.hs +++ b/src/OptEnvConf.hs @@ -37,6 +37,7 @@ hidden, metavar, completer, + requiredCapability, -- ** Commands commands, @@ -85,6 +86,7 @@ checkMapIOForgivable, checkMapMaybeForgivable, checkMapMaybe, + checkWithRequiredCapability, mapIO, choice, withDefault, @@ -112,6 +114,7 @@ readSecretTextFile, secretTextFileSetting, secretTextFileOrBareSetting, + readSecretCapability, -- *** Migration strOption, @@ -137,6 +140,7 @@ module OptEnvConf.Casing, module OptEnvConf.Doc, module OptEnvConf.Nix, + module OptEnvConf.Capability, module OptEnvConf.Parser, module OptEnvConf.Completer, module OptEnvConf.Reader, @@ -147,6 +151,7 @@ where import Control.Applicative +import OptEnvConf.Capability import OptEnvConf.Casing import OptEnvConf.Completer import OptEnvConf.Doc diff --git a/src/OptEnvConf/Capability.hs b/src/OptEnvConf/Capability.hs new file mode 100644 --- /dev/null +++ b/src/OptEnvConf/Capability.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module OptEnvConf.Capability + ( Capabilities (..), + Capability (..), + allCapabilities, + enableCapability, + disableCapability, + missingCapabilities, + + -- * Predefined capabilities + readSecretCapability, + ) +where + +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import Data.Set (Set) +import qualified Data.Set as Set +import Data.String +import Data.Text (Text) +import Data.Validity +import Data.Validity.Containers () +import Data.Validity.Text () +import GHC.Generics (Generic) + +-- Set of disabled capabilities +newtype Capabilities = Capabilities {unCapabilities :: Set Capability} + deriving (Show, Generic) + +instance Validity Capabilities + +allCapabilities :: Capabilities +allCapabilities = Capabilities {unCapabilities = Set.empty} + +enableCapability :: Capability -> Capabilities -> Capabilities +enableCapability cap (Capabilities caps) = + Capabilities (Set.delete cap caps) + +disableCapability :: Capability -> Capabilities -> Capabilities +disableCapability cap (Capabilities caps) = + Capabilities (Set.insert cap caps) + +missingCapabilities :: Capabilities -> Set Capability -> Maybe (NonEmpty Capability) +missingCapabilities (Capabilities caps) requiredCapabilities = + NE.nonEmpty (Set.toList (Set.intersection requiredCapabilities caps)) + +newtype Capability = Capability {unCapability :: Text} + deriving stock (Generic) + deriving newtype (Show, Eq, Ord, IsString) + +instance Validity Capability + +-- | The annotation for any setting reading secrets. +-- +-- We add these so that we can disable them in settings checks, to avoid +-- failing settings checks when secrets are read at runtime instead of +-- build-time. +readSecretCapability :: String +readSecretCapability = "read-secret" diff --git a/src/OptEnvConf/Check.hs b/src/OptEnvConf/Check.hs --- a/src/OptEnvConf/Check.hs +++ b/src/OptEnvConf/Check.hs @@ -16,6 +16,7 @@ import GHC.Generics (Generic) import GHC.Stack (SrcLoc) import OptEnvConf.Args as Args +import OptEnvConf.Capability import OptEnvConf.EnvMap (EnvMap (..)) import OptEnvConf.Error import OptEnvConf.Parser diff --git a/src/OptEnvConf/Main.hs b/src/OptEnvConf/Main.hs --- a/src/OptEnvConf/Main.hs +++ b/src/OptEnvConf/Main.hs @@ -11,6 +11,7 @@ import qualified Data.Text as T import Data.Version import OptEnvConf.Args as Args +import OptEnvConf.Capability import OptEnvConf.Check import OptEnvConf.Completion import OptEnvConf.Doc diff --git a/src/OptEnvConf/Parser.hs b/src/OptEnvConf/Parser.hs --- a/src/OptEnvConf/Parser.hs +++ b/src/OptEnvConf/Parser.hs @@ -1,8 +1,6 @@ {-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} @@ -27,8 +25,8 @@ checkMapEitherForgivable, checkMapIOForgivable, checkMapMaybeForgivable, + checkWithRequiredCapability, allOrNothing, - requireCapability, commands, command, defaultCommand, @@ -105,10 +103,9 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T -import Data.Validity -import GHC.Generics (Generic) import GHC.Stack (HasCallStack, SrcLoc, callStack, getCallStack, withFrozenCallStack) import OptEnvConf.Args (Dashed (..), prefixDashed) +import OptEnvConf.Capability import OptEnvConf.Casing import OptEnvConf.Completer import OptEnvConf.Reader @@ -226,20 +223,6 @@ !(Setting a) -> Parser a -newtype Capability = Capability {unCapability :: Text} - deriving stock (Generic) - deriving newtype (Show, Eq, Ord, IsString) - -instance Validity Capability - --- | The annotation for any setting reading secrets. --- --- We add these so that we can disable them in settings checks, to avoid --- failing settings checks when secrets are read at runtime instead of --- build-time. -readSecretCapability :: String -readSecretCapability = "read-secret" - instance Functor Parser where -- We case-match to produce shallower parser structures. fmap f = \case @@ -669,13 +652,13 @@ -- that we can run a settings check without that power to still check the rest -- of the parser. -- --- This only makes sense when used with a 'checkMap', 'checkEither', 'mapIO', --- 'runIO', or similar function because the capability requirement is attached --- to the Check node in the parser tree. +-- This only makes sense when used with a 'checkMap', 'checkEither', +-- 'mapIO', 'runIO', or similar function because the capability requirement is +-- attached to the Setting or Check node in the parser tree. -- When used without such a node, this will attach a no-op Check node to the -- parser tree and as such still try to do all the parsing below but not above. -requireCapability :: (HasCallStack) => String -> Parser a -> Parser a -requireCapability capName = \case +checkWithRequiredCapability :: (HasCallStack) => String -> Parser a -> Parser a +checkWithRequiredCapability capName = \case ParserCheck mLoc' forgivable caps f p -> ParserCheck mLoc' forgivable (Set.insert cap caps) f p p -> ParserCheck mLoc False (Set.singleton cap) (pure . Right) p @@ -921,7 +904,8 @@ settingHidden = True, settingMetavar = Nothing, settingHelp = Nothing, - settingCompleter = Nothing + settingCompleter = Nothing, + settingRequiredCapabilities = Set.empty } parseDisableSwitch :: Parser Bool parseDisableSwitch = @@ -939,7 +923,8 @@ settingHidden = True, settingMetavar = Nothing, settingHelp = Nothing, - settingCompleter = Nothing + settingCompleter = Nothing, + settingRequiredCapabilities = Set.empty } parseEnv :: Maybe (Parser Bool) @@ -960,7 +945,8 @@ settingHidden = False, settingMetavar = Just "BOOL", settingHelp = settingHelp s, - settingCompleter = Nothing + settingCompleter = Nothing, + settingRequiredCapabilities = Set.empty } parseConfigVal :: Maybe (Parser Bool) parseConfigVal = do @@ -980,7 +966,8 @@ settingHidden = False, settingMetavar = Nothing, settingHelp = settingHelp s, - settingCompleter = Nothing + settingCompleter = Nothing, + settingRequiredCapabilities = Set.empty } parseDummy :: Parser Bool parseDummy = @@ -998,7 +985,8 @@ settingHidden = False, settingMetavar = Nothing, settingHelp = settingHelp s, - settingCompleter = Nothing + settingCompleter = Nothing, + settingRequiredCapabilities = Set.empty } prefixDashedLong :: String -> Dashed -> Maybe Dashed prefixDashedLong prefix = \case @@ -1014,7 +1002,9 @@ secretTextFileSetting :: (HasCallStack) => [Builder FilePath] -> Parser Text secretTextFileSetting bs = withFrozenCallStack $ - requireCapability readSecretCapability $ + -- Require the capability only for reading the secret file, not for parsing + -- the string as a path. + checkWithRequiredCapability readSecretCapability $ mapIO readSecretTextFile $ filePathSetting bs @@ -1038,12 +1028,16 @@ bareSetting p f = do let s = completeBuilder $ mconcat [mapMaybeBuilder f b, reader str, metavar "SECRET"] guard $ p s - pure $ T.pack <$> ParserSetting mLoc s + pure $ + -- Require the capability for the entire setting because the secret may be + -- passed as an env var. + checkWithRequiredCapability readSecretCapability $ + T.pack <$> ParserSetting mLoc s fileSetting p f = do let s = completeBuilder $ mconcat [mapMaybeBuilder f b, reader str, metavar "FILE_PATH"] guard $ p s pure $ - requireCapability readSecretCapability $ + checkWithRequiredCapability readSecretCapability $ -- These two mapIOs are not combined because the capability should -- only apply to the reading, not the resolving. mapIO readSecretTextFile $ diff --git a/src/OptEnvConf/Run.hs b/src/OptEnvConf/Run.hs --- a/src/OptEnvConf/Run.hs +++ b/src/OptEnvConf/Run.hs @@ -1,19 +1,15 @@ {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} module OptEnvConf.Run - ( Capabilities (..), - allCapabilities, - enableCapability, - disableCapability, - runParserOn, + ( runParserOn, runHelpParser, ) where @@ -38,10 +34,9 @@ import qualified Data.Set as Set import qualified Data.Text as T import Data.Traversable -import Data.Validity (Validity) -import GHC.Generics (Generic) import GHC.Stack (SrcLoc) import OptEnvConf.Args as Args +import OptEnvConf.Capability import OptEnvConf.Doc import OptEnvConf.EnvMap (EnvMap (..)) import qualified OptEnvConf.EnvMap as EnvMap @@ -55,27 +50,6 @@ import System.IO import Text.Colour --- Set of disabled capabilities -newtype Capabilities = Capabilities {unCapabilities :: Set Capability} - deriving (Show, Generic) - -instance Validity Capabilities - -allCapabilities :: Capabilities -allCapabilities = Capabilities {unCapabilities = Set.empty} - -enableCapability :: Capability -> Capabilities -> Capabilities -enableCapability cap (Capabilities caps) = - Capabilities (Set.delete cap caps) - -disableCapability :: Capability -> Capabilities -> Capabilities -disableCapability cap (Capabilities caps) = - Capabilities (Set.insert cap caps) - -missingCapabilities :: Capabilities -> Set Capability -> Maybe (NonEmpty Capability) -missingCapabilities (Capabilities caps) requiredCapabilities = - NE.nonEmpty (Set.toList (Set.intersection requiredCapabilities caps)) - -- | Run a parser on given arguments and environment instead of getting them -- from the current process. runParserOn :: @@ -214,13 +188,8 @@ a <- ppIndent $ go p' debug ["check"] -- Only perform the check (IO) if capabilities are sufficient - ppIndent $ case missingCapabilities capabilities requiredCapabilities of - Just missings -> do - debug $ - "Missing capabilities: " - : capabilitiesChunks (Set.fromList (NE.toList missings)) - ppErrors mLoc $ NE.map ParseErrorMissingCapability missings - Nothing -> do + ppIndent $ + withCapabilities mLoc requiredCapabilities capabilities $ do errOrB <- liftIO $ f a case errOrB of Left err -> do @@ -263,6 +232,17 @@ go pa ParserSetting mLoc set@Setting {..} -> do debug [syntaxChunk "Setting", ": ", mSrcLocChunk mLoc] + when (not (Set.null settingRequiredCapabilities)) $ + debug $ + "Requires capabilities: " + : capabilitiesChunks settingRequiredCapabilities + + -- Any argument parsing needs to still try to consume the relevant arguments, so we need to put + -- this helper function after that instead of arround the whole setting parsing. + -- After all the arguments, options, and switches have been tried, the rest can have a blanket 'cap'. + let cap :: forall r. PP r -> PP r + cap = withCapabilities mLoc settingRequiredCapabilities capabilities + ppIndent $ do let markParsed = do maybe @@ -289,7 +269,7 @@ Nothing -> do debug ["could not set based on argument: no argument"] pure NotFound - Just argStr -> do + Just argStr -> cap $ case tryReaders rs argStr of Left errs -> ppError mLoc $ ParseErrorArgumentRead mOptDoc errs Right a -> do @@ -316,7 +296,7 @@ chunk $ T.pack $ show $ map renderDashed settingDasheds ] pure NotFound - Just () -> do + Just () -> cap $ do debug ["set based on switch."] pure $ Found a @@ -339,7 +319,7 @@ chunk $ T.pack $ show $ map renderDashed settingDasheds ] pure NotFound - Just optionStr -> do + Just optionStr -> cap $ case tryReaders rs optionStr of Left err -> ppError mLoc $ ParseErrorOptionRead mOptDoc err Right a -> do @@ -356,7 +336,7 @@ pure a _ -> do let mEnvDoc = settingEnvDoc set - mEnv <- case settingEnvVars of + mEnv <- cap $ case settingEnvVars of Nothing -> pure NotRun Just ne -> do -- Require readers before finding the env vars so the parser @@ -472,6 +452,21 @@ parseResultError (ParseErrorMissingEnvVar mEnvDoc) mEnv, parseResultError (ParseErrorMissingConfVal mConfDoc) mConf ] + +withCapabilities :: + Maybe SrcLoc -> + Set Capability -> + Capabilities -> + PP a -> + PP a +withCapabilities mLoc requiredCapabilities capabilities func = + case missingCapabilities capabilities requiredCapabilities of + Just missings -> do + debug $ + "Missing capabilities: " + : capabilitiesChunks (Set.fromList (NE.toList missings)) + ppErrors mLoc $ NE.map ParseErrorMissingCapability missings + Nothing -> func data ParseResult a = NotRun diff --git a/src/OptEnvConf/Setting.hs b/src/OptEnvConf/Setting.hs --- a/src/OptEnvConf/Setting.hs +++ b/src/OptEnvConf/Setting.hs @@ -1,8 +1,10 @@ +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-unused-pattern-binds #-} module OptEnvConf.Setting ( Setting (..), @@ -37,6 +39,8 @@ completer, Builder (..), BuildInstruction (..), + requiredCapability, + readSecretCapability, -- * Internal showSettingABit, @@ -59,7 +63,11 @@ import Data.List.NonEmpty (NonEmpty (..), (<|)) import qualified Data.List.NonEmpty as NE import Data.Maybe +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.Text as T import OptEnvConf.Args (Dashed (..), renderDashed) +import OptEnvConf.Capability import OptEnvConf.Casing import OptEnvConf.Completer import OptEnvConf.Reader @@ -99,7 +107,8 @@ -- | Which metavar should be show in documentation settingMetavar :: !(Maybe Metavar), settingHelp :: !(Maybe String), - settingCompleter :: !(Maybe Completer) + settingCompleter :: !(Maybe Completer), + settingRequiredCapabilities :: !(Set Capability) } -- An 'Ord'-able Setting without giving 'Setting' an 'Eq' instance @@ -180,33 +189,43 @@ settingExamples = [], settingHidden = False, settingDefaultValue = Nothing, - settingCompleter = Nothing + settingCompleter = Nothing, + settingRequiredCapabilities = Set.empty } -- | Show a 'Setting' as much as possible, for debugging showSettingABit :: Setting a -> ShowS showSettingABit Setting {..} = - showParen True $ - showString "Setting " - . showsPrec 11 settingDasheds - . showString " " - . showListWith (\_ -> showString "_") settingReaders - . showString " " - . showsPrec 11 settingTryArgument - . showString " " - . showMaybeWith (\_ -> showString "_") settingSwitchValue - . showString " " - . showsPrec 11 settingTryOption - . showString " " - . showsPrec 11 settingEnvVars - . showString " " - . showMaybeWith (showNonEmptyWith showConfigValSettingABit) settingConfigVals - . showString " " - . showMaybeWith (\_ -> showString "_") settingDefaultValue - . showString " " - . showsPrec 11 settingMetavar - . showString " " - . showsPrec 11 settingHelp + let Setting _ _ _ _ _ _ _ _ _ _ _ _ _ _ = undefined + in showParen True $ + showString "Setting " + . showsPrec 11 settingDasheds + . showString " " + . showListWith (\_ -> showString "_") settingReaders + . showString " " + . showsPrec 11 settingTryArgument + . showString " " + . showMaybeWith (\_ -> showString "_") settingSwitchValue + . showString " " + . showsPrec 11 settingTryOption + . showString " " + . showsPrec 11 settingEnvVars + . showString " " + . showMaybeWith (showNonEmptyWith showConfigValSettingABit) settingConfigVals + . showString " " + . showMaybeWith (\_ -> showString "_") settingDefaultValue + . showString " " + . showsPrec 11 settingExamples + . showString " " + . showsPrec 11 settingHidden + . showString " " + . showsPrec 11 settingMetavar + . showString " " + . showsPrec 11 settingHelp + . showString " " + . showMaybeWith (\_ -> showString "_") settingCompleter + . showString " " + . showsPrec 11 settingRequiredCapabilities showConfigValSettingABit :: ConfigValSetting a -> ShowS showConfigValSettingABit ConfigValSetting {..} = @@ -244,6 +263,7 @@ | BuildAddExample !String | BuildSetHidden | BuildSetCompleter !Completer + | BuildAddRequiredCapability !Capability applyBuildInstructions :: [BuildInstruction a] -> Setting a -> Setting a applyBuildInstructions is s = foldr applyBuildInstruction s is @@ -264,6 +284,7 @@ BuildAddExample e -> s {settingExamples = e : settingExamples s} BuildSetHidden -> s {settingHidden = True} BuildSetCompleter c -> s {settingCompleter = Just c} + BuildAddRequiredCapability c -> s {settingRequiredCapabilities = Set.insert c (settingRequiredCapabilities s)} instance Semigroup (Builder f) where (<>) (Builder f1) (Builder f2) = Builder (f1 <> f2) @@ -446,3 +467,7 @@ -- Multiple 'completer's are redundant. completer :: Completer -> Builder a completer c = Builder [BuildSetCompleter c] + +-- | Annotate a setting with a required capability. +requiredCapability :: String -> Builder a +requiredCapability c = Builder [BuildAddRequiredCapability (Capability (T.pack c))]