Utils.hs 59.4 KB
Newer Older
1 2
{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
3
{-# LANGUAGE FlexibleContexts #-}
4
{-# LANGUAGE RankNTypes #-}
5 6
{-# LANGUAGE DeriveGeneric #-}

7 8 9
-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Simple.Utils
ijones's avatar
ijones committed
10
-- Copyright   :  Isaac Jones, Simon Marlow 2003-2004
11
-- License     :  BSD3
Duncan Coutts's avatar
Duncan Coutts committed
12
--                portions Copyright (c) 2007, Galois Inc.
13
--
Duncan Coutts's avatar
Duncan Coutts committed
14
-- Maintainer  :  cabal-devel@haskell.org
ijones's avatar
ijones committed
15
-- Portability :  portable
16
--
Duncan Coutts's avatar
Duncan Coutts committed
17 18 19 20 21
-- A large and somewhat miscellaneous collection of utility functions used
-- throughout the rest of the Cabal lib and in other tools that use the Cabal
-- lib like @cabal-install@. It has a very simple set of logging actions. It
-- has low level functions for running programs, a bunch of wrappers for
-- various directory and file functions that do extra logging.
22 23

module Distribution.Simple.Utils (
24
        cabalVersion,
25 26

        -- * logging and errors
27 28
        die,
        dieWithLocation,
29
        dieMsg, dieMsgNoWrap,
30
        topHandler, topHandlerWith,
31
        warn, notice, noticeNoWrap, setupMessage, info, debug,
32
        debugNoWrap, chattyTry,
Neil Vice's avatar
Neil Vice committed
33
        printRawCommandAndArgs, printRawCommandAndArgsAndEnv,
34

35 36 37
        -- * exceptions
        handleDoesNotExist,

38
        -- * running programs
39
        rawSystemExit,
tibbe's avatar
tibbe committed
40
        rawSystemExitCode,
41
        rawSystemExitWithEnv,
42
        rawSystemStdout,
43
        rawSystemStdInOut,
44
        rawSystemIOWithEnv,
45
        createProcessWithEnv,
46
        maybeExit,
47
        xargs,
48
        findProgramLocation,
49
        findProgramVersion,
50 51

        -- * copying files
52
        smartCopySources,
53
        createDirectoryIfMissingVerbose,
54
        copyFileVerbose,
55
        copyDirectoryRecursiveVerbose,
56
        copyFiles,
refold's avatar
refold committed
57
        copyFileTo,
58

59 60 61
        -- * installing files
        installOrdinaryFile,
        installExecutableFile,
refold's avatar
refold committed
62
        installMaybeExecutableFile,
63
        installOrdinaryFiles,
refold's avatar
refold committed
64 65
        installExecutableFiles,
        installMaybeExecutableFiles,
66
        installDirectoryContents,
67
        copyDirectoryRecursive,
68

69
        -- * File permissions
70
        doesExecutableExist,
71 72 73
        setFileOrdinary,
        setFileExecutable,

74
        -- * file names
ijones's avatar
ijones committed
75
        currentDir,
76
        shortRelativePath,
77 78
        dropExeExtension,
        exeExtensions,
79 80

        -- * finding files
81
        findFile,
82
        findFirstFile,
83 84
        findFileWithExtension,
        findFileWithExtension',
85
        findAllFilesWithExtension,
86 87 88
        findModuleFile,
        findModuleFiles,
        getDirectoryContentsRecursive,
89

90 91
        -- * environment variables
        isInSearchPath,
92
        addLibraryPath,
93

94 95
        -- * simple file globbing
        matchFileGlob,
Ian Lynagh's avatar
Ian Lynagh committed
96
        matchDirFileGlob,
97 98
        parseFileGlob,
        FileGlob(..),
99

100 101
        -- * modification time
        moreRecentFile,
102
        existsAndIsMoreRecentThan,
103

Duncan Coutts's avatar
Duncan Coutts committed
104
        -- * temp files and dirs
105 106 107
        TempFileOptions(..), defaultTempFileOptions,
        withTempFile, withTempFileEx,
        withTempDirectory, withTempDirectoryEx,
108 109

        -- * .cabal and .buildinfo files
110 111
        defaultPackageDesc,
        findPackageDesc,
112
        tryFindPackageDesc,
113 114
        defaultHookedPackageDesc,
        findHookedPackageDesc,
115

116 117 118
        -- * reading and writing files safely
        withFileContents,
        writeFileAtomic,
119
        rewriteFile,
120

121 122
        -- * Unicode
        fromUTF8,
Oleg Grenrus's avatar
Oleg Grenrus committed
123 124
        fromUTF8BS,
        fromUTF8LBS,
125
        toUTF8,
126
        readUTF8File,
127
        withUTF8FileContents,
128
        writeUTF8File,
129
        normaliseLineEndings,
130

Oleg Grenrus's avatar
Oleg Grenrus committed
131 132 133
        -- * BOM
        startsWithBOM,
        fileHasBOM,
134
        ignoreBOM,
Oleg Grenrus's avatar
Oleg Grenrus committed
135

136
        -- * generic utils
137 138
        dropWhileEndLE,
        takeWhileEndLE,
139 140 141 142 143
        equating,
        comparing,
        isInfixOf,
        intercalate,
        lowercase,
144 145 146 147
        listUnion,
        listUnionRight,
        ordNub,
        ordNubRight,
148
        safeTail,
ttuegel's avatar
ttuegel committed
149
        unintersperse,
150
        wrapText,
151
        wrapLine,
152 153

        -- * FilePath stuff
154 155
        isAbsoluteOnAnyPlatform,
        isRelativeOnAnyPlatform,
156 157
  ) where

158 159 160
import Prelude ()
import Distribution.Compat.Prelude

161
import Distribution.Text
162
import Distribution.Utils.String
163 164 165 166 167 168 169
import Distribution.Package
import Distribution.ModuleName as ModuleName
import Distribution.System
import Distribution.Version
import Distribution.Compat.CopyFile
import Distribution.Compat.Internal.TempFile
import Distribution.Compat.Exception
170
import Distribution.Compat.Stack
171 172
import Distribution.Verbosity

Edward Z. Yang's avatar
Edward Z. Yang committed
173
#if __GLASGOW_HASKELL__ < 711
174
#ifdef VERSION_base
Edward Z. Yang's avatar
Edward Z. Yang committed
175 176 177
#define BOOTSTRAPPED_CABAL 1
#endif
#else
Edward Z. Yang's avatar
Edward Z. Yang committed
178
#ifdef CURRENT_PACKAGE_KEY
Edward Z. Yang's avatar
Edward Z. Yang committed
179 180 181 182 183
#define BOOTSTRAPPED_CABAL 1
#endif
#endif

#ifdef BOOTSTRAPPED_CABAL
184 185 186
import qualified Paths_Cabal (version)
#endif

187 188
import Control.Concurrent.MVar
    ( newEmptyMVar, putMVar, takeMVar )
189
import Data.Bits
190
    ( Bits((.|.), (.&.), shiftL, shiftR) )
191
import Data.List
192
    ( isInfixOf )
193 194
import Data.Typeable
    ( cast )
195 196
import Data.Ord
    ( comparing )
197 198
import qualified Data.ByteString.Lazy as BS
import qualified Data.ByteString.Lazy.Char8 as BS.Char8
199
import qualified Data.Set as Set
200

Oleg Grenrus's avatar
Oleg Grenrus committed
201 202
import qualified Data.ByteString as SBS

203
import System.Directory
refold's avatar
refold committed
204
    ( Permissions(executable), getDirectoryContents, getPermissions
205 206
    , doesDirectoryExist, doesFileExist, removeFile, findExecutable
    , getModificationTime )
207
import System.Environment
208
    ( getProgName )
209 210 211
import System.Exit
    ( exitWith, ExitCode(..) )
import System.FilePath
212
    ( normalise, (</>), (<.>)
213
    , getSearchPath, joinPath, takeDirectory, splitFileName
214 215
    , splitExtension, splitExtensions, splitDirectories
    , searchPathSeparator )
216
import System.Directory
217
    ( createDirectory, renameFile, removeDirectoryRecursive )
218
import System.IO
219
    ( Handle, openFile, openBinaryFile, openBinaryTempFileWithDefaultPermissions
220
    , IOMode(ReadMode), hSetBinaryMode
221
    , hGetContents, stderr, stdout, hPutStr, hFlush, hClose )
222
import System.IO.Error as IO.Error
223 224
    ( isDoesNotExistError, isAlreadyExistsError
    , ioeSetFileName, ioeGetFileName, ioeGetErrorString )
Duncan Coutts's avatar
Duncan Coutts committed
225 226
import System.IO.Error
    ( ioeSetLocation, ioeGetLocation )
227 228
import System.IO.Unsafe
    ( unsafeInterleaveIO )
229
import qualified Control.Exception as Exception
230

231
import Control.Exception (IOException, evaluate, throwIO)
232
import Control.Concurrent (forkIO)
233 234 235
import qualified System.Process as Process
         ( CreateProcess(..), StdStream(..), proc)
import System.Process
236
         ( ProcessHandle, createProcess, rawSystem, runInteractiveProcess
237
         , showCommandForUser, waitForProcess)
238

239 240
-- We only get our own version number when we're building with ourselves
cabalVersion :: Version
Edward Z. Yang's avatar
Edward Z. Yang committed
241
#if defined(BOOTSTRAPPED_CABAL)
242
cabalVersion = mkVersion' Paths_Cabal.version
243
#elif defined(CABAL_VERSION)
244
cabalVersion = mkVersion [CABAL_VERSION]
245
#else
246
cabalVersion = mkVersion [1,9999]  --used when bootstrapping
247 248
#endif

249 250
-- ----------------------------------------------------------------------------
-- Exception and logging utils
ijones's avatar
ijones committed
251

252 253
dieWithLocation :: FilePath -> Maybe Int -> String -> IO a
dieWithLocation filename lineno msg =
254 255 256 257 258 259
  ioError . setLocation lineno
          . flip ioeSetFileName (normalise filename)
          $ userError msg
  where
    setLocation Nothing  err = err
    setLocation (Just n) err = ioeSetLocation err (show n)
260
    _ = callStack -- TODO: Attach CallStack to exception
simonmar's avatar
simonmar committed
261 262

die :: String -> IO a
263
die msg = ioError (userError msg)
264 265
  where
    _ = callStack -- TODO: Attach CallStack to exception
266

267
topHandlerWith :: forall a. (Exception.SomeException -> IO a) -> IO a -> IO a
Edsko de Vries's avatar
Edsko de Vries committed
268 269 270
topHandlerWith cont prog =
    Exception.catches prog [
        Exception.Handler rethrowAsyncExceptions
271
      , Exception.Handler rethrowExitStatus
Edsko de Vries's avatar
Edsko de Vries committed
272 273
      , Exception.Handler handle
      ]
274
  where
Edsko de Vries's avatar
Edsko de Vries committed
275
    -- Let async exceptions rise to the top for the default top-handler
276 277
    rethrowAsyncExceptions :: Exception.AsyncException -> NoCallStackIO a
    rethrowAsyncExceptions a = throwIO a
Edsko de Vries's avatar
Edsko de Vries committed
278

279
    -- ExitCode gets thrown asynchronously too, and we don't want to print it
280
    rethrowExitStatus :: ExitCode -> NoCallStackIO a
281 282 283
    rethrowExitStatus = throwIO

    -- Print all other exceptions
284
    handle :: Exception.SomeException -> NoCallStackIO a
285
    handle se = do
286 287
      hFlush stdout
      pname <- getProgName
288
      hPutStr stderr (wrapText (message pname se))
289 290 291 292 293 294 295 296 297 298
      cont se

    message :: String -> Exception.SomeException -> String
    message pname (Exception.SomeException se) =
      case cast se :: Maybe Exception.IOException of
        Just ioe ->
          let file         = case ioeGetFileName ioe of
                               Nothing   -> ""
                               Just path -> path ++ location ++ ": "
              location     = case ioeGetLocation ioe of
299
                               l@(n:_) | isDigit n -> ':' : l
300 301
                               _                        -> ""
              detail       = ioeGetErrorString ioe
302
          in pname ++ ": " ++ file ++ detail
303 304 305 306 307 308
        Nothing ->
#if __GLASGOW_HASKELL__ < 710
          show se
#else
          Exception.displayException se
#endif
simonmar's avatar
simonmar committed
309

310 311 312
topHandler :: IO a -> IO a
topHandler prog = topHandlerWith (const $ exitWith (ExitFailure 1)) prog

313
-- | Print out a call site/stack according to 'Verbosity'.
314
hPutCallStackPrefix :: Handle -> Verbosity -> IO ()
315 316 317 318 319 320
hPutCallStackPrefix h verbosity = withFrozenCallStack $ do
  when (isVerboseCallSite verbosity) $
    hPutStr h parentSrcLocPrefix
  when (isVerboseCallStack verbosity) $
    hPutStr h ("----\n" ++ prettyCallStack callStack ++ "\n")

321 322 323 324 325 326 327 328
-- | This can be used to help produce formatted messages as part of a fatal
-- error condition, prior to using 'die' or 'exitFailure'.
--
-- For fatal conditions we normally simply use 'die' which throws an
-- exception. Sometimes however 'die' is not sufficiently flexible to
-- produce the desired output.
--
-- Like 'die', these messages are always displayed on @stderr@, irrespective
329 330
-- of the 'Verbosity' level. The 'Verbosity' parameter is needed though to
-- decide how to format the output (e.g. line-wrapping).
331
--
332 333
dieMsg :: Verbosity -> String -> NoCallStackIO ()
dieMsg verbosity msg = do
334
    hFlush stdout
335
    hPutStr stderr (wrapTextVerbosity verbosity msg)
336 337 338 339 340 341 342 343

-- | As 'dieMsg' but with pre-formatted text.
--
dieMsgNoWrap :: String -> NoCallStackIO ()
dieMsgNoWrap msg = do
    hFlush stdout
    hPutStr stderr msg

344 345 346 347
-- | Non fatal conditions that may be indicative of an error or problem.
--
-- We display these at the 'normal' verbosity level.
--
348
warn :: Verbosity -> String -> IO ()
349
warn verbosity msg = withFrozenCallStack $ do
350 351
  when (verbosity >= normal) $ do
    hFlush stdout
352
    hPutCallStackPrefix stderr verbosity
353
    hPutStr stderr (wrapTextVerbosity verbosity ("Warning: " ++ msg))
354 355 356 357 358 359 360 361

-- | Useful status messages.
--
-- We display these at the 'normal' verbosity level.
--
-- This is for the ordinary helpful status messages that users see. Just
-- enough information to know that things are working but not floods of detail.
--
362
notice :: Verbosity -> String -> IO ()
363 364 365
notice verbosity msg = withFrozenCallStack $ do
  when (verbosity >= normal) $ do
    hPutCallStackPrefix stdout verbosity
366
    putStr (wrapTextVerbosity verbosity msg)
367

368
noticeNoWrap :: Verbosity -> String -> IO ()
369 370 371
noticeNoWrap verbosity msg = withFrozenCallStack $ do
  when (verbosity >= normal) $ do
    hPutCallStackPrefix stdout verbosity
372 373
    putStr msg

374
setupMessage :: Verbosity -> String -> PackageIdentifier -> IO ()
375
setupMessage verbosity msg pkgid = withFrozenCallStack $ do
376
    notice verbosity (msg ++ ' ': display pkgid ++ "...")
377

378
-- | More detail on the operation of some action.
379
--
380 381
-- We display these messages when the verbosity level is 'verbose'
--
382
info :: Verbosity -> String -> IO ()
383 384 385
info verbosity msg = withFrozenCallStack $
  when (verbosity >= verbose) $ do
    hPutCallStackPrefix stdout verbosity
386
    putStr (wrapTextVerbosity verbosity msg)
387 388 389 390 391

-- | Detailed internal debugging information
--
-- We display these messages when the verbosity level is 'deafening'
--
392
debug :: Verbosity -> String -> IO ()
393
debug verbosity msg = withFrozenCallStack $
394
  when (verbosity >= deafening) $ do
395
    hPutCallStackPrefix stdout verbosity
396
    putStr (wrapTextVerbosity verbosity msg)
397
    hFlush stdout
398

399 400
-- | A variant of 'debug' that doesn't perform the automatic line
-- wrapping. Produces better output in some cases.
401
debugNoWrap :: Verbosity -> String -> IO ()
402
debugNoWrap verbosity msg = withFrozenCallStack $
403
  when (verbosity >= deafening) $ do
404
    hPutCallStackPrefix stdout verbosity
405 406 407
    putStrLn msg
    hFlush stdout

408 409 410 411 412 413
-- | Perform an IO action, catching any IO exceptions and printing an error
--   if one occurs.
chattyTry :: String  -- ^ a description of the action we were attempting
          -> IO ()   -- ^ the action itself
          -> IO ()
chattyTry desc action =
414
  catchIO action $ \exception ->
415
    putStrLn $ "Error while " ++ desc ++ ": " ++ show exception
416

417 418
-- | Run an IO computation, returning @e@ if it raises a "file
-- does not exist" error.
419
handleDoesNotExist :: a -> NoCallStackIO a -> NoCallStackIO a
420 421 422 423 424
handleDoesNotExist e =
    Exception.handleJust
      (\ioe -> if isDoesNotExistError ioe then Just ioe else Nothing)
      (\_ -> return e)

425 426 427
-- -----------------------------------------------------------------------------
-- Helper functions

428 429
-- | Wraps text to the default line width. Existing newlines are preserved.
wrapText :: String -> String
430
wrapText = unlines
431 432 433 434
         . map (intercalate "\n"
              . map unwords
              . wrapLine 79
              . words)
435
         . lines
436

437 438 439 440 441 442
-- | Wraps text unless the @+nowrap@ verbosity flag is active
wrapTextVerbosity :: Verbosity -> String -> String
wrapTextVerbosity verb
  | isVerboseNoWrap verb = unlines . lines -- makes sure there's a trailing LF
  | otherwise            = wrapText

443 444 445
-- | Wraps a list of words to a list of lines of words of a particular width.
wrapLine :: Int -> [String] -> [[String]]
wrapLine width = wrap 0 []
446 447 448 449 450 451 452 453 454 455 456 457 458
  where wrap :: Int -> [String] -> [String] -> [[String]]
        wrap 0   []   (w:ws)
          | length w + 1 > width
          = wrap (length w) [w] ws
        wrap col line (w:ws)
          | col + length w + 1 > width
          = reverse line : wrap 0 [] (w:ws)
        wrap col line (w:ws)
          = let col' = col + length w + 1
             in wrap col' (w:line) ws
        wrap _ []   [] = []
        wrap _ line [] = [reverse line]

simonmar's avatar
simonmar committed
459 460 461 462 463
-- -----------------------------------------------------------------------------
-- rawSystem variants
maybeExit :: IO ExitCode -> IO ()
maybeExit cmd = do
  res <- cmd
464
  unless (res == ExitSuccess) $ exitWith res
simonmar's avatar
simonmar committed
465

466
printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO ()
467
printRawCommandAndArgs verbosity path args = withFrozenCallStack $
Neil Vice's avatar
Neil Vice committed
468
    printRawCommandAndArgsAndEnv verbosity path args Nothing
Ian Lynagh's avatar
Ian Lynagh committed
469

470 471
printRawCommandAndArgsAndEnv :: Verbosity
                             -> FilePath
472
                             -> [String]
Neil Vice's avatar
Neil Vice committed
473
                             -> Maybe [(String, String)]
474
                             -> IO ()
Neil Vice's avatar
Neil Vice committed
475 476
printRawCommandAndArgsAndEnv verbosity path args menv
 | verbosity >= deafening = do
477
       traverse_ (putStrLn . ("Environment: " ++) . show) menv
478
       hPutCallStackPrefix stdout verbosity
Neil Vice's avatar
Neil Vice committed
479
       print (path, args)
480 481 482
 | verbosity >= verbose   = do
    hPutCallStackPrefix stdout verbosity
    putStrLn $ showCommandForUser path args
483 484
 | otherwise              = return ()

485

Ian D. Bollinger's avatar
Ian D. Bollinger committed
486
-- Exit with the same exit code if the subcommand fails
487
rawSystemExit :: Verbosity -> FilePath -> [String] -> IO ()
488
rawSystemExit verbosity path args = withFrozenCallStack $ do
Ian Lynagh's avatar
Ian Lynagh committed
489
  printRawCommandAndArgs verbosity path args
490
  hFlush stdout
491 492 493 494
  exitcode <- rawSystem path args
  unless (exitcode == ExitSuccess) $ do
    debug verbosity $ path ++ " returned " ++ show exitcode
    exitWith exitcode
simonmar's avatar
simonmar committed
495

496
rawSystemExitCode :: Verbosity -> FilePath -> [String] -> IO ExitCode
497
rawSystemExitCode verbosity path args = withFrozenCallStack $ do
tibbe's avatar
tibbe committed
498 499 500 501 502 503 504
  printRawCommandAndArgs verbosity path args
  hFlush stdout
  exitcode <- rawSystem path args
  unless (exitcode == ExitSuccess) $ do
    debug verbosity $ path ++ " returned " ++ show exitcode
  return exitcode

505 506
rawSystemExitWithEnv :: Verbosity
                     -> FilePath
507 508
                     -> [String]
                     -> [(String, String)]
509
                     -> IO ()
510
rawSystemExitWithEnv verbosity path args env = withFrozenCallStack $ do
Neil Vice's avatar
Neil Vice committed
511
    printRawCommandAndArgsAndEnv verbosity path args (Just env)
512
    hFlush stdout
513 514
    (_,_,_,ph) <- createProcess $
                  (Process.proc path args) { Process.env = (Just env)
Edward Z. Yang's avatar
Edward Z. Yang committed
515 516
#ifdef MIN_VERSION_process
#if MIN_VERSION_process(1,2,0)
517 518 519
-- delegate_ctlc has been added in process 1.2, and we still want to be able to
-- bootstrap GHC on systems not having that version
                                           , Process.delegate_ctlc = True
Edward Z. Yang's avatar
Edward Z. Yang committed
520
#endif
521 522
#endif
                                           }
523
    exitcode <- waitForProcess ph
524 525 526 527
    unless (exitcode == ExitSuccess) $ do
        debug verbosity $ path ++ " returned " ++ show exitcode
        exitWith exitcode

528
-- Closes the passed in handles before returning.
529 530
rawSystemIOWithEnv :: Verbosity
                   -> FilePath
531
                   -> [String]
532 533
                   -> Maybe FilePath           -- ^ New working dir or inherit
                   -> Maybe [(String, String)] -- ^ New environment or inherit
534 535 536
                   -> Maybe Handle  -- ^ stdin
                   -> Maybe Handle  -- ^ stdout
                   -> Maybe Handle  -- ^ stderr
537
                   -> IO ExitCode
538
rawSystemIOWithEnv verbosity path args mcwd menv inp out err = withFrozenCallStack $ do
539 540 541 542 543 544 545 546 547 548
    (_,_,_,ph) <- createProcessWithEnv verbosity path args mcwd menv
                                       (mbToStd inp) (mbToStd out) (mbToStd err)
    exitcode <- waitForProcess ph
    unless (exitcode == ExitSuccess) $ do
      debug verbosity $ path ++ " returned " ++ show exitcode
    return exitcode
  where
    mbToStd :: Maybe Handle -> Process.StdStream
    mbToStd = maybe Process.Inherit Process.UseHandle

Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
549
createProcessWithEnv ::
550 551
     Verbosity
  -> FilePath
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
552 553 554 555 556 557
  -> [String]
  -> Maybe FilePath           -- ^ New working dir or inherit
  -> Maybe [(String, String)] -- ^ New environment or inherit
  -> Process.StdStream  -- ^ stdin
  -> Process.StdStream  -- ^ stdout
  -> Process.StdStream  -- ^ stderr
558
  -> IO (Maybe Handle, Maybe Handle, Maybe Handle,ProcessHandle)
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
559 560
  -- ^ Any handles created for stdin, stdout, or stderr
  -- with 'CreateProcess', and a handle to the process.
561
createProcessWithEnv verbosity path args mcwd menv inp out err = withFrozenCallStack $ do
Neil Vice's avatar
Neil Vice committed
562
    printRawCommandAndArgsAndEnv verbosity path args menv
563
    hFlush stdout
564 565 566 567 568 569 570
    (inp', out', err', ph) <- createProcess $
                                (Process.proc path args) {
                                    Process.cwd           = mcwd
                                  , Process.env           = menv
                                  , Process.std_in        = inp
                                  , Process.std_out       = out
                                  , Process.std_err       = err
Edward Z. Yang's avatar
Edward Z. Yang committed
571 572
#ifdef MIN_VERSION_process
#if MIN_VERSION_process(1,2,0)
573 574
-- delegate_ctlc has been added in process 1.2, and we still want to be able to
-- bootstrap GHC on systems not having that version
575
                                  , Process.delegate_ctlc = True
Edward Z. Yang's avatar
Edward Z. Yang committed
576
#endif
577
#endif
578 579
                                  }
    return (inp', out', err', ph)
580

581 582
-- | Run a command and return its output.
--
583
-- The output is assumed to be text in the locale encoding.
584
--
585
rawSystemStdout :: Verbosity -> FilePath -> [String] -> IO String
586
rawSystemStdout verbosity path args = withFrozenCallStack $ do
587
  (output, errors, exitCode) <- rawSystemStdInOut verbosity path args
588
                                                  Nothing Nothing
589 590 591
                                                  Nothing False
  when (exitCode /= ExitSuccess) $
    die errors
592 593
  return output

594 595 596 597
-- | Run a command and return its output, errors and exit status. Optionally
-- also supply some input. Also provides control over whether the binary/text
-- mode of the input and output.
--
598 599
rawSystemStdInOut :: Verbosity
                  -> FilePath                 -- ^ Program location
600 601 602 603 604
                  -> [String]                 -- ^ Arguments
                  -> Maybe FilePath           -- ^ New working dir or inherit
                  -> Maybe [(String, String)] -- ^ New environment or inherit
                  -> Maybe (String, Bool)     -- ^ input text and binary mode
                  -> Bool                     -- ^ output in binary mode
605
                  -> IO (String, String, ExitCode) -- ^ output, errors, exit
606
rawSystemStdInOut verbosity path args mcwd menv input outputBinary = withFrozenCallStack $ do
Ian Lynagh's avatar
Ian Lynagh committed
607
  printRawCommandAndArgs verbosity path args
608

609
  Exception.bracket
610
     (runInteractiveProcess path args mcwd menv)
611
     (\(inh,outh,errh,_) -> hClose inh >> hClose outh >> hClose errh)
612
    $ \(inh,outh,errh,pid) -> do
613

614 615 616 617
      -- output mode depends on what the caller wants
      hSetBinaryMode outh outputBinary
      -- but the errors are always assumed to be text (in the current locale)
      hSetBinaryMode errh False
618

619
      -- fork off a couple threads to pull on the stderr and stdout
620
      -- so if the process writes to stderr we do not block.
621

622
      err <- hGetContents errh
623
      out <- hGetContents outh
624

625
      mv <- newEmptyMVar
626 627 628
      let force str = do
            mberr <- Exception.try (evaluate (length str) >> return ())
            putMVar mv (mberr :: Either IOError ())
629 630
      _ <- forkIO $ force out
      _ <- forkIO $ force err
631 632 633 634 635 636 637 638 639 640 641 642 643

      -- push all the input, if any
      case input of
        Nothing -> return ()
        Just (inputStr, inputBinary) -> do
                -- input mode depends on what the caller wants
          hSetBinaryMode inh inputBinary
          hPutStr inh inputStr
          hClose inh
          --TODO: this probably fails if the process refuses to consume
          -- or if it closes stdin (eg if it exits)

      -- wait for both to finish, in either order
644 645
      mberr1 <- takeMVar mv
      mberr2 <- takeMVar mv
646 647 648

      -- wait for the program to terminate
      exitcode <- waitForProcess pid
649 650 651 652
      unless (exitcode == ExitSuccess) $
        debug verbosity $ path ++ " returned " ++ show exitcode
                       ++ if null err then "" else
                          " with error message:\n" ++ err
653 654 655 656
                       ++ case input of
                            Nothing       -> ""
                            Just ("",  _) -> ""
                            Just (inp, _) -> "\nstdin input:\n" ++ inp
657

658 659 660 661 662
      -- Check if we we hit an exception while consuming the output
      -- (e.g. a text decoding error)
      reportOutputIOError mberr1
      reportOutputIOError mberr2

663
      return (out, err, exitcode)
664
  where
665
    reportOutputIOError :: Either IOError () -> NoCallStackIO ()
666 667 668
    reportOutputIOError =
      either (\e -> throwIO (ioeSetFileName e ("output of " ++ path)))
             return
669 670


671 672
{-# DEPRECATED findProgramLocation
    "No longer used within Cabal, try findProgramOnSearchPath" #-}
673
-- | Look for a program on the path.
674
findProgramLocation :: Verbosity -> FilePath -> IO (Maybe FilePath)
675
findProgramLocation verbosity prog = withFrozenCallStack $ do
676 677 678 679 680 681 682 683 684 685 686 687 688 689 690
  debug verbosity $ "searching for " ++ prog ++ " in path."
  res <- findExecutable prog
  case res of
      Nothing   -> debug verbosity ("Cannot find " ++ prog ++ " on the path")
      Just path -> debug verbosity ("found " ++ prog ++ " at "++ path)
  return res


-- | Look for a program and try to find it's version number. It can accept
-- either an absolute path or the name of a program binary, in which case we
-- will look for the program on the path.
--
findProgramVersion :: String             -- ^ version args
                   -> (String -> String) -- ^ function to select version
                                         --   number from program output
691 692 693
                   -> Verbosity
                   -> FilePath           -- ^ location
                   -> IO (Maybe Version)
694
findProgramVersion versionArg selectVersion verbosity path = withFrozenCallStack $ do
695 696 697 698 699 700 701 702 703 704 705 706
  str <- rawSystemStdout verbosity path [versionArg]
         `catchIO`   (\_ -> return "")
         `catchExit` (\_ -> return "")
  let version :: Maybe Version
      version = simpleParse (selectVersion str)
  case version of
      Nothing -> warn verbosity $ "cannot determine version of " ++ path
                               ++ " :\n" ++ show str
      Just v  -> debug verbosity $ path ++ " is version " ++ display v
  return version


Ian D. Bollinger's avatar
Ian D. Bollinger committed
707
-- | Like the Unix xargs program. Useful for when we've got very long command
708 709 710 711
-- 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.
--
-- Use it with either of the rawSystem variants above. For example:
712
--
713
-- > xargs (32*1024) (rawSystemExit verbosity) prog fixedArgs bigArgs
714
--
715 716 717
xargs :: Int -> ([String] -> IO ())
      -> [String] -> [String] -> IO ()
xargs maxSize rawSystemFun fixedArgs bigArgs =
718
  let fixedArgSize = sum (map length fixedArgs) + length fixedArgs
719
      chunkSize = maxSize - fixedArgSize
720
   in traverse_ (rawSystemFun . (fixedArgs ++)) (chunks chunkSize bigArgs)
721 722 723 724 725

  where chunks len = unfoldr $ \s ->
          if null s then Nothing
                    else Just (chunk [] len s)

Ian Lynagh's avatar
Ian Lynagh committed
726
        chunk acc _   []     = (reverse acc,[])
727 728 729 730
        chunk acc len (s:ss)
          | len' < len = chunk (s:acc) (len-len'-1) ss
          | otherwise  = (reverse acc, s:ss)
          where len' = length s
ijones's avatar
ijones committed
731 732 733 734 735

-- ------------------------------------------------------------
-- * File Utilities
-- ------------------------------------------------------------

736 737 738 739 740
----------------
-- Finding files

-- | Find a file by looking in a search path. The file path must match exactly.
--
ijones's avatar
ijones committed
741 742 743
findFile :: [FilePath]    -- ^search locations
         -> FilePath      -- ^File Name
         -> IO FilePath
744 745 746 747 748 749
findFile searchPath fileName =
  findFirstFile id
    [ path </> fileName
    | path <- nub searchPath]
  >>= maybe (die $ fileName ++ " doesn't exist") return

750 751 752 753
-- | Find a file by looking in a search path with one of a list of possible
-- file extensions. The file base name should be given and it will be tried
-- with each of the extensions in each element of the search path.
--
754 755 756
findFileWithExtension :: [String]
                      -> [FilePath]
                      -> FilePath
757
                      -> NoCallStackIO (Maybe FilePath)
758 759 760 761 762 763
findFileWithExtension extensions searchPath baseName =
  findFirstFile id
    [ path </> baseName <.> ext
    | path <- nub searchPath
    , ext <- nub extensions ]

764 765 766
findAllFilesWithExtension :: [String]
                          -> [FilePath]
                          -> FilePath
767
                          -> NoCallStackIO [FilePath]
768 769 770 771 772 773
findAllFilesWithExtension extensions searchPath basename =
  findAllFiles id
    [ path </> basename <.> ext
    | path <- nub searchPath
    , ext <- nub extensions ]

774 775 776
-- | Like 'findFileWithExtension' but returns which element of the search path
-- the file was found in, and the file path relative to that base directory.
--
777 778 779
findFileWithExtension' :: [String]
                       -> [FilePath]
                       -> FilePath
780
                       -> NoCallStackIO (Maybe (FilePath, FilePath))
781 782 783 784 785 786
findFileWithExtension' extensions searchPath baseName =
  findFirstFile (uncurry (</>))
    [ (path, baseName <.> ext)
    | path <- nub searchPath
    , ext <- nub extensions ]