X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FDirectory.hs;h=13a6a660774a2cee67a48cc3871595a7ea49a3cc;hb=b513fe8c184b758a71dc7c7d0accaabdaf7797f0;hp=e7affb68f03a1a7f85c8ce182f469a89f0e6432f;hpb=b33cc8f0d60e7ab53a916bff339ff40a677e0a62;p=haskell-directory.git diff --git a/System/Directory.hs b/System/Directory.hs index e7affb6..13a6a66 100644 --- a/System/Directory.hs +++ b/System/Directory.hs @@ -1,3 +1,6 @@ +{-# OPTIONS_GHC -w #-} +-- XXX We get some warnings on Windows + ----------------------------------------------------------------------------- -- | -- Module : System.Directory @@ -67,12 +70,15 @@ module System.Directory ) where import Prelude hiding ( catch ) +import qualified Prelude +import Control.Monad (guard) import System.Environment ( getEnv ) import System.FilePath +import System.IO import System.IO.Error hiding ( catch, try ) import Control.Monad ( when, unless ) -import Control.Exception +import Control.Exception.Base #ifdef __NHC__ import Directory @@ -92,16 +98,21 @@ import Foreign.C import System.Posix.Types import System.Posix.Internals import System.Time ( ClockTime(..) ) -import System.IO import GHC.IOBase ( IOException(..), IOErrorType(..), ioException ) +#ifdef mingw32_HOST_OS +import qualified System.Win32 +#else +import qualified System.Posix +#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 entries may be hidden, inaccessible, or have some administrative function (e.g. `.' or `..' under POSIX -), but in +), but in this standard all such entries are considered to form part of the directory contents. Entries in sub-directories are not, however, considered to form part of the directory contents. @@ -165,30 +176,30 @@ getPermissions name = do allocaBytes sizeof_stat $ \ p_stat -> do throwErrnoIfMinus1_ "getPermissions" $ c_stat s p_stat mode <- st_mode p_stat - let read = mode .&. s_IRUSR - let write = mode .&. s_IWUSR - let exec = mode .&. s_IXUSR + let usr_read = mode .&. s_IRUSR + let usr_write = mode .&. s_IWUSR + let usr_exec = mode .&. s_IXUSR let is_dir = mode .&. s_IFDIR return ( Permissions { - readable = read /= 0, - writable = write /= 0, - executable = is_dir == 0 && exec /= 0, - searchable = is_dir /= 0 && exec /= 0 + readable = usr_read /= 0, + writable = usr_write /= 0, + executable = is_dir == 0 && usr_exec /= 0, + searchable = is_dir /= 0 && usr_exec /= 0 } ) #else - read <- c_access s r_OK - write <- c_access s w_OK - exec <- c_access s x_OK + read_ok <- c_access s r_OK + write_ok <- c_access s w_OK + exec_ok <- c_access s x_OK withFileStatus "getPermissions" name $ \st -> do is_dir <- isDirectory st return ( Permissions { - readable = read == 0, - writable = write == 0, - executable = not is_dir && exec == 0, - searchable = is_dir && exec == 0 + readable = read_ok == 0, + writable = write_ok == 0, + executable = not is_dir && exec_ok == 0, + searchable = is_dir && exec_ok == 0 } ) #endif @@ -274,10 +285,11 @@ 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 +#ifdef mingw32_HOST_OS + System.Win32.createDirectory path Nothing +#else + System.Posix.createDirectory path 0o777 +#endif #else /* !__GLASGOW_HASKELL__ */ @@ -293,14 +305,40 @@ copyPermissions fromFPath toFPath 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) $ mkParents file - (_, False, _) -> createDirectory file - where mkParents = scanl1 () . splitDirectories . normalise +createDirectoryIfMissing create_parents path0 + | create_parents = createDirs (parents path0) + | otherwise = createDirs (take 1 (parents path0)) + where + parents = reverse . scanl1 () . splitDirectories . normalise + + createDirs [] = return () + createDirs (dir:[]) = createDir dir throw + createDirs (dir:dirs) = + createDir dir $ \_ -> do + createDirs dirs + createDir dir throw + + createDir :: FilePath -> (IOException -> IO ()) -> IO () + createDir dir notExistHandler = do + r <- try $ createDirectory dir + case (r :: Either IOException ()) of + Right () -> return () + Left e + | isDoesNotExistError e -> notExistHandler e + -- createDirectory (and indeed POSIX mkdir) does not distinguish + -- between a dir already existing and a file already existing. So we + -- check for it here. Unfortunately there is a slight race condition + -- here, but we think it is benign. It could report an exeption in + -- the case that the dir did exist but another process deletes the + -- directory and creates a file in its place before we can check + -- that the directory did indeed exist. + | isAlreadyExistsError e -> + (withFileStatus "createDirectoryIfMissing" dir $ \st -> do + isDir <- isDirectory st + if isDir then return () + else throw e + ) `catch` ((\_ -> return ()) :: IOException -> IO ()) + | otherwise -> throw e #if __GLASGOW_HASKELL__ {- | @'removeDirectory' dir@ removes an existing directory /dir/. The @@ -345,10 +383,13 @@ 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) +removeDirectory path = +#ifdef mingw32_HOST_OS + System.Win32.removeDirectory path +#else + System.Posix.removeDirectory path +#endif + #endif -- | @'removeDirectoryRecursive' dir@ removes an existing directory /dir/ @@ -365,7 +406,7 @@ removeDirectoryRecursive startLoc = do case temp of Left e -> do isDir <- doesDirectoryExist f -- If f is not a directory, re-throw the error - unless isDir $ throw e + unless isDir $ throw (e :: SomeException) removeDirectoryRecursive f Right _ -> return () @@ -405,10 +446,12 @@ The operand refers to an existing directory. -} removeFile :: FilePath -> IO () -removeFile path = do - modifyIOError (`ioeSetFileName` path) $ - withCString path $ \s -> - throwErrnoIfMinus1Retry_ "removeFile" (c_unlink s) +removeFile path = +#if mingw32_HOST_OS + System.Win32.deleteFile path +#else + System.Posix.removeLink path +#endif {- |@'renameDirectory' old new@ changes the name of an existing directory from /old/ to /new/. If the /new/ directory @@ -461,16 +504,19 @@ Either path refers to an existing non-directory object. renameDirectory :: FilePath -> FilePath -> IO () renameDirectory opath npath = + -- XXX this test isn't performed atomically with the following rename withFileStatus "renameDirectory" opath $ \st -> do is_dir <- isDirectory st if (not is_dir) - then ioException (IOError Nothing InappropriateType "renameDirectory" - ("not a directory") (Just opath)) + then ioException (ioeSetErrorString + (mkIOError InappropriateType "renameDirectory" Nothing (Just opath)) + "not a directory") else do - - withCString opath $ \s1 -> - withCString npath $ \s2 -> - throwErrnoIfMinus1Retry_ "renameDirectory" (c_rename s1 s2) +#ifdef mingw32_HOST_OS + System.Win32.moveFileEx opath npath System.Win32.mOVEFILE_REPLACE_EXISTING +#else + System.Posix.rename opath npath +#endif {- |@'renameFile' old new@ changes the name of an existing file system object from /old/ to /new/. If the /new/ object already @@ -518,16 +564,19 @@ Either path refers to an existing directory. renameFile :: FilePath -> FilePath -> IO () renameFile opath npath = + -- XXX this test isn't performed atomically with the following rename withFileOrSymlinkStatus "renameFile" opath $ \st -> do is_dir <- isDirectory st if is_dir - then ioException (IOError Nothing InappropriateType "renameFile" - "is a directory" (Just opath)) + then ioException (ioeSetErrorString + (mkIOError InappropriateType "renameFile" Nothing (Just opath)) + "is a directory") else do - - withCString opath $ \s1 -> - withCString npath $ \s2 -> - throwErrnoIfMinus1Retry_ "renameFile" (c_rename s1 s2) +#ifdef mingw32_HOST_OS + System.Win32.moveFileEx opath npath System.Win32.mOVEFILE_REPLACE_EXISTING +#else + System.Posix.rename opath npath +#endif #endif /* __GLASGOW_HASKELL__ */ @@ -541,23 +590,21 @@ copyFile :: FilePath -> FilePath -> IO () #ifdef __NHC__ copyFile fromFPath toFPath = do readFile fromFPath >>= writeFile toFPath - try (copyPermissions fromFPath toFPath) - return () + Prelude.catch (copyPermissions fromFPath toFPath) + (\_ -> return ()) #else copyFile fromFPath toFPath = - copy `catch` (\e -> case e of - IOException e -> - throw $ IOException $ ioeSetLocation e "copyFile" - _ -> throw e) + copy `Prelude.catch` (\exc -> throw $ ioeSetLocation exc "copyFile") where copy = bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom -> bracketOnError openTmp cleanTmp $ \(tmpFPath, hTmp) -> do allocaBytes bufferSize $ copyContents hFrom hTmp hClose hTmp - try (copyPermissions fromFPath toFPath) + ignoreIOExceptions $ copyPermissions fromFPath tmpFPath renameFile tmpFPath toFPath openTmp = openBinaryTempFile (takeDirectory toFPath) ".copyFile.tmp" - cleanTmp (tmpFPath, hTmp) = do try $ hClose hTmp - try $ removeFile tmpFPath + cleanTmp (tmpFPath, hTmp) + = do ignoreIOExceptions $ hClose hTmp + ignoreIOExceptions $ removeFile tmpFPath bufferSize = 1024 copyContents hFrom hTo buffer = do @@ -565,6 +612,10 @@ copyFile fromFPath toFPath = when (count > 0) $ do hPutBuf hTo buffer count copyContents hFrom hTo buffer + + ignoreIOExceptions io = io `catch` ioExceptionIgnorer + ioExceptionIgnorer :: IOException -> IO () + ioExceptionIgnorer _ = return () #endif -- | Given path referring to a file or directory, returns a @@ -584,7 +635,9 @@ canonicalizePath fpath = #else do c_realpath pInPath pOutPath #endif - peekCString pOutPath + path <- peekCString pOutPath + return (normalise path) + -- normalise does more stuff, like upper-casing the drive letter #if defined(mingw32_HOST_OS) foreign import stdcall unsafe "GetFullPathNameA" @@ -744,6 +797,8 @@ The operating system has no notion of current directory. getCurrentDirectory :: IO FilePath getCurrentDirectory = do +#ifdef mingw32_HOST_OS + -- XXX: should use something from Win32 p <- mallocBytes long_path_size go p long_path_size where go p bytes = do @@ -755,9 +810,17 @@ getCurrentDirectory = do else do errno <- getErrno if errno == eRANGE then do let bytes' = bytes * 2 - p' <- reallocBytes p bytes' - go p' bytes' + p'' <- reallocBytes p bytes' + go p'' bytes' else throwErrno "getCurrentDirectory" +#else + System.Posix.getWorkingDirectory +#endif + +#ifdef mingw32_HOST_OS +foreign import ccall unsafe "getcwd" + c_getcwd :: Ptr CChar -> CSize -> IO (Ptr CChar) +#endif {- |If the operating system has a notion of current directories, @'setCurrentDirectory' dir@ changes the current @@ -792,31 +855,30 @@ 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 +setCurrentDirectory path = +#ifdef mingw32_HOST_OS + System.Win32.setCurrentDirectory path +#else + System.Posix.changeWorkingDirectory path +#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 name = (withFileStatus "doesDirectoryExist" name $ \st -> isDirectory st) - (\ _ -> return False) + `catch` ((\ _ -> return False) :: IOException -> IO Bool) {- |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 name = (withFileStatus "doesFileExist" name $ \st -> do b <- isDirectory st; return (not b)) - (\ _ -> return False) + `catch` ((\ _ -> return False) :: IOException -> IO Bool) {- |The 'getModificationTime' operation returns the clock time at which the file or directory was last modified. @@ -873,7 +935,9 @@ 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 +#ifdef mingw32_HOST_OS foreign import ccall unsafe "__hscore_S_IFDIR" s_IFDIR :: CMode +#endif foreign import ccall unsafe "__hscore_long_path_size" long_path_size :: Int @@ -909,11 +973,11 @@ getHomeDirectory :: IO FilePath getHomeDirectory = #if defined(mingw32_HOST_OS) allocaBytes long_path_size $ \pPath -> do - r <- c_SHGetFolderPath nullPtr csidl_PROFILE nullPtr 0 pPath - if (r < 0) + r0 <- c_SHGetFolderPath nullPtr csidl_PROFILE nullPtr 0 pPath + if (r0 < 0) then do - r <- c_SHGetFolderPath nullPtr csidl_WINDOWS nullPtr 0 pPath - when (r < 0) (raiseUnsupported "System.Directory.getHomeDirectory") + r1 <- c_SHGetFolderPath nullPtr csidl_WINDOWS nullPtr 0 pPath + when (r1 < 0) (raiseUnsupported "System.Directory.getHomeDirectory") else return () peekCString pPath #else @@ -1022,10 +1086,16 @@ getTemporaryDirectory :: IO FilePath getTemporaryDirectory = do #if defined(mingw32_HOST_OS) allocaBytes long_path_size $ \pPath -> do - r <- c_GetTempPath (fromIntegral long_path_size) pPath + _r <- c_GetTempPath (fromIntegral long_path_size) pPath peekCString pPath #else - catch (getEnv "TMPDIR") (\ex -> return "/tmp") + getEnv "TMPDIR" +#if !__NHC__ + `Prelude.catch` \e -> if isDoesNotExistError e then return "/tmp" + else throw e +#else + `Prelude.catch` (\ex -> return "/tmp") +#endif #endif #if defined(mingw32_HOST_OS) @@ -1043,8 +1113,9 @@ foreign import ccall unsafe "__hscore_CSIDL_PERSONAL" csidl_PERSONAL :: CInt foreign import stdcall unsafe "GetTempPathA" c_GetTempPath :: CInt -> CString -> IO CInt +raiseUnsupported :: String -> IO () raiseUnsupported loc = - ioException (IOError Nothing UnsupportedOperation loc "unsupported operation" Nothing) + ioException (ioeSetErrorString (mkIOError UnsupportedOperation loc Nothing Nothing) "unsupported operation") #endif