diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,14 @@ # Changelog +## [0.12.0.0] - 2025-11-25 + +### Added + +* Support for capabilities during settings parsing, and disabling them in the + settings check. + +This is technically a breaking change, but if you don't use any `opt-env-conf` +internals, nothing should break for you. ## [0.11.1.0] - 2025-10-23 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.11.1.0 +version: 0.12.1.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 @@ -27,12 +27,14 @@ OptEnvConf OptEnvConf.Args OptEnvConf.Casing + OptEnvConf.Check OptEnvConf.Completer OptEnvConf.Completion OptEnvConf.Doc OptEnvConf.EnvMap OptEnvConf.Error OptEnvConf.Lint + OptEnvConf.Main OptEnvConf.Nix OptEnvConf.NonDet OptEnvConf.Output diff --git a/src/OptEnvConf.hs b/src/OptEnvConf.hs --- a/src/OptEnvConf.hs +++ b/src/OptEnvConf.hs @@ -150,6 +150,7 @@ import OptEnvConf.Casing import OptEnvConf.Completer import OptEnvConf.Doc +import OptEnvConf.Main import OptEnvConf.Nix import OptEnvConf.Parser import OptEnvConf.Reader diff --git a/src/OptEnvConf/Check.hs b/src/OptEnvConf/Check.hs new file mode 100644 --- /dev/null +++ b/src/OptEnvConf/Check.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module OptEnvConf.Check + ( runSettingsCheck, + runSettingsCheckOn, + ) +where + +import qualified Data.Aeson as JSON +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import Data.Maybe +import GHC.Generics (Generic) +import GHC.Stack (SrcLoc) +import OptEnvConf.Args as Args +import OptEnvConf.EnvMap (EnvMap (..)) +import OptEnvConf.Error +import OptEnvConf.Parser +import OptEnvConf.Run +import OptEnvConf.Terminal (getTerminalCapabilitiesFromHandle) +import System.Exit +import System.IO (stderr, stdout) +import Text.Colour + +runSettingsCheck :: Capabilities -> Parser a -> Args -> EnvMap -> Maybe JSON.Object -> IO void +runSettingsCheck capabilities p args envVars mConfig = do + stderrTc <- getTerminalCapabilitiesFromHandle stderr + errOrSets <- runSettingsCheckOn capabilities stderrTc p args envVars mConfig + case errOrSets of + CheckFailed errs -> do + hPutChunksLocaleWith stderrTc stderr $ renderErrors errs + exitFailure + CheckIncapable missingCaps -> do + tc <- getTerminalCapabilitiesFromHandle stdout + hPutChunksLocaleWith tc stdout ["Could not complete parsing settings because of missing capabilities, but no errors were found so far."] + hPutChunksLocaleWith stderrTc stderr $ renderMissingCapabilities missingCaps + exitSuccess + CheckSucceeded _ -> do + tc <- getTerminalCapabilitiesFromHandle stdout + hPutChunksLocaleWith tc stdout ["Settings parsed successfully."] + exitSuccess + +renderMissingCapabilities :: NonEmpty MissingCapability -> [Chunk] +renderMissingCapabilities = renderErrors . NE.map capabilityErorr + where + capabilityErorr (MissingCapability mLoc cap) = + ParseError mLoc $ ParseErrorMissingCapability cap + +data CheckResult a + = -- | Check succeeded + CheckSucceeded a + | -- | Check could not be completed because of missing capability + CheckIncapable (NonEmpty MissingCapability) + | -- | Check failed with parse errors + CheckFailed (NonEmpty ParseError) + deriving (Show, Generic, Functor) + +data MissingCapability + = MissingCapability + -- Where the capability was needed + !(Maybe SrcLoc) + -- Where the capability was needed + !Capability + deriving (Show, Generic) + +runSettingsCheckOn :: + Capabilities -> + -- DebugMode, always on + TerminalCapabilities -> + Parser a -> + Args -> + EnvMap -> + Maybe JSON.Object -> + IO (CheckResult a) +runSettingsCheckOn capabilities debugMode p args envVars mConfig = do + errOrSets <- runParserOn capabilities (Just debugMode) p args envVars mConfig + pure $ case errOrSets of + Right a -> CheckSucceeded a + Left errs -> + let missingCaps = + mapMaybe + ( \case + ParseError mLoc (ParseErrorMissingCapability cap) -> Just (MissingCapability mLoc cap) + _ -> Nothing + ) + (NE.toList errs) + in case NE.nonEmpty missingCaps of + Just ne -> CheckIncapable ne + Nothing -> CheckFailed errs diff --git a/src/OptEnvConf/Completion.hs b/src/OptEnvConf/Completion.hs --- a/src/OptEnvConf/Completion.hs +++ b/src/OptEnvConf/Completion.hs @@ -284,7 +284,7 @@ Nothing -> pure Nothing Just os -> fmap (os ++) <$> go p ParserAllOrNothing _ p -> go p - ParserCheck _ _ _ p -> go p + ParserCheck _ _ _ _ p -> go p ParserWithConfig _ p1 p2 -> -- The config-file auto-completion is probably less important, we put it second. andCompletions p2 p1 diff --git a/src/OptEnvConf/Doc.hs b/src/OptEnvConf/Doc.hs --- a/src/OptEnvConf/Doc.hs +++ b/src/OptEnvConf/Doc.hs @@ -172,7 +172,7 @@ ParserMany _ p -> AnyDocsOr [go p, AnyDocsSingle Nothing] ParserSome mLoc p -> AnyDocsAnd [go p, go (ParserMany mLoc p)] -- TODO: is this right? ParserAllOrNothing _ p -> go p - ParserCheck _ _ _ p -> go p + ParserCheck _ _ _ _ p -> go p ParserCommands _ mDefault cs -> AnyDocsCommands mDefault $ map commandParserDocs cs ParserWithConfig _ p1 p2 -> AnyDocsAnd [go p1, go p2] -- TODO: is this right? Maybe we want to document that it's not a pure parser? ParserSetting _ set -> AnyDocsSingle $ settingSetDoc set diff --git a/src/OptEnvConf/Error.hs b/src/OptEnvConf/Error.hs --- a/src/OptEnvConf/Error.hs +++ b/src/OptEnvConf/Error.hs @@ -12,6 +12,7 @@ import GHC.Stack (SrcLoc) import OptEnvConf.Doc import OptEnvConf.Output +import OptEnvConf.Parser import OptEnvConf.Setting import Text.Colour @@ -39,6 +40,7 @@ | ParseErrorUnrecognisedCommand !String ![CommandDoc ()] | ParseErrorAllOrNothing !(Map SettingHash SrcLoc) | ParseErrorUnrecognised !(NonEmpty String) + | ParseErrorMissingCapability !Capability deriving (Show) -- | Whether the other side of an 'Alt' should be tried if we find this error. @@ -64,6 +66,7 @@ ParseErrorUnrecognisedCommand _ _ -> False ParseErrorAllOrNothing _ -> False ParseErrorUnrecognised _ -> False + ParseErrorMissingCapability _ -> False eraseErrorSrcLocs :: (Functor f) => f ParseError -> f ParseError eraseErrorSrcLocs = fmap eraseErrorSrcLoc @@ -131,7 +134,9 @@ ] ++ map (pure . srcLocChunk) (M.elems locs) ParseErrorUnrecognised leftovers -> - ["Unrecognised args: " : unwordsChunks (map (pure . chunk . T.pack) (NE.toList leftovers))], + ["Unrecognised args: " : unwordsChunks (map (pure . chunk . T.pack) (NE.toList leftovers))] + ParseErrorMissingCapability cap -> + ["Missing capability: " : [chunk $ T.pack $ show cap]], maybe [] (pure . ("see " :) . pure . srcLocChunk) parseErrorSrcLoc ] diff --git a/src/OptEnvConf/Lint.hs b/src/OptEnvConf/Lint.hs --- a/src/OptEnvConf/Lint.hs +++ b/src/OptEnvConf/Lint.hs @@ -271,7 +271,7 @@ validationTFailure LintErrorManyInfinite pure c ParserAllOrNothing _ p -> go p - ParserCheck _ _ _ p -> go p + ParserCheck _ _ _ _ p -> go p ParserCommands mLoc mDefault cs -> do if null cs then validationTFailure $ LintError mLoc LintErrorNoCommands diff --git a/src/OptEnvConf/Main.hs b/src/OptEnvConf/Main.hs new file mode 100644 --- /dev/null +++ b/src/OptEnvConf/Main.hs @@ -0,0 +1,305 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module OptEnvConf.Main + ( runSettingsParser, + runParser, + internalParser, + ) +where + +import qualified Data.Text as T +import Data.Version +import OptEnvConf.Args as Args +import OptEnvConf.Check +import OptEnvConf.Completion +import OptEnvConf.Doc +import qualified OptEnvConf.EnvMap as EnvMap +import OptEnvConf.Error +import OptEnvConf.Lint +import OptEnvConf.Nix +import OptEnvConf.Parser +import OptEnvConf.Reader +import OptEnvConf.Run +import OptEnvConf.Setting +import OptEnvConf.Terminal (getTerminalCapabilitiesFromHandle) +import Path +import System.Environment (getArgs, getEnvironment, getProgName) +import System.Exit +import System.IO +import Text.Colour + +-- | Run 'runParser' on your @Settings@' type's 'settingsParser'. +-- +-- __This is most likely the function you want to be using.__ +runSettingsParser :: + (HasParser a) => + -- | Program version, get this from Paths_your_package_name + Version -> + -- | Program description + String -> + IO a +runSettingsParser version progDesc = + runParser version progDesc settingsParser + +-- | Run a parser +-- +-- This function with exit on: +-- +-- * Parse failure: show a nice error message. +-- * @-h|--help@: Show help text +-- * @--version@: Show version information +-- * @--render-man-page@: Render a man page +-- * @--bash-completion-script@: Render a bash completion script +-- * @--zsh-completion-script@: Render a zsh completion script +-- * @--fish-completion-script@: Render a fish completion script +-- * @query-opt-env-conf-completion@: Perform a completion query +-- +-- This gets the arguments and environment variables from the current process. +runParser :: + -- | Program version, get this from Paths_your_package_name + Version -> + -- | Program description + String -> + Parser a -> + IO a +runParser version progDesc p = do + completeEnv <- getEnvironment + let envVars = EnvMap.parse completeEnv + + case lintParser p of + Just errs -> do + tc <- getTerminalCapabilitiesFromHandle stderr + hPutChunksLocaleWith tc stderr $ renderLintErrors errs + exitFailure + Nothing -> do + let docs = parserDocs p + + allArgs <- getArgs + let (debugMode, args) = consumeDebugMode allArgs + + mDebugMode <- + if debugMode + then Just <$> getTerminalCapabilitiesFromHandle stderr + else pure Nothing + + let (helpMode, args') = consumeHelpMode args + + if helpMode + then do + progname <- getProgName + errOrDocs <- runHelpParser mDebugMode (Args.parseArgs args') p + case errOrDocs of + Left errs -> do + stderrTc <- getTerminalCapabilitiesFromHandle stderr + hPutChunksLocaleWith stderrTc stderr $ renderErrors errs + exitFailure + Right mCommandDoc -> do + tc <- getTerminalCapabilitiesFromHandle stdout + hPutChunksLocaleWith tc stdout $ case mCommandDoc of + Nothing -> renderHelpPage progname version progDesc docs + Just (path, cDoc) -> renderCommandHelpPage progname path cDoc + exitSuccess + else do + let (capabilities, args'') = consumeCapabilities args' + let (checkMode, args''') = consumeCheckMode args'' + + let readyArgs = Args.parseArgs args''' + + let mConfig = Nothing -- We start with no config loaded. + if checkMode + then runSettingsCheck capabilities p readyArgs envVars mConfig + else do + let p' = internalParser p + errOrResult <- + runParserOn + capabilities + mDebugMode + p' + readyArgs + envVars + mConfig + case errOrResult of + Left errs -> do + tc <- getTerminalCapabilitiesFromHandle stderr + hPutChunksLocaleWith tc stderr $ renderErrors errs + exitFailure + Right i -> case i of + ShowVersion -> do + progname <- getProgName + tc <- getTerminalCapabilitiesFromHandle stdout + hPutChunksLocaleWith tc stdout $ renderVersionPage progname version + exitSuccess + RenderMan -> do + progname <- getProgName + tc <- getTerminalCapabilitiesFromHandle stdout + hPutChunksLocaleWith tc stdout $ renderManPage progname version progDesc docs + exitSuccess + RenderDocumentation -> do + progname <- getProgName + tc <- getTerminalCapabilitiesFromHandle stdout + hPutChunksLocaleWith tc stdout $ renderReferenceDocumentation progname docs + exitSuccess + RenderNixosOptions -> do + putStrLn $ T.unpack $ renderParserNixOptions p' + exitSuccess + BashCompletionScript progPath -> do + progname <- getProgName + generateBashCompletionScript progPath progname + exitSuccess + ZshCompletionScript progPath -> do + progname <- getProgName + generateZshCompletionScript progPath progname + exitSuccess + FishCompletionScript progPath -> do + progname <- getProgName + generateFishCompletionScript progPath progname + exitSuccess + CompletionQuery enriched index ws -> do + runCompletionQuery p' enriched index ws + exitSuccess + ParsedNormally a -> pure a + +-- We use [String] instead of [Args] because we want to remove these args, and act on them, before any real arg parsing happens. +consumeExactArg :: String -> [String] -> (Bool, [String]) +consumeExactArg arg = go + where + go = \case + [] -> (False, []) + (x : xs) + | x == arg -> (True, xs) + | otherwise -> + let (found, rest) = go xs + in (found, x : rest) + +consumeDebugMode :: [String] -> (Bool, [String]) +consumeDebugMode = consumeExactArg "--debug-optparse" + +-- Note: Here we only consume exact -h as an arg, not -h as part of another arg like -hu +consumeHelpMode :: [String] -> (Bool, [String]) +consumeHelpMode as = + let (found, as') = consumeExactArg "--help" as + in if found + then (True, as') + else consumeExactArg "-h" as' + +consumeCheckMode :: [String] -> (Bool, [String]) +consumeCheckMode = consumeExactArg "--run-settings-check" + +consumeCapabilities :: [String] -> (Capabilities, [String]) +consumeCapabilities = go allCapabilities + where + go :: Capabilities -> [String] -> (Capabilities, [String]) + go caps = \case + [] -> (caps, []) + (x : xs) -> + let t = T.pack x + in case T.stripPrefix "--settings-capabilities-disable-" t of + Just capName -> go (disableCapability (Capability capName) caps) xs + Nothing -> case T.stripPrefix "--settings-capabilities-enable-" t of + Just capName -> go (enableCapability (Capability capName) caps) xs + Nothing -> + let (finalCaps, rest) = go caps xs + in (finalCaps, x : rest) + +-- Internal structure to help us do what the framework +-- is supposed to. +data Internal a + = ShowVersion + | RenderMan + | RenderDocumentation + | RenderNixosOptions + | BashCompletionScript (Path Abs File) + | ZshCompletionScript (Path Abs File) + | FishCompletionScript (Path Abs File) + | CompletionQuery + -- Enriched + !Bool + -- Index + !Int + -- Args + ![String] + | ParsedNormally !a + +internalParser :: Parser a -> Parser (Internal a) +internalParser p = + choice + [ setting + [ switch ShowVersion, + long "version", + hidden + ], + setting + [ switch RenderMan, + long "render-man-page", + hidden, + help "Render a manpage" + ], + setting + [ switch RenderDocumentation, + long "render-reference-documentation", + hidden, + help "Render reference documentation" + ], + setting + [ switch RenderNixosOptions, + long "render-nix-options", + hidden, + help "Render Nix options" + ], + BashCompletionScript + <$> setting + [ option, + reader $ maybeReader parseAbsFile, + long "bash-completion-script", + hidden, + help "Render the bash completion script" + ], + ZshCompletionScript + <$> setting + [ option, + reader $ maybeReader parseAbsFile, + long "zsh-completion-script", + hidden, + help "Render the zsh completion script" + ], + ZshCompletionScript + <$> setting + [ option, + reader $ maybeReader parseAbsFile, + long "fish-completion-script", + hidden, + help "Render the fish completion script" + ], + setting + [ help "Query completion", + switch CompletionQuery, + -- Long string that no normal user would ever use. + long "query-opt-env-conf-completion", + hidden + ] + <*> setting + [ switch True, + long "completion-enriched", + value False, + hidden, + help "Whether to enable enriched completion" + ] + <*> setting + [ option, + reader auto, + long "completion-index", + hidden, + help "The index between the arguments where completion was invoked." + ] + <*> many + ( setting + [ option, + reader str, + long "completion-word", + hidden, + help "The words (arguments) that have already been typed" + ] + ), + ParsedNormally <$> p + ] diff --git a/src/OptEnvConf/Nix.hs b/src/OptEnvConf/Nix.hs --- a/src/OptEnvConf/Nix.hs +++ b/src/OptEnvConf/Nix.hs @@ -39,7 +39,7 @@ ParserMany _ p -> go p ParserSome _ p -> go p ParserAllOrNothing _ p -> go p - ParserCheck _ _ _ p -> go p + ParserCheck _ _ _ _ p -> go p ParserCommands _ _ cs -> M.unionsWith combineOption $ map goCommand cs ParserWithConfig _ p1 p2 -> -- I'm not sure if we need the first as well because you wouldn't use a diff --git a/src/OptEnvConf/Output.hs b/src/OptEnvConf/Output.hs --- a/src/OptEnvConf/Output.hs +++ b/src/OptEnvConf/Output.hs @@ -6,6 +6,8 @@ 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 Data.Text (Text) import qualified Data.Text as T import Data.Version @@ -79,6 +81,14 @@ syntaxChunk :: String -> Chunk syntaxChunk = fore blue . chunk . T.pack + +capabilitiesChunks :: Set Capability -> [Chunk] +capabilitiesChunks caps = case Set.toList caps of + [] -> [] + cs -> intersperse ", " (map capabilityChunk cs) + +capabilityChunk :: Capability -> Chunk +capabilityChunk = fore green . chunk . unCapability mSrcLocChunk :: Maybe SrcLoc -> Chunk mSrcLocChunk = maybe "without srcLoc" srcLocChunk diff --git a/src/OptEnvConf/Parser.hs b/src/OptEnvConf/Parser.hs --- a/src/OptEnvConf/Parser.hs +++ b/src/OptEnvConf/Parser.hs @@ -1,5 +1,8 @@ {-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} @@ -25,6 +28,7 @@ checkMapIOForgivable, checkMapMaybeForgivable, allOrNothing, + requireCapability, commands, command, defaultCommand, @@ -56,9 +60,11 @@ readSecretTextFile, secretTextFileSetting, secretTextFileOrBareSetting, + readSecretCapability, -- * Parser implementation Parser (..), + Capability (..), HasParser (..), Command (..), CommandsBuilder (..), @@ -93,10 +99,14 @@ import Data.Map (Map) import qualified Data.Map as M import Data.Maybe +import Data.Set (Set) +import qualified Data.Set as Set import Data.String 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.Casing @@ -191,6 +201,9 @@ !(Maybe SrcLoc) -> -- | Forgivable !Bool -> + -- | Necessary capabilities + !(Set Capability) -> + -- | Check function !(a -> IO (Either String b)) -> !(Parser a) -> Parser b @@ -213,6 +226,20 @@ !(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 @@ -221,11 +248,11 @@ ParserSelect pe pf -> ParserSelect (fmap (fmap f) pe) (fmap (fmap f) pf) ParserEmpty mLoc -> ParserEmpty mLoc ParserAlt p1 p2 -> ParserAlt (fmap f p1) (fmap f p2) - ParserCheck mLoc forgivable g p -> ParserCheck mLoc forgivable (fmap (fmap f) . g) p + ParserCheck mLoc forgivable caps g p -> ParserCheck mLoc forgivable caps (fmap (fmap f) . g) p ParserCommands mLoc mDefault cs -> ParserCommands mLoc mDefault $ map (fmap f) cs ParserWithConfig mLoc pc pa -> ParserWithConfig mLoc pc (fmap f pa) - -- TODO: make setting a functor and fmap here - p -> ParserCheck Nothing True (pure . Right . f) p + -- If we ever make Setting a functor, then we need to fmap here + p -> ParserCheck Nothing True Set.empty (pure . Right . f) p instance Applicative Parser where pure = ParserPure @@ -250,7 +277,7 @@ ParserMany _ p -> isEmpty p ParserSome _ p -> isEmpty p ParserAllOrNothing _ p -> isEmpty p - ParserCheck _ _ _ p -> isEmpty p + ParserCheck _ _ _ _ p -> isEmpty p ParserCommands _ _ cs -> null cs ParserWithConfig _ pc ps -> isEmpty pc && isEmpty ps ParserSetting _ _ -> False @@ -331,12 +358,14 @@ . showsPrec 11 mLoc . showString " " . go 11 p - ParserCheck mLoc forgivable _ p -> + ParserCheck mLoc forgivable caps _ p -> showParen (d > 10) $ showString "Check " . showsPrec 11 mLoc . showString " " . showsPrec 11 forgivable + . showString " " + . showsPrec 11 caps . showString " _ " . go 11 p ParserCommands mLoc mDefault cs -> @@ -599,11 +628,11 @@ -- | Check a 'Parser' after the fact, purely. checkMapEither :: (HasCallStack) => (a -> Either String b) -> Parser a -> Parser b -checkMapEither func p = withFrozenCallStack $ checkMapIO (pure . func) p +checkMapEither f = withFrozenCallStack $ checkMapIO (pure . f) -- | Check a 'Parser' after the fact, allowing IO. checkMapIO :: (HasCallStack) => (a -> IO (Either String b)) -> Parser a -> Parser b -checkMapIO = ParserCheck mLoc False +checkMapIO = ParserCheck mLoc False Set.empty where mLoc = snd <$> listToMaybe (getCallStack callStack) @@ -634,6 +663,26 @@ where mLoc = snd <$> listToMaybe (getCallStack callStack) +-- | Require the given capability for running the given parser. +-- +-- This lets us annotate a parser with a power that it needs to be executed so +-- 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. +-- 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 + 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 + where + cap = Capability (T.pack capName) + mLoc = snd <$> listToMaybe (getCallStack callStack) + -- | Like 'checkMapMaybe', but allow trying the other side of any alternative if the result is Nothing. checkMapMaybeForgivable :: (HasCallStack) => (a -> Maybe b) -> Parser a -> Parser b checkMapMaybeForgivable func p = @@ -647,12 +696,11 @@ -- | Like 'checkMapEither', but allow trying the other side of any alternative if the result is Nothing. checkMapEitherForgivable :: (HasCallStack) => (a -> Either String b) -> Parser a -> Parser b -checkMapEitherForgivable func p = withFrozenCallStack $ checkMapIOForgivable (pure . func) p +checkMapEitherForgivable f = withFrozenCallStack $ checkMapIOForgivable (pure . f) -- | Like 'checkMapIO', but allow trying the other side of any alternative if the result is Nothing. --- TODO add a SRCLoc here checkMapIOForgivable :: (HasCallStack) => (a -> IO (Either String b)) -> Parser a -> Parser b -checkMapIOForgivable = ParserCheck mLoc True +checkMapIOForgivable = ParserCheck mLoc True Set.empty where mLoc = snd <$> listToMaybe (getCallStack callStack) @@ -964,7 +1012,11 @@ -- | Load a secret from a text file, with 'readSecretTextFile' secretTextFileSetting :: (HasCallStack) => [Builder FilePath] -> Parser Text -secretTextFileSetting bs = withFrozenCallStack $ mapIO readSecretTextFile $ filePathSetting bs +secretTextFileSetting bs = + withFrozenCallStack $ + requireCapability readSecretCapability $ + mapIO readSecretTextFile $ + filePathSetting bs -- | Load a secret from a text file, with 'readSecretTextFile', or specify it -- directly @@ -990,7 +1042,13 @@ fileSetting p f = do let s = completeBuilder $ mconcat [mapMaybeBuilder f b, reader str, metavar "FILE_PATH"] guard $ p s - pure $ mapIO (resolveFile' >=> readSecretTextFile) $ ParserSetting mLoc s + pure $ + requireCapability readSecretCapability $ + -- These two mapIOs are not combined because the capability should + -- only apply to the reading, not the resolving. + mapIO readSecretTextFile $ + mapIO resolveFile' $ + ParserSetting mLoc s bareOption = bareSetting settingTryOption $ \case BuildTryArgument -> Nothing @@ -1117,7 +1175,7 @@ ParserMany _ p -> ParserMany Nothing (go p) ParserSome _ p -> ParserSome Nothing (go p) ParserAllOrNothing _ p -> ParserAllOrNothing Nothing (go p) - ParserCheck _ forgivable f p -> ParserCheck Nothing forgivable f (go p) + ParserCheck _ forgivable caps f p -> ParserCheck Nothing forgivable caps f (go p) ParserCommands _ mDefault cs -> ParserCommands Nothing mDefault $ map commandEraseSrcLocs cs ParserWithConfig _ p1 p2 -> ParserWithConfig Nothing (go p1) (go p2) ParserSetting _ s -> ParserSetting Nothing s @@ -1154,7 +1212,7 @@ ParserMany mLoc p -> ParserMany mLoc <$> go p ParserSome mLoc p -> ParserSome mLoc <$> go p ParserAllOrNothing mLoc p -> ParserAllOrNothing mLoc <$> go p - ParserCheck mLoc forgivable f p -> ParserCheck mLoc forgivable f <$> go p + ParserCheck mLoc forgivable caps f p -> ParserCheck mLoc forgivable caps f <$> go p ParserCommands mLoc mDefault cs -> ParserCommands mLoc mDefault <$> traverse (commandTraverseSetting func) cs ParserWithConfig mLoc p1 p2 -> ParserWithConfig mLoc <$> go p1 <*> go p2 ParserSetting mLoc s -> ParserSetting mLoc <$> func s @@ -1183,7 +1241,7 @@ ParserMany _ p -> go p ParserSome _ p -> go p ParserAllOrNothing _ p -> go p -- TODO is this right? - ParserCheck _ _ _ p -> go p + ParserCheck _ _ _ _ p -> go p ParserCommands _ _ cs -> M.unions $ map (go . commandParser) cs ParserWithConfig _ p1 p2 -> M.union (go p1) (go p2) -- The nothing part shouldn't happen but I don't know when it doesn't diff --git a/src/OptEnvConf/Run.hs b/src/OptEnvConf/Run.hs --- a/src/OptEnvConf/Run.hs +++ b/src/OptEnvConf/Run.hs @@ -1,15 +1,20 @@ {-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module OptEnvConf.Run - ( runSettingsParser, - runParser, + ( Capabilities (..), + allCapabilities, + enableCapability, + disableCapability, runParserOn, runHelpParser, - internalParser, ) where @@ -29,282 +34,52 @@ import Data.Map (Map) import qualified Data.Map as M import Data.Maybe +import Data.Set (Set) +import qualified Data.Set as Set import qualified Data.Text as T import Data.Traversable -import Data.Version +import Data.Validity (Validity) +import GHC.Generics (Generic) import GHC.Stack (SrcLoc) import OptEnvConf.Args as Args -import OptEnvConf.Completion import OptEnvConf.Doc import OptEnvConf.EnvMap (EnvMap (..)) import qualified OptEnvConf.EnvMap as EnvMap import OptEnvConf.Error -import OptEnvConf.Lint -import OptEnvConf.Nix import OptEnvConf.NonDet import OptEnvConf.Output import OptEnvConf.Parser import OptEnvConf.Reader import OptEnvConf.Setting -import OptEnvConf.Terminal (getTerminalCapabilitiesFromHandle) import OptEnvConf.Validation -import Path -import System.Environment (getArgs, getEnvironment, getProgName) -import System.Exit import System.IO import Text.Colour --- | Run 'runParser' on your @Settings@' type's 'settingsParser'. --- --- __This is most likely the function you want to be using.__ -runSettingsParser :: - (HasParser a) => - -- | Program version, get this from Paths_your_package_name - Version -> - -- | Program description - String -> - IO a -runSettingsParser version progDesc = - runParser version progDesc settingsParser - --- | Run a parser --- --- This function with exit on: --- --- * Parse failure: show a nice error message. --- * @-h|--help@: Show help text --- * @--version@: Show version information --- * @--render-man-page@: Render a man page --- * @--bash-completion-script@: Render a bash completion script --- * @--zsh-completion-script@: Render a zsh completion script --- * @--fish-completion-script@: Render a fish completion script --- * @query-opt-env-conf-completion@: Perform a completion query --- --- This gets the arguments and environment variables from the current process. -runParser :: - -- | Program version, get this from Paths_your_package_name - Version -> - -- | Program description - String -> - Parser a -> - IO a -runParser version progDesc p = do - allArgs <- getArgs - let argMap' = parseArgs allArgs - let mArgMap = consumeSwitch ["--debug-optparse"] argMap' - let (debugMode, argMap) = case mArgMap of - Nothing -> (False, argMap') - Just am -> (True, am) - - completeEnv <- getEnvironment - let envVars = EnvMap.parse completeEnv - - case lintParser p of - Just errs -> do - tc <- getTerminalCapabilitiesFromHandle stderr - hPutChunksLocaleWith tc stderr $ renderLintErrors errs - exitFailure - Nothing -> do - let docs = parserDocs p - - mDebugMode <- - if debugMode - then Just <$> getTerminalCapabilitiesFromHandle stderr - else pure Nothing +-- Set of disabled capabilities +newtype Capabilities = Capabilities {unCapabilities :: Set Capability} + deriving (Show, Generic) - let mHelpConsumed = consumeSwitch ["-h", "--help"] argMap - let (helpMode, args') = case mHelpConsumed of - Nothing -> (False, argMap) - Just am -> (True, am) +instance Validity Capabilities - if helpMode - then do - progname <- getProgName - errOrDocs <- runHelpParser mDebugMode args' p - case errOrDocs of - Left errs -> do - stderrTc <- getTerminalCapabilitiesFromHandle stderr - hPutChunksLocaleWith stderrTc stderr $ renderErrors errs - exitFailure - Right mCommandDoc -> do - tc <- getTerminalCapabilitiesFromHandle stdout - hPutChunksLocaleWith tc stdout $ case mCommandDoc of - Nothing -> renderHelpPage progname version progDesc docs - Just (path, cDoc) -> renderCommandHelpPage progname path cDoc - exitSuccess - else do - let mCheckConsumed = consumeSwitch ["--run-settings-check"] args' - let (checkMode, args) = case mCheckConsumed of - Nothing -> (False, args') - Just am -> (True, am) +allCapabilities :: Capabilities +allCapabilities = Capabilities {unCapabilities = Set.empty} - if checkMode - then do - stderrTc <- getTerminalCapabilitiesFromHandle stderr - errOrSets <- runParserOn (Just stderrTc) p args envVars Nothing - case errOrSets of - Left errs -> do - hPutChunksLocaleWith stderrTc stderr $ renderErrors errs - exitFailure - Right _ -> do - tc <- getTerminalCapabilitiesFromHandle stdout - hPutChunksLocaleWith tc stdout ["Settings parsed successfully."] - exitSuccess - else do - let p' = internalParser p - errOrResult <- - runParserOn - mDebugMode - p' - args - envVars - Nothing - case errOrResult of - Left errs -> do - tc <- getTerminalCapabilitiesFromHandle stderr - hPutChunksLocaleWith tc stderr $ renderErrors errs - exitFailure - Right i -> case i of - ShowVersion -> do - progname <- getProgName - tc <- getTerminalCapabilitiesFromHandle stdout - hPutChunksLocaleWith tc stdout $ renderVersionPage progname version - exitSuccess - RenderMan -> do - progname <- getProgName - tc <- getTerminalCapabilitiesFromHandle stdout - hPutChunksLocaleWith tc stdout $ renderManPage progname version progDesc docs - exitSuccess - RenderDocumentation -> do - progname <- getProgName - tc <- getTerminalCapabilitiesFromHandle stdout - hPutChunksLocaleWith tc stdout $ renderReferenceDocumentation progname docs - exitSuccess - RenderNixosOptions -> do - putStrLn $ T.unpack $ renderParserNixOptions p' - exitSuccess - BashCompletionScript progPath -> do - progname <- getProgName - generateBashCompletionScript progPath progname - exitSuccess - ZshCompletionScript progPath -> do - progname <- getProgName - generateZshCompletionScript progPath progname - exitSuccess - FishCompletionScript progPath -> do - progname <- getProgName - generateFishCompletionScript progPath progname - exitSuccess - CompletionQuery enriched index ws -> do - runCompletionQuery p' enriched index ws - exitSuccess - ParsedNormally a -> pure a +enableCapability :: Capability -> Capabilities -> Capabilities +enableCapability cap (Capabilities caps) = + Capabilities (Set.delete cap caps) --- Internal structure to help us do what the framework --- is supposed to. -data Internal a - = ShowVersion - | RenderMan - | RenderDocumentation - | RenderNixosOptions - | BashCompletionScript (Path Abs File) - | ZshCompletionScript (Path Abs File) - | FishCompletionScript (Path Abs File) - | CompletionQuery - -- Enriched - !Bool - -- Index - !Int - -- Args - ![String] - | ParsedNormally !a +disableCapability :: Capability -> Capabilities -> Capabilities +disableCapability cap (Capabilities caps) = + Capabilities (Set.insert cap caps) -internalParser :: Parser a -> Parser (Internal a) -internalParser p = - choice - [ setting - [ switch ShowVersion, - long "version", - hidden - ], - setting - [ switch RenderMan, - long "render-man-page", - hidden, - help "Render a manpage" - ], - setting - [ switch RenderDocumentation, - long "render-reference-documentation", - hidden, - help "Render reference documentation" - ], - setting - [ switch RenderNixosOptions, - long "render-nix-options", - hidden, - help "Render Nix options" - ], - BashCompletionScript - <$> setting - [ option, - reader $ maybeReader parseAbsFile, - long "bash-completion-script", - hidden, - help "Render the bash completion script" - ], - ZshCompletionScript - <$> setting - [ option, - reader $ maybeReader parseAbsFile, - long "zsh-completion-script", - hidden, - help "Render the zsh completion script" - ], - ZshCompletionScript - <$> setting - [ option, - reader $ maybeReader parseAbsFile, - long "fish-completion-script", - hidden, - help "Render the fish completion script" - ], - setting - [ help "Query completion", - switch CompletionQuery, - -- Long string that no normal user would ever use. - long "query-opt-env-conf-completion", - hidden - ] - <*> setting - [ switch True, - long "completion-enriched", - value False, - hidden, - help "Whether to enable enriched completion" - ] - <*> setting - [ option, - reader auto, - long "completion-index", - hidden, - help "The index between the arguments where completion was invoked." - ] - <*> many - ( setting - [ option, - reader str, - long "completion-word", - hidden, - help "The words (arguments) that have already been typed" - ] - ), - ParsedNormally <$> p - ] +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 :: + Capabilities -> -- DebugMode Maybe TerminalCapabilities -> Parser a -> @@ -312,7 +87,7 @@ EnvMap -> Maybe JSON.Object -> IO (Either (NonEmpty ParseError) a) -runParserOn mDebugMode parser args envVars mConfig = do +runParserOn capabilities mDebugMode parser args envVars mConfig = do let ppState = PPState { ppStateArgs = args, @@ -344,6 +119,7 @@ Nothing -> pure $ Left $ + -- Only show source locations in debug mode. let f = case mDebugMode of Nothing -> eraseErrorSrcLocs Just _ -> id @@ -425,21 +201,30 @@ if null parsedSettingsMap then ppErrors' errs else ppErrors' $ errs <> (ParseError mLoc (ParseErrorAllOrNothing parsedSettingsMap) :| []) - ParserCheck mLoc forgivable f p' -> do + ParserCheck mLoc forgivable requiredCapabilities f p' -> do debug [syntaxChunk "Parser with check", ": ", mSrcLocChunk mLoc] + when (not (Set.null requiredCapabilities)) $ + debug $ + "Requires capabilities: " + : capabilitiesChunks requiredCapabilities + ppIndent $ do debug ["parser"] + -- Definitely parse below a <- ppIndent $ go p' debug ["check"] - ppIndent $ do - errOrB <- liftIO $ f a - case errOrB of - Left err -> do - debug ["failed, forgivable: ", chunk $ T.pack $ show forgivable] - ppError mLoc $ ParseErrorCheckFailed forgivable err - Right b -> do - debug ["succeeded"] - pure b + -- Only perform the check (IO) if capabilities are sufficient + ppIndent $ case missingCapabilities capabilities requiredCapabilities of + Just missings -> ppErrors mLoc $ NE.map ParseErrorMissingCapability missings + Nothing -> do + errOrB <- liftIO $ f a + case errOrB of + Left err -> do + debug ["failed, forgivable: ", chunk $ T.pack $ show forgivable] + ppError mLoc $ ParseErrorCheckFailed forgivable err + Right b -> do + debug ["succeeded"] + pure b ParserCommands mLoc mDefault cs -> do debug [syntaxChunk "Commands", ": ", mSrcLocChunk mLoc] forM_ mDefault $ \d -> debug ["default:", chunk $ T.pack $ show d] @@ -778,7 +563,7 @@ ParserAllOrNothing mLoc p' -> do debug [syntaxChunk "AllOrNothing", ": ", mSrcLocChunk mLoc] ppIndent $ go p' - ParserCheck mLoc _ _ p' -> do + ParserCheck mLoc _ _ _ p' -> do debug [syntaxChunk "Parser with check", ": ", mSrcLocChunk mLoc] ppIndent $ go p' ParserWithConfig mLoc pc pa -> do @@ -811,14 +596,23 @@ Nothing -> Just (reverse path, commandParserDocs c) Just res -> pure res -type PP a = ReaderT PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a +newtype PP a = PP (ReaderT PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a) + deriving + ( Functor, + Applicative, + Selective, + Monad, + MonadIO, + MonadReader PPEnv, + MonadState PPState + ) runPP :: PP a -> PPState -> PPEnv -> IO [(Validation ParseError a, PPState)] -runPP p args envVars = +runPP (PP p) args envVars = runNonDetT (runStateT (runValidationT (runReaderT p envVars)) args) runPPLazy :: @@ -831,7 +625,7 @@ NonDetT IO (Validation ParseError a, PPState) ) ) -runPPLazy p args envVars = +runPPLazy (PP p) args envVars = runNonDetTLazy (runStateT (runValidationT (runReaderT p envVars)) args) tryPP :: PP a -> PP (Maybe a) @@ -851,7 +645,7 @@ pure $ Just a ppNonDet :: NonDetT IO a -> PP a -ppNonDet = lift . lift . lift +ppNonDet = PP . lift . lift . lift ppNonDetList :: [a] -> PP a ppNonDetList = ppNonDet . liftNonDetTList @@ -923,7 +717,7 @@ pure (Just ()) ppErrors' :: NonEmpty ParseError -> PP a -ppErrors' = lift . ValidationT . lift . pure . Failure +ppErrors' = PP . lift . ValidationT . lift . pure . Failure ppErrors :: Maybe SrcLoc -> NonEmpty ParseErrorMessage -> PP a ppErrors mLoc = ppErrors' . NE.map (ParseError mLoc)