1{-# LANGUAGE CPP #-} 2{-# LANGUAGE GADTs #-} 3{-# LANGUAGE ScopedTypeVariables #-} 4{-# LANGUAGE FlexibleContexts #-} 5{-# LANGUAGE RankNTypes #-} 6{-# LANGUAGE DeriveGeneric #-} 7{-# LANGUAGE BangPatterns #-} 8 9----------------------------------------------------------------------------- 10-- | 11-- Module : Distribution.Simple.Utils 12-- Copyright : Isaac Jones, Simon Marlow 2003-2004 13-- License : BSD3 14-- portions Copyright (c) 2007, Galois Inc. 15-- 16-- Maintainer : cabal-devel@haskell.org 17-- Portability : portable 18-- 19-- A large and somewhat miscellaneous collection of utility functions used 20-- throughout the rest of the Cabal lib and in other tools that use the Cabal 21-- lib like @cabal-install@. It has a very simple set of logging actions. It 22-- has low level functions for running programs, a bunch of wrappers for 23-- various directory and file functions that do extra logging. 24 25module Distribution.Simple.Utils ( 26 cabalVersion, 27 28 -- * logging and errors 29 dieNoVerbosity, 30 die', dieWithLocation', 31 dieNoWrap, 32 topHandler, topHandlerWith, 33 warn, 34 notice, noticeNoWrap, noticeDoc, 35 setupMessage, 36 info, infoNoWrap, 37 debug, debugNoWrap, 38 chattyTry, 39 annotateIO, 40 printRawCommandAndArgs, printRawCommandAndArgsAndEnv, 41 withOutputMarker, 42 43 -- * exceptions 44 handleDoesNotExist, 45 46 -- * running programs 47 rawSystemExit, 48 rawSystemExitCode, 49 rawSystemExitWithEnv, 50 rawSystemStdout, 51 rawSystemStdInOut, 52 rawSystemIOWithEnv, 53 rawSystemIOWithEnvAndAction, 54 createProcessWithEnv, 55 maybeExit, 56 xargs, 57 findProgramVersion, 58 59 -- ** 'IOData' re-export 60 -- 61 -- These types are re-exported from 62 -- "Distribution.Utils.IOData" for convience as they're 63 -- exposed in the API of 'rawSystemStdInOut' 64 IOData(..), 65 KnownIODataMode (..), 66 IODataMode (..), 67 68 -- * copying files 69 createDirectoryIfMissingVerbose, 70 copyFileVerbose, 71 copyFiles, 72 copyFileTo, 73 74 -- * installing files 75 installOrdinaryFile, 76 installExecutableFile, 77 installMaybeExecutableFile, 78 installOrdinaryFiles, 79 installExecutableFiles, 80 installMaybeExecutableFiles, 81 installDirectoryContents, 82 copyDirectoryRecursive, 83 84 -- * File permissions 85 doesExecutableExist, 86 setFileOrdinary, 87 setFileExecutable, 88 89 -- * file names 90 currentDir, 91 shortRelativePath, 92 dropExeExtension, 93 exeExtensions, 94 95 -- * finding files 96 findFileEx, 97 findFileCwd, 98 findFirstFile, 99 findFileWithExtension, 100 findFileCwdWithExtension, 101 findFileWithExtension', 102 findAllFilesWithExtension, 103 findAllFilesCwdWithExtension, 104 findModuleFileEx, 105 findModuleFilesEx, 106 getDirectoryContentsRecursive, 107 108 -- * environment variables 109 isInSearchPath, 110 addLibraryPath, 111 112 -- * modification time 113 moreRecentFile, 114 existsAndIsMoreRecentThan, 115 116 -- * temp files and dirs 117 TempFileOptions(..), defaultTempFileOptions, 118 withTempFile, withTempFileEx, 119 withTempDirectory, withTempDirectoryEx, 120 createTempDirectory, 121 122 -- * .cabal and .buildinfo files 123 defaultPackageDesc, 124 findPackageDesc, 125 findPackageDescCwd, 126 tryFindPackageDesc, 127 tryFindPackageDescCwd, 128 findHookedPackageDesc, 129 130 -- * reading and writing files safely 131 withFileContents, 132 writeFileAtomic, 133 rewriteFileEx, 134 rewriteFileLBS, 135 136 -- * Unicode 137 fromUTF8BS, 138 fromUTF8LBS, 139 toUTF8BS, 140 toUTF8LBS, 141 readUTF8File, 142 withUTF8FileContents, 143 writeUTF8File, 144 normaliseLineEndings, 145 146 -- * BOM 147 ignoreBOM, 148 149 -- * generic utils 150 dropWhileEndLE, 151 takeWhileEndLE, 152 equating, 153 comparing, 154 isInfixOf, 155 intercalate, 156 lowercase, 157 listUnion, 158 listUnionRight, 159 ordNub, 160 ordNubBy, 161 ordNubRight, 162 safeHead, 163 safeTail, 164 safeLast, 165 safeInit, 166 unintersperse, 167 wrapText, 168 wrapLine, 169 170 -- * FilePath stuff 171 isAbsoluteOnAnyPlatform, 172 isRelativeOnAnyPlatform, 173 174 -- * Deprecated functions 175 findFile, 176 findModuleFile, 177 findModuleFiles, 178 ) where 179 180import Prelude () 181import Distribution.Compat.Prelude 182 183import Distribution.Utils.Generic 184import Distribution.Utils.IOData (IOData(..), IODataMode (..), KnownIODataMode (..)) 185import qualified Distribution.Utils.IOData as IOData 186import Distribution.ModuleName as ModuleName 187import Distribution.System 188import Distribution.Version 189import Distribution.Compat.Async 190import Distribution.Compat.CopyFile 191import Distribution.Compat.Internal.TempFile 192import Distribution.Compat.FilePath as FilePath 193import Distribution.Compat.Stack 194import Distribution.Verbosity 195import Distribution.Types.PackageId 196 197#if __GLASGOW_HASKELL__ < 711 198#ifdef VERSION_base 199#define BOOTSTRAPPED_CABAL 1 200#endif 201#else 202#ifdef CURRENT_PACKAGE_KEY 203#define BOOTSTRAPPED_CABAL 1 204#endif 205#endif 206 207#ifdef BOOTSTRAPPED_CABAL 208import qualified Paths_Cabal (version) 209#endif 210 211import Distribution.Pretty 212import Distribution.Parsec 213 214import Data.Typeable 215 ( cast ) 216import qualified Data.ByteString.Lazy as BS 217 218import System.Directory 219 ( Permissions(executable), getDirectoryContents, getPermissions 220 , doesDirectoryExist, doesFileExist, removeFile 221 , getModificationTime, createDirectory, removeDirectoryRecursive ) 222import System.Environment 223 ( getProgName ) 224import System.FilePath as FilePath 225 ( normalise, (</>), (<.>) 226 , getSearchPath, joinPath, takeDirectory, splitExtension 227 , splitDirectories, searchPathSeparator ) 228import System.IO 229 ( Handle, hSetBinaryMode, hGetContents, stderr, stdout, hPutStr, hFlush 230 , hClose, hSetBuffering, BufferMode(..), hPutStrLn ) 231import System.IO.Error 232import System.IO.Unsafe 233 ( unsafeInterleaveIO ) 234import qualified Control.Exception as Exception 235 236import Foreign.C.Error (Errno (..), ePIPE) 237import Data.Time.Clock.POSIX (getPOSIXTime, POSIXTime) 238import Numeric (showFFloat) 239import Distribution.Compat.Process (createProcess, rawSystem, runInteractiveProcess) 240import System.Process 241 ( ProcessHandle 242 , showCommandForUser, waitForProcess) 243import qualified System.Process as Process 244import qualified GHC.IO.Exception as GHC 245 246import qualified Text.PrettyPrint as Disp 247 248-- We only get our own version number when we're building with ourselves 249cabalVersion :: Version 250#if defined(BOOTSTRAPPED_CABAL) 251cabalVersion = mkVersion' Paths_Cabal.version 252#elif defined(CABAL_VERSION) 253cabalVersion = mkVersion [CABAL_VERSION] 254#else 255cabalVersion = mkVersion [3,0] --used when bootstrapping 256#endif 257 258-- ---------------------------------------------------------------------------- 259-- Exception and logging utils 260 261-- Cabal's logging infrastructure has a few constraints: 262-- 263-- * We must make all logging formatting and emissions decisions based 264-- on the 'Verbosity' parameter, which is the only parameter that is 265-- plumbed to enough call-sites to actually be used for this matter. 266-- (One of Cabal's "big mistakes" is to have never have defined a 267-- monad of its own.) 268-- 269-- * When we 'die', we must raise an IOError. This a backwards 270-- compatibility consideration, because that's what we've raised 271-- previously, and if we change to any other exception type, 272-- exception handlers which match on IOError will no longer work. 273-- One case where it is known we rely on IOError being catchable 274-- is 'readPkgConfigDb' in cabal-install; there may be other 275-- user code that also assumes this. 276-- 277-- * The 'topHandler' does not know what 'Verbosity' is, because 278-- it gets called before we've done command line parsing (where 279-- the 'Verbosity' parameter would come from). 280-- 281-- This leads to two big architectural choices: 282-- 283-- * Although naively we might imagine 'Verbosity' to be a simple 284-- enumeration type, actually it is a full-on abstract data type 285-- that may contain arbitrarily complex information. At the 286-- moment, it is fully representable as a string, but we might 287-- eventually also use verbosity to let users register their 288-- own logging handler. 289-- 290-- * When we call 'die', we perform all the formatting and addition 291-- of extra information we need, and then ship this in the IOError 292-- to the top-level handler. Here are alternate designs that 293-- don't work: 294-- 295-- a) Ship the unformatted info to the handler. This doesn't 296-- work because at the point the handler gets the message, 297-- we've lost call stacks, and even if we did, we don't have access 298-- to 'Verbosity' to decide whether or not to render it. 299-- 300-- b) Print the information at the 'die' site, then raise an 301-- error. This means that if the exception is subsequently 302-- caught by a handler, we will still have emitted the output, 303-- which is not the correct behavior. 304-- 305-- For the top-level handler to "know" that an error message 306-- contains one of these fully formatted packets, we set a sentinel 307-- in one of IOError's extra fields. This is handled by 308-- 'ioeSetVerbatim' and 'ioeGetVerbatim'. 309-- 310 311dieNoVerbosity :: String -> IO a 312dieNoVerbosity msg 313 = ioError (userError msg) 314 where 315 _ = callStack -- TODO: Attach CallStack to exception 316 317-- | Tag an 'IOError' whose error string should be output to the screen 318-- verbatim. 319ioeSetVerbatim :: IOError -> IOError 320ioeSetVerbatim e = ioeSetLocation e "dieVerbatim" 321 322-- | Check if an 'IOError' should be output verbatim to screen. 323ioeGetVerbatim :: IOError -> Bool 324ioeGetVerbatim e = ioeGetLocation e == "dieVerbatim" 325 326-- | Create a 'userError' whose error text will be output verbatim 327verbatimUserError :: String -> IOError 328verbatimUserError = ioeSetVerbatim . userError 329 330dieWithLocation' :: Verbosity -> FilePath -> Maybe Int -> String -> IO a 331dieWithLocation' verbosity filename mb_lineno msg = withFrozenCallStack $ do 332 ts <- getPOSIXTime 333 pname <- getProgName 334 ioError . verbatimUserError 335 . withMetadata ts AlwaysMark VerboseTrace verbosity 336 . wrapTextVerbosity verbosity 337 $ pname ++ ": " ++ 338 filename ++ (case mb_lineno of 339 Just lineno -> ":" ++ show lineno 340 Nothing -> "") ++ 341 ": " ++ msg 342 343die' :: Verbosity -> String -> IO a 344die' verbosity msg = withFrozenCallStack $ do 345 ts <- getPOSIXTime 346 pname <- getProgName 347 ioError . verbatimUserError 348 . withMetadata ts AlwaysMark VerboseTrace verbosity 349 . wrapTextVerbosity verbosity 350 $ pname ++ ": " ++ msg 351 352dieNoWrap :: Verbosity -> String -> IO a 353dieNoWrap verbosity msg = withFrozenCallStack $ do 354 -- TODO: should this have program name or not? 355 ts <- getPOSIXTime 356 ioError . verbatimUserError 357 . withMetadata ts AlwaysMark VerboseTrace verbosity 358 $ msg 359 360-- | Given a block of IO code that may raise an exception, annotate 361-- it with the metadata from the current scope. Use this as close 362-- to external code that raises IO exceptions as possible, since 363-- this function unconditionally wraps the error message with a trace 364-- (so it is NOT idempotent.) 365annotateIO :: Verbosity -> IO a -> IO a 366annotateIO verbosity act = do 367 ts <- getPOSIXTime 368 modifyIOError (f ts) act 369 where 370 f ts ioe = ioeSetErrorString ioe 371 . withMetadata ts NeverMark VerboseTrace verbosity 372 $ ioeGetErrorString ioe 373 374 375{-# NOINLINE topHandlerWith #-} 376topHandlerWith :: forall a. (Exception.SomeException -> IO a) -> IO a -> IO a 377topHandlerWith cont prog = do 378 -- By default, stderr to a terminal device is NoBuffering. But this 379 -- is *really slow* 380 hSetBuffering stderr LineBuffering 381 Exception.catches prog [ 382 Exception.Handler rethrowAsyncExceptions 383 , Exception.Handler rethrowExitStatus 384 , Exception.Handler handle 385 ] 386 where 387 -- Let async exceptions rise to the top for the default top-handler 388 rethrowAsyncExceptions :: Exception.AsyncException -> IO a 389 rethrowAsyncExceptions a = throwIO a 390 391 -- ExitCode gets thrown asynchronously too, and we don't want to print it 392 rethrowExitStatus :: ExitCode -> IO a 393 rethrowExitStatus = throwIO 394 395 -- Print all other exceptions 396 handle :: Exception.SomeException -> IO a 397 handle se = do 398 hFlush stdout 399 pname <- getProgName 400 hPutStr stderr (message pname se) 401 cont se 402 403 message :: String -> Exception.SomeException -> String 404 message pname (Exception.SomeException se) = 405 case cast se :: Maybe Exception.IOException of 406 Just ioe 407 | ioeGetVerbatim ioe -> 408 -- Use the message verbatim 409 ioeGetErrorString ioe ++ "\n" 410 | isUserError ioe -> 411 let file = case ioeGetFileName ioe of 412 Nothing -> "" 413 Just path -> path ++ location ++ ": " 414 location = case ioeGetLocation ioe of 415 l@(n:_) | isDigit n -> ':' : l 416 _ -> "" 417 detail = ioeGetErrorString ioe 418 in wrapText (pname ++ ": " ++ file ++ detail) 419 _ -> 420 displaySomeException se ++ "\n" 421 422-- | BC wrapper around 'Exception.displayException'. 423displaySomeException :: Exception.Exception e => e -> String 424displaySomeException se = 425#if __GLASGOW_HASKELL__ < 710 426 show se 427#else 428 Exception.displayException se 429#endif 430 431topHandler :: IO a -> IO a 432topHandler prog = topHandlerWith (const $ exitWith (ExitFailure 1)) prog 433 434verbosityHandle :: Verbosity -> Handle 435verbosityHandle verbosity 436 | isVerboseStderr verbosity = stderr 437 | otherwise = stdout 438 439-- | Non fatal conditions that may be indicative of an error or problem. 440-- 441-- We display these at the 'normal' verbosity level. 442-- 443warn :: Verbosity -> String -> IO () 444warn verbosity msg = withFrozenCallStack $ do 445 when (verbosity >= normal) $ do 446 ts <- getPOSIXTime 447 hFlush stdout 448 hPutStr stderr . withMetadata ts NormalMark FlagTrace verbosity 449 . wrapTextVerbosity verbosity 450 $ "Warning: " ++ msg 451 452-- | Useful status messages. 453-- 454-- We display these at the 'normal' verbosity level. 455-- 456-- This is for the ordinary helpful status messages that users see. Just 457-- enough information to know that things are working but not floods of detail. 458-- 459notice :: Verbosity -> String -> IO () 460notice verbosity msg = withFrozenCallStack $ do 461 when (verbosity >= normal) $ do 462 let h = verbosityHandle verbosity 463 ts <- getPOSIXTime 464 hPutStr h 465 $ withMetadata ts NormalMark FlagTrace verbosity 466 $ wrapTextVerbosity verbosity 467 $ msg 468 469-- | Display a message at 'normal' verbosity level, but without 470-- wrapping. 471-- 472noticeNoWrap :: Verbosity -> String -> IO () 473noticeNoWrap verbosity msg = withFrozenCallStack $ do 474 when (verbosity >= normal) $ do 475 let h = verbosityHandle verbosity 476 ts <- getPOSIXTime 477 hPutStr h . withMetadata ts NormalMark FlagTrace verbosity $ msg 478 479-- | Pretty-print a 'Disp.Doc' status message at 'normal' verbosity 480-- level. Use this if you need fancy formatting. 481-- 482noticeDoc :: Verbosity -> Disp.Doc -> IO () 483noticeDoc verbosity msg = withFrozenCallStack $ do 484 when (verbosity >= normal) $ do 485 let h = verbosityHandle verbosity 486 ts <- getPOSIXTime 487 hPutStr h 488 $ withMetadata ts NormalMark FlagTrace verbosity 489 $ Disp.renderStyle defaultStyle 490 $ msg 491 492-- | Display a "setup status message". Prefer using setupMessage' 493-- if possible. 494-- 495setupMessage :: Verbosity -> String -> PackageIdentifier -> IO () 496setupMessage verbosity msg pkgid = withFrozenCallStack $ do 497 noticeNoWrap verbosity (msg ++ ' ': prettyShow pkgid ++ "...") 498 499-- | More detail on the operation of some action. 500-- 501-- We display these messages when the verbosity level is 'verbose' 502-- 503info :: Verbosity -> String -> IO () 504info verbosity msg = withFrozenCallStack $ 505 when (verbosity >= verbose) $ do 506 let h = verbosityHandle verbosity 507 ts <- getPOSIXTime 508 hPutStr h 509 $ withMetadata ts NeverMark FlagTrace verbosity 510 $ wrapTextVerbosity verbosity 511 $ msg 512 513infoNoWrap :: Verbosity -> String -> IO () 514infoNoWrap verbosity msg = withFrozenCallStack $ 515 when (verbosity >= verbose) $ do 516 let h = verbosityHandle verbosity 517 ts <- getPOSIXTime 518 hPutStr h 519 $ withMetadata ts NeverMark FlagTrace verbosity 520 $ msg 521 522-- | Detailed internal debugging information 523-- 524-- We display these messages when the verbosity level is 'deafening' 525-- 526debug :: Verbosity -> String -> IO () 527debug verbosity msg = withFrozenCallStack $ 528 when (verbosity >= deafening) $ do 529 let h = verbosityHandle verbosity 530 ts <- getPOSIXTime 531 hPutStr h $ withMetadata ts NeverMark FlagTrace verbosity 532 $ wrapTextVerbosity verbosity 533 $ msg 534 -- ensure that we don't lose output if we segfault/infinite loop 535 hFlush stdout 536 537-- | A variant of 'debug' that doesn't perform the automatic line 538-- wrapping. Produces better output in some cases. 539debugNoWrap :: Verbosity -> String -> IO () 540debugNoWrap verbosity msg = withFrozenCallStack $ 541 when (verbosity >= deafening) $ do 542 let h = verbosityHandle verbosity 543 ts <- getPOSIXTime 544 hPutStr h 545 $ withMetadata ts NeverMark FlagTrace verbosity 546 $ msg 547 -- ensure that we don't lose output if we segfault/infinite loop 548 hFlush stdout 549 550-- | Perform an IO action, catching any IO exceptions and printing an error 551-- if one occurs. 552chattyTry :: String -- ^ a description of the action we were attempting 553 -> IO () -- ^ the action itself 554 -> IO () 555chattyTry desc action = 556 catchIO action $ \exception -> 557 hPutStrLn stderr $ "Error while " ++ desc ++ ": " ++ show exception 558 559-- | Run an IO computation, returning @e@ if it raises a "file 560-- does not exist" error. 561handleDoesNotExist :: a -> IO a -> IO a 562handleDoesNotExist e = 563 Exception.handleJust 564 (\ioe -> if isDoesNotExistError ioe then Just ioe else Nothing) 565 (\_ -> return e) 566 567-- ----------------------------------------------------------------------------- 568-- Helper functions 569 570-- | Wraps text unless the @+nowrap@ verbosity flag is active 571wrapTextVerbosity :: Verbosity -> String -> String 572wrapTextVerbosity verb 573 | isVerboseNoWrap verb = withTrailingNewline 574 | otherwise = withTrailingNewline . wrapText 575 576 577-- | Prepends a timestamp if @+timestamp@ verbosity flag is set 578-- 579-- This is used by 'withMetadata' 580-- 581withTimestamp :: Verbosity -> POSIXTime -> String -> String 582withTimestamp v ts msg 583 | isVerboseTimestamp v = msg' 584 | otherwise = msg -- no-op 585 where 586 msg' = case lines msg of 587 [] -> tsstr "\n" 588 l1:rest -> unlines (tsstr (' ':l1) : map (contpfx++) rest) 589 590 -- format timestamp to be prepended to first line with msec precision 591 tsstr = showFFloat (Just 3) (realToFrac ts :: Double) 592 593 -- continuation prefix for subsequent lines of msg 594 contpfx = replicate (length (tsstr " ")) ' ' 595 596-- | Wrap output with a marker if @+markoutput@ verbosity flag is set. 597-- 598-- NB: Why is markoutput done with start/end markers, and not prefixes? 599-- Markers are more convenient to add (if we want to add prefixes, 600-- we have to 'lines' and then 'map'; here's it's just some 601-- concatenates). Note that even in the prefix case, we can't 602-- guarantee that the markers are unambiguous, because some of 603-- Cabal's output comes straight from external programs, where 604-- we don't have the ability to interpose on the output. 605-- 606-- This is used by 'withMetadata' 607-- 608withOutputMarker :: Verbosity -> String -> String 609withOutputMarker v xs | not (isVerboseMarkOutput v) = xs 610withOutputMarker _ "" = "" -- Minor optimization, don't mark uselessly 611withOutputMarker _ xs = 612 "-----BEGIN CABAL OUTPUT-----\n" ++ 613 withTrailingNewline xs ++ 614 "-----END CABAL OUTPUT-----\n" 615 616-- | Append a trailing newline to a string if it does not 617-- already have a trailing newline. 618-- 619withTrailingNewline :: String -> String 620withTrailingNewline "" = "" 621withTrailingNewline (x:xs) = x : go x xs 622 where 623 go _ (c:cs) = c : go c cs 624 go '\n' "" = "" 625 go _ "" = "\n" 626 627-- | Prepend a call-site and/or call-stack based on Verbosity 628-- 629withCallStackPrefix :: WithCallStack (TraceWhen -> Verbosity -> String -> String) 630withCallStackPrefix tracer verbosity s = withFrozenCallStack $ 631 (if isVerboseCallSite verbosity 632 then parentSrcLocPrefix ++ 633 -- Hack: need a newline before starting output marker :( 634 if isVerboseMarkOutput verbosity 635 then "\n" 636 else "" 637 else "") ++ 638 (case traceWhen verbosity tracer of 639 Just pre -> pre ++ prettyCallStack callStack ++ "\n" 640 Nothing -> "") ++ 641 s 642 643-- | When should we emit the call stack? We always emit 644-- for internal errors, emit the trace for errors when we 645-- are in verbose mode, and otherwise only emit it if 646-- explicitly asked for using the @+callstack@ verbosity 647-- flag. (At the moment, 'AlwaysTrace' is not used. 648-- 649data TraceWhen 650 = AlwaysTrace 651 | VerboseTrace 652 | FlagTrace 653 deriving (Eq) 654 655-- | Determine if we should emit a call stack. 656-- If we trace, it also emits any prefix we should append. 657traceWhen :: Verbosity -> TraceWhen -> Maybe String 658traceWhen _ AlwaysTrace = Just "" 659traceWhen v VerboseTrace | v >= verbose = Just "" 660traceWhen v FlagTrace | isVerboseCallStack v = Just "----\n" 661traceWhen _ _ = Nothing 662 663-- | When should we output the marker? Things like 'die' 664-- always get marked, but a 'NormalMark' will only be 665-- output if we're not a quiet verbosity. 666-- 667data MarkWhen = AlwaysMark | NormalMark | NeverMark 668 669-- | Add all necessary metadata to a logging message 670-- 671withMetadata :: WithCallStack (POSIXTime -> MarkWhen -> TraceWhen -> Verbosity -> String -> String) 672withMetadata ts marker tracer verbosity x = withFrozenCallStack $ 673 -- NB: order matters. Output marker first because we 674 -- don't want to capture call stacks. 675 withTrailingNewline 676 . withCallStackPrefix tracer verbosity 677 . (case marker of 678 AlwaysMark -> withOutputMarker verbosity 679 NormalMark | not (isVerboseQuiet verbosity) 680 -> withOutputMarker verbosity 681 | otherwise 682 -> id 683 NeverMark -> id) 684 -- Clear out any existing markers 685 . clearMarkers 686 . withTimestamp verbosity ts 687 $ x 688 689clearMarkers :: String -> String 690clearMarkers s = unlines . filter isMarker $ lines s 691 where 692 isMarker "-----BEGIN CABAL OUTPUT-----" = False 693 isMarker "-----END CABAL OUTPUT-----" = False 694 isMarker _ = True 695 696-- ----------------------------------------------------------------------------- 697-- rawSystem variants 698maybeExit :: IO ExitCode -> IO () 699maybeExit cmd = do 700 res <- cmd 701 unless (res == ExitSuccess) $ exitWith res 702 703 704 705printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO () 706printRawCommandAndArgs verbosity path args = withFrozenCallStack $ 707 printRawCommandAndArgsAndEnv verbosity path args Nothing Nothing 708 709printRawCommandAndArgsAndEnv :: Verbosity 710 -> FilePath 711 -> [String] 712 -> Maybe FilePath 713 -> Maybe [(String, String)] 714 -> IO () 715printRawCommandAndArgsAndEnv verbosity path args mcwd menv = do 716 case menv of 717 Just env -> debugNoWrap verbosity ("Environment: " ++ show env) 718 Nothing -> return () 719 case mcwd of 720 Just cwd -> debugNoWrap verbosity ("Working directory: " ++ show cwd) 721 Nothing -> return () 722 infoNoWrap verbosity (showCommandForUser path args) 723 724-- Exit with the same exit code if the subcommand fails 725rawSystemExit :: Verbosity -> FilePath -> [String] -> IO () 726rawSystemExit verbosity path args = withFrozenCallStack $ do 727 printRawCommandAndArgs verbosity path args 728 hFlush stdout 729 exitcode <- rawSystem path args 730 unless (exitcode == ExitSuccess) $ do 731 debug verbosity $ path ++ " returned " ++ show exitcode 732 exitWith exitcode 733 734rawSystemExitCode :: Verbosity -> FilePath -> [String] -> IO ExitCode 735rawSystemExitCode verbosity path args = withFrozenCallStack $ do 736 printRawCommandAndArgs verbosity path args 737 hFlush stdout 738 exitcode <- rawSystem path args 739 unless (exitcode == ExitSuccess) $ do 740 debug verbosity $ path ++ " returned " ++ show exitcode 741 return exitcode 742 743rawSystemExitWithEnv :: Verbosity 744 -> FilePath 745 -> [String] 746 -> [(String, String)] 747 -> IO () 748rawSystemExitWithEnv verbosity path args env = withFrozenCallStack $ do 749 printRawCommandAndArgsAndEnv verbosity path args Nothing (Just env) 750 hFlush stdout 751 (_,_,_,ph) <- createProcess $ 752 (Process.proc path args) { Process.env = (Just env) 753#ifdef MIN_VERSION_process 754#if MIN_VERSION_process(1,2,0) 755-- delegate_ctlc has been added in process 1.2, and we still want to be able to 756-- bootstrap GHC on systems not having that version 757 , Process.delegate_ctlc = True 758#endif 759#endif 760 } 761 exitcode <- waitForProcess ph 762 unless (exitcode == ExitSuccess) $ do 763 debug verbosity $ path ++ " returned " ++ show exitcode 764 exitWith exitcode 765 766-- Closes the passed in handles before returning. 767rawSystemIOWithEnv :: Verbosity 768 -> FilePath 769 -> [String] 770 -> Maybe FilePath -- ^ New working dir or inherit 771 -> Maybe [(String, String)] -- ^ New environment or inherit 772 -> Maybe Handle -- ^ stdin 773 -> Maybe Handle -- ^ stdout 774 -> Maybe Handle -- ^ stderr 775 -> IO ExitCode 776rawSystemIOWithEnv verbosity path args mcwd menv inp out err = withFrozenCallStack $ do 777 (_,_,_,ph) <- createProcessWithEnv verbosity path args mcwd menv 778 (mbToStd inp) (mbToStd out) (mbToStd err) 779 exitcode <- waitForProcess ph 780 unless (exitcode == ExitSuccess) $ do 781 debug verbosity $ path ++ " returned " ++ show exitcode 782 return exitcode 783 where 784 mbToStd :: Maybe Handle -> Process.StdStream 785 mbToStd = maybe Process.Inherit Process.UseHandle 786 787rawSystemIOWithEnvAndAction 788 :: Verbosity 789 -> FilePath 790 -> [String] 791 -> Maybe FilePath -- ^ New working dir or inherit 792 -> Maybe [(String, String)] -- ^ New environment or inherit 793 -> IO a -- ^ action to perform after process is created, but before 'waitForProcess'. 794 -> Maybe Handle -- ^ stdin 795 -> Maybe Handle -- ^ stdout 796 -> Maybe Handle -- ^ stderr 797 -> IO (ExitCode, a) 798rawSystemIOWithEnvAndAction verbosity path args mcwd menv action inp out err = withFrozenCallStack $ do 799 (_,_,_,ph) <- createProcessWithEnv verbosity path args mcwd menv 800 (mbToStd inp) (mbToStd out) (mbToStd err) 801 a <- action 802 exitcode <- waitForProcess ph 803 unless (exitcode == ExitSuccess) $ do 804 debug verbosity $ path ++ " returned " ++ show exitcode 805 return (exitcode, a) 806 where 807 mbToStd :: Maybe Handle -> Process.StdStream 808 mbToStd = maybe Process.Inherit Process.UseHandle 809 810createProcessWithEnv :: 811 Verbosity 812 -> FilePath 813 -> [String] 814 -> Maybe FilePath -- ^ New working dir or inherit 815 -> Maybe [(String, String)] -- ^ New environment or inherit 816 -> Process.StdStream -- ^ stdin 817 -> Process.StdStream -- ^ stdout 818 -> Process.StdStream -- ^ stderr 819 -> IO (Maybe Handle, Maybe Handle, Maybe Handle,ProcessHandle) 820 -- ^ Any handles created for stdin, stdout, or stderr 821 -- with 'CreateProcess', and a handle to the process. 822createProcessWithEnv verbosity path args mcwd menv inp out err = withFrozenCallStack $ do 823 printRawCommandAndArgsAndEnv verbosity path args mcwd menv 824 hFlush stdout 825 (inp', out', err', ph) <- createProcess $ 826 (Process.proc path args) { 827 Process.cwd = mcwd 828 , Process.env = menv 829 , Process.std_in = inp 830 , Process.std_out = out 831 , Process.std_err = err 832#ifdef MIN_VERSION_process 833#if MIN_VERSION_process(1,2,0) 834-- delegate_ctlc has been added in process 1.2, and we still want to be able to 835-- bootstrap GHC on systems not having that version 836 , Process.delegate_ctlc = True 837#endif 838#endif 839 } 840 return (inp', out', err', ph) 841 842-- | Run a command and return its output. 843-- 844-- The output is assumed to be text in the locale encoding. 845-- 846rawSystemStdout :: forall mode. KnownIODataMode mode => Verbosity -> FilePath -> [String] -> IO mode 847rawSystemStdout verbosity path args = withFrozenCallStack $ do 848 (output, errors, exitCode) <- rawSystemStdInOut verbosity path args 849 Nothing Nothing Nothing (IOData.iodataMode :: IODataMode mode) 850 when (exitCode /= ExitSuccess) $ 851 die' verbosity errors 852 return output 853 854-- | Run a command and return its output, errors and exit status. Optionally 855-- also supply some input. Also provides control over whether the binary/text 856-- mode of the input and output. 857-- 858rawSystemStdInOut :: KnownIODataMode mode 859 => Verbosity 860 -> FilePath -- ^ Program location 861 -> [String] -- ^ Arguments 862 -> Maybe FilePath -- ^ New working dir or inherit 863 -> Maybe [(String, String)] -- ^ New environment or inherit 864 -> Maybe IOData -- ^ input text and binary mode 865 -> IODataMode mode -- ^ iodata mode, acts as proxy 866 -> IO (mode, String, ExitCode) -- ^ output, errors, exit 867rawSystemStdInOut verbosity path args mcwd menv input _ = withFrozenCallStack $ do 868 printRawCommandAndArgs verbosity path args 869 870 Exception.bracket 871 (runInteractiveProcess path args mcwd menv) 872 (\(inh,outh,errh,_) -> hClose inh >> hClose outh >> hClose errh) 873 $ \(inh,outh,errh,pid) -> do 874 875 -- output mode depends on what the caller wants 876 -- but the errors are always assumed to be text (in the current locale) 877 hSetBinaryMode errh False 878 879 -- fork off a couple threads to pull on the stderr and stdout 880 -- so if the process writes to stderr we do not block. 881 882 withAsyncNF (hGetContents errh) $ \errA -> withAsyncNF (IOData.hGetIODataContents outh) $ \outA -> do 883 -- push all the input, if any 884 ignoreSigPipe $ case input of 885 Nothing -> hClose inh 886 Just inputData -> IOData.hPutContents inh inputData 887 888 -- wait for both to finish 889 mberr1 <- waitCatch outA 890 mberr2 <- waitCatch errA 891 892 -- wait for the program to terminate 893 exitcode <- waitForProcess pid 894 895 -- get the stderr, so it can be added to error message 896 err <- reportOutputIOError mberr2 897 898 unless (exitcode == ExitSuccess) $ 899 debug verbosity $ path ++ " returned " ++ show exitcode 900 ++ if null err then "" else 901 " with error message:\n" ++ err 902 ++ case input of 903 Nothing -> "" 904 Just d | IOData.null d -> "" 905 Just (IODataText inp) -> "\nstdin input:\n" ++ inp 906 Just (IODataBinary inp) -> "\nstdin input (binary):\n" ++ show inp 907 908 -- Check if we hit an exception while consuming the output 909 -- (e.g. a text decoding error) 910 out <- reportOutputIOError mberr1 911 912 return (out, err, exitcode) 913 where 914 reportOutputIOError :: Either Exception.SomeException a -> IO a 915 reportOutputIOError (Right x) = return x 916 reportOutputIOError (Left exc) = case fromException exc of 917 Just ioe -> throwIO (ioeSetFileName ioe ("output of " ++ path)) 918 Nothing -> throwIO exc 919 920 ignoreSigPipe :: IO () -> IO () 921 ignoreSigPipe = Exception.handle $ \e -> case e of 922 GHC.IOError { GHC.ioe_type = GHC.ResourceVanished, GHC.ioe_errno = Just ioe } 923 | Errno ioe == ePIPE -> return () 924 _ -> throwIO e 925 926-- | Look for a program and try to find it's version number. It can accept 927-- either an absolute path or the name of a program binary, in which case we 928-- will look for the program on the path. 929-- 930findProgramVersion :: String -- ^ version args 931 -> (String -> String) -- ^ function to select version 932 -- number from program output 933 -> Verbosity 934 -> FilePath -- ^ location 935 -> IO (Maybe Version) 936findProgramVersion versionArg selectVersion verbosity path = withFrozenCallStack $ do 937 str <- rawSystemStdout verbosity path [versionArg] 938 `catchIO` (\_ -> return "") 939 `catchExit` (\_ -> return "") 940 let version :: Maybe Version 941 version = simpleParsec (selectVersion str) 942 case version of 943 Nothing -> warn verbosity $ "cannot determine version of " ++ path 944 ++ " :\n" ++ show str 945 Just v -> debug verbosity $ path ++ " is version " ++ prettyShow v 946 return version 947 948 949-- | Like the Unix xargs program. Useful for when we've got very long command 950-- lines that might overflow an OS limit on command line length and so you 951-- need to invoke a command multiple times to get all the args in. 952-- 953-- Use it with either of the rawSystem variants above. For example: 954-- 955-- > xargs (32*1024) (rawSystemExit verbosity) prog fixedArgs bigArgs 956-- 957xargs :: Int -> ([String] -> IO ()) 958 -> [String] -> [String] -> IO () 959xargs maxSize rawSystemFun fixedArgs bigArgs = 960 let fixedArgSize = sum (map length fixedArgs) + length fixedArgs 961 chunkSize = maxSize - fixedArgSize 962 in traverse_ (rawSystemFun . (fixedArgs ++)) (chunks chunkSize bigArgs) 963 964 where chunks len = unfoldr $ \s -> 965 if null s then Nothing 966 else Just (chunk [] len s) 967 968 chunk acc _ [] = (reverse acc,[]) 969 chunk acc len (s:ss) 970 | len' < len = chunk (s:acc) (len-len'-1) ss 971 | otherwise = (reverse acc, s:ss) 972 where len' = length s 973 974-- ------------------------------------------------------------ 975-- * File Utilities 976-- ------------------------------------------------------------ 977 978---------------- 979-- Finding files 980 981 982{-# DEPRECATED findFile "Use findFileEx instead. This symbol will be removed in Cabal 3.2 (est. December 2019)" #-} 983findFile :: [FilePath] -- ^search locations 984 -> FilePath -- ^File Name 985 -> IO FilePath 986findFile = findFileEx normal 987 988-- | Find a file by looking in a search path. The file path must match exactly. 989-- 990-- @since 3.4.0.0 991findFileCwd 992 :: Verbosity 993 -> FilePath -- ^ cwd 994 -> [FilePath] -- ^ relative search location 995 -> FilePath -- ^ File Name 996 -> IO FilePath 997findFileCwd verbosity cwd searchPath fileName = 998 findFirstFile (cwd </>) 999 [ path </> fileName 1000 | path <- nub searchPath] 1001 >>= maybe (die' verbosity $ fileName ++ " doesn't exist") return 1002 1003-- | Find a file by looking in a search path. The file path must match exactly. 1004-- 1005findFileEx :: Verbosity 1006 -> [FilePath] -- ^search locations 1007 -> FilePath -- ^File Name 1008 -> IO FilePath 1009findFileEx verbosity searchPath fileName = 1010 findFirstFile id 1011 [ path </> fileName 1012 | path <- nub searchPath] 1013 >>= maybe (die' verbosity $ fileName ++ " doesn't exist") return 1014 1015-- | Find a file by looking in a search path with one of a list of possible 1016-- file extensions. The file base name should be given and it will be tried 1017-- with each of the extensions in each element of the search path. 1018-- 1019findFileWithExtension :: [String] 1020 -> [FilePath] 1021 -> FilePath 1022 -> IO (Maybe FilePath) 1023findFileWithExtension extensions searchPath baseName = 1024 findFirstFile id 1025 [ path </> baseName <.> ext 1026 | path <- nub searchPath 1027 , ext <- nub extensions ] 1028 1029-- | @since 3.4.0.0 1030findFileCwdWithExtension 1031 :: FilePath 1032 -> [String] 1033 -> [FilePath] 1034 -> FilePath 1035 -> IO (Maybe FilePath) 1036findFileCwdWithExtension cwd extensions searchPath baseName = 1037 findFirstFile (cwd </>) 1038 [ path </> baseName <.> ext 1039 | path <- nub searchPath 1040 , ext <- nub extensions ] 1041 1042-- | @since 3.4.0.0 1043findAllFilesCwdWithExtension 1044 :: FilePath -- ^ cwd 1045 -> [String] -- ^ extensions 1046 -> [FilePath] -- ^ relative search locations 1047 -> FilePath -- ^ basename 1048 -> IO [FilePath] 1049findAllFilesCwdWithExtension cwd extensions searchPath basename = 1050 findAllFiles (cwd </>) 1051 [ path </> basename <.> ext 1052 | path <- nub searchPath 1053 , ext <- nub extensions ] 1054 1055findAllFilesWithExtension :: [String] 1056 -> [FilePath] 1057 -> FilePath 1058 -> IO [FilePath] 1059findAllFilesWithExtension extensions searchPath basename = 1060 findAllFiles id 1061 [ path </> basename <.> ext 1062 | path <- nub searchPath 1063 , ext <- nub extensions ] 1064 1065-- | Like 'findFileWithExtension' but returns which element of the search path 1066-- the file was found in, and the file path relative to that base directory. 1067-- 1068findFileWithExtension' :: [String] 1069 -> [FilePath] 1070 -> FilePath 1071 -> IO (Maybe (FilePath, FilePath)) 1072findFileWithExtension' extensions searchPath baseName = 1073 findFirstFile (uncurry (</>)) 1074 [ (path, baseName <.> ext) 1075 | path <- nub searchPath 1076 , ext <- nub extensions ] 1077 1078findFirstFile :: (a -> FilePath) -> [a] -> IO (Maybe a) 1079findFirstFile file = findFirst 1080 where findFirst [] = return Nothing 1081 findFirst (x:xs) = do exists <- doesFileExist (file x) 1082 if exists 1083 then return (Just x) 1084 else findFirst xs 1085 1086findAllFiles :: (a -> FilePath) -> [a] -> IO [a] 1087findAllFiles file = filterM (doesFileExist . file) 1088 1089 1090{-# DEPRECATED findModuleFiles "Use findModuleFilesEx instead. This symbol will be removed in Cabal 3.2 (est. December 2019)" #-} 1091findModuleFiles :: [FilePath] -- ^ build prefix (location of objects) 1092 -> [String] -- ^ search suffixes 1093 -> [ModuleName] -- ^ modules 1094 -> IO [(FilePath, FilePath)] 1095findModuleFiles = findModuleFilesEx normal 1096 1097-- | Finds the files corresponding to a list of Haskell module names. 1098-- 1099-- As 'findModuleFile' but for a list of module names. 1100-- 1101findModuleFilesEx :: Verbosity 1102 -> [FilePath] -- ^ build prefix (location of objects) 1103 -> [String] -- ^ search suffixes 1104 -> [ModuleName] -- ^ modules 1105 -> IO [(FilePath, FilePath)] 1106findModuleFilesEx verbosity searchPath extensions moduleNames = 1107 traverse (findModuleFileEx verbosity searchPath extensions) moduleNames 1108 1109{-# DEPRECATED findModuleFile "Use findModuleFileEx instead. This symbol will be removed in Cabal 3.2 (est. December 2019)" #-} 1110findModuleFile :: [FilePath] -- ^ build prefix (location of objects) 1111 -> [String] -- ^ search suffixes 1112 -> ModuleName -- ^ module 1113 -> IO (FilePath, FilePath) 1114findModuleFile = findModuleFileEx normal 1115 1116-- | Find the file corresponding to a Haskell module name. 1117-- 1118-- This is similar to 'findFileWithExtension'' but specialised to a module 1119-- name. The function fails if the file corresponding to the module is missing. 1120-- 1121findModuleFileEx :: Verbosity 1122 -> [FilePath] -- ^ build prefix (location of objects) 1123 -> [String] -- ^ search suffixes 1124 -> ModuleName -- ^ module 1125 -> IO (FilePath, FilePath) 1126findModuleFileEx verbosity searchPath extensions mod_name = 1127 maybe notFound return 1128 =<< findFileWithExtension' extensions searchPath 1129 (ModuleName.toFilePath mod_name) 1130 where 1131 notFound = die' verbosity $ 1132 "Error: Could not find module: " ++ prettyShow mod_name 1133 ++ " with any suffix: " ++ show extensions 1134 ++ " in the search path: " ++ show searchPath 1135 1136-- | List all the files in a directory and all subdirectories. 1137-- 1138-- The order places files in sub-directories after all the files in their 1139-- parent directories. The list is generated lazily so is not well defined if 1140-- the source directory structure changes before the list is used. 1141-- 1142getDirectoryContentsRecursive :: FilePath -> IO [FilePath] 1143getDirectoryContentsRecursive topdir = recurseDirectories [""] 1144 where 1145 recurseDirectories :: [FilePath] -> IO [FilePath] 1146 recurseDirectories [] = return [] 1147 recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do 1148 (files, dirs') <- collect [] [] =<< getDirectoryContents (topdir </> dir) 1149 files' <- recurseDirectories (dirs' ++ dirs) 1150 return (files ++ files') 1151 1152 where 1153 collect files dirs' [] = return (reverse files 1154 ,reverse dirs') 1155 collect files dirs' (entry:entries) | ignore entry 1156 = collect files dirs' entries 1157 collect files dirs' (entry:entries) = do 1158 let dirEntry = dir </> entry 1159 isDirectory <- doesDirectoryExist (topdir </> dirEntry) 1160 if isDirectory 1161 then collect files (dirEntry:dirs') entries 1162 else collect (dirEntry:files) dirs' entries 1163 1164 ignore ['.'] = True 1165 ignore ['.', '.'] = True 1166 ignore _ = False 1167 1168------------------------ 1169-- Environment variables 1170 1171-- | Is this directory in the system search path? 1172isInSearchPath :: FilePath -> IO Bool 1173isInSearchPath path = fmap (elem path) getSearchPath 1174 1175addLibraryPath :: OS 1176 -> [FilePath] 1177 -> [(String,String)] 1178 -> [(String,String)] 1179addLibraryPath os paths = addEnv 1180 where 1181 pathsString = intercalate [searchPathSeparator] paths 1182 ldPath = case os of 1183 OSX -> "DYLD_LIBRARY_PATH" 1184 _ -> "LD_LIBRARY_PATH" 1185 1186 addEnv [] = [(ldPath,pathsString)] 1187 addEnv ((key,value):xs) 1188 | key == ldPath = 1189 if null value 1190 then (key,pathsString):xs 1191 else (key,value ++ (searchPathSeparator:pathsString)):xs 1192 | otherwise = (key,value):addEnv xs 1193 1194-------------------- 1195-- Modification time 1196 1197-- | Compare the modification times of two files to see if the first is newer 1198-- than the second. The first file must exist but the second need not. 1199-- The expected use case is when the second file is generated using the first. 1200-- In this use case, if the result is True then the second file is out of date. 1201-- 1202moreRecentFile :: FilePath -> FilePath -> IO Bool 1203moreRecentFile a b = do 1204 exists <- doesFileExist b 1205 if not exists 1206 then return True 1207 else do tb <- getModificationTime b 1208 ta <- getModificationTime a 1209 return (ta > tb) 1210 1211-- | Like 'moreRecentFile', but also checks that the first file exists. 1212existsAndIsMoreRecentThan :: FilePath -> FilePath -> IO Bool 1213existsAndIsMoreRecentThan a b = do 1214 exists <- doesFileExist a 1215 if not exists 1216 then return False 1217 else a `moreRecentFile` b 1218 1219---------------------------------------- 1220-- Copying and installing files and dirs 1221 1222-- | Same as 'createDirectoryIfMissing' but logs at higher verbosity levels. 1223-- 1224createDirectoryIfMissingVerbose :: Verbosity 1225 -> Bool -- ^ Create its parents too? 1226 -> FilePath 1227 -> IO () 1228createDirectoryIfMissingVerbose verbosity create_parents path0 1229 | create_parents = withFrozenCallStack $ createDirs (parents path0) 1230 | otherwise = withFrozenCallStack $ createDirs (take 1 (parents path0)) 1231 where 1232 parents = reverse . scanl1 (</>) . splitDirectories . normalise 1233 1234 createDirs [] = return () 1235 createDirs (dir:[]) = createDir dir throwIO 1236 createDirs (dir:dirs) = 1237 createDir dir $ \_ -> do 1238 createDirs dirs 1239 createDir dir throwIO 1240 1241 createDir :: FilePath -> (IOException -> IO ()) -> IO () 1242 createDir dir notExistHandler = do 1243 r <- tryIO $ createDirectoryVerbose verbosity dir 1244 case (r :: Either IOException ()) of 1245 Right () -> return () 1246 Left e 1247 | isDoesNotExistError e -> notExistHandler e 1248 -- createDirectory (and indeed POSIX mkdir) does not distinguish 1249 -- between a dir already existing and a file already existing. So we 1250 -- check for it here. Unfortunately there is a slight race condition 1251 -- here, but we think it is benign. It could report an exception in 1252 -- the case that the dir did exist but another process deletes the 1253 -- directory and creates a file in its place before we can check 1254 -- that the directory did indeed exist. 1255 | isAlreadyExistsError e -> (do 1256 isDir <- doesDirectoryExist dir 1257 unless isDir $ throwIO e 1258 ) `catchIO` ((\_ -> return ()) :: IOException -> IO ()) 1259 | otherwise -> throwIO e 1260 1261createDirectoryVerbose :: Verbosity -> FilePath -> IO () 1262createDirectoryVerbose verbosity dir = withFrozenCallStack $ do 1263 info verbosity $ "creating " ++ dir 1264 createDirectory dir 1265 setDirOrdinary dir 1266 1267-- | Copies a file without copying file permissions. The target file is created 1268-- with default permissions. Any existing target file is replaced. 1269-- 1270-- At higher verbosity levels it logs an info message. 1271-- 1272copyFileVerbose :: Verbosity -> FilePath -> FilePath -> IO () 1273copyFileVerbose verbosity src dest = withFrozenCallStack $ do 1274 info verbosity ("copy " ++ src ++ " to " ++ dest) 1275 copyFile src dest 1276 1277-- | Install an ordinary file. This is like a file copy but the permissions 1278-- are set appropriately for an installed file. On Unix it is \"-rw-r--r--\" 1279-- while on Windows it uses the default permissions for the target directory. 1280-- 1281installOrdinaryFile :: Verbosity -> FilePath -> FilePath -> IO () 1282installOrdinaryFile verbosity src dest = withFrozenCallStack $ do 1283 info verbosity ("Installing " ++ src ++ " to " ++ dest) 1284 copyOrdinaryFile src dest 1285 1286-- | Install an executable file. This is like a file copy but the permissions 1287-- are set appropriately for an installed file. On Unix it is \"-rwxr-xr-x\" 1288-- while on Windows it uses the default permissions for the target directory. 1289-- 1290installExecutableFile :: Verbosity -> FilePath -> FilePath -> IO () 1291installExecutableFile verbosity src dest = withFrozenCallStack $ do 1292 info verbosity ("Installing executable " ++ src ++ " to " ++ dest) 1293 copyExecutableFile src dest 1294 1295-- | Install a file that may or not be executable, preserving permissions. 1296installMaybeExecutableFile :: Verbosity -> FilePath -> FilePath -> IO () 1297installMaybeExecutableFile verbosity src dest = withFrozenCallStack $ do 1298 perms <- getPermissions src 1299 if (executable perms) --only checks user x bit 1300 then installExecutableFile verbosity src dest 1301 else installOrdinaryFile verbosity src dest 1302 1303-- | Given a relative path to a file, copy it to the given directory, preserving 1304-- the relative path and creating the parent directories if needed. 1305copyFileTo :: Verbosity -> FilePath -> FilePath -> IO () 1306copyFileTo verbosity dir file = withFrozenCallStack $ do 1307 let targetFile = dir </> file 1308 createDirectoryIfMissingVerbose verbosity True (takeDirectory targetFile) 1309 installOrdinaryFile verbosity file targetFile 1310 1311-- | Common implementation of 'copyFiles', 'installOrdinaryFiles', 1312-- 'installExecutableFiles' and 'installMaybeExecutableFiles'. 1313copyFilesWith :: (Verbosity -> FilePath -> FilePath -> IO ()) 1314 -> Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () 1315copyFilesWith doCopy verbosity targetDir srcFiles = withFrozenCallStack $ do 1316 1317 -- Create parent directories for everything 1318 let dirs = map (targetDir </>) . nub . map (takeDirectory . snd) $ srcFiles 1319 traverse_ (createDirectoryIfMissingVerbose verbosity True) dirs 1320 1321 -- Copy all the files 1322 sequence_ [ let src = srcBase </> srcFile 1323 dest = targetDir </> srcFile 1324 in doCopy verbosity src dest 1325 | (srcBase, srcFile) <- srcFiles ] 1326 1327-- | Copies a bunch of files to a target directory, preserving the directory 1328-- structure in the target location. The target directories are created if they 1329-- do not exist. 1330-- 1331-- The files are identified by a pair of base directory and a path relative to 1332-- that base. It is only the relative part that is preserved in the 1333-- destination. 1334-- 1335-- For example: 1336-- 1337-- > copyFiles normal "dist/src" 1338-- > [("", "src/Foo.hs"), ("dist/build/", "src/Bar.hs")] 1339-- 1340-- This would copy \"src\/Foo.hs\" to \"dist\/src\/src\/Foo.hs\" and 1341-- copy \"dist\/build\/src\/Bar.hs\" to \"dist\/src\/src\/Bar.hs\". 1342-- 1343-- This operation is not atomic. Any IO failure during the copy (including any 1344-- missing source files) leaves the target in an unknown state so it is best to 1345-- use it with a freshly created directory so that it can be simply deleted if 1346-- anything goes wrong. 1347-- 1348copyFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () 1349copyFiles v fp fs = withFrozenCallStack (copyFilesWith copyFileVerbose v fp fs) 1350 1351-- | This is like 'copyFiles' but uses 'installOrdinaryFile'. 1352-- 1353installOrdinaryFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () 1354installOrdinaryFiles v fp fs = withFrozenCallStack (copyFilesWith installOrdinaryFile v fp fs) 1355 1356-- | This is like 'copyFiles' but uses 'installExecutableFile'. 1357-- 1358installExecutableFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] 1359 -> IO () 1360installExecutableFiles v fp fs = withFrozenCallStack (copyFilesWith installExecutableFile v fp fs) 1361 1362-- | This is like 'copyFiles' but uses 'installMaybeExecutableFile'. 1363-- 1364installMaybeExecutableFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] 1365 -> IO () 1366installMaybeExecutableFiles v fp fs = withFrozenCallStack (copyFilesWith installMaybeExecutableFile v fp fs) 1367 1368-- | This installs all the files in a directory to a target location, 1369-- preserving the directory layout. All the files are assumed to be ordinary 1370-- rather than executable files. 1371-- 1372installDirectoryContents :: Verbosity -> FilePath -> FilePath -> IO () 1373installDirectoryContents verbosity srcDir destDir = withFrozenCallStack $ do 1374 info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.") 1375 srcFiles <- getDirectoryContentsRecursive srcDir 1376 installOrdinaryFiles verbosity destDir [ (srcDir, f) | f <- srcFiles ] 1377 1378-- | Recursively copy the contents of one directory to another path. 1379copyDirectoryRecursive :: Verbosity -> FilePath -> FilePath -> IO () 1380copyDirectoryRecursive verbosity srcDir destDir = withFrozenCallStack $ do 1381 info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.") 1382 srcFiles <- getDirectoryContentsRecursive srcDir 1383 copyFilesWith (const copyFile) verbosity destDir [ (srcDir, f) 1384 | f <- srcFiles ] 1385 1386------------------- 1387-- File permissions 1388 1389-- | Like 'doesFileExist', but also checks that the file is executable. 1390doesExecutableExist :: FilePath -> IO Bool 1391doesExecutableExist f = do 1392 exists <- doesFileExist f 1393 if exists 1394 then do perms <- getPermissions f 1395 return (executable perms) 1396 else return False 1397 1398--------------------------- 1399-- Temporary files and dirs 1400 1401-- | Advanced options for 'withTempFile' and 'withTempDirectory'. 1402data TempFileOptions = TempFileOptions { 1403 optKeepTempFiles :: Bool -- ^ Keep temporary files? 1404 } 1405 1406defaultTempFileOptions :: TempFileOptions 1407defaultTempFileOptions = TempFileOptions { optKeepTempFiles = False } 1408 1409-- | Use a temporary filename that doesn't already exist. 1410-- 1411withTempFile :: FilePath -- ^ Temp dir to create the file in 1412 -> String -- ^ File name template. See 'openTempFile'. 1413 -> (FilePath -> Handle -> IO a) -> IO a 1414withTempFile tmpDir template action = 1415 withTempFileEx defaultTempFileOptions tmpDir template action 1416 1417-- | A version of 'withTempFile' that additionally takes a 'TempFileOptions' 1418-- argument. 1419withTempFileEx :: TempFileOptions 1420 -> FilePath -- ^ Temp dir to create the file in 1421 -> String -- ^ File name template. See 'openTempFile'. 1422 -> (FilePath -> Handle -> IO a) -> IO a 1423withTempFileEx opts tmpDir template action = 1424 Exception.bracket 1425 (openTempFile tmpDir template) 1426 (\(name, handle) -> do hClose handle 1427 unless (optKeepTempFiles opts) $ 1428 handleDoesNotExist () . removeFile $ name) 1429 (withLexicalCallStack (\x -> uncurry action x)) 1430 1431-- | Create and use a temporary directory. 1432-- 1433-- Creates a new temporary directory inside the given directory, making use 1434-- of the template. The temp directory is deleted after use. For example: 1435-- 1436-- > withTempDirectory verbosity "src" "sdist." $ \tmpDir -> do ... 1437-- 1438-- The @tmpDir@ will be a new subdirectory of the given directory, e.g. 1439-- @src/sdist.342@. 1440-- 1441withTempDirectory :: Verbosity -> FilePath -> String -> (FilePath -> IO a) -> IO a 1442withTempDirectory verbosity targetDir template f = withFrozenCallStack $ 1443 withTempDirectoryEx verbosity defaultTempFileOptions targetDir template 1444 (withLexicalCallStack (\x -> f x)) 1445 1446-- | A version of 'withTempDirectory' that additionally takes a 1447-- 'TempFileOptions' argument. 1448withTempDirectoryEx :: Verbosity -> TempFileOptions 1449 -> FilePath -> String -> (FilePath -> IO a) -> IO a 1450withTempDirectoryEx _verbosity opts targetDir template f = withFrozenCallStack $ 1451 Exception.bracket 1452 (createTempDirectory targetDir template) 1453 (unless (optKeepTempFiles opts) 1454 . handleDoesNotExist () . removeDirectoryRecursive) 1455 (withLexicalCallStack (\x -> f x)) 1456 1457----------------------------------- 1458-- Safely reading and writing files 1459 1460-- | Write a file but only if it would have new content. If we would be writing 1461-- the same as the existing content then leave the file as is so that we do not 1462-- update the file's modification time. 1463-- 1464-- NB: Before Cabal-3.0 the file content was assumed to be 1465-- ASCII-representable. Since Cabal-3.0 the file is assumed to be 1466-- UTF-8 encoded. 1467rewriteFileEx :: Verbosity -> FilePath -> String -> IO () 1468rewriteFileEx verbosity path = 1469 rewriteFileLBS verbosity path . toUTF8LBS 1470 1471-- | Same as `rewriteFileEx` but for 'ByteString's. 1472rewriteFileLBS :: Verbosity -> FilePath -> BS.ByteString -> IO () 1473rewriteFileLBS verbosity path newContent = 1474 flip catchIO mightNotExist $ do 1475 existingContent <- annotateIO verbosity $ BS.readFile path 1476 _ <- evaluate (BS.length existingContent) 1477 unless (existingContent == newContent) $ 1478 annotateIO verbosity $ 1479 writeFileAtomic path newContent 1480 where 1481 mightNotExist e | isDoesNotExistError e 1482 = annotateIO verbosity $ writeFileAtomic path newContent 1483 | otherwise 1484 = ioError e 1485 1486 1487-- | The path name that represents the current directory. 1488-- In Unix, it's @\".\"@, but this is system-specific. 1489-- (E.g. AmigaOS uses the empty string @\"\"@ for the current directory.) 1490currentDir :: FilePath 1491currentDir = "." 1492 1493shortRelativePath :: FilePath -> FilePath -> FilePath 1494shortRelativePath from to = 1495 case dropCommonPrefix (splitDirectories from) (splitDirectories to) of 1496 (stuff, path) -> joinPath (map (const "..") stuff ++ path) 1497 where 1498 dropCommonPrefix :: Eq a => [a] -> [a] -> ([a],[a]) 1499 dropCommonPrefix (x:xs) (y:ys) 1500 | x == y = dropCommonPrefix xs ys 1501 dropCommonPrefix xs ys = (xs,ys) 1502 1503-- | Drop the extension if it's one of 'exeExtensions', or return the path 1504-- unchanged. 1505dropExeExtension :: FilePath -> FilePath 1506dropExeExtension filepath = 1507 -- System.FilePath's extension handling functions are horribly 1508 -- inconsistent, consider: 1509 -- 1510 -- isExtensionOf "" "foo" == False but 1511 -- isExtensionOf "" "foo." == True. 1512 -- 1513 -- On the other hand stripExtension doesn't remove the empty extension: 1514 -- 1515 -- stripExtension "" "foo." == Just "foo." 1516 -- 1517 -- Since by "" in exeExtensions we mean 'no extension' anyways we can 1518 -- just always ignore it here. 1519 let exts = [ ext | ext <- exeExtensions, ext /= "" ] in 1520 fromMaybe filepath $ do 1521 ext <- find (`FilePath.isExtensionOf` filepath) exts 1522 ext `FilePath.stripExtension` filepath 1523 1524-- | List of possible executable file extensions on the current build 1525-- platform. 1526exeExtensions :: [String] 1527exeExtensions = case buildOS of 1528 -- Possible improvement: on Windows, read the list of extensions from the 1529 -- PATHEXT environment variable. By default PATHEXT is ".com; .exe; .bat; 1530 -- .cmd". 1531 Windows -> ["", "exe"] 1532 Ghcjs -> ["", "exe"] 1533 _ -> [""] 1534 1535-- ------------------------------------------------------------ 1536-- * Finding the description file 1537-- ------------------------------------------------------------ 1538 1539-- | Package description file (/pkgname/@.cabal@) 1540defaultPackageDesc :: Verbosity -> IO FilePath 1541defaultPackageDesc verbosity = tryFindPackageDesc verbosity currentDir 1542 1543-- |Find a package description file in the given directory. Looks for 1544-- @.cabal@ files. 1545findPackageDesc :: FilePath -- ^Where to look 1546 -> IO (Either String FilePath) -- ^<pkgname>.cabal 1547findPackageDesc = findPackageDescCwd "." 1548 1549-- | @since 3.4.0.0 1550findPackageDescCwd 1551 :: FilePath -- ^ project root 1552 -> FilePath -- ^ relative directory 1553 -> IO (Either String FilePath) -- ^ <pkgname>.cabal relative to the project root 1554findPackageDescCwd cwd dir 1555 = do files <- getDirectoryContents (cwd </> dir) 1556 -- to make sure we do not mistake a ~/.cabal/ dir for a <pkgname>.cabal 1557 -- file we filter to exclude dirs and null base file names: 1558 cabalFiles <- filterM (doesFileExist . snd) 1559 [ (dir </> file, cwd </> dir </> file) 1560 | file <- files 1561 , let (name, ext) = splitExtension file 1562 , not (null name) && ext == ".cabal" ] 1563 case map fst cabalFiles of 1564 [] -> return (Left noDesc) 1565 [cabalFile] -> return (Right cabalFile) 1566 multiple -> return (Left $ multiDesc multiple) 1567 1568 where 1569 noDesc :: String 1570 noDesc = "No cabal file found.\n" 1571 ++ "Please create a package description file <pkgname>.cabal" 1572 1573 multiDesc :: [String] -> String 1574 multiDesc l = "Multiple cabal files found.\n" 1575 ++ "Please use only one of: " 1576 ++ intercalate ", " l 1577 1578-- |Like 'findPackageDesc', but calls 'die' in case of error. 1579tryFindPackageDesc :: Verbosity -> FilePath -> IO FilePath 1580tryFindPackageDesc verbosity dir = 1581 either (die' verbosity) return =<< findPackageDesc dir 1582 1583-- | Like 'findPackageDescCwd', but calls 'die' in case of error. 1584-- 1585-- @since 3.4.0.0 1586tryFindPackageDescCwd :: Verbosity -> FilePath -> FilePath -> IO FilePath 1587tryFindPackageDescCwd verbosity cwd dir = 1588 either (die' verbosity) return =<< findPackageDescCwd cwd dir 1589 1590-- |Find auxiliary package information in the given directory. 1591-- Looks for @.buildinfo@ files. 1592findHookedPackageDesc 1593 :: Verbosity 1594 -> FilePath -- ^Directory to search 1595 -> IO (Maybe FilePath) -- ^/dir/@\/@/pkgname/@.buildinfo@, if present 1596findHookedPackageDesc verbosity dir = do 1597 files <- getDirectoryContents dir 1598 buildInfoFiles <- filterM doesFileExist 1599 [ dir </> file 1600 | file <- files 1601 , let (name, ext) = splitExtension file 1602 , not (null name) && ext == buildInfoExt ] 1603 case buildInfoFiles of 1604 [] -> return Nothing 1605 [f] -> return (Just f) 1606 _ -> die' verbosity ("Multiple files with extension " ++ buildInfoExt) 1607 1608buildInfoExt :: String 1609buildInfoExt = ".buildinfo" 1610