{- 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 :: String -> [String] -> Maybe String -> IO (String, Bool)
processTranscript String
cmd [String]
opts = CreateProcess -> Maybe String -> IO (String, Bool)
processTranscript' (String -> [String] -> CreateProcess
proc String
cmd [String]
opts)

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

processTranscript'' :: CreateProcess -> Maybe String -> IO (String, ExitCode)
processTranscript'' :: CreateProcess -> Maybe String -> IO (String, ExitCode)
processTranscript'' CreateProcess
cp Maybe String
input = do
#ifndef mingw32_HOST_OS
{- This implementation interleves stdout and stderr in exactly the order
 - the process writes them. -}
	(readf, writef) <- IO (Fd, Fd)
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 :: Handle -> IO (Async String)
asyncreader = IO String -> IO (Async String)
forall a. IO a -> IO (Async a)
async (IO String -> IO (Async String))
-> (Handle -> IO String) -> Handle -> IO (Async String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> IO String
hGetContentsStrict

	writeinput :: Maybe String
-> (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO ()
writeinput (Just String
s) (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
p = do
		let inh :: Handle
inh = HandleExtractor
stdinHandle (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
p
		Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
			Handle -> String -> IO ()
hPutStr Handle
inh String
s
			Handle -> IO ()
hFlush Handle
inh
		Handle -> IO ()
hClose Handle
inh
	writeinput Maybe String
Nothing (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()