diff --git a/System/Directory.hs b/System/Directory.hs --- a/System/Directory.hs +++ b/System/Directory.hs @@ -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 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 --- . --- --- 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\//\/\/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\//\/\/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\//\/\/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 --- . --- --- 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 diff --git a/System/Directory/Internal.hs b/System/Directory/Internal.hs --- a/System/Directory/Internal.hs +++ b/System/Directory/Internal.hs @@ -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 diff --git a/System/Directory/Internal/Common.hs b/System/Directory/Internal/Common.hs --- a/System/Directory/Internal/Common.hs +++ b/System/Directory/Internal/Common.hs @@ -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 +-- . +-- +-- 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\//\/\/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\//\/\/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\//\/\/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 +-- . +-- +-- 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) diff --git a/System/Directory/Internal/Config.hs b/System/Directory/Internal/Config.hs --- a/System/Directory/Internal/Config.hs +++ b/System/Directory/Internal/Config.hs @@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} -#include module System.Directory.Internal.Config where +#include exeExtension :: String exeExtension = EXE_EXTENSION diff --git a/System/Directory/Internal/Posix.hsc b/System/Directory/Internal/Posix.hsc --- a/System/Directory/Internal/Posix.hsc +++ b/System/Directory/Internal/Posix.hsc @@ -1,17 +1,33 @@ module System.Directory.Internal.Posix where #include -#ifndef mingw32_HOST_OS +#if !defined(mingw32_HOST_OS) #ifdef HAVE_LIMITS_H # include #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 diff --git a/System/Directory/Internal/Prelude.hs b/System/Directory/Internal/Prelude.hs --- a/System/Directory/Internal/Prelude.hs +++ b/System/Directory/Internal/Prelude.hs @@ -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 diff --git a/System/Directory/Internal/Windows.hsc b/System/Directory/Internal/Windows.hsc --- a/System/Directory/Internal/Windows.hsc +++ b/System/Directory/Internal/Windows.hsc @@ -1,10 +1,10 @@ {-# LANGUAGE CPP #-} module System.Directory.Internal.Windows where #include -#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 diff --git a/System/Directory/Internal/utility.h b/System/Directory/Internal/utility.h --- a/System/Directory/Internal/utility.h +++ b/System/Directory/Internal/utility.h @@ -1,4 +1,4 @@ -#if !defined alignof && __cplusplus < 201103L +#if !defined(alignof) && __cplusplus < 201103L # ifdef STDC_HEADERS # include # endif diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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. diff --git a/directory.cabal b/directory.cabal --- a/directory.cabal +++ b/directory.cabal @@ -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 diff --git a/tests/CreateDirectoryIfMissing001.hs b/tests/CreateDirectoryIfMissing001.hs --- a/tests/CreateDirectoryIfMissing001.hs +++ b/tests/CreateDirectoryIfMissing001.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 diff --git a/tests/DoesDirectoryExist001.hs b/tests/DoesDirectoryExist001.hs --- a/tests/DoesDirectoryExist001.hs +++ b/tests/DoesDirectoryExist001.hs @@ -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 = "/" diff --git a/tests/DoesPathExist.hs b/tests/DoesPathExist.hs --- a/tests/DoesPathExist.hs +++ b/tests/DoesPathExist.hs @@ -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 = "/" diff --git a/tests/MakeAbsolute.hs b/tests/MakeAbsolute.hs --- a/tests/MakeAbsolute.hs +++ b/tests/MakeAbsolute.hs @@ -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 diff --git a/tests/RemoveDirectoryRecursive001.hs b/tests/RemoveDirectoryRecursive001.hs --- a/tests/RemoveDirectoryRecursive001.hs +++ b/tests/RemoveDirectoryRecursive001.hs @@ -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 diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -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 diff --git a/tests/Xdg.hs b/tests/Xdg.hs --- a/tests/Xdg.hs +++ b/tests/Xdg.hs @@ -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/"] =<<