diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index a84822ec39..8545908f9d 100644 --- a/src/Stack/Build/Execute.hs +++ b/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. diff --git a/src/Stack/Exec.hs b/src/Stack/Exec.hs index 437e1eb2c5..a91f809f72 100644 --- a/src/Stack/Exec.hs +++ b/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 diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index d31766e41d..4f2a4949b3 100644 --- a/src/Stack/Setup.hs +++ b/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 diff --git a/src/System/Process/Log.hs b/src/System/Process/Log.hs index 0b40a83e14..46c85025b9 100644 --- a/src/System/Process/Log.hs +++ b/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 diff --git a/src/System/Process/Read.hs b/src/System/Process/Read.hs index 89c5b89973..c60167951b 100644 --- a/src/System/Process/Read.hs +++ b/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. diff --git a/stack-7.8.yaml b/stack-7.8.yaml index 7d2eabffa4..c22f9d7dfb 100644 --- a/stack-7.8.yaml +++ b/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 \ No newline at end of file + old-locale: false diff --git a/stack.cabal b/stack.cabal index 30baba933f..89b284a8d5 100644 --- a/stack.cabal +++ b/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