+{-# OPTIONS_GHC -w #-}
+-- XXX We get some warnings on Windows
+
-----------------------------------------------------------------------------
-- |
-- 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
+import Directory hiding ( getDirectoryContents
+ , doesDirectoryExist, doesFileExist
+ , getModificationTime )
import System (system)
#endif /* __NHC__ */
{-# CFILES cbits/directory.c #-}
-#ifdef __GLASGOW_HASKELL__
import System.Posix.Types
import System.Posix.Internals
import System.Time ( ClockTime(..) )
-import System.IO
+#ifdef __GLASGOW_HASKELL__
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
-<http://www.opengroup.org/onlinepubs/007904975/toc.htm>), but in
+<http://www.opengroup.org/onlinepubs/009695399/>), 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.
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
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__ */
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
-}
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/
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 ()
-}
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
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
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__ */
#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
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
#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"
#endif
-#ifdef __GLASGOW_HASKELL__
+#ifndef __HUGS__
{- |@'getDirectoryContents' dir@ returns a list of /all/ entries
in /dir/.
return (entry:entries)
else do errno <- getErrno
if (errno == eINTR) then loop ptr_dEnt dir else do
- let (Errno eo) = errno
- if (eo == end_of_dir)
- then return []
- else throwErrno desc
-
+ let (Errno eo) = errno
+ if (eo == end_of_dir)
+ then return []
+ else throwErrno desc
+#endif /* !__HUGS__ */
{- |If the operating system has a notion of current directories,
The operating system has no notion of current directory.
-}
-
+#ifdef __GLASGOW_HASKELL__
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
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
-}
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
+
+#endif /* __GLASGOW_HASKELL__ */
+#ifndef __HUGS__
{- |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.
withFileStatus "getModificationTime" name $ \ st ->
modificationTime st
+#endif /* !__HUGS__ */
+
withFileStatus :: String -> FilePath -> (Ptr CStat -> IO a) -> IO a
withFileStatus loc name f = do
modifyIOError (`ioeSetFileName` name) $
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
+
+#ifdef __GLASGOW_HASKELL__
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.
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
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)
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
#else
exeExtension = ""
#endif
-
projects / haskell-directory.git / blobdiff