[feat] make running without colour possible

MangoIV · Jun 1, 2024 · ec24563 · ec24563
1 parent 2eaae7e
commit ec24563
Show file tree

Hide file tree

Showing 5 changed files with 138 additions and 53 deletions.
diff --git a/cabal-audit.cabal b/cabal-audit.cabal
@@ -35,27 +35,37 @@ common common-all
 
   default-extensions:
     BlockArguments
+    DataKinds
     DeriveGeneric
     DerivingStrategies
+    DerivingVia
     EmptyCase
+    FlexibleContexts
+    FlexibleInstances
     GADTs
     ImportQualifiedPost
     LambdaCase
+    MultiParamTypeClasses
     NamedFieldPuns
     NoStarIsType
+    OverloadedLists
     OverloadedStrings
     PartialTypeSignatures
     RankNTypes
     ScopedTypeVariables
     StandaloneDeriving
     StandaloneKindSignatures
     TypeApplications
+    TypeFamilies
+    TypeOperators
+    UndecidableInstances
     ViewPatterns
 
 library
   import:           common-all
   exposed-modules:
     Distribution.Audit
+    Effect.Pretty
     Security.Advisories.Cabal
 
   build-depends:
@@ -76,8 +86,10 @@ library
     , process
     , temporary
     , text
+    , transformers
     , unliftio
     , validation-selective
+    , vector
 
   hs-source-dirs:   src
   default-language: Haskell2010

diff --git a/cabal.project b/cabal.project
@@ -6,6 +6,6 @@ source-repository-package
   type: git
   subdir: code/hsec-tools
   location: https://github.com/mangoiv/security-advisories.git
-  tag: 8e8b11e08d8026af91f4487391935dcdc8833c75
+  tag: c1703e8cdb1b78a8692921a74a0584b66bef917e
 
 test-show-details: direct
diff --git a/nix/cabal-audit.nix b/nix/cabal-audit.nix
@@ -19,8 +19,10 @@
   process,
   temporary,
   text,
+  transformers,
   unliftio,
   validation-selective,
+  vector,
 }:
 mkDerivation {
   pname = "cabal-audit";
@@ -46,8 +48,10 @@ mkDerivation {
     process
     temporary
     text
+    transformers
     unliftio
     validation-selective
+    vector
   ];
   executableHaskellDepends = [base];
   testHaskellDepends = [base hspec];

diff --git a/src/Distribution/Audit.hs b/src/Distribution/Audit.hs
@@ -9,7 +9,10 @@
 module Distribution.Audit (auditMain, buildAdvisories, AuditConfig (..), AuditException (..)) where
 
 import Colourista.Pure (blue, bold, formatWith, green, red, yellow)
-import Control.Exception (Exception (displayException), SomeException (SomeException), catch, throwIO)
+import Control.Algebra (Has)
+import Control.Carrier.Error.Church (runError)
+import Control.Carrier.Lift (runM)
+import Control.Exception (Exception (displayException), SomeException (SomeException))
 import Control.Monad (when)
 import Control.Monad.Codensity (Codensity (Codensity, runCodensity))
 import Data.Aeson (KeyValue ((.=)), Value, object)
@@ -23,7 +26,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,16 +40,17 @@ import Distribution.Client.Setup (defaultGlobalFlags)
 import Distribution.Types.PackageName (PackageName, unPackageName)
 import Distribution.Verbosity qualified as Verbosity
 import Distribution.Version (Version, versionNumbers)
+import Effect.Pretty (Pretty, PrettyC, owo, pwetty, runPretty)
 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.Temp (withSystemTempDirectory)
+import System.IO (Handle, IOMode (WriteMode), stdout, withFile)
 import System.Process (callProcess)
+import UnliftIO (MonadIO (..), MonadUnliftIO (..), catch, throwIO, withSystemTempDirectory)
 import Validation (validation)
 
 data AuditException
@@ -88,6 +92,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,42 +103,49 @@ 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 interpPretty :: forall m a. PrettyC [Text] m a -> m a
+      interpPretty = if noColour auditConfig then runPretty (const id) else runPretty formatWith
+      interp = runM . interpPretty
   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
+    interp do
+      buildAdvisories auditConfig nixStyleFlags
+        >>= handleBuiltAdvisories (outputHandle auditConfig) (outputFormat auditConfig)
+    `catch` \(SomeException ex) -> runM $ interpPretty 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
+  :: (MonadUnliftIO m, Has (Pretty [Text]) sig m)
+  => AuditConfig
+  -> NixStyleFlags ()
+  -> m (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}
+    runError
+      (\ex -> throwIO $ CabalException {reason = "trying to establish project base context", cabalException = ex})
+      pure
+      do 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 =
@@ -141,24 +154,24 @@ buildAdvisories MkAuditConfig {advisoriesPathOrURL, verbosity} flags = do
     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 :: (MonadUnliftIO m, Has (Pretty [Text]) sig m) => Codensity IO Handle -> OutputFormat -> M.Map PackageName ElaboratedPackageInfoAdvised -> m ()
 handleBuiltAdvisories mkHandle = \case
   HumanReadable -> humanReadableHandler mkHandle . M.toList
   Osv -> osvHandler mkHandle
 
-osvHandler :: Codensity IO Handle -> M.Map PackageName ElaboratedPackageInfoAdvised -> IO ()
+osvHandler :: MonadUnliftIO m => Codensity IO Handle -> M.Map PackageName ElaboratedPackageInfoAdvised -> m ()
 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 +189,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 :: (MonadUnliftIO m, Has (Pretty [Text]) sig m) => Codensity IO Handle -> [(PackageName, ElaboratedPackageInfoAdvised)] -> m ()
 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 +270,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/Effect/Pretty.hs b/src/Effect/Pretty.hs
@@ -0,0 +1,48 @@
+module Effect.Pretty (Pretty (..), PrettyC (..), runPretty, BlandC (..), pwetty, uwu, owo) where
+
+import Control.Algebra (Algebra (..), Has, send, (:+:) (..))
+import Control.Carrier.Reader (ReaderC (..))
+import Control.Monad.Trans.Identity (IdentityT (..))
+import Data.Kind (Type)
+import Data.Text (Text)
+import Data.Text.IO qualified as T
+import Data.Vector (Vector)
+import System.IO (Handle, stderr, stdout)
+import UnliftIO (MonadIO (..), MonadUnliftIO)
+
+pwetty :: Has (Pretty spec) sig m => Handle -> Vector (spec, Text) -> m ()
+pwetty hdl line = send $ PrettyLine hdl line
+
+owo :: Has (Pretty spec) sig m => Vector (spec, Text) -> m ()
+owo = pwetty stderr
+
+uwu :: Has (Pretty spec) sig m => Vector (spec, Text) -> m ()
+uwu = pwetty stdout
+
+type Pretty :: Type -> (Type -> Type) -> Type -> Type
+data Pretty spec m r where
+  PrettyLine :: Handle -> Vector (spec, Text) -> Pretty spec m ()
+
+newtype PrettyC spec m a = MkPrettyC {runPrettyC :: (spec -> Text -> Text) -> m a}
+  deriving (Functor, Applicative, Monad, MonadIO, MonadUnliftIO) via ReaderC (spec -> Text -> Text) m
+
+runPretty :: (spec -> Text -> Text) -> PrettyC spec m a -> m a
+runPretty = flip runPrettyC
+
+newtype BlandC spec m a = MkBlandC {runBland :: m a}
+  deriving (Functor, Applicative, Monad, MonadIO, MonadUnliftIO) via IdentityT m
+
+instance (Algebra sig m, MonadIO m) => Algebra (Pretty spec :+: sig) (PrettyC spec m) where
+  alg hdl sig ctx =
+    case sig of
+      L (PrettyLine hdl' spec) ->
+        ctx <$ MkPrettyC \colour ->
+          liftIO $ T.hPutStrLn hdl' (uncurry colour `foldMap` spec)
+      R other -> MkPrettyC \colour -> alg (runPretty colour . hdl) other ctx
+
+instance (Algebra sig m, MonadIO m) => Algebra (Pretty spec :+: sig) (BlandC spec m) where
+  alg hdl sig ctx = case sig of
+    L (PrettyLine hdl' spec) ->
+      ctx <$ MkBlandC do
+        liftIO $ T.hPutStrLn hdl' $ foldMap snd spec
+    R other -> MkBlandC $ alg (runBland . hdl) other ctx