directory 1.3.2.2 → 1.3.3.0

raw patch · 17 files changed

+804/−722 lines, 17 filesdep ~unixPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: unix

API changes (from Hackage documentation)

Files

• System/Directory.hs +168/−545
• System/Directory/Internal.hs +2/−10
• System/Directory/Internal/Common.hs +172/−65
• System/Directory/Internal/Config.hs +1/−1
• System/Directory/Internal/Posix.hsc +185/−13
• System/Directory/Internal/Prelude.hs +19/−6
• System/Directory/Internal/Windows.hsc +229/−64
• System/Directory/Internal/utility.h +1/−1
• changelog.md +10/−0
• directory.cabal +4/−4
• tests/CreateDirectoryIfMissing001.hs +1/−1
• tests/DoesDirectoryExist001.hs +2/−2
• tests/DoesPathExist.hs +2/−2
• tests/MakeAbsolute.hs +2/−2
• tests/RemoveDirectoryRecursive001.hs +1/−1
• tests/TestUtils.hs +3/−3
• tests/Xdg.hs +2/−2

@@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} -#if !(MIN_VERSION_base(4,8,0))+#if !MIN_VERSION_base(4, 8, 0) -- In base-4.8.0 the Foreign module became Safe {-# LANGUAGE Trustworthy #-} #endif@@ -19,7 +19,6 @@ -- ----------------------------------------------------------------------------- -#include <HsDirectoryConfig.h> module System.Directory    (     -- $intro@@ -115,15 +114,20 @@ import System.Directory.Internal import System.Directory.Internal.Prelude import System.FilePath+  ( (<.>)+  , (</>)+  , addTrailingPathSeparator+  , dropTrailingPathSeparator+  , hasTrailingPathSeparator+  , isAbsolute+  , joinPath+  , makeRelative+  , normalise+  , splitDirectories+  , takeDirectory+  ) import Data.Time (UTCTime)-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-#else-import qualified GHC.Foreign as GHC-import qualified System.Posix as Posix-#endif+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)  {- $intro A directory contains a series of entries, each of which is a named@@ -141,28 +145,6 @@ 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 @@ -303,14 +285,7 @@ -}  createDirectory :: FilePath -> IO ()-createDirectory path = do-#ifdef mingw32_HOST_OS-  (`ioeSetFileName` path) `modifyIOError` do-    path' <- toExtendedLengthPath <$> prependCurrentDirectory path-    Win32.createDirectory path' Nothing-#else-  Posix.createDirectory path 0o777-#endif+createDirectory = createDirectoryInternal  -- | @'createDirectoryIfMissing' parents dir@ creates a new directory -- @dir@ if it doesn\'t exist. If the first argument is 'True'@@ -324,7 +299,7 @@   where     parents = reverse . scanl1 (</>) . splitDirectories . normalise -    createDirs []         = return ()+    createDirs []         = pure ()     createDirs (dir:[])   = createDir dir ioError     createDirs (dir:dirs) =       createDir dir $ \_ -> do@@ -334,7 +309,7 @@     createDir dir notExistHandler = do       r <- tryIOError (createDirectory dir)       case r of-        Right ()                   -> return ()+        Right ()                   -> pure ()         Left  e           | isDoesNotExistError  e -> notExistHandler e           -- createDirectory (and indeed POSIX mkdir) does not distinguish@@ -354,7 +329,7 @@          || isPermissionError    e -> do               canIgnore <- pathIsDirectory dir                              `catchIOError` \ _ ->-                               return (isAlreadyExistsError e)+                               pure (isAlreadyExistsError e)               unless canIgnore (ioError e)           | otherwise              -> ioError e @@ -401,14 +376,7 @@ -}  removeDirectory :: FilePath -> IO ()-removeDirectory path =-#ifdef mingw32_HOST_OS-  (`ioeSetFileName` path) `modifyIOError` do-    path' <- toExtendedLengthPath <$> prependCurrentDirectory path-    Win32.removeDirectory path'-#else-  Posix.removeDirectory path-#endif+removeDirectory = removePathInternal True  -- | @'removeDirectoryRecursive' dir@ removes an existing directory /dir/ -- together with its contents and subdirectories. Within this directory,@@ -447,7 +415,7 @@ removeContentsRecursive path =   (`ioeAddLocation` "removeContentsRecursive") `modifyIOError` do     cont <- listDirectory path-    mapM_ removePathRecursive [path </> x | x <- cont]+    traverse_ removePathRecursive [path </> x | x <- cont]     removeDirectory path  -- | Removes a file or directory at /path/ together with its contents and@@ -471,7 +439,7 @@ removePathForcibly :: FilePath -> IO () removePathForcibly path =   (`ioeAddLocation` "removePathForcibly") `modifyIOError` do-    makeRemovable path `catchIOError` \ _ -> return ()+    makeRemovable path `catchIOError` \ _ -> pure ()     ignoreDoesNotExistError $ do       m <- getSymbolicLinkMetadata path       case fileTypeFromMetadata m of@@ -485,9 +453,8 @@   where      ignoreDoesNotExistError :: IO () -> IO ()-    ignoreDoesNotExistError action = do-      _ <- tryIOErrorType isDoesNotExistError action-      return ()+    ignoreDoesNotExistError action =+      () <$ tryIOErrorType isDoesNotExistError action      makeRemovable :: FilePath -> IO ()     makeRemovable p = do@@ -496,23 +463,6 @@                                , searchable = True                                , writable = True } -sequenceWithIOErrors_ :: [IO ()] -> IO ()-sequenceWithIOErrors_ actions = go (Right ()) actions-  where--    go :: Either IOError () -> [IO ()] -> IO ()-    go (Left e)   []       = ioError e-    go (Right ()) []       = return ()-    go s          (m : ms) = s `seq` do-      r <- tryIOError m-      go (thenEither s r) ms--    -- equivalent to (*>) for Either, defined here to retain compatibility-    -- with base prior to 4.3-    thenEither :: Either b a -> Either b a -> Either b a-    thenEither x@(Left _) _ = x-    thenEither _          y = y- {- |'removeFile' /file/ removes the directory entry for an existing file /file/, where /file/ is not itself a directory. The implementation may specify additional constraints which must be@@ -548,14 +498,7 @@ -}  removeFile :: FilePath -> IO ()-removeFile path =-#ifdef mingw32_HOST_OS-  (`ioeSetFileName` path) `modifyIOError` do-    path' <- toExtendedLengthPath <$> prependCurrentDirectory path-    Win32.deleteFile path'-#else-  Posix.removeLink path-#endif+removeFile = removePathInternal False  {- |@'renameDirectory' old new@ changes the name of an existing directory from /old/ to /new/.  If the /new/ directory@@ -661,27 +604,26 @@ -}  renameFile :: FilePath -> FilePath -> IO ()-renameFile opath npath = (`ioeAddLocation` "renameFile") `modifyIOError` do-   -- XXX the tests are not performed atomically with the rename-   checkNotDir opath-   renamePath opath npath-     -- The underlying rename implementation can throw odd exceptions when the-     -- destination is a directory.  For example, Windows typically throws a-     -- permission error, while POSIX systems may throw a resource busy error-     -- if one of the paths refers to the current directory.  In these cases,-     -- we check if the destination is a directory and, if so, throw an-     -- InappropriateType error.-     `catchIOError` \ err -> do-       checkNotDir npath-       ioError err-   where checkNotDir path = do-           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)+renameFile opath npath =+  (`ioeAddLocation` "renameFile") `modifyIOError` do+    -- XXX the tests are not performed atomically with the rename+    checkNotDir opath+    renamePath opath npath+      -- The underlying rename implementation can throw odd exceptions when the+      -- destination is a directory.  For example, Windows typically throws a+      -- permission error, while POSIX systems may throw a resource busy error+      -- if one of the paths refers to the current directory.  In these cases,+      -- we check if the destination is a directory and, if so, throw an+      -- InappropriateType error.+      `catchIOError` \ err -> do+        checkNotDir npath+        ioError err+  where checkNotDir path = do+          m <- tryIOError (getSymbolicLinkMetadata path)+          case fileTypeIsDirectory . fileTypeFromMetadata <$> m of+            Right True -> ioError . (`ioeSetErrorString` "is a directory") $+                          mkIOError InappropriateType "" Nothing (Just path)+            _          -> pure ()  -- | Rename a file or directory.  If the destination path already exists, it -- is replaced atomically.  The destination path must not point to an existing@@ -728,19 +670,9 @@ renamePath :: FilePath                  -- ^ Old path            -> FilePath                  -- ^ New path            -> IO ()-renamePath opath npath = (`ioeAddLocation` "renamePath") `modifyIOError` do-#ifdef mingw32_HOST_OS-   (`ioeSetFileName` opath) `modifyIOError` do-     opath' <- toExtendedLengthPath <$> prependCurrentDirectory opath-     npath' <- toExtendedLengthPath <$> prependCurrentDirectory npath-#  if MIN_VERSION_Win32(2,6,0)-     Win32.moveFileEx opath' (Just npath') Win32.mOVEFILE_REPLACE_EXISTING-#  else-     Win32.moveFileEx opath' npath' Win32.mOVEFILE_REPLACE_EXISTING-#  endif-#else-   Posix.rename opath npath-#endif+renamePath opath npath =+  (`ioeAddLocation` "renamePath") `modifyIOError` do+    renamePathInternal opath npath  -- | Copy a file with its permissions.  If the destination file already exists, -- it is replaced atomically.  Neither path may refer to an existing@@ -754,20 +686,6 @@     atomicCopyFileContents fromFPath toFPath       (ignoreIOExceptions . copyPermissions fromFPath) -#ifndef mingw32_HOST_OS--- | Truncate the destination file and then copy the contents of the source--- file to the destination file.  If the destination file already exists, its--- attributes shall remain unchanged.  Otherwise, its attributes are reset to--- the defaults.-copyFileContents :: FilePath            -- ^ Source filename-                 -> FilePath            -- ^ Destination filename-                 -> IO ()-copyFileContents fromFPath toFPath =-  (`ioeAddLocation` "copyFileContents") `modifyIOError` do-    withBinaryFile toFPath WriteMode $ \ hTo ->-      copyFileToHandle fromFPath hTo-#endif- -- | Copy the contents of a source file to a destination file, replacing the -- destination file atomically via 'withReplacementFile', resetting the -- attributes of the destination file to the defaults.@@ -801,36 +719,7 @@         hClose hTmp         restore (postAction tmpFPath)         renameFile tmpFPath path-        return r---- | Attempt to perform the given action, silencing any IO exception thrown by--- it.-ignoreIOExceptions :: IO () -> IO ()-ignoreIOExceptions io = io `catchIOError` (\_ -> return ())---- | Copy all data from a file to a handle.-copyFileToHandle :: FilePath            -- ^ Source file-                 -> Handle              -- ^ Destination handle-                 -> IO ()-copyFileToHandle fromFPath hTo =-  (`ioeAddLocation` "copyFileToHandle") `modifyIOError` do-    withBinaryFile fromFPath ReadMode $ \ hFrom ->-      copyHandleData hFrom hTo---- | Copy data from one handle to another until end of file.-copyHandleData :: Handle                -- ^ Source handle-               -> Handle                -- ^ Destination handle-               -> IO ()-copyHandleData hFrom hTo =-  (`ioeAddLocation` "copyData") `modifyIOError` do-    allocaBytes bufferSize go-  where-    bufferSize = 131072 -- 128 KiB, as coreutils `cp` uses as of May 2014 (see ioblksize.h)-    go buffer = do-      count <- hGetBuf hFrom buffer bufferSize-      when (count > 0) $ do-        hPutBuf hTo buffer count-        go buffer+        pure r  -- | Copy a file with its associated metadata.  If the destination file -- already exists, it is overwritten.  There is no guarantee of atomicity in@@ -854,54 +743,17 @@                      -> FilePath        -- ^ Destination file                      -> IO () copyFileWithMetadata src dst =-  (`ioeAddLocation` "copyFileWithMetadata") `modifyIOError` doCopy-  where-#ifdef mingw32_HOST_OS-    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-      copyFileContents src dst-      copyMetadataFromStatus st dst-#endif--#ifndef mingw32_HOST_OS-copyMetadataFromStatus :: Posix.FileStatus -> FilePath -> IO ()-copyMetadataFromStatus st dst = do-  tryCopyOwnerAndGroupFromStatus st dst-  copyPermissionsFromMetadata st dst-  copyFileTimesFromStatus st dst-#endif--#ifndef mingw32_HOST_OS-tryCopyOwnerAndGroupFromStatus :: Posix.FileStatus -> FilePath -> IO ()-tryCopyOwnerAndGroupFromStatus st dst = do-  ignoreIOExceptions (copyOwnerFromStatus st dst)-  ignoreIOExceptions (copyGroupFromStatus st dst)-#endif--#ifndef mingw32_HOST_OS-copyOwnerFromStatus :: Posix.FileStatus -> FilePath -> IO ()-copyOwnerFromStatus st dst = do-  Posix.setOwnerAndGroup dst (Posix.fileOwner st) (-1)-#endif--#ifndef mingw32_HOST_OS-copyGroupFromStatus :: Posix.FileStatus -> FilePath -> IO ()-copyGroupFromStatus st dst = do-  Posix.setOwnerAndGroup dst (-1) (Posix.fileGroup st)-#endif+  (`ioeAddLocation` "copyFileWithMetadata") `modifyIOError`+    copyFileWithMetadataInternal copyPermissionsFromMetadata+                                 copyTimesFromMetadata+                                 src+                                 dst -#ifndef mingw32_HOST_OS-copyFileTimesFromStatus :: Posix.FileStatus -> FilePath -> IO ()-copyFileTimesFromStatus st dst = do+copyTimesFromMetadata :: Metadata -> FilePath -> IO ()+copyTimesFromMetadata st dst = do   let atime = accessTimeFromMetadata st   let mtime = modificationTimeFromMetadata st   setFileTimes dst (Just atime, Just mtime)-#endif  -- | Make a path absolute, 'normalise' the path, and remove as many -- indirections from it as possible.  Any trailing path separators are@@ -968,35 +820,17 @@ -- canonicalizePath :: FilePath -> IO FilePath canonicalizePath = \ path ->-  modifyIOError ((`ioeAddLocation` "canonicalizePath") .-                 (`ioeSetFileName` path)) $-  -- normalise does more stuff, like upper-casing the drive letter-  dropTrailingPathSeparator . normalise <$>-    (transform =<< prependCurrentDirectory path)+  ((`ioeAddLocation` "canonicalizePath") .+   (`ioeSetFileName` path)) `modifyIOError` do+    -- normalise does more stuff, like upper-casing the drive letter+    dropTrailingPathSeparator . normalise <$>+      (canonicalizePathWith attemptRealpath =<< prependCurrentDirectory path)   where -#if defined(mingw32_HOST_OS)-    transform = attemptRealpath getFinalPathName--    simplify path =-      (fromExtendedLengthPath <$>-       Win32.getFullPathName (toExtendedLengthPath path))-        `catchIOError` \ _ ->-          return path-#else-    transform path = do-      encoding <- getFileSystemEncoding-      let realpath path' =-            GHC.withCString encoding path'-              (`withRealpath` GHC.peekCString encoding)-      attemptRealpath realpath path--    simplify = return-#endif-     -- allow up to 64 cycles before giving up     attemptRealpath realpath =-      attemptRealpathWith (64 :: Int) Nothing realpath <=< simplify+      attemptRealpathWith (64 :: Int) Nothing realpath+      <=< canonicalizePathSimplify      -- 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@@ -1004,7 +838,7 @@     attemptRealpathWith n mFallback realpath path =       case mFallback of         -- too many indirections ... giving up.-        Just fallback | n <= 0 -> return fallback+        Just fallback | n <= 0 -> pure fallback         -- either mFallback == Nothing (first attempt)         --     or n > 0 (still have some attempts left)         _ -> realpathPrefix (reverse (zip prefixes suffixes))@@ -1018,7 +852,7 @@         -- try to call realpath on the largest possible prefix         realpathPrefix candidates =           case candidates of-            [] -> return path+            [] -> pure path             (prefix, suffix) : rest -> do               exist <- doesPathExist prefix               if not exist@@ -1040,16 +874,17 @@         -- (this is essentially the fix to #64)         realpathFurther fallback p suffix =           case splitDirectories suffix of-            [] -> return fallback+            [] -> pure fallback             next : restSuffix -> do               -- see if the 'next' segment is a symlink               mTarget <- tryIOError (getSymbolicLinkTarget (p </> next))               case mTarget of-                Left _ -> return fallback+                Left _ -> pure 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)+                  path' <- canonicalizePathSimplify+                             (p </> target </> joinPath restSuffix)                   attemptRealpathWith (n - 1) mFallback' realpath path'  -- | Convert a path into an absolute path.  If the given path is relative, the@@ -1065,9 +900,9 @@ -- makeAbsolute :: FilePath -> IO FilePath makeAbsolute path =-  modifyIOError ((`ioeAddLocation` "makeAbsolute") .-                 (`ioeSetFileName` path)) $-  matchTrailingSeparator path . normalise <$> prependCurrentDirectory path+  ((`ioeAddLocation` "makeAbsolute") .+   (`ioeSetFileName` path)) `modifyIOError` do+    matchTrailingSeparator path . normalise <$> prependCurrentDirectory path  -- | Add or remove the trailing path separator in the second path so as to -- match its presence in the first path.@@ -1084,8 +919,7 @@ -- The operation may fail with the same exceptions as 'getCurrentDirectory'. makeRelativeToCurrentDirectory :: FilePath -> IO FilePath makeRelativeToCurrentDirectory x = do-    cur <- getCurrentDirectory-    return $ makeRelative cur x+  (`makeRelative` x) <$> getCurrentDirectory  -- | Given the name or path of an executable file, 'findExecutable' searches -- for such a file in a list of system-defined locations, which generally@@ -1110,17 +944,9 @@ -- 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)-#  if MIN_VERSION_Win32(2,6,0)-    Win32.searchPath Nothing binary (Just exeExtension)-#  else-    Win32.searchPath Nothing binary exeExtension-# endif-#else-    path <- getPath-    findFileWith isExecutable path (binary <.> exeExtension)-#endif+findExecutable binary =+  listTHead+    (findExecutablesLazyInternal findExecutablesInDirectoriesLazy binary)  -- | Search for executable files in a list of system-defined locations, which -- generally includes @PATH@ and possibly more.@@ -1135,22 +961,9 @@ -- -- @since 1.2.2.0 findExecutables :: String -> IO [FilePath]-findExecutables binary = do-#if defined(mingw32_HOST_OS)-    file <- findExecutable binary-    return $ maybeToList file-#else-    path <- getPath-    findExecutablesInDirectories path binary-#endif--#ifndef mingw32_HOST_OS--- | Get the contents of the @PATH@ environment variable.-getPath :: IO [FilePath]-getPath = do-    path <- getEnv "PATH"-    return (splitSearchPath path)-#endif+findExecutables binary =+  listTToList+    (findExecutablesLazyInternal findExecutablesInDirectoriesLazy binary)  -- | Given a name or path, 'findExecutable' appends the 'exeExtension' to the -- query and searches for executable files in the list of given search@@ -1167,20 +980,22 @@ -- @since 1.2.4.0 findExecutablesInDirectories :: [FilePath] -> String -> IO [FilePath] findExecutablesInDirectories path binary =-    findFilesWith isExecutable path (binary <.> exeExtension)+  listTToList (findExecutablesInDirectoriesLazy path binary) +findExecutablesInDirectoriesLazy :: [FilePath] -> String -> ListT IO FilePath+findExecutablesInDirectoriesLazy path binary =+  findFilesWithLazy isExecutable path (binary <.> exeExtension)+ -- | Test whether a file has executable permissions. isExecutable :: FilePath -> IO Bool-isExecutable file = do-    perms <- getPermissions file-    return (executable perms)+isExecutable file = executable <$> getPermissions 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)+findFile = findFileWith (\ _ -> pure True)  -- | Search through the given list of directories for the given file and -- returns all paths where the given file exists.@@ -1190,7 +1005,7 @@ -- -- @since 1.2.1.0 findFiles :: [FilePath] -> String -> IO [FilePath]-findFiles = findFilesWith (\_ -> return True)+findFiles = findFilesWith (\ _ -> pure True)  -- | 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@@ -1235,12 +1050,12 @@    where -    find []       = return Nothing+    find []       = pure Nothing     find (d : ds) = do       let p = d </> path       found <- doesFileExist p `andM` f p       if found-        then return (Just (p, ListT (find ds)))+        then pure (Just (p, ListT (find ds)))         else find ds  -- | Filename extension for executable files (including the dot if any)@@ -1248,7 +1063,7 @@ -- -- @since 1.2.4.0 exeExtension :: String-exeExtension = Cfg.exeExtension+exeExtension = exeExtensionInternal  -- | Similar to 'listDirectory', but always includes the special entries (@.@ -- and @..@).  (This applies to Windows as well.)@@ -1256,40 +1071,9 @@ -- The operation may fail with the same exceptions as 'listDirectory'. getDirectoryContents :: FilePath -> IO [FilePath] getDirectoryContents path =-  modifyIOError ((`ioeSetFileName` path) .-                 (`ioeAddLocation` "getDirectoryContents")) $ do-#ifndef mingw32_HOST_OS-    bracket-      (Posix.openDirStream path)-      Posix.closeDirStream-      start- where-  start dirp =-      loop id-    where-      loop acc = do-        e <- Posix.readDirStream dirp-        if null e-          then return (acc [])-          else loop (acc . (e:))-#else-  query <- toExtendedLengthPath <$> prependCurrentDirectory (path </> "*")-  bracket-     (Win32.findFirstFile query)-     (\(h,_) -> Win32.findClose h)-     (\(h,fdat) -> loop h fdat [])-  where-        -- we needn't worry about empty directories: adirectory always-        -- has at least "." and ".." entries-    loop :: Win32.HANDLE -> Win32.FindData -> [FilePath] -> IO [FilePath]-    loop h fdat acc = do-       filename <- Win32.getFindDataFileName fdat-       more <- Win32.findNextFile h fdat-       if more-          then loop h fdat (filename:acc)-          else return (filename:acc)-                 -- no need to reverse, ordering is undefined-#endif /* mingw32 */+  ((`ioeSetFileName` path) .+   (`ioeAddLocation` "getDirectoryContents")) `modifyIOError` do+    getDirectoryContentsInternal path  -- | @'listDirectory' dir@ returns a list of /all/ entries in /dir/ without -- the special entries (@.@ and @..@).@@ -1323,10 +1107,44 @@ -- @since 1.2.5.0 -- listDirectory :: FilePath -> IO [FilePath]-listDirectory path =-  (filter f) <$> (getDirectoryContents path)+listDirectory path = 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 =+  (`ioeAddLocation` "getCurrentDirectory") `modifyIOError` do+    specializeErrorString+      "Current working directory no longer exists"+      isDoesNotExistError+      getCurrentDirectoryInternal+ -- | Change the working directory to the given path. -- -- In a multithreaded program, the current working directory is a global state@@ -1361,14 +1179,7 @@ -- @[ENOTDIR]@ -- setCurrentDirectory :: FilePath -> IO ()-setCurrentDirectory path = do-#ifdef mingw32_HOST_OS-  -- 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 path-#endif+setCurrentDirectory = setCurrentDirectoryInternal  -- | Run an 'IO' action with the given working directory and restore the -- original working directory afterwards, even if the given action fails due@@ -1404,7 +1215,7 @@ doesPathExist path = do   (True <$ getFileMetadata path)     `catchIOError` \ _ ->-      return False+      pure False  {- |The operation 'doesDirectoryExist' returns 'True' if the argument file exists and is either a directory or a symbolic link to a directory,@@ -1415,7 +1226,7 @@ doesDirectoryExist path = do   pathIsDirectory path     `catchIOError` \ _ ->-      return False+      pure False  {- |The operation 'doesFileExist' returns 'True' if the argument file exists and is not a directory, and 'False' otherwise.@@ -1425,15 +1236,12 @@ doesFileExist path = do   (not <$> pathIsDirectory path)     `catchIOError` \ _ ->-      return False+      pure 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+pathIsDirectory path =+  (`ioeAddLocation` "pathIsDirectory") `modifyIOError` do+    fileTypeIsDirectory . fileTypeFromMetadata <$> getFileMetadata path  -- | 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@@ -1446,13 +1254,14 @@ -- 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+-- symbolic links on Windows may require privileges 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.+-- On Windows, the function is implemented using @CreateSymbolicLink@.  Since+-- 1.3.3.0, the @SYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE@ flag is included+-- if supported by the operating system.  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@@ -1466,11 +1275,7 @@   -> 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@@ -1483,13 +1288,15 @@ -- 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+-- symbolic links on Windows may require privileges 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.+-- @SYMBOLIC_LINK_FLAG_DIRECTORY@.  Since 1.3.3.0, the+-- @SYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE@ flag is also included if+-- supported by the operating system.   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@@ -1503,11 +1310,7 @@   -> 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. --@@ -1520,11 +1323,7 @@ removeDirectoryLink :: FilePath -> IO () removeDirectoryLink path =   (`ioeAddLocation` "removeDirectoryLink") `modifyIOError` do-#ifdef mingw32_HOST_OS-    removeDirectory path-#else-    removeFile path-#endif+    removePathInternal linkToDirectoryIsDirectory path  -- | Check whether the path refers to a symbolic link.  An exception is thrown -- if the path does not exist or is inaccessible.@@ -1538,12 +1337,7 @@ pathIsSymbolicLink path =   ((`ioeAddLocation` "pathIsSymbolicLink") .    (`ioeSetFileName` path)) `modifyIOError` do-    m <- getSymbolicLinkMetadata path-    return $-      case fileTypeFromMetadata m of-        DirectoryLink -> True-        SymbolicLink  -> True-        _             -> False+     fileTypeIsLink . fileTypeFromMetadata <$> getSymbolicLinkMetadata path  {-# DEPRECATED isSymbolicLink "Use 'pathIsSymbolicLink' instead" #-} isSymbolicLink :: FilePath -> IO Bool@@ -1565,24 +1359,8 @@ 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 =-  (`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- -- | Obtain the time at which the file or directory was last accessed. -- -- The operation may fail with:@@ -1600,7 +1378,7 @@ -- getAccessTime :: FilePath -> IO UTCTime getAccessTime path =-  modifyIOError (`ioeAddLocation` "getAccessTime") $ do+  (`ioeAddLocation` "getAccessTime") `modifyIOError` do     accessTimeFromMetadata <$> getFileMetadata path  -- | Obtain the time at which the file or directory was last modified.@@ -1618,7 +1396,7 @@ -- getModificationTime :: FilePath -> IO UTCTime getModificationTime path =-  modifyIOError (`ioeAddLocation` "getModificationTime") $ do+  (`ioeAddLocation` "getModificationTime") `modifyIOError` do     modificationTimeFromMetadata <$> getFileMetadata path  -- | Change the time at which the file or directory was last accessed.@@ -1646,7 +1424,7 @@ -- setAccessTime :: FilePath -> UTCTime -> IO () setAccessTime path atime =-  modifyIOError (`ioeAddLocation` "setAccessTime") $+  (`ioeAddLocation` "setAccessTime") `modifyIOError` do     setFileTimes path (Just atime, Nothing)  -- | Change the time at which the file or directory was last modified.@@ -1674,54 +1452,16 @@ -- setModificationTime :: FilePath -> UTCTime -> IO () setModificationTime path mtime =-  modifyIOError (`ioeAddLocation` "setModificationTime") $+  (`ioeAddLocation` "setModificationTime") `modifyIOError` do     setFileTimes path (Nothing, Just mtime)  setFileTimes :: FilePath -> (Maybe UTCTime, Maybe UTCTime) -> IO () setFileTimes _ (Nothing, Nothing) = return () setFileTimes path (atime, mtime) =-  modifyIOError (`ioeAddLocation` "setFileTimes") .-  modifyIOError (`ioeSetFileName` path) $-    setTimes (utcTimeToPOSIXSeconds <$> atime, utcTimeToPOSIXSeconds <$> mtime)-  where-    path' = normalise path              -- handle empty paths--    setTimes :: (Maybe POSIXTime, Maybe POSIXTime) -> IO ()-#ifdef mingw32_HOST_OS-    setTimes (atime', mtime') =-      bracket (openFileHandle path' Win32.gENERIC_WRITE)-              Win32.closeHandle $ \ handle ->-      maybeWith with (posixToWindowsTime <$> atime') $ \ atime'' ->-      maybeWith with (posixToWindowsTime <$> mtime') $ \ mtime'' ->-      Win32.failIf_ not "" $-        Win32.c_SetFileTime handle nullPtr atime'' mtime''-#elif defined HAVE_UTIMENSAT-    setTimes (atime', mtime') =-      withFilePath path' $ \ path'' ->-      withArray [ maybe utimeOmit toCTimeSpec atime'-                , maybe utimeOmit toCTimeSpec mtime' ] $ \ times ->-      throwErrnoPathIfMinus1_ "" path' $-        c_utimensat c_AT_FDCWD path'' times 0-#else-    setTimes (Just atime', Just mtime') = setFileTimes' path' atime' mtime'-    setTimes (atime', mtime') = do-      m <- getFileMetadata path'-      let atimeOld = accessTimeFromMetadata m-      let mtimeOld = modificationTimeFromMetadata m-      setFileTimes' path'-        (fromMaybe (utcTimeToPOSIXSeconds atimeOld) atime')-        (fromMaybe (utcTimeToPOSIXSeconds mtimeOld) mtime')--    setFileTimes' :: FilePath -> POSIXTime -> POSIXTime -> IO ()-# if MIN_VERSION_unix(2, 7, 0)-    setFileTimes' = Posix.setFileTimesHiRes-#  else-    setFileTimes' pth atime' mtime' =-      Posix.setFileTimes pth-        (fromInteger (truncate atime'))-        (fromInteger (truncate mtime'))-# endif-#endif+  ((`ioeAddLocation` "setFileTimes") .+   (`ioeSetFileName` path)) `modifyIOError` do+    setTimes (normalise path)           -- handle empty paths+             (utcTimeToPOSIXSeconds <$> atime, utcTimeToPOSIXSeconds <$> mtime)  {- | Returns the current user's home directory. @@ -1744,46 +1484,9 @@ cannot be found. -} getHomeDirectory :: IO FilePath-getHomeDirectory = modifyIOError (`ioeAddLocation` "getHomeDirectory") get-  where-#if defined(mingw32_HOST_OS)-    get = getFolderPath Win32.cSIDL_PROFILE `catchIOError` \ _ ->-          getFolderPath Win32.cSIDL_WINDOWS-    getFolderPath what = Win32.sHGetFolderPath nullPtr what nullPtr 0-#else-    get = getEnv "HOME"-#endif---- | Special directories for storing user-specific application data,---   configuration, and cache files, as specified by the---   <http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html XDG Base Directory Specification>.------   Note: On Windows, 'XdgData' and 'XdgConfig' map to the same directory.------   @since 1.2.3.0-data XdgDirectory-  = XdgData-    -- ^ For data files (e.g. images).-    --   Defaults to @~\/.local\/share@ and can be-    --   overridden by the @XDG_DATA_HOME@ environment variable.-    --   On Windows, it is @%APPDATA%@-    --   (e.g. @C:\/Users\//\<user\>/\/AppData\/Roaming@).-    --   Can be considered as the user-specific equivalent of @\/usr\/share@.-  | XdgConfig-    -- ^ For configuration files.-    --   Defaults to @~\/.config@ and can be-    --   overridden by the @XDG_CONFIG_HOME@ environment variable.-    --   On Windows, it is @%APPDATA%@-    --   (e.g. @C:\/Users\//\<user\>/\/AppData\/Roaming@).-    --   Can be considered as the user-specific equivalent of @\/etc@.-  | XdgCache-    -- ^ For non-essential files (e.g. cache).-    --   Defaults to @~\/.cache@ and can be-    --   overridden by the @XDG_CACHE_HOME@ environment variable.-    --   On Windows, it is @%LOCALAPPDATA%@-    --   (e.g. @C:\/Users\//\<user\>/\/AppData\/Local@).-    --   Can be considered as the user-specific equivalent of @\/var\/cache@.-  deriving (Bounded, Enum, Eq, Ord, Read, Show)+getHomeDirectory =+  (`ioeAddLocation` "getHomeDirectory") `modifyIOError` do+    getHomeDirectoryInternal  -- | Obtain the paths to special directories for storing user-specific --   application data, configuration, and cache files, conforming to the@@ -1808,78 +1511,14 @@                                         --   path is returned                 -> IO FilePath getXdgDirectory xdgDir suffix =-  modifyIOError (`ioeAddLocation` "getXdgDirectory") $-  normalise . (</> suffix) <$>-  case xdgDir of-    XdgData   -> get False "XDG_DATA_HOME"   ".local/share"-    XdgConfig -> get False "XDG_CONFIG_HOME" ".config"-    XdgCache  -> get True  "XDG_CACHE_HOME"  ".cache"-  where-#if defined(mingw32_HOST_OS)-    get isLocal _ _ = Win32.sHGetFolderPath nullPtr which nullPtr 0-      where which | isLocal   = win32_cSIDL_LOCAL_APPDATA-                  | otherwise = Win32.cSIDL_APPDATA-#else-    get _ name fallback = do-      env <- lookupEnv name-      case env of-        Nothing                     -> fallback'-        Just path | isRelative path -> fallback'-                  | otherwise       -> return path-      where fallback' = (</> fallback) <$> getHomeDirectory-#endif---- | Search paths for various application data, as specified by the---   <http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html XDG Base Directory Specification>.------   Note: On Windows, 'XdgDataDirs' and 'XdgConfigDirs' yield the same result.------   @since 1.3.2.0-data XdgDirectoryList-  = XdgDataDirs-    -- ^ For data files (e.g. images).-    --   Defaults to @/usr/local/share/@ and @/usr/share/@ and can be-    --   overridden by the @XDG_DATA_DIRS@ environment variable.-    --   On Windows, it is @%PROGRAMDATA%@ or @%ALLUSERSPROFILE%@-    --   (e.g. @C:\/ProgramData@).-  | XdgConfigDirs-    -- ^ For configuration files.-    --   Defaults to @/etc/xdg@ and can be-    --   overridden by the @XDG_CONFIG_DIRS@ environment variable.-    --   On Windows, it is @%PROGRAMDATA%@ or @%ALLUSERSPROFILE%@-    --   (e.g. @C:\/ProgramData@).-  deriving (Bounded, Enum, Eq, Ord, Read, Show)+  (`ioeAddLocation` "getXdgDirectory") `modifyIOError` do+    normalise . (</> suffix) <$> getXdgDirectoryInternal getHomeDirectory xdgDir  getXdgDirectoryList :: XdgDirectoryList -- ^ which special directory list                     -> IO [FilePath]-getXdgDirectoryList xdgDir =-  modifyIOError (`ioeAddLocation` "getXdgDirectoryList") $-  case xdgDir of-    XdgDataDirs   -> get "XDG_DATA_DIRS"   ["/usr/local/share/", "/usr/share/"]-    XdgConfigDirs -> get "XDG_CONFIG_DIRS" ["/etc/xdg"]-  where-#if defined(mingw32_HOST_OS)-    get _ _ =-      return <$> Win32.sHGetFolderPath nullPtr win32_cSIDL_COMMON_APPDATA-                                       nullPtr 0-#else-    get name fallback = do-      env <- lookupEnv name-      case env of-        Nothing    -> return fallback-        Just paths -> return (splitSearchPath paths)-#endif--#if !defined(mingw32_HOST_OS)--- | Return the value of an environment variable, or 'Nothing' if there is no---   such value.  (Equivalent to "lookupEnv" from base-4.6.)-lookupEnv :: String -> IO (Maybe String)-lookupEnv name = do-  env <- tryIOErrorType isDoesNotExistError (getEnv name)-  case env of-    Left  _     -> return Nothing-    Right value -> return (Just value)-#endif+getXdgDirectoryList xdgDirs =+  (`ioeAddLocation` "getXdgDirectoryList") `modifyIOError` do+    getXdgDirectoryListInternal xdgDirs  -- | Obtain the path to a special directory for storing user-specific --   application data (traditional Unix location).  Newer applications may@@ -1911,14 +1550,8 @@                                         --   to the path                         -> IO FilePath getAppUserDataDirectory appName = do-  modifyIOError (`ioeAddLocation` "getAppUserDataDirectory") $ do-#if defined(mingw32_HOST_OS)-    s <- Win32.sHGetFolderPath nullPtr Win32.cSIDL_APPDATA nullPtr 0-    return (s++'\\':appName)-#else-    path <- getEnv "HOME"-    return (path++'/':'.':appName)-#endif+  (`ioeAddLocation` "getAppUserDataDirectory") `modifyIOError` do+    getAppUserDataDirectoryInternal appName  {- | Returns the current user's document directory. @@ -1942,12 +1575,8 @@ -} getUserDocumentsDirectory :: IO FilePath getUserDocumentsDirectory = do-  modifyIOError (`ioeAddLocation` "getUserDocumentsDirectory") $ do-#if defined(mingw32_HOST_OS)-    Win32.sHGetFolderPath nullPtr Win32.cSIDL_PERSONAL nullPtr 0-#else-    getEnv "HOME"-#endif+  (`ioeAddLocation` "getUserDocumentsDirectory") `modifyIOError` do+    getUserDocumentsDirectoryInternal  {- | Returns the current directory for temporary files. @@ -1976,10 +1605,4 @@ The function doesn\'t verify whether the path exists. -} getTemporaryDirectory :: IO FilePath-getTemporaryDirectory =-#if defined(mingw32_HOST_OS)-  Win32.getTemporaryDirectory-#else-  getEnv "TMPDIR" `catchIOError` \ err ->-  if isDoesNotExistError err then return "/tmp" else ioError err-#endif+getTemporaryDirectory = getTemporaryDirectoryInternal

@@ -13,26 +13,18 @@ module System.Directory.Internal   ( module System.Directory.Internal.Common -#ifdef mingw32_HOST_OS+#if defined(mingw32_HOST_OS)   , module System.Directory.Internal.Windows #else   , module System.Directory.Internal.Posix #endif -#ifdef HAVE_UTIMENSAT-  , module System.Directory.Internal.C_utimensat-#endif-   ) where  import System.Directory.Internal.Common -#ifdef mingw32_HOST_OS+#if defined(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

@@ -1,30 +1,81 @@-{-# 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 +-- | A generator with side-effects.+newtype ListT m a = ListT { unListT :: m (Maybe (a, ListT m a)) }++emptyListT :: Applicative m => ListT m a+emptyListT = ListT (pure Nothing)++maybeToListT :: Applicative m => m (Maybe a) -> ListT m a+maybeToListT m = ListT (((\ x -> (x, emptyListT)) <$>) <$> m)++listToListT :: Applicative m => [a] -> ListT m a+listToListT [] = emptyListT+listToListT (x : xs) = ListT (pure (Just (x, listToListT xs)))++liftJoinListT :: Monad m => m (ListT m a) -> ListT m a+liftJoinListT m = ListT (m >>= unListT)++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++sequenceWithIOErrors_ :: [IO ()] -> IO ()+sequenceWithIOErrors_ actions = go (Right ()) actions+  where++    go :: Either IOError () -> [IO ()] -> IO ()+    go (Left e)   []       = ioError e+    go (Right ()) []       = pure ()+    go s          (m : ms) = s `seq` do+      r <- tryIOError m+      go (thenEither s r) ms++    -- equivalent to (*>) for Either, defined here to retain compatibility+    -- with base prior to 4.3+    thenEither :: Either b a -> Either b a -> Either b a+    thenEither x@(Left _) _ = x+    thenEither _          y = y+ -- | 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)+    Left  err -> if check err then pure (Left err) else throwIO err+    Right val -> pure (Right val) +-- | Attempt to perform the given action, silencing any IO exception thrown by+-- it.+ignoreIOExceptions :: IO () -> IO ()+ignoreIOExceptions io = io `catchIOError` (\_ -> pure ())+ 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+    Left  e -> throwIO (ioeSetErrorString e str)+    Right x -> pure x  ioeAddLocation :: IOError -> String -> IOError ioeAddLocation e loc = do@@ -36,7 +87,7 @@ data FileType = File               | SymbolicLink -- ^ POSIX: either file or directory link; Windows: file link               | Directory-              | DirectoryLink -- ^ Windows only+              | DirectoryLink -- ^ Windows only: directory link               deriving (Bounded, Enum, Eq, Ord, Read, Show)  -- | Check whether the given 'FileType' is considered a directory by the@@ -47,6 +98,12 @@ fileTypeIsDirectory DirectoryLink = True fileTypeIsDirectory _             = False +-- | Return whether the given 'FileType' is a link.+fileTypeIsLink :: FileType -> Bool+fileTypeIsLink SymbolicLink  = True+fileTypeIsLink DirectoryLink = True+fileTypeIsLink _             = False+ data Permissions   = Permissions   { readable :: Bool@@ -55,44 +112,6 @@   , 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@@ -102,19 +121,107 @@ -- 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+prependCurrentDirectoryWith :: IO FilePath -> FilePath -> IO FilePath+prependCurrentDirectoryWith getCurrentDirectory path =+  ((`ioeAddLocation` "prependCurrentDirectory") .+   (`ioeSetFileName` path)) `modifyIOError` do+    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)+      pure . (</> subpath) $+        case drive of+          _ : _ | (toUpper <$> drive) /= (toUpper <$> curDrive) ->+                    drive <> [pathSeparator]+          _ -> cwd+    else pure path++-- | Truncate the destination file and then copy the contents of the source+-- file to the destination file.  If the destination file already exists, its+-- attributes shall remain unchanged.  Otherwise, its attributes are reset to+-- the defaults.+copyFileContents :: FilePath            -- ^ Source filename+                 -> FilePath            -- ^ Destination filename+                 -> IO ()+copyFileContents fromFPath toFPath =+  (`ioeAddLocation` "copyFileContents") `modifyIOError` do+    withBinaryFile toFPath WriteMode $ \ hTo ->+      copyFileToHandle fromFPath hTo++-- | Copy all data from a file to a handle.+copyFileToHandle :: FilePath            -- ^ Source file+                 -> Handle              -- ^ Destination handle+                 -> IO ()+copyFileToHandle fromFPath hTo =+  (`ioeAddLocation` "copyFileToHandle") `modifyIOError` do+    withBinaryFile fromFPath ReadMode $ \ hFrom ->+      copyHandleData hFrom hTo++-- | Copy data from one handle to another until end of file.+copyHandleData :: Handle                -- ^ Source handle+               -> Handle                -- ^ Destination handle+               -> IO ()+copyHandleData hFrom hTo =+  (`ioeAddLocation` "copyData") `modifyIOError` do+    allocaBytes bufferSize go+  where+    bufferSize = 131072 -- 128 KiB, as coreutils `cp` uses as of May 2014 (see ioblksize.h)+    go buffer = do+      count <- hGetBuf hFrom buffer bufferSize+      when (count > 0) $ do+        hPutBuf hTo buffer count+        go buffer++-- | Special directories for storing user-specific application data,+--   configuration, and cache files, as specified by the+--   <http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html XDG Base Directory Specification>.+--+--   Note: On Windows, 'XdgData' and 'XdgConfig' map to the same directory.+--+--   @since 1.2.3.0+data XdgDirectory+  = XdgData+    -- ^ For data files (e.g. images).+    --   Defaults to @~\/.local\/share@ and can be+    --   overridden by the @XDG_DATA_HOME@ environment variable.+    --   On Windows, it is @%APPDATA%@+    --   (e.g. @C:\/Users\//\<user\>/\/AppData\/Roaming@).+    --   Can be considered as the user-specific equivalent of @\/usr\/share@.+  | XdgConfig+    -- ^ For configuration files.+    --   Defaults to @~\/.config@ and can be+    --   overridden by the @XDG_CONFIG_HOME@ environment variable.+    --   On Windows, it is @%APPDATA%@+    --   (e.g. @C:\/Users\//\<user\>/\/AppData\/Roaming@).+    --   Can be considered as the user-specific equivalent of @\/etc@.+  | XdgCache+    -- ^ For non-essential files (e.g. cache).+    --   Defaults to @~\/.cache@ and can be+    --   overridden by the @XDG_CACHE_HOME@ environment variable.+    --   On Windows, it is @%LOCALAPPDATA%@+    --   (e.g. @C:\/Users\//\<user\>/\/AppData\/Local@).+    --   Can be considered as the user-specific equivalent of @\/var\/cache@.+  deriving (Bounded, Enum, Eq, Ord, Read, Show)++-- | Search paths for various application data, as specified by the+--   <http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html XDG Base Directory Specification>.+--+--   Note: On Windows, 'XdgDataDirs' and 'XdgConfigDirs' yield the same result.+--+--   @since 1.3.2.0+data XdgDirectoryList+  = XdgDataDirs+    -- ^ For data files (e.g. images).+    --   Defaults to @/usr/local/share/@ and @/usr/share/@ and can be+    --   overridden by the @XDG_DATA_DIRS@ environment variable.+    --   On Windows, it is @%PROGRAMDATA%@ or @%ALLUSERSPROFILE%@+    --   (e.g. @C:\/ProgramData@).+  | XdgConfigDirs+    -- ^ For configuration files.+    --   Defaults to @/etc/xdg@ and can be+    --   overridden by the @XDG_CONFIG_DIRS@ environment variable.+    --   On Windows, it is @%PROGRAMDATA%@ or @%ALLUSERSPROFILE%@+    --   (e.g. @C:\/ProgramData@).+  deriving (Bounded, Enum, Eq, Ord, Read, Show)

@@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-}-#include <HsDirectoryConfig.h> module System.Directory.Internal.Config where+#include <HsDirectoryConfig.h>  exeExtension :: String exeExtension = EXE_EXTENSION

@@ -1,17 +1,33 @@ module System.Directory.Internal.Posix where #include <HsDirectoryConfig.h>-#ifndef mingw32_HOST_OS+#if !defined(mingw32_HOST_OS) #ifdef HAVE_LIMITS_H # include <limits.h> #endif import Prelude () import System.Directory.Internal.Prelude+#ifdef HAVE_UTIMENSAT+import System.Directory.Internal.C_utimensat+#endif import System.Directory.Internal.Common+import System.Directory.Internal.Config (exeExtension) import Data.Time (UTCTime)-import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime)-import System.FilePath (normalise)+import Data.Time.Clock.POSIX (POSIXTime)+import System.FilePath ((</>), isRelative, normalise, splitSearchPath)+import qualified Data.Time.Clock.POSIX as POSIXTime+import qualified GHC.Foreign as GHC import qualified System.Posix as Posix +createDirectoryInternal :: FilePath -> IO ()+createDirectoryInternal path = Posix.createDirectory path 0o777++removePathInternal :: Bool -> FilePath -> IO ()+removePathInternal True  = Posix.removeDirectory+removePathInternal False = Posix.removeLink++renamePathInternal :: FilePath -> FilePath -> IO ()+renamePathInternal = Posix.rename+ -- we use the 'free' from the standard library here since it's not entirely -- clear whether Haskell's 'free' corresponds to the same one foreign import ccall unsafe "free" c_free :: Ptr a -> IO ()@@ -26,8 +42,7 @@ c_PATH_MAX = Nothing #endif -foreign import ccall "realpath" c_realpath-  :: CString -> CString -> IO CString+foreign import ccall "realpath" c_realpath :: CString -> CString -> IO CString  withRealpath :: CString -> (CString -> IO a) -> IO a withRealpath path action = case c_PATH_MAX of@@ -40,6 +55,62 @@     allocaBytes (pathMax + 1) (realpath >=> action)   where realpath = throwErrnoIfNull "" . c_realpath path +canonicalizePathWith :: ((FilePath -> IO FilePath) -> FilePath -> IO FilePath)+                     -> FilePath+                     -> IO FilePath+canonicalizePathWith attemptRealpath path = do+  encoding <- getFileSystemEncoding+  let realpath path' =+        GHC.withCString encoding path' (`withRealpath` GHC.peekCString encoding)+  attemptRealpath realpath path++canonicalizePathSimplify :: FilePath -> IO FilePath+canonicalizePathSimplify = pure++findExecutablesLazyInternal :: ([FilePath] -> String -> ListT IO FilePath)+                            -> String+                            -> ListT IO FilePath+findExecutablesLazyInternal findExecutablesInDirectoriesLazy binary =+  liftJoinListT $ do+    path <- getPath+    pure (findExecutablesInDirectoriesLazy path binary)++exeExtensionInternal :: String+exeExtensionInternal = exeExtension++getDirectoryContentsInternal :: FilePath -> IO [FilePath]+getDirectoryContentsInternal path =+  bracket+    (Posix.openDirStream path)+    Posix.closeDirStream+    start+  where+    start dirp = loop id+      where+        loop acc = do+          e <- Posix.readDirStream dirp+          if null e+            then pure (acc [])+            else loop (acc . (e:))++getCurrentDirectoryInternal :: IO FilePath+getCurrentDirectoryInternal = Posix.getWorkingDirectory++prependCurrentDirectory :: FilePath -> IO FilePath+prependCurrentDirectory = prependCurrentDirectoryWith getCurrentDirectoryInternal++setCurrentDirectoryInternal :: FilePath -> IO ()+setCurrentDirectoryInternal = Posix.changeWorkingDirectory++linkToDirectoryIsDirectory :: Bool+linkToDirectoryIsDirectory = False++createSymbolicLink :: Bool -> FilePath -> FilePath -> IO ()+createSymbolicLink _ = Posix.createSymbolicLink++readSymbolicLink :: FilePath -> IO FilePath+readSymbolicLink = Posix.readSymbolicLink+ type Metadata = Posix.FileStatus  -- note: normalise is needed to handle empty paths@@ -64,11 +135,11 @@  accessTimeFromMetadata :: Metadata -> UTCTime accessTimeFromMetadata =-  posixSecondsToUTCTime . posix_accessTimeHiRes+  POSIXTime.posixSecondsToUTCTime . posix_accessTimeHiRes  modificationTimeFromMetadata :: Metadata -> UTCTime modificationTimeFromMetadata =-  posixSecondsToUTCTime . posix_modificationTimeHiRes+  POSIXTime.posixSecondsToUTCTime . posix_modificationTimeHiRes  posix_accessTimeHiRes, posix_modificationTimeHiRes   :: Posix.FileStatus -> POSIXTime@@ -111,12 +182,12 @@   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-         }+  pure Permissions+       { readable   = r+       , writable   = w+       , executable = x && not isDir+       , searchable = x && isDir+       }  setAccessPermissions :: FilePath -> Permissions -> IO () setAccessPermissions path (Permissions r w e s) = do@@ -129,5 +200,106 @@     modifyBit :: Bool -> Posix.FileMode -> Posix.FileMode -> Posix.FileMode     modifyBit False b m = m .&. complement b     modifyBit True  b m = m .|. b++copyOwnerFromStatus :: Posix.FileStatus -> FilePath -> IO ()+copyOwnerFromStatus st dst = do+  Posix.setOwnerAndGroup dst (Posix.fileOwner st) (-1)++copyGroupFromStatus :: Posix.FileStatus -> FilePath -> IO ()+copyGroupFromStatus st dst = do+  Posix.setOwnerAndGroup dst (-1) (Posix.fileGroup st)++tryCopyOwnerAndGroupFromStatus :: Posix.FileStatus -> FilePath -> IO ()+tryCopyOwnerAndGroupFromStatus st dst = do+  ignoreIOExceptions (copyOwnerFromStatus st dst)+  ignoreIOExceptions (copyGroupFromStatus st dst)++copyFileWithMetadataInternal :: (Metadata -> FilePath -> IO ())+                             -> (Metadata -> FilePath -> IO ())+                             -> FilePath+                             -> FilePath+                             -> IO ()+copyFileWithMetadataInternal copyPermissionsFromMetadata+                             copyTimesFromMetadata+                             src+                             dst = do+  st <- Posix.getFileStatus src+  copyFileContents src dst+  tryCopyOwnerAndGroupFromStatus st dst+  copyPermissionsFromMetadata st dst+  copyTimesFromMetadata st dst++setTimes :: FilePath -> (Maybe POSIXTime, Maybe POSIXTime) -> IO ()+#ifdef HAVE_UTIMENSAT+setTimes path' (atime', mtime') =+  withFilePath path' $ \ path'' ->+  withArray [ maybe utimeOmit toCTimeSpec atime'+            , maybe utimeOmit toCTimeSpec mtime' ] $ \ times ->+  throwErrnoPathIfMinus1_ "" path' $+    c_utimensat c_AT_FDCWD path'' times 0+#else+setTimes path' (Just atime', Just mtime') = setFileTimes' path' atime' mtime'+setTimes path' (atime', mtime') = do+  m <- getFileMetadata path'+  let atimeOld = accessTimeFromMetadata m+  let mtimeOld = modificationTimeFromMetadata m+  setFileTimes' path'+    (fromMaybe (POSIXTime.utcTimeToPOSIXSeconds atimeOld) atime')+    (fromMaybe (POSIXTime.utcTimeToPOSIXSeconds mtimeOld) mtime')++setFileTimes' :: FilePath -> POSIXTime -> POSIXTime -> IO ()+# if MIN_VERSION_unix(2, 7, 0)+setFileTimes' = Posix.setFileTimesHiRes+#  else+setFileTimes' pth atime' mtime' =+  Posix.setFileTimes pth+    (fromInteger (truncate atime'))+    (fromInteger (truncate mtime'))+# endif+#endif++-- | Get the contents of the @PATH@ environment variable.+getPath :: IO [FilePath]+getPath = splitSearchPath <$> getEnv "PATH"++getHomeDirectoryInternal :: IO FilePath+getHomeDirectoryInternal = getEnv "HOME"++getXdgDirectoryInternal :: IO FilePath -> XdgDirectory -> IO FilePath+getXdgDirectoryInternal getHomeDirectory xdgDir = do+  case xdgDir of+    XdgData   -> get "XDG_DATA_HOME"   ".local/share"+    XdgConfig -> get "XDG_CONFIG_HOME" ".config"+    XdgCache  -> get "XDG_CACHE_HOME"  ".cache"+  where+    get name fallback = do+      env <- lookupEnv name+      case env of+        Nothing                     -> fallback'+        Just path | isRelative path -> fallback'+                  | otherwise       -> pure path+      where fallback' = (</> fallback) <$> getHomeDirectory++getXdgDirectoryListInternal :: XdgDirectoryList -> IO [FilePath]+getXdgDirectoryListInternal xdgDirs =+  case xdgDirs of+    XdgDataDirs   -> get "XDG_DATA_DIRS"   ["/usr/local/share/", "/usr/share/"]+    XdgConfigDirs -> get "XDG_CONFIG_DIRS" ["/etc/xdg"]+  where+    get name fallback = do+      env <- lookupEnv name+      case env of+        Nothing    -> pure fallback+        Just paths -> pure (splitSearchPath paths)++getAppUserDataDirectoryInternal :: FilePath -> IO FilePath+getAppUserDataDirectoryInternal appName =+  (\ home -> home <> ('/' : '.' : appName)) <$> getHomeDirectoryInternal++getUserDocumentsDirectoryInternal :: IO FilePath+getUserDocumentsDirectoryInternal = getHomeDirectoryInternal++getTemporaryDirectoryInternal :: IO FilePath+getTemporaryDirectoryInternal = fromMaybe "/tmp" <$> lookupEnv "TMPDIR"  #endif

@@ -7,12 +7,12 @@  module System.Directory.Internal.Prelude   ( module Prelude-#if MIN_VERSION_base(4, 8, 0)-  , module Data.Void-#else+#if !MIN_VERSION_base(4, 6, 0)+  , lookupEnv+#endif+#if !MIN_VERSION_base(4, 8, 0)   , module Control.Applicative   , module Data.Functor-  , Void #endif   , module Control.Arrow   , module Control.Concurrent@@ -37,14 +37,17 @@   , module System.Posix.Internals   , module System.Posix.Types   , module System.Timeout+  , Void   ) where-#if !MIN_VERSION_base(4, 6, 0)+#if MIN_VERSION_base(4, 6, 0)+import System.Environment (lookupEnv)+#else import Prelude hiding (catch) #endif #if MIN_VERSION_base(4, 8, 0) import Data.Void (Void) #else-import Control.Applicative ((<*>), pure)+import Control.Applicative (Applicative, (<*>), pure) import Data.Functor ((<$>), (<$)) #endif import Control.Arrow (second)@@ -164,6 +167,16 @@ import System.Posix.Internals (withFilePath) import System.Posix.Types (EpochTime) import System.Timeout (timeout)++#if !MIN_VERSION_base(4, 6, 0)+lookupEnv :: String -> IO (Maybe String)+lookupEnv name = do+  env <- tryIOError (getEnv name)+  case env of+    Left err | isDoesNotExistError err -> pure Nothing+             | otherwise               -> throwIO err+    Right value -> pure (Just value)+#endif  #if !MIN_VERSION_base(4, 8, 0) data Void = Void

@@ -1,10 +1,10 @@ {-# LANGUAGE CPP #-} module System.Directory.Internal.Windows where #include <HsDirectoryConfig.h>-#ifdef mingw32_HOST_OS-##if defined i386_HOST_ARCH+#if defined(mingw32_HOST_OS)+##if defined(i386_HOST_ARCH) ## define WINAPI stdcall-##elif defined x86_64_HOST_ARCH+##elif defined(x86_64_HOST_ARCH) ## define WINAPI ccall ##else ## error unknown architecture@@ -16,15 +16,61 @@ import Prelude () import System.Directory.Internal.Prelude import System.Directory.Internal.Common+import System.Directory.Internal.Config (exeExtension) 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 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 +createDirectoryInternal :: FilePath -> IO ()+createDirectoryInternal path =+  (`ioeSetFileName` path) `modifyIOError` do+    path' <- toExtendedLengthPath <$> prependCurrentDirectory path+    Win32.createDirectory path' Nothing++removePathInternal :: Bool -> FilePath -> IO ()+removePathInternal isDir path =+  (`ioeSetFileName` path) `modifyIOError` do+    toExtendedLengthPath <$> prependCurrentDirectory path+      >>= if isDir then Win32.removeDirectory else Win32.deleteFile++renamePathInternal :: FilePath -> FilePath -> IO ()+renamePathInternal opath npath =+  (`ioeSetFileName` opath) `modifyIOError` do+    opath' <- toExtendedLengthPath <$> prependCurrentDirectory opath+    npath' <- toExtendedLengthPath <$> prependCurrentDirectory npath+#if MIN_VERSION_Win32(2, 6, 0)+    Win32.moveFileEx opath' (Just npath') Win32.mOVEFILE_REPLACE_EXISTING+#else+    Win32.moveFileEx opath' npath' Win32.mOVEFILE_REPLACE_EXISTING+#endif++copyFileWithMetadataInternal :: (Metadata -> FilePath -> IO ())+                             -> (Metadata -> FilePath -> IO ())+                             -> FilePath+                             -> FilePath+                             -> IO ()+copyFileWithMetadataInternal _ _ src dst =+  (`ioeSetFileName` src) `modifyIOError` do+    src' <- toExtendedLengthPath <$> prependCurrentDirectory src+    dst' <- toExtendedLengthPath <$> prependCurrentDirectory dst+    Win32.copyFile src' dst' False+ win32_cSIDL_LOCAL_APPDATA :: Win32.CSIDL #if MIN_VERSION_Win32(2, 3, 1) win32_cSIDL_LOCAL_APPDATA = Win32.cSIDL_LOCAL_APPDATA@@ -36,8 +82,20 @@ win32_cSIDL_COMMON_APPDATA = (#const CSIDL_COMMON_APPDATA)  win32_eRROR_INVALID_FUNCTION :: Win32.ErrCode-win32_eRROR_INVALID_FUNCTION = 0x1+win32_eRROR_INVALID_FUNCTION = (#const ERROR_INVALID_FUNCTION) +win32_eRROR_INVALID_PARAMETER :: Win32.ErrCode+win32_eRROR_INVALID_PARAMETER = (#const ERROR_INVALID_PARAMETER)++win32_eRROR_PRIVILEGE_NOT_HELD :: Win32.ErrCode+win32_eRROR_PRIVILEGE_NOT_HELD = (#const ERROR_PRIVILEGE_NOT_HELD)++win32_sYMBOLIC_LINK_FLAG_DIRECTORY :: Win32.DWORD+win32_sYMBOLIC_LINK_FLAG_DIRECTORY = 0x1++win32_sYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE :: Win32.DWORD+win32_sYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE = 0x2+ win32_fILE_ATTRIBUTE_REPARSE_POINT :: Win32.FileAttributeOrFlag #if MIN_VERSION_Win32(2, 4, 0) win32_fILE_ATTRIBUTE_REPARSE_POINT = Win32.fILE_ATTRIBUTE_REPARSE_POINT@@ -64,14 +122,14 @@ win32_getShortPathName = Win32.getShortPathName #else win32_getLongPathName path =-  modifyIOError ((`ioeSetLocation` "GetLongPathName") .-                 (`ioeSetFileName` path)) $ do+  ((`ioeSetLocation` "GetLongPathName") .+   (`ioeSetFileName` path)) `modifyIOError` do     withCWString path $ \ ptrPath -> do       getPathNameWith (c_GetLongPathName ptrPath)  win32_getShortPathName path =-  modifyIOError ((`ioeSetLocation` "GetShortPathName") .-                 (`ioeSetFileName` path)) $ do+  ((`ioeSetLocation` "GetShortPathName") .+   (`ioeSetFileName` path)) `modifyIOError` do     withCWString path $ \ ptrPath -> do       getPathNameWith (c_GetShortPathName ptrPath) @@ -92,7 +150,7 @@  win32_getFinalPathNameByHandle :: Win32.HANDLE -> Win32.DWORD -> IO FilePath win32_getFinalPathNameByHandle _h _flags =-  modifyIOError (`ioeSetLocation` "GetFinalPathNameByHandle") $ do+  (`ioeSetLocation` "GetFinalPathNameByHandle") `modifyIOError` do #ifdef HAVE_GETFINALPATHNAMEBYHANDLEW     getPathNameWith $ \ ptr len -> do       c_GetFinalPathNameByHandle _h ptr len _flags@@ -210,13 +268,11 @@   -> 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+    ok <- c_DeviceIoControl h code inPtr (fromIntegral inSize) outPtr+                            (fromIntegral outSize) lenPtr nullPtr+    if ok+      then Right . fromIntegral <$> peek lenPtr+      else Left <$> Win32.getLastError  foreign import WINAPI unsafe "windows.h DeviceIoControl"   c_DeviceIoControl@@ -231,30 +287,31 @@     -> IO Win32.BOOL  readSymbolicLink :: FilePath -> IO FilePath-readSymbolicLink path = modifyIOError (`ioeSetFileName` path) $ do-  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-                                (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)+readSymbolicLink path =+  (`ioeSetFileName` path) `modifyIOError` do+    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+                                  (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 _ -> pure ()+        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     strip sn = fromMaybe sn (List.stripPrefix "\\??\\" sn) @@ -374,15 +431,74 @@         Left _ -> throwIO (mkIOError OtherError "" Nothing Nothing                            `ioeSetErrorString` "path changed unexpectedly") -win32_createSymbolicLink :: String -> String -> Bool -> IO ()-win32_createSymbolicLink link _target _isDir =+canonicalizePathWith :: ((FilePath -> IO FilePath) -> FilePath -> IO FilePath)+                     -> FilePath+                     -> IO FilePath+canonicalizePathWith attemptRealpath = attemptRealpath getFinalPathName++canonicalizePathSimplify :: FilePath -> IO FilePath+canonicalizePathSimplify path =+  (fromExtendedLengthPath <$>+   Win32.getFullPathName (toExtendedLengthPath path))+    `catchIOError` \ _ ->+      pure path++searchPathEnvForExes :: String -> IO (Maybe FilePath)+searchPathEnvForExes binary = Win32.searchPath Nothing binary $+#if MIN_VERSION_Win32(2, 6, 0)+  Just+#endif+  exeExtension++findExecutablesLazyInternal :: ([FilePath] -> String -> ListT IO FilePath)+                            -> String+                            -> ListT IO FilePath+findExecutablesLazyInternal _ = maybeToListT . searchPathEnvForExes++exeExtensionInternal :: String+exeExtensionInternal = exeExtension++getDirectoryContentsInternal :: FilePath -> IO [FilePath]+getDirectoryContentsInternal path = do+  query <- toExtendedLengthPath <$> prependCurrentDirectory (path </> "*")+  bracket+    (Win32.findFirstFile query)+    (\ (h, _) -> Win32.findClose h)+    (\ (h, fdat) -> loop h fdat [])+  where+    -- we needn't worry about empty directories: a directory always+    -- has at least "." and ".." entries+    loop :: Win32.HANDLE -> Win32.FindData -> [FilePath] -> IO [FilePath]+    loop h fdat acc = do+      filename <- Win32.getFindDataFileName fdat+      more <- Win32.findNextFile h fdat+      if more+        then loop h fdat (filename : acc)+        else pure (filename : acc)+             -- no need to reverse, ordering is undefined++getCurrentDirectoryInternal :: IO FilePath+getCurrentDirectoryInternal = Win32.getCurrentDirectory++prependCurrentDirectory :: FilePath -> IO FilePath+prependCurrentDirectory = prependCurrentDirectoryWith getCurrentDirectoryInternal++-- SetCurrentDirectory does not support long paths even with the \\?\ prefix+-- https://ghc.haskell.org/trac/ghc/ticket/13373#comment:6+setCurrentDirectoryInternal :: FilePath -> IO ()+setCurrentDirectoryInternal = Win32.setCurrentDirectory++createSymbolicLinkUnpriv :: String -> String -> Bool -> IO ()+createSymbolicLinkUnpriv 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+    call pLink pTarget flags win32_sYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE+  where+    call pLink pTarget flags unpriv = do+      status <- c_CreateSymbolicLink pLink pTarget (flags .|. unpriv)+      when (status == 0) $ do         e <- Win32.getLastError         case () of           _ | e == win32_eRROR_INVALID_FUNCTION -> do@@ -398,16 +514,13 @@                 throwIO (mkIOError permissionErrorType "CreateSymbolicLink"                                    Nothing (Just link)                          `ioeSetErrorString` msg)+            | e == win32_eRROR_INVALID_PARAMETER &&+              unpriv /= 0 ->+                -- for compatibility with older versions of Windows,+                -- try it again without the flag+                call pLink pTarget flags 0             | 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@@ -419,12 +532,15 @@   where unsupportedErrorMsg = "Not supported on Windows XP or older" #endif +linkToDirectoryIsDirectory :: Bool+linkToDirectoryIsDirectory = True+ 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+    createSymbolicLinkUnpriv link' (normaliseSeparators target) isDir  type Metadata = Win32.BY_HANDLE_FILE_INFORMATION @@ -483,6 +599,25 @@ posixToWindowsTime t = Win32.FILETIME $   truncate (t * 10000000 + windowsPosixEpochDifference) +setTimes :: FilePath -> (Maybe POSIXTime, Maybe POSIXTime) -> IO ()+setTimes path' (atime', mtime') =+  bracket (openFileHandle path' Win32.gENERIC_WRITE)+          Win32.closeHandle $ \ handle ->+  maybeWith with (posixToWindowsTime <$> atime') $ \ atime'' ->+  maybeWith with (posixToWindowsTime <$> mtime') $ \ mtime'' ->+  Win32.failIf_ not "" $+    Win32.c_SetFileTime handle nullPtr atime'' mtime''++-- | Open the handle of an existing file or directory.+openFileHandle :: String -> Win32.AccessMode -> IO Win32.HANDLE+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+ type Mode = Win32.FileAttributeOrFlag  modeFromMetadata :: Metadata -> Mode@@ -516,15 +651,45 @@   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-         }+  pure 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)++getFolderPath :: Win32.CSIDL -> IO FilePath+getFolderPath what = Win32.sHGetFolderPath nullPtr what nullPtr 0++getHomeDirectoryInternal :: IO FilePath+getHomeDirectoryInternal =+  getFolderPath Win32.cSIDL_PROFILE `catchIOError` \ _ ->+    getFolderPath Win32.cSIDL_WINDOWS++getXdgDirectoryInternal :: IO FilePath -> XdgDirectory -> IO FilePath+getXdgDirectoryInternal _ xdgDir = do+  case xdgDir of+    XdgData   -> getFolderPath Win32.cSIDL_APPDATA+    XdgConfig -> getFolderPath Win32.cSIDL_APPDATA+    XdgCache  -> getFolderPath win32_cSIDL_LOCAL_APPDATA++getXdgDirectoryListInternal :: XdgDirectoryList -> IO [FilePath]+getXdgDirectoryListInternal _ =+  pure <$> getFolderPath win32_cSIDL_COMMON_APPDATA++getAppUserDataDirectoryInternal :: FilePath -> IO FilePath+getAppUserDataDirectoryInternal appName =+  (\ appData -> appData <> ('\\' : appName))+  <$> getXdgDirectoryInternal getHomeDirectoryInternal XdgData++getUserDocumentsDirectoryInternal :: IO FilePath+getUserDocumentsDirectoryInternal = getFolderPath Win32.cSIDL_PERSONAL++getTemporaryDirectoryInternal :: IO FilePath+getTemporaryDirectoryInternal = Win32.getTemporaryDirectory  #endif

@@ -1,4 +1,4 @@-#if !defined alignof && __cplusplus < 201103L+#if !defined(alignof) && __cplusplus < 201103L # ifdef STDC_HEADERS #  include <stddef.h> # endif

@@ -1,6 +1,16 @@ Changelog for the [`directory`][1] package ========================================== +## 1.3.3.0 (June 2018)++  * Relax `unix` version bounds to support 2.8.++  * Relax `Win32` version bounds to support 2.8.++  * Use `SYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE` when creating symbolic+    links on Windows, if possible.+    ([#83](https://github.com/haskell/directory/issues/83))+ ## 1.3.2.2 (April 2018)    * Relax `base` version bounds to support 4.12.

@@ -1,5 +1,5 @@ name:           directory-version:        1.3.2.2+version:        1.3.3.0 -- NOTE: Don't forget to update ./changelog.md license:        BSD3 license-file:   LICENSE@@ -59,15 +59,15 @@         time     >= 1.4 && < 1.10,         filepath >= 1.3 && < 1.5     if os(windows)-        build-depends: Win32 >= 2.2.2 && < 2.8+        build-depends: Win32 >= 2.2.2 && < 2.9     else-        build-depends: unix >= 2.5.1 && < 2.8+        build-depends: unix >= 2.5.1 && < 2.9      ghc-options: -Wall  test-suite test     default-language: Haskell2010-    other-extensions: BangPatterns, CPP+    other-extensions: BangPatterns, CPP, Safe     ghc-options:      -Wall     hs-source-dirs:   tests     main-is:          Main.hs

@@ -88,7 +88,7 @@     catchAny :: IO a -> (SomeException -> IO a) -> IO a     catchAny = catch -#ifdef mingw32_HOST_OS+#if defined(mingw32_HOST_OS)     isNotADirectoryError = isAlreadyExistsError #else     isNotADirectoryError = isInappropriateTypeError

@@ -12,12 +12,12 @@    T(expect) () . not =<< doesDirectoryExist "nonexistent"   T(expect) () =<< doesDirectoryExist "somedir"-#ifdef mingw32_HOST_OS+#if defined(mingw32_HOST_OS)   T(expect) () =<< doesDirectoryExist "SoMeDiR" #endif    where-#ifdef mingw32_HOST_OS+#if defined(mingw32_HOST_OS)     rootDir = "C:\\" #else     rootDir = "/"

@@ -15,14 +15,14 @@   T(expect) () =<< doesPathExist "somedir"   T(expect) () =<< doesPathExist "somefile"   T(expect) () =<< doesPathExist "./somefile"-#ifdef mingw32_HOST_OS+#if defined(mingw32_HOST_OS)   T(expect) () =<< doesPathExist "SoMeDiR"   T(expect) () =<< doesPathExist "sOmEfIlE" #endif   T(expect) () =<< doesPathExist "\x3c0\x42f\x97f3\xe6\x221e"    where-#ifdef mingw32_HOST_OS+#if defined(mingw32_HOST_OS)     rootDir = "C:\\" #else     rootDir = "/"

@@ -3,7 +3,7 @@ #include "util.inl" import System.FilePath ((</>), addTrailingPathSeparator,                         dropTrailingPathSeparator, normalise)-#ifdef mingw32_HOST_OS+#if defined(mingw32_HOST_OS) import System.FilePath (takeDrive) #endif @@ -35,7 +35,7 @@   T(expectEq) () sfoo sfoo2   T(expectEq) () sfoo sfoo3 -#ifdef mingw32_HOST_OS+#if defined(mingw32_HOST_OS)   cwd <- getCurrentDirectory   let driveLetter = toUpper (head (takeDrive cwd))   let driveLetter' = if driveLetter == 'Z' then 'A' else succ driveLetter

@@ -47,7 +47,7 @@    removeDirectoryRecursive (tmp "d")     `catchIOError` \ _ -> removeFile      (tmp "d")-#ifdef mingw32_HOST_OS+#if defined(mingw32_HOST_OS)     `catchIOError` \ _ -> removeDirectory (tmp "d") #endif 

@@ -10,7 +10,7 @@ import System.Directory.Internal.Prelude import System.Directory import System.FilePath ((</>), normalise, takeDirectory)-#ifdef mingw32_HOST_OS+#if defined(mingw32_HOST_OS) import System.Directory.Internal (win32_getFinalPathNameByHandle) import qualified System.Win32 as Win32 #endif@@ -44,7 +44,7 @@   -> IO a                               -- ^ arbitrary action   -> IO a handleSymlinkUnavail _handler action = action-#ifdef mingw32_HOST_OS+#if defined(mingw32_HOST_OS)   `catchIOError` \ e ->     case ioeGetErrorType e of       UnsupportedOperation -> _handler@@ -85,7 +85,7 @@  supportsLinkDeref :: IO Bool supportsLinkDeref = do-#ifdef mingw32_HOST_OS+#if defined(mingw32_HOST_OS)     True <$ win32_getFinalPathNameByHandle Win32.nullHANDLE 0   `catchIOError` \ e ->     case ioeGetErrorType e of

@@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} module Xdg where-#if !defined(mingw32_HOST_OS) && MIN_VERSION_base(4,7,0)+#if !defined(mingw32_HOST_OS) && MIN_VERSION_base(4, 7, 0) import System.Environment (setEnv, unsetEnv) #endif #include "util.inl"@@ -14,7 +14,7 @@    T(expect) () True -- avoid warnings about redundant imports -#if !defined(mingw32_HOST_OS) && MIN_VERSION_base(4,7,0)+#if !defined(mingw32_HOST_OS) && MIN_VERSION_base(4, 7, 0)   unsetEnv "XDG_DATA_DIRS"   unsetEnv "XDG_CONFIG_DIRS"   T(expectEq) () ["/usr/local/share/", "/usr/share/"] =<<