diff --git a/HsDirectoryConfig.h.in b/HsDirectoryConfig.h.in --- a/HsDirectoryConfig.h.in +++ b/HsDirectoryConfig.h.in @@ -6,6 +6,9 @@ /* Define to 1 if you have the header file. */ #undef HAVE_FCNTL_H +/* Define to 1 if you have the `GetFinalPathNameByHandleW' function. */ +#undef HAVE_GETFINALPATHNAMEBYHANDLEW + /* Define to 1 if you have the header file. */ #undef HAVE_INTTYPES_H diff --git a/System/Directory.hs b/System/Directory.hs --- a/System/Directory.hs +++ b/System/Directory.hs @@ -73,7 +73,7 @@ , doesDirectoryExist -- * Symbolic links - , isSymbolicLink + , pathIsSymbolicLink -- * Permissions @@ -101,74 +101,27 @@ , setAccessTime , setModificationTime - ) where -import Control.Exception (bracket, mask, onException) -import Control.Monad ( when, unless ) -#ifdef mingw32_HOST_OS -#if !MIN_VERSION_base(4, 8, 0) -import Control.Applicative ((<*>)) -#endif -import Data.Function (on) -#endif -#if !MIN_VERSION_base(4, 8, 0) -import Data.Functor ((<$>)) -#endif -import Data.Maybe - ( catMaybes -#ifdef mingw32_HOST_OS - , maybeToList -#endif -#if !defined(mingw32_HOST_OS) && ! defined(HAVE_UTIMENSAT) - , fromMaybe -#endif - ) + -- * Deprecated + , isSymbolicLink + ) where +import Prelude () +import System.Directory.Internal +import System.Directory.Internal.Prelude import System.FilePath -import System.IO -import System.IO.Error - ( catchIOError - , ioeSetErrorString - , ioeSetFileName - , ioeSetLocation - , isAlreadyExistsError - , isDoesNotExistError - , isPermissionError - , mkIOError - , modifyIOError - , tryIOError ) - -import Foreign - -{-# CFILES cbits/directory.c #-} - -import Data.Time ( UTCTime ) +import Data.Time (UTCTime) import Data.Time.Clock.POSIX ( posixSecondsToUTCTime , utcTimeToPOSIXSeconds , POSIXTime ) - -import GHC.IO.Exception ( IOErrorType(InappropriateType) ) - #ifdef mingw32_HOST_OS -import Foreign.C -import System.Posix.Types -import System.Posix.Internals import qualified System.Win32 as Win32 #else -import GHC.IO.Encoding -import GHC.Foreign as GHC -import System.Environment ( getEnv ) +import qualified GHC.Foreign as GHC import qualified System.Posix as Posix #endif -#ifdef HAVE_UTIMENSAT -import Foreign.C (throwErrnoPathIfMinus1_) -import System.Posix.Internals ( withFilePath ) -#endif - -import System.Directory.Internal - {- $intro A directory contains a series of entries, each of which is a named reference to a file system object (file, directory etc.). Some @@ -327,7 +280,7 @@ let mode3 = modifyBit (e || s) mode2 Posix.ownerExecuteMode Posix.setFileMode name mode3 where - modifyBit :: Bool -> Posix.FileMode -> Posix.FileMode -> Posix.FileMode + modifyBit :: Bool -> FileMode -> FileMode -> FileMode modifyBit False m b = m .&. (complement b) modifyBit True m b = m .|. b #endif @@ -463,12 +416,12 @@ -- | Obtain the type of a directory. getDirectoryType :: FilePath -> IO DirectoryType getDirectoryType path = - (`ioeSetLocation` "getDirectoryType") `modifyIOError` do + (`ioeAddLocation` "getDirectoryType") `modifyIOError` do #ifdef mingw32_HOST_OS isDir <- withFileStatus "getDirectoryType" path isDirectory if isDir then do - isLink <- isSymbolicLink path + isLink <- pathIsSymbolicLink path if isLink then return DirectoryLink else return Directory @@ -537,7 +490,7 @@ -- On Windows, the operation fails if /dir/ is a directory symbolic link. removeDirectoryRecursive :: FilePath -> IO () removeDirectoryRecursive path = - (`ioeSetLocation` "removeDirectoryRecursive") `modifyIOError` do + (`ioeAddLocation` "removeDirectoryRecursive") `modifyIOError` do dirType <- getDirectoryType path case dirType of Directory -> @@ -553,7 +506,7 @@ -- removed without affecting their the targets. removePathRecursive :: FilePath -> IO () removePathRecursive path = - (`ioeSetLocation` "removePathRecursive") `modifyIOError` do + (`ioeAddLocation` "removePathRecursive") `modifyIOError` do dirType <- getDirectoryType path case dirType of NotDirectory -> removeFile path @@ -565,7 +518,7 @@ -- targets. removeContentsRecursive :: FilePath -> IO () removeContentsRecursive path = - (`ioeSetLocation` "removeContentsRecursive") `modifyIOError` do + (`ioeAddLocation` "removeContentsRecursive") `modifyIOError` do cont <- listDirectory path mapM_ removePathRecursive [path x | x <- cont] removeDirectory path @@ -589,7 +542,7 @@ -- @since 1.2.7.0 removePathForcibly :: FilePath -> IO () removePathForcibly path = - (`ioeSetLocation` "removePathForcibly") `modifyIOError` do + (`ioeAddLocation` "removePathForcibly") `modifyIOError` do makeRemovable path `catchIOError` \ _ -> return () ignoreDoesNotExistError $ do dirType <- getDirectoryType path @@ -785,7 +738,7 @@ -} renameFile :: FilePath -> FilePath -> IO () -renameFile opath npath = (`ioeSetLocation` "renameFile") `modifyIOError` do +renameFile opath npath = (`ioeAddLocation` "renameFile") `modifyIOError` do -- XXX the tests are not performed atomically with the rename checkNotDir opath renamePath opath npath @@ -853,7 +806,7 @@ renamePath :: FilePath -- ^ Old path -> FilePath -- ^ New path -> IO () -renamePath opath npath = (`ioeSetLocation` "renamePath") `modifyIOError` do +renamePath opath npath = (`ioeAddLocation` "renamePath") `modifyIOError` do #ifdef mingw32_HOST_OS Win32.moveFileEx opath npath Win32.mOVEFILE_REPLACE_EXISTING #else @@ -868,7 +821,7 @@ -> FilePath -- ^ Destination filename -> IO () copyFile fromFPath toFPath = - (`ioeSetLocation` "copyFile") `modifyIOError` do + (`ioeAddLocation` "copyFile") `modifyIOError` do atomicCopyFileContents fromFPath toFPath (ignoreIOExceptions . copyPermissions fromFPath) @@ -881,7 +834,7 @@ -> FilePath -- ^ Destination filename -> IO () copyFileContents fromFPath toFPath = - (`ioeSetLocation` "copyFileContents") `modifyIOError` do + (`ioeAddLocation` "copyFileContents") `modifyIOError` do withBinaryFile toFPath WriteMode $ \ hTo -> copyFileToHandle fromFPath hTo #endif @@ -894,7 +847,7 @@ -> (FilePath -> IO ()) -- ^ Post-action -> IO () atomicCopyFileContents fromFPath toFPath postAction = - (`ioeSetLocation` "atomicCopyFileContents") `modifyIOError` do + (`ioeAddLocation` "atomicCopyFileContents") `modifyIOError` do withReplacementFile toFPath postAction $ \ hTo -> do copyFileToHandle fromFPath hTo @@ -909,7 +862,7 @@ -> (Handle -> IO a) -- ^ Main action -> IO a withReplacementFile path postAction action = - (`ioeSetLocation` "withReplacementFile") `modifyIOError` do + (`ioeAddLocation` "withReplacementFile") `modifyIOError` do mask $ \ restore -> do (tmpFPath, hTmp) <- openBinaryTempFile (takeDirectory path) ".copyFile.tmp" @@ -931,7 +884,7 @@ -> Handle -- ^ Destination handle -> IO () copyFileToHandle fromFPath hTo = - (`ioeSetLocation` "copyFileToHandle") `modifyIOError` do + (`ioeAddLocation` "copyFileToHandle") `modifyIOError` do withBinaryFile fromFPath ReadMode $ \ hFrom -> copyHandleData hFrom hTo @@ -940,7 +893,7 @@ -> Handle -- ^ Destination handle -> IO () copyHandleData hFrom hTo = - (`ioeSetLocation` "copyData") `modifyIOError` do + (`ioeAddLocation` "copyData") `modifyIOError` do allocaBytes bufferSize go where bufferSize = 1024 @@ -972,7 +925,7 @@ -> FilePath -- ^ Destination file -> IO () copyFileWithMetadata src dst = - (`ioeSetLocation` "copyFileWithMetadata") `modifyIOError` doCopy + (`ioeAddLocation` "copyFileWithMetadata") `modifyIOError` doCopy where #ifdef mingw32_HOST_OS doCopy = Win32.copyFile src dst False @@ -1017,67 +970,102 @@ setFileTimes dst (Just atime, Just mtime) #endif --- | Make a path absolute and remove as many indirections from it as possible. +-- | Make a path absolute, 'normalise' the path, and remove as many +-- indirections from it as possible. Any trailing path separators are +-- discarded via 'dropTrailingPathSeparator'. Additionally, on Windows the +-- letter case of the path is canonicalized. +-- +-- __Note__: This function is a very big hammer. If you only need an absolute +-- path, 'makeAbsolute' is sufficient for removing dependence on the current +-- working directory. +-- -- Indirections include the two special directories @.@ and @..@, as well as --- any Unix symbolic links. The input path does not have to point to an --- existing file or directory. +-- any symbolic links. The input path need not point to an existing file or +-- directory. Canonicalization is performed on the longest prefix of the path +-- that points to an existing file or directory. The remaining portion of the +-- path that does not point to an existing file or directory will still +-- undergo 'normalise', but case canonicalization and indirection removal are +-- skipped as they are impossible to do on a nonexistent path. -- --- __Note__: if you only need an absolute path, use 'makeAbsolute' instead. --- Most programs should not worry about whether a path contains symbolic links. +-- Most programs should not worry about the canonicity of a path. In +-- particular, despite the name, the function does not truly guarantee +-- canonicity of the returned path due to the presence of hard links, mount +-- points, etc. -- --- Since symbolic links and the special parent directory (@..@) are dependent --- on the state of the existing filesystem, the function can only make a --- conservative attempt by removing symbolic links and @..@ from the longest --- prefix of the path that still points to an existing file or directory. If --- the input path points to an existing file or directory, then the output --- path shall also point to the same file or directory, provided that the --- relevant parts of the filesystem have not changed in the meantime (the --- function is not atomic). +-- If the path points to an existing file or directory, then the output path +-- shall also point to the same file or directory, subject to the condition +-- that the relevant parts of the file system do not change while the function +-- is still running. In other words, the function is definitively not atomic. +-- The results can be utterly wrong if the portions of the path change while +-- this function is running. -- --- Despite the name, the function does not guarantee canonicity of the --- returned path due to the presence of hard links, mount points, etc. +-- Since symbolic links (and, on non-Windows systems, parent directories @..@) +-- are dependent on the state of the existing filesystem, the function can +-- only make a conservative attempt by removing such indirections from the +-- longest prefix of the path that still points to an existing file or +-- directory. -- +-- Note that on Windows parent directories @..@ are always fully expanded +-- before the symbolic links, as consistent with the rest of the Windows API +-- (such as @GetFullPathName@). In contrast, on POSIX systems parent +-- directories @..@ are expanded alongside symbolic links from left to right. +-- To put this more concretely: if @L@ is a symbolic link for @R/P@, then on +-- Windows @L\\..@ refers to @.@, whereas on other operating systems @L/..@ +-- refers to @R@. +-- -- Similar to 'normalise', passing an empty path is equivalent to passing the --- current directory. The function preserves the presence or absence of the --- trailing path separator unless the path refers to the root directory @/@. +-- current directory. -- --- /Known bug(s)/: on Windows, the function does not resolve symbolic links. +-- /Known bugs/: When the path contains an existing symbolic link, but the +-- target of the link does not exist, then the path is not dereferenced (bug +-- #64). Symbolic link expansion is not performed on Windows XP or earlier +-- due to the absence of @GetFinalPathNameByHandle@. -- -- /Changes since 1.2.3.0:/ The function has been altered to be more robust -- and has the same exception behavior as 'makeAbsolute'. -- +-- /Changes since 1.3.0.0:/ The function no longer preserves the trailing path +-- separator. File symbolic links that appear in the middle of a path are +-- properly dereferenced. Case canonicalization and symbolic link expansion +-- are now performed on Windows. +-- canonicalizePath :: FilePath -> IO FilePath canonicalizePath = \ path -> - modifyIOError ((`ioeSetLocation` "canonicalizePath") . + modifyIOError ((`ioeAddLocation` "canonicalizePath") . (`ioeSetFileName` path)) $ -- normalise does more stuff, like upper-casing the drive letter - normalise <$> (transform =<< prependCurrentDirectory path) + dropTrailingPathSeparator . normalise <$> + (transform =<< prependCurrentDirectory path) where + #if defined(mingw32_HOST_OS) - transform path = Win32.getFullPathName path - `catchIOError` \ _ -> return path + transform path = + attemptRealpath getFinalPathName =<< + (Win32.getFullPathName path `catchIOError` \ _ -> return path) #else - transform path = matchTrailingSeparator path <$> do + transform path = do encoding <- getFileSystemEncoding - realpathPrefix encoding (reverse (zip prefixes suffixes)) path - where segments = splitPath path + let realpath path' = + GHC.withCString encoding path' + (`withRealpath` GHC.peekCString encoding) + attemptRealpath realpath path +#endif + + attemptRealpath realpath path = + realpathPrefix realpath (reverse (zip prefixes suffixes)) path + where segments = splitDirectories path prefixes = scanl1 () segments suffixes = tail (scanr () "" segments) -- call realpath on the largest possible prefix - realpathPrefix encoding ((prefix, suffix) : rest) path = do + realpathPrefix realpath ((prefix, suffix) : rest) path = do exist <- doesPathExist prefix if exist -- never call realpath on an inaccessible path - then (( suffix) <$> realpath encoding prefix) - `catchIOError` \ _ -> realpathPrefix encoding rest path - else realpathPrefix encoding rest path + then (( suffix) <$> realpath prefix) + `catchIOError` \ _ -> realpathPrefix realpath rest path + else realpathPrefix realpath rest path realpathPrefix _ _ path = return path - realpath encoding path = - GHC.withCString encoding path - (`withRealpath` GHC.peekCString encoding) -#endif - -- | Convert a path into an absolute path. If the given path is relative, the -- current directory is prepended and then the combined result is -- 'normalise'd. If the path is already absolute, the path is simply @@ -1088,9 +1076,10 @@ -- operation may fail with the same exceptions as 'getCurrentDirectory'. -- -- @since 1.2.2.0 +-- makeAbsolute :: FilePath -> IO FilePath makeAbsolute path = - modifyIOError ((`ioeSetLocation` "makeAbsolute") . + modifyIOError ((`ioeAddLocation` "makeAbsolute") . (`ioeSetFileName` path)) $ matchTrailingSeparator path . normalise <$> prependCurrentDirectory path @@ -1105,16 +1094,11 @@ -- (internal API) prependCurrentDirectory :: FilePath -> IO FilePath prependCurrentDirectory path = - modifyIOError ((`ioeSetLocation` "prependCurrentDirectory") . + modifyIOError ((`ioeAddLocation` "prependCurrentDirectory") . (`ioeSetFileName` path)) $ - case path of - "" -> -- avoid trailing path separator - prependCurrentDirectory "." - _ -- avoid the call to `getCurrentDirectory` if we can - | isRelative path -> - ( path) . addTrailingPathSeparator <$> getCurrentDirectory - | otherwise -> - return path + if isRelative path -- avoid the call to `getCurrentDirectory` if we can + then ( path) <$> getCurrentDirectory + else return path -- | Add or remove the trailing path separator in the second path so as to -- match its presence in the first path. @@ -1262,7 +1246,7 @@ getDirectoryContents :: FilePath -> IO [FilePath] getDirectoryContents path = modifyIOError ((`ioeSetFileName` path) . - (`ioeSetLocation` "getDirectoryContents")) $ do + (`ioeAddLocation` "getDirectoryContents")) $ do #ifndef mingw32_HOST_OS bracket (Posix.openDirStream path) @@ -1360,7 +1344,7 @@ -- getCurrentDirectory :: IO FilePath getCurrentDirectory = - modifyIOError (`ioeSetLocation` "getCurrentDirectory") $ + modifyIOError (`ioeAddLocation` "getCurrentDirectory") $ specializeErrorString "Current working directory no longer exists" isDoesNotExistError @@ -1435,7 +1419,7 @@ -- @since 1.2.7.0 getFileSize :: FilePath -> IO Integer getFileSize path = - (`ioeSetLocation` "getFileSize") `modifyIOError` do + (`ioeAddLocation` "getFileSize") `modifyIOError` do #ifdef mingw32_HOST_OS fromIntegral <$> withFileStatus "" path st_size #else @@ -1488,10 +1472,10 @@ -- | Check whether the path refers to a symbolic link. On Windows, this tests -- for @FILE_ATTRIBUTE_REPARSE_POINT@. -- --- @since 1.2.6.0 -isSymbolicLink :: FilePath -> IO Bool -isSymbolicLink path = - (`ioeSetLocation` "getDirectoryType") `modifyIOError` do +-- @since 1.3.0.0 +pathIsSymbolicLink :: FilePath -> IO Bool +pathIsSymbolicLink path = + (`ioeAddLocation` "getDirectoryType") `modifyIOError` do #ifdef mingw32_HOST_OS isReparsePoint <$> Win32.getFileAttributes path where @@ -1500,6 +1484,10 @@ Posix.isSymbolicLink <$> Posix.getSymbolicLinkStatus path #endif +{-# DEPRECATED isSymbolicLink "Use 'pathIsSymbolicLink' instead" #-} +isSymbolicLink :: FilePath -> IO Bool +isSymbolicLink = pathIsSymbolicLink + #ifdef mingw32_HOST_OS -- | Open the handle of an existing file or directory. openFileHandle :: String -> Win32.AccessMode -> IO Win32.HANDLE @@ -1528,7 +1516,7 @@ -- @since 1.2.3.0 -- getAccessTime :: FilePath -> IO UTCTime -getAccessTime = modifyIOError (`ioeSetLocation` "getAccessTime") . +getAccessTime = modifyIOError (`ioeAddLocation` "getAccessTime") . (fst <$>) . getFileTimes -- | Obtain the time at which the file or directory was last modified. @@ -1545,12 +1533,12 @@ -- and the underlying filesystem supports them. -- getModificationTime :: FilePath -> IO UTCTime -getModificationTime = modifyIOError (`ioeSetLocation` "getModificationTime") . +getModificationTime = modifyIOError (`ioeAddLocation` "getModificationTime") . (snd <$>) . getFileTimes getFileTimes :: FilePath -> IO (UTCTime, UTCTime) getFileTimes path = - modifyIOError (`ioeSetLocation` "getFileTimes") . + modifyIOError (`ioeAddLocation` "getFileTimes") . modifyIOError (`ioeSetFileName` path) $ getTimes where @@ -1607,7 +1595,7 @@ -- setAccessTime :: FilePath -> UTCTime -> IO () setAccessTime path atime = - modifyIOError (`ioeSetLocation` "setAccessTime") $ + modifyIOError (`ioeAddLocation` "setAccessTime") $ setFileTimes path (Just atime, Nothing) -- | Change the time at which the file or directory was last modified. @@ -1635,13 +1623,13 @@ -- setModificationTime :: FilePath -> UTCTime -> IO () setModificationTime path mtime = - modifyIOError (`ioeSetLocation` "setModificationTime") $ + modifyIOError (`ioeAddLocation` "setModificationTime") $ setFileTimes path (Nothing, Just mtime) setFileTimes :: FilePath -> (Maybe UTCTime, Maybe UTCTime) -> IO () setFileTimes _ (Nothing, Nothing) = return () setFileTimes path (atime, mtime) = - modifyIOError (`ioeSetLocation` "setFileTimes") . + modifyIOError (`ioeAddLocation` "setFileTimes") . modifyIOError (`ioeSetFileName` path) $ setTimes (utcTimeToPOSIXSeconds <$> atime, utcTimeToPOSIXSeconds <$> mtime) where @@ -1739,7 +1727,7 @@ cannot be found. -} getHomeDirectory :: IO FilePath -getHomeDirectory = modifyIOError (`ioeSetLocation` "getHomeDirectory") get +getHomeDirectory = modifyIOError (`ioeAddLocation` "getHomeDirectory") get where #if defined(mingw32_HOST_OS) get = getFolderPath Win32.cSIDL_PROFILE `catchIOError` \ _ -> @@ -1803,7 +1791,7 @@ -- path is returned -> IO FilePath getXdgDirectory xdgDir suffix = - modifyIOError (`ioeSetLocation` "getXdgDirectory") $ + modifyIOError (`ioeAddLocation` "getXdgDirectory") $ normalise . ( suffix) <$> case xdgDir of XdgData -> get False "XDG_DATA_HOME" ".local/share" @@ -1879,7 +1867,7 @@ -- to the path -> IO FilePath getAppUserDataDirectory appName = do - modifyIOError (`ioeSetLocation` "getAppUserDataDirectory") $ do + modifyIOError (`ioeAddLocation` "getAppUserDataDirectory") $ do #if defined(mingw32_HOST_OS) s <- Win32.sHGetFolderPath nullPtr Win32.cSIDL_APPDATA nullPtr 0 return (s++'\\':appName) @@ -1910,7 +1898,7 @@ -} getUserDocumentsDirectory :: IO FilePath getUserDocumentsDirectory = do - modifyIOError (`ioeSetLocation` "getUserDocumentsDirectory") $ do + modifyIOError (`ioeAddLocation` "getUserDocumentsDirectory") $ do #if defined(mingw32_HOST_OS) Win32.sHGetFolderPath nullPtr Win32.cSIDL_PERSONAL nullPtr 0 #else @@ -1951,3 +1939,10 @@ getEnv "TMPDIR" `catchIOError` \ err -> if isDoesNotExistError err then return "/tmp" else ioError err #endif + +ioeAddLocation :: IOError -> String -> IOError +ioeAddLocation e loc = do + ioeSetLocation e newLoc + where + newLoc = loc <> if null oldLoc then "" else ":" <> oldLoc + oldLoc = ioeGetLocation e diff --git a/System/Directory/Internal.hs b/System/Directory/Internal.hs --- a/System/Directory/Internal.hs +++ b/System/Directory/Internal.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# OPTIONS_HADDOCK hide #-} #include module System.Directory.Internal diff --git a/System/Directory/Internal/C_utimensat.hsc b/System/Directory/Internal/C_utimensat.hsc --- a/System/Directory/Internal/C_utimensat.hsc +++ b/System/Directory/Internal/C_utimensat.hsc @@ -10,18 +10,19 @@ #ifdef HAVE_SYS_STAT_H # include #endif -import Foreign -import Foreign.C +#include +import Prelude () +import System.Directory.Internal.Prelude import Data.Time.Clock.POSIX (POSIXTime) -import System.Posix.Types data CTimeSpec = CTimeSpec EpochTime CLong instance Storable CTimeSpec where - sizeOf _ = #size struct timespec - alignment _ = alignment (undefined :: CInt) + sizeOf _ = #{size struct timespec} + -- workaround (hsc2hs for GHC < 8.0 doesn't support #{alignment ...}) + alignment _ = #{size char[alignof(struct timespec)] } poke p (CTimeSpec sec nsec) = do - (#poke struct timespec, tv_sec ) p sec + (#poke struct timespec, tv_sec) p sec (#poke struct timespec, tv_nsec) p nsec peek p = do sec <- #{peek struct timespec, tv_sec } p diff --git a/System/Directory/Internal/Posix.hsc b/System/Directory/Internal/Posix.hsc --- a/System/Directory/Internal/Posix.hsc +++ b/System/Directory/Internal/Posix.hsc @@ -4,10 +4,8 @@ #ifdef HAVE_LIMITS_H # include #endif -import Control.Monad ((>=>)) -import Control.Exception (bracket) -import Foreign -import Foreign.C +import Prelude () +import System.Directory.Internal.Prelude -- we use the 'free' from the standard library here since it's not entirely -- clear whether Haskell's 'free' corresponds to the same one diff --git a/System/Directory/Internal/Prelude.hs b/System/Directory/Internal/Prelude.hs new file mode 100644 --- /dev/null +++ b/System/Directory/Internal/Prelude.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_HADDOCK hide #-} +module System.Directory.Internal.Prelude + ( module Prelude +#if !MIN_VERSION_base(4, 8, 0) + , module Control.Applicative + , module Data.Functor +#endif + , module Control.Arrow + , module Control.Concurrent + , module Control.Exception + , module Control.Monad + , module Data.Bits + , module Data.Char + , module Data.Foldable + , module Data.Function + , module Data.Maybe + , module Data.Monoid + , module Data.IORef + , module Data.Traversable + , module Foreign + , module Foreign.C + , module GHC.IO.Encoding + , module GHC.IO.Exception + , module System.Environment + , module System.Exit + , module System.IO + , module System.IO.Error + , module System.Posix.Internals + , module System.Posix.Types + , module System.Timeout + , Void + ) where +#if !MIN_VERSION_base(4, 6, 0) +import Prelude hiding (catch) +#endif +#if MIN_VERSION_base(4, 8, 0) +import Data.Void (Void) +#else +import Control.Applicative ((<*>), pure) +import Data.Functor ((<$>), (<$)) +#endif +import Control.Arrow (second) +import Control.Concurrent + ( forkIO + , killThread + , newEmptyMVar + , putMVar + , readMVar + , takeMVar + ) +import Control.Exception + ( SomeException + , bracket + , bracket_ + , catch + , finally + , mask + , onException + , throwIO + , try + ) +import Control.Monad ((>=>), (<=<), unless, when, replicateM_) +import Data.Bits ((.&.), (.|.), complement) +import Data.Char (isAlpha, isAscii, toLower) +import Data.Foldable (for_, traverse_) +import Data.Function (on) +import Data.Maybe (catMaybes, fromMaybe, maybeToList) +import Data.Monoid ((<>), mconcat, mempty) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.Traversable (for) +import Foreign + ( Ptr + , Storable + ( alignment + , peek + , peekByteOff + , peekElemOff + , poke + , pokeByteOff + , pokeElemOff + , sizeOf + ) + , alloca + , allocaArray + , allocaBytes + , allocaBytesAligned + , maybeWith + , nullPtr + , plusPtr + , with + , withArray + ) +import Foreign.C + ( CInt(..) + , CLong(..) + , CString + , CTime(..) + , CUChar(..) + , CULong(..) + , CUShort(..) + , CWString + , CWchar(..) + , peekCString + , peekCWStringLen + , throwErrnoIfMinus1Retry_ + , throwErrnoIfMinus1_ + , throwErrnoIfNull + , throwErrnoPathIfMinus1_ + , withCString + , withCWString + ) +import GHC.IO.Exception + ( IOErrorType + ( InappropriateType + , OtherError + , UnsupportedOperation + ) + ) +import GHC.IO.Encoding (getFileSystemEncoding) +import System.Environment (getArgs, getEnv) +import System.Exit (exitFailure) +import System.IO + ( Handle + , IOMode(ReadMode, WriteMode) + , hClose + , hFlush + , hGetBuf + , hPutBuf + , hPutStr + , hPutStrLn + , openBinaryTempFile + , stderr + , stdout + , withBinaryFile + ) +import System.IO.Error + ( IOError + , catchIOError + , ioeGetErrorString + , ioeGetErrorType + , ioeGetLocation + , ioeSetErrorString + , ioeSetFileName + , ioeSetLocation + , isAlreadyExistsError + , isDoesNotExistError + , isPermissionError + , mkIOError + , modifyIOError + , permissionErrorType + , tryIOError + , userError + ) +import System.Posix.Internals + ( CStat + , c_stat + , withFilePath + , s_isdir + , sizeof_stat + , st_mode + , st_size + ) +import System.Posix.Types (CMode(..), EpochTime, FileMode) +import System.Timeout (timeout) + +#if !MIN_VERSION_base(4, 8, 0) +data Void = Void + +_unusedVoid :: Void +_unusedVoid = Void +#endif diff --git a/System/Directory/Internal/Windows.hsc b/System/Directory/Internal/Windows.hsc --- a/System/Directory/Internal/Windows.hsc +++ b/System/Directory/Internal/Windows.hsc @@ -1,13 +1,22 @@ +{-# LANGUAGE CPP #-} module System.Directory.Internal.Windows where #include #ifdef mingw32_HOST_OS +##if defined i386_HOST_ARCH +## define WINAPI stdcall +##elif defined x86_64_HOST_ARCH +## define WINAPI ccall +##else +## error unknown architecture +##endif #include #include #ifdef HAVE_SYS_STAT_H # include #endif -import Foreign.C -import System.Posix.Types +import Prelude () +import System.Directory.Internal.Prelude +import System.FilePath (isRelative, normalise, splitDirectories) import qualified System.Win32 as Win32 win32_cSIDL_LOCAL_APPDATA :: Win32.CSIDL @@ -26,6 +35,131 @@ #else win32_fILE_SHARE_DELETE = (#const FILE_SHARE_DELETE) #endif + +win32_getLongPathName, win32_getShortPathName :: FilePath -> IO FilePath +#if MIN_VERSION_Win32(2, 4, 0) +win32_getLongPathName = Win32.getLongPathName +win32_getShortPathName = Win32.getShortPathName +#else +win32_getLongPathName path = + modifyIOError ((`ioeSetLocation` "GetLongPathName") . + (`ioeSetFileName` path)) $ do + withCWString path $ \ ptrPath -> do + getPathNameWith (c_GetLongPathName ptrPath) + +win32_getShortPathName path = + modifyIOError ((`ioeSetLocation` "GetShortPathName") . + (`ioeSetFileName` path)) $ do + withCWString path $ \ ptrPath -> do + getPathNameWith (c_GetShortPathName ptrPath) + +foreign import WINAPI unsafe "windows.h GetLongPathNameW" + c_GetLongPathName + :: Ptr CWchar + -> Ptr CWchar + -> Win32.DWORD + -> IO Win32.DWORD + +foreign import WINAPI unsafe "windows.h GetShortPathNameW" + c_GetShortPathName + :: Ptr CWchar + -> Ptr CWchar + -> Win32.DWORD + -> IO Win32.DWORD +#endif + +win32_getFinalPathNameByHandle :: Win32.HANDLE -> Win32.DWORD -> IO FilePath +win32_getFinalPathNameByHandle _h _flags = + modifyIOError (`ioeSetLocation` "GetFinalPathNameByHandle") $ do +#ifdef HAVE_GETFINALPATHNAMEBYHANDLEW + getPathNameWith $ \ ptr len -> do + c_GetFinalPathNameByHandle _h ptr len _flags + +foreign import WINAPI unsafe "windows.h GetFinalPathNameByHandleW" + c_GetFinalPathNameByHandle + :: Win32.HANDLE + -> Ptr CWchar + -> Win32.DWORD + -> Win32.DWORD + -> IO Win32.DWORD + +#else + throwIO (mkIOError UnsupportedOperation + "platform does not support GetFinalPathNameByHandle" + Nothing Nothing) +#endif + +getFinalPathName :: FilePath -> IO FilePath +getFinalPathName = + (fromExtendedLengthPath <$>) . rawGetFinalPathName . toExtendedLengthPath + where +#ifdef HAVE_GETFINALPATHNAMEBYHANDLEW + rawGetFinalPathName path = do + let open = Win32.createFile path 0 shareMode Nothing + Win32.oPEN_EXISTING Win32.fILE_FLAG_BACKUP_SEMANTICS Nothing + bracket open Win32.closeHandle $ \ h -> do + win32_getFinalPathNameByHandle h 0 + shareMode = + win32_fILE_SHARE_DELETE .|. + Win32.fILE_SHARE_READ .|. + Win32.fILE_SHARE_WRITE +#else + rawGetFinalPathName = win32_getLongPathName <=< win32_getShortPathName +#endif + +-- | Add the @"\\\\?\\"@ prefix if necessary or possible. +-- The path remains unchanged if the prefix is not added. +toExtendedLengthPath :: FilePath -> FilePath +toExtendedLengthPath path + | isRelative path = path + | otherwise = + case normalise path of + -- note: as of filepath-1.4.1.0 normalise doesn't honor \\?\ + -- https://github.com/haskell/filepath/issues/56 + -- this means we cannot trust the result of normalise on + -- paths that start with \\?\ + '\\' : '\\' : '?' : '\\' : _ -> path + '\\' : '\\' : '.' : '\\' : _ -> path + '\\' : subpath@('\\' : _) -> "\\\\?\\UNC" <> subpath + normalisedPath -> "\\\\?\\" <> normalisedPath + +-- | Strip the @"\\\\?\\"@ prefix if possible. +-- The prefix is kept if the meaning of the path would otherwise change. +fromExtendedLengthPath :: FilePath -> FilePath +fromExtendedLengthPath ePath = + case ePath of + '\\' : '\\' : '?' : '\\' : path -> + case path of + 'U' : 'N' : 'C' : subpath@('\\' : _) -> "\\" <> subpath + drive : ':' : subpath + -- if the path is not "regular", then the prefix is necessary + -- to ensure the path is interpreted literally + | isAlpha drive && isAscii drive && isPathRegular subpath -> path + _ -> ePath + _ -> ePath + where + isPathRegular path = + not ('/' `elem` path || + "." `elem` splitDirectories path || + ".." `elem` splitDirectories path) + +getPathNameWith :: (Ptr CWchar -> Win32.DWORD -> IO Win32.DWORD) -> IO FilePath +getPathNameWith cFunc = do + let getPathNameWithLen len = do + allocaArray (fromIntegral len) $ \ ptrPathOut -> do + len' <- Win32.failIfZero "" (cFunc ptrPathOut len) + if len' <= len + then Right <$> peekCWStringLen (ptrPathOut, fromIntegral len') + else pure (Left len') + r <- getPathNameWithLen ((#const MAX_PATH) * (#size wchar_t)) + case r of + Right s -> pure s + Left len -> do + r' <- getPathNameWithLen len + case r' of + Right s -> pure s + Left _ -> ioError (mkIOError OtherError "" Nothing Nothing + `ioeSetErrorString` "path changed unexpectedly") foreign import ccall unsafe "_wchmod" c_wchmod :: CWString -> CMode -> IO CInt diff --git a/System/Directory/Internal/utility.h b/System/Directory/Internal/utility.h new file mode 100644 --- /dev/null +++ b/System/Directory/Internal/utility.h @@ -0,0 +1,6 @@ +#if !defined alignof && __cplusplus < 201103L +# ifdef STDC_HEADERS +# include +# endif +# define alignof(x) offsetof(struct { char c; x m; }, m) +#endif diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,6 +1,25 @@ Changelog for the [`directory`][1] package ========================================== +## 1.3.0.0 (December 2016) + + * Drop trailing slashes in `canonicalizePath` + ([#63](https://github.com/haskell/directory/issues/63)) + + * Rename `isSymbolicLink` to `pathIsSymbolicLink`. The old name will remain + available but may be removed in the next major release. + ([#52](https://github.com/haskell/directory/issues/52)) + + * Changed `canonicalizePath` to dereference symbolic links even if it points + to a file and is not the last path segment + + * On Windows, `canonicalizePath` now canonicalizes the letter case too + + * On Windows, `canonicalizePath` now also dereferences symbolic links + + * When exceptions are thrown, the error location will now contain additional + information about the internal function(s) used. + ## 1.2.7.1 (November 2016) * Don't abort `removePathForcibly` if files or directories go missing. diff --git a/configure b/configure --- a/configure +++ b/configure @@ -3339,6 +3339,17 @@ fi done +for ac_func in GetFinalPathNameByHandleW +do : + ac_fn_c_check_func "$LINENO" "GetFinalPathNameByHandleW" "ac_cv_func_GetFinalPathNameByHandleW" +if test "x$ac_cv_func_GetFinalPathNameByHandleW" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE_GETFINALPATHNAMEBYHANDLEW 1 +_ACEOF + +fi +done + # EXTEXT is defined automatically by AC_PROG_CC; # we just need to capture it in the header file diff --git a/configure.ac b/configure.ac --- a/configure.ac +++ b/configure.ac @@ -31,6 +31,7 @@ AC_CHECK_HEADERS([fcntl.h limits.h sys/types.h sys/stat.h time.h]) AC_CHECK_FUNCS([utimensat]) +AC_CHECK_FUNCS([GetFinalPathNameByHandleW]) # EXTEXT is defined automatically by AC_PROG_CC; # we just need to capture it in the header file diff --git a/directory.cabal b/directory.cabal --- a/directory.cabal +++ b/directory.cabal @@ -1,5 +1,5 @@ name: directory -version: 1.2.7.1 +version: 1.3.0.0 -- NOTE: Don't forget to update ./changelog.md license: BSD3 license-file: LICENSE @@ -21,12 +21,13 @@ HsDirectoryConfig.h extra-source-files: - changelog.md + HsDirectoryConfig.h.in README.md + System/Directory/Internal/*.h + changelog.md configure configure.ac directory.buildinfo - HsDirectoryConfig.h.in tests/*.hs tests/util.inl @@ -42,8 +43,9 @@ exposed-modules: System.Directory - other-modules: System.Directory.Internal + System.Directory.Internal.Prelude + other-modules: System.Directory.Internal.Config System.Directory.Internal.C_utimensat System.Directory.Internal.Posix @@ -95,7 +97,8 @@ GetFileSize GetHomeDirectory001 GetPermissions001 - IsSymbolicLink + MakeAbsolute + PathIsSymbolicLink RemoveDirectoryRecursive001 RemovePathForcibly RenameDirectory diff --git a/tests/CanonicalizePath.hs b/tests/CanonicalizePath.hs --- a/tests/CanonicalizePath.hs +++ b/tests/CanonicalizePath.hs @@ -1,26 +1,159 @@ {-# LANGUAGE CPP #-} module CanonicalizePath where #include "util.inl" -import System.Directory -import System.FilePath ((), hasTrailingPathSeparator, normalise) +import System.FilePath ((), dropFileName, dropTrailingPathSeparator, + normalise, takeFileName) +import TestUtils +#ifdef mingw32_HOST_OS +import System.Directory.Internal (win32_getFinalPathNameByHandle) +import qualified System.Win32 as Win32 +#endif main :: TestEnv -> IO () main _t = do - dot' <- canonicalizePath "./" - dot <- canonicalizePath "." - nul <- canonicalizePath "" - T(expectEq) () dot nul - T(expect) dot (not (hasTrailingPathSeparator dot)) - T(expect) dot' (hasTrailingPathSeparator dot') + dot <- canonicalizePath "" + dot2 <- canonicalizePath "." + dot3 <- canonicalizePath "./" + dot4 <- canonicalizePath "./." + T(expectEq) () dot (dropTrailingPathSeparator dot) + T(expectEq) () dot dot2 + T(expectEq) () dot dot3 + T(expectEq) () dot dot4 writeFile "bar" "" bar <- canonicalizePath "bar" + bar2 <- canonicalizePath "bar/" + bar3 <- canonicalizePath "bar/." + bar4 <- canonicalizePath "bar/./" + bar5 <- canonicalizePath "./bar" + bar6 <- canonicalizePath "./bar/" + bar7 <- canonicalizePath "./bar/." T(expectEq) () bar (normalise (dot "bar")) + T(expectEq) () bar bar2 + T(expectEq) () bar bar3 + T(expectEq) () bar bar4 + T(expectEq) () bar bar5 + T(expectEq) () bar bar6 + T(expectEq) () bar bar7 createDirectory "foo" - foo <- canonicalizePath "foo/" - T(expectEq) () foo (normalise (dot "foo/")) + foo <- canonicalizePath "foo" + foo2 <- canonicalizePath "foo/" + foo3 <- canonicalizePath "foo/." + foo4 <- canonicalizePath "foo/./" + foo5 <- canonicalizePath "./foo" + foo6 <- canonicalizePath "./foo/" + T(expectEq) () foo (normalise (dot "foo")) + T(expectEq) () foo foo2 + T(expectEq) () foo foo3 + T(expectEq) () foo foo4 + T(expectEq) () foo foo5 + T(expectEq) () foo foo6 -- should not fail for non-existent paths fooNon <- canonicalizePath "foo/non-existent" + fooNon2 <- canonicalizePath "foo/non-existent/" + fooNon3 <- canonicalizePath "foo/non-existent/." + fooNon4 <- canonicalizePath "foo/non-existent/./" + fooNon5 <- canonicalizePath "./foo/non-existent" + fooNon6 <- canonicalizePath "./foo/non-existent/" + fooNon7 <- canonicalizePath "./foo/./non-existent" + fooNon8 <- canonicalizePath "./foo/./non-existent/" T(expectEq) () fooNon (normalise (foo "non-existent")) + T(expectEq) () fooNon fooNon2 + T(expectEq) () fooNon fooNon3 + T(expectEq) () fooNon fooNon4 + T(expectEq) () fooNon fooNon5 + T(expectEq) () fooNon fooNon6 + T(expectEq) () fooNon fooNon7 + T(expectEq) () fooNon fooNon8 + + supportsSymbolicLinks <- do +#ifdef mingw32_HOST_OS + hasSymbolicLinkPrivileges <- + (True <$ createSymbolicLink "_symlinktest_src" "_symlinktest_dst") + -- only test if symbolic links can be created + -- (usually disabled on Windows by group policy) + `catchIOError` \ e -> + if isPermissionError e + then pure False + else ioError e + + supportsGetFinalPathNameByHandle <- + (True <$ win32_getFinalPathNameByHandle Win32.nullHANDLE 0) + `catchIOError` \ e -> + case ioeGetErrorType e of + UnsupportedOperation -> pure False + _ -> pure True + + pure (hasSymbolicLinkPrivileges && supportsGetFinalPathNameByHandle) +#else + pure True +#endif + + when supportsSymbolicLinks $ do + + let barQux = dot "bar" "qux" + + createSymbolicLink "../bar" "foo/bar" + T(expectEq) () bar =<< canonicalizePath "foo/bar" + T(expectEq) () barQux =<< canonicalizePath "foo/bar/qux" + + createSymbolicLink "foo" "lfoo" + T(expectEq) () foo =<< canonicalizePath "lfoo" + T(expectEq) () foo =<< canonicalizePath "lfoo/" + T(expectEq) () bar =<< canonicalizePath "lfoo/bar" + T(expectEq) () barQux =<< canonicalizePath "lfoo/bar/qux" + + -- FIXME: uncomment this test once #64 is fixed + -- createSymbolicLink "../foo/non-existent" "foo/qux" + -- qux <- canonicalizePath "foo/qux" + -- T(expectEq) () qux (dot "../foo/non-existent") + + caseInsensitive <- + (False <$ createDirectory "FOO") + `catch` \ e -> + if isAlreadyExistsError e + then pure True + else throwIO e + + -- if platform is case-insensitive, we expect case to be canonicalized too + when caseInsensitive $ do + foo7 <- canonicalizePath "FOO" + foo8 <- canonicalizePath "FOO/" + T(expectEq) () foo foo7 + T(expectEq) () foo foo8 + + fooNon9 <- canonicalizePath "FOO/non-existent" + fooNon10 <- canonicalizePath "fOo/non-existent/" + fooNon11 <- canonicalizePath "foO/non-existent/." + fooNon12 <- canonicalizePath "FoO/non-existent/./" + fooNon13 <- canonicalizePath "./fOO/non-existent" + fooNon14 <- canonicalizePath "./FOo/non-existent/" + cfooNon15 <- canonicalizePath "./FOO/./NON-EXISTENT" + cfooNon16 <- canonicalizePath "./FOO/./NON-EXISTENT/" + T(expectEq) () fooNon fooNon9 + T(expectEq) () fooNon fooNon10 + T(expectEq) () fooNon fooNon11 + T(expectEq) () fooNon fooNon12 + T(expectEq) () fooNon fooNon13 + T(expectEq) () fooNon fooNon14 + T(expectEq) () fooNon (dropFileName cfooNon15 <> + (toLower <$> takeFileName cfooNon15)) + T(expectEq) () fooNon (dropFileName cfooNon16 <> + (toLower <$> takeFileName cfooNon16)) + T(expectNe) () fooNon cfooNon15 + T(expectNe) () fooNon cfooNon16 + + setCurrentDirectory "foo" + foo9 <- canonicalizePath "../FOO" + foo10 <- canonicalizePath "../FOO/" + T(expectEq) () foo foo9 + T(expectEq) () foo foo10 + + -- Make sure long file names can be canonicalized too + -- (i.e. GetLongPathName by itself won't work) + createDirectory "verylongdirectoryname" + vldn <- canonicalizePath "verylongdirectoryname" + vldn2 <- canonicalizePath "VERYLONGDIRECTORYNAME" + T(expectEq) () vldn vldn2 diff --git a/tests/CopyFile001.hs b/tests/CopyFile001.hs --- a/tests/CopyFile001.hs +++ b/tests/CopyFile001.hs @@ -1,17 +1,16 @@ {-# LANGUAGE CPP #-} module CopyFile001 where #include "util.inl" -import System.Directory -import Data.List (sort) import System.FilePath (()) +import qualified Data.List as List main :: TestEnv -> IO () main _t = do createDirectory dir writeFile (dir from) contents - T(expectEq) () [from] . sort =<< listDirectory dir + T(expectEq) () [from] . List.sort =<< listDirectory dir copyFile (dir from) (dir to) - T(expectEq) () [from, to] . sort =<< listDirectory dir + T(expectEq) () [from, to] . List.sort =<< listDirectory dir T(expectEq) () contents =<< readFile (dir to) where contents = "This is the data\n" diff --git a/tests/CopyFile002.hs b/tests/CopyFile002.hs --- a/tests/CopyFile002.hs +++ b/tests/CopyFile002.hs @@ -1,17 +1,16 @@ {-# LANGUAGE CPP #-} module CopyFile002 where #include "util.inl" -import System.Directory -import Data.List (sort) +import qualified Data.List as List main :: TestEnv -> IO () main _t = do -- Similar to CopyFile001 but moves a file in the current directory -- (Bug #1652 on GHC Trac) writeFile from contents - T(expectEq) () [from] . sort =<< listDirectory "." + T(expectEq) () [from] . List.sort =<< listDirectory "." copyFile from to - T(expectEq) () [from, to] . sort =<< listDirectory "." + T(expectEq) () [from, to] . List.sort =<< listDirectory "." T(expectEq) () contents =<< readFile to where contents = "This is the data\n" diff --git a/tests/CopyFileWithMetadata.hs b/tests/CopyFileWithMetadata.hs --- a/tests/CopyFileWithMetadata.hs +++ b/tests/CopyFileWithMetadata.hs @@ -1,11 +1,7 @@ {-# LANGUAGE CPP #-} module CopyFileWithMetadata where #include "util.inl" -import System.Directory -import Control.Exception (finally) -import Data.Foldable (for_) -import Data.List (sort) -import System.IO.Error (catchIOError) +import qualified Data.List as List main :: TestEnv -> IO () main _t = (`finally` cleanup) $ do @@ -18,14 +14,14 @@ perm <- getPermissions "a" -- sanity check - T(expectEq) () ["a", "b"] . sort =<< listDirectory "." + T(expectEq) () ["a", "b"] . List.sort =<< listDirectory "." -- copy file copyFileWithMetadata "a" "b" copyFileWithMetadata "a" "c" -- make sure we got the right results - T(expectEq) () ["a", "b", "c"] . sort =<< listDirectory "." + T(expectEq) () ["a", "b", "c"] . List.sort =<< listDirectory "." for_ ["b", "c"] $ \ f -> do T(expectEq) f perm =<< getPermissions f T(expectEq) f mtime =<< getModificationTime f diff --git a/tests/CreateDirectory001.hs b/tests/CreateDirectory001.hs --- a/tests/CreateDirectory001.hs +++ b/tests/CreateDirectory001.hs @@ -1,8 +1,6 @@ {-# LANGUAGE CPP #-} module CreateDirectory001 where #include "util.inl" -import System.Directory -import System.IO.Error (isAlreadyExistsError) main :: TestEnv -> IO () main _t = do diff --git a/tests/CreateDirectoryIfMissing001.hs b/tests/CreateDirectoryIfMissing001.hs --- a/tests/CreateDirectoryIfMissing001.hs +++ b/tests/CreateDirectoryIfMissing001.hs @@ -1,15 +1,7 @@ {-# LANGUAGE CPP #-} module CreateDirectoryIfMissing001 where #include "util.inl" -import System.Directory -import Control.Concurrent (forkIO, newEmptyMVar, putMVar, takeMVar) -import qualified Control.Exception as E -import Control.Monad (replicateM_) -import Data.Monoid ((<>)) -import GHC.IO.Exception (IOErrorType(InappropriateType)) import System.FilePath ((), addTrailingPathSeparator) -import System.IO.Error (ioeGetErrorType, isAlreadyExistsError, - isDoesNotExistError, isPermissionError) main :: TestEnv -> IO () main _t = do @@ -86,15 +78,15 @@ -- It is also allowed to fail with permission errors -- (see bug #2924 on GHC Trac) create = - createDirectoryIfMissing True testdir_a `E.catch` \ e -> + createDirectoryIfMissing True testdir_a `catch` \ e -> if isDoesNotExistError e || isPermissionError e || isInappropriateTypeError e then return () else ioError e cleanup = removeDirectoryRecursive testdir `catchAny` \ _ -> return () - catchAny :: IO a -> (E.SomeException -> IO a) -> IO a - catchAny = E.catch + catchAny :: IO a -> (SomeException -> IO a) -> IO a + catchAny = catch #ifdef mingw32_HOST_OS isNotADirectoryError = isAlreadyExistsError diff --git a/tests/CurrentDirectory001.hs b/tests/CurrentDirectory001.hs --- a/tests/CurrentDirectory001.hs +++ b/tests/CurrentDirectory001.hs @@ -1,14 +1,13 @@ {-# LANGUAGE CPP #-} module CurrentDirectory001 where #include "util.inl" -import System.Directory -import Data.List (sort) +import qualified Data.List as List main :: TestEnv -> IO () main _t = do prevDir <- getCurrentDirectory createDirectory "dir" setCurrentDirectory "dir" - T(expectEq) () [".", ".."] . sort =<< getDirectoryContents "." + T(expectEq) () [".", ".."] . List.sort =<< getDirectoryContents "." setCurrentDirectory prevDir removeDirectory "dir" diff --git a/tests/Directory001.hs b/tests/Directory001.hs --- a/tests/Directory001.hs +++ b/tests/Directory001.hs @@ -1,7 +1,6 @@ {-# LANGUAGE CPP #-} module Directory001 where #include "util.inl" -import System.Directory main :: TestEnv -> IO () main _t = do diff --git a/tests/DoesDirectoryExist001.hs b/tests/DoesDirectoryExist001.hs --- a/tests/DoesDirectoryExist001.hs +++ b/tests/DoesDirectoryExist001.hs @@ -1,7 +1,6 @@ {-# LANGUAGE CPP #-} module DoesDirectoryExist001 where #include "util.inl" -import System.Directory main :: TestEnv -> IO () main _t = do diff --git a/tests/DoesPathExist.hs b/tests/DoesPathExist.hs --- a/tests/DoesPathExist.hs +++ b/tests/DoesPathExist.hs @@ -1,7 +1,6 @@ {-# LANGUAGE CPP #-} module DoesPathExist where #include "util.inl" -import System.Directory main :: TestEnv -> IO () main _t = do diff --git a/tests/FileTime.hs b/tests/FileTime.hs --- a/tests/FileTime.hs +++ b/tests/FileTime.hs @@ -1,16 +1,13 @@ {-# LANGUAGE CPP #-} module FileTime where #include "util.inl" -import System.Directory -import System.IO.Error (isDoesNotExistError) -import Data.Foldable (for_) -import qualified Data.Time.Clock as Time +import Data.Time.Clock (addUTCTime, getCurrentTime) main :: TestEnv -> IO () main _t = do - now <- Time.getCurrentTime - let someTimeAgo = Time.addUTCTime (-3600) now - someTimeAgo' = Time.addUTCTime (-7200) now + now <- getCurrentTime + let someTimeAgo = addUTCTime (-3600) now + someTimeAgo' = addUTCTime (-7200) now T(expectIOErrorType) () isDoesNotExistError $ getAccessTime "nonexistent-file" diff --git a/tests/FindFile001.hs b/tests/FindFile001.hs --- a/tests/FindFile001.hs +++ b/tests/FindFile001.hs @@ -1,8 +1,7 @@ {-# LANGUAGE CPP #-} module FindFile001 where #include "util.inl" -import System.Directory -import System.FilePath +import System.FilePath (()) main :: TestEnv -> IO () main _t = do diff --git a/tests/GetDirContents001.hs b/tests/GetDirContents001.hs --- a/tests/GetDirContents001.hs +++ b/tests/GetDirContents001.hs @@ -1,22 +1,23 @@ {-# LANGUAGE CPP #-} module GetDirContents001 where #include "util.inl" -import System.Directory -import Data.List (sort) -import Data.Monoid ((<>)) -import Data.Traversable (for) -import System.FilePath (()) +import System.FilePath (()) +import qualified Data.List as List main :: TestEnv -> IO () main _t = do createDirectory dir - T(expectEq) () specials . sort =<< getDirectoryContents dir - T(expectEq) () [] . sort =<< listDirectory dir + T(expectEq) () specials . List.sort =<< + getDirectoryContents dir + T(expectEq) () [] . List.sort =<< + listDirectory dir names <- for [1 .. 100 :: Int] $ \ i -> do let name = 'f' : show i writeFile (dir name) "" return name - T(expectEq) () (sort (specials <> names)) . sort =<< getDirectoryContents dir - T(expectEq) () (sort names) . sort =<< listDirectory dir + T(expectEq) () (List.sort (specials <> names)) . List.sort =<< + getDirectoryContents dir + T(expectEq) () (List.sort names) . List.sort =<< + listDirectory dir where dir = "dir" specials = [".", ".."] diff --git a/tests/GetDirContents002.hs b/tests/GetDirContents002.hs --- a/tests/GetDirContents002.hs +++ b/tests/GetDirContents002.hs @@ -1,8 +1,6 @@ {-# LANGUAGE CPP #-} module GetDirContents002 where #include "util.inl" -import System.Directory -import System.IO.Error (isDoesNotExistError) main :: TestEnv -> IO () main _t = do diff --git a/tests/GetFileSize.hs b/tests/GetFileSize.hs --- a/tests/GetFileSize.hs +++ b/tests/GetFileSize.hs @@ -1,16 +1,14 @@ {-# 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 + withBinaryFile "emptyfile" WriteMode $ \ _ -> do return () - IO.withBinaryFile "testfile" IO.WriteMode $ \ h -> do - IO.hPutStr h string + withBinaryFile "testfile" WriteMode $ \ h -> do + hPutStr h string T(expectEq) () 0 =<< getFileSize "emptyfile" T(expectEq) () (fromIntegral (length string)) =<< getFileSize "testfile" diff --git a/tests/GetHomeDirectory001.hs b/tests/GetHomeDirectory001.hs --- a/tests/GetHomeDirectory001.hs +++ b/tests/GetHomeDirectory001.hs @@ -1,7 +1,6 @@ {-# LANGUAGE CPP #-} module GetHomeDirectory001 where #include "util.inl" -import System.Directory main :: TestEnv -> IO () main _t = do diff --git a/tests/GetPermissions001.hs b/tests/GetPermissions001.hs --- a/tests/GetPermissions001.hs +++ b/tests/GetPermissions001.hs @@ -1,7 +1,6 @@ {-# LANGUAGE CPP #-} module GetPermissions001 where #include "util.inl" -import System.Directory main :: TestEnv -> IO () main _t = do diff --git a/tests/IsSymbolicLink.hs b/tests/IsSymbolicLink.hs deleted file mode 100644 --- a/tests/IsSymbolicLink.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE CPP #-} -module IsSymbolicLink where -#include "util.inl" -import System.Directory -import Control.Monad (when) -#ifdef mingw32_HOST_OS -import System.IO.Error (catchIOError, isPermissionError) -#endif -import TestUtils - -main :: TestEnv -> IO () -main _t = do - success <- (createSymbolicLink "x" "y" >> return True) -#ifdef mingw32_HOST_OS - -- only test if symbolic links can be created - -- (usually disabled on Windows by group policy) - `catchIOError` \ e -> - if isPermissionError e - then return False - else ioError e -#endif - when success $ - T(expect) () =<< isSymbolicLink "y" diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -17,7 +17,8 @@ import qualified GetFileSize import qualified GetHomeDirectory001 import qualified GetPermissions001 -import qualified IsSymbolicLink +import qualified MakeAbsolute +import qualified PathIsSymbolicLink import qualified RemoveDirectoryRecursive001 import qualified RemovePathForcibly import qualified RenameDirectory @@ -46,7 +47,8 @@ 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 "MakeAbsolute" MakeAbsolute.main + T.isolatedRun _t "PathIsSymbolicLink" PathIsSymbolicLink.main T.isolatedRun _t "RemoveDirectoryRecursive001" RemoveDirectoryRecursive001.main T.isolatedRun _t "RemovePathForcibly" RemovePathForcibly.main T.isolatedRun _t "RenameDirectory" RenameDirectory.main diff --git a/tests/MakeAbsolute.hs b/tests/MakeAbsolute.hs new file mode 100644 --- /dev/null +++ b/tests/MakeAbsolute.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE CPP #-} +module MakeAbsolute where +#include "util.inl" +import System.FilePath ((), addTrailingPathSeparator, + dropTrailingPathSeparator, normalise) + +main :: TestEnv -> IO () +main _t = do + dot <- makeAbsolute "" + dot2 <- makeAbsolute "." + dot3 <- makeAbsolute "./." + T(expectEq) () dot (dropTrailingPathSeparator dot) + T(expectEq) () dot dot2 + T(expectEq) () dot dot3 + + sdot <- makeAbsolute "./" + sdot2 <- makeAbsolute "././" + T(expectEq) () sdot (addTrailingPathSeparator sdot) + T(expectEq) () sdot sdot2 + + foo <- makeAbsolute "foo" + foo2 <- makeAbsolute "foo/." + foo3 <- makeAbsolute "./foo" + T(expectEq) () foo (normalise (dot "foo")) + T(expectEq) () foo foo2 + T(expectEq) () foo foo3 + + sfoo <- makeAbsolute "foo/" + sfoo2 <- makeAbsolute "foo/./" + sfoo3 <- makeAbsolute "./foo/" + T(expectEq) () sfoo (normalise (dot "foo/")) + T(expectEq) () sfoo sfoo2 + T(expectEq) () sfoo sfoo3 diff --git a/tests/PathIsSymbolicLink.hs b/tests/PathIsSymbolicLink.hs new file mode 100644 --- /dev/null +++ b/tests/PathIsSymbolicLink.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE CPP #-} +module PathIsSymbolicLink where +#include "util.inl" +import TestUtils + +main :: TestEnv -> IO () +main _t = do + success <- (createSymbolicLink "x" "y" >> return True) +#ifdef mingw32_HOST_OS + -- only test if symbolic links can be created + -- (usually disabled on Windows by group policy) + `catchIOError` \ e -> + if isPermissionError e + then return False + else ioError e +#endif + when success $ + T(expect) () =<< pathIsSymbolicLink "y" diff --git a/tests/RemoveDirectoryRecursive001.hs b/tests/RemoveDirectoryRecursive001.hs --- a/tests/RemoveDirectoryRecursive001.hs +++ b/tests/RemoveDirectoryRecursive001.hs @@ -1,10 +1,8 @@ {-# LANGUAGE CPP #-} module RemoveDirectoryRecursive001 where #include "util.inl" -import System.Directory -import Data.List (sort) import System.FilePath ((), normalise) -import System.IO.Error (catchIOError) +import qualified Data.List as List import TestUtils main :: TestEnv -> IO () @@ -36,15 +34,15 @@ ------------------------------------------------------------ -- tests - T(expectEq) () [".", "..", "a", "b", "c", "d"] . sort =<< + T(expectEq) () [".", "..", "a", "b", "c", "d"] . List.sort =<< getDirectoryContents tmpD - T(expectEq) () [".", "..", "t", "x", "y", "z"] . sort =<< + T(expectEq) () [".", "..", "t", "x", "y", "z"] . List.sort =<< getDirectoryContents (tmp "a") - T(expectEq) () [".", "..", "g"] . sort =<< + T(expectEq) () [".", "..", "g"] . List.sort =<< getDirectoryContents (tmp "b") - T(expectEq) () [".", "..", "h"] . sort =<< + T(expectEq) () [".", "..", "h"] . List.sort =<< getDirectoryContents (tmp "c") - T(expectEq) () [".", "..", "t", "x", "y", "z"] . sort =<< + T(expectEq) () [".", "..", "t", "x", "y", "z"] . List.sort =<< getDirectoryContents (tmp "d") removeDirectoryRecursive (tmp "d") @@ -53,13 +51,13 @@ `catchIOError` \ _ -> removeDirectory (tmp "d") #endif - T(expectEq) () [".", "..", "a", "b", "c"] . sort =<< + T(expectEq) () [".", "..", "a", "b", "c"] . List.sort =<< getDirectoryContents tmpD - T(expectEq) () [".", "..", "t", "x", "y", "z"] . sort =<< + T(expectEq) () [".", "..", "t", "x", "y", "z"] . List.sort =<< getDirectoryContents (tmp "a") - T(expectEq) () [".", "..", "g"] . sort =<< + T(expectEq) () [".", "..", "g"] . List.sort =<< getDirectoryContents (tmp "b") - T(expectEq) () [".", "..", "h"] . sort =<< + T(expectEq) () [".", "..", "h"] . List.sort =<< getDirectoryContents (tmp "c") removeDirectoryRecursive (tmp "c") @@ -67,23 +65,23 @@ modifyPermissions (tmp "c") (\ p -> p { writable = True }) removeDirectoryRecursive (tmp "c") - T(expectEq) () [".", "..", "a", "b"] . sort =<< + T(expectEq) () [".", "..", "a", "b"] . List.sort =<< getDirectoryContents tmpD - T(expectEq) () [".", "..", "t", "x", "y", "z"] . sort =<< + T(expectEq) () [".", "..", "t", "x", "y", "z"] . List.sort =<< getDirectoryContents (tmp "a") - T(expectEq) () [".", "..", "g"] . sort =<< + T(expectEq) () [".", "..", "g"] . List.sort =<< getDirectoryContents (tmp "b") removeDirectoryRecursive (tmp "b") - T(expectEq) () [".", "..", "a"] . sort =<< + T(expectEq) () [".", "..", "a"] . List.sort =<< getDirectoryContents tmpD - T(expectEq) () [".", "..", "t", "x", "y", "z"] . sort =<< + T(expectEq) () [".", "..", "t", "x", "y", "z"] . List.sort =<< getDirectoryContents (tmp "a") removeDirectoryRecursive (tmp "a") - T(expectEq) () [".", ".."] . sort =<< + T(expectEq) () [".", ".."] . List.sort =<< getDirectoryContents tmpD where testName = "removeDirectoryRecursive001" diff --git a/tests/RemovePathForcibly.hs b/tests/RemovePathForcibly.hs --- a/tests/RemovePathForcibly.hs +++ b/tests/RemovePathForcibly.hs @@ -1,10 +1,8 @@ {-# 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 qualified Data.List as List import TestUtils main :: TestEnv -> IO () @@ -42,47 +40,47 @@ removePathForcibly (tmp "f") removePathForcibly (tmp "e") -- intentionally non-existent - T(expectEq) () [".", "..", "a", "b", "c", "d"] . sort =<< + T(expectEq) () [".", "..", "a", "b", "c", "d"] . List.sort =<< getDirectoryContents tmpD - T(expectEq) () [".", "..", "t", "x", "y", "z"] . sort =<< + T(expectEq) () [".", "..", "t", "x", "y", "z"] . List.sort =<< getDirectoryContents (tmp "a") - T(expectEq) () [".", "..", "g"] . sort =<< + T(expectEq) () [".", "..", "g"] . List.sort =<< getDirectoryContents (tmp "b") - T(expectEq) () [".", "..", "h"] . sort =<< + T(expectEq) () [".", "..", "h"] . List.sort =<< getDirectoryContents (tmp "c") - T(expectEq) () [".", "..", "t", "x", "y", "z"] . sort =<< + T(expectEq) () [".", "..", "t", "x", "y", "z"] . List.sort =<< getDirectoryContents (tmp "d") removePathForcibly (tmp "d") - T(expectEq) () [".", "..", "a", "b", "c"] . sort =<< + T(expectEq) () [".", "..", "a", "b", "c"] . List.sort =<< getDirectoryContents tmpD - T(expectEq) () [".", "..", "t", "x", "y", "z"] . sort =<< + T(expectEq) () [".", "..", "t", "x", "y", "z"] . List.sort =<< getDirectoryContents (tmp "a") - T(expectEq) () [".", "..", "g"] . sort =<< + T(expectEq) () [".", "..", "g"] . List.sort =<< getDirectoryContents (tmp "b") - T(expectEq) () [".", "..", "h"] . sort =<< + T(expectEq) () [".", "..", "h"] . List.sort =<< getDirectoryContents (tmp "c") removePathForcibly (tmp "c") - T(expectEq) () [".", "..", "a", "b"] . sort =<< + T(expectEq) () [".", "..", "a", "b"] . List.sort =<< getDirectoryContents tmpD - T(expectEq) () [".", "..", "t", "x", "y", "z"] . sort =<< + T(expectEq) () [".", "..", "t", "x", "y", "z"] . List.sort =<< getDirectoryContents (tmp "a") - T(expectEq) () [".", "..", "g"] . sort =<< + T(expectEq) () [".", "..", "g"] . List.sort =<< getDirectoryContents (tmp "b") removePathForcibly (tmp "b") - T(expectEq) () [".", "..", "a"] . sort =<< + T(expectEq) () [".", "..", "a"] . List.sort =<< getDirectoryContents tmpD - T(expectEq) () [".", "..", "t", "x", "y", "z"] . sort =<< + T(expectEq) () [".", "..", "t", "x", "y", "z"] . List.sort =<< getDirectoryContents (tmp "a") removePathForcibly (tmp "a") - T(expectEq) () [".", ".."] . sort =<< + T(expectEq) () [".", ".."] . List.sort =<< getDirectoryContents tmpD where testName = "removePathForcibly" diff --git a/tests/RenameDirectory.hs b/tests/RenameDirectory.hs --- a/tests/RenameDirectory.hs +++ b/tests/RenameDirectory.hs @@ -1,7 +1,6 @@ {-# LANGUAGE CPP #-} module RenameDirectory where #include "util.inl" -import System.Directory main :: TestEnv -> IO () main _t = do diff --git a/tests/RenameFile001.hs b/tests/RenameFile001.hs --- a/tests/RenameFile001.hs +++ b/tests/RenameFile001.hs @@ -1,7 +1,6 @@ {-# LANGUAGE CPP #-} module RenameFile001 where #include "util.inl" -import System.Directory main :: TestEnv -> IO () main _t = do diff --git a/tests/RenamePath.hs b/tests/RenamePath.hs --- a/tests/RenamePath.hs +++ b/tests/RenamePath.hs @@ -1,7 +1,6 @@ {-# LANGUAGE CPP #-} module RenamePath where #include "util.inl" -import System.Directory main :: TestEnv -> IO () main _t = do diff --git a/tests/T8482.hs b/tests/T8482.hs --- a/tests/T8482.hs +++ b/tests/T8482.hs @@ -1,9 +1,6 @@ {-# LANGUAGE CPP #-} module T8482 where #include "util.inl" -import GHC.IO.Exception (IOErrorType(InappropriateType)) -import System.Directory -import System.IO.Error (ioeGetErrorType) tmp1 :: FilePath tmp1 = "T8482.tmp1" diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -5,18 +5,15 @@ , modifyPermissions , tryCreateSymbolicLink ) where +import Prelude () +import System.Directory.Internal.Prelude import System.Directory import System.FilePath (()) -import System.IO.Error (ioeSetLocation, modifyIOError) #ifdef mingw32_HOST_OS -import Foreign (Ptr) -import Foreign.C (CUChar(..), CULong(..), CWchar(..), withCWString) import System.FilePath (takeDirectory) -import System.IO.Error (catchIOError, ioeSetErrorString, isPermissionError, - mkIOError, permissionErrorType) -import System.Win32.Types (failWith, getLastError) +import qualified System.Win32 as Win32 #else -import System.Posix.Files (createSymbolicLink) +import System.Posix (createSymbolicLink) #endif #ifdef mingw32_HOST_OS @@ -58,19 +55,22 @@ (`ioeSetLocation` "createSymbolicLink") `modifyIOError` do isDir <- (fromIntegral . fromEnum) `fmap` doesDirectoryExist (takeDirectory link target) - withCWString target $ \ target' -> - withCWString link $ \ link' -> do - status <- c_CreateSymbolicLink link' target' isDir + let target' = fixSlash <$> target + withCWString target' $ \ pTarget -> + withCWString link $ \ pLink -> do + status <- c_CreateSymbolicLink pLink pTarget isDir if status == 0 then do - errCode <- getLastError + errCode <- Win32.getLastError if errCode == c_ERROR_PRIVILEGE_NOT_HELD then ioError . (`ioeSetErrorString` permissionErrorMsg) $ mkIOError permissionErrorType "" Nothing (Just link) - else failWith "createSymbolicLink" errCode + else Win32.failWith "createSymbolicLink" errCode else return () where c_ERROR_PRIVILEGE_NOT_HELD = 0x522 permissionErrorMsg = "no permission to create symbolic links" + fixSlash '/' = '\\' + fixSlash c = c #endif -- | Attempt to create a symbolic link. On Windows, this falls back to diff --git a/tests/Util.hs b/tests/Util.hs --- a/tests/Util.hs +++ b/tests/Util.hs @@ -1,31 +1,11 @@ -{-# LANGUAGE BangPatterns, CPP #-} +{-# LANGUAGE BangPatterns #-} module Util where -import Prelude (Eq(..), Num(..), Ord(..), RealFrac(..), Show(..), - Bool(..), Double, Either(..), Int, Integer, Maybe(..), String, - ($), (.), not, otherwise) -import Data.Char (toLower) -import Data.Foldable (traverse_) -import Data.Functor ((<$>)) -import Data.IORef (IORef, newIORef, readIORef, writeIORef) -import Data.List (drop, elem, intercalate, lookup, reverse, span) -import Data.Maybe (fromMaybe) -import Data.Monoid ((<>)) +import Prelude () +import System.Directory.Internal.Prelude +import System.Directory import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime) -import Control.Arrow (second) -import Control.Concurrent (forkIO, killThread) -import Control.Concurrent.MVar (newEmptyMVar, putMVar, readMVar) -import Control.Exception (SomeException, bracket_, mask, onException, try) -import Control.Monad (Monad(..), unless, when) -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, ioError, tryIOError, userError) -import System.Timeout (timeout) -import Text.Read (Read, reads) +import System.FilePath ((), normalise) +import qualified Data.List as List modifyIORef' :: IORef a -> (a -> a) -> IO () modifyIORef' r f = do @@ -43,7 +23,7 @@ timeLimit time action = do result <- timeout (round (1000000 * time)) action case result of - Nothing -> ioError (userError "timed out") + Nothing -> throwIO (userError "timed out") Just x -> return x data TestEnv = @@ -57,12 +37,12 @@ printInfo :: TestEnv -> [String] -> IO () printInfo TestEnv{testSilent = True} _ = return () printInfo TestEnv{testSilent = False} msg = do - putStrLn (intercalate ": " msg) + putStrLn (List.intercalate ": " msg) hFlush stdout printErr :: [String] -> IO () printErr msg = do - hPutStrLn stderr ("*** " <> intercalate ": " msg) + hPutStrLn stderr ("*** " <> List.intercalate ": " msg) hFlush stderr printFailure :: TestEnv -> [String] -> IO () @@ -104,6 +84,14 @@ [show x <> " equals " <> show y] [show x <> " is not equal to " <> show y] +expectNe :: (Eq a, Show a, Show b) => + TestEnv -> String -> Integer -> b -> a -> a -> IO () +expectNe t file line context x y = + check t (x /= y) + [showContext file line context] + [show x <> " is not equal to " <> show y] + [show x <> " equals " <> show y] + expectNear :: (Num a, Ord a, Show a, Show b) => TestEnv -> String -> Integer -> b -> a -> a -> a -> IO () expectNear t file line context x y diff = @@ -125,7 +113,7 @@ TestEnv -> String -> Integer -> a -> (IOError -> Bool) -> IO b -> IO () expectIOErrorType t file line context which action = do - result <- tryIOError action + result <- try action checkEither t [showContext file line context] $ case result of Left e | which e -> Right ["got expected exception (" <> show e <> ")"] | otherwise -> Left ["got wrong exception: ", show e] @@ -137,7 +125,7 @@ dirExists <- doesDirectoryExist path if dirExists then do - isLink <- isSymbolicLink path + isLink <- pathIsSymbolicLink path f path when (not isLink) $ do names <- listDirectory path @@ -154,8 +142,8 @@ isolateWorkingDirectory :: Bool -> FilePath -> IO a -> IO a isolateWorkingDirectory keep dir action = do - when (normalise dir `elem` [".", "./"]) $ - ioError (userError ("isolateWorkingDirectory cannot be used " <> + when (normalise dir `List.elem` [".", "./"]) $ + throwIO (userError ("isolateWorkingDirectory cannot be used " <> "with current directory")) dir' <- makeAbsolute dir removePathForcibly dir' @@ -183,7 +171,7 @@ getArg :: (String -> Maybe a) -> TestEnv -> String -> String -> a -> a getArg parse TestEnv{testArgs = args} testname name defaultValue = - fromMaybe defaultValue (lookup (prefix <> name) args >>= parse) + fromMaybe defaultValue (List.lookup (prefix <> name) args >>= parse) where prefix | testname == "" = "" | otherwise = testname <> "." @@ -198,7 +186,7 @@ _ -> False parseArgs :: [String] -> [(String, String)] -parseArgs = reverse . (second (drop 1) . span (/= '=') <$>) +parseArgs = List.reverse . (second (List.drop 1) . List.span (/= '=') <$>) testMain :: (TestEnv -> IO ()) -> IO () testMain action = do diff --git a/tests/WithCurrentDirectory.hs b/tests/WithCurrentDirectory.hs --- a/tests/WithCurrentDirectory.hs +++ b/tests/WithCurrentDirectory.hs @@ -1,21 +1,20 @@ {-# LANGUAGE CPP #-} module WithCurrentDirectory where #include "util.inl" -import Data.List (sort) -import System.Directory import System.FilePath (()) +import qualified Data.List as List main :: TestEnv -> IO () main _t = do createDirectory dir -- Make sure we're starting empty - T(expectEq) () [] . sort =<< listDirectory dir + T(expectEq) () [] . List.sort =<< listDirectory dir cwd <- getCurrentDirectory withCurrentDirectory dir (writeFile testfile contents) -- Are we still in original directory? T(expectEq) () cwd =<< getCurrentDirectory -- Did the test file get created? - T(expectEq) () [testfile] . sort =<< listDirectory dir + T(expectEq) () [testfile] . List.sort =<< listDirectory dir -- Does the file contain what we expected to write? T(expectEq) () contents =<< readFile (dir testfile) where diff --git a/tests/util.inl b/tests/util.inl --- a/tests/util.inl +++ b/tests/util.inl @@ -1,4 +1,7 @@ #define T(f) (T.f _t __FILE__ __LINE__) +import Prelude () +import System.Directory.Internal.Prelude +import System.Directory import Util (TestEnv) import qualified Util as T