{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}

-----------------------------------------------------------------------------

-- |
-- Module      :  Distribution.Simple.Program.Run
-- Copyright   :  Duncan Coutts 2009
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- This module provides a data type for program invocations and functions to
-- run them.
module Distribution.Simple.Program.Run
  ( ProgramInvocation (..)
  , IOEncoding (..)
  , emptyProgramInvocation
  , simpleProgramInvocation
  , programInvocation
  , multiStageProgramInvocation
  , runProgramInvocation
  , getProgramInvocationOutput
  , getProgramInvocationLBS
  , getProgramInvocationOutputAndErrors
  , getProgramInvocationLBSAndErrors
  , getEffectiveEnvironment
  ) where

import Distribution.Compat.Prelude
import Prelude ()

import Distribution.Compat.Environment
import Distribution.Simple.Errors
import Distribution.Simple.Program.Types
import Distribution.Simple.Utils
import Distribution.Utils.Generic
import Distribution.Verbosity

import qualified Data.ByteString.Lazy as LBS
import qualified Data.Map as Map

-- | Represents a specific invocation of a specific program.
--
-- This is used as an intermediate type between deciding how to call a program
-- and actually doing it. This provides the opportunity to the caller to
-- adjust how the program will be called. These invocations can either be run
-- directly or turned into shell or batch scripts.
data ProgramInvocation = ProgramInvocation
  { ProgramInvocation -> String
progInvokePath :: FilePath
  , ProgramInvocation -> [String]
progInvokeArgs :: [String]
  , ProgramInvocation -> [(String, Maybe String)]
progInvokeEnv :: [(String, Maybe String)]
  , ProgramInvocation -> Maybe String
progInvokeCwd :: Maybe FilePath
  , ProgramInvocation -> Maybe IOData
progInvokeInput :: Maybe IOData
  , ProgramInvocation -> IOEncoding
progInvokeInputEncoding :: IOEncoding
  -- ^ TODO: remove this, make user decide when constructing 'progInvokeInput'.
  , ProgramInvocation -> IOEncoding
progInvokeOutputEncoding :: IOEncoding
  }

data IOEncoding
  = IOEncodingText -- locale mode text
  | IOEncodingUTF8 -- always utf8

encodeToIOData :: IOEncoding -> IOData -> IOData
encodeToIOData :: IOEncoding -> IOData -> IOData
encodeToIOData IOEncoding
_ iod :: IOData
iod@(IODataBinary ByteString
_) = IOData
iod
encodeToIOData IOEncoding
IOEncodingText iod :: IOData
iod@(IODataText String
_) = IOData
iod
encodeToIOData IOEncoding
IOEncodingUTF8 (IODataText String
str) = ByteString -> IOData
IODataBinary (String -> ByteString
toUTF8LBS String
str)

emptyProgramInvocation :: ProgramInvocation
emptyProgramInvocation :: ProgramInvocation
emptyProgramInvocation =
  ProgramInvocation
    { progInvokePath :: String
progInvokePath = String
""
    , progInvokeArgs :: [String]
progInvokeArgs = []
    , progInvokeEnv :: [(String, Maybe String)]
progInvokeEnv = []
    , progInvokeCwd :: Maybe String
progInvokeCwd = Maybe String
forall a. Maybe a
Nothing
    , progInvokeInput :: Maybe IOData
progInvokeInput = Maybe IOData
forall a. Maybe a
Nothing
    , progInvokeInputEncoding :: IOEncoding
progInvokeInputEncoding = IOEncoding
IOEncodingText
    , progInvokeOutputEncoding :: IOEncoding
progInvokeOutputEncoding = IOEncoding
IOEncodingText
    }

simpleProgramInvocation :: FilePath -> [String] -> ProgramInvocation
simpleProgramInvocation :: String -> [String] -> ProgramInvocation
simpleProgramInvocation String
path [String]
args =
  ProgramInvocation
emptyProgramInvocation
    { progInvokePath = path
    , progInvokeArgs = args
    }

programInvocation :: ConfiguredProgram -> [String] -> ProgramInvocation
programInvocation :: ConfiguredProgram -> [String] -> ProgramInvocation
programInvocation ConfiguredProgram
prog [String]
args =
  ProgramInvocation
emptyProgramInvocation
    { progInvokePath = programPath prog
    , progInvokeArgs =
        programDefaultArgs prog
          ++ args
          ++ programOverrideArgs prog
    , progInvokeEnv = programOverrideEnv prog
    }

runProgramInvocation :: Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation :: Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation
  Verbosity
verbosity
  ProgramInvocation
    { progInvokePath :: ProgramInvocation -> String
progInvokePath = String
path
    , progInvokeArgs :: ProgramInvocation -> [String]
progInvokeArgs = [String]
args
    , progInvokeEnv :: ProgramInvocation -> [(String, Maybe String)]
progInvokeEnv = []
    , progInvokeCwd :: ProgramInvocation -> Maybe String
progInvokeCwd = Maybe String
Nothing
    , progInvokeInput :: ProgramInvocation -> Maybe IOData
progInvokeInput = Maybe IOData
Nothing
    } =
    Verbosity -> String -> [String] -> IO ()
rawSystemExit Verbosity
verbosity String
path [String]
args
runProgramInvocation
  Verbosity
verbosity
  ProgramInvocation
    { progInvokePath :: ProgramInvocation -> String
progInvokePath = String
path
    , progInvokeArgs :: ProgramInvocation -> [String]
progInvokeArgs = [String]
args
    , progInvokeEnv :: ProgramInvocation -> [(String, Maybe String)]
progInvokeEnv = [(String, Maybe String)]
envOverrides
    , progInvokeCwd :: ProgramInvocation -> Maybe String
progInvokeCwd = Maybe String
mcwd
    , progInvokeInput :: ProgramInvocation -> Maybe IOData
progInvokeInput = Maybe IOData
Nothing
    } = do
    menv <- [(String, Maybe String)] -> IO (Maybe [(String, String)])
getEffectiveEnvironment [(String, Maybe String)]
envOverrides
    maybeExit $
      rawSystemIOWithEnv
        verbosity
        path
        args
        mcwd
        menv
        Nothing
        Nothing
        Nothing
runProgramInvocation
  Verbosity
verbosity
  ProgramInvocation
    { progInvokePath :: ProgramInvocation -> String
progInvokePath = String
path
    , progInvokeArgs :: ProgramInvocation -> [String]
progInvokeArgs = [String]
args
    , progInvokeEnv :: ProgramInvocation -> [(String, Maybe String)]
progInvokeEnv = [(String, Maybe String)]
envOverrides
    , progInvokeCwd :: ProgramInvocation -> Maybe String
progInvokeCwd = Maybe String
mcwd
    , progInvokeInput :: ProgramInvocation -> Maybe IOData
progInvokeInput = Just IOData
inputStr
    , progInvokeInputEncoding :: ProgramInvocation -> IOEncoding
progInvokeInputEncoding = IOEncoding
encoding
    } = do
    menv <- [(String, Maybe String)] -> IO (Maybe [(String, String)])
getEffectiveEnvironment [(String, Maybe String)]
envOverrides
    (_, errors, exitCode) <-
      rawSystemStdInOut
        verbosity
        path
        args
        mcwd
        menv
        (Just input)
        IODataModeBinary
    when (exitCode /= ExitSuccess) $
      dieWithException verbosity $
        RunProgramInvocationException path errors
    where
      input :: IOData
input = IOEncoding -> IOData -> IOData
encodeToIOData IOEncoding
encoding IOData
inputStr

getProgramInvocationOutput :: Verbosity -> ProgramInvocation -> IO String
getProgramInvocationOutput :: Verbosity -> ProgramInvocation -> IO String
getProgramInvocationOutput Verbosity
verbosity ProgramInvocation
inv = do
  (output, errors, exitCode) <- Verbosity -> ProgramInvocation -> IO (String, String, ExitCode)
getProgramInvocationOutputAndErrors Verbosity
verbosity ProgramInvocation
inv
  when (exitCode /= ExitSuccess) $
    die' verbosity $
      "'" ++ progInvokePath inv ++ "' exited with an error:\n" ++ errors
  return output

getProgramInvocationLBS :: Verbosity -> ProgramInvocation -> IO LBS.ByteString
getProgramInvocationLBS :: Verbosity -> ProgramInvocation -> IO ByteString
getProgramInvocationLBS Verbosity
verbosity ProgramInvocation
inv = do
  (output, errors, exitCode) <- Verbosity
-> ProgramInvocation
-> IODataMode ByteString
-> IO (ByteString, String, ExitCode)
forall mode.
KnownIODataMode mode =>
Verbosity
-> ProgramInvocation
-> IODataMode mode
-> IO (mode, String, ExitCode)
getProgramInvocationIODataAndErrors Verbosity
verbosity ProgramInvocation
inv IODataMode ByteString
IODataModeBinary
  when (exitCode /= ExitSuccess) $
    dieWithException verbosity $
      GetProgramInvocationLBSException (progInvokePath inv) errors
  return output

getProgramInvocationOutputAndErrors
  :: Verbosity
  -> ProgramInvocation
  -> IO (String, String, ExitCode)
getProgramInvocationOutputAndErrors :: Verbosity -> ProgramInvocation -> IO (String, String, ExitCode)
getProgramInvocationOutputAndErrors Verbosity
verbosity ProgramInvocation
inv = case ProgramInvocation -> IOEncoding
progInvokeOutputEncoding ProgramInvocation
inv of
  IOEncoding
IOEncodingText -> do
    (output, errors, exitCode) <- Verbosity
-> ProgramInvocation
-> IODataMode String
-> IO (String, String, ExitCode)
forall mode.
KnownIODataMode mode =>
Verbosity
-> ProgramInvocation
-> IODataMode mode
-> IO (mode, String, ExitCode)
getProgramInvocationIODataAndErrors Verbosity
verbosity ProgramInvocation
inv IODataMode String
IODataModeText
    return (output, errors, exitCode)
  IOEncoding
IOEncodingUTF8 -> do
    (output', errors, exitCode) <- Verbosity
-> ProgramInvocation
-> IODataMode ByteString
-> IO (ByteString, String, ExitCode)
forall mode.
KnownIODataMode mode =>
Verbosity
-> ProgramInvocation
-> IODataMode mode
-> IO (mode, String, ExitCode)
getProgramInvocationIODataAndErrors Verbosity
verbosity ProgramInvocation
inv IODataMode ByteString
IODataModeBinary
    return (normaliseLineEndings (fromUTF8LBS output'), errors, exitCode)

getProgramInvocationLBSAndErrors
  :: Verbosity
  -> ProgramInvocation
  -> IO (LBS.ByteString, String, ExitCode)
getProgramInvocationLBSAndErrors :: Verbosity -> ProgramInvocation -> IO (ByteString, String, ExitCode)
getProgramInvocationLBSAndErrors Verbosity
verbosity ProgramInvocation
inv =
  Verbosity
-> ProgramInvocation
-> IODataMode ByteString
-> IO (ByteString, String, ExitCode)
forall mode.
KnownIODataMode mode =>
Verbosity
-> ProgramInvocation
-> IODataMode mode
-> IO (mode, String, ExitCode)
getProgramInvocationIODataAndErrors Verbosity
verbosity ProgramInvocation
inv IODataMode ByteString
IODataModeBinary

getProgramInvocationIODataAndErrors
  :: KnownIODataMode mode
  => Verbosity
  -> ProgramInvocation
  -> IODataMode mode
  -> IO (mode, String, ExitCode)
getProgramInvocationIODataAndErrors :: forall mode.
KnownIODataMode mode =>
Verbosity
-> ProgramInvocation
-> IODataMode mode
-> IO (mode, String, ExitCode)
getProgramInvocationIODataAndErrors
  Verbosity
verbosity
  ProgramInvocation
    { progInvokePath :: ProgramInvocation -> String
progInvokePath = String
path
    , progInvokeArgs :: ProgramInvocation -> [String]
progInvokeArgs = [String]
args
    , progInvokeEnv :: ProgramInvocation -> [(String, Maybe String)]
progInvokeEnv = [(String, Maybe String)]
envOverrides
    , progInvokeCwd :: ProgramInvocation -> Maybe String
progInvokeCwd = Maybe String
mcwd
    , progInvokeInput :: ProgramInvocation -> Maybe IOData
progInvokeInput = Maybe IOData
minputStr
    , progInvokeInputEncoding :: ProgramInvocation -> IOEncoding
progInvokeInputEncoding = IOEncoding
encoding
    }
  IODataMode mode
mode = do
    menv <- [(String, Maybe String)] -> IO (Maybe [(String, String)])
getEffectiveEnvironment [(String, Maybe String)]
envOverrides
    rawSystemStdInOut verbosity path args mcwd menv input mode
    where
      input :: Maybe IOData
input = IOEncoding -> IOData -> IOData
encodeToIOData IOEncoding
encoding (IOData -> IOData) -> Maybe IOData -> Maybe IOData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe IOData
minputStr

-- | Return the current environment extended with the given overrides.
-- If an entry is specified twice in @overrides@, the second entry takes
-- precedence.
getEffectiveEnvironment
  :: [(String, Maybe String)]
  -> IO (Maybe [(String, String)])
getEffectiveEnvironment :: [(String, Maybe String)] -> IO (Maybe [(String, String)])
getEffectiveEnvironment [] = Maybe [(String, String)] -> IO (Maybe [(String, String)])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [(String, String)]
forall a. Maybe a
Nothing
getEffectiveEnvironment [(String, Maybe String)]
overrides =
  ([(String, String)] -> Maybe [(String, String)])
-> IO [(String, String)] -> IO (Maybe [(String, String)])
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([(String, String)] -> Maybe [(String, String)]
forall a. a -> Maybe a
Just ([(String, String)] -> Maybe [(String, String)])
-> ([(String, String)] -> [(String, String)])
-> [(String, String)]
-> Maybe [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map String String -> [(String, String)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map String String -> [(String, String)])
-> ([(String, String)] -> Map String String)
-> [(String, String)]
-> [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(String, Maybe String)] -> Map String String -> Map String String
forall {t :: * -> *} {k} {a}.
(Foldable t, Ord k) =>
t (k, Maybe a) -> Map k a -> Map k a
apply [(String, Maybe String)]
overrides (Map String String -> Map String String)
-> ([(String, String)] -> Map String String)
-> [(String, String)]
-> Map String String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(String, String)] -> Map String String
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList) IO [(String, String)]
getEnvironment
  where
    apply :: t (k, Maybe a) -> Map k a -> Map k a
apply t (k, Maybe a)
os Map k a
env = (Map k a -> (k, Maybe a) -> Map k a)
-> Map k a -> t (k, Maybe a) -> Map k a
forall b a. (b -> a -> b) -> b -> t a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (((k, Maybe a) -> Map k a -> Map k a)
-> Map k a -> (k, Maybe a) -> Map k a
forall a b c. (a -> b -> c) -> b -> a -> c
flip (k, Maybe a) -> Map k a -> Map k a
forall {k} {a}. Ord k => (k, Maybe a) -> Map k a -> Map k a
update) Map k a
env t (k, Maybe a)
os
    update :: (k, Maybe a) -> Map k a -> Map k a
update (k
var, Maybe a
Nothing) = k -> Map k a -> Map k a
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete k
var
    update (k
var, Just a
val) = k -> a -> Map k a -> Map k a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
var a
val

-- | Like the unix xargs program. Useful for when we've got very long command
-- lines that might overflow an OS limit on command line length and so you
-- need to invoke a command multiple times to get all the args in.
--
-- It takes four template invocations corresponding to the simple, initial,
-- middle and last invocations. If the number of args given is small enough
-- that we can get away with just a single invocation then the simple one is
-- used:
--
-- > $ simple args
--
-- If the number of args given means that we need to use multiple invocations
-- then the templates for the initial, middle and last invocations are used:
--
-- > $ initial args_0
-- > $ middle  args_1
-- > $ middle  args_2
-- >   ...
-- > $ final   args_n
multiStageProgramInvocation
  :: ProgramInvocation
  -> (ProgramInvocation, ProgramInvocation, ProgramInvocation)
  -> [String]
  -> [ProgramInvocation]
multiStageProgramInvocation :: ProgramInvocation
-> (ProgramInvocation, ProgramInvocation, ProgramInvocation)
-> [String]
-> [ProgramInvocation]
multiStageProgramInvocation ProgramInvocation
simple (ProgramInvocation
initial, ProgramInvocation
middle, ProgramInvocation
final) [String]
args =
  let argSize :: ProgramInvocation -> Int
argSize ProgramInvocation
inv =
        String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ProgramInvocation -> String
progInvokePath ProgramInvocation
inv)
          Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int -> String -> Int) -> Int -> [String] -> Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Int
s String
a -> String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
s) Int
1 (ProgramInvocation -> [String]
progInvokeArgs ProgramInvocation
inv)
      fixedArgSize :: Int
fixedArgSize = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ((ProgramInvocation -> Int) -> [ProgramInvocation] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ProgramInvocation -> Int
argSize [ProgramInvocation
simple, ProgramInvocation
initial, ProgramInvocation
middle, ProgramInvocation
final])
      chunkSize :: Int
chunkSize = Int
maxCommandLineSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
fixedArgSize
   in case Int -> [String] -> [[String]]
forall a. Int -> [[a]] -> [[[a]]]
splitChunks Int
chunkSize [String]
args of
        [] -> [ProgramInvocation
simple]
        [[String]
c] -> [ProgramInvocation
simple ProgramInvocation -> [String] -> ProgramInvocation
`appendArgs` [String]
c]
        ([String]
c : [String]
c2 : [[String]]
cs)
          | ([[String]]
xs, [String]
x) <- NonEmpty [String] -> ([[String]], [String])
forall a. NonEmpty a -> ([a], a)
unsnocNE ([String]
c2 [String] -> [[String]] -> NonEmpty [String]
forall a. a -> [a] -> NonEmpty a
:| [[String]]
cs) ->
              [ProgramInvocation
initial ProgramInvocation -> [String] -> ProgramInvocation
`appendArgs` [String]
c]
                [ProgramInvocation] -> [ProgramInvocation] -> [ProgramInvocation]
forall a. [a] -> [a] -> [a]
++ [ProgramInvocation
middle ProgramInvocation -> [String] -> ProgramInvocation
`appendArgs` [String]
c' | [String]
c' <- [[String]]
xs]
                [ProgramInvocation] -> [ProgramInvocation] -> [ProgramInvocation]
forall a. [a] -> [a] -> [a]
++ [ProgramInvocation
final ProgramInvocation -> [String] -> ProgramInvocation
`appendArgs` [String]
x]
  where
    appendArgs :: ProgramInvocation -> [String] -> ProgramInvocation
    ProgramInvocation
inv appendArgs :: ProgramInvocation -> [String] -> ProgramInvocation
`appendArgs` [String]
as = ProgramInvocation
inv{progInvokeArgs = progInvokeArgs inv ++ as}

    splitChunks :: Int -> [[a]] -> [[[a]]]
    splitChunks :: forall a. Int -> [[a]] -> [[[a]]]
splitChunks Int
len = ([[a]] -> Maybe ([[a]], [[a]])) -> [[a]] -> [[[a]]]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr (([[a]] -> Maybe ([[a]], [[a]])) -> [[a]] -> [[[a]]])
-> ([[a]] -> Maybe ([[a]], [[a]])) -> [[a]] -> [[[a]]]
forall a b. (a -> b) -> a -> b
$ \[[a]]
s ->
      if [[a]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[a]]
s
        then Maybe ([[a]], [[a]])
forall a. Maybe a
Nothing
        else ([[a]], [[a]]) -> Maybe ([[a]], [[a]])
forall a. a -> Maybe a
Just (Int -> [[a]] -> ([[a]], [[a]])
forall a. Int -> [[a]] -> ([[a]], [[a]])
chunk Int
len [[a]]
s)

    chunk :: Int -> [[a]] -> ([[a]], [[a]])
    chunk :: forall a. Int -> [[a]] -> ([[a]], [[a]])
chunk Int
len ([a]
s : [[a]]
_) | [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
len = String -> ([[a]], [[a]])
forall a. HasCallStack => String -> a
error String
toolong
    chunk Int
len [[a]]
ss = [[a]] -> Int -> [[a]] -> ([[a]], [[a]])
forall a. [[a]] -> Int -> [[a]] -> ([[a]], [[a]])
chunk' [] Int
len [[a]]
ss

    chunk' :: [[a]] -> Int -> [[a]] -> ([[a]], [[a]])
    chunk' :: forall a. [[a]] -> Int -> [[a]] -> ([[a]], [[a]])
chunk' [[a]]
acc Int
len ([a]
s : [[a]]
ss)
      | Int
len' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
len = [[a]] -> Int -> [[a]] -> ([[a]], [[a]])
forall a. [[a]] -> Int -> [[a]] -> ([[a]], [[a]])
chunk' ([a]
s [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [[a]]
acc) (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
len' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [[a]]
ss
      where
        len' :: Int
len' = [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
s
    chunk' [[a]]
acc Int
_ [[a]]
ss = ([[a]] -> [[a]]
forall a. [a] -> [a]
reverse [[a]]
acc, [[a]]
ss)

    toolong :: String
toolong =
      String
"multiStageProgramInvocation: a single program arg is larger "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"than the maximum command line length!"

-- FIXME: discover this at configure time or runtime on unix
-- The value is 32k on Windows and posix specifies a minimum of 4k
-- but all sensible unixes use more than 4k.
-- we could use getSysVar ArgumentLimit but that's in the unix lib
--
maxCommandLineSize :: Int
maxCommandLineSize :: Int
maxCommandLineSize = Int
30 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024