summaryrefslogtreecommitdiff
path: root/src/Utility/Process/Transcript.hs
blob: 68fb2223ebad83f4601d4f8454a18b4b1b050b93 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
{- Process transcript
 -
 - Copyright 2012-2018 Joey Hess <id@joeyh.name>
 -
 - License: BSD-2-clause
 -}

{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}

module Utility.Process.Transcript where

import Utility.Process
import Utility.Misc

import System.IO
import System.Exit
import Control.Concurrent.Async
import Control.Monad
#ifndef mingw32_HOST_OS
import qualified System.Posix.IO
#else
import Control.Applicative
#endif
import Data.Maybe
import Prelude

-- | Runs a process and returns a transcript combining its stdout and
-- stderr, and whether it succeeded or failed.
processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool)
processTranscript cmd opts = processTranscript' (proc cmd opts)

-- | Also feeds the process some input.
processTranscript' :: CreateProcess -> Maybe String -> IO (String, Bool)
processTranscript' cp input = do
	(t, c) <- processTranscript'' cp input
	return (t, c == ExitSuccess)

processTranscript'' :: CreateProcess -> Maybe String -> IO (String, ExitCode)
processTranscript'' cp input = do
#ifndef mingw32_HOST_OS
{- This implementation interleves stdout and stderr in exactly the order
 - the process writes them. -}
	(readf, writef) <- System.Posix.IO.createPipe
	System.Posix.IO.setFdOption readf System.Posix.IO.CloseOnExec True
	System.Posix.IO.setFdOption writef System.Posix.IO.CloseOnExec True
	readh <- System.Posix.IO.fdToHandle readf
	writeh <- System.Posix.IO.fdToHandle writef
	p@(_, _, _, pid) <- createProcess $ cp
		{ std_in = if isJust input then CreatePipe else Inherit
		, std_out = UseHandle writeh
		, std_err = UseHandle writeh
		}
	hClose writeh

	get <- asyncreader readh
	writeinput input p
	transcript <- wait get
#else
{- This implementation for Windows puts stderr after stdout. -}
	p@(_, _, _, pid) <- createProcess $ cp
		{ std_in = if isJust input then CreatePipe else Inherit
		, std_out = CreatePipe
		, std_err = CreatePipe
		}

	getout <- asyncreader (stdoutHandle p)
	geterr <- asyncreader (stderrHandle p)
	writeinput input p
	transcript <- (++) <$> wait getout <*> wait geterr
#endif
	code <- waitForProcess pid
	return (transcript, code)
  where
	asyncreader = async . hGetContentsStrict

	writeinput (Just s) p = do
		let inh = stdinHandle p
		unless (null s) $ do
			hPutStr inh s
			hFlush inh
		hClose inh
	writeinput Nothing _ = return ()