diff --git a/System/Directory.hs b/System/Directory.hs --- a/System/Directory.hs +++ b/System/Directory.hs @@ -1,10 +1,3 @@ -{-# LANGUAGE CPP #-} - -#if !MIN_VERSION_base(4, 8, 0) --- In base-4.8.0 the Foreign module became Safe -{-# LANGUAGE Trustworthy #-} -#endif - ----------------------------------------------------------------------------- -- | -- Module : System.Directory @@ -15,7 +8,7 @@ -- Stability : stable -- Portability : portable -- --- System-independent interface to directory manipulation. +-- System-independent interface to directory manipulation (FilePath API). -- ----------------------------------------------------------------------------- @@ -113,21 +106,9 @@ import Prelude () import System.Directory.Internal import System.Directory.Internal.Prelude -import System.FilePath - ( (<.>) - , () - , addTrailingPathSeparator - , dropTrailingPathSeparator - , hasTrailingPathSeparator - , isAbsolute - , joinPath - , makeRelative - , splitDirectories - , splitSearchPath - , takeDirectory - ) import Data.Time (UTCTime) -import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) +import System.OsPath (decodeFS, encodeFS) +import qualified System.Directory.OsPath as D {- $intro A directory contains a series of entries, each of which is a named @@ -221,9 +202,7 @@ -- -- * 'isDoesNotExistError' if the file or directory does not exist. getPermissions :: FilePath -> IO Permissions -getPermissions path = - (`ioeAddLocation` "getPermissions") `modifyIOError` do - getAccessPermissions (emptyToCurDir path) +getPermissions = encodeFS >=> D.getPermissions -- | Set the permissions of a file or directory. -- @@ -240,9 +219,7 @@ -- -- * 'isDoesNotExistError' if the file or directory does not exist. setPermissions :: FilePath -> Permissions -> IO () -setPermissions path p = - (`ioeAddLocation` "setPermissions") `modifyIOError` do - setAccessPermissions (emptyToCurDir path) p +setPermissions path p = encodeFS path >>= (`D.setPermissions` p) -- | Copy the permissions of one file to another. This reproduces the -- permissions more accurately than using 'getPermissions' followed by @@ -252,16 +229,11 @@ -- -- On POSIX systems, this is equivalent to @stat@ followed by @chmod@. copyPermissions :: FilePath -> FilePath -> IO () -copyPermissions src dst = - (`ioeAddLocation` "copyPermissions") `modifyIOError` do - m <- getFileMetadata src - copyPermissionsFromMetadata m dst +copyPermissions src dst = do + src' <- encodeFS src + dst' <- encodeFS dst + D.copyPermissions src' dst' -copyPermissionsFromMetadata :: Metadata -> FilePath -> IO () -copyPermissionsFromMetadata m dst = do - -- instead of setFileMode, setFilePermissions is used here - -- this is to retain backward compatibility in copyPermissions - setFilePermissions dst (modeFromMetadata m) ----------------------------------------------------------------------------- -- Implementation @@ -304,7 +276,7 @@ -} createDirectory :: FilePath -> IO () -createDirectory = createDirectoryInternal +createDirectory = encodeFS >=> D.createDirectory -- | @'createDirectoryIfMissing' parents dir@ creates a new directory -- @dir@ if it doesn\'t exist. If the first argument is 'True' @@ -312,45 +284,7 @@ createDirectoryIfMissing :: Bool -- ^ Create its parents too? -> FilePath -- ^ The path to the directory you want to make -> IO () -createDirectoryIfMissing create_parents path0 - | create_parents = createDirs (parents path0) - | otherwise = createDirs (take 1 (parents path0)) - where - parents = reverse . scanl1 () . splitDirectories . simplify - - createDirs [] = pure () - createDirs (dir:[]) = createDir dir ioError - createDirs (dir:dirs) = - createDir dir $ \_ -> do - createDirs dirs - createDir dir ioError - - createDir dir notExistHandler = do - r <- tryIOError (createDirectory dir) - case r of - Right () -> pure () - Left e - | isDoesNotExistError e -> notExistHandler e - -- createDirectory (and indeed POSIX mkdir) does not distinguish - -- between a dir already existing and a file already existing. So we - -- check for it here. Unfortunately there is a slight race condition - -- here, but we think it is benign. It could report an exception in - -- the case that the dir did exist but another process deletes the - -- directory and creates a file in its place before we can check - -- that the directory did indeed exist. - -- We also follow this path when we get a permissions error, as - -- trying to create "." when in the root directory on Windows - -- fails with - -- CreateDirectory ".": permission denied (Access is denied.) - -- This caused GHCi to crash when loading a module in the root - -- directory. - | isAlreadyExistsError e - || isPermissionError e -> do - canIgnore <- pathIsDirectory dir - `catchIOError` \ _ -> - pure (isAlreadyExistsError e) - unless canIgnore (ioError e) - | otherwise -> ioError e +createDirectoryIfMissing cp = encodeFS >=> D.createDirectoryIfMissing cp {- | @'removeDirectory' dir@ removes an existing directory /dir/. The @@ -395,7 +329,7 @@ -} removeDirectory :: FilePath -> IO () -removeDirectory = removePathInternal True +removeDirectory = encodeFS >=> D.removeDirectory -- | @'removeDirectoryRecursive' dir@ removes an existing directory /dir/ -- together with its contents and subdirectories. Within this directory, @@ -406,45 +340,7 @@ -- This operation is reported to be flaky on Windows so retry logic may -- be advisable. See: https://github.com/haskell/directory/pull/108 removeDirectoryRecursive :: FilePath -> IO () -removeDirectoryRecursive path = - (`ioeAddLocation` "removeDirectoryRecursive") `modifyIOError` do - m <- getSymbolicLinkMetadata path - case fileTypeFromMetadata m of - Directory -> - removeContentsRecursive path - DirectoryLink -> - ioError (err `ioeSetErrorString` "is a directory symbolic link") - _ -> - ioError (err `ioeSetErrorString` "not a directory") - where err = mkIOError InappropriateType "" Nothing (Just path) - --- | @removePathRecursive path@ removes an existing file or directory at --- /path/ together with its contents and subdirectories. Symbolic links are --- removed without affecting their the targets. --- --- This operation is reported to be flaky on Windows so retry logic may --- be advisable. See: https://github.com/haskell/directory/pull/108 -removePathRecursive :: FilePath -> IO () -removePathRecursive path = - (`ioeAddLocation` "removePathRecursive") `modifyIOError` do - m <- getSymbolicLinkMetadata path - case fileTypeFromMetadata m of - Directory -> removeContentsRecursive path - DirectoryLink -> removeDirectory path - _ -> removeFile path - --- | @removeContentsRecursive dir@ removes the contents of the directory --- /dir/ recursively. Symbolic links are removed without affecting their the --- targets. --- --- This operation is reported to be flaky on Windows so retry logic may --- be advisable. See: https://github.com/haskell/directory/pull/108 -removeContentsRecursive :: FilePath -> IO () -removeContentsRecursive path = - (`ioeAddLocation` "removeContentsRecursive") `modifyIOError` do - cont <- listDirectory path - traverse_ removePathRecursive [path x | x <- cont] - removeDirectory path +removeDirectoryRecursive = encodeFS >=> D.removeDirectoryRecursive -- | Removes a file or directory at /path/ together with its contents and -- subdirectories. Symbolic links are removed without affecting their @@ -465,31 +361,7 @@ -- -- @since 1.2.7.0 removePathForcibly :: FilePath -> IO () -removePathForcibly path = - (`ioeAddLocation` "removePathForcibly") `modifyIOError` do - makeRemovable path `catchIOError` \ _ -> pure () - ignoreDoesNotExistError $ do - m <- getSymbolicLinkMetadata path - case fileTypeFromMetadata m of - DirectoryLink -> removeDirectory path - Directory -> do - names <- listDirectory path - sequenceWithIOErrors_ $ - [ removePathForcibly (path name) | name <- names ] ++ - [ removeDirectory path ] - _ -> removeFile path - where - - ignoreDoesNotExistError :: IO () -> IO () - ignoreDoesNotExistError action = - () <$ tryIOErrorType isDoesNotExistError action - - makeRemovable :: FilePath -> IO () - makeRemovable p = do - perms <- getPermissions p - setPermissions path perms{ readable = True - , searchable = True - , writable = True } +removePathForcibly = encodeFS >=> D.removePathForcibly {- |'removeFile' /file/ removes the directory entry for an existing file /file/, where /file/ is not itself a directory. The @@ -526,7 +398,7 @@ -} removeFile :: FilePath -> IO () -removeFile = removePathInternal False +removeFile = encodeFS >=> D.removeFile {- |@'renameDirectory' old new@ changes the name of an existing directory from /old/ to /new/. If the /new/ directory @@ -578,14 +450,10 @@ -} renameDirectory :: FilePath -> FilePath -> IO () -renameDirectory opath npath = - (`ioeAddLocation` "renameDirectory") `modifyIOError` do - -- XXX this test isn't performed atomically with the following rename - isDir <- pathIsDirectory opath - when (not isDir) $ do - ioError . (`ioeSetErrorString` "not a directory") $ - (mkIOError InappropriateType "renameDirectory" Nothing (Just opath)) - renamePath opath npath +renameDirectory opath npath = do + opath' <- encodeFS opath + npath' <- encodeFS npath + D.renameDirectory opath' npath' {- |@'renameFile' old new@ changes the name of an existing file system object from /old/ to /new/. If the /new/ object already exists, it is @@ -637,26 +505,10 @@ -} 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 fileTypeIsDirectory . fileTypeFromMetadata <$> m of - Right True -> ioError . (`ioeSetErrorString` "is a directory") $ - mkIOError InappropriateType "" Nothing (Just path) - _ -> pure () +renameFile opath npath = do + opath' <- encodeFS opath + npath' <- encodeFS npath + D.renameFile opath' npath' -- | Rename a file or directory. If the destination path already exists, it -- is replaced atomically. The destination path must not point to an existing @@ -703,9 +555,10 @@ renamePath :: FilePath -- ^ Old path -> FilePath -- ^ New path -> IO () -renamePath opath npath = - (`ioeAddLocation` "renamePath") `modifyIOError` do - renamePathInternal opath npath +renamePath opath npath = do + opath' <- encodeFS opath + npath' <- encodeFS npath + D.renamePath 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 @@ -714,45 +567,10 @@ copyFile :: FilePath -- ^ Source filename -> FilePath -- ^ Destination filename -> IO () -copyFile fromFPath toFPath = - (`ioeAddLocation` "copyFile") `modifyIOError` do - atomicCopyFileContents fromFPath toFPath - (ignoreIOExceptions . copyPermissions fromFPath) - --- | 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. -atomicCopyFileContents :: FilePath -- ^ Source filename - -> FilePath -- ^ Destination filename - -> (FilePath -> IO ()) -- ^ Post-action - -> IO () -atomicCopyFileContents fromFPath toFPath postAction = - (`ioeAddLocation` "atomicCopyFileContents") `modifyIOError` do - withReplacementFile toFPath postAction $ \ hTo -> do - copyFileToHandle fromFPath hTo - --- | A helper function useful for replacing files in an atomic manner. The --- function creates a temporary file in the directory of the destination file, --- opens it, performs the main action with its handle, closes it, performs the --- post-action with its path, and finally replaces the destination file with --- the temporary file. If an error occurs during any step of this process, --- the temporary file is removed and the destination file remains untouched. -withReplacementFile :: FilePath -- ^ Destination file - -> (FilePath -> IO ()) -- ^ Post-action - -> (Handle -> IO a) -- ^ Main action - -> IO a -withReplacementFile path postAction action = - (`ioeAddLocation` "withReplacementFile") `modifyIOError` do - mask $ \ restore -> do - (tmpFPath, hTmp) <- openBinaryTempFile (takeDirectory path) - ".copyFile.tmp" - (`onException` ignoreIOExceptions (removeFile tmpFPath)) $ do - r <- (`onException` ignoreIOExceptions (hClose hTmp)) $ do - restore (action hTmp) - hClose hTmp - restore (postAction tmpFPath) - renameFile tmpFPath path - pure r +copyFile fromFPath toFPath = do + fromFPath' <- encodeFS fromFPath + toFPath' <- encodeFS toFPath + D.copyFile fromFPath' toFPath' -- | Copy a file with its associated metadata. If the destination file -- already exists, it is overwritten. There is no guarantee of atomicity in @@ -775,18 +593,11 @@ copyFileWithMetadata :: FilePath -- ^ Source file -> FilePath -- ^ Destination file -> IO () -copyFileWithMetadata src dst = - (`ioeAddLocation` "copyFileWithMetadata") `modifyIOError` - copyFileWithMetadataInternal copyPermissionsFromMetadata - copyTimesFromMetadata - src - dst +copyFileWithMetadata src dst = do + src' <- encodeFS src + dst' <- encodeFS dst + D.copyFileWithMetadata src' dst' -copyTimesFromMetadata :: Metadata -> FilePath -> IO () -copyTimesFromMetadata st dst = do - let atime = accessTimeFromMetadata st - let mtime = modificationTimeFromMetadata st - setFileTimes dst (Just atime, Just mtime) -- | Make a path absolute, normalize the path, and remove as many indirections -- from it as possible. Any trailing path separators are discarded via @@ -852,73 +663,7 @@ -- are now performed on Windows. -- canonicalizePath :: FilePath -> IO FilePath -canonicalizePath = \ path -> - ((`ioeAddLocation` "canonicalizePath") . - (`ioeSetFileName` path)) `modifyIOError` do - -- simplify does more stuff, like upper-casing the drive letter - dropTrailingPathSeparator . simplify <$> - (canonicalizePathWith attemptRealpath =<< prependCurrentDirectory path) - where - - -- allow up to 64 cycles before giving up - attemptRealpath realpath = - 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 - -- any arbitrarily clever algorithm - attemptRealpathWith n mFallback realpath path = - case mFallback of - -- too many indirections ... giving up. - Just fallback | n <= 0 -> pure fallback - -- either mFallback == Nothing (first attempt) - -- or n > 0 (still have some attempts left) - _ -> realpathPrefix (reverse (zip prefixes suffixes)) - - where - - segments = splitDirectories path - prefixes = scanl1 () segments - suffixes = tail (scanr () "" segments) - - -- try to call realpath on the largest possible prefix - realpathPrefix candidates = - case candidates of - [] -> pure path - (prefix, suffix) : rest -> do - exist <- doesPathExist prefix - if not exist - -- never call realpath on an inaccessible path - -- (to avoid bugs in system realpath implementations) - -- try a smaller prefix instead - then realpathPrefix rest - else do - mp <- tryIOError (realpath prefix) - case mp of - -- realpath failed: try a smaller prefix instead - Left _ -> realpathPrefix rest - -- realpath succeeded: fine-tune the result - Right p -> realpathFurther (p suffix) p suffix - - -- by now we have a reasonable fallback value that we can use if we - -- run into too many indirections; the fallback value is the same - -- result that we have been returning in versions prior to 1.3.1.0 - -- (this is essentially the fix to #64) - realpathFurther fallback p suffix = - case splitDirectories suffix of - [] -> pure fallback - next : restSuffix -> do - -- see if the 'next' segment is a symlink - mTarget <- tryIOError (getSymbolicLinkTarget (p next)) - case mTarget of - Left _ -> pure fallback - Right target -> do - -- if so, dereference it and restart the whole cycle - let mFallback' = Just (fromMaybe fallback mFallback) - path' <- canonicalizePathSimplify - (p target joinPath restSuffix) - attemptRealpathWith (n - 1) mFallback' realpath path' +canonicalizePath = encodeFS >=> D.canonicalizePath >=> decodeFS -- | Convert a path into an absolute path. If the given path is relative, the -- current directory is prepended and then the combined result is normalized. @@ -932,27 +677,15 @@ -- @since 1.2.2.0 -- makeAbsolute :: FilePath -> IO FilePath -makeAbsolute path = - ((`ioeAddLocation` "makeAbsolute") . - (`ioeSetFileName` path)) `modifyIOError` do - matchTrailingSeparator path . simplify <$> prependCurrentDirectory path - --- | Add or remove the trailing path separator in the second path so as to --- match its presence in the first path. --- --- (internal API) -matchTrailingSeparator :: FilePath -> FilePath -> FilePath -matchTrailingSeparator path - | hasTrailingPathSeparator path = addTrailingPathSeparator - | otherwise = dropTrailingPathSeparator +makeAbsolute = encodeFS >=> D.makeAbsolute >=> decodeFS -- | Construct a path relative to the current directory, similar to -- 'makeRelative'. -- -- The operation may fail with the same exceptions as 'getCurrentDirectory'. makeRelativeToCurrentDirectory :: FilePath -> IO FilePath -makeRelativeToCurrentDirectory x = do - (`makeRelative` x) <$> getCurrentDirectory +makeRelativeToCurrentDirectory = + encodeFS >=> D.makeRelativeToCurrentDirectory >=> decodeFS -- | Given the name or path of an executable file, 'findExecutable' searches -- for such a file in a list of system-defined locations, which generally @@ -978,9 +711,7 @@ -- testing each file for executable permissions. Details can be found in the -- documentation of 'findFileWith'. findExecutable :: String -> IO (Maybe FilePath) -findExecutable binary = - listTHead - (findExecutablesLazyInternal findExecutablesInDirectoriesLazy binary) +findExecutable = encodeFS >=> D.findExecutable >=> (`for` decodeFS) -- | Search for executable files in a list of system-defined locations, which -- generally includes @PATH@ and possibly more. @@ -995,9 +726,7 @@ -- -- @since 1.2.2.0 findExecutables :: String -> IO [FilePath] -findExecutables binary = - listTToList - (findExecutablesLazyInternal findExecutablesInDirectoriesLazy binary) +findExecutables = encodeFS >=> D.findExecutables >=> (`for` decodeFS) -- | Given a name or path, 'findExecutable' appends the 'exeExtension' to the -- query and searches for executable files in the list of given search @@ -1013,16 +742,11 @@ -- -- @since 1.2.4.0 findExecutablesInDirectories :: [FilePath] -> String -> IO [FilePath] -findExecutablesInDirectories path binary = - 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 = executable <$> getPermissions file +findExecutablesInDirectories path binary = do + path' <- for path encodeFS + binary' <- encodeFS binary + D.findExecutablesInDirectories path' binary' + >>= (`for` decodeFS) -- | Search through the given list of directories for the given file. -- @@ -1051,7 +775,11 @@ -- -- @since 1.2.6.0 findFileWith :: (FilePath -> IO Bool) -> [FilePath] -> String -> IO (Maybe FilePath) -findFileWith f ds name = listTHead (findFilesWithLazy f ds name) +findFileWith f ds name = do + ds' <- for ds encodeFS + name' <- encodeFS name + D.findFileWith (decodeFS >=> f) ds' name' + >>= (`for` decodeFS) -- | @findFilesWith predicate dirs name@ searches through the list of -- directories (@dirs@) for files that have the given @name@ and satisfy the @@ -1072,42 +800,25 @@ -- -- @since 1.2.1.0 findFilesWith :: (FilePath -> IO Bool) -> [FilePath] -> String -> IO [FilePath] -findFilesWith f ds name = listTToList (findFilesWithLazy f ds name) - -findFilesWithLazy - :: (FilePath -> IO Bool) -> [FilePath] -> String -> ListT IO FilePath -findFilesWithLazy f dirs path - -- make sure absolute paths are handled properly irrespective of 'dirs' - -- https://github.com/haskell/directory/issues/72 - | isAbsolute path = ListT (find [""]) - | otherwise = ListT (find dirs) - - where - - find [] = pure Nothing - find (d : ds) = do - let p = d path - found <- doesFileExist p `andM` f p - if found - then pure (Just (p, ListT (find ds))) - else find ds +findFilesWith f ds name = do + ds' <- for ds encodeFS + name' <- encodeFS name + res <- D.findFilesWith (decodeFS >=> f) ds' name' + for res decodeFS -- | Filename extension for executable files (including the dot if any) -- (usually @\"\"@ on POSIX systems and @\".exe\"@ on Windows or OS\/2). -- -- @since 1.2.4.0 exeExtension :: String -exeExtension = exeExtensionInternal +exeExtension = so D.exeExtension -- | Similar to 'listDirectory', but always includes the special entries (@.@ -- and @..@). (This applies to Windows as well.) -- -- The operation may fail with the same exceptions as 'listDirectory'. getDirectoryContents :: FilePath -> IO [FilePath] -getDirectoryContents path = - ((`ioeSetFileName` path) . - (`ioeAddLocation` "getDirectoryContents")) `modifyIOError` do - getDirectoryContentsInternal path +getDirectoryContents = encodeFS >=> D.getDirectoryContents >=> (`for` decodeFS) -- | @'listDirectory' dir@ returns a list of /all/ entries in /dir/ without -- the special entries (@.@ and @..@). @@ -1141,8 +852,7 @@ -- @since 1.2.5.0 -- listDirectory :: FilePath -> IO [FilePath] -listDirectory path = filter f <$> getDirectoryContents path - where f filename = filename /= "." && filename /= ".." +listDirectory = encodeFS >=> D.listDirectory >=> (`for` decodeFS) -- | Obtain the current working directory as an absolute path. -- @@ -1178,12 +888,7 @@ -- 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 +getCurrentDirectory = D.getCurrentDirectory >>= decodeFS -- | Change the working directory to the given path. -- @@ -1219,7 +924,7 @@ -- @[ENOTDIR]@ -- setCurrentDirectory :: FilePath -> IO () -setCurrentDirectory = setCurrentDirectoryInternal +setCurrentDirectory = encodeFS >=> D.setCurrentDirectory -- | Run an 'IO' action with the given working directory and restore the -- original working directory afterwards, even if the given action fails due @@ -1234,17 +939,13 @@ -> IO a -- ^ Action to be executed -> IO a withCurrentDirectory dir action = - bracket getCurrentDirectory setCurrentDirectory $ \ _ -> do - setCurrentDirectory dir - action + encodeFS dir >>= (`D.withCurrentDirectory` action) -- | Obtain the size of a file in bytes. -- -- @since 1.2.7.0 getFileSize :: FilePath -> IO Integer -getFileSize path = - (`ioeAddLocation` "getFileSize") `modifyIOError` do - fileSizeFromMetadata <$> getFileMetadata path +getFileSize = encodeFS >=> D.getFileSize -- | Test whether the given path points to an existing filesystem object. If -- the user lacks necessary permissions to search the parent directories, this @@ -1252,10 +953,7 @@ -- -- @since 1.2.7.0 doesPathExist :: FilePath -> IO Bool -doesPathExist path = do - (True <$ getFileMetadata path) - `catchIOError` \ _ -> - pure False +doesPathExist = encodeFS >=> D.doesPathExist {- |The operation 'doesDirectoryExist' returns 'True' if the argument file exists and is either a directory or a symbolic link to a directory, @@ -1263,25 +961,15 @@ -} doesDirectoryExist :: FilePath -> IO Bool -doesDirectoryExist path = do - pathIsDirectory path - `catchIOError` \ _ -> - pure False +doesDirectoryExist = encodeFS >=> D.doesDirectoryExist {- |The operation 'doesFileExist' returns 'True' if the argument file exists and is not a directory, and 'False' otherwise. -} doesFileExist :: FilePath -> IO Bool -doesFileExist path = do - (not <$> pathIsDirectory path) - `catchIOError` \ _ -> - pure False +doesFileExist = encodeFS >=> D.doesFileExist -pathIsDirectory :: FilePath -> IO Bool -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 @@ -1313,10 +1001,12 @@ :: FilePath -- ^ path to the target file -> FilePath -- ^ path of the link to be created -> IO () -createFileLink target link = - (`ioeAddLocation` "createFileLink") `modifyIOError` do - createSymbolicLink False target link +createFileLink target link = do + target' <- encodeFS target + link' <- encodeFS link + D.createFileLink target' link' + -- | Create a /directory/ symbolic link. The target path can be either -- absolute or relative and need not refer to an existing directory. The -- order of arguments follows the POSIX convention. @@ -1348,9 +1038,10 @@ :: FilePath -- ^ path to the target directory -> FilePath -- ^ path of the link to be created -> IO () -createDirectoryLink target link = - (`ioeAddLocation` "createDirectoryLink") `modifyIOError` do - createSymbolicLink True target link +createDirectoryLink target link = do + target' <- encodeFS target + link' <- encodeFS link + D.createDirectoryLink target' link' -- | Remove an existing /directory/ symbolic link. -- @@ -1361,9 +1052,7 @@ -- -- @since 1.3.1.0 removeDirectoryLink :: FilePath -> IO () -removeDirectoryLink path = - (`ioeAddLocation` "removeDirectoryLink") `modifyIOError` do - removePathInternal linkToDirectoryIsDirectory path +removeDirectoryLink = encodeFS >=> D.removeDirectoryLink -- | Check whether an existing @path@ is a symbolic link. If @path@ is a -- regular file or directory, 'False' is returned. If @path@ does not exist @@ -1382,10 +1071,7 @@ -- -- @since 1.3.0.0 pathIsSymbolicLink :: FilePath -> IO Bool -pathIsSymbolicLink path = - ((`ioeAddLocation` "pathIsSymbolicLink") . - (`ioeSetFileName` path)) `modifyIOError` do - fileTypeIsLink . fileTypeFromMetadata <$> getSymbolicLinkMetadata path +pathIsSymbolicLink = encodeFS >=> D.pathIsSymbolicLink {-# DEPRECATED isSymbolicLink "Use 'pathIsSymbolicLink' instead" #-} isSymbolicLink :: FilePath -> IO Bool @@ -1405,9 +1091,7 @@ -- -- @since 1.3.1.0 getSymbolicLinkTarget :: FilePath -> IO FilePath -getSymbolicLinkTarget path = - (`ioeAddLocation` "getSymbolicLinkTarget") `modifyIOError` do - readSymbolicLink path +getSymbolicLinkTarget = encodeFS >=> D.getSymbolicLinkTarget >=> decodeFS -- | Obtain the time at which the file or directory was last accessed. -- @@ -1425,9 +1109,7 @@ -- @since 1.2.3.0 -- getAccessTime :: FilePath -> IO UTCTime -getAccessTime path = - (`ioeAddLocation` "getAccessTime") `modifyIOError` do - accessTimeFromMetadata <$> getFileMetadata (emptyToCurDir path) +getAccessTime = encodeFS >=> D.getAccessTime -- | Obtain the time at which the file or directory was last modified. -- @@ -1443,9 +1125,7 @@ -- and the underlying filesystem supports them. -- getModificationTime :: FilePath -> IO UTCTime -getModificationTime path = - (`ioeAddLocation` "getModificationTime") `modifyIOError` do - modificationTimeFromMetadata <$> getFileMetadata (emptyToCurDir path) +getModificationTime = encodeFS >=> D.getModificationTime -- | Change the time at which the file or directory was last accessed. -- @@ -1471,9 +1151,7 @@ -- @since 1.2.3.0 -- setAccessTime :: FilePath -> UTCTime -> IO () -setAccessTime path atime = - (`ioeAddLocation` "setAccessTime") `modifyIOError` do - setFileTimes path (Just atime, Nothing) +setAccessTime path atime = encodeFS path >>= (`D.setAccessTime` atime) -- | Change the time at which the file or directory was last modified. -- @@ -1500,16 +1178,7 @@ -- setModificationTime :: FilePath -> UTCTime -> IO () setModificationTime path mtime = - (`ioeAddLocation` "setModificationTime") `modifyIOError` do - setFileTimes path (Nothing, Just mtime) - -setFileTimes :: FilePath -> (Maybe UTCTime, Maybe UTCTime) -> IO () -setFileTimes _ (Nothing, Nothing) = return () -setFileTimes path (atime, mtime) = - ((`ioeAddLocation` "setFileTimes") . - (`ioeSetFileName` path)) `modifyIOError` do - setTimes (emptyToCurDir path) - (utcTimeToPOSIXSeconds <$> atime, utcTimeToPOSIXSeconds <$> mtime) + encodeFS path >>= (`D.setModificationTime` mtime) {- | Returns the current user's home directory. @@ -1535,9 +1204,7 @@ cannot be found. -} getHomeDirectory :: IO FilePath -getHomeDirectory = - (`ioeAddLocation` "getHomeDirectory") `modifyIOError` do - getHomeDirectoryInternal +getHomeDirectory = D.getHomeDirectory >>= decodeFS -- | Obtain the paths to special directories for storing user-specific -- application data, configuration, and cache files, conforming to the @@ -1568,17 +1235,7 @@ -- to the path; if empty, the base -- path is returned -> IO FilePath -getXdgDirectory xdgDir suffix = - (`ioeAddLocation` "getXdgDirectory") `modifyIOError` do - simplify . ( suffix) <$> do - env <- lookupEnv $ case xdgDir of - XdgData -> "XDG_DATA_HOME" - XdgConfig -> "XDG_CONFIG_HOME" - XdgCache -> "XDG_CACHE_HOME" - XdgState -> "XDG_STATE_HOME" - case env of - Just path | isAbsolute path -> pure path - _ -> getXdgDirectoryFallback getHomeDirectory xdgDir +getXdgDirectory xdgDir = encodeFS >=> D.getXdgDirectory xdgDir >=> decodeFS -- | Similar to 'getXdgDirectory' but retrieves the entire list of XDG -- directories. @@ -1589,14 +1246,7 @@ -- Refer to the docs of 'XdgDirectoryList' for more details. getXdgDirectoryList :: XdgDirectoryList -- ^ which special directory list -> IO [FilePath] -getXdgDirectoryList xdgDirs = - (`ioeAddLocation` "getXdgDirectoryList") `modifyIOError` do - env <- lookupEnv $ case xdgDirs of - XdgDataDirs -> "XDG_DATA_DIRS" - XdgConfigDirs -> "XDG_CONFIG_DIRS" - case env of - Nothing -> getXdgDirectoryListFallback xdgDirs - Just paths -> pure (splitSearchPath paths) +getXdgDirectoryList = D.getXdgDirectoryList >=> (`for` decodeFS) -- | Obtain the path to a special directory for storing user-specific -- application data (traditional Unix location). Newer applications may @@ -1627,9 +1277,7 @@ getAppUserDataDirectory :: FilePath -- ^ a relative path that is appended -- to the path -> IO FilePath -getAppUserDataDirectory appName = do - (`ioeAddLocation` "getAppUserDataDirectory") `modifyIOError` do - getAppUserDataDirectoryInternal appName +getAppUserDataDirectory = encodeFS >=> D.getAppUserDataDirectory >=>decodeFS {- | Returns the current user's document directory. @@ -1652,9 +1300,7 @@ cannot be found. -} getUserDocumentsDirectory :: IO FilePath -getUserDocumentsDirectory = do - (`ioeAddLocation` "getUserDocumentsDirectory") `modifyIOError` do - getUserDocumentsDirectoryInternal +getUserDocumentsDirectory = D.getUserDocumentsDirectory >>= decodeFS {- | Returns the current directory for temporary files. @@ -1683,4 +1329,4 @@ The function doesn\'t verify whether the path exists. -} getTemporaryDirectory :: IO FilePath -getTemporaryDirectory = getTemporaryDirectoryInternal +getTemporaryDirectory = D.getTemporaryDirectory >>= decodeFS 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,18 +1,35 @@ -module System.Directory.Internal.Common where +module System.Directory.Internal.Common + ( module System.Directory.Internal.Common + , OsPath + , OsString + ) where import Prelude () import System.Directory.Internal.Prelude -import System.FilePath - ( addTrailingPathSeparator +import GHC.IO.Encoding.Failure (CodingFailureMode(TransliterateCodingFailure)) +import GHC.IO.Encoding.UTF16 (mkUTF16le) +import GHC.IO.Encoding.UTF8 (mkUTF8) +import System.IO (hSetBinaryMode) +import System.OsPath + ( OsPath + , OsString + , addTrailingPathSeparator + , decodeUtf + , decodeWith + , encodeUtf , hasTrailingPathSeparator , isPathSeparator , isRelative , joinDrive , joinPath , normalise + , pack , pathSeparator , pathSeparators , splitDirectories , splitDrive + , toChar + , unpack + , unsafeFromChar ) -- | A generator with side-effects. @@ -59,13 +76,7 @@ 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 + go (s *> r) ms -- | Similar to 'try' but only catches a specify kind of 'IOError' as -- specified by the predicate. @@ -95,46 +106,69 @@ newLoc = loc <> if null oldLoc then "" else ":" <> oldLoc oldLoc = ioeGetLocation e +rightOrError :: Exception e => Either e a -> a +rightOrError (Left e) = error (displayException e) +rightOrError (Right a) = a + +-- | Fallibly converts String to OsString. Only intended to be used on literals. +os :: String -> OsString +os = rightOrError . encodeUtf + +-- | Fallibly converts OsString to String. Only intended to be used on literals. +so :: OsString -> String +so = rightOrError . decodeUtf + +ioeSetOsPath :: IOError -> OsPath -> IOError +ioeSetOsPath err = + ioeSetFileName err . + rightOrError . + decodeWith + (mkUTF8 TransliterateCodingFailure) + (mkUTF16le TransliterateCodingFailure) + -- | Given a list of path segments, expand @.@ and @..@. The path segments -- must not contain path separators. -expandDots :: [FilePath] -> [FilePath] +expandDots :: [OsPath] -> [OsPath] expandDots = reverse . go [] where go ys' xs' = case xs' of [] -> ys' - x : xs -> - case x of - "." -> go ys' xs - ".." -> + x : xs + | x == os "." -> go ys' xs + | x == os ".." -> case ys' of [] -> go (x : ys') xs - ".." : _ -> go (x : ys') xs - _ : ys -> go ys xs - _ -> go (x : ys') xs + y : ys + | y == os ".." -> go (x : ys') xs + | otherwise -> go ys xs + | otherwise -> go (x : ys') xs -- | Convert to the right kind of slashes. -normalisePathSeps :: FilePath -> FilePath -normalisePathSeps p = (\ c -> if isPathSeparator c then pathSeparator else c) <$> p +normalisePathSeps :: OsPath -> OsPath +normalisePathSeps p = pack (normaliseChar <$> unpack p) + where normaliseChar c = if isPathSeparator c then pathSeparator else c -- | Remove redundant trailing slashes and pick the right kind of slash. -normaliseTrailingSep :: FilePath -> FilePath +normaliseTrailingSep :: OsPath -> OsPath normaliseTrailingSep path = do - let path' = reverse path + let path' = reverse (unpack path) let (sep, path'') = span isPathSeparator path' let addSep = if null sep then id else (pathSeparator :) - reverse (addSep path'') + pack (reverse (addSep path'')) -- | Convert empty paths to the current directory, otherwise leave it -- unchanged. -emptyToCurDir :: FilePath -> FilePath -emptyToCurDir "" = "." -emptyToCurDir path = path +emptyToCurDir :: OsPath -> OsPath +emptyToCurDir path + | path == mempty = os "." + | otherwise = path -- | Similar to 'normalise' but empty paths stay empty. -simplifyPosix :: FilePath -> FilePath -simplifyPosix "" = "" -simplifyPosix path = normalise path +simplifyPosix :: OsPath -> OsPath +simplifyPosix path + | path == mempty = mempty + | otherwise = normalise path -- | Similar to 'normalise' but: -- @@ -143,12 +177,11 @@ -- * paths starting with @\\\\?\\@ are preserved. -- -- The goal is to preserve the meaning of paths better than 'normalise'. -simplifyWindows :: FilePath -> FilePath -simplifyWindows "" = "" -simplifyWindows path = - case drive' of - "\\\\?\\" -> drive' <> subpath - _ -> simplifiedPath +simplifyWindows :: OsPath -> OsPath +simplifyWindows path + | path == mempty = mempty + | drive' == os "\\\\?\\" = drive' <> subpath + | otherwise = simplifiedPath where simplifiedPath = joinDrive drive' subpath' (drive, subpath) = splitDrive path @@ -157,24 +190,29 @@ stripPardirs . expandDots . skipSeps . splitDirectories $ subpath - upperDrive d = case d of - c : ':' : s | isAlpha c && all isPathSeparator s -> toUpper c : ':' : s + upperDrive d = case unpack d of + c : k : s + | isAlpha (toChar c), toChar k == ':', all isPathSeparator s -> + -- unsafeFromChar is safe here since all characters are ASCII. + pack (unsafeFromChar (toUpper (toChar c)) : unsafeFromChar ':' : s) _ -> d - skipSeps = filter (not . (`elem` (pure <$> pathSeparators))) - stripPardirs | pathIsAbsolute || subpathIsAbsolute = dropWhile (== "..") + skipSeps = + (pack <$>) . + filter (not . (`elem` (pure <$> pathSeparators))) . + (unpack <$>) + stripPardirs | pathIsAbsolute || subpathIsAbsolute = dropWhile (== os "..") | otherwise = id - prependSep | subpathIsAbsolute = (pathSeparator :) + prependSep | subpathIsAbsolute = (pack [pathSeparator] <>) | otherwise = id avoidEmpty | not pathIsAbsolute - && (null drive || hasTrailingPathSep) -- prefer "C:" over "C:." + , drive == mempty || hasTrailingPathSep -- prefer "C:" over "C:." = emptyToCurDir | otherwise = id - appendSep p | hasTrailingPathSep - && not (pathIsAbsolute && null p) + appendSep p | hasTrailingPathSep, not (pathIsAbsolute && p == mempty) = addTrailingPathSeparator p | otherwise = p pathIsAbsolute = not (isRelative path) - subpathIsAbsolute = any isPathSeparator (take 1 subpath) + subpathIsAbsolute = any isPathSeparator (take 1 (unpack subpath)) hasTrailingPathSep = hasTrailingPathSeparator subpath data FileType = File @@ -205,26 +243,13 @@ , searchable :: Bool } deriving (Eq, Ord, Read, Show) --- | 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 +withBinaryHandle :: IO Handle -> (Handle -> IO r) -> IO r +withBinaryHandle open = bracket openBinary hClose + where + openBinary = do + h <- open + hSetBinaryMode h True + pure h -- | Copy data from one handle to another until end of file. copyHandleData :: Handle -- ^ Source handle 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,9 +1,10 @@ {-# LANGUAGE CPP #-} module System.Directory.Internal.Config where #include +import System.Directory.Internal.Common -exeExtension :: String -exeExtension = EXE_EXTENSION +exeExtension :: OsString +exeExtension = os EXE_EXTENSION -- We avoid using #const_str from hsc because it breaks cross-compilation -- builds, so we use this ugly workaround where we simply paste the C string -- literal directly in here. This will probably break if the 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 @@ -13,24 +13,34 @@ import System.Directory.Internal.Config (exeExtension) import Data.Time (UTCTime) import Data.Time.Clock.POSIX (POSIXTime) -import System.FilePath ((), isRelative, splitSearchPath) +import System.OsPath ((), encodeFS, isRelative, splitSearchPath) +import System.OsString.Internal.Types (OsString(OsString, getOsString)) import qualified Data.Time.Clock.POSIX as POSIXTime -import qualified GHC.Foreign as GHC -import qualified System.Posix as Posix -import qualified System.Posix.User as PU +import qualified System.Posix.Directory.PosixPath as Posix +import qualified System.Posix.Env.PosixString as Posix +import qualified System.Posix.Files.PosixString as Posix +import qualified System.Posix.IO.PosixString as Posix +import qualified System.Posix.PosixPath.FilePath as Posix +import qualified System.Posix.Types as Posix +import qualified System.Posix.User as Posix -createDirectoryInternal :: FilePath -> IO () -createDirectoryInternal path = Posix.createDirectory path 0o777 +createDirectoryInternal :: OsPath -> IO () +createDirectoryInternal (OsString path) = Posix.createDirectory path 0o777 -removePathInternal :: Bool -> FilePath -> IO () -removePathInternal True = Posix.removeDirectory -removePathInternal False = Posix.removeLink +removePathInternal :: Bool -> OsPath -> IO () +removePathInternal True = Posix.removeDirectory . getOsString +removePathInternal False = Posix.removeLink . getOsString -renamePathInternal :: FilePath -> FilePath -> IO () -renamePathInternal = Posix.rename +renamePathInternal :: OsPath -> OsPath -> IO () +renamePathInternal (OsString p1) (OsString p2) = Posix.rename p1 p2 +-- On POSIX, the removability of a file is only affected by the attributes of +-- the containing directory. +filesAlwaysRemovable :: Bool +filesAlwaysRemovable = True + -- | On POSIX, equivalent to 'simplifyPosix'. -simplify :: FilePath -> FilePath +simplify :: OsPath -> OsPath simplify = simplifyPosix -- we use the 'free' from the standard library here since it's not entirely @@ -71,31 +81,31 @@ allocaBytes (pathMax + 1) (realpath >=> action) where realpath = throwErrnoIfNull "" . c_realpath path -canonicalizePathWith :: ((FilePath -> IO FilePath) -> FilePath -> IO FilePath) - -> FilePath - -> IO FilePath +canonicalizePathWith :: ((OsPath -> IO OsPath) -> OsPath -> IO OsPath) + -> OsPath + -> IO OsPath canonicalizePathWith attemptRealpath path = do - encoding <- getFileSystemEncoding - let realpath path' = - GHC.withCString encoding path' (`withRealpath` GHC.peekCString encoding) + let realpath (OsString path') = + Posix.withFilePath path' + (`withRealpath` ((OsString <$>) . Posix.peekFilePath)) attemptRealpath realpath path -canonicalizePathSimplify :: FilePath -> IO FilePath +canonicalizePathSimplify :: OsPath -> IO OsPath canonicalizePathSimplify = pure -findExecutablesLazyInternal :: ([FilePath] -> String -> ListT IO FilePath) - -> String - -> ListT IO FilePath +findExecutablesLazyInternal :: ([OsPath] -> OsString -> ListT IO OsPath) + -> OsString + -> ListT IO OsPath findExecutablesLazyInternal findExecutablesInDirectoriesLazy binary = liftJoinListT $ do path <- getPath pure (findExecutablesInDirectoriesLazy path binary) -exeExtensionInternal :: String +exeExtensionInternal :: OsString exeExtensionInternal = exeExtension -getDirectoryContentsInternal :: FilePath -> IO [FilePath] -getDirectoryContentsInternal path = +getDirectoryContentsInternal :: OsPath -> IO [OsPath] +getDirectoryContentsInternal (OsString path) = bracket (Posix.openDirStream path) Posix.closeDirStream @@ -105,12 +115,12 @@ where loop acc = do e <- Posix.readDirStream dirp - if null e + if e == mempty then pure (acc []) - else loop (acc . (e:)) + else loop (acc . (OsString e :)) -getCurrentDirectoryInternal :: IO FilePath -getCurrentDirectoryInternal = Posix.getWorkingDirectory +getCurrentDirectoryInternal :: IO OsPath +getCurrentDirectoryInternal = OsString <$> Posix.getWorkingDirectory -- | Convert a path into an absolute path. If the given path is relative, the -- current directory is prepended and the path may or may not be simplified. @@ -121,33 +131,37 @@ -- operation may throw exceptions. -- -- Empty paths are treated as the current directory. -prependCurrentDirectory :: FilePath -> IO FilePath +prependCurrentDirectory :: OsPath -> IO OsPath prependCurrentDirectory path | isRelative path = ((`ioeAddLocation` "prependCurrentDirectory") . - (`ioeSetFileName` path)) `modifyIOError` do + (`ioeSetOsPath` path)) `modifyIOError` do ( path) <$> getCurrentDirectoryInternal | otherwise = pure path -setCurrentDirectoryInternal :: FilePath -> IO () -setCurrentDirectoryInternal = Posix.changeWorkingDirectory +setCurrentDirectoryInternal :: OsPath -> IO () +setCurrentDirectoryInternal = Posix.changeWorkingDirectory . getOsString linkToDirectoryIsDirectory :: Bool linkToDirectoryIsDirectory = False -createSymbolicLink :: Bool -> FilePath -> FilePath -> IO () -createSymbolicLink _ = Posix.createSymbolicLink +createHardLink :: OsPath -> OsPath -> IO () +createHardLink (OsString p1) (OsString p2) = Posix.createLink p1 p2 -readSymbolicLink :: FilePath -> IO FilePath -readSymbolicLink = Posix.readSymbolicLink +createSymbolicLink :: Bool -> OsPath -> OsPath -> IO () +createSymbolicLink _ (OsString p1) (OsString p2) = + Posix.createSymbolicLink p1 p2 +readSymbolicLink :: OsPath -> IO OsPath +readSymbolicLink = (OsString <$>) . Posix.readSymbolicLink . getOsString + type Metadata = Posix.FileStatus -getSymbolicLinkMetadata :: FilePath -> IO Metadata -getSymbolicLinkMetadata = Posix.getSymbolicLinkStatus +getSymbolicLinkMetadata :: OsPath -> IO Metadata +getSymbolicLinkMetadata = Posix.getSymbolicLinkStatus . getOsString -getFileMetadata :: FilePath -> IO Metadata -getFileMetadata = Posix.getFileStatus +getFileMetadata :: OsPath -> IO Metadata +getFileMetadata = Posix.getFileStatus . getOsString fileTypeFromMetadata :: Metadata -> FileType fileTypeFromMetadata stat @@ -163,21 +177,11 @@ accessTimeFromMetadata :: Metadata -> UTCTime accessTimeFromMetadata = - POSIXTime.posixSecondsToUTCTime . posix_accessTimeHiRes + POSIXTime.posixSecondsToUTCTime . Posix.accessTimeHiRes modificationTimeFromMetadata :: Metadata -> UTCTime modificationTimeFromMetadata = - POSIXTime.posixSecondsToUTCTime . posix_modificationTimeHiRes - -posix_accessTimeHiRes, posix_modificationTimeHiRes - :: Posix.FileStatus -> POSIXTime -#if MIN_VERSION_unix(2, 6, 0) -posix_accessTimeHiRes = Posix.accessTimeHiRes -posix_modificationTimeHiRes = Posix.modificationTimeHiRes -#else -posix_accessTimeHiRes = realToFrac . Posix.accessTime -posix_modificationTimeHiRes = realToFrac . Posix.modificationTime -#endif + POSIXTime.posixSecondsToUTCTime . Posix.modificationTimeHiRes type Mode = Posix.FileMode @@ -197,19 +201,20 @@ setWriteMode False m = m .&. complement allWriteMode setWriteMode True m = m .|. allWriteMode -setFileMode :: FilePath -> Mode -> IO () -setFileMode = Posix.setFileMode +setFileMode :: OsPath -> Mode -> IO () +setFileMode = Posix.setFileMode . getOsString -setFilePermissions :: FilePath -> Mode -> IO () +setFilePermissions :: OsPath -> Mode -> IO () setFilePermissions = setFileMode -getAccessPermissions :: FilePath -> IO Permissions +getAccessPermissions :: OsPath -> IO Permissions getAccessPermissions path = do m <- getFileMetadata path let isDir = fileTypeIsDirectory (fileTypeFromMetadata m) - r <- Posix.fileAccess path True False False - w <- Posix.fileAccess path False True False - x <- Posix.fileAccess path False False True + let OsString path' = path + r <- Posix.fileAccess path' True False False + w <- Posix.fileAccess path' False True False + x <- Posix.fileAccess path' False False True pure Permissions { readable = r , writable = w @@ -217,7 +222,7 @@ , searchable = x && isDir } -setAccessPermissions :: FilePath -> Permissions -> IO () +setAccessPermissions :: OsPath -> Permissions -> IO () setAccessPermissions path (Permissions r w e s) = do m <- getFileMetadata path setFileMode path (modifyBit (e || s) Posix.ownerExecuteMode . @@ -229,98 +234,141 @@ modifyBit False b m = m .&. complement b modifyBit True b m = m .|. b -copyOwnerFromStatus :: Posix.FileStatus -> FilePath -> IO () -copyOwnerFromStatus st dst = do +copyOwnerFromStatus :: Posix.FileStatus -> OsPath -> IO () +copyOwnerFromStatus st (OsString dst) = do Posix.setOwnerAndGroup dst (Posix.fileOwner st) (-1) -copyGroupFromStatus :: Posix.FileStatus -> FilePath -> IO () -copyGroupFromStatus st dst = do +copyGroupFromStatus :: Posix.FileStatus -> OsPath -> IO () +copyGroupFromStatus st (OsString dst) = do Posix.setOwnerAndGroup dst (-1) (Posix.fileGroup st) -tryCopyOwnerAndGroupFromStatus :: Posix.FileStatus -> FilePath -> IO () +tryCopyOwnerAndGroupFromStatus :: Posix.FileStatus -> OsPath -> IO () tryCopyOwnerAndGroupFromStatus st dst = do ignoreIOExceptions (copyOwnerFromStatus st dst) ignoreIOExceptions (copyGroupFromStatus st dst) -copyFileWithMetadataInternal :: (Metadata -> FilePath -> IO ()) - -> (Metadata -> FilePath -> IO ()) - -> FilePath - -> FilePath +defaultFlags :: Posix.OpenFileFlags +defaultFlags = + Posix.defaultFileFlags + { Posix.noctty = True + , Posix.nonBlock = True + , Posix.cloexec = True + } + +openFileForRead :: OsPath -> IO Handle +openFileForRead (OsString p) = + Posix.fdToHandle =<< Posix.openFd p Posix.ReadOnly defaultFlags + +openFileForWrite :: OsPath -> IO Handle +openFileForWrite (OsString p) = + Posix.fdToHandle =<< + Posix.openFd p Posix.WriteOnly + defaultFlags { Posix.creat = Just 0o666, Posix.trunc = True } + +-- | 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 :: OsPath -- ^ Source filename + -> OsPath -- ^ Destination filename + -> IO () +copyFileContents fromFPath toFPath = + (`ioeAddLocation` "copyFileContents") `modifyIOError` do + withBinaryHandle (openFileForWrite toFPath) $ \ hTo -> do + withBinaryHandle (openFileForRead fromFPath) $ \ hFrom -> do + copyHandleData hFrom hTo + +copyFileWithMetadataInternal :: (Metadata -> OsPath -> IO ()) + -> (Metadata -> OsPath -> IO ()) + -> OsPath + -> OsPath -> IO () copyFileWithMetadataInternal copyPermissionsFromMetadata copyTimesFromMetadata src dst = do - st <- Posix.getFileStatus src + st <- Posix.getFileStatus (getOsString src) copyFileContents src dst tryCopyOwnerAndGroupFromStatus st dst copyPermissionsFromMetadata st dst copyTimesFromMetadata st dst -setTimes :: FilePath -> (Maybe POSIXTime, Maybe POSIXTime) -> IO () +setTimes :: OsPath -> (Maybe POSIXTime, Maybe POSIXTime) -> IO () #ifdef HAVE_UTIMENSAT -setTimes path' (atime', mtime') = - withFilePath path' $ \ path'' -> +setTimes (OsString path') (atime', mtime') = + Posix.withFilePath path' $ \ path'' -> withArray [ maybe utimeOmit toCTimeSpec atime' , maybe utimeOmit toCTimeSpec mtime' ] $ \ times -> - throwErrnoPathIfMinus1_ "" path' $ + Posix.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' +setTimes (OsString path') (Just atime', Just mtime') = + Posix.setFileTimesHiRes path' atime' mtime' +setTimes (OsString path') (atime', mtime') = do + m <- getFileMetadata (OsString path') let atimeOld = accessTimeFromMetadata m let mtimeOld = modificationTimeFromMetadata m - setFileTimes' path' + Posix.setFileTimesHiRes 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 +lookupEnvOs :: OsString -> IO (Maybe OsString) +lookupEnvOs (OsString name) = (OsString <$>) <$> Posix.getEnv name + +getEnvOs :: OsString -> IO OsString +getEnvOs name = do + env <- lookupEnvOs name + case env of + Nothing -> + throwIO $ + mkIOError + doesNotExistErrorType + ("env var " <> show name <> " not found") + Nothing + Nothing + Just value -> pure value + -- | Get the contents of the @PATH@ environment variable. -getPath :: IO [FilePath] -getPath = splitSearchPath <$> getEnv "PATH" +getPath :: IO [OsPath] +getPath = splitSearchPath <$> getEnvOs (os "PATH") -- | $HOME is preferred, because the user has control over it. However, POSIX -- doesn't define it as a mandatory variable, so fall back to `getpwuid_r`. -getHomeDirectoryInternal :: IO FilePath +getHomeDirectoryInternal :: IO OsPath getHomeDirectoryInternal = do - e <- lookupEnv "HOME" + e <- lookupEnvOs (os "HOME") case e of Just fp -> pure fp - Nothing -> PU.homeDirectory <$> (PU.getEffectiveUserID >>= PU.getUserEntryForID) + -- TODO: os here is bad, but unix's System.Posix.User.UserEntry does not + -- have ByteString/OsString variants + Nothing -> + encodeFS =<< + Posix.homeDirectory <$> + (Posix.getEffectiveUserID >>= Posix.getUserEntryForID) -getXdgDirectoryFallback :: IO FilePath -> XdgDirectory -> IO FilePath +getXdgDirectoryFallback :: IO OsPath -> XdgDirectory -> IO OsPath getXdgDirectoryFallback getHomeDirectory xdgDir = do (<$> getHomeDirectory) $ flip () $ case xdgDir of - XdgData -> ".local/share" - XdgConfig -> ".config" - XdgCache -> ".cache" - XdgState -> ".local/state" + XdgData -> os ".local/share" + XdgConfig -> os ".config" + XdgCache -> os ".cache" + XdgState -> os ".local/state" -getXdgDirectoryListFallback :: XdgDirectoryList -> IO [FilePath] +getXdgDirectoryListFallback :: XdgDirectoryList -> IO [OsPath] getXdgDirectoryListFallback xdgDirs = pure $ case xdgDirs of - XdgDataDirs -> ["/usr/local/share/", "/usr/share/"] - XdgConfigDirs -> ["/etc/xdg"] + XdgDataDirs -> [os "/usr/local/share/", os "/usr/share/"] + XdgConfigDirs -> [os "/etc/xdg"] -getAppUserDataDirectoryInternal :: FilePath -> IO FilePath +getAppUserDataDirectoryInternal :: OsPath -> IO OsPath getAppUserDataDirectoryInternal appName = - (\ home -> home <> ('/' : '.' : appName)) <$> getHomeDirectoryInternal + (\ home -> home <> (os "/" <> os "." <> appName)) <$> getHomeDirectoryInternal -getUserDocumentsDirectoryInternal :: IO FilePath +getUserDocumentsDirectoryInternal :: IO OsPath getUserDocumentsDirectoryInternal = getHomeDirectoryInternal -getTemporaryDirectoryInternal :: IO FilePath -getTemporaryDirectoryInternal = fromMaybe "/tmp" <$> lookupEnv "TMPDIR" +getTemporaryDirectoryInternal :: IO OsPath +getTemporaryDirectoryInternal = fromMaybe (os "/tmp") <$> lookupEnvOs (os "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 @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Stability: unstable @@ -8,14 +7,6 @@ module System.Directory.Internal.Prelude ( module Prelude -#if !MIN_VERSION_base(4, 6, 0) - , forkFinally - , lookupEnv -#endif -#if !MIN_VERSION_base(4, 8, 0) - , module Control.Applicative - , module Data.Functor -#endif , module Control.Arrow , module Control.Concurrent , module Control.Exception @@ -36,22 +27,11 @@ , module System.Exit , module System.IO , module System.IO.Error - , module System.Posix.Internals , module System.Posix.Types , module System.Timeout , Void ) where -#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 (Applicative, (<*>), (*>), pure) -import Data.Functor ((<$>), (<$)) -#endif import Control.Arrow (second) import Control.Concurrent ( forkIO @@ -60,16 +40,14 @@ , putMVar , readMVar , takeMVar -#if MIN_VERSION_base(4, 6, 0) , forkFinally -#else - , ThreadId -#endif ) import Control.Exception - ( SomeException + ( Exception(displayException) + , SomeException , bracket , bracket_ + , bracketOnError , catch , finally , mask @@ -80,7 +58,7 @@ import Control.Monad ((>=>), (<=<), unless, when, replicateM, replicateM_) import Data.Bits ((.&.), (.|.), complement) import Data.Char (isAlpha, isAscii, toLower, toUpper) -import Data.Foldable (for_, traverse_) +import Data.Foldable (for_) import Data.Function (on) import Data.Maybe (catMaybes, fromMaybe, maybeToList) import Data.Monoid ((<>), mconcat, mempty) @@ -118,14 +96,9 @@ , CUShort(..) , CWString , CWchar(..) - , peekCString - , peekCWStringLen , throwErrnoIfMinus1Retry_ , throwErrnoIfMinus1_ , throwErrnoIfNull - , throwErrnoPathIfMinus1_ - , withCString - , withCWString ) import GHC.IO.Exception ( IOErrorType @@ -136,7 +109,7 @@ ) ) import GHC.IO.Encoding (getFileSystemEncoding) -import System.Environment (getArgs, getEnv) +import System.Environment (getArgs) import System.Exit (exitFailure) import System.IO ( Handle @@ -150,11 +123,11 @@ , openBinaryTempFile , stderr , stdout - , withBinaryFile ) import System.IO.Error ( IOError , catchIOError + , doesNotExistErrorType , illegalOperationErrorType , ioeGetErrorString , ioeGetErrorType @@ -172,28 +145,5 @@ , tryIOError , userError ) -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) - -forkFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId -forkFinally action and_then = - mask $ \restore -> - forkIO $ try (restore action) >>= and_then -#endif - -#if !MIN_VERSION_base(4, 8, 0) -data Void = Void - -_unusedVoid :: Void -_unusedVoid = Void -#endif 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 @@ -11,6 +11,7 @@ ##endif #include #include +#include #include #include import Prelude () @@ -19,61 +20,70 @@ import System.Directory.Internal.Config (exeExtension) import Data.Time (UTCTime) import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime) -import System.FilePath +#ifdef __IO_MANAGER_WINIO__ +import GHC.IO.SubSystem (IoSubSystem(IoPOSIX, IoNative), ioSubSystem) +#endif +import System.OsPath ( () , isPathSeparator , isRelative + , pack , pathSeparator , splitDirectories , takeExtension + , toChar + , unpack ) +import System.OsPath.Types (WindowsPath, WindowsString) +import System.OsString.Internal.Types (OsString(OsString, getOsString)) import qualified Data.List as List -import qualified System.Win32 as Win32 +import qualified System.Win32.WindowsString.File as Win32 +import qualified System.Win32.WindowsString.Info as Win32 +import qualified System.Win32.WindowsString.Shell as Win32 +import qualified System.Win32.WindowsString.Time as Win32 +import qualified System.Win32.WindowsString.Types as Win32 -createDirectoryInternal :: FilePath -> IO () +createDirectoryInternal :: OsPath -> IO () createDirectoryInternal path = - (`ioeSetFileName` path) `modifyIOError` do + (`ioeSetOsPath` path) `modifyIOError` do path' <- furnishPath path Win32.createDirectory path' Nothing -removePathInternal :: Bool -> FilePath -> IO () +removePathInternal :: Bool -> OsPath -> IO () removePathInternal isDir path = - (`ioeSetFileName` path) `modifyIOError` do + (`ioeSetOsPath` path) `modifyIOError` do furnishPath path >>= if isDir then Win32.removeDirectory else Win32.deleteFile -renamePathInternal :: FilePath -> FilePath -> IO () +renamePathInternal :: OsPath -> OsPath -> IO () renamePathInternal opath npath = - (`ioeSetFileName` opath) `modifyIOError` do + (`ioeSetOsPath` opath) `modifyIOError` do opath' <- furnishPath opath npath' <- furnishPath 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 +-- On Windows, the removability of a file may be affected by the attributes of +-- the file itself. +filesAlwaysRemovable :: Bool +filesAlwaysRemovable = False + +copyFileWithMetadataInternal :: (Metadata -> OsPath -> IO ()) + -> (Metadata -> OsPath -> IO ()) + -> OsPath + -> OsPath -> IO () copyFileWithMetadataInternal _ _ src dst = - (`ioeSetFileName` src) `modifyIOError` do + (`ioeSetOsPath` src) `modifyIOError` do src' <- furnishPath src dst' <- furnishPath 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 -#else -win32_cSIDL_LOCAL_APPDATA = (#const CSIDL_LOCAL_APPDATA) -#endif - win32_cSIDL_COMMON_APPDATA :: Win32.CSIDL win32_cSIDL_COMMON_APPDATA = (#const CSIDL_COMMON_APPDATA) +win32_eRROR_ENVVAR_NOT_FOUND :: Win32.ErrCode +win32_eRROR_ENVVAR_NOT_FOUND = (#const ERROR_ENVVAR_NOT_FOUND) + win32_eRROR_INVALID_FUNCTION :: Win32.ErrCode win32_eRROR_INVALID_FUNCTION = (#const ERROR_INVALID_FUNCTION) @@ -89,64 +99,42 @@ 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 -#else -win32_fILE_ATTRIBUTE_REPARSE_POINT = (#const FILE_ATTRIBUTE_REPARSE_POINT) -#endif - -win32_fILE_SHARE_DELETE :: Win32.ShareMode -#if MIN_VERSION_Win32(2, 3, 1) -win32_fILE_SHARE_DELETE = Win32.fILE_SHARE_DELETE -- added in 2.3.0.2 -#else -win32_fILE_SHARE_DELETE = (#const FILE_SHARE_DELETE) -#endif - maxShareMode :: Win32.ShareMode maxShareMode = - win32_fILE_SHARE_DELETE .|. + Win32.fILE_SHARE_DELETE .|. Win32.fILE_SHARE_READ .|. Win32.fILE_SHARE_WRITE -win32_getLongPathName, win32_getShortPathName :: FilePath -> IO FilePath -#if MIN_VERSION_Win32(2, 4, 0) -win32_getLongPathName = Win32.getLongPathName -win32_getShortPathName = Win32.getShortPathName -#else -win32_getLongPathName path = - ((`ioeSetLocation` "GetLongPathName") . - (`ioeSetFileName` path)) `modifyIOError` do - withCWString path $ \ ptrPath -> do - getPathNameWith (c_GetLongPathName ptrPath) - -win32_getShortPathName path = - ((`ioeSetLocation` "GetShortPathName") . - (`ioeSetFileName` path)) `modifyIOError` do - withCWString path $ \ ptrPath -> do - getPathNameWith (c_GetShortPathName ptrPath) - -foreign import WINAPI unsafe "windows.h GetLongPathNameW" - c_GetLongPathName - :: Ptr CWchar - -> Ptr CWchar - -> Win32.DWORD - -> IO Win32.DWORD +openFileForRead :: OsPath -> IO Handle +openFileForRead (OsString path) = + bracketOnError + (Win32.createFile + path + Win32.gENERIC_READ + maxShareMode + Nothing + Win32.oPEN_ALWAYS + (Win32.fILE_ATTRIBUTE_NORMAL .|. possiblyOverlapped) + Nothing) + Win32.closeHandle + Win32.hANDLEToHandle -foreign import WINAPI unsafe "windows.h GetShortPathNameW" - c_GetShortPathName - :: Ptr CWchar - -> Ptr CWchar - -> Win32.DWORD - -> IO Win32.DWORD +possiblyOverlapped :: Win32.FileAttributeOrFlag +#ifdef __IO_MANAGER_WINIO__ +possiblyOverlapped | ioSubSystem == IoNative = Win32.fILE_FLAG_OVERLAPPED + | otherwise = 0 +#else +possiblyOverlapped = 0 #endif -win32_getFinalPathNameByHandle :: Win32.HANDLE -> Win32.DWORD -> IO FilePath -win32_getFinalPathNameByHandle _h _flags = - (`ioeSetLocation` "GetFinalPathNameByHandle") `modifyIOError` do +win32_getFinalPathNameByHandle :: Win32.HANDLE -> Win32.DWORD -> IO WindowsPath #ifdef HAVE_GETFINALPATHNAMEBYHANDLEW - getPathNameWith $ \ ptr len -> do - c_GetFinalPathNameByHandle _h ptr len _flags +win32_getFinalPathNameByHandle h flags = do + result <- peekTStringWith (#const MAX_PATH) $ \ ptr len -> do + c_GetFinalPathNameByHandle h ptr len flags + case result of + Left errCode -> Win32.failWith "GetFinalPathNameByHandle" errCode + Right path -> pure path foreign import WINAPI unsafe "windows.h GetFinalPathNameByHandleW" c_GetFinalPathNameByHandle @@ -157,14 +145,19 @@ -> IO Win32.DWORD #else - throwIO (mkIOError UnsupportedOperation - "platform does not support GetFinalPathNameByHandle" - Nothing Nothing) +win32_getFinalPathNameByHandle _ _ = throwIO $ + mkIOError + UnsupportedOperation + "platform does not support GetFinalPathNameByHandle" + Nothing + Nothing #endif -getFinalPathName :: FilePath -> IO FilePath +getFinalPathName :: OsPath -> IO OsPath getFinalPathName = - (fromExtendedLengthPath <$>) . rawGetFinalPathName . toExtendedLengthPath + (fromExtendedLengthPath <$>) . + rawGetFinalPathName . + toExtendedLengthPath where #ifdef HAVE_GETFINALPATHNAMEBYHANDLEW rawGetFinalPathName path = do @@ -173,7 +166,7 @@ bracket open Win32.closeHandle $ \ h -> do win32_getFinalPathNameByHandle h 0 #else - rawGetFinalPathName = win32_getLongPathName <=< win32_getShortPathName + rawGetFinalPathName = Win32.getLongPathName <=< Win32.getShortPathName #endif win32_fILE_FLAG_OPEN_REPARSE_POINT :: Win32.FileAttributeOrFlag @@ -194,9 +187,9 @@ win32_sYMLINK_FLAG_RELATIVE = 0x00000001 data Win32_REPARSE_DATA_BUFFER - = Win32_MOUNT_POINT_REPARSE_DATA_BUFFER String String + = Win32_MOUNT_POINT_REPARSE_DATA_BUFFER WindowsString WindowsString -- ^ substituteName printName - | Win32_SYMLINK_REPARSE_DATA_BUFFER String String Bool + | Win32_SYMLINK_REPARSE_DATA_BUFFER WindowsString WindowsString Bool -- ^ substituteName printName isRelative | Win32_GENERIC_REPARSE_DATA_BUFFER @@ -247,10 +240,10 @@ (flags .&. win32_sYMLINK_FLAG_RELATIVE /= 0)) | otherwise -> pure Win32_GENERIC_REPARSE_DATA_BUFFER where - peekName :: Ptr CWchar -> CUShort -> CUShort -> IO String + peekName :: Ptr CWchar -> CUShort -> CUShort -> IO WindowsString peekName buf offset size = - peekCWStringLen ( buf `plusPtr` fromIntegral offset - , fromIntegral size `div` sizeOf (0 :: CWchar) ) + Win32.peekTStringLen ( buf `plusPtr` fromIntegral offset + , fromIntegral size `div` sizeOf (0 :: CWchar) ) deviceIoControl :: Win32.HANDLE @@ -279,9 +272,9 @@ -> Ptr Void -> IO Win32.BOOL -readSymbolicLink :: FilePath -> IO FilePath +readSymbolicLink :: OsPath -> IO OsPath readSymbolicLink path = - (`ioeSetFileName` path) `modifyIOError` do + (`ioeSetOsPath` path) `modifyIOError` do path' <- furnishPath path let open = Win32.createFile path' 0 maxShareMode Nothing Win32.oPEN_EXISTING (Win32.fILE_FLAG_BACKUP_SEMANTICS .|. @@ -300,41 +293,47 @@ | otherwise -> Win32.failWith "DeviceIoControl" e Right _ -> pure () rData <- win32_peek_REPARSE_DATA_BUFFER ptr - strip <$> case rData of + strip . OsString <$> 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) + strip sn = + fromMaybe sn + (pack <$> List.stripPrefix (unpack (os "\\??\\")) (unpack sn)) -- | On Windows, equivalent to 'simplifyWindows'. -simplify :: FilePath -> FilePath +simplify :: OsPath -> OsPath simplify = simplifyWindows -- | Normalise the path separators and prepend the @"\\\\?\\"@ prefix if -- necessary or possible. This is used for symbolic links targets because -- they can't handle forward slashes. -normaliseSeparators :: FilePath -> FilePath +normaliseSeparators :: OsPath -> WindowsPath normaliseSeparators path - | isRelative path = normaliseSep <$> path + | isRelative path = getOsString (pack (normaliseSep <$> unpack path)) | otherwise = toExtendedLengthPath path where normaliseSep c = if isPathSeparator c then pathSeparator else c -- | 'simplify' the path and prepend the @"\\\\?\\"@ if possible. This -- function can sometimes be used to bypass the @MAX_PATH@ length restriction -- in Windows API calls. -toExtendedLengthPath :: FilePath -> FilePath -toExtendedLengthPath path - | isRelative path = simplifiedPath - | otherwise = - case simplifiedPath of - '\\' : '?' : '?' : '\\' : _ -> simplifiedPath - '\\' : '\\' : '?' : '\\' : _ -> simplifiedPath - '\\' : '\\' : '.' : '\\' : _ -> simplifiedPath - '\\' : subpath@('\\' : _) -> "\\\\?\\UNC" <> subpath - _ -> "\\\\?\\" <> simplifiedPath +toExtendedLengthPath :: OsPath -> WindowsPath +toExtendedLengthPath path = + getOsString $ + if isRelative path + then simplifiedPath + else + case toChar <$> simplifiedPath' of + '\\' : '?' : '?' : '\\' : _ -> simplifiedPath + '\\' : '\\' : '?' : '\\' : _ -> simplifiedPath + '\\' : '\\' : '.' : '\\' : _ -> simplifiedPath + '\\' : '\\' : _ -> + os "\\\\?\\UNC" <> pack (tail simplifiedPath') + _ -> os "\\\\?\\" <> simplifiedPath where simplifiedPath = simplify path + simplifiedPath' = unpack simplifiedPath -- | Make a path absolute and convert to an extended length path, if possible. -- @@ -342,79 +341,99 @@ -- -- This function never fails. If it doesn't understand the path, it just -- returns the path unchanged. -furnishPath :: FilePath -> IO FilePath +furnishPath :: OsPath -> IO WindowsPath furnishPath path = (toExtendedLengthPath <$> rawPrependCurrentDirectory path) `catchIOError` \ _ -> - pure path + pure (getOsString path) -- | Strip the @"\\\\?\\"@ prefix if possible. -- The prefix is kept if the meaning of the path would otherwise change. -fromExtendedLengthPath :: FilePath -> FilePath -fromExtendedLengthPath ePath = - case ePath of - '\\' : '\\' : '?' : '\\' : path -> +fromExtendedLengthPath :: WindowsPath -> OsPath +fromExtendedLengthPath ePath' = + case unpack ePath of + c1 : c2 : c3 : c4 : path + | (toChar <$> [c1, c2, c3, c4]) == "\\\\?\\" -> case path of - 'U' : 'N' : 'C' : subpath@('\\' : _) -> "\\" <> subpath - drive : ':' : subpath + c5 : c6 : c7 : subpath@(c8 : _) + | (toChar <$> [c5, c6, c7, c8]) == "UNC\\" -> pack subpath + drive : col : subpath -- if the path is not "regular", then the prefix is necessary -- to ensure the path is interpreted literally - | isAlpha drive && isAscii drive && isPathRegular subpath -> path + | toChar col == ':', isDriveChar drive, isPathRegular subpath -> + pack path _ -> ePath _ -> ePath where + ePath = OsString ePath' + isDriveChar drive = isAlpha (toChar drive) && isAscii (toChar drive) isPathRegular path = - not ('/' `elem` path || - "." `elem` splitDirectories path || - ".." `elem` splitDirectories path) + not ('/' `elem` (toChar <$> path) || + os "." `elem` splitDirectories (pack path) || + os ".." `elem` splitDirectories (pack path)) -getPathNameWith :: (Ptr CWchar -> Win32.DWORD -> IO Win32.DWORD) -> IO FilePath -getPathNameWith cFunc = do - let getPathNameWithLen len = do - allocaArray (fromIntegral len) $ \ ptrPathOut -> do - len' <- Win32.failIfZero "" (cFunc ptrPathOut len) - if len' <= len - then Right <$> peekCWStringLen (ptrPathOut, fromIntegral len') - else pure (Left len') - r <- getPathNameWithLen ((#const MAX_PATH) * (#size wchar_t)) - case r of - Right s -> pure s - Left len -> do - r' <- getPathNameWithLen len - case r' of - Right s -> pure s - Left _ -> throwIO (mkIOError OtherError "" Nothing Nothing - `ioeSetErrorString` "path changed unexpectedly") +saturatingDouble :: Win32.DWORD -> Win32.DWORD +saturatingDouble s | s > maxBound `div` 2 = maxBound + | otherwise = s * 2 -canonicalizePathWith :: ((FilePath -> IO FilePath) -> FilePath -> IO FilePath) - -> FilePath - -> IO FilePath +-- Handles Windows APIs that write strings through a user-provided buffer and +-- can propose a new length when it isn't big enough. This is similar to +-- Win32.try, but also returns the precise error code. +peekTStringWith :: Win32.DWORD + -> (Win32.LPTSTR -> Win32.DWORD -> IO Win32.DWORD) + -- ^ Must accept a buffer and its size in TCHARs. If the + -- buffer is large enough for the function, it must write a + -- string to it, which need not be null-terminated, and + -- return the length of the string, not including the null + -- terminator if present. If the buffer is too small, it + -- must return a proposed buffer size in TCHARs, although it + -- need not guarantee success with the proposed size if, + -- say, the underlying data changes in the interim. If it + -- fails for any other reason, it must return zero and + -- communicate the error code through GetLastError. + -> IO (Either Win32.ErrCode WindowsPath) +peekTStringWith bufferSize cFunc = do + outcome <- do + allocaArray (fromIntegral bufferSize) $ \ ptr -> do + size <- cFunc ptr bufferSize + case size of + 0 -> Right . Left <$> Win32.getLastError + _ | size <= bufferSize -> + Right . Right <$> Win32.peekTStringLen (ptr, fromIntegral size) + | otherwise -> + -- At least double the size to ensure fast termination. + pure (Left (max size (saturatingDouble bufferSize))) + case outcome of + Left proposedSize -> peekTStringWith proposedSize cFunc + Right result -> pure result + +canonicalizePathWith :: ((OsPath -> IO OsPath) -> OsPath -> IO OsPath) + -> OsPath + -> IO OsPath canonicalizePathWith attemptRealpath = attemptRealpath getFinalPathName -canonicalizePathSimplify :: FilePath -> IO FilePath +canonicalizePathSimplify :: OsPath -> IO OsPath canonicalizePathSimplify path = getFullPathName 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 +searchPathEnvForExes :: OsString -> IO (Maybe OsPath) +searchPathEnvForExes (OsString binary) = + (OsString <$>) <$> + Win32.searchPath Nothing binary (Just (getOsString exeExtension)) -findExecutablesLazyInternal :: ([FilePath] -> String -> ListT IO FilePath) - -> String - -> ListT IO FilePath +findExecutablesLazyInternal :: ([OsPath] -> OsString -> ListT IO OsPath) + -> OsString + -> ListT IO OsPath findExecutablesLazyInternal _ = maybeToListT . searchPathEnvForExes -exeExtensionInternal :: String +exeExtensionInternal :: OsString exeExtensionInternal = exeExtension -getDirectoryContentsInternal :: FilePath -> IO [FilePath] +getDirectoryContentsInternal :: OsPath -> IO [OsPath] getDirectoryContentsInternal path = do - query <- furnishPath (path "*") + query <- furnishPath (path os "*") bracket (Win32.findFirstFile query) (\ (h, _) -> Win32.findClose h) @@ -422,28 +441,28 @@ 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 :: Win32.HANDLE -> Win32.FindData -> [OsPath] -> IO [OsPath] 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) + then loop h fdat (OsString filename : acc) + else pure (OsString filename : acc) -- no need to reverse, ordering is undefined -getCurrentDirectoryInternal :: IO FilePath -getCurrentDirectoryInternal = Win32.getCurrentDirectory +getCurrentDirectoryInternal :: IO OsPath +getCurrentDirectoryInternal = OsString <$> Win32.getCurrentDirectory -getFullPathName :: FilePath -> IO FilePath +getFullPathName :: OsPath -> IO OsPath getFullPathName path = fromExtendedLengthPath <$> Win32.getFullPathName (toExtendedLengthPath path) -- | Similar to 'prependCurrentDirectory' but fails for empty paths. -rawPrependCurrentDirectory :: FilePath -> IO FilePath +rawPrependCurrentDirectory :: OsPath -> IO OsPath rawPrependCurrentDirectory path | isRelative path = ((`ioeAddLocation` "prependCurrentDirectory") . - (`ioeSetFileName` path)) `modifyIOError` do + (`ioeSetOsPath` path)) `modifyIOError` do getFullPathName path | otherwise = pure path @@ -456,19 +475,19 @@ -- operation may throw exceptions. -- -- Empty paths are treated as the current directory. -prependCurrentDirectory :: FilePath -> IO FilePath +prependCurrentDirectory :: OsPath -> IO OsPath prependCurrentDirectory = rawPrependCurrentDirectory . emptyToCurDir -- 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 +setCurrentDirectoryInternal :: OsPath -> IO () +setCurrentDirectoryInternal = Win32.setCurrentDirectory . getOsString -createSymbolicLinkUnpriv :: String -> String -> Bool -> IO () +createSymbolicLinkUnpriv :: WindowsPath -> WindowsPath -> Bool -> IO () createSymbolicLinkUnpriv link _target _isDir = #ifdef HAVE_CREATESYMBOLICLINKW - withCWString link $ \ pLink -> - withCWString _target $ \ pTarget -> do + Win32.withTString link $ \ pLink -> + Win32.withTString _target $ \ pTarget -> do let flags = if _isDir then win32_sYMBOLIC_LINK_FLAG_DIRECTORY else 0 call pLink pTarget flags win32_sYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE where @@ -481,14 +500,16 @@ let msg = "Incorrect function. The underlying file system " <> "might not support symbolic links." throwIO (mkIOError illegalOperationErrorType - "CreateSymbolicLink" Nothing (Just link) + "CreateSymbolicLink" Nothing Nothing + `ioeSetOsPath` OsString link `ioeSetErrorString` msg) | e == win32_eRROR_PRIVILEGE_NOT_HELD -> do let msg = "A required privilege is not held by the client. " <> "Creating symbolic links usually requires " <> "administrative rights." throwIO (mkIOError permissionErrorType "CreateSymbolicLink" - Nothing (Just link) + Nothing Nothing + `ioeSetOsPath` OsString link `ioeSetErrorString` msg) | e == win32_eRROR_INVALID_PARAMETER && unpriv /= 0 -> @@ -502,27 +523,31 @@ :: Ptr CWchar -> Ptr CWchar -> Win32.DWORD -> IO Win32.BYTE #else - throwIO . (`ioeSetErrorString` unsupportedErrorMsg) $ + throwIO . (`ioeSetErrorString` unsupportedErrorMsg) + . (`ioeSetOsPath` OsString link) $ mkIOError UnsupportedOperation "CreateSymbolicLink" - Nothing (Just link) + Nothing Nothing where unsupportedErrorMsg = "Not supported on Windows XP or older" #endif linkToDirectoryIsDirectory :: Bool linkToDirectoryIsDirectory = True -createSymbolicLink :: Bool -> FilePath -> FilePath -> IO () +createSymbolicLink :: Bool -> OsPath -> OsPath -> IO () createSymbolicLink isDir target link = - (`ioeSetFileName` link) `modifyIOError` do + (`ioeSetOsPath` link) `modifyIOError` do -- normaliseSeparators ensures the target gets normalised properly link' <- furnishPath link - createSymbolicLinkUnpriv link' (normaliseSeparators target) isDir + createSymbolicLinkUnpriv + link' + (normaliseSeparators target) + isDir type Metadata = Win32.BY_HANDLE_FILE_INFORMATION -getSymbolicLinkMetadata :: FilePath -> IO Metadata +getSymbolicLinkMetadata :: OsPath -> IO Metadata getSymbolicLinkMetadata path = - (`ioeSetFileName` path) `modifyIOError` do + (`ioeSetOsPath` path) `modifyIOError` do path' <- furnishPath path let open = Win32.createFile path' 0 maxShareMode Nothing Win32.oPEN_EXISTING (Win32.fILE_FLAG_BACKUP_SEMANTICS .|. @@ -530,9 +555,9 @@ bracket open Win32.closeHandle $ \ h -> do Win32.getFileInformationByHandle h -getFileMetadata :: FilePath -> IO Metadata +getFileMetadata :: OsPath -> IO Metadata getFileMetadata path = - (`ioeSetFileName` path) `modifyIOError` do + (`ioeSetOsPath` path) `modifyIOError` do path' <- furnishPath path let open = Win32.createFile path' 0 maxShareMode Nothing Win32.oPEN_EXISTING Win32.fILE_FLAG_BACKUP_SEMANTICS Nothing @@ -545,7 +570,7 @@ | isDir = Directory | otherwise = File where - isLink = attrs .&. win32_fILE_ATTRIBUTE_REPARSE_POINT /= 0 + isLink = attrs .&. Win32.fILE_ATTRIBUTE_REPARSE_POINT /= 0 isDir = attrs .&. Win32.fILE_ATTRIBUTE_DIRECTORY /= 0 attrs = Win32.bhfiFileAttributes info @@ -575,23 +600,16 @@ posixToWindowsTime t = Win32.FILETIME $ truncate (t * 10000000 + windowsPosixEpochDifference) -setTimes :: FilePath -> (Maybe POSIXTime, Maybe POSIXTime) -> IO () +setTimes :: OsPath -> (Maybe POSIXTime, Maybe POSIXTime) -> IO () setTimes path' (atime', mtime') = bracket (openFileHandle path' Win32.gENERIC_WRITE) Win32.closeHandle $ \ handle -> -#if MIN_VERSION_Win32(2,12,0) Win32.setFileTime handle Nothing (posixToWindowsTime <$> atime') (posixToWindowsTime <$> mtime') -#else - maybeWith with (posixToWindowsTime <$> atime') $ \ atime'' -> - maybeWith with (posixToWindowsTime <$> mtime') $ \ mtime'' -> - Win32.failIf_ not "" $ - Win32.c_SetFileTime handle nullPtr atime'' mtime'' -#endif -- | Open the handle of an existing file or directory. -openFileHandle :: String -> Win32.AccessMode -> IO Win32.HANDLE +openFileHandle :: OsString -> Win32.AccessMode -> IO Win32.HANDLE openFileHandle path mode = - (`ioeSetFileName` path) `modifyIOError` do + (`ioeSetOsPath` path) `modifyIOError` do path' <- furnishPath path Win32.createFile path' mode maxShareMode Nothing Win32.oPEN_EXISTING flags Nothing @@ -610,26 +628,26 @@ setWriteMode False m = m .|. Win32.fILE_ATTRIBUTE_READONLY setWriteMode True m = m .&. complement Win32.fILE_ATTRIBUTE_READONLY -setFileMode :: FilePath -> Mode -> IO () +setFileMode :: OsPath -> Mode -> IO () setFileMode path mode = - (`ioeSetFileName` path) `modifyIOError` do + (`ioeSetOsPath` path) `modifyIOError` do path' <- furnishPath path Win32.setFileAttributes path' mode -- | A restricted form of 'setFileMode' that only sets the permission bits. -- For Windows, this means only the "read-only" attribute is affected. -setFilePermissions :: FilePath -> Mode -> IO () +setFilePermissions :: OsPath -> Mode -> IO () setFilePermissions path m = do m' <- modeFromMetadata <$> getFileMetadata path setFileMode path ((m' .&. complement Win32.fILE_ATTRIBUTE_READONLY) .|. (m .&. Win32.fILE_ATTRIBUTE_READONLY)) -getAccessPermissions :: FilePath -> IO Permissions +getAccessPermissions :: OsPath -> IO Permissions getAccessPermissions path = do m <- getFileMetadata path let isDir = fileTypeIsDirectory (fileTypeFromMetadata m) let w = hasWriteMode (modeFromMetadata m) - let x = (toLower <$> takeExtension path) + let x = (toLower . toChar <$> unpack (takeExtension path)) `elem` [".bat", ".cmd", ".com", ".exe"] pure Permissions { readable = True @@ -638,39 +656,57 @@ , searchable = isDir } -setAccessPermissions :: FilePath -> Permissions -> IO () +setAccessPermissions :: OsPath -> 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 +lookupEnvOs :: OsString -> IO (Maybe OsString) +lookupEnvOs (OsString name) = do + result <- + Win32.withTString name $ \ pName -> + peekTStringWith 256 $ \ pBuffer size -> + c_GetEnvironmentVariable pName pBuffer size + case result of + Left errCode | errCode == win32_eRROR_ENVVAR_NOT_FOUND -> pure Nothing + | otherwise -> Win32.failWith "GetEnvironmentVariable" errCode + Right value -> pure (Just (OsString value)) -getHomeDirectoryInternal :: IO FilePath +foreign import WINAPI unsafe "windows.h GetEnvironmentVariableW" + c_GetEnvironmentVariable + :: Win32.LPWSTR + -> Win32.LPWSTR + -> Win32.DWORD + -> IO Win32.DWORD + +getFolderPath :: Win32.CSIDL -> IO OsPath +getFolderPath what = OsString <$> Win32.sHGetFolderPath nullPtr what nullPtr 0 + +getHomeDirectoryInternal :: IO OsPath getHomeDirectoryInternal = getFolderPath Win32.cSIDL_PROFILE `catchIOError` \ _ -> getFolderPath Win32.cSIDL_WINDOWS -getXdgDirectoryFallback :: IO FilePath -> XdgDirectory -> IO FilePath +getXdgDirectoryFallback :: IO OsPath -> XdgDirectory -> IO OsPath getXdgDirectoryFallback _ xdgDir = do case xdgDir of XdgData -> getFolderPath Win32.cSIDL_APPDATA XdgConfig -> getFolderPath Win32.cSIDL_APPDATA - XdgCache -> getFolderPath win32_cSIDL_LOCAL_APPDATA - XdgState -> getFolderPath win32_cSIDL_LOCAL_APPDATA + XdgCache -> getFolderPath Win32.cSIDL_LOCAL_APPDATA + XdgState -> getFolderPath Win32.cSIDL_LOCAL_APPDATA -getXdgDirectoryListFallback :: XdgDirectoryList -> IO [FilePath] +getXdgDirectoryListFallback :: XdgDirectoryList -> IO [OsPath] getXdgDirectoryListFallback _ = pure <$> getFolderPath win32_cSIDL_COMMON_APPDATA -getAppUserDataDirectoryInternal :: FilePath -> IO FilePath +getAppUserDataDirectoryInternal :: OsPath -> IO OsPath getAppUserDataDirectoryInternal appName = - (\ appData -> appData <> ('\\' : appName)) + (\ appData -> appData <> (os "\\" <> appName)) <$> getXdgDirectoryFallback getHomeDirectoryInternal XdgData -getUserDocumentsDirectoryInternal :: IO FilePath +getUserDocumentsDirectoryInternal :: IO OsPath getUserDocumentsDirectoryInternal = getFolderPath Win32.cSIDL_PERSONAL -getTemporaryDirectoryInternal :: IO FilePath -getTemporaryDirectoryInternal = Win32.getTemporaryDirectory +getTemporaryDirectoryInternal :: IO OsPath +getTemporaryDirectoryInternal = OsString <$> Win32.getTemporaryDirectory #endif diff --git a/System/Directory/OsPath.hs b/System/Directory/OsPath.hs new file mode 100644 --- /dev/null +++ b/System/Directory/OsPath.hs @@ -0,0 +1,1652 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Directory.OsPath +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : portable +-- +-- System-independent interface to directory manipulation. +-- +-- @since 1.2.8.0 +-- +----------------------------------------------------------------------------- + +module System.Directory.OsPath + ( + -- $intro + + -- * Actions on directories + createDirectory + , createDirectoryIfMissing + , removeDirectory + , removeDirectoryRecursive + , removePathForcibly + , renameDirectory + , listDirectory + , getDirectoryContents + -- ** Current working directory + , getCurrentDirectory + , setCurrentDirectory + , withCurrentDirectory + + -- * Pre-defined directories + , getHomeDirectory + , XdgDirectory(..) + , getXdgDirectory + , XdgDirectoryList(..) + , getXdgDirectoryList + , getAppUserDataDirectory + , getUserDocumentsDirectory + , getTemporaryDirectory + + -- * Actions on files + , removeFile + , renameFile + , renamePath + , copyFile + , copyFileWithMetadata + , getFileSize + + , canonicalizePath + , makeAbsolute + , makeRelativeToCurrentDirectory + + -- * Existence tests + , doesPathExist + , doesFileExist + , doesDirectoryExist + + , findExecutable + , findExecutables + , findExecutablesInDirectories + , findFile + , findFiles + , findFileWith + , findFilesWith + , exeExtension + + -- * Symbolic links + , createFileLink + , createDirectoryLink + , removeDirectoryLink + , pathIsSymbolicLink + , getSymbolicLinkTarget + + -- * Permissions + + -- $permissions + + , Permissions + , emptyPermissions + , readable + , writable + , executable + , searchable + , setOwnerReadable + , setOwnerWritable + , setOwnerExecutable + , setOwnerSearchable + + , getPermissions + , setPermissions + , copyPermissions + + -- * Timestamps + + , getAccessTime + , getModificationTime + , setAccessTime + , setModificationTime + + ) where +import Prelude () +import System.Directory.Internal +import System.Directory.Internal.Prelude +import System.OsPath + ( (<.>) + , () + , addTrailingPathSeparator + , decodeFS + , dropTrailingPathSeparator + , encodeFS + , hasTrailingPathSeparator + , isAbsolute + , joinPath + , makeRelative + , splitDirectories + , splitSearchPath + , takeDirectory + ) +import Data.Time (UTCTime) +import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) + +{- $intro +A directory contains a series of entries, each of which is a named +reference to a file system object (file, directory etc.). Some +entries may be hidden, inaccessible, or have some administrative +function (e.g. @.@ or @..@ under +), but in +this standard all such entries are considered to form part of the +directory contents. Entries in sub-directories are not, however, +considered to form part of the directory contents. + +Each file system object is referenced by a /path/. There is +normally at least one absolute path to each file system object. In +some operating systems, it may also be possible to have paths which +are relative to the current directory. + +Unless otherwise documented: + +* 'IO' operations in this package may throw any 'IOError'. No other types of + exceptions shall be thrown. + +* The list of possible 'IOErrorType's in the API documentation is not + exhaustive. The full list may vary by platform and/or evolve over time. + +-} + +----------------------------------------------------------------------------- +-- Permissions + +{- $permissions + +directory offers a limited (and quirky) interface for reading and setting file +and directory permissions; see 'getPermissions' and 'setPermissions' for a +discussion of their limitations. Because permissions are very difficult to +implement portably across different platforms, users who wish to do more +sophisticated things with permissions are advised to use other, +platform-specific libraries instead. For example, if you are only interested +in permissions on POSIX-like platforms, + +offers much more flexibility. + + The 'Permissions' type is used to record whether certain operations are + permissible on a file\/directory. 'getPermissions' and 'setPermissions' + get and set these permissions, respectively. Permissions apply both to + files and directories. For directories, the executable field will be + 'False', and for files the searchable field will be 'False'. Note that + directories may be searchable without being readable, if permission has + been given to use them as part of a path, but not to examine the + directory contents. + +Note that to change some, but not all permissions, a construct on the following lines must be used. + +> makeReadable f = do +> p <- getPermissions f +> setPermissions f (p {readable = True}) + +-} + +emptyPermissions :: Permissions +emptyPermissions = Permissions { + readable = False, + writable = False, + executable = False, + searchable = False + } + +setOwnerReadable :: Bool -> Permissions -> Permissions +setOwnerReadable b p = p { readable = b } + +setOwnerWritable :: Bool -> Permissions -> Permissions +setOwnerWritable b p = p { writable = b } + +setOwnerExecutable :: Bool -> Permissions -> Permissions +setOwnerExecutable b p = p { executable = b } + +setOwnerSearchable :: Bool -> Permissions -> Permissions +setOwnerSearchable b p = p { searchable = b } + +-- | Get the permissions of a file or directory. +-- +-- On Windows, the 'writable' permission corresponds to the "read-only" +-- attribute. The 'executable' permission is set if the file extension is of +-- an executable file type. The 'readable' permission is always set. +-- +-- On POSIX systems, this returns the result of @access@. +-- +-- The operation may fail with: +-- +-- * 'isPermissionError' if the user is not permitted to access the +-- permissions, or +-- +-- * 'isDoesNotExistError' if the file or directory does not exist. +getPermissions :: OsPath -> IO Permissions +getPermissions path = + (`ioeAddLocation` "getPermissions") `modifyIOError` do + getAccessPermissions (emptyToCurDir path) + +-- | Set the permissions of a file or directory. +-- +-- On Windows, this is only capable of changing the 'writable' permission, +-- which corresponds to the "read-only" attribute. Changing the other +-- permissions has no effect. +-- +-- On POSIX systems, this sets the /owner/ permissions. +-- +-- The operation may fail with: +-- +-- * 'isPermissionError' if the user is not permitted to set the permissions, +-- or +-- +-- * 'isDoesNotExistError' if the file or directory does not exist. +setPermissions :: OsPath -> Permissions -> IO () +setPermissions path p = + (`ioeAddLocation` "setPermissions") `modifyIOError` do + setAccessPermissions (emptyToCurDir path) p + +-- | Copy the permissions of one file to another. This reproduces the +-- permissions more accurately than using 'getPermissions' followed by +-- 'setPermissions'. +-- +-- On Windows, this copies only the read-only attribute. +-- +-- On POSIX systems, this is equivalent to @stat@ followed by @chmod@. +copyPermissions :: OsPath -> OsPath -> IO () +copyPermissions src dst = + (`ioeAddLocation` "copyPermissions") `modifyIOError` do + m <- getFileMetadata src + copyPermissionsFromMetadata m dst + +copyPermissionsFromMetadata :: Metadata -> OsPath -> IO () +copyPermissionsFromMetadata m dst = do + -- instead of setFileMode, setFilePermissions is used here + -- this is to retain backward compatibility in copyPermissions + setFilePermissions dst (modeFromMetadata m) + +----------------------------------------------------------------------------- +-- Implementation + +{- |@'createDirectory' dir@ creates a new directory @dir@ which is +initially empty, or as near to empty as the operating system +allows. + +The operation may fail with: + +* 'isPermissionError' +The process has insufficient privileges to perform the operation. +@[EROFS, EACCES]@ + +* 'isAlreadyExistsError' +The operand refers to a directory that already exists. +@ [EEXIST]@ + +* @HardwareFault@ +A physical I\/O error has occurred. +@[EIO]@ + +* @InvalidArgument@ +The operand is not a valid directory name. +@[ENAMETOOLONG, ELOOP]@ + +* 'isDoesNotExistError' +There is no path to the directory. +@[ENOENT, ENOTDIR]@ + +* 'System.IO.isFullError' +Insufficient resources (virtual memory, process file descriptors, +physical disk space, etc.) are available to perform the operation. +@[EDQUOT, ENOSPC, ENOMEM, EMLINK]@ + +* @InappropriateType@ +The path refers to an existing non-directory object. +@[EEXIST]@ + +-} + +createDirectory :: OsPath -> IO () +createDirectory = createDirectoryInternal + +-- | @'createDirectoryIfMissing' parents dir@ creates a new directory +-- @dir@ if it doesn\'t exist. If the first argument is 'True' +-- the function will also create all parent directories if they are missing. +createDirectoryIfMissing :: Bool -- ^ Create its parents too? + -> OsPath -- ^ The path to the directory you want to make + -> IO () +createDirectoryIfMissing create_parents path0 + | create_parents = createDirs (parents path0) + | otherwise = createDirs (take 1 (parents path0)) + where + parents = reverse . scanl1 () . splitDirectories . simplify + + createDirs [] = pure () + createDirs (dir:[]) = createDir dir ioError + createDirs (dir:dirs) = + createDir dir $ \_ -> do + createDirs dirs + createDir dir ioError + + createDir dir notExistHandler = do + r <- tryIOError (createDirectory dir) + case r of + Right () -> pure () + Left e + | isDoesNotExistError e -> notExistHandler e + -- createDirectory (and indeed POSIX mkdir) does not distinguish + -- between a dir already existing and a file already existing. So we + -- check for it here. Unfortunately there is a slight race condition + -- here, but we think it is benign. It could report an exception in + -- the case that the dir did exist but another process deletes the + -- directory and creates a file in its place before we can check + -- that the directory did indeed exist. + -- We also follow this path when we get a permissions error, as + -- trying to create "." when in the root directory on Windows + -- fails with + -- CreateDirectory ".": permission denied (Access is denied.) + -- This caused GHCi to crash when loading a module in the root + -- directory. + | isAlreadyExistsError e + || isPermissionError e -> do + canIgnore <- pathIsDirectory dir + `catchIOError` \ _ -> + pure (isAlreadyExistsError e) + unless canIgnore (ioError e) + | otherwise -> ioError e + + +{- | @'removeDirectory' dir@ removes an existing directory /dir/. The +implementation may specify additional constraints which must be +satisfied before a directory can be removed (e.g. the directory has to +be empty, or may not be in use by other processes). It is not legal +for an implementation to partially remove a directory unless the +entire directory is removed. A conformant implementation need not +support directory removal in all situations (e.g. removal of the root +directory). + +The operation may fail with: + +* @HardwareFault@ +A physical I\/O error has occurred. +@[EIO]@ + +* @InvalidArgument@ +The operand is not a valid directory name. +@[ENAMETOOLONG, ELOOP]@ + +* 'isDoesNotExistError' +The directory does not exist. +@[ENOENT, ENOTDIR]@ + +* 'isPermissionError' +The process has insufficient privileges to perform the operation. +@[EROFS, EACCES, EPERM]@ + +* @UnsatisfiedConstraints@ +Implementation-dependent constraints are not satisfied. +@[EBUSY, ENOTEMPTY, EEXIST]@ + +* @UnsupportedOperation@ +The implementation does not support removal in this situation. +@[EINVAL]@ + +* @InappropriateType@ +The operand refers to an existing non-directory object. +@[ENOTDIR]@ + +-} + +removeDirectory :: OsPath -> IO () +removeDirectory = removePathInternal True + +-- | @'removeDirectoryRecursive' dir@ removes an existing directory /dir/ +-- together with its contents and subdirectories. Within this directory, +-- symbolic links are removed without affecting their targets. +-- +-- On Windows, the operation fails if /dir/ is a directory symbolic link. +-- +-- This operation is reported to be flaky on Windows so retry logic may +-- be advisable. See: https://github.com/haskell/directory/pull/108 +removeDirectoryRecursive :: OsPath -> IO () +removeDirectoryRecursive path = + (`ioeAddLocation` "removeDirectoryRecursive") `modifyIOError` do + m <- getSymbolicLinkMetadata path + case fileTypeFromMetadata m of + Directory -> + removeContentsRecursive path + DirectoryLink -> + ioError (err `ioeSetErrorString` "is a directory symbolic link") + _ -> + ioError (err `ioeSetErrorString` "not a directory") + where err = mkIOError InappropriateType "" Nothing Nothing `ioeSetOsPath` path + +-- | @removePathRecursive path@ removes an existing file or directory at +-- /path/ together with its contents and subdirectories. Symbolic links are +-- removed without affecting their the targets. +-- +-- This operation is reported to be flaky on Windows so retry logic may +-- be advisable. See: https://github.com/haskell/directory/pull/108 +removePathRecursive :: OsPath -> IO () +removePathRecursive path = + (`ioeAddLocation` "removePathRecursive") `modifyIOError` do + m <- getSymbolicLinkMetadata path + case fileTypeFromMetadata m of + Directory -> removeContentsRecursive path + DirectoryLink -> removeDirectory path + _ -> removeFile path + +-- | @removeContentsRecursive dir@ removes the contents of the directory +-- /dir/ recursively. Symbolic links are removed without affecting their the +-- targets. +-- +-- This operation is reported to be flaky on Windows so retry logic may +-- be advisable. See: https://github.com/haskell/directory/pull/108 +removeContentsRecursive :: OsPath -> IO () +removeContentsRecursive path = + (`ioeAddLocation` "removeContentsRecursive") `modifyIOError` do + cont <- listDirectory path + for_ [path x | x <- cont] removePathRecursive + removeDirectory path + +-- | Removes a file or directory at /path/ together with its contents and +-- subdirectories. Symbolic links are removed without affecting their +-- targets. If the path does not exist, nothing happens. +-- +-- Unlike other removal functions, this function will also attempt to delete +-- files marked as read-only or otherwise made unremovable due to permissions. +-- As a result, if the removal is incomplete, the permissions or attributes on +-- the remaining files may be altered. If there are hard links in the +-- directory, then permissions on all related hard links may be altered. +-- +-- If an entry within the directory vanishes while @removePathForcibly@ is +-- running, it is silently ignored. +-- +-- If an exception occurs while removing an entry, @removePathForcibly@ will +-- still try to remove as many entries as it can before failing with an +-- exception. The first exception that it encountered is re-thrown. +removePathForcibly :: OsPath -> IO () +removePathForcibly path = + (`ioeAddLocation` "removePathForcibly") `modifyIOError` do + ignoreDoesNotExistError $ do + m <- getSymbolicLinkMetadata path + case fileTypeFromMetadata m of + DirectoryLink -> do + makeRemovable path + removeDirectory path + Directory -> do + makeRemovable path + names <- listDirectory path + sequenceWithIOErrors_ $ + [ removePathForcibly (path name) | name <- names ] ++ + [ removeDirectory path ] + _ -> do + unless filesAlwaysRemovable (makeRemovable path) + removeFile path + where + + ignoreDoesNotExistError :: IO () -> IO () + ignoreDoesNotExistError action = + () <$ tryIOErrorType isDoesNotExistError action + + makeRemovable :: OsPath -> IO () + makeRemovable p = (`catchIOError` \ _ -> pure ()) $ do + perms <- getPermissions p + setPermissions path perms{ readable = True + , searchable = True + , writable = True } + +{- |'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 +satisfied before a file can be removed (e.g. the file may not be in +use by other processes). + +The operation may fail with: + +* @HardwareFault@ +A physical I\/O error has occurred. +@[EIO]@ + +* @InvalidArgument@ +The operand is not a valid file name. +@[ENAMETOOLONG, ELOOP]@ + +* 'isDoesNotExistError' +The file does not exist. +@[ENOENT, ENOTDIR]@ + +* 'isPermissionError' +The process has insufficient privileges to perform the operation. +@[EROFS, EACCES, EPERM]@ + +* @UnsatisfiedConstraints@ +Implementation-dependent constraints are not satisfied. +@[EBUSY]@ + +* @InappropriateType@ +The operand refers to an existing directory. +@[EPERM, EINVAL]@ + +-} + +removeFile :: OsPath -> IO () +removeFile = removePathInternal False + +{- |@'renameDirectory' old new@ changes the name of an existing +directory from /old/ to /new/. If the /new/ directory +already exists, it is atomically replaced by the /old/ directory. +If the /new/ directory is neither the /old/ directory nor an +alias of the /old/ directory, it is removed as if by +'removeDirectory'. A conformant implementation need not support +renaming directories in all situations (e.g. renaming to an existing +directory, or across different physical devices), but the constraints +must be documented. + +On Win32 platforms, @renameDirectory@ fails if the /new/ directory already +exists. + +The operation may fail with: + +* @HardwareFault@ +A physical I\/O error has occurred. +@[EIO]@ + +* @InvalidArgument@ +Either operand is not a valid directory name. +@[ENAMETOOLONG, ELOOP]@ + +* 'isDoesNotExistError' +The original directory does not exist, or there is no path to the target. +@[ENOENT, ENOTDIR]@ + +* 'isPermissionError' +The process has insufficient privileges to perform the operation. +@[EROFS, EACCES, EPERM]@ + +* 'System.IO.isFullError' +Insufficient resources are available to perform the operation. +@[EDQUOT, ENOSPC, ENOMEM, EMLINK]@ + +* @UnsatisfiedConstraints@ +Implementation-dependent constraints are not satisfied. +@[EBUSY, ENOTEMPTY, EEXIST]@ + +* @UnsupportedOperation@ +The implementation does not support renaming in this situation. +@[EINVAL, EXDEV]@ + +* @InappropriateType@ +Either path refers to an existing non-directory object. +@[ENOTDIR, EISDIR]@ + +-} + +renameDirectory :: OsPath -> OsPath -> IO () +renameDirectory opath npath = + (`ioeAddLocation` "renameDirectory") `modifyIOError` do + -- XXX this test isn't performed atomically with the following rename + isDir <- pathIsDirectory opath + when (not isDir) . ioError $ + mkIOError InappropriateType "renameDirectory" Nothing Nothing + `ioeSetErrorString` "not a directory" + `ioeSetOsPath` opath + renamePath opath npath + +{- |@'renameFile' old new@ changes the name of an existing file system +object from /old/ to /new/. If the /new/ object already exists, it is +replaced by the /old/ object. Neither path may refer to an existing +directory. A conformant implementation need not support renaming files +in all situations (e.g. renaming across different physical devices), but +the constraints must be documented. + +On Windows, this calls @MoveFileEx@ with @MOVEFILE_REPLACE_EXISTING@ set, +which is not guaranteed to be atomic +(). + +On other platforms, this operation is atomic. + +The operation may fail with: + +* @HardwareFault@ +A physical I\/O error has occurred. +@[EIO]@ + +* @InvalidArgument@ +Either operand is not a valid file name. +@[ENAMETOOLONG, ELOOP]@ + +* 'isDoesNotExistError' +The original file does not exist, or there is no path to the target. +@[ENOENT, ENOTDIR]@ + +* 'isPermissionError' +The process has insufficient privileges to perform the operation. +@[EROFS, EACCES, EPERM]@ + +* 'System.IO.isFullError' +Insufficient resources are available to perform the operation. +@[EDQUOT, ENOSPC, ENOMEM, EMLINK]@ + +* @UnsatisfiedConstraints@ +Implementation-dependent constraints are not satisfied. +@[EBUSY]@ + +* @UnsupportedOperation@ +The implementation does not support renaming in this situation. +@[EXDEV]@ + +* @InappropriateType@ +Either path refers to an existing directory. +@[ENOTDIR, EISDIR, EINVAL, EEXIST, ENOTEMPTY]@ + +-} + +renameFile :: OsPath -> OsPath -> 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 fileTypeIsDirectory . fileTypeFromMetadata <$> m of + Right True -> + ioError $ + mkIOError InappropriateType "" Nothing Nothing + `ioeSetErrorString` "is a directory" + `ioeSetOsPath` 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 +-- directory. A conformant implementation need not support renaming files in +-- all situations (e.g. renaming across different physical devices), but the +-- constraints must be documented. +-- +-- The operation may fail with: +-- +-- * @HardwareFault@ +-- A physical I\/O error has occurred. +-- @[EIO]@ +-- +-- * @InvalidArgument@ +-- Either operand is not a valid file name. +-- @[ENAMETOOLONG, ELOOP]@ +-- +-- * 'isDoesNotExistError' +-- The original file does not exist, or there is no path to the target. +-- @[ENOENT, ENOTDIR]@ +-- +-- * 'isPermissionError' +-- The process has insufficient privileges to perform the operation. +-- @[EROFS, EACCES, EPERM]@ +-- +-- * 'System.IO.isFullError' +-- Insufficient resources are available to perform the operation. +-- @[EDQUOT, ENOSPC, ENOMEM, EMLINK]@ +-- +-- * @UnsatisfiedConstraints@ +-- Implementation-dependent constraints are not satisfied. +-- @[EBUSY]@ +-- +-- * @UnsupportedOperation@ +-- The implementation does not support renaming in this situation. +-- @[EXDEV]@ +-- +-- * @InappropriateType@ +-- Either the destination path refers to an existing directory, or one of the +-- parent segments in the destination path is not a directory. +-- @[ENOTDIR, EISDIR, EINVAL, EEXIST, ENOTEMPTY]@ +renamePath :: OsPath -- ^ Old path + -> OsPath -- ^ New path + -> IO () +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 +-- directory. No exceptions are thrown if the permissions could not be +-- copied. +copyFile :: OsPath -- ^ Source filename + -> OsPath -- ^ Destination filename + -> IO () +copyFile fromFPath toFPath = + (`ioeAddLocation` "copyFile") `modifyIOError` do + atomicCopyFileContents fromFPath toFPath + (ignoreIOExceptions . copyPermissions fromFPath) + +-- | Copy all data from a file to a handle. +copyFileToHandle :: OsPath -- ^ Source file + -> Handle -- ^ Destination handle + -> IO () +copyFileToHandle fromFPath hTo = + (`ioeAddLocation` "copyFileToHandle") `modifyIOError` do + withBinaryHandle (openFileForRead fromFPath) $ \ hFrom -> + copyHandleData hFrom hTo + +-- | 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. +atomicCopyFileContents :: OsPath -- ^ Source filename + -> OsPath -- ^ Destination filename + -> (OsPath -> IO ()) -- ^ Post-action + -> IO () +atomicCopyFileContents fromFPath toFPath postAction = + (`ioeAddLocation` "atomicCopyFileContents") `modifyIOError` do + withReplacementFile toFPath postAction $ \ hTo -> do + copyFileToHandle fromFPath hTo + +-- | A helper function useful for replacing files in an atomic manner. The +-- function creates a temporary file in the directory of the destination file, +-- opens it, performs the main action with its handle, closes it, performs the +-- post-action with its path, and finally replaces the destination file with +-- the temporary file. If an error occurs during any step of this process, +-- the temporary file is removed and the destination file remains untouched. +withReplacementFile :: OsPath -- ^ Destination file + -> (OsPath -> IO ()) -- ^ Post-action + -> (Handle -> IO a) -- ^ Main action + -> IO a +withReplacementFile path postAction action = + (`ioeAddLocation` "withReplacementFile") `modifyIOError` do + mask $ \ restore -> do + -- TODO: AFPP doesn't support openBinaryTempFile yet, + -- so we have to use this (sad) workaround + -- (on unix, converts using filesystem encoding, on windows + -- converts with UTF-16LE) + d <- decodeFS (takeDirectory path) + (tmpFPath', hTmp) <- openBinaryTempFile d ".copyFile.tmp" + tmpFPath <- encodeFS tmpFPath' + (`onException` ignoreIOExceptions (removeFile tmpFPath)) $ do + r <- (`onException` ignoreIOExceptions (hClose hTmp)) $ do + restore (action hTmp) + hClose hTmp + restore (postAction tmpFPath) + renameFile tmpFPath path + 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 +-- the replacement of the destination file. Neither path may refer to an +-- existing directory. If the source and/or destination are symbolic links, +-- the copy is performed on the targets of the links. +-- +-- On Windows, it behaves like the Win32 function +-- , +-- which copies various kinds of metadata including file attributes and +-- security resource properties. +-- +-- On Unix-like systems, permissions, access time, and modification time are +-- preserved. If possible, the owner and group are also preserved. Note that +-- the very act of copying can change the access time of the source file, +-- hence the access times of the two files may differ after the operation +-- completes. +copyFileWithMetadata :: OsPath -- ^ Source file + -> OsPath -- ^ Destination file + -> IO () +copyFileWithMetadata src dst = + (`ioeAddLocation` "copyFileWithMetadata") `modifyIOError` + copyFileWithMetadataInternal copyPermissionsFromMetadata + copyTimesFromMetadata + src + dst + +copyTimesFromMetadata :: Metadata -> OsPath -> IO () +copyTimesFromMetadata st dst = do + let atime = accessTimeFromMetadata st + let mtime = modificationTimeFromMetadata st + setFileTimes dst (Just atime, Just mtime) + +-- | Make a path absolute, normalize the path, and remove as many indirections +-- from it as possible. Any trailing path separators are discarded via +-- 'dropTrailingPathSeparator'. Additionally, on Windows the letter case of +-- the path is canonicalized. +-- +-- __Note__: This function is a very big hammer. If you only need an absolute +-- path, 'makeAbsolute' is sufficient for removing dependence on the current +-- working directory. +-- +-- Indirections include the two special directories @.@ and @..@, as well as +-- any symbolic links (and junction points on Windows). The input path need +-- not point to an existing file or directory. Canonicalization is performed +-- on the longest prefix of the path that points to an existing file or +-- directory. The remaining portion of the path that does not point to an +-- existing file or directory will still be normalized, but case +-- canonicalization and indirection removal are skipped as they are impossible +-- to do on a nonexistent path. +-- +-- Most programs should not worry about the canonicity of a path. In +-- particular, despite the name, the function does not truly guarantee +-- canonicity of the returned path due to the presence of hard links, mount +-- points, etc. +-- +-- If the path points to an existing file or directory, then the output path +-- shall also point to the same file or directory, subject to the condition +-- that the relevant parts of the file system do not change while the function +-- is still running. In other words, the function is definitively not atomic. +-- The results can be utterly wrong if the portions of the path change while +-- this function is running. +-- +-- Since some indirections (symbolic links on all systems, @..@ on non-Windows +-- systems, and junction points on Windows) are dependent on the state of the +-- existing filesystem, the function can only make a conservative attempt by +-- removing such indirections from the longest prefix of the path that still +-- points to an existing file or directory. +-- +-- Note that on Windows parent directories @..@ are always fully expanded +-- before the symbolic links, as consistent with the rest of the Windows API +-- (such as @GetFullPathName@). In contrast, on POSIX systems parent +-- directories @..@ are expanded alongside symbolic links from left to right. +-- To put this more concretely: if @L@ is a symbolic link for @R/P@, then on +-- Windows @L\\..@ refers to @.@, whereas on other operating systems @L/..@ +-- refers to @R@. +-- +-- Similar to 'System.FilePath.normalise', passing an empty path is equivalent +-- to passing the current directory. +-- +-- @canonicalizePath@ can resolve at least 64 indirections in a single path, +-- more than what is supported by most operating systems. Therefore, it may +-- return the fully resolved path even though the operating system itself +-- would have long given up. +-- +-- On Windows XP or earlier systems, junction expansion is not performed due +-- to their lack of @GetFinalPathNameByHandle@. +-- +-- /Changes since 1.2.3.0:/ The function has been altered to be more robust +-- and has the same exception behavior as 'makeAbsolute'. +-- +-- /Changes since 1.3.0.0:/ The function no longer preserves the trailing path +-- separator. File symbolic links that appear in the middle of a path are +-- properly dereferenced. Case canonicalization and symbolic link expansion +-- are now performed on Windows. +-- +canonicalizePath :: OsPath -> IO OsPath +canonicalizePath = \ path -> + ((`ioeAddLocation` "canonicalizePath") . + (`ioeSetOsPath` path)) `modifyIOError` do + -- simplify does more stuff, like upper-casing the drive letter + dropTrailingPathSeparator . simplify <$> + (canonicalizePathWith attemptRealpath =<< prependCurrentDirectory path) + where + + -- allow up to 64 cycles before giving up + attemptRealpath realpath = + 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 + -- any arbitrarily clever algorithm + attemptRealpathWith n mFallback realpath path = + case mFallback of + -- too many indirections ... giving up. + Just fallback | n <= 0 -> pure fallback + -- either mFallback == Nothing (first attempt) + -- or n > 0 (still have some attempts left) + _ -> realpathPrefix (reverse (zip prefixes suffixes)) + + where + + segments = splitDirectories path + prefixes = scanl1 () segments + suffixes = tail (scanr () mempty segments) + + -- try to call realpath on the largest possible prefix + realpathPrefix candidates = + case candidates of + [] -> pure path + (prefix, suffix) : rest -> do + exist <- doesPathExist prefix + if not exist + -- never call realpath on an inaccessible path + -- (to avoid bugs in system realpath implementations) + -- try a smaller prefix instead + then realpathPrefix rest + else do + mp <- tryIOError (realpath prefix) + case mp of + -- realpath failed: try a smaller prefix instead + Left _ -> realpathPrefix rest + -- realpath succeeded: fine-tune the result + Right p -> realpathFurther (p suffix) p suffix + + -- by now we have a reasonable fallback value that we can use if we + -- run into too many indirections; the fallback value is the same + -- result that we have been returning in versions prior to 1.3.1.0 + -- (this is essentially the fix to #64) + realpathFurther fallback p suffix = + case splitDirectories suffix of + [] -> pure fallback + next : restSuffix -> do + -- see if the 'next' segment is a symlink + mTarget <- tryIOError (getSymbolicLinkTarget (p next)) + case mTarget of + Left _ -> pure fallback + Right target -> do + -- if so, dereference it and restart the whole cycle + let mFallback' = Just (fromMaybe fallback mFallback) + 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 +-- current directory is prepended and then the combined result is normalized. +-- If the path is already absolute, the path is simply normalized. The +-- function preserves the presence or absence of the trailing path separator +-- unless the path refers to the root directory @/@. +-- +-- If the path is already absolute, the operation never fails. Otherwise, the +-- operation may fail with the same exceptions as 'getCurrentDirectory'. +-- +makeAbsolute :: OsPath -> IO OsPath +makeAbsolute path = + ((`ioeAddLocation` "makeAbsolute") . + (`ioeSetOsPath` path)) `modifyIOError` do + matchTrailingSeparator path . simplify <$> prependCurrentDirectory path + +-- | Add or remove the trailing path separator in the second path so as to +-- match its presence in the first path. +-- +-- (internal API) +matchTrailingSeparator :: OsPath -> OsPath -> OsPath +matchTrailingSeparator path + | hasTrailingPathSeparator path = addTrailingPathSeparator + | otherwise = dropTrailingPathSeparator + +-- | Construct a path relative to the current directory, similar to +-- 'makeRelative'. +-- +-- The operation may fail with the same exceptions as 'getCurrentDirectory'. +makeRelativeToCurrentDirectory :: OsPath -> IO OsPath +makeRelativeToCurrentDirectory x = do + (`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 +-- includes @PATH@ and possibly more. The full path to the executable is +-- returned if found. For example, @(findExecutable \"ghc\")@ would normally +-- give you the path to GHC. +-- +-- The path returned by @'findExecutable' name@ corresponds to the program +-- that would be executed by +-- @@ +-- when passed the same string (as a @RawCommand@, not a @ShellCommand@), +-- provided that @name@ is not a relative path with more than one segment. +-- +-- On Windows, 'findExecutable' calls the Win32 function +-- @@, +-- which may search other places before checking the directories in the @PATH@ +-- environment variable. Where it actually searches depends on registry +-- settings, but notably includes the directory containing the current +-- executable. +-- +-- On non-Windows platforms, the behavior is equivalent to 'findFileWith' +-- using the search directories from the @PATH@ environment variable and +-- testing each file for executable permissions. Details can be found in the +-- documentation of 'findFileWith'. +findExecutable :: OsString -> IO (Maybe OsPath) +findExecutable binary = + listTHead + (findExecutablesLazyInternal findExecutablesInDirectoriesLazy binary) + +-- | Search for executable files in a list of system-defined locations, which +-- generally includes @PATH@ and possibly more. +-- +-- On Windows, this /only returns the first occurrence/, if any. Its behavior +-- is therefore equivalent to 'findExecutable'. +-- +-- On non-Windows platforms, the behavior is equivalent to +-- 'findExecutablesInDirectories' using the search directories from the @PATH@ +-- environment variable. Details can be found in the documentation of +-- 'findExecutablesInDirectories'. +findExecutables :: OsString -> IO [OsPath] +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 +-- directories and returns all occurrences. +-- +-- The behavior is equivalent to 'findFileWith' using the given search +-- directories and testing each file for executable permissions. Details can +-- be found in the documentation of 'findFileWith'. +-- +-- Unlike other similarly named functions, 'findExecutablesInDirectories' does +-- not use @SearchPath@ from the Win32 API. The behavior of this function on +-- Windows is therefore equivalent to those on non-Windows platforms. +findExecutablesInDirectories :: [OsPath] -> OsString -> IO [OsPath] +findExecutablesInDirectories path binary = + listTToList (findExecutablesInDirectoriesLazy path binary) + +findExecutablesInDirectoriesLazy :: [OsPath] -> OsString -> ListT IO OsPath +findExecutablesInDirectoriesLazy path binary = + findFilesWithLazy isExecutable path (binary <.> exeExtension) + +-- | Test whether a file has executable permissions. +isExecutable :: OsPath -> IO Bool +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 :: [OsPath] -> OsString -> IO (Maybe OsPath) +findFile = findFileWith (\ _ -> pure True) + +-- | Search through the given list of directories for the given file and +-- returns all paths where the given file exists. +-- +-- The behavior is equivalent to 'findFilesWith'. Details can be found in the +-- documentation of 'findFilesWith'. +findFiles :: [OsPath] -> OsString -> IO [OsPath] +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 +-- occurrence. The directories are checked in a left-to-right order. +-- +-- This is essentially a more performant version of 'findFilesWith' that +-- always returns the first result, if any. Details can be found in the +-- documentation of 'findFilesWith'. +findFileWith :: (OsPath -> IO Bool) -> [OsPath] -> OsString -> IO (Maybe OsPath) +findFileWith f ds name = listTHead (findFilesWithLazy f ds name) + +-- | @findFilesWith predicate dirs name@ searches through the list of +-- directories (@dirs@) for files that have the given @name@ and satisfy the +-- given @predicate@ and returns the paths of those files. The directories +-- are checked in a left-to-right order and the paths are returned in the same +-- order. +-- +-- If the @name@ is a relative path, then for every search directory @dir@, +-- the function checks whether @dir '' name@ exists and satisfies the +-- predicate. If so, @dir '' name@ is returned as one of the results. In +-- other words, the returned paths can be either relative or absolute +-- depending on the search directories were used. If there are no search +-- directories, no results are ever returned. +-- +-- If the @name@ is an absolute path, then the function will return a single +-- result if the file exists and satisfies the predicate and no results +-- otherwise. This is irrespective of what search directories were given. +findFilesWith :: (OsPath -> IO Bool) -> [OsPath] -> OsString -> IO [OsPath] +findFilesWith f ds name = listTToList (findFilesWithLazy f ds name) + +findFilesWithLazy + :: (OsPath -> IO Bool) -> [OsPath] -> OsString -> ListT IO OsPath +findFilesWithLazy f dirs path + -- make sure absolute paths are handled properly irrespective of 'dirs' + -- https://github.com/haskell/directory/issues/72 + | isAbsolute path = ListT (find [mempty]) + | otherwise = ListT (find dirs) + + where + + find [] = pure Nothing + find (d : ds) = do + let p = d path + found <- doesFileExist p `andM` f p + if found + then pure (Just (p, ListT (find ds))) + else find ds + +-- | Filename extension for executable files (including the dot if any) +-- (usually @\"\"@ on POSIX systems and @\".exe\"@ on Windows or OS\/2). +exeExtension :: OsString +exeExtension = exeExtensionInternal + +-- | Similar to 'listDirectory', but always includes the special entries (@.@ +-- and @..@). (This applies to Windows as well.) +-- +-- The operation may fail with the same exceptions as 'listDirectory'. +getDirectoryContents :: OsPath -> IO [OsPath] +getDirectoryContents path = + ((`ioeSetOsPath` path) . + (`ioeAddLocation` "getDirectoryContents")) `modifyIOError` do + getDirectoryContentsInternal path + +-- | @'listDirectory' dir@ returns a list of /all/ entries in /dir/ without +-- the special entries (@.@ and @..@). +-- +-- The operation may fail with: +-- +-- * @HardwareFault@ +-- A physical I\/O error has occurred. +-- @[EIO]@ +-- +-- * @InvalidArgument@ +-- The operand is not a valid directory name. +-- @[ENAMETOOLONG, ELOOP]@ +-- +-- * 'isDoesNotExistError' +-- The directory does not exist. +-- @[ENOENT, ENOTDIR]@ +-- +-- * 'isPermissionError' +-- The process has insufficient privileges to perform the operation. +-- @[EACCES]@ +-- +-- * 'System.IO.isFullError' +-- Insufficient resources are available to perform the operation. +-- @[EMFILE, ENFILE]@ +-- +-- * @InappropriateType@ +-- The path refers to an existing non-directory object. +-- @[ENOTDIR]@ +-- +listDirectory :: OsPath -> IO [OsPath] +listDirectory path = filter f <$> getDirectoryContents path + where f filename = filename /= os "." && filename /= os ".." + +-- | 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'). +-- +-- Note that 'getCurrentDirectory' is not guaranteed to return the same path +-- received by 'setCurrentDirectory'. On POSIX systems, the path returned will +-- always be fully dereferenced (not contain any symbolic links). For more +-- information, refer to the documentation of +-- . +-- +-- The operation may fail with: +-- +-- * @HardwareFault@ +-- A physical I\/O error has occurred. +-- @[EIO]@ +-- +-- * 'isDoesNotExistError' +-- There is no path referring to the working directory. +-- @[EPERM, ENOENT, ESTALE...]@ +-- +-- * 'isPermissionError' +-- The process has insufficient privileges to perform the operation. +-- @[EACCES]@ +-- +-- * 'System.IO.isFullError' +-- Insufficient resources are available to perform the operation. +-- +-- * @UnsupportedOperation@ +-- The operating system has no notion of current working directory. +-- +getCurrentDirectory :: IO OsPath +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 +-- 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]@ +-- +-- * @InvalidArgument@ +-- The operand is not a valid directory name. +-- @[ENAMETOOLONG, ELOOP]@ +-- +-- * 'isDoesNotExistError' +-- The directory does not exist. +-- @[ENOENT, ENOTDIR]@ +-- +-- * 'isPermissionError' +-- The process has insufficient privileges to perform the operation. +-- @[EACCES]@ +-- +-- * @UnsupportedOperation@ +-- The operating system has no notion of current working directory, or the +-- working directory cannot be dynamically changed. +-- +-- * @InappropriateType@ +-- The path refers to an existing non-directory object. +-- @[ENOTDIR]@ +-- +setCurrentDirectory :: OsPath -> IO () +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 +-- to an exception. +-- +-- The operation may fail with the same exceptions as 'getCurrentDirectory' +-- and 'setCurrentDirectory'. +-- +withCurrentDirectory :: OsPath -- ^ Directory to execute in + -> IO a -- ^ Action to be executed + -> IO a +withCurrentDirectory dir action = + bracket getCurrentDirectory setCurrentDirectory $ \ _ -> do + setCurrentDirectory dir + action + +-- | Obtain the size of a file in bytes. +getFileSize :: OsPath -> IO Integer +getFileSize path = + (`ioeAddLocation` "getFileSize") `modifyIOError` do + fileSizeFromMetadata <$> getFileMetadata path + +-- | Test whether the given path points to an existing filesystem object. If +-- the user lacks necessary permissions to search the parent directories, this +-- function may return false even if the file does actually exist. This +-- operation traverses symbolic links, so it can return either True or False +-- for them. +doesPathExist :: OsPath -> IO Bool +doesPathExist path = do + (True <$ getFileMetadata path) + `catchIOError` \ _ -> + pure False + +-- | The operation 'doesDirectoryExist' returns 'True' if the argument file +-- exists and is either a directory or a symbolic link to a directory, and +-- 'False' otherwise. This operation traverses symbolic links, so it can +-- return either True or False for them. +doesDirectoryExist :: OsPath -> IO Bool +doesDirectoryExist path = do + pathIsDirectory path + `catchIOError` \ _ -> + pure False + +-- | The operation 'doesFileExist' returns 'True' if the argument file exists +-- and is not a directory, and 'False' otherwise. This operation traverses +-- symbolic links, so it can return either True or False for them. +doesFileExist :: OsPath -> IO Bool +doesFileExist path = do + (not <$> pathIsDirectory path) + `catchIOError` \ _ -> + pure False + +pathIsDirectory :: OsPath -> IO Bool +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 +-- follows the POSIX convention. +-- +-- To remove an existing file symbolic link, use 'removeFile'. +-- +-- Although the distinction between /file/ symbolic links and /directory/ +-- symbolic links does not exist on POSIX systems, on Windows this is an +-- intrinsic property of every symbolic link and cannot be changed without +-- recreating the link. A file symbolic link that actually points to a +-- directory will fail to dereference and vice versa. Moreover, creating +-- symbolic links on Windows 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@. 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 +-- fail with 'illegalOperationErrorType' if the file system does not support +-- symbolic links. +createFileLink + :: OsPath -- ^ path to the target file + -> OsPath -- ^ path of the link to be created + -> IO () +createFileLink target link = + (`ioeAddLocation` "createFileLink") `modifyIOError` do + createSymbolicLink False target link + +-- | Create a /directory/ symbolic link. The target path can be either +-- absolute or relative and need not refer to an existing directory. The +-- order of arguments follows the POSIX convention. +-- +-- To remove an existing directory symbolic link, use 'removeDirectoryLink'. +-- +-- Although the distinction between /file/ symbolic links and /directory/ +-- symbolic links does not exist on POSIX systems, on Windows this is an +-- intrinsic property of every symbolic link and cannot be changed without +-- recreating the link. A file symbolic link that actually points to a +-- directory will fail to dereference and vice versa. Moreover, creating +-- symbolic links on Windows 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 +-- @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 +-- fail with 'illegalOperationErrorType' if the file system does not support +-- symbolic links. +createDirectoryLink + :: OsPath -- ^ path to the target directory + -> OsPath -- ^ path of the link to be created + -> IO () +createDirectoryLink target link = + (`ioeAddLocation` "createDirectoryLink") `modifyIOError` do + createSymbolicLink True target link + +-- | Remove an existing /directory/ symbolic link. +-- +-- On Windows, this is an alias for 'removeDirectory'. On POSIX systems, this +-- is an alias for 'removeFile'. +-- +-- See also: 'removeFile', which can remove an existing /file/ symbolic link. +removeDirectoryLink :: OsPath -> IO () +removeDirectoryLink path = + (`ioeAddLocation` "removeDirectoryLink") `modifyIOError` do + removePathInternal linkToDirectoryIsDirectory path + +-- | Check whether an existing @path@ is a symbolic link. If @path@ is a +-- regular file or directory, 'False' is returned. If @path@ does not exist +-- or is otherwise inaccessible, an exception is thrown (see below). +-- +-- On Windows, this checks for @FILE_ATTRIBUTE_REPARSE_POINT@. In addition to +-- symbolic links, the function also returns true on junction points. On +-- POSIX systems, this checks for @S_IFLNK@. +-- +-- The operation may fail with: +-- +-- * 'isDoesNotExistError' if the symbolic link does not exist; or +-- +-- * 'isPermissionError' if the user is not permitted to read the symbolic +-- link. +pathIsSymbolicLink :: OsPath -> IO Bool +pathIsSymbolicLink path = + ((`ioeAddLocation` "pathIsSymbolicLink") . + (`ioeSetOsPath` path)) `modifyIOError` do + fileTypeIsLink . fileTypeFromMetadata <$> getSymbolicLinkMetadata path + +-- | Retrieve the target path of either a file or directory symbolic link. +-- The returned path may not be absolute, may not exist, and may not even be a +-- valid path. +-- +-- On Windows systems, this calls @DeviceIoControl@ with +-- @FSCTL_GET_REPARSE_POINT@. In addition to symbolic links, the function +-- also works on junction points. On POSIX systems, this calls @readlink@. +-- +-- Windows-specific errors: This operation may fail with +-- 'illegalOperationErrorType' if the file system does not support symbolic +-- links. +getSymbolicLinkTarget :: OsPath -> IO OsPath +getSymbolicLinkTarget path = + (`ioeAddLocation` "getSymbolicLinkTarget") `modifyIOError` do + readSymbolicLink path + +-- | Obtain the time at which the file or directory was last accessed. +-- +-- The operation may fail with: +-- +-- * 'isPermissionError' if the user is not permitted to read +-- the access time; or +-- +-- * 'isDoesNotExistError' if the file or directory does not exist. +-- +-- Caveat for POSIX systems: This function returns a timestamp with sub-second +-- resolution only if this package is compiled against @unix-2.6.0.0@ or later +-- and the underlying filesystem supports them. +-- +getAccessTime :: OsPath -> IO UTCTime +getAccessTime path = + (`ioeAddLocation` "getAccessTime") `modifyIOError` do + accessTimeFromMetadata <$> getFileMetadata (emptyToCurDir path) + +-- | Obtain the time at which the file or directory was last modified. +-- +-- The operation may fail with: +-- +-- * 'isPermissionError' if the user is not permitted to read +-- the modification time; or +-- +-- * 'isDoesNotExistError' if the file or directory does not exist. +-- +-- Caveat for POSIX systems: This function returns a timestamp with sub-second +-- resolution only if this package is compiled against @unix-2.6.0.0@ or later +-- and the underlying filesystem supports them. +-- +getModificationTime :: OsPath -> IO UTCTime +getModificationTime path = + (`ioeAddLocation` "getModificationTime") `modifyIOError` do + modificationTimeFromMetadata <$> getFileMetadata (emptyToCurDir path) + +-- | Change the time at which the file or directory was last accessed. +-- +-- The operation may fail with: +-- +-- * 'isPermissionError' if the user is not permitted to alter the +-- access time; or +-- +-- * 'isDoesNotExistError' if the file or directory does not exist. +-- +-- Some caveats for POSIX systems: +-- +-- * Not all systems support @utimensat@, in which case the function can only +-- emulate the behavior by reading the modification time and then setting +-- both the access and modification times together. On systems where +-- @utimensat@ is supported, the access time is set atomically with +-- nanosecond precision. +-- +-- * If compiled against a version of @unix@ prior to @2.7.0.0@, the function +-- would not be able to set timestamps with sub-second resolution. In this +-- case, there would also be loss of precision in the modification time. +-- +setAccessTime :: OsPath -> UTCTime -> IO () +setAccessTime path atime = + (`ioeAddLocation` "setAccessTime") `modifyIOError` do + setFileTimes path (Just atime, Nothing) + +-- | Change the time at which the file or directory was last modified. +-- +-- The operation may fail with: +-- +-- * 'isPermissionError' if the user is not permitted to alter the +-- modification time; or +-- +-- * 'isDoesNotExistError' if the file or directory does not exist. +-- +-- Some caveats for POSIX systems: +-- +-- * Not all systems support @utimensat@, in which case the function can only +-- emulate the behavior by reading the access time and then setting both the +-- access and modification times together. On systems where @utimensat@ is +-- supported, the modification time is set atomically with nanosecond +-- precision. +-- +-- * If compiled against a version of @unix@ prior to @2.7.0.0@, the function +-- would not be able to set timestamps with sub-second resolution. In this +-- case, there would also be loss of precision in the access time. +-- +setModificationTime :: OsPath -> UTCTime -> IO () +setModificationTime path mtime = + (`ioeAddLocation` "setModificationTime") `modifyIOError` do + setFileTimes path (Nothing, Just mtime) + +setFileTimes :: OsPath -> (Maybe UTCTime, Maybe UTCTime) -> IO () +setFileTimes _ (Nothing, Nothing) = return () +setFileTimes path (atime, mtime) = + ((`ioeAddLocation` "setFileTimes") . + (`ioeSetOsPath` path)) `modifyIOError` do + setTimes (emptyToCurDir path) + (utcTimeToPOSIXSeconds <$> atime, utcTimeToPOSIXSeconds <$> mtime) + +{- | Returns the current user's home directory. + +The directory returned is expected to be writable by the current user, +but note that it isn't generally considered good practice to store +application-specific data here; use 'getXdgDirectory' or +'getAppUserDataDirectory' instead. + +On Unix, 'getHomeDirectory' behaves as follows: + +* Returns $HOME env variable if set (including to an empty string). +* Otherwise uses home directory returned by `getpwuid_r` using the UID of the current proccesses user. This basically reads the /etc/passwd file. An empty home directory field is considered valid. + +On Windows, the system is queried for a suitable path; a typical path might be @C:\/Users\//\/@. + +The operation may fail with: + +* @UnsupportedOperation@ +The operating system has no notion of home directory. + +* 'isDoesNotExistError' +The home directory for the current user does not exist, or +cannot be found. +-} +getHomeDirectory :: IO OsPath +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 +-- . +-- Compared with 'getAppUserDataDirectory', this function provides a more +-- fine-grained hierarchy as well as greater flexibility for the user. +-- +-- On Windows, 'XdgData' and 'XdgConfig' usually map to the same directory +-- unless overridden. +-- +-- Refer to the docs of 'XdgDirectory' for more details. +-- +-- The second argument is usually the name of the application. Since it +-- will be integrated into the path, it must consist of valid path +-- characters. Note: if the second argument is an absolute path, it will +-- just return the second argument. +-- +-- Note: The directory may not actually exist, in which case you would need +-- to create it with file mode @700@ (i.e. only accessible by the owner). +-- +-- As of 1.3.5.0, the environment variable is ignored if set to a relative +-- path, per revised XDG Base Directory Specification. See +-- . +getXdgDirectory :: XdgDirectory -- ^ which special directory + -> OsPath -- ^ a relative path that is appended + -- to the path; if empty, the base + -- path is returned + -> IO OsPath +getXdgDirectory xdgDir suffix = + (`ioeAddLocation` "getXdgDirectory") `modifyIOError` do + simplify . ( suffix) <$> do + env <- lookupEnvOs . os $ case xdgDir of + XdgData -> "XDG_DATA_HOME" + XdgConfig -> "XDG_CONFIG_HOME" + XdgCache -> "XDG_CACHE_HOME" + XdgState -> "XDG_STATE_HOME" + case env of + Just path | isAbsolute path -> pure path + _ -> getXdgDirectoryFallback getHomeDirectory xdgDir + +-- | Similar to 'getXdgDirectory' but retrieves the entire list of XDG +-- directories. +-- +-- On Windows, 'XdgDataDirs' and 'XdgConfigDirs' usually map to the same list +-- of directories unless overridden. +-- +-- Refer to the docs of 'XdgDirectoryList' for more details. +getXdgDirectoryList :: XdgDirectoryList -- ^ which special directory list + -> IO [OsPath] +getXdgDirectoryList xdgDirs = + (`ioeAddLocation` "getXdgDirectoryList") `modifyIOError` do + env <- lookupEnvOs . os $ case xdgDirs of + XdgDataDirs -> "XDG_DATA_DIRS" + XdgConfigDirs -> "XDG_CONFIG_DIRS" + case env of + Nothing -> getXdgDirectoryListFallback xdgDirs + Just paths -> pure (splitSearchPath paths) + +-- | Obtain the path to a special directory for storing user-specific +-- application data (traditional Unix location). Newer applications may +-- prefer the the XDG-conformant location provided by 'getXdgDirectory' +-- (). +-- +-- The argument is usually the name of the application. Since it will be +-- integrated into the path, it must consist of valid path characters. +-- +-- * On Unix-like systems, the path is @~\/./\/@. +-- * On Windows, the path is @%APPDATA%\//\/@ +-- (e.g. @C:\/Users\//\/\/AppData\/Roaming\//\/@) +-- +-- Note: the directory may not actually exist, in which case you would need +-- to create it. It is expected that the parent directory exists and is +-- writable. +-- +-- The operation may fail with: +-- +-- * @UnsupportedOperation@ +-- The operating system has no notion of application-specific data +-- directory. +-- +-- * 'isDoesNotExistError' +-- The home directory for the current user does not exist, or cannot be +-- found. +-- +getAppUserDataDirectory :: OsPath -- ^ a relative path that is appended + -- to the path + -> IO OsPath +getAppUserDataDirectory appName = do + (`ioeAddLocation` "getAppUserDataDirectory") `modifyIOError` do + getAppUserDataDirectoryInternal appName + +{- | Returns the current user's document directory. + +The directory returned is expected to be writable by the current user, +but note that it isn't generally considered good practice to store +application-specific data here; use 'getXdgDirectory' or +'getAppUserDataDirectory' instead. + +On Unix, 'getUserDocumentsDirectory' returns the value of the @HOME@ +environment variable. On Windows, the system is queried for a +suitable path; a typical path might be @C:\/Users\//\/\/Documents@. + +The operation may fail with: + +* @UnsupportedOperation@ +The operating system has no notion of document directory. + +* 'isDoesNotExistError' +The document directory for the current user does not exist, or +cannot be found. +-} +getUserDocumentsDirectory :: IO OsPath +getUserDocumentsDirectory = do + (`ioeAddLocation` "getUserDocumentsDirectory") `modifyIOError` do + getUserDocumentsDirectoryInternal + +{- | Returns the current directory for temporary files. + +On Unix, 'getTemporaryDirectory' returns the value of the @TMPDIR@ +environment variable or \"\/tmp\" if the variable isn\'t defined. +On Windows, the function checks for the existence of environment variables in +the following order and uses the first path found: + +* +TMP environment variable. + +* +TEMP environment variable. + +* +USERPROFILE environment variable. + +* +The Windows directory + +The operation may fail with: + +* @UnsupportedOperation@ +The operating system has no notion of temporary directory. + +The function doesn\'t verify whether the path exists. +-} +getTemporaryDirectory :: IO OsPath +getTemporaryDirectory = getTemporaryDirectoryInternal diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,6 +1,24 @@ Changelog for the [`directory`][1] package ========================================== +## 1.3.8.0 (Sep 2022) + + * Drop support for `base` older than 4.11.0. + * Drop support for `filepath` older than 1.4.100. + * Drop support for `time` older than 1.8.0. + * Drop support for `unix` older than 2.8.0. + * Drop support for `Win32` older than 2.13.3. + * Modules in `directory` are no longer considered + [Safe](https://downloads.haskell.org/ghc/latest/docs/users_guide/exts/safe_haskell.html) + because the `System.OsPath` dependency is no longer Safe. + * A new module, `System.Directory.OsPath`, has been introduced to support + AFPP (`OsPath` and `OsString`) with an analogous API. The old module, + `System.Directory`, shall be in maintenance mode as new features will no + longer be accepted there. + ([#136](https://github.com/haskell/directory/pull/136)) + * `removePathForcibly` no longer changes permissions of files on non-Windows + systems. ([#135](https://github.com/haskell/directory/issues/135)) + ## 1.3.7.1 (Jul 2022) * Relax `time` version bounds to support 1.12. diff --git a/directory.cabal b/directory.cabal --- a/directory.cabal +++ b/directory.cabal @@ -1,5 +1,5 @@ name: directory -version: 1.3.7.1 +version: 1.3.8.0 license: BSD3 license-file: LICENSE maintainer: libraries@haskell.org @@ -36,12 +36,11 @@ Library default-language: Haskell2010 - other-extensions: - CPP - Trustworthy + other-extensions: CPP exposed-modules: System.Directory + System.Directory.OsPath System.Directory.Internal System.Directory.Internal.Prelude other-modules: @@ -54,19 +53,20 @@ include-dirs: . build-depends: - base >= 4.5 && < 4.18, - time >= 1.4 && < 1.13, - filepath >= 1.3 && < 1.5 + base >= 4.11.0 && < 4.18, + time >= 1.8.0 && < 1.13, + filepath >= 1.4.100 && < 1.5 if os(windows) - build-depends: Win32 >= 2.2.2 && < 2.14 + build-depends: Win32 >= 2.13.3 && < 2.14 else - build-depends: unix >= 2.5.1 && < 2.9 + build-depends: unix >= 2.8.0 && < 2.9 ghc-options: -Wall test-suite test default-language: Haskell2010 - other-extensions: BangPatterns, CPP, Safe + other-extensions: BangPatterns, CPP + default-extensions: OverloadedStrings ghc-options: -Wall hs-source-dirs: tests main-is: Main.hs @@ -107,7 +107,6 @@ RenameDirectory RenameFile001 RenamePath - Safe Simplify T8482 WithCurrentDirectory diff --git a/tests/CanonicalizePath.hs b/tests/CanonicalizePath.hs --- a/tests/CanonicalizePath.hs +++ b/tests/CanonicalizePath.hs @@ -1,8 +1,9 @@ {-# LANGUAGE CPP #-} module CanonicalizePath where #include "util.inl" -import System.FilePath ((), dropFileName, dropTrailingPathSeparator, - normalise, takeFileName) +import System.Directory.Internal +import System.OsPath ((), dropFileName, dropTrailingPathSeparator, + normalise, takeFileName) import TestUtils main :: TestEnv -> IO () @@ -141,9 +142,9 @@ T(expectEq) () fooNon fooNon13 T(expectEq) () fooNon fooNon14 T(expectEq) () fooNon (dropFileName cfooNon15 <> - (toLower <$> takeFileName cfooNon15)) + (os (toLower <$> so (takeFileName cfooNon15)))) T(expectEq) () fooNon (dropFileName cfooNon16 <> - (toLower <$> takeFileName cfooNon16)) + (os (toLower <$> so (takeFileName cfooNon16)))) T(expectNe) () fooNon cfooNon15 T(expectNe) () fooNon cfooNon16 diff --git a/tests/CopyFile001.hs b/tests/CopyFile001.hs --- a/tests/CopyFile001.hs +++ b/tests/CopyFile001.hs @@ -1,17 +1,18 @@ {-# LANGUAGE CPP #-} module CopyFile001 where #include "util.inl" -import System.FilePath (()) +import System.Directory.Internal +import System.OsPath (()) import qualified Data.List as List main :: TestEnv -> IO () main _t = do createDirectory dir - writeFile (dir from) contents + writeFile (so (dir from)) contents T(expectEq) () [from] . List.sort =<< listDirectory dir copyFile (dir from) (dir to) T(expectEq) () [from, to] . List.sort =<< listDirectory dir - T(expectEq) () contents =<< readFile (dir to) + T(expectEq) () contents =<< readFile (so (dir to)) where contents = "This is the data\n" from = "source" diff --git a/tests/CopyFile002.hs b/tests/CopyFile002.hs --- a/tests/CopyFile002.hs +++ b/tests/CopyFile002.hs @@ -1,17 +1,18 @@ {-# LANGUAGE CPP #-} module CopyFile002 where #include "util.inl" +import System.Directory.Internal import qualified Data.List as List main :: TestEnv -> IO () main _t = do -- Similar to CopyFile001 but moves a file in the current directory -- (Bug #1652 on GHC Trac) - writeFile from contents + writeFile (so from) contents T(expectEq) () [from] . List.sort =<< listDirectory "." copyFile from to T(expectEq) () [from, to] . List.sort =<< listDirectory "." - T(expectEq) () contents =<< readFile to + T(expectEq) () contents =<< readFile (so to) where contents = "This is the data\n" from = "source" diff --git a/tests/CopyFileWithMetadata.hs b/tests/CopyFileWithMetadata.hs --- a/tests/CopyFileWithMetadata.hs +++ b/tests/CopyFileWithMetadata.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} module CopyFileWithMetadata where #include "util.inl" +import System.Directory.Internal import qualified Data.List as List main :: TestEnv -> IO () @@ -25,7 +26,7 @@ for_ ["b", "c"] $ \ f -> do T(expectEq) f perm =<< getPermissions f T(expectEq) f mtime =<< getModificationTime f - T(expectEq) f contents =<< readFile f + T(expectEq) f contents =<< readFile (so f) where contents = "This is the data\n" diff --git a/tests/CreateDirectoryIfMissing001.hs b/tests/CreateDirectoryIfMissing001.hs --- a/tests/CreateDirectoryIfMissing001.hs +++ b/tests/CreateDirectoryIfMissing001.hs @@ -2,7 +2,8 @@ module CreateDirectoryIfMissing001 where #include "util.inl" import Data.Either (lefts) -import System.FilePath ((), addTrailingPathSeparator) +import System.Directory.Internal +import System.OsPath ((), addTrailingPathSeparator) main :: TestEnv -> IO () main _t = do @@ -27,13 +28,13 @@ T(inform) "done." cleanup - writeFile testdir testdir + writeFile (so testdir) (so testdir) T(expectIOErrorType) () isAlreadyExistsError $ createDirectoryIfMissing False testdir removeFile testdir cleanup - writeFile testdir testdir + writeFile (so testdir) (so testdir) T(expectIOErrorType) () isNotADirectoryError $ createDirectoryIfMissing True testdir_a removeFile testdir @@ -43,7 +44,7 @@ testname = "CreateDirectoryIfMissing001" - testdir = testname <> ".d" + testdir = os (testname <> ".d") testdir_a = testdir "a" numRepeats = T.readArg _t testname "num-repeats" 10000 diff --git a/tests/DoesPathExist.hs b/tests/DoesPathExist.hs --- a/tests/DoesPathExist.hs +++ b/tests/DoesPathExist.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} module DoesPathExist where #include "util.inl" +import TestUtils (supportsSymlinks) main :: TestEnv -> IO () main _t = do @@ -22,6 +23,20 @@ T(expect) () =<< doesPathExist "sOmEfIlE" #endif T(expect) () =<< doesPathExist "\x3c0\x42f\x97f3\xe6\x221e" + + supportsSymbolicLinks <- supportsSymlinks + when supportsSymbolicLinks $ do + + createDirectoryLink "somedir" "somedirlink" + createFileLink "somefile" "somefilelink" + createFileLink "nonexistent" "nonexistentlink" + + T(expect) () =<< doesFileExist "somefilelink" + T(expect) () . not =<< doesDirectoryExist "somefilelink" + T(expect) () =<< doesDirectoryExist "somedirlink" + T(expect) () . not =<< doesFileExist "somedirlink" + T(expect) () . not =<< doesDirectoryExist "nonexistentlink" + T(expect) () . not =<< doesFileExist "nonexistentlink" where #if defined(mingw32_HOST_OS) diff --git a/tests/FindFile001.hs b/tests/FindFile001.hs --- a/tests/FindFile001.hs +++ b/tests/FindFile001.hs @@ -2,7 +2,8 @@ module FindFile001 where #include "util.inl" import qualified Data.List as List -import System.FilePath (()) +import System.Directory.Internal +import System.OsPath (()) main :: TestEnv -> IO () main _t = do @@ -10,8 +11,8 @@ createDirectory "bar" createDirectory "qux" writeFile "foo" "" - writeFile ("bar" "foo") "" - writeFile ("qux" "foo") ":3" + writeFile (so ("bar" "foo")) "" + writeFile (so ("qux" "foo")) ":3" -- make sure findFile is lazy enough T(expectEq) () (Just ("." "foo")) =<< findFile ("." : undefined) "foo" @@ -23,7 +24,7 @@ T(expectEq) () (Just ("." "foo")) =<< findFile [".", "bar"] ("foo") T(expectEq) () (Just ("bar" "foo")) =<< findFile ["bar", "."] ("foo") - let f fn = (== ":3") <$> readFile fn + let f fn = (== ":3") <$> readFile (so fn) for_ (List.permutations ["qux", "bar", "."]) $ \ ds -> do let (match, noMatch) = List.partition (== "qux") ds diff --git a/tests/GetDirContents001.hs b/tests/GetDirContents001.hs --- a/tests/GetDirContents001.hs +++ b/tests/GetDirContents001.hs @@ -1,7 +1,8 @@ {-# LANGUAGE CPP #-} module GetDirContents001 where #include "util.inl" -import System.FilePath (()) +import System.Directory.Internal +import System.OsPath (()) import qualified Data.List as List main :: TestEnv -> IO () @@ -12,8 +13,8 @@ T(expectEq) () [] . List.sort =<< listDirectory dir names <- for [1 .. 100 :: Int] $ \ i -> do - let name = 'f' : show i - writeFile (dir name) "" + let name = "f" <> os (show i) + writeFile (so (dir name)) "" return name T(expectEq) () (List.sort (specials <> names)) . List.sort =<< getDirectoryContents dir diff --git a/tests/GetFileSize.hs b/tests/GetFileSize.hs --- a/tests/GetFileSize.hs +++ b/tests/GetFileSize.hs @@ -5,10 +5,8 @@ main :: TestEnv -> IO () main _t = do - withBinaryFile "emptyfile" WriteMode $ \ _ -> do - return () - withBinaryFile "testfile" WriteMode $ \ h -> do - hPutStr h string + writeFile "emptyfile" "" + writeFile "testfile" string T(expectEq) () 0 =<< getFileSize "emptyfile" T(expectEq) () (fromIntegral (length string)) =<< getFileSize "testfile" diff --git a/tests/LongPaths.hs b/tests/LongPaths.hs --- a/tests/LongPaths.hs +++ b/tests/LongPaths.hs @@ -2,7 +2,7 @@ module LongPaths where #include "util.inl" import TestUtils -import System.FilePath (()) +import System.OsPath (()) main :: TestEnv -> IO () main _t = do diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -27,7 +27,6 @@ import qualified RenameDirectory import qualified RenameFile001 import qualified RenamePath -import qualified Safe import qualified Simplify import qualified T8482 import qualified WithCurrentDirectory @@ -62,7 +61,6 @@ T.isolatedRun _t "RenameDirectory" RenameDirectory.main T.isolatedRun _t "RenameFile001" RenameFile001.main T.isolatedRun _t "RenamePath" RenamePath.main - T.isolatedRun _t "Safe" Safe.main T.isolatedRun _t "Simplify" Simplify.main T.isolatedRun _t "T8482" T8482.main T.isolatedRun _t "WithCurrentDirectory" WithCurrentDirectory.main diff --git a/tests/MakeAbsolute.hs b/tests/MakeAbsolute.hs --- a/tests/MakeAbsolute.hs +++ b/tests/MakeAbsolute.hs @@ -1,10 +1,11 @@ {-# LANGUAGE CPP #-} module MakeAbsolute where #include "util.inl" -import System.FilePath ((), addTrailingPathSeparator, - dropTrailingPathSeparator, normalise) +import System.OsPath ((), addTrailingPathSeparator, + dropTrailingPathSeparator, normalise) #if defined(mingw32_HOST_OS) -import System.FilePath (takeDrive) +import System.Directory.Internal +import System.OsPath (takeDrive, toChar, unpack) #endif main :: TestEnv -> IO () @@ -37,10 +38,10 @@ #if defined(mingw32_HOST_OS) cwd <- getCurrentDirectory - let driveLetter = toUpper (head (takeDrive cwd)) + let driveLetter = toUpper (toChar (head (unpack (takeDrive cwd)))) let driveLetter' = if driveLetter == 'Z' then 'A' else succ driveLetter - drp1 <- makeAbsolute (driveLetter : ":foobar") - drp2 <- makeAbsolute (driveLetter' : ":foobar") + drp1 <- makeAbsolute (os (driveLetter : ":foobar")) + drp2 <- makeAbsolute (os (driveLetter' : ":foobar")) T(expectEq) () drp1 =<< makeAbsolute "foobar" - T(expectEq) () drp2 (driveLetter' : ":\\foobar") + T(expectEq) () drp2 (os (driveLetter' : ":\\foobar")) #endif diff --git a/tests/MinimizeNameConflicts.hs b/tests/MinimizeNameConflicts.hs --- a/tests/MinimizeNameConflicts.hs +++ b/tests/MinimizeNameConflicts.hs @@ -1,7 +1,7 @@ {-# LANGUAGE CPP #-} module MinimizeNameConflicts ( main - , module System.Directory + , module System.Directory.OsPath #if defined(mingw32_HOST_OS) , module System.Win32 #else @@ -31,4 +31,4 @@ -- https://github.com/haskell/directory/issues/52 main :: TestEnv -> IO () main _t = do - T(expect) "no-op" True + T(expect) ("no-op" :: String) True diff --git a/tests/RemoveDirectoryRecursive001.hs b/tests/RemoveDirectoryRecursive001.hs --- a/tests/RemoveDirectoryRecursive001.hs +++ b/tests/RemoveDirectoryRecursive001.hs @@ -1,9 +1,10 @@ {-# LANGUAGE CPP #-} module RemoveDirectoryRecursive001 where #include "util.inl" -import System.FilePath ((), normalise) +import System.Directory.Internal +import System.OsPath ((), normalise) import qualified Data.List as List -import TestUtils +import TestUtils (modifyPermissions, symlinkOrCopy) main :: TestEnv -> IO () main _t = do @@ -24,8 +25,8 @@ createDirectoryIfMissing True (tmp "a/z") createDirectoryIfMissing True (tmp "b") createDirectoryIfMissing True (tmp "c") - writeFile (tmp "a/x/w/u") "foo" - writeFile (tmp "a/t") "bar" + writeFile (so (tmp "a/x/w/u")) "foo" + writeFile (so (tmp "a/t")) "bar" symlinkOrCopy (normalise "../a") (tmp "b/g") symlinkOrCopy (normalise "../b") (tmp "c/h") symlinkOrCopy (normalise "a") (tmp "d") @@ -85,5 +86,5 @@ getDirectoryContents tmpD where testName = "removeDirectoryRecursive001" - tmpD = testName ++ ".tmp" + tmpD = testName <> ".tmp" tmp s = tmpD normalise s diff --git a/tests/RemovePathForcibly.hs b/tests/RemovePathForcibly.hs --- a/tests/RemovePathForcibly.hs +++ b/tests/RemovePathForcibly.hs @@ -1,9 +1,10 @@ {-# LANGUAGE CPP #-} module RemovePathForcibly where #include "util.inl" -import System.FilePath ((), normalise) +import System.Directory.Internal +import System.OsPath ((), normalise) import qualified Data.List as List -import TestUtils +import TestUtils (hardLinkOrCopy, modifyPermissions, symlinkOrCopy) main :: TestEnv -> IO () main _t = do @@ -25,9 +26,9 @@ createDirectoryIfMissing True (tmp "b") createDirectoryIfMissing True (tmp "c") createDirectoryIfMissing True (tmp "f") - writeFile (tmp "a/x/w/u") "foo" - writeFile (tmp "a/t") "bar" - writeFile (tmp "f/s") "qux" + writeFile (so (tmp "a/x/w/u")) "foo" + writeFile (so (tmp "a/t")) "bar" + writeFile (so (tmp "f/s")) "qux" symlinkOrCopy (normalise "../a") (tmp "b/g") symlinkOrCopy (normalise "../b") (tmp "c/h") symlinkOrCopy (normalise "a") (tmp "d") @@ -83,6 +84,16 @@ T(expectEq) () [".", ".."] . List.sort =<< getDirectoryContents tmpD + ---------------------------------------------------------------------- + -- regression test for https://github.com/haskell/directory/issues/135 + + writeFile "hl1" "hardlinked" + setPermissions "hl1" emptyPermissions + origPermissions <- getPermissions "hl1" + hardLinkOrCopy "hl1" "hl2" + removePathForcibly "hl2" + T(expectEq) () origPermissions =<< getPermissions "hl1" + where testName = "removePathForcibly" - tmpD = testName ++ ".tmp" + tmpD = testName <> ".tmp" tmp s = tmpD normalise s diff --git a/tests/RenameFile001.hs b/tests/RenameFile001.hs --- a/tests/RenameFile001.hs +++ b/tests/RenameFile001.hs @@ -1,14 +1,15 @@ {-# LANGUAGE CPP #-} module RenameFile001 where #include "util.inl" +import System.Directory.Internal main :: TestEnv -> IO () main _t = do writeFile tmp1 contents1 - renameFile tmp1 tmp2 + renameFile (os tmp1) (os tmp2) T(expectEq) () contents1 =<< readFile tmp2 writeFile tmp1 contents2 - renameFile tmp2 tmp1 + renameFile (os tmp2) (os tmp1) T(expectEq) () contents1 =<< readFile tmp1 where tmp1 = "tmp1" diff --git a/tests/RenamePath.hs b/tests/RenamePath.hs --- a/tests/RenamePath.hs +++ b/tests/RenamePath.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} module RenamePath where #include "util.inl" +import System.Directory.Internal main :: TestEnv -> IO () main _t = do @@ -11,10 +12,10 @@ T(expectEq) () ["b"] =<< listDirectory "." writeFile tmp1 contents1 - renamePath tmp1 tmp2 + renamePath (os tmp1) (os tmp2) T(expectEq) () contents1 =<< readFile tmp2 writeFile tmp1 contents2 - renamePath tmp2 tmp1 + renamePath (os tmp2) (os tmp1) T(expectEq) () contents1 =<< readFile tmp1 where diff --git a/tests/Safe.hs b/tests/Safe.hs deleted file mode 100644 --- a/tests/Safe.hs +++ /dev/null @@ -1,7 +0,0 @@ --- Verify that System.Directory is indeed Safe (regression test for issue #30) -{-# LANGUAGE Safe #-} -module Safe where -import System.Directory () - -main :: a -> IO () -main _ = return () diff --git a/tests/Simplify.hs b/tests/Simplify.hs --- a/tests/Simplify.hs +++ b/tests/Simplify.hs @@ -2,7 +2,7 @@ module Simplify where #include "util.inl" import System.Directory.Internal (simplifyWindows) -import System.FilePath (normalise) +import System.OsPath (normalise) main :: TestEnv -> IO () main _t = do diff --git a/tests/T8482.hs b/tests/T8482.hs --- a/tests/T8482.hs +++ b/tests/T8482.hs @@ -1,16 +1,17 @@ {-# LANGUAGE CPP #-} module T8482 where #include "util.inl" +import System.Directory.Internal -tmp1 :: FilePath +tmp1 :: OsPath tmp1 = "T8482.tmp1" -testdir :: FilePath +testdir :: OsPath testdir = "T8482.dir" main :: TestEnv -> IO () main _t = do - writeFile tmp1 "hello" + writeFile (so tmp1) "hello" createDirectory testdir T(expectIOErrorType) () (is InappropriateType) (renameFile testdir tmp1) T(expectIOErrorType) () (is InappropriateType) (renameFile tmp1 testdir) diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -1,17 +1,20 @@ {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-orphans #-} -- | Utility functions specific to 'directory' tests module TestUtils ( copyPathRecursive + , hardLinkOrCopy , modifyPermissions , symlinkOrCopy , supportsSymlinks ) where import Prelude () import System.Directory.Internal.Prelude -import System.Directory -import System.FilePath ((), normalise, takeDirectory) +import System.Directory.Internal +import System.Directory.OsPath +import Data.String (IsString(fromString)) +import System.OsPath ((), normalise, takeDirectory) #if defined(mingw32_HOST_OS) -import System.Directory.Internal (win32_getFinalPathNameByHandle) import qualified System.Win32 as Win32 #endif @@ -19,7 +22,7 @@ -- /path/ together with its contents and subdirectories. -- -- Warning: mostly untested and might not handle symlinks correctly. -copyPathRecursive :: FilePath -> FilePath -> IO () +copyPathRecursive :: OsPath -> OsPath -> IO () copyPathRecursive source dest = (`ioeSetLocation` "copyPathRecursive") `modifyIOError` do dirExists <- doesDirectoryExist source @@ -31,7 +34,7 @@ [(source x, dest x) | x <- contents] else copyFile source dest -modifyPermissions :: FilePath -> (Permissions -> Permissions) -> IO () +modifyPermissions :: OsPath -> (Permissions -> Permissions) -> IO () modifyPermissions path modify = do permissions <- getPermissions path setPermissions path (modify permissions) @@ -52,11 +55,19 @@ _ -> ioError e #endif +-- | Create a hard link on Posix. On Windows, it just copies. +hardLinkOrCopy :: OsPath -> OsPath -> IO () +#if defined(mingw32_HOST_OS) +hardLinkOrCopy = copyPathRecursive +#else +hardLinkOrCopy = createHardLink +#endif + -- | Create a symbolic link. On Windows, this falls back to copying if -- forbidden by Group Policy or is not supported. On other platforms, there -- is no fallback. Also, automatically detect if the source is a file or a -- directory and create the appropriate type of link. -symlinkOrCopy :: FilePath -> FilePath -> IO () +symlinkOrCopy :: OsPath -> OsPath -> IO () symlinkOrCopy target link = do let fullTarget = takeDirectory link target handleSymlinkUnavail (copyPathRecursive fullTarget link) $ do @@ -76,7 +87,7 @@ -- returns 'True'. supportsLinkCreation :: IO Bool supportsLinkCreation = do - let path = "_symlink_test.tmp" + let path = os "_symlink_test.tmp" isSupported <- handleSymlinkUnavail (return False) $ do True <$ createFileLink path path when isSupported $ do @@ -94,3 +105,6 @@ #else return True #endif + +instance IsString OsString where + fromString = os diff --git a/tests/Util.hs b/tests/Util.hs --- a/tests/Util.hs +++ b/tests/Util.hs @@ -4,14 +4,11 @@ module Util where import Prelude () import System.Directory.Internal.Prelude -import System.Directory +import System.Directory.Internal +import System.Directory.OsPath import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime) -#if MIN_VERSION_base(4, 7, 0) import System.Environment (getEnvironment, setEnv, unsetEnv) -#elif !defined(mingw32_HOST_OS) -import qualified System.Posix as Posix -#endif -import System.FilePath ((), normalise) +import System.OsPath ((), decodeFS, encodeFS, normalise) import qualified Data.List as List modifyIORef' :: IORef a -> (a -> a) -> IO () @@ -127,7 +124,7 @@ Right _ -> Left ["did not throw an exception"] -- | Traverse the directory tree in preorder. -preprocessPathRecursive :: (FilePath -> IO ()) -> FilePath -> IO () +preprocessPathRecursive :: (OsPath -> IO ()) -> OsPath -> IO () preprocessPathRecursive f path = do dirExists <- doesDirectoryExist path if dirExists @@ -136,11 +133,11 @@ f path when (not isLink) $ do names <- listDirectory path - traverse_ (preprocessPathRecursive f) ((path ) <$> names) + for_ ((path ) <$> names) (preprocessPathRecursive f) else do f path -withNewDirectory :: Bool -> FilePath -> IO a -> IO a +withNewDirectory :: Bool -> OsPath -> IO a -> IO a withNewDirectory keep dir action = do dir' <- makeAbsolute dir bracket_ (createDirectoryIfMissing True dir') (cleanup dir') action @@ -167,20 +164,11 @@ updateEnvs [] [] = pure () updateEnvs kvs1 [] = for_ kvs1 (unsetEnv . fst) updateEnvs [] kvs2 = for_ kvs2 (uncurry setEnv) -#if MIN_VERSION_base(4, 7, 0) -#elif !defined(mingw32_HOST_OS) - getEnvironment = Posix.getEnvironment - setEnv k v = Posix.setEnv k v True - unsetEnv = Posix.unsetEnv -#else - getEnvironment = pure [] - setEnv _ _ = pure () - unsetEnv _ = pure () -#endif -isolateWorkingDirectory :: Bool -> FilePath -> IO a -> IO a +isolateWorkingDirectory :: Bool -> OsPath -> IO a -> IO a isolateWorkingDirectory keep dir action = do - when (normalise dir `List.elem` [".", "./"]) $ + normalisedDir <- decodeFS (normalise dir) + when (normalisedDir `List.elem` [".", "./"]) $ throwIO (userError ("isolateWorkingDirectory cannot be used " <> "with current directory")) dir' <- makeAbsolute dir @@ -197,11 +185,11 @@ Right () -> return () isolatedRun :: TestEnv -> String -> (TestEnv -> IO ()) -> IO () -isolatedRun t@TestEnv{testKeepDirs = keep} name = run t name . (isolate .) +isolatedRun t@TestEnv{testKeepDirs = keep} name action = do + workDir <- encodeFS ("dist/test-" <> name <> ".tmp") + run t name (isolate workDir . action) where - isolate = - isolateEnvironment . - isolateWorkingDirectory keep ("dist/test-" <> name <> ".tmp") + isolate workDir = isolateEnvironment . isolateWorkingDirectory keep workDir tryRead :: Read a => String -> Maybe a tryRead s = diff --git a/tests/WithCurrentDirectory.hs b/tests/WithCurrentDirectory.hs --- a/tests/WithCurrentDirectory.hs +++ b/tests/WithCurrentDirectory.hs @@ -1,7 +1,8 @@ {-# LANGUAGE CPP #-} module WithCurrentDirectory where #include "util.inl" -import System.FilePath (()) +import System.Directory.Internal +import System.OsPath (()) import qualified Data.List as List main :: TestEnv -> IO () @@ -10,13 +11,13 @@ -- Make sure we're starting empty T(expectEq) () [] . List.sort =<< listDirectory dir cwd <- getCurrentDirectory - withCurrentDirectory dir (writeFile testfile contents) + withCurrentDirectory dir (writeFile (so testfile) contents) -- Are we still in original directory? T(expectEq) () cwd =<< getCurrentDirectory -- Did the test file get created? T(expectEq) () [testfile] . List.sort =<< listDirectory dir -- Does the file contain what we expected to write? - T(expectEq) () contents =<< readFile (dir testfile) + T(expectEq) () contents =<< readFile (so (dir testfile)) where testfile = "testfile" contents = "some data\n" diff --git a/tests/Xdg.hs b/tests/Xdg.hs --- a/tests/Xdg.hs +++ b/tests/Xdg.hs @@ -1,12 +1,10 @@ {-# LANGUAGE CPP #-} module Xdg where -#if MIN_VERSION_base(4, 7, 0) import qualified Data.List as List import System.Environment (setEnv, unsetEnv) import System.FilePath (searchPathSeparator) #if !defined(mingw32_HOST_OS) -import System.FilePath (()) -#endif +import System.OsPath (()) #endif #include "util.inl" @@ -20,7 +18,6 @@ T(expect) () True -- avoid warnings about redundant imports -- setEnv, unsetEnv require base 4.7.0.0+ -#if MIN_VERSION_base(4, 7, 0) #if !defined(mingw32_HOST_OS) unsetEnv "XDG_CONFIG_HOME" home <- getHomeDirectory @@ -61,6 +58,5 @@ setEnv "XDG_CONFIG_DIRS" (List.intercalate [searchPathSeparator] ["/c", "/d"]) T(expectEq) () ["/a", "/b"] =<< getXdgDirectoryList XdgDataDirs T(expectEq) () ["/c", "/d"] =<< getXdgDirectoryList XdgConfigDirs -#endif return () diff --git a/tests/util.inl b/tests/util.inl --- a/tests/util.inl +++ b/tests/util.inl @@ -2,7 +2,8 @@ import Prelude () import System.Directory.Internal.Prelude -import System.Directory +import System.Directory.OsPath +import TestUtils () import Util (TestEnv) import qualified Util as T -- This comment prevents "T" above from being treated as the function-like