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

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