Cabal/src/Distribution/Simple/Program/Run.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE GADTs #-}
   3 {-# LANGUAGE RankNTypes #-}
   4
   5 -----------------------------------------------------------------------------
   6
   7 -- |
   8 -- Module      :  Distribution.Simple.Program.Run
   9 -- Copyright   :  Duncan Coutts 2009
  10 --
  11 -- Maintainer  :  cabal-devel@haskell.org
  12 -- Portability :  portable
  13 --
  14 -- This module provides a data type for program invocations and functions to
  15 -- run them.
  16 module Distribution.Simple.Program.Run
  17   ( ProgramInvocation (..)
  18   , IOEncoding (..)
  19   , emptyProgramInvocation
  20   , simpleProgramInvocation
  21   , programInvocation
  22   , multiStageProgramInvocation
  23   , runProgramInvocation
  24   , getProgramInvocationOutput
  25   , getProgramInvocationLBS
  26   , getProgramInvocationOutputAndErrors
  27   , getEffectiveEnvironment
  28   ) where
  29
  30 import Distribution.Compat.Prelude
  31 import Prelude ()
  32
  33 import Distribution.Compat.Environment
  34 import Distribution.Simple.Errors
  35 import Distribution.Simple.Program.Types
  36 import Distribution.Simple.Utils
  37 import Distribution.Utils.Generic
  38 import Distribution.Verbosity
  39 import System.FilePath (searchPathSeparator)
  40
  41 import qualified Data.ByteString.Lazy as LBS
  42 import qualified Data.Map as Map
  43
  44 -- | Represents a specific invocation of a specific program.
  45 --
  46 -- This is used as an intermediate type between deciding how to call a program
  47 -- and actually doing it. This provides the opportunity to the caller to
  48 -- adjust how the program will be called. These invocations can either be run
  49 -- directly or turned into shell or batch scripts.
  50 data ProgramInvocation = ProgramInvocation
  51   { progInvokePath :: FilePath
  52   , progInvokeArgs :: [String]
  53   , progInvokeEnv :: [(String, Maybe String)]
  54   , -- Extra paths to add to PATH
  55     progInvokePathEnv :: [FilePath]
  56   , progInvokeCwd :: Maybe FilePath
  57   , progInvokeInput :: Maybe IOData
  58   , progInvokeInputEncoding :: IOEncoding
  59   -- ^ TODO: remove this, make user decide when constructing 'progInvokeInput'.
  60   , progInvokeOutputEncoding :: IOEncoding
  61   }
  62
  63 data IOEncoding
  64   = IOEncodingText -- locale mode text
  65   | IOEncodingUTF8 -- always utf8
  66
  67 encodeToIOData :: IOEncoding -> IOData -> IOData
  68 encodeToIOData _ iod@(IODataBinary _) = iod
  69 encodeToIOData IOEncodingText iod@(IODataText _) = iod
  70 encodeToIOData IOEncodingUTF8 (IODataText str) = IODataBinary (toUTF8LBS str)
  71
  72 emptyProgramInvocation :: ProgramInvocation
  73 emptyProgramInvocation =
  74   ProgramInvocation
  75     { progInvokePath = ""
  76     , progInvokeArgs = []
  77     , progInvokeEnv = []
  78     , progInvokePathEnv = []
  79     , progInvokeCwd = Nothing
  80     , progInvokeInput = Nothing
  81     , progInvokeInputEncoding = IOEncodingText
  82     , progInvokeOutputEncoding = IOEncodingText
  83     }
  84
  85 simpleProgramInvocation :: FilePath -> [String] -> ProgramInvocation
  86 simpleProgramInvocation path args =
  87   emptyProgramInvocation
  88     { progInvokePath = path
  89     , progInvokeArgs = args
  90     }
  91
  92 programInvocation :: ConfiguredProgram -> [String] -> ProgramInvocation
  93 programInvocation prog args =
  94   emptyProgramInvocation
  95     { progInvokePath = programPath prog
  96     , progInvokeArgs =
  97         programDefaultArgs prog
  98           ++ args
  99           ++ programOverrideArgs prog
 100     , progInvokeEnv = programOverrideEnv prog
 101     }
 102
 103 runProgramInvocation :: Verbosity -> ProgramInvocation -> IO ()
 104 runProgramInvocation
 105   verbosity
 106   ProgramInvocation
 107     { progInvokePath = path
 108     , progInvokeArgs = args
 109     , progInvokeEnv = []
 110     , progInvokePathEnv = []
 111     , progInvokeCwd = Nothing
 112     , progInvokeInput = Nothing
 113     } =
 114     rawSystemExit verbosity path args
 115 runProgramInvocation
 116   verbosity
 117   ProgramInvocation
 118     { progInvokePath = path
 119     , progInvokeArgs = args
 120     , progInvokeEnv = envOverrides
 121     , progInvokePathEnv = extraPath
 122     , progInvokeCwd = mcwd
 123     , progInvokeInput = Nothing
 124     } = do
 125     pathOverride <- getExtraPathEnv envOverrides extraPath
 126     menv <- getEffectiveEnvironment (envOverrides ++ pathOverride)
 127     maybeExit $
 128       rawSystemIOWithEnv
 129         verbosity
 130         path
 131         args
 132         mcwd
 133         menv
 134         Nothing
 135         Nothing
 136         Nothing
 137 runProgramInvocation
 138   verbosity
 139   ProgramInvocation
 140     { progInvokePath = path
 141     , progInvokeArgs = args
 142     , progInvokeEnv = envOverrides
 143     , progInvokePathEnv = extraPath
 144     , progInvokeCwd = mcwd
 145     , progInvokeInput = Just inputStr
 146     , progInvokeInputEncoding = encoding
 147     } = do
 148     pathOverride <- getExtraPathEnv envOverrides extraPath
 149     menv <- getEffectiveEnvironment (envOverrides ++ pathOverride)
 150     (_, errors, exitCode) <-
 151       rawSystemStdInOut
 152         verbosity
 153         path
 154         args
 155         mcwd
 156         menv
 157         (Just input)
 158         IODataModeBinary
 159     when (exitCode /= ExitSuccess) $
 160       dieWithException verbosity $
 161         RunProgramInvocationException path errors
 162     where
 163       input = encodeToIOData encoding inputStr
 164
 165 getProgramInvocationOutput :: Verbosity -> ProgramInvocation -> IO String
 166 getProgramInvocationOutput verbosity inv = do
 167   (output, errors, exitCode) <- getProgramInvocationOutputAndErrors verbosity inv
 168   when (exitCode /= ExitSuccess) $
 169     die' verbosity $
 170       "'" ++ progInvokePath inv ++ "' exited with an error:\n" ++ errors
 171   return output
 172
 173 getProgramInvocationLBS :: Verbosity -> ProgramInvocation -> IO LBS.ByteString
 174 getProgramInvocationLBS verbosity inv = do
 175   (output, errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeBinary
 176   when (exitCode /= ExitSuccess) $
 177     dieWithException verbosity $
 178       GetProgramInvocationLBSException (progInvokePath inv) errors
 179   return output
 180
 181 getProgramInvocationOutputAndErrors
 182   :: Verbosity
 183   -> ProgramInvocation
 184   -> IO (String, String, ExitCode)
 185 getProgramInvocationOutputAndErrors verbosity inv = case progInvokeOutputEncoding inv of
 186   IOEncodingText -> do
 187     (output, errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeText
 188     return (output, errors, exitCode)
 189   IOEncodingUTF8 -> do
 190     (output', errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeBinary
 191     return (normaliseLineEndings (fromUTF8LBS output'), errors, exitCode)
 192
 193 getProgramInvocationIODataAndErrors
 194   :: KnownIODataMode mode
 195   => Verbosity
 196   -> ProgramInvocation
 197   -> IODataMode mode
 198   -> IO (mode, String, ExitCode)
 199 getProgramInvocationIODataAndErrors
 200   verbosity
 201   ProgramInvocation
 202     { progInvokePath = path
 203     , progInvokeArgs = args
 204     , progInvokeEnv = envOverrides
 205     , progInvokePathEnv = extraPath
 206     , progInvokeCwd = mcwd
 207     , progInvokeInput = minputStr
 208     , progInvokeInputEncoding = encoding
 209     }
 210   mode = do
 211     pathOverride <- getExtraPathEnv envOverrides extraPath
 212     menv <- getEffectiveEnvironment (envOverrides ++ pathOverride)
 213     rawSystemStdInOut verbosity path args mcwd menv input mode
 214     where
 215       input = encodeToIOData encoding <$> minputStr
 216
 217 getExtraPathEnv :: [(String, Maybe String)] -> [FilePath] -> IO [(String, Maybe String)]
 218 getExtraPathEnv _ [] = return []
 219 getExtraPathEnv env extras = do
 220   mb_path <- case lookup "PATH" env of
 221     Just x -> return x
 222     Nothing -> lookupEnv "PATH"
 223   let extra = intercalate [searchPathSeparator] extras
 224       path' = case mb_path of
 225         Nothing -> extra
 226         Just path -> extra ++ searchPathSeparator : path
 227   return [("PATH", Just path')]
 228
 229 -- | Return the current environment extended with the given overrides.
 230 -- If an entry is specified twice in @overrides@, the second entry takes
 231 -- precedence.
 232 getEffectiveEnvironment
 233   :: [(String, Maybe String)]
 234   -> IO (Maybe [(String, String)])
 235 getEffectiveEnvironment [] = return Nothing
 236 getEffectiveEnvironment overrides =
 237   fmap (Just . Map.toList . apply overrides . Map.fromList) getEnvironment
 238   where
 239     apply os env = foldl' (flip update) env os
 240     update (var, Nothing) = Map.delete var
 241     update (var, Just val) = Map.insert var val
 242
 243 -- | Like the unix xargs program. Useful for when we've got very long command
 244 -- lines that might overflow an OS limit on command line length and so you
 245 -- need to invoke a command multiple times to get all the args in.
 246 --
 247 -- It takes four template invocations corresponding to the simple, initial,
 248 -- middle and last invocations. If the number of args given is small enough
 249 -- that we can get away with just a single invocation then the simple one is
 250 -- used:
 251 --
 252 -- > $ simple args
 253 --
 254 -- If the number of args given means that we need to use multiple invocations
 255 -- then the templates for the initial, middle and last invocations are used:
 256 --
 257 -- > $ initial args_0
 258 -- > $ middle  args_1
 259 -- > $ middle  args_2
 260 -- >   ...
 261 -- > $ final   args_n
 262 multiStageProgramInvocation
 263   :: ProgramInvocation
 264   -> (ProgramInvocation, ProgramInvocation, ProgramInvocation)
 265   -> [String]
 266   -> [ProgramInvocation]
 267 multiStageProgramInvocation simple (initial, middle, final) args =
 268   let argSize inv =
 269         length (progInvokePath inv)
 270           + foldl' (\s a -> length a + 1 + s) 1 (progInvokeArgs inv)
 271       fixedArgSize = maximum (map argSize [simple, initial, middle, final])
 272       chunkSize = maxCommandLineSize - fixedArgSize
 273    in case splitChunks chunkSize args of
 274         [] -> [simple]
 275         [c] -> [simple `appendArgs` c]
 276         (c : c2 : cs)
 277           | (xs, x) <- unsnocNE (c2 :| cs) ->
 278               [initial `appendArgs` c]
 279                 ++ [middle `appendArgs` c' | c' <- xs]
 280                 ++ [final `appendArgs` x]
 281   where
 282     appendArgs :: ProgramInvocation -> [String] -> ProgramInvocation
 283     inv `appendArgs` as = inv{progInvokeArgs = progInvokeArgs inv ++ as}
 284
 285     splitChunks :: Int -> [[a]] -> [[[a]]]
 286     splitChunks len = unfoldr $ \s ->
 287       if null s
 288         then Nothing
 289         else Just (chunk len s)
 290
 291     chunk :: Int -> [[a]] -> ([[a]], [[a]])
 292     chunk len (s : _) | length s >= len = error toolong
 293     chunk len ss = chunk' [] len ss
 294
 295     chunk' :: [[a]] -> Int -> [[a]] -> ([[a]], [[a]])
 296     chunk' acc len (s : ss)
 297       | len' < len = chunk' (s : acc) (len - len' - 1) ss
 298       where
 299         len' = length s
 300     chunk' acc _ ss = (reverse acc, ss)
 301
 302     toolong =
 303       "multiStageProgramInvocation: a single program arg is larger "
 304         ++ "than the maximum command line length!"
 305
 306 -- FIXME: discover this at configure time or runtime on unix
 307 -- The value is 32k on Windows and posix specifies a minimum of 4k
 308 -- but all sensible unixes use more than 4k.
 309 -- we could use getSysVar ArgumentLimit but that's in the unix lib
 310 --
 311 maxCommandLineSize :: Int
 312 maxCommandLineSize = 30 * 1024