Skip to content

Commit 7bcbe7e

Browse files
mgsloanmgsloan
committed
Some process utility additions
1 parent 9f6f9ed commit 7bcbe7e

5 files changed

Lines changed: 74 additions & 39 deletions

File tree

‎src/Stack/Build/Execute.hs‎

Lines changed: 4 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -50,7 +50,6 @@ import Data.Maybe.Extra (forMaybeM)
5050
import Data.Monoid ((<>))
5151
import Data.Set (Set)
5252
import qualified Data.Set as Set
53-
import qualified Data.Streaming.Process as Process
5453
import Data.Streaming.Process hiding (callProcess, env)
5554
import Data.Text (Text)
5655
import qualified Data.Text as T
@@ -1252,16 +1251,12 @@ singleTest runInBase topts testsToRun ac ee task installedMap = do
12521251
case mlogFile of
12531252
Nothing -> Inherit
12541253
Just (_, h) -> UseHandle h
1255-
cp = (proc (toFilePath exePath) args)
1256-
{ cwd = Just $ toFilePath pkgDir
1257-
, Process.env = envHelper menv
1258-
, std_in = CreatePipe
1259-
, std_out = output
1260-
, std_err = output
1261-
}
12621254

12631255
-- Use createProcess_ to avoid the log file being closed afterwards
1264-
(Just inH, Nothing, Nothing, ph) <- liftIO $ createProcess_ "singleBuild.runTests" cp
1256+
(Just inH, Nothing, Nothing, ph) <- createProcess'
1257+
stestName
1258+
(\cp -> cp { std_in = CreatePipe, std_out = output, std_err = output })
1259+
(Cmd (Just pkgDir) (toFilePath exePath) menv args)
12651260
when isTestTypeLib $ do
12661261
logPath <- buildLogPath package (Just stestName)
12671262
ensureDir (parent logPath)

‎src/Stack/Setup.hs‎

Lines changed: 1 addition & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -38,7 +38,6 @@ import qualified Data.ByteString.Char8 as S8
3838
import qualified Data.ByteString.Lazy as LBS
3939
import Data.Char (isSpace)
4040
import Data.Conduit (Conduit, ($$), (=$), await, yield, awaitForever)
41-
import qualified Data.Conduit.Binary as CB
4241
import Data.Conduit.Lift (evalStateC)
4342
import qualified Data.Conduit.List as CL
4443
import Data.Either
@@ -64,7 +63,6 @@ import Distribution.System (OS, Arch (..), Platform (..))
6463
import qualified Distribution.System as Cabal
6564
import Distribution.Text (simpleParse)
6665
import Lens.Micro (set)
67-
import Language.Haskell.TH as TH
6866
import Network.HTTP.Client.Conduit
6967
import Network.HTTP.Download.Verified
7068
import Path
@@ -997,17 +995,9 @@ bootGhcjs stackYaml destDir = do
997995
"This version is specified by the stack.yaml file included in the ghcjs tarball.\n"
998996
_ -> return ()
999997
$logSticky "Booting GHCJS (this will take a long time) ..."
1000-
runAndLog Nothing "ghcjs-boot" menv' ["--clean"]
998+
logProcessStderrStdout Nothing "ghcjs-boot" menv' ["--clean"]
1001999
$logStickyDone "GHCJS booted."
10021000

1003-
-- TODO: something similar is done in Stack.Build.Execute. Create some utilities
1004-
-- for this?
1005-
runAndLog :: (MonadIO m, MonadBaseControl IO m, MonadLogger m)
1006-
=> Maybe (Path Abs Dir) -> String -> EnvOverride -> [String] -> m ()
1007-
runAndLog mdir name menv args = liftBaseWith $ \restore -> do
1008-
let logLines = CB.lines =$ CL.mapM_ (void . restore . monadLoggerLog $(TH.location >>= liftLoc) "" LevelInfo . toLogStr)
1009-
void $ restore $ sinkProcessStderrStdout mdir menv name args logLines logLines
1010-
10111001
loadGhcjsEnvConfig :: (MonadIO m, HasHttpManager r, MonadReader r m, HasTerminal r, HasReExec r, HasLogLevel r)
10121002
=> Path Abs File -> Path b t -> m EnvConfig
10131003
loadGhcjsEnvConfig stackYaml binPath = runInnerStackLoggingT $ do

‎src/System/Process/Log.hs‎

Lines changed: 17 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -3,7 +3,8 @@
33
-- | Separate module because TH.
44

55
module System.Process.Log
6-
(logProcessRun
6+
(logCreateProcess
7+
,logProcessRun
78
,showProcessArgDebug)
89
where
910

@@ -12,6 +13,21 @@ import Data.Monoid
1213
import Data.Text (Text)
1314
import qualified Data.Text as T
1415
import Language.Haskell.TH
16+
import System.Process (CreateProcess(..), CmdSpec(..))
17+
18+
-- | Log running a process with its arguments, for debugging (-v).
19+
logCreateProcess :: Q Exp
20+
logCreateProcess =
21+
[|let f :: MonadLogger m => CreateProcess -> m ()
22+
f (CreateProcess { cmdspec = ShellCommand shellCmd }) =
23+
$logDebug ("Creating shell process: " <> T.pack shellCmd)
24+
f (CreateProcess { cmdspec = RawCommand name args }) =
25+
$logDebug
26+
("Creating process: " <> T.pack name <> " " <>
27+
T.intercalate
28+
" "
29+
(map showProcessArgDebug args))
30+
in f|]
1531

1632
-- | Log running a process with its arguments, for debugging (-v).
1733
logProcessRun :: Q Exp

‎src/System/Process/Read.hs‎

Lines changed: 19 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -15,6 +15,7 @@ module System.Process.Read
1515
,sinkProcessStdout
1616
,sinkProcessStderrStdout
1717
,sinkProcessStderrStdoutHandle
18+
,logProcessStderrStdout
1819
,readProcess
1920
,EnvOverride(..)
2021
,unEnvOverride
@@ -38,15 +39,16 @@ module System.Process.Read
3839
import Control.Arrow ((***), first)
3940
import Control.Concurrent.Async (concurrently)
4041
import Control.Exception hiding (try, catch)
41-
import Control.Monad (join, liftM, unless)
42+
import Control.Monad (join, liftM, unless, void)
4243
import Control.Monad.Catch (MonadThrow, MonadCatch, throwM, try, catch)
4344
import Control.Monad.IO.Class (MonadIO, liftIO)
44-
import Control.Monad.Logger (MonadLogger, logError)
45-
import Control.Monad.Trans.Control (MonadBaseControl)
45+
import Control.Monad.Logger
46+
import Control.Monad.Trans.Control (MonadBaseControl, liftBaseWith)
4647
import qualified Data.ByteString as S
47-
import qualified Data.ByteString.Lazy as L
4848
import Data.ByteString.Builder
49+
import qualified Data.ByteString.Lazy as L
4950
import Data.Conduit
51+
import qualified Data.Conduit.Binary as CB
5052
import qualified Data.Conduit.List as CL
5153
import Data.Conduit.Process hiding (callProcess)
5254
import Data.Foldable (forM_)
@@ -58,10 +60,11 @@ import Data.Monoid
5860
import Data.Text (Text)
5961
import qualified Data.Text as T
6062
import Data.Text.Encoding.Error (lenientDecode)
61-
import qualified Data.Text.Lazy.Encoding as LT
6263
import qualified Data.Text.Lazy as LT
64+
import qualified Data.Text.Lazy.Encoding as LT
6365
import Data.Typeable (Typeable)
6466
import Distribution.System (OS (Windows), Platform (Platform))
67+
import Language.Haskell.TH as TH (location)
6568
import Path
6669
import Path.IO hiding (findExecutable)
6770
import Prelude -- Fix AMP warning
@@ -256,6 +259,17 @@ sinkProcessStdout wd menv name args sinkStdout = do
256259
(toLazyByteString stderrBuilder))
257260
return sinkRet
258261

262+
logProcessStderrStdout
263+
:: (MonadIO m, MonadBaseControl IO m, MonadLogger m)
264+
=> Maybe (Path Abs Dir)
265+
-> String
266+
-> EnvOverride
267+
-> [String]
268+
-> m ()
269+
logProcessStderrStdout mdir name menv args = liftBaseWith $ \restore -> do
270+
let logLines = CB.lines =$ CL.mapM_ (void . restore . monadLoggerLog $(TH.location >>= liftLoc) "" LevelInfo . toLogStr)
271+
void $ restore $ sinkProcessStderrStdout mdir menv name args logLines logLines
272+
259273
-- | Consume the stdout and stderr of a process feeding strict 'S.ByteString's to the consumers.
260274
sinkProcessStderrStdout :: forall m e o. (MonadIO m, MonadLogger m)
261275
=> Maybe (Path Abs Dir) -- ^ Optional directory to run in

‎src/System/Process/Run.hs‎

Lines changed: 33 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -13,25 +13,28 @@ module System.Process.Run
1313
,runCmd'
1414
,callProcess
1515
,callProcess'
16+
,createProcess'
1617
,ProcessExitedUnsuccessfully
1718
,Cmd(..)
1819
)
1920
where
2021

2122
import Control.Exception.Lifted
22-
import Control.Monad.Trans.Control (MonadBaseControl)
2323
import Control.Monad.IO.Class (MonadIO, liftIO)
2424
import Control.Monad.Logger (MonadLogger, logError)
25+
import Control.Monad.Trans.Control (MonadBaseControl)
2526
import Data.Conduit.Process hiding (callProcess)
2627
import Data.Foldable (forM_)
2728
import Data.Text (Text)
2829
import qualified Data.Text as T
30+
import Path (Dir, Abs, Path)
2931
import Path (toFilePath)
3032
import Prelude -- Fix AMP warning
3133
import System.Exit (exitWith, ExitCode (..))
34+
import System.IO
3235
import qualified System.Process
36+
import System.Process.Log
3337
import System.Process.Read
34-
import Path (Dir, Abs, Path)
3538

3639
-- | Cmd holds common infos needed to running a process in most cases
3740
data Cmd = Cmd
@@ -92,15 +95,32 @@ callProcess = callProcess' id
9295
-- Inherits stdout and stderr.
9396
callProcess' :: (MonadIO m, MonadLogger m)
9497
=> (CreateProcess -> CreateProcess) -> Cmd -> m ()
95-
callProcess' modCP (Cmd wd cmd0 menv args) = do
98+
callProcess' modCP cmd = do
99+
c <- modCP <$> cmdToCreateProcess cmd
100+
$logCreateProcess c
101+
liftIO $ do
102+
(_, _, _, p) <- System.Process.createProcess c
103+
exit_code <- waitForProcess p
104+
case exit_code of
105+
ExitSuccess -> return ()
106+
ExitFailure _ -> throwIO (ProcessExitedUnsuccessfully c exit_code)
107+
108+
-- | Like 'System.Process.Internal.createProcess_', but taking a 'Cmd'.
109+
-- Note that the 'Handle's provided by 'UseHandle' are not closed
110+
-- automatically.
111+
createProcess' :: (MonadIO m, MonadLogger m)
112+
=> String
113+
-> (CreateProcess -> CreateProcess)
114+
-> Cmd
115+
-> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
116+
createProcess' tag modCP cmd = do
117+
c <- modCP <$> cmdToCreateProcess cmd
118+
$logCreateProcess c
119+
liftIO $ System.Process.createProcess_ tag c
120+
121+
cmdToCreateProcess :: MonadIO m => Cmd -> m CreateProcess
122+
cmdToCreateProcess (Cmd wd cmd0 menv args) = do
96123
cmd <- preProcess wd menv cmd0
97-
let c = modCP $ (proc cmd args) { delegate_ctlc = True
98-
, cwd = fmap toFilePath wd
99-
, env = envHelper menv }
100-
action (_, _, _, p) = do
101-
exit_code <- waitForProcess p
102-
case exit_code of
103-
ExitSuccess -> return ()
104-
ExitFailure _ -> throwIO (ProcessExitedUnsuccessfully c exit_code)
105-
$logProcessRun cmd args
106-
liftIO (System.Process.createProcess c >>= action)
124+
return $ (proc cmd args) { delegate_ctlc = True
125+
, cwd = fmap toFilePath wd
126+
, env = envHelper menv }

0 commit comments

Comments
 (0)