{- 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
	(String
t, ExitCode
c) <- CreateProcess -> Maybe String -> IO (String, ExitCode)
processTranscript'' CreateProcess
cp Maybe String
input
	(String, Bool) -> IO (String, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
t, ExitCode
c ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
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. -}
	(Fd
readf, Fd
writef) <- IO (Fd, Fd)
System.Posix.IO.createPipe
	Fd -> FdOption -> Bool -> IO ()
System.Posix.IO.setFdOption Fd
readf FdOption
System.Posix.IO.CloseOnExec Bool
True
	Fd -> FdOption -> Bool -> IO ()
System.Posix.IO.setFdOption Fd
writef FdOption
System.Posix.IO.CloseOnExec Bool
True
	Handle
readh <- Fd -> IO Handle
System.Posix.IO.fdToHandle Fd
readf
	Handle
writeh <- Fd -> IO Handle
System.Posix.IO.fdToHandle Fd
writef
	p :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
p@(Maybe Handle
_, Maybe Handle
_, Maybe Handle
_, ProcessHandle
pid) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (CreateProcess
 -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
-> CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a b. (a -> b) -> a -> b
$ CreateProcess
cp
		{ std_in :: StdStream
std_in = if Maybe String -> Bool
forall a. Maybe a -> Bool
isJust Maybe String
input then StdStream
CreatePipe else StdStream
Inherit
		, std_out :: StdStream
std_out = Handle -> StdStream
UseHandle Handle
writeh
		, std_err :: StdStream
std_err = Handle -> StdStream
UseHandle Handle
writeh
		}
	Handle -> IO ()
hClose Handle
writeh

	Async String
get <- Handle -> IO (Async String)
asyncreader Handle
readh
	Maybe String
-> (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO ()
writeinput Maybe String
input (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
p
	String
transcript <- Async String -> IO String
forall a. Async a -> IO a
wait Async String
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
	ExitCode
code <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
pid
	(String, ExitCode) -> IO (String, ExitCode)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
transcript, ExitCode
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 (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 (m :: * -> *) a. Monad m => a -> m a
return ()