diff --git a/cabal-audit.cabal b/cabal-audit.cabal index dae34a0..4d8fa11 100644 --- a/cabal-audit.cabal +++ b/cabal-audit.cabal @@ -35,14 +35,17 @@ common common-all default-extensions: BlockArguments + DataKinds DeriveGeneric DerivingStrategies EmptyCase + FlexibleContexts GADTs ImportQualifiedPost LambdaCase NamedFieldPuns NoStarIsType + OverloadedLists OverloadedStrings PartialTypeSignatures RankNTypes @@ -50,12 +53,15 @@ common common-all StandaloneDeriving StandaloneKindSignatures TypeApplications + TypeFamilies + TypeOperators ViewPatterns library import: common-all exposed-modules: Distribution.Audit + Effectful.Pretty Security.Advisories.Cabal build-depends: @@ -66,6 +72,7 @@ library , cabal-install , colourista , containers + , effectful , filepath , fused-effects , hsec-core ^>=0.1 @@ -78,6 +85,7 @@ library , text , unliftio , validation-selective + , vector hs-source-dirs: src default-language: Haskell2010 diff --git a/nix/cabal-audit.nix b/nix/cabal-audit.nix index 6771db0..5cbc0e1 100644 --- a/nix/cabal-audit.nix +++ b/nix/cabal-audit.nix @@ -7,6 +7,7 @@ cabal-install, colourista, containers, + effectful, filepath, fused-effects, hsec-core, @@ -21,6 +22,7 @@ text, unliftio, validation-selective, + vector, }: mkDerivation { pname = "cabal-audit"; @@ -36,6 +38,7 @@ mkDerivation { cabal-install colourista containers + effectful filepath fused-effects hsec-core @@ -48,6 +51,7 @@ mkDerivation { text unliftio validation-selective + vector ]; executableHaskellDepends = [base]; testHaskellDepends = [base hspec]; diff --git a/src/Distribution/Audit.hs b/src/Distribution/Audit.hs index 91f4ac2..f774771 100644 --- a/src/Distribution/Audit.hs +++ b/src/Distribution/Audit.hs @@ -23,7 +23,7 @@ import Data.Map qualified as M import Data.String (IsString (fromString)) import Data.Text (Text) import Data.Text qualified as T -import Data.Text.IO qualified as T +import Data.Vector (Vector) import Distribution.Client.NixStyleOptions (NixStyleFlags, defaultNixStyleFlags) import Distribution.Client.ProjectConfig (ProjectConfig) import Distribution.Client.ProjectOrchestration @@ -37,6 +37,9 @@ import Distribution.Client.Setup (defaultGlobalFlags) import Distribution.Types.PackageName (PackageName, unPackageName) import Distribution.Verbosity qualified as Verbosity import Distribution.Version (Version, versionNumbers) +import Effectful (Eff, IOE, MonadIO (liftIO), MonadUnliftIO (withRunInIO), runEff, type (:>)) +import Effectful.Error.Dynamic (Error, runErrorNoCallStackWith, throwError) +import Effectful.Pretty (Pretty, owo, pwetty, runPrettyBland, runPrettyColoured) import GHC.Generics (Generic) import Options.Applicative import Security.Advisories (Advisory (..), Keyword (..), ParseAdvisoryError (..), printHsecId) @@ -44,7 +47,7 @@ import Security.Advisories.Cabal (ElaboratedPackageInfoAdvised, ElaboratedPackag import Security.Advisories.Convert.OSV qualified as OSV import Security.Advisories.Filesystem (listAdvisories) import System.Exit (exitFailure) -import System.IO (Handle, IOMode (WriteMode), hPutStrLn, stderr, stdout, withFile) +import System.IO (Handle, IOMode (WriteMode), stdout, withFile) import System.IO.Temp (withSystemTempDirectory) import System.Process (callProcess) import Validation (validation) @@ -88,6 +91,8 @@ data AuditConfig = MkAuditConfig -- ^ what output format to use , outputHandle :: Codensity IO Handle -- ^ which handle to write to + , noColour :: Bool + -- ^ whether or not to write coloured output } -- | the main action to invoke @@ -97,52 +102,56 @@ auditMain = do info (helper <*> auditCommandParser) do mconcat [ fullDesc - , progDesc (formatWith [blue] "audit your cabal projects for vulnerabilities") - , header (formatWith [bold, blue] "Welcome to cabal audit") + , progDesc "audit your cabal projects for vulnerabilities" + , header "Welcome to cabal audit" ] - + let prettyHandler :: forall es a. IOE :> es => Eff (Pretty [Text] : es) a -> Eff es a + prettyHandler = if noColour auditConfig then runPrettyBland else runPrettyColoured formatWith do - buildAdvisories auditConfig nixStyleFlags - >>= handleBuiltAdvisories (outputHandle auditConfig) (outputFormat auditConfig) - `catch` \(SomeException ex) -> do - hPutStrLn stderr $ - unlines - [ formatWith [red, bold] "cabal-audit failed:" - , formatWith [red] $ displayException ex - ] - exitFailure + runEff + . runErrorNoCallStackWith (\(e :: AuditException) -> liftIO $ throwIO e) + . prettyHandler + $ do + buildAdvisories auditConfig nixStyleFlags + >>= handleBuiltAdvisories (outputHandle auditConfig) (outputFormat auditConfig) + `catch` \(SomeException ex) -> runEff $ prettyHandler do + owo @[Text] + [ ([red, bold], "cabal-audit failed:\n") + , ([red], T.pack $ displayException ex) + ] + liftIO exitFailure -buildAdvisories :: AuditConfig -> NixStyleFlags () -> IO (M.Map PackageName ElaboratedPackageInfoAdvised) +buildAdvisories :: (IOE :> es, Error AuditException :> es, Pretty [Text] :> es) => AuditConfig -> NixStyleFlags () -> Eff es (M.Map PackageName ElaboratedPackageInfoAdvised) buildAdvisories MkAuditConfig {advisoriesPathOrURL, verbosity} flags = do let cliConfig = projectConfigFromFlags flags ProjectBaseContext {distDirLayout, cabalDirLayout, projectConfig, localPackages} <- - establishProjectBaseContext - verbosity - cliConfig - OtherCommand - `catch` \ex -> throwIO $ CabalException {reason = "trying to establish project base context", cabalException = ex} + runErrorNoCallStackWith + (\ex -> throwError $ CabalException {reason = "trying to establish project base context", cabalException = ex}) + (liftIO (establishProjectBaseContext verbosity cliConfig OtherCommand)) + -- the two plans are -- 1. the "improved plan" with packages replaced by in-store packages -- 2. the "original" elaborated plan -- -- as far as I can tell, for our use case these should be indistinguishable (_improvedPlan, plan, _, _, _) <- - rebuildInstallPlan verbosity distDirLayout cabalDirLayout projectConfig localPackages Nothing - `catch` \ex -> throwIO $ CabalException {reason = "elaborating the install-plan", cabalException = ex} + liftIO $ + rebuildInstallPlan verbosity distDirLayout cabalDirLayout projectConfig localPackages Nothing + `catch` \ex -> throwIO $ CabalException {reason = "elaborating the install-plan", cabalException = ex} when (verbosity > Verbosity.normal) do - hPutStrLn stderr (formatWith [blue] "Finished building the cabal install plan, looking for advisories...") + owo @[Text] [([blue], "Finished building the cabal install plan, looking for advisories...")] advisories <- do let k realPath = listAdvisories realPath - >>= validation (throwIO . ListAdvisoryValidationError realPath) pure + >>= validation (throwError . ListAdvisoryValidationError realPath) pure case advisoriesPathOrURL of Left fp -> k fp Right url -> withSystemTempDirectory "cabal-audit" \tmp -> do - hPutStrLn stderr $ formatWith [blue] $ "trying to clone " <> url - callProcess "git" ["clone", "--depth", "1", url, tmp] + owo @[Text] [([blue], "trying to clone " <> T.pack url)] + liftIO $ callProcess "git" ["clone", "--depth", "1", url, tmp] k tmp pure $ matchAdvisoriesForPlan plan advisories @@ -150,15 +159,15 @@ buildAdvisories MkAuditConfig {advisoriesPathOrURL, verbosity} flags = do -- | provides the built advisories in some consumable form, e.g. as human readable form -- -- FUTUREWORK(mangoiv): provide output as JSON -handleBuiltAdvisories :: Codensity IO Handle -> OutputFormat -> M.Map PackageName ElaboratedPackageInfoAdvised -> IO () +handleBuiltAdvisories :: (IOE :> es, Pretty [Text] :> es) => Codensity IO Handle -> OutputFormat -> M.Map PackageName ElaboratedPackageInfoAdvised -> Eff es () handleBuiltAdvisories mkHandle = \case HumanReadable -> humanReadableHandler mkHandle . M.toList Osv -> osvHandler mkHandle -osvHandler :: Codensity IO Handle -> M.Map PackageName ElaboratedPackageInfoAdvised -> IO () +osvHandler :: IOE :> es => Codensity IO Handle -> M.Map PackageName ElaboratedPackageInfoAdvised -> Eff es () osvHandler mkHandle mp = - runCodensity mkHandle \hdl -> - BSL.hPutStr hdl . Aeson.encode @Value . object $ + withRunCodensityInIO mkHandle \hdl -> + liftIO . BSL.hPutStr hdl . Aeson.encode @Value . object $ flip M.foldMapWithKey mp \pn MkElaboratedPackageInfoWith {elaboratedPackageVersion, packageAdvisories} -> [ fromString (unPackageName pn) .= object @@ -176,35 +185,36 @@ prettyVersion :: IsString s => Version -> s prettyVersion = fromString . List.intercalate "." . map show . versionNumbers {-# INLINE prettyVersion #-} -prettyAdvisory :: Advisory -> Maybe Version -> Text +prettyAdvisory :: Advisory -> Maybe Version -> Vector ([Text], Text) prettyAdvisory Advisory {advisoryId, advisoryPublished, advisoryKeywords, advisorySummary} mfv = - T.unlines do - let hsecId = T.pack (printHsecId advisoryId) - map - (" " <>) - [ formatWith [bold, blue] hsecId <> " \"" <> advisorySummary <> "\"" - , "published: " <> formatWith [bold] (T.pack $ show advisoryPublished) - , "https://haskell.github.io/security-advisories/advisory/" <> hsecId - , fixAvailable - , formatWith [blue] $ T.intercalate ", " (coerce advisoryKeywords) - ] + let hsecId = T.pack (printHsecId advisoryId) + in fmap (\line -> " " <> line <> "\n") + <$> [ ([bold, blue], hsecId <> " \"" <> advisorySummary <> "\"") + , ([], "published: ") <> ([bold], T.pack $ show advisoryPublished) + , ([], "https://haskell.github.io/security-advisories/advisory/" <> hsecId) + ] + <> fixAvailable + <> [([blue], T.intercalate ", " (coerce advisoryKeywords))] where fixAvailable = case mfv of - Nothing -> formatWith [bold, red] "No fix version available" - Just fv -> formatWith [bold, green] "Fix available since version " <> formatWith [yellow] (prettyVersion fv) + Nothing -> [([bold, red], "No fix version available")] + Just fv -> [([bold, green], "Fix available since version "), ([yellow], prettyVersion fv)] + +withRunCodensityInIO :: MonadUnliftIO m => Codensity IO a -> (a -> m b) -> m b +withRunCodensityInIO cod k = withRunInIO \inIO -> runCodensity cod (inIO . k) -- | this is handler is used when displaying to the user -humanReadableHandler :: Codensity IO Handle -> [(PackageName, ElaboratedPackageInfoAdvised)] -> IO () +humanReadableHandler :: (IOE :> es, Pretty [Text] :> es) => Codensity IO Handle -> [(PackageName, ElaboratedPackageInfoAdvised)] -> Eff es () humanReadableHandler mkHandle = - runCodensity mkHandle . flip \hdl -> \case - [] -> hPutStrLn hdl (formatWith [green, bold] "No advisories found.") + withRunCodensityInIO mkHandle . flip \hdl -> \case + [] -> pwetty @[Text] hdl [([green, bold], "No advisories found.")] avs -> do - hPutStrLn hdl (formatWith [bold, red] "\n\nFound advisories:\n") + pwetty @[Text] hdl [([bold, red], "\n\nFound advisories:\n")] for_ avs \(pn, i) -> do - let verString = formatWith [yellow] $ prettyVersion $ elaboratedPackageVersion i - pkgName = formatWith [yellow] $ show $ unPackageName pn - hPutStrLn hdl ("dependency " <> pkgName <> " at version " <> verString <> " is vulnerable for:") - for_ (runIdentity (packageAdvisories i)) (T.hPutStrLn hdl . uncurry prettyAdvisory) + let verString = ([yellow], prettyVersion $ elaboratedPackageVersion i) + pkgName = ([yellow], T.pack $ show $ unPackageName pn) + pwetty @[Text] hdl [([], "dependency "), pkgName, ([], " at version "), verString, ([], " is vulnerable for:")] + for_ (runIdentity (packageAdvisories i)) (pwetty hdl . uncurry prettyAdvisory) projectConfigFromFlags :: NixStyleFlags a -> ProjectConfig projectConfigFromFlags flags = commandLineFlagsToProjectConfig defaultGlobalFlags flags mempty @@ -256,6 +266,13 @@ auditCommandParser = , help "specify a file to write to, instead of stdout" ] <|> pure (Codensity \k -> k stdout) + <*> switch do + mconcat + [ long "no-colour" + , long "no-color" + , short 'b' + , help "don't colour the output" + ] -- FUTUREWORK(mangoiv): this will accept cabal flags as an additional argument with something like -- --cabal-flags "--some-cabal-flag" and print a helper that just forwards the cabal help text <*> pure (defaultNixStyleFlags ()) diff --git a/src/Effectful/Pretty.hs b/src/Effectful/Pretty.hs new file mode 100644 index 0000000..b987b22 --- /dev/null +++ b/src/Effectful/Pretty.hs @@ -0,0 +1,32 @@ +module Effectful.Pretty (Pretty (..), pwetty, uwu, owo, runPrettyColoured, runPrettyBland) where + +import Data.Kind (Type) +import Data.Text (Text) +import Data.Text.IO qualified as T +import Data.Vector (Vector) +import Effectful +import Effectful.Dispatch.Dynamic (interpret, send) +import System.IO (Handle, stderr, stdout) + +pwetty :: Pretty spec :> es => Handle -> Vector (spec, Text) -> Eff es () +pwetty hdl line = send $ PrettyLine hdl line + +owo :: Pretty spec :> es => Vector (spec, Text) -> Eff es () +owo = pwetty stderr + +uwu :: Pretty spec :> es => Vector (spec, Text) -> Eff es () +uwu = pwetty stdout + +type Pretty :: Type -> Effect +data Pretty spec m r where + PrettyLine :: Handle -> Vector (spec, Text) -> Pretty spec m () + +type instance DispatchOf (Pretty spec) = Dynamic + +runPrettyColoured :: IOE :> es => (spec -> Text -> Text) -> Eff (Pretty spec : es) a -> Eff es a +runPrettyColoured colour = interpret \_ -> \case + PrettyLine hdl txt -> liftIO $ T.hPutStrLn hdl $ uncurry colour `foldMap` txt + +runPrettyBland :: IOE :> es => Eff (Pretty spec : es) a -> Eff es a +runPrettyBland = interpret \_ -> \case + PrettyLine hdl txt -> liftIO $ T.hPutStrLn hdl $ foldMap snd txt