directory 1.3.1.0 → 1.3.1.1

raw patch · 13 files changed

+685/−463 lines, 13 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• System/Directory.hs +148/−405
• System/Directory/Internal.hs +8/−6
• System/Directory/Internal/Common.hs +120/−0
• System/Directory/Internal/Posix.hsc +95/−0
• System/Directory/Internal/Prelude.hs +3/−11
• System/Directory/Internal/Windows.hsc +186/−40
• changelog.md +13/−0
• directory.cabal +3/−1
• tests/CanonicalizePath.hs +18/−0
• tests/GetPermissions001.hs +15/−0
• tests/LongPaths.hs +61/−0
• tests/Main.hs +2/−0
• tests/MakeAbsolute.hs +13/−0

@@ -114,11 +114,7 @@ import System.Directory.Internal.Prelude import System.FilePath import Data.Time (UTCTime)-import Data.Time.Clock.POSIX-  ( posixSecondsToUTCTime-  , utcTimeToPOSIXSeconds-  , POSIXTime-  )+import Data.Time.Clock.POSIX (POSIXTime, utcTimeToPOSIXSeconds) import qualified System.Directory.Internal.Config as Cfg #ifdef mingw32_HOST_OS import qualified System.Win32 as Win32@@ -187,12 +183,6 @@  -} -data Permissions- = Permissions {-    readable,   writable,-    executable, searchable :: Bool-   } deriving (Eq, Ord, Read, Show)- emptyPermissions :: Permissions emptyPermissions = Permissions {                        readable   = False,@@ -213,125 +203,62 @@ setOwnerSearchable :: Bool -> Permissions -> Permissions setOwnerSearchable b p = p { searchable = b } -{- |The 'getPermissions' operation returns the-permissions for the file or directory.--The operation may fail with:--* 'isPermissionError' if the user is not permitted to access-  the permissions; or--* 'isDoesNotExistError' if the file or directory does not exist.---}-+-- | Get the permissions of a file or directory.+--+-- On Windows, the 'writable' permission corresponds to the "read-only"+-- attribute.  The 'executable' permission is set if the file extension is of+-- an executable file type.  The 'readable' permission is always set.+--+-- On POSIX systems, this returns the result of @access@.+--+-- The operation may fail with:+--+-- * 'isPermissionError' if the user is not permitted to access the+--   permissions, or+--+-- * 'isDoesNotExistError' if the file or directory does not exist. getPermissions :: FilePath -> IO Permissions-getPermissions name =-#ifdef mingw32_HOST_OS-  -- issue #9: Windows doesn't like trailing path separators-  withFilePath (dropTrailingPathSeparator name) $ \s ->-  -- 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 :-)-  ---  -- I tried for a while to do this properly, using the Windows security API,-  -- and eventually gave up.  getPermissions is a flawed API anyway. -- SimonM-  allocaBytes sizeof_stat $ \ p_stat -> do-  throwErrnoIfMinus1_ "getPermissions" $ c_stat s p_stat-  mode <- st_mode p_stat-  let usr_read   = mode .&. s_IRUSR-  let usr_write  = mode .&. s_IWUSR-  let usr_exec   = mode .&. s_IXUSR-  let is_dir = mode .&. s_IFDIR-  return (-    Permissions {-      readable   = usr_read  /= 0,-      writable   = usr_write /= 0,-      executable = is_dir == 0 && usr_exec /= 0,-      searchable = is_dir /= 0 && usr_exec /= 0-    }-   )-#else-  do-  read_ok  <- Posix.fileAccess name True  False False-  write_ok <- Posix.fileAccess name False True  False-  exec_ok  <- Posix.fileAccess name False False True-  stat <- Posix.getFileStatus name-  let is_dir = Posix.isDirectory stat-  return (-    Permissions {-      readable   = read_ok,-      writable   = write_ok,-      executable = not is_dir && exec_ok,-      searchable = is_dir && exec_ok-    }-   )-#endif--{- |The 'setPermissions' operation sets the-permissions for the file or directory.--The operation may fail with:--* 'isPermissionError' if the user is not permitted to set-  the permissions; or--* 'isDoesNotExistError' if the file or directory does not exist.---}+getPermissions path =+  (`ioeAddLocation` "getPermissions") `modifyIOError` do+    getAccessPermissions path +-- | Set the permissions of a file or directory.+--+-- On Windows, this is only capable of changing the 'writable' permission,+-- which corresponds to the "read-only" attribute.  Changing the other+-- permissions has no effect.+--+-- On POSIX systems, this sets the /owner/ permissions.+--+-- The operation may fail with:+--+-- * 'isPermissionError' if the user is not permitted to set the permissions,+--   or+--+-- * 'isDoesNotExistError' if the file or directory does not exist. setPermissions :: FilePath -> Permissions -> IO ()-setPermissions name (Permissions r w e s) =-#ifdef mingw32_HOST_OS-  allocaBytes sizeof_stat $ \ p_stat ->-  withFilePath name $ \p_name -> do-    throwErrnoIfMinus1_ "setPermissions" $-      c_stat p_name p_stat--    throwErrnoIfMinus1_ "setPermissions" $ do-      mode <- st_mode p_stat-      let mode1 = modifyBit r mode s_IRUSR-      let mode2 = modifyBit w mode1 s_IWUSR-      let mode3 = modifyBit (e || s) mode2 s_IXUSR-      c_wchmod p_name mode3- where-   modifyBit :: Bool -> CMode -> CMode -> CMode-   modifyBit False m b = m .&. (complement b)-   modifyBit True  m b = m .|. b-#else-  do-      stat <- Posix.getFileStatus name-      let mode = Posix.fileMode stat-      let mode1 = modifyBit r mode  Posix.ownerReadMode-      let mode2 = modifyBit w mode1 Posix.ownerWriteMode-      let mode3 = modifyBit (e || s) mode2 Posix.ownerExecuteMode-      Posix.setFileMode name mode3- where-   modifyBit :: Bool -> FileMode -> FileMode -> FileMode-   modifyBit False m b = m .&. (complement b)-   modifyBit True  m b = m .|. b-#endif+setPermissions path p =+  (`ioeAddLocation` "setPermissions") `modifyIOError` do+    setAccessPermissions path p +-- | Copy the permissions of one file to another.  This reproduces the+-- permissions more accurately than using 'getPermissions' followed by+-- 'setPermissions'.+--+-- On Windows, this copies only the read-only attribute.+--+-- On POSIX systems, this is equivalent to @stat@ followed by @chmod@. copyPermissions :: FilePath -> FilePath -> IO ()-copyPermissions source dest =-#ifdef mingw32_HOST_OS-  allocaBytes sizeof_stat $ \ p_stat ->-  withFilePath source $ \p_source ->-  withFilePath dest $ \p_dest -> do-    throwErrnoIfMinus1_ "copyPermissions" $ c_stat p_source p_stat-    mode <- st_mode p_stat-    throwErrnoIfMinus1_ "copyPermissions" $ c_wchmod p_dest mode-#else-  do-  stat <- Posix.getFileStatus source-  copyPermissionsFromStatus stat dest-#endif+copyPermissions src dst =+  (`ioeAddLocation` "copyPermissions") `modifyIOError` do+    m <- getFileMetadata src+    copyPermissionsFromMetadata m dst -#ifndef mingw32_HOST_OS-copyPermissionsFromStatus :: Posix.FileStatus -> FilePath -> IO ()-copyPermissionsFromStatus st dst = do-  Posix.setFileMode dst (Posix.fileMode st)-#endif+copyPermissionsFromMetadata :: Metadata -> FilePath -> IO ()+copyPermissionsFromMetadata m dst = do+  -- instead of setFileMode, setFilePermissions is used here+  -- this is to retain backward compatibility in copyPermissions+  setFilePermissions dst (modeFromMetadata m)  ----------------------------------------------------------------------------- -- Implementation@@ -376,7 +303,9 @@ createDirectory :: FilePath -> IO () createDirectory path = do #ifdef mingw32_HOST_OS-  Win32.createDirectory path Nothing+  (`ioeSetFileName` path) `modifyIOError` do+    path' <- toExtendedLengthPath <$> prependCurrentDirectory path+    Win32.createDirectory path' Nothing #else   Posix.createDirectory path 0o777 #endif@@ -421,46 +350,13 @@           -- directory.           | isAlreadyExistsError e          || isPermissionError    e -> do-              canIgnore <- isDir `catchIOError` \ _ ->-                           return (isAlreadyExistsError e)+              canIgnore <- pathIsDirectory dir+                             `catchIOError` \ _ ->+                               return (isAlreadyExistsError e)               unless canIgnore (ioError e)           | otherwise              -> ioError e-      where-#ifdef mingw32_HOST_OS-        isDir = withFileStatus "createDirectoryIfMissing" dir isDirectory-#else-        isDir = (Posix.isDirectory <$> Posix.getFileStatus dir)-#endif --- | * @'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 =-  (`ioeAddLocation` "getDirectoryType") `modifyIOError` do-#ifdef mingw32_HOST_OS-    isDir <- withSymbolicLinkStatus "getDirectoryType" path isDirectory-    if isDir-      then do-        isLink <- pathIsSymbolicLink path-        if isLink-          then return DirectoryLink-          else return Directory-      else do-        return NotDirectory-#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@@ -505,7 +401,9 @@ removeDirectory :: FilePath -> IO () removeDirectory path = #ifdef mingw32_HOST_OS-  Win32.removeDirectory path+  (`ioeSetFileName` path) `modifyIOError` do+    path' <- toExtendedLengthPath <$> prependCurrentDirectory path+    Win32.removeDirectory path' #else   Posix.removeDirectory path #endif@@ -518,13 +416,13 @@ removeDirectoryRecursive :: FilePath -> IO () removeDirectoryRecursive path =   (`ioeAddLocation` "removeDirectoryRecursive") `modifyIOError` do-    dirType <- getDirectoryType path-    case dirType of+    m <- getSymbolicLinkMetadata path+    case fileTypeFromMetadata m of       Directory ->         removeContentsRecursive path       DirectoryLink ->         ioError (err `ioeSetErrorString` "is a directory symbolic link")-      NotDirectory ->+      _ ->         ioError (err `ioeSetErrorString` "not a directory")   where err = mkIOError InappropriateType "" Nothing (Just path) @@ -534,11 +432,11 @@ removePathRecursive :: FilePath -> IO () removePathRecursive path =   (`ioeAddLocation` "removePathRecursive") `modifyIOError` do-    dirType <- getDirectoryType path-    case dirType of-      NotDirectory  -> removeFile path+    m <- getSymbolicLinkMetadata path+    case fileTypeFromMetadata m of       Directory     -> removeContentsRecursive path       DirectoryLink -> removeDirectory path+      _             -> removeFile path  -- | @'removeContentsRecursive' dir@ removes the contents of the directory -- /dir/ recursively. Symbolic links are removed without affecting their the@@ -573,15 +471,15 @@   (`ioeAddLocation` "removePathForcibly") `modifyIOError` do     makeRemovable path `catchIOError` \ _ -> return ()     ignoreDoesNotExistError $ do-      dirType <- getDirectoryType path-      case dirType of-        NotDirectory  -> removeFile path+      m <- getSymbolicLinkMetadata path+      case fileTypeFromMetadata m of         DirectoryLink -> removeDirectory path         Directory     -> do           names <- listDirectory path           sequenceWithIOErrors_ $             [ removePathForcibly (path </> name) | name <- names ] ++             [ removeDirectory path ]+        _             -> removeFile path   where      ignoreDoesNotExistError :: IO () -> IO ()@@ -650,7 +548,9 @@ removeFile :: FilePath -> IO () removeFile path = #ifdef mingw32_HOST_OS-  Win32.deleteFile path+  (`ioeSetFileName` path) `modifyIOError` do+    path' <- toExtendedLengthPath <$> prependCurrentDirectory path+    Win32.deleteFile path' #else   Posix.removeLink path #endif@@ -706,20 +606,13 @@  renameDirectory :: FilePath -> FilePath -> IO () renameDirectory opath npath =-   -- XXX this test isn't performed atomically with the following rename-#ifdef mingw32_HOST_OS-   -- ToDo: use Win32 API-   withFileStatus "renameDirectory" opath $ \st -> do-   is_dir <- isDirectory st-#else-   do-   stat <- Posix.getFileStatus opath-   let is_dir = Posix.fileMode stat .&. Posix.directoryMode /= 0-#endif-   when (not is_dir) $ do-     ioError . (`ioeSetErrorString` "not a directory") $-       (mkIOError InappropriateType "renameDirectory" Nothing (Just opath))-   renamePath opath npath+   (`ioeAddLocation` "renameDirectory") `modifyIOError` do+     -- XXX this test isn't performed atomically with the following rename+     isDir <- pathIsDirectory opath+     when (not isDir) $ do+       ioError . (`ioeSetErrorString` "not a directory") $+         (mkIOError InappropriateType "renameDirectory" Nothing (Just opath))+     renamePath opath npath  {- |@'renameFile' old new@ changes the name of an existing file system object from /old/ to /new/.  If the /new/ object already@@ -780,12 +673,11 @@        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 ()+           m <- tryIOError (getSymbolicLinkMetadata path)+           case fileTypeFromMetadata <$> m of+             Right Directory     -> errIsDir path+             Right DirectoryLink -> errIsDir path+             _                   -> return ()          errIsDir path = ioError . (`ioeSetErrorString` "is a directory") $                          mkIOError InappropriateType "" Nothing (Just path) @@ -836,7 +728,10 @@            -> IO () renamePath opath npath = (`ioeAddLocation` "renamePath") `modifyIOError` do #ifdef mingw32_HOST_OS-   Win32.moveFileEx opath npath Win32.mOVEFILE_REPLACE_EXISTING+   (`ioeSetFileName` opath) `modifyIOError` do+     opath' <- toExtendedLengthPath <$> prependCurrentDirectory opath+     npath' <- toExtendedLengthPath <$> prependCurrentDirectory npath+     Win32.moveFileEx opath' npath' Win32.mOVEFILE_REPLACE_EXISTING #else    Posix.rename opath npath #endif@@ -956,7 +851,10 @@   (`ioeAddLocation` "copyFileWithMetadata") `modifyIOError` doCopy   where #ifdef mingw32_HOST_OS-    doCopy = Win32.copyFile src dst False+    doCopy = (`ioeSetFileName` src) `modifyIOError` do+      src' <- toExtendedLengthPath <$> prependCurrentDirectory src+      dst' <- toExtendedLengthPath <$> prependCurrentDirectory dst+      Win32.copyFile src' dst' False #else     doCopy = do       st <- Posix.getFileStatus src@@ -968,7 +866,7 @@ copyMetadataFromStatus :: Posix.FileStatus -> FilePath -> IO () copyMetadataFromStatus st dst = do   tryCopyOwnerAndGroupFromStatus st dst-  copyPermissionsFromStatus st dst+  copyPermissionsFromMetadata st dst   copyFileTimesFromStatus st dst #endif @@ -994,7 +892,8 @@ #ifndef mingw32_HOST_OS copyFileTimesFromStatus :: Posix.FileStatus -> FilePath -> IO () copyFileTimesFromStatus st dst = do-  let (atime, mtime) = fileTimesFromStatus st+  let atime = accessTimeFromMetadata st+  let mtime = modificationTimeFromMetadata st   setFileTimes dst (Just atime, Just mtime) #endif @@ -1074,7 +973,8 @@     transform = attemptRealpath getFinalPathName      simplify path =-      Win32.getFullPathName path+      (fromExtendedLengthPath <$>+       Win32.getFullPathName (toExtendedLengthPath path))         `catchIOError` \ _ ->           return path #else@@ -1163,23 +1063,6 @@                  (`ioeSetFileName` path)) $   matchTrailingSeparator path . normalise <$> prependCurrentDirectory path --- | Convert a path into an absolute path.  If the given path is relative, the--- current directory is prepended.  If the path is already absolute, the path--- is returned unchanged.  The function preserves the presence or absence of--- the trailing path separator.------ If the path is already absolute, the operation never fails.  Otherwise, the--- operation may fail with the same exceptions as 'getCurrentDirectory'.------ (internal API)-prependCurrentDirectory :: FilePath -> IO FilePath-prependCurrentDirectory path =-  modifyIOError ((`ioeAddLocation` "prependCurrentDirectory") .-                 (`ioeSetFileName` path)) $-  if isRelative path -- avoid the call to `getCurrentDirectory` if we can-  then (</> path) <$> getCurrentDirectory-  else return path- -- | Add or remove the trailing path separator in the second path so as to -- match its presence in the first path. --@@ -1380,8 +1263,9 @@           then return (acc [])           else loop (acc . (e:)) #else+  query <- toExtendedLengthPath <$> prependCurrentDirectory (path </> "*")   bracket-     (Win32.findFirstFile (path </> "*"))+     (Win32.findFirstFile query)      (\(h,_) -> Win32.findClose h)      (\(h,fdat) -> loop h fdat [])   where@@ -1433,47 +1317,6 @@   (filter f) <$> (getDirectoryContents path)   where f filename = filename /= "." && filename /= ".." --- | Obtain the current working directory as an absolute path.------ In a multithreaded program, the current working directory is a global state--- shared among all threads of the process.  Therefore, when performing--- filesystem operations from multiple threads, it is highly recommended to--- use absolute rather than relative paths (see: 'makeAbsolute').------ The operation may fail with:------ * 'HardwareFault'--- A physical I\/O error has occurred.--- @[EIO]@------ * 'isDoesNotExistError' or 'NoSuchThing'--- There is no path referring to the working directory.--- @[EPERM, ENOENT, ESTALE...]@------ * 'isPermissionError' or 'PermissionDenied'--- The process has insufficient privileges to perform the operation.--- @[EACCES]@------ * 'ResourceExhausted'--- Insufficient resources are available to perform the operation.------ * 'UnsupportedOperation'--- The operating system has no notion of current working directory.----getCurrentDirectory :: IO FilePath-getCurrentDirectory =-  modifyIOError (`ioeAddLocation` "getCurrentDirectory") $-  specializeErrorString-    "Current working directory no longer exists"-    isDoesNotExistError-    getCwd-  where-#ifdef mingw32_HOST_OS-    getCwd = Win32.getCurrentDirectory-#else-    getCwd = Posix.getWorkingDirectory-#endif- -- | Change the working directory to the given path. -- -- In a multithreaded program, the current working directory is a global state@@ -1508,11 +1351,13 @@ -- @[ENOTDIR]@ -- setCurrentDirectory :: FilePath -> IO ()-setCurrentDirectory =+setCurrentDirectory path = do #ifdef mingw32_HOST_OS-  Win32.setCurrentDirectory+  -- SetCurrentDirectory does not support long paths even with the \\?\ prefix+  -- https://ghc.haskell.org/trac/ghc/ticket/13373#comment:6+  Win32.setCurrentDirectory path #else-  Posix.changeWorkingDirectory+  Posix.changeWorkingDirectory path #endif  -- | Run an 'IO' action with the given working directory and restore the@@ -1538,11 +1383,7 @@ getFileSize :: FilePath -> IO Integer getFileSize path =   (`ioeAddLocation` "getFileSize") `modifyIOError` do-#ifdef mingw32_HOST_OS-    fromIntegral <$> withFileStatus "" path st_size-#else-    fromIntegral . Posix.fileSize <$> Posix.getFileStatus path-#endif+    fileSizeFromMetadata <$> getFileMetadata path  -- | Test whether the given path points to an existing filesystem object.  If -- the user lacks necessary permissions to search the parent directories, this@@ -1550,13 +1391,10 @@ -- -- @since 1.2.7.0 doesPathExist :: FilePath -> IO Bool-doesPathExist path =-#ifdef mingw32_HOST_OS-  (withFileStatus "" path $ \ _ -> return True)-#else-  (Posix.getFileStatus path >> return True)-#endif-  `catchIOError` \ _ -> return False+doesPathExist path = do+  (True <$ getFileMetadata path)+    `catchIOError` \ _ ->+      return False  {- |The operation 'doesDirectoryExist' returns 'True' if the argument file exists and is either a directory or a symbolic link to a directory,@@ -1564,29 +1402,29 @@ -}  doesDirectoryExist :: FilePath -> IO Bool-doesDirectoryExist name =-#ifdef mingw32_HOST_OS-   (withFileStatus "doesDirectoryExist" name $ \st -> isDirectory st)-#else-   (do stat <- Posix.getFileStatus name-       return (Posix.isDirectory stat))-#endif-   `catchIOError` \ _ -> return False+doesDirectoryExist path = do+  pathIsDirectory path+    `catchIOError` \ _ ->+      return False  {- |The operation 'doesFileExist' returns 'True' if the argument file exists and is not a directory, and 'False' otherwise. -}  doesFileExist :: FilePath -> IO Bool-doesFileExist name =-#ifdef mingw32_HOST_OS-   (withFileStatus "doesFileExist" name $ \st -> do b <- isDirectory st; return (not b))-#else-   (do stat <- Posix.getFileStatus name-       return (not (Posix.isDirectory stat)))-#endif-   `catchIOError` \ _ -> return False+doesFileExist path = do+  (not <$> pathIsDirectory path)+    `catchIOError` \ _ ->+      return False +pathIsDirectory :: FilePath -> IO Bool+pathIsDirectory path = (`ioeAddLocation` "pathIsDirectory") `modifyIOError` do+  m <- getFileMetadata path+  case fileTypeFromMetadata m of+    Directory     -> return True+    DirectoryLink -> return True+    _             -> return False+ -- | 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.@@ -1688,14 +1526,14 @@ -- @since 1.3.0.0 pathIsSymbolicLink :: FilePath -> IO Bool pathIsSymbolicLink path =-  (`ioeAddLocation` "pathIsSymbolicLink") `modifyIOError` do-#ifdef mingw32_HOST_OS-    isReparsePoint <$> Win32.getFileAttributes path-  where-    isReparsePoint attr = attr .&. win32_fILE_ATTRIBUTE_REPARSE_POINT /= 0-#else-    Posix.isSymbolicLink <$> Posix.getSymbolicLinkStatus path-#endif+  ((`ioeAddLocation` "pathIsSymbolicLink") .+   (`ioeSetFileName` path)) `modifyIOError` do+    m <- getSymbolicLinkMetadata path+    return $+      case fileTypeFromMetadata m of+        DirectoryLink -> True+        SymbolicLink  -> True+        _             -> False  {-# DEPRECATED isSymbolicLink "Use 'pathIsSymbolicLink' instead" #-} isSymbolicLink :: FilePath -> IO Bool@@ -1726,12 +1564,12 @@ #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-                                            Win32.oPEN_EXISTING flags Nothing-  where share =  win32_fILE_SHARE_DELETE-             .|. Win32.fILE_SHARE_READ-             .|. Win32.fILE_SHARE_WRITE-        flags =  Win32.fILE_ATTRIBUTE_NORMAL+openFileHandle path mode =+  (`ioeSetFileName` path) `modifyIOError` do+    path' <- toExtendedLengthPath <$> prependCurrentDirectory path+    Win32.createFile path' mode maxShareMode Nothing+                     Win32.oPEN_EXISTING flags Nothing+  where flags =  Win32.fILE_ATTRIBUTE_NORMAL              .|. Win32.fILE_FLAG_BACKUP_SEMANTICS -- required for directories #endif @@ -1751,8 +1589,9 @@ -- @since 1.2.3.0 -- getAccessTime :: FilePath -> IO UTCTime-getAccessTime = modifyIOError (`ioeAddLocation` "getAccessTime") .-                (fst <$>) . getFileTimes+getAccessTime path =+  modifyIOError (`ioeAddLocation` "getAccessTime") $ do+    accessTimeFromMetadata <$> getFileMetadata path  -- | Obtain the time at which the file or directory was last modified. --@@ -1768,42 +1607,9 @@ -- and the underlying filesystem supports them. -- getModificationTime :: FilePath -> IO UTCTime-getModificationTime = modifyIOError (`ioeAddLocation` "getModificationTime") .-                      (snd <$>) . getFileTimes--getFileTimes :: FilePath -> IO (UTCTime, UTCTime)-getFileTimes path =-  modifyIOError (`ioeAddLocation` "getFileTimes") .-  modifyIOError (`ioeSetFileName` path) $-    getTimes-  where-    path' = normalise path              -- handle empty paths-#ifdef mingw32_HOST_OS-    getTimes =-      bracket (openFileHandle path' Win32.gENERIC_READ)-              Win32.closeHandle $ \ handle ->-      alloca $ \ atime ->-      alloca $ \ mtime -> do-        Win32.failIf_ not "" $-          Win32.c_GetFileTime handle nullPtr atime mtime-        ((,) `on` posixSecondsToUTCTime . windowsToPosixTime)-          <$> peek atime-          <*> peek mtime-#else-    getTimes = fileTimesFromStatus <$> Posix.getFileStatus path'-#endif--#ifndef mingw32_HOST_OS-fileTimesFromStatus :: Posix.FileStatus -> (UTCTime, UTCTime)-fileTimesFromStatus st =-# if MIN_VERSION_unix(2, 6, 0)-  ( posixSecondsToUTCTime (Posix.accessTimeHiRes st)-  , posixSecondsToUTCTime (Posix.modificationTimeHiRes st) )-# else-  ( posixSecondsToUTCTime (realToFrac (Posix.accessTime st))-  , posixSecondsToUTCTime (realToFrac (Posix.modificationTime st)) )-# endif-#endif+getModificationTime path =+  modifyIOError (`ioeAddLocation` "getModificationTime") $ do+    modificationTimeFromMetadata <$> getFileMetadata path  -- | Change the time at which the file or directory was last accessed. --@@ -1889,7 +1695,9 @@ #else     setTimes (Just atime', Just mtime') = setFileTimes' path' atime' mtime'     setTimes (atime', mtime') = do-      (atimeOld, mtimeOld) <- fileTimesFromStatus <$> Posix.getFileStatus path'+      m <- getFileMetadata path'+      let atimeOld = accessTimeFromMetadata m+      let mtimeOld = modificationTimeFromMetadata m       setFileTimes' path'         (fromMaybe (utcTimeToPOSIXSeconds atimeOld) atime')         (fromMaybe (utcTimeToPOSIXSeconds mtimeOld) mtime')@@ -1905,48 +1713,6 @@ # endif #endif -#ifdef mingw32_HOST_OS--- | Difference between the Windows and POSIX epochs in units of 100ns.-windowsPosixEpochDifference :: Num a => a-windowsPosixEpochDifference = 116444736000000000---- | Convert from Windows time to POSIX time.-windowsToPosixTime :: Win32.FILETIME -> POSIXTime-windowsToPosixTime (Win32.FILETIME t) =-  (fromIntegral t - windowsPosixEpochDifference) / 10000000---- | Convert from POSIX time to Windows time.  This is lossy as Windows time---   has a resolution of only 100ns.-posixToWindowsTime :: POSIXTime -> Win32.FILETIME-posixToWindowsTime t = Win32.FILETIME $-  truncate (t * 10000000 + windowsPosixEpochDifference)-#endif--#ifdef mingw32_HOST_OS-withFileStatus :: String -> FilePath -> (Ptr CStat -> IO a) -> IO a-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)-        f p--isDirectory :: Ptr CStat -> IO Bool-isDirectory stat = do-  mode <- st_mode stat-  return (s_isdir mode)--fileNameEndClean :: String -> String-fileNameEndClean name = if isDrive name then addTrailingPathSeparator name-                                        else dropTrailingPathSeparator name-#endif- {- | Returns the current user's home directory.  The directory returned is expected to be writable by the current user,@@ -2062,22 +1828,6 @@     Right value -> return (Just value) #endif --- | Similar to 'try' but only catches a specify kind of 'IOError' as---   specified by the predicate.-tryIOErrorType :: (IOError -> Bool) -> IO a -> IO (Either IOError a)-tryIOErrorType check action = do-  result <- tryIOError action-  case result of-    Left  err -> if check err then return (Left err) else ioError err-    Right val -> return (Right val)--specializeErrorString :: String -> (IOError -> Bool) -> IO a -> IO a-specializeErrorString str errType action = do-  mx <- tryIOErrorType errType action-  case mx of-    Left  e -> ioError (ioeSetErrorString e str)-    Right x -> return x- -- | Obtain the path to a special directory for storing user-specific --   application data (traditional Unix location).  Newer applications may --   prefer the the XDG-conformant location provided by 'getXdgDirectory'@@ -2180,10 +1930,3 @@   getEnv "TMPDIR" `catchIOError` \ err ->   if isDoesNotExistError err then return "/tmp" else ioError err #endif--ioeAddLocation :: IOError -> String -> IOError-ioeAddLocation e loc = do-  ioeSetLocation e newLoc-  where-    newLoc = loc <> if null oldLoc then "" else ":" <> oldLoc-    oldLoc = ioeGetLocation e

@@ -11,12 +11,12 @@ #include <HsDirectoryConfig.h>  module System.Directory.Internal-  (+  ( module System.Directory.Internal.Common  #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@@ -25,12 +25,14 @@    ) where -#ifdef HAVE_UTIMENSAT-import System.Directory.Internal.C_utimensat-#endif+import System.Directory.Internal.Common  #ifdef mingw32_HOST_OS import System.Directory.Internal.Windows #else import System.Directory.Internal.Posix+#endif++#ifdef HAVE_UTIMENSAT+import System.Directory.Internal.C_utimensat #endif

@@ -0,0 +1,120 @@+{-# LANGUAGE CPP #-}+module System.Directory.Internal.Common where+import Prelude ()+import System.Directory.Internal.Prelude+import System.FilePath ((</>), isPathSeparator, isRelative,+                        pathSeparator, splitDrive, takeDrive)+#ifdef mingw32_HOST_OS+import qualified System.Win32 as Win32+#else+import qualified System.Posix as Posix+#endif++-- | Similar to 'try' but only catches a specify kind of 'IOError' as+--   specified by the predicate.+tryIOErrorType :: (IOError -> Bool) -> IO a -> IO (Either IOError a)+tryIOErrorType check action = do+  result <- tryIOError action+  case result of+    Left  err -> if check err then return (Left err) else ioError err+    Right val -> return (Right val)++specializeErrorString :: String -> (IOError -> Bool) -> IO a -> IO a+specializeErrorString str errType action = do+  mx <- tryIOErrorType errType action+  case mx of+    Left  e -> ioError (ioeSetErrorString e str)+    Right x -> return x++ioeAddLocation :: IOError -> String -> IOError+ioeAddLocation e loc = do+  ioeSetLocation e newLoc+  where+    newLoc = loc <> if null oldLoc then "" else ":" <> oldLoc+    oldLoc = ioeGetLocation e++data FileType = File+              | SymbolicLink -- ^ POSIX: either file or directory link; Windows: file link+              | Directory+              | DirectoryLink -- ^ Windows only+              deriving (Bounded, Enum, Eq, Ord, Read, Show)++-- | Check whether the given 'FileType' is considered a directory by the+-- operating system.  This affects the choice of certain functions+-- e.g. `removeDirectory` vs `removeFile`.+fileTypeIsDirectory :: FileType -> Bool+fileTypeIsDirectory Directory     = True+fileTypeIsDirectory DirectoryLink = True+fileTypeIsDirectory _             = False++data Permissions+  = Permissions+  { readable :: Bool+  , writable :: Bool+  , executable :: Bool+  , searchable :: Bool+  } deriving (Eq, Ord, Read, Show)++-- | Obtain the current working directory as an absolute path.+--+-- In a multithreaded program, the current working directory is a global state+-- shared among all threads of the process.  Therefore, when performing+-- filesystem operations from multiple threads, it is highly recommended to+-- use absolute rather than relative paths (see: 'makeAbsolute').+--+-- The operation may fail with:+--+-- * 'HardwareFault'+-- A physical I\/O error has occurred.+-- @[EIO]@+--+-- * 'isDoesNotExistError' or 'NoSuchThing'+-- There is no path referring to the working directory.+-- @[EPERM, ENOENT, ESTALE...]@+--+-- * 'isPermissionError' or 'PermissionDenied'+-- The process has insufficient privileges to perform the operation.+-- @[EACCES]@+--+-- * 'ResourceExhausted'+-- Insufficient resources are available to perform the operation.+--+-- * 'UnsupportedOperation'+-- The operating system has no notion of current working directory.+--+getCurrentDirectory :: IO FilePath+getCurrentDirectory = (`ioeAddLocation` "getCurrentDirectory") `modifyIOError`+  specializeErrorString+    "Current working directory no longer exists"+    isDoesNotExistError+#ifdef mingw32_HOST_OS+    Win32.getCurrentDirectory+#else+    Posix.getWorkingDirectory+#endif++-- | Convert a path into an absolute path.  If the given path is relative, the+-- current directory is prepended.  If the path is already absolute, the path+-- is returned unchanged.  The function preserves the presence or absence of+-- the trailing path separator.+--+-- If the path is already absolute, the operation never fails.  Otherwise, the+-- operation may fail with the same exceptions as 'getCurrentDirectory'.+--+-- (internal API)+prependCurrentDirectory :: FilePath -> IO FilePath+prependCurrentDirectory path =+  modifyIOError ((`ioeAddLocation` "prependCurrentDirectory") .+                 (`ioeSetFileName` path)) $+  if isRelative path -- avoid the call to `getCurrentDirectory` if we can+  then do+    cwd <- getCurrentDirectory+    let curDrive = takeWhile (not . isPathSeparator) (takeDrive cwd)+    let (drive, subpath) = splitDrive path+    -- handle drive-relative paths (Windows only)+    return . (</> subpath) $+      case drive of+        _ : _ | (toUpper <$> drive) /= (toUpper <$> curDrive) ->+                  drive <> [pathSeparator]+        _ -> cwd+  else return path

@@ -6,6 +6,11 @@ #endif import Prelude () import System.Directory.Internal.Prelude+import System.Directory.Internal.Common+import Data.Time (UTCTime)+import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime)+import System.FilePath (normalise)+import qualified System.Posix as Posix  -- we use the 'free' from the standard library here since it's not entirely -- clear whether Haskell's 'free' corresponds to the same one@@ -34,5 +39,95 @@     -- allocate one extra just to be safe     allocaBytes (pathMax + 1) (realpath >=> action)   where realpath = throwErrnoIfNull "" . c_realpath path++type Metadata = Posix.FileStatus++-- note: normalise is needed to handle empty paths++getSymbolicLinkMetadata :: FilePath -> IO Metadata+getSymbolicLinkMetadata = Posix.getSymbolicLinkStatus . normalise++getFileMetadata :: FilePath -> IO Metadata+getFileMetadata = Posix.getFileStatus . normalise++fileTypeFromMetadata :: Metadata -> FileType+fileTypeFromMetadata stat+  | isLink    = SymbolicLink+  | isDir     = Directory+  | otherwise = File+  where+    isLink = Posix.isSymbolicLink stat+    isDir  = Posix.isDirectory stat++fileSizeFromMetadata :: Metadata -> Integer+fileSizeFromMetadata = fromIntegral . Posix.fileSize++accessTimeFromMetadata :: Metadata -> UTCTime+accessTimeFromMetadata =+  posixSecondsToUTCTime . posix_accessTimeHiRes++modificationTimeFromMetadata :: Metadata -> UTCTime+modificationTimeFromMetadata =+  posixSecondsToUTCTime . posix_modificationTimeHiRes++posix_accessTimeHiRes, posix_modificationTimeHiRes+  :: Posix.FileStatus -> POSIXTime+#if MIN_VERSION_unix(2, 6, 0)+posix_accessTimeHiRes = Posix.accessTimeHiRes+posix_modificationTimeHiRes = Posix.modificationTimeHiRes+#else+posix_accessTimeHiRes = realToFrac . Posix.accessTime+posix_modificationTimeHiRes = realToFrac . Posix.modificationTime+#endif++type Mode = Posix.FileMode++modeFromMetadata :: Metadata -> Mode+modeFromMetadata = Posix.fileMode++allWriteMode :: Posix.FileMode+allWriteMode =+  Posix.ownerWriteMode .|.+  Posix.groupWriteMode .|.+  Posix.otherWriteMode++hasWriteMode :: Mode -> Bool+hasWriteMode m = m .&. allWriteMode /= 0++setWriteMode :: Bool -> Mode -> Mode+setWriteMode False m = m .&. complement allWriteMode+setWriteMode True  m = m .|. allWriteMode++setFileMode :: FilePath -> Mode -> IO ()+setFileMode = Posix.setFileMode++setFilePermissions :: FilePath -> Mode -> IO ()+setFilePermissions = setFileMode++getAccessPermissions :: FilePath -> IO Permissions+getAccessPermissions path = do+  m <- getFileMetadata path+  let isDir = fileTypeIsDirectory (fileTypeFromMetadata m)+  r <- Posix.fileAccess path True  False False+  w <- Posix.fileAccess path False True  False+  x <- Posix.fileAccess path False False True+  return Permissions+         { readable   = r+         , writable   = w+         , executable = x && not isDir+         , searchable = x && isDir+         }++setAccessPermissions :: FilePath -> Permissions -> IO ()+setAccessPermissions path (Permissions r w e s) = do+  m <- getFileMetadata path+  setFileMode path (modifyBit (e || s) Posix.ownerExecuteMode .+                    modifyBit w Posix.ownerWriteMode .+                    modifyBit r Posix.ownerReadMode .+                    modeFromMetadata $ m)+  where+    modifyBit :: Bool -> Posix.FileMode -> Posix.FileMode -> Posix.FileMode+    modifyBit False b m = m .&. complement b+    modifyBit True  b m = m .|. b  #endif

@@ -69,7 +69,7 @@   ) import Control.Monad ((>=>), (<=<), unless, when, replicateM_) import Data.Bits ((.&.), (.|.), complement)-import Data.Char (isAlpha, isAscii, toLower)+import Data.Char (isAlpha, isAscii, toLower, toUpper) import Data.Foldable (for_, traverse_) import Data.Function (on) import Data.Maybe (catMaybes, fromMaybe, maybeToList)@@ -161,16 +161,8 @@   , tryIOError   , userError   )-import System.Posix.Internals-  ( CStat-  , c_stat-  , withFilePath-  , s_isdir-  , sizeof_stat-  , st_mode-  , st_size-  )-import System.Posix.Types (CMode(..), EpochTime, FileMode)+import System.Posix.Internals (withFilePath)+import System.Posix.Types (EpochTime) import System.Timeout (timeout)  #if !MIN_VERSION_base(4, 8, 0)

@@ -11,15 +11,17 @@ ##endif #include <shlobj.h> #include <windows.h>-#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 (isPathSeparator, isRelative, normalise,-                        pathSeparator, splitDirectories)+import System.Directory.Internal.Common+import Data.Time (UTCTime)+import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime)+import System.FilePath (addTrailingPathSeparator, hasTrailingPathSeparator,+                        isPathSeparator, isRelative, joinDrive, joinPath,+                        normalise, pathSeparator, pathSeparators,+                        splitDirectories, splitDrive, takeExtension) import qualified Data.List as List import qualified System.Win32 as Win32 @@ -34,7 +36,11 @@ win32_eRROR_INVALID_FUNCTION = 0x1  win32_fILE_ATTRIBUTE_REPARSE_POINT :: Win32.FileAttributeOrFlag+#if MIN_VERSION_Win32(2, 4, 0)+win32_fILE_ATTRIBUTE_REPARSE_POINT = Win32.fILE_ATTRIBUTE_REPARSE_POINT+#else win32_fILE_ATTRIBUTE_REPARSE_POINT = (#const FILE_ATTRIBUTE_REPARSE_POINT)+#endif  win32_fILE_SHARE_DELETE :: Win32.ShareMode #if MIN_VERSION_Win32(2, 3, 1)@@ -43,6 +49,12 @@ win32_fILE_SHARE_DELETE = (#const FILE_SHARE_DELETE) #endif +maxShareMode :: Win32.ShareMode+maxShareMode =+  win32_fILE_SHARE_DELETE .|.+  Win32.fILE_SHARE_READ   .|.+  Win32.fILE_SHARE_WRITE+ win32_getLongPathName, win32_getShortPathName :: FilePath -> IO FilePath #if MIN_VERSION_Win32(2, 4, 0) win32_getLongPathName = Win32.getLongPathName@@ -102,14 +114,10 @@   where #ifdef HAVE_GETFINALPATHNAMEBYHANDLEW     rawGetFinalPathName path = do-      let open = Win32.createFile path 0 shareMode Nothing+      let open = Win32.createFile path 0 maxShareMode Nothing                  Win32.oPEN_EXISTING Win32.fILE_FLAG_BACKUP_SEMANTICS Nothing       bracket open Win32.closeHandle $ \ h -> do         win32_getFinalPathNameByHandle h 0-    shareMode =-      win32_fILE_SHARE_DELETE .|.-      Win32.fILE_SHARE_READ   .|.-      Win32.fILE_SHARE_WRITE #else     rawGetFinalPathName = win32_getLongPathName <=< win32_getShortPathName #endif@@ -221,10 +229,10 @@  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+  path' <- toExtendedLengthPath <$> prependCurrentDirectory path+  let open = Win32.createFile path' 0 maxShareMode 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@@ -245,31 +253,81 @@         _ -> 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) +-- | Given a list of path segments, expand @.@ and @..@.  The path segments+-- must not contain path separators.+expandDots :: [FilePath] -> [FilePath]+expandDots = reverse . go []+  where+    go ys' xs' =+      case xs' of+        [] -> ys'+        x : xs ->+          case x of+            "." -> go ys' xs+            ".." ->+              case ys' of+                _ : ys -> go ys xs+                [] -> go (x : ys') xs+            _ -> go (x : ys') xs++-- | Remove redundant trailing slashes and pick the right kind of slash.+normaliseTrailingSep :: FilePath -> FilePath+normaliseTrailingSep path = do+  let path' = reverse path+  let (sep, path'') = span isPathSeparator path'+  let addSep = if null sep then id else (pathSeparator :)+  reverse (addSep path'')++-- | A variant of 'normalise' to handle Windows paths a little better.  It+--+-- * deduplicates trailing slashes after the drive,+-- * expands parent dirs (@..@), and+-- * preserves paths with @\\\\?\\@.+normaliseW :: FilePath -> FilePath+normaliseW path@('\\' : '\\' : '?' : '\\' : _) = path+normaliseW path = normalise (joinDrive drive' subpath')+  where+    (drive, subpath) = splitDrive path+    drive' = normaliseTrailingSep drive+    subpath' = appendSep . prependSep . joinPath .+               stripPardirs . expandDots . skipSeps .+               splitDirectories $ subpath++    skipSeps = filter (not . (`elem` (pure <$> pathSeparators)))+    stripPardirs | not (isRelative path) = dropWhile (== "..")+                 | otherwise = id+    prependSep | any isPathSeparator (take 1 subpath) = (pathSeparator :)+               | otherwise = id+    appendSep | hasTrailingPathSeparator subpath = addTrailingPathSeparator+              | otherwise = id++-- | Like 'toExtendedLengthPath' but normalises relative paths too.+-- This is needed to make sure e.g. getModificationTime works on empty paths.+toNormalisedExtendedLengthPath :: FilePath -> FilePath+toNormalisedExtendedLengthPath path+  | isRelative path = normalise path+  | otherwise = toExtendedLengthPath path+ -- | Normalise the path separators and prepend the @"\\\\?\\"@ prefix if--- necessary or possible.+-- necessary or possible.  This is used for symbolic links targets because+-- they can't handle forward slashes. 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.+-- | Add the @"\\\\?\\"@ prefix if necessary or possible.  The path remains+-- unchanged if the prefix is not added.  This function can sometimes be used+-- to bypass the @MAX_PATH@ length restriction in Windows API calls. toExtendedLengthPath :: FilePath -> FilePath toExtendedLengthPath path   | isRelative path = path   | otherwise =-      case normalise path of-        -- note: as of filepath-1.4.1.0 normalise doesn't honor \\?\-        -- https://github.com/haskell/filepath/issues/56-        -- this means we cannot trust the result of normalise on-        -- paths that start with \\?\+      case normaliseW path of+        '\\' : '?'  : '?' : '\\' : _ -> path         '\\' : '\\' : '?' : '\\' : _ -> path         '\\' : '\\' : '.' : '\\' : _ -> path         '\\' : subpath@('\\' : _) -> "\\\\?\\UNC" <> subpath@@ -358,24 +416,112 @@   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+createSymbolicLink :: Bool -> FilePath -> FilePath -> IO ()+createSymbolicLink isDir target link =+  (`ioeSetFileName` link) `modifyIOError` do+    -- normaliseSeparators ensures the target gets normalised properly+    link' <- toExtendedLengthPath <$> prependCurrentDirectory link+    win32_createSymbolicLink link' (normaliseSeparators target) isDir -foreign import ccall unsafe "_wchmod"-  c_wchmod :: CWString -> CMode -> IO CInt+type Metadata = Win32.BY_HANDLE_FILE_INFORMATION -s_IRUSR :: CMode-s_IRUSR = (#const S_IRUSR)+getSymbolicLinkMetadata :: FilePath -> IO Metadata+getSymbolicLinkMetadata path =+  (`ioeSetFileName` path) `modifyIOError` do+    path' <- toNormalisedExtendedLengthPath <$> prependCurrentDirectory path+    let open = Win32.createFile path' 0 maxShareMode Nothing Win32.oPEN_EXISTING+                                (Win32.fILE_FLAG_BACKUP_SEMANTICS .|.+                                 win32_fILE_FLAG_OPEN_REPARSE_POINT) Nothing+    bracket open Win32.closeHandle $ \ h -> do+      Win32.getFileInformationByHandle h -s_IWUSR :: CMode-s_IWUSR = (#const S_IWUSR)+getFileMetadata :: FilePath -> IO Metadata+getFileMetadata path =+  (`ioeSetFileName` path) `modifyIOError` do+    path' <- toNormalisedExtendedLengthPath <$> prependCurrentDirectory path+    let open = Win32.createFile path' 0 maxShareMode Nothing Win32.oPEN_EXISTING+                                Win32.fILE_FLAG_BACKUP_SEMANTICS Nothing+    bracket open Win32.closeHandle $ \ h -> do+      Win32.getFileInformationByHandle h -s_IXUSR :: CMode-s_IXUSR = (#const S_IXUSR)+fileTypeFromMetadata :: Metadata -> FileType+fileTypeFromMetadata info+  | isLink    = if isDir then DirectoryLink else SymbolicLink+  | isDir     = Directory+  | otherwise = File+  where+    isLink = attrs .&. win32_fILE_ATTRIBUTE_REPARSE_POINT /= 0+    isDir  = attrs .&. Win32.fILE_ATTRIBUTE_DIRECTORY /= 0+    attrs  = Win32.bhfiFileAttributes info -s_IFDIR :: CMode-s_IFDIR = (#const S_IFDIR)+fileSizeFromMetadata :: Metadata -> Integer+fileSizeFromMetadata = fromIntegral . Win32.bhfiSize++accessTimeFromMetadata :: Metadata -> UTCTime+accessTimeFromMetadata =+  posixSecondsToUTCTime . windowsToPosixTime . Win32.bhfiLastAccessTime++modificationTimeFromMetadata :: Metadata -> UTCTime+modificationTimeFromMetadata =+  posixSecondsToUTCTime . windowsToPosixTime . Win32.bhfiLastWriteTime++-- | Difference between the Windows and POSIX epochs in units of 100ns.+windowsPosixEpochDifference :: Num a => a+windowsPosixEpochDifference = 116444736000000000++-- | Convert from Windows time to POSIX time.+windowsToPosixTime :: Win32.FILETIME -> POSIXTime+windowsToPosixTime (Win32.FILETIME t) =+  (fromIntegral t - windowsPosixEpochDifference) / 10000000++-- | Convert from POSIX time to Windows time.  This is lossy as Windows time+--   has a resolution of only 100ns.+posixToWindowsTime :: POSIXTime -> Win32.FILETIME+posixToWindowsTime t = Win32.FILETIME $+  truncate (t * 10000000 + windowsPosixEpochDifference)++type Mode = Win32.FileAttributeOrFlag++modeFromMetadata :: Metadata -> Mode+modeFromMetadata = Win32.bhfiFileAttributes++hasWriteMode :: Mode -> Bool+hasWriteMode m = m .&. Win32.fILE_ATTRIBUTE_READONLY == 0++setWriteMode :: Bool -> Mode -> Mode+setWriteMode False m = m .|. Win32.fILE_ATTRIBUTE_READONLY+setWriteMode True  m = m .&. complement Win32.fILE_ATTRIBUTE_READONLY++setFileMode :: FilePath -> Mode -> IO ()+setFileMode path mode =+  (`ioeSetFileName` path) `modifyIOError` do+    path' <- toNormalisedExtendedLengthPath <$> prependCurrentDirectory path+    Win32.setFileAttributes path' mode++-- | A restricted form of 'setFileMode' that only sets the permission bits.+-- For Windows, this means only the "read-only" attribute is affected.+setFilePermissions :: FilePath -> Mode -> IO ()+setFilePermissions path m = do+  m' <- modeFromMetadata <$> getFileMetadata path+  setFileMode path ((m' .&. complement Win32.fILE_ATTRIBUTE_READONLY) .|.+                    (m  .&. Win32.fILE_ATTRIBUTE_READONLY))++getAccessPermissions :: FilePath -> IO Permissions+getAccessPermissions path = do+  m <- getFileMetadata path+  let isDir = fileTypeIsDirectory (fileTypeFromMetadata m)+  let w = hasWriteMode (modeFromMetadata m)+  let x = (toLower <$> takeExtension path)+          `elem` [".bat", ".cmd", ".com", ".exe"]+  return Permissions+         { readable   = True+         , writable   = w+         , executable = x && not isDir+         , searchable = isDir+         }++setAccessPermissions :: FilePath -> Permissions -> IO ()+setAccessPermissions path Permissions{writable = w} = do+  setFilePermissions path (setWriteMode w 0)  #endif

@@ -1,6 +1,19 @@ Changelog for the [`directory`][1] package ========================================== +## 1.3.1.1 (March 2017)++  * Fix a bug where `createFileLink` and `createDirectoryLink` failed to+    handle `..` in absolute paths.++  * Improve support (partially) for paths longer than 260 characters on+    Windows.  To achieve this, many functions will now automatically prepend+    `\\?\` before calling the Windows API.  As a side effect, the `\\?\`+    prefix may show up in the error messages of the affected functions.++  * `makeAbsolute` can now handle drive-relative paths on Windows such as+    `C:foobar`+ ## 1.3.1.0 (March 2017)    * `findFile` (and similar functions): when an absolute path is given, the

@@ -1,5 +1,5 @@ name:           directory-version:        1.3.1.0+version:        1.3.1.1 -- NOTE: Don't forget to update ./changelog.md license:        BSD3 license-file:   LICENSE@@ -47,6 +47,7 @@         System.Directory.Internal.Prelude     other-modules:         System.Directory.Internal.C_utimensat+        System.Directory.Internal.Common         System.Directory.Internal.Config         System.Directory.Internal.Posix         System.Directory.Internal.Windows@@ -97,6 +98,7 @@         GetFileSize         GetHomeDirectory001         GetPermissions001+        LongPaths         MakeAbsolute         PathIsSymbolicLink         RemoveDirectoryRecursive001

@@ -64,6 +64,11 @@   T(expectEq) () fooNon fooNon7   T(expectEq) () fooNon fooNon8 +  -- make sure ".." gets expanded properly by 'toExtendedLengthPath'+  -- (turns out this test won't detect the problem because GetFullPathName+  -- would expand them for us if we don't, but leaving it here anyway)+  T(expectEq) () foo =<< canonicalizePath (foo </> ".." </> "foo")+   supportsSymbolicLinks <- supportsSymlinks   when supportsSymbolicLinks $ do @@ -81,10 +86,18 @@     T(expectEq) () bar =<< canonicalizePath "lfoo/bar"     T(expectEq) () barQux =<< canonicalizePath "lfoo/bar/qux" +    -- create a haphazard chain of links+    createDirectoryLink "./../foo/../foo/." "./foo/./somelink3"+    createDirectoryLink ".././foo/somelink3" "foo/somelink2"+    createDirectoryLink "./foo/somelink2" "somelink"+    T(expectEq) () foo =<< canonicalizePath "somelink"+     -- regression test for #64     createFileLink "../foo/non-existent" "foo/qux"+    removeDirectoryLink "foo/somelink3" -- break the chain made earlier     qux <- canonicalizePath "foo/qux"     T(expectEq) () qux =<< canonicalizePath "foo/non-existent"+    T(expectEq) () (foo </> "somelink3") =<< canonicalizePath "somelink"      -- make sure it can handle loops     createFileLink "loop1" "loop2"@@ -93,6 +106,11 @@     loop2 <- canonicalizePath "loop2"     T(expectEq) () loop1 (normalise (dot </> "loop1"))     T(expectEq) () loop2 (normalise (dot </> "loop2"))++    -- make sure ".." gets expanded properly by 'toExtendedLengthPath'+    createDirectoryLink (foo </> ".." </> "foo") "foolink"+    _ <- listDirectory "foolink" -- make sure directory is accessible+    T(expectEq) () foo =<< canonicalizePath "foolink"    caseInsensitive <-     (False <$ createDirectory "FOO")

@@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} module GetPermissions001 where #include "util.inl"+import TestUtils  main :: TestEnv -> IO () main _t = do@@ -9,6 +10,20 @@   checkExecutable   checkOrdinary   checkTrailingSlash++  -- 'writable' is the only permission that can be changed on Windows+  writeFile "foo.txt" ""+  foo <- makeAbsolute "foo.txt"+  modifyPermissions "foo.txt" (\ p -> p { writable = False })+  T(expect) () =<< not . writable <$> getPermissions "foo.txt"+  modifyPermissions "foo.txt" (\ p -> p { writable = True })+  T(expect) () =<< writable <$> getPermissions "foo.txt"+  modifyPermissions "foo.txt" (\ p -> p { writable = False })+  T(expect) () =<< not . writable <$> getPermissions "foo.txt"+  modifyPermissions foo (\ p -> p { writable = True })+  T(expect) () =<< writable <$> getPermissions foo+  modifyPermissions foo (\ p -> p { writable = False })+  T(expect) () =<< not . writable <$> getPermissions foo    where 

@@ -0,0 +1,61 @@+{-# LANGUAGE CPP #-}+module LongPaths where+#include "util.inl"+import TestUtils+import System.FilePath ((</>))++main :: TestEnv -> IO ()+main _t = do+  let longName = mconcat (replicate 10 "its_very_long")+  longDir <- makeAbsolute (longName </> longName)++  supportsLongPaths <- do+      -- create 2 dirs because 1 path segment by itself can't exceed MAX_PATH+      -- tests: [createDirectory]+      createDirectory =<< makeAbsolute longName+      createDirectory longDir+      return True+    `catchIOError` \ _ ->+      return False++  -- skip tests on file systems that do not support long paths+  when supportsLongPaths $ do++    -- test relative paths+    let relDir = longName </> mconcat (replicate 8 "yeah_its_long")+    createDirectory relDir+    T(expect) () =<< doesDirectoryExist relDir+    T(expectEq) () [] =<< listDirectory relDir+    setPermissions relDir emptyPermissions+    T(expectEq) () False =<< writable <$> getPermissions relDir++    writeFile "foobar.txt" "^.^" -- writeFile does not support long paths yet++    -- tests: [renamePath], [copyFileWithMetadata]+    renamePath "foobar.txt" (longDir </> "foobar_tmp.txt")+    renamePath (longDir </> "foobar_tmp.txt") (longDir </> "foobar.txt")+    copyFileWithMetadata (longDir </> "foobar.txt")+                         (longDir </> "foobar_copy.txt")++    -- tests: [doesDirectoryExist], [doesFileExist], [doesPathExist]+    T(expect) () =<< doesDirectoryExist longDir+    T(expect) () =<< doesFileExist (longDir </> "foobar.txt")+    T(expect) () =<< doesPathExist longDir+    T(expect) () =<< doesPathExist (longDir </> "foobar.txt")++    -- tests: [getFileSize], [getModificationTime]+    T(expectEq) () 3 =<< getFileSize (longDir </> "foobar.txt")+    _ <- getModificationTime (longDir </> "foobar.txt")++    supportsSymbolicLinks <- supportsSymlinks+    when supportsSymbolicLinks $ do++      -- tests: [createDirectoryLink], [getSymbolicLinkTarget], [listDirectory]+      -- also tests expansion of "." and ".."+      createDirectoryLink "." (longDir </> "link")+      _ <- listDirectory (longDir </> ".." </> longName </> "link")+      T(expectEq) () "." =<< getSymbolicLinkTarget (longDir </> "." </> "link")++      return ()++  -- [removeFile], [removeDirectory] are automatically tested by the cleanup

@@ -17,6 +17,7 @@ import qualified GetFileSize import qualified GetHomeDirectory001 import qualified GetPermissions001+import qualified LongPaths import qualified MakeAbsolute import qualified PathIsSymbolicLink import qualified RemoveDirectoryRecursive001@@ -47,6 +48,7 @@   T.isolatedRun _t "GetFileSize" GetFileSize.main   T.isolatedRun _t "GetHomeDirectory001" GetHomeDirectory001.main   T.isolatedRun _t "GetPermissions001" GetPermissions001.main+  T.isolatedRun _t "LongPaths" LongPaths.main   T.isolatedRun _t "MakeAbsolute" MakeAbsolute.main   T.isolatedRun _t "PathIsSymbolicLink" PathIsSymbolicLink.main   T.isolatedRun _t "RemoveDirectoryRecursive001" RemoveDirectoryRecursive001.main

@@ -3,6 +3,9 @@ #include "util.inl" import System.FilePath ((</>), addTrailingPathSeparator,                         dropTrailingPathSeparator, normalise)+#ifdef mingw32_HOST_OS+import System.FilePath (takeDrive)+#endif  main :: TestEnv -> IO () main _t = do@@ -31,3 +34,13 @@   T(expectEq) () sfoo (normalise (dot </> "foo/"))   T(expectEq) () sfoo sfoo2   T(expectEq) () sfoo sfoo3++#ifdef mingw32_HOST_OS+  cwd <- getCurrentDirectory+  let driveLetter = toUpper (head (takeDrive cwd))+  let driveLetter' = if driveLetter == 'Z' then 'A' else succ driveLetter+  drp1 <- makeAbsolute (driveLetter : ":foobar")+  drp2 <- makeAbsolute (driveLetter' : ":foobar")+  T(expectEq) () drp1 =<< makeAbsolute "foobar"+  T(expectEq) () drp2 (driveLetter' : ":\\foobar")+#endif