[feat] make running without colour possible

cabal-audit.cabal

@@ -35,27 +35,33 @@ common common-all
 
   default-extensions:
     BlockArguments
+    DataKinds
     DeriveGeneric
     DerivingStrategies
     EmptyCase
+    FlexibleContexts
     GADTs
     ImportQualifiedPost
     LambdaCase
     NamedFieldPuns
     NoStarIsType
+    OverloadedLists
     OverloadedStrings
     PartialTypeSignatures
     RankNTypes
     ScopedTypeVariables
     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

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];

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,14 +37,17 @@ 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)
 import Security.Advisories.Cabal (ElaboratedPackageInfoAdvised, ElaboratedPackageInfoWith (..), matchAdvisoriesForPlan)
 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,68 +102,72 @@ 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
 
 -- | 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 ())

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