Utils.hs 48.3 KB
Newer Older
1
{-# LANGUAGE CPP, ForeignFunctionInterface #-}
2
3
4
-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Simple.Utils
ijones's avatar
ijones committed
5
-- Copyright   :  Isaac Jones, Simon Marlow 2003-2004
6
-- License     :  BSD3
Duncan Coutts's avatar
Duncan Coutts committed
7
--                portions Copyright (c) 2007, Galois Inc.
8
--
Duncan Coutts's avatar
Duncan Coutts committed
9
-- Maintainer  :  cabal-devel@haskell.org
ijones's avatar
ijones committed
10
-- Portability :  portable
11
--
Duncan Coutts's avatar
Duncan Coutts committed
12
13
14
15
16
-- 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.
17
18

module Distribution.Simple.Utils (
19
        cabalVersion,
20
21

        -- * logging and errors
22
23
        die,
        dieWithLocation,
24
        topHandler, topHandlerWith,
25
        warn, notice, setupMessage, info, debug,
26
        debugNoWrap, chattyTry,
Neil Vice's avatar
Neil Vice committed
27
        printRawCommandAndArgs, printRawCommandAndArgsAndEnv,
28
29

        -- * running programs
30
        rawSystemExit,
tibbe's avatar
tibbe committed
31
        rawSystemExitCode,
32
        rawSystemExitWithEnv,
33
        rawSystemStdout,
34
        rawSystemStdInOut,
35
        rawSystemIOWithEnv,
36
        maybeExit,
37
        xargs,
38
        findProgramLocation,
39
        findProgramVersion,
40
41

        -- * copying files
42
        smartCopySources,
43
        createDirectoryIfMissingVerbose,
44
        copyFileVerbose,
45
        copyDirectoryRecursiveVerbose,
46
        copyFiles,
refold's avatar
refold committed
47
        copyFileTo,
48

49
50
51
        -- * installing files
        installOrdinaryFile,
        installExecutableFile,
refold's avatar
refold committed
52
        installMaybeExecutableFile,
53
        installOrdinaryFiles,
refold's avatar
refold committed
54
55
        installExecutableFiles,
        installMaybeExecutableFiles,
56
57
        installDirectoryContents,

58
        -- * File permissions
59
        doesExecutableExist,
60
61
62
        setFileOrdinary,
        setFileExecutable,

63
        -- * file names
ijones's avatar
ijones committed
64
        currentDir,
65
66

        -- * finding files
67
        findFile,
68
        findFirstFile,
69
70
        findFileWithExtension,
        findFileWithExtension',
71
72
73
        findModuleFile,
        findModuleFiles,
        getDirectoryContentsRecursive,
74

75
76
77
        -- * environment variables
        isInSearchPath,

78
79
        -- * simple file globbing
        matchFileGlob,
Ian Lynagh's avatar
Ian Lynagh committed
80
        matchDirFileGlob,
81
82
        parseFileGlob,
        FileGlob(..),
83

84
85
        -- * modification time
        moreRecentFile,
86
        existsAndIsMoreRecentThan,
87

Duncan Coutts's avatar
Duncan Coutts committed
88
        -- * temp files and dirs
89
90
91
        TempFileOptions(..), defaultTempFileOptions,
        withTempFile, withTempFileEx,
        withTempDirectory, withTempDirectoryEx,
92
93

        -- * .cabal and .buildinfo files
94
95
        defaultPackageDesc,
        findPackageDesc,
96
        tryFindPackageDesc,
97
98
        defaultHookedPackageDesc,
        findHookedPackageDesc,
99

100
101
102
        -- * reading and writing files safely
        withFileContents,
        writeFileAtomic,
103
        rewriteFile,
104

105
106
107
        -- * Unicode
        fromUTF8,
        toUTF8,
108
        readUTF8File,
109
        withUTF8FileContents,
110
        writeUTF8File,
111
        normaliseLineEndings,
112

113
        -- * generic utils
114
115
        dropWhileEndLE,
        takeWhileEndLE,
116
117
118
119
120
        equating,
        comparing,
        isInfixOf,
        intercalate,
        lowercase,
121
122
123
124
        listUnion,
        listUnionRight,
        ordNub,
        ordNubRight,
125
        wrapText,
126
        wrapLine,
127
128
  ) where

129
import Control.Monad
130
    ( join, when, unless, filterM )
131
132
import Control.Concurrent.MVar
    ( newEmptyMVar, putMVar, takeMVar )
133
import Data.List
134
  ( nub, unfoldr, isPrefixOf, tails, intercalate )
135
import Data.Char as Char
136
    ( isDigit, toLower, chr, ord )
137
import Data.Bits
138
    ( Bits((.|.), (.&.), shiftL, shiftR) )
139
140
import qualified Data.ByteString.Lazy as BS
import qualified Data.ByteString.Lazy.Char8 as BS.Char8
141
import qualified Data.Set as Set
142
143

import System.Directory
refold's avatar
refold committed
144
    ( Permissions(executable), getDirectoryContents, getPermissions
145
146
    , doesDirectoryExist, doesFileExist, removeFile, findExecutable
    , getModificationTime )
147
148
149
150
151
import System.Environment
    ( getProgName )
import System.Exit
    ( exitWith, ExitCode(..) )
import System.FilePath
152
153
    ( normalise, (</>), (<.>)
    , getSearchPath, takeDirectory, splitFileName
154
    , splitExtension, splitExtensions, splitDirectories )
155
import System.Directory
156
    ( createDirectory, renameFile, removeDirectoryRecursive )
157
import System.IO
158
    ( Handle, openFile, openBinaryFile, openBinaryTempFileWithDefaultPermissions
159
    , IOMode(ReadMode), hSetBinaryMode
160
    , hGetContents, stderr, stdout, hPutStr, hFlush, hClose )
161
import System.IO.Error as IO.Error
162
163
    ( isDoesNotExistError, isAlreadyExistsError
    , ioeSetFileName, ioeGetFileName, ioeGetErrorString )
Duncan Coutts's avatar
Duncan Coutts committed
164
165
import System.IO.Error
    ( ioeSetLocation, ioeGetLocation )
166
167
import System.IO.Unsafe
    ( unsafeInterleaveIO )
168
import qualified Control.Exception as Exception
169

170
import Distribution.Text
171
    ( display, simpleParse )
172
import Distribution.Package
173
    ( PackageIdentifier )
174
175
import Distribution.ModuleName (ModuleName)
import qualified Distribution.ModuleName as ModuleName
176
177
import Distribution.Version
    (Version(..))
178

179
import Control.Exception (IOException, evaluate, throwIO)
180
import Control.Concurrent (forkIO)
181
182
183
184
185
import qualified System.Process as Process
         ( CreateProcess(..), StdStream(..), proc)
import System.Process
         ( createProcess, rawSystem, runInteractiveProcess
         , showCommandForUser, waitForProcess)
186
import Distribution.Compat.CopyFile
187
         ( copyFile, copyOrdinaryFile, copyExecutableFile
188
         , setFileOrdinary, setFileExecutable, setDirOrdinary )
189
import Distribution.Compat.TempFile
190
         ( openTempFile, createTempDirectory )
191
import Distribution.Compat.Exception
192
         ( tryIO, catchIO, catchExit )
193
import Distribution.Verbosity
194

195
196
#ifdef VERSION_base
import qualified Paths_Cabal (version)
197
198
#endif

199
200
-- We only get our own version number when we're building with ourselves
cabalVersion :: Version
201
#if defined(VERSION_base)
202
cabalVersion = Paths_Cabal.version
203
204
#elif defined(CABAL_VERSION)
cabalVersion = Version [CABAL_VERSION] []
205
#else
206
cabalVersion = Version [1,9999] []  --used when bootstrapping
207
208
#endif

209
210
-- ----------------------------------------------------------------------------
-- Exception and logging utils
ijones's avatar
ijones committed
211

212
213
dieWithLocation :: FilePath -> Maybe Int -> String -> IO a
dieWithLocation filename lineno msg =
214
215
216
217
218
219
  ioError . setLocation lineno
          . flip ioeSetFileName (normalise filename)
          $ userError msg
  where
    setLocation Nothing  err = err
    setLocation (Just n) err = ioeSetLocation err (show n)
simonmar's avatar
simonmar committed
220
221

die :: String -> IO a
222
223
die msg = ioError (userError msg)

224
225
topHandlerWith :: (Exception.IOException -> IO a) -> IO a -> IO a
topHandlerWith cont prog = catchIO prog handle
226
227
228
229
230
  where
    handle ioe = do
      hFlush stdout
      pname <- getProgName
      hPutStr stderr (mesage pname)
231
      cont ioe
232
233
234
235
236
237
      where
        mesage pname = wrapText (pname ++ ": " ++ file ++ detail)
        file         = case ioeGetFileName ioe of
                         Nothing   -> ""
                         Just path -> path ++ location ++ ": "
        location     = case ioeGetLocation ioe of
238
239
                         l@(n:_) | Char.isDigit n -> ':' : l
                         _                        -> ""
240
        detail       = ioeGetErrorString ioe
simonmar's avatar
simonmar committed
241

242
243
244
topHandler :: IO a -> IO a
topHandler prog = topHandlerWith (const $ exitWith (ExitFailure 1)) prog

245
246
247
248
-- | Non fatal conditions that may be indicative of an error or problem.
--
-- We display these at the 'normal' verbosity level.
--
249
warn :: Verbosity -> String -> IO ()
250
warn verbosity msg =
251
252
  when (verbosity >= normal) $ do
    hFlush stdout
253
    hPutStr stderr (wrapText ("Warning: " ++ msg))
254
255
256
257
258
259
260
261
262
263
264

-- | 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.
--
notice :: Verbosity -> String -> IO ()
notice verbosity msg =
  when (verbosity >= normal) $
265
    putStr (wrapText msg)
266

267
268
setupMessage :: Verbosity -> String -> PackageIdentifier -> IO ()
setupMessage verbosity msg pkgid =
269
    notice verbosity (msg ++ ' ': display pkgid ++ "...")
270

271
-- | More detail on the operation of some action.
272
--
273
274
275
276
277
-- We display these messages when the verbosity level is 'verbose'
--
info :: Verbosity -> String -> IO ()
info verbosity msg =
  when (verbosity >= verbose) $
278
    putStr (wrapText msg)
279
280
281
282
283
284
285

-- | Detailed internal debugging information
--
-- We display these messages when the verbosity level is 'deafening'
--
debug :: Verbosity -> String -> IO ()
debug verbosity msg =
286
  when (verbosity >= deafening) $ do
287
    putStr (wrapText msg)
288
    hFlush stdout
289

290
291
292
293
294
295
296
297
-- | A variant of 'debug' that doesn't perform the automatic line
-- wrapping. Produces better output in some cases.
debugNoWrap :: Verbosity -> String -> IO ()
debugNoWrap verbosity msg =
  when (verbosity >= deafening) $ do
    putStrLn msg
    hFlush stdout

298
299
300
301
302
303
-- | 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 =
304
  catchIO action $ \exception ->
305
    putStrLn $ "Error while " ++ desc ++ ": " ++ show exception
306

307
308
309
-- -----------------------------------------------------------------------------
-- Helper functions

310
311
-- | Wraps text to the default line width. Existing newlines are preserved.
wrapText :: String -> String
312
wrapText = unlines
313
314
315
316
         . map (intercalate "\n"
              . map unwords
              . wrapLine 79
              . words)
317
         . lines
318
319
320
321

-- | Wraps a list of words to a list of lines of words of a particular width.
wrapLine :: Int -> [String] -> [[String]]
wrapLine width = wrap 0 []
322
323
324
325
326
327
328
329
330
331
332
333
334
  where wrap :: Int -> [String] -> [String] -> [[String]]
        wrap 0   []   (w:ws)
          | length w + 1 > width
          = wrap (length w) [w] ws
        wrap col line (w:ws)
          | col + length w + 1 > width
          = reverse line : wrap 0 [] (w:ws)
        wrap col line (w:ws)
          = let col' = col + length w + 1
             in wrap col' (w:line) ws
        wrap _ []   [] = []
        wrap _ line [] = [reverse line]

simonmar's avatar
simonmar committed
335
336
337
338
339
-- -----------------------------------------------------------------------------
-- rawSystem variants
maybeExit :: IO ExitCode -> IO ()
maybeExit cmd = do
  res <- cmd
340
  unless (res == ExitSuccess) $ exitWith res
simonmar's avatar
simonmar committed
341

Ian Lynagh's avatar
Ian Lynagh committed
342
printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO ()
Neil Vice's avatar
Neil Vice committed
343
344
printRawCommandAndArgs verbosity path args =
    printRawCommandAndArgsAndEnv verbosity path args Nothing
Ian Lynagh's avatar
Ian Lynagh committed
345

346
347
348
printRawCommandAndArgsAndEnv :: Verbosity
                             -> FilePath
                             -> [String]
Neil Vice's avatar
Neil Vice committed
349
                             -> Maybe [(String, String)]
350
                             -> IO ()
Neil Vice's avatar
Neil Vice committed
351
352
353
354
355
printRawCommandAndArgsAndEnv verbosity path args menv
 | verbosity >= deafening = do
       maybe (return ()) (putStrLn . ("Environment: " ++) . show) menv
       print (path, args)
 | verbosity >= verbose   = putStrLn $ showCommandForUser path args
356
357
 | otherwise              = return ()

358

Ian D. Bollinger's avatar
Ian D. Bollinger committed
359
-- Exit with the same exit code if the subcommand fails
360
361
rawSystemExit :: Verbosity -> FilePath -> [String] -> IO ()
rawSystemExit verbosity path args = do
Ian Lynagh's avatar
Ian Lynagh committed
362
  printRawCommandAndArgs verbosity path args
363
  hFlush stdout
364
365
366
367
  exitcode <- rawSystem path args
  unless (exitcode == ExitSuccess) $ do
    debug verbosity $ path ++ " returned " ++ show exitcode
    exitWith exitcode
simonmar's avatar
simonmar committed
368

tibbe's avatar
tibbe committed
369
370
371
372
373
374
375
376
377
rawSystemExitCode :: Verbosity -> FilePath -> [String] -> IO ExitCode
rawSystemExitCode verbosity path args = do
  printRawCommandAndArgs verbosity path args
  hFlush stdout
  exitcode <- rawSystem path args
  unless (exitcode == ExitSuccess) $ do
    debug verbosity $ path ++ " returned " ++ show exitcode
  return exitcode

378
379
380
381
382
rawSystemExitWithEnv :: Verbosity
                     -> FilePath
                     -> [String]
                     -> [(String, String)]
                     -> IO ()
383
rawSystemExitWithEnv verbosity path args env = do
Neil Vice's avatar
Neil Vice committed
384
    printRawCommandAndArgsAndEnv verbosity path args (Just env)
385
    hFlush stdout
386
387
    (_,_,_,ph) <- createProcess $
                  (Process.proc path args) { Process.env = (Just env)
Edward Z. Yang's avatar
Edward Z. Yang committed
388
389
#ifdef MIN_VERSION_process
#if MIN_VERSION_process(1,2,0)
390
391
392
-- 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
393
#endif
394
395
#endif
                                           }
396
    exitcode <- waitForProcess ph
397
398
399
400
    unless (exitcode == ExitSuccess) $ do
        debug verbosity $ path ++ " returned " ++ show exitcode
        exitWith exitcode

401
402
403
404
-- Closes the passed in handles before returning.
rawSystemIOWithEnv :: Verbosity
                   -> FilePath
                   -> [String]
405
406
                   -> Maybe FilePath           -- ^ New working dir or inherit
                   -> Maybe [(String, String)] -- ^ New environment or inherit
407
408
409
410
                   -> Maybe Handle  -- ^ stdin
                   -> Maybe Handle  -- ^ stdout
                   -> Maybe Handle  -- ^ stderr
                   -> IO ExitCode
411
rawSystemIOWithEnv verbosity path args mcwd menv inp out err = do
Neil Vice's avatar
Neil Vice committed
412
    printRawCommandAndArgsAndEnv verbosity path args menv
413
    hFlush stdout
414
415
416
417
418
419
    (_,_,_,ph) <- createProcess $
                  (Process.proc path args) { Process.cwd           = mcwd
                                           , Process.env           = menv
                                           , Process.std_in        = mbToStd inp
                                           , Process.std_out       = mbToStd out
                                           , Process.std_err       = mbToStd err
Edward Z. Yang's avatar
Edward Z. Yang committed
420
421
#ifdef MIN_VERSION_process
#if MIN_VERSION_process(1,2,0)
422
423
424
-- 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
425
#endif
426
427
#endif
                                           }
428
    exitcode <- waitForProcess ph
429
430
431
    unless (exitcode == ExitSuccess) $ do
      debug verbosity $ path ++ " returned " ++ show exitcode
    return exitcode
432
  where
433
434
    mbToStd :: Maybe Handle -> Process.StdStream
    mbToStd = maybe Process.Inherit Process.UseHandle
435

436
437
-- | Run a command and return its output.
--
438
-- The output is assumed to be text in the locale encoding.
439
--
440
441
rawSystemStdout :: Verbosity -> FilePath -> [String] -> IO String
rawSystemStdout verbosity path args = do
442
  (output, errors, exitCode) <- rawSystemStdInOut verbosity path args
443
                                                  Nothing Nothing
444
445
446
                                                  Nothing False
  when (exitCode /= ExitSuccess) $
    die errors
447
448
  return output

449
450
451
452
453
-- | 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.
--
rawSystemStdInOut :: Verbosity
454
455
456
457
458
459
                  -> FilePath                 -- ^ Program location
                  -> [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
460
                  -> IO (String, String, ExitCode) -- ^ output, errors, exit
461
rawSystemStdInOut verbosity path args mcwd menv input outputBinary = do
Ian Lynagh's avatar
Ian Lynagh committed
462
  printRawCommandAndArgs verbosity path args
463

464
  Exception.bracket
465
     (runInteractiveProcess path args mcwd menv)
466
     (\(inh,outh,errh,_) -> hClose inh >> hClose outh >> hClose errh)
467
    $ \(inh,outh,errh,pid) -> do
468

469
470
471
472
      -- 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
473

474
      -- fork off a couple threads to pull on the stderr and stdout
475
      -- so if the process writes to stderr we do not block.
476

477
      err <- hGetContents errh
478
      out <- hGetContents outh
479

480
      mv <- newEmptyMVar
481
      let force str = (evaluate (length str) >> return ())
482
            `Exception.finally` putMVar mv ()
483
          --TODO: handle exceptions like text decoding.
484
485
      _ <- forkIO $ force out
      _ <- forkIO $ force err
486
487
488
489
490
491
492
493
494
495
496
497
498

      -- 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
499
500
      takeMVar mv
      takeMVar mv
501
502
503

      -- wait for the program to terminate
      exitcode <- waitForProcess pid
504
505
506
507
      unless (exitcode == ExitSuccess) $
        debug verbosity $ path ++ " returned " ++ show exitcode
                       ++ if null err then "" else
                          " with error message:\n" ++ err
508
509
510
511
                       ++ case input of
                            Nothing       -> ""
                            Just ("",  _) -> ""
                            Just (inp, _) -> "\nstdin input:\n" ++ inp
512

513
      return (out, err, exitcode)
514
515
516


-- | Look for a program on the path.
517
518
findProgramLocation :: Verbosity -> FilePath -> IO (Maybe FilePath)
findProgramLocation verbosity prog = do
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
  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
                   -> Verbosity
                   -> FilePath           -- ^ location
                   -> IO (Maybe Version)
findProgramVersion versionArg selectVersion verbosity path = do
  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
550
-- | Like the Unix xargs program. Useful for when we've got very long command
551
552
553
554
-- 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:
555
--
556
-- > xargs (32*1024) (rawSystemExit verbosity) prog fixedArgs bigArgs
557
--
558
559
560
xargs :: Int -> ([String] -> IO ())
      -> [String] -> [String] -> IO ()
xargs maxSize rawSystemFun fixedArgs bigArgs =
561
  let fixedArgSize = sum (map length fixedArgs) + length fixedArgs
562
      chunkSize = maxSize - fixedArgSize
563
   in mapM_ (rawSystemFun . (fixedArgs ++)) (chunks chunkSize bigArgs)
564
565
566
567
568

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

Ian Lynagh's avatar
Ian Lynagh committed
569
        chunk acc _   []     = (reverse acc,[])
570
571
572
573
        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
574
575
576
577
578

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

579
580
581
582
583
----------------
-- Finding files

-- | Find a file by looking in a search path. The file path must match exactly.
--
ijones's avatar
ijones committed
584
585
586
findFile :: [FilePath]    -- ^search locations
         -> FilePath      -- ^File Name
         -> IO FilePath
587
588
589
590
591
592
findFile searchPath fileName =
  findFirstFile id
    [ path </> fileName
    | path <- nub searchPath]
  >>= maybe (die $ fileName ++ " doesn't exist") return

593
594
595
596
-- | 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.
--
597
598
599
600
601
602
603
604
605
606
findFileWithExtension :: [String]
                      -> [FilePath]
                      -> FilePath
                      -> IO (Maybe FilePath)
findFileWithExtension extensions searchPath baseName =
  findFirstFile id
    [ path </> baseName <.> ext
    | path <- nub searchPath
    , ext <- nub extensions ]

607
608
609
-- | Like 'findFileWithExtension' but returns which element of the search path
-- the file was found in, and the file path relative to that base directory.
--
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
findFileWithExtension' :: [String]
                       -> [FilePath]
                       -> FilePath
                       -> IO (Maybe (FilePath, FilePath))
findFileWithExtension' extensions searchPath baseName =
  findFirstFile (uncurry (</>))
    [ (path, baseName <.> ext)
    | path <- nub searchPath
    , ext <- nub extensions ]

findFirstFile :: (a -> FilePath) -> [a] -> IO (Maybe a)
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
627

628
629
630
631
-- | Finds the files corresponding to a list of Haskell module names.
--
-- As 'findModuleFile' but for a list of module names.
--
632
633
634
635
636
637
638
findModuleFiles :: [FilePath]   -- ^ build prefix (location of objects)
                -> [String]     -- ^ search suffixes
                -> [ModuleName] -- ^ modules
                -> IO [(FilePath, FilePath)]
findModuleFiles searchPath extensions moduleNames =
  mapM (findModuleFile searchPath extensions) moduleNames

639
640
641
642
643
-- | 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.
--
644
645
646
647
648
649
650
651
652
653
654
655
656
findModuleFile :: [FilePath]  -- ^ build prefix (location of objects)
               -> [String]    -- ^ search suffixes
               -> ModuleName  -- ^ module
               -> IO (FilePath, FilePath)
findModuleFile searchPath extensions moduleName =
      maybe notFound return
  =<< findFileWithExtension' extensions searchPath
                             (ModuleName.toFilePath moduleName)
  where
    notFound = die $ "Error: Could not find module: " ++ display moduleName
                  ++ " with any suffix: " ++ show extensions
                  ++ " in the search path: " ++ show searchPath

657
658
659
660
661
662
-- | List all the files in a directory and all subdirectories.
--
-- The order places files in sub-directories after all the files in their
-- parent directories. The list is generated lazily so is not well defined if
-- the source directory structure changes before the list is used.
--
663
664
665
666
667
668
669
670
671
672
673
getDirectoryContentsRecursive :: FilePath -> IO [FilePath]
getDirectoryContentsRecursive topdir = recurseDirectories [""]
  where
    recurseDirectories :: [FilePath] -> IO [FilePath]
    recurseDirectories []         = return []
    recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do
      (files, dirs') <- collect [] [] =<< getDirectoryContents (topdir </> dir)
      files' <- recurseDirectories (dirs' ++ dirs)
      return (files ++ files')

      where
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
674
675
        collect files dirs' []              = return (reverse files
                                                     ,reverse dirs')
676
677
678
679
680
681
682
683
684
685
686
687
688
        collect files dirs' (entry:entries) | ignore entry
                                            = collect files dirs' entries
        collect files dirs' (entry:entries) = do
          let dirEntry = dir </> entry
          isDirectory <- doesDirectoryExist (topdir </> dirEntry)
          if isDirectory
            then collect files (dirEntry:dirs') entries
            else collect (dirEntry:files) dirs' entries

        ignore ['.']      = True
        ignore ['.', '.'] = True
        ignore _          = False

689
690
691
692
693
694
695
------------------------
-- Environment variables

-- | Is this directory in the system search path?
isInSearchPath :: FilePath -> IO Bool
isInSearchPath path = fmap (elem path) getSearchPath

696
697
698
----------------
-- File globbing

699
700
701
702
data FileGlob
   -- | No glob at all, just an ordinary file
   = NoGlob FilePath

Duncan Coutts's avatar
Duncan Coutts committed
703
   -- | dir prefix and extension, like @\"foo\/bar\/\*.baz\"@ corresponds to
704
   --    @FileGlob \"foo\/bar\" \".baz\"@
705
706
707
708
709
710
   | FileGlob FilePath String

parseFileGlob :: FilePath -> Maybe FileGlob
parseFileGlob filepath = case splitExtensions filepath of
  (filepath', ext) -> case splitFileName filepath' of
    (dir, "*") | '*' `elem` dir
711
712
              || '*' `elem` ext
              || null ext            -> Nothing
713
714
715
716
717
718
               | null dir            -> Just (FileGlob "." ext)
               | otherwise           -> Just (FileGlob dir ext)
    _          | '*' `elem` filepath -> Nothing
               | otherwise           -> Just (NoGlob filepath)

matchFileGlob :: FilePath -> IO [FilePath]
719
matchFileGlob = matchDirFileGlob "."
720

Ian Lynagh's avatar
Ian Lynagh committed
721
722
matchDirFileGlob :: FilePath -> FilePath -> IO [FilePath]
matchDirFileGlob dir filepath = case parseFileGlob filepath of
723
  Nothing -> die $ "invalid file glob '" ++ filepath
Ian Lynagh's avatar
Ian Lynagh committed
724
725
                ++ "'. Wildcards '*' are only allowed in place of the file"
                ++ " name, not in the directory name or file extension."
726
                ++ " If a wildcard is used it must be with an file extension."
Ian Lynagh's avatar
Ian Lynagh committed
727
728
729
  Just (NoGlob filepath') -> return [filepath']
  Just (FileGlob dir' ext) -> do
    files <- getDirectoryContents (dir </> dir')
730
    case   [ dir' </> file
731
732
           | file <- files
           , let (name, ext') = splitExtensions file
733
734
735
736
           , not (null name) && ext' == ext ] of
      []      -> die $ "filepath wildcard '" ++ filepath
                    ++ "' does not match any files."
      matches -> return matches
Ian Lynagh's avatar
Ian Lynagh committed
737

738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
--------------------
-- Modification time

-- | Compare the modification times of two files to see if the first is newer
-- than the second. The first file must exist but the second need not.
-- The expected use case is when the second file is generated using the first.
-- In this use case, if the result is True then the second file is out of date.
--
moreRecentFile :: FilePath -> FilePath -> IO Bool
moreRecentFile a b = do
  exists <- doesFileExist b
  if not exists
    then return True
    else do tb <- getModificationTime b
            ta <- getModificationTime a
            return (ta > tb)

755
756
757
758
759
760
761
762
-- | Like 'moreRecentFile', but also checks that the first file exists.
existsAndIsMoreRecentThan :: FilePath -> FilePath -> IO Bool
existsAndIsMoreRecentThan a b = do
  exists <- doesFileExist a
  if not exists
    then return False
    else a `moreRecentFile` b

763
764
----------------------------------------
-- Copying and installing files and dirs
ijones's avatar
ijones committed
765

766
767
-- | Same as 'createDirectoryIfMissing' but logs at higher verbosity levels.
--
768
769
770
771
772
773
774
775
776
777
778
createDirectoryIfMissingVerbose :: Verbosity
                                -> Bool     -- ^ Create its parents too?
                                -> FilePath
                                -> IO ()
createDirectoryIfMissingVerbose verbosity create_parents path0
  | create_parents = createDirs (parents path0)
  | otherwise      = createDirs (take 1 (parents path0))
  where
    parents = reverse . scanl1 (</>) . splitDirectories . normalise

    createDirs []         = return ()
779
    createDirs (dir:[])   = createDir dir throwIO
780
781
782
    createDirs (dir:dirs) =
      createDir dir $ \_ -> do
        createDirs dirs
783
        createDir dir throwIO
784
785
786
787
788
789
790
791
792
793
794

    createDir :: FilePath -> (IOException -> IO ()) -> IO ()
    createDir dir notExistHandler = do
      r <- tryIO $ createDirectoryVerbose verbosity dir
      case (r :: Either IOException ()) of
        Right ()                   -> return ()
        Left  e
          | isDoesNotExistError  e -> notExistHandler e
          -- createDirectory (and indeed POSIX mkdir) does not distinguish
          -- between a dir already existing and a file already existing. So we
          -- check for it here. Unfortunately there is a slight race condition
Ian D. Bollinger's avatar
Ian D. Bollinger committed
795
          -- here, but we think it is benign. It could report an exception in
796
797
798
799
800
801
          -- the case that the dir did exist but another process deletes the
          -- directory and creates a file in its place before we can check
          -- that the directory did indeed exist.
          | isAlreadyExistsError e -> (do
              isDir <- doesDirectoryExist dir
              if isDir then return ()
802
                       else throwIO e
Duncan Coutts's avatar
Duncan Coutts committed
803
              ) `catchIO` ((\_ -> return ()) :: IOException -> IO ())
804
          | otherwise              -> throwIO e
805
806
807
808
809
810

createDirectoryVerbose :: Verbosity -> FilePath -> IO ()
createDirectoryVerbose verbosity dir = do
  info verbosity $ "creating " ++ dir
  createDirectory dir
  setDirOrdinary dir
811

812
813
814
815
816
-- | Copies a file without copying file permissions. The target file is created
-- with default permissions. Any existing target file is replaced.
--
-- At higher verbosity levels it logs an info message.
--
817
818
copyFileVerbose :: Verbosity -> FilePath -> FilePath -> IO ()
copyFileVerbose verbosity src dest = do
819
  info verbosity ("copy " ++ src ++ " to " ++ dest)
820
821
  copyFile src dest

822
823
824
825
-- | Install an ordinary file. This is like a file copy but the permissions
-- are set appropriately for an installed file. On Unix it is \"-rw-r--r--\"
-- while on Windows it uses the default permissions for the target directory.
--
826
827
828
829
830
installOrdinaryFile :: Verbosity -> FilePath -> FilePath -> IO ()
installOrdinaryFile verbosity src dest = do
  info verbosity ("Installing " ++ src ++ " to " ++ dest)
  copyOrdinaryFile src dest

831
832
833
834
-- | Install an executable file. This is like a file copy but the permissions
-- are set appropriately for an installed file. On Unix it is \"-rwxr-xr-x\"
-- while on Windows it uses the default permissions for the target directory.
--
835
836
837
838
839
installExecutableFile :: Verbosity -> FilePath -> FilePath -> IO ()
installExecutableFile verbosity src dest = do
  info verbosity ("Installing executable " ++ src ++ " to " ++ dest)
  copyExecutableFile src dest

refold's avatar
refold committed
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
-- | Install a file that may or not be executable, preserving permissions.
installMaybeExecutableFile :: Verbosity -> FilePath -> FilePath -> IO ()
installMaybeExecutableFile verbosity src dest = do
  perms <- getPermissions src
  if (executable perms) --only checks user x bit
    then installExecutableFile verbosity src dest
    else installOrdinaryFile   verbosity src dest

-- | Given a relative path to a file, copy it to the given directory, preserving
-- the relative path and creating the parent directories if needed.
copyFileTo :: Verbosity -> FilePath -> FilePath -> IO ()
copyFileTo verbosity dir file = do
  let targetFile = dir </> file
  createDirectoryIfMissingVerbose verbosity True (takeDirectory targetFile)
  installOrdinaryFile verbosity file targetFile

-- | Common implementation of 'copyFiles', 'installOrdinaryFiles',
-- 'installExecutableFiles' and 'installMaybeExecutableFiles'.
copyFilesWith :: (Verbosity -> FilePath -> FilePath -> IO ())
              -> Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()
copyFilesWith doCopy verbosity targetDir srcFiles = do

  -- Create parent directories for everything
  let dirs = map (targetDir </>) . nub . map (takeDirectory . snd) $ srcFiles
  mapM_ (createDirectoryIfMissingVerbose verbosity True) dirs

  -- Copy all the files
  sequence_ [ let src  = srcBase   </> srcFile
                  dest = targetDir </> srcFile
               in doCopy verbosity src dest
            | (srcBase, srcFile) <- srcFiles ]

872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
-- | Copies a bunch of files to a target directory, preserving the directory
-- structure in the target location. The target directories are created if they
-- do not exist.
--
-- The files are identified by a pair of base directory and a path relative to
-- that base. It is only the relative part that is preserved in the
-- destination.
--
-- For example:
--
-- > copyFiles normal "dist/src"
-- >    [("", "src/Foo.hs"), ("dist/build/", "src/Bar.hs")]
--
-- This would copy \"src\/Foo.hs\" to \"dist\/src\/src\/Foo.hs\" and
-- copy \"dist\/build\/src\/Bar.hs\" to \"dist\/src\/src\/Bar.hs\".
--
-- This operation is not atomic. Any IO failure during the copy (including any
-- missing source files) leaves the target in an unknown state so it is best to
-- use it with a freshly created directory so that it can be simply deleted if
-- anything goes wrong.
--
copyFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()
refold's avatar
refold committed
894
copyFiles = copyFilesWith copyFileVerbose
895

896
897
-- | This is like 'copyFiles' but uses 'installOrdinaryFile'.
--
898
installOrdinaryFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()
refold's avatar
refold committed
899
installOrdinaryFiles = copyFilesWith installOrdinaryFile
900

refold's avatar
refold committed
901
902
903
904
905
-- | This is like 'copyFiles' but uses 'installExecutableFile'.
--
installExecutableFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)]
                          -> IO ()
installExecutableFiles = copyFilesWith installExecutableFile
906

refold's avatar
refold committed
907
908
909
910
911
-- | This is like 'copyFiles' but uses 'installMaybeExecutableFile'.
--
installMaybeExecutableFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)]
                               -> IO ()
installMaybeExecutableFiles = copyFilesWith installMaybeExecutableFile
912

913
914
915
916
-- | This installs all the files in a directory to a target location,
-- preserving the directory layout. All the files are assumed to be ordinary
-- rather than executable files.
--
917
918
919
920
921
922
installDirectoryContents :: Verbosity -> FilePath -> FilePath -> IO ()
installDirectoryContents verbosity srcDir destDir = do
  info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.")
  srcFiles <- getDirectoryContentsRecursive srcDir
  installOrdinaryFiles verbosity destDir [ (srcDir, f) | f <- srcFiles ]

923
924
925
926
927
928
929
930
931
932
933
934
-------------------
-- File permissions

-- | Like 'doesFileExist', but also checks that the file is executable.
doesExecutableExist :: FilePath -> IO Bool
doesExecutableExist f = do
  exists <- doesFileExist f
  if exists
    then do perms <- getPermissions f
            return (executable perms)
    else return False

935
936
937
938
939
940
941
942
943
944
945
---------------------------------
-- Deprecated file copy functions

{-# DEPRECATED smartCopySources
      "Use findModuleFiles and copyFiles or installOrdinaryFiles" #-}
smartCopySources :: Verbosity -> [FilePath] -> FilePath
                 -> [ModuleName] -> [String] -> IO ()
smartCopySources verbosity searchPath targetDir moduleNames extensions =
      findModuleFiles searchPath extensions moduleNames
  >>= copyFiles verbosity targetDir

946
947
{-# DEPRECATED copyDirectoryRecursiveVerbose
      "You probably want installDirectoryContents instead" #-}
948
949
copyDirectoryRecursiveVerbose :: Verbosity -> FilePath -> FilePath -> IO ()
copyDirectoryRecursiveVerbose verbosity srcDir destDir = do
950
  info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.")
951
952
  srcFiles <- getDirectoryContentsRecursive srcDir
  copyFiles verbosity destDir [ (srcDir, f) | f <- srcFiles ]
953

954
955
956
---------------------------
-- Temporary files and dirs

957
958
959
960
961
962
963
964
-- | Advanced options for 'withTempFile' and 'withTempDirectory'.
data TempFileOptions = TempFileOptions {
  optKeepTempFiles :: Bool  -- ^ Keep temporary files?
  }

defaultTempFileOptions :: TempFileOptions
defaultTempFileOptions = TempFileOptions { optKeepTempFiles = False }

965
966
-- | Use a temporary filename that doesn't already exist.
--
967
968
969
970
971
972
973
974
975
976
977
978
979
withTempFile :: FilePath    -- ^ Temp dir to create the file in
                -> String   -- ^ File name template. See 'openTempFile'.
                -> (FilePath -> Handle -> IO a) -> IO a
withTempFile tmpDir template action =
  withTempFileEx defaultTempFileOptions tmpDir template action

-- | A version of 'withTempFile' that additionally takes a 'TempFileOptions'
-- argument.
withTempFileEx :: TempFileOptions
                 -> FilePath -- ^ Temp dir to create the file in
                 -> String   -- ^ File name template. See 'openTempFile'.
                 -> (FilePath -> Handle -> IO a) -> IO a
withTempFileEx opts tmpDir template action =
980
981
  Exception.bracket
    (openTempFile tmpDir template)
982
    (\(name, handle) -> do hClose handle
983
                           unless (optKeepTempFiles opts) $ removeFile name)
984
985
    (uncurry action)

986
-- | Create and use a temporary directory.
Duncan Coutts's avatar
Duncan Coutts committed
987
--
988
989
990
991
992
993
994
-- Creates a new temporary directory inside the given directory, making use
-- of the template. The temp directory is deleted after use. For example:
--
-- > withTempDirectory verbosity "src" "sdist." $ \tmpDir -> do ...
--
-- The @tmpDir@ will be a new subdirectory of the given directory, e.g.
-- @src/sdist.342@.
Duncan Coutts's avatar
Duncan Coutts committed
995
--
996
withTempDirectory :: Verbosity
997
998
999
1000
                     -> FilePath -> String -> (FilePath -> IO a) -> IO a
withTempDirectory verbosity targetDir template =
  withTempDirectoryEx verbosity defaultTempFileOptions targetDir template