GHC/SysTools/Process.hs

    {-# LANGUAGE CPP #-}
    -----------------------------------------------------------------------------
    --
    -- Misc process handling code for SysTools
    --
    -- (c) The GHC Team 2017
    --
    -----------------------------------------------------------------------------
    module GHC.SysTools.Process where

    #include "HsVersions.h"

    import GHC.Utils.Exception
    import GHC.Utils.Error
    import GHC.Driver.Session
    import GHC.Data.FastString
    import GHC.Utils.Outputable
    import GHC.Utils.Panic
    import GHC.Prelude
    import GHC.Utils.Misc
    import GHC.Types.SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )

    import Control.Concurrent
    import Data.Char

    import System.Exit
    import System.Environment
    import System.FilePath
    import System.IO
    import System.IO.Error as IO
    import System.Process

    import GHC.SysTools.FileCleanup

    -- | Enable process jobs support on Windows if it can be expected to work (e.g.
    -- @process >= 1.6.9.0@).
    enableProcessJobs :: CreateProcess -> CreateProcess
    #if defined(MIN_VERSION_process)
    #if MIN_VERSION_process(1,6,9)
    enableProcessJobs opts = opts { use_process_jobs = True }
    #else
    enableProcessJobs opts = opts
    #endif
    #else
    enableProcessJobs opts = opts
    #endif

    -- Similar to System.Process.readCreateProcessWithExitCode, but stderr is
    -- inherited from the parent process, and output to stderr is not captured.
    readCreateProcessWithExitCode'
        :: CreateProcess
        -> IO (ExitCode, String)    -- ^ stdout
    readCreateProcessWithExitCode' proc = do
        (_, Just outh, _, pid) <-
            createProcess $ enableProcessJobs $ proc{ std_out = CreatePipe }

        -- fork off a thread to start consuming the output
        output  <- hGetContents outh
        outMVar <- newEmptyMVar
        _ <- forkIO $ evaluate (length output) >> putMVar outMVar ()

        -- wait on the output
        takeMVar outMVar
        hClose outh

        -- wait on the process
        ex <- waitForProcess pid

        return (ex, output)

    replaceVar :: (String, String) -> [(String, String)] -> [(String, String)]
    replaceVar (var, value) env =
        (var, value) : filter (\(var',_) -> var /= var') env

    -- | Version of @System.Process.readProcessWithExitCode@ that takes a
    -- key-value tuple to insert into the environment.
    readProcessEnvWithExitCode
        :: String -- ^ program path
        -> [String] -- ^ program args
        -> (String, String) -- ^ addition to the environment
        -> IO (ExitCode, String, String) -- ^ (exit_code, stdout, stderr)
    readProcessEnvWithExitCode prog args env_update = do
        current_env <- getEnvironment
        readCreateProcessWithExitCode (proc prog args) {
            env = Just (replaceVar env_update current_env) } ""

    -- Don't let gcc localize version info string, #8825
    c_locale_env :: (String, String)
    c_locale_env = ("LANGUAGE", "C")

    -- If the -B<dir> option is set, add <dir> to PATH.  This works around
    -- a bug in gcc on Windows Vista where it can't find its auxiliary
    -- binaries (see bug #1110).
    getGccEnv :: [Option] -> IO (Maybe [(String,String)])
    getGccEnv opts =
      if null b_dirs
         then return Nothing
         else do env <- getEnvironment
                 return (Just (mangle_paths env))
     where
      (b_dirs, _) = partitionWith get_b_opt opts

      get_b_opt (Option ('-':'B':dir)) = Left dir
      get_b_opt other = Right other

      -- Work around #1110 on Windows only (lest we stumble into #17266).
    #if defined(mingw32_HOST_OS)
      mangle_paths = map mangle_path
      mangle_path (path,paths) | map toUpper path == "PATH"
            = (path, '\"' : head b_dirs ++ "\";" ++ paths)
      mangle_path other = other
    #else
      mangle_paths = id
    #endif

    -----------------------------------------------------------------------------
    -- Running an external program

    runSomething :: DynFlags
                 -> String          -- For -v message
                 -> String          -- Command name (possibly a full path)
                                    --      assumed already dos-ified
                 -> [Option]        -- Arguments
                                    --      runSomething will dos-ify them
                 -> IO ()

    runSomething dflags phase_name pgm args =
      runSomethingFiltered dflags id phase_name pgm args Nothing Nothing

    -- | Run a command, placing the arguments in an external response file.
    --
    -- This command is used in order to avoid overlong command line arguments on
    -- Windows. The command line arguments are first written to an external,
    -- temporary response file, and then passed to the linker via @filepath.
    -- response files for passing them in. See:
    --
    --     https://gcc.gnu.org/wiki/Response_Files
    --     https://gitlab.haskell.org/ghc/ghc/issues/10777
    runSomethingResponseFile
      :: DynFlags -> (String->String) -> String -> String -> [Option]
      -> Maybe [(String,String)] -> IO ()

    runSomethingResponseFile dflags filter_fn phase_name pgm args mb_env =
        runSomethingWith dflags phase_name pgm args $ \real_args -> do
            fp <- getResponseFile real_args
            let args = ['@':fp]
            r <- builderMainLoop dflags filter_fn pgm args Nothing mb_env
            return (r,())
      where
        getResponseFile args = do
          fp <- newTempName dflags TFL_CurrentModule "rsp"
          withFile fp WriteMode $ \h -> do
    #if defined(mingw32_HOST_OS)
              hSetEncoding h latin1
    #else
              hSetEncoding h utf8
    #endif
              hPutStr h $ unlines $ map escape args
          return fp

        -- Note: Response files have backslash-escaping, double quoting, and are
        -- whitespace separated (some implementations use newline, others any
        -- whitespace character). Therefore, escape any backslashes, newlines, and
        -- double quotes in the argument, and surround the content with double
        -- quotes.
        --
        -- Another possibility that could be considered would be to convert
        -- backslashes in the argument to forward slashes. This would generally do
        -- the right thing, since backslashes in general only appear in arguments
        -- as part of file paths on Windows, and the forward slash is accepted for
        -- those. However, escaping is more reliable, in case somehow a backslash
        -- appears in a non-file.
        escape x = concat
            [ "\""
            , concatMap
                (\c ->
                    case c of
                        '\\' -> "\\\\"
                        '\n' -> "\\n"
                        '\"' -> "\\\""
                        _    -> [c])
                x
            , "\""
            ]

    runSomethingFiltered
      :: DynFlags -> (String->String) -> String -> String -> [Option]
      -> Maybe FilePath -> Maybe [(String,String)] -> IO ()

    runSomethingFiltered dflags filter_fn phase_name pgm args mb_cwd mb_env = do
        runSomethingWith dflags phase_name pgm args $ \real_args -> do
            r <- builderMainLoop dflags filter_fn pgm real_args mb_cwd mb_env
            return (r,())

    runSomethingWith
      :: DynFlags -> String -> String -> [Option]
      -> ([String] -> IO (ExitCode, a))
      -> IO a

    runSomethingWith dflags phase_name pgm args io = do
      let real_args = filter notNull (map showOpt args)
          cmdLine = showCommandForUser pgm real_args
      traceCmd dflags phase_name cmdLine $ handleProc pgm phase_name $ io real_args

    handleProc :: String -> String -> IO (ExitCode, r) -> IO r
    handleProc pgm phase_name proc = do
        (rc, r) <- proc `catchIO` handler
        case rc of
          ExitSuccess{} -> return r
          ExitFailure n -> throwGhcExceptionIO (
                ProgramError ("`" ++ takeFileName pgm ++ "'" ++
                              " failed in phase `" ++ phase_name ++ "'." ++
                              " (Exit code: " ++ show n ++ ")"))
      where
        handler err =
           if IO.isDoesNotExistError err
              then does_not_exist
              else throwGhcExceptionIO (ProgramError $ show err)

        does_not_exist = throwGhcExceptionIO (InstallationError ("could not execute: " ++ pgm))

    builderMainLoop :: DynFlags -> (String -> String) -> FilePath
                    -> [String] -> Maybe FilePath -> Maybe [(String, String)]
                    -> IO ExitCode
    builderMainLoop dflags filter_fn pgm real_args mb_cwd mb_env = do
      chan <- newChan

      -- We use a mask here rather than a bracket because we want
      -- to distinguish between cleaning up with and without an
      -- exception. This is to avoid calling terminateProcess
      -- unless an exception was raised.
      let safely inner = mask $ \restore -> do
            -- acquire
            -- On Windows due to how exec is emulated the old process will exit and
            -- a new process will be created. This means waiting for termination of
            -- the parent process will get you in a race condition as the child may
            -- not have finished yet.  This caused #16450.  To fix this use a
            -- process job to track all child processes and wait for each one to
            -- finish.
            let procdata =
                  enableProcessJobs
                  $ (proc pgm real_args) { cwd = mb_cwd
                                         , env = mb_env
                                         , std_in  = CreatePipe
                                         , std_out = CreatePipe
                                         , std_err = CreatePipe
                                         }
            (Just hStdIn, Just hStdOut, Just hStdErr, hProcess) <- restore $
              createProcess_ "builderMainLoop" procdata
            let cleanup_handles = do
                  hClose hStdIn
                  hClose hStdOut
                  hClose hStdErr
            r <- try $ restore $ do
              hSetBuffering hStdOut LineBuffering
              hSetBuffering hStdErr LineBuffering
              let make_reader_proc h = forkIO $ readerProc chan h filter_fn
              bracketOnError (make_reader_proc hStdOut) killThread $ \_ ->
                bracketOnError (make_reader_proc hStdErr) killThread $ \_ ->
                inner hProcess
            case r of
              -- onException
              Left (SomeException e) -> do
                terminateProcess hProcess
                cleanup_handles
                throw e
              -- cleanup when there was no exception
              Right s -> do
                cleanup_handles
                return s
      safely $ \h -> do
        -- we don't want to finish until 2 streams have been complete
        -- (stdout and stderr)
        log_loop chan (2 :: Integer)
        -- after that, we wait for the process to finish and return the exit code.
        waitForProcess h
      where
        -- t starts at the number of streams we're listening to (2) decrements each
        -- time a reader process sends EOF. We are safe from looping forever if a
        -- reader thread dies, because they send EOF in a finally handler.
        log_loop _ 0 = return ()
        log_loop chan t = do
          msg <- readChan chan
          case msg of
            BuildMsg msg -> do
              putLogMsg dflags NoReason SevInfo noSrcSpan
                  $ withPprStyle defaultUserStyle msg
              log_loop chan t
            BuildError loc msg -> do
              putLogMsg dflags NoReason SevError (mkSrcSpan loc loc)
                  $ withPprStyle defaultUserStyle msg
              log_loop chan t
            EOF ->
              log_loop chan  (t-1)

    readerProc :: Chan BuildMessage -> Handle -> (String -> String) -> IO ()
    readerProc chan hdl filter_fn =
        (do str <- hGetContents hdl
            loop (linesPlatform (filter_fn str)) Nothing)
        `finally`
           writeChan chan EOF
            -- ToDo: check errors more carefully
            -- ToDo: in the future, the filter should be implemented as
            -- a stream transformer.
        where
            loop []     Nothing    = return ()
            loop []     (Just err) = writeChan chan err
            loop (l:ls) in_err     =
                    case in_err of
                      Just err@(BuildError srcLoc msg)
                        | leading_whitespace l -> do
                            loop ls (Just (BuildError srcLoc (msg $$ text l)))
                        | otherwise -> do
                            writeChan chan err
                            checkError l ls
                      Nothing -> do
                            checkError l ls
                      _ -> panic "readerProc/loop"

            checkError l ls
               = case parseError l of
                    Nothing -> do
                        writeChan chan (BuildMsg (text l))
                        loop ls Nothing
                    Just (file, lineNum, colNum, msg) -> do
                        let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum
                        loop ls (Just (BuildError srcLoc (text msg)))

            leading_whitespace []    = False
            leading_whitespace (x:_) = isSpace x

    parseError :: String -> Maybe (String, Int, Int, String)
    parseError s0 = case breakColon s0 of
                    Just (filename, s1) ->
                        case breakIntColon s1 of
                        Just (lineNum, s2) ->
                            case breakIntColon s2 of
                            Just (columnNum, s3) ->
                                Just (filename, lineNum, columnNum, s3)
                            Nothing ->
                                Just (filename, lineNum, 0, s2)
                        Nothing -> Nothing
                    Nothing -> Nothing

    -- | Break a line of an error message into a filename and the rest of the line,
    -- taking care to ignore colons in Windows drive letters (as noted in #17786).
    -- For instance,
    --
    -- * @"hi.c: ABCD"@ is mapped to @Just ("hi.c", \"ABCD\")@
    -- * @"C:\\hi.c: ABCD"@ is mapped to @Just ("C:\\hi.c", \"ABCD\")@
    breakColon :: String -> Maybe (String, String)
    breakColon = go []
      where
        -- Don't break on Windows drive letters (e.g. @C:\@ or @C:/@)
        go accum  (':':'\\':rest) = go ('\\':':':accum) rest
        go accum  (':':'/':rest)  = go ('/':':':accum) rest
        go accum  (':':rest)      = Just (reverse accum, rest)
        go accum  (c:rest)        = go (c:accum) rest
        go _accum []              = Nothing

    breakIntColon :: String -> Maybe (Int, String)
    breakIntColon xs = case break (':' ==) xs of
                           (ys, _:zs)
                            | not (null ys) && all isAscii ys && all isDigit ys ->
                               Just (read ys, zs)
                           _ -> Nothing

    data BuildMessage
      = BuildMsg   !SDoc
      | BuildError !SrcLoc !SDoc
      | EOF

    -- Divvy up text stream into lines, taking platform dependent
    -- line termination into account.
    linesPlatform :: String -> [String]
    #if !defined(mingw32_HOST_OS)
    linesPlatform ls = lines ls
    #else
    linesPlatform "" = []
    linesPlatform xs =
      case lineBreak xs of
        (as,xs1) -> as : linesPlatform xs1
      where
       lineBreak "" = ("","")
       lineBreak ('\r':'\n':xs) = ([],xs)
       lineBreak ('\n':xs) = ([],xs)
       lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs)

    #endif