[feat] replace the cabal parser with optparse-applicative

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
 

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"
-    ["<hsec-advisory-directory>"]
-    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 "<path to advisories>")
+        <*> 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 ())