From 113b10cdc96d45b049bb0c7128c33bdb117fd774 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Wed, 15 Feb 2017 16:00:59 -0400
Subject: [PATCH] simpler more generic processTranscript'

This allows using functions that generate CreateProcess and passing the
result to processTranscript', which is more flexible, and also simpler
than the old interface.

This commit was sponsored by Riku Voipio.
---
 Assistant/WebApp/Configurators/Ssh.hs |  2 +-
 Build/EvilLinker.hs                   |  2 +-
 Utility/Process.hs                    | 28 +++++++++++++--------------
 3 files changed, 15 insertions(+), 17 deletions(-)

diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs
index 66f45d6ec9..9b137c3bc9 100644
--- a/Assistant/WebApp/Configurators/Ssh.hs
+++ b/Assistant/WebApp/Configurators/Ssh.hs
@@ -379,7 +379,7 @@ sshAuthTranscript sshinput opts input = case inputAuthMethod sshinput of
 	geti f = maybe "" T.unpack (f sshinput)
 
 	go extraopts environ = processTranscript' 
-		(askPass environ) "ssh" (extraopts ++ opts)
+		(askPass environ (proc "ssh" (extraopts ++ opts)))
 		-- Always provide stdin, even when empty.
 		(Just (fromMaybe "" input))
 
diff --git a/Build/EvilLinker.hs b/Build/EvilLinker.hs
index 94e399dfe1..47111d4763 100644
--- a/Build/EvilLinker.hs
+++ b/Build/EvilLinker.hs
@@ -127,7 +127,7 @@ getOutput c ps environ = do
 	putStrLn $ unwords [c, show ps]
 	systemenviron <- getEnvironment
 	let environ' = fromMaybe [] environ ++ systemenviron
-	out@(_, ok) <- processTranscript' (\p -> p { Utility.Process.env = Just environ' }) c ps Nothing
+	out@(_, ok) <- processTranscript' ((proc c ps) { Utility.Process.env = Just environ' }) Nothing
 	putStrLn $ unwords [c, "finished", show ok]
 	return out
 
diff --git a/Utility/Process.hs b/Utility/Process.hs
index ed02f49e51..6d981cb51a 100644
--- a/Utility/Process.hs
+++ b/Utility/Process.hs
@@ -174,22 +174,21 @@ createBackgroundProcess p a = a =<< createProcess p
 -- returns a transcript combining its stdout and stderr, and
 -- whether it succeeded or failed.
 processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool)
-processTranscript = processTranscript' id
+processTranscript cmd opts = processTranscript' (proc cmd opts)
 
-processTranscript' :: (CreateProcess -> CreateProcess) -> String -> [String] -> Maybe String -> IO (String, Bool)
-processTranscript' modproc cmd opts input = do
+processTranscript' :: CreateProcess -> Maybe String -> IO (String, Bool)
+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
 	readh <- System.Posix.IO.fdToHandle readf
 	writeh <- System.Posix.IO.fdToHandle writef
-	p@(_, _, _, pid) <- createProcess $ modproc $
-		(proc cmd opts)
-			{ std_in = if isJust input then CreatePipe else Inherit
-			, std_out = UseHandle writeh
-			, std_err = UseHandle writeh
-			}
+	p@(_, _, _, pid) <- createProcess $ cp
+		{ std_in = if isJust input then CreatePipe else Inherit
+		, std_out = UseHandle writeh
+		, std_err = UseHandle writeh
+		}
 	hClose writeh
 
 	get <- mkreader readh
@@ -200,12 +199,11 @@ processTranscript' modproc cmd opts input = do
 	return (transcript, ok)
 #else
 {- This implementation for Windows puts stderr after stdout. -}
-	p@(_, _, _, pid) <- createProcess $ modproc $
-		(proc cmd opts)
-			{ std_in = if isJust input then CreatePipe else Inherit
-			, std_out = CreatePipe
-			, std_err = CreatePipe
-			}
+	p@(_, _, _, pid) <- createProcess $ cp
+		{ std_in = if isJust input then CreatePipe else Inherit
+		, std_out = CreatePipe
+		, std_err = CreatePipe
+		}
 
 	getout <- mkreader (stdoutHandle p)
 	geterr <- mkreader (stderrHandle p)