directory 1.3.8.0 → 1.3.11.0
raw patch · 47 files changed
Files
- System/Directory.hs +30/−10
- System/Directory/Internal/C_utimensat.hsc +6/−8
- System/Directory/Internal/Common.hs +40/−22
- System/Directory/Internal/Posix.hsc +119/−55
- System/Directory/Internal/Prelude.hs +4/−3
- System/Directory/Internal/Windows.hsc +76/−57
- System/Directory/Internal/utility.h +0/−6
- System/Directory/OsPath.hs +105/−88
- changelog.md +80/−0
- directory.buildinfo +0/−1
- directory.cabal +20/−13
- tests/CanonicalizePath.hs +73/−62
- tests/CopyFile001.hs +16/−5
- tests/CopyFile002.hs +9/−5
- tests/CopyFileWithMetadata.hs +14/−10
- tests/CreateDirectory001.hs +7/−3
- tests/CreateDirectoryIfMissing001.hs +19/−14
- tests/CurrentDirectory001.hs +7/−3
- tests/Directory001.hs +7/−3
- tests/DoesDirectoryExist001.hs +12/−7
- tests/DoesPathExist.hs +21/−17
- tests/FileTime.hs +14/−10
- tests/FindExecutable.hs +27/−0
- tests/FindFile001.hs +21/−15
- tests/GetDirContents001.hs +11/−7
- tests/GetDirContents002.hs +7/−3
- tests/GetFileSize.hs +8/−4
- tests/GetHomeDirectory001.hs +9/−5
- tests/GetHomeDirectory002.hs +7/−2
- tests/GetPermissions001.hs +22/−19
- tests/LongPaths.hs +18/−14
- tests/Main.hs +2/−0
- tests/MakeAbsolute.hs +21/−15
- tests/MinimizeNameConflicts.hs +7/−2
- tests/PathIsSymbolicLink.hs +17/−14
- tests/RemoveDirectoryRecursive001.hs +23/−19
- tests/RemovePathForcibly.hs +24/−21
- tests/RenameDirectory.hs +8/−4
- tests/RenameFile001.hs +8/−4
- tests/RenamePath.hs +10/−6
- tests/Simplify.hs +35/−30
- tests/T8482.hs +9/−5
- tests/TestUtils.hs +6/−6
- tests/Util.hs +84/−52
- tests/WithCurrentDirectory.hs +10/−6
- tests/Xdg.hs +16/−13
- tests/util.inl +0/−10
System/Directory.hs view
@@ -40,6 +40,9 @@ , getUserDocumentsDirectory , getTemporaryDirectory + -- * PATH+ , getExecSearchPath+ -- * Actions on files , removeFile , renameFile@@ -159,7 +162,8 @@ been given to use them as part of a path, but not to examine the directory contents. -Note that to change some, but not all permissions, a construct on the following lines must be used.+Note that to change some, but not all permissions, a construct on the+following lines must be used. > makeReadable f = do > p <- getPermissions f@@ -281,9 +285,10 @@ -- | @'createDirectoryIfMissing' parents dir@ creates a new directory -- @dir@ if it doesn\'t exist. If the first argument is 'True' -- the function will also create all parent directories if they are missing.-createDirectoryIfMissing :: Bool -- ^ Create its parents too?- -> FilePath -- ^ The path to the directory you want to make- -> IO ()+createDirectoryIfMissing+ :: Bool -- ^ Create its parents too?+ -> FilePath -- ^ The path to the directory you want to make+ -> IO () createDirectoryIfMissing cp = encodeFS >=> D.createDirectoryIfMissing cp @@ -458,10 +463,14 @@ {- |@'renameFile' old new@ changes the name of an existing file system object from /old/ to /new/. If the /new/ object already exists, it is replaced by the /old/ object. Neither path may refer to an existing-directory. A conformant implementation need not support renaming files-in all situations (e.g. renaming across different physical devices), but-the constraints must be documented.+directory. +A conformant implementation need not support renaming files in all situations+(e.g. renaming across different physical devices), but the constraints must be+documented. On Windows, this does not support renaming across different physical+devices; if you are looking to do so, consider using 'copyFileWithMetadata' and+'removeFile'.+ On Windows, this calls @MoveFileEx@ with @MOVEFILE_REPLACE_EXISTING@ set, which is not guaranteed to be atomic (<https://github.com/haskell/directory/issues/109>).@@ -774,7 +783,8 @@ -- documentation of 'findFilesWith'. -- -- @since 1.2.6.0-findFileWith :: (FilePath -> IO Bool) -> [FilePath] -> String -> IO (Maybe FilePath)+findFileWith+ :: (FilePath -> IO Bool) -> [FilePath] -> String -> IO (Maybe FilePath) findFileWith f ds name = do ds' <- for ds encodeFS name' <- encodeFS name@@ -1162,6 +1172,9 @@ -- -- * 'isDoesNotExistError' if the file or directory does not exist. --+-- * 'InvalidArgument' on FAT32 file system if the time is before+-- DOS Epoch (1 January 1980).+-- -- Some caveats for POSIX systems: -- -- * Not all systems support @utimensat@, in which case the function can only@@ -1190,9 +1203,12 @@ On Unix, 'getHomeDirectory' behaves as follows: * Returns $HOME env variable if set (including to an empty string).-* Otherwise uses home directory returned by `getpwuid_r` using the UID of the current proccesses user. This basically reads the /etc/passwd file. An empty home directory field is considered valid.+* Otherwise uses home directory returned by @getpwuid_r@ using the UID of the+ current process' user. This basically reads the @\/etc\/passwd@ file. An+ empty home directory field is considered valid. -On Windows, the system is queried for a suitable path; a typical path might be @C:\/Users\//\<user\>/@.+On Windows, the system is queried for a suitable path; a typical path might be+@C:\/Users\//\<user\>/@. The operation may fail with: @@ -1330,3 +1346,7 @@ -} getTemporaryDirectory :: IO FilePath getTemporaryDirectory = D.getTemporaryDirectory >>= decodeFS++-- | Get the contents of the @PATH@ environment variable.+getExecSearchPath :: IO [FilePath]+getExecSearchPath = D.getExecSearchPath >>= (`for` decodeFS)
System/Directory/Internal/C_utimensat.hsc view
@@ -1,3 +1,5 @@+{-# LANGUAGE CApiFFI #-}+ module System.Directory.Internal.C_utimensat where #include <HsDirectoryConfig.h> #ifdef HAVE_UTIMENSAT@@ -10,17 +12,16 @@ #ifdef HAVE_SYS_STAT_H # include <sys/stat.h> #endif-#include <System/Directory/Internal/utility.h> import Prelude () import System.Directory.Internal.Prelude import Data.Time.Clock.POSIX (POSIXTime)+import qualified System.Posix as Posix data CTimeSpec = CTimeSpec EpochTime CLong instance Storable CTimeSpec where sizeOf _ = #{size struct timespec}- -- workaround (hsc2hs for GHC < 8.0 doesn't support #{alignment ...})- alignment _ = #{size char[alignof(struct timespec)] }+ alignment _ = #{alignment struct timespec} poke p (CTimeSpec sec nsec) = do (#poke struct timespec, tv_sec) p sec (#poke struct timespec, tv_nsec) p nsec@@ -29,9 +30,6 @@ nsec <- #{peek struct timespec, tv_nsec} p return (CTimeSpec sec nsec) -c_AT_FDCWD :: CInt-c_AT_FDCWD = (#const AT_FDCWD)- utimeOmit :: CTimeSpec utimeOmit = CTimeSpec (CTime 0) (#const UTIME_OMIT) @@ -41,7 +39,7 @@ (sec, frac) = if frac' < 0 then (sec' - 1, frac' + 1) else (sec', frac') (sec', frac') = properFraction (toRational t) -foreign import ccall "utimensat" c_utimensat- :: CInt -> CString -> Ptr CTimeSpec -> CInt -> IO CInt+foreign import capi "sys/stat.h utimensat" c_utimensat+ :: Posix.Fd -> CString -> Ptr CTimeSpec -> CInt -> IO CInt #endif
System/Directory/Internal/Common.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} module System.Directory.Internal.Common ( module System.Directory.Internal.Common , OsPath@@ -8,7 +9,7 @@ import GHC.IO.Encoding.Failure (CodingFailureMode(TransliterateCodingFailure)) import GHC.IO.Encoding.UTF16 (mkUTF16le) import GHC.IO.Encoding.UTF8 (mkUTF8)-import System.IO (hSetBinaryMode)+import qualified System.File.OsPath.Internal as File import System.OsPath ( OsPath , OsString@@ -55,17 +56,17 @@ listTToList (ListT m) = do mx <- m case mx of- Nothing -> return []+ Nothing -> pure [] Just (x, m') -> do xs <- listTToList m'- return (x : xs)+ pure (x : xs) andM :: Monad m => m Bool -> m Bool -> m Bool andM mx my = do x <- mx if x then my- else return x+ else pure x sequenceWithIOErrors_ :: [IO ()] -> IO () sequenceWithIOErrors_ actions = go (Right ()) actions@@ -126,6 +127,10 @@ (mkUTF8 TransliterateCodingFailure) (mkUTF16le TransliterateCodingFailure) +dropSpecialDotDirs :: [OsPath] -> [OsPath]+dropSpecialDotDirs = filter f+ where f filename = filename /= os "." && filename /= os ".."+ -- | Given a list of path segments, expand @.@ and @..@. The path segments -- must not contain path separators. expandDots :: [OsPath] -> [OsPath]@@ -174,14 +179,15 @@ -- -- * empty paths stay empty, -- * parent dirs (@..@) are expanded, and--- * paths starting with @\\\\?\\@ are preserved.+-- * paths starting with @\\\\@ are preserved. -- -- The goal is to preserve the meaning of paths better than 'normalise'. simplifyWindows :: OsPath -> OsPath simplifyWindows path- | path == mempty = mempty- | drive' == os "\\\\?\\" = drive' <> subpath- | otherwise = simplifiedPath+ | path == mempty = mempty+ | otherwise = case toChar <$> unpack drive' of+ '\\' : '\\' : _ -> drive' <> subpath+ _ -> simplifiedPath where simplifiedPath = joinDrive drive' subpath' (drive, subpath) = splitDrive path@@ -215,12 +221,19 @@ subpathIsAbsolute = any isPathSeparator (take 1 (unpack subpath)) hasTrailingPathSep = hasTrailingPathSeparator subpath -data FileType = File- | SymbolicLink -- ^ POSIX: either file or directory link; Windows: file link- | Directory- | DirectoryLink -- ^ Windows only: directory link- deriving (Bounded, Enum, Eq, Ord, Read, Show)+data WhetherFollow = NoFollow | FollowLinks deriving (Show) +isNoFollow :: WhetherFollow -> Bool+isNoFollow NoFollow = True+isNoFollow FollowLinks = False++data FileType+ = File+ | SymbolicLink -- ^ POSIX: either file or directory link; Windows: file link+ | Directory+ | DirectoryLink -- ^ Windows only: directory link+ deriving (Bounded, Enum, Eq, Ord, Read, Show)+ -- | Check whether the given 'FileType' is considered a directory by the -- operating system. This affects the choice of certain functions -- e.g. 'System.Directory.removeDirectory' vs 'System.Directory.removeFile'.@@ -243,14 +256,18 @@ , searchable :: Bool } deriving (Eq, Ord, Read, Show) -withBinaryHandle :: IO Handle -> (Handle -> IO r) -> IO r-withBinaryHandle open = bracket openBinary hClose- where- openBinary = do- h <- open- hSetBinaryMode h True- pure h+withBinaryFile :: OsPath -> IOMode -> (Handle -> IO r) -> IO r+withBinaryFile path mode =+ bracket (File.openFileWithCloseOnExec path mode) hClose +openTempFile' :: String -> OsPath -> OsString -> Bool -> CMode -> Bool+ -> IO (OsPath, Handle)+openTempFile' loc tmpDir template binary mode _cloExec =+ File.openTempFile' loc tmpDir template binary mode+#if MIN_VERSION_file_io(0, 2, 0)+ _cloExec+#endif+ -- | Copy data from one handle to another until end of file. copyHandleData :: Handle -- ^ Source handle -> Handle -- ^ Destination handle@@ -259,7 +276,8 @@ (`ioeAddLocation` "copyData") `modifyIOError` do allocaBytes bufferSize go where- bufferSize = 131072 -- 128 KiB, as coreutils `cp` uses as of May 2014 (see ioblksize.h)+ -- 128 KiB, as coreutils `cp` uses as of May 2014 (see ioblksize.h)+ bufferSize = 131072 go buffer = do count <- hGetBuf hFrom buffer bufferSize when (count > 0) $ do@@ -301,7 +319,7 @@ -- but that is not important or portable enough to the user that it -- should be stored in 'XdgData'. -- It uses the @XDG_STATE_HOME@ environment variable.- -- On non-Windows sytems, the default is @~\/.local\/state@. On+ -- On non-Windows systems, the default is @~\/.local\/state@. On -- Windows, the default is @%LOCALAPPDATA%@ -- (e.g. @C:\/Users\//\<user\>/\/AppData\/Local@). --
System/Directory/Internal/Posix.hsc view
@@ -1,9 +1,14 @@+{-# LANGUAGE CApiFFI #-} module System.Directory.Internal.Posix where #include <HsDirectoryConfig.h> #if !defined(mingw32_HOST_OS)+#include <fcntl.h> #ifdef HAVE_LIMITS_H # include <limits.h> #endif+#ifdef HAVE_SYS_STAT_H+# include <sys/stat.h>+#endif import Prelude () import System.Directory.Internal.Prelude #ifdef HAVE_UTIMENSAT@@ -13,20 +18,66 @@ import System.Directory.Internal.Config (exeExtension) import Data.Time (UTCTime) import Data.Time.Clock.POSIX (POSIXTime)-import System.OsPath ((</>), encodeFS, isRelative, splitSearchPath)+import System.OsPath ((</>), isRelative, splitSearchPath) import System.OsString.Internal.Types (OsString(OsString, getOsString)) import qualified Data.Time.Clock.POSIX as POSIXTime+import qualified System.OsPath.Internal as OsPath+import qualified System.Posix.Directory.Fd as Posix import qualified System.Posix.Directory.PosixPath as Posix import qualified System.Posix.Env.PosixString as Posix+import qualified System.Posix.Files as Posix (FileStatus(..)) import qualified System.Posix.Files.PosixString as Posix+import qualified System.Posix.Internals as Posix (CStat) import qualified System.Posix.IO.PosixString as Posix import qualified System.Posix.PosixPath.FilePath as Posix import qualified System.Posix.Types as Posix-import qualified System.Posix.User as Posix+import qualified System.Posix.User.ByteString as Posix +c_AT_FDCWD :: Posix.Fd+c_AT_FDCWD = Posix.Fd (#const AT_FDCWD)++c_AT_SYMLINK_NOFOLLOW :: CInt+c_AT_SYMLINK_NOFOLLOW = (#const AT_SYMLINK_NOFOLLOW)++atWhetherFollow :: WhetherFollow -> CInt+atWhetherFollow NoFollow = c_AT_SYMLINK_NOFOLLOW+atWhetherFollow FollowLinks = 0++defaultOpenFlags :: Posix.OpenFileFlags+defaultOpenFlags =+ Posix.defaultFileFlags+ { Posix.noctty = True+ , Posix.nonBlock = True+ , Posix.cloexec = True+ }++type RawHandle = Posix.Fd++openRaw :: WhetherFollow -> Maybe RawHandle -> OsPath -> IO RawHandle+openRaw whetherFollow dir (OsString path) =+ Posix.openFdAt dir path Posix.ReadOnly flags+ where+ flags = defaultOpenFlags { Posix.nofollow = isNoFollow whetherFollow }++closeRaw :: RawHandle -> IO ()+closeRaw = Posix.closeFd+ createDirectoryInternal :: OsPath -> IO () createDirectoryInternal (OsString path) = Posix.createDirectory path 0o777 +foreign import ccall "unistd.h unlinkat" c_unlinkat+ :: Posix.Fd -> CString -> CInt -> IO CInt++removePathAt :: FileType -> Maybe RawHandle -> OsPath -> IO ()+removePathAt ty dir (OsString path) =+ Posix.withFilePath path $ \ pPath -> do+ Posix.throwErrnoPathIfMinus1_ "unlinkat" path+ (c_unlinkat (fromMaybe c_AT_FDCWD dir) pPath flag)+ pure ()+ where+ flag | fileTypeIsDirectory ty = (#const AT_REMOVEDIR)+ | otherwise = 0+ removePathInternal :: Bool -> OsPath -> IO () removePathInternal True = Posix.removeDirectory . getOsString removePathInternal False = Posix.removeLink . getOsString@@ -62,7 +113,13 @@ #if !defined(HAVE_REALPATH) c_realpath :: CString -> CString -> IO CString-c_realpath _ _ = throwIO (mkIOError UnsupportedOperation "platform does not support realpath" Nothing Nothing)+c_realpath _ _ =+ throwIO+ (mkIOError+ UnsupportedOperation+ "platform does not support realpath"+ Nothing+ Nothing) #else @@ -81,14 +138,10 @@ allocaBytes (pathMax + 1) (realpath >=> action) where realpath = throwErrnoIfNull "" . c_realpath path -canonicalizePathWith :: ((OsPath -> IO OsPath) -> OsPath -> IO OsPath)- -> OsPath- -> IO OsPath-canonicalizePathWith attemptRealpath path = do- let realpath (OsString path') =- Posix.withFilePath path'- (`withRealpath` ((OsString <$>) . Posix.peekFilePath))- attemptRealpath realpath path+realPath :: OsPath -> IO OsPath+realPath (OsString path') =+ Posix.withFilePath path'+ (`withRealpath` ((OsString <$>) . Posix.peekFilePath)) canonicalizePathSimplify :: OsPath -> IO OsPath canonicalizePathSimplify = pure@@ -101,23 +154,31 @@ path <- getPath pure (findExecutablesInDirectoriesLazy path binary) +getPath :: IO [OsPath]+getPath = splitSearchPath <$> getEnvOs (os "PATH")+ exeExtensionInternal :: OsString exeExtensionInternal = exeExtension +openDirFromFd :: Posix.Fd -> IO Posix.DirStream+openDirFromFd fd = Posix.unsafeOpenDirStreamFd =<< Posix.dup fd++readDirStreamToEnd :: Posix.DirStream -> IO [OsPath]+readDirStreamToEnd stream = loop id+ where+ loop acc = do+ e <- Posix.readDirStream stream+ if e == mempty+ then pure (acc [])+ else loop (acc . (OsString e :))++readDirToEnd :: RawHandle -> IO [OsPath]+readDirToEnd fd =+ bracket (openDirFromFd fd) Posix.closeDirStream readDirStreamToEnd+ getDirectoryContentsInternal :: OsPath -> IO [OsPath] getDirectoryContentsInternal (OsString path) =- bracket- (Posix.openDirStream path)- Posix.closeDirStream- start- where- start dirp = loop id- where- loop acc = do- e <- Posix.readDirStream dirp- if e == mempty- then pure (acc [])- else loop (acc . (OsString e :))+ bracket (Posix.openDirStream path) Posix.closeDirStream readDirStreamToEnd getCurrentDirectoryInternal :: IO OsPath getCurrentDirectoryInternal = OsString <$> Posix.getWorkingDirectory@@ -157,6 +218,20 @@ type Metadata = Posix.FileStatus +foreign import capi "sys/stat.h fstatat" c_fstatat+ :: Posix.Fd -> CString -> Ptr Posix.CStat -> CInt -> IO CInt++getMetadataAt :: WhetherFollow -> Maybe RawHandle -> OsPath -> IO Metadata+getMetadataAt whetherFollow dir (OsString path) =+ Posix.withFilePath path $ \ pPath -> do+ stat <- mallocForeignPtrBytes (#const sizeof(struct stat))+ withForeignPtr stat $ \ pStat -> do+ Posix.throwErrnoPathIfMinus1_ "fstatat" path $ do+ c_fstatat (fromMaybe c_AT_FDCWD dir) pPath pStat flags+ pure (Posix.FileStatus stat)+ where+ flags = atWhetherFollow whetherFollow+ getSymbolicLinkMetadata :: OsPath -> IO Metadata getSymbolicLinkMetadata = Posix.getSymbolicLinkStatus . getOsString @@ -201,6 +276,18 @@ setWriteMode False m = m .&. complement allWriteMode setWriteMode True m = m .|. allWriteMode +setForceRemoveMode :: Mode -> Mode+setForceRemoveMode m = m .|. Posix.ownerModes++foreign import capi "sys/stat.h fchmodat" c_fchmodat+ :: Posix.Fd -> CString -> Posix.FileMode -> CInt -> IO CInt++setModeAt :: Maybe RawHandle -> OsPath -> Mode -> IO ()+setModeAt dir (OsString path) mode = do+ Posix.withFilePath path $ \ pPath ->+ Posix.throwErrnoPathIfMinus1_ "fchmodat" path $ do+ c_fchmodat (fromMaybe c_AT_FDCWD dir) pPath mode 0+ setFileMode :: OsPath -> Mode -> IO () setFileMode = Posix.setFileMode . getOsString @@ -247,24 +334,6 @@ ignoreIOExceptions (copyOwnerFromStatus st dst) ignoreIOExceptions (copyGroupFromStatus st dst) -defaultFlags :: Posix.OpenFileFlags-defaultFlags =- Posix.defaultFileFlags- { Posix.noctty = True- , Posix.nonBlock = True- , Posix.cloexec = True- }--openFileForRead :: OsPath -> IO Handle-openFileForRead (OsString p) =- Posix.fdToHandle =<< Posix.openFd p Posix.ReadOnly defaultFlags--openFileForWrite :: OsPath -> IO Handle-openFileForWrite (OsString p) =- Posix.fdToHandle =<<- Posix.openFd p Posix.WriteOnly- defaultFlags { Posix.creat = Just 0o666, Posix.trunc = True }- -- | Truncate the destination file and then copy the contents of the source -- file to the destination file. If the destination file already exists, its -- attributes shall remain unchanged. Otherwise, its attributes are reset to@@ -274,8 +343,8 @@ -> IO () copyFileContents fromFPath toFPath = (`ioeAddLocation` "copyFileContents") `modifyIOError` do- withBinaryHandle (openFileForWrite toFPath) $ \ hTo -> do- withBinaryHandle (openFileForRead fromFPath) $ \ hFrom -> do+ withBinaryFile toFPath WriteMode $ \ hTo -> do+ withBinaryFile fromFPath ReadMode $ \ hFrom -> do copyHandleData hFrom hTo copyFileWithMetadataInternal :: (Metadata -> OsPath -> IO ())@@ -329,23 +398,17 @@ Nothing Just value -> pure value --- | Get the contents of the @PATH@ environment variable.-getPath :: IO [OsPath]-getPath = splitSearchPath <$> getEnvOs (os "PATH")- -- | $HOME is preferred, because the user has control over it. However, POSIX -- doesn't define it as a mandatory variable, so fall back to `getpwuid_r`. getHomeDirectoryInternal :: IO OsPath getHomeDirectoryInternal = do e <- lookupEnvOs (os "HOME") case e of- Just fp -> pure fp- -- TODO: os here is bad, but unix's System.Posix.User.UserEntry does not- -- have ByteString/OsString variants- Nothing ->- encodeFS =<<- Posix.homeDirectory <$>- (Posix.getEffectiveUserID >>= Posix.getUserEntryForID)+ Just fp -> pure fp+ Nothing ->+ OsPath.fromBytes . Posix.homeDirectory =<<+ Posix.getUserEntryForID =<<+ Posix.getEffectiveUserID getXdgDirectoryFallback :: IO OsPath -> XdgDirectory -> IO OsPath getXdgDirectoryFallback getHomeDirectory xdgDir = do@@ -369,6 +432,7 @@ getUserDocumentsDirectoryInternal = getHomeDirectoryInternal getTemporaryDirectoryInternal :: IO OsPath-getTemporaryDirectoryInternal = fromMaybe (os "/tmp") <$> lookupEnvOs (os "TMPDIR")+getTemporaryDirectoryInternal =+ fromMaybe (os "/tmp") <$> lookupEnvOs (os "TMPDIR") #endif
System/Directory/Internal/Prelude.hs view
@@ -58,7 +58,7 @@ import Control.Monad ((>=>), (<=<), unless, when, replicateM, replicateM_) import Data.Bits ((.&.), (.|.), complement) import Data.Char (isAlpha, isAscii, toLower, toUpper)-import Data.Foldable (for_)+import Data.Foldable (for_, sequenceA_) import Data.Function (on) import Data.Maybe (catMaybes, fromMaybe, maybeToList) import Data.Monoid ((<>), mconcat, mempty)@@ -80,11 +80,13 @@ , allocaArray , allocaBytes , allocaBytesAligned+ , mallocForeignPtrBytes , maybeWith , nullPtr , plusPtr , with , withArray+ , withForeignPtr ) import Foreign.C ( CInt(..)@@ -120,7 +122,6 @@ , hPutBuf , hPutStr , hPutStrLn- , openBinaryTempFile , stderr , stdout )@@ -145,5 +146,5 @@ , tryIOError , userError )-import System.Posix.Types (EpochTime)+import System.Posix.Types (CMode, EpochTime) import System.Timeout (timeout)
System/Directory/Internal/Windows.hsc view
@@ -4,7 +4,7 @@ #if defined(mingw32_HOST_OS) ##if defined(i386_HOST_ARCH) ## define WINAPI stdcall-##elif defined(x86_64_HOST_ARCH)+##elif defined(x86_64_HOST_ARCH) || defined(aarch64_HOST_ARCH) ## define WINAPI ccall ##else ## error unknown architecture@@ -12,7 +12,6 @@ #include <shlobj.h> #include <windows.h> #include <HsBaseConfig.h>-#include <System/Directory/Internal/utility.h> #include <System/Directory/Internal/windows_ext.h> import Prelude () import System.Directory.Internal.Prelude@@ -25,11 +24,14 @@ #endif import System.OsPath ( (</>)+ , hasExtension+ , isExtensionOf , isPathSeparator , isRelative , pack , pathSeparator , splitDirectories+ , splitSearchPath , takeExtension , toChar , unpack@@ -42,13 +44,49 @@ import qualified System.Win32.WindowsString.Shell as Win32 import qualified System.Win32.WindowsString.Time as Win32 import qualified System.Win32.WindowsString.Types as Win32+import qualified System.Win32.WindowsString.Console as Win32 +type RawHandle = OsPath++pathAt :: Maybe RawHandle -> OsPath -> OsPath+pathAt dir path = fromMaybe mempty dir </> path++openRaw :: WhetherFollow -> Maybe RawHandle -> OsPath -> IO RawHandle+openRaw _ dir path = pure (pathAt dir path)++closeRaw :: RawHandle -> IO ()+closeRaw _ = pure ()++lookupEnvOs :: OsString -> IO (Maybe OsString)+lookupEnvOs (OsString name) = (OsString <$>) <$> Win32.getEnv name++getEnvOs :: OsString -> IO OsString+getEnvOs name = do+ env <- lookupEnvOs name+ case env of+ Nothing ->+ throwIO $+ mkIOError+ doesNotExistErrorType+ ("env var " <> show name <> " not found")+ Nothing+ Nothing+ Just value -> pure value++-- | Get the contents of the @PATH@ environment variable.+getPath :: IO [OsPath]+getPath = splitSearchPath <$> getEnvOs (os "PATH")+ createDirectoryInternal :: OsPath -> IO () createDirectoryInternal path = (`ioeSetOsPath` path) `modifyIOError` do path' <- furnishPath path Win32.createDirectory path' Nothing +removePathAt :: FileType -> Maybe RawHandle -> OsPath -> IO ()+removePathAt ty dir path = removePathInternal isDir (pathAt dir path)+ where isDir = fileTypeIsDirectory ty+ removePathInternal :: Bool -> OsPath -> IO () removePathInternal isDir path = (`ioeSetOsPath` path) `modifyIOError` do@@ -105,28 +143,6 @@ Win32.fILE_SHARE_READ .|. Win32.fILE_SHARE_WRITE -openFileForRead :: OsPath -> IO Handle-openFileForRead (OsString path) =- bracketOnError- (Win32.createFile- path- Win32.gENERIC_READ- maxShareMode- Nothing- Win32.oPEN_ALWAYS- (Win32.fILE_ATTRIBUTE_NORMAL .|. possiblyOverlapped)- Nothing)- Win32.closeHandle- Win32.hANDLEToHandle--possiblyOverlapped :: Win32.FileAttributeOrFlag-#ifdef __IO_MANAGER_WINIO__-possiblyOverlapped | ioSubSystem == IoNative = Win32.fILE_FLAG_OVERLAPPED- | otherwise = 0-#else-possiblyOverlapped = 0-#endif- win32_getFinalPathNameByHandle :: Win32.HANDLE -> Win32.DWORD -> IO WindowsPath #ifdef HAVE_GETFINALPATHNAMEBYHANDLEW win32_getFinalPathNameByHandle h flags = do@@ -199,8 +215,7 @@ allocaBytesAligned size align $ \ ptr -> action (ptr, size) where size = fromIntegral win32_mAXIMUM_REPARSE_DATA_BUFFER_SIZE- -- workaround (hsc2hs for GHC < 8.0 don't support #{alignment ...})- align = #{size char[alignof(HsDirectory_REPARSE_DATA_BUFFER)]}+ align = #{alignment HsDirectory_REPARSE_DATA_BUFFER} win32_peek_REPARSE_DATA_BUFFER :: Ptr Win32_REPARSE_DATA_BUFFER -> IO Win32_REPARSE_DATA_BUFFER@@ -327,10 +342,7 @@ else case toChar <$> simplifiedPath' of '\\' : '?' : '?' : '\\' : _ -> simplifiedPath- '\\' : '\\' : '?' : '\\' : _ -> simplifiedPath- '\\' : '\\' : '.' : '\\' : _ -> simplifiedPath- '\\' : '\\' : _ ->- os "\\\\?\\UNC" <> pack (tail simplifiedPath')+ '\\' : '\\' : _ -> simplifiedPath _ -> os "\\\\?\\" <> simplifiedPath where simplifiedPath = simplify path simplifiedPath' = unpack simplifiedPath@@ -356,7 +368,8 @@ | (toChar <$> [c1, c2, c3, c4]) == "\\\\?\\" -> case path of c5 : c6 : c7 : subpath@(c8 : _)- | (toChar <$> [c5, c6, c7, c8]) == "UNC\\" -> pack subpath+ | (toChar <$> [c5, c6, c7, c8]) == "UNC\\" ->+ pack (c8 : subpath) drive : col : subpath -- if the path is not "regular", then the prefix is necessary -- to ensure the path is interpreted literally@@ -407,10 +420,8 @@ Left proposedSize -> peekTStringWith proposedSize cFunc Right result -> pure result -canonicalizePathWith :: ((OsPath -> IO OsPath) -> OsPath -> IO OsPath)- -> OsPath- -> IO OsPath-canonicalizePathWith attemptRealpath = attemptRealpath getFinalPathName+realPath :: OsPath -> IO OsPath+realPath = getFinalPathName canonicalizePathSimplify :: OsPath -> IO OsPath canonicalizePathSimplify path =@@ -419,9 +430,18 @@ pure path searchPathEnvForExes :: OsString -> IO (Maybe OsPath)-searchPathEnvForExes (OsString binary) =- (OsString <$>) <$>- Win32.searchPath Nothing binary (Just (getOsString exeExtension))+searchPathEnvForExes binaryPath@(OsString binary) = do+ maybePath <- search+ `catch` \e ->+ if ioeGetErrorType e == InvalidArgument+ then pure Nothing+ else throwIO e+ pure (OsString <$> maybePath >>= verify)+ where+ search = Win32.searchPath Nothing binary (Just (getOsString exeExtension))+ verify p+ | hasExtension binaryPath || exeExtension `isExtensionOf` p = Just p+ | otherwise = Nothing findExecutablesLazyInternal :: ([OsPath] -> OsString -> ListT IO OsPath) -> OsString@@ -431,6 +451,9 @@ exeExtensionInternal :: OsString exeExtensionInternal = exeExtension +readDirToEnd :: RawHandle -> IO [OsPath]+readDirToEnd = getDirectoryContentsInternal+ getDirectoryContentsInternal :: OsPath -> IO [OsPath] getDirectoryContentsInternal path = do query <- furnishPath (path </> os "*")@@ -545,6 +568,10 @@ type Metadata = Win32.BY_HANDLE_FILE_INFORMATION +getMetadataAt :: WhetherFollow -> Maybe RawHandle -> OsPath -> IO Metadata+getMetadataAt NoFollow dir path = getSymbolicLinkMetadata (pathAt dir path)+getMetadataAt FollowLinks dir path = getFileMetadata (pathAt dir path)+ getSymbolicLinkMetadata :: OsPath -> IO Metadata getSymbolicLinkMetadata path = (`ioeSetOsPath` path) `modifyIOError` do@@ -604,7 +631,11 @@ setTimes path' (atime', mtime') = bracket (openFileHandle path' Win32.gENERIC_WRITE) Win32.closeHandle $ \ handle ->- Win32.setFileTime handle Nothing (posixToWindowsTime <$> atime') (posixToWindowsTime <$> mtime')+ Win32.setFileTime+ handle+ Nothing+ (posixToWindowsTime <$> atime')+ (posixToWindowsTime <$> mtime') -- | Open the handle of an existing file or directory. openFileHandle :: OsString -> Win32.AccessMode -> IO Win32.HANDLE@@ -628,6 +659,12 @@ setWriteMode False m = m .|. Win32.fILE_ATTRIBUTE_READONLY setWriteMode True m = m .&. complement Win32.fILE_ATTRIBUTE_READONLY +setForceRemoveMode :: Mode -> Mode+setForceRemoveMode m = m .&. complement Win32.fILE_ATTRIBUTE_READONLY++setModeAt :: Maybe RawHandle -> OsPath -> Mode -> IO ()+setModeAt dir path = setFileMode (pathAt dir path)+ setFileMode :: OsPath -> Mode -> IO () setFileMode path mode = (`ioeSetOsPath` path) `modifyIOError` do@@ -659,24 +696,6 @@ setAccessPermissions :: OsPath -> Permissions -> IO () setAccessPermissions path Permissions{writable = w} = do setFilePermissions path (setWriteMode w 0)--lookupEnvOs :: OsString -> IO (Maybe OsString)-lookupEnvOs (OsString name) = do- result <-- Win32.withTString name $ \ pName ->- peekTStringWith 256 $ \ pBuffer size ->- c_GetEnvironmentVariable pName pBuffer size- case result of- Left errCode | errCode == win32_eRROR_ENVVAR_NOT_FOUND -> pure Nothing- | otherwise -> Win32.failWith "GetEnvironmentVariable" errCode- Right value -> pure (Just (OsString value))--foreign import WINAPI unsafe "windows.h GetEnvironmentVariableW"- c_GetEnvironmentVariable- :: Win32.LPWSTR- -> Win32.LPWSTR- -> Win32.DWORD- -> IO Win32.DWORD getFolderPath :: Win32.CSIDL -> IO OsPath getFolderPath what = OsString <$> Win32.sHGetFolderPath nullPtr what nullPtr 0
− System/Directory/Internal/utility.h
@@ -1,6 +0,0 @@-#if !defined(alignof) && __cplusplus < 201103L-# ifdef STDC_HEADERS-# include <stddef.h>-# endif-# define alignof(x) offsetof(struct { char c; x m; }, m)-#endif
System/Directory/OsPath.hs view
@@ -10,7 +10,7 @@ -- -- System-independent interface to directory manipulation. ----- @since 1.2.8.0+-- @since 1.3.8.0 -- ----------------------------------------------------------------------------- @@ -42,6 +42,9 @@ , getUserDocumentsDirectory , getTemporaryDirectory + -- * PATH+ , getExecSearchPath+ -- * Actions on files , removeFile , renameFile@@ -109,9 +112,7 @@ ( (<.>) , (</>) , addTrailingPathSeparator- , decodeFS , dropTrailingPathSeparator- , encodeFS , hasTrailingPathSeparator , isAbsolute , joinPath@@ -119,9 +120,14 @@ , splitDirectories , splitSearchPath , takeDirectory+ , encodeWith )+import qualified Data.List.NonEmpty as NE import Data.Time (UTCTime) import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)+import GHC.IO.Encoding.UTF8 ( mkUTF8 )+import GHC.IO.Encoding.UTF16 ( mkUTF16le )+import GHC.IO.Encoding.Failure ( CodingFailureMode(..) ) {- $intro A directory contains a series of entries, each of which is a named@@ -172,7 +178,8 @@ been given to use them as part of a path, but not to examine the directory contents. -Note that to change some, but not all permissions, a construct on the following lines must be used.+Note that to change some, but not all permissions, a construct on the+following lines must be used. > makeReadable f = do > p <- getPermissions f@@ -303,9 +310,10 @@ -- | @'createDirectoryIfMissing' parents dir@ creates a new directory -- @dir@ if it doesn\'t exist. If the first argument is 'True' -- the function will also create all parent directories if they are missing.-createDirectoryIfMissing :: Bool -- ^ Create its parents too?- -> OsPath -- ^ The path to the directory you want to make- -> IO ()+createDirectoryIfMissing+ :: Bool -- ^ Create its parents too?+ -> OsPath -- ^ The path to the directory you want to make+ -> IO () createDirectoryIfMissing create_parents path0 | create_parents = createDirs (parents path0) | otherwise = createDirs (take 1 (parents path0))@@ -313,7 +321,7 @@ parents = reverse . scanl1 (</>) . splitDirectories . simplify createDirs [] = pure ()- createDirs (dir:[]) = createDir dir ioError+ createDirs [dir] = createDir dir ioError createDirs (dir:dirs) = createDir dir $ \_ -> do createDirs dirs@@ -391,6 +399,42 @@ removeDirectory :: OsPath -> IO () removeDirectory = removePathInternal True +type Preremover = Maybe RawHandle -> OsPath -> Metadata -> IO ()++noPreremover :: Preremover+noPreremover _ _ _ = pure ()++forcePreremover :: Preremover+forcePreremover dir path metadata = do+ when (fileTypeIsDirectory (fileTypeFromMetadata metadata)+ || not filesAlwaysRemovable) $ do+ setModeAt dir path mode+ `catchIOError` \ _ -> pure ()+ where+ mode = setForceRemoveMode (modeFromMetadata metadata)++removeRecursivelyAt+ :: (IO () -> IO ())+ -> ([IO ()] -> IO ())+ -> Preremover+ -> Maybe RawHandle+ -> OsPath+ -> IO ()+removeRecursivelyAt catcher sequencer preremover dir name = catcher $ do+ metadata <- getMetadataAt NoFollow dir name+ preremover dir name metadata+ let+ fileType = fileTypeFromMetadata metadata+ subremovals = do+ when (fileType == Directory) $ do+ bracket (openRaw NoFollow dir name) closeRaw $ \ handle -> do+ -- dropSpecialDotDirs is extremely important! Otherwise it will+ -- recurse into the parent directory and wreak havoc.+ names <- dropSpecialDotDirs <$> readDirToEnd handle+ sequencer (recurse (Just handle) <$> names)+ sequencer [subremovals, removePathAt fileType dir name]+ where recurse = removeRecursivelyAt catcher sequencer preremover+ -- | @'removeDirectoryRecursive' dir@ removes an existing directory /dir/ -- together with its contents and subdirectories. Within this directory, -- symbolic links are removed without affecting their targets.@@ -405,41 +449,13 @@ m <- getSymbolicLinkMetadata path case fileTypeFromMetadata m of Directory ->- removeContentsRecursive path+ removeRecursivelyAt id sequenceA_ noPreremover Nothing path DirectoryLink -> ioError (err `ioeSetErrorString` "is a directory symbolic link") _ -> ioError (err `ioeSetErrorString` "not a directory") where err = mkIOError InappropriateType "" Nothing Nothing `ioeSetOsPath` path --- | @removePathRecursive path@ removes an existing file or directory at--- /path/ together with its contents and subdirectories. Symbolic links are--- removed without affecting their the targets.------ This operation is reported to be flaky on Windows so retry logic may--- be advisable. See: https://github.com/haskell/directory/pull/108-removePathRecursive :: OsPath -> IO ()-removePathRecursive path =- (`ioeAddLocation` "removePathRecursive") `modifyIOError` do- m <- getSymbolicLinkMetadata path- case fileTypeFromMetadata m of- Directory -> removeContentsRecursive path- DirectoryLink -> removeDirectory path- _ -> removeFile path---- | @removeContentsRecursive dir@ removes the contents of the directory--- /dir/ recursively. Symbolic links are removed without affecting their the--- targets.------ This operation is reported to be flaky on Windows so retry logic may--- be advisable. See: https://github.com/haskell/directory/pull/108-removeContentsRecursive :: OsPath -> IO ()-removeContentsRecursive path =- (`ioeAddLocation` "removeContentsRecursive") `modifyIOError` do- cont <- listDirectory path- for_ [path </> x | x <- cont] removePathRecursive- removeDirectory path- -- | Removes a file or directory at /path/ together with its contents and -- subdirectories. Symbolic links are removed without affecting their -- targets. If the path does not exist, nothing happens.@@ -459,34 +475,19 @@ removePathForcibly :: OsPath -> IO () removePathForcibly path = (`ioeAddLocation` "removePathForcibly") `modifyIOError` do- ignoreDoesNotExistError $ do- m <- getSymbolicLinkMetadata path- case fileTypeFromMetadata m of- DirectoryLink -> do- makeRemovable path- removeDirectory path- Directory -> do- makeRemovable path- names <- listDirectory path- sequenceWithIOErrors_ $- [ removePathForcibly (path </> name) | name <- names ] ++- [ removeDirectory path ]- _ -> do- unless filesAlwaysRemovable (makeRemovable path)- removeFile path+ removeRecursivelyAt+ ignoreDoesNotExistError+ sequenceWithIOErrors_+ forcePreremover+ Nothing+ path+ where ignoreDoesNotExistError :: IO () -> IO () ignoreDoesNotExistError action = () <$ tryIOErrorType isDoesNotExistError action - makeRemovable :: OsPath -> IO ()- makeRemovable p = (`catchIOError` \ _ -> pure ()) $ do- perms <- getPermissions p- setPermissions path perms{ readable = True- , searchable = True- , writable = True }- {- |'removeFile' /file/ removes the directory entry for an existing file /file/, where /file/ is not itself a directory. The implementation may specify additional constraints which must be@@ -587,10 +588,14 @@ {- |@'renameFile' old new@ changes the name of an existing file system object from /old/ to /new/. If the /new/ object already exists, it is replaced by the /old/ object. Neither path may refer to an existing-directory. A conformant implementation need not support renaming files-in all situations (e.g. renaming across different physical devices), but-the constraints must be documented.+directory. +A conformant implementation need not support renaming files in all situations+(e.g. renaming across different physical devices), but the constraints must be+documented. On Windows, this does not support renaming across different physical+devices; if you are looking to do so, consider using 'copyFileWithMetadata' and+'removeFile'.+ On Windows, this calls @MoveFileEx@ with @MOVEFILE_REPLACE_EXISTING@ set, which is not guaranteed to be atomic (<https://github.com/haskell/directory/issues/109>).@@ -723,7 +728,7 @@ -> IO () copyFileToHandle fromFPath hTo = (`ioeAddLocation` "copyFileToHandle") `modifyIOError` do- withBinaryHandle (openFileForRead fromFPath) $ \ hFrom ->+ withBinaryFile fromFPath ReadMode $ \ hFrom -> copyHandleData hFrom hTo -- | Copy the contents of a source file to a destination file, replacing the@@ -746,18 +751,21 @@ -- the temporary file is removed and the destination file remains untouched. withReplacementFile :: OsPath -- ^ Destination file -> (OsPath -> IO ()) -- ^ Post-action- -> (Handle -> IO a) -- ^ Main action+ -> (Handle -> IO a) -- ^ Main action -> IO a withReplacementFile path postAction action = (`ioeAddLocation` "withReplacementFile") `modifyIOError` do mask $ \ restore -> do- -- TODO: AFPP doesn't support openBinaryTempFile yet,- -- so we have to use this (sad) workaround- -- (on unix, converts using filesystem encoding, on windows- -- converts with UTF-16LE)- d <- decodeFS (takeDirectory path)- (tmpFPath', hTmp) <- openBinaryTempFile d ".copyFile.tmp"- tmpFPath <- encodeFS tmpFPath'+ let tmpPath = case encodeWith (mkUTF8 ErrorOnCodingFailure)+ (mkUTF16le ErrorOnCodingFailure)+ ".copyFile.tmp"+ of+ Left err ->+ error ("withReplacementFile: invalid encoding: " <> show err)+ Right p -> p+ let dir = takeDirectory path+ (tmpFPath, hTmp) <-+ openTempFile' "openTempFile'" dir tmpPath True 0o600 True (`onException` ignoreIOExceptions (removeFile tmpFPath)) $ do r <- (`onException` ignoreIOExceptions (hClose hTmp)) $ do restore (action hTmp)@@ -867,7 +875,7 @@ (`ioeSetOsPath` path)) `modifyIOError` do -- simplify does more stuff, like upper-casing the drive letter dropTrailingPathSeparator . simplify <$>- (canonicalizePathWith attemptRealpath =<< prependCurrentDirectory path)+ (attemptRealpath realPath =<< prependCurrentDirectory path) where -- allow up to 64 cycles before giving up@@ -890,7 +898,7 @@ segments = splitDirectories path prefixes = scanl1 (</>) segments- suffixes = tail (scanr (</>) mempty segments)+ suffixes = NE.tail (NE.scanr (</>) mempty segments) -- try to call realpath on the largest possible prefix realpathPrefix candidates =@@ -1135,8 +1143,7 @@ -- @[ENOTDIR]@ -- listDirectory :: OsPath -> IO [OsPath]-listDirectory path = filter f <$> getDirectoryContents path- where f filename = filename /= os "." && filename /= os ".."+listDirectory path = dropSpecialDotDirs <$> getDirectoryContents path -- | Obtain the current working directory as an absolute path. --@@ -1454,6 +1461,9 @@ -- -- * 'isDoesNotExistError' if the file or directory does not exist. --+-- * 'InvalidArgument' on FAT32 file system if the time is before+-- DOS Epoch (1 January 1980).+-- -- Some caveats for POSIX systems: -- -- * Not all systems support @utimensat@, in which case the function can only@@ -1472,7 +1482,7 @@ setFileTimes path (Nothing, Just mtime) setFileTimes :: OsPath -> (Maybe UTCTime, Maybe UTCTime) -> IO ()-setFileTimes _ (Nothing, Nothing) = return ()+setFileTimes _ (Nothing, Nothing) = pure () setFileTimes path (atime, mtime) = ((`ioeAddLocation` "setFileTimes") . (`ioeSetOsPath` path)) `modifyIOError` do@@ -1489,9 +1499,12 @@ On Unix, 'getHomeDirectory' behaves as follows: * Returns $HOME env variable if set (including to an empty string).-* Otherwise uses home directory returned by `getpwuid_r` using the UID of the current proccesses user. This basically reads the /etc/passwd file. An empty home directory field is considered valid.+* Otherwise uses home directory returned by @getpwuid_r@ using the UID of the+ current process' user. This basically reads the @\/etc\/passwd@ file. An+ empty home directory field is considered valid. -On Windows, the system is queried for a suitable path; a typical path might be @C:\/Users\//\<user\>/@.+On Windows, the system is queried for a suitable path; a typical path might be+@C:\/Users\//\<user\>/@. The operation may fail with: @@ -1530,21 +1543,21 @@ -- path, per revised XDG Base Directory Specification. See -- <https://github.com/haskell/directory/issues/100 #100>. getXdgDirectory :: XdgDirectory -- ^ which special directory- -> OsPath -- ^ a relative path that is appended+ -> OsPath -- ^ a relative path that is appended -- to the path; if empty, the base -- path is returned -> IO OsPath getXdgDirectory xdgDir suffix = (`ioeAddLocation` "getXdgDirectory") `modifyIOError` do simplify . (</> suffix) <$> do- env <- lookupEnvOs . os $ case xdgDir of- XdgData -> "XDG_DATA_HOME"- XdgConfig -> "XDG_CONFIG_HOME"- XdgCache -> "XDG_CACHE_HOME"- XdgState -> "XDG_STATE_HOME"+ env <- lookupEnvOs $ case xdgDir of+ XdgData -> os "XDG_DATA_HOME"+ XdgConfig -> os "XDG_CONFIG_HOME"+ XdgCache -> os "XDG_CACHE_HOME"+ XdgState -> os "XDG_STATE_HOME" case env of Just path | isAbsolute path -> pure path- _ -> getXdgDirectoryFallback getHomeDirectory xdgDir+ _ -> getXdgDirectoryFallback getHomeDirectory xdgDir -- | Similar to 'getXdgDirectory' but retrieves the entire list of XDG -- directories.@@ -1557,9 +1570,9 @@ -> IO [OsPath] getXdgDirectoryList xdgDirs = (`ioeAddLocation` "getXdgDirectoryList") `modifyIOError` do- env <- lookupEnvOs . os $ case xdgDirs of- XdgDataDirs -> "XDG_DATA_DIRS"- XdgConfigDirs -> "XDG_CONFIG_DIRS"+ env <- lookupEnvOs $ case xdgDirs of+ XdgDataDirs -> os "XDG_DATA_DIRS"+ XdgConfigDirs -> os "XDG_CONFIG_DIRS" case env of Nothing -> getXdgDirectoryListFallback xdgDirs Just paths -> pure (splitSearchPath paths)@@ -1650,3 +1663,7 @@ -} getTemporaryDirectory :: IO OsPath getTemporaryDirectory = getTemporaryDirectoryInternal++-- | Get the contents of the @PATH@ environment variable.+getExecSearchPath :: IO [OsPath]+getExecSearchPath = getPath
changelog.md view
@@ -1,6 +1,86 @@ Changelog for the [`directory`][1] package ========================================== +## 1.3.11.0 (May 2026)++ * Cabal flag `os-string` was removed in favor of `impl(ghc >= 9.2)`.+ ([#176](https://github.com/haskell/directory/issues/176))+ * Enable close-on-exec flag when copying files and relax `file-io` version+ bounds to support 0.2.0. Note that close-on-exec when copying is only+ enabled on `file-io` 0.2.0 or later.+ ([#203](https://github.com/haskell/directory/issues/203))+ * Relax `time` version bounds to support 1.16.++## 1.3.10.1 (Jan 2026)++ * Make `findExecutable` return `Nothing` on absolute paths that aren't+ executable.+ ([#187](https://github.com/haskell/directory/issues/187))+ * Ensure `removePathForcibly` removes write-protected files on all+ platforms.+ ([#194](https://github.com/haskell/directory/issues/194))++## 1.3.10.0 (Dec 2025)++ * Add `getExecSearchPath` as replacement for+ `System.FilePath.getSearchPath`.+ ([#198](https://github.com/haskell/directory/pull/198))+ * The [extended-length prefix][extended-length prefix] (`\\?\`) is no longer+ implicitly prepended to Windows UNC paths to avoid triggering a Win32+ implementation bug. Clients using long UNC paths should find alternatives+ to [enable long paths][enable long paths].+ ([#206](https://github.com/haskell/directory/issues/206))++[extended-length prefix]: https://learn.microsoft.com/en-us/windows/win32/fileio/maximum-file-path-limitation#:~:text=%5C%5C%3F%5C+[enable long paths]: https://learn.microsoft.com/en-us/windows/win32/fileio/maximum-file-path-limitation#enable-long-paths-in-windows-10-version-1607-and-later++## 1.3.9.0 (Oct 2024)++ * Rely on `file-io` for file I/O.+ * Drop support for `base` older than 4.12.0.+ * Resolve TOCTOU issue with `removeDirectoryRecursive` and+ `removePathForcibly` on POSIX systems.+ (part of [#97](https://github.com/haskell/directory/issues/97))+ * `findExecutable ""` now returns `Nothing`, matching non-Windows systems+ ([#180](https://github.com/haskell/directory/issues/180))++## 1.3.8.5 (May 2024)++ * Fix regression that causes copying of nonexistent files to create empty+ files.+ ([#177](https://github.com/haskell/directory/issues/177))++## 1.3.8.4 (Apr 2024)++ * Relax `time` version bounds to support 1.14.+ ([#171](https://github.com/haskell/directory/issues/171))+ * Relax `base` version bounds to support 4.20.+ ([#173](https://github.com/haskell/directory/issues/173))+ * Relax `filepath` version bounds to support 1.4.300 when `os-string` is+ unavailable.+ ([#175](https://github.com/haskell/directory/issues/175))++## 1.3.8.3 (Jan 2024)++ * Relax `Win32` version bounds to support 2.14.0.0.+ ([#166](https://github.com/haskell/directory/issues/166))+ * Fix regression in `canonicalizePath` on Windows UNC paths.+ ([#170](https://github.com/haskell/directory/issues/170))++## 1.3.8.2 (Dec 2023)++ * Relax `base` version bounds to support 4.19.+ ([#157](https://github.com/haskell/directory/pull/157))+ * Support filepath >= 1.5.0.0 and os-string.+ ([#164](https://github.com/haskell/directory/issues/164))++## 1.3.8.1 (Feb 2023)++ * Use CApiFFI for utimensat.+ ([#145](https://github.com/haskell/directory/pull/145))+ * Relax `base` version bounds to support 4.18.+ ([#151](https://github.com/haskell/directory/pull/151))+ ## 1.3.8.0 (Sep 2022) * Drop support for `base` older than 4.11.0.
− directory.buildinfo
@@ -1,1 +0,0 @@-install-includes: HsDirectoryConfig.h
directory.cabal view
@@ -1,6 +1,7 @@+cabal-version: 2.2 name: directory-version: 1.3.8.0-license: BSD3+version: 1.3.11.0+license: BSD-3-Clause license-file: LICENSE maintainer: libraries@haskell.org bug-reports: https://github.com/haskell/directory/issues@@ -10,8 +11,7 @@ directories in a portable way. category: System build-type: Configure-cabal-version: >= 1.10-tested-with: GHC>=7.4.1+tested-with: GHC == 8.10.7 || == 9.0.2 || == 9.2.4 || == 9.4.3 extra-tmp-files: autom4te.cache@@ -19,16 +19,16 @@ config.status HsDirectoryConfig.h +extra-doc-files:+ README.md+ changelog.md+ extra-source-files: HsDirectoryConfig.h.in- README.md System/Directory/Internal/*.h- changelog.md configure configure.ac- directory.buildinfo tests/*.hs- tests/util.inl source-repository head type: git@@ -36,7 +36,7 @@ Library default-language: Haskell2010- other-extensions: CPP+ other-extensions: CApiFFI, CPP exposed-modules: System.Directory@@ -53,14 +53,20 @@ include-dirs: . build-depends:- base >= 4.11.0 && < 4.18,- time >= 1.8.0 && < 1.13,- filepath >= 1.4.100 && < 1.5+ base >= 4.13.0 && < 4.23,+ file-io >= 0.1.4 && < 0.3,+ time >= 1.8.0 && < 1.17, if os(windows)- build-depends: Win32 >= 2.13.3 && < 2.14+ build-depends: Win32 >= 2.14.1.0 && < 2.15 else build-depends: unix >= 2.8.0 && < 2.9 + if impl(ghc >= 9.2)+ build-depends: filepath >= 1.5.0 && < 1.6,+ os-string >= 2.0.0 && < 2.1,+ else+ build-depends: filepath >= 1.4.100 && < 1.5+ ghc-options: -Wall test-suite test@@ -91,6 +97,7 @@ DoesDirectoryExist001 DoesPathExist FileTime+ FindExecutable FindFile001 GetDirContents001 GetDirContents002
tests/CanonicalizePath.hs view
@@ -1,10 +1,14 @@ {-# LANGUAGE CPP #-} module CanonicalizePath where-#include "util.inl"+import Prelude ()+import System.Directory.Internal.Prelude import System.Directory.Internal+import System.Directory.OsPath+import TestUtils+import Util (TestEnv)+import qualified Util as T import System.OsPath ((</>), dropFileName, dropTrailingPathSeparator, normalise, takeFileName)-import TestUtils main :: TestEnv -> IO () main _t = do@@ -12,10 +16,10 @@ dot2 <- canonicalizePath "." dot3 <- canonicalizePath "./" dot4 <- canonicalizePath "./."- T(expectEq) () dot (dropTrailingPathSeparator dot)- T(expectEq) () dot dot2- T(expectEq) () dot dot3- T(expectEq) () dot dot4+ T.expectEq _t () dot (dropTrailingPathSeparator dot)+ T.expectEq _t () dot dot2+ T.expectEq _t () dot dot3+ T.expectEq _t () dot dot4 writeFile "bar" "" bar <- canonicalizePath "bar"@@ -25,13 +29,13 @@ 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+ T.expectEq _t () bar (normalise (dot </> "bar"))+ T.expectEq _t () bar bar2+ T.expectEq _t () bar bar3+ T.expectEq _t () bar bar4+ T.expectEq _t () bar bar5+ T.expectEq _t () bar bar6+ T.expectEq _t () bar bar7 createDirectory "foo" foo <- canonicalizePath "foo"@@ -40,12 +44,12 @@ 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+ T.expectEq _t () foo (normalise (dot </> "foo"))+ T.expectEq _t () foo foo2+ T.expectEq _t () foo foo3+ T.expectEq _t () foo foo4+ T.expectEq _t () foo foo5+ T.expectEq _t () foo foo6 -- should not fail for non-existent paths fooNon <- canonicalizePath "foo/non-existent"@@ -56,19 +60,19 @@ 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+ T.expectEq _t () fooNon (normalise (foo </> "non-existent"))+ T.expectEq _t () fooNon fooNon2+ T.expectEq _t () fooNon fooNon3+ T.expectEq _t () fooNon fooNon4+ T.expectEq _t () fooNon fooNon5+ T.expectEq _t () fooNon fooNon6+ T.expectEq _t () fooNon fooNon7+ T.expectEq _t () fooNon fooNon8 -- make sure ".." gets expanded properly by 'toExtendedLengthPath' -- (turns out this test won't detect the problem because GetFullPathName -- would expand them for us if we don't, but leaving it here anyway)- T(expectEq) () foo =<< canonicalizePath (foo </> ".." </> "foo")+ T.expectEq _t () foo =<< canonicalizePath (foo </> ".." </> "foo") supportsSymbolicLinks <- supportsSymlinks when supportsSymbolicLinks $ do@@ -78,40 +82,40 @@ -- note: this also checks that "../bar" gets normalized to "..\\bar" -- since Windows does not like "/" in symbolic links targets createFileLink "../bar" "foo/bar"- T(expectEq) () bar =<< canonicalizePath "foo/bar"- T(expectEq) () barQux =<< canonicalizePath "foo/bar/qux"+ T.expectEq _t () bar =<< canonicalizePath "foo/bar"+ T.expectEq _t () barQux =<< canonicalizePath "foo/bar/qux" createDirectoryLink "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"+ T.expectEq _t () foo =<< canonicalizePath "lfoo"+ T.expectEq _t () foo =<< canonicalizePath "lfoo/"+ T.expectEq _t () bar =<< canonicalizePath "lfoo/bar"+ T.expectEq _t () barQux =<< canonicalizePath "lfoo/bar/qux" -- create a haphazard chain of links createDirectoryLink "./../foo/../foo/." "./foo/./somelink3" createDirectoryLink ".././foo/somelink3" "foo/somelink2" createDirectoryLink "./foo/somelink2" "somelink"- T(expectEq) () foo =<< canonicalizePath "somelink"+ T.expectEq _t () foo =<< canonicalizePath "somelink" -- regression test for #64 createFileLink "../foo/non-existent" "foo/qux" removeDirectoryLink "foo/somelink3" -- break the chain made earlier qux <- canonicalizePath "foo/qux"- T(expectEq) () qux =<< canonicalizePath "foo/non-existent"- T(expectEq) () (foo </> "somelink3") =<< canonicalizePath "somelink"+ T.expectEq _t () qux =<< canonicalizePath "foo/non-existent"+ T.expectEq _t () (foo </> "somelink3") =<< canonicalizePath "somelink" -- make sure it can handle loops createFileLink "loop1" "loop2" createFileLink "loop2" "loop1" loop1 <- canonicalizePath "loop1" loop2 <- canonicalizePath "loop2"- T(expectEq) () loop1 (normalise (dot </> "loop1"))- T(expectEq) () loop2 (normalise (dot </> "loop2"))+ T.expectEq _t () loop1 (normalise (dot </> "loop1"))+ T.expectEq _t () loop2 (normalise (dot </> "loop2")) -- make sure ".." gets expanded properly by 'toExtendedLengthPath' createDirectoryLink (foo </> ".." </> "foo") "foolink" _ <- listDirectory "foolink" -- make sure directory is accessible- T(expectEq) () foo =<< canonicalizePath "foolink"+ T.expectEq _t () foo =<< canonicalizePath "foolink" caseInsensitive <- (False <$ createDirectory "FOO")@@ -124,8 +128,8 @@ when caseInsensitive $ do foo7 <- canonicalizePath "FOO" foo8 <- canonicalizePath "FOO/"- T(expectEq) () foo foo7- T(expectEq) () foo foo8+ T.expectEq _t () foo foo7+ T.expectEq _t () foo foo8 fooNon9 <- canonicalizePath "FOO/non-existent" fooNon10 <- canonicalizePath "fOo/non-existent/"@@ -135,28 +139,35 @@ 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 <>- (os (toLower <$> so (takeFileName cfooNon15))))- T(expectEq) () fooNon (dropFileName cfooNon16 <>- (os (toLower <$> so (takeFileName cfooNon16))))- T(expectNe) () fooNon cfooNon15- T(expectNe) () fooNon cfooNon16+ T.expectEq _t () fooNon fooNon9+ T.expectEq _t () fooNon fooNon10+ T.expectEq _t () fooNon fooNon11+ T.expectEq _t () fooNon fooNon12+ T.expectEq _t () fooNon fooNon13+ T.expectEq _t () fooNon fooNon14+ T.expectEq _t () fooNon+ (dropFileName cfooNon15 <> os (toLower <$> so (takeFileName cfooNon15)))+ T.expectEq _t () fooNon+ (dropFileName cfooNon16 <> os (toLower <$> so (takeFileName cfooNon16)))+ T.expectNe _t () fooNon cfooNon15+ T.expectNe _t () fooNon cfooNon16 setCurrentDirectory "foo" foo9 <- canonicalizePath "../FOO" foo10 <- canonicalizePath "../FOO/"- T(expectEq) () foo foo9- T(expectEq) () foo foo10+ T.expectEq _t () foo foo9+ T.expectEq _t () 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+ let isWindows =+#if defined(mingw32_HOST_OS)+ True+#else+ False+#endif++ when isWindows $ do+ -- https://github.com/haskell/directory/issues/170+ T.expectEq _t () "\\\\localhost" =<< canonicalizePath "\\\\localhost"+ -- https://github.com/haskell/directory/issues/206+ T.expectEq _t () "\\\\localhost\\C$" =<<+ canonicalizePath "\\\\localhost\\C$\\.."
tests/CopyFile001.hs view
@@ -1,7 +1,11 @@-{-# LANGUAGE CPP #-} module CopyFile001 where-#include "util.inl"+import Prelude ()+import System.Directory.Internal.Prelude import System.Directory.Internal+import System.Directory.OsPath+import TestUtils ()+import Util (TestEnv)+import qualified Util as T import System.OsPath ((</>)) import qualified Data.List as List @@ -9,10 +13,17 @@ main _t = do createDirectory dir writeFile (so (dir </> from)) contents- T(expectEq) () [from] . List.sort =<< listDirectory dir+ T.expectEq _t () [from] . List.sort =<< listDirectory dir copyFile (dir </> from) (dir </> to)- T(expectEq) () [from, to] . List.sort =<< listDirectory dir- T(expectEq) () contents =<< readFile (so (dir </> to))+ T.expectEq _t () [from, to] . List.sort =<< listDirectory dir+ T.expectEq _t () contents =<< readFile (so (dir </> to))++ -- Regression test for https://github.com/haskell/directory/issues/177+ createDirectory "issue177"+ T.expectIOErrorType _t () isDoesNotExistError+ (copyFile "issue177/nonexistentSrc" "issue177/dst")+ T.expectEq _t () [] =<< listDirectory "issue177"+ where contents = "This is the data\n" from = "source"
tests/CopyFile002.hs view
@@ -1,7 +1,11 @@-{-# LANGUAGE CPP #-} module CopyFile002 where-#include "util.inl"+import Prelude ()+import System.Directory.Internal.Prelude import System.Directory.Internal+import System.Directory.OsPath+import TestUtils ()+import Util (TestEnv)+import qualified Util as T import qualified Data.List as List main :: TestEnv -> IO ()@@ -9,10 +13,10 @@ -- Similar to CopyFile001 but moves a file in the current directory -- (Bug #1652 on GHC Trac) writeFile (so from) contents- T(expectEq) () [from] . List.sort =<< listDirectory "."+ T.expectEq _t () [from] . List.sort =<< listDirectory "." copyFile from to- T(expectEq) () [from, to] . List.sort =<< listDirectory "."- T(expectEq) () contents =<< readFile (so to)+ T.expectEq _t () [from, to] . List.sort =<< listDirectory "."+ T.expectEq _t () contents =<< readFile (so to) where contents = "This is the data\n" from = "source"
tests/CopyFileWithMetadata.hs view
@@ -1,7 +1,11 @@-{-# LANGUAGE CPP #-} module CopyFileWithMetadata where-#include "util.inl"+import Prelude ()+import System.Directory.Internal.Prelude import System.Directory.Internal+import System.Directory.OsPath+import TestUtils ()+import Util (TestEnv)+import qualified Util as T import qualified Data.List as List main :: TestEnv -> IO ()@@ -15,18 +19,18 @@ perm <- getPermissions "a" -- sanity check- T(expectEq) () ["a", "b"] . List.sort =<< listDirectory "."+ T.expectEq _t () ["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"] . List.sort =<< listDirectory "."+ T.expectEq _t () ["a", "b", "c"] . List.sort =<< listDirectory "." for_ ["b", "c"] $ \ f -> do- T(expectEq) f perm =<< getPermissions f- T(expectEq) f mtime =<< getModificationTime f- T(expectEq) f contents =<< readFile (so f)+ T.expectEq _t f perm =<< getPermissions f+ T.expectEq _t f mtime =<< getModificationTime f+ T.expectEq _t f contents =<< readFile (so f) where contents = "This is the data\n"@@ -34,9 +38,9 @@ cleanup = do -- needed to ensure the test runner can clean up our mess- modifyWritable True "a" `catchIOError` \ _ -> return ()- modifyWritable True "b" `catchIOError` \ _ -> return ()- modifyWritable True "c" `catchIOError` \ _ -> return ()+ modifyWritable True "a" `catchIOError` \ _ -> pure ()+ modifyWritable True "b" `catchIOError` \ _ -> pure ()+ modifyWritable True "c" `catchIOError` \ _ -> pure () modifyWritable b f = do perm <- getPermissions f
tests/CreateDirectory001.hs view
@@ -1,9 +1,13 @@-{-# LANGUAGE CPP #-} module CreateDirectory001 where-#include "util.inl"+import Prelude ()+import System.Directory.Internal.Prelude+import System.Directory.OsPath+import TestUtils ()+import Util (TestEnv)+import qualified Util as T main :: TestEnv -> IO () main _t = do createDirectory testdir- T(expectIOErrorType) () isAlreadyExistsError (createDirectory testdir)+ T.expectIOErrorType _t () isAlreadyExistsError (createDirectory testdir) where testdir = "dir"
tests/CreateDirectoryIfMissing001.hs view
@@ -1,8 +1,13 @@ {-# LANGUAGE CPP #-} module CreateDirectoryIfMissing001 where-#include "util.inl"-import Data.Either (lefts)+import Prelude ()+import System.Directory.Internal.Prelude import System.Directory.Internal+import System.Directory.OsPath+import TestUtils ()+import Util (TestEnv)+import qualified Util as T+import Data.Either (lefts) import System.OsPath ((</>), addTrailingPathSeparator) main :: TestEnv -> IO ()@@ -11,7 +16,7 @@ createDirectoryIfMissing False testdir cleanup - T(expectIOErrorType) () isDoesNotExistError $+ T.expectIOErrorType _t () isDoesNotExistError $ createDirectoryIfMissing False testdir_a createDirectoryIfMissing True testdir_a@@ -21,21 +26,21 @@ createDirectoryIfMissing True (addTrailingPathSeparator testdir_a) - T(inform) "testing for race conditions ..."+ T.inform _t "testing for race conditions ..." raceCheck1- T(inform) "testing for race conditions ..."+ T.inform _t "testing for race conditions ..." raceCheck2- T(inform) "done."+ T.inform _t "done." cleanup writeFile (so testdir) (so testdir)- T(expectIOErrorType) () isAlreadyExistsError $+ T.expectIOErrorType _t () isAlreadyExistsError $ createDirectoryIfMissing False testdir removeFile testdir cleanup writeFile (so testdir) (so testdir)- T(expectIOErrorType) () isNotADirectoryError $+ T.expectIOErrorType _t () isNotADirectoryError $ createDirectoryIfMissing True testdir_a removeFile testdir cleanup@@ -47,7 +52,7 @@ testdir = os (testname <> ".d") testdir_a = testdir </> "a" - numRepeats = T.readArg _t testname "num-repeats" 10000+ numRepeats = T.readArg _t testname "num-repeats" 10 numThreads = T.readArg _t testname "num-threads" 4 forkPut mvar action = () <$ forkFinally action (putMVar mvar)@@ -61,18 +66,18 @@ forkPut m $ do replicateM_ numRepeats cleanup results <- replicateM 2 (takeMVar m)- T(expectEq) () [] (show <$> lefts results)+ T.expectEq _t () [] (show <$> lefts results) -- This test fails on Windows (see bug #2924 on GHC Trac): raceCheck2 = do m <- newEmptyMVar- replicateM_ numThreads $+ replicateM_ numThreads $ do forkPut m $ do replicateM_ numRepeats $ do create cleanup results <- replicateM numThreads (takeMVar m)- T(expectEq) () [] (show <$> lefts results)+ T.expectEq _t () [] (show <$> lefts results) -- createDirectoryIfMissing is allowed to fail with isDoesNotExistError if -- another process/thread removes one of the directories during the process@@ -86,10 +91,10 @@ || isPermissionError e || isInappropriateTypeError e || ioeGetErrorType e == InvalidArgument- then return ()+ then pure () else ioError e - cleanup = removeDirectoryRecursive testdir `catchAny` \ _ -> return ()+ cleanup = removeDirectoryRecursive testdir `catchAny` \ _ -> pure () catchAny :: IO a -> (SomeException -> IO a) -> IO a catchAny = catch
tests/CurrentDirectory001.hs view
@@ -1,6 +1,10 @@-{-# LANGUAGE CPP #-} module CurrentDirectory001 where-#include "util.inl"+import Prelude ()+import System.Directory.Internal.Prelude+import System.Directory.OsPath+import TestUtils ()+import Util (TestEnv)+import qualified Util as T import qualified Data.List as List main :: TestEnv -> IO ()@@ -8,6 +12,6 @@ prevDir <- getCurrentDirectory createDirectory "dir" setCurrentDirectory "dir"- T(expectEq) () [".", ".."] . List.sort =<< getDirectoryContents "."+ T.expectEq _t () [".", ".."] . List.sort =<< getDirectoryContents "." setCurrentDirectory prevDir removeDirectory "dir"
tests/Directory001.hs view
@@ -1,6 +1,10 @@-{-# LANGUAGE CPP #-} module Directory001 where-#include "util.inl"+import Prelude ()+import System.Directory.Internal.Prelude+import System.Directory.OsPath+import TestUtils ()+import Util (TestEnv)+import qualified Util as T main :: TestEnv -> IO () main _t = do@@ -10,7 +14,7 @@ renameFile "foo/bar" "foo/baz" renameDirectory "foo" "bar" str' <- readFile "bar/baz"- T(expectEq) () str' str+ T.expectEq _t () str' str removeFile "bar/baz" removeDirectory "bar"
tests/DoesDirectoryExist001.hs view
@@ -1,21 +1,26 @@ {-# LANGUAGE CPP #-} module DoesDirectoryExist001 where-#include "util.inl"+import Prelude ()+import System.Directory.Internal.Prelude+import System.Directory.OsPath+import TestUtils ()+import Util (TestEnv)+import qualified Util as T main :: TestEnv -> IO () main _t = do -- [regression test] "/" was not recognised as a directory prior to GHC 6.1- T(expect) () =<< doesDirectoryExist rootDir+ T.expect _t () =<< doesDirectoryExist rootDir createDirectory "somedir" - T(expect) () . not =<< doesDirectoryExist ""- T(expect) () . not =<< doesDirectoryExist "nonexistent"- T(expect) () =<< doesDirectoryExist "."- T(expect) () =<< doesDirectoryExist "somedir"+ T.expect _t () . not =<< doesDirectoryExist ""+ T.expect _t () . not =<< doesDirectoryExist "nonexistent"+ T.expect _t () =<< doesDirectoryExist "."+ T.expect _t () =<< doesDirectoryExist "somedir" #if defined(mingw32_HOST_OS)- T(expect) () =<< doesDirectoryExist "SoMeDiR"+ T.expect _t () =<< doesDirectoryExist "SoMeDiR" #endif where
tests/DoesPathExist.hs view
@@ -1,28 +1,32 @@ {-# LANGUAGE CPP #-} module DoesPathExist where-#include "util.inl"+import Prelude ()+import System.Directory.Internal.Prelude+import System.Directory.OsPath import TestUtils (supportsSymlinks)+import Util (TestEnv)+import qualified Util as T main :: TestEnv -> IO () main _t = do - T(expect) () =<< doesPathExist rootDir+ T.expect _t () =<< doesPathExist rootDir createDirectory "somedir" writeFile "somefile" "somedata" writeFile "\x3c0\x42f\x97f3\xe6\x221e" "somedata" - T(expect) () . not =<< doesPathExist ""- T(expect) () . not =<< doesPathExist "nonexistent"- T(expect) () =<< doesPathExist "."- T(expect) () =<< doesPathExist "somedir"- T(expect) () =<< doesPathExist "somefile"- T(expect) () =<< doesPathExist "./somefile"+ T.expect _t () . not =<< doesPathExist ""+ T.expect _t () . not =<< doesPathExist "nonexistent"+ T.expect _t () =<< doesPathExist "."+ T.expect _t () =<< doesPathExist "somedir"+ T.expect _t () =<< doesPathExist "somefile"+ T.expect _t () =<< doesPathExist "./somefile" #if defined(mingw32_HOST_OS)- T(expect) () =<< doesPathExist "SoMeDiR"- T(expect) () =<< doesPathExist "sOmEfIlE"+ T.expect _t () =<< doesPathExist "SoMeDiR"+ T.expect _t () =<< doesPathExist "sOmEfIlE" #endif- T(expect) () =<< doesPathExist "\x3c0\x42f\x97f3\xe6\x221e"+ T.expect _t () =<< doesPathExist "\x3c0\x42f\x97f3\xe6\x221e" supportsSymbolicLinks <- supportsSymlinks when supportsSymbolicLinks $ do@@ -31,12 +35,12 @@ createFileLink "somefile" "somefilelink" createFileLink "nonexistent" "nonexistentlink" - T(expect) () =<< doesFileExist "somefilelink"- T(expect) () . not =<< doesDirectoryExist "somefilelink"- T(expect) () =<< doesDirectoryExist "somedirlink"- T(expect) () . not =<< doesFileExist "somedirlink"- T(expect) () . not =<< doesDirectoryExist "nonexistentlink"- T(expect) () . not =<< doesFileExist "nonexistentlink"+ T.expect _t () =<< doesFileExist "somefilelink"+ T.expect _t () . not =<< doesDirectoryExist "somefilelink"+ T.expect _t () =<< doesDirectoryExist "somedirlink"+ T.expect _t () . not =<< doesFileExist "somedirlink"+ T.expect _t () . not =<< doesDirectoryExist "nonexistentlink"+ T.expect _t () . not =<< doesFileExist "nonexistentlink" where #if defined(mingw32_HOST_OS)
tests/FileTime.hs view
@@ -1,6 +1,10 @@-{-# LANGUAGE CPP #-} module FileTime where-#include "util.inl"+import Prelude ()+import System.Directory.Internal.Prelude+import System.Directory.OsPath+import TestUtils ()+import Util (TestEnv)+import qualified Util as T import Data.Time.Clock (addUTCTime, getCurrentTime) main :: TestEnv -> IO ()@@ -9,13 +13,13 @@ let someTimeAgo = addUTCTime (-3600) now someTimeAgo' = addUTCTime (-7200) now - T(expectIOErrorType) () isDoesNotExistError $+ T.expectIOErrorType _t () isDoesNotExistError $ getAccessTime "nonexistent-file"- T(expectIOErrorType) () isDoesNotExistError $+ T.expectIOErrorType _t () isDoesNotExistError $ setAccessTime "nonexistent-file" someTimeAgo- T(expectIOErrorType) () isDoesNotExistError $+ T.expectIOErrorType _t () isDoesNotExistError $ getModificationTime "nonexistent-file"- T(expectIOErrorType) () isDoesNotExistError $+ T.expectIOErrorType _t () isDoesNotExistError $ setModificationTime "nonexistent-file" someTimeAgo writeFile "foo" ""@@ -31,11 +35,11 @@ mtime2 <- getModificationTime file -- modification time should be set with at worst 1 sec resolution- T(expectNearTime) file mtime mtime2 1+ T.expectNearTime _t file mtime mtime2 1 -- access time should not change, although it may lose some precision -- on POSIX systems without 'utimensat'- T(expectNearTime) file atime1 atime2 1+ T.expectNearTime _t file atime1 atime2 1 setAccessTime file atime @@ -44,11 +48,11 @@ when setAtime $ do -- access time should be set with at worst 1 sec resolution- T(expectNearTime) file atime atime3 1+ T.expectNearTime _t file atime atime3 1 -- modification time should not change, although it may lose some precision -- on POSIX systems without 'utimensat'- T(expectNearTime) file mtime2 mtime3 1+ T.expectNearTime _t file mtime2 mtime3 1 where
+ tests/FindExecutable.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE CPP #-}+module FindExecutable where+import Prelude ()+import System.Directory.Internal.Prelude+import System.Directory.OsPath+import TestUtils ()+import Util (TestEnv)+import qualified Util as T++main :: TestEnv -> IO ()+main _t = do++ -- 'find' expected to exist on both Windows and POSIX,+ -- though we have no idea if it's writable+ Just _ <- findExecutable "find"++ T.expectEq _t () Nothing =<<+ findExecutable "__nonexistent_binary_gbowyxcejjawf7r6__"++ -- https://github.com/haskell/directory/issues/187+ T.expectEq _t () Nothing =<< findExecutable "/"+ T.expectEq _t () Nothing =<< findExecutable "//"+#if !defined(mingw32_HOST_OS)+ T.expectEq _t () Nothing =<< findExecutable "\\"+ T.expectEq _t () Nothing =<< findExecutable "\\\\"+ T.expectEq _t () Nothing =<< findExecutable "\\\\localhost\\c$"+#endif
tests/FindFile001.hs view
@@ -1,8 +1,12 @@-{-# LANGUAGE CPP #-} module FindFile001 where-#include "util.inl"-import qualified Data.List as List+import Prelude ()+import System.Directory.Internal.Prelude import System.Directory.Internal+import System.Directory.OsPath+import TestUtils ()+import Util (TestEnv)+import qualified Util as T+import qualified Data.List as List import System.OsPath ((</>)) main :: TestEnv -> IO ()@@ -15,38 +19,40 @@ writeFile (so ("qux" </> "foo")) ":3" -- make sure findFile is lazy enough- T(expectEq) () (Just ("." </> "foo")) =<< findFile ("." : undefined) "foo"+ T.expectEq _t () (Just ("." </> "foo")) =<< findFile ("." : undefined) "foo" -- make sure relative paths work- T(expectEq) () (Just ("." </> "bar" </> "foo")) =<<+ T.expectEq _t () (Just ("." </> "bar" </> "foo")) =<< findFile ["."] ("bar" </> "foo") - T(expectEq) () (Just ("." </> "foo")) =<< findFile [".", "bar"] ("foo")- T(expectEq) () (Just ("bar" </> "foo")) =<< findFile ["bar", "."] ("foo")+ T.expectEq _t () (Just ("." </> "foo")) =<< findFile [".", "bar"] "foo"+ T.expectEq _t () (Just ("bar" </> "foo")) =<< findFile ["bar", "."] "foo" let f fn = (== ":3") <$> readFile (so fn) for_ (List.permutations ["qux", "bar", "."]) $ \ ds -> do let (match, noMatch) = List.partition (== "qux") ds+ match0 : _ <- pure match+ noMatch0 : _ <- pure noMatch - T(expectEq) ds (Just (List.head match </> "foo")) =<<+ T.expectEq _t ds (Just (match0 </> "foo")) =<< findFileWith f ds "foo" - T(expectEq) ds ((</> "foo") <$> match) =<< findFilesWith f ds "foo"+ T.expectEq _t ds ((</> "foo") <$> match) =<< findFilesWith f ds "foo" - T(expectEq) ds (Just (List.head noMatch </> "foo")) =<<+ T.expectEq _t ds (Just (noMatch0 </> "foo")) =<< findFileWith ((not <$>) . f) ds "foo" - T(expectEq) ds ((</> "foo") <$> noMatch) =<<+ T.expectEq _t ds ((</> "foo") <$> noMatch) =<< findFilesWith ((not <$>) . f) ds "foo" - T(expectEq) ds Nothing =<< findFileWith (\ _ -> return False) ds "foo"+ T.expectEq _t ds Nothing =<< findFileWith (\ _ -> pure False) ds "foo" - T(expectEq) ds [] =<< findFilesWith (\ _ -> return False) ds "foo"+ T.expectEq _t ds [] =<< findFilesWith (\ _ -> pure False) ds "foo" -- make sure absolute paths are handled properly irrespective of 'dirs' -- https://github.com/haskell/directory/issues/72 absPath <- makeAbsolute ("bar" </> "foo") absPath2 <- makeAbsolute ("bar" </> "nonexistent")- T(expectEq) () (Just absPath) =<< findFile [] absPath- T(expectEq) () Nothing =<< findFile [] absPath2+ T.expectEq _t () (Just absPath) =<< findFile [] absPath+ T.expectEq _t () Nothing =<< findFile [] absPath2
tests/GetDirContents001.hs view
@@ -1,24 +1,28 @@-{-# LANGUAGE CPP #-} module GetDirContents001 where-#include "util.inl"+import Prelude ()+import System.Directory.Internal.Prelude import System.Directory.Internal+import System.Directory.OsPath+import TestUtils ()+import Util (TestEnv)+import qualified Util as T import System.OsPath ((</>)) import qualified Data.List as List main :: TestEnv -> IO () main _t = do createDirectory dir- T(expectEq) () specials . List.sort =<<+ T.expectEq _t () specials . List.sort =<< getDirectoryContents dir- T(expectEq) () [] . List.sort =<<+ T.expectEq _t () [] . List.sort =<< listDirectory dir names <- for [1 .. 100 :: Int] $ \ i -> do let name = "f" <> os (show i) writeFile (so (dir </> name)) ""- return name- T(expectEq) () (List.sort (specials <> names)) . List.sort =<<+ pure name+ T.expectEq _t () (List.sort (specials <> names)) . List.sort =<< getDirectoryContents dir- T(expectEq) () (List.sort names) . List.sort =<<+ T.expectEq _t () (List.sort names) . List.sort =<< listDirectory dir where dir = "dir" specials = [".", ".."]
tests/GetDirContents002.hs view
@@ -1,8 +1,12 @@-{-# LANGUAGE CPP #-} module GetDirContents002 where-#include "util.inl"+import Prelude ()+import System.Directory.Internal.Prelude+import System.Directory.OsPath+import TestUtils ()+import Util (TestEnv)+import qualified Util as T main :: TestEnv -> IO () main _t = do- T(expectIOErrorType) () isDoesNotExistError $+ T.expectIOErrorType _t () isDoesNotExistError $ getDirectoryContents "nonexistent"
tests/GetFileSize.hs view
@@ -1,6 +1,10 @@-{-# LANGUAGE CPP #-} module GetFileSize where-#include "util.inl"+import Prelude ()+import System.Directory.Internal.Prelude+import System.Directory.OsPath+import TestUtils ()+import Util (TestEnv)+import qualified Util as T main :: TestEnv -> IO () main _t = do@@ -8,8 +12,8 @@ writeFile "emptyfile" "" writeFile "testfile" string - T(expectEq) () 0 =<< getFileSize "emptyfile"- T(expectEq) () (fromIntegral (length string)) =<< getFileSize "testfile"+ T.expectEq _t () 0 =<< getFileSize "emptyfile"+ T.expectEq _t () (fromIntegral (length string)) =<< getFileSize "testfile" where string = "The quick brown fox jumps over the lazy dog."
tests/GetHomeDirectory001.hs view
@@ -1,16 +1,20 @@-{-# LANGUAGE CPP #-} module GetHomeDirectory001 where-#include "util.inl"+import Prelude ()+import System.Directory.Internal.Prelude+import System.Directory.OsPath+import TestUtils ()+import Util (TestEnv)+import qualified Util as T main :: TestEnv -> IO () main _t = do homeDir <- getHomeDirectory- T(expect) () (homeDir /= "") -- sanity check+ T.expect _t () (homeDir /= mempty) -- sanity check _ <- getAppUserDataDirectory "test" _ <- getXdgDirectory XdgCache "test" _ <- getXdgDirectory XdgConfig "test" _ <- getXdgDirectory XdgData "test"- _ <- getXdgDirectory XdgCache "test"+ _ <- getXdgDirectory XdgState "test" _ <- getUserDocumentsDirectory _ <- getTemporaryDirectory- return ()+ pure ()
tests/GetHomeDirectory002.hs view
@@ -4,7 +4,12 @@ #if !defined(mingw32_HOST_OS) import System.Posix.Env #endif-#include "util.inl"+import Prelude ()+import System.Directory.Internal.Prelude+import System.Directory.OsPath+import TestUtils ()+import Util (TestEnv)+import qualified Util as T -- Test that the getpwuid_r fallback works. -- This is only relevant on unix.@@ -14,4 +19,4 @@ unsetEnv "HOME" #endif _ <- getHomeDirectory- T(expect) () True -- avoid warnings about redundant imports+ T.expect _t () True -- avoid warnings about redundant imports
tests/GetPermissions001.hs view
@@ -1,7 +1,10 @@-{-# LANGUAGE CPP #-} module GetPermissions001 where-#include "util.inl"+import Prelude ()+import System.Directory.Internal.Prelude+import System.Directory.OsPath import TestUtils+import Util (TestEnv)+import qualified Util as T main :: TestEnv -> IO () main _t = do@@ -15,15 +18,15 @@ writeFile "foo.txt" "" foo <- makeAbsolute "foo.txt" modifyPermissions "foo.txt" (\ p -> p { writable = False })- T(expect) () =<< not . writable <$> getPermissions "foo.txt"+ T.expect _t () =<< not . writable <$> getPermissions "foo.txt" modifyPermissions "foo.txt" (\ p -> p { writable = True })- T(expect) () =<< writable <$> getPermissions "foo.txt"+ T.expect _t () =<< writable <$> getPermissions "foo.txt" modifyPermissions "foo.txt" (\ p -> p { writable = False })- T(expect) () =<< not . writable <$> getPermissions "foo.txt"+ T.expect _t () =<< not . writable <$> getPermissions "foo.txt" modifyPermissions foo (\ p -> p { writable = True })- T(expect) () =<< writable <$> getPermissions foo+ T.expect _t () =<< writable <$> getPermissions foo modifyPermissions foo (\ p -> p { writable = False })- T(expect) () =<< not . writable <$> getPermissions foo+ T.expect _t () =<< not . writable <$> getPermissions foo -- test empty path modifyPermissions "" id@@ -34,31 +37,31 @@ -- since the current directory is created by the test runner, -- it should be readable, writable, and searchable p <- getPermissions "."- T(expect) () (readable p)- T(expect) () (writable p)- T(expect) () (not (executable p))- T(expect) () (searchable p)+ T.expect _t () (readable p)+ T.expect _t () (writable p)+ T.expect _t () (not (executable p))+ T.expect _t () (searchable p) checkExecutable = do -- 'find' expected to exist on both Windows and POSIX, -- though we have no idea if it's writable Just f <- findExecutable "find" p <- getPermissions f- T(expect) () (readable p)- T(expect) () (executable p)- T(expect) () (not (searchable p))+ T.expect _t () (readable p)+ T.expect _t () (executable p)+ T.expect _t () (not (searchable p)) checkOrdinary = do writeFile "foo" "" p <- getPermissions "foo"- T(expect) () (readable p)- T(expect) () (writable p)- T(expect) () (not (executable p))- T(expect) () (not (searchable p))+ T.expect _t () (readable p)+ T.expect _t () (writable p)+ T.expect _t () (not (executable p))+ T.expect _t () (not (searchable p)) -- [regression test] (issue #9) -- Windows doesn't like trailing path separators checkTrailingSlash = do createDirectory "bar" _ <- getPermissions "bar/"- return ()+ pure ()
tests/LongPaths.hs view
@@ -1,7 +1,10 @@-{-# LANGUAGE CPP #-} module LongPaths where-#include "util.inl"+import Prelude ()+import System.Directory.Internal.Prelude+import System.Directory.OsPath import TestUtils+import Util (TestEnv)+import qualified Util as T import System.OsPath ((</>)) main :: TestEnv -> IO ()@@ -14,9 +17,9 @@ -- tests: [createDirectory] createDirectory =<< makeAbsolute longName createDirectory longDir- return True+ pure True `catchIOError` \ _ ->- return False+ pure False -- skip tests on file systems that do not support long paths when supportsLongPaths $ do@@ -24,10 +27,10 @@ -- test relative paths let relDir = longName </> mconcat (replicate 8 "yeah_its_long") createDirectory relDir- T(expect) () =<< doesDirectoryExist relDir- T(expectEq) () [] =<< listDirectory relDir+ T.expect _t () =<< doesDirectoryExist relDir+ T.expectEq _t () [] =<< listDirectory relDir setPermissions relDir emptyPermissions- T(expectEq) () False =<< writable <$> getPermissions relDir+ T.expectEq _t () False =<< writable <$> getPermissions relDir writeFile "foobar.txt" "^.^" -- writeFile does not support long paths yet @@ -38,13 +41,13 @@ (longDir </> "foobar_copy.txt") -- tests: [doesDirectoryExist], [doesFileExist], [doesPathExist]- T(expect) () =<< doesDirectoryExist longDir- T(expect) () =<< doesFileExist (longDir </> "foobar.txt")- T(expect) () =<< doesPathExist longDir- T(expect) () =<< doesPathExist (longDir </> "foobar.txt")+ T.expect _t () =<< doesDirectoryExist longDir+ T.expect _t () =<< doesFileExist (longDir </> "foobar.txt")+ T.expect _t () =<< doesPathExist longDir+ T.expect _t () =<< doesPathExist (longDir </> "foobar.txt") -- tests: [getFileSize], [getModificationTime]- T(expectEq) () 3 =<< getFileSize (longDir </> "foobar.txt")+ T.expectEq _t () 3 =<< getFileSize (longDir </> "foobar.txt") _ <- getModificationTime (longDir </> "foobar.txt") supportsSymbolicLinks <- supportsSymlinks@@ -54,8 +57,9 @@ -- also tests expansion of "." and ".." createDirectoryLink "." (longDir </> "link") _ <- listDirectory (longDir </> ".." </> longName </> "link")- T(expectEq) () "." =<< getSymbolicLinkTarget (longDir </> "." </> "link")+ T.expectEq _t () "." =<<+ getSymbolicLinkTarget (longDir </> "." </> "link") - return ()+ pure () -- [removeFile], [removeDirectory] are automatically tested by the cleanup
tests/Main.hs view
@@ -11,6 +11,7 @@ import qualified DoesDirectoryExist001 import qualified DoesPathExist import qualified FileTime+import qualified FindExecutable import qualified FindFile001 import qualified GetDirContents001 import qualified GetDirContents002@@ -45,6 +46,7 @@ T.isolatedRun _t "DoesDirectoryExist001" DoesDirectoryExist001.main T.isolatedRun _t "DoesPathExist" DoesPathExist.main T.isolatedRun _t "FileTime" FileTime.main+ T.isolatedRun _t "FindExecutable" FindExecutable.main T.isolatedRun _t "FindFile001" FindFile001.main T.isolatedRun _t "GetDirContents001" GetDirContents001.main T.isolatedRun _t "GetDirContents002" GetDirContents002.main
tests/MakeAbsolute.hs view
@@ -1,6 +1,11 @@ {-# LANGUAGE CPP #-} module MakeAbsolute where-#include "util.inl"+import Prelude ()+import System.Directory.Internal.Prelude+import System.Directory.OsPath+import TestUtils ()+import Util (TestEnv)+import qualified Util as T import System.OsPath ((</>), addTrailingPathSeparator, dropTrailingPathSeparator, normalise) #if defined(mingw32_HOST_OS)@@ -13,35 +18,36 @@ dot <- makeAbsolute "" dot2 <- makeAbsolute "." dot3 <- makeAbsolute "./."- T(expectEq) () dot (dropTrailingPathSeparator dot)- T(expectEq) () dot dot2- T(expectEq) () dot dot3+ T.expectEq _t () dot (dropTrailingPathSeparator dot)+ T.expectEq _t () dot dot2+ T.expectEq _t () dot dot3 sdot <- makeAbsolute "./" sdot2 <- makeAbsolute "././"- T(expectEq) () sdot (addTrailingPathSeparator sdot)- T(expectEq) () sdot sdot2+ T.expectEq _t () sdot (addTrailingPathSeparator sdot)+ T.expectEq _t () 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+ T.expectEq _t () foo (normalise (dot </> "foo"))+ T.expectEq _t () foo foo2+ T.expectEq _t () 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+ T.expectEq _t () sfoo (normalise (dot </> "foo/"))+ T.expectEq _t () sfoo sfoo2+ T.expectEq _t () sfoo sfoo3 #if defined(mingw32_HOST_OS) cwd <- getCurrentDirectory- let driveLetter = toUpper (toChar (head (unpack (takeDrive cwd))))+ cwdDriveLetter : _ <- pure (unpack (takeDrive cwd))+ let driveLetter = toUpper (toChar cwdDriveLetter) let driveLetter' = if driveLetter == 'Z' then 'A' else succ driveLetter drp1 <- makeAbsolute (os (driveLetter : ":foobar")) drp2 <- makeAbsolute (os (driveLetter' : ":foobar"))- T(expectEq) () drp1 =<< makeAbsolute "foobar"- T(expectEq) () drp2 (os (driveLetter' : ":\\foobar"))+ T.expectEq _t () drp1 =<< makeAbsolute "foobar"+ T.expectEq _t () drp2 (os (driveLetter' : ":\\foobar")) #endif
tests/MinimizeNameConflicts.hs view
@@ -8,7 +8,12 @@ , module System.Posix #endif ) where-#include "util.inl"+import Prelude ()+import System.Directory.Internal.Prelude+import System.Directory.OsPath+import TestUtils ()+import Util (TestEnv)+import qualified Util as T #if defined(mingw32_HOST_OS) import System.Win32 hiding ( copyFile@@ -31,4 +36,4 @@ -- https://github.com/haskell/directory/issues/52 main :: TestEnv -> IO () main _t = do- T(expect) ("no-op" :: String) True+ T.expect _t ("no-op" :: String) True
tests/PathIsSymbolicLink.hs view
@@ -1,7 +1,10 @@-{-# LANGUAGE CPP #-} module PathIsSymbolicLink where-#include "util.inl"+import Prelude ()+import System.Directory.Internal.Prelude+import System.Directory.OsPath import TestUtils+import Util (TestEnv)+import qualified Util as T main :: TestEnv -> IO () main _t = do@@ -11,23 +14,23 @@ createFileLink "x" "y" createDirectoryLink "a" "b" - T(expect) () =<< pathIsSymbolicLink "y"- T(expect) () =<< pathIsSymbolicLink "b"- T(expectEq) () "x" =<< getSymbolicLinkTarget "y"- T(expectEq) () "a" =<< getSymbolicLinkTarget "b"- T(expectEq) () False =<< doesFileExist "y"- T(expectEq) () False =<< doesDirectoryExist "b"+ T.expect _t () =<< pathIsSymbolicLink "y"+ T.expect _t () =<< pathIsSymbolicLink "b"+ T.expectEq _t () "x" =<< getSymbolicLinkTarget "y"+ T.expectEq _t () "a" =<< getSymbolicLinkTarget "b"+ T.expectEq _t () False =<< doesFileExist "y"+ T.expectEq _t () False =<< doesDirectoryExist "b" writeFile "x" "" createDirectory "a" - T(expect) () =<< doesFileExist "y"- T(expect) () =<< doesDirectoryExist "b"+ T.expect _t () =<< doesFileExist "y"+ T.expect _t () =<< doesDirectoryExist "b" removeFile "y" removeDirectoryLink "b" - T(expectIOErrorType) () isDoesNotExistError (pathIsSymbolicLink "y")- T(expectIOErrorType) () isDoesNotExistError (pathIsSymbolicLink "b")- T(expectEq) () False =<< doesFileExist "y"- T(expectEq) () False =<< doesDirectoryExist "b"+ T.expectIOErrorType _t () isDoesNotExistError (pathIsSymbolicLink "y")+ T.expectIOErrorType _t () isDoesNotExistError (pathIsSymbolicLink "b")+ T.expectEq _t () False =<< doesFileExist "y"+ T.expectEq _t () False =<< doesDirectoryExist "b"
tests/RemoveDirectoryRecursive001.hs view
@@ -1,10 +1,14 @@ {-# LANGUAGE CPP #-} module RemoveDirectoryRecursive001 where-#include "util.inl"+import Prelude ()+import System.Directory.Internal.Prelude import System.Directory.Internal+import System.Directory.OsPath+import TestUtils (modifyPermissions, symlinkOrCopy)+import Util (TestEnv)+import qualified Util as T import System.OsPath ((</>), normalise) import qualified Data.List as List-import TestUtils (modifyPermissions, symlinkOrCopy) main :: TestEnv -> IO () main _t = do@@ -13,9 +17,9 @@ -- clean up junk from previous invocations modifyPermissions (tmp "c") (\ p -> p { writable = True })- `catchIOError` \ _ -> return ()+ `catchIOError` \ _ -> pure () removeDirectoryRecursive tmpD- `catchIOError` \ _ -> return ()+ `catchIOError` \ _ -> pure () ------------------------------------------------------------ -- set up@@ -35,15 +39,15 @@ ------------------------------------------------------------ -- tests - T(expectEq) () [".", "..", "a", "b", "c", "d"] . List.sort =<<+ T.expectEq _t () [".", "..", "a", "b", "c", "d"] . List.sort =<< getDirectoryContents tmpD- T(expectEq) () [".", "..", "t", "x", "y", "z"] . List.sort =<<+ T.expectEq _t () [".", "..", "t", "x", "y", "z"] . List.sort =<< getDirectoryContents (tmp "a")- T(expectEq) () [".", "..", "g"] . List.sort =<<+ T.expectEq _t () [".", "..", "g"] . List.sort =<< getDirectoryContents (tmp "b")- T(expectEq) () [".", "..", "h"] . List.sort =<<+ T.expectEq _t () [".", "..", "h"] . List.sort =<< getDirectoryContents (tmp "c")- T(expectEq) () [".", "..", "t", "x", "y", "z"] . List.sort =<<+ T.expectEq _t () [".", "..", "t", "x", "y", "z"] . List.sort =<< getDirectoryContents (tmp "d") removeDirectoryRecursive (tmp "d")@@ -52,13 +56,13 @@ `catchIOError` \ _ -> removeDirectory (tmp "d") #endif - T(expectEq) () [".", "..", "a", "b", "c"] . List.sort =<<+ T.expectEq _t () [".", "..", "a", "b", "c"] . List.sort =<< getDirectoryContents tmpD- T(expectEq) () [".", "..", "t", "x", "y", "z"] . List.sort =<<+ T.expectEq _t () [".", "..", "t", "x", "y", "z"] . List.sort =<< getDirectoryContents (tmp "a")- T(expectEq) () [".", "..", "g"] . List.sort =<<+ T.expectEq _t () [".", "..", "g"] . List.sort =<< getDirectoryContents (tmp "b")- T(expectEq) () [".", "..", "h"] . List.sort =<<+ T.expectEq _t () [".", "..", "h"] . List.sort =<< getDirectoryContents (tmp "c") removeDirectoryRecursive (tmp "c")@@ -66,23 +70,23 @@ modifyPermissions (tmp "c") (\ p -> p { writable = True }) removeDirectoryRecursive (tmp "c") - T(expectEq) () [".", "..", "a", "b"] . List.sort =<<+ T.expectEq _t () [".", "..", "a", "b"] . List.sort =<< getDirectoryContents tmpD- T(expectEq) () [".", "..", "t", "x", "y", "z"] . List.sort =<<+ T.expectEq _t () [".", "..", "t", "x", "y", "z"] . List.sort =<< getDirectoryContents (tmp "a")- T(expectEq) () [".", "..", "g"] . List.sort =<<+ T.expectEq _t () [".", "..", "g"] . List.sort =<< getDirectoryContents (tmp "b") removeDirectoryRecursive (tmp "b") - T(expectEq) () [".", "..", "a"] . List.sort =<<+ T.expectEq _t () [".", "..", "a"] . List.sort =<< getDirectoryContents tmpD- T(expectEq) () [".", "..", "t", "x", "y", "z"] . List.sort =<<+ T.expectEq _t () [".", "..", "t", "x", "y", "z"] . List.sort =<< getDirectoryContents (tmp "a") removeDirectoryRecursive (tmp "a") - T(expectEq) () [".", ".."] . List.sort =<<+ T.expectEq _t () [".", ".."] . List.sort =<< getDirectoryContents tmpD where testName = "removeDirectoryRecursive001"
tests/RemovePathForcibly.hs view
@@ -1,10 +1,13 @@-{-# LANGUAGE CPP #-} module RemovePathForcibly where-#include "util.inl"+import Prelude ()+import System.Directory.Internal.Prelude+import System.Directory.OsPath+import TestUtils (hardLinkOrCopy, modifyPermissions, symlinkOrCopy)+import Util (TestEnv)+import qualified Util as T import System.Directory.Internal import System.OsPath ((</>), normalise) import qualified Data.List as List-import TestUtils (hardLinkOrCopy, modifyPermissions, symlinkOrCopy) main :: TestEnv -> IO () main _t = do@@ -13,9 +16,9 @@ -- clean up junk from previous invocations modifyPermissions (tmp "c") (\ p -> p { writable = True })- `catchIOError` \ _ -> return ()+ `catchIOError` \ _ -> pure () removePathForcibly tmpD- `catchIOError` \ _ -> return ()+ `catchIOError` \ _ -> pure () ------------------------------------------------------------ -- set up@@ -41,47 +44,47 @@ removePathForcibly (tmp "f") removePathForcibly (tmp "e") -- intentionally non-existent - T(expectEq) () [".", "..", "a", "b", "c", "d"] . List.sort =<<+ T.expectEq _t () [".", "..", "a", "b", "c", "d"] . List.sort =<< getDirectoryContents tmpD- T(expectEq) () [".", "..", "t", "x", "y", "z"] . List.sort =<<+ T.expectEq _t () [".", "..", "t", "x", "y", "z"] . List.sort =<< getDirectoryContents (tmp "a")- T(expectEq) () [".", "..", "g"] . List.sort =<<+ T.expectEq _t () [".", "..", "g"] . List.sort =<< getDirectoryContents (tmp "b")- T(expectEq) () [".", "..", "h"] . List.sort =<<+ T.expectEq _t () [".", "..", "h"] . List.sort =<< getDirectoryContents (tmp "c")- T(expectEq) () [".", "..", "t", "x", "y", "z"] . List.sort =<<+ T.expectEq _t () [".", "..", "t", "x", "y", "z"] . List.sort =<< getDirectoryContents (tmp "d") removePathForcibly (tmp "d") - T(expectEq) () [".", "..", "a", "b", "c"] . List.sort =<<+ T.expectEq _t () [".", "..", "a", "b", "c"] . List.sort =<< getDirectoryContents tmpD- T(expectEq) () [".", "..", "t", "x", "y", "z"] . List.sort =<<+ T.expectEq _t () [".", "..", "t", "x", "y", "z"] . List.sort =<< getDirectoryContents (tmp "a")- T(expectEq) () [".", "..", "g"] . List.sort =<<+ T.expectEq _t () [".", "..", "g"] . List.sort =<< getDirectoryContents (tmp "b")- T(expectEq) () [".", "..", "h"] . List.sort =<<+ T.expectEq _t () [".", "..", "h"] . List.sort =<< getDirectoryContents (tmp "c") removePathForcibly (tmp "c") - T(expectEq) () [".", "..", "a", "b"] . List.sort =<<+ T.expectEq _t () [".", "..", "a", "b"] . List.sort =<< getDirectoryContents tmpD- T(expectEq) () [".", "..", "t", "x", "y", "z"] . List.sort =<<+ T.expectEq _t () [".", "..", "t", "x", "y", "z"] . List.sort =<< getDirectoryContents (tmp "a")- T(expectEq) () [".", "..", "g"] . List.sort =<<+ T.expectEq _t () [".", "..", "g"] . List.sort =<< getDirectoryContents (tmp "b") removePathForcibly (tmp "b") - T(expectEq) () [".", "..", "a"] . List.sort =<<+ T.expectEq _t () [".", "..", "a"] . List.sort =<< getDirectoryContents tmpD- T(expectEq) () [".", "..", "t", "x", "y", "z"] . List.sort =<<+ T.expectEq _t () [".", "..", "t", "x", "y", "z"] . List.sort =<< getDirectoryContents (tmp "a") removePathForcibly (tmp "a") - T(expectEq) () [".", ".."] . List.sort =<<+ T.expectEq _t () [".", ".."] . List.sort =<< getDirectoryContents tmpD ----------------------------------------------------------------------@@ -92,7 +95,7 @@ origPermissions <- getPermissions "hl1" hardLinkOrCopy "hl1" "hl2" removePathForcibly "hl2"- T(expectEq) () origPermissions =<< getPermissions "hl1"+ T.expectEq _t () origPermissions =<< getPermissions "hl1" where testName = "removePathForcibly" tmpD = testName <> ".tmp"
tests/RenameDirectory.hs view
@@ -1,10 +1,14 @@-{-# LANGUAGE CPP #-} module RenameDirectory where-#include "util.inl"+import Prelude ()+import System.Directory.Internal.Prelude+import System.Directory.OsPath+import TestUtils ()+import Util (TestEnv)+import qualified Util as T main :: TestEnv -> IO () main _t = do createDirectory "a"- T(expectEq) () ["a"] =<< listDirectory "."+ T.expectEq _t () ["a"] =<< listDirectory "." renameDirectory "a" "b"- T(expectEq) () ["b"] =<< listDirectory "."+ T.expectEq _t () ["b"] =<< listDirectory "."
tests/RenameFile001.hs view
@@ -1,16 +1,20 @@-{-# LANGUAGE CPP #-} module RenameFile001 where-#include "util.inl"+import Prelude ()+import System.Directory.Internal.Prelude import System.Directory.Internal+import System.Directory.OsPath+import TestUtils ()+import Util (TestEnv)+import qualified Util as T main :: TestEnv -> IO () main _t = do writeFile tmp1 contents1 renameFile (os tmp1) (os tmp2)- T(expectEq) () contents1 =<< readFile tmp2+ T.expectEq _t () contents1 =<< readFile tmp2 writeFile tmp1 contents2 renameFile (os tmp2) (os tmp1)- T(expectEq) () contents1 =<< readFile tmp1+ T.expectEq _t () contents1 =<< readFile tmp1 where tmp1 = "tmp1" tmp2 = "tmp2"
tests/RenamePath.hs view
@@ -1,22 +1,26 @@-{-# LANGUAGE CPP #-} module RenamePath where-#include "util.inl"+import Prelude ()+import System.Directory.Internal.Prelude import System.Directory.Internal+import System.Directory.OsPath+import TestUtils ()+import Util (TestEnv)+import qualified Util as T main :: TestEnv -> IO () main _t = do createDirectory "a"- T(expectEq) () ["a"] =<< listDirectory "."+ T.expectEq _t () ["a"] =<< listDirectory "." renamePath "a" "b"- T(expectEq) () ["b"] =<< listDirectory "."+ T.expectEq _t () ["b"] =<< listDirectory "." writeFile tmp1 contents1 renamePath (os tmp1) (os tmp2)- T(expectEq) () contents1 =<< readFile tmp2+ T.expectEq _t () contents1 =<< readFile tmp2 writeFile tmp1 contents2 renamePath (os tmp2) (os tmp1)- T(expectEq) () contents1 =<< readFile tmp1+ T.expectEq _t () contents1 =<< readFile tmp1 where tmp1 = "tmp1"
tests/Simplify.hs view
@@ -1,39 +1,44 @@ {-# LANGUAGE CPP #-} module Simplify where-#include "util.inl"+import Prelude ()+import System.Directory.Internal.Prelude import System.Directory.Internal (simplifyWindows)+import System.Directory.OsPath+import TestUtils ()+import Util (TestEnv)+import qualified Util as T import System.OsPath (normalise) main :: TestEnv -> IO () main _t = do- T(expectIOErrorType) () (const True) (setCurrentDirectory "")- T(expectEq) () (simplifyWindows "") ""- T(expectEq) () (simplifyWindows ".") "."- T(expectEq) () (simplifyWindows "a///b") (normalise "a/b")- T(expectEq) () (simplifyWindows "./a//b") (normalise "a/b")- T(expectEq) () (simplifyWindows "a/../../../b/.") (normalise "../../b")- T(expectEq) () (simplifyWindows "a/.././b/./") (normalise "b/")- T(expectEq) () (simplifyWindows "C:/a/../b") (normalise "C:/b")- T(expectEq) () (simplifyWindows "\\\\?\\./a\\../b") "\\\\?\\./a\\../b"- T(expectEq) () (simplifyWindows "C:/a") (normalise "C:/a")- T(expectEq) () (simplifyWindows "/a") (normalise "/a")+ T.expectIOErrorType _t () (const True) (setCurrentDirectory "")+ T.expectEq _t () (simplifyWindows "") ""+ T.expectEq _t () (simplifyWindows ".") "."+ T.expectEq _t () (simplifyWindows "a///b") (normalise "a/b")+ T.expectEq _t () (simplifyWindows "./a//b") (normalise "a/b")+ T.expectEq _t () (simplifyWindows "a/../../../b/.") (normalise "../../b")+ T.expectEq _t () (simplifyWindows "a/.././b/./") (normalise "b/")+ T.expectEq _t () (simplifyWindows "C:/a/../b") (normalise "C:/b")+ T.expectEq _t () (simplifyWindows "\\\\?\\./a\\../b") "\\\\?\\./a\\../b"+ T.expectEq _t () (simplifyWindows "C:/a") (normalise "C:/a")+ T.expectEq _t () (simplifyWindows "/a") (normalise "/a") #ifdef mingw32_HOST_OS- T(expectEq) () (simplifyWindows "C:") "C:"- T(expectEq) () (simplifyWindows "c:\\\\") "C:\\"- T(expectEq) () (simplifyWindows "C:.") "C:"- T(expectEq) () (simplifyWindows "C:.\\\\") "C:.\\"- T(expectEq) () (simplifyWindows "C:..") "C:.."- T(expectEq) () (simplifyWindows "C:..\\") "C:..\\"- T(expectEq) () (simplifyWindows "C:\\.\\") "C:\\"- T(expectEq) () (simplifyWindows "C:\\a") "C:\\a"- T(expectEq) () (simplifyWindows "C:\\a\\\\b\\") "C:\\a\\b\\"- T(expectEq) () (simplifyWindows "\\\\a\\b") "\\\\a\\b"- T(expectEq) () (simplifyWindows "//a\\b/c/./d") "\\\\a\\b\\c\\d"- T(expectEq) () (simplifyWindows "/.") "\\"- T(expectEq) () (simplifyWindows "/./") "\\"- T(expectEq) () (simplifyWindows "/../") "\\"- T(expectEq) () (simplifyWindows "\\a\\.") "\\a"- T(expectEq) () (simplifyWindows "//?") "\\\\?"- T(expectEq) () (simplifyWindows "//?\\") "\\\\?\\"- T(expectEq) () (simplifyWindows "//?/a/b") "\\\\?\\a/b"+ T.expectEq _t () (simplifyWindows "C:") "C:"+ T.expectEq _t () (simplifyWindows "c:\\\\") "C:\\"+ T.expectEq _t () (simplifyWindows "C:.") "C:"+ T.expectEq _t () (simplifyWindows "C:.\\\\") "C:.\\"+ T.expectEq _t () (simplifyWindows "C:..") "C:.."+ T.expectEq _t () (simplifyWindows "C:..\\") "C:..\\"+ T.expectEq _t () (simplifyWindows "C:\\.\\") "C:\\"+ T.expectEq _t () (simplifyWindows "C:\\a") "C:\\a"+ T.expectEq _t () (simplifyWindows "C:\\a\\\\b\\") "C:\\a\\b\\"+ T.expectEq _t () (simplifyWindows "\\\\a\\b") "\\\\a\\b"+ T.expectEq _t () (simplifyWindows "//a\\b/c/./d") "\\\\a\\b/c/./d"+ T.expectEq _t () (simplifyWindows "/.") "\\"+ T.expectEq _t () (simplifyWindows "/./") "\\"+ T.expectEq _t () (simplifyWindows "/../") "\\"+ T.expectEq _t () (simplifyWindows "\\a\\.") "\\a"+ T.expectEq _t () (simplifyWindows "//?") "\\\\?"+ T.expectEq _t () (simplifyWindows "//?\\") "\\\\?\\"+ T.expectEq _t () (simplifyWindows "//?/a/b") "\\\\?\\a/b" #endif
tests/T8482.hs view
@@ -1,7 +1,11 @@-{-# LANGUAGE CPP #-} module T8482 where-#include "util.inl"+import Prelude ()+import System.Directory.Internal.Prelude import System.Directory.Internal+import System.Directory.OsPath+import TestUtils ()+import Util (TestEnv)+import qualified Util as T tmp1 :: OsPath tmp1 = "T8482.tmp1"@@ -13,7 +17,7 @@ main _t = do writeFile (so tmp1) "hello" createDirectory testdir- T(expectIOErrorType) () (is InappropriateType) (renameFile testdir tmp1)- T(expectIOErrorType) () (is InappropriateType) (renameFile tmp1 testdir)- T(expectIOErrorType) () (is InappropriateType) (renameFile tmp1 ".")+ T.expectIOErrorType _t () (is InappropriateType) (renameFile testdir tmp1)+ T.expectIOErrorType _t () (is InappropriateType) (renameFile tmp1 testdir)+ T.expectIOErrorType _t () (is InappropriateType) (renameFile tmp1 ".") where is t = (== t) . ioeGetErrorType
tests/TestUtils.hs view
@@ -80,7 +80,7 @@ supportsSymlinks = do canCreate <- supportsLinkCreation canDeref <- supportsLinkDeref- return (canCreate && canDeref)+ pure (canCreate && canDeref) -- | On Windows, test if symbolic link creation is supported and the user has -- the necessary privileges to create them. On other platforms, this always@@ -88,11 +88,11 @@ supportsLinkCreation :: IO Bool supportsLinkCreation = do let path = os "_symlink_test.tmp"- isSupported <- handleSymlinkUnavail (return False) $ do+ isSupported <- handleSymlinkUnavail (pure False) $ do True <$ createFileLink path path when isSupported $ do removeFile path- return isSupported+ pure isSupported supportsLinkDeref :: IO Bool supportsLinkDeref = do@@ -100,10 +100,10 @@ True <$ win32_getFinalPathNameByHandle Win32.nullHANDLE 0 `catchIOError` \ e -> case ioeGetErrorType e of- UnsupportedOperation -> return False- _ -> return True+ UnsupportedOperation -> pure False+ _ -> pure True #else- return True+ pure True #endif instance IsString OsString where
tests/Util.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-} -- | A rudimentary testing framework module Util where import Prelude ()@@ -7,6 +6,8 @@ import System.Directory.Internal import System.Directory.OsPath import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime)+import GHC.Stack (CallStack, HasCallStack, callStack, getCallStack, srcLocFile,+ srcLocStartLine) import System.Environment (getEnvironment, setEnv, unsetEnv) import System.OsPath ((</>), decodeFS, encodeFS, normalise) import qualified Data.List as List@@ -28,7 +29,7 @@ result <- timeout (round (1000000 * time)) action case result of Nothing -> throwIO (userError "timed out")- Just x -> return x+ Just x -> pure x data TestEnv = TestEnv@@ -39,7 +40,7 @@ } printInfo :: TestEnv -> [String] -> IO ()-printInfo TestEnv{testSilent = True} _ = return ()+printInfo TestEnv{testSilent = True} _ = pure () printInfo TestEnv{testSilent = False} msg = do putStrLn (List.intercalate ": " msg) hFlush stdout@@ -62,63 +63,66 @@ checkEither t prefix (Right msg) = printInfo t (prefix <> msg) checkEither t prefix (Left msg) = printFailure t (prefix <> msg) -showContext :: Show a => String -> Integer -> a -> String-showContext file line context =- file <> ":" <> show line <>+showContext :: Show a => CallStack -> a -> String+showContext stack context =+ case getCallStack stack of+ (_, l) : _ -> srcLocFile l <> ":" <> show (srcLocStartLine l)+ [] -> "<unknown caller>"+ <> case show context of "()" -> "" s -> ":" <> s -inform :: TestEnv -> String -> Integer -> String -> IO ()-inform t file line msg =- printInfo t [showContext file line (), msg]+inform :: HasCallStack => TestEnv -> String -> IO ()+inform t msg =+ printInfo t [showContext callStack (), msg] -expect :: Show a => TestEnv -> String -> Integer -> a -> Bool -> IO ()-expect t file line context x =++expect :: (HasCallStack, Show a) => TestEnv -> a -> Bool -> IO ()+expect t context x = check t x- [showContext file line context]+ [showContext callStack context] ["True"] ["False, but True was expected"] -expectEq :: (Eq a, Show a, Show b) =>- TestEnv -> String -> Integer -> b -> a -> a -> IO ()-expectEq t file line context x y =+expectEq :: (HasCallStack, Eq a, Show a, Show b) =>+ TestEnv -> b -> a -> a -> IO ()+expectEq t context x y = check t (x == y)- [showContext file line context]+ [showContext callStack context] [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 =+expectNe :: (HasCallStack, Eq a, Show a, Show b) =>+ TestEnv -> b -> a -> a -> IO ()+expectNe t context x y = check t (x /= y)- [showContext file line context]+ [showContext callStack 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 =+expectNear :: (HasCallStack, Num a, Ord a, Show a, Show b) =>+ TestEnv -> b -> a -> a -> a -> IO ()+expectNear t context x y diff = check t (abs (x - y) <= diff)- [showContext file line context]+ [showContext callStack context] [show x <> " is near " <> show y] [show x <> " is not near " <> show y] -expectNearTime :: Show a =>- TestEnv -> String -> Integer -> a ->+expectNearTime :: (HasCallStack, Show a) =>+ TestEnv -> a -> UTCTime -> UTCTime -> NominalDiffTime -> IO ()-expectNearTime t file line context x y diff =+expectNearTime t context x y diff = check t (abs (diffUTCTime x y) <= diff)- [showContext file line context]+ [showContext callStack context] [show x <> " is near " <> show y] [show x <> " is not near " <> show y] -expectIOErrorType :: Show a =>- TestEnv -> String -> Integer -> a- -> (IOError -> Bool) -> IO b -> IO ()-expectIOErrorType t file line context which action = do+expectIOErrorType :: (HasCallStack, Show a) =>+ TestEnv -> a -> (IOError -> Bool) -> IO b -> IO ()+expectIOErrorType t context which action = do result <- try action- checkEither t [showContext file line context] $ case result of+ checkEither t [showContext callStack context] $ case result of Left e | which e -> Right ["got expected exception (" <> show e <> ")"] | otherwise -> Left ["got wrong exception: ", show e] Right _ -> Left ["did not throw an exception"]@@ -141,29 +145,57 @@ withNewDirectory keep dir action = do dir' <- makeAbsolute dir bracket_ (createDirectoryIfMissing True dir') (cleanup dir') action- where cleanup dir' | keep = return ()+ where cleanup dir' | keep = pure () | otherwise = removePathForcibly dir' +diffAsc' :: (j -> k -> Ordering)+ -> (u -> v -> Bool)+ -> [(j, u)]+ -> [(k, v)]+ -> ([(j, u)], [(k, v)])+diffAsc' cmp eq = go id id+ where+ go a b [] [] = (a [], b [])+ go a b jus [] = go (a . (jus <>)) b [] []+ go a b [] kvs = go a (b . (kvs <>)) [] []+ go a b jus@((j, u) : jus') kvs@((k, v) : kvs') =+ case cmp j k of+ LT -> go (a . ((j, u) :)) b jus' kvs+ GT -> go a (b . ((k, v) :)) jus kvs'+ EQ | eq u v -> go a b jus' kvs'+ | otherwise -> go (a . ((j, u) :)) (b . ((k, v) :)) jus' kvs'++diffAsc :: (Ord k, Eq v) => [(k, v)] -> [(k, v)] -> ([(k, v)], [(k, v)])+diffAsc = diffAsc' compare (==)++-- Environment variables may be sensitive, so don't log their values.+scrubEnv :: (String, String) -> (String, String)+scrubEnv (k, v)+ -- Allowlist for nonsensitive variables.+ | k `elem` ["XDG_CONFIG_HOME"] = (k, v)+ | otherwise = (k, "<" <> show (length v) <> " chars>")+ isolateEnvironment :: IO a -> IO a isolateEnvironment = bracket getEnvs setEnvs . const where- getEnvs = List.sort . filter (\(k, _) -> k /= "") <$> getEnvironment+ -- Duplicate environment variables will cause problems for this code.+ -- https://github.com/haskell/cabal/issues/10718+ getEnvs = List.sort . filter (\(k, _) -> not (null k)) <$> getEnvironment setEnvs target = do current <- getEnvs- updateEnvs current target+ let (deletions, insertions) = diffAsc current target+ updateEnvs deletions insertions new <- getEnvs when (target /= new) $ do- -- Environment variables may be sensitive, so don't log them.- throwIO (userError "isolateEnvironment.setEnvs failed")- updateEnvs kvs1@((k1, v1) : kvs1') kvs2@((k2, v2) : kvs2') =- case compare k1 k2 of- LT -> unsetEnv k1 *> updateEnvs kvs1' kvs2- EQ | v1 == v2 -> updateEnvs kvs1' kvs2'- | otherwise -> setEnv k1 v2 *> updateEnvs kvs1' kvs2'- GT -> setEnv k2 v2 *> updateEnvs kvs1 kvs2'- updateEnvs [] [] = pure ()- updateEnvs kvs1 [] = for_ kvs1 (unsetEnv . fst)- updateEnvs [] kvs2 = for_ kvs2 (uncurry setEnv)+ let (missing, extraneous) = diffAsc target new+ throwIO (userError ("isolateEnvironment.setEnvs failed:" <>+ " deletions=" <> show (scrubEnv <$> deletions) <>+ " insertions=" <> show (scrubEnv <$> insertions) <>+ " missing=" <> show (scrubEnv <$> missing) <>+ " extraneous=" <> show (scrubEnv <$> extraneous)))+ updateEnvs deletions insertions = do+ for_ deletions (unsetEnv . fst)+ for_ insertions (uncurry setEnv) isolateWorkingDirectory :: Bool -> OsPath -> IO a -> IO a isolateWorkingDirectory keep dir action = do@@ -173,8 +205,8 @@ "with current directory")) dir' <- makeAbsolute dir removePathForcibly dir'- withNewDirectory keep dir' $- withCurrentDirectory dir' $+ withNewDirectory keep dir' $ do+ withCurrentDirectory dir' $ do action run :: TestEnv -> String -> (TestEnv -> IO ()) -> IO ()@@ -182,11 +214,11 @@ result <- tryAny (action t) case result of Left e -> check t False [name] [] ["exception", show e]- Right () -> return ()+ Right () -> pure () isolatedRun :: TestEnv -> String -> (TestEnv -> IO ()) -> IO () isolatedRun t@TestEnv{testKeepDirs = keep} name action = do- workDir <- encodeFS ("dist/test-" <> name <> ".tmp")+ workDir <- encodeFS ("dist-newstyle/tmp/test-" <> name <> ".tmp") run t name (isolate workDir . action) where isolate workDir = isolateEnvironment . isolateWorkingDirectory keep workDir@@ -227,7 +259,7 @@ , testArgs = args } action t- n <- readIORef (counter)+ n <- readIORef counter unless (n == 0) $ do putStrLn ("[" <> show n <> " failures]") hFlush stdout
tests/WithCurrentDirectory.hs view
@@ -1,7 +1,11 @@-{-# LANGUAGE CPP #-} module WithCurrentDirectory where-#include "util.inl"+import Prelude ()+import System.Directory.Internal.Prelude import System.Directory.Internal+import System.Directory.OsPath+import TestUtils ()+import Util (TestEnv)+import qualified Util as T import System.OsPath ((</>)) import qualified Data.List as List @@ -9,15 +13,15 @@ main _t = do createDirectory dir -- Make sure we're starting empty- T(expectEq) () [] . List.sort =<< listDirectory dir+ T.expectEq _t () [] . List.sort =<< listDirectory dir cwd <- getCurrentDirectory withCurrentDirectory dir (writeFile (so testfile) contents) -- Are we still in original directory?- T(expectEq) () cwd =<< getCurrentDirectory+ T.expectEq _t () cwd =<< getCurrentDirectory -- Did the test file get created?- T(expectEq) () [testfile] . List.sort =<< listDirectory dir+ T.expectEq _t () [testfile] . List.sort =<< listDirectory dir -- Does the file contain what we expected to write?- T(expectEq) () contents =<< readFile (so (dir </> testfile))+ T.expectEq _t () contents =<< readFile (so (dir </> testfile)) where testfile = "testfile" contents = "some data\n"
tests/Xdg.hs view
@@ -1,12 +1,17 @@ {-# LANGUAGE CPP #-} module Xdg where+import Prelude ()+import System.Directory.Internal.Prelude+import System.Directory.OsPath+import TestUtils ()+import Util (TestEnv)+import qualified Util as T import qualified Data.List as List import System.Environment (setEnv, unsetEnv) import System.FilePath (searchPathSeparator) #if !defined(mingw32_HOST_OS) import System.OsPath ((</>)) #endif-#include "util.inl" main :: TestEnv -> IO () main _t = do@@ -15,13 +20,13 @@ _ <- getXdgDirectoryList XdgDataDirs _ <- getXdgDirectoryList XdgConfigDirs - T(expect) () True -- avoid warnings about redundant imports+ T.expect _t () True -- avoid warnings about redundant imports -- setEnv, unsetEnv require base 4.7.0.0+ #if !defined(mingw32_HOST_OS) unsetEnv "XDG_CONFIG_HOME" home <- getHomeDirectory- T(expectEq) () (home </> ".config/mow") =<< getXdgDirectory XdgConfig "mow"+ T.expectEq _t () (home </> ".config/mow") =<< getXdgDirectory XdgConfig "mow" #endif -- unset variables, so env doesn't affect test running@@ -39,10 +44,10 @@ setEnv "XDG_CONFIG_HOME" "aw" setEnv "XDG_CACHE_HOME" "ba" setEnv "XDG_STATE_HOME" "uw"- T(expectEq) () xdgData =<< getXdgDirectory XdgData "ff"- T(expectEq) () xdgConfig =<< getXdgDirectory XdgConfig "oo"- T(expectEq) () xdgCache =<< getXdgDirectory XdgCache "rk"- T(expectEq) () xdgState =<< getXdgDirectory XdgState "aa"+ T.expectEq _t () xdgData =<< getXdgDirectory XdgData "ff"+ T.expectEq _t () xdgConfig =<< getXdgDirectory XdgConfig "oo"+ T.expectEq _t () xdgCache =<< getXdgDirectory XdgCache "rk"+ T.expectEq _t () xdgState =<< getXdgDirectory XdgState "aa" unsetEnv "XDG_CONFIG_DIRS" unsetEnv "XDG_DATA_DIRS"@@ -50,13 +55,11 @@ _xdgDataDirs <- getXdgDirectoryList XdgDataDirs #if !defined(mingw32_HOST_OS)- T(expectEq) () ["/etc/xdg"] _xdgConfigDirs- T(expectEq) () ["/usr/local/share/", "/usr/share/"] _xdgDataDirs+ T.expectEq _t () ["/etc/xdg"] _xdgConfigDirs+ T.expectEq _t () ["/usr/local/share/", "/usr/share/"] _xdgDataDirs #endif setEnv "XDG_DATA_DIRS" (List.intercalate [searchPathSeparator] ["/a", "/b"]) setEnv "XDG_CONFIG_DIRS" (List.intercalate [searchPathSeparator] ["/c", "/d"])- T(expectEq) () ["/a", "/b"] =<< getXdgDirectoryList XdgDataDirs- T(expectEq) () ["/c", "/d"] =<< getXdgDirectoryList XdgConfigDirs-- return ()+ T.expectEq _t () ["/a", "/b"] =<< getXdgDirectoryList XdgDataDirs+ T.expectEq _t () ["/c", "/d"] =<< getXdgDirectoryList XdgConfigDirs
− tests/util.inl
@@ -1,10 +0,0 @@-#define T(f) (T.f _t __FILE__ __LINE__)--import Prelude ()-import System.Directory.Internal.Prelude-import System.Directory.OsPath-import TestUtils ()-import Util (TestEnv)-import qualified Util as T--- This comment prevents "T" above from being treated as the function-like--- macro defined earlier.