X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FDirectory.hs;h=78dd94ccc0b42f988b69f12267484f05a081c9cb;hb=3cc1f5d185caf783013bbfe4858a1ed09b3329e0;hp=46d69498b5b5acfc967e254e4655220a31d5a1bf;hpb=468611bd4c41cd427c6f98e780154db804b51b28;p=haskell-directory.git diff --git a/System/Directory.hs b/System/Directory.hs index 46d6949..78dd94c 100644 --- 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 --- Stability : provisional +-- Stability : stable -- Portability : portable -- -- System-independent interface to directory manipulation. @@ -14,22 +14,10 @@ module System.Directory ( - -- $intro - - -- * Permissions - - -- $permissions - - Permissions( - Permissions, - readable, -- :: Permissions -> Bool - writable, -- :: Permissions -> Bool - executable, -- :: Permissions -> Bool - searchable -- :: Permissions -> Bool - ) + -- $intro -- * Actions on directories - , createDirectory -- :: FilePath -> IO () + createDirectory -- :: FilePath -> IO () , removeDirectory -- :: FilePath -> IO () , renameDirectory -- :: FilePath -> FilePath -> IO () @@ -37,15 +25,33 @@ module System.Directory , getCurrentDirectory -- :: IO FilePath , setCurrentDirectory -- :: FilePath -> IO () + -- * Pre-defined directories + , getHomeDirectory + , getAppUserDataDirectory + , getUserDocumentsDirectory + -- * 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 - -- * 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 () @@ -55,18 +61,39 @@ module System.Directory , getModificationTime -- :: FilePath -> IO ClockTime ) where +#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 + import Prelude +import Control.Exception ( bracket ) +import Control.Monad ( when ) +import System.Posix.Types +import System.Posix.Internals import System.Time ( ClockTime(..) ) import System.IO +import System.IO.Error import Foreign import Foreign.C #ifdef __GLASGOW_HASKELL__ -import GHC.Posix 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 @@ -111,13 +138,25 @@ data Permissions 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 - withFileStatus name $ \st -> do + withFileStatus "getPermissions" name $ \st -> do is_dir <- isDirectory st return ( Permissions { @@ -128,17 +167,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 @@ -205,7 +261,7 @@ EIO The operand is not a valid directory name. [ENAMETOOLONG, ELOOP] -* 'isDoesNotExist' 'NoSuchThing' +* 'isDoesNotExistError' \/ 'NoSuchThing' The directory does not exist. @[ENOENT, ENOTDIR]@ @@ -229,10 +285,11 @@ The operand refers to an existing non-directory object. removeDirectory :: FilePath -> IO () removeDirectory path = do + modifyIOError (`ioeSetFileName` path) $ 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 @@ -242,13 +299,13 @@ The operation may fail with: * 'HardwareFault' A physical I\/O error has occurred. -'EIO' +@[EIO]@ * 'InvalidArgument' The operand is not a valid file name. @[ENAMETOOLONG, ELOOP]@ -* 'isDoesNotExist' \/ 'NoSuchThing' +* 'isDoesNotExistError' \/ 'NoSuchThing' The file does not exist. @[ENOENT, ENOTDIR]@ @@ -268,6 +325,7 @@ The operand refers to an existing directory. removeFile :: FilePath -> IO () removeFile path = do + modifyIOError (`ioeSetFileName` path) $ withCString path $ \s -> throwErrnoIfMinus1Retry_ "removeFile" (c_unlink s) @@ -281,6 +339,9 @@ renaming directories in all situations (e.g. renaming to an existing 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' @@ -319,7 +380,7 @@ Either path refers to an existing non-directory object. 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" @@ -376,7 +437,7 @@ Either path refers to an existing directory. 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" @@ -387,6 +448,28 @@ renameFile opath npath = 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/. @@ -420,6 +503,7 @@ The path refers to an existing non-directory object. getDirectoryContents :: FilePath -> IO [FilePath] getDirectoryContents path = do + modifyIOError (`ioeSetFileName` path) $ alloca $ \ ptr_dEnt -> bracket (withCString path $ \s -> @@ -480,8 +564,8 @@ The operating system has no notion of current directory. 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 @@ -529,78 +613,205 @@ The path refers to an existing non-directory object. setCurrentDirectory :: FilePath -> IO () setCurrentDirectory path = do + modifyIOError (`ioeSetFileName` path) $ withCString path $ \s -> 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 - (withFileStatus name $ \st -> isDirectory st) + (withFileStatus "doesDirectoryExist" name $ \st -> isDirectory st) (\ _ -> 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 - (withFileStatus name $ \st -> do b <- isDirectory st; return (not b)) + (withFileStatus "doesFileExist" name $ \st -> do b <- isDirectory st; return (not b)) (\ _ -> 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 = - withFileStatus name $ \ st -> + withFileStatus "getModificationTime" name $ \ 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 name $ \s -> do - throwErrnoIfMinus1Retry_ "withFileStatus" (c_stat s p) + withCString (fileNameEndClean name) $ \s -> do + throwErrnoIfMinus1Retry_ loc (c_stat s 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 - throwErrnoIfMinus1Retry_ "withFileOrSymlinkStatus" (lstat s p) + throwErrnoIfMinus1Retry_ loc (lstat s p) 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 mode <- st_mode stat return (s_isdir mode) -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 +fileNameEndClean :: String -> String +fileNameEndClean name = + if i > 0 && (ec == '\\' || ec == '/') then + fileNameEndClean (take i name) + else + name + where + i = (length name) - 1 + ec = name !! i -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 @@ -609,3 +820,5 @@ foreign import ccall unsafe "__hscore_X_OK" x_OK :: CMode foreign import ccall unsafe "__hscore_S_IRUSR" s_IRUSR :: CMode foreign import ccall unsafe "__hscore_S_IWUSR" s_IWUSR :: CMode foreign import ccall unsafe "__hscore_S_IXUSR" s_IXUSR :: CMode + +#endif