+{-# OPTIONS_GHC -w #-}
+-- XXX We get some warnings on Windows
+
-----------------------------------------------------------------------------
-- |
-- Module : System.Directory
, getModificationTime -- :: FilePath -> IO ClockTime
) where
+import Prelude hiding ( catch )
+import qualified Prelude
+
import System.Environment ( getEnv )
import System.FilePath
-import System.IO.Error
+import System.IO
+import System.IO.Error hiding ( catch, try )
import Control.Monad ( when, unless )
+import Control.Exception.Base
#ifdef __NHC__
import Directory
+import System (system)
#endif /* __NHC__ */
#ifdef __HUGS__
{-# CFILES cbits/directory.c #-}
#ifdef __GLASGOW_HASKELL__
-import Prelude
-
-import Control.Exception ( bracket )
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
-<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.
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
+#ifdef mingw32_HOST_OS
+ -- stat() does a better job of guessing the permissions on Windows
+ -- than access() does. e.g. for execute permission, it looks at the
+ -- filename extension :-)
+ --
+ -- I tried for a while to do this properly, using the Windows security API,
+ -- and eventually gave up. getPermissions is a flawed API anyway. -- SimonM
+ allocaBytes sizeof_stat $ \ p_stat -> do
+ throwErrnoIfMinus1_ "getPermissions" $ c_stat s p_stat
+ mode <- st_mode p_stat
+ 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 = usr_read /= 0,
+ writable = usr_write /= 0,
+ executable = is_dir == 0 && usr_exec /= 0,
+ searchable = is_dir /= 0 && usr_exec /= 0
+ }
+ )
+#else
+ 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
{- |The 'setPermissions' operation sets the
permissions for the file or directory.
case temp of
Left e -> do isDir <- doesDirectoryExist f
-- If f is not a directory, re-throw the error
- unless isDir $ ioError e
+ unless isDir $ throw (e :: SomeException)
removeDirectoryRecursive f
Right _ -> return ()
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))
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 s1 s2
+#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))
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 s1 s2
+#endif
#endif /* __GLASGOW_HASKELL__ */
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 ()
+#ifdef __NHC__
copyFile fromFPath toFPath =
-#if (!(defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 600))
- do readFile fromFPath >>= writeFile toFPath
- try (copyPermissions fromFPath toFPath)
- return ()
+ do readFile fromFPath >>= writeFile toFPath
+ Prelude.catch (copyPermissions fromFPath toFPath)
+ (\_ -> return ())
#else
- (bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom ->
- bracket (openBinaryFile toFPath WriteMode) hClose $ \hTo ->
- allocaBytes bufferSize $ \buffer -> do
- copyContents hFrom hTo buffer
- try (copyPermissions fromFPath toFPath)
- return ()) `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
+copyFile fromFPath toFPath =
+ 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
+ ignoreIOExceptions $ copyPermissions fromFPath tmpFPath
+ renameFile tmpFPath toFPath
+ openTmp = openBinaryTempFile (takeDirectory toFPath) ".copyFile.tmp"
+ cleanTmp (tmpFPath, hTmp)
+ = do ignoreIOExceptions $ hClose hTmp
+ ignoreIOExceptions $ removeFile tmpFPath
+ bufferSize = 1024
+
+ copyContents hFrom hTo buffer = do
+ count <- hGetBuf hFrom buffer bufferSize
+ 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"
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"
{- |If the operating system has a notion of current directories,
-}
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.
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
+fileNameEndClean name = if isDrive name then addTrailingPathSeparator name
+ else dropTrailingPathSeparator name
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_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
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)
projects / haskell-directory.git / blobdiff