Improve logging of sub-processes

src/Stack/Build/Execute.hs

@@ -87,7 +87,7 @@ import           System.Exit (ExitCode (ExitSuccess))
 import qualified System.FilePath as FP
 import           System.IO
 import           System.PosixCompat.Files (createLink)
-import           System.Process.Log (showProcessArgDebug)
+import           System.Process.Log (showProcessArgDebug, withProcessTimeLog)
 import           System.Process.Read
 import           System.Process.Run
 
@@ -453,9 +453,9 @@ executePlan menv boptsCli baseConfigOpts locals globalPackages snapshotPackages
                     , esStackExe = True
                     , esLocaleUtf8 = False
                     }
-    forM_ (boptsCLIExec boptsCli) $ \(cmd, args) -> do
-        $logProcessRun cmd args
-        callProcess (Cmd Nothing cmd menv' args)
+    forM_ (boptsCLIExec boptsCli) $ \(cmd, args) ->
+        $withProcessTimeLog cmd args $
+            callProcess (Cmd Nothing cmd menv' args)
 
 -- | Windows can't write over the current executable. Instead, we rename the
 -- current executable to something else and then do the copy.

src/Stack/Exec.hs

@@ -61,9 +61,9 @@ exec :: (MonadIO m, MonadLogger m, MonadBaseControl IO m)
 exec = execSpawn
 #else
 exec menv cmd0 args = do
-    $logProcessRun cmd0 args
     cmd <- preProcess Nothing menv cmd0
-    liftIO $ executeFile cmd True args (envHelper menv)
+    $withProcessTimeLog cmd args $
+        liftIO $ executeFile cmd True args (envHelper menv)
 #endif
 
 -- | Like 'exec', but does not use 'execv' on non-windows. This way, there
@@ -73,8 +73,8 @@ exec menv cmd0 args = do
 execSpawn :: (MonadIO m, MonadLogger m, MonadBaseControl IO m)
      => EnvOverride -> String -> [String] -> m b
 execSpawn menv cmd0 args = do
-    $logProcessRun cmd0 args
-    e <- try (callProcess (Cmd Nothing cmd0 menv args))
+    e <- $withProcessTimeLog cmd0 args $
+        try (callProcess (Cmd Nothing cmd0 menv args))
     liftIO $ case e of
         Left (ProcessExitedUnsuccessfully _ ec) -> exitWith ec
         Right () -> exitSuccess

src/Stack/Setup.hs

@@ -87,6 +87,7 @@ import           System.Exit (ExitCode (ExitSuccess))
 import           System.FilePath (searchPathSeparator)
 import qualified System.FilePath as FP
 import           System.Process (rawSystem)
+import           System.Process.Log (withProcessTimeLog)
 import           System.Process.Read
 import           System.Process.Run (runCmd, Cmd(..))
 import           Text.Printf (printf)
@@ -1196,8 +1197,8 @@ setup7z si = do
                         , "-y"
                         , toFilePath archive
                         ]
-                $logProcessRun cmd args
-                ec <- liftIO $ rawSystem cmd args
+                ec <- $withProcessTimeLog cmd args $
+                    liftIO $ rawSystem cmd args
                 when (ec /= ExitSuccess)
                     $ liftIO $ throwM (ProblemWhileDecompressing archive)
         _ -> throwM SetupInfoMissingSevenz

src/System/Process/Log.hs

@@ -1,18 +1,21 @@
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 -- | Separate module because TH.
 
 module System.Process.Log
     (logCreateProcess
-    ,logProcessRun
+    ,withProcessTimeLog
     ,showProcessArgDebug)
     where
 
 import           Control.Monad.Logger
+import           Control.Monad.IO.Class
 import           Data.Monoid
 import           Data.Text (Text)
 import qualified Data.Text as T
 import           Language.Haskell.TH
+import qualified System.Clock as Clock
 import           System.Process (CreateProcess(..), CmdSpec(..))
 
 -- | Log running a process with its arguments, for debugging (-v).
@@ -30,17 +33,31 @@ logCreateProcess =
       in f|]
 
 -- | Log running a process with its arguments, for debugging (-v).
-logProcessRun :: Q Exp
-logProcessRun =
-    [|let f :: MonadLogger m => String -> [String] -> m ()
-          f name args =
+--
+-- This logs one message before running the process and one message after.
+withProcessTimeLog :: Q Exp
+withProcessTimeLog =
+    [|let f :: (MonadIO m, MonadLogger m) => String -> [String] -> m a -> m a
+          f name args proc = do
+              let cmdText =
+                      T.intercalate
+                          " "
+                          (T.pack name : map showProcessArgDebug args)
+              $logDebug ("Run process: " <> cmdText)
+              start <- liftIO $ Clock.getTime Clock.Monotonic
+              x <- proc
+              end <- liftIO $ Clock.getTime Clock.Monotonic
+              let diff = Clock.diffTimeSpec start end
               $logDebug
-                  ("Run process: " <> T.pack name <> " " <>
-                   T.intercalate
-                       " "
-                       (map showProcessArgDebug args))
+                  ("Process finished in " <> timeSpecMilliSecondText diff <>
+                   ": " <> cmdText)
+              return x
       in f|]
 
+timeSpecMilliSecondText :: Clock.TimeSpec -> Text
+timeSpecMilliSecondText t =
+    (T.pack . show . (`div` 10^(6 :: Int)) . Clock.toNanoSecs) t <> " ms"
+
 -- | Show a process arg including speechmarks when necessary. Just for
 -- debugging purposes, not functionally important.
 showProcessArgDebug :: String -> Text

src/System/Process/Read.hs

@@ -29,7 +29,6 @@ module System.Process.Read
   ,preProcess
   ,readProcessNull
   ,readInNull
-  ,logProcessRun
   ,ReadProcessException (..)
   ,augmentPath
   ,augmentPathMap
@@ -289,11 +288,11 @@ sinkProcessStderrStdout :: forall m e o. (MonadIO m, MonadLogger m)
                         -> Sink S.ByteString IO o -- ^ Sink for stdout
                         -> m (e,o)
 sinkProcessStderrStdout wd menv name args sinkStderr sinkStdout = do
-  $logProcessRun name args
   name' <- preProcess wd menv name
-  liftIO $ withCheckedProcess
-      (proc name' args) { env = envHelper menv, cwd = fmap toFilePath wd }
-      (\ClosedStream out err -> f err out)
+  $withProcessTimeLog name' args $
+      liftIO $ withCheckedProcess
+          (proc name' args) { env = envHelper menv, cwd = fmap toFilePath wd }
+          (\ClosedStream out err -> f err out)
   where
     f :: Source IO S.ByteString -> Source IO S.ByteString -> IO (e, o)
     f err out = (err $$ sinkStderr) `concurrently` (out $$ sinkStdout)
@@ -307,16 +306,16 @@ sinkProcessStderrStdoutHandle :: (MonadIO m, MonadLogger m)
                               -> Handle
                               -> m ()
 sinkProcessStderrStdoutHandle wd menv name args err out = do
-  $logProcessRun name args
   name' <- preProcess wd menv name
-  liftIO $ withCheckedProcess
-      (proc name' args)
-          { env = envHelper menv
-          , cwd = fmap toFilePath wd
-          , std_err = UseHandle err
-          , std_out = UseHandle out
-          }
-      (\ClosedStream UseProvidedHandle UseProvidedHandle -> return ())
+  $withProcessTimeLog name' args $
+      liftIO $ withCheckedProcess
+          (proc name' args)
+              { env = envHelper menv
+              , cwd = fmap toFilePath wd
+              , std_err = UseHandle err
+              , std_out = UseHandle out
+              }
+          (\ClosedStream UseProvidedHandle UseProvidedHandle -> return ())
 
 -- | Perform pre-call-process tasks.  Ensure the working directory exists and find the
 -- executable path.

stack-7.8.yaml

@@ -62,6 +62,7 @@ extra-deps:
 - th-orphans-0.13.1
 - base-orphans-0.5.4
 - tar-0.5.0.3
+- clock-0.7.2
 flags:
   time-locale-compat:
-    old-locale: false
+    old-locale: false

stack.cabal

@@ -152,6 +152,7 @@ library
                    , blaze-builder
                    , byteable
                    , bytestring >= 0.10.4.0
+                   , clock >= 0.7.2
                    , conduit >= 1.2.4
                    , conduit-extra >= 1.1.7.1
                    , containers >= 0.5.5.1