System/Directory.hs

   1 {-# OPTIONS_GHC -w #-}
   2 -- XXX We get some warnings on Windows
   3
   4 -----------------------------------------------------------------------------
   5 -- |
   6 -- Module      :  System.Directory
   7 -- Copyright   :  (c) The University of Glasgow 2001
   8 -- License     :  BSD-style (see the file libraries/base/LICENSE)
   9 --
  10 -- Maintainer  :  libraries@haskell.org
  11 -- Stability   :  stable
  12 -- Portability :  portable
  13 --
  14 -- System-independent interface to directory manipulation.
  15 --
  16 -----------------------------------------------------------------------------
  17
  18 module System.Directory
  19    (
  20     -- $intro
  21
  22     -- * Actions on directories
  23       createDirectory           -- :: FilePath -> IO ()
  24     , createDirectoryIfMissing  -- :: Bool -> FilePath -> IO ()
  25     , removeDirectory           -- :: FilePath -> IO ()
  26     , removeDirectoryRecursive  -- :: FilePath -> IO ()
  27     , renameDirectory           -- :: FilePath -> FilePath -> IO ()
  28
  29     , getDirectoryContents      -- :: FilePath -> IO [FilePath]
  30     , getCurrentDirectory       -- :: IO FilePath
  31     , setCurrentDirectory       -- :: FilePath -> IO ()
  32
  33     -- * Pre-defined directories
  34     , getHomeDirectory
  35     , getAppUserDataDirectory
  36     , getUserDocumentsDirectory
  37     , getTemporaryDirectory
  38
  39     -- * Actions on files
  40     , removeFile                -- :: FilePath -> IO ()
  41     , renameFile                -- :: FilePath -> FilePath -> IO ()
  42     , copyFile                  -- :: FilePath -> FilePath -> IO ()
  43
  44     , canonicalizePath
  45     , makeRelativeToCurrentDirectory
  46     , findExecutable
  47
  48     -- * Existence tests
  49     , doesFileExist             -- :: FilePath -> IO Bool
  50     , doesDirectoryExist        -- :: FilePath -> IO Bool
  51
  52     -- * Permissions
  53
  54     -- $permissions
  55
  56     , Permissions(
  57         Permissions,
  58         readable,               -- :: Permissions -> Bool
  59         writable,               -- :: Permissions -> Bool
  60         executable,             -- :: Permissions -> Bool
  61         searchable              -- :: Permissions -> Bool
  62       )
  63
  64     , getPermissions            -- :: FilePath -> IO Permissions
  65     , setPermissions            -- :: FilePath -> Permissions -> IO ()
  66
  67     -- * Timestamps
  68
  69     , getModificationTime       -- :: FilePath -> IO ClockTime
  70    ) where
  71
  72 import Prelude hiding ( catch )
  73 import qualified Prelude
  74
  75 import Control.Monad (guard)
  76 import System.Environment      ( getEnv )
  77 import System.FilePath
  78 import System.IO
  79 import System.IO.Error hiding ( catch, try )
  80 import Control.Monad           ( when, unless )
  81 import Control.Exception.Base
  82
  83 #ifdef __NHC__
  84 import Directory hiding ( getDirectoryContents
  85                         , doesDirectoryExist, doesFileExist
  86                         , getModificationTime )
  87 import System (system)
  88 #endif /* __NHC__ */
  89
  90 #ifdef __HUGS__
  91 import Hugs.Directory
  92 #endif /* __HUGS__ */
  93
  94 import Foreign
  95 import Foreign.C
  96
  97 {-# CFILES cbits/directory.c #-}
  98
  99 import System.Posix.Types
 100 import System.Posix.Internals
 101 import System.Time             ( ClockTime(..) )
 102
 103 #ifdef __GLASGOW_HASKELL__
 104 import GHC.IOBase       ( IOException(..), IOErrorType(..), ioException )
 105
 106 #ifdef mingw32_HOST_OS
 107 import qualified System.Win32
 108 #else
 109 import qualified System.Posix
 110 #endif
 111
 112 {- $intro
 113 A directory contains a series of entries, each of which is a named
 114 reference to a file system object (file, directory etc.).  Some
 115 entries may be hidden, inaccessible, or have some administrative
 116 function (e.g. `.' or `..' under POSIX
 117 <http://www.opengroup.org/onlinepubs/009695399/>), but in
 118 this standard all such entries are considered to form part of the
 119 directory contents. Entries in sub-directories are not, however,
 120 considered to form part of the directory contents.
 121
 122 Each file system object is referenced by a /path/.  There is
 123 normally at least one absolute path to each file system object.  In
 124 some operating systems, it may also be possible to have paths which
 125 are relative to the current directory.
 126 -}
 127
 128 -----------------------------------------------------------------------------
 129 -- Permissions
 130
 131 {- $permissions
 132
 133  The 'Permissions' type is used to record whether certain operations are
 134  permissible on a file\/directory. 'getPermissions' and 'setPermissions'
 135  get and set these permissions, respectively. Permissions apply both to
 136  files and directories. For directories, the executable field will be
 137  'False', and for files the searchable field will be 'False'. Note that
 138  directories may be searchable without being readable, if permission has
 139  been given to use them as part of a path, but not to examine the
 140  directory contents.
 141
 142 Note that to change some, but not all permissions, a construct on the following lines must be used.
 143
 144 >  makeReadable f = do
 145 >     p <- getPermissions f
 146 >     setPermissions f (p {readable = True})
 147
 148 -}
 149
 150 data Permissions
 151  = Permissions {
 152     readable,   writable,
 153     executable, searchable :: Bool
 154    } deriving (Eq, Ord, Read, Show)
 155
 156 {- |The 'getPermissions' operation returns the
 157 permissions for the file or directory.
 158
 159 The operation may fail with:
 160
 161 * 'isPermissionError' if the user is not permitted to access
 162   the permissions; or
 163
 164 * 'isDoesNotExistError' if the file or directory does not exist.
 165
 166 -}
 167
 168 getPermissions :: FilePath -> IO Permissions
 169 getPermissions name = do
 170   withCString name $ \s -> do
 171 #ifdef mingw32_HOST_OS
 172   -- stat() does a better job of guessing the permissions on Windows
 173   -- than access() does.  e.g. for execute permission, it looks at the
 174   -- filename extension :-)
 175   --
 176   -- I tried for a while to do this properly, using the Windows security API,
 177   -- and eventually gave up.  getPermissions is a flawed API anyway. -- SimonM
 178   allocaBytes sizeof_stat $ \ p_stat -> do
 179   throwErrnoIfMinus1_ "getPermissions" $ c_stat s p_stat
 180   mode <- st_mode p_stat
 181   let usr_read   = mode .&. s_IRUSR
 182   let usr_write  = mode .&. s_IWUSR
 183   let usr_exec   = mode .&. s_IXUSR
 184   let is_dir = mode .&. s_IFDIR
 185   return (
 186     Permissions {
 187       readable   = usr_read  /= 0,
 188       writable   = usr_write /= 0,
 189       executable = is_dir == 0 && usr_exec /= 0,
 190       searchable = is_dir /= 0 && usr_exec /= 0
 191     }
 192    )
 193 #else
 194   read_ok  <- c_access s r_OK
 195   write_ok <- c_access s w_OK
 196   exec_ok  <- c_access s x_OK
 197   withFileStatus "getPermissions" name $ \st -> do
 198   is_dir <- isDirectory st
 199   return (
 200     Permissions {
 201       readable   = read_ok  == 0,
 202       writable   = write_ok == 0,
 203       executable = not is_dir && exec_ok == 0,
 204       searchable = is_dir && exec_ok == 0
 205     }
 206    )
 207 #endif
 208
 209 {- |The 'setPermissions' operation sets the
 210 permissions for the file or directory.
 211
 212 The operation may fail with:
 213
 214 * 'isPermissionError' if the user is not permitted to set
 215   the permissions; or
 216
 217 * 'isDoesNotExistError' if the file or directory does not exist.
 218
 219 -}
 220
 221 setPermissions :: FilePath -> Permissions -> IO ()
 222 setPermissions name (Permissions r w e s) = do
 223   allocaBytes sizeof_stat $ \ p_stat -> do
 224   withCString name $ \p_name -> do
 225     throwErrnoIfMinus1_ "setPermissions" $ do
 226       c_stat p_name p_stat
 227       mode <- st_mode p_stat
 228       let mode1 = modifyBit r mode s_IRUSR
 229       let mode2 = modifyBit w mode1 s_IWUSR
 230       let mode3 = modifyBit (e || s) mode2 s_IXUSR
 231       c_chmod p_name mode3
 232
 233  where
 234    modifyBit :: Bool -> CMode -> CMode -> CMode
 235    modifyBit False m b = m .&. (complement b)
 236    modifyBit True  m b = m .|. b
 237
 238
 239 copyPermissions :: FilePath -> FilePath -> IO ()
 240 copyPermissions source dest = do
 241   allocaBytes sizeof_stat $ \ p_stat -> do
 242   withCString source $ \p_source -> do
 243   withCString dest $ \p_dest -> do
 244     throwErrnoIfMinus1_ "copyPermissions" $ c_stat p_source p_stat
 245     mode <- st_mode p_stat
 246     throwErrnoIfMinus1_ "copyPermissions" $ c_chmod p_dest mode
 247
 248 -----------------------------------------------------------------------------
 249 -- Implementation
 250
 251 {- |@'createDirectory' dir@ creates a new directory @dir@ which is
 252 initially empty, or as near to empty as the operating system
 253 allows.
 254
 255 The operation may fail with:
 256
 257 * 'isPermissionError' \/ 'PermissionDenied'
 258 The process has insufficient privileges to perform the operation.
 259 @[EROFS, EACCES]@
 260
 261 * 'isAlreadyExistsError' \/ 'AlreadyExists'
 262 The operand refers to a directory that already exists.
 263 @ [EEXIST]@
 264
 265 * 'HardwareFault'
 266 A physical I\/O error has occurred.
 267 @[EIO]@
 268
 269 * 'InvalidArgument'
 270 The operand is not a valid directory name.
 271 @[ENAMETOOLONG, ELOOP]@
 272
 273 * 'NoSuchThing'
 274 There is no path to the directory.
 275 @[ENOENT, ENOTDIR]@
 276
 277 * 'ResourceExhausted'
 278 Insufficient resources (virtual memory, process file descriptors,
 279 physical disk space, etc.) are available to perform the operation.
 280 @[EDQUOT, ENOSPC, ENOMEM, EMLINK]@
 281
 282 * 'InappropriateType'
 283 The path refers to an existing non-directory object.
 284 @[EEXIST]@
 285
 286 -}
 287
 288 createDirectory :: FilePath -> IO ()
 289 createDirectory path = do
 290 #ifdef mingw32_HOST_OS
 291   System.Win32.createDirectory path Nothing
 292 #else
 293   System.Posix.createDirectory path 0o777
 294 #endif
 295
 296 #else /* !__GLASGOW_HASKELL__ */
 297
 298 copyPermissions :: FilePath -> FilePath -> IO ()
 299 copyPermissions fromFPath toFPath
 300   = getPermissions fromFPath >>= setPermissions toFPath
 301
 302 #endif
 303
 304 -- | @'createDirectoryIfMissing' parents dir@ creates a new directory
 305 -- @dir@ if it doesn\'t exist. If the first argument is 'True'
 306 -- the function will also create all parent directories if they are missing.
 307 createDirectoryIfMissing :: Bool     -- ^ Create its parents too?
 308                          -> FilePath -- ^ The path to the directory you want to make
 309                          -> IO ()
 310 createDirectoryIfMissing create_parents path0
 311   | create_parents = createDirs (parents path0)
 312   | otherwise      = createDirs (take 1 (parents path0))
 313   where
 314     parents = reverse . scanl1 (</>) . splitDirectories . normalise
 315
 316     createDirs []         = return ()
 317     createDirs (dir:[])   = createDir dir throw
 318     createDirs (dir:dirs) =
 319       createDir dir $ \_ -> do
 320         createDirs dirs
 321         createDir dir throw
 322
 323     createDir :: FilePath -> (IOException -> IO ()) -> IO ()
 324     createDir dir notExistHandler = do
 325       r <- try $ createDirectory dir
 326       case (r :: Either IOException ()) of
 327         Right ()                   -> return ()
 328         Left  e
 329           | isDoesNotExistError  e -> notExistHandler e
 330           -- createDirectory (and indeed POSIX mkdir) does not distinguish
 331           -- between a dir already existing and a file already existing. So we
 332           -- check for it here. Unfortunately there is a slight race condition
 333           -- here, but we think it is benign. It could report an exeption in
 334           -- the case that the dir did exist but another process deletes the
 335           -- directory and creates a file in its place before we can check
 336           -- that the directory did indeed exist.
 337           | isAlreadyExistsError e ->
 338               (withFileStatus "createDirectoryIfMissing" dir $ \st -> do
 339                  isDir <- isDirectory st
 340                  if isDir then return ()
 341                           else throw e
 342               ) `catch` ((\_ -> return ()) :: IOException -> IO ())
 343           | otherwise              -> throw e
 344
 345 #if __GLASGOW_HASKELL__
 346 {- | @'removeDirectory' dir@ removes an existing directory /dir/.  The
 347 implementation may specify additional constraints which must be
 348 satisfied before a directory can be removed (e.g. the directory has to
 349 be empty, or may not be in use by other processes).  It is not legal
 350 for an implementation to partially remove a directory unless the
 351 entire directory is removed. A conformant implementation need not
 352 support directory removal in all situations (e.g. removal of the root
 353 directory).
 354
 355 The operation may fail with:
 356
 357 * 'HardwareFault'
 358 A physical I\/O error has occurred.
 359 EIO
 360
 361 * 'InvalidArgument'
 362 The operand is not a valid directory name.
 363 [ENAMETOOLONG, ELOOP]
 364
 365 * 'isDoesNotExistError' \/ 'NoSuchThing'
 366 The directory does not exist.
 367 @[ENOENT, ENOTDIR]@
 368
 369 * 'isPermissionError' \/ 'PermissionDenied'
 370 The process has insufficient privileges to perform the operation.
 371 @[EROFS, EACCES, EPERM]@
 372
 373 * 'UnsatisfiedConstraints'
 374 Implementation-dependent constraints are not satisfied.
 375 @[EBUSY, ENOTEMPTY, EEXIST]@
 376
 377 * 'UnsupportedOperation'
 378 The implementation does not support removal in this situation.
 379 @[EINVAL]@
 380
 381 * 'InappropriateType'
 382 The operand refers to an existing non-directory object.
 383 @[ENOTDIR]@
 384
 385 -}
 386
 387 removeDirectory :: FilePath -> IO ()
 388 removeDirectory path =
 389 #ifdef mingw32_HOST_OS
 390   System.Win32.removeDirectory path
 391 #else
 392   System.Posix.removeDirectory path
 393 #endif
 394
 395 #endif
 396
 397 -- | @'removeDirectoryRecursive' dir@  removes an existing directory /dir/
 398 -- together with its content and all subdirectories. Be careful,
 399 -- if the directory contains symlinks, the function will follow them.
 400 removeDirectoryRecursive :: FilePath -> IO ()
 401 removeDirectoryRecursive startLoc = do
 402   cont <- getDirectoryContents startLoc
 403   sequence_ [rm (startLoc </> x) | x <- cont, x /= "." && x /= ".."]
 404   removeDirectory startLoc
 405   where
 406     rm :: FilePath -> IO ()
 407     rm f = do temp <- try (removeFile f)
 408               case temp of
 409                 Left e  -> do isDir <- doesDirectoryExist f
 410                               -- If f is not a directory, re-throw the error
 411                               unless isDir $ throw (e :: SomeException)
 412                               removeDirectoryRecursive f
 413                 Right _ -> return ()
 414
 415 #if __GLASGOW_HASKELL__
 416 {- |'removeFile' /file/ removes the directory entry for an existing file
 417 /file/, where /file/ is not itself a directory. The
 418 implementation may specify additional constraints which must be
 419 satisfied before a file can be removed (e.g. the file may not be in
 420 use by other processes).
 421
 422 The operation may fail with:
 423
 424 * 'HardwareFault'
 425 A physical I\/O error has occurred.
 426 @[EIO]@
 427
 428 * 'InvalidArgument'
 429 The operand is not a valid file name.
 430 @[ENAMETOOLONG, ELOOP]@
 431
 432 * 'isDoesNotExistError' \/ 'NoSuchThing'
 433 The file does not exist.
 434 @[ENOENT, ENOTDIR]@
 435
 436 * 'isPermissionError' \/ 'PermissionDenied'
 437 The process has insufficient privileges to perform the operation.
 438 @[EROFS, EACCES, EPERM]@
 439
 440 * 'UnsatisfiedConstraints'
 441 Implementation-dependent constraints are not satisfied.
 442 @[EBUSY]@
 443
 444 * 'InappropriateType'
 445 The operand refers to an existing directory.
 446 @[EPERM, EINVAL]@
 447
 448 -}
 449
 450 removeFile :: FilePath -> IO ()
 451 removeFile path =
 452 #if mingw32_HOST_OS
 453   System.Win32.deleteFile path
 454 #else
 455   System.Posix.removeLink path
 456 #endif
 457
 458 {- |@'renameDirectory' old new@ changes the name of an existing
 459 directory from /old/ to /new/.  If the /new/ directory
 460 already exists, it is atomically replaced by the /old/ directory.
 461 If the /new/ directory is neither the /old/ directory nor an
 462 alias of the /old/ directory, it is removed as if by
 463 'removeDirectory'.  A conformant implementation need not support
 464 renaming directories in all situations (e.g. renaming to an existing
 465 directory, or across different physical devices), but the constraints
 466 must be documented.
 467
 468 On Win32 platforms, @renameDirectory@ fails if the /new/ directory already
 469 exists.
 470
 471 The operation may fail with:
 472
 473 * 'HardwareFault'
 474 A physical I\/O error has occurred.
 475 @[EIO]@
 476
 477 * 'InvalidArgument'
 478 Either operand is not a valid directory name.
 479 @[ENAMETOOLONG, ELOOP]@
 480
 481 * 'isDoesNotExistError' \/ 'NoSuchThing'
 482 The original directory does not exist, or there is no path to the target.
 483 @[ENOENT, ENOTDIR]@
 484
 485 * 'isPermissionError' \/ 'PermissionDenied'
 486 The process has insufficient privileges to perform the operation.
 487 @[EROFS, EACCES, EPERM]@
 488
 489 * 'ResourceExhausted'
 490 Insufficient resources are available to perform the operation.
 491 @[EDQUOT, ENOSPC, ENOMEM, EMLINK]@
 492
 493 * 'UnsatisfiedConstraints'
 494 Implementation-dependent constraints are not satisfied.
 495 @[EBUSY, ENOTEMPTY, EEXIST]@
 496
 497 * 'UnsupportedOperation'
 498 The implementation does not support renaming in this situation.
 499 @[EINVAL, EXDEV]@
 500
 501 * 'InappropriateType'
 502 Either path refers to an existing non-directory object.
 503 @[ENOTDIR, EISDIR]@
 504
 505 -}
 506
 507 renameDirectory :: FilePath -> FilePath -> IO ()
 508 renameDirectory opath npath =
 509    -- XXX this test isn't performed atomically with the following rename
 510    withFileStatus "renameDirectory" opath $ \st -> do
 511    is_dir <- isDirectory st
 512    if (not is_dir)
 513         then ioException (ioeSetErrorString
 514                           (mkIOError InappropriateType "renameDirectory" Nothing (Just opath))
 515                           "not a directory")
 516         else do
 517 #ifdef mingw32_HOST_OS
 518    System.Win32.moveFileEx opath npath System.Win32.mOVEFILE_REPLACE_EXISTING
 519 #else
 520    System.Posix.rename opath npath
 521 #endif
 522
 523 {- |@'renameFile' old new@ changes the name of an existing file system
 524 object from /old/ to /new/.  If the /new/ object already
 525 exists, it is atomically replaced by the /old/ object.  Neither
 526 path may refer to an existing directory.  A conformant implementation
 527 need not support renaming files in all situations (e.g. renaming
 528 across different physical devices), but the constraints must be
 529 documented.
 530
 531 The operation may fail with:
 532
 533 * 'HardwareFault'
 534 A physical I\/O error has occurred.
 535 @[EIO]@
 536
 537 * 'InvalidArgument'
 538 Either operand is not a valid file name.
 539 @[ENAMETOOLONG, ELOOP]@
 540
 541 * 'isDoesNotExistError' \/ 'NoSuchThing'
 542 The original file does not exist, or there is no path to the target.
 543 @[ENOENT, ENOTDIR]@
 544
 545 * 'isPermissionError' \/ 'PermissionDenied'
 546 The process has insufficient privileges to perform the operation.
 547 @[EROFS, EACCES, EPERM]@
 548
 549 * 'ResourceExhausted'
 550 Insufficient resources are available to perform the operation.
 551 @[EDQUOT, ENOSPC, ENOMEM, EMLINK]@
 552
 553 * 'UnsatisfiedConstraints'
 554 Implementation-dependent constraints are not satisfied.
 555 @[EBUSY]@
 556
 557 * 'UnsupportedOperation'
 558 The implementation does not support renaming in this situation.
 559 @[EXDEV]@
 560
 561 * 'InappropriateType'
 562 Either path refers to an existing directory.
 563 @[ENOTDIR, EISDIR, EINVAL, EEXIST, ENOTEMPTY]@
 564
 565 -}
 566
 567 renameFile :: FilePath -> FilePath -> IO ()
 568 renameFile opath npath =
 569    -- XXX this test isn't performed atomically with the following rename
 570    withFileOrSymlinkStatus "renameFile" opath $ \st -> do
 571    is_dir <- isDirectory st
 572    if is_dir
 573         then ioException (ioeSetErrorString
 574                           (mkIOError InappropriateType "renameFile" Nothing (Just opath))
 575                           "is a directory")
 576         else do
 577 #ifdef mingw32_HOST_OS
 578    System.Win32.moveFileEx opath npath System.Win32.mOVEFILE_REPLACE_EXISTING
 579 #else
 580    System.Posix.rename opath npath
 581 #endif
 582
 583 #endif /* __GLASGOW_HASKELL__ */
 584
 585 {- |@'copyFile' old new@ copies the existing file from /old/ to /new/.
 586 If the /new/ file already exists, it is atomically replaced by the /old/ file.
 587 Neither path may refer to an existing directory.  The permissions of /old/ are
 588 copied to /new/, if possible.
 589 -}
 590
 591 copyFile :: FilePath -> FilePath -> IO ()
 592 #ifdef __NHC__
 593 copyFile fromFPath toFPath =
 594     do readFile fromFPath >>= writeFile toFPath
 595        Prelude.catch (copyPermissions fromFPath toFPath)
 596                      (\_ -> return ())
 597 #else
 598 copyFile fromFPath toFPath =
 599     copy `Prelude.catch` (\exc -> throw $ ioeSetLocation exc "copyFile")
 600     where copy = bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom ->
 601                  bracketOnError openTmp cleanTmp $ \(tmpFPath, hTmp) ->
 602                  do allocaBytes bufferSize $ copyContents hFrom hTmp
 603                     hClose hTmp
 604                     ignoreIOExceptions $ copyPermissions fromFPath tmpFPath
 605                     renameFile tmpFPath toFPath
 606           openTmp = openBinaryTempFile (takeDirectory toFPath) ".copyFile.tmp"
 607           cleanTmp (tmpFPath, hTmp)
 608               = do ignoreIOExceptions $ hClose hTmp
 609                    ignoreIOExceptions $ removeFile tmpFPath
 610           bufferSize = 1024
 611
 612           copyContents hFrom hTo buffer = do
 613                   count <- hGetBuf hFrom buffer bufferSize
 614                   when (count > 0) $ do
 615                           hPutBuf hTo buffer count
 616                           copyContents hFrom hTo buffer
 617
 618           ignoreIOExceptions io = io `catch` ioExceptionIgnorer
 619           ioExceptionIgnorer :: IOException -> IO ()
 620           ioExceptionIgnorer _ = return ()
 621 #endif
 622
 623 -- | Given path referring to a file or directory, returns a
 624 -- canonicalized path, with the intent that two paths referring
 625 -- to the same file\/directory will map to the same canonicalized
 626 -- path. Note that it is impossible to guarantee that the
 627 -- implication (same file\/dir \<=\> same canonicalizedPath) holds
 628 -- in either direction: this function can make only a best-effort
 629 -- attempt.
 630 canonicalizePath :: FilePath -> IO FilePath
 631 canonicalizePath fpath =
 632   withCString fpath $ \pInPath ->
 633   allocaBytes long_path_size $ \pOutPath ->
 634 #if defined(mingw32_HOST_OS)
 635   alloca $ \ppFilePart ->
 636     do c_GetFullPathName pInPath (fromIntegral long_path_size) pOutPath ppFilePart
 637 #else
 638     do c_realpath pInPath pOutPath
 639 #endif
 640        path <- peekCString pOutPath
 641        return (normalise path)
 642         -- normalise does more stuff, like upper-casing the drive letter
 643
 644 #if defined(mingw32_HOST_OS)
 645 foreign import stdcall unsafe "GetFullPathNameA"
 646             c_GetFullPathName :: CString
 647                               -> CInt
 648                               -> CString
 649                               -> Ptr CString
 650                               -> IO CInt
 651 #else
 652 foreign import ccall unsafe "realpath"
 653                    c_realpath :: CString
 654                               -> CString
 655                               -> IO CString
 656 #endif
 657
 658 -- | 'makeRelative' the current directory.
 659 makeRelativeToCurrentDirectory :: FilePath -> IO FilePath
 660 makeRelativeToCurrentDirectory x = do
 661     cur <- getCurrentDirectory
 662     return $ makeRelative cur x
 663
 664 -- | Given an executable file name, searches for such file
 665 -- in the directories listed in system PATH. The returned value
 666 -- is the path to the found executable or Nothing if there isn't
 667 -- such executable. For example (findExecutable \"ghc\")
 668 -- gives you the path to GHC.
 669 findExecutable :: String -> IO (Maybe FilePath)
 670 findExecutable binary =
 671 #if defined(mingw32_HOST_OS)
 672   withCString binary $ \c_binary ->
 673   withCString ('.':exeExtension) $ \c_ext ->
 674   allocaBytes long_path_size $ \pOutPath ->
 675   alloca $ \ppFilePart -> do
 676     res <- c_SearchPath nullPtr c_binary c_ext (fromIntegral long_path_size) pOutPath ppFilePart
 677     if res > 0 && res < fromIntegral long_path_size
 678       then do fpath <- peekCString pOutPath
 679               return (Just fpath)
 680       else return Nothing
 681
 682 foreign import stdcall unsafe "SearchPathA"
 683             c_SearchPath :: CString
 684                          -> CString
 685                          -> CString
 686                          -> CInt
 687                          -> CString
 688                          -> Ptr CString
 689                          -> IO CInt
 690 #else
 691  do
 692   path <- getEnv "PATH"
 693   search (splitSearchPath path)
 694   where
 695     fileName = binary <.> exeExtension
 696
 697     search :: [FilePath] -> IO (Maybe FilePath)
 698     search [] = return Nothing
 699     search (d:ds) = do
 700         let path = d </> fileName
 701         b <- doesFileExist path
 702         if b then return (Just path)
 703              else search ds
 704 #endif
 705
 706
 707 #ifndef __HUGS__
 708 {- |@'getDirectoryContents' dir@ returns a list of /all/ entries
 709 in /dir/.
 710
 711 The operation may fail with:
 712
 713 * 'HardwareFault'
 714 A physical I\/O error has occurred.
 715 @[EIO]@
 716
 717 * 'InvalidArgument'
 718 The operand is not a valid directory name.
 719 @[ENAMETOOLONG, ELOOP]@
 720
 721 * 'isDoesNotExistError' \/ 'NoSuchThing'
 722 The directory does not exist.
 723 @[ENOENT, ENOTDIR]@
 724
 725 * 'isPermissionError' \/ 'PermissionDenied'
 726 The process has insufficient privileges to perform the operation.
 727 @[EACCES]@
 728
 729 * 'ResourceExhausted'
 730 Insufficient resources are available to perform the operation.
 731 @[EMFILE, ENFILE]@
 732
 733 * 'InappropriateType'
 734 The path refers to an existing non-directory object.
 735 @[ENOTDIR]@
 736
 737 -}
 738
 739 getDirectoryContents :: FilePath -> IO [FilePath]
 740 getDirectoryContents path = do
 741   modifyIOError (`ioeSetFileName` path) $
 742    alloca $ \ ptr_dEnt ->
 743      bracket
 744         (withCString path $ \s ->
 745            throwErrnoIfNullRetry desc (c_opendir s))
 746         (\p -> throwErrnoIfMinus1_ desc (c_closedir p))
 747         (\p -> loop ptr_dEnt p)
 748   where
 749     desc = "getDirectoryContents"
 750
 751     loop :: Ptr (Ptr CDirent) -> Ptr CDir -> IO [String]
 752     loop ptr_dEnt dir = do
 753       resetErrno
 754       r <- readdir dir ptr_dEnt
 755       if (r == 0)
 756          then do
 757                  dEnt    <- peek ptr_dEnt
 758                  if (dEnt == nullPtr)
 759                    then return []
 760                    else do
 761                     entry   <- (d_name dEnt >>= peekCString)
 762                     freeDirEnt dEnt
 763                     entries <- loop ptr_dEnt dir
 764                     return (entry:entries)
 765          else do errno <- getErrno
 766                  if (errno == eINTR) then loop ptr_dEnt dir else do
 767                    let (Errno eo) = errno
 768                    if (eo == end_of_dir)
 769                       then return []
 770                       else throwErrno desc
 771 #endif /* !__HUGS__ */
 772
 773
 774 {- |If the operating system has a notion of current directories,
 775 'getCurrentDirectory' returns an absolute path to the
 776 current directory of the calling process.
 777
 778 The operation may fail with:
 779
 780 * 'HardwareFault'
 781 A physical I\/O error has occurred.
 782 @[EIO]@
 783
 784 * 'isDoesNotExistError' \/ 'NoSuchThing'
 785 There is no path referring to the current directory.
 786 @[EPERM, ENOENT, ESTALE...]@
 787
 788 * 'isPermissionError' \/ 'PermissionDenied'
 789 The process has insufficient privileges to perform the operation.
 790 @[EACCES]@
 791
 792 * 'ResourceExhausted'
 793 Insufficient resources are available to perform the operation.
 794
 795 * 'UnsupportedOperation'
 796 The operating system has no notion of current directory.
 797
 798 -}
 799 #ifdef __GLASGOW_HASKELL__
 800 getCurrentDirectory :: IO FilePath
 801 getCurrentDirectory = do
 802 #ifdef mingw32_HOST_OS
 803   -- XXX: should use something from Win32
 804   p <- mallocBytes long_path_size
 805   go p long_path_size
 806   where go p bytes = do
 807           p' <- c_getcwd p (fromIntegral bytes)
 808           if p' /= nullPtr
 809              then do s <- peekCString p'
 810                      free p'
 811                      return s
 812              else do errno <- getErrno
 813                      if errno == eRANGE
 814                         then do let bytes' = bytes * 2
 815                                 p'' <- reallocBytes p bytes'
 816                                 go p'' bytes'
 817                         else throwErrno "getCurrentDirectory"
 818 #else
 819   System.Posix.getWorkingDirectory
 820 #endif
 821
 822 #ifdef mingw32_HOST_OS
 823 foreign import ccall unsafe "getcwd"
 824    c_getcwd   :: Ptr CChar -> CSize -> IO (Ptr CChar)
 825 #endif
 826
 827 {- |If the operating system has a notion of current directories,
 828 @'setCurrentDirectory' dir@ changes the current
 829 directory of the calling process to /dir/.
 830
 831 The operation may fail with:
 832
 833 * 'HardwareFault'
 834 A physical I\/O error has occurred.
 835 @[EIO]@
 836
 837 * 'InvalidArgument'
 838 The operand is not a valid directory name.
 839 @[ENAMETOOLONG, ELOOP]@
 840
 841 * 'isDoesNotExistError' \/ 'NoSuchThing'
 842 The directory does not exist.
 843 @[ENOENT, ENOTDIR]@
 844
 845 * 'isPermissionError' \/ 'PermissionDenied'
 846 The process has insufficient privileges to perform the operation.
 847 @[EACCES]@
 848
 849 * 'UnsupportedOperation'
 850 The operating system has no notion of current directory, or the
 851 current directory cannot be dynamically changed.
 852
 853 * 'InappropriateType'
 854 The path refers to an existing non-directory object.
 855 @[ENOTDIR]@
 856
 857 -}
 858
 859 setCurrentDirectory :: FilePath -> IO ()
 860 setCurrentDirectory path =
 861 #ifdef mingw32_HOST_OS
 862   System.Win32.setCurrentDirectory path
 863 #else
 864   System.Posix.changeWorkingDirectory path
 865 #endif
 866
 867 #endif /* __GLASGOW_HASKELL__ */
 868
 869 #ifndef __HUGS__
 870 {- |The operation 'doesDirectoryExist' returns 'True' if the argument file
 871 exists and is a directory, and 'False' otherwise.
 872 -}
 873
 874 doesDirectoryExist :: FilePath -> IO Bool
 875 doesDirectoryExist name =
 876    (withFileStatus "doesDirectoryExist" name $ \st -> isDirectory st)
 877    `catch` ((\ _ -> return False) :: IOException -> IO Bool)
 878
 879 {- |The operation 'doesFileExist' returns 'True'
 880 if the argument file exists and is not a directory, and 'False' otherwise.
 881 -}
 882
 883 doesFileExist :: FilePath -> IO Bool
 884 doesFileExist name =
 885    (withFileStatus "doesFileExist" name $ \st -> do b <- isDirectory st; return (not b))
 886    `catch` ((\ _ -> return False) :: IOException -> IO Bool)
 887
 888 {- |The 'getModificationTime' operation returns the
 889 clock time at which the file or directory was last modified.
 890
 891 The operation may fail with:
 892
 893 * 'isPermissionError' if the user is not permitted to access
 894   the modification time; or
 895
 896 * 'isDoesNotExistError' if the file or directory does not exist.
 897
 898 -}
 899
 900 getModificationTime :: FilePath -> IO ClockTime
 901 getModificationTime name =
 902  withFileStatus "getModificationTime" name $ \ st ->
 903  modificationTime st
 904
 905 #endif /* !__HUGS__ */
 906
 907 withFileStatus :: String -> FilePath -> (Ptr CStat -> IO a) -> IO a
 908 withFileStatus loc name f = do
 909   modifyIOError (`ioeSetFileName` name) $
 910     allocaBytes sizeof_stat $ \p ->
 911       withCString (fileNameEndClean name) $ \s -> do
 912         throwErrnoIfMinus1Retry_ loc (c_stat s p)
 913         f p
 914
 915 withFileOrSymlinkStatus :: String -> FilePath -> (Ptr CStat -> IO a) -> IO a
 916 withFileOrSymlinkStatus loc name f = do
 917   modifyIOError (`ioeSetFileName` name) $
 918     allocaBytes sizeof_stat $ \p ->
 919       withCString name $ \s -> do
 920         throwErrnoIfMinus1Retry_ loc (lstat s p)
 921         f p
 922
 923 modificationTime :: Ptr CStat -> IO ClockTime
 924 modificationTime stat = do
 925     mtime <- st_mtime stat
 926     let realToInteger = round . realToFrac :: Real a => a -> Integer
 927     return (TOD (realToInteger (mtime :: CTime)) 0)
 928
 929 isDirectory :: Ptr CStat -> IO Bool
 930 isDirectory stat = do
 931   mode <- st_mode stat
 932   return (s_isdir mode)
 933
 934 fileNameEndClean :: String -> String
 935 fileNameEndClean name = if isDrive name then addTrailingPathSeparator name
 936                                         else dropTrailingPathSeparator name
 937
 938 foreign import ccall unsafe "__hscore_R_OK" r_OK :: CInt
 939 foreign import ccall unsafe "__hscore_W_OK" w_OK :: CInt
 940 foreign import ccall unsafe "__hscore_X_OK" x_OK :: CInt
 941
 942 foreign import ccall unsafe "__hscore_S_IRUSR" s_IRUSR :: CMode
 943 foreign import ccall unsafe "__hscore_S_IWUSR" s_IWUSR :: CMode
 944 foreign import ccall unsafe "__hscore_S_IXUSR" s_IXUSR :: CMode
 945 #ifdef mingw32_HOST_OS
 946 foreign import ccall unsafe "__hscore_S_IFDIR" s_IFDIR :: CMode
 947 #endif
 948
 949
 950 #ifdef __GLASGOW_HASKELL__
 951 foreign import ccall unsafe "__hscore_long_path_size"
 952   long_path_size :: Int
 953 #else
 954 long_path_size :: Int
 955 long_path_size = 2048   --  // guess?
 956 #endif /* __GLASGOW_HASKELL__ */
 957
 958 {- | Returns the current user's home directory.
 959
 960 The directory returned is expected to be writable by the current user,
 961 but note that it isn't generally considered good practice to store
 962 application-specific data here; use 'getAppUserDataDirectory'
 963 instead.
 964
 965 On Unix, 'getHomeDirectory' returns the value of the @HOME@
 966 environment variable.  On Windows, the system is queried for a
 967 suitable path; a typical path might be
 968 @C:/Documents And Settings/user@.
 969
 970 The operation may fail with:
 971
 972 * 'UnsupportedOperation'
 973 The operating system has no notion of home directory.
 974
 975 * 'isDoesNotExistError'
 976 The home directory for the current user does not exist, or
 977 cannot be found.
 978 -}
 979 getHomeDirectory :: IO FilePath
 980 getHomeDirectory =
 981 #if defined(mingw32_HOST_OS)
 982   allocaBytes long_path_size $ \pPath -> do
 983      r0 <- c_SHGetFolderPath nullPtr csidl_PROFILE nullPtr 0 pPath
 984      if (r0 < 0)
 985        then do
 986           r1 <- c_SHGetFolderPath nullPtr csidl_WINDOWS nullPtr 0 pPath
 987           when (r1 < 0) (raiseUnsupported "System.Directory.getHomeDirectory")
 988        else return ()
 989      peekCString pPath
 990 #else
 991   getEnv "HOME"
 992 #endif
 993
 994 {- | Returns the pathname of a directory in which application-specific
 995 data for the current user can be stored.  The result of
 996 'getAppUserDataDirectory' for a given application is specific to
 997 the current user.
 998
 999 The argument should be the name of the application, which will be used
1000 to construct the pathname (so avoid using unusual characters that
1001 might result in an invalid pathname).
1002
1003 Note: the directory may not actually exist, and may need to be created
1004 first.  It is expected that the parent directory exists and is
1005 writable.
1006
1007 On Unix, this function returns @$HOME\/.appName@.  On Windows, a
1008 typical path might be
1009
1010 > C:/Documents And Settings/user/Application Data/appName
1011
1012 The operation may fail with:
1013
1014 * 'UnsupportedOperation'
1015 The operating system has no notion of application-specific data directory.
1016
1017 * 'isDoesNotExistError'
1018 The home directory for the current user does not exist, or
1019 cannot be found.
1020 -}
1021 getAppUserDataDirectory :: String -> IO FilePath
1022 getAppUserDataDirectory appName = do
1023 #if defined(mingw32_HOST_OS)
1024   allocaBytes long_path_size $ \pPath -> do
1025      r <- c_SHGetFolderPath nullPtr csidl_APPDATA nullPtr 0 pPath
1026      when (r<0) (raiseUnsupported "System.Directory.getAppUserDataDirectory")
1027      s <- peekCString pPath
1028      return (s++'\\':appName)
1029 #else
1030   path <- getEnv "HOME"
1031   return (path++'/':'.':appName)
1032 #endif
1033
1034 {- | Returns the current user's document directory.
1035
1036 The directory returned is expected to be writable by the current user,
1037 but note that it isn't generally considered good practice to store
1038 application-specific data here; use 'getAppUserDataDirectory'
1039 instead.
1040
1041 On Unix, 'getUserDocumentsDirectory' returns the value of the @HOME@
1042 environment variable.  On Windows, the system is queried for a
1043 suitable path; a typical path might be
1044 @C:\/Documents and Settings\/user\/My Documents@.
1045
1046 The operation may fail with:
1047
1048 * 'UnsupportedOperation'
1049 The operating system has no notion of document directory.
1050
1051 * 'isDoesNotExistError'
1052 The document directory for the current user does not exist, or
1053 cannot be found.
1054 -}
1055 getUserDocumentsDirectory :: IO FilePath
1056 getUserDocumentsDirectory = do
1057 #if defined(mingw32_HOST_OS)
1058   allocaBytes long_path_size $ \pPath -> do
1059      r <- c_SHGetFolderPath nullPtr csidl_PERSONAL nullPtr 0 pPath
1060      when (r<0) (raiseUnsupported "System.Directory.getUserDocumentsDirectory")
1061      peekCString pPath
1062 #else
1063   getEnv "HOME"
1064 #endif
1065
1066 {- | Returns the current directory for temporary files.
1067
1068 On Unix, 'getTemporaryDirectory' returns the value of the @TMPDIR@
1069 environment variable or \"\/tmp\" if the variable isn\'t defined.
1070 On Windows, the function checks for the existence of environment variables in
1071 the following order and uses the first path found:
1072
1073 *
1074 TMP environment variable.
1075
1076 *
1077 TEMP environment variable.
1078
1079 *
1080 USERPROFILE environment variable.
1081
1082 *
1083 The Windows directory
1084
1085 The operation may fail with:
1086
1087 * 'UnsupportedOperation'
1088 The operating system has no notion of temporary directory.
1089
1090 The function doesn\'t verify whether the path exists.
1091 -}
1092 getTemporaryDirectory :: IO FilePath
1093 getTemporaryDirectory = do
1094 #if defined(mingw32_HOST_OS)
1095   allocaBytes long_path_size $ \pPath -> do
1096      _r <- c_GetTempPath (fromIntegral long_path_size) pPath
1097      peekCString pPath
1098 #else
1099   getEnv "TMPDIR"
1100 #if !__NHC__
1101     `Prelude.catch` \e -> if isDoesNotExistError e then return "/tmp"
1102                           else throw e
1103 #else
1104     `Prelude.catch` (\ex -> return "/tmp")
1105 #endif
1106 #endif
1107
1108 #if defined(mingw32_HOST_OS)
1109 foreign import ccall unsafe "__hscore_getFolderPath"
1110             c_SHGetFolderPath :: Ptr ()
1111                               -> CInt
1112                               -> Ptr ()
1113                               -> CInt
1114                               -> CString
1115                               -> IO CInt
1116 foreign import ccall unsafe "__hscore_CSIDL_PROFILE"  csidl_PROFILE  :: CInt
1117 foreign import ccall unsafe "__hscore_CSIDL_APPDATA"  csidl_APPDATA  :: CInt
1118 foreign import ccall unsafe "__hscore_CSIDL_WINDOWS"  csidl_WINDOWS  :: CInt
1119 foreign import ccall unsafe "__hscore_CSIDL_PERSONAL" csidl_PERSONAL :: CInt
1120
1121 foreign import stdcall unsafe "GetTempPathA" c_GetTempPath :: CInt -> CString -> IO CInt
1122
1123 raiseUnsupported :: String -> IO ()
1124 raiseUnsupported loc =
1125    ioException (ioeSetErrorString (mkIOError UnsupportedOperation loc Nothing Nothing) "unsupported operation")
1126
1127 #endif
1128
1129 -- ToDo: This should be determined via autoconf (AC_EXEEXT)
1130 -- | Extension for executable files
1131 -- (typically @\"\"@ on Unix and @\"exe\"@ on Windows or OS\/2)
1132 exeExtension :: String
1133 #ifdef mingw32_HOST_OS
1134 exeExtension = "exe"
1135 #else
1136 exeExtension = ""
1137 #endif