-- cabal-helper: Simple interface to Cabal's configuration state
-- Copyright (C) 2018  Daniel Gröber <cabal-helper@dxld.at>
--
-- SPDX-License-Identifier: Apache-2.0
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
--
--     http://www.apache.org/licenses/LICENSE-2.0

{-|
Module      : CabalHelper.Compiletime.Process
Description : System process utilities
License     : Apache-2.0
-}

module CabalHelper.Compiletime.Process
    ( module CabalHelper.Compiletime.Process
    , module System.Process
    ) where

import Data.Char
import Data.List
import Data.Maybe
import qualified Data.Map.Strict as Map
import GHC.IO.Exception (IOErrorType(OtherError))
import System.IO
import System.IO.Error
import System.Environment
import System.Exit
import System.Process

import CabalHelper.Compiletime.Types
import CabalHelper.Compiletime.Log

readProcess' :: Verbose => FilePath -> [String] -> String -> IO String
readProcess' :: FilePath -> [FilePath] -> FilePath -> IO FilePath
readProcess' exe :: FilePath
exe args :: [FilePath]
args inp :: FilePath
inp =
  Verbose =>
Maybe FilePath
-> [(FilePath, EnvOverride)]
-> FilePath
-> [FilePath]
-> FilePath
-> IO FilePath
Maybe FilePath
-> [(FilePath, EnvOverride)]
-> FilePath
-> [FilePath]
-> FilePath
-> IO FilePath
readProcessStderr Maybe FilePath
forall a. Maybe a
Nothing [] FilePath
exe [FilePath]
args FilePath
inp

readProcessStderr :: Verbose => Maybe FilePath -> [(String, EnvOverride)]
                  -> FilePath -> [String] -> String -> IO String
readProcessStderr :: Maybe FilePath
-> [(FilePath, EnvOverride)]
-> FilePath
-> [FilePath]
-> FilePath
-> IO FilePath
readProcessStderr mcwd :: Maybe FilePath
mcwd env :: [(FilePath, EnvOverride)]
env exe :: FilePath
exe args :: [FilePath]
args inp :: FilePath
inp = do
  Verbose =>
Maybe FilePath
-> [(FilePath, EnvOverride)] -> FilePath -> [FilePath] -> IO ()
Maybe FilePath
-> [(FilePath, EnvOverride)] -> FilePath -> [FilePath] -> IO ()
logProcessCall Maybe FilePath
mcwd [(FilePath, EnvOverride)]
env FilePath
exe [FilePath]
args
  [(FilePath, FilePath)]
env' <- [(FilePath, EnvOverride)]
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
execEnvOverrides [(FilePath, EnvOverride)]
env ([(FilePath, FilePath)] -> [(FilePath, FilePath)])
-> IO [(FilePath, FilePath)] -> IO [(FilePath, FilePath)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [(FilePath, FilePath)]
getEnvironment
  FilePath
outp <- CreateProcess -> FilePath -> IO FilePath
readCreateProcess (FilePath -> [FilePath] -> CreateProcess
proc FilePath
exe [FilePath]
args)
    { cwd :: Maybe FilePath
cwd = Maybe FilePath
mcwd
    , env :: Maybe [(FilePath, FilePath)]
env = if [(FilePath, EnvOverride)]
env [(FilePath, EnvOverride)] -> [(FilePath, EnvOverride)] -> Bool
forall a. Eq a => a -> a -> Bool
== [] then Maybe [(FilePath, FilePath)]
forall a. Maybe a
Nothing else [(FilePath, FilePath)] -> Maybe [(FilePath, FilePath)]
forall a. a -> Maybe a
Just [(FilePath, FilePath)]
env'
    } FilePath
inp
  FilePath -> IO ()
forall (m :: * -> *). (MonadIO m, Verbose) => FilePath -> m ()
vLog (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unlines ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map ("=> "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++) ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath]
lines FilePath
outp
  FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
outp

-- | Essentially 'System.Process.callProcess' but returns exit code, has
-- additional options and logging to stderr when verbosity is enabled.
callProcessStderr'
    :: Verbose => Maybe FilePath -> [(String, EnvOverride)]
    -> FilePath -> [String] -> IO ExitCode
callProcessStderr' :: Maybe FilePath
-> [(FilePath, EnvOverride)]
-> FilePath
-> [FilePath]
-> IO ExitCode
callProcessStderr' mcwd :: Maybe FilePath
mcwd env :: [(FilePath, EnvOverride)]
env exe :: FilePath
exe args :: [FilePath]
args = do
  Verbose =>
Maybe FilePath
-> [(FilePath, EnvOverride)] -> FilePath -> [FilePath] -> IO ()
Maybe FilePath
-> [(FilePath, EnvOverride)] -> FilePath -> [FilePath] -> IO ()
logProcessCall Maybe FilePath
mcwd [(FilePath, EnvOverride)]
env FilePath
exe [FilePath]
args
  [(FilePath, FilePath)]
env' <- [(FilePath, EnvOverride)]
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
execEnvOverrides [(FilePath, EnvOverride)]
env ([(FilePath, FilePath)] -> [(FilePath, FilePath)])
-> IO [(FilePath, FilePath)] -> IO [(FilePath, FilePath)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [(FilePath, FilePath)]
getEnvironment
  (_, _, _, h :: ProcessHandle
h) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (FilePath -> [FilePath] -> CreateProcess
proc FilePath
exe [FilePath]
args)
    { std_out :: StdStream
std_out = Handle -> StdStream
UseHandle Handle
stderr
    , env :: Maybe [(FilePath, FilePath)]
env = if [(FilePath, EnvOverride)]
env [(FilePath, EnvOverride)] -> [(FilePath, EnvOverride)] -> Bool
forall a. Eq a => a -> a -> Bool
== [] then Maybe [(FilePath, FilePath)]
forall a. Maybe a
Nothing else [(FilePath, FilePath)] -> Maybe [(FilePath, FilePath)]
forall a. a -> Maybe a
Just [(FilePath, FilePath)]
env'
    , cwd :: Maybe FilePath
cwd = Maybe FilePath
mcwd
    }
  ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
h

logProcessCall :: Verbose => Maybe FilePath -> [(String, EnvOverride)]
               -> FilePath -> [String] -> IO ()
logProcessCall :: Maybe FilePath
-> [(FilePath, EnvOverride)] -> FilePath -> [FilePath] -> IO ()
logProcessCall mcwd :: Maybe FilePath
mcwd env :: [(FilePath, EnvOverride)]
env exe :: FilePath
exe args :: [FilePath]
args = do
  FilePath -> IO ()
forall (m :: * -> *). (MonadIO m, Verbose) => FilePath -> m ()
vLog (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate " " ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ [FilePath]
cd [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
env_args [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> FilePath
formatProcessArg (FilePath
exeFilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:[FilePath]
args)
  where
    env_args :: [FilePath]
env_args = ((FilePath, EnvOverride) -> FilePath)
-> [(FilePath, EnvOverride)] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (\(k :: FilePath
k,v :: EnvOverride
v) -> FilePath
k FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ EnvOverride -> FilePath
forall a. Show a => a -> FilePath
show EnvOverride
v) [(FilePath, EnvOverride)]
env
    cd :: [FilePath]
cd = case Maybe FilePath
mcwd of
      Nothing -> []; Just cwd :: FilePath
cwd -> [ "cd", FilePath -> FilePath
formatProcessArg FilePath
cwdFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++";" ]

execEnvOverride :: EnvOverride -> String -> Maybe String
execEnvOverride :: EnvOverride -> FilePath -> Maybe FilePath
execEnvOverride (EnvPrepend x :: FilePath
x) y :: FilePath
y = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath
x FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
y)
execEnvOverride (EnvAppend  y :: FilePath
y) x :: FilePath
x = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath
x FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
y)
execEnvOverride (EnvSet x :: FilePath
x)     _ = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
x
execEnvOverride  EnvUnset      _ = Maybe FilePath
forall a. Maybe a
Nothing

execEnvOverrides
    :: [(String, EnvOverride)] -> [(String, String)] -> [(String, String)]
execEnvOverrides :: [(FilePath, EnvOverride)]
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
execEnvOverrides overrides :: [(FilePath, EnvOverride)]
overrides env :: [(FilePath, FilePath)]
env =
    Map FilePath FilePath -> [(FilePath, FilePath)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map FilePath FilePath -> [(FilePath, FilePath)])
-> Map FilePath FilePath -> [(FilePath, FilePath)]
forall a b. (a -> b) -> a -> b
$ (Map FilePath FilePath
 -> (FilePath, EnvOverride) -> Map FilePath FilePath)
-> Map FilePath FilePath
-> [(FilePath, EnvOverride)]
-> Map FilePath FilePath
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Map FilePath FilePath
-> (FilePath, EnvOverride) -> Map FilePath FilePath
forall k.
Ord k =>
Map k FilePath -> (k, EnvOverride) -> Map k FilePath
f ([(FilePath, FilePath)] -> Map FilePath FilePath
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(FilePath, FilePath)]
env) [(FilePath, EnvOverride)]
overrides
  where
    f :: Map k FilePath -> (k, EnvOverride) -> Map k FilePath
f em :: Map k FilePath
em (k :: k
k, o :: EnvOverride
o) = (Maybe FilePath -> Maybe FilePath)
-> k -> Map k FilePath -> Map k FilePath
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (EnvOverride -> FilePath -> Maybe FilePath
execEnvOverride EnvOverride
o (FilePath -> Maybe FilePath)
-> (Maybe FilePath -> FilePath) -> Maybe FilePath -> Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe "") k
k Map k FilePath
em

-- | Essentially 'System.Process.callProcess' but with additional options
-- and logging to stderr when verbosity is enabled.
callProcessStderr :: Verbose => Maybe FilePath -> [(String, EnvOverride)]
                  -> FilePath -> [String] -> IO ()
callProcessStderr :: Maybe FilePath
-> [(FilePath, EnvOverride)] -> FilePath -> [FilePath] -> IO ()
callProcessStderr mwd :: Maybe FilePath
mwd env :: [(FilePath, EnvOverride)]
env exe :: FilePath
exe args :: [FilePath]
args = do
  ExitCode
rv <- Verbose =>
Maybe FilePath
-> [(FilePath, EnvOverride)]
-> FilePath
-> [FilePath]
-> IO ExitCode
Maybe FilePath
-> [(FilePath, EnvOverride)]
-> FilePath
-> [FilePath]
-> IO ExitCode
callProcessStderr' Maybe FilePath
mwd [(FilePath, EnvOverride)]
env FilePath
exe [FilePath]
args
  case ExitCode
rv of
    ExitSuccess -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    ExitFailure v :: Int
v -> FilePath -> FilePath -> [FilePath] -> Int -> IO ()
forall a. FilePath -> FilePath -> [FilePath] -> Int -> IO a
processFailedException "callProcessStderr" FilePath
exe [FilePath]
args Int
v

processFailedException :: String -> String -> [String] -> Int -> IO a
processFailedException :: FilePath -> FilePath -> [FilePath] -> Int -> IO a
processFailedException fn :: FilePath
fn exe :: FilePath
exe args :: [FilePath]
args rv :: Int
rv =
    IOError -> IO a
forall a. IOError -> IO a
ioError (IOError -> IO a) -> IOError -> IO a
forall a b. (a -> b) -> a -> b
$ IOErrorType
-> FilePath -> Maybe Handle -> Maybe FilePath -> IOError
mkIOError IOErrorType
OtherError FilePath
msg Maybe Handle
forall a. Maybe a
Nothing Maybe FilePath
forall a. Maybe a
Nothing
  where
    msg :: FilePath
msg = [FilePath] -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ FilePath
fn, ": ", FilePath
exe, " "
                 , FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate " " ((FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> FilePath
formatProcessArg [FilePath]
args)
                 , " (exit " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
rv FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ")"
                 ]

formatProcessArg :: String -> String
formatProcessArg :: FilePath -> FilePath
formatProcessArg xs :: FilePath
xs
    | (Char -> Bool) -> FilePath -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Char -> Bool
isSpace FilePath
xs = "'"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
xs FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++"'"
    | Bool
otherwise      = FilePath
xs