diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,23 @@ +`directory` [![Hackage][1]][2] [![Build Status][3]][4] +=========== + +Documentation can be found on [Hackage][2]. + +Building from Git repository +---------------------------- + +When building this package directly from the Git repository, one must run +`autoreconf -i` to generate the `configure` script needed by `cabal +configure`. This requires [Autoconf][5] to be installed. + + autoreconf -i + cabal install + +There is no need to run the `configure` script manually however, as `cabal +configure` does that automatically. + +[1]: https://img.shields.io/hackage/v/directory.svg +[2]: https://hackage.haskell.org/package/directory +[3]: https://travis-ci.org/haskell/directory.svg?branch=master +[4]: https://travis-ci.org/haskell/directory +[5]: https://gnu.org/software/autoconf diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -3,4 +3,4 @@ import Distribution.Simple main :: IO () -main = defaultMainWithHooks defaultUserHooks +main = defaultMainWithHooks autoconfUserHooks diff --git a/System/Directory.hs b/System/Directory.hs --- a/System/Directory.hs +++ b/System/Directory.hs @@ -44,8 +44,10 @@ , copyFile , canonicalizePath + , makeAbsolute , makeRelativeToCurrentDirectory , findExecutable + , findExecutables , findFile , findFiles , findFilesWith @@ -95,8 +97,8 @@ import Data.Maybe -import Data.Time -import Data.Time.Clock.POSIX +import Data.Time ( UTCTime ) +import Data.Time.Clock.POSIX ( posixSecondsToUTCTime ) #ifdef __GLASGOW_HASKELL__ @@ -196,7 +198,8 @@ getPermissions :: FilePath -> IO Permissions getPermissions name = do #ifdef mingw32_HOST_OS - withFilePath name $ \s -> do + -- issue #9: Windows doesn't like trailing path separators + withFilePath (dropTrailingPathSeparator name) $ \s -> do -- stat() does a better job of guessing the permissions on Windows -- than access() does. e.g. for execute permission, it looks at the -- filename extension :-) @@ -366,11 +369,11 @@ parents = reverse . scanl1 () . splitDirectories . normalise createDirs [] = return () - createDirs (dir:[]) = createDir dir throw + createDirs (dir:[]) = createDir dir throwIO createDirs (dir:dirs) = createDir dir $ \_ -> do createDirs dirs - createDir dir throw + createDir dir throwIO createDir :: FilePath -> (IOException -> IO ()) -> IO () createDir dir notExistHandler = do @@ -393,22 +396,45 @@ -- This caused GHCi to crash when loading a module in the root -- directory. | isAlreadyExistsError e - || isPermissionError e -> (do + || isPermissionError e -> do #ifdef mingw32_HOST_OS - withFileStatus "createDirectoryIfMissing" dir $ \st -> do - isDir <- isDirectory st - if isDir then return () - else throw e + canIgnore <- (withFileStatus "createDirectoryIfMissing" dir isDirectory) #else - stat <- Posix.getFileStatus dir - if Posix.isDirectory stat - then return () - else throw e + canIgnore <- (Posix.isDirectory `fmap` Posix.getFileStatus dir) #endif - ) `E.catch` ((\_ -> return ()) :: IOException -> IO ()) - | otherwise -> throw e + `E.catch` ((\ _ -> return (isAlreadyExistsError e)) + :: IOException -> IO Bool) + unless canIgnore (throwIO e) + | otherwise -> throwIO e #if __GLASGOW_HASKELL__ + +-- | * @'NotDirectory'@: not a directory. +-- * @'Directory'@: a true directory (not a symbolic link). +-- * @'DirectoryLink'@: a directory symbolic link (only exists on Windows). +data DirectoryType = NotDirectory + | Directory + | DirectoryLink + deriving (Enum, Eq, Ord, Read, Show) + +-- | Obtain the type of a directory. +getDirectoryType :: FilePath -> IO DirectoryType +getDirectoryType path = + (`ioeSetLocation` "getDirectoryType") `modifyIOError` do +#ifdef mingw32_HOST_OS + fmap classify (Win32.getFileAttributes path) + where fILE_ATTRIBUTE_REPARSE_POINT = 0x400 + classify attr + | attr .&. Win32.fILE_ATTRIBUTE_DIRECTORY == 0 = NotDirectory + | attr .&. fILE_ATTRIBUTE_REPARSE_POINT == 0 = Directory + | otherwise = DirectoryLink +#else + stat <- Posix.getSymbolicLinkStatus path + return $ if Posix.isDirectory stat + then Directory + else NotDirectory +#endif + {- | @'removeDirectory' dir@ removes an existing directory /dir/. The implementation may specify additional constraints which must be satisfied before a directory can be removed (e.g. the directory has to @@ -460,24 +486,40 @@ #endif --- | @'removeDirectoryRecursive' dir@ removes an existing directory /dir/ --- together with its content and all subdirectories. Be careful, --- if the directory contains symlinks, the function will follow them. +-- | @'removeDirectoryRecursive' dir@ removes an existing directory /dir/ +-- together with its contents and subdirectories. Symbolic links are removed +-- without affecting their the targets. removeDirectoryRecursive :: FilePath -> IO () -removeDirectoryRecursive startLoc = do - cont <- getDirectoryContents startLoc - sequence_ [rm (startLoc x) | x <- cont, x /= "." && x /= ".."] - removeDirectory startLoc - where - rm :: FilePath -> IO () - rm f = do temp <- E.try (removeFile f) - case temp of - Left e -> do isDir <- doesDirectoryExist f - -- If f is not a directory, re-throw the error - unless isDir $ throw (e :: SomeException) - removeDirectoryRecursive f - Right _ -> return () +removeDirectoryRecursive path = + (`ioeSetLocation` "removeDirectoryRecursive") `modifyIOError` do + dirType <- getDirectoryType path + case dirType of + Directory -> removeContentsRecursive path + _ -> ioError . (`ioeSetErrorString` "not a directory") $ + mkIOError InappropriateType "" Nothing (Just 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. +removePathRecursive :: FilePath -> IO () +removePathRecursive path = + (`ioeSetLocation` "removePathRecursive") `modifyIOError` do + dirType <- getDirectoryType path + case dirType of + NotDirectory -> removeFile path + Directory -> removeContentsRecursive path + DirectoryLink -> removeDirectory path + +-- | @'removeContentsRecursive' dir@ removes the contents of the directory +-- /dir/ recursively. Symbolic links are removed without affecting their the +-- targets. +removeContentsRecursive :: FilePath -> IO () +removeContentsRecursive path = + (`ioeSetLocation` "removeContentsRecursive") `modifyIOError` do + cont <- getDirectoryContents path + mapM_ removePathRecursive [path x | x <- cont, x /= "." && x /= ".."] + removeDirectory path + #if __GLASGOW_HASKELL__ {- |'removeFile' /file/ removes the directory entry for an existing file /file/, where /file/ is not itself a directory. The @@ -637,26 +679,32 @@ -} renameFile :: FilePath -> FilePath -> IO () -renameFile opath npath = do - -- XXX this test isn't performed atomically with the following rename -#ifdef mingw32_HOST_OS - -- ToDo: use Win32 API - withFileOrSymlinkStatus "renameFile" opath $ \st -> do - is_dir <- isDirectory st -#else - stat <- Posix.getSymbolicLinkStatus opath - let is_dir = Posix.isDirectory stat -#endif - if is_dir - then ioError (ioeSetErrorString - (mkIOError InappropriateType "renameFile" Nothing (Just opath)) - "is a directory") - else do +renameFile opath npath = (`ioeSetLocation` "renameFile") `modifyIOError` do + -- XXX the tests are not performed atomically with the rename + checkNotDir opath #ifdef mingw32_HOST_OS Win32.moveFileEx opath npath Win32.mOVEFILE_REPLACE_EXISTING #else Posix.rename opath npath #endif + -- The underlying rename implementation can throw odd exceptions when the + -- destination is a directory. For example, Windows typically throws a + -- permission error, while POSIX systems may throw a resource busy error + -- if one of the paths refers to the current directory. In these cases, + -- we check if the destination is a directory and, if so, throw an + -- InappropriateType error. + `catchIOError` \ err -> do + checkNotDir npath + ioError err + where checkNotDir path = do + dirType <- getDirectoryType path + `catchIOError` \ _ -> return NotDirectory + case dirType of + Directory -> errIsDir path + DirectoryLink -> errIsDir path + NotDirectory -> return () + errIsDir path = ioError . (`ioeSetErrorString` "is a directory") $ + mkIOError InappropriateType "" Nothing (Just path) #endif /* __GLASGOW_HASKELL__ */ @@ -668,7 +716,7 @@ copyFile :: FilePath -> FilePath -> IO () copyFile fromFPath toFPath = - copy `catchIOError` (\exc -> throw $ ioeSetLocation exc "copyFile") + copy `catchIOError` (\exc -> throwIO $ ioeSetLocation exc "copyFile") where copy = bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom -> bracketOnError openTmp cleanTmp $ \(tmpFPath, hTmp) -> do allocaBytes bufferSize $ copyContents hFrom hTmp @@ -689,22 +737,29 @@ ignoreIOExceptions io = io `catchIOError` (\_ -> return ()) --- | Given a path referring to a file or directory, returns a --- canonicalized path. The intent is that two paths referring --- to the same file\/directory will map to the same canonicalized --- path. +-- | Canonicalize the path of an existing file or directory. The intent is +-- that two paths referring to the same file\/directory will map to the same +-- canonicalized path. -- --- Note that it is impossible to guarantee that the --- implication (same file\/dir \<=\> same canonicalizedPath) holds --- in either direction: this function can make only a best-effort --- attempt. +-- __Note__: if you only require an absolute path, consider using +-- @'makeAbsolute'@ instead, which is more reliable and does not have +-- unspecified behavior on nonexistent paths. -- --- The precise behaviour is that of the C realpath function --- GetFullPathNameW on Windows). In particular, the behaviour --- on paths that do not exist is known to vary from platform --- to platform. Some platforms do not alter the input, some --- do, and on some an exception will be thrown. +-- It is impossible to guarantee that the implication (same file\/dir \<=\> +-- same canonicalized path) holds in either direction: this function can make +-- only a best-effort attempt. +-- +-- The precise behaviour is that of the POSIX @realpath@ function (or +-- @GetFullPathNameW@ on Windows). In particular, the behaviour on paths that +-- don't exist can vary from platform to platform. Some platforms do not +-- alter the input, some do, and some throw an exception. +-- +-- An empty path is considered to be equivalent to the current directory. +-- +-- /Known bug(s)/: on Windows, this function does not resolve symbolic links. +-- canonicalizePath :: FilePath -> IO FilePath +canonicalizePath "" = canonicalizePath "." canonicalizePath fpath = #if defined(mingw32_HOST_OS) do path <- Win32.getFullPathName fpath @@ -713,6 +768,7 @@ GHC.withCString enc fpath $ \pInPath -> allocaBytes long_path_size $ \pOutPath -> do _ <- throwErrnoPathIfNull "canonicalizePath" fpath $ c_realpath pInPath pOutPath + -- NB: pOutPath will be passed thru as result pointer by c_realpath path <- GHC.peekCString enc pOutPath #endif @@ -726,6 +782,18 @@ -> IO CString #endif +-- | Make a path absolute by prepending the current directory (if it isn't +-- already absolute) and applying @'normalise'@ to the result. +-- +-- The operation may fail with the same exceptions as @'getCurrentDirectory'@. +-- +-- /Since: 1.2.2.0/ +makeAbsolute :: FilePath -> IO FilePath +makeAbsolute = fmap normalise . absolutize + where absolutize path -- avoid the call to `getCurrentDirectory` if we can + | isRelative path = fmap ( path) getCurrentDirectory + | otherwise = return path + -- | 'makeRelative' the current directory. makeRelativeToCurrentDirectory :: FilePath -> IO FilePath makeRelativeToCurrentDirectory x = do @@ -758,7 +826,7 @@ -- | Given a file name, searches for the file and returns a list of all -- occurences that are executable. -- --- /Since: 1.2.1.0/ +-- /Since: 1.2.2.0/ findExecutables :: String -> IO [FilePath] findExecutables binary = do #if defined(mingw32_HOST_OS) @@ -842,13 +910,16 @@ bracket (Posix.openDirStream path) Posix.closeDirStream - loop + start where - loop dirp = do - e <- Posix.readDirStream dirp - if null e then return [] else do - es <- loop dirp - return (e:es) + start dirp = + loop id + where + loop acc = do + e <- Posix.readDirStream dirp + if null e + then return (acc []) + else loop (acc . (e:)) #else bracket (Win32.findFirstFile (path "*")) @@ -996,28 +1067,35 @@ * 'isDoesNotExistError' if the file or directory does not exist. -Note: When linked against @unix-2.6.0.0@ or later the reported time -supports sub-second precision if provided by the underlying system -call. - +Note: This function returns a timestamp with sub-second resolution +only if this package is compiled against @unix-2.6.0.0@ or later +for unix systems, and @Win32-2.3.1.0@ or later for windows systems. +Of course this also requires that the underlying file system supports +such high resolution timestamps. -} getModificationTime :: FilePath -> IO UTCTime getModificationTime name = do #ifdef mingw32_HOST_OS - -- ToDo: use Win32 API so we can get sub-second resolution - withFileStatus "getModificationTime" name $ \ st -> do - modificationTime st +#if MIN_VERSION_Win32(2,3,1) + fad <- Win32.getFileAttributesExStandard name + let win32_epoch_adjust = 116444736000000000 + Win32.FILETIME ft = Win32.fadLastWriteTime fad + mod_time = fromIntegral (ft - win32_epoch_adjust) / 10000000 #else + mod_time <- withFileStatus "getModificationTime" name $ \stat -> do + mtime <- st_mtime stat + return $ realToFrac (mtime :: CTime) +#endif +#else stat <- Posix.getFileStatus name - let mod_time :: POSIXTime #if MIN_VERSION_unix(2,6,0) - mod_time = Posix.modificationTimeHiRes stat + let mod_time = Posix.modificationTimeHiRes stat #else - mod_time = realToFrac $ Posix.modificationTime stat + let mod_time = realToFrac $ Posix.modificationTime stat #endif - return $ posixSecondsToUTCTime mod_time #endif + return $ posixSecondsToUTCTime mod_time #endif /* __GLASGOW_HASKELL__ */ @@ -1030,19 +1108,6 @@ throwErrnoIfMinus1Retry_ loc (c_stat s p) f p -withFileOrSymlinkStatus :: String -> FilePath -> (Ptr CStat -> IO a) -> IO a -withFileOrSymlinkStatus loc name f = do - modifyIOError (`ioeSetFileName` name) $ - allocaBytes sizeof_stat $ \p -> - withFilePath name $ \s -> do - throwErrnoIfMinus1Retry_ loc (lstat s p) - f p - -modificationTime :: Ptr CStat -> IO UTCTime -modificationTime stat = do - mtime <- st_mtime stat - return $ posixSecondsToUTCTime $ realToFrac (mtime :: CTime) - isDirectory :: Ptr CStat -> IO Bool isDirectory stat = do mode <- st_mode stat @@ -1121,7 +1186,7 @@ On Unix, this function returns @$HOME\/.appName@. On Windows, a typical path might be -> C:/Documents And Settings/user/Application Data/appName +> C:/Users/user/AppData/Roaming/appName The operation may fail with: @@ -1206,7 +1271,7 @@ #else getEnv "TMPDIR" `catchIOError` \e -> if isDoesNotExistError e then return "/tmp" - else throw e + else throwIO e #endif -- ToDo: This should be determined via autoconf (AC_EXEEXT) diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,7 +1,39 @@ -# Changelog for [`directory` package](http://hackage.haskell.org/package/directory) +Changelog for the [`directory`][1] package +========================================== -## 1.2.1.0 *Mar 2014* +## 1.2.2.0 (Mar 2015) + * Bundled with GHC 7.10.1 + + * Make `getModificationTime` support sub-second resolution on Windows + + * Fix silent failure in `createDirectoryIfMissing` + + * Replace `throw` by better defined `throwIO`s + + * [#17](https://github.com/haskell/directory/pull/17): + Avoid stack overflow in `getDirectoryContents` + + * [#14](https://github.com/haskell/directory/issues/14): + Expose `findExecutables` + + * [#15](https://github.com/haskell/directory/issues/15): + `removeDirectoryRecursive` no longer follows symlinks under any + circumstances + + * [#9](https://github.com/haskell/directory/issues/9): + Allow trailing path separators in `getPermissions` on Windows + + * [#8](https://github.com/haskell/directory/pull/8): + `renameFile` now always throws the correct error type + (`InappropriateType`) when the destination is a directory, as long as the + filesystem is not being modified concurrently + + * Add `makeAbsolute`, which should be preferred over `canonicalizePath` + unless one requires symbolic links to be resolved + +## 1.2.1.0 (Mar 2014) + * Bundled with GHC 7.8.1 * Add support for sub-second precision in `getModificationTime` when @@ -19,3 +51,5 @@ * Fix `findExecutable` to check that file permissions indicate executable * New convenience functions `findFiles` and `findFilesWith` + +[1]: https://hackage.haskell.org/package/directory diff --git a/config.guess b/config.guess --- a/config.guess +++ b/config.guess @@ -1,8 +1,8 @@ #! /bin/sh # Attempt to guess a canonical system name. -# Copyright 1992-2013 Free Software Foundation, Inc. +# Copyright 1992-2014 Free Software Foundation, Inc. -timestamp='2013-06-10' +timestamp='2014-03-23' # This file is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by @@ -50,7 +50,7 @@ GNU config.guess ($timestamp) Originally written by Per Bothner. -Copyright 1992-2013 Free Software Foundation, Inc. +Copyright 1992-2014 Free Software Foundation, Inc. This is free software; see the source for copying conditions. There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." @@ -149,7 +149,7 @@ LIBC=gnu #endif EOF - eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^LIBC'` + eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^LIBC' | sed 's, ,,g'` ;; esac @@ -826,7 +826,7 @@ *:MINGW*:*) echo ${UNAME_MACHINE}-pc-mingw32 exit ;; - i*:MSYS*:*) + *:MSYS*:*) echo ${UNAME_MACHINE}-pc-msys exit ;; i*:windows32*:*) @@ -969,10 +969,10 @@ eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^CPU'` test x"${CPU}" != x && { echo "${CPU}-unknown-linux-${LIBC}"; exit; } ;; - or1k:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux-${LIBC} + openrisc*:Linux:*:*) + echo or1k-unknown-linux-${LIBC} exit ;; - or32:Linux:*:*) + or32:Linux:*:* | or1k*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; padre:Linux:*:*) @@ -1260,16 +1260,26 @@ if test "$UNAME_PROCESSOR" = unknown ; then UNAME_PROCESSOR=powerpc fi - if [ "$CC_FOR_BUILD" != 'no_compiler_found' ]; then - if (echo '#ifdef __LP64__'; echo IS_64BIT_ARCH; echo '#endif') | \ - (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | \ - grep IS_64BIT_ARCH >/dev/null - then - case $UNAME_PROCESSOR in - i386) UNAME_PROCESSOR=x86_64 ;; - powerpc) UNAME_PROCESSOR=powerpc64 ;; - esac + if test `echo "$UNAME_RELEASE" | sed -e 's/\..*//'` -le 10 ; then + if [ "$CC_FOR_BUILD" != 'no_compiler_found' ]; then + if (echo '#ifdef __LP64__'; echo IS_64BIT_ARCH; echo '#endif') | \ + (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | \ + grep IS_64BIT_ARCH >/dev/null + then + case $UNAME_PROCESSOR in + i386) UNAME_PROCESSOR=x86_64 ;; + powerpc) UNAME_PROCESSOR=powerpc64 ;; + esac + fi fi + elif test "$UNAME_PROCESSOR" = i386 ; then + # Avoid executing cc on OS X 10.9, as it ships with a stub + # that puts up a graphical alert prompting to install + # developer tools. Any system running Mac OS X 10.7 or + # later (Darwin 11 and later) is required to have a 64-bit + # processor. This is not true of the ARM version of Darwin + # that Apple uses in portable devices. + UNAME_PROCESSOR=x86_64 fi echo ${UNAME_PROCESSOR}-apple-darwin${UNAME_RELEASE} exit ;; @@ -1360,154 +1370,6 @@ echo ${UNAME_MACHINE}-unknown-esx exit ;; esac - -eval $set_cc_for_build -cat >$dummy.c < -# include -#endif -main () -{ -#if defined (sony) -#if defined (MIPSEB) - /* BFD wants "bsd" instead of "newsos". Perhaps BFD should be changed, - I don't know.... */ - printf ("mips-sony-bsd\n"); exit (0); -#else -#include - printf ("m68k-sony-newsos%s\n", -#ifdef NEWSOS4 - "4" -#else - "" -#endif - ); exit (0); -#endif -#endif - -#if defined (__arm) && defined (__acorn) && defined (__unix) - printf ("arm-acorn-riscix\n"); exit (0); -#endif - -#if defined (hp300) && !defined (hpux) - printf ("m68k-hp-bsd\n"); exit (0); -#endif - -#if defined (NeXT) -#if !defined (__ARCHITECTURE__) -#define __ARCHITECTURE__ "m68k" -#endif - int version; - version=`(hostinfo | sed -n 's/.*NeXT Mach \([0-9]*\).*/\1/p') 2>/dev/null`; - if (version < 4) - printf ("%s-next-nextstep%d\n", __ARCHITECTURE__, version); - else - printf ("%s-next-openstep%d\n", __ARCHITECTURE__, version); - exit (0); -#endif - -#if defined (MULTIMAX) || defined (n16) -#if defined (UMAXV) - printf ("ns32k-encore-sysv\n"); exit (0); -#else -#if defined (CMU) - printf ("ns32k-encore-mach\n"); exit (0); -#else - printf ("ns32k-encore-bsd\n"); exit (0); -#endif -#endif -#endif - -#if defined (__386BSD__) - printf ("i386-pc-bsd\n"); exit (0); -#endif - -#if defined (sequent) -#if defined (i386) - printf ("i386-sequent-dynix\n"); exit (0); -#endif -#if defined (ns32000) - printf ("ns32k-sequent-dynix\n"); exit (0); -#endif -#endif - -#if defined (_SEQUENT_) - struct utsname un; - - uname(&un); - - if (strncmp(un.version, "V2", 2) == 0) { - printf ("i386-sequent-ptx2\n"); exit (0); - } - if (strncmp(un.version, "V1", 2) == 0) { /* XXX is V1 correct? */ - printf ("i386-sequent-ptx1\n"); exit (0); - } - printf ("i386-sequent-ptx\n"); exit (0); - -#endif - -#if defined (vax) -# if !defined (ultrix) -# include -# if defined (BSD) -# if BSD == 43 - printf ("vax-dec-bsd4.3\n"); exit (0); -# else -# if BSD == 199006 - printf ("vax-dec-bsd4.3reno\n"); exit (0); -# else - printf ("vax-dec-bsd\n"); exit (0); -# endif -# endif -# else - printf ("vax-dec-bsd\n"); exit (0); -# endif -# else - printf ("vax-dec-ultrix\n"); exit (0); -# endif -#endif - -#if defined (alliant) && defined (i860) - printf ("i860-alliant-bsd\n"); exit (0); -#endif - - exit (1); -} -EOF - -$CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null && SYSTEM_NAME=`$dummy` && - { echo "$SYSTEM_NAME"; exit; } - -# Apollos put the system type in the environment. - -test -d /usr/apollo && { echo ${ISP}-apollo-${SYSTYPE}; exit; } - -# Convex versions that predate uname can use getsysinfo(1) - -if [ -x /usr/convex/getsysinfo ] -then - case `getsysinfo -f cpu_type` in - c1*) - echo c1-convex-bsd - exit ;; - c2*) - if getsysinfo -f scalar_acc - then echo c32-convex-bsd - else echo c2-convex-bsd - fi - exit ;; - c34*) - echo c34-convex-bsd - exit ;; - c38*) - echo c38-convex-bsd - exit ;; - c4*) - echo c4-convex-bsd - exit ;; - esac -fi cat >&2 <= 1.10 -tested-with: GHC==7.6.3, GHC==7.6.2, GHC==7.6.1, GHC==7.4.2, GHC==7.4.1 +tested-with: GHC>=7.4.1 extra-tmp-files: autom4te.cache @@ -21,6 +22,7 @@ extra-source-files: changelog.md + README.md config.guess config.sub configure @@ -28,15 +30,27 @@ directory.buildinfo include/HsDirectoryConfig.h.in install-sh + tests/*.hs + tests/*.stderr + tests/*.stdout + tests/Makefile + tests/all.T + tests/copyFile001dir/source + tests/copyFile002dir/source + tests/createDirectory001.stdout-mingw32 + tests/createDirectoryIfMissing001.stdout-mingw32 + tests/getDirContents002.stderr-mingw32 + tests/getPermissions001.stdout-alpha-dec-osf3 + tests/getPermissions001.stdout-i386-unknown-freebsd + tests/getPermissions001.stdout-i386-unknown-openbsd + tests/getPermissions001.stdout-mingw + tests/getPermissions001.stdout-x86_64-unknown-openbsd + tools/ghc.patch + tools/run-tests source-repository head type: git - location: http://git.haskell.org/packages/directory.git - -source-repository this - type: git - location: http://git.haskell.org/packages/directory.git - tag: directory-1.2.0.2-release + location: https://github.com/haskell/directory Library default-language: Haskell2010 @@ -57,12 +71,21 @@ HsDirectory.h build-depends: - base >= 4.5 && < 4.8, - time >= 1.4 && < 1.5, - filepath >= 1.3 && < 1.4 + base >= 4.5 && < 4.9, + time >= 1.4 && < 1.6, + filepath >= 1.3 && < 1.5 if os(windows) build-depends: Win32 >= 2.2.2 && < 2.4 else build-depends: unix >= 2.5.1 && < 2.8 ghc-options: -Wall + +test-suite test + default-language: Haskell2010 + other-extensions: CPP ForeignFunctionInterface + ghc-options: -Wall + hs-source-dirs: tools + main-is: dispatch-tests.hs + type: exitcode-stdio-1.0 + build-depends: base, directory diff --git a/tests/Makefile b/tests/Makefile new file mode 100644 --- /dev/null +++ b/tests/Makefile @@ -0,0 +1,7 @@ +# This Makefile runs the tests using GHC's testsuite framework. It +# assumes the package is part of a GHC build tree with the testsuite +# installed in ../../../testsuite. + +TOP=../../../testsuite +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/tests/T8482.hs b/tests/T8482.hs new file mode 100644 --- /dev/null +++ b/tests/T8482.hs @@ -0,0 +1,16 @@ +import System.Directory +import Control.Exception + +tmp1 = "T8482.tmp1" +testdir = "T8482.dir" + +main = do + writeFile tmp1 "hello" + createDirectory testdir + tryRenameFile testdir tmp1 >>= print -- InappropriateType + tryRenameFile tmp1 testdir >>= print -- InappropriateType + tryRenameFile tmp1 "." >>= print -- InappropriateType + removeDirectory testdir + removeFile tmp1 + where tryRenameFile :: FilePath -> FilePath -> IO (Either IOException ()) + tryRenameFile opath npath = try $ renameFile opath npath diff --git a/tests/T8482.stdout b/tests/T8482.stdout new file mode 100644 --- /dev/null +++ b/tests/T8482.stdout @@ -0,0 +1,3 @@ +Left T8482.dir: renameFile: inappropriate type (is a directory) +Left T8482.dir: renameFile: inappropriate type (is a directory) +Left .: renameFile: inappropriate type (is a directory) diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs new file mode 100644 --- /dev/null +++ b/tests/TestUtils.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} +module TestUtils + ( copyPathRecursive + , createSymbolicLink + , modifyPermissions + , tryCreateSymbolicLink + ) where +import System.Directory +import System.FilePath (()) +import System.IO.Error (ioeSetLocation, modifyIOError) +#ifdef mingw32_HOST_OS +import Foreign (Ptr) +import Foreign.C (CUChar(..), CULong(..), CWchar(..), withCWString) +import System.FilePath (takeDirectory) +import System.IO (hPutStrLn, stderr) +import System.IO.Error (catchIOError, ioeSetErrorString, isPermissionError, + mkIOError, permissionErrorType) +import System.Win32.Types (failWith, getLastError) +#else +import System.Posix.Files (createSymbolicLink) +#endif + +#ifdef mingw32_HOST_OS +# if defined i386_HOST_ARCH +# define WINAPI stdcall +# elif defined x86_64_HOST_ARCH +# define WINAPI ccall +# else +# error unknown architecture +# endif +foreign import WINAPI unsafe "windows.h CreateSymbolicLinkW" + c_CreateSymbolicLink :: Ptr CWchar -> Ptr CWchar -> CULong -> IO CUChar +#endif + +-- | @'copyPathRecursive' path@ copies an existing file or directory at +-- /path/ together with its contents and subdirectories. +-- +-- Warning: mostly untested and might not handle symlinks correctly. +copyPathRecursive :: FilePath -> FilePath -> IO () +copyPathRecursive source dest = + (`ioeSetLocation` "copyPathRecursive") `modifyIOError` do + dirExists <- doesDirectoryExist source + if dirExists + then do + contents <- getDirectoryContents source + createDirectory dest + mapM_ (uncurry copyPathRecursive) + [(source x, dest x) | x <- contents, x /= "." && x /= ".."] + else copyFile source dest + +modifyPermissions :: FilePath -> (Permissions -> Permissions) -> IO () +modifyPermissions path modify = do + permissions <- getPermissions path + setPermissions path (modify permissions) + +#if mingw32_HOST_OS +createSymbolicLink :: String -> String -> IO () +createSymbolicLink target link = + (`ioeSetLocation` "createSymbolicLink") `modifyIOError` do + isDir <- (fromIntegral . fromEnum) `fmap` + doesDirectoryExist (takeDirectory link target) + withCWString target $ \ target' -> + withCWString link $ \ link' -> do + status <- c_CreateSymbolicLink link' target' isDir + if status == 0 + then do + errCode <- getLastError + if errCode == c_ERROR_PRIVILEGE_NOT_HELD + then ioError . (`ioeSetErrorString` permissionErrorMsg) $ + mkIOError permissionErrorType "" Nothing (Just link) + else failWith "createSymbolicLink" errCode + else return () + where c_ERROR_PRIVILEGE_NOT_HELD = 0x522 + permissionErrorMsg = "no permission to create symbolic links" +#endif + +-- | Attempt to create a symbolic link. On Windows, this falls back to +-- copying if forbidden due to Group Policies. +tryCreateSymbolicLink :: FilePath -> FilePath -> IO () +tryCreateSymbolicLink target link = createSymbolicLink target link +#ifdef mingw32_HOST_OS + `catchIOError` \ e -> + if isPermissionError e + then copyPathRecursive (takeDirectory link target) link + else ioError e +#endif diff --git a/tests/all.T b/tests/all.T new file mode 100644 --- /dev/null +++ b/tests/all.T @@ -0,0 +1,32 @@ +test('canonicalizePath001', normal, compile_and_run, ['']) +test('currentDirectory001', normal, compile_and_run, ['']) +test('directory001', normal, compile_and_run, ['']) +test('doesDirectoryExist001', normal, compile_and_run, ['']) + +# This test is a bit bogus. Disable for GHCi. +test('getDirContents001', omit_ways(['ghci']), compile_and_run, ['-fno-gen-manifest']) + +test('getDirContents002', [ normalise_exe, exit_code(1) ], + compile_and_run, ['']) + +# Depends on binary from previous run, which gets removed by the driver way=ghci +test('getPermissions001', omit_ways(['ghci']), compile_and_run, ['-cpp']) + +test('copyFile001', extra_clean(['copyFile001dir/target']), + compile_and_run, ['']) +test('copyFile002', extra_clean(['copyFile002dir/target']), + compile_and_run, ['']) + +test('renameFile001', extra_clean(['renameFile001.tmp1','renameFile001.tmp2']), + compile_and_run, ['']) + +test('createDirectory001', normal, compile_and_run, ['']) + +test('createDirectoryIfMissing001', normal, compile_and_run, ['']) + +# No sane way to tell whether the output is reasonable here... +test('getHomeDirectory001', ignore_output, compile_and_run, ['']) + +test('T8482', normal, compile_and_run, ['']) + +test('removeDirectoryRecursive001', normal, compile_and_run, ['']) diff --git a/tests/canonicalizePath001.hs b/tests/canonicalizePath001.hs new file mode 100644 --- /dev/null +++ b/tests/canonicalizePath001.hs @@ -0,0 +1,8 @@ +module Main (main) where +import System.Directory +import System.IO.Error (catchIOError) + +main = do + dot <- canonicalizePath "." + nul <- canonicalizePath "" `catchIOError` \ _ -> return "" + print (dot == nul) diff --git a/tests/canonicalizePath001.stdout b/tests/canonicalizePath001.stdout new file mode 100644 --- /dev/null +++ b/tests/canonicalizePath001.stdout @@ -0,0 +1,1 @@ +True diff --git a/tests/copyFile001.hs b/tests/copyFile001.hs new file mode 100644 --- /dev/null +++ b/tests/copyFile001.hs @@ -0,0 +1,26 @@ + +module Main (main) where + +import Control.Exception +import Data.List +import System.Directory +import System.IO + +main :: IO () +main = do tryIO $ removeFile to + cs_before <- getDirectoryContents "copyFile001dir" + putStrLn "Before:" + print $ sort cs_before + copyFile from to + cs_before <- getDirectoryContents "copyFile001dir" + putStrLn "After:" + print $ sort cs_before + readFile to >>= print + +tryIO :: IO a -> IO (Either IOException a) +tryIO = try + +from, to :: FilePath +from = "copyFile001dir/source" +to = "copyFile001dir/target" + diff --git a/tests/copyFile001.stdout b/tests/copyFile001.stdout new file mode 100644 --- /dev/null +++ b/tests/copyFile001.stdout @@ -0,0 +1,5 @@ +Before: +[".","..","source"] +After: +[".","..","source","target"] +"This is the data" diff --git a/tests/copyFile001dir/source b/tests/copyFile001dir/source new file mode 100644 --- /dev/null +++ b/tests/copyFile001dir/source @@ -0,0 +1,1 @@ +This is the data diff --git a/tests/copyFile002.hs b/tests/copyFile002.hs new file mode 100644 --- /dev/null +++ b/tests/copyFile002.hs @@ -0,0 +1,31 @@ + +module Main (main) where + +import Control.Exception +import Data.List +import System.Directory +import System.IO + +-- like copyFile001, but moves a file in the current directory +-- See bug #1652 +main :: IO () +main = do d <- getCurrentDirectory + flip finally (setCurrentDirectory d) $ do + setCurrentDirectory "copyFile002dir" + tryIO $ removeFile to + cs_before <- getDirectoryContents "." + putStrLn "Before:" + print $ sort cs_before + copyFile from to + cs_before <- getDirectoryContents "." + putStrLn "After:" + print $ sort cs_before + readFile to >>= print + +tryIO :: IO a -> IO (Either IOException a) +tryIO = try + +from, to :: FilePath +from = "source" +to = "target" + diff --git a/tests/copyFile002.stdout b/tests/copyFile002.stdout new file mode 100644 --- /dev/null +++ b/tests/copyFile002.stdout @@ -0,0 +1,5 @@ +Before: +[".","..","source"] +After: +[".","..","source","target"] +"This is the data" diff --git a/tests/copyFile002dir/source b/tests/copyFile002dir/source new file mode 100644 --- /dev/null +++ b/tests/copyFile002dir/source @@ -0,0 +1,1 @@ +This is the data diff --git a/tests/createDirectory001.hs b/tests/createDirectory001.hs new file mode 100644 --- /dev/null +++ b/tests/createDirectory001.hs @@ -0,0 +1,12 @@ +import System.Directory +import Control.Exception + +testdir = "createDirectory001.dir" + +main = do + try (removeDirectory testdir) :: IO (Either IOException ()) + createDirectory testdir + r <- try $ createDirectory testdir + print (r :: Either IOException ()) -- already exists + removeDirectory testdir + diff --git a/tests/createDirectory001.stdout b/tests/createDirectory001.stdout new file mode 100644 --- /dev/null +++ b/tests/createDirectory001.stdout @@ -0,0 +1,1 @@ +Left createDirectory001.dir: createDirectory: already exists (File exists) diff --git a/tests/createDirectory001.stdout-mingw32 b/tests/createDirectory001.stdout-mingw32 new file mode 100644 --- /dev/null +++ b/tests/createDirectory001.stdout-mingw32 @@ -0,0 +1,1 @@ +Left CreateDirectory "createDirectory001.dir": already exists (Cannot create a file when that file already exists.) diff --git a/tests/createDirectoryIfMissing001.hs b/tests/createDirectoryIfMissing001.hs new file mode 100644 --- /dev/null +++ b/tests/createDirectoryIfMissing001.hs @@ -0,0 +1,79 @@ +module Main(main) where + +import Control.Concurrent +import Control.Monad +import Control.Exception as E +import System.Directory +import System.FilePath +import System.IO.Error + +testdir = "createDirectoryIfMissing001.d" +testdir_a = testdir "a" + +main = do + cleanup + + report $ createDirectoryIfMissing False testdir + cleanup + + report $ createDirectoryIfMissing False testdir_a + -- should fail with does not exist + + report $ createDirectoryIfMissing True testdir_a + -- should succeed with no error + report $ createDirectoryIfMissing False testdir_a + -- should succeed with no error + report $ createDirectoryIfMissing False (addTrailingPathSeparator testdir_a) + -- should succeed with no error + + cleanup + report $ createDirectoryIfMissing True (addTrailingPathSeparator testdir_a) + + -- look for race conditions: #2808. This fails with + -- +RTS -N2 and directory 1.0.0.2. + m <- newEmptyMVar + forkIO $ do replicateM_ 10000 create; putMVar m () + forkIO $ do replicateM_ 10000 cleanup; putMVar m () + replicateM_ 2 $ takeMVar m + +-- This test fails on Windows; see #2924 +-- replicateM_ 2 $ +-- forkIO $ do replicateM_ 5000 (do create; cleanup); putMVar m () +-- replicateM_ 2 $ takeMVar m + + cleanup + + -- these are all supposed to fail + + writeFile testdir testdir + report $ createDirectoryIfMissing False testdir + removeFile testdir + cleanup + + writeFile testdir testdir + report $ createDirectoryIfMissing True testdir_a + removeFile testdir + cleanup + +-- createDirectoryIfMissing is allowed to fail with isDoesNotExistError if +-- another process/thread removes one of the directories during the proces +-- of creating the hierarchy. +-- +-- It is also allowed to fail with permission errors (see #2924) +create = tryJust (guard . (\e -> isDoesNotExistError e || isPermissionError e)) $ createDirectoryIfMissing True testdir_a + +cleanup = ignore $ removeDirectoryRecursive testdir + +report :: Show a => IO a -> IO () +report io = do + r <- E.try io + case r of + Left e -> print (e :: SomeException) + Right a -> print a + +ignore :: IO a -> IO () +ignore io = do + r <- E.try io + case r of + Left e -> let _ = e :: SomeException in return () + Right a -> return () diff --git a/tests/createDirectoryIfMissing001.stdout b/tests/createDirectoryIfMissing001.stdout new file mode 100644 --- /dev/null +++ b/tests/createDirectoryIfMissing001.stdout @@ -0,0 +1,8 @@ +() +createDirectoryIfMissing001.d/a: createDirectory: does not exist (No such file or directory) +() +() +() +() +createDirectoryIfMissing001.d: createDirectory: already exists (File exists) +createDirectoryIfMissing001.d/a: createDirectory: inappropriate type (Not a directory) diff --git a/tests/createDirectoryIfMissing001.stdout-mingw32 b/tests/createDirectoryIfMissing001.stdout-mingw32 new file mode 100644 --- /dev/null +++ b/tests/createDirectoryIfMissing001.stdout-mingw32 @@ -0,0 +1,8 @@ +() +CreateDirectory "createDirectoryIfMissing001.d\\a": does not exist (The system cannot find the path specified.) +() +() +() +() +CreateDirectory "createDirectoryIfMissing001.d": already exists (Cannot create a file when that file already exists.) +CreateDirectory "createDirectoryIfMissing001.d": already exists (Cannot create a file when that file already exists.) diff --git a/tests/currentDirectory001.hs b/tests/currentDirectory001.hs new file mode 100644 --- /dev/null +++ b/tests/currentDirectory001.hs @@ -0,0 +1,27 @@ + +import System.Directory (getCurrentDirectory, setCurrentDirectory, + createDirectory, removeDirectory, + getDirectoryContents) + +main :: IO () +main = do + oldpwd <- getCurrentDirectory + createDirectory dir + setCurrentDirectory dir + ~[n1, n2] <- getDirectoryContents "." + if dot n1 && dot n2 + then do + setCurrentDirectory oldpwd + removeDirectory dir + putStr "Okay\n" + else + ioError (userError "Oops") + +dot :: String -> Bool +dot "." = True +dot ".." = True +dot _ = False + +dir :: FilePath +dir = "currentDirectory001-dir" + diff --git a/tests/currentDirectory001.stdout b/tests/currentDirectory001.stdout new file mode 100644 --- /dev/null +++ b/tests/currentDirectory001.stdout @@ -0,0 +1,1 @@ +Okay diff --git a/tests/directory001.hs b/tests/directory001.hs new file mode 100644 --- /dev/null +++ b/tests/directory001.hs @@ -0,0 +1,16 @@ +import System.IO +import System.Directory + +main = do + createDirectory "foo" + h <- openFile "foo/bar" WriteMode + hPutStr h "Okay\n" + hClose h + renameFile "foo/bar" "foo/baz" + renameDirectory "foo" "bar" + h <- openFile "bar/baz" ReadMode + stuff <- hGetContents h + putStr stuff +-- hClose h -- an error ! + removeFile "bar/baz" + removeDirectory "bar" diff --git a/tests/directory001.stdout b/tests/directory001.stdout new file mode 100644 --- /dev/null +++ b/tests/directory001.stdout @@ -0,0 +1,1 @@ +Okay diff --git a/tests/doesDirectoryExist001.hs b/tests/doesDirectoryExist001.hs new file mode 100644 --- /dev/null +++ b/tests/doesDirectoryExist001.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE CPP #-} +-- !!! "/" was not recognised as a directory in 6.0.x +import System.Directory + +#ifdef mingw32_HOST_OS +root = "C:\\" +#else +root = "/" +#endif + +main = doesDirectoryExist root >>= print diff --git a/tests/doesDirectoryExist001.stdout b/tests/doesDirectoryExist001.stdout new file mode 100644 --- /dev/null +++ b/tests/doesDirectoryExist001.stdout @@ -0,0 +1,1 @@ +True diff --git a/tests/getDirContents001.hs b/tests/getDirContents001.hs new file mode 100644 --- /dev/null +++ b/tests/getDirContents001.hs @@ -0,0 +1,18 @@ +import System.Directory +import Control.Exception +import System.FilePath +import Data.List + +dir = "getDirContents001.dir" + +main = do + try cleanup :: IO (Either IOException ()) + bracket (createDirectory dir) (const cleanup) $ \_ -> do + getDirectoryContents dir >>= print . sort + mapM_ (\s -> writeFile (dir ('f':show s)) (show s)) [1..100] + getDirectoryContents dir >>= print . sort + +cleanup = do + files <- getDirectoryContents dir + mapM_ (removeFile . (dir )) (filter (not . ("." `isPrefixOf`)) files) + removeDirectory dir diff --git a/tests/getDirContents001.stdout b/tests/getDirContents001.stdout new file mode 100644 --- /dev/null +++ b/tests/getDirContents001.stdout @@ -0,0 +1,2 @@ +[".",".."] +[".","..","f1","f10","f100","f11","f12","f13","f14","f15","f16","f17","f18","f19","f2","f20","f21","f22","f23","f24","f25","f26","f27","f28","f29","f3","f30","f31","f32","f33","f34","f35","f36","f37","f38","f39","f4","f40","f41","f42","f43","f44","f45","f46","f47","f48","f49","f5","f50","f51","f52","f53","f54","f55","f56","f57","f58","f59","f6","f60","f61","f62","f63","f64","f65","f66","f67","f68","f69","f7","f70","f71","f72","f73","f74","f75","f76","f77","f78","f79","f8","f80","f81","f82","f83","f84","f85","f86","f87","f88","f89","f9","f90","f91","f92","f93","f94","f95","f96","f97","f98","f99"] diff --git a/tests/getDirContents002.hs b/tests/getDirContents002.hs new file mode 100644 --- /dev/null +++ b/tests/getDirContents002.hs @@ -0,0 +1,3 @@ +import System.Directory + +main = getDirectoryContents "nonexistent" diff --git a/tests/getDirContents002.stderr b/tests/getDirContents002.stderr new file mode 100644 --- /dev/null +++ b/tests/getDirContents002.stderr @@ -0,0 +1,1 @@ +getDirContents002: nonexistent: getDirectoryContents: does not exist (No such file or directory) diff --git a/tests/getDirContents002.stderr-mingw32 b/tests/getDirContents002.stderr-mingw32 new file mode 100644 --- /dev/null +++ b/tests/getDirContents002.stderr-mingw32 @@ -0,0 +1,1 @@ +getDirContents002.exe: nonexistent: getDirectoryContents: does not exist (The system cannot find the path specified.) diff --git a/tests/getHomeDirectory001.hs b/tests/getHomeDirectory001.hs new file mode 100644 --- /dev/null +++ b/tests/getHomeDirectory001.hs @@ -0,0 +1,8 @@ +import System.Directory + +main = do + getHomeDirectory >>= print + getAppUserDataDirectory "test" >>= print + getUserDocumentsDirectory >>= print + getTemporaryDirectory >>= print + return () diff --git a/tests/getPermissions001.hs b/tests/getPermissions001.hs new file mode 100644 --- /dev/null +++ b/tests/getPermissions001.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE CPP #-} +import System.Directory + +main = do +#ifdef mingw32_HOST_OS + let exe = ".exe" +#else + let exe = "" +#endif + p <- getPermissions "." + print p + p <- getPermissions "getPermissions001.hs" + print p + p <- getPermissions ("getPermissions001" ++ exe) + print p + + -- issue #9: Windows doesn't like trailing path separators + _ <- getPermissions "../tests/" + + return () diff --git a/tests/getPermissions001.stdout b/tests/getPermissions001.stdout new file mode 100644 --- /dev/null +++ b/tests/getPermissions001.stdout @@ -0,0 +1,3 @@ +Permissions {readable = True, writable = True, executable = False, searchable = True} +Permissions {readable = True, writable = True, executable = False, searchable = False} +Permissions {readable = True, writable = True, executable = True, searchable = False} diff --git a/tests/getPermissions001.stdout-alpha-dec-osf3 b/tests/getPermissions001.stdout-alpha-dec-osf3 new file mode 100644 --- /dev/null +++ b/tests/getPermissions001.stdout-alpha-dec-osf3 @@ -0,0 +1,3 @@ +Permissions {readable = True, writable = True, executable = False, searchable = True} +Permissions {readable = True, writable = True, executable = False, searchable = False} +Permissions {readable = True, writable = False, executable = True, searchable = False} diff --git a/tests/getPermissions001.stdout-i386-unknown-freebsd b/tests/getPermissions001.stdout-i386-unknown-freebsd new file mode 100644 --- /dev/null +++ b/tests/getPermissions001.stdout-i386-unknown-freebsd @@ -0,0 +1,3 @@ +Permissions {readable = True, writable = True, executable = False, searchable = True} +Permissions {readable = True, writable = True, executable = False, searchable = False} +Permissions {readable = True, writable = False, executable = True, searchable = False} diff --git a/tests/getPermissions001.stdout-i386-unknown-openbsd b/tests/getPermissions001.stdout-i386-unknown-openbsd new file mode 100644 --- /dev/null +++ b/tests/getPermissions001.stdout-i386-unknown-openbsd @@ -0,0 +1,3 @@ +Permissions {readable = True, writable = True, executable = False, searchable = True} +Permissions {readable = True, writable = True, executable = False, searchable = False} +Permissions {readable = True, writable = False, executable = True, searchable = False} diff --git a/tests/getPermissions001.stdout-mingw b/tests/getPermissions001.stdout-mingw new file mode 100644 --- /dev/null +++ b/tests/getPermissions001.stdout-mingw @@ -0,0 +1,3 @@ +Permissions {readable = True, writable = True, executable = True, searchable = True} +Permissions {readable = True, writable = True, executable = True, searchable = True} +Permissions {readable = True, writable = True, executable = True, searchable = True} diff --git a/tests/getPermissions001.stdout-x86_64-unknown-openbsd b/tests/getPermissions001.stdout-x86_64-unknown-openbsd new file mode 100644 --- /dev/null +++ b/tests/getPermissions001.stdout-x86_64-unknown-openbsd @@ -0,0 +1,3 @@ +Permissions {readable = True, writable = True, executable = False, searchable = True} +Permissions {readable = True, writable = True, executable = False, searchable = False} +Permissions {readable = True, writable = False, executable = True, searchable = False} diff --git a/tests/removeDirectoryRecursive001.hs b/tests/removeDirectoryRecursive001.hs new file mode 100644 --- /dev/null +++ b/tests/removeDirectoryRecursive001.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE CPP #-} +module Main (main) where +import Data.List (sort) +import System.Directory +import System.FilePath ((), normalise) +import System.IO.Error (catchIOError) +import TestUtils + +testName :: String +testName = "removeDirectoryRecursive001" + +tmpD :: String +tmpD = testName ++ ".tmp" + +tmp :: String -> String +tmp s = tmpD normalise s + +main :: IO () +main = do + + ------------------------------------------------------------ + -- clean up junk from previous invocations + + modifyPermissions (tmp "c") (\ p -> p { writable = True }) + `catchIOError` \ _ -> return () + removeDirectoryRecursive tmpD + `catchIOError` \ _ -> return () + + ------------------------------------------------------------ + -- set up + + createDirectoryIfMissing True (tmp "a/x/w") + createDirectoryIfMissing True (tmp "a/y") + createDirectoryIfMissing True (tmp "a/z") + createDirectoryIfMissing True (tmp "b") + createDirectoryIfMissing True (tmp "c") + writeFile (tmp "a/x/w/u") "foo" + writeFile (tmp "a/t") "bar" + tryCreateSymbolicLink (normalise "../a") (tmp "b/g") + tryCreateSymbolicLink (normalise "../b") (tmp "c/h") + tryCreateSymbolicLink (normalise "a") (tmp "d") + modifyPermissions (tmp "c") (\ p -> p { writable = False }) + + ------------------------------------------------------------ + -- tests + + getDirectoryContents tmpD >>= putStrLn . unwords . sort + getDirectoryContents (tmp "a") >>= putStrLn . unwords . sort + getDirectoryContents (tmp "b") >>= putStrLn . unwords . sort + getDirectoryContents (tmp "c") >>= putStrLn . unwords . sort + getDirectoryContents (tmp "d") >>= putStrLn . unwords . sort + + putStrLn "" + + removeDirectoryRecursive (tmp "d") + `catchIOError` \ _ -> removeFile (tmp "d") +#ifdef mingw32_HOST_OS + `catchIOError` \ _ -> removeDirectory (tmp "d") +#endif + + getDirectoryContents tmpD >>= putStrLn . unwords . sort + getDirectoryContents (tmp "a") >>= putStrLn . unwords . sort + getDirectoryContents (tmp "b") >>= putStrLn . unwords . sort + getDirectoryContents (tmp "c") >>= putStrLn . unwords . sort + + putStrLn "" + + removeDirectoryRecursive (tmp "c") + `catchIOError` \ _ -> do + modifyPermissions (tmp "c") (\ p -> p { writable = True }) + removeDirectoryRecursive (tmp "c") + + getDirectoryContents tmpD >>= putStrLn . unwords . sort + getDirectoryContents (tmp "a") >>= putStrLn . unwords . sort + getDirectoryContents (tmp "b") >>= putStrLn . unwords . sort + + putStrLn "" + + removeDirectoryRecursive (tmp "b") + + getDirectoryContents tmpD >>= putStrLn . unwords . sort + getDirectoryContents (tmp "a") >>= putStrLn . unwords . sort + + putStrLn "" + + removeDirectoryRecursive (tmp "a") + + getDirectoryContents tmpD >>= putStrLn . unwords . sort + + ------------------------------------------------------------ + -- clean up + + removeDirectoryRecursive tmpD diff --git a/tests/removeDirectoryRecursive001.stdout b/tests/removeDirectoryRecursive001.stdout new file mode 100644 --- /dev/null +++ b/tests/removeDirectoryRecursive001.stdout @@ -0,0 +1,19 @@ +. .. a b c d +. .. t x y z +. .. g +. .. h +. .. t x y z + +. .. a b c +. .. t x y z +. .. g +. .. h + +. .. a b +. .. t x y z +. .. g + +. .. a +. .. t x y z + +. .. diff --git a/tests/renameFile001.hs b/tests/renameFile001.hs new file mode 100644 --- /dev/null +++ b/tests/renameFile001.hs @@ -0,0 +1,13 @@ +import System.Directory + +tmp1 = "renameFile001.tmp1" +tmp2 = "renameFile001.tmp2" + +main = do + writeFile tmp1 "test" + renameFile tmp1 tmp2 + readFile tmp2 >>= print + writeFile tmp1 "test2" + renameFile tmp2 tmp1 + readFile tmp1 >>= print + diff --git a/tests/renameFile001.stdout b/tests/renameFile001.stdout new file mode 100644 --- /dev/null +++ b/tests/renameFile001.stdout @@ -0,0 +1,2 @@ +"test" +"test" diff --git a/tools/dispatch-tests.hs b/tools/dispatch-tests.hs new file mode 100644 --- /dev/null +++ b/tools/dispatch-tests.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} +module Main (main) where +import Foreign (Ptr) +import Foreign.C (CChar(..), CInt(..), withCString) +import Data.Functor ((<$>)) +import System.Directory () -- to make sure `directory` is built beforehand +import System.Environment (getArgs) +import System.Exit (ExitCode(ExitSuccess, ExitFailure), exitWith) + +main :: IO () +main = do + + -- check if 'cabal exec' is supported (didn't exist until 1.20) + cabalExecTest <- rawSystem "sh" ["-c", "cabal >/dev/null 2>&1 exec true"] + + -- execute in the Cabal sandbox environment if possible + let prefix = case cabalExecTest of + ExitSuccess -> ["cabal", "exec", "--"] + ExitFailure _ -> [] + + args <- getArgs + let command : arguments = prefix ++ ["sh", "tools/run-tests"] ++ args + exitWith =<< normalizeExitCode <$> rawSystem command arguments + +makeExitCode :: Int -> ExitCode +makeExitCode 0 = ExitSuccess +makeExitCode e = ExitFailure e + +-- on Linux the exit code is right-shifted by 8 bits, causing exit codes to be +-- rather large; older versions of GHC don't seem to handle that well in +-- `exitWith` +normalizeExitCode :: ExitCode -> ExitCode +normalizeExitCode ExitSuccess = ExitSuccess +normalizeExitCode (ExitFailure _) = ExitFailure 1 + +-- we can't use the `process` library as it causes a dependency cycle with +-- Cabal, so we reinvent the wheel here in a simplistic way; this will +-- probably break with non-ASCII characters on Windows +rawSystem :: String -> [String] -> IO ExitCode +rawSystem cmd args = + withCString (quoteCmdArgs (cmd : args)) $ \ c_command -> + makeExitCode . fromIntegral <$> c_system c_command + +-- handle the different quoting rules in CMD.EXE vs POSIX shells +quoteCmdArgs :: [String] -> String +quoteCmdArgs cmdArgs = +#ifdef mingw32_HOST_OS + -- the arcane quoting rules require us to add an extra set of quotes + -- around the entire thing: see `help cmd` or look at + -- https://superuser.com/a/238813 + "\"" ++ unwords (quote <$> cmdArgs) ++ "\"" + where quote s = "\"" ++ replaceElem '"' "\"\"" s ++ "\"" +#else + unwords (quote <$> cmdArgs) + where quote s = "'" ++ replaceElem '\'' "'\\''" s ++ "'" +#endif + +replaceElem :: Eq a => a -> [a] -> [a] -> [a] +replaceElem match repl = concat . (replace <$>) + where replace c | c == match = repl + | otherwise = [c] + +foreign import ccall safe "stdlib.h system" c_system :: Ptr CChar -> IO CInt diff --git a/tools/ghc.patch b/tools/ghc.patch new file mode 100644 --- /dev/null +++ b/tools/ghc.patch @@ -0,0 +1,62 @@ +# allow ghc and its tools to be located in different directories +--- testsuite/mk/boilerplate.mk ++++ testsuite/mk/boilerplate.mk +@@ -56,6 +56,7 @@ TEST_HC := $(STAGE2_GHC) + endif + + else ++implicit_compiler = YES + IN_TREE_COMPILER = NO + TEST_HC := $(shell which ghc) + endif +@@ -87,24 +88,30 @@ endif + # containing spaces + BIN_ROOT = $(shell dirname '$(TEST_HC)') + ++ifeq "$(implicit_compiler)" "YES" ++find_tool = $(shell which $(1)) ++else ++find_tool = $(BIN_ROOT)/$(1) ++endif ++ + ifeq "$(GHC_PKG)" "" +-GHC_PKG := $(BIN_ROOT)/ghc-pkg ++GHC_PKG := $(call find_tool,ghc-pkg) + endif + + ifeq "$(RUNGHC)" "" +-RUNGHC := $(BIN_ROOT)/runghc ++RUNGHC := $(call find_tool,runghc) + endif + + ifeq "$(HSC2HS)" "" +-HSC2HS := $(BIN_ROOT)/hsc2hs ++HSC2HS := $(call find_tool,hsc2hs) + endif + + ifeq "$(HP2PS_ABS)" "" +-HP2PS_ABS := $(BIN_ROOT)/hp2ps ++HP2PS_ABS := $(call find_tool,hp2ps) + endif + + ifeq "$(HPC)" "" +-HPC := $(BIN_ROOT)/hpc ++HPC := $(call find_tool,hpc) + endif + + $(eval $(call canonicaliseExecutable,TEST_HC)) + +# 'die' is not available until GHC 7.10 +--- testsuite/timeout/timeout.hs ++++ testsuite/timeout/timeout.hs +@@ -30,8 +30,8 @@ main = do + [secs,cmd] -> + case reads secs of + [(secs', "")] -> run secs' cmd +- _ -> die ("Can't parse " ++ show secs ++ " as a number of seconds") +- _ -> die ("Bad arguments " ++ show args) ++ _ -> ((>> exitFailure) . hPutStrLn stderr) ("Can't parse " ++ show secs ++ " as a number of seconds") ++ _ -> ((>> exitFailure) . hPutStrLn stderr) ("Bad arguments " ++ show args) + + timeoutMsg :: String + timeoutMsg = "Timeout happened...killing process..." diff --git a/tools/run-tests b/tools/run-tests new file mode 100644 --- /dev/null +++ b/tools/run-tests @@ -0,0 +1,50 @@ +#!/bin/sh +# run all of the tests under the `tests` directory using the GHC test +# framework; for more info about this framework, see: +# https://ghc.haskell.org/trac/ghc/wiki/Building/RunningTests +# +# arguments received by this script are passed as arguments to the `make` +# invocation that initiates the tests +set -e + +# check if `-package-db` is supported (didn't exist until 1.20) +# note that we don't use `-package-db` directly because older versions will +# interpret it as `-package -db` +if ghc 2>&1 -no-user-package-db | + grep >/dev/null 2>&1 "ghc: unrecognised flags: -no-user-package-db" +then db=conf +else db=db +fi + +[ -z "$HSFLAGS" ] || HSFLAGS=\ $HSFLAGS +HSFLAGS="-package-$db ../dist/package.conf.inplace$HSFLAGS" +HSFLAGS="-optP-include -optP../dist/build/autogen/cabal_macros.h $HSFLAGS" +export HSFLAGS + +# download the GHC repository +[ -f dist/testsuite/ghc.ok ] || { + rm -fr dist/testsuite/ghc + git clone --depth 1 https://github.com/ghc/ghc dist/testsuite/ghc + patch dist/testsuite/Makefile \ + "s|^TOP=.*$|TOP=../dist/testsuite/ghc/testsuite|" \ + tests/Makefile + +cd tests +make -f ../dist/testsuite/Makefile WAY=normal EXTRA_HC_OPTS="$HSFLAGS" "$@" | + tee ../dist/testsuite/test.out + +# since the test framework doesn't report an exit status, we need to manually +# find out whether the test had any failures> +{ + grep '^ *0 had missing libraries$' ../dist/testsuite/test.out + grep '^ *0 caused framework failures$' ../dist/testsuite/test.out + grep '^ *0 unexpected passes$' ../dist/testsuite/test.out + grep '^ *0 unexpected failures$' ../dist/testsuite/test.out + grep '^ *0 unexpected stat failures$' ../dist/testsuite/test.out +} >/dev/null 2>/dev/null