directory 1.3.0.2 → 1.3.1.0

raw patch · 18 files changed

+797/−221 lines, 18 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• HsDirectoryConfig.h.in +3/−0
• System/Directory.hs +343/−103
• System/Directory/Internal.hs +16/−9
• System/Directory/Internal/Config.hs +0/−4
• System/Directory/Internal/Prelude.hs +12/−3
• System/Directory/Internal/Windows.hsc +204/−2
• System/Directory/Internal/windows.h +29/−0
• changelog.md +26/−0
• configure +11/−0
• configure.ac +1/−0
• directory.cabal +2/−2
• tests/CanonicalizePath.hs +17/−33
• tests/FindFile001.hs +43/−2
• tests/PathIsSymbolicLink.hs +25/−10
• tests/RemoveDirectoryRecursive001.hs +3/−3
• tests/RemovePathForcibly.hs +3/−3
• tests/TestUtils.hs +58/−47
• tests/Util.hs +1/−0

@@ -3,6 +3,9 @@ /* Filename extension of executable files */ #undef EXE_EXTENSION +/* Define to 1 if you have the `CreateSymbolicLinkW' function. */+#undef HAVE_CREATESYMBOLICLINKW+ /* Define to 1 if you have the <fcntl.h> header file. */ #undef HAVE_FCNTL_H 

@@ -52,10 +52,17 @@     , renamePath     , copyFile     , copyFileWithMetadata+    , getFileSize      , canonicalizePath     , makeAbsolute     , makeRelativeToCurrentDirectory++    -- * Existence tests+    , doesPathExist+    , doesFileExist+    , doesDirectoryExist+     , findExecutable     , findExecutables     , findExecutablesInDirectories@@ -65,15 +72,12 @@     , findFilesWith     , exeExtension -    , getFileSize--    -- * Existence tests-    , doesPathExist-    , doesFileExist-    , doesDirectoryExist-     -- * Symbolic links+    , createFileLink+    , createDirectoryLink+    , removeDirectoryLink     , pathIsSymbolicLink+    , getSymbolicLinkTarget      -- * Permissions @@ -115,6 +119,7 @@   , utcTimeToPOSIXSeconds   , POSIXTime   )+import qualified System.Directory.Internal.Config as Cfg #ifdef mingw32_HOST_OS import qualified System.Win32 as Win32 #else@@ -138,6 +143,28 @@ are relative to the current directory. -} +-- | A generator with side-effects.+newtype ListT m a = ListT (m (Maybe (a, ListT m a)))++listTHead :: Functor m => ListT m a -> m (Maybe a)+listTHead (ListT m) = (fst <$>) <$> m++listTToList :: Monad m => ListT m a -> m [a]+listTToList (ListT m) = do+  mx <- m+  case mx of+    Nothing -> return []+    Just (x, m') -> do+      xs <- listTToList m'+      return (x : xs)++andM :: Monad m => m Bool -> m Bool -> m Bool+andM mx my = do+  x <- mx+  if x+    then my+    else return x+ ----------------------------------------------------------------------------- -- Permissions @@ -418,7 +445,7 @@ getDirectoryType path =   (`ioeAddLocation` "getDirectoryType") `modifyIOError` do #ifdef mingw32_HOST_OS-    isDir <- withFileStatus "getDirectoryType" path isDirectory+    isDir <- withSymbolicLinkStatus "getDirectoryType" path isDirectory     if isDir       then do         isLink <- pathIsSymbolicLink path@@ -981,12 +1008,13 @@ -- working directory. -- -- Indirections include the two special directories @.@ and @..@, as well as--- any symbolic links.  The input path need not point to an existing file or--- directory.  Canonicalization is performed on the longest prefix of the path--- that points to an existing file or directory.  The remaining portion of the--- path that does not point to an existing file or directory will still--- undergo 'normalise', but case canonicalization and indirection removal are--- skipped as they are impossible to do on a nonexistent path.+-- any symbolic links (and junction points on Windows).  The input path need+-- not point to an existing file or directory.  Canonicalization is performed+-- on the longest prefix of the path that points to an existing file or+-- directory.  The remaining portion of the path that does not point to an+-- existing file or directory will still undergo 'normalise', but case+-- canonicalization and indirection removal are skipped as they are impossible+-- to do on a nonexistent path. -- -- Most programs should not worry about the canonicity of a path.  In -- particular, despite the name, the function does not truly guarantee@@ -1000,11 +1028,11 @@ -- The results can be utterly wrong if the portions of the path change while -- this function is running. ----- Since symbolic links (and, on non-Windows systems, parent directories @..@)--- are dependent on the state of the existing filesystem, the function can--- only make a conservative attempt by removing such indirections from the--- longest prefix of the path that still points to an existing file or--- directory.+-- Since some indirections (symbolic links on all systems, @..@ on non-Windows+-- systems, and junction points on Windows) are dependent on the state of the+-- existing filesystem, the function can only make a conservative attempt by+-- removing such indirections from the longest prefix of the path that still+-- points to an existing file or directory. -- -- Note that on Windows parent directories @..@ are always fully expanded -- before the symbolic links, as consistent with the rest of the Windows API@@ -1017,11 +1045,14 @@ -- Similar to 'normalise', passing an empty path is equivalent to passing the -- current directory. ----- /Known bugs/: When the path contains an existing symbolic link, but the--- target of the link does not exist, then the path is not dereferenced (bug--- #64).  Symbolic link expansion is not performed on Windows XP or earlier--- due to the absence of @GetFinalPathNameByHandle@.+-- @canonicalizePath@ can resolve at least 64 indirections in a single path,+-- more than what is supported by most operating systems.  Therefore, it may+-- return the fully resolved path even though the operating system itself+-- would have long given up. --+-- On Windows XP or earlier systems, junction expansion is not performed due+-- to their lack of @GetFinalPathNameByHandle@.+-- -- /Changes since 1.2.3.0:/ The function has been altered to be more robust -- and has the same exception behavior as 'makeAbsolute'. --@@ -1040,9 +1071,12 @@   where  #if defined(mingw32_HOST_OS)-    transform path =-      attemptRealpath getFinalPathName =<<-        (Win32.getFullPathName path `catchIOError` \ _ -> return path)+    transform = attemptRealpath getFinalPathName++    simplify path =+      Win32.getFullPathName path+        `catchIOError` \ _ ->+          return path #else     transform path = do       encoding <- getFileSystemEncoding@@ -1050,23 +1084,68 @@             GHC.withCString encoding path'               (`withRealpath` GHC.peekCString encoding)       attemptRealpath realpath path++    simplify = return #endif -    attemptRealpath realpath path =-      realpathPrefix realpath (reverse (zip prefixes suffixes)) path-      where segments = splitDirectories path-            prefixes = scanl1 (</>) segments-            suffixes = tail (scanr (</>) "" segments)+    -- allow up to 64 cycles before giving up+    attemptRealpath realpath =+      attemptRealpathWith (64 :: Int) Nothing realpath <=< simplify -    -- call realpath on the largest possible prefix-    realpathPrefix realpath ((prefix, suffix) : rest) path = do-      exist <- doesPathExist prefix-      if exist -- never call realpath on an inaccessible path-        then ((</> suffix) <$> realpath prefix)-             `catchIOError` \ _ -> realpathPrefix realpath rest path-        else realpathPrefix realpath rest path-    realpathPrefix _ _ path = return path+    -- n is a counter to make sure we don't run into an infinite loop; we+    -- don't try to do any cycle detection here because an adversary could DoS+    -- any arbitrarily clever algorithm+    attemptRealpathWith n mFallback realpath path =+      case mFallback of+        -- too many indirections ... giving up.+        Just fallback | n <= 0 -> return fallback+        -- either mFallback == Nothing (first attempt)+        --     or n > 0 (still have some attempts left)+        _ -> realpathPrefix (reverse (zip prefixes suffixes)) +      where++        segments = splitDirectories path+        prefixes = scanl1 (</>) segments+        suffixes = tail (scanr (</>) "" segments)++        -- try to call realpath on the largest possible prefix+        realpathPrefix candidates =+          case candidates of+            [] -> return path+            (prefix, suffix) : rest -> do+              exist <- doesPathExist prefix+              if not exist+                -- never call realpath on an inaccessible path+                -- (to avoid bugs in system realpath implementations)+                -- try a smaller prefix instead+                then realpathPrefix rest+                else do+                  mp <- tryIOError (realpath prefix)+                  case mp of+                    -- realpath failed: try a smaller prefix instead+                    Left _ -> realpathPrefix rest+                    -- realpath succeeded: fine-tune the result+                    Right p -> realpathFurther (p </> suffix) p suffix++        -- by now we have a reasonable fallback value that we can use if we+        -- run into too many indirections; the fallback value is the same+        -- result that we have been returning in versions prior to 1.3.1.0+        -- (this is essentially the fix to #64)+        realpathFurther fallback p suffix =+          case splitDirectories suffix of+            [] -> return fallback+            next : restSuffix -> do+              -- see if the 'next' segment is a symlink+              mTarget <- tryIOError (getSymbolicLinkTarget (p </> next))+              case mTarget of+                Left _ -> return fallback+                Right target -> do+                  -- if so, dereference it and restart the whole cycle+                  let mFallback' = Just (fromMaybe fallback mFallback)+                  path' <- simplify (p </> target </> joinPath restSuffix)+                  attemptRealpathWith (n - 1) mFallback' realpath path'+ -- | Convert a path into an absolute path.  If the given path is relative, the -- current directory is prepended and then the combined result is -- 'normalise'd.  If the path is already absolute, the path is simply@@ -1119,24 +1198,28 @@     cur <- getCurrentDirectory     return $ makeRelative cur x --- | Given an executable file name, searches for such file in the--- directories listed in system PATH. The returned value is the path--- to the found executable or Nothing if an executable with the given--- name was not found. For example (findExecutable \"ghc\") gives you--- the path to GHC.+-- | Given the name or path of an executable file, 'findExecutable' searches+-- for such a file in a list of system-defined locations, which generally+-- includes @PATH@ and possibly more.  The full path to the executable is+-- returned if found.  For example, @(findExecutable \"ghc\")@ would normally+-- give you the path to GHC. ----- The path returned by 'findExecutable' corresponds to the--- program that would be executed by 'System.Process.createProcess'--- when passed the same string (as a RawCommand, not a ShellCommand).+-- The path returned by @'findExecutable' name@ corresponds to the program+-- that would be executed by 'System.Process.createProcess' when passed the+-- same string (as a @RawCommand@, not a @ShellCommand@), provided that @name@+-- is not a relative path with more than one segment. ----- On Windows, 'findExecutable' calls the Win32 function 'SearchPath',--- which may search other places before checking the directories in--- @PATH@.  Where it actually searches depends on registry settings,--- but notably includes the directory containing the current--- executable. See--- <http://msdn.microsoft.com/en-us/library/aa365527.aspx> for more--- details.+-- On Windows, 'findExecutable' calls the Win32 function+-- @<https://msdn.microsoft.com/en-us/library/aa365527.aspx SearchPath>@,+-- which may search other places before checking the directories in the @PATH@+-- environment variable.  Where it actually searches depends on registry+-- settings, but notably includes the directory containing the current+-- executable. --+-- On non-Windows platforms, the behavior is equivalent to 'findFileWith'+-- using the search directories from the @PATH@ environment variable and+-- testing each file for executable permissions.  Details can be found in the+-- documentation of 'findFileWith'. findExecutable :: String -> IO (Maybe FilePath) findExecutable binary = do #if defined(mingw32_HOST_OS)@@ -1146,13 +1229,17 @@     findFileWith isExecutable path (binary <.> exeExtension) #endif --- | Given a file name, searches for the file and returns a list of all--- occurences that are executable.+-- | Search for executable files in a list of system-defined locations, which+-- generally includes @PATH@ and possibly more. ----- On Windows, this only returns the first ocurrence, if any.  It uses the--- @SearchPath@ from the Win32 API, so the caveats noted in 'findExecutable'--- apply here as well.+-- On Windows, this /only returns the first ocurrence/, if any.  Its behavior+-- is therefore equivalent to 'findExecutable'. --+-- On non-Windows platforms, the behavior is equivalent to+-- 'findExecutablesInDirectories' using the search directories from the @PATH@+-- environment variable.  Details can be found in the documentation of+-- 'findExecutablesInDirectories'.+-- -- @since 1.2.2.0 findExecutables :: String -> IO [FilePath] findExecutables binary = do@@ -1172,74 +1259,104 @@     return (splitSearchPath path) #endif --- | Given a file name, searches for the file on the given paths and returns a--- list of all occurences that are executable.+-- | Given a name or path, 'findExecutable' appends the 'exeExtension' to the+-- query and searches for executable files in the list of given search+-- directories and returns all occurrences. --+-- The behavior is equivalent to 'findFileWith' using the given search+-- directories and testing each file for executable permissions.  Details can+-- be found in the documentation of 'findFileWith'.+--+-- Unlike other similarly named functions, 'findExecutablesInDirectories' does+-- not use @SearchPath@ from the Win32 API.  The behavior of this function on+-- Windows is therefore equivalent to those on non-Windows platforms.+-- -- @since 1.2.4.0 findExecutablesInDirectories :: [FilePath] -> String -> IO [FilePath] findExecutablesInDirectories path binary =     findFilesWith isExecutable path (binary <.> exeExtension) --- | Test whether a file is executable.+-- | Test whether a file has executable permissions. isExecutable :: FilePath -> IO Bool isExecutable file = do     perms <- getPermissions file     return (executable perms) --- | Search through the given set of directories for the given file.+-- | Search through the given list of directories for the given file.+--+-- The behavior is equivalent to 'findFileWith', returning only the first+-- occurrence.  Details can be found in the documentation of 'findFileWith'. findFile :: [FilePath] -> String -> IO (Maybe FilePath) findFile = findFileWith (\_ -> return True) --- | Search through the given set of directories for the given file and--- returns a list of paths where the given file exists.+-- | Search through the given list of directories for the given file and+-- returns all paths where the given file exists. --+-- The behavior is equivalent to 'findFilesWith'.  Details can be found in the+-- documentation of 'findFilesWith'.+-- -- @since 1.2.1.0 findFiles :: [FilePath] -> String -> IO [FilePath] findFiles = findFilesWith (\_ -> return True) --- | Search through the given set of directories for the given file and--- with the given property (usually permissions) and returns the file path--- where the given file exists and has the property.+-- | Search through a given list of directories for a file that has the given+-- name and satisfies the given predicate and return the path of the first+-- occurrence.  The directories are checked in a left-to-right order. --+-- This is essentially a more performant version of 'findFilesWith' that+-- always returns the first result, if any.  Details can be found in the+-- documentation of 'findFilesWith'.+-- -- @since 1.2.6.0 findFileWith :: (FilePath -> IO Bool) -> [FilePath] -> String -> IO (Maybe FilePath)-findFileWith f ds name = asumMaybeT (map (findFileWithIn f name) ds)+findFileWith f ds name = listTHead (findFilesWithLazy f ds name) --- | 'Data.Foldable.asum' for 'Control.Monad.Trans.Maybe.MaybeT', essentially.+-- | @findFilesWith predicate dirs name@ searches through the list of+-- directories (@dirs@) for files that have the given @name@ and satisfy the+-- given @predicate@ ands return the paths of those files.  The directories+-- are checked in a left-to-right order and the paths are returned in the same+-- order. ----- Returns the first 'Just' in the list or 'Nothing' if there aren't any.-asumMaybeT :: Monad m => [m (Maybe a)] -> m (Maybe a)-asumMaybeT = foldr attempt (return Nothing)-  where-    attempt mmx mx' = do-        mx <- mmx-        case mx of-            Nothing -> mx'-            Just _  -> return mx---- | Search through the given set of directories for the given file and--- with the given property (usually permissions) and returns a list of--- paths where the given file exists and has the property.+-- If the @name@ is a relative path, then for every search directory @dir@,+-- the function checks whether @dir '</>' name@ exists and satisfies the+-- predicate.  If so, @dir '</>' name@ is returned as one of the results.  In+-- other words, the returned paths can be either relative or absolute+-- depending on the search directories were used.  If there are no search+-- directories, no results are ever returned. --+-- If the @name@ is an absolute path, then the function will return a single+-- result if the file exists and satisfies the predicate and no results+-- otherwise.  This is irrespective of what search directories were given.+-- -- @since 1.2.1.0 findFilesWith :: (FilePath -> IO Bool) -> [FilePath] -> String -> IO [FilePath]-findFilesWith f ds name = do-    mfiles <- mapM (findFileWithIn f name) ds-    return (catMaybes mfiles)+findFilesWith f ds name = listTToList (findFilesWithLazy f ds name) --- | Like 'findFileWith', but searches only a single directory.-findFileWithIn :: (FilePath -> IO Bool) -> String -> FilePath -> IO (Maybe FilePath)-findFileWithIn f name d = do-    let path = d </> name-    exist <- doesFileExist path-    if exist-        then do-            ok <- f path-            if ok-                then return (Just path)-                else return Nothing-        else return Nothing+findFilesWithLazy+  :: (FilePath -> IO Bool) -> [FilePath] -> String -> ListT IO FilePath+findFilesWithLazy f dirs path+  -- make sure absolute paths are handled properly irrespective of 'dirs'+  -- https://github.com/haskell/directory/issues/72+  | isAbsolute path = ListT (find [""])+  | otherwise       = ListT (find dirs) +  where++    find []       = return Nothing+    find (d : ds) = do+      let p = d </> path+      found <- doesFileExist p `andM` f p+      if found+        then return (Just (p, ListT (find ds)))+        else find ds++-- | Filename extension for executable files (including the dot if any)+--   (usually @\"\"@ on POSIX systems and @\".exe\"@ on Windows or OS\/2).+--+-- @since 1.2.4.0+exeExtension :: String+exeExtension = Cfg.exeExtension+ -- | Similar to 'listDirectory', but always includes the special entries (@.@ -- and @..@).  (This applies to Windows as well.) --@@ -1470,13 +1587,108 @@ #endif    `catchIOError` \ _ -> return False --- | Check whether the path refers to a symbolic link.  On Windows, this tests--- for @FILE_ATTRIBUTE_REPARSE_POINT@.+-- | Create a /file/ symbolic link.  The target path can be either absolute or+-- relative and need not refer to an existing file.  The order of arguments+-- follows the POSIX convention. --+-- To remove an existing file symbolic link, use 'removeFile'.+--+-- Although the distinction between /file/ symbolic links and /directory/+-- symbolic links does not exist on POSIX systems, on Windows this is an+-- intrinsic property of every symbolic link and cannot be changed without+-- recreating the link.  A file symbolic link that actually points to a+-- directory will fail to dereference and vice versa.  Moreover, creating+-- symbolic links on Windows requires privileges normally unavailable to users+-- outside the Administrators group.  Portable programs that use symbolic+-- links should take both into consideration.+--+-- On Windows, the function is implemented using @CreateSymbolicLink@ with+-- @dwFlags@ set to zero.  On POSIX, the function uses @symlink@ and+-- is therefore atomic.+--+-- Windows-specific errors: This operation may fail with 'permissionErrorType'+-- if the user lacks the privileges to create symbolic links.  It may also+-- fail with 'illegalOperationErrorType' if the file system does not support+-- symbolic links.+--+-- @since 1.3.1.0+createFileLink+  :: FilePath                           -- ^ path to the target file+  -> FilePath                           -- ^ path of the link to be created+  -> IO ()+createFileLink target link =+  (`ioeAddLocation` "createFileLink") `modifyIOError` do+#ifdef mingw32_HOST_OS+    createSymbolicLink False target link+#else+    Posix.createSymbolicLink target link+#endif++-- | Create a /directory/ symbolic link.  The target path can be either+-- absolute or relative and need not refer to an existing directory.  The+-- order of arguments follows the POSIX convention.+--+-- To remove an existing directory symbolic link, use 'removeDirectoryLink'.+--+-- Although the distinction between /file/ symbolic links and /directory/+-- symbolic links does not exist on POSIX systems, on Windows this is an+-- intrinsic property of every symbolic link and cannot be changed without+-- recreating the link.  A file symbolic link that actually points to a+-- directory will fail to dereference and vice versa.  Moreover, creating+-- symbolic links on Windows requires privileges normally unavailable to users+-- outside the Administrators group.  Portable programs that use symbolic+-- links should take both into consideration.+--+-- On Windows, the function is implemented using @CreateSymbolicLink@ with+-- @dwFlags@ set to @SYMBOLIC_LINK_FLAG_DIRECTORY@.  On POSIX, this is an+-- alias for 'createFileLink' and is therefore atomic.+--+-- Windows-specific errors: This operation may fail with 'permissionErrorType'+-- if the user lacks the privileges to create symbolic links.  It may also+-- fail with 'illegalOperationErrorType' if the file system does not support+-- symbolic links.+--+-- @since 1.3.1.0+createDirectoryLink+  :: FilePath                           -- ^ path to the target directory+  -> FilePath                           -- ^ path of the link to be created+  -> IO ()+createDirectoryLink target link =+  (`ioeAddLocation` "createDirectoryLink") `modifyIOError` do+#ifdef mingw32_HOST_OS+    createSymbolicLink True target link+#else+    createFileLink target link+#endif++-- | Remove an existing /directory/ symbolic link.+--+-- On Windows, this is an alias for 'removeDirectory'.  On POSIX systems, this+-- is an alias for 'removeFile'.+--+-- See also: 'removeFile', which can remove an existing /file/ symbolic link.+--+-- @since 1.3.1.0+removeDirectoryLink :: FilePath -> IO ()+removeDirectoryLink path =+  (`ioeAddLocation` "removeDirectoryLink") `modifyIOError` do+#ifdef mingw32_HOST_OS+    removeDirectory path+#else+    removeFile path+#endif++-- | Check whether the path refers to a symbolic link.  An exception is thrown+-- if the path does not exist or is inaccessible.+--+-- On Windows, this checks for @FILE_ATTRIBUTE_REPARSE_POINT@.  In addition to+-- symbolic links, the function also returns true on junction points.  On+-- POSIX systems, this checks for @S_IFLNK@.+-- -- @since 1.3.0.0 pathIsSymbolicLink :: FilePath -> IO Bool pathIsSymbolicLink path =-  (`ioeAddLocation` "getDirectoryType") `modifyIOError` do+  (`ioeAddLocation` "pathIsSymbolicLink") `modifyIOError` do #ifdef mingw32_HOST_OS     isReparsePoint <$> Win32.getFileAttributes path   where@@ -1489,7 +1701,29 @@ isSymbolicLink :: FilePath -> IO Bool isSymbolicLink = pathIsSymbolicLink +-- | Retrieve the target path of either a file or directory symbolic link.+-- The returned path may not be absolute, may not exist, and may not even be a+-- valid path.+--+-- On Windows systems, this calls @DeviceIoControl@ with+-- @FSCTL_GET_REPARSE_POINT@.  In addition to symbolic links, the function+-- also works on junction points.  On POSIX systems, this calls `readlink`.+--+-- Windows-specific errors: This operation may fail with+-- 'illegalOperationErrorType' if the file system does not support symbolic+-- links.+--+-- @since 1.3.1.0+getSymbolicLinkTarget :: FilePath -> IO FilePath+getSymbolicLinkTarget path =+  (`ioeAddLocation` "getSymbolicLinkTarget") `modifyIOError` do #ifdef mingw32_HOST_OS+    readSymbolicLink path+#else+    Posix.readSymbolicLink path+#endif++#ifdef mingw32_HOST_OS -- | Open the handle of an existing file or directory. openFileHandle :: String -> Win32.AccessMode -> IO Win32.HANDLE openFileHandle path mode = Win32.createFile path mode share Nothing@@ -1690,8 +1924,14 @@  #ifdef mingw32_HOST_OS withFileStatus :: String -> FilePath -> (Ptr CStat -> IO a) -> IO a-withFileStatus loc name f = do-  modifyIOError (`ioeSetFileName` name) $+withFileStatus loc name f =+  modifyIOError (`ioeSetFileName` name) $ do+    name' <- getFinalPathName name+    withSymbolicLinkStatus loc name' f++withSymbolicLinkStatus :: String -> FilePath -> (Ptr CStat -> IO a) -> IO a+withSymbolicLinkStatus loc name f = do+  modifyIOError (`ioeSetFileName` name) $ do     allocaBytes sizeof_stat $ \p ->       withFilePath (fileNameEndClean name) $ \s -> do         throwErrnoIfMinus1Retry_ loc (c_stat s p)

@@ -1,22 +1,29 @@ {-# LANGUAGE CPP #-}-{-# OPTIONS_HADDOCK hide #-}+-- |+-- Stability: unstable+-- Portability: unportable+--+-- Internal modules are always subject to change from version to version.+-- The contents of this module are also platform-dependent, hence what is+-- shown in the Hackage documentation may differ from what is actually+-- available on your system.+ #include <HsDirectoryConfig.h>  module System.Directory.Internal-  ( module System.Directory.Internal.Config--#ifdef HAVE_UTIMENSAT-  , module System.Directory.Internal.C_utimensat-#endif+  (  #ifdef mingw32_HOST_OS-  , module System.Directory.Internal.Windows+    module System.Directory.Internal.Windows #else-  , module System.Directory.Internal.Posix+    module System.Directory.Internal.Posix #endif +#ifdef HAVE_UTIMENSAT+  , module System.Directory.Internal.C_utimensat+#endif+   ) where-import System.Directory.Internal.Config  #ifdef HAVE_UTIMENSAT import System.Directory.Internal.C_utimensat

@@ -2,10 +2,6 @@ #include <HsDirectoryConfig.h> module System.Directory.Internal.Config where --- | Filename extension for executable files (including the dot if any)---   (usually @\"\"@ on POSIX systems and @\".exe\"@ on Windows or OS\/2).------ @since 1.2.4.0 exeExtension :: String exeExtension = EXE_EXTENSION -- We avoid using #const_str from hsc because it breaks cross-compilation

@@ -1,10 +1,18 @@ {-# LANGUAGE CPP #-}-{-# OPTIONS_HADDOCK hide #-}+-- |+-- Stability: unstable+-- Portability: portable+--+-- Internal modules are always subject to change from version to version.+ module System.Directory.Internal.Prelude   ( module Prelude-#if !MIN_VERSION_base(4, 8, 0)+#if MIN_VERSION_base(4, 8, 0)+  , module Data.Void+#else   , module Control.Applicative   , module Data.Functor+  , Void #endif   , module Control.Arrow   , module Control.Concurrent@@ -29,7 +37,6 @@   , module System.Posix.Internals   , module System.Posix.Types   , module System.Timeout-  , Void   ) where #if !MIN_VERSION_base(4, 6, 0) import Prelude hiding (catch)@@ -137,6 +144,7 @@ import System.IO.Error   ( IOError   , catchIOError+  , illegalOperationErrorType   , ioeGetErrorString   , ioeGetErrorType   , ioeGetLocation@@ -145,6 +153,7 @@   , ioeSetLocation   , isAlreadyExistsError   , isDoesNotExistError+  , isIllegalOperation   , isPermissionError   , mkIOError   , modifyIOError

@@ -14,9 +14,13 @@ #ifdef HAVE_SYS_STAT_H # include <sys/stat.h> #endif+#include <System/Directory/Internal/utility.h>+#include <System/Directory/Internal/windows.h> import Prelude () import System.Directory.Internal.Prelude-import System.FilePath (isRelative, normalise, splitDirectories)+import System.FilePath (isPathSeparator, isRelative, normalise,+                        pathSeparator, splitDirectories)+import qualified Data.List as List import qualified System.Win32 as Win32  win32_cSIDL_LOCAL_APPDATA :: Win32.CSIDL@@ -26,6 +30,9 @@ win32_cSIDL_LOCAL_APPDATA = (#const CSIDL_LOCAL_APPDATA) #endif +win32_eRROR_INVALID_FUNCTION :: Win32.ErrCode+win32_eRROR_INVALID_FUNCTION = 0x1+ win32_fILE_ATTRIBUTE_REPARSE_POINT :: Win32.FileAttributeOrFlag win32_fILE_ATTRIBUTE_REPARSE_POINT = (#const FILE_ATTRIBUTE_REPARSE_POINT) @@ -107,6 +114,151 @@     rawGetFinalPathName = win32_getLongPathName <=< win32_getShortPathName #endif +win32_fILE_FLAG_OPEN_REPARSE_POINT :: Win32.FileAttributeOrFlag+win32_fILE_FLAG_OPEN_REPARSE_POINT = 0x00200000++win32_fSCTL_GET_REPARSE_POINT :: Win32.DWORD+win32_fSCTL_GET_REPARSE_POINT = 0x900a8++win32_iO_REPARSE_TAG_MOUNT_POINT, win32_iO_REPARSE_TAG_SYMLINK :: CULong+win32_iO_REPARSE_TAG_MOUNT_POINT = (#const IO_REPARSE_TAG_MOUNT_POINT)+win32_iO_REPARSE_TAG_SYMLINK = (#const IO_REPARSE_TAG_SYMLINK)++win32_mAXIMUM_REPARSE_DATA_BUFFER_SIZE :: Win32.DWORD+win32_mAXIMUM_REPARSE_DATA_BUFFER_SIZE =+  (#const MAXIMUM_REPARSE_DATA_BUFFER_SIZE)++win32_sYMLINK_FLAG_RELATIVE :: CULong+win32_sYMLINK_FLAG_RELATIVE = 0x00000001++data Win32_REPARSE_DATA_BUFFER+  = Win32_MOUNT_POINT_REPARSE_DATA_BUFFER String String+    -- ^ substituteName printName+  | Win32_SYMLINK_REPARSE_DATA_BUFFER String String Bool+    -- ^ substituteName printName isRelative+  | Win32_GENERIC_REPARSE_DATA_BUFFER++win32_alloca_REPARSE_DATA_BUFFER+  :: ((Ptr Win32_REPARSE_DATA_BUFFER, Int) -> IO a) -> IO a+win32_alloca_REPARSE_DATA_BUFFER action =+  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)]}++win32_peek_REPARSE_DATA_BUFFER+  :: Ptr Win32_REPARSE_DATA_BUFFER -> IO Win32_REPARSE_DATA_BUFFER+win32_peek_REPARSE_DATA_BUFFER p = do+  tag <- #{peek HsDirectory_REPARSE_DATA_BUFFER, ReparseTag} p+  case () of+    _ | tag == win32_iO_REPARSE_TAG_MOUNT_POINT -> do+          let buf = #{ptr HsDirectory_REPARSE_DATA_BUFFER,+                          MountPointReparseBuffer.PathBuffer} p+          sni <- #{peek HsDirectory_REPARSE_DATA_BUFFER,+                        MountPointReparseBuffer.SubstituteNameOffset} p+          sns <- #{peek HsDirectory_REPARSE_DATA_BUFFER,+                        MountPointReparseBuffer.SubstituteNameLength} p+          sn <- peekName buf sni sns+          pni <- #{peek HsDirectory_REPARSE_DATA_BUFFER,+                        MountPointReparseBuffer.PrintNameOffset} p+          pns <- #{peek HsDirectory_REPARSE_DATA_BUFFER,+                        MountPointReparseBuffer.PrintNameLength} p+          pn <- peekName buf pni pns+          pure (Win32_MOUNT_POINT_REPARSE_DATA_BUFFER sn pn)+      | tag == win32_iO_REPARSE_TAG_SYMLINK -> do+          let buf = #{ptr HsDirectory_REPARSE_DATA_BUFFER,+                          SymbolicLinkReparseBuffer.PathBuffer} p+          sni <- #{peek HsDirectory_REPARSE_DATA_BUFFER,+                        SymbolicLinkReparseBuffer.SubstituteNameOffset} p+          sns <- #{peek HsDirectory_REPARSE_DATA_BUFFER,+                        SymbolicLinkReparseBuffer.SubstituteNameLength} p+          sn <- peekName buf sni sns+          pni <- #{peek HsDirectory_REPARSE_DATA_BUFFER,+                        SymbolicLinkReparseBuffer.PrintNameOffset} p+          pns <- #{peek HsDirectory_REPARSE_DATA_BUFFER,+                        SymbolicLinkReparseBuffer.PrintNameLength} p+          pn <- peekName buf pni pns+          flags <- #{peek HsDirectory_REPARSE_DATA_BUFFER,+                          SymbolicLinkReparseBuffer.Flags} p+          pure (Win32_SYMLINK_REPARSE_DATA_BUFFER sn pn+                (flags .&. win32_sYMLINK_FLAG_RELATIVE /= 0))+      | otherwise -> pure Win32_GENERIC_REPARSE_DATA_BUFFER+  where+    peekName :: Ptr CWchar -> CUShort -> CUShort -> IO String+    peekName buf offset size =+      peekCWStringLen ( buf `plusPtr` fromIntegral offset+                      , fromIntegral size `div` sizeOf (0 :: CWchar) )++deviceIoControl+  :: Win32.HANDLE+  -> Win32.DWORD+  -> (Ptr a, Int)+  -> (Ptr b, Int)+  -> Maybe Void+  -> IO (Either Win32.ErrCode Int)+deviceIoControl h code (inPtr, inSize) (outPtr, outSize) _ = do+  with 0 $ \ lenPtr -> do+    status <- c_DeviceIoControl h code inPtr (fromIntegral inSize) outPtr+                                (fromIntegral outSize) lenPtr nullPtr+    if not status+      then do+        Left <$> Win32.getLastError+      else+        Right . fromIntegral <$> peek lenPtr++foreign import WINAPI unsafe "windows.h DeviceIoControl"+  c_DeviceIoControl+    :: Win32.HANDLE+    -> Win32.DWORD+    -> Ptr a+    -> Win32.DWORD+    -> Ptr b+    -> Win32.DWORD+    -> Ptr Win32.DWORD+    -> Ptr Void+    -> IO Win32.BOOL++readSymbolicLink :: FilePath -> IO FilePath+readSymbolicLink path = modifyIOError (`ioeSetFileName` path) $ do+  let open = Win32.createFile (toExtendedLengthPath path)+                               0 shareMode Nothing Win32.oPEN_EXISTING+                               (Win32.fILE_FLAG_BACKUP_SEMANTICS .|.+                               win32_fILE_FLAG_OPEN_REPARSE_POINT) Nothing+  bracket open Win32.closeHandle $ \ h -> do+    win32_alloca_REPARSE_DATA_BUFFER $ \ ptrAndSize@(ptr, _) -> do+      result <- deviceIoControl h win32_fSCTL_GET_REPARSE_POINT+                                (nullPtr, 0) ptrAndSize Nothing+      case result of+        Left e | e == win32_eRROR_INVALID_FUNCTION -> do+                   let msg = "Incorrect function. The file system " <>+                             "might not support symbolic links."+                   throwIO (mkIOError illegalOperationErrorType+                                      "DeviceIoControl" Nothing Nothing+                            `ioeSetErrorString` msg)+               | otherwise -> Win32.failWith "DeviceIoControl" e+        Right _ -> return ()+      rData <- win32_peek_REPARSE_DATA_BUFFER ptr+      strip <$> case rData of+        Win32_MOUNT_POINT_REPARSE_DATA_BUFFER sn _ -> pure sn+        Win32_SYMLINK_REPARSE_DATA_BUFFER sn _ _ -> pure sn+        _ -> throwIO (mkIOError InappropriateType+                                "readSymbolicLink" Nothing Nothing)+  where+    shareMode =+      win32_fILE_SHARE_DELETE .|.+      Win32.fILE_SHARE_READ   .|.+      Win32.fILE_SHARE_WRITE+    strip sn = fromMaybe sn (List.stripPrefix "\\??\\" sn)++-- | Normalise the path separators and prepend the @"\\\\?\\"@ prefix if+-- necessary or possible.+normaliseSeparators :: FilePath -> FilePath+normaliseSeparators path+  | isRelative path = normaliseSep <$> path+  | otherwise = toExtendedLengthPath path+  where normaliseSep c = if isPathSeparator c then pathSeparator else c+ -- | Add the @"\\\\?\\"@ prefix if necessary or possible. -- The path remains unchanged if the prefix is not added. toExtendedLengthPath :: FilePath -> FilePath@@ -158,8 +310,58 @@       r' <- getPathNameWithLen len       case r' of         Right s -> pure s-        Left _ -> ioError (mkIOError OtherError "" Nothing Nothing+        Left _ -> throwIO (mkIOError OtherError "" Nothing Nothing                            `ioeSetErrorString` "path changed unexpectedly")++win32_createSymbolicLink :: String -> String -> Bool -> IO ()+win32_createSymbolicLink link _target _isDir =+#ifdef HAVE_CREATESYMBOLICLINKW+  withCWString link $ \ pLink ->+  withCWString _target $ \ pTarget -> do+    let flags = if _isDir then win32_sYMBOLIC_LINK_FLAG_DIRECTORY else 0+    status <- c_CreateSymbolicLink pLink pTarget flags+    if status == 0+      then do+        e <- Win32.getLastError+        case () of+          _ | e == win32_eRROR_INVALID_FUNCTION -> do+                let msg = "Incorrect function. The underlying file system " <>+                          "might not support symbolic links."+                throwIO (mkIOError illegalOperationErrorType+                                   "CreateSymbolicLink" Nothing (Just link)+                         `ioeSetErrorString` msg)+            | e == win32_eRROR_PRIVILEGE_NOT_HELD -> do+                let msg = "A required privilege is not held by the client. " <>+                          "Creating symbolic links usually requires " <>+                          "administrative rights."+                throwIO (mkIOError permissionErrorType "CreateSymbolicLink"+                                   Nothing (Just link)+                         `ioeSetErrorString` msg)+            | otherwise -> Win32.failWith "CreateSymbolicLink" e+      else return ()+  where++win32_eRROR_PRIVILEGE_NOT_HELD :: Win32.ErrCode+win32_eRROR_PRIVILEGE_NOT_HELD = 0x522++win32_sYMBOLIC_LINK_FLAG_DIRECTORY :: Win32.DWORD+win32_sYMBOLIC_LINK_FLAG_DIRECTORY = 0x1++foreign import WINAPI unsafe "windows.h CreateSymbolicLinkW"+  c_CreateSymbolicLink+    :: Ptr CWchar -> Ptr CWchar -> Win32.DWORD -> IO Win32.BYTE++#else+  throwIO . (`ioeSetErrorString` unsupportedErrorMsg) $+               mkIOError UnsupportedOperation "CreateSymbolicLink"+                         Nothing (Just link)+  where unsupportedErrorMsg = "Not supported on Windows XP or older"+#endif++createSymbolicLink :: Bool -> String -> String -> IO ()+createSymbolicLink isDir target link = do+  -- toExtendedLengthPath ensures the target gets normalised properly+  win32_createSymbolicLink link (normaliseSeparators target) isDir  foreign import ccall unsafe "_wchmod"   c_wchmod :: CWString -> CMode -> IO CInt

@@ -0,0 +1,29 @@+#include <windows.h>++// define prototype to get size, offsets, and alignments+// (can't include <ntifs.h> because that only exists in WDK)+typedef struct {+    ULONG ReparseTag;+    USHORT ReparseDataLength;+    USHORT Reserved;+    union {+        struct {+            USHORT SubstituteNameOffset;+            USHORT SubstituteNameLength;+            USHORT PrintNameOffset;+            USHORT PrintNameLength;+            ULONG Flags;+            WCHAR PathBuffer[1];+        } SymbolicLinkReparseBuffer;+        struct {+            USHORT SubstituteNameOffset;+            USHORT SubstituteNameLength;+            USHORT PrintNameOffset;+            USHORT PrintNameLength;+            WCHAR PathBuffer[1];+        } MountPointReparseBuffer;+        struct {+            UCHAR DataBuffer[1];+        } GenericReparseBuffer;+    };+} HsDirectory_REPARSE_DATA_BUFFER;

@@ -1,6 +1,32 @@ Changelog for the [`directory`][1] package ========================================== +## 1.3.1.0 (March 2017)++  * `findFile` (and similar functions): when an absolute path is given, the+    list of search directories is now completely ignored.  Previously, if the+    list was empty, `findFile` would always fail.+    ([#72](https://github.com/haskell/directory/issues/72))++  * For symbolic links on Windows, the following functions had previously+    interpreted paths as referring to the links themselves rather than their+    targets.  This was inconsistent with other platforms and has been fixed.+      * `getFileSize`+      * `doesPathExist`+      * `doesDirectoryExist`+      * `doesFileExist`++  * Fix incorrect location info in errors from `pathIsSymbolicLink`.++  * Add functions for symbolic link manipulation:+      * `createFileLink`+      * `createDirectoryLink`+      * `removeDirectoryLink`+      * `getSymbolicLinkTarget`++  * `canonicalizePath` can now resolve broken symbolic links too.+    ([#64](https://github.com/haskell/directory/issues/64))+ ## 1.3.0.2 (February 2017)    * [optimization] Increase internal buffer size of `copyFile`

@@ -3339,6 +3339,17 @@ fi done +for ac_func in CreateSymbolicLinkW+do :+  ac_fn_c_check_func "$LINENO" "CreateSymbolicLinkW" "ac_cv_func_CreateSymbolicLinkW"+if test "x$ac_cv_func_CreateSymbolicLinkW" = xyes; then :+  cat >>confdefs.h <<_ACEOF+#define HAVE_CREATESYMBOLICLINKW 1+_ACEOF++fi+done+ for ac_func in GetFinalPathNameByHandleW do :   ac_fn_c_check_func "$LINENO" "GetFinalPathNameByHandleW" "ac_cv_func_GetFinalPathNameByHandleW"

@@ -31,6 +31,7 @@ AC_CHECK_HEADERS([fcntl.h limits.h sys/types.h sys/stat.h time.h])  AC_CHECK_FUNCS([utimensat])+AC_CHECK_FUNCS([CreateSymbolicLinkW]) AC_CHECK_FUNCS([GetFinalPathNameByHandleW])  # EXTEXT is defined automatically by AC_PROG_CC;

@@ -1,5 +1,5 @@ name:           directory-version:        1.3.0.2+version:        1.3.1.0 -- NOTE: Don't forget to update ./changelog.md license:        BSD3 license-file:   LICENSE@@ -46,8 +46,8 @@         System.Directory.Internal         System.Directory.Internal.Prelude     other-modules:-        System.Directory.Internal.Config         System.Directory.Internal.C_utimensat+        System.Directory.Internal.Config         System.Directory.Internal.Posix         System.Directory.Internal.Windows 

@@ -4,10 +4,6 @@ import System.FilePath ((</>), dropFileName, dropTrailingPathSeparator,                         normalise, takeFileName) import TestUtils-#ifdef mingw32_HOST_OS-import System.Directory.Internal (win32_getFinalPathNameByHandle)-import qualified System.Win32 as Win32-#endif  main :: TestEnv -> IO () main _t = do@@ -68,47 +64,35 @@   T(expectEq) () fooNon fooNon7   T(expectEq) () fooNon fooNon8 -  supportsSymbolicLinks <- do-#ifdef mingw32_HOST_OS-    hasSymbolicLinkPrivileges <--      (True <$ createSymbolicLink "_symlinktest_src" "_symlinktest_dst")-        -- only test if symbolic links can be created-        -- (usually disabled on Windows by group policy)-        `catchIOError` \ e ->-          if isPermissionError e-          then pure False-          else ioError e--    supportsGetFinalPathNameByHandle <--      (True <$ win32_getFinalPathNameByHandle Win32.nullHANDLE 0)-        `catchIOError` \ e ->-          case ioeGetErrorType e of-            UnsupportedOperation -> pure False-            _ -> pure True--    pure (hasSymbolicLinkPrivileges && supportsGetFinalPathNameByHandle)-#else-    pure True-#endif-+  supportsSymbolicLinks <- supportsSymlinks   when supportsSymbolicLinks $ do      let barQux = dot </> "bar" </> "qux" -    createSymbolicLink "../bar" "foo/bar"+    -- 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" -    createSymbolicLink "foo" "lfoo"+    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" -    -- FIXME: uncomment this test once #64 is fixed-    -- createSymbolicLink "../foo/non-existent" "foo/qux"-    -- qux <- canonicalizePath "foo/qux"-    -- T(expectEq) () qux (dot </> "../foo/non-existent")+    -- regression test for #64+    createFileLink "../foo/non-existent" "foo/qux"+    qux <- canonicalizePath "foo/qux"+    T(expectEq) () qux =<< canonicalizePath "foo/non-existent"++    -- 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"))    caseInsensitive <-     (False <$ createDirectory "FOO")

@@ -1,10 +1,51 @@ {-# LANGUAGE CPP #-} module FindFile001 where #include "util.inl"+import qualified Data.List as List import System.FilePath ((</>))  main :: TestEnv -> IO () main _t = do++  createDirectory "bar"+  createDirectory "qux"   writeFile "foo" ""-  found <- findFile ("." : undefined) "foo"-  T(expectEq) () found (Just ("." </> "foo"))+  writeFile ("bar" </> "foo") ""+  writeFile ("qux" </> "foo") ":3"++  -- make sure findFile is lazy enough+  T(expectEq) () (Just ("." </> "foo")) =<< findFile ("." : undefined) "foo"++  -- make sure relative paths work+  T(expectEq) () (Just ("." </> "bar" </> "foo")) =<<+    findFile ["."] ("bar" </> "foo")++  T(expectEq) () (Just ("." </> "foo")) =<< findFile [".", "bar"] ("foo")+  T(expectEq) () (Just ("bar" </> "foo")) =<< findFile ["bar", "."] ("foo")++  let f fn = (== ":3") <$> readFile fn+  for_ (List.permutations ["qux", "bar", "."]) $ \ ds -> do++    let (match, noMatch) = List.partition (== "qux") ds++    T(expectEq) ds (Just (List.head match </> "foo")) =<<+      findFileWith f ds "foo"++    T(expectEq) ds ((</> "foo") <$> match) =<< findFilesWith f ds "foo"++    T(expectEq) ds (Just (List.head noMatch </> "foo")) =<<+      findFileWith ((not <$>) . f) ds "foo"++    T(expectEq) ds ((</> "foo") <$> noMatch) =<<+      findFilesWith ((not <$>) . f) ds "foo"++    T(expectEq) ds Nothing =<< findFileWith (\ _ -> return False) ds "foo"++    T(expectEq) ds [] =<< findFilesWith (\ _ -> return 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

@@ -5,14 +5,29 @@  main :: TestEnv -> IO () main _t = do-  success <- (createSymbolicLink "x" "y" >> return True)-#ifdef mingw32_HOST_OS-    -- only test if symbolic links can be created-    -- (usually disabled on Windows by group policy)-    `catchIOError` \ e ->-      if isPermissionError e-      then return False-      else ioError e-#endif-  when success $+  supportsSymbolicLinks <- supportsSymlinks+  when supportsSymbolicLinks $ do++    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"++    writeFile "x" ""+    createDirectory "a"++    T(expect) () =<< doesFileExist "y"+    T(expect) () =<< 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"

@@ -26,9 +26,9 @@   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")+  symlinkOrCopy (normalise "../a") (tmp "b/g")+  symlinkOrCopy (normalise "../b") (tmp "c/h")+  symlinkOrCopy (normalise "a")    (tmp "d")   modifyPermissions (tmp "c") (\ p -> p { writable = False })    ------------------------------------------------------------

@@ -28,9 +28,9 @@   writeFile (tmp "a/x/w/u") "foo"   writeFile (tmp "a/t")     "bar"   writeFile (tmp "f/s")     "qux"-  tryCreateSymbolicLink (normalise "../a") (tmp "b/g")-  tryCreateSymbolicLink (normalise "../b") (tmp "c/h")-  tryCreateSymbolicLink (normalise "a")    (tmp "d")+  symlinkOrCopy (normalise "../a") (tmp "b/g")+  symlinkOrCopy (normalise "../b") (tmp "c/h")+  symlinkOrCopy (normalise "a")    (tmp "d")   setPermissions (tmp "f/s") emptyPermissions   setPermissions (tmp "f") emptyPermissions 

@@ -1,33 +1,20 @@-{-# LANGUAGE CPP, ForeignFunctionInterface #-}+{-# LANGUAGE CPP #-}+-- | Utility functions specific to 'directory' tests module TestUtils   ( copyPathRecursive-  , createSymbolicLink   , modifyPermissions-  , tryCreateSymbolicLink+  , symlinkOrCopy+  , supportsSymlinks   ) where import Prelude () import System.Directory.Internal.Prelude import System.Directory-import System.FilePath ((</>))+import System.FilePath ((</>), normalise, takeDirectory) #ifdef mingw32_HOST_OS-import System.FilePath (takeDirectory)+import System.Directory.Internal (win32_getFinalPathNameByHandle) import qualified System.Win32 as Win32-#else-import System.Posix (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. --@@ -49,37 +36,61 @@   permissions <- getPermissions path   setPermissions path (modify permissions) +-- | On Windows, the handler is called if symbolic links are unsupported or+-- the user lacks the necessary privileges to create them.  On other+-- platforms, the handler is never run.+handleSymlinkUnavail+  :: IO a                               -- ^ handler+  -> IO a                               -- ^ arbitrary action+  -> IO a+handleSymlinkUnavail _handler action = action #ifdef mingw32_HOST_OS-createSymbolicLink :: String -> String -> IO ()-createSymbolicLink target link =-  (`ioeSetLocation` "createSymbolicLink") `modifyIOError` do-    isDir <- (fromIntegral . fromEnum) `fmap`-             doesDirectoryExist (takeDirectory link </> target)-    let target' = fixSlash <$> target-    withCWString target' $ \ pTarget ->-      withCWString link $ \ pLink -> do-        status <- c_CreateSymbolicLink pLink pTarget isDir-        if status == 0-          then do-            errCode <- Win32.getLastError-            if errCode == c_ERROR_PRIVILEGE_NOT_HELD-              then ioError . (`ioeSetErrorString` permissionErrorMsg) $-                   mkIOError permissionErrorType "" Nothing (Just link)-              else Win32.failWith "createSymbolicLink" errCode-          else return ()-  where c_ERROR_PRIVILEGE_NOT_HELD = 0x522-        permissionErrorMsg = "no permission to create symbolic links"-        fixSlash '/' = '\\'-        fixSlash c   = c+  `catchIOError` \ e ->+    case ioeGetErrorType e of+      UnsupportedOperation -> _handler+      _ | isIllegalOperation e || isPermissionError e -> _handler+      _ -> ioError e #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+-- | Create a symbolic link.  On Windows, this falls back to copying if+-- forbidden by Group Policy or is not supported.  On other platforms, there+-- is no fallback.  Also, automatically detect if the source is a file or a+-- directory and create the appropriate type of link.+symlinkOrCopy :: FilePath -> FilePath -> IO ()+symlinkOrCopy target link = do+  let fullTarget = takeDirectory link </> target+  handleSymlinkUnavail (copyPathRecursive fullTarget link) $ do+    isDir <- doesDirectoryExist fullTarget+    (if isDir then createDirectoryLink else createFileLink)+      (normalise target)+      link++supportsSymlinks :: IO Bool+supportsSymlinks = do+  canCreate <- supportsLinkCreation+  canDeref <- supportsLinkDeref+  return (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+-- returns 'True'.+supportsLinkCreation :: IO Bool+supportsLinkCreation = do+  let path = "_symlink_test.tmp"+  isSupported <- handleSymlinkUnavail (return False) $ do+    True <$ createFileLink path path+  when isSupported $ do+    removeFile path+  return isSupported++supportsLinkDeref :: IO Bool+supportsLinkDeref = do #ifdef mingw32_HOST_OS+    True <$ win32_getFinalPathNameByHandle Win32.nullHANDLE 0   `catchIOError` \ e ->-    if isPermissionError e-    then copyPathRecursive (takeDirectory link </> target) link-    else ioError e+    case ioeGetErrorType e of+      UnsupportedOperation -> return False+      _ -> return True+#else+    return True #endif

@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-}+-- | A rudimentary testing framework module Util where import Prelude () import System.Directory.Internal.Prelude