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

8 9 10
-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Simple.Utils
ijones's avatar
ijones committed
11
-- Copyright   :  Isaac Jones, Simon Marlow 2003-2004
12
-- License     :  BSD3
Duncan Coutts's avatar
Duncan Coutts committed
13
--                portions Copyright (c) 2007, Galois Inc.
14
--
Duncan Coutts's avatar
Duncan Coutts committed
15
-- Maintainer  :  cabal-devel@haskell.org
ijones's avatar
ijones committed
16
-- Portability :  portable
17
--
Duncan Coutts's avatar
Duncan Coutts committed
18 19 20 21 22
-- 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.
23 24

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

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

38 39 40
        -- * exceptions
        handleDoesNotExist,

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

        -- * copying files
55
        smartCopySources,
56
        createDirectoryIfMissingVerbose,
57
        copyFileVerbose,
58
        copyDirectoryRecursiveVerbose,
59
        copyFiles,
refold's avatar
refold committed
60
        copyFileTo,
61

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

72
        -- * File permissions
73
        doesExecutableExist,
74 75 76
        setFileOrdinary,
        setFileExecutable,

77
        -- * file names
ijones's avatar
ijones committed
78
        currentDir,
79
        shortRelativePath,
80 81
        dropExeExtension,
        exeExtensions,
82 83

        -- * finding files
84
        findFile,
85
        findFirstFile,
86 87
        findFileWithExtension,
        findFileWithExtension',
88
        findAllFilesWithExtension,
89 90 91
        findModuleFile,
        findModuleFiles,
        getDirectoryContentsRecursive,
92

93 94
        -- * environment variables
        isInSearchPath,
95
        addLibraryPath,
96

97 98
        -- * simple file globbing
        matchFileGlob,
Ian Lynagh's avatar
Ian Lynagh committed
99
        matchDirFileGlob,
100 101
        parseFileGlob,
        FileGlob(..),
102

103 104
        -- * modification time
        moreRecentFile,
105
        existsAndIsMoreRecentThan,
106

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

        -- * .cabal and .buildinfo files
113 114
        defaultPackageDesc,
        findPackageDesc,
115
        tryFindPackageDesc,
116 117
        defaultHookedPackageDesc,
        findHookedPackageDesc,
118

119 120 121
        -- * reading and writing files safely
        withFileContents,
        writeFileAtomic,
122
        rewriteFile,
123

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

Oleg Grenrus's avatar
Oleg Grenrus committed
134 135 136
        -- * BOM
        startsWithBOM,
        fileHasBOM,
137
        ignoreBOM,
Oleg Grenrus's avatar
Oleg Grenrus committed
138

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

        -- * FilePath stuff
158 159
        isAbsoluteOnAnyPlatform,
        isRelativeOnAnyPlatform,
160 161
  ) where

162 163 164
import Prelude ()
import Distribution.Compat.Prelude

165
import Distribution.Text
166 167
import Distribution.Utils.Generic
import Distribution.Package
168 169 170 171 172 173
import Distribution.ModuleName as ModuleName
import Distribution.System
import Distribution.Version
import Distribution.Compat.CopyFile
import Distribution.Compat.Internal.TempFile
import Distribution.Compat.Exception
174
import Distribution.Compat.Stack
175 176
import Distribution.Verbosity

Edward Z. Yang's avatar
Edward Z. Yang committed
177
#if __GLASGOW_HASKELL__ < 711
178
#ifdef VERSION_base
Edward Z. Yang's avatar
Edward Z. Yang committed
179 180 181
#define BOOTSTRAPPED_CABAL 1
#endif
#else
Edward Z. Yang's avatar
Edward Z. Yang committed
182
#ifdef CURRENT_PACKAGE_KEY
Edward Z. Yang's avatar
Edward Z. Yang committed
183 184 185 186 187
#define BOOTSTRAPPED_CABAL 1
#endif
#endif

#ifdef BOOTSTRAPPED_CABAL
188 189 190
import qualified Paths_Cabal (version)
#endif

191 192
import Control.Concurrent.MVar
    ( newEmptyMVar, putMVar, takeMVar )
193 194
import Data.Typeable
    ( cast )
195
import qualified Data.ByteString.Lazy.Char8 as BS.Char8
Oleg Grenrus's avatar
Oleg Grenrus committed
196

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

224
import Control.Exception (IOException, evaluate, throwIO)
225
import Control.Concurrent (forkIO)
226 227 228
import qualified System.Process as Process
         ( CreateProcess(..), StdStream(..), proc)
import System.Process
229
         ( ProcessHandle, createProcess, rawSystem, runInteractiveProcess
230
         , showCommandForUser, waitForProcess)
231

232 233
import qualified Text.PrettyPrint as Disp

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

244 245
-- ----------------------------------------------------------------------------
-- Exception and logging utils
ijones's avatar
ijones committed
246

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

die :: String -> IO a
258
die msg = ioError (userError msg)
259 260
  where
    _ = callStack -- TODO: Attach CallStack to exception
261

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

274
    -- ExitCode gets thrown asynchronously too, and we don't want to print it
275
    rethrowExitStatus :: ExitCode -> NoCallStackIO a
276 277 278
    rethrowExitStatus = throwIO

    -- Print all other exceptions
279
    handle :: Exception.SomeException -> NoCallStackIO a
280
    handle se = do
281 282
      hFlush stdout
      pname <- getProgName
283
      hPutStr stderr (wrapText (message pname se))
284 285 286 287 288 289 290 291 292 293
      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
294
                               l@(n:_) | isDigit n -> ':' : l
295 296
                               _                        -> ""
              detail       = ioeGetErrorString ioe
297
          in pname ++ ": " ++ file ++ detail
298 299 300 301 302 303
        Nothing ->
#if __GLASGOW_HASKELL__ < 710
          show se
#else
          Exception.displayException se
#endif
simonmar's avatar
simonmar committed
304

305 306 307
topHandler :: IO a -> IO a
topHandler prog = topHandlerWith (const $ exitWith (ExitFailure 1)) prog

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

316 317 318 319 320 321 322 323
-- | 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
324 325
-- of the 'Verbosity' level. The 'Verbosity' parameter is needed though to
-- decide how to format the output (e.g. line-wrapping).
326
--
327 328
dieMsg :: Verbosity -> String -> NoCallStackIO ()
dieMsg verbosity msg = do
329
    hFlush stdout
330
    hPutStr stderr (wrapTextVerbosity verbosity msg)
331 332 333 334 335 336 337 338

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

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

-- | 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.
--
357
notice :: Verbosity -> String -> IO ()
358 359 360
notice verbosity msg = withFrozenCallStack $ do
  when (verbosity >= normal) $ do
    hPutCallStackPrefix stdout verbosity
361
    putStr (wrapTextVerbosity verbosity msg)
362

363
noticeNoWrap :: Verbosity -> String -> IO ()
364 365 366
noticeNoWrap verbosity msg = withFrozenCallStack $ do
  when (verbosity >= normal) $ do
    hPutCallStackPrefix stdout verbosity
367 368
    putStr msg

369 370 371 372 373 374 375 376 377
-- | Pretty-print a 'Disp.Doc' status message at 'normal' verbosity
-- level.  Use this if you need fancy formatting.
--
noticeDoc :: Verbosity -> Disp.Doc -> IO ()
noticeDoc verbosity msg = withFrozenCallStack $ do
  when (verbosity >= normal) $ do
    hPutCallStackPrefix stdout verbosity
    putStrLn (Disp.renderStyle defaultStyle msg)

378
setupMessage :: Verbosity -> String -> PackageIdentifier -> IO ()
379
setupMessage verbosity msg pkgid = withFrozenCallStack $ do
380
    noticeNoWrap verbosity (msg ++ ' ': display pkgid ++ "...\n")
381

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

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

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

412 413 414 415 416 417
-- | 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 =
418
  catchIO action $ \exception ->
419
    putStrLn $ "Error while " ++ desc ++ ": " ++ show exception
420

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

429 430 431
-- -----------------------------------------------------------------------------
-- Helper functions

432 433 434 435 436 437
-- | 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

simonmar's avatar
simonmar committed
438 439 440 441 442
-- -----------------------------------------------------------------------------
-- rawSystem variants
maybeExit :: IO ExitCode -> IO ()
maybeExit cmd = do
  res <- cmd
443
  unless (res == ExitSuccess) $ exitWith res
simonmar's avatar
simonmar committed
444

445
printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO ()
446
printRawCommandAndArgs verbosity path args = withFrozenCallStack $
Neil Vice's avatar
Neil Vice committed
447
    printRawCommandAndArgsAndEnv verbosity path args Nothing
Ian Lynagh's avatar
Ian Lynagh committed
448

449 450
printRawCommandAndArgsAndEnv :: Verbosity
                             -> FilePath
451
                             -> [String]
Neil Vice's avatar
Neil Vice committed
452
                             -> Maybe [(String, String)]
453
                             -> IO ()
Neil Vice's avatar
Neil Vice committed
454 455
printRawCommandAndArgsAndEnv verbosity path args menv
 | verbosity >= deafening = do
456
       traverse_ (putStrLn . ("Environment: " ++) . show) menv
457
       hPutCallStackPrefix stdout verbosity
Neil Vice's avatar
Neil Vice committed
458
       print (path, args)
459 460 461
 | verbosity >= verbose   = do
    hPutCallStackPrefix stdout verbosity
    putStrLn $ showCommandForUser path args
462 463
 | otherwise              = return ()

464

Ian D. Bollinger's avatar
Ian D. Bollinger committed
465
-- Exit with the same exit code if the subcommand fails
466
rawSystemExit :: Verbosity -> FilePath -> [String] -> IO ()
467
rawSystemExit verbosity path args = withFrozenCallStack $ do
Ian Lynagh's avatar
Ian Lynagh committed
468
  printRawCommandAndArgs verbosity path args
469
  hFlush stdout
470 471 472 473
  exitcode <- rawSystem path args
  unless (exitcode == ExitSuccess) $ do
    debug verbosity $ path ++ " returned " ++ show exitcode
    exitWith exitcode
simonmar's avatar
simonmar committed
474

475
rawSystemExitCode :: Verbosity -> FilePath -> [String] -> IO ExitCode
476
rawSystemExitCode verbosity path args = withFrozenCallStack $ do
tibbe's avatar
tibbe committed
477 478 479 480 481 482 483
  printRawCommandAndArgs verbosity path args
  hFlush stdout
  exitcode <- rawSystem path args
  unless (exitcode == ExitSuccess) $ do
    debug verbosity $ path ++ " returned " ++ show exitcode
  return exitcode

484 485
rawSystemExitWithEnv :: Verbosity
                     -> FilePath
486 487
                     -> [String]
                     -> [(String, String)]
488
                     -> IO ()
489
rawSystemExitWithEnv verbosity path args env = withFrozenCallStack $ do
Neil Vice's avatar
Neil Vice committed
490
    printRawCommandAndArgsAndEnv verbosity path args (Just env)
491
    hFlush stdout
492 493
    (_,_,_,ph) <- createProcess $
                  (Process.proc path args) { Process.env = (Just env)
Edward Z. Yang's avatar
Edward Z. Yang committed
494 495
#ifdef MIN_VERSION_process
#if MIN_VERSION_process(1,2,0)
496 497 498
-- 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
499
#endif
500 501
#endif
                                           }
502
    exitcode <- waitForProcess ph
503 504 505 506
    unless (exitcode == ExitSuccess) $ do
        debug verbosity $ path ++ " returned " ++ show exitcode
        exitWith exitcode

507
-- Closes the passed in handles before returning.
508 509
rawSystemIOWithEnv :: Verbosity
                   -> FilePath
510
                   -> [String]
511 512
                   -> Maybe FilePath           -- ^ New working dir or inherit
                   -> Maybe [(String, String)] -- ^ New environment or inherit
513 514 515
                   -> Maybe Handle  -- ^ stdin
                   -> Maybe Handle  -- ^ stdout
                   -> Maybe Handle  -- ^ stderr
516
                   -> IO ExitCode
517
rawSystemIOWithEnv verbosity path args mcwd menv inp out err = withFrozenCallStack $ do
518 519 520 521 522 523 524 525 526 527
    (_,_,_,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
528
createProcessWithEnv ::
529 530
     Verbosity
  -> FilePath
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
531 532 533 534 535 536
  -> [String]
  -> Maybe FilePath           -- ^ New working dir or inherit
  -> Maybe [(String, String)] -- ^ New environment or inherit
  -> Process.StdStream  -- ^ stdin
  -> Process.StdStream  -- ^ stdout
  -> Process.StdStream  -- ^ stderr
537
  -> IO (Maybe Handle, Maybe Handle, Maybe Handle,ProcessHandle)
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
538 539
  -- ^ Any handles created for stdin, stdout, or stderr
  -- with 'CreateProcess', and a handle to the process.
540
createProcessWithEnv verbosity path args mcwd menv inp out err = withFrozenCallStack $ do
Neil Vice's avatar
Neil Vice committed
541
    printRawCommandAndArgsAndEnv verbosity path args menv
542
    hFlush stdout
543 544 545 546 547 548 549
    (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
550 551
#ifdef MIN_VERSION_process
#if MIN_VERSION_process(1,2,0)
552 553
-- 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
554
                                  , Process.delegate_ctlc = True
Edward Z. Yang's avatar
Edward Z. Yang committed
555
#endif
556
#endif
557 558
                                  }
    return (inp', out', err', ph)
559

560 561
-- | Run a command and return its output.
--
562
-- The output is assumed to be text in the locale encoding.
563
--
564
rawSystemStdout :: Verbosity -> FilePath -> [String] -> IO String
565
rawSystemStdout verbosity path args = withFrozenCallStack $ do
566
  (output, errors, exitCode) <- rawSystemStdInOut verbosity path args
567
                                                  Nothing Nothing
568 569 570
                                                  Nothing False
  when (exitCode /= ExitSuccess) $
    die errors
571 572
  return output

573 574 575 576
-- | 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.
--
577 578
rawSystemStdInOut :: Verbosity
                  -> FilePath                 -- ^ Program location
579 580 581 582 583
                  -> [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
584
                  -> IO (String, String, ExitCode) -- ^ output, errors, exit
585
rawSystemStdInOut verbosity path args mcwd menv input outputBinary = withFrozenCallStack $ do
Ian Lynagh's avatar
Ian Lynagh committed
586
  printRawCommandAndArgs verbosity path args
587

588
  Exception.bracket
589
     (runInteractiveProcess path args mcwd menv)
590
     (\(inh,outh,errh,_) -> hClose inh >> hClose outh >> hClose errh)
591
    $ \(inh,outh,errh,pid) -> do
592

593 594 595 596
      -- 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
597

598
      -- fork off a couple threads to pull on the stderr and stdout
599
      -- so if the process writes to stderr we do not block.
600

601
      err <- hGetContents errh
602
      out <- hGetContents outh
603

604
      mv <- newEmptyMVar
605 606 607
      let force str = do
            mberr <- Exception.try (evaluate (length str) >> return ())
            putMVar mv (mberr :: Either IOError ())
608 609
      _ <- forkIO $ force out
      _ <- forkIO $ force err
610 611 612 613 614 615 616 617 618 619 620 621 622

      -- 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
623 624
      mberr1 <- takeMVar mv
      mberr2 <- takeMVar mv
625 626 627

      -- wait for the program to terminate
      exitcode <- waitForProcess pid
628 629 630 631
      unless (exitcode == ExitSuccess) $
        debug verbosity $ path ++ " returned " ++ show exitcode
                       ++ if null err then "" else
                          " with error message:\n" ++ err
632 633 634 635
                       ++ case input of
                            Nothing       -> ""
                            Just ("",  _) -> ""
                            Just (inp, _) -> "\nstdin input:\n" ++ inp
636

637 638 639 640 641
      -- Check if we we hit an exception while consuming the output
      -- (e.g. a text decoding error)
      reportOutputIOError mberr1
      reportOutputIOError mberr2

642
      return (out, err, exitcode)
643
  where
644
    reportOutputIOError :: Either IOError () -> NoCallStackIO ()
645 646 647
    reportOutputIOError =
      either (\e -> throwIO (ioeSetFileName e ("output of " ++ path)))
             return
648 649


650 651
{-# DEPRECATED findProgramLocation
    "No longer used within Cabal, try findProgramOnSearchPath" #-}
652
-- | Look for a program on the path.
653
findProgramLocation :: Verbosity -> FilePath -> IO (Maybe FilePath)
654
findProgramLocation verbosity prog = withFrozenCallStack $ do
655 656 657 658 659 660 661 662 663 664 665 666 667 668 669
  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
670 671 672
                   -> Verbosity
                   -> FilePath           -- ^ location
                   -> IO (Maybe Version)
673
findProgramVersion versionArg selectVersion verbosity path = withFrozenCallStack $ do
674 675 676 677 678 679 680 681 682 683 684 685
  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
686
-- | Like the Unix xargs program. Useful for when we've got very long command
687 688 689 690
-- 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:
691
--
692
-- > xargs (32*1024) (rawSystemExit verbosity) prog fixedArgs bigArgs
693
--
694 695 696
xargs :: Int -> ([String] -> IO ())
      -> [String] -> [String] -> IO ()
xargs maxSize rawSystemFun fixedArgs bigArgs =
697
  let fixedArgSize = sum (map length fixedArgs) + length fixedArgs
698
      chunkSize = maxSize - fixedArgSize
699
   in traverse_ (rawSystemFun . (fixedArgs ++)) (chunks chunkSize bigArgs)
700 701 702 703 704

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

Ian Lynagh's avatar
Ian Lynagh committed
705
        chunk acc _   []     = (reverse acc,[])
706 707 708 709
        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
710 711 712 713 714

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

715 716 717 718 719
----------------
-- Finding files

-- | Find a file by looking in a search path. The file path must match exactly.
--
ijones's avatar
ijones committed
720 721 722
findFile :: [FilePath]    -- ^search locations
         -> FilePath      -- ^File Name
         -> IO FilePath
723 724 725 726 727 728
findFile searchPath fileName =
  findFirstFile id
    [ path </> fileName
    | path <- nub searchPath]
  >>= maybe (die $ fileName ++ " doesn't exist") return

729 730 731 732
-- | 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.
--
733 734 735
findFileWithExtension :: [String]
                      -> [FilePath]
                      -> FilePath
736
                      -> NoCallStackIO (Maybe FilePath)
737 738 739 740 741 742
findFileWithExtension extensions searchPath baseName =
  findFirstFile id
    [ path </> baseName <.> ext
    | path <- nub searchPath
    , ext <- nub extensions ]

743 744 745
findAllFilesWithExtension :: [String]
                          -> [FilePath]
                          -> FilePath
746
                          -> NoCallStackIO [FilePath]
747 748 749 750 751 752
findAllFilesWithExtension extensions searchPath basename =
  findAllFiles id
    [ path </> basename <.> ext
    | path <- nub searchPath
    , ext <- nub extensions ]

753 754 755
-- | Like 'findFileWithExtension' but returns which element of the search path
-- the file was found in, and the file path relative to that base directory.
--
756 757 758
findFileWithExtension' :: [String]
                       -> [FilePath]
                       -> FilePath
759
                       -> NoCallStackIO (Maybe (FilePath, FilePath))
760 761 762 763 764 765
findFileWithExtension' extensions searchPath baseName =
  findFirstFile (uncurry (</>))
    [ (path, baseName <.> ext)
    | path <- nub searchPath
    , ext <- nub extensions ]

766
findFirstFile :: (a -> FilePath) -> [a] -> NoCallStackIO (Maybe a)
767 768 769 770 771 772
findFirstFile file = findFirst
  where findFirst []     = return Nothing
        findFirst (x:xs) = do exists <- doesFileExist (file x)
                              if exists
                                then return (Just x)
                                else findFirst xs
ijones's avatar
ijones committed
773

774
findAllFiles :: (a -> FilePath) -> [a] -> NoCallStackIO [a]
775 776
findAllFiles file = filterM (doesFileExist . file)

777 778 779 780
-- | Finds the files corresponding to a list of Haskell module names.
--
-- As 'findModuleFile' but for a list of module names.
--
781 782 783 784 785
findModuleFiles :: [FilePath]   -- ^ build prefix (location of objects)
                -> [String]     -- ^ search suffixes
                -> [ModuleName] -- ^ modules
                -> IO [(FilePath, FilePath)]
findModuleFiles searchPath extensions moduleNames =
786
  traverse (findModuleFile searchPath extensions) moduleNames
787

788 789 790 791 792
-- | Find the file corresponding to a Haskell module name.
--
-- This is similar to 'findFileWithExtension'' but specialised to a module
-- name. The function fails if the file corresponding to the module is missing.
--