    {- 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 a. a -> IO a
    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 a. a -> IO a
    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 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 ()