directory 1.2.7.1 → 1.3.0.0
raw patch · 43 files changed
+797/−339 lines, 43 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ System.Directory: pathIsSymbolicLink :: FilePath -> IO Bool
Files
- HsDirectoryConfig.h.in +3/−0
- System/Directory.hs +128/−133
- System/Directory/Internal.hs +1/−0
- System/Directory/Internal/C_utimensat.hsc +7/−6
- System/Directory/Internal/Posix.hsc +2/−4
- System/Directory/Internal/Prelude.hs +172/−0
- System/Directory/Internal/Windows.hsc +136/−2
- System/Directory/Internal/utility.h +6/−0
- changelog.md +19/−0
- configure +11/−0
- configure.ac +1/−0
- directory.cabal +8/−5
- tests/CanonicalizePath.hs +143/−10
- tests/CopyFile001.hs +3/−4
- tests/CopyFile002.hs +3/−4
- tests/CopyFileWithMetadata.hs +3/−7
- tests/CreateDirectory001.hs +0/−2
- tests/CreateDirectoryIfMissing001.hs +3/−11
- tests/CurrentDirectory001.hs +2/−3
- tests/Directory001.hs +0/−1
- tests/DoesDirectoryExist001.hs +0/−1
- tests/DoesPathExist.hs +0/−1
- tests/FileTime.hs +4/−7
- tests/FindFile001.hs +1/−2
- tests/GetDirContents001.hs +10/−9
- tests/GetDirContents002.hs +0/−2
- tests/GetFileSize.hs +3/−5
- tests/GetHomeDirectory001.hs +0/−1
- tests/GetPermissions001.hs +0/−1
- tests/IsSymbolicLink.hs +0/−23
- tests/Main.hs +4/−2
- tests/MakeAbsolute.hs +33/−0
- tests/PathIsSymbolicLink.hs +18/−0
- tests/RemoveDirectoryRecursive001.hs +16/−18
- tests/RemovePathForcibly.hs +16/−18
- tests/RenameDirectory.hs +0/−1
- tests/RenameFile001.hs +0/−1
- tests/RenamePath.hs +0/−1
- tests/T8482.hs +0/−3
- tests/TestUtils.hs +12/−12
- tests/Util.hs +23/−35
- tests/WithCurrentDirectory.hs +3/−4
- tests/util.inl +3/−0
HsDirectoryConfig.h.in view
@@ -6,6 +6,9 @@ /* Define to 1 if you have the <fcntl.h> 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 <inttypes.h> header file. */ #undef HAVE_INTTYPES_H
System/Directory.hs view
@@ -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
System/Directory/Internal.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# OPTIONS_HADDOCK hide #-} #include <HsDirectoryConfig.h> module System.Directory.Internal
System/Directory/Internal/C_utimensat.hsc view
@@ -10,18 +10,19 @@ #ifdef HAVE_SYS_STAT_H # include <sys/stat.h> #endif-import Foreign-import Foreign.C+#include <System/Directory/Internal/utility.h>+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
System/Directory/Internal/Posix.hsc view
@@ -4,10 +4,8 @@ #ifdef HAVE_LIMITS_H # include <limits.h> #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
+ System/Directory/Internal/Prelude.hs view
@@ -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
System/Directory/Internal/Windows.hsc view
@@ -1,13 +1,22 @@+{-# LANGUAGE CPP #-} module System.Directory.Internal.Windows where #include <HsDirectoryConfig.h> #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 <shlobj.h> #include <windows.h> #ifdef HAVE_SYS_STAT_H # include <sys/stat.h> #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
+ System/Directory/Internal/utility.h view
@@ -0,0 +1,6 @@+#if !defined alignof && __cplusplus < 201103L+# ifdef STDC_HEADERS+# include <stddef.h>+# endif+# define alignof(x) offsetof(struct { char c; x m; }, m)+#endif
changelog.md view
@@ -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.
configure view
@@ -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
configure.ac view
@@ -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
directory.cabal view
@@ -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
tests/CanonicalizePath.hs view
@@ -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
tests/CopyFile001.hs view
@@ -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"
tests/CopyFile002.hs view
@@ -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"
tests/CopyFileWithMetadata.hs view
@@ -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
tests/CreateDirectory001.hs view
@@ -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
tests/CreateDirectoryIfMissing001.hs view
@@ -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
tests/CurrentDirectory001.hs view
@@ -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"
tests/Directory001.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE CPP #-} module Directory001 where #include "util.inl"-import System.Directory main :: TestEnv -> IO () main _t = do
tests/DoesDirectoryExist001.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE CPP #-} module DoesDirectoryExist001 where #include "util.inl"-import System.Directory main :: TestEnv -> IO () main _t = do
tests/DoesPathExist.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE CPP #-} module DoesPathExist where #include "util.inl"-import System.Directory main :: TestEnv -> IO () main _t = do
tests/FileTime.hs view
@@ -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"
tests/FindFile001.hs view
@@ -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
tests/GetDirContents001.hs view
@@ -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 = [".", ".."]
tests/GetDirContents002.hs view
@@ -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
tests/GetFileSize.hs view
@@ -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"
tests/GetHomeDirectory001.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE CPP #-} module GetHomeDirectory001 where #include "util.inl"-import System.Directory main :: TestEnv -> IO () main _t = do
tests/GetPermissions001.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE CPP #-} module GetPermissions001 where #include "util.inl"-import System.Directory main :: TestEnv -> IO () main _t = do
− tests/IsSymbolicLink.hs
@@ -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"
tests/Main.hs view
@@ -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
+ tests/MakeAbsolute.hs view
@@ -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
+ tests/PathIsSymbolicLink.hs view
@@ -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"
tests/RemoveDirectoryRecursive001.hs view
@@ -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"
tests/RemovePathForcibly.hs view
@@ -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"
tests/RenameDirectory.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE CPP #-} module RenameDirectory where #include "util.inl"-import System.Directory main :: TestEnv -> IO () main _t = do
tests/RenameFile001.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE CPP #-} module RenameFile001 where #include "util.inl"-import System.Directory main :: TestEnv -> IO () main _t = do
tests/RenamePath.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE CPP #-} module RenamePath where #include "util.inl"-import System.Directory main :: TestEnv -> IO () main _t = do
tests/T8482.hs view
@@ -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"
tests/TestUtils.hs view
@@ -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
tests/Util.hs view
@@ -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
tests/WithCurrentDirectory.hs view
@@ -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
tests/util.inl view
@@ -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