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). -- ----------------------------------------------------------------------------- @@ -47,6 +40,9 @@ , getUserDocumentsDirectory , getTemporaryDirectory + -- * PATH + , getExecSearchPath + -- * Actions on files , removeFile , renameFile @@ -113,21 +109,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 @@ -178,7 +162,8 @@ 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. +Note that to change some, but not all permissions, a construct on the +following lines must be used. > makeReadable f = do > p <- getPermissions f @@ -221,9 +206,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 +223,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 +233,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,53 +280,16 @@ -} 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' -- the function will also create all parent directories if they are missing. -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 + :: Bool -- ^ Create its parents too? + -> FilePath -- ^ The path to the directory you want to make + -> IO () +createDirectoryIfMissing cp = encodeFS >=> D.createDirectoryIfMissing cp {- | @'removeDirectory' dir@ removes an existing directory /dir/. The @@ -395,7 +334,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 +345,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 +366,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 +403,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,22 +455,22 @@ -} 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 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. +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 does not support renaming across different physical +devices; if you are looking to do so, consider using 'copyFileWithMetadata' and +'removeFile'. + On Windows, this calls @MoveFileEx@ with @MOVEFILE_REPLACE_EXISTING@ set, which is not guaranteed to be atomic (). @@ -637,26 +514,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 +564,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 +576,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 +602,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 +672,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 +686,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 +720,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 +735,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 +751,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. -- @@ -1050,8 +783,13 @@ -- documentation of 'findFilesWith'. -- -- @since 1.2.6.0 -findFileWith :: (FilePath -> IO Bool) -> [FilePath] -> String -> IO (Maybe FilePath) -findFileWith f ds name = listTHead (findFilesWithLazy f ds name) +findFileWith + :: (FilePath -> IO Bool) -> [FilePath] -> String -> IO (Maybe FilePath) +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 +810,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 +862,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 +898,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 +934,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 +949,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 +963,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 +971,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 +1011,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 +1048,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 +1062,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 +1081,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 +1101,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 +1119,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 +1135,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 +1161,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. -- @@ -1484,6 +1172,9 @@ -- -- * 'isDoesNotExistError' if the file or directory does not exist. -- +-- * 'InvalidArgument' on FAT32 file system if the time is before +-- DOS Epoch (1 January 1980). +-- -- Some caveats for POSIX systems: -- -- * Not all systems support @utimensat@, in which case the function can only @@ -1500,16 +1191,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. @@ -1521,9 +1203,12 @@ 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. +* Otherwise uses home directory returned by @getpwuid_r@ using the UID of the + current process' 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\//\/@. +On Windows, the system is queried for a suitable path; a typical path might be +@C:\/Users\//\/@. The operation may fail with: @@ -1535,9 +1220,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 +1251,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 +1262,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 +1293,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 +1316,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 +1345,8 @@ The function doesn\'t verify whether the path exists. -} getTemporaryDirectory :: IO FilePath -getTemporaryDirectory = getTemporaryDirectoryInternal +getTemporaryDirectory = D.getTemporaryDirectory >>= decodeFS + +-- | Get the contents of the @PATH@ environment variable. +getExecSearchPath :: IO [FilePath] +getExecSearchPath = D.getExecSearchPath >>= (`for` decodeFS) diff --git a/System/Directory/Internal/C_utimensat.hsc b/System/Directory/Internal/C_utimensat.hsc --- a/System/Directory/Internal/C_utimensat.hsc +++ b/System/Directory/Internal/C_utimensat.hsc @@ -1,3 +1,5 @@ +{-# LANGUAGE CApiFFI #-} + module System.Directory.Internal.C_utimensat where #include #ifdef HAVE_UTIMENSAT @@ -10,17 +12,16 @@ #ifdef HAVE_SYS_STAT_H # include #endif -#include import Prelude () import System.Directory.Internal.Prelude import Data.Time.Clock.POSIX (POSIXTime) +import qualified System.Posix as Posix data CTimeSpec = CTimeSpec EpochTime CLong instance Storable CTimeSpec where sizeOf _ = #{size struct timespec} - -- workaround (hsc2hs for GHC < 8.0 doesn't support #{alignment ...}) - alignment _ = #{size char[alignof(struct timespec)] } + alignment _ = #{alignment struct timespec} poke p (CTimeSpec sec nsec) = do (#poke struct timespec, tv_sec) p sec (#poke struct timespec, tv_nsec) p nsec @@ -29,9 +30,6 @@ nsec <- #{peek struct timespec, tv_nsec} p return (CTimeSpec sec nsec) -c_AT_FDCWD :: CInt -c_AT_FDCWD = (#const AT_FDCWD) - utimeOmit :: CTimeSpec utimeOmit = CTimeSpec (CTime 0) (#const UTIME_OMIT) @@ -41,7 +39,7 @@ (sec, frac) = if frac' < 0 then (sec' - 1, frac' + 1) else (sec', frac') (sec', frac') = properFraction (toRational t) -foreign import ccall "utimensat" c_utimensat - :: CInt -> CString -> Ptr CTimeSpec -> CInt -> IO CInt +foreign import capi "sys/stat.h utimensat" c_utimensat + :: Posix.Fd -> CString -> Ptr CTimeSpec -> CInt -> IO CInt #endif diff --git a/System/Directory/Internal/Common.hs b/System/Directory/Internal/Common.hs --- a/System/Directory/Internal/Common.hs +++ b/System/Directory/Internal/Common.hs @@ -1,18 +1,36 @@ -module System.Directory.Internal.Common where +{-# LANGUAGE CPP #-} +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 qualified System.File.OsPath.Internal as File +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. @@ -38,17 +56,17 @@ listTToList (ListT m) = do mx <- m case mx of - Nothing -> return [] + Nothing -> pure [] Just (x, m') -> do xs <- listTToList m' - return (x : xs) + pure (x : xs) andM :: Monad m => m Bool -> m Bool -> m Bool andM mx my = do x <- mx if x then my - else return x + else pure x sequenceWithIOErrors_ :: [IO ()] -> IO () sequenceWithIOErrors_ actions = go (Right ()) actions @@ -59,13 +77,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,60 +107,87 @@ 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) + +dropSpecialDotDirs :: [OsPath] -> [OsPath] +dropSpecialDotDirs = filter f + where f filename = filename /= os "." && filename /= os ".." + -- | 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: -- -- * empty paths stay empty, -- * parent dirs (@..@) are expanded, and --- * paths starting with @\\\\?\\@ are preserved. +-- * 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 + | otherwise = case toChar <$> unpack drive' of + '\\' : '\\' : _ -> drive' <> subpath + _ -> simplifiedPath where simplifiedPath = joinDrive drive' subpath' (drive, subpath) = splitDrive path @@ -157,32 +196,44 @@ 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 - | SymbolicLink -- ^ POSIX: either file or directory link; Windows: file link - | Directory - | DirectoryLink -- ^ Windows only: directory link - deriving (Bounded, Enum, Eq, Ord, Read, Show) +data WhetherFollow = NoFollow | FollowLinks deriving (Show) +isNoFollow :: WhetherFollow -> Bool +isNoFollow NoFollow = True +isNoFollow FollowLinks = False + +data FileType + = File + | SymbolicLink -- ^ POSIX: either file or directory link; Windows: file link + | Directory + | DirectoryLink -- ^ Windows only: directory link + deriving (Bounded, Enum, Eq, Ord, Read, Show) + -- | Check whether the given 'FileType' is considered a directory by the -- operating system. This affects the choice of certain functions -- e.g. 'System.Directory.removeDirectory' vs 'System.Directory.removeFile'. @@ -205,26 +256,17 @@ , 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 +withBinaryFile :: OsPath -> IOMode -> (Handle -> IO r) -> IO r +withBinaryFile path mode = + bracket (File.openFileWithCloseOnExec path mode) hClose --- | 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 +openTempFile' :: String -> OsPath -> OsString -> Bool -> CMode -> Bool + -> IO (OsPath, Handle) +openTempFile' loc tmpDir template binary mode _cloExec = + File.openTempFile' loc tmpDir template binary mode +#if MIN_VERSION_file_io(0, 2, 0) + _cloExec +#endif -- | Copy data from one handle to another until end of file. copyHandleData :: Handle -- ^ Source handle @@ -234,7 +276,8 @@ (`ioeAddLocation` "copyData") `modifyIOError` do allocaBytes bufferSize go where - bufferSize = 131072 -- 128 KiB, as coreutils `cp` uses as of May 2014 (see ioblksize.h) + -- 128 KiB, as coreutils `cp` uses as of May 2014 (see ioblksize.h) + bufferSize = 131072 go buffer = do count <- hGetBuf hFrom buffer bufferSize when (count > 0) $ do @@ -276,7 +319,7 @@ -- but that is not important or portable enough to the user that it -- should be stored in 'XdgData'. -- It uses the @XDG_STATE_HOME@ environment variable. - -- On non-Windows sytems, the default is @~\/.local\/state@. On + -- On non-Windows systems, the default is @~\/.local\/state@. On -- Windows, the default is @%LOCALAPPDATA%@ -- (e.g. @C:\/Users\//\/\/AppData\/Local@). -- 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 @@ -1,9 +1,14 @@ +{-# LANGUAGE CApiFFI #-} module System.Directory.Internal.Posix where #include #if !defined(mingw32_HOST_OS) +#include #ifdef HAVE_LIMITS_H # include #endif +#ifdef HAVE_SYS_STAT_H +# include +#endif import Prelude () import System.Directory.Internal.Prelude #ifdef HAVE_UTIMENSAT @@ -13,24 +18,80 @@ import System.Directory.Internal.Config (exeExtension) import Data.Time (UTCTime) import Data.Time.Clock.POSIX (POSIXTime) -import System.FilePath ((), isRelative, splitSearchPath) +import System.OsPath ((), 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.OsPath.Internal as OsPath +import qualified System.Posix.Directory.Fd as Posix +import qualified System.Posix.Directory.PosixPath as Posix +import qualified System.Posix.Env.PosixString as Posix +import qualified System.Posix.Files as Posix (FileStatus(..)) +import qualified System.Posix.Files.PosixString as Posix +import qualified System.Posix.Internals as Posix (CStat) +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.ByteString as Posix -createDirectoryInternal :: FilePath -> IO () -createDirectoryInternal path = Posix.createDirectory path 0o777 +c_AT_FDCWD :: Posix.Fd +c_AT_FDCWD = Posix.Fd (#const AT_FDCWD) -removePathInternal :: Bool -> FilePath -> IO () -removePathInternal True = Posix.removeDirectory -removePathInternal False = Posix.removeLink +c_AT_SYMLINK_NOFOLLOW :: CInt +c_AT_SYMLINK_NOFOLLOW = (#const AT_SYMLINK_NOFOLLOW) -renamePathInternal :: FilePath -> FilePath -> IO () -renamePathInternal = Posix.rename +atWhetherFollow :: WhetherFollow -> CInt +atWhetherFollow NoFollow = c_AT_SYMLINK_NOFOLLOW +atWhetherFollow FollowLinks = 0 +defaultOpenFlags :: Posix.OpenFileFlags +defaultOpenFlags = + Posix.defaultFileFlags + { Posix.noctty = True + , Posix.nonBlock = True + , Posix.cloexec = True + } + +type RawHandle = Posix.Fd + +openRaw :: WhetherFollow -> Maybe RawHandle -> OsPath -> IO RawHandle +openRaw whetherFollow dir (OsString path) = + Posix.openFdAt dir path Posix.ReadOnly flags + where + flags = defaultOpenFlags { Posix.nofollow = isNoFollow whetherFollow } + +closeRaw :: RawHandle -> IO () +closeRaw = Posix.closeFd + +createDirectoryInternal :: OsPath -> IO () +createDirectoryInternal (OsString path) = Posix.createDirectory path 0o777 + +foreign import ccall "unistd.h unlinkat" c_unlinkat + :: Posix.Fd -> CString -> CInt -> IO CInt + +removePathAt :: FileType -> Maybe RawHandle -> OsPath -> IO () +removePathAt ty dir (OsString path) = + Posix.withFilePath path $ \ pPath -> do + Posix.throwErrnoPathIfMinus1_ "unlinkat" path + (c_unlinkat (fromMaybe c_AT_FDCWD dir) pPath flag) + pure () + where + flag | fileTypeIsDirectory ty = (#const AT_REMOVEDIR) + | otherwise = 0 + +removePathInternal :: Bool -> OsPath -> IO () +removePathInternal True = Posix.removeDirectory . getOsString +removePathInternal False = Posix.removeLink . getOsString + +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 @@ -52,7 +113,13 @@ #if !defined(HAVE_REALPATH) c_realpath :: CString -> CString -> IO CString -c_realpath _ _ = throwIO (mkIOError UnsupportedOperation "platform does not support realpath" Nothing Nothing) +c_realpath _ _ = + throwIO + (mkIOError + UnsupportedOperation + "platform does not support realpath" + Nothing + Nothing) #else @@ -71,47 +138,51 @@ allocaBytes (pathMax + 1) (realpath >=> action) where realpath = throwErrnoIfNull "" . c_realpath path -canonicalizePathWith :: ((FilePath -> IO FilePath) -> FilePath -> IO FilePath) - -> FilePath - -> IO FilePath -canonicalizePathWith attemptRealpath path = do - encoding <- getFileSystemEncoding - let realpath path' = - GHC.withCString encoding path' (`withRealpath` GHC.peekCString encoding) - attemptRealpath realpath path +realPath :: OsPath -> IO OsPath +realPath (OsString path') = + Posix.withFilePath path' + (`withRealpath` ((OsString <$>) . Posix.peekFilePath)) -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 +getPath :: IO [OsPath] +getPath = splitSearchPath <$> getEnvOs (os "PATH") + +exeExtensionInternal :: OsString exeExtensionInternal = exeExtension -getDirectoryContentsInternal :: FilePath -> IO [FilePath] -getDirectoryContentsInternal path = - bracket - (Posix.openDirStream path) - Posix.closeDirStream - start +openDirFromFd :: Posix.Fd -> IO Posix.DirStream +openDirFromFd fd = Posix.unsafeOpenDirStreamFd =<< Posix.dup fd + +readDirStreamToEnd :: Posix.DirStream -> IO [OsPath] +readDirStreamToEnd stream = loop id where - start dirp = loop id - where - loop acc = do - e <- Posix.readDirStream dirp - if null e - then pure (acc []) - else loop (acc . (e:)) + loop acc = do + e <- Posix.readDirStream stream + if e == mempty + then pure (acc []) + else loop (acc . (OsString e :)) -getCurrentDirectoryInternal :: IO FilePath -getCurrentDirectoryInternal = Posix.getWorkingDirectory +readDirToEnd :: RawHandle -> IO [OsPath] +readDirToEnd fd = + bracket (openDirFromFd fd) Posix.closeDirStream readDirStreamToEnd +getDirectoryContentsInternal :: OsPath -> IO [OsPath] +getDirectoryContentsInternal (OsString path) = + bracket (Posix.openDirStream path) Posix.closeDirStream readDirStreamToEnd + +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. -- If the path is already absolute, the path is returned unchanged. The @@ -121,34 +192,52 @@ -- 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 +foreign import capi "sys/stat.h fstatat" c_fstatat + :: Posix.Fd -> CString -> Ptr Posix.CStat -> CInt -> IO CInt -getFileMetadata :: FilePath -> IO Metadata -getFileMetadata = Posix.getFileStatus +getMetadataAt :: WhetherFollow -> Maybe RawHandle -> OsPath -> IO Metadata +getMetadataAt whetherFollow dir (OsString path) = + Posix.withFilePath path $ \ pPath -> do + stat <- mallocForeignPtrBytes (#const sizeof(struct stat)) + withForeignPtr stat $ \ pStat -> do + Posix.throwErrnoPathIfMinus1_ "fstatat" path $ do + c_fstatat (fromMaybe c_AT_FDCWD dir) pPath pStat flags + pure (Posix.FileStatus stat) + where + flags = atWhetherFollow whetherFollow +getSymbolicLinkMetadata :: OsPath -> IO Metadata +getSymbolicLinkMetadata = Posix.getSymbolicLinkStatus . getOsString + +getFileMetadata :: OsPath -> IO Metadata +getFileMetadata = Posix.getFileStatus . getOsString + fileTypeFromMetadata :: Metadata -> FileType fileTypeFromMetadata stat | isLink = SymbolicLink @@ -163,21 +252,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 +276,32 @@ setWriteMode False m = m .&. complement allWriteMode setWriteMode True m = m .|. allWriteMode -setFileMode :: FilePath -> Mode -> IO () -setFileMode = Posix.setFileMode +setForceRemoveMode :: Mode -> Mode +setForceRemoveMode m = m .|. Posix.ownerModes -setFilePermissions :: FilePath -> Mode -> IO () +foreign import capi "sys/stat.h fchmodat" c_fchmodat + :: Posix.Fd -> CString -> Posix.FileMode -> CInt -> IO CInt + +setModeAt :: Maybe RawHandle -> OsPath -> Mode -> IO () +setModeAt dir (OsString path) mode = do + Posix.withFilePath path $ \ pPath -> + Posix.throwErrnoPathIfMinus1_ "fchmodat" path $ do + c_fchmodat (fromMaybe c_AT_FDCWD dir) pPath mode 0 + +setFileMode :: OsPath -> Mode -> IO () +setFileMode = Posix.setFileMode . getOsString + +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 +309,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 +321,118 @@ 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 +-- | 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 + withBinaryFile toFPath WriteMode $ \ hTo -> do + withBinaryFile fromFPath ReadMode $ \ 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 --- | Get the contents of the @PATH@ environment variable. -getPath :: IO [FilePath] -getPath = splitSearchPath <$> getEnv "PATH" +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 + -- | $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) + Just fp -> pure fp + Nothing -> + OsPath.fromBytes . Posix.homeDirectory =<< + Posix.getUserEntryForID =<< + Posix.getEffectiveUserID -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_, sequenceA_) import Data.Function (on) import Data.Maybe (catMaybes, fromMaybe, maybeToList) import Data.Monoid ((<>), mconcat, mempty) @@ -102,11 +80,13 @@ , allocaArray , allocaBytes , allocaBytesAligned + , mallocForeignPtrBytes , maybeWith , nullPtr , plusPtr , with , withArray + , withForeignPtr ) import Foreign.C ( CInt(..) @@ -118,14 +98,9 @@ , CUShort(..) , CWString , CWchar(..) - , peekCString - , peekCWStringLen , throwErrnoIfMinus1Retry_ , throwErrnoIfMinus1_ , throwErrnoIfNull - , throwErrnoPathIfMinus1_ - , withCString - , withCWString ) import GHC.IO.Exception ( IOErrorType @@ -136,7 +111,7 @@ ) ) import GHC.IO.Encoding (getFileSystemEncoding) -import System.Environment (getArgs, getEnv) +import System.Environment (getArgs) import System.Exit (exitFailure) import System.IO ( Handle @@ -147,14 +122,13 @@ , hPutBuf , hPutStr , hPutStrLn - , openBinaryTempFile , stderr , stdout - , withBinaryFile ) import System.IO.Error ( IOError , catchIOError + , doesNotExistErrorType , illegalOperationErrorType , ioeGetErrorString , ioeGetErrorType @@ -172,28 +146,5 @@ , tryIOError , userError ) -import System.Posix.Internals (withFilePath) -import System.Posix.Types (EpochTime) +import System.Posix.Types (CMode, 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 @@ -4,14 +4,14 @@ #if defined(mingw32_HOST_OS) ##if defined(i386_HOST_ARCH) ## define WINAPI stdcall -##elif defined(x86_64_HOST_ARCH) +##elif defined(x86_64_HOST_ARCH) || defined(aarch64_HOST_ARCH) ## define WINAPI ccall ##else ## error unknown architecture ##endif #include #include -#include +#include #include import Prelude () import System.Directory.Internal.Prelude @@ -19,61 +19,109 @@ 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 ( () + , hasExtension + , isExtensionOf , isPathSeparator , isRelative + , pack , pathSeparator , splitDirectories + , splitSearchPath , 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 +import qualified System.Win32.WindowsString.Console as Win32 -createDirectoryInternal :: FilePath -> IO () +type RawHandle = OsPath + +pathAt :: Maybe RawHandle -> OsPath -> OsPath +pathAt dir path = fromMaybe mempty dir path + +openRaw :: WhetherFollow -> Maybe RawHandle -> OsPath -> IO RawHandle +openRaw _ dir path = pure (pathAt dir path) + +closeRaw :: RawHandle -> IO () +closeRaw _ = pure () + +lookupEnvOs :: OsString -> IO (Maybe OsString) +lookupEnvOs (OsString name) = (OsString <$>) <$> Win32.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 [OsPath] +getPath = splitSearchPath <$> getEnvOs (os "PATH") + +createDirectoryInternal :: OsPath -> IO () createDirectoryInternal path = - (`ioeSetFileName` path) `modifyIOError` do + (`ioeSetOsPath` path) `modifyIOError` do path' <- furnishPath path Win32.createDirectory path' Nothing -removePathInternal :: Bool -> FilePath -> IO () +removePathAt :: FileType -> Maybe RawHandle -> OsPath -> IO () +removePathAt ty dir path = removePathInternal isDir (pathAt dir path) + where isDir = fileTypeIsDirectory ty + +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 +137,20 @@ 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 - -foreign import WINAPI unsafe "windows.h GetShortPathNameW" - c_GetShortPathName - :: Ptr CWchar - -> Ptr CWchar - -> Win32.DWORD - -> IO Win32.DWORD -#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 +161,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 +182,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 +203,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 @@ -206,8 +215,7 @@ allocaBytesAligned size align $ \ ptr -> action (ptr, size) where size = fromIntegral win32_mAXIMUM_REPARSE_DATA_BUFFER_SIZE - -- workaround (hsc2hs for GHC < 8.0 don't support #{alignment ...}) - align = #{size char[alignof(HsDirectory_REPARSE_DATA_BUFFER)]} + align = #{alignment HsDirectory_REPARSE_DATA_BUFFER} win32_peek_REPARSE_DATA_BUFFER :: Ptr Win32_REPARSE_DATA_BUFFER -> IO Win32_REPARSE_DATA_BUFFER @@ -247,10 +255,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 +287,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 +308,44 @@ | 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 + _ -> os "\\\\?\\" <> simplifiedPath where simplifiedPath = simplify path + simplifiedPath' = unpack simplifiedPath -- | Make a path absolute and convert to an extended length path, if possible. -- @@ -342,79 +353,110 @@ -- -- 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 (c8 : 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 -canonicalizePathWith attemptRealpath = attemptRealpath getFinalPathName +-- 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 -canonicalizePathSimplify :: FilePath -> IO FilePath +realPath :: OsPath -> IO OsPath +realPath = getFinalPathName + +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 binaryPath@(OsString binary) = do + maybePath <- search + `catch` \e -> + if ioeGetErrorType e == InvalidArgument + then pure Nothing + else throwIO e + pure (OsString <$> maybePath >>= verify) + where + search = Win32.searchPath Nothing binary (Just (getOsString exeExtension)) + verify p + | hasExtension binaryPath || exeExtension `isExtensionOf` p = Just p + | otherwise = Nothing -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] +readDirToEnd :: RawHandle -> IO [OsPath] +readDirToEnd = getDirectoryContentsInternal + +getDirectoryContentsInternal :: OsPath -> IO [OsPath] getDirectoryContentsInternal path = do - query <- furnishPath (path "*") + query <- furnishPath (path os "*") bracket (Win32.findFirstFile query) (\ (h, _) -> Win32.findClose h) @@ -422,28 +464,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 +498,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 +523,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 +546,35 @@ :: 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 +getMetadataAt :: WhetherFollow -> Maybe RawHandle -> OsPath -> IO Metadata +getMetadataAt NoFollow dir path = getSymbolicLinkMetadata (pathAt dir path) +getMetadataAt FollowLinks dir path = getFileMetadata (pathAt dir path) + +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 +582,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 +597,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 +627,20 @@ 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 + Win32.setFileTime + handle + Nothing + (posixToWindowsTime <$> atime') + (posixToWindowsTime <$> mtime') -- | 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 +659,32 @@ setWriteMode False m = m .|. Win32.fILE_ATTRIBUTE_READONLY setWriteMode True m = m .&. complement Win32.fILE_ATTRIBUTE_READONLY -setFileMode :: FilePath -> Mode -> IO () +setForceRemoveMode :: Mode -> Mode +setForceRemoveMode m = m .&. complement Win32.fILE_ATTRIBUTE_READONLY + +setModeAt :: Maybe RawHandle -> OsPath -> Mode -> IO () +setModeAt dir path = setFileMode (pathAt dir path) + +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 +693,39 @@ , 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 +getFolderPath :: Win32.CSIDL -> IO OsPath +getFolderPath what = OsString <$> Win32.sHGetFolderPath nullPtr what nullPtr 0 -getHomeDirectoryInternal :: IO FilePath +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/Internal/utility.h b/System/Directory/Internal/utility.h deleted file mode 100644 --- a/System/Directory/Internal/utility.h +++ /dev/null @@ -1,6 +0,0 @@ -#if !defined(alignof) && __cplusplus < 201103L -# ifdef STDC_HEADERS -# include -# endif -# define alignof(x) offsetof(struct { char c; x m; }, m) -#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,1669 @@ +----------------------------------------------------------------------------- +-- | +-- 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.3.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 + + -- * PATH + , getExecSearchPath + + -- * 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 + , dropTrailingPathSeparator + , hasTrailingPathSeparator + , isAbsolute + , joinPath + , makeRelative + , splitDirectories + , splitSearchPath + , takeDirectory + , encodeWith + ) +import qualified Data.List.NonEmpty as NE +import Data.Time (UTCTime) +import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) +import GHC.IO.Encoding.UTF8 ( mkUTF8 ) +import GHC.IO.Encoding.UTF16 ( mkUTF16le ) +import GHC.IO.Encoding.Failure ( CodingFailureMode(..) ) + +{- $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 + +type Preremover = Maybe RawHandle -> OsPath -> Metadata -> IO () + +noPreremover :: Preremover +noPreremover _ _ _ = pure () + +forcePreremover :: Preremover +forcePreremover dir path metadata = do + when (fileTypeIsDirectory (fileTypeFromMetadata metadata) + || not filesAlwaysRemovable) $ do + setModeAt dir path mode + `catchIOError` \ _ -> pure () + where + mode = setForceRemoveMode (modeFromMetadata metadata) + +removeRecursivelyAt + :: (IO () -> IO ()) + -> ([IO ()] -> IO ()) + -> Preremover + -> Maybe RawHandle + -> OsPath + -> IO () +removeRecursivelyAt catcher sequencer preremover dir name = catcher $ do + metadata <- getMetadataAt NoFollow dir name + preremover dir name metadata + let + fileType = fileTypeFromMetadata metadata + subremovals = do + when (fileType == Directory) $ do + bracket (openRaw NoFollow dir name) closeRaw $ \ handle -> do + -- dropSpecialDotDirs is extremely important! Otherwise it will + -- recurse into the parent directory and wreak havoc. + names <- dropSpecialDotDirs <$> readDirToEnd handle + sequencer (recurse (Just handle) <$> names) + sequencer [subremovals, removePathAt fileType dir name] + where recurse = removeRecursivelyAt catcher sequencer preremover + +-- | @'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 -> + removeRecursivelyAt id sequenceA_ noPreremover Nothing path + DirectoryLink -> + ioError (err `ioeSetErrorString` "is a directory symbolic link") + _ -> + ioError (err `ioeSetErrorString` "not a directory") + where err = mkIOError InappropriateType "" Nothing Nothing `ioeSetOsPath` 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 + removeRecursivelyAt + ignoreDoesNotExistError + sequenceWithIOErrors_ + forcePreremover + Nothing + path + + where + + ignoreDoesNotExistError :: IO () -> IO () + ignoreDoesNotExistError action = + () <$ tryIOErrorType isDoesNotExistError action + +{- |'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 does not support renaming across different physical +devices; if you are looking to do so, consider using 'copyFileWithMetadata' and +'removeFile'. + +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 + withBinaryFile fromFPath ReadMode $ \ 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 + let tmpPath = case encodeWith (mkUTF8 ErrorOnCodingFailure) + (mkUTF16le ErrorOnCodingFailure) + ".copyFile.tmp" + of + Left err -> + error ("withReplacementFile: invalid encoding: " <> show err) + Right p -> p + let dir = takeDirectory path + (tmpFPath, hTmp) <- + openTempFile' "openTempFile'" dir tmpPath True 0o600 True + (`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 <$> + (attemptRealpath realPath =<< 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 = NE.tail (NE.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 = dropSpecialDotDirs <$> getDirectoryContents path + +-- | 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. +-- +-- * 'InvalidArgument' on FAT32 file system if the time is before +-- DOS Epoch (1 January 1980). +-- +-- 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) = pure () +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 process' 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 $ case xdgDir of + XdgData -> os "XDG_DATA_HOME" + XdgConfig -> os "XDG_CONFIG_HOME" + XdgCache -> os "XDG_CACHE_HOME" + XdgState -> os "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 $ case xdgDirs of + XdgDataDirs -> os "XDG_DATA_DIRS" + XdgConfigDirs -> os "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 + +-- | Get the contents of the @PATH@ environment variable. +getExecSearchPath :: IO [OsPath] +getExecSearchPath = getPath diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,6 +1,104 @@ Changelog for the [`directory`][1] package ========================================== +## 1.3.11.0 (May 2026) + + * Cabal flag `os-string` was removed in favor of `impl(ghc >= 9.2)`. + ([#176](https://github.com/haskell/directory/issues/176)) + * Enable close-on-exec flag when copying files and relax `file-io` version + bounds to support 0.2.0. Note that close-on-exec when copying is only + enabled on `file-io` 0.2.0 or later. + ([#203](https://github.com/haskell/directory/issues/203)) + * Relax `time` version bounds to support 1.16. + +## 1.3.10.1 (Jan 2026) + + * Make `findExecutable` return `Nothing` on absolute paths that aren't + executable. + ([#187](https://github.com/haskell/directory/issues/187)) + * Ensure `removePathForcibly` removes write-protected files on all + platforms. + ([#194](https://github.com/haskell/directory/issues/194)) + +## 1.3.10.0 (Dec 2025) + + * Add `getExecSearchPath` as replacement for + `System.FilePath.getSearchPath`. + ([#198](https://github.com/haskell/directory/pull/198)) + * The [extended-length prefix][extended-length prefix] (`\\?\`) is no longer + implicitly prepended to Windows UNC paths to avoid triggering a Win32 + implementation bug. Clients using long UNC paths should find alternatives + to [enable long paths][enable long paths]. + ([#206](https://github.com/haskell/directory/issues/206)) + +[extended-length prefix]: https://learn.microsoft.com/en-us/windows/win32/fileio/maximum-file-path-limitation#:~:text=%5C%5C%3F%5C +[enable long paths]: https://learn.microsoft.com/en-us/windows/win32/fileio/maximum-file-path-limitation#enable-long-paths-in-windows-10-version-1607-and-later + +## 1.3.9.0 (Oct 2024) + + * Rely on `file-io` for file I/O. + * Drop support for `base` older than 4.12.0. + * Resolve TOCTOU issue with `removeDirectoryRecursive` and + `removePathForcibly` on POSIX systems. + (part of [#97](https://github.com/haskell/directory/issues/97)) + * `findExecutable ""` now returns `Nothing`, matching non-Windows systems + ([#180](https://github.com/haskell/directory/issues/180)) + +## 1.3.8.5 (May 2024) + + * Fix regression that causes copying of nonexistent files to create empty + files. + ([#177](https://github.com/haskell/directory/issues/177)) + +## 1.3.8.4 (Apr 2024) + + * Relax `time` version bounds to support 1.14. + ([#171](https://github.com/haskell/directory/issues/171)) + * Relax `base` version bounds to support 4.20. + ([#173](https://github.com/haskell/directory/issues/173)) + * Relax `filepath` version bounds to support 1.4.300 when `os-string` is + unavailable. + ([#175](https://github.com/haskell/directory/issues/175)) + +## 1.3.8.3 (Jan 2024) + + * Relax `Win32` version bounds to support 2.14.0.0. + ([#166](https://github.com/haskell/directory/issues/166)) + * Fix regression in `canonicalizePath` on Windows UNC paths. + ([#170](https://github.com/haskell/directory/issues/170)) + +## 1.3.8.2 (Dec 2023) + + * Relax `base` version bounds to support 4.19. + ([#157](https://github.com/haskell/directory/pull/157)) + * Support filepath >= 1.5.0.0 and os-string. + ([#164](https://github.com/haskell/directory/issues/164)) + +## 1.3.8.1 (Feb 2023) + + * Use CApiFFI for utimensat. + ([#145](https://github.com/haskell/directory/pull/145)) + * Relax `base` version bounds to support 4.18. + ([#151](https://github.com/haskell/directory/pull/151)) + +## 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.buildinfo b/directory.buildinfo deleted file mode 100644 --- a/directory.buildinfo +++ /dev/null @@ -1,1 +0,0 @@ -install-includes: HsDirectoryConfig.h diff --git a/directory.cabal b/directory.cabal --- a/directory.cabal +++ b/directory.cabal @@ -1,6 +1,7 @@ +cabal-version: 2.2 name: directory -version: 1.3.7.1 -license: BSD3 +version: 1.3.11.0 +license: BSD-3-Clause license-file: LICENSE maintainer: libraries@haskell.org bug-reports: https://github.com/haskell/directory/issues @@ -10,8 +11,7 @@ directories in a portable way. category: System build-type: Configure -cabal-version: >= 1.10 -tested-with: GHC>=7.4.1 +tested-with: GHC == 8.10.7 || == 9.0.2 || == 9.2.4 || == 9.4.3 extra-tmp-files: autom4te.cache @@ -19,16 +19,16 @@ config.status HsDirectoryConfig.h +extra-doc-files: + README.md + changelog.md + extra-source-files: HsDirectoryConfig.h.in - README.md System/Directory/Internal/*.h - changelog.md configure configure.ac - directory.buildinfo tests/*.hs - tests/util.inl source-repository head type: git @@ -36,12 +36,11 @@ Library default-language: Haskell2010 - other-extensions: - CPP - Trustworthy + other-extensions: CApiFFI, CPP exposed-modules: System.Directory + System.Directory.OsPath System.Directory.Internal System.Directory.Internal.Prelude other-modules: @@ -54,19 +53,26 @@ include-dirs: . build-depends: - base >= 4.5 && < 4.18, - time >= 1.4 && < 1.13, - filepath >= 1.3 && < 1.5 + base >= 4.13.0 && < 4.23, + file-io >= 0.1.4 && < 0.3, + time >= 1.8.0 && < 1.17, if os(windows) - build-depends: Win32 >= 2.2.2 && < 2.14 + build-depends: Win32 >= 2.14.1.0 && < 2.15 else - build-depends: unix >= 2.5.1 && < 2.9 + build-depends: unix >= 2.8.0 && < 2.9 + if impl(ghc >= 9.2) + build-depends: filepath >= 1.5.0 && < 1.6, + os-string >= 2.0.0 && < 2.1, + else + build-depends: filepath >= 1.4.100 && < 1.5 + 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 @@ -91,6 +97,7 @@ DoesDirectoryExist001 DoesPathExist FileTime + FindExecutable FindFile001 GetDirContents001 GetDirContents002 @@ -107,7 +114,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,9 +1,14 @@ {-# LANGUAGE CPP #-} module CanonicalizePath where -#include "util.inl" -import System.FilePath ((), dropFileName, dropTrailingPathSeparator, - normalise, takeFileName) +import Prelude () +import System.Directory.Internal.Prelude +import System.Directory.Internal +import System.Directory.OsPath import TestUtils +import Util (TestEnv) +import qualified Util as T +import System.OsPath ((), dropFileName, dropTrailingPathSeparator, + normalise, takeFileName) main :: TestEnv -> IO () main _t = do @@ -11,10 +16,10 @@ dot2 <- canonicalizePath "." dot3 <- canonicalizePath "./" dot4 <- canonicalizePath "./." - T(expectEq) () dot (dropTrailingPathSeparator dot) - T(expectEq) () dot dot2 - T(expectEq) () dot dot3 - T(expectEq) () dot dot4 + T.expectEq _t () dot (dropTrailingPathSeparator dot) + T.expectEq _t () dot dot2 + T.expectEq _t () dot dot3 + T.expectEq _t () dot dot4 writeFile "bar" "" bar <- canonicalizePath "bar" @@ -24,13 +29,13 @@ bar5 <- canonicalizePath "./bar" bar6 <- canonicalizePath "./bar/" bar7 <- canonicalizePath "./bar/." - T(expectEq) () bar (normalise (dot "bar")) - T(expectEq) () bar bar2 - T(expectEq) () bar bar3 - T(expectEq) () bar bar4 - T(expectEq) () bar bar5 - T(expectEq) () bar bar6 - T(expectEq) () bar bar7 + T.expectEq _t () bar (normalise (dot "bar")) + T.expectEq _t () bar bar2 + T.expectEq _t () bar bar3 + T.expectEq _t () bar bar4 + T.expectEq _t () bar bar5 + T.expectEq _t () bar bar6 + T.expectEq _t () bar bar7 createDirectory "foo" foo <- canonicalizePath "foo" @@ -39,12 +44,12 @@ foo4 <- canonicalizePath "foo/./" foo5 <- canonicalizePath "./foo" foo6 <- canonicalizePath "./foo/" - T(expectEq) () foo (normalise (dot "foo")) - T(expectEq) () foo foo2 - T(expectEq) () foo foo3 - T(expectEq) () foo foo4 - T(expectEq) () foo foo5 - T(expectEq) () foo foo6 + T.expectEq _t () foo (normalise (dot "foo")) + T.expectEq _t () foo foo2 + T.expectEq _t () foo foo3 + T.expectEq _t () foo foo4 + T.expectEq _t () foo foo5 + T.expectEq _t () foo foo6 -- should not fail for non-existent paths fooNon <- canonicalizePath "foo/non-existent" @@ -55,19 +60,19 @@ fooNon6 <- canonicalizePath "./foo/non-existent/" fooNon7 <- canonicalizePath "./foo/./non-existent" fooNon8 <- canonicalizePath "./foo/./non-existent/" - T(expectEq) () fooNon (normalise (foo "non-existent")) - T(expectEq) () fooNon fooNon2 - T(expectEq) () fooNon fooNon3 - T(expectEq) () fooNon fooNon4 - T(expectEq) () fooNon fooNon5 - T(expectEq) () fooNon fooNon6 - T(expectEq) () fooNon fooNon7 - T(expectEq) () fooNon fooNon8 + T.expectEq _t () fooNon (normalise (foo "non-existent")) + T.expectEq _t () fooNon fooNon2 + T.expectEq _t () fooNon fooNon3 + T.expectEq _t () fooNon fooNon4 + T.expectEq _t () fooNon fooNon5 + T.expectEq _t () fooNon fooNon6 + T.expectEq _t () fooNon fooNon7 + T.expectEq _t () fooNon fooNon8 -- make sure ".." gets expanded properly by 'toExtendedLengthPath' -- (turns out this test won't detect the problem because GetFullPathName -- would expand them for us if we don't, but leaving it here anyway) - T(expectEq) () foo =<< canonicalizePath (foo ".." "foo") + T.expectEq _t () foo =<< canonicalizePath (foo ".." "foo") supportsSymbolicLinks <- supportsSymlinks when supportsSymbolicLinks $ do @@ -77,40 +82,40 @@ -- note: this also checks that "../bar" gets normalized to "..\\bar" -- since Windows does not like "/" in symbolic links targets createFileLink "../bar" "foo/bar" - T(expectEq) () bar =<< canonicalizePath "foo/bar" - T(expectEq) () barQux =<< canonicalizePath "foo/bar/qux" + T.expectEq _t () bar =<< canonicalizePath "foo/bar" + T.expectEq _t () barQux =<< canonicalizePath "foo/bar/qux" createDirectoryLink "foo" "lfoo" - T(expectEq) () foo =<< canonicalizePath "lfoo" - T(expectEq) () foo =<< canonicalizePath "lfoo/" - T(expectEq) () bar =<< canonicalizePath "lfoo/bar" - T(expectEq) () barQux =<< canonicalizePath "lfoo/bar/qux" + T.expectEq _t () foo =<< canonicalizePath "lfoo" + T.expectEq _t () foo =<< canonicalizePath "lfoo/" + T.expectEq _t () bar =<< canonicalizePath "lfoo/bar" + T.expectEq _t () barQux =<< canonicalizePath "lfoo/bar/qux" -- create a haphazard chain of links createDirectoryLink "./../foo/../foo/." "./foo/./somelink3" createDirectoryLink ".././foo/somelink3" "foo/somelink2" createDirectoryLink "./foo/somelink2" "somelink" - T(expectEq) () foo =<< canonicalizePath "somelink" + T.expectEq _t () foo =<< canonicalizePath "somelink" -- regression test for #64 createFileLink "../foo/non-existent" "foo/qux" removeDirectoryLink "foo/somelink3" -- break the chain made earlier qux <- canonicalizePath "foo/qux" - T(expectEq) () qux =<< canonicalizePath "foo/non-existent" - T(expectEq) () (foo "somelink3") =<< canonicalizePath "somelink" + T.expectEq _t () qux =<< canonicalizePath "foo/non-existent" + T.expectEq _t () (foo "somelink3") =<< canonicalizePath "somelink" -- make sure it can handle loops createFileLink "loop1" "loop2" createFileLink "loop2" "loop1" loop1 <- canonicalizePath "loop1" loop2 <- canonicalizePath "loop2" - T(expectEq) () loop1 (normalise (dot "loop1")) - T(expectEq) () loop2 (normalise (dot "loop2")) + T.expectEq _t () loop1 (normalise (dot "loop1")) + T.expectEq _t () loop2 (normalise (dot "loop2")) -- make sure ".." gets expanded properly by 'toExtendedLengthPath' createDirectoryLink (foo ".." "foo") "foolink" _ <- listDirectory "foolink" -- make sure directory is accessible - T(expectEq) () foo =<< canonicalizePath "foolink" + T.expectEq _t () foo =<< canonicalizePath "foolink" caseInsensitive <- (False <$ createDirectory "FOO") @@ -123,8 +128,8 @@ when caseInsensitive $ do foo7 <- canonicalizePath "FOO" foo8 <- canonicalizePath "FOO/" - T(expectEq) () foo foo7 - T(expectEq) () foo foo8 + T.expectEq _t () foo foo7 + T.expectEq _t () foo foo8 fooNon9 <- canonicalizePath "FOO/non-existent" fooNon10 <- canonicalizePath "fOo/non-existent/" @@ -134,28 +139,35 @@ fooNon14 <- canonicalizePath "./FOo/non-existent/" cfooNon15 <- canonicalizePath "./FOO/./NON-EXISTENT" cfooNon16 <- canonicalizePath "./FOO/./NON-EXISTENT/" - T(expectEq) () fooNon fooNon9 - T(expectEq) () fooNon fooNon10 - T(expectEq) () fooNon fooNon11 - T(expectEq) () fooNon fooNon12 - T(expectEq) () fooNon fooNon13 - T(expectEq) () fooNon fooNon14 - T(expectEq) () fooNon (dropFileName cfooNon15 <> - (toLower <$> takeFileName cfooNon15)) - T(expectEq) () fooNon (dropFileName cfooNon16 <> - (toLower <$> takeFileName cfooNon16)) - T(expectNe) () fooNon cfooNon15 - T(expectNe) () fooNon cfooNon16 + T.expectEq _t () fooNon fooNon9 + T.expectEq _t () fooNon fooNon10 + T.expectEq _t () fooNon fooNon11 + T.expectEq _t () fooNon fooNon12 + T.expectEq _t () fooNon fooNon13 + T.expectEq _t () fooNon fooNon14 + T.expectEq _t () fooNon + (dropFileName cfooNon15 <> os (toLower <$> so (takeFileName cfooNon15))) + T.expectEq _t () fooNon + (dropFileName cfooNon16 <> os (toLower <$> so (takeFileName cfooNon16))) + T.expectNe _t () fooNon cfooNon15 + T.expectNe _t () fooNon cfooNon16 setCurrentDirectory "foo" foo9 <- canonicalizePath "../FOO" foo10 <- canonicalizePath "../FOO/" - T(expectEq) () foo foo9 - T(expectEq) () foo foo10 + T.expectEq _t () foo foo9 + T.expectEq _t () foo foo10 - -- Make sure long file names can be canonicalized too - -- (i.e. GetLongPathName by itself won't work) - createDirectory "verylongdirectoryname" - vldn <- canonicalizePath "verylongdirectoryname" - vldn2 <- canonicalizePath "VERYLONGDIRECTORYNAME" - T(expectEq) () vldn vldn2 + let isWindows = +#if defined(mingw32_HOST_OS) + True +#else + False +#endif + + when isWindows $ do + -- https://github.com/haskell/directory/issues/170 + T.expectEq _t () "\\\\localhost" =<< canonicalizePath "\\\\localhost" + -- https://github.com/haskell/directory/issues/206 + T.expectEq _t () "\\\\localhost\\C$" =<< + canonicalizePath "\\\\localhost\\C$\\.." diff --git a/tests/CopyFile001.hs b/tests/CopyFile001.hs --- a/tests/CopyFile001.hs +++ b/tests/CopyFile001.hs @@ -1,17 +1,29 @@ -{-# LANGUAGE CPP #-} module CopyFile001 where -#include "util.inl" -import System.FilePath (()) +import Prelude () +import System.Directory.Internal.Prelude +import System.Directory.Internal +import System.Directory.OsPath +import TestUtils () +import Util (TestEnv) +import qualified Util as T +import System.OsPath (()) import qualified Data.List as List main :: TestEnv -> IO () main _t = do createDirectory dir - writeFile (dir from) contents - T(expectEq) () [from] . List.sort =<< listDirectory dir + writeFile (so (dir from)) contents + T.expectEq _t () [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 _t () [from, to] . List.sort =<< listDirectory dir + T.expectEq _t () contents =<< readFile (so (dir to)) + + -- Regression test for https://github.com/haskell/directory/issues/177 + createDirectory "issue177" + T.expectIOErrorType _t () isDoesNotExistError + (copyFile "issue177/nonexistentSrc" "issue177/dst") + T.expectEq _t () [] =<< listDirectory "issue177" + 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,22 @@ -{-# LANGUAGE CPP #-} module CopyFile002 where -#include "util.inl" +import Prelude () +import System.Directory.Internal.Prelude +import System.Directory.Internal +import System.Directory.OsPath +import TestUtils () +import Util (TestEnv) +import qualified Util as T 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 - T(expectEq) () [from] . List.sort =<< listDirectory "." + writeFile (so from) contents + T.expectEq _t () [from] . List.sort =<< listDirectory "." copyFile from to - T(expectEq) () [from, to] . List.sort =<< listDirectory "." - T(expectEq) () contents =<< readFile to + T.expectEq _t () [from, to] . List.sort =<< listDirectory "." + T.expectEq _t () 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,11 @@ -{-# LANGUAGE CPP #-} module CopyFileWithMetadata where -#include "util.inl" +import Prelude () +import System.Directory.Internal.Prelude +import System.Directory.Internal +import System.Directory.OsPath +import TestUtils () +import Util (TestEnv) +import qualified Util as T import qualified Data.List as List main :: TestEnv -> IO () @@ -14,18 +19,18 @@ perm <- getPermissions "a" -- sanity check - T(expectEq) () ["a", "b"] . List.sort =<< listDirectory "." + T.expectEq _t () ["a", "b"] . List.sort =<< listDirectory "." -- copy file copyFileWithMetadata "a" "b" copyFileWithMetadata "a" "c" -- make sure we got the right results - T(expectEq) () ["a", "b", "c"] . List.sort =<< listDirectory "." + T.expectEq _t () ["a", "b", "c"] . List.sort =<< listDirectory "." 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 _t f perm =<< getPermissions f + T.expectEq _t f mtime =<< getModificationTime f + T.expectEq _t f contents =<< readFile (so f) where contents = "This is the data\n" @@ -33,9 +38,9 @@ cleanup = do -- needed to ensure the test runner can clean up our mess - modifyWritable True "a" `catchIOError` \ _ -> return () - modifyWritable True "b" `catchIOError` \ _ -> return () - modifyWritable True "c" `catchIOError` \ _ -> return () + modifyWritable True "a" `catchIOError` \ _ -> pure () + modifyWritable True "b" `catchIOError` \ _ -> pure () + modifyWritable True "c" `catchIOError` \ _ -> pure () modifyWritable b f = do perm <- getPermissions f diff --git a/tests/CreateDirectory001.hs b/tests/CreateDirectory001.hs --- a/tests/CreateDirectory001.hs +++ b/tests/CreateDirectory001.hs @@ -1,9 +1,13 @@ -{-# LANGUAGE CPP #-} module CreateDirectory001 where -#include "util.inl" +import Prelude () +import System.Directory.Internal.Prelude +import System.Directory.OsPath +import TestUtils () +import Util (TestEnv) +import qualified Util as T main :: TestEnv -> IO () main _t = do createDirectory testdir - T(expectIOErrorType) () isAlreadyExistsError (createDirectory testdir) + T.expectIOErrorType _t () isAlreadyExistsError (createDirectory testdir) where testdir = "dir" diff --git a/tests/CreateDirectoryIfMissing001.hs b/tests/CreateDirectoryIfMissing001.hs --- a/tests/CreateDirectoryIfMissing001.hs +++ b/tests/CreateDirectoryIfMissing001.hs @@ -1,8 +1,14 @@ {-# LANGUAGE CPP #-} module CreateDirectoryIfMissing001 where -#include "util.inl" +import Prelude () +import System.Directory.Internal.Prelude +import System.Directory.Internal +import System.Directory.OsPath +import TestUtils () +import Util (TestEnv) +import qualified Util as T import Data.Either (lefts) -import System.FilePath ((), addTrailingPathSeparator) +import System.OsPath ((), addTrailingPathSeparator) main :: TestEnv -> IO () main _t = do @@ -10,7 +16,7 @@ createDirectoryIfMissing False testdir cleanup - T(expectIOErrorType) () isDoesNotExistError $ + T.expectIOErrorType _t () isDoesNotExistError $ createDirectoryIfMissing False testdir_a createDirectoryIfMissing True testdir_a @@ -20,21 +26,21 @@ createDirectoryIfMissing True (addTrailingPathSeparator testdir_a) - T(inform) "testing for race conditions ..." + T.inform _t "testing for race conditions ..." raceCheck1 - T(inform) "testing for race conditions ..." + T.inform _t "testing for race conditions ..." raceCheck2 - T(inform) "done." + T.inform _t "done." cleanup - writeFile testdir testdir - T(expectIOErrorType) () isAlreadyExistsError $ + writeFile (so testdir) (so testdir) + T.expectIOErrorType _t () isAlreadyExistsError $ createDirectoryIfMissing False testdir removeFile testdir cleanup - writeFile testdir testdir - T(expectIOErrorType) () isNotADirectoryError $ + writeFile (so testdir) (so testdir) + T.expectIOErrorType _t () isNotADirectoryError $ createDirectoryIfMissing True testdir_a removeFile testdir cleanup @@ -43,10 +49,10 @@ testname = "CreateDirectoryIfMissing001" - testdir = testname <> ".d" + testdir = os (testname <> ".d") testdir_a = testdir "a" - numRepeats = T.readArg _t testname "num-repeats" 10000 + numRepeats = T.readArg _t testname "num-repeats" 10 numThreads = T.readArg _t testname "num-threads" 4 forkPut mvar action = () <$ forkFinally action (putMVar mvar) @@ -60,18 +66,18 @@ forkPut m $ do replicateM_ numRepeats cleanup results <- replicateM 2 (takeMVar m) - T(expectEq) () [] (show <$> lefts results) + T.expectEq _t () [] (show <$> lefts results) -- This test fails on Windows (see bug #2924 on GHC Trac): raceCheck2 = do m <- newEmptyMVar - replicateM_ numThreads $ + replicateM_ numThreads $ do forkPut m $ do replicateM_ numRepeats $ do create cleanup results <- replicateM numThreads (takeMVar m) - T(expectEq) () [] (show <$> lefts results) + T.expectEq _t () [] (show <$> lefts results) -- createDirectoryIfMissing is allowed to fail with isDoesNotExistError if -- another process/thread removes one of the directories during the process @@ -85,10 +91,10 @@ || isPermissionError e || isInappropriateTypeError e || ioeGetErrorType e == InvalidArgument - then return () + then pure () else ioError e - cleanup = removeDirectoryRecursive testdir `catchAny` \ _ -> return () + cleanup = removeDirectoryRecursive testdir `catchAny` \ _ -> pure () catchAny :: IO a -> (SomeException -> IO a) -> IO a catchAny = catch diff --git a/tests/CurrentDirectory001.hs b/tests/CurrentDirectory001.hs --- a/tests/CurrentDirectory001.hs +++ b/tests/CurrentDirectory001.hs @@ -1,6 +1,10 @@ -{-# LANGUAGE CPP #-} module CurrentDirectory001 where -#include "util.inl" +import Prelude () +import System.Directory.Internal.Prelude +import System.Directory.OsPath +import TestUtils () +import Util (TestEnv) +import qualified Util as T import qualified Data.List as List main :: TestEnv -> IO () @@ -8,6 +12,6 @@ prevDir <- getCurrentDirectory createDirectory "dir" setCurrentDirectory "dir" - T(expectEq) () [".", ".."] . List.sort =<< getDirectoryContents "." + T.expectEq _t () [".", ".."] . List.sort =<< getDirectoryContents "." setCurrentDirectory prevDir removeDirectory "dir" diff --git a/tests/Directory001.hs b/tests/Directory001.hs --- a/tests/Directory001.hs +++ b/tests/Directory001.hs @@ -1,6 +1,10 @@ -{-# LANGUAGE CPP #-} module Directory001 where -#include "util.inl" +import Prelude () +import System.Directory.Internal.Prelude +import System.Directory.OsPath +import TestUtils () +import Util (TestEnv) +import qualified Util as T main :: TestEnv -> IO () main _t = do @@ -10,7 +14,7 @@ renameFile "foo/bar" "foo/baz" renameDirectory "foo" "bar" str' <- readFile "bar/baz" - T(expectEq) () str' str + T.expectEq _t () str' str removeFile "bar/baz" removeDirectory "bar" diff --git a/tests/DoesDirectoryExist001.hs b/tests/DoesDirectoryExist001.hs --- a/tests/DoesDirectoryExist001.hs +++ b/tests/DoesDirectoryExist001.hs @@ -1,21 +1,26 @@ {-# LANGUAGE CPP #-} module DoesDirectoryExist001 where -#include "util.inl" +import Prelude () +import System.Directory.Internal.Prelude +import System.Directory.OsPath +import TestUtils () +import Util (TestEnv) +import qualified Util as T main :: TestEnv -> IO () main _t = do -- [regression test] "/" was not recognised as a directory prior to GHC 6.1 - T(expect) () =<< doesDirectoryExist rootDir + T.expect _t () =<< doesDirectoryExist rootDir createDirectory "somedir" - T(expect) () . not =<< doesDirectoryExist "" - T(expect) () . not =<< doesDirectoryExist "nonexistent" - T(expect) () =<< doesDirectoryExist "." - T(expect) () =<< doesDirectoryExist "somedir" + T.expect _t () . not =<< doesDirectoryExist "" + T.expect _t () . not =<< doesDirectoryExist "nonexistent" + T.expect _t () =<< doesDirectoryExist "." + T.expect _t () =<< doesDirectoryExist "somedir" #if defined(mingw32_HOST_OS) - T(expect) () =<< doesDirectoryExist "SoMeDiR" + T.expect _t () =<< doesDirectoryExist "SoMeDiR" #endif where diff --git a/tests/DoesPathExist.hs b/tests/DoesPathExist.hs --- a/tests/DoesPathExist.hs +++ b/tests/DoesPathExist.hs @@ -1,27 +1,46 @@ {-# LANGUAGE CPP #-} module DoesPathExist where -#include "util.inl" +import Prelude () +import System.Directory.Internal.Prelude +import System.Directory.OsPath +import TestUtils (supportsSymlinks) +import Util (TestEnv) +import qualified Util as T main :: TestEnv -> IO () main _t = do - T(expect) () =<< doesPathExist rootDir + T.expect _t () =<< doesPathExist rootDir createDirectory "somedir" writeFile "somefile" "somedata" writeFile "\x3c0\x42f\x97f3\xe6\x221e" "somedata" - T(expect) () . not =<< doesPathExist "" - T(expect) () . not =<< doesPathExist "nonexistent" - T(expect) () =<< doesPathExist "." - T(expect) () =<< doesPathExist "somedir" - T(expect) () =<< doesPathExist "somefile" - T(expect) () =<< doesPathExist "./somefile" + T.expect _t () . not =<< doesPathExist "" + T.expect _t () . not =<< doesPathExist "nonexistent" + T.expect _t () =<< doesPathExist "." + T.expect _t () =<< doesPathExist "somedir" + T.expect _t () =<< doesPathExist "somefile" + T.expect _t () =<< doesPathExist "./somefile" #if defined(mingw32_HOST_OS) - T(expect) () =<< doesPathExist "SoMeDiR" - T(expect) () =<< doesPathExist "sOmEfIlE" + T.expect _t () =<< doesPathExist "SoMeDiR" + T.expect _t () =<< doesPathExist "sOmEfIlE" #endif - T(expect) () =<< doesPathExist "\x3c0\x42f\x97f3\xe6\x221e" + T.expect _t () =<< doesPathExist "\x3c0\x42f\x97f3\xe6\x221e" + + supportsSymbolicLinks <- supportsSymlinks + when supportsSymbolicLinks $ do + + createDirectoryLink "somedir" "somedirlink" + createFileLink "somefile" "somefilelink" + createFileLink "nonexistent" "nonexistentlink" + + T.expect _t () =<< doesFileExist "somefilelink" + T.expect _t () . not =<< doesDirectoryExist "somefilelink" + T.expect _t () =<< doesDirectoryExist "somedirlink" + T.expect _t () . not =<< doesFileExist "somedirlink" + T.expect _t () . not =<< doesDirectoryExist "nonexistentlink" + T.expect _t () . not =<< doesFileExist "nonexistentlink" where #if defined(mingw32_HOST_OS) diff --git a/tests/FileTime.hs b/tests/FileTime.hs --- a/tests/FileTime.hs +++ b/tests/FileTime.hs @@ -1,6 +1,10 @@ -{-# LANGUAGE CPP #-} module FileTime where -#include "util.inl" +import Prelude () +import System.Directory.Internal.Prelude +import System.Directory.OsPath +import TestUtils () +import Util (TestEnv) +import qualified Util as T import Data.Time.Clock (addUTCTime, getCurrentTime) main :: TestEnv -> IO () @@ -9,13 +13,13 @@ let someTimeAgo = addUTCTime (-3600) now someTimeAgo' = addUTCTime (-7200) now - T(expectIOErrorType) () isDoesNotExistError $ + T.expectIOErrorType _t () isDoesNotExistError $ getAccessTime "nonexistent-file" - T(expectIOErrorType) () isDoesNotExistError $ + T.expectIOErrorType _t () isDoesNotExistError $ setAccessTime "nonexistent-file" someTimeAgo - T(expectIOErrorType) () isDoesNotExistError $ + T.expectIOErrorType _t () isDoesNotExistError $ getModificationTime "nonexistent-file" - T(expectIOErrorType) () isDoesNotExistError $ + T.expectIOErrorType _t () isDoesNotExistError $ setModificationTime "nonexistent-file" someTimeAgo writeFile "foo" "" @@ -31,11 +35,11 @@ mtime2 <- getModificationTime file -- modification time should be set with at worst 1 sec resolution - T(expectNearTime) file mtime mtime2 1 + T.expectNearTime _t file mtime mtime2 1 -- access time should not change, although it may lose some precision -- on POSIX systems without 'utimensat' - T(expectNearTime) file atime1 atime2 1 + T.expectNearTime _t file atime1 atime2 1 setAccessTime file atime @@ -44,11 +48,11 @@ when setAtime $ do -- access time should be set with at worst 1 sec resolution - T(expectNearTime) file atime atime3 1 + T.expectNearTime _t file atime atime3 1 -- modification time should not change, although it may lose some precision -- on POSIX systems without 'utimensat' - T(expectNearTime) file mtime2 mtime3 1 + T.expectNearTime _t file mtime2 mtime3 1 where diff --git a/tests/FindExecutable.hs b/tests/FindExecutable.hs new file mode 100644 --- /dev/null +++ b/tests/FindExecutable.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE CPP #-} +module FindExecutable where +import Prelude () +import System.Directory.Internal.Prelude +import System.Directory.OsPath +import TestUtils () +import Util (TestEnv) +import qualified Util as T + +main :: TestEnv -> IO () +main _t = do + + -- 'find' expected to exist on both Windows and POSIX, + -- though we have no idea if it's writable + Just _ <- findExecutable "find" + + T.expectEq _t () Nothing =<< + findExecutable "__nonexistent_binary_gbowyxcejjawf7r6__" + + -- https://github.com/haskell/directory/issues/187 + T.expectEq _t () Nothing =<< findExecutable "/" + T.expectEq _t () Nothing =<< findExecutable "//" +#if !defined(mingw32_HOST_OS) + T.expectEq _t () Nothing =<< findExecutable "\\" + T.expectEq _t () Nothing =<< findExecutable "\\\\" + T.expectEq _t () Nothing =<< findExecutable "\\\\localhost\\c$" +#endif diff --git a/tests/FindFile001.hs b/tests/FindFile001.hs --- a/tests/FindFile001.hs +++ b/tests/FindFile001.hs @@ -1,8 +1,13 @@ -{-# LANGUAGE CPP #-} module FindFile001 where -#include "util.inl" +import Prelude () +import System.Directory.Internal.Prelude +import System.Directory.Internal +import System.Directory.OsPath +import TestUtils () +import Util (TestEnv) +import qualified Util as T import qualified Data.List as List -import System.FilePath (()) +import System.OsPath (()) main :: TestEnv -> IO () main _t = do @@ -10,42 +15,44 @@ 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" + T.expectEq _t () (Just ("." "foo")) =<< findFile ("." : undefined) "foo" -- make sure relative paths work - T(expectEq) () (Just ("." "bar" "foo")) =<< + T.expectEq _t () (Just ("." "bar" "foo")) =<< findFile ["."] ("bar" "foo") - T(expectEq) () (Just ("." "foo")) =<< findFile [".", "bar"] ("foo") - T(expectEq) () (Just ("bar" "foo")) =<< findFile ["bar", "."] ("foo") + T.expectEq _t () (Just ("." "foo")) =<< findFile [".", "bar"] "foo" + T.expectEq _t () (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 + match0 : _ <- pure match + noMatch0 : _ <- pure noMatch - T(expectEq) ds (Just (List.head match "foo")) =<< + T.expectEq _t ds (Just (match0 "foo")) =<< findFileWith f ds "foo" - T(expectEq) ds (( "foo") <$> match) =<< findFilesWith f ds "foo" + T.expectEq _t ds (( "foo") <$> match) =<< findFilesWith f ds "foo" - T(expectEq) ds (Just (List.head noMatch "foo")) =<< + T.expectEq _t ds (Just (noMatch0 "foo")) =<< findFileWith ((not <$>) . f) ds "foo" - T(expectEq) ds (( "foo") <$> noMatch) =<< + T.expectEq _t ds (( "foo") <$> noMatch) =<< findFilesWith ((not <$>) . f) ds "foo" - T(expectEq) ds Nothing =<< findFileWith (\ _ -> return False) ds "foo" + T.expectEq _t ds Nothing =<< findFileWith (\ _ -> pure False) ds "foo" - T(expectEq) ds [] =<< findFilesWith (\ _ -> return False) ds "foo" + T.expectEq _t ds [] =<< findFilesWith (\ _ -> pure False) ds "foo" -- make sure absolute paths are handled properly irrespective of 'dirs' -- https://github.com/haskell/directory/issues/72 absPath <- makeAbsolute ("bar" "foo") absPath2 <- makeAbsolute ("bar" "nonexistent") - T(expectEq) () (Just absPath) =<< findFile [] absPath - T(expectEq) () Nothing =<< findFile [] absPath2 + T.expectEq _t () (Just absPath) =<< findFile [] absPath + T.expectEq _t () Nothing =<< findFile [] absPath2 diff --git a/tests/GetDirContents001.hs b/tests/GetDirContents001.hs --- a/tests/GetDirContents001.hs +++ b/tests/GetDirContents001.hs @@ -1,23 +1,28 @@ -{-# LANGUAGE CPP #-} module GetDirContents001 where -#include "util.inl" -import System.FilePath (()) +import Prelude () +import System.Directory.Internal.Prelude +import System.Directory.Internal +import System.Directory.OsPath +import TestUtils () +import Util (TestEnv) +import qualified Util as T +import System.OsPath (()) import qualified Data.List as List main :: TestEnv -> IO () main _t = do createDirectory dir - T(expectEq) () specials . List.sort =<< + T.expectEq _t () specials . List.sort =<< getDirectoryContents dir - T(expectEq) () [] . List.sort =<< + T.expectEq _t () [] . List.sort =<< listDirectory dir names <- for [1 .. 100 :: Int] $ \ i -> do - let name = 'f' : show i - writeFile (dir name) "" - return name - T(expectEq) () (List.sort (specials <> names)) . List.sort =<< + let name = "f" <> os (show i) + writeFile (so (dir name)) "" + pure name + T.expectEq _t () (List.sort (specials <> names)) . List.sort =<< getDirectoryContents dir - T(expectEq) () (List.sort names) . List.sort =<< + T.expectEq _t () (List.sort names) . List.sort =<< listDirectory dir where dir = "dir" specials = [".", ".."] diff --git a/tests/GetDirContents002.hs b/tests/GetDirContents002.hs --- a/tests/GetDirContents002.hs +++ b/tests/GetDirContents002.hs @@ -1,8 +1,12 @@ -{-# LANGUAGE CPP #-} module GetDirContents002 where -#include "util.inl" +import Prelude () +import System.Directory.Internal.Prelude +import System.Directory.OsPath +import TestUtils () +import Util (TestEnv) +import qualified Util as T main :: TestEnv -> IO () main _t = do - T(expectIOErrorType) () isDoesNotExistError $ + T.expectIOErrorType _t () isDoesNotExistError $ getDirectoryContents "nonexistent" diff --git a/tests/GetFileSize.hs b/tests/GetFileSize.hs --- a/tests/GetFileSize.hs +++ b/tests/GetFileSize.hs @@ -1,17 +1,19 @@ -{-# LANGUAGE CPP #-} module GetFileSize where -#include "util.inl" +import Prelude () +import System.Directory.Internal.Prelude +import System.Directory.OsPath +import TestUtils () +import Util (TestEnv) +import qualified Util as T 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" + T.expectEq _t () 0 =<< getFileSize "emptyfile" + T.expectEq _t () (fromIntegral (length string)) =<< getFileSize "testfile" where string = "The quick brown fox jumps over the lazy dog." diff --git a/tests/GetHomeDirectory001.hs b/tests/GetHomeDirectory001.hs --- a/tests/GetHomeDirectory001.hs +++ b/tests/GetHomeDirectory001.hs @@ -1,16 +1,20 @@ -{-# LANGUAGE CPP #-} module GetHomeDirectory001 where -#include "util.inl" +import Prelude () +import System.Directory.Internal.Prelude +import System.Directory.OsPath +import TestUtils () +import Util (TestEnv) +import qualified Util as T main :: TestEnv -> IO () main _t = do homeDir <- getHomeDirectory - T(expect) () (homeDir /= "") -- sanity check + T.expect _t () (homeDir /= mempty) -- sanity check _ <- getAppUserDataDirectory "test" _ <- getXdgDirectory XdgCache "test" _ <- getXdgDirectory XdgConfig "test" _ <- getXdgDirectory XdgData "test" - _ <- getXdgDirectory XdgCache "test" + _ <- getXdgDirectory XdgState "test" _ <- getUserDocumentsDirectory _ <- getTemporaryDirectory - return () + pure () diff --git a/tests/GetHomeDirectory002.hs b/tests/GetHomeDirectory002.hs --- a/tests/GetHomeDirectory002.hs +++ b/tests/GetHomeDirectory002.hs @@ -4,7 +4,12 @@ #if !defined(mingw32_HOST_OS) import System.Posix.Env #endif -#include "util.inl" +import Prelude () +import System.Directory.Internal.Prelude +import System.Directory.OsPath +import TestUtils () +import Util (TestEnv) +import qualified Util as T -- Test that the getpwuid_r fallback works. -- This is only relevant on unix. @@ -14,4 +19,4 @@ unsetEnv "HOME" #endif _ <- getHomeDirectory - T(expect) () True -- avoid warnings about redundant imports + T.expect _t () True -- avoid warnings about redundant imports diff --git a/tests/GetPermissions001.hs b/tests/GetPermissions001.hs --- a/tests/GetPermissions001.hs +++ b/tests/GetPermissions001.hs @@ -1,7 +1,10 @@ -{-# LANGUAGE CPP #-} module GetPermissions001 where -#include "util.inl" +import Prelude () +import System.Directory.Internal.Prelude +import System.Directory.OsPath import TestUtils +import Util (TestEnv) +import qualified Util as T main :: TestEnv -> IO () main _t = do @@ -15,15 +18,15 @@ writeFile "foo.txt" "" foo <- makeAbsolute "foo.txt" modifyPermissions "foo.txt" (\ p -> p { writable = False }) - T(expect) () =<< not . writable <$> getPermissions "foo.txt" + T.expect _t () =<< not . writable <$> getPermissions "foo.txt" modifyPermissions "foo.txt" (\ p -> p { writable = True }) - T(expect) () =<< writable <$> getPermissions "foo.txt" + T.expect _t () =<< writable <$> getPermissions "foo.txt" modifyPermissions "foo.txt" (\ p -> p { writable = False }) - T(expect) () =<< not . writable <$> getPermissions "foo.txt" + T.expect _t () =<< not . writable <$> getPermissions "foo.txt" modifyPermissions foo (\ p -> p { writable = True }) - T(expect) () =<< writable <$> getPermissions foo + T.expect _t () =<< writable <$> getPermissions foo modifyPermissions foo (\ p -> p { writable = False }) - T(expect) () =<< not . writable <$> getPermissions foo + T.expect _t () =<< not . writable <$> getPermissions foo -- test empty path modifyPermissions "" id @@ -34,31 +37,31 @@ -- since the current directory is created by the test runner, -- it should be readable, writable, and searchable p <- getPermissions "." - T(expect) () (readable p) - T(expect) () (writable p) - T(expect) () (not (executable p)) - T(expect) () (searchable p) + T.expect _t () (readable p) + T.expect _t () (writable p) + T.expect _t () (not (executable p)) + T.expect _t () (searchable p) checkExecutable = do -- 'find' expected to exist on both Windows and POSIX, -- though we have no idea if it's writable Just f <- findExecutable "find" p <- getPermissions f - T(expect) () (readable p) - T(expect) () (executable p) - T(expect) () (not (searchable p)) + T.expect _t () (readable p) + T.expect _t () (executable p) + T.expect _t () (not (searchable p)) checkOrdinary = do writeFile "foo" "" p <- getPermissions "foo" - T(expect) () (readable p) - T(expect) () (writable p) - T(expect) () (not (executable p)) - T(expect) () (not (searchable p)) + T.expect _t () (readable p) + T.expect _t () (writable p) + T.expect _t () (not (executable p)) + T.expect _t () (not (searchable p)) -- [regression test] (issue #9) -- Windows doesn't like trailing path separators checkTrailingSlash = do createDirectory "bar" _ <- getPermissions "bar/" - return () + pure () diff --git a/tests/LongPaths.hs b/tests/LongPaths.hs --- a/tests/LongPaths.hs +++ b/tests/LongPaths.hs @@ -1,8 +1,11 @@ -{-# LANGUAGE CPP #-} module LongPaths where -#include "util.inl" +import Prelude () +import System.Directory.Internal.Prelude +import System.Directory.OsPath import TestUtils -import System.FilePath (()) +import Util (TestEnv) +import qualified Util as T +import System.OsPath (()) main :: TestEnv -> IO () main _t = do @@ -14,9 +17,9 @@ -- tests: [createDirectory] createDirectory =<< makeAbsolute longName createDirectory longDir - return True + pure True `catchIOError` \ _ -> - return False + pure False -- skip tests on file systems that do not support long paths when supportsLongPaths $ do @@ -24,10 +27,10 @@ -- test relative paths let relDir = longName mconcat (replicate 8 "yeah_its_long") createDirectory relDir - T(expect) () =<< doesDirectoryExist relDir - T(expectEq) () [] =<< listDirectory relDir + T.expect _t () =<< doesDirectoryExist relDir + T.expectEq _t () [] =<< listDirectory relDir setPermissions relDir emptyPermissions - T(expectEq) () False =<< writable <$> getPermissions relDir + T.expectEq _t () False =<< writable <$> getPermissions relDir writeFile "foobar.txt" "^.^" -- writeFile does not support long paths yet @@ -38,13 +41,13 @@ (longDir "foobar_copy.txt") -- tests: [doesDirectoryExist], [doesFileExist], [doesPathExist] - T(expect) () =<< doesDirectoryExist longDir - T(expect) () =<< doesFileExist (longDir "foobar.txt") - T(expect) () =<< doesPathExist longDir - T(expect) () =<< doesPathExist (longDir "foobar.txt") + T.expect _t () =<< doesDirectoryExist longDir + T.expect _t () =<< doesFileExist (longDir "foobar.txt") + T.expect _t () =<< doesPathExist longDir + T.expect _t () =<< doesPathExist (longDir "foobar.txt") -- tests: [getFileSize], [getModificationTime] - T(expectEq) () 3 =<< getFileSize (longDir "foobar.txt") + T.expectEq _t () 3 =<< getFileSize (longDir "foobar.txt") _ <- getModificationTime (longDir "foobar.txt") supportsSymbolicLinks <- supportsSymlinks @@ -54,8 +57,9 @@ -- also tests expansion of "." and ".." createDirectoryLink "." (longDir "link") _ <- listDirectory (longDir ".." longName "link") - T(expectEq) () "." =<< getSymbolicLinkTarget (longDir "." "link") + T.expectEq _t () "." =<< + getSymbolicLinkTarget (longDir "." "link") - return () + pure () -- [removeFile], [removeDirectory] are automatically tested by the cleanup diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -11,6 +11,7 @@ import qualified DoesDirectoryExist001 import qualified DoesPathExist import qualified FileTime +import qualified FindExecutable import qualified FindFile001 import qualified GetDirContents001 import qualified GetDirContents002 @@ -27,7 +28,6 @@ import qualified RenameDirectory import qualified RenameFile001 import qualified RenamePath -import qualified Safe import qualified Simplify import qualified T8482 import qualified WithCurrentDirectory @@ -46,6 +46,7 @@ T.isolatedRun _t "DoesDirectoryExist001" DoesDirectoryExist001.main T.isolatedRun _t "DoesPathExist" DoesPathExist.main T.isolatedRun _t "FileTime" FileTime.main + T.isolatedRun _t "FindExecutable" FindExecutable.main T.isolatedRun _t "FindFile001" FindFile001.main T.isolatedRun _t "GetDirContents001" GetDirContents001.main T.isolatedRun _t "GetDirContents002" GetDirContents002.main @@ -62,7 +63,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,16 @@ {-# LANGUAGE CPP #-} module MakeAbsolute where -#include "util.inl" -import System.FilePath ((), addTrailingPathSeparator, - dropTrailingPathSeparator, normalise) +import Prelude () +import System.Directory.Internal.Prelude +import System.Directory.OsPath +import TestUtils () +import Util (TestEnv) +import qualified Util as T +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 () @@ -12,35 +18,36 @@ dot <- makeAbsolute "" dot2 <- makeAbsolute "." dot3 <- makeAbsolute "./." - T(expectEq) () dot (dropTrailingPathSeparator dot) - T(expectEq) () dot dot2 - T(expectEq) () dot dot3 + T.expectEq _t () dot (dropTrailingPathSeparator dot) + T.expectEq _t () dot dot2 + T.expectEq _t () dot dot3 sdot <- makeAbsolute "./" sdot2 <- makeAbsolute "././" - T(expectEq) () sdot (addTrailingPathSeparator sdot) - T(expectEq) () sdot sdot2 + T.expectEq _t () sdot (addTrailingPathSeparator sdot) + T.expectEq _t () sdot sdot2 foo <- makeAbsolute "foo" foo2 <- makeAbsolute "foo/." foo3 <- makeAbsolute "./foo" - T(expectEq) () foo (normalise (dot "foo")) - T(expectEq) () foo foo2 - T(expectEq) () foo foo3 + T.expectEq _t () foo (normalise (dot "foo")) + T.expectEq _t () foo foo2 + T.expectEq _t () foo foo3 sfoo <- makeAbsolute "foo/" sfoo2 <- makeAbsolute "foo/./" sfoo3 <- makeAbsolute "./foo/" - T(expectEq) () sfoo (normalise (dot "foo/")) - T(expectEq) () sfoo sfoo2 - T(expectEq) () sfoo sfoo3 + T.expectEq _t () sfoo (normalise (dot "foo/")) + T.expectEq _t () sfoo sfoo2 + T.expectEq _t () sfoo sfoo3 #if defined(mingw32_HOST_OS) cwd <- getCurrentDirectory - let driveLetter = toUpper (head (takeDrive cwd)) + cwdDriveLetter : _ <- pure (unpack (takeDrive cwd)) + let driveLetter = toUpper (toChar cwdDriveLetter) let driveLetter' = if driveLetter == 'Z' then 'A' else succ driveLetter - drp1 <- makeAbsolute (driveLetter : ":foobar") - drp2 <- makeAbsolute (driveLetter' : ":foobar") - T(expectEq) () drp1 =<< makeAbsolute "foobar" - T(expectEq) () drp2 (driveLetter' : ":\\foobar") + drp1 <- makeAbsolute (os (driveLetter : ":foobar")) + drp2 <- makeAbsolute (os (driveLetter' : ":foobar")) + T.expectEq _t () drp1 =<< makeAbsolute "foobar" + T.expectEq _t () drp2 (os (driveLetter' : ":\\foobar")) #endif diff --git a/tests/MinimizeNameConflicts.hs b/tests/MinimizeNameConflicts.hs --- a/tests/MinimizeNameConflicts.hs +++ b/tests/MinimizeNameConflicts.hs @@ -1,14 +1,19 @@ {-# LANGUAGE CPP #-} module MinimizeNameConflicts ( main - , module System.Directory + , module System.Directory.OsPath #if defined(mingw32_HOST_OS) , module System.Win32 #else , module System.Posix #endif ) where -#include "util.inl" +import Prelude () +import System.Directory.Internal.Prelude +import System.Directory.OsPath +import TestUtils () +import Util (TestEnv) +import qualified Util as T #if defined(mingw32_HOST_OS) import System.Win32 hiding ( copyFile @@ -31,4 +36,4 @@ -- https://github.com/haskell/directory/issues/52 main :: TestEnv -> IO () main _t = do - T(expect) "no-op" True + T.expect _t ("no-op" :: String) True diff --git a/tests/PathIsSymbolicLink.hs b/tests/PathIsSymbolicLink.hs --- a/tests/PathIsSymbolicLink.hs +++ b/tests/PathIsSymbolicLink.hs @@ -1,7 +1,10 @@ -{-# LANGUAGE CPP #-} module PathIsSymbolicLink where -#include "util.inl" +import Prelude () +import System.Directory.Internal.Prelude +import System.Directory.OsPath import TestUtils +import Util (TestEnv) +import qualified Util as T main :: TestEnv -> IO () main _t = do @@ -11,23 +14,23 @@ createFileLink "x" "y" createDirectoryLink "a" "b" - T(expect) () =<< pathIsSymbolicLink "y" - T(expect) () =<< pathIsSymbolicLink "b" - T(expectEq) () "x" =<< getSymbolicLinkTarget "y" - T(expectEq) () "a" =<< getSymbolicLinkTarget "b" - T(expectEq) () False =<< doesFileExist "y" - T(expectEq) () False =<< doesDirectoryExist "b" + T.expect _t () =<< pathIsSymbolicLink "y" + T.expect _t () =<< pathIsSymbolicLink "b" + T.expectEq _t () "x" =<< getSymbolicLinkTarget "y" + T.expectEq _t () "a" =<< getSymbolicLinkTarget "b" + T.expectEq _t () False =<< doesFileExist "y" + T.expectEq _t () False =<< doesDirectoryExist "b" writeFile "x" "" createDirectory "a" - T(expect) () =<< doesFileExist "y" - T(expect) () =<< doesDirectoryExist "b" + T.expect _t () =<< doesFileExist "y" + T.expect _t () =<< doesDirectoryExist "b" removeFile "y" removeDirectoryLink "b" - T(expectIOErrorType) () isDoesNotExistError (pathIsSymbolicLink "y") - T(expectIOErrorType) () isDoesNotExistError (pathIsSymbolicLink "b") - T(expectEq) () False =<< doesFileExist "y" - T(expectEq) () False =<< doesDirectoryExist "b" + T.expectIOErrorType _t () isDoesNotExistError (pathIsSymbolicLink "y") + T.expectIOErrorType _t () isDoesNotExistError (pathIsSymbolicLink "b") + T.expectEq _t () False =<< doesFileExist "y" + T.expectEq _t () False =<< doesDirectoryExist "b" diff --git a/tests/RemoveDirectoryRecursive001.hs b/tests/RemoveDirectoryRecursive001.hs --- a/tests/RemoveDirectoryRecursive001.hs +++ b/tests/RemoveDirectoryRecursive001.hs @@ -1,9 +1,14 @@ {-# LANGUAGE CPP #-} module RemoveDirectoryRecursive001 where -#include "util.inl" -import System.FilePath ((), normalise) +import Prelude () +import System.Directory.Internal.Prelude +import System.Directory.Internal +import System.Directory.OsPath +import TestUtils (modifyPermissions, symlinkOrCopy) +import Util (TestEnv) +import qualified Util as T +import System.OsPath ((), normalise) import qualified Data.List as List -import TestUtils main :: TestEnv -> IO () main _t = do @@ -12,9 +17,9 @@ -- clean up junk from previous invocations modifyPermissions (tmp "c") (\ p -> p { writable = True }) - `catchIOError` \ _ -> return () + `catchIOError` \ _ -> pure () removeDirectoryRecursive tmpD - `catchIOError` \ _ -> return () + `catchIOError` \ _ -> pure () ------------------------------------------------------------ -- set up @@ -24,8 +29,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") @@ -34,15 +39,15 @@ ------------------------------------------------------------ -- tests - T(expectEq) () [".", "..", "a", "b", "c", "d"] . List.sort =<< + T.expectEq _t () [".", "..", "a", "b", "c", "d"] . List.sort =<< getDirectoryContents tmpD - T(expectEq) () [".", "..", "t", "x", "y", "z"] . List.sort =<< + T.expectEq _t () [".", "..", "t", "x", "y", "z"] . List.sort =<< getDirectoryContents (tmp "a") - T(expectEq) () [".", "..", "g"] . List.sort =<< + T.expectEq _t () [".", "..", "g"] . List.sort =<< getDirectoryContents (tmp "b") - T(expectEq) () [".", "..", "h"] . List.sort =<< + T.expectEq _t () [".", "..", "h"] . List.sort =<< getDirectoryContents (tmp "c") - T(expectEq) () [".", "..", "t", "x", "y", "z"] . List.sort =<< + T.expectEq _t () [".", "..", "t", "x", "y", "z"] . List.sort =<< getDirectoryContents (tmp "d") removeDirectoryRecursive (tmp "d") @@ -51,13 +56,13 @@ `catchIOError` \ _ -> removeDirectory (tmp "d") #endif - T(expectEq) () [".", "..", "a", "b", "c"] . List.sort =<< + T.expectEq _t () [".", "..", "a", "b", "c"] . List.sort =<< getDirectoryContents tmpD - T(expectEq) () [".", "..", "t", "x", "y", "z"] . List.sort =<< + T.expectEq _t () [".", "..", "t", "x", "y", "z"] . List.sort =<< getDirectoryContents (tmp "a") - T(expectEq) () [".", "..", "g"] . List.sort =<< + T.expectEq _t () [".", "..", "g"] . List.sort =<< getDirectoryContents (tmp "b") - T(expectEq) () [".", "..", "h"] . List.sort =<< + T.expectEq _t () [".", "..", "h"] . List.sort =<< getDirectoryContents (tmp "c") removeDirectoryRecursive (tmp "c") @@ -65,25 +70,25 @@ modifyPermissions (tmp "c") (\ p -> p { writable = True }) removeDirectoryRecursive (tmp "c") - T(expectEq) () [".", "..", "a", "b"] . List.sort =<< + T.expectEq _t () [".", "..", "a", "b"] . List.sort =<< getDirectoryContents tmpD - T(expectEq) () [".", "..", "t", "x", "y", "z"] . List.sort =<< + T.expectEq _t () [".", "..", "t", "x", "y", "z"] . List.sort =<< getDirectoryContents (tmp "a") - T(expectEq) () [".", "..", "g"] . List.sort =<< + T.expectEq _t () [".", "..", "g"] . List.sort =<< getDirectoryContents (tmp "b") removeDirectoryRecursive (tmp "b") - T(expectEq) () [".", "..", "a"] . List.sort =<< + T.expectEq _t () [".", "..", "a"] . List.sort =<< getDirectoryContents tmpD - T(expectEq) () [".", "..", "t", "x", "y", "z"] . List.sort =<< + T.expectEq _t () [".", "..", "t", "x", "y", "z"] . List.sort =<< getDirectoryContents (tmp "a") removeDirectoryRecursive (tmp "a") - T(expectEq) () [".", ".."] . List.sort =<< + T.expectEq _t () [".", ".."] . List.sort =<< 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,13 @@ -{-# LANGUAGE CPP #-} module RemovePathForcibly where -#include "util.inl" -import System.FilePath ((), normalise) +import Prelude () +import System.Directory.Internal.Prelude +import System.Directory.OsPath +import TestUtils (hardLinkOrCopy, modifyPermissions, symlinkOrCopy) +import Util (TestEnv) +import qualified Util as T +import System.Directory.Internal +import System.OsPath ((), normalise) import qualified Data.List as List -import TestUtils main :: TestEnv -> IO () main _t = do @@ -12,9 +16,9 @@ -- clean up junk from previous invocations modifyPermissions (tmp "c") (\ p -> p { writable = True }) - `catchIOError` \ _ -> return () + `catchIOError` \ _ -> pure () removePathForcibly tmpD - `catchIOError` \ _ -> return () + `catchIOError` \ _ -> pure () ------------------------------------------------------------ -- set up @@ -25,9 +29,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") @@ -40,49 +44,59 @@ removePathForcibly (tmp "f") removePathForcibly (tmp "e") -- intentionally non-existent - T(expectEq) () [".", "..", "a", "b", "c", "d"] . List.sort =<< + T.expectEq _t () [".", "..", "a", "b", "c", "d"] . List.sort =<< getDirectoryContents tmpD - T(expectEq) () [".", "..", "t", "x", "y", "z"] . List.sort =<< + T.expectEq _t () [".", "..", "t", "x", "y", "z"] . List.sort =<< getDirectoryContents (tmp "a") - T(expectEq) () [".", "..", "g"] . List.sort =<< + T.expectEq _t () [".", "..", "g"] . List.sort =<< getDirectoryContents (tmp "b") - T(expectEq) () [".", "..", "h"] . List.sort =<< + T.expectEq _t () [".", "..", "h"] . List.sort =<< getDirectoryContents (tmp "c") - T(expectEq) () [".", "..", "t", "x", "y", "z"] . List.sort =<< + T.expectEq _t () [".", "..", "t", "x", "y", "z"] . List.sort =<< getDirectoryContents (tmp "d") removePathForcibly (tmp "d") - T(expectEq) () [".", "..", "a", "b", "c"] . List.sort =<< + T.expectEq _t () [".", "..", "a", "b", "c"] . List.sort =<< getDirectoryContents tmpD - T(expectEq) () [".", "..", "t", "x", "y", "z"] . List.sort =<< + T.expectEq _t () [".", "..", "t", "x", "y", "z"] . List.sort =<< getDirectoryContents (tmp "a") - T(expectEq) () [".", "..", "g"] . List.sort =<< + T.expectEq _t () [".", "..", "g"] . List.sort =<< getDirectoryContents (tmp "b") - T(expectEq) () [".", "..", "h"] . List.sort =<< + T.expectEq _t () [".", "..", "h"] . List.sort =<< getDirectoryContents (tmp "c") removePathForcibly (tmp "c") - T(expectEq) () [".", "..", "a", "b"] . List.sort =<< + T.expectEq _t () [".", "..", "a", "b"] . List.sort =<< getDirectoryContents tmpD - T(expectEq) () [".", "..", "t", "x", "y", "z"] . List.sort =<< + T.expectEq _t () [".", "..", "t", "x", "y", "z"] . List.sort =<< getDirectoryContents (tmp "a") - T(expectEq) () [".", "..", "g"] . List.sort =<< + T.expectEq _t () [".", "..", "g"] . List.sort =<< getDirectoryContents (tmp "b") removePathForcibly (tmp "b") - T(expectEq) () [".", "..", "a"] . List.sort =<< + T.expectEq _t () [".", "..", "a"] . List.sort =<< getDirectoryContents tmpD - T(expectEq) () [".", "..", "t", "x", "y", "z"] . List.sort =<< + T.expectEq _t () [".", "..", "t", "x", "y", "z"] . List.sort =<< getDirectoryContents (tmp "a") removePathForcibly (tmp "a") - T(expectEq) () [".", ".."] . List.sort =<< + T.expectEq _t () [".", ".."] . 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 _t () origPermissions =<< getPermissions "hl1" + where testName = "removePathForcibly" - tmpD = testName ++ ".tmp" + tmpD = testName <> ".tmp" tmp s = tmpD normalise s diff --git a/tests/RenameDirectory.hs b/tests/RenameDirectory.hs --- a/tests/RenameDirectory.hs +++ b/tests/RenameDirectory.hs @@ -1,10 +1,14 @@ -{-# LANGUAGE CPP #-} module RenameDirectory where -#include "util.inl" +import Prelude () +import System.Directory.Internal.Prelude +import System.Directory.OsPath +import TestUtils () +import Util (TestEnv) +import qualified Util as T main :: TestEnv -> IO () main _t = do createDirectory "a" - T(expectEq) () ["a"] =<< listDirectory "." + T.expectEq _t () ["a"] =<< listDirectory "." renameDirectory "a" "b" - T(expectEq) () ["b"] =<< listDirectory "." + T.expectEq _t () ["b"] =<< listDirectory "." diff --git a/tests/RenameFile001.hs b/tests/RenameFile001.hs --- a/tests/RenameFile001.hs +++ b/tests/RenameFile001.hs @@ -1,15 +1,20 @@ -{-# LANGUAGE CPP #-} module RenameFile001 where -#include "util.inl" +import Prelude () +import System.Directory.Internal.Prelude +import System.Directory.Internal +import System.Directory.OsPath +import TestUtils () +import Util (TestEnv) +import qualified Util as T main :: TestEnv -> IO () main _t = do writeFile tmp1 contents1 - renameFile tmp1 tmp2 - T(expectEq) () contents1 =<< readFile tmp2 + renameFile (os tmp1) (os tmp2) + T.expectEq _t () contents1 =<< readFile tmp2 writeFile tmp1 contents2 - renameFile tmp2 tmp1 - T(expectEq) () contents1 =<< readFile tmp1 + renameFile (os tmp2) (os tmp1) + T.expectEq _t () contents1 =<< readFile tmp1 where tmp1 = "tmp1" tmp2 = "tmp2" diff --git a/tests/RenamePath.hs b/tests/RenamePath.hs --- a/tests/RenamePath.hs +++ b/tests/RenamePath.hs @@ -1,21 +1,26 @@ -{-# LANGUAGE CPP #-} module RenamePath where -#include "util.inl" +import Prelude () +import System.Directory.Internal.Prelude +import System.Directory.Internal +import System.Directory.OsPath +import TestUtils () +import Util (TestEnv) +import qualified Util as T main :: TestEnv -> IO () main _t = do createDirectory "a" - T(expectEq) () ["a"] =<< listDirectory "." + T.expectEq _t () ["a"] =<< listDirectory "." renamePath "a" "b" - T(expectEq) () ["b"] =<< listDirectory "." + T.expectEq _t () ["b"] =<< listDirectory "." writeFile tmp1 contents1 - renamePath tmp1 tmp2 - T(expectEq) () contents1 =<< readFile tmp2 + renamePath (os tmp1) (os tmp2) + T.expectEq _t () contents1 =<< readFile tmp2 writeFile tmp1 contents2 - renamePath tmp2 tmp1 - T(expectEq) () contents1 =<< readFile tmp1 + renamePath (os tmp2) (os tmp1) + T.expectEq _t () contents1 =<< readFile tmp1 where tmp1 = "tmp1" 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 @@ -1,39 +1,44 @@ {-# LANGUAGE CPP #-} module Simplify where -#include "util.inl" +import Prelude () +import System.Directory.Internal.Prelude import System.Directory.Internal (simplifyWindows) -import System.FilePath (normalise) +import System.Directory.OsPath +import TestUtils () +import Util (TestEnv) +import qualified Util as T +import System.OsPath (normalise) main :: TestEnv -> IO () main _t = do - T(expectIOErrorType) () (const True) (setCurrentDirectory "") - T(expectEq) () (simplifyWindows "") "" - T(expectEq) () (simplifyWindows ".") "." - T(expectEq) () (simplifyWindows "a///b") (normalise "a/b") - T(expectEq) () (simplifyWindows "./a//b") (normalise "a/b") - T(expectEq) () (simplifyWindows "a/../../../b/.") (normalise "../../b") - T(expectEq) () (simplifyWindows "a/.././b/./") (normalise "b/") - T(expectEq) () (simplifyWindows "C:/a/../b") (normalise "C:/b") - T(expectEq) () (simplifyWindows "\\\\?\\./a\\../b") "\\\\?\\./a\\../b" - T(expectEq) () (simplifyWindows "C:/a") (normalise "C:/a") - T(expectEq) () (simplifyWindows "/a") (normalise "/a") + T.expectIOErrorType _t () (const True) (setCurrentDirectory "") + T.expectEq _t () (simplifyWindows "") "" + T.expectEq _t () (simplifyWindows ".") "." + T.expectEq _t () (simplifyWindows "a///b") (normalise "a/b") + T.expectEq _t () (simplifyWindows "./a//b") (normalise "a/b") + T.expectEq _t () (simplifyWindows "a/../../../b/.") (normalise "../../b") + T.expectEq _t () (simplifyWindows "a/.././b/./") (normalise "b/") + T.expectEq _t () (simplifyWindows "C:/a/../b") (normalise "C:/b") + T.expectEq _t () (simplifyWindows "\\\\?\\./a\\../b") "\\\\?\\./a\\../b" + T.expectEq _t () (simplifyWindows "C:/a") (normalise "C:/a") + T.expectEq _t () (simplifyWindows "/a") (normalise "/a") #ifdef mingw32_HOST_OS - T(expectEq) () (simplifyWindows "C:") "C:" - T(expectEq) () (simplifyWindows "c:\\\\") "C:\\" - T(expectEq) () (simplifyWindows "C:.") "C:" - T(expectEq) () (simplifyWindows "C:.\\\\") "C:.\\" - T(expectEq) () (simplifyWindows "C:..") "C:.." - T(expectEq) () (simplifyWindows "C:..\\") "C:..\\" - T(expectEq) () (simplifyWindows "C:\\.\\") "C:\\" - T(expectEq) () (simplifyWindows "C:\\a") "C:\\a" - T(expectEq) () (simplifyWindows "C:\\a\\\\b\\") "C:\\a\\b\\" - T(expectEq) () (simplifyWindows "\\\\a\\b") "\\\\a\\b" - T(expectEq) () (simplifyWindows "//a\\b/c/./d") "\\\\a\\b\\c\\d" - T(expectEq) () (simplifyWindows "/.") "\\" - T(expectEq) () (simplifyWindows "/./") "\\" - T(expectEq) () (simplifyWindows "/../") "\\" - T(expectEq) () (simplifyWindows "\\a\\.") "\\a" - T(expectEq) () (simplifyWindows "//?") "\\\\?" - T(expectEq) () (simplifyWindows "//?\\") "\\\\?\\" - T(expectEq) () (simplifyWindows "//?/a/b") "\\\\?\\a/b" + T.expectEq _t () (simplifyWindows "C:") "C:" + T.expectEq _t () (simplifyWindows "c:\\\\") "C:\\" + T.expectEq _t () (simplifyWindows "C:.") "C:" + T.expectEq _t () (simplifyWindows "C:.\\\\") "C:.\\" + T.expectEq _t () (simplifyWindows "C:..") "C:.." + T.expectEq _t () (simplifyWindows "C:..\\") "C:..\\" + T.expectEq _t () (simplifyWindows "C:\\.\\") "C:\\" + T.expectEq _t () (simplifyWindows "C:\\a") "C:\\a" + T.expectEq _t () (simplifyWindows "C:\\a\\\\b\\") "C:\\a\\b\\" + T.expectEq _t () (simplifyWindows "\\\\a\\b") "\\\\a\\b" + T.expectEq _t () (simplifyWindows "//a\\b/c/./d") "\\\\a\\b/c/./d" + T.expectEq _t () (simplifyWindows "/.") "\\" + T.expectEq _t () (simplifyWindows "/./") "\\" + T.expectEq _t () (simplifyWindows "/../") "\\" + T.expectEq _t () (simplifyWindows "\\a\\.") "\\a" + T.expectEq _t () (simplifyWindows "//?") "\\\\?" + T.expectEq _t () (simplifyWindows "//?\\") "\\\\?\\" + T.expectEq _t () (simplifyWindows "//?/a/b") "\\\\?\\a/b" #endif diff --git a/tests/T8482.hs b/tests/T8482.hs --- a/tests/T8482.hs +++ b/tests/T8482.hs @@ -1,18 +1,23 @@ -{-# LANGUAGE CPP #-} module T8482 where -#include "util.inl" +import Prelude () +import System.Directory.Internal.Prelude +import System.Directory.Internal +import System.Directory.OsPath +import TestUtils () +import Util (TestEnv) +import qualified Util as T -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) - T(expectIOErrorType) () (is InappropriateType) (renameFile tmp1 ".") + T.expectIOErrorType _t () (is InappropriateType) (renameFile testdir tmp1) + T.expectIOErrorType _t () (is InappropriateType) (renameFile tmp1 testdir) + T.expectIOErrorType _t () (is InappropriateType) (renameFile tmp1 ".") where is t = (== t) . ioeGetErrorType 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 @@ -69,19 +80,19 @@ supportsSymlinks = do canCreate <- supportsLinkCreation canDeref <- supportsLinkDeref - return (canCreate && canDeref) + pure (canCreate && canDeref) -- | On Windows, test if symbolic link creation is supported and the user has -- the necessary privileges to create them. On other platforms, this always -- returns 'True'. supportsLinkCreation :: IO Bool supportsLinkCreation = do - let path = "_symlink_test.tmp" - isSupported <- handleSymlinkUnavail (return False) $ do + let path = os "_symlink_test.tmp" + isSupported <- handleSymlinkUnavail (pure False) $ do True <$ createFileLink path path when isSupported $ do removeFile path - return isSupported + pure isSupported supportsLinkDeref :: IO Bool supportsLinkDeref = do @@ -89,8 +100,11 @@ True <$ win32_getFinalPathNameByHandle Win32.nullHANDLE 0 `catchIOError` \ e -> case ioeGetErrorType e of - UnsupportedOperation -> return False - _ -> return True + UnsupportedOperation -> pure False + _ -> pure True #else - return True + pure 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 @@ -1,17 +1,15 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -- | A rudimentary testing framework 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 GHC.Stack (CallStack, HasCallStack, callStack, getCallStack, srcLocFile, + srcLocStartLine) 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 () @@ -31,7 +29,7 @@ result <- timeout (round (1000000 * time)) action case result of Nothing -> throwIO (userError "timed out") - Just x -> return x + Just x -> pure x data TestEnv = TestEnv @@ -42,7 +40,7 @@ } printInfo :: TestEnv -> [String] -> IO () -printInfo TestEnv{testSilent = True} _ = return () +printInfo TestEnv{testSilent = True} _ = pure () printInfo TestEnv{testSilent = False} msg = do putStrLn (List.intercalate ": " msg) hFlush stdout @@ -65,69 +63,72 @@ checkEither t prefix (Right msg) = printInfo t (prefix <> msg) checkEither t prefix (Left msg) = printFailure t (prefix <> msg) -showContext :: Show a => String -> Integer -> a -> String -showContext file line context = - file <> ":" <> show line <> +showContext :: Show a => CallStack -> a -> String +showContext stack context = + case getCallStack stack of + (_, l) : _ -> srcLocFile l <> ":" <> show (srcLocStartLine l) + [] -> "" + <> case show context of "()" -> "" s -> ":" <> s -inform :: TestEnv -> String -> Integer -> String -> IO () -inform t file line msg = - printInfo t [showContext file line (), msg] +inform :: HasCallStack => TestEnv -> String -> IO () +inform t msg = + printInfo t [showContext callStack (), msg] -expect :: Show a => TestEnv -> String -> Integer -> a -> Bool -> IO () -expect t file line context x = + +expect :: (HasCallStack, Show a) => TestEnv -> a -> Bool -> IO () +expect t context x = check t x - [showContext file line context] + [showContext callStack context] ["True"] ["False, but True was expected"] -expectEq :: (Eq a, Show a, Show b) => - TestEnv -> String -> Integer -> b -> a -> a -> IO () -expectEq t file line context x y = +expectEq :: (HasCallStack, Eq a, Show a, Show b) => + TestEnv -> b -> a -> a -> IO () +expectEq t context x y = check t (x == y) - [showContext file line context] + [showContext callStack context] [show x <> " equals " <> show y] [show x <> " is not equal to " <> show y] -expectNe :: (Eq a, Show a, Show b) => - TestEnv -> String -> Integer -> b -> a -> a -> IO () -expectNe t file line context x y = +expectNe :: (HasCallStack, Eq a, Show a, Show b) => + TestEnv -> b -> a -> a -> IO () +expectNe t context x y = check t (x /= y) - [showContext file line context] + [showContext callStack context] [show x <> " is not equal to " <> show y] [show x <> " equals " <> show y] -expectNear :: (Num a, Ord a, Show a, Show b) => - TestEnv -> String -> Integer -> b -> a -> a -> a -> IO () -expectNear t file line context x y diff = +expectNear :: (HasCallStack, Num a, Ord a, Show a, Show b) => + TestEnv -> b -> a -> a -> a -> IO () +expectNear t context x y diff = check t (abs (x - y) <= diff) - [showContext file line context] + [showContext callStack context] [show x <> " is near " <> show y] [show x <> " is not near " <> show y] -expectNearTime :: Show a => - TestEnv -> String -> Integer -> a -> +expectNearTime :: (HasCallStack, Show a) => + TestEnv -> a -> UTCTime -> UTCTime -> NominalDiffTime -> IO () -expectNearTime t file line context x y diff = +expectNearTime t context x y diff = check t (abs (diffUTCTime x y) <= diff) - [showContext file line context] + [showContext callStack context] [show x <> " is near " <> show y] [show x <> " is not near " <> show y] -expectIOErrorType :: Show a => - TestEnv -> String -> Integer -> a - -> (IOError -> Bool) -> IO b -> IO () -expectIOErrorType t file line context which action = do +expectIOErrorType :: (HasCallStack, Show a) => + TestEnv -> a -> (IOError -> Bool) -> IO b -> IO () +expectIOErrorType t context which action = do result <- try action - checkEither t [showContext file line context] $ case result of + checkEither t [showContext callStack context] $ case result of Left e | which e -> Right ["got expected exception (" <> show e <> ")"] | otherwise -> Left ["got wrong exception: ", show e] 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,57 +137,76 @@ 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 - where cleanup dir' | keep = return () + where cleanup dir' | keep = pure () | otherwise = removePathForcibly dir' +diffAsc' :: (j -> k -> Ordering) + -> (u -> v -> Bool) + -> [(j, u)] + -> [(k, v)] + -> ([(j, u)], [(k, v)]) +diffAsc' cmp eq = go id id + where + go a b [] [] = (a [], b []) + go a b jus [] = go (a . (jus <>)) b [] [] + go a b [] kvs = go a (b . (kvs <>)) [] [] + go a b jus@((j, u) : jus') kvs@((k, v) : kvs') = + case cmp j k of + LT -> go (a . ((j, u) :)) b jus' kvs + GT -> go a (b . ((k, v) :)) jus kvs' + EQ | eq u v -> go a b jus' kvs' + | otherwise -> go (a . ((j, u) :)) (b . ((k, v) :)) jus' kvs' + +diffAsc :: (Ord k, Eq v) => [(k, v)] -> [(k, v)] -> ([(k, v)], [(k, v)]) +diffAsc = diffAsc' compare (==) + +-- Environment variables may be sensitive, so don't log their values. +scrubEnv :: (String, String) -> (String, String) +scrubEnv (k, v) + -- Allowlist for nonsensitive variables. + | k `elem` ["XDG_CONFIG_HOME"] = (k, v) + | otherwise = (k, "<" <> show (length v) <> " chars>") + isolateEnvironment :: IO a -> IO a isolateEnvironment = bracket getEnvs setEnvs . const where - getEnvs = List.sort . filter (\(k, _) -> k /= "") <$> getEnvironment + -- Duplicate environment variables will cause problems for this code. + -- https://github.com/haskell/cabal/issues/10718 + getEnvs = List.sort . filter (\(k, _) -> not (null k)) <$> getEnvironment setEnvs target = do current <- getEnvs - updateEnvs current target + let (deletions, insertions) = diffAsc current target + updateEnvs deletions insertions new <- getEnvs when (target /= new) $ do - -- Environment variables may be sensitive, so don't log them. - throwIO (userError "isolateEnvironment.setEnvs failed") - updateEnvs kvs1@((k1, v1) : kvs1') kvs2@((k2, v2) : kvs2') = - case compare k1 k2 of - LT -> unsetEnv k1 *> updateEnvs kvs1' kvs2 - EQ | v1 == v2 -> updateEnvs kvs1' kvs2' - | otherwise -> setEnv k1 v2 *> updateEnvs kvs1' kvs2' - GT -> setEnv k2 v2 *> updateEnvs kvs1 kvs2' - 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 + let (missing, extraneous) = diffAsc target new + throwIO (userError ("isolateEnvironment.setEnvs failed:" <> + " deletions=" <> show (scrubEnv <$> deletions) <> + " insertions=" <> show (scrubEnv <$> insertions) <> + " missing=" <> show (scrubEnv <$> missing) <> + " extraneous=" <> show (scrubEnv <$> extraneous))) + updateEnvs deletions insertions = do + for_ deletions (unsetEnv . fst) + for_ insertions (uncurry setEnv) -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 removePathForcibly dir' - withNewDirectory keep dir' $ - withCurrentDirectory dir' $ + withNewDirectory keep dir' $ do + withCurrentDirectory dir' $ do action run :: TestEnv -> String -> (TestEnv -> IO ()) -> IO () @@ -194,14 +214,14 @@ result <- tryAny (action t) case result of Left e -> check t False [name] [] ["exception", show e] - Right () -> return () + Right () -> pure () 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-newstyle/tmp/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 = @@ -239,7 +259,7 @@ , testArgs = args } action t - n <- readIORef (counter) + n <- readIORef counter unless (n == 0) $ do putStrLn ("[" <> show n <> " failures]") hFlush stdout diff --git a/tests/WithCurrentDirectory.hs b/tests/WithCurrentDirectory.hs --- a/tests/WithCurrentDirectory.hs +++ b/tests/WithCurrentDirectory.hs @@ -1,22 +1,27 @@ -{-# LANGUAGE CPP #-} module WithCurrentDirectory where -#include "util.inl" -import System.FilePath (()) +import Prelude () +import System.Directory.Internal.Prelude +import System.Directory.Internal +import System.Directory.OsPath +import TestUtils () +import Util (TestEnv) +import qualified Util as T +import System.OsPath (()) import qualified Data.List as List main :: TestEnv -> IO () main _t = do createDirectory dir -- Make sure we're starting empty - T(expectEq) () [] . List.sort =<< listDirectory dir + T.expectEq _t () [] . 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 + T.expectEq _t () cwd =<< getCurrentDirectory -- Did the test file get created? - T(expectEq) () [testfile] . List.sort =<< listDirectory dir + T.expectEq _t () [testfile] . List.sort =<< listDirectory dir -- Does the file contain what we expected to write? - T(expectEq) () contents =<< readFile (dir testfile) + T.expectEq _t () 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,14 +1,17 @@ {-# LANGUAGE CPP #-} module Xdg where -#if MIN_VERSION_base(4, 7, 0) +import Prelude () +import System.Directory.Internal.Prelude +import System.Directory.OsPath +import TestUtils () +import Util (TestEnv) +import qualified Util as T 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" main :: TestEnv -> IO () main _t = do @@ -17,14 +20,13 @@ _ <- getXdgDirectoryList XdgDataDirs _ <- getXdgDirectoryList XdgConfigDirs - T(expect) () True -- avoid warnings about redundant imports + T.expect _t () 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 - T(expectEq) () (home ".config/mow") =<< getXdgDirectory XdgConfig "mow" + T.expectEq _t () (home ".config/mow") =<< getXdgDirectory XdgConfig "mow" #endif -- unset variables, so env doesn't affect test running @@ -42,10 +44,10 @@ setEnv "XDG_CONFIG_HOME" "aw" setEnv "XDG_CACHE_HOME" "ba" setEnv "XDG_STATE_HOME" "uw" - T(expectEq) () xdgData =<< getXdgDirectory XdgData "ff" - T(expectEq) () xdgConfig =<< getXdgDirectory XdgConfig "oo" - T(expectEq) () xdgCache =<< getXdgDirectory XdgCache "rk" - T(expectEq) () xdgState =<< getXdgDirectory XdgState "aa" + T.expectEq _t () xdgData =<< getXdgDirectory XdgData "ff" + T.expectEq _t () xdgConfig =<< getXdgDirectory XdgConfig "oo" + T.expectEq _t () xdgCache =<< getXdgDirectory XdgCache "rk" + T.expectEq _t () xdgState =<< getXdgDirectory XdgState "aa" unsetEnv "XDG_CONFIG_DIRS" unsetEnv "XDG_DATA_DIRS" @@ -53,14 +55,11 @@ _xdgDataDirs <- getXdgDirectoryList XdgDataDirs #if !defined(mingw32_HOST_OS) - T(expectEq) () ["/etc/xdg"] _xdgConfigDirs - T(expectEq) () ["/usr/local/share/", "/usr/share/"] _xdgDataDirs + T.expectEq _t () ["/etc/xdg"] _xdgConfigDirs + T.expectEq _t () ["/usr/local/share/", "/usr/share/"] _xdgDataDirs #endif setEnv "XDG_DATA_DIRS" (List.intercalate [searchPathSeparator] ["/a", "/b"]) setEnv "XDG_CONFIG_DIRS" (List.intercalate [searchPathSeparator] ["/c", "/d"]) - T(expectEq) () ["/a", "/b"] =<< getXdgDirectoryList XdgDataDirs - T(expectEq) () ["/c", "/d"] =<< getXdgDirectoryList XdgConfigDirs -#endif - - return () + T.expectEq _t () ["/a", "/b"] =<< getXdgDirectoryList XdgDataDirs + T.expectEq _t () ["/c", "/d"] =<< getXdgDirectoryList XdgConfigDirs diff --git a/tests/util.inl b/tests/util.inl deleted file mode 100644 --- a/tests/util.inl +++ /dev/null @@ -1,9 +0,0 @@ -#define T(f) (T.f _t __FILE__ __LINE__) - -import Prelude () -import System.Directory.Internal.Prelude -import System.Directory -import Util (TestEnv) -import qualified Util as T --- This comment prevents "T" above from being treated as the function-like --- macro defined earlier.