Skip to content

Commit 9e7b590

Browse files
sjakobimgsloan
sjakobi
authored and
mgsloan
committed
Improve logging of sub-processes
* Log the fully qualified command name (/usr/bin/ldd instead of ldd) * Log how long the sub-process took to finish
1 parent 099ca78 commit 9e7b590

6 files changed

Lines changed: 51 additions & 33 deletions

File tree

‎src/Stack/Build/Execute.hs‎

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -94,7 +94,7 @@ import System.Exit (ExitCode (ExitSuccess))
9494
import qualified System.FilePath as FP
9595
import System.IO
9696
import System.PosixCompat.Files (createLink)
97-
import System.Process.Log (showProcessArgDebug)
97+
import System.Process.Log (showProcessArgDebug, withProcessTimeLog)
9898
import System.Process.Read
9999
import System.Process.Run
100100

@@ -461,9 +461,9 @@ executePlan menv boptsCli baseConfigOpts locals globalPackages snapshotPackages
461461
, esStackExe = True
462462
, esLocaleUtf8 = False
463463
}
464-
forM_ (boptsCLIExec boptsCli) $ \(cmd, args) -> do
465-
$logProcessRun cmd args
466-
callProcess (Cmd Nothing cmd menv' args)
464+
forM_ (boptsCLIExec boptsCli) $ \(cmd, args) ->
465+
$withProcessTimeLog cmd args $
466+
callProcess (Cmd Nothing cmd menv' args)
467467

468468
-- | Windows can't write over the current executable. Instead, we rename the
469469
-- current executable to something else and then do the copy.

‎src/Stack/Exec.hs‎

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -61,9 +61,9 @@ exec :: (MonadIO m, MonadLogger m, MonadBaseControl IO m)
6161
exec = execSpawn
6262
#else
6363
exec menv cmd0 args = do
64-
$logProcessRun cmd0 args
6564
cmd <- preProcess Nothing menv cmd0
66-
liftIO $ executeFile cmd True args (envHelper menv)
65+
$withProcessTimeLog cmd args $
66+
liftIO $ executeFile cmd True args (envHelper menv)
6767
#endif
6868

6969
-- | Like 'exec', but does not use 'execv' on non-windows. This way, there
@@ -73,8 +73,8 @@ exec menv cmd0 args = do
7373
execSpawn :: (MonadIO m, MonadLogger m, MonadBaseControl IO m)
7474
=> EnvOverride -> String -> [String] -> m b
7575
execSpawn menv cmd0 args = do
76-
$logProcessRun cmd0 args
77-
e <- try (callProcess (Cmd Nothing cmd0 menv args))
76+
e <- $withProcessTimeLog cmd0 args $
77+
try (callProcess (Cmd Nothing cmd0 menv args))
7878
liftIO $ case e of
7979
Left (ProcessExitedUnsuccessfully _ ec) -> exitWith ec
8080
Right () -> exitSuccess

‎src/Stack/Setup.hs‎

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -94,6 +94,7 @@ import System.Exit (ExitCode (ExitSuccess))
9494
import System.FilePath (searchPathSeparator)
9595
import qualified System.FilePath as FP
9696
import System.Process (rawSystem)
97+
import System.Process.Log (withProcessTimeLog)
9798
import System.Process.Read
9899
import System.Process.Run (runCmd, Cmd(..))
99100
import Text.Printf (printf)
@@ -1203,8 +1204,8 @@ setup7z si = do
12031204
, "-y"
12041205
, toFilePath archive
12051206
]
1206-
$logProcessRun cmd args
1207-
ec <- liftIO $ rawSystem cmd args
1207+
ec <- $withProcessTimeLog cmd args $
1208+
liftIO $ rawSystem cmd args
12081209
when (ec /= ExitSuccess)
12091210
$ liftIO $ throwM (ProblemWhileDecompressing archive)
12101211
_ -> throwM SetupInfoMissingSevenz

‎src/System/Process/Log.hs‎

Lines changed: 26 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -1,18 +1,21 @@
11
{-# LANGUAGE TemplateHaskell #-}
2+
{-# LANGUAGE OverloadedStrings #-}
23

34
-- | Separate module because TH.
45

56
module System.Process.Log
67
(logCreateProcess
7-
,logProcessRun
8+
,withProcessTimeLog
89
,showProcessArgDebug)
910
where
1011

1112
import Control.Monad.Logger
13+
import Control.Monad.IO.Class
1214
import Data.Monoid
1315
import Data.Text (Text)
1416
import qualified Data.Text as T
1517
import Language.Haskell.TH
18+
import qualified System.Clock as Clock
1619
import System.Process (CreateProcess(..), CmdSpec(..))
1720

1821
-- | Log running a process with its arguments, for debugging (-v).
@@ -30,17 +33,31 @@ logCreateProcess =
3033
in f|]
3134

3235
-- | Log running a process with its arguments, for debugging (-v).
33-
logProcessRun :: Q Exp
34-
logProcessRun =
35-
[|let f :: MonadLogger m => String -> [String] -> m ()
36-
f name args =
36+
--
37+
-- This logs one message before running the process and one message after.
38+
withProcessTimeLog :: Q Exp
39+
withProcessTimeLog =
40+
[|let f :: (MonadIO m, MonadLogger m) => String -> [String] -> m a -> m a
41+
f name args proc = do
42+
let cmdText =
43+
T.intercalate
44+
" "
45+
(T.pack name : map showProcessArgDebug args)
46+
$logDebug ("Run process: " <> cmdText)
47+
start <- liftIO $ Clock.getTime Clock.Monotonic
48+
x <- proc
49+
end <- liftIO $ Clock.getTime Clock.Monotonic
50+
let diff = Clock.diffTimeSpec start end
3751
$logDebug
38-
("Run process: " <> T.pack name <> " " <>
39-
T.intercalate
40-
" "
41-
(map showProcessArgDebug args))
52+
("Process finished in " <> timeSpecMilliSecondText diff <>
53+
": " <> cmdText)
54+
return x
4255
in f|]
4356

57+
timeSpecMilliSecondText :: Clock.TimeSpec -> Text
58+
timeSpecMilliSecondText t =
59+
(T.pack . show . (`div` 10^(6 :: Int)) . Clock.toNanoSecs) t <> " ms"
60+
4461
-- | Show a process arg including speechmarks when necessary. Just for
4562
-- debugging purposes, not functionally important.
4663
showProcessArgDebug :: String -> Text

‎src/System/Process/Read.hs‎

Lines changed: 13 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -29,7 +29,6 @@ module System.Process.Read
2929
,preProcess
3030
,readProcessNull
3131
,readInNull
32-
,logProcessRun
3332
,ReadProcessException (..)
3433
,augmentPath
3534
,augmentPathMap
@@ -290,11 +289,11 @@ sinkProcessStderrStdout :: forall m e o. (MonadIO m, MonadLogger m)
290289
-> Sink S.ByteString IO o -- ^ Sink for stdout
291290
-> m (e,o)
292291
sinkProcessStderrStdout wd menv name args sinkStderr sinkStdout = do
293-
$logProcessRun name args
294292
name' <- preProcess wd menv name
295-
liftIO $ withCheckedProcess
296-
(proc name' args) { env = envHelper menv, cwd = fmap toFilePath wd }
297-
(\ClosedStream out err -> f err out)
293+
$withProcessTimeLog name' args $
294+
liftIO $ withCheckedProcess
295+
(proc name' args) { env = envHelper menv, cwd = fmap toFilePath wd }
296+
(\ClosedStream out err -> f err out)
298297
where
299298
f :: Source IO S.ByteString -> Source IO S.ByteString -> IO (e, o)
300299
f err out = (err $$ sinkStderr) `concurrently` (out $$ sinkStdout)
@@ -308,16 +307,16 @@ sinkProcessStderrStdoutHandle :: (MonadIO m, MonadLogger m)
308307
-> Handle
309308
-> m ()
310309
sinkProcessStderrStdoutHandle wd menv name args err out = do
311-
$logProcessRun name args
312310
name' <- preProcess wd menv name
313-
liftIO $ withCheckedProcess
314-
(proc name' args)
315-
{ env = envHelper menv
316-
, cwd = fmap toFilePath wd
317-
, std_err = UseHandle err
318-
, std_out = UseHandle out
319-
}
320-
(\ClosedStream UseProvidedHandle UseProvidedHandle -> return ())
311+
$withProcessTimeLog name' args $
312+
liftIO $ withCheckedProcess
313+
(proc name' args)
314+
{ env = envHelper menv
315+
, cwd = fmap toFilePath wd
316+
, std_err = UseHandle err
317+
, std_out = UseHandle out
318+
}
319+
(\ClosedStream UseProvidedHandle UseProvidedHandle -> return ())
321320

322321
-- | Perform pre-call-process tasks. Ensure the working directory exists and find the
323322
-- executable path.

‎stack.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -156,6 +156,7 @@ library
156156
, blaze-builder
157157
, byteable
158158
, bytestring >= 0.10.4.0
159+
, clock
159160
, conduit >= 1.2.4
160161
, conduit-extra >= 1.1.7.1
161162
, containers >= 0.5.5.1

0 commit comments

Comments
 (0)