cabal-validate/src/ProcessUtil.hs

   1 -- | Utilities for running processes and timing them.
   2 module ProcessUtil
   3   ( timed
   4   , timedWithCwd
   5   ) where
   6
   7 import Control.Exception (throwIO)
   8 import Control.Monad (when)
   9 import Data.ByteString.Lazy (ByteString)
  10 import qualified Data.ByteString.Lazy as ByteString
  11 import Data.Text (Text)
  12 import qualified Data.Text as T
  13 import qualified Data.Text.IO as T
  14 import qualified Data.Text.Lazy as T (toStrict)
  15 import qualified Data.Text.Lazy.Encoding as T (decodeUtf8)
  16 import System.Directory (withCurrentDirectory)
  17 import System.Exit (ExitCode (ExitFailure, ExitSuccess))
  18 import System.Process.Typed (ExitCodeException (..), proc, readProcess, runProcess)
  19
  20 import ANSI (SGR (BrightBlue, BrightGreen, BrightRed, Reset), setSGR)
  21 import Cli (Opts (..), Verbosity (..))
  22 import ClockUtil (diffAbsoluteTime, formatDiffTime, getAbsoluteTime)
  23
  24 -- | Like `timed`, but runs the command in a given directory.
  25 timedWithCwd
  26   :: Opts
  27   -- ^ @cabal-validate@ options.
  28   -> FilePath
  29   -- ^ Path to run the command in.
  30   -> FilePath
  31   -- ^ The command to run.
  32   -> [String]
  33   -- ^ Arguments to pass to the command.
  34   -> IO ()
  35 timedWithCwd opts cdPath command args =
  36   withCurrentDirectory cdPath (timed opts command args)
  37
  38 -- | Run a command, displaying timing information after it finishes.
  39 --
  40 -- This prints out the command to be executed before it's run, handles hiding
  41 -- or showing output (according to the value of `verbose`), and throws an
  42 -- `ExitCodeException` if the command fails.
  43 timed
  44   :: Opts
  45   -- ^ @cabal-validate@ options.
  46   -> FilePath
  47   -- ^ The command to run.
  48   -> [String]
  49   -- ^ Arguments to pass to the command.
  50   -> IO ()
  51 timed opts command args = do
  52   let prettyCommand = displayCommand command args
  53       process = proc command args
  54
  55   startTime' <- getAbsoluteTime
  56
  57   -- TODO: Replace `$HOME` or `opts.cwd` for brevity?
  58   putStrLn $
  59     setSGR [BrightBlue]
  60       <> "$ "
  61       <> prettyCommand
  62       <> setSGR [Reset]
  63
  64   (exitCode, rawStdout, rawStderr) <-
  65     if verbosity opts > Quiet
  66       then do
  67         exitCode <- runProcess process
  68         pure (exitCode, ByteString.empty, ByteString.empty)
  69       else readProcess process
  70
  71   endTime <- getAbsoluteTime
  72
  73   let duration = diffAbsoluteTime endTime startTime'
  74       totalDuration = diffAbsoluteTime endTime (startTime opts)
  75
  76       output = decodeStrip rawStdout <> "\n" <> decodeStrip rawStderr
  77       linesLimit = 50
  78       outputLines = T.lines output
  79       hiddenLines = length outputLines - linesLimit
  80       tailLines = drop hiddenLines outputLines
  81
  82   case exitCode of
  83     ExitSuccess -> do
  84       -- Output is captured when `--quiet` is used, so only print it here
  85       -- if `--quiet` _isn't_ used.
  86       when (verbosity opts > Quiet) $ do
  87         if hiddenLines <= 0
  88           then T.putStrLn output
  89           else
  90             T.putStrLn $
  91               "("
  92                 <> T.pack (show hiddenLines)
  93                 <> " lines hidden, use `--verbose` to show)\n"
  94                 <> "...\n"
  95                 <> T.unlines tailLines
  96
  97       putStrLn $
  98         setSGR [BrightGreen]
  99           <> "Finished after "
 100           <> formatDiffTime duration
 101           <> ": "
 102           <> prettyCommand
 103           <> "\nTotal time so far: "
 104           <> formatDiffTime totalDuration
 105           <> setSGR [Reset]
 106     ExitFailure exitCode' -> do
 107       when (verbosity opts <= Info) $ do
 108         T.putStrLn output
 109
 110       putStrLn $
 111         setSGR [BrightRed]
 112           <> "Failed with exit code "
 113           <> show exitCode'
 114           <> " after "
 115           <> formatDiffTime duration
 116           <> ": "
 117           <> prettyCommand
 118           <> "\nTotal time so far: "
 119           <> formatDiffTime totalDuration
 120           <> setSGR [Reset]
 121
 122       throwIO
 123         ExitCodeException
 124           { eceExitCode = exitCode
 125           , eceProcessConfig = process
 126           , eceStdout = rawStdout
 127           , eceStderr = rawStderr
 128           }
 129
 130 -- | Decode `ByteString` output from a command and strip whitespace at the
 131 -- start and end.
 132 decodeStrip :: ByteString -> Text
 133 decodeStrip = T.strip . T.toStrict . T.decodeUtf8
 134
 135 -- | Escape a shell command to display it to a user.
 136 --
 137 -- TODO: Shell escaping
 138 displayCommand :: String -> [String] -> String
 139 displayCommand command args = command <> " " <> unwords args