{- 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 ()