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

ijones's avatar
ijones committed
19
{- All rights reserved.
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

    * Redistributions of source code must retain the above copyright
      notice, this list of conditions and the following disclaimer.

    * Redistributions in binary form must reproduce the above
      copyright notice, this list of conditions and the following
      disclaimer in the documentation and/or other materials provided
      with the distribution.

    * Neither the name of Isaac Jones nor the names of other
      contributors may be used to endorse or promote products derived
      from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}

module Distribution.Simple.Utils (
50
        cabalVersion,
51
        cabalBootstrapping,
52
53

        -- * logging and errors
54
55
        die,
        dieWithLocation,
56
        warn, notice, setupMessage, info, debug,
57
        chattyTry,
58
59

        -- * running programs
60
        rawSystemExit,
61
        rawSystemStdout,
62
        rawSystemStdout',
63
        maybeExit,
64
        xargs,
65
66

        -- * copying files
67
        smartCopySources,
68
        createDirectoryIfMissingVerbose,
69
        copyFileVerbose,
70
        copyDirectoryRecursiveVerbose,
71
        copyFiles,
72
73

        -- * file names
ijones's avatar
ijones committed
74
        currentDir,
75
76

        -- * finding files
77
        findFile,
78
79
        findFileWithExtension,
        findFileWithExtension',
80

81
82
        -- * simple file globbing
        matchFileGlob,
Ian Lynagh's avatar
Ian Lynagh committed
83
        matchDirFileGlob,
84
85
        parseFileGlob,
        FileGlob(..),
86

Duncan Coutts's avatar
Duncan Coutts committed
87
        -- * temp files and dirs
88
        withTempFile,
Duncan Coutts's avatar
Duncan Coutts committed
89
        withTempDirectory,
90
91

        -- * .cabal and .buildinfo files
92
93
        defaultPackageDesc,
        findPackageDesc,
94
95
        defaultHookedPackageDesc,
        findHookedPackageDesc,
96

97
98
99
        -- * reading and writing files safely
        withFileContents,
        writeFileAtomic,
100
        rewriteFile,
101

102
103
104
        -- * Unicode
        fromUTF8,
        toUTF8,
105
        readUTF8File,
106
        withUTF8FileContents,
107
        writeUTF8File,
108

109
110
111
112
113
114
115
        -- * generic utils
        equating,
        comparing,
        isInfixOf,
        intercalate,
        lowercase,
        wrapText,
116
        wrapLine,
117
118
  ) where

119
import Control.Monad
120
    ( when, unless, filterM )
121
import Data.List
122
123
    ( nub, unfoldr, isPrefixOf, tails, intersperse )
import Data.Char as Char
124
125
    ( toLower, chr, ord )
import Data.Bits
126
    ( Bits((.|.), (.&.), shiftL, shiftR) )
127
128

import System.Directory
Duncan Coutts's avatar
Duncan Coutts committed
129
    ( getDirectoryContents, doesDirectoryExist, doesFileExist, removeFile )
130
131
import System.Environment
    ( getProgName )
132
133
import System.Cmd
    ( rawSystem )
134
135
136
import System.Exit
    ( exitWith, ExitCode(..) )
import System.FilePath
137
    ( normalise, (</>), (<.>), takeDirectory, splitFileName
138
    , splitExtension, splitExtensions )
139
import System.Directory
Duncan Coutts's avatar
Duncan Coutts committed
140
    ( copyFile, createDirectoryIfMissing, renameFile, removeDirectoryRecursive )
141
import System.IO
142
143
    ( Handle, openFile, openBinaryFile, IOMode(ReadMode), hSetBinaryMode
    , hGetContents, stderr, stdout, hPutStr, hFlush, hClose )
144
import System.IO.Error as IO.Error
145
    ( try, isDoesNotExistError )
146
import qualified Control.Exception as Exception
147

148
149
import Distribution.Text
    ( display )
150
import Distribution.Package
151
    ( PackageIdentifier )
152
153
import Distribution.ModuleName (ModuleName)
import qualified Distribution.ModuleName as ModuleName
154
155
import Distribution.Version
    (Version(..))
156

Malcolm.Wallace's avatar
Malcolm.Wallace committed
157
158
import Control.Exception (evaluate)

159
160
161
162
163
164
#ifdef __GLASGOW_HASKELL__
import Control.Concurrent (forkIO)
import System.Process (runInteractiveProcess, waitForProcess)
#else
import System.Cmd (system)
import System.Directory (getTemporaryDirectory)
165
#endif
simonmar's avatar
simonmar committed
166

167
168
import Distribution.Compat.TempFile (openTempFile,
                                     openNewBinaryFile)
169
import Distribution.Compat.Exception (catchIO, onException)
Ian Lynagh's avatar
Ian Lynagh committed
170
171
172
#if mingw32_HOST_OS || mingw32_TARGET_OS
import Distribution.Compat.Exception (throwIOIO)
#endif
173
import Distribution.Verbosity
174

175
176
177
178
179
180
181
182
-- We only get our own version number when we're building with ourselves
cabalVersion :: Version
#ifdef CABAL_VERSION
cabalVersion = Version [CABAL_VERSION] []
#else
cabalVersion = error "Cabal was not bootstrapped correctly"
#endif

183
184
185
186
187
188
189
cabalBootstrapping :: Bool
#ifdef CABAL_VERSION
cabalBootstrapping = False
#else
cabalBootstrapping = True
#endif

ijones's avatar
ijones committed
190
191
-- ------------------------------------------------------------------------------- Utils for setup

192
193
194
195
196
dieWithLocation :: FilePath -> Maybe Int -> String -> IO a
dieWithLocation filename lineno msg =
  die $ normalise filename
     ++ maybe "" (\n -> ":" ++ show n) lineno
     ++ ": " ++ msg
simonmar's avatar
simonmar committed
197
198

die :: String -> IO a
ijones's avatar
ijones committed
199
200
201
die msg = do
  hFlush stdout
  pname <- getProgName
202
  hPutStr stderr (wrapText (pname ++ ": " ++ msg))
ijones's avatar
ijones committed
203
  exitWith (ExitFailure 1)
simonmar's avatar
simonmar committed
204

205
206
207
208
-- | Non fatal conditions that may be indicative of an error or problem.
--
-- We display these at the 'normal' verbosity level.
--
209
warn :: Verbosity -> String -> IO ()
210
warn verbosity msg =
211
212
  when (verbosity >= normal) $ do
    hFlush stdout
213
    hPutStr stderr (wrapText ("Warning: " ++ msg))
214
215
216
217
218
219
220
221
222
223
224

-- | 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) $
225
    putStr (wrapText msg)
226

227
228
setupMessage :: Verbosity -> String -> PackageIdentifier -> IO ()
setupMessage verbosity msg pkgid =
229
    notice verbosity (msg ++ ' ': display pkgid ++ "...")
230

231
-- | More detail on the operation of some action.
232
--
233
234
235
236
237
-- We display these messages when the verbosity level is 'verbose'
--
info :: Verbosity -> String -> IO ()
info verbosity msg =
  when (verbosity >= verbose) $
238
    putStr (wrapText msg)
239
240
241
242
243
244
245

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

250
251
252
253
254
255
-- | 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 =
256
  catchIO action $ \exception ->
257
    putStrLn $ "Error while " ++ desc ++ ": " ++ show exception
258

259
260
261
-- -----------------------------------------------------------------------------
-- Helper functions

262
263
-- | Wraps text to the default line width. Existing newlines are preserved.
wrapText :: String -> String
264
265
266
267
268
wrapText = unlines
         . concatMap (map unwords
                    . wrapLine 79
                    . words)
         . lines
269
270
271
272

-- | Wraps a list of words to a list of lines of words of a particular width.
wrapLine :: Int -> [String] -> [[String]]
wrapLine width = wrap 0 []
273
274
275
276
277
278
279
280
281
282
283
284
285
  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
286
287
288
289
290
-- -----------------------------------------------------------------------------
-- rawSystem variants
maybeExit :: IO ExitCode -> IO ()
maybeExit cmd = do
  res <- cmd
291
  unless (res == ExitSuccess) $ exitWith res
simonmar's avatar
simonmar committed
292

Ian Lynagh's avatar
Ian Lynagh committed
293
294
295
296
297
298
printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO ()
printRawCommandAndArgs verbosity path args
 | verbosity >= deafening = print (path, args)
 | verbosity >= verbose   = putStrLn $ unwords (path : args)
 | otherwise              = return ()

simonmar's avatar
simonmar committed
299
-- Exit with the same exitcode if the subcommand fails
300
301
rawSystemExit :: Verbosity -> FilePath -> [String] -> IO ()
rawSystemExit verbosity path args = do
Ian Lynagh's avatar
Ian Lynagh committed
302
  printRawCommandAndArgs verbosity path args
303
  hFlush stdout
304
305
306
307
  exitcode <- rawSystem path args
  unless (exitcode == ExitSuccess) $ do
    debug verbosity $ path ++ " returned " ++ show exitcode
    exitWith exitcode
simonmar's avatar
simonmar committed
308

309
310
311
312
-- | Run a command and return its output.
--
-- The output is assumed to be encoded as UTF8.
--
313
314
rawSystemStdout :: Verbosity -> FilePath -> [String] -> IO String
rawSystemStdout verbosity path args = do
315
316
317
318
319
320
  (output, exitCode) <- rawSystemStdout' verbosity path args
  unless (exitCode == ExitSuccess) $ exitWith exitCode
  return output

rawSystemStdout' :: Verbosity -> FilePath -> [String] -> IO (String, ExitCode)
rawSystemStdout' verbosity path args = do
Ian Lynagh's avatar
Ian Lynagh committed
321
  printRawCommandAndArgs verbosity path args
322

323
#ifdef __GLASGOW_HASKELL__
324
325
326
  Exception.bracket
     (runInteractiveProcess path args Nothing Nothing)
     (\(inh,outh,errh,_) -> hClose inh >> hClose outh >> hClose errh)
327
328
    $ \(_,outh,errh,pid) -> do

329
330
331
      -- We want to process the output as text.
      hSetBinaryMode outh False

332
333
      -- fork off a thread to pull on (and discard) the stderr
      -- so if the process writes to stderr we do not block.
334
335
336
      -- NB. do the hGetContents synchronously, otherwise the outer
      -- bracket can exit before this thread has run, and hGetContents
      -- will fail.
337
      err <- hGetContents errh
338
      forkIO $ do evaluate (length err); return ()
339
340

      -- wait for all the output
341
      output <- hGetContents outh
342
343
344
345
      evaluate (length output)

      -- wait for the program to terminate
      exitcode <- waitForProcess pid
346
347
348
349
      unless (exitcode == ExitSuccess) $
        debug verbosity $ path ++ " returned " ++ show exitcode
                       ++ if null err then "" else
                          " with error message:\n" ++ err
350
351

      return (output, exitcode)
352
#else
353
354
355
  tmpDir <- getTemporaryDirectory
  withTempFile tmpDir ".cmd.stdout" $ \tmpName tmpHandle -> do
    hClose tmpHandle
356
    let quote name = "'" ++ name ++ "'"
357
    exitcode <- system $ unwords (map quote (path:args)) ++ " >" ++ quote tmpName
358
359
    unless (exitcode == ExitSuccess) $
      debug verbosity $ path ++ " returned " ++ show exitcode
360
361
    withFileContents tmpName $ \output ->
      length output `seq` return (output, exitcode)
362
#endif
363

364
365
366
367
368
-- | Like the unix xargs program. Useful for when we've got very long command
-- 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:
369
--
370
-- > xargs (32*1024) (rawSystemExit verbosity) prog fixedArgs bigArgs
371
--
372
373
374
xargs :: Int -> ([String] -> IO ())
      -> [String] -> [String] -> IO ()
xargs maxSize rawSystemFun fixedArgs bigArgs =
375
  let fixedArgSize = sum (map length fixedArgs) + length fixedArgs
376
      chunkSize = maxSize - fixedArgSize
377
   in mapM_ (rawSystemFun . (fixedArgs ++)) (chunks chunkSize bigArgs)
378
379
380
381
382

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

Ian Lynagh's avatar
Ian Lynagh committed
383
        chunk acc _   []     = (reverse acc,[])
384
385
386
387
        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
388
389
390
391
392

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

ijones's avatar
ijones committed
393
394
395
findFile :: [FilePath]    -- ^search locations
         -> FilePath      -- ^File Name
         -> IO FilePath
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
findFile searchPath fileName =
  findFirstFile id
    [ path </> fileName
    | path <- nub searchPath]
  >>= maybe (die $ fileName ++ " doesn't exist") return

findFileWithExtension :: [String]
                      -> [FilePath]
                      -> FilePath
                      -> IO (Maybe FilePath)
findFileWithExtension extensions searchPath baseName =
  findFirstFile id
    [ path </> baseName <.> ext
    | path <- nub searchPath
    , ext <- nub extensions ]

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
429

430
431
432
433
data FileGlob
   -- | No glob at all, just an ordinary file
   = NoGlob FilePath

Duncan Coutts's avatar
Duncan Coutts committed
434
   -- | dir prefix and extension, like @\"foo\/bar\/\*.baz\"@ corresponds to
435
   --    @FileGlob \"foo\/bar\" \".baz\"@
436
437
438
439
440
441
   | FileGlob FilePath String

parseFileGlob :: FilePath -> Maybe FileGlob
parseFileGlob filepath = case splitExtensions filepath of
  (filepath', ext) -> case splitFileName filepath' of
    (dir, "*") | '*' `elem` dir
442
443
              || '*' `elem` ext
              || null ext            -> Nothing
444
445
446
447
448
449
               | null dir            -> Just (FileGlob "." ext)
               | otherwise           -> Just (FileGlob dir ext)
    _          | '*' `elem` filepath -> Nothing
               | otherwise           -> Just (NoGlob filepath)

matchFileGlob :: FilePath -> IO [FilePath]
450
matchFileGlob = matchDirFileGlob "."
451

Ian Lynagh's avatar
Ian Lynagh committed
452
453
matchDirFileGlob :: FilePath -> FilePath -> IO [FilePath]
matchDirFileGlob dir filepath = case parseFileGlob filepath of
454
  Nothing -> die $ "invalid file glob '" ++ filepath
Ian Lynagh's avatar
Ian Lynagh committed
455
456
                ++ "'. Wildcards '*' are only allowed in place of the file"
                ++ " name, not in the directory name or file extension."
457
                ++ " If a wildcard is used it must be with an file extension."
Ian Lynagh's avatar
Ian Lynagh committed
458
459
460
  Just (NoGlob filepath') -> return [filepath']
  Just (FileGlob dir' ext) -> do
    files <- getDirectoryContents (dir </> dir')
461
    case   [ dir' </> file
462
463
           | file <- files
           , let (name, ext') = splitExtensions file
464
465
466
467
           , 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
468

469
470
471
472
473
-- |Copy the source files into the right directory.  Looks in the
-- build prefix for files that look like the input modules, based on
-- the input search suffixes.  It copies the files into the target
-- directory.

474
smartCopySources :: Verbosity -- ^verbosity
ijones's avatar
ijones committed
475
            -> [FilePath] -- ^build prefix (location of objects)
476
            -> FilePath -- ^Target directory
477
            -> [ModuleName] -- ^Modules
ijones's avatar
ijones committed
478
            -> [String] -- ^search suffixes
ijones's avatar
ijones committed
479
            -> IO ()
480
481
smartCopySources verbosity srcDirs targetDir sources searchSuffixes
    = mapM moduleToFPErr sources >>= copyFiles verbosity targetDir
482

ijones's avatar
ijones committed
483
    where moduleToFPErr m
484
              = findFileWithExtension' searchSuffixes srcDirs (ModuleName.toFilePath m)
485
            >>= maybe notFound return
486
            where notFound = die $ "Error: Could not find module: " ++ display m
487
                                ++ " with any suffix: " ++ show searchSuffixes
ijones's avatar
ijones committed
488

489
490
createDirectoryIfMissingVerbose :: Verbosity -> Bool -> FilePath -> IO ()
createDirectoryIfMissingVerbose verbosity parentsToo dir = do
491
492
  let msgParents = if parentsToo then " (and its parents)" else ""
  info verbosity ("Creating " ++ dir ++ msgParents)
493
494
  createDirectoryIfMissing parentsToo dir

495
496
copyFileVerbose :: Verbosity -> FilePath -> FilePath -> IO ()
copyFileVerbose verbosity src dest = do
497
  info verbosity ("copy " ++ src ++ " to " ++ dest)
498
499
  copyFile src dest

500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
-- | 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 ()
copyFiles 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 copyFileVerbose verbosity src dest
            | (srcBase, srcFile) <- srcFiles ]

534
-- adaptation of removeDirectoryRecursive
535
536
copyDirectoryRecursiveVerbose :: Verbosity -> FilePath -> FilePath -> IO ()
copyDirectoryRecursiveVerbose verbosity srcDir destDir = do
537
  info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.")
538
539
  let aux src dest =
         let cp :: FilePath -> IO ()
540
541
             cp f = let srcFile  = src  </> f
                        destFile = dest </> f
542
                    in  do success <- try (copyFileVerbose verbosity srcFile destFile)
543
544
545
546
547
548
                           case success of
                              Left e  -> do isDir <- doesDirectoryExist srcFile
                                            -- If f is not a directory, re-throw the error
                                            unless isDir $ ioError e
                                            aux srcFile destFile
                              Right _ -> return ()
549
         in  do createDirectoryIfMissingVerbose verbosity False dest
550
551
552
                getDirectoryContentsWithoutSpecial src >>= mapM_ cp
   in aux srcDir destDir

553
554
555
  where getDirectoryContentsWithoutSpecial =
            fmap (filter (not . flip elem [".", ".."]))
          . getDirectoryContents
556

557
558
559
560
561
562
-- | Use a temporary filename that doesn't already exist.
--
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 =
563
564
565
566
567
  Exception.bracket
    (openTempFile tmpDir template)
    (\(name, handle) -> hClose handle >> removeFile name)
    (uncurry action)

Duncan Coutts's avatar
Duncan Coutts committed
568
569
570
571
572
573
574
575
576
577
-- | Use a temporary directory.
--
-- Use this exact given dir which must not already exist.
--
withTempDirectory :: Verbosity -> FilePath -> IO a -> IO a
withTempDirectory verbosity tmpDir =
  Exception.bracket_
    (createDirectoryIfMissingVerbose verbosity True tmpDir)
    (removeDirectoryRecursive tmpDir)

578
579
580
581
582
583
584
585
586
587
-- | Gets the contents of a file, but guarantee that it gets closed.
--
-- The file is read lazily but if it is not fully consumed by the action then
-- the remaining input is truncated and the file is closed.
--
withFileContents :: FilePath -> (String -> IO a) -> IO a
withFileContents name action =
  Exception.bracket (openFile name ReadMode) hClose
                    (\hnd -> hGetContents hnd >>= action)

588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
-- | Writes a file atomically.
--
-- The file is either written sucessfully or an IO exception is raised and
-- the original file is left unchanged.
--
-- * Warning: On Windows this operation is very nearly but not quite atomic.
--   See below.
--
-- On Posix it works by writing a temporary file and atomically renaming over
-- the top any pre-existing target file with the temporary one.
--
-- On Windows it is not possible to rename over an existing file so the target
-- file has to be deleted before the temporary file is renamed to the target.
-- Therefore there is a race condition between the existing file being removed
-- and the temporary file being renamed. Another thread could write to the
-- target or change the permission on the target directory between the deleting
-- and renaming steps. An exception would be raised but the target file would
-- either no longer exist or have the content as written by the other thread.
--
-- On windows it is not possible to delete a file that is open by a process.
-- This case will give an IO exception but the atomic property is not affected.
--
writeFileAtomic :: FilePath -> String -> IO ()
writeFileAtomic targetFile content = do
612
  (tmpFile, tmpHandle) <- openNewBinaryFile targetDir template
613
  do  hPutStr tmpHandle content
614
615
616
617
      hClose tmpHandle
#if mingw32_HOST_OS || mingw32_TARGET_OS
      renameFile tmpFile targetFile
        -- If the targetFile exists then renameFile will fail
Ian Lynagh's avatar
Ian Lynagh committed
618
        `catchIO` \err -> do
619
          exists <- doesFileExist targetFile
620
          if exists
621
            then do removeFile targetFile
622
623
                    -- Big fat hairy race condition
                    renameFile tmpFile targetFile
624
625
                    -- If the removeFile succeeds and the renameFile fails
                    -- then we've lost the atomic property.
Ian Lynagh's avatar
Ian Lynagh committed
626
            else throwIOIO err
627
628
629
#else
      renameFile tmpFile targetFile
#endif
630
631
   `onException` do hClose tmpHandle
                    removeFile tmpFile
632
633
634
635
636
637
638
639
  where
    template = targetName <.> "tmp"
    targetDir | null targetDir_ = currentDir
              | otherwise       = targetDir_
    --TODO: remove this when takeDirectory/splitFileName is fixed
    --      to always return a valid dir
    (targetDir_,targetName) = splitFileName targetFile

640
641
642
643
644
645
646
647
648
649
650
651
652
653
-- | Write a file but only if it would have new content. If we would be writing
-- the same as the existing content then leave the file as is so that we do not
-- update the file's modification time.
--
rewriteFile :: FilePath -> String -> IO ()
rewriteFile path newContent =
  flip catch mightNotExist $ do
    existingContent <- readFile path
    evaluate (length existingContent)
    unless (existingContent == newContent) $
      writeFileAtomic path newContent
  where
    mightNotExist e | isDoesNotExistError e = writeFileAtomic path newContent
                    | otherwise             = ioError e
654
655
656
657

-- | The path name that represents the current directory.
-- In Unix, it's @\".\"@, but this is system-specific.
-- (E.g. AmigaOS uses the empty string @\"\"@ for the current directory.)
ijones's avatar
ijones committed
658
659
currentDir :: FilePath
currentDir = "."
660

661
662
663
664
-- ------------------------------------------------------------
-- * Finding the description file
-- ------------------------------------------------------------

ijones's avatar
ijones committed
665
-- |Package description file (/pkgname/@.cabal@)
666
defaultPackageDesc :: Verbosity -> IO FilePath
667
defaultPackageDesc _verbosity = findPackageDesc currentDir
668
669

-- |Find a package description file in the given directory.  Looks for
ijones's avatar
ijones committed
670
-- @.cabal@ files.
671
findPackageDesc :: FilePath    -- ^Where to look
672
                -> IO FilePath -- ^<pkgname>.cabal
673
findPackageDesc dir
674
 = do files <- getDirectoryContents dir
675
676
677
678
679
680
681
682
      -- to make sure we do not mistake a ~/.cabal/ dir for a <pkgname>.cabal
      -- file we filter to exclude dirs and null base file names:
      cabalFiles <- filterM doesFileExist
                       [ dir </> file
                       | file <- files
                       , let (name, ext) = splitExtension file
                       , not (null name) && ext == ".cabal" ]
      case cabalFiles of
683
        []          -> noDesc
684
        [cabalFile] -> return cabalFile
685
686
687
688
689
690
691
692
693
694
695
        multiple    -> multiDesc multiple

  where
    noDesc :: IO a
    noDesc = die $ "No cabal file found.\n"
                ++ "Please create a package description file <pkgname>.cabal"

    multiDesc :: [String] -> IO a
    multiDesc l = die $ "Multiple cabal files found.\n"
                    ++ "Please use only one of: "
                    ++ show l
696

697
698
-- |Optional auxiliary package information file (/pkgname/@.buildinfo@)
defaultHookedPackageDesc :: IO (Maybe FilePath)
699
defaultHookedPackageDesc = findHookedPackageDesc currentDir
700
701
702
703

-- |Find auxiliary package information in the given directory.
-- Looks for @.buildinfo@ files.
findHookedPackageDesc
704
705
    :: FilePath                 -- ^Directory to search
    -> IO (Maybe FilePath)      -- ^/dir/@\/@/pkgname/@.buildinfo@, if present
706
findHookedPackageDesc dir = do
707
708
709
710
711
712
713
    files <- getDirectoryContents dir
    buildInfoFiles <- filterM doesFileExist
                        [ dir </> file
                        | file <- files
                        , let (name, ext) = splitExtension file
                        , not (null name) && ext == buildInfoExt ]
    case buildInfoFiles of
714
715
716
        [] -> return Nothing
        [f] -> return (Just f)
        _ -> die ("Multiple files with extension " ++ buildInfoExt)
717

718
719
720
buildInfoExt  :: String
buildInfoExt = ".buildinfo"

721
-- ------------------------------------------------------------
722
-- * Unicode stuff
723
724
-- ------------------------------------------------------------

Duncan Coutts's avatar
Duncan Coutts committed
725
726
-- This is a modification of the UTF8 code from gtk2hs and the
-- utf8-string package.
727
728
729
730
731
732

fromUTF8 :: String -> String
fromUTF8 []     = []
fromUTF8 (c:cs)
  | c <= '\x7F' = c : fromUTF8 cs
  | c <= '\xBF' = replacementChar : fromUTF8 cs
Duncan Coutts's avatar
Duncan Coutts committed
733
734
735
736
737
  | c <= '\xDF' = twoBytes c cs
  | c <= '\xEF' = moreBytes 3 0x800     cs (ord c .&. 0xF)
  | c <= '\xF7' = moreBytes 4 0x10000   cs (ord c .&. 0x7)
  | c <= '\xFB' = moreBytes 5 0x200000  cs (ord c .&. 0x3)
  | c <= '\xFD' = moreBytes 6 0x4000000 cs (ord c .&. 0x1)
738
739
  | otherwise   = replacementChar : fromUTF8 cs
  where
Duncan Coutts's avatar
Duncan Coutts committed
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
    twoBytes c0 (c1:cs')
      | ord c1 .&. 0xC0 == 0x80
      = let d = ((ord c0 .&. 0x1F) `shiftL` 6)
             .|. (ord c1 .&. 0x3F)
         in if d >= 0x80
               then  chr d           : fromUTF8 cs'
               else  replacementChar : fromUTF8 cs'
    twoBytes _ cs' = replacementChar : fromUTF8 cs'

    moreBytes :: Int -> Int -> [Char] -> Int -> [Char]
    moreBytes 1 overlong cs' acc
      | overlong <= acc && acc <= 0x10FFFF
     && (acc < 0xD800 || 0xDFFF < acc)
     && (acc < 0xFFFE || 0xFFFF < acc)
      = chr acc : fromUTF8 cs'

      | otherwise
      = replacementChar : fromUTF8 cs'

    moreBytes byteCount overlong (cn:cs') acc
      | ord cn .&. 0xC0 == 0x80
      = moreBytes (byteCount-1) overlong cs'
          ((acc `shiftL` 6) .|. ord cn .&. 0x3F)

    moreBytes _ _ cs' _
      = replacementChar : fromUTF8 cs'
766
767
768
769
770
771
772
773
774
775
776

    replacementChar = '\xfffd'

toUTF8 :: String -> String
toUTF8 []        = []
toUTF8 (c:cs)
  | c <= '\x07F' = c
                 : toUTF8 cs
  | c <= '\x7FF' = chr (0xC0 .|. (w `shiftR` 6))
                 : chr (0x80 .|. (w .&. 0x3F))
                 : toUTF8 cs
Duncan Coutts's avatar
Duncan Coutts committed
777
778
779
780
781
782
  | c <= '\xFFFF'= chr (0xE0 .|.  (w `shiftR` 12))
                 : chr (0x80 .|. ((w `shiftR` 6)  .&. 0x3F))
                 : chr (0x80 .|.  (w .&. 0x3F))
                 : toUTF8 cs
  | otherwise    = chr (0xf0 .|.  (w `shiftR` 18))
                 : chr (0x80 .|. ((w `shiftR` 12)  .&. 0x3F))
783
784
785
786
787
                 : chr (0x80 .|. ((w `shiftR` 6)  .&. 0x3F))
                 : chr (0x80 .|.  (w .&. 0x3F))
                 : toUTF8 cs
  where w = ord c

788
789
790
791
-- | Reads a UTF8 encoded text file as a Unicode String
--
-- Reads lazily using ordinary 'readFile'.
--
792
793
readUTF8File :: FilePath -> IO String
readUTF8File f = fmap fromUTF8 . hGetContents =<< openBinaryFile f ReadMode
794

795
796
797
798
799
800
801
802
803
-- | Reads a UTF8 encoded text file as a Unicode String
--
-- Same behaviour as 'withFileContents'.
--
withUTF8FileContents :: FilePath -> (String -> IO a) -> IO a
withUTF8FileContents name action =
  Exception.bracket (openBinaryFile name ReadMode) hClose
                    (\hnd -> hGetContents hnd >>= action . fromUTF8)

804
805
806
807
-- | Writes a Unicode String as a UTF8 encoded text file.
--
-- Uses 'writeFileAtomic', so provides the same guarantees.
--
808
809
writeUTF8File :: FilePath -> String -> IO ()
writeUTF8File path = writeFileAtomic path . toUTF8
810

811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
-- ------------------------------------------------------------
-- * Common utils
-- ------------------------------------------------------------

equating :: Eq a => (b -> a) -> b -> b -> Bool
equating p x y = p x == p y

comparing :: Ord a => (b -> a) -> b -> b -> Ordering
comparing p x y = p x `compare` p y

isInfixOf :: String -> String -> Bool
isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack)

intercalate :: [a] -> [[a]] -> [a]
intercalate sep = concat . intersperse sep

lowercase :: String -> String
lowercase = map Char.toLower