X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FDirectory.hs;h=beed8798cca5fa154974083563baaaf4055361f4;hb=30c6a57ac9dfc3808a28bb2654912aa7460568c8;hp=096712c48f2314e5fc27b5fb70d1616a11cdcede;hpb=df61fc232892d3c23257de2bcc4d88e547ee028c;p=haskell-directory.git diff --git a/System/Directory.hs b/System/Directory.hs index 096712c..beed879 100644 --- a/System/Directory.hs +++ b/System/Directory.hs @@ -18,7 +18,9 @@ module System.Directory -- * Actions on directories createDirectory -- :: FilePath -> IO () + , createDirectoryIfMissing -- :: Bool -> FilePath -> IO () , removeDirectory -- :: FilePath -> IO () + , removeDirectoryRecursive -- :: FilePath -> IO () , renameDirectory -- :: FilePath -> FilePath -> IO () , getDirectoryContents -- :: FilePath -> IO [FilePath] @@ -29,13 +31,16 @@ module System.Directory , getHomeDirectory , getAppUserDataDirectory , getUserDocumentsDirectory + , getTemporaryDirectory -- * Actions on files , removeFile -- :: FilePath -> IO () , renameFile -- :: FilePath -> FilePath -> IO () -#ifdef __GLASGOW_HASKELL__ , copyFile -- :: FilePath -> FilePath -> IO () -#endif + + , canonicalizePath + , makeRelativeToCurrentDirectory + , findExecutable -- * Existence tests , doesFileExist -- :: FilePath -> IO Bool @@ -61,39 +66,35 @@ module System.Directory , getModificationTime -- :: FilePath -> IO ClockTime ) where +import System.Directory.Internals +import System.Environment ( getEnv ) +import System.FilePath +import System.IO.Error +import Control.Monad ( when, unless ) + #ifdef __NHC__ import Directory -import System (getEnv) -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__) +#endif /* __NHC__ */ + +#ifdef __HUGS__ import Hugs.Directory -#else +#endif /* __HUGS__ */ +import Foreign +import Foreign.C + +{-# CFILES cbits/directory.c #-} + +#ifdef __GLASGOW_HASKELL__ 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.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 @@ -197,6 +198,16 @@ setPermissions name (Permissions r w e s) = do modifyBit False m b = m .&. (complement b) modifyBit True m b = m .|. b + +copyPermissions :: FilePath -> FilePath -> IO () +copyPermissions source dest = do + allocaBytes sizeof_stat $ \ p_stat -> do + withCString source $ \p_source -> do + withCString dest $ \p_dest -> do + throwErrnoIfMinus1_ "copyPermissions" $ c_stat p_source p_stat + mode <- st_mode p_stat + throwErrnoIfMinus1_ "copyPermissions" $ c_chmod p_dest mode + ----------------------------------------------------------------------------- -- Implementation @@ -239,10 +250,34 @@ The path refers to an existing non-directory object. createDirectory :: FilePath -> IO () createDirectory path = do + modifyIOError (`ioeSetFileName` path) $ withCString path $ \s -> do throwErrnoIfMinus1Retry_ "createDirectory" $ mkdir s 0o777 +#else /* !__GLASGOW_HASKELL__ */ + +copyPermissions :: FilePath -> FilePath -> IO () +copyPermissions fromFPath toFPath + = getPermissions fromFPath >>= setPermissions toFPath + +#endif + +-- | @'createDirectoryIfMissing' parents dir@ creates a new directory +-- @dir@ if it doesn\'t exist. If the first argument is 'True' +-- the function will also create all parent directories if they are missing. +createDirectoryIfMissing :: Bool -- ^ Create its parents too? + -> FilePath -- ^ The path to the directory you want to make + -> IO () +createDirectoryIfMissing parents file = do + b <- doesDirectoryExist file + case (b,parents, file) of + (_, _, "") -> return () + (True, _, _) -> return () + (_, True, _) -> mapM_ (createDirectoryIfMissing False) (tail (pathParents file)) + (_, False, _) -> createDirectory file + +#if __GLASGOW_HASKELL__ {- | @'removeDirectory' dir@ removes an existing directory /dir/. The implementation may specify additional constraints which must be satisfied before a directory can be removed (e.g. the directory has to @@ -289,7 +324,27 @@ removeDirectory path = do modifyIOError (`ioeSetFileName` path) $ withCString path $ \s -> throwErrnoIfMinus1Retry_ "removeDirectory" (c_rmdir s) +#endif +-- | @'removeDirectoryRecursive' dir@ removes an existing directory /dir/ +-- together with its content and all subdirectories. Be careful, +-- if the directory contains symlinks, the function will follow them. +removeDirectoryRecursive :: FilePath -> IO () +removeDirectoryRecursive startLoc = do + cont <- getDirectoryContents startLoc + sequence_ [rm (startLoc `joinFileName` x) | x <- cont, x /= "." && x /= ".."] + removeDirectory startLoc + where + rm :: FilePath -> IO () + rm f = do temp <- try (removeFile f) + case temp of + Left e -> do isDir <- doesDirectoryExist f + -- If f is not a directory, re-throw the error + unless isDir $ ioError e + removeDirectoryRecursive f + Right _ -> return () + +#if __GLASGOW_HASKELL__ {- |'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 @@ -449,16 +504,55 @@ renameFile opath npath = withCString npath $ \s2 -> throwErrnoIfMinus1Retry_ "renameFile" (c_rename s1 s2) +#endif /* __GLASGOW_HASKELL__ */ + {- |@'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. +Neither path may refer to an existing directory. The permissions of /old/ are +copied to /new/, if possible. +-} + +{- NOTES: + +It's tempting to try to remove the target file before opening it for +writing. This could be useful: for example if the target file is an +executable that is in use, writing will fail, but unlinking first +would succeed. + +However, it certainly isn't always what you want. + + * if the target file is hardlinked, removing it would break + the hard link, but just opening would preserve it. + + * opening and truncating will preserve permissions and + ACLs on the target. + + * If the destination file is read-only in a writable directory, + we might want copyFile to fail. Removing the target first + would succeed, however. + + * If the destination file is special (eg. /dev/null), removing + it is probably not the right thing. Copying to /dev/null + should leave /dev/null intact, not replace it with a plain + file. + + * There's a small race condition between removing the target and + opening it for writing during which time someone might + create it again. -} copyFile :: FilePath -> FilePath -> IO () copyFile fromFPath toFPath = +#if (!(defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 600)) + do readFile fromFPath >>= writeFile toFPath + try (copyPermissions fromFPath toFPath) + return () +#else (bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom -> bracket (openBinaryFile toFPath WriteMode) hClose $ \hTo -> - allocaBytes bufferSize $ \buffer -> - copyContents hFrom hTo buffer) `catch` (ioError . changeFunName) + allocaBytes bufferSize $ \buffer -> do + copyContents hFrom hTo buffer + try (copyPermissions fromFPath toFPath) + return ()) `catch` (ioError . changeFunName) where bufferSize = 1024 @@ -469,8 +563,91 @@ copyFile fromFPath toFPath = when (count > 0) $ do hPutBuf hTo buffer count copyContents hFrom hTo buffer +#endif + +-- | Given path referring to a file or directory, returns a +-- canonicalized path, with the intent that two paths referring +-- to the same file\/directory will map to the same canonicalized +-- path. Note that it is impossible to guarantee that the +-- implication (same file\/dir \<=\> same canonicalizedPath) holds +-- in either direction: this function can make only a best-effort +-- attempt. +canonicalizePath :: FilePath -> IO FilePath +canonicalizePath fpath = + withCString fpath $ \pInPath -> + allocaBytes long_path_size $ \pOutPath -> +#if defined(mingw32_HOST_OS) + alloca $ \ppFilePart -> + do c_GetFullPathName pInPath (fromIntegral long_path_size) pOutPath ppFilePart +#else + do c_realpath pInPath pOutPath +#endif + peekCString pOutPath + +#if defined(mingw32_HOST_OS) +foreign import stdcall unsafe "GetFullPathNameA" + c_GetFullPathName :: CString + -> CInt + -> CString + -> Ptr CString + -> IO CInt +#else +foreign import ccall unsafe "realpath" + c_realpath :: CString + -> CString + -> IO CString +#endif + +-- | 'makeRelative' the current directory. +makeRelativeToCurrentDirectory :: FilePath -> IO FilePath +makeRelativeToCurrentDirectory x = do + cur <- getCurrentDirectory + return $ makeRelative cur x + +-- | Given an executable file name, searches for such file +-- in the directories listed in system PATH. The returned value +-- is the path to the found executable or Nothing if there isn't +-- such executable. For example (findExecutable \"ghc\") +-- gives you the path to GHC. +findExecutable :: String -> IO (Maybe FilePath) +findExecutable binary = +#if defined(mingw32_HOST_OS) + withCString binary $ \c_binary -> + withCString ('.':exeExtension) $ \c_ext -> + allocaBytes long_path_size $ \pOutPath -> + alloca $ \ppFilePart -> do + res <- c_SearchPath nullPtr c_binary c_ext (fromIntegral long_path_size) pOutPath ppFilePart + if res > 0 && res < fromIntegral long_path_size + then do fpath <- peekCString pOutPath + return (Just fpath) + else return Nothing + +foreign import stdcall unsafe "SearchPathA" + c_SearchPath :: CString + -> CString + -> CString + -> CInt + -> CString + -> Ptr CString + -> IO CInt +#else + do + path <- getEnv "PATH" + search (parseSearchPath path) + where + fileName = binary `joinFileExt` exeExtension + + search :: [FilePath] -> IO (Maybe FilePath) + search [] = return Nothing + search (d:ds) = do + let path = d `joinFileName` fileName + b <- doesFileExist path + if b then return (Just path) + else search ds +#endif +#ifdef __GLASGOW_HASKELL__ {- |@'getDirectoryContents' dir@ returns a list of /all/ entries in /dir/. @@ -619,6 +796,97 @@ setCurrentDirectory path = do throwErrnoIfMinus1Retry_ "setCurrentDirectory" (c_chdir s) -- ToDo: add path to error +{- |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 "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 "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 "getModificationTime" name $ \ st -> + modificationTime st + +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 + throwErrnoIfMinus1Retry_ loc (c_stat s p) + f p + +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_ loc (lstat s p) + f p + +modificationTime :: Ptr CStat -> IO ClockTime +modificationTime stat = do + mtime <- st_mtime stat + 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) + +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_R_OK" r_OK :: CInt +foreign import ccall unsafe "__hscore_W_OK" w_OK :: CInt +foreign import ccall unsafe "__hscore_X_OK" x_OK :: CInt + +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 + +foreign import ccall unsafe "__hscore_long_path_size" + long_path_size :: Int + +#else +long_path_size :: Int +long_path_size = 2048 -- // guess? + +#endif /* __GLASGOW_HASKELL__ */ + {- | Returns the current user's home directory. The directory returned is expected to be writable by the current user, @@ -642,12 +910,14 @@ cannot be found. -} getHomeDirectory :: IO FilePath getHomeDirectory = -#ifdef mingw32_TARGET_OS +#if defined(mingw32_HOST_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 + then do + r <- c_SHGetFolderPath nullPtr csidl_WINDOWS nullPtr 0 pPath + when (r < 0) (raiseUnsupported "System.Directory.getHomeDirectory") + else return () peekCString pPath #else getEnv "HOME" @@ -682,9 +952,10 @@ cannot be found. -} getAppUserDataDirectory :: String -> IO FilePath getAppUserDataDirectory appName = do -#ifdef mingw32_TARGET_OS +#if defined(mingw32_HOST_OS) allocaBytes long_path_size $ \pPath -> do r <- c_SHGetFolderPath nullPtr csidl_APPDATA nullPtr 0 pPath + when (r<0) (raiseUnsupported "System.Directory.getAppUserDataDirectory") s <- peekCString pPath return (s++'\\':appName) #else @@ -715,111 +986,67 @@ cannot be found. -} getUserDocumentsDirectory :: IO FilePath getUserDocumentsDirectory = do -#ifdef mingw32_TARGET_OS +#if defined(mingw32_HOST_OS) allocaBytes long_path_size $ \pPath -> do r <- c_SHGetFolderPath nullPtr csidl_PERSONAL nullPtr 0 pPath + when (r<0) (raiseUnsupported "System.Directory.getUserDocumentsDirectory") 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 +{- | Returns the current directory for temporary files. -{- |The operation 'doesDirectoryExist' returns 'True' if the argument file -exists and is a directory, and 'False' otherwise. --} +On Unix, 'getTemporaryDirectory' returns the value of the @TMPDIR@ +environment variable or \"\/tmp\" if the variable isn\'t defined. +On Windows, the function checks for the existence of environment variables in +the following order and uses the first path found: -doesDirectoryExist :: FilePath -> IO Bool -doesDirectoryExist name = - catch - (withFileStatus "doesDirectoryExist" name $ \st -> isDirectory st) - (\ _ -> return False) +* +TMP environment variable. -{- |The operation 'doesFileExist' returns 'True' -if the argument file exists and is not a directory, and 'False' otherwise. --} +* +TEMP environment variable. -doesFileExist :: FilePath -> IO Bool -doesFileExist name = do - catch - (withFileStatus "doesFileExist" name $ \st -> do b <- isDirectory st; return (not b)) - (\ _ -> return False) +* +USERPROFILE environment variable. -{- |The 'getModificationTime' operation returns the -clock time at which the file or directory was last modified. +* +The Windows directory 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. +* 'UnsupportedOperation' +The operating system has no notion of temporary directory. +The function doesn\'t verify whether the path exists. -} +getTemporaryDirectory :: IO FilePath +getTemporaryDirectory = do +#if defined(mingw32_HOST_OS) + allocaBytes long_path_size $ \pPath -> do + r <- c_GetTempPath (fromIntegral long_path_size) pPath + peekCString pPath +#else + catch (getEnv "TMPDIR") (\ex -> return "/tmp") +#endif -getModificationTime :: FilePath -> IO ClockTime -getModificationTime name = - withFileStatus "getModificationTime" name $ \ st -> - modificationTime st - -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 - throwErrnoIfMinus1Retry_ loc (c_stat s p) - f p - -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_ loc (lstat s p) - f p - -modificationTime :: Ptr CStat -> IO ClockTime -modificationTime stat = do - mtime <- st_mtime stat - 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) - -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_long_path_size" - long_path_size :: Int +#if defined(mingw32_HOST_OS) +foreign import ccall unsafe "__hscore_getFolderPath" + 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 -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_X_OK" x_OK :: CMode +foreign import stdcall unsafe "GetTempPathA" c_GetTempPath :: CInt -> CString -> IO CInt -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 +raiseUnsupported loc = + ioException (IOError Nothing UnsupportedOperation loc "unsupported operation" Nothing) #endif