From c307208f53e81c4226dbd49a1b1b7eb07afa061e Mon Sep 17 00:00:00 2001 From: mangoiv Date: Sun, 17 Mar 2024 20:06:49 +0100 Subject: [PATCH] [feat] replace the cabal parser with optparse-applicative --- code/hsec-cabal/hsec-cabal.cabal | 2 + code/hsec-cabal/src/Distribution/Audit.hs | 148 ++++++++++------------ 2 files changed, 66 insertions(+), 84 deletions(-) diff --git a/code/hsec-cabal/hsec-cabal.cabal b/code/hsec-cabal/hsec-cabal.cabal index c5783791..34665513 100644 --- a/code/hsec-cabal/hsec-cabal.cabal +++ b/code/hsec-cabal/hsec-cabal.cabal @@ -45,6 +45,7 @@ common common-all ScopedTypeVariables StandaloneDeriving StandaloneKindSignatures + TypeApplications library import: common-all @@ -60,6 +61,7 @@ library , filepath , hsec-core , hsec-tools + , optparse-applicative , text , validation-selective diff --git a/code/hsec-cabal/src/Distribution/Audit.hs b/code/hsec-cabal/src/Distribution/Audit.hs index a7a890dc..1dcb3218 100644 --- a/code/hsec-cabal/src/Distribution/Audit.hs +++ b/code/hsec-cabal/src/Distribution/Audit.hs @@ -1,108 +1,88 @@ module Distribution.Audit (auditMain) where -import Data.Foldable (traverse_) -import Distribution.Client.NixStyleOptions - ( NixStyleFlags (configFlags) - , defaultNixStyleFlags - , nixStyleOptions - ) +import Control.Exception (Exception (displayException), throwIO) +import Distribution.Client.NixStyleOptions (NixStyleFlags, defaultNixStyleFlags) import Distribution.Client.ProjectConfig (ProjectConfig) import Distribution.Client.ProjectOrchestration ( CurrentCommand (OtherCommand) - , ProjectBaseContext - ( ProjectBaseContext - , cabalDirLayout - , distDirLayout - , localPackages - , projectConfig - ) + , ProjectBaseContext (ProjectBaseContext, cabalDirLayout, distDirLayout, localPackages, projectConfig) , commandLineFlagsToProjectConfig , establishProjectBaseContext ) import Distribution.Client.ProjectPlanning (rebuildInstallPlan) -import Distribution.Client.Setup (ConfigFlags (configVerbosity), defaultGlobalFlags) -import Distribution.Simple.Command - ( CommandParse (CommandErrors, CommandHelp, CommandList, CommandReadyToGo) - , CommandUI (..) - , commandParseArgs - , mkCommandUI - ) -import Distribution.Simple.Flag (fromFlagOrDefault) -import qualified Distribution.Verbosity as Verbosity -import System.Environment (getArgs) -import qualified System.FilePath as FP -import Control.Exception (throwIO, Exception (displayException)) -import Security.Advisories.Filesystem (listAdvisories) -import Validation (validation) -import Security.Advisories (ParseAdvisoryError) +import Distribution.Client.Setup (defaultGlobalFlags) +import Distribution.Verbosity qualified as Verbosity import GHC.Generics (Generic) +import Options.Applicative +import Security.Advisories (ParseAdvisoryError) import Security.Advisories.Cabal (matchAdvisoriesForPlan) +import Security.Advisories.Filesystem (listAdvisories) +import Validation (validation) -data AuditException - = MissingArgs - | TooManyArgs - | InvalidFilePath String +data AuditException + = InvalidFilePath String | ListAdvisoryValidationError FilePath [ParseAdvisoryError] deriving stock (Eq, Show, Generic) instance Exception AuditException where - displayException = \case - MissingArgs -> "You didn't specify where to take the audit results from" - TooManyArgs -> "Expected only one argument" - InvalidFilePath fp -> show fp <> " is not a valid filepath" - ListAdvisoryValidationError dir errs -> unlines - [ "Listing the advisories in directory " <> dir <> " failed with:" - , show errs - ] + displayException = \case + InvalidFilePath fp -> show fp <> " is not a valid filepath" + ListAdvisoryValidationError dir errs -> + unlines + [ "Listing the advisories in directory " <> dir <> " failed with:" + , show errs + ] + +-- | configuration that is specific to the cabal audit command +data AuditConfig = MkAuditConfig + { advisoriesPath :: FilePath + -- ^ path to the advisories + , verbosity :: Verbosity.Verbosity + -- ^ verbosity of cabal + } auditMain :: IO () -auditMain = - handleArgs auditCommandUI \args flags -> do - let verbosity = verbosityFromFlags flags - cliConfig = projectConfigFromFlags flags - ProjectBaseContext {distDirLayout, cabalDirLayout, projectConfig, localPackages} <- - establishProjectBaseContext - verbosity - cliConfig - OtherCommand - (plan', plan, _, _, _) <- - rebuildInstallPlan verbosity distDirLayout cabalDirLayout projectConfig localPackages Nothing +auditMain = do + (MkAuditConfig {advisoriesPath, verbosity}, flags) <- customExecParser (prefs showHelpOnEmpty) do + info + do helper <*> auditCommandParser + do + mconcat + [ fullDesc + , progDesc "audit your cabal projects for vulnerabilities" + , header "Welcome to cabal audit" + ] + let cliConfig = projectConfigFromFlags flags - fp <- case args of - [] -> throwIO MissingArgs - [fp] -> if FP.isValid fp then pure fp else throwIO (InvalidFilePath fp) - (_x : _y : _zs) -> throwIO TooManyArgs - advisories <- listAdvisories fp - >>= validation (throwIO . ListAdvisoryValidationError fp) pure + ProjectBaseContext {distDirLayout, cabalDirLayout, projectConfig, localPackages} <- + establishProjectBaseContext + verbosity + cliConfig + OtherCommand + (_plan', plan, _, _, _) <- + rebuildInstallPlan verbosity distDirLayout cabalDirLayout projectConfig localPackages Nothing + advisories <- + listAdvisories advisoriesPath + >>= validation (throwIO . ListAdvisoryValidationError advisoriesPath) pure + print $ matchAdvisoriesForPlan plan advisories - print $ matchAdvisoriesForPlan plan advisories - print $ matchAdvisoriesForPlan plan' advisories - -- TODO(mangoiv): find out what's the correct plan +-- print $ matchAdvisoriesForPlan plan' advisories +-- TODO(mangoiv): find out what's the correct plan projectConfigFromFlags :: NixStyleFlags a -> ProjectConfig projectConfigFromFlags flags = commandLineFlagsToProjectConfig defaultGlobalFlags flags mempty -verbosityFromFlags :: NixStyleFlags a -> Verbosity.Verbosity -verbosityFromFlags = fromFlagOrDefault Verbosity.normal . configVerbosity . configFlags - -auditCommandUI :: CommandUI (NixStyleFlags ()) -auditCommandUI = - mkCommandUI - "audit" - "Audits your cabal project" - [""] - do defaultNixStyleFlags () - do nixStyleOptions (const []) - --- | handle cabal global command args -handleArgs - :: CommandUI flags - -> ([String] -> flags -> IO ()) - -> IO () -handleArgs ui k = do - args <- getArgs - case commandParseArgs ui False args of - CommandHelp help -> putStrLn $ help "cabal" - CommandList opts -> putStrLn `traverse_` opts - CommandErrors errs -> putStrLn `traverse_` errs - CommandReadyToGo (flags, commandParse) -> k commandParse $ flags $ commandDefaultFlags ui +auditCommandParser :: Parser (AuditConfig, NixStyleFlags ()) +auditCommandParser = + (,) + <$> do + MkAuditConfig + <$> strArgument (metavar "") + <*> flip option (long "verbosity" <> value Verbosity.normal <> showDefaultWith (const "normal")) do + eitherReader \case + "silent" -> Right Verbosity.silent + "normal" -> Right Verbosity.normal + "verbose" -> Right Verbosity.verbose + "deafening" -> Right Verbosity.deafening + _ -> Left "verbosity has to be one of \"silent\", \"normal\", \"verbose\" or \"deafening\"" + <*> pure (defaultNixStyleFlags ())