[project @ 2004-08-18 17:48:44 by krasimir]

[haskell-directory.git] / System / Directory.hs

diff --git a/System/Directory.hs b/System/Directory.hs
index d37a364..9f8e38e 100644 (file)
--- a/System/Directory.hs
+++ b/System/Directory.hs
@@ -5,7 +5,7 @@
 -- License     :  BSD-style (see the file libraries/base/LICENSE)
 -- 
 -- Maintainer  :  libraries@haskell.org
 -- License     :  BSD-style (see the file libraries/base/LICENSE)
 -- 
 -- Maintainer  :  libraries@haskell.org

--- Stability   :  provisional
+-- Stability   :  stable

 -- Portability :  portable
 --
 -- System-independent interface to directory manipulation.
 -- Portability :  portable
 --
 -- System-independent interface to directory manipulation.

@@ -14,38 +14,42 @@
 
 module System.Directory 
    ( 
 
 module System.Directory 
    ( 

-     -- $intro
-
-     -- * Permissions
-
-     -- $permissions
-
-     Permissions(
-       Permissions,
-       readable,               -- :: Permissions -> Bool 
-       writable,               -- :: Permissions -> Bool
-       executable,             -- :: Permissions -> Bool
-       searchable              -- :: Permissions -> Bool
-     )
+    -- $intro

 
     -- * Actions on directories
 
     -- * Actions on directories

-    , createDirectory          -- :: FilePath -> IO ()
+      createDirectory          -- :: FilePath -> IO ()

     , removeDirectory          -- :: FilePath -> IO ()
     , renameDirectory          -- :: FilePath -> FilePath -> IO ()
 
     , getDirectoryContents      -- :: FilePath -> IO [FilePath]
     , getCurrentDirectory       -- :: IO FilePath
     , setCurrentDirectory       -- :: FilePath -> IO ()
     , removeDirectory          -- :: FilePath -> IO ()
     , renameDirectory          -- :: FilePath -> FilePath -> IO ()
 
     , getDirectoryContents      -- :: FilePath -> IO [FilePath]
     , getCurrentDirectory       -- :: IO FilePath
     , setCurrentDirectory       -- :: FilePath -> IO ()

+    , getHomeDirectory
+    , getAppUserDataDirectory
+    , getUserDocumentsDirectory

 
     -- * Actions on files
     , removeFile               -- :: FilePath -> IO ()
     , renameFile                -- :: FilePath -> FilePath -> IO ()
 
     -- * Actions on files
     , removeFile               -- :: FilePath -> IO ()
     , renameFile                -- :: FilePath -> FilePath -> IO ()

+#ifdef __GLASGOW_HASKELL__
+    , copyFile                  -- :: FilePath -> FilePath -> IO ()
+#endif

 
     -- * Existence tests
     , doesFileExist            -- :: FilePath -> IO Bool
     , doesDirectoryExist        -- :: FilePath -> IO Bool
 
 
     -- * Existence tests
     , doesFileExist            -- :: FilePath -> IO Bool
     , doesDirectoryExist        -- :: FilePath -> IO Bool
 

-    -- * Setting and retrieving permissions
+    -- * Permissions
+
+    -- $permissions
+
+    , Permissions(
+       Permissions,
+       readable,               -- :: Permissions -> Bool
+       writable,               -- :: Permissions -> Bool
+       executable,             -- :: Permissions -> Bool
+       searchable              -- :: Permissions -> Bool
+      )

 
     , getPermissions            -- :: FilePath -> IO Permissions
     , setPermissions           -- :: FilePath -> Permissions -> IO ()
 
     , getPermissions            -- :: FilePath -> IO Permissions
     , setPermissions           -- :: FilePath -> Permissions -> IO ()

@@ -57,6 +61,13 @@ module System.Directory
 
 #ifdef __NHC__
 import Directory
 
 #ifdef __NHC__
 import Directory

+getHomeDirectory :: IO FilePath
+getHomeDirectory = getEnv "HOME"
+getAppUserDataDirectory :: String -> IO FilePath
+getAppUserDataDirectory appName = do path <- getEnv "HOME"
+                                     return (path++'/':'.':appName)
+getUserDocumentsDirectory :: IO FilePath
+getUserDocumentsDirectory= getEnv "HOME"

 #elif defined(__HUGS__)
 import Hugs.Directory
 #else
 #elif defined(__HUGS__)
 import Hugs.Directory
 #else

@@ -64,7 +75,9 @@ import Hugs.Directory
 import Prelude
 
 import Control.Exception       ( bracket )
 import Prelude
 
 import Control.Exception       ( bracket )

+import Control.Monad           ( when )

 import System.Posix.Types
 import System.Posix.Types

+import System.Posix.Internals

 import System.Time             ( ClockTime(..) )
 import System.IO
 import System.IO.Error
 import System.Time             ( ClockTime(..) )
 import System.IO
 import System.IO.Error

@@ -72,10 +85,13 @@ import Foreign
 import Foreign.C
 
 #ifdef __GLASGOW_HASKELL__
 import Foreign.C
 
 #ifdef __GLASGOW_HASKELL__

-import System.Posix.Internals

 import GHC.IOBase      ( IOException(..), IOErrorType(..), ioException )
 #endif
 
 import GHC.IOBase      ( IOException(..), IOErrorType(..), ioException )
 #endif
 

+#ifndef mingw32_TARGET_OS
+import System.Environment
+#endif
+

 {- $intro
 A directory contains a series of entries, each of which is a named
 reference to a file system object (file, directory etc.).  Some
 {- $intro
 A directory contains a series of entries, each of which is a named
 reference to a file system object (file, directory etc.).  Some

@@ -120,13 +136,25 @@ data Permissions
     executable, searchable :: Bool 
    } deriving (Eq, Ord, Read, Show)
 
     executable, searchable :: Bool 
    } deriving (Eq, Ord, Read, Show)
 

+{- |The 'getPermissions' operation returns the
+permissions for the file or directory.
+
+The operation may fail with:
+
+* 'isPermissionError' if the user is not permitted to access
+  the permissions; or
+
+* 'isDoesNotExistError' if the file or directory does not exist.
+
+-}
+

 getPermissions :: FilePath -> IO Permissions
 getPermissions name = do
   withCString name $ \s -> do
   read  <- c_access s r_OK
   write <- c_access s w_OK
   exec  <- c_access s x_OK
 getPermissions :: FilePath -> IO Permissions
 getPermissions name = do
   withCString name $ \s -> do
   read  <- c_access s r_OK
   write <- c_access s w_OK
   exec  <- c_access s x_OK

-  withFileStatus name $ \st -> do
+  withFileStatus "getPermissions" name $ \st -> do

   is_dir <- isDirectory st
   return (
     Permissions {
   is_dir <- isDirectory st
   return (
     Permissions {

@@ -137,17 +165,34 @@ getPermissions name = do
     }
    )
 
     }
    )
 

-setPermissions :: FilePath -> Permissions -> IO ()
-setPermissions name (Permissions r w e s) = do
-    let
-     read  = if r      then s_IRUSR else emptyCMode
-     write = if w      then s_IWUSR else emptyCMode
-     exec  = if e || s then s_IXUSR else emptyCMode
+{- |The 'setPermissions' operation sets the
+permissions for the file or directory.
+
+The operation may fail with:

 
 

-     mode  = read `unionCMode` (write `unionCMode` exec)
+* 'isPermissionError' if the user is not permitted to set
+  the permissions; or

 
 

-    withCString name $ \s ->
-      throwErrnoIfMinus1_ "setPermissions" $ c_chmod s mode
+* 'isDoesNotExistError' if the file or directory does not exist.
+
+-}
+
+setPermissions :: FilePath -> Permissions -> IO ()
+setPermissions name (Permissions r w e s) = do
+  allocaBytes sizeof_stat $ \ p_stat -> do
+  withCString name $ \p_name -> do
+    throwErrnoIfMinus1_ "setPermissions" $ do
+      c_stat p_name p_stat
+      mode <- st_mode p_stat
+      let mode1 = modifyBit r mode s_IRUSR
+      let mode2 = modifyBit w mode1 s_IWUSR
+      let mode3 = modifyBit (e || s) mode2 s_IXUSR
+      c_chmod p_name mode3
+
+ where
+   modifyBit :: Bool -> CMode -> CMode -> CMode
+   modifyBit False m b = m .&. (complement b)
+   modifyBit True  m b = m .|. b

 
 -----------------------------------------------------------------------------
 -- Implementation
 
 -----------------------------------------------------------------------------
 -- Implementation

@@ -214,7 +259,7 @@ EIO
 The operand is not a valid directory name.
 [ENAMETOOLONG, ELOOP]
 
 The operand is not a valid directory name.
 [ENAMETOOLONG, ELOOP]
 

-* 'isDoesNotExist'  'NoSuchThing'
+* 'isDoesNotExistError' \/ 'NoSuchThing'

 The directory does not exist. 
 @[ENOENT, ENOTDIR]@
 
 The directory does not exist. 
 @[ENOENT, ENOTDIR]@
 

@@ -242,7 +287,7 @@ removeDirectory path = do
     withCString path $ \s ->
        throwErrnoIfMinus1Retry_ "removeDirectory" (c_rmdir s)
 
     withCString path $ \s ->
        throwErrnoIfMinus1Retry_ "removeDirectory" (c_rmdir s)
 

-{- |@'removefile' file@ removes the directory entry for an existing file
+{- |'removeFile' /file/ removes the directory entry for an existing file

 /file/, where /file/ is not itself a directory. The
 implementation may specify additional constraints which must be
 satisfied before a file can be removed (e.g. the file may not be in
 /file/, where /file/ is not itself a directory. The
 implementation may specify additional constraints which must be
 satisfied before a file can be removed (e.g. the file may not be in

@@ -252,13 +297,13 @@ The operation may fail with:
 
 * 'HardwareFault'
 A physical I\/O error has occurred.
 
 * 'HardwareFault'
 A physical I\/O error has occurred.

-'EIO'
+@[EIO]@

 
 * 'InvalidArgument'
 The operand is not a valid file name.
 @[ENAMETOOLONG, ELOOP]@
 
 
 * 'InvalidArgument'
 The operand is not a valid file name.
 @[ENAMETOOLONG, ELOOP]@
 

-* 'isDoesNotExist' \/ 'NoSuchThing'
+* 'isDoesNotExistError' \/ 'NoSuchThing'

 The file does not exist. 
 @[ENOENT, ENOTDIR]@
 
 The file does not exist. 
 @[ENOENT, ENOTDIR]@
 

@@ -292,6 +337,9 @@ renaming directories in all situations (e.g. renaming to an existing
 directory, or across different physical devices), but the constraints
 must be documented.
 
 directory, or across different physical devices), but the constraints
 must be documented.
 

+On Win32 platforms, @renameDirectory@ fails if the /new/ directory already
+exists.
+

 The operation may fail with:
 
 * 'HardwareFault'
 The operation may fail with:
 
 * 'HardwareFault'

@@ -330,7 +378,7 @@ Either path refers to an existing non-directory object.
 
 renameDirectory :: FilePath -> FilePath -> IO ()
 renameDirectory opath npath =
 
 renameDirectory :: FilePath -> FilePath -> IO ()
 renameDirectory opath npath =

-   withFileStatus opath $ \st -> do
+   withFileStatus "renameDirectory" opath $ \st -> do

    is_dir <- isDirectory st
    if (not is_dir)
        then ioException (IOError Nothing InappropriateType "renameDirectory"
    is_dir <- isDirectory st
    if (not is_dir)
        then ioException (IOError Nothing InappropriateType "renameDirectory"

@@ -387,7 +435,7 @@ Either path refers to an existing directory.
 
 renameFile :: FilePath -> FilePath -> IO ()
 renameFile opath npath =
 
 renameFile :: FilePath -> FilePath -> IO ()
 renameFile opath npath =

-   withFileOrSymlinkStatus opath $ \st -> do
+   withFileOrSymlinkStatus "renameFile" opath $ \st -> do

    is_dir <- isDirectory st
    if is_dir
        then ioException (IOError Nothing InappropriateType "renameFile"
    is_dir <- isDirectory st
    if is_dir
        then ioException (IOError Nothing InappropriateType "renameFile"

@@ -398,6 +446,28 @@ renameFile opath npath =
       withCString npath $ \s2 ->
          throwErrnoIfMinus1Retry_ "renameFile" (c_rename s1 s2)
 
       withCString npath $ \s2 ->
          throwErrnoIfMinus1Retry_ "renameFile" (c_rename s1 s2)
 

+{- |@'copyFile' old new@ copies the existing file from /old/ to /new/.
+If the /new/ file already exists, it is atomically replaced by the /old/ file.
+Neither path may refer to an existing directory.
+-}
+copyFile :: FilePath -> FilePath -> IO ()
+copyFile fromFPath toFPath =
+       (bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom ->
+        bracket (openBinaryFile toFPath WriteMode) hClose $ \hTo ->
+        allocaBytes bufferSize $ \buffer ->
+               copyContents hFrom hTo buffer) `catch` (ioError . changeFunName)
+       where
+               bufferSize = 1024
+               
+               changeFunName (IOError h iot fun str mb_fp) = IOError h iot "copyFile" str mb_fp
+               
+               copyContents hFrom hTo buffer = do
+                       count <- hGetBuf hFrom buffer bufferSize
+                       when (count > 0) $ do
+                               hPutBuf hTo buffer count
+                               copyContents hFrom hTo buffer
+
+

 {- |@'getDirectoryContents' dir@ returns a list of /all/ entries
 in /dir/. 
 
 {- |@'getDirectoryContents' dir@ returns a list of /all/ entries
 in /dir/. 
 

@@ -492,8 +562,8 @@ The operating system has no notion of current directory.
 
 getCurrentDirectory :: IO FilePath
 getCurrentDirectory = do
 
 getCurrentDirectory :: IO FilePath
 getCurrentDirectory = do

-  p <- mallocBytes path_max
-  go p path_max
+  p <- mallocBytes long_path_size
+  go p long_path_size

   where go p bytes = do
          p' <- c_getcwd p (fromIntegral bytes)
          if p' /= nullPtr 
   where go p bytes = do
          p' <- c_getcwd p (fromIntegral bytes)
          if p' /= nullPtr 

@@ -546,49 +616,182 @@ setCurrentDirectory path = do
        throwErrnoIfMinus1Retry_ "setCurrentDirectory" (c_chdir s)
        -- ToDo: add path to error
 
        throwErrnoIfMinus1Retry_ "setCurrentDirectory" (c_chdir s)
        -- ToDo: add path to error
 

-{- |To clarify, 'doesDirectoryExist' returns 'True' if a file system object
-exist, and it's a directory. 'doesFileExist' returns 'True' if the file
-system object exist, but it's not a directory (i.e., for every other 
-file system object that is not a directory.) 
+{- | Returns the current user's home directory.
+
+The directory returned is expected to be writable by the current user,
+but note that it isn't generally considered good practice to store
+application-specific data here; use 'getAppUserDataDirectory'
+instead.
+
+On Unix, 'getHomeDirectory' returns the value of the @HOME@
+environment variable.  On Windows, the system is queried for a
+suitable path; a typical path might be 
+@C:/Documents And Settings/user@.
+
+The operation may fail with:
+
+* 'UnsupportedOperation'
+The operating system has no notion of home directory.
+
+* 'isDoesNotExistError'
+The home directory for the current user does not exist, or
+cannot be found.
+-}
+getHomeDirectory :: IO FilePath
+getHomeDirectory =
+#ifdef mingw32_TARGET_OS
+  allocaBytes long_path_size $ \pPath -> do
+     r <- c_SHGetFolderPath nullPtr csidl_PROFILE nullPtr 0 pPath
+     if (r < 0)
+       then c_SHGetFolderPath nullPtr csidl_WINDOWS nullPtr 0 pPath
+       else return 0
+     peekCString pPath
+#else
+  getEnv "HOME"
+#endif
+
+{- | Returns the pathname of a directory in which application-specific
+data for the current user can be stored.  The result of
+'getAppUserDataDirectory' for a given application is specific to
+the current user.
+
+The argument should be the name of the application, which will be used
+to construct the pathname (so avoid using unusual characters that
+might result in an invalid pathname).
+
+Note: the directory may not actually exist, and may need to be created
+first.  It is expected that the parent directory exists and is
+writable.
+
+On Unix, this function returns @$HOME\/.appName@.  On Windows, a
+typical path might be 
+
+> C:/Documents And Settings/user/Application Data/appName
+
+The operation may fail with:
+
+* 'UnsupportedOperation'
+The operating system has no notion of application-specific data directory.
+
+* 'isDoesNotExistError'
+The home directory for the current user does not exist, or
+cannot be found.
+-}
+getAppUserDataDirectory :: String -> IO FilePath
+getAppUserDataDirectory appName = do
+#ifdef mingw32_TARGET_OS
+  allocaBytes long_path_size $ \pPath -> do
+     r <- c_SHGetFolderPath nullPtr csidl_APPDATA nullPtr 0 pPath
+     s <- peekCString pPath
+     return (s++'\\':appName)
+#else
+  path <- getEnv "HOME"
+  return (path++'/':'.':appName)
+#endif
+
+{- | Returns the current user's document directory.
+
+The directory returned is expected to be writable by the current user,
+but note that it isn't generally considered good practice to store
+application-specific data here; use 'getAppUserDataDirectory'
+instead.
+
+On Unix, 'getUserDocumentsDirectory' returns the value of the @HOME@
+environment variable.  On Windows, the system is queried for a
+suitable path; a typical path might be 
+@C:/Documents and Settings/user/My Documents@.
+
+The operation may fail with:
+
+* 'UnsupportedOperation'
+The operating system has no notion of document directory.
+
+* 'isDoesNotExistError'
+The document directory for the current user does not exist, or
+cannot be found.
+-}
+getUserDocumentsDirectory :: IO FilePath
+getUserDocumentsDirectory = do
+#ifdef mingw32_TARGET_OS
+  allocaBytes long_path_size $ \pPath -> do
+     r <- c_SHGetFolderPath nullPtr csidl_PERSONAL nullPtr 0 pPath
+     peekCString pPath
+#else
+  getEnv "HOME"
+#endif
+
+#ifdef mingw32_TARGET_OS
+foreign import stdcall unsafe "SHGetFolderPath" 
+            c_SHGetFolderPath :: Ptr () 
+                              -> CInt 
+                              -> Ptr () 
+                              -> CInt 
+                              -> CString 
+                              -> IO CInt
+foreign import ccall unsafe "__hscore_CSIDL_PROFILE"  csidl_PROFILE  :: CInt
+foreign import ccall unsafe "__hscore_CSIDL_APPDATA"  csidl_APPDATA  :: CInt
+foreign import ccall unsafe "__hscore_CSIDL_WINDOWS"  csidl_WINDOWS  :: CInt
+foreign import ccall unsafe "__hscore_CSIDL_PERSONAL" csidl_PERSONAL :: CInt
+#endif
+
+{- |The operation 'doesDirectoryExist' returns 'True' if the argument file
+exists and is a directory, and 'False' otherwise.

 -}
 
 doesDirectoryExist :: FilePath -> IO Bool
 doesDirectoryExist name = 
  catch
 -}
 
 doesDirectoryExist :: FilePath -> IO Bool
 doesDirectoryExist name = 
  catch

-   (withFileStatus name $ \st -> isDirectory st)
+   (withFileStatus "doesDirectoryExist" name $ \st -> isDirectory st)

    (\ _ -> return False)
 
    (\ _ -> return False)
 

+{- |The operation 'doesFileExist' returns 'True'
+if the argument file exists and is not a directory, and 'False' otherwise.
+-}
+

 doesFileExist :: FilePath -> IO Bool
 doesFileExist name = do 
  catch
 doesFileExist :: FilePath -> IO Bool
 doesFileExist name = do 
  catch

-   (withFileStatus name $ \st -> do b <- isDirectory st; return (not b))
+   (withFileStatus "doesFileExist" name $ \st -> do b <- isDirectory st; return (not b))

    (\ _ -> return False)
 
    (\ _ -> return False)
 

+{- |The 'getModificationTime' operation returns the
+clock time at which the file or directory was last modified.
+
+The operation may fail with:
+
+* 'isPermissionError' if the user is not permitted to access
+  the modification time; or
+
+* 'isDoesNotExistError' if the file or directory does not exist.
+
+-}
+

 getModificationTime :: FilePath -> IO ClockTime
 getModificationTime name =
 getModificationTime :: FilePath -> IO ClockTime
 getModificationTime name =

- withFileStatus name $ \ st ->
+ withFileStatus "getModificationTime" name $ \ st ->

  modificationTime st
 
  modificationTime st
 

-withFileStatus :: FilePath -> (Ptr CStat -> IO a) -> IO a
-withFileStatus name f = do
+withFileStatus :: String -> FilePath -> (Ptr CStat -> IO a) -> IO a
+withFileStatus loc name f = do

   modifyIOError (`ioeSetFileName` name) $
     allocaBytes sizeof_stat $ \p ->
       withCString (fileNameEndClean name) $ \s -> do
   modifyIOError (`ioeSetFileName` name) $
     allocaBytes sizeof_stat $ \p ->
       withCString (fileNameEndClean name) $ \s -> do

-        throwErrnoIfMinus1Retry_ "withFileStatus" (c_stat s p)
+        throwErrnoIfMinus1Retry_ loc (c_stat s p)

        f p
 
        f p
 

-withFileOrSymlinkStatus :: FilePath -> (Ptr CStat -> IO a) -> IO a
-withFileOrSymlinkStatus name f = do
+withFileOrSymlinkStatus :: String -> FilePath -> (Ptr CStat -> IO a) -> IO a
+withFileOrSymlinkStatus loc name f = do

   modifyIOError (`ioeSetFileName` name) $
     allocaBytes sizeof_stat $ \p ->
       withCString name $ \s -> do
   modifyIOError (`ioeSetFileName` name) $
     allocaBytes sizeof_stat $ \p ->
       withCString name $ \s -> do

-        throwErrnoIfMinus1Retry_ "withFileOrSymlinkStatus" (lstat s p)
+        throwErrnoIfMinus1Retry_ loc (lstat s p)

        f p
 
 modificationTime :: Ptr CStat -> IO ClockTime
 modificationTime stat = do
     mtime <- st_mtime stat
        f p
 
 modificationTime :: Ptr CStat -> IO ClockTime
 modificationTime stat = do
     mtime <- st_mtime stat

-    return (TOD (toInteger (mtime :: CTime)) 0)
+    let realToInteger = round . realToFrac :: Real a => a -> Integer
+    return (TOD (realToInteger (mtime :: CTime)) 0)

     
 isDirectory :: Ptr CStat -> IO Bool
 isDirectory stat = do
     
 isDirectory :: Ptr CStat -> IO Bool
 isDirectory stat = do

@@ -597,7 +800,7 @@ isDirectory stat = do
 
 fileNameEndClean :: String -> String
 fileNameEndClean name = 
 
 fileNameEndClean :: String -> String
 fileNameEndClean name = 

-  if i >= 0 && (ec == '\\' || ec == '/') then 
+  if i > 0 && (ec == '\\' || ec == '/') then 

      fileNameEndClean (take i name)
    else
      name
      fileNameEndClean (take i name)
    else
      name

@@ -605,27 +808,8 @@ fileNameEndClean name =
       i  = (length name) - 1
       ec = name !! i
 
       i  = (length name) - 1
       ec = name !! i
 

-emptyCMode     :: CMode
-emptyCMode     = 0
-
-unionCMode     :: CMode -> CMode -> CMode
-unionCMode     = (+)
-
-
-foreign import ccall unsafe "__hscore_path_max"
-  path_max :: Int
-
-foreign import ccall unsafe "__hscore_readdir"
-  readdir  :: Ptr CDir -> Ptr (Ptr CDirent) -> IO CInt
-
-foreign import ccall unsafe "__hscore_free_dirent"
-  freeDirEnt  :: Ptr CDirent -> IO ()
-
-foreign import ccall unsafe "__hscore_end_of_dir"
-  end_of_dir :: CInt
-
-foreign import ccall unsafe "__hscore_d_name"
-  d_name :: Ptr CDirent -> IO CString
+foreign import ccall unsafe "__hscore_long_path_size"
+  long_path_size :: Int

 
 foreign import ccall unsafe "__hscore_R_OK" r_OK :: CMode
 foreign import ccall unsafe "__hscore_W_OK" w_OK :: CMode
 
 foreign import ccall unsafe "__hscore_R_OK" r_OK :: CMode
 foreign import ccall unsafe "__hscore_W_OK" w_OK :: CMode