diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -24,6 +24,6 @@ [hl]: https://hackage.haskell.org/package/directory [bi]: https://travis-ci.org/haskell/directory.svg?branch=master [bl]: https://travis-ci.org/haskell/directory -[wi]: https://ci.appveyor.com/api/projects/status/github/haskell/directory?svg=true -[wl]: https://ci.appveyor.com/project/Rufflewind/directory +[wi]: https://ci.appveyor.com/api/projects/status/github/haskell/directory?branch=master&svg=true +[wl]: https://ci.appveyor.com/project/hvr/directory [ac]: https://gnu.org/software/autoconf diff --git a/System/Directory.hs b/System/Directory.hs --- a/System/Directory.hs +++ b/System/Directory.hs @@ -29,6 +29,7 @@ , createDirectoryIfMissing , removeDirectory , removeDirectoryRecursive + , removePathForcibly , renameDirectory , listDirectory , getDirectoryContents @@ -48,6 +49,7 @@ -- * Actions on files , removeFile , renameFile + , renamePath , copyFile , copyFileWithMetadata @@ -63,7 +65,10 @@ , findFilesWith , exeExtension + , getFileSize + -- * Existence tests + , doesPathExist , doesFileExist , doesDirectoryExist @@ -565,6 +570,33 @@ mapM_ removePathRecursive [path x | x <- cont] removeDirectory path +-- | @'removePathForcibly@ removes a file or directory at /path/ together with +-- its contents and subdirectories. Symbolic links are removed without +-- affecting their the targets. If the path does not exist, nothing happens. +-- +-- Unlike other removal functions, this function will also attempt to delete +-- files marked as read-only or otherwise made unremovable due to permissions. +-- As a result, if the removal is incomplete, the permissions or attributes on +-- the remaining files may be altered. +removePathForcibly :: FilePath -> IO () +removePathForcibly path = + (`ioeSetLocation` "removePathForcibly") `modifyIOError` do + makeRemovable path `catchIOError` \ _ -> return () + dirType <- tryIOErrorType isDoesNotExistError (getDirectoryType path) + case dirType of + Left _ -> return () + Right NotDirectory -> removeFile path + Right DirectoryLink -> removeDirectory path + Right Directory -> do + mapM_ (removePathForcibly . (path )) =<< listDirectory path + removeDirectory path + where + makeRemovable p = do + perms <- getPermissions p + setPermissions path perms{ readable = True + , searchable = True + , writable = True } + {- |'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 @@ -671,11 +703,7 @@ when (not is_dir) $ do ioError . (`ioeSetErrorString` "not a directory") $ (mkIOError InappropriateType "renameDirectory" Nothing (Just opath)) -#ifdef mingw32_HOST_OS - Win32.moveFileEx opath npath Win32.mOVEFILE_REPLACE_EXISTING -#else - Posix.rename opath npath -#endif + renamePath opath npath {- |@'renameFile' old new@ changes the name of an existing file system object from /old/ to /new/. If the /new/ object already @@ -725,11 +753,7 @@ renameFile opath npath = (`ioeSetLocation` "renameFile") `modifyIOError` do -- XXX the tests are not performed atomically with the rename checkNotDir opath -#ifdef mingw32_HOST_OS - Win32.moveFileEx opath npath Win32.mOVEFILE_REPLACE_EXISTING -#else - Posix.rename opath npath -#endif + renamePath opath npath -- The underlying rename implementation can throw odd exceptions when the -- destination is a directory. For example, Windows typically throws a -- permission error, while POSIX systems may throw a resource busy error @@ -749,6 +773,57 @@ errIsDir path = ioError . (`ioeSetErrorString` "is a directory") $ mkIOError InappropriateType "" Nothing (Just path) +-- | Rename a file or directory. If the destination path already exists, it +-- is replaced atomically. The destination path must not point to an existing +-- directory. A conformant implementation need not support renaming files in +-- all situations (e.g. renaming across different physical devices), but the +-- constraints must be documented. +-- +-- The operation may fail with: +-- +-- * 'HardwareFault' +-- A physical I\/O error has occurred. +-- @[EIO]@ +-- +-- * 'InvalidArgument' +-- Either operand is not a valid file name. +-- @[ENAMETOOLONG, ELOOP]@ +-- +-- * 'isDoesNotExistError' \/ 'NoSuchThing' +-- The original file does not exist, or there is no path to the target. +-- @[ENOENT, ENOTDIR]@ +-- +-- * 'isPermissionError' \/ 'PermissionDenied' +-- The process has insufficient privileges to perform the operation. +-- @[EROFS, EACCES, EPERM]@ +-- +-- * 'ResourceExhausted' +-- Insufficient resources are available to perform the operation. +-- @[EDQUOT, ENOSPC, ENOMEM, EMLINK]@ +-- +-- * 'UnsatisfiedConstraints' +-- Implementation-dependent constraints are not satisfied. +-- @[EBUSY]@ +-- +-- * 'UnsupportedOperation' +-- The implementation does not support renaming in this situation. +-- @[EXDEV]@ +-- +-- * 'InappropriateType' +-- Either the destination path refers to an existing directory, or one of the +-- parent segments in the destination path is not a directory. +-- @[ENOTDIR, EISDIR, EINVAL, EEXIST, ENOTEMPTY]@ +-- +renamePath :: FilePath -- ^ Old path + -> FilePath -- ^ New path + -> IO () +renamePath opath npath = (`ioeSetLocation` "renamePath") `modifyIOError` do +#ifdef mingw32_HOST_OS + Win32.moveFileEx opath npath Win32.mOVEFILE_REPLACE_EXISTING +#else + Posix.rename opath npath +#endif + -- | Copy a file with its permissions. If the destination file already exists, -- it is replaced atomically. Neither path may refer to an existing -- directory. No exceptions are thrown if the permissions could not be @@ -965,9 +1040,6 @@ realpath encoding path = GHC.withCString encoding path (`withRealpath` GHC.peekCString encoding) - - doesPathExist path = (Posix.getFileStatus path >> return True) - `catchIOError` \ _ -> return False #endif -- | Convert a path into an absolute path. If the given path is relative, the @@ -1321,6 +1393,28 @@ bracket getCurrentDirectory setCurrentDirectory $ \ _ -> do setCurrentDirectory dir action + +-- | Obtain the size of a file in bytes. +getFileSize :: FilePath -> IO Integer +getFileSize path = + (`ioeSetLocation` "getFileSize") `modifyIOError` do +#ifdef mingw32_HOST_OS + fromIntegral <$> withFileStatus "" path st_size +#else + fromIntegral . Posix.fileSize <$> Posix.getFileStatus path +#endif + +-- | Test whether the given path points to an existing filesystem object. If +-- the user lacks necessary permissions to search the parent directories, this +-- function may return false even if the file does actually exist. +doesPathExist :: FilePath -> IO Bool +doesPathExist path = +#ifdef mingw32_HOST_OS + (withFileStatus "" path $ \ _ -> return True) +#else + (Posix.getFileStatus path >> return True) +#endif + `catchIOError` \ _ -> return False {- |The operation 'doesDirectoryExist' returns 'True' if the argument file exists and is either a directory or a symbolic link to a directory, diff --git a/cbits/directory.c b/cbits/directory.c deleted file mode 100644 --- a/cbits/directory.c +++ /dev/null @@ -1,9 +0,0 @@ -/* - * (c) The University of Glasgow 2002 - * - */ - -/* [DEPRECATED] This file may be removed in future versions. */ - -#define INLINE -#include "HsDirectory.h" diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,24 +1,39 @@ Changelog for the [`directory`][1] package ========================================== -## 1.2.6.3 (May 2015) +## 1.2.7.0 (August 2016) + * Remove deprecated C bits. This means `HsDirectory.h` and its functions + are no longer available. + ([#50](https://github.com/haskell/directory/issues/50)) + + * Add `doesPathExist` and `getFileSize` + ([#57](https://github.com/haskell/directory/issues/57)) + + * Add `renamePath` + ([#58](https://github.com/haskell/directory/issues/58)) + + * Add `removePathForcibly` + ([#59](https://github.com/haskell/directory/issues/59)) + +## 1.2.6.3 (May 2016) + * Add missing import of `(<*>)` on Windows for `base` earlier than 4.8.0.0 ([#53](https://github.com/haskell/directory/issues/53)) -## 1.2.6.2 (April 2015) +## 1.2.6.2 (April 2016) + * Bundled with GHC 8.0.1 + * Fix typo in file time functions when `utimensat` is not available and version of `unix` package is lower than 2.7.0.0 -## 1.2.6.1 (April 2015) - - * Bundled with GHC 8.0.1 +## 1.2.6.1 (April 2016) * Fix mistake in file time functions when `utimensat` is not available ([#47](https://github.com/haskell/directory/pull/47)) -## 1.2.6.0 (April 2015) +## 1.2.6.0 (April 2016) * Make `findExecutable`, `findExecutables`, `findExecutablesInDirectories`, `findFile`, and `findFilesWith` lazier @@ -36,7 +51,7 @@ * Drop support for Hugs. -## 1.2.5.1 (February 2015) +## 1.2.5.1 (February 2016) * Improve error message of `getCurrentDirectory` when the current working directory no longer exists diff --git a/directory.cabal b/directory.cabal --- a/directory.cabal +++ b/directory.cabal @@ -1,5 +1,5 @@ name: directory -version: 1.2.6.3 +version: 1.2.7.0 -- NOTE: Don't forget to update ./changelog.md license: BSD3 license-file: LICENSE @@ -49,13 +49,7 @@ System.Directory.Internal.Posix System.Directory.Internal.Windows - c-sources: - cbits/directory.c - include-dirs: . include - includes: - HsDirectory.h - install-includes: - HsDirectory.h + include-dirs: . build-depends: base >= 4.5 && < 4.10, @@ -93,16 +87,20 @@ CurrentDirectory001 Directory001 DoesDirectoryExist001 + DoesPathExist FileTime FindFile001 GetDirContents001 GetDirContents002 + GetFileSize GetHomeDirectory001 GetPermissions001 IsSymbolicLink RemoveDirectoryRecursive001 + RemovePathForcibly RenameDirectory RenameFile001 + RenamePath Safe T8482 WithCurrentDirectory diff --git a/include/HsDirectory.h b/include/HsDirectory.h deleted file mode 100644 --- a/include/HsDirectory.h +++ /dev/null @@ -1,70 +0,0 @@ -/* ----------------------------------------------------------------------------- - * - * (c) The University of Glasgow 2001-2004 - * - * Definitions for package `directory' which are visible in Haskell land. - * - * ---------------------------------------------------------------------------*/ - -/* [DEPRECATED] Do not include this header nor HsDirectoryConfig.h. They are - for internal use only and may be removed in future versions. */ - -#ifndef __HSDIRECTORY_H__ -#define __HSDIRECTORY_H__ - -// On Solaris we have to make sure _FILE_OFFSET_BITS is defined -// before including below, because that header -// will try and define it if it isn't already. -#include "HsFFI.h" - -#include "HsDirectoryConfig.h" - -// Otherwise these clash with similar definitions from other packages: -#undef PACKAGE_BUGREPORT -#undef PACKAGE_NAME -#undef PACKAGE_STRING -#undef PACKAGE_TARNAME -#undef PACKAGE_VERSION - -#if HAVE_SYS_STAT_H -#include -#endif - -#if HAVE_SYS_TYPES_H -#include -#endif - -#include "HsFFI.h" - -/* ----------------------------------------------------------------------------- - INLINE functions. - - These functions are given as inlines here for when compiling via C, - but we also generate static versions into the cbits library for - when compiling to native code. - -------------------------------------------------------------------------- */ - -#ifndef INLINE -# if defined(_MSC_VER) -# define INLINE extern __inline -# else -# define INLINE static inline -# endif -#endif - -/* Do not use: it may give the wrong value on systems where PATH_MAX is not - defined (e.g. Hurd). Instead, use System.Directory.Internal.c_PATH_MAX. */ -INLINE HsInt __hscore_long_path_size(void) { -#ifdef PATH_MAX - return PATH_MAX; -#else - return 4096; -#endif -} - -INLINE mode_t __hscore_S_IRUSR(void) { return S_IRUSR; } -INLINE mode_t __hscore_S_IWUSR(void) { return S_IWUSR; } -INLINE mode_t __hscore_S_IXUSR(void) { return S_IXUSR; } -INLINE mode_t __hscore_S_IFDIR(void) { return S_IFDIR; } - -#endif /* __HSDIRECTORY_H__ */ diff --git a/tests/DoesDirectoryExist001.hs b/tests/DoesDirectoryExist001.hs --- a/tests/DoesDirectoryExist001.hs +++ b/tests/DoesDirectoryExist001.hs @@ -9,6 +9,14 @@ -- [regression test] "/" was not recognised as a directory prior to GHC 6.1 T(expect) () =<< doesDirectoryExist rootDir + createDirectory "somedir" + + T(expect) () . not =<< doesDirectoryExist "nonexistent" + T(expect) () =<< doesDirectoryExist "somedir" +#ifdef mingw32_HOST_OS + T(expect) () =<< doesDirectoryExist "SoMeDiR" +#endif + where #ifdef mingw32_HOST_OS rootDir = "C:\\" diff --git a/tests/DoesPathExist.hs b/tests/DoesPathExist.hs new file mode 100644 --- /dev/null +++ b/tests/DoesPathExist.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE CPP #-} +module DoesPathExist where +#include "util.inl" +import System.Directory + +main :: TestEnv -> IO () +main _t = do + + T(expect) () =<< doesPathExist rootDir + + createDirectory "somedir" + writeFile "somefile" "somedata" + writeFile "\x3c0\x42f\x97f3\xe6\x221e" "somedata" + + T(expect) () . not =<< doesPathExist "nonexistent" + T(expect) () =<< doesPathExist "somedir" + T(expect) () =<< doesPathExist "somefile" + T(expect) () =<< doesPathExist "./somefile" +#ifdef mingw32_HOST_OS + T(expect) () =<< doesPathExist "SoMeDiR" + T(expect) () =<< doesPathExist "sOmEfIlE" +#endif + T(expect) () =<< doesPathExist "\x3c0\x42f\x97f3\xe6\x221e" + + where +#ifdef mingw32_HOST_OS + rootDir = "C:\\" +#else + rootDir = "/" +#endif diff --git a/tests/GetFileSize.hs b/tests/GetFileSize.hs new file mode 100644 --- /dev/null +++ b/tests/GetFileSize.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE CPP #-} +module GetFileSize where +#include "util.inl" +import System.Directory +import qualified System.IO as IO + +main :: TestEnv -> IO () +main _t = do + + IO.withBinaryFile "emptyfile" IO.WriteMode $ \ _ -> do + return () + IO.withBinaryFile "testfile" IO.WriteMode $ \ h -> do + IO.hPutStr h string + + T(expectEq) () 0 =<< getFileSize "emptyfile" + T(expectEq) () (fromIntegral (length string)) =<< getFileSize "testfile" + + where + string = "The quick brown fox jumps over the lazy dog." diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -9,16 +9,20 @@ import qualified CurrentDirectory001 import qualified Directory001 import qualified DoesDirectoryExist001 +import qualified DoesPathExist import qualified FileTime import qualified FindFile001 import qualified GetDirContents001 import qualified GetDirContents002 +import qualified GetFileSize import qualified GetHomeDirectory001 import qualified GetPermissions001 import qualified IsSymbolicLink import qualified RemoveDirectoryRecursive001 +import qualified RemovePathForcibly import qualified RenameDirectory import qualified RenameFile001 +import qualified RenamePath import qualified Safe import qualified T8482 import qualified WithCurrentDirectory @@ -34,16 +38,20 @@ T.isolatedRun _t "CurrentDirectory001" CurrentDirectory001.main T.isolatedRun _t "Directory001" Directory001.main T.isolatedRun _t "DoesDirectoryExist001" DoesDirectoryExist001.main + T.isolatedRun _t "DoesPathExist" DoesPathExist.main T.isolatedRun _t "FileTime" FileTime.main T.isolatedRun _t "FindFile001" FindFile001.main T.isolatedRun _t "GetDirContents001" GetDirContents001.main T.isolatedRun _t "GetDirContents002" GetDirContents002.main + T.isolatedRun _t "GetFileSize" GetFileSize.main T.isolatedRun _t "GetHomeDirectory001" GetHomeDirectory001.main T.isolatedRun _t "GetPermissions001" GetPermissions001.main T.isolatedRun _t "IsSymbolicLink" IsSymbolicLink.main T.isolatedRun _t "RemoveDirectoryRecursive001" RemoveDirectoryRecursive001.main + T.isolatedRun _t "RemovePathForcibly" RemovePathForcibly.main T.isolatedRun _t "RenameDirectory" RenameDirectory.main T.isolatedRun _t "RenameFile001" RenameFile001.main + T.isolatedRun _t "RenamePath" RenamePath.main T.isolatedRun _t "Safe" Safe.main T.isolatedRun _t "T8482" T8482.main T.isolatedRun _t "WithCurrentDirectory" WithCurrentDirectory.main diff --git a/tests/RemovePathForcibly.hs b/tests/RemovePathForcibly.hs new file mode 100644 --- /dev/null +++ b/tests/RemovePathForcibly.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE CPP #-} +module RemovePathForcibly where +#include "util.inl" +import System.Directory +import Data.List (sort) +import System.FilePath ((), normalise) +import System.IO.Error (catchIOError) +import TestUtils + +main :: TestEnv -> IO () +main _t = do + + ------------------------------------------------------------ + -- clean up junk from previous invocations + + modifyPermissions (tmp "c") (\ p -> p { writable = True }) + `catchIOError` \ _ -> return () + removePathForcibly tmpD + `catchIOError` \ _ -> return () + + ------------------------------------------------------------ + -- set up + + createDirectoryIfMissing True (tmp "a/x/w") + createDirectoryIfMissing True (tmp "a/y") + createDirectoryIfMissing True (tmp "a/z") + createDirectoryIfMissing True (tmp "b") + createDirectoryIfMissing True (tmp "c") + createDirectoryIfMissing True (tmp "f") + writeFile (tmp "a/x/w/u") "foo" + writeFile (tmp "a/t") "bar" + writeFile (tmp "f/s") "qux" + tryCreateSymbolicLink (normalise "../a") (tmp "b/g") + tryCreateSymbolicLink (normalise "../b") (tmp "c/h") + tryCreateSymbolicLink (normalise "a") (tmp "d") + setPermissions (tmp "f/s") emptyPermissions + setPermissions (tmp "f") emptyPermissions + + ------------------------------------------------------------ + -- tests + + removePathForcibly (tmp "f") + removePathForcibly (tmp "e") -- intentionally non-existent + + T(expectEq) () [".", "..", "a", "b", "c", "d"] . sort =<< + getDirectoryContents tmpD + T(expectEq) () [".", "..", "t", "x", "y", "z"] . sort =<< + getDirectoryContents (tmp "a") + T(expectEq) () [".", "..", "g"] . sort =<< + getDirectoryContents (tmp "b") + T(expectEq) () [".", "..", "h"] . sort =<< + getDirectoryContents (tmp "c") + T(expectEq) () [".", "..", "t", "x", "y", "z"] . sort =<< + getDirectoryContents (tmp "d") + + removePathForcibly (tmp "d") + + T(expectEq) () [".", "..", "a", "b", "c"] . sort =<< + getDirectoryContents tmpD + T(expectEq) () [".", "..", "t", "x", "y", "z"] . sort =<< + getDirectoryContents (tmp "a") + T(expectEq) () [".", "..", "g"] . sort =<< + getDirectoryContents (tmp "b") + T(expectEq) () [".", "..", "h"] . sort =<< + getDirectoryContents (tmp "c") + + removePathForcibly (tmp "c") + + T(expectEq) () [".", "..", "a", "b"] . sort =<< + getDirectoryContents tmpD + T(expectEq) () [".", "..", "t", "x", "y", "z"] . sort =<< + getDirectoryContents (tmp "a") + T(expectEq) () [".", "..", "g"] . sort =<< + getDirectoryContents (tmp "b") + + removePathForcibly (tmp "b") + + T(expectEq) () [".", "..", "a"] . sort =<< + getDirectoryContents tmpD + T(expectEq) () [".", "..", "t", "x", "y", "z"] . sort =<< + getDirectoryContents (tmp "a") + + removePathForcibly (tmp "a") + + T(expectEq) () [".", ".."] . sort =<< + getDirectoryContents tmpD + + where testName = "removePathForcibly" + tmpD = testName ++ ".tmp" + tmp s = tmpD normalise s diff --git a/tests/RenamePath.hs b/tests/RenamePath.hs new file mode 100644 --- /dev/null +++ b/tests/RenamePath.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE CPP #-} +module RenamePath where +#include "util.inl" +import System.Directory + +main :: TestEnv -> IO () +main _t = do + + createDirectory "a" + T(expectEq) () ["a"] =<< listDirectory "." + renamePath "a" "b" + T(expectEq) () ["b"] =<< listDirectory "." + + writeFile tmp1 contents1 + renamePath tmp1 tmp2 + T(expectEq) () contents1 =<< readFile tmp2 + writeFile tmp1 contents2 + renamePath tmp2 tmp1 + T(expectEq) () contents1 =<< readFile tmp1 + + where + tmp1 = "tmp1" + tmp2 = "tmp2" + contents1 = "test" + contents2 = "test2" diff --git a/tests/Util.hs b/tests/Util.hs --- a/tests/Util.hs +++ b/tests/Util.hs @@ -14,20 +14,16 @@ import Control.Arrow (second) import Control.Concurrent (forkIO, killThread) import Control.Concurrent.MVar (newEmptyMVar, putMVar, readMVar) -import Control.Exception (SomeException, bracket_, catch, - mask, onException, try) +import Control.Exception (SomeException, bracket_, mask, onException, try) import Control.Monad (Monad(..), unless, when) -import System.Directory (createDirectoryIfMissing, emptyPermissions, - doesDirectoryExist, isSymbolicLink, listDirectory, - makeAbsolute, removeDirectoryRecursive, readable, - searchable, setPermissions, withCurrentDirectory, - writable) +import System.Directory (createDirectoryIfMissing, doesDirectoryExist, + isSymbolicLink, listDirectory, makeAbsolute, + removePathForcibly, withCurrentDirectory) import System.Environment (getArgs) import System.Exit (exitFailure) import System.FilePath (FilePath, (), normalise) import System.IO (IO, hFlush, hPutStrLn, putStrLn, stderr, stdout) -import System.IO.Error (IOError, isDoesNotExistError, - ioError, tryIOError, userError) +import System.IO.Error (IOError, ioError, tryIOError, userError) import System.Timeout (timeout) import Text.Read (Read, reads) @@ -154,7 +150,7 @@ dir' <- makeAbsolute dir bracket_ (createDirectoryIfMissing True dir') (cleanup dir') action where cleanup dir' | keep = return () - | otherwise = removeDirectoryRecursive dir' + | otherwise = removePathForcibly dir' isolateWorkingDirectory :: Bool -> FilePath -> IO a -> IO a isolateWorkingDirectory keep dir action = do @@ -162,16 +158,7 @@ ioError (userError ("isolateWorkingDirectory cannot be used " <> "with current directory")) dir' <- makeAbsolute dir - (`preprocessPathRecursive` dir') $ \ f -> do - setPermissions f emptyPermissions{ readable = True - , searchable = True - , writable = True } - `catch` \ e -> - unless (isDoesNotExistError e) $ - ioError e - removeDirectoryRecursive dir' `catch` \ e -> - unless (isDoesNotExistError e) $ - ioError e + removePathForcibly dir' withNewDirectory keep dir' $ withCurrentDirectory dir' $ action