diff --git a/System/Directory.hs b/System/Directory.hs --- a/System/Directory.hs +++ b/System/Directory.hs @@ -114,11 +114,7 @@ import System.Directory.Internal.Prelude import System.FilePath import Data.Time (UTCTime) -import Data.Time.Clock.POSIX - ( posixSecondsToUTCTime - , utcTimeToPOSIXSeconds - , POSIXTime - ) +import Data.Time.Clock.POSIX (POSIXTime, utcTimeToPOSIXSeconds) import qualified System.Directory.Internal.Config as Cfg #ifdef mingw32_HOST_OS import qualified System.Win32 as Win32 @@ -187,12 +183,6 @@ -} -data Permissions - = Permissions { - readable, writable, - executable, searchable :: Bool - } deriving (Eq, Ord, Read, Show) - emptyPermissions :: Permissions emptyPermissions = Permissions { readable = False, @@ -213,125 +203,62 @@ setOwnerSearchable :: Bool -> Permissions -> Permissions setOwnerSearchable b p = p { searchable = b } -{- |The 'getPermissions' operation returns the -permissions for the file or directory. - -The operation may fail with: - -* 'isPermissionError' if the user is not permitted to access - the permissions; or - -* 'isDoesNotExistError' if the file or directory does not exist. - --} - +-- | Get the permissions of a file or directory. +-- +-- On Windows, the 'writable' permission corresponds to the "read-only" +-- attribute. The 'executable' permission is set if the file extension is of +-- an executable file type. The 'readable' permission is always set. +-- +-- On POSIX systems, this returns the result of @access@. +-- +-- The operation may fail with: +-- +-- * 'isPermissionError' if the user is not permitted to access the +-- permissions, or +-- +-- * 'isDoesNotExistError' if the file or directory does not exist. getPermissions :: FilePath -> IO Permissions -getPermissions name = -#ifdef mingw32_HOST_OS - -- issue #9: Windows doesn't like trailing path separators - withFilePath (dropTrailingPathSeparator name) $ \s -> - -- stat() does a better job of guessing the permissions on Windows - -- than access() does. e.g. for execute permission, it looks at the - -- filename extension :-) - -- - -- I tried for a while to do this properly, using the Windows security API, - -- and eventually gave up. getPermissions is a flawed API anyway. -- SimonM - allocaBytes sizeof_stat $ \ p_stat -> do - throwErrnoIfMinus1_ "getPermissions" $ c_stat s p_stat - mode <- st_mode p_stat - let usr_read = mode .&. s_IRUSR - let usr_write = mode .&. s_IWUSR - let usr_exec = mode .&. s_IXUSR - let is_dir = mode .&. s_IFDIR - return ( - Permissions { - readable = usr_read /= 0, - writable = usr_write /= 0, - executable = is_dir == 0 && usr_exec /= 0, - searchable = is_dir /= 0 && usr_exec /= 0 - } - ) -#else - do - read_ok <- Posix.fileAccess name True False False - write_ok <- Posix.fileAccess name False True False - exec_ok <- Posix.fileAccess name False False True - stat <- Posix.getFileStatus name - let is_dir = Posix.isDirectory stat - return ( - Permissions { - readable = read_ok, - writable = write_ok, - executable = not is_dir && exec_ok, - searchable = is_dir && exec_ok - } - ) -#endif - -{- |The 'setPermissions' operation sets the -permissions for the file or directory. - -The operation may fail with: - -* 'isPermissionError' if the user is not permitted to set - the permissions; or - -* 'isDoesNotExistError' if the file or directory does not exist. - --} +getPermissions path = + (`ioeAddLocation` "getPermissions") `modifyIOError` do + getAccessPermissions path +-- | Set the permissions of a file or directory. +-- +-- On Windows, this is only capable of changing the 'writable' permission, +-- which corresponds to the "read-only" attribute. Changing the other +-- permissions has no effect. +-- +-- On POSIX systems, this sets the /owner/ permissions. +-- +-- The operation may fail with: +-- +-- * 'isPermissionError' if the user is not permitted to set the permissions, +-- or +-- +-- * 'isDoesNotExistError' if the file or directory does not exist. setPermissions :: FilePath -> Permissions -> IO () -setPermissions name (Permissions r w e s) = -#ifdef mingw32_HOST_OS - allocaBytes sizeof_stat $ \ p_stat -> - withFilePath name $ \p_name -> do - throwErrnoIfMinus1_ "setPermissions" $ - c_stat p_name p_stat - - throwErrnoIfMinus1_ "setPermissions" $ do - mode <- st_mode p_stat - let mode1 = modifyBit r mode s_IRUSR - let mode2 = modifyBit w mode1 s_IWUSR - let mode3 = modifyBit (e || s) mode2 s_IXUSR - c_wchmod p_name mode3 - where - modifyBit :: Bool -> CMode -> CMode -> CMode - modifyBit False m b = m .&. (complement b) - modifyBit True m b = m .|. b -#else - do - stat <- Posix.getFileStatus name - let mode = Posix.fileMode stat - let mode1 = modifyBit r mode Posix.ownerReadMode - let mode2 = modifyBit w mode1 Posix.ownerWriteMode - let mode3 = modifyBit (e || s) mode2 Posix.ownerExecuteMode - Posix.setFileMode name mode3 - where - modifyBit :: Bool -> FileMode -> FileMode -> FileMode - modifyBit False m b = m .&. (complement b) - modifyBit True m b = m .|. b -#endif +setPermissions path p = + (`ioeAddLocation` "setPermissions") `modifyIOError` do + setAccessPermissions path p +-- | Copy the permissions of one file to another. This reproduces the +-- permissions more accurately than using 'getPermissions' followed by +-- 'setPermissions'. +-- +-- On Windows, this copies only the read-only attribute. +-- +-- On POSIX systems, this is equivalent to @stat@ followed by @chmod@. copyPermissions :: FilePath -> FilePath -> IO () -copyPermissions source dest = -#ifdef mingw32_HOST_OS - allocaBytes sizeof_stat $ \ p_stat -> - withFilePath source $ \p_source -> - withFilePath dest $ \p_dest -> do - throwErrnoIfMinus1_ "copyPermissions" $ c_stat p_source p_stat - mode <- st_mode p_stat - throwErrnoIfMinus1_ "copyPermissions" $ c_wchmod p_dest mode -#else - do - stat <- Posix.getFileStatus source - copyPermissionsFromStatus stat dest -#endif +copyPermissions src dst = + (`ioeAddLocation` "copyPermissions") `modifyIOError` do + m <- getFileMetadata src + copyPermissionsFromMetadata m dst -#ifndef mingw32_HOST_OS -copyPermissionsFromStatus :: Posix.FileStatus -> FilePath -> IO () -copyPermissionsFromStatus st dst = do - Posix.setFileMode dst (Posix.fileMode st) -#endif +copyPermissionsFromMetadata :: Metadata -> FilePath -> IO () +copyPermissionsFromMetadata m dst = do + -- instead of setFileMode, setFilePermissions is used here + -- this is to retain backward compatibility in copyPermissions + setFilePermissions dst (modeFromMetadata m) ----------------------------------------------------------------------------- -- Implementation @@ -376,7 +303,9 @@ createDirectory :: FilePath -> IO () createDirectory path = do #ifdef mingw32_HOST_OS - Win32.createDirectory path Nothing + (`ioeSetFileName` path) `modifyIOError` do + path' <- toExtendedLengthPath <$> prependCurrentDirectory path + Win32.createDirectory path' Nothing #else Posix.createDirectory path 0o777 #endif @@ -421,46 +350,13 @@ -- directory. | isAlreadyExistsError e || isPermissionError e -> do - canIgnore <- isDir `catchIOError` \ _ -> - return (isAlreadyExistsError e) + canIgnore <- pathIsDirectory dir + `catchIOError` \ _ -> + return (isAlreadyExistsError e) unless canIgnore (ioError e) | otherwise -> ioError e - where -#ifdef mingw32_HOST_OS - isDir = withFileStatus "createDirectoryIfMissing" dir isDirectory -#else - isDir = (Posix.isDirectory <$> Posix.getFileStatus dir) -#endif --- | * @'NotDirectory'@: not a directory. --- * @'Directory'@: a true directory (not a symbolic link). --- * @'DirectoryLink'@: a directory symbolic link (only exists on Windows). -data DirectoryType = NotDirectory - | Directory - | DirectoryLink - deriving (Enum, Eq, Ord, Read, Show) --- | Obtain the type of a directory. -getDirectoryType :: FilePath -> IO DirectoryType -getDirectoryType path = - (`ioeAddLocation` "getDirectoryType") `modifyIOError` do -#ifdef mingw32_HOST_OS - isDir <- withSymbolicLinkStatus "getDirectoryType" path isDirectory - if isDir - then do - isLink <- pathIsSymbolicLink path - if isLink - then return DirectoryLink - else return Directory - else do - return NotDirectory -#else - stat <- Posix.getSymbolicLinkStatus path - return $ if Posix.isDirectory stat - then Directory - else NotDirectory -#endif - {- | @'removeDirectory' dir@ removes an existing directory /dir/. The implementation may specify additional constraints which must be satisfied before a directory can be removed (e.g. the directory has to @@ -505,7 +401,9 @@ removeDirectory :: FilePath -> IO () removeDirectory path = #ifdef mingw32_HOST_OS - Win32.removeDirectory path + (`ioeSetFileName` path) `modifyIOError` do + path' <- toExtendedLengthPath <$> prependCurrentDirectory path + Win32.removeDirectory path' #else Posix.removeDirectory path #endif @@ -518,13 +416,13 @@ removeDirectoryRecursive :: FilePath -> IO () removeDirectoryRecursive path = (`ioeAddLocation` "removeDirectoryRecursive") `modifyIOError` do - dirType <- getDirectoryType path - case dirType of + m <- getSymbolicLinkMetadata path + case fileTypeFromMetadata m of Directory -> removeContentsRecursive path DirectoryLink -> ioError (err `ioeSetErrorString` "is a directory symbolic link") - NotDirectory -> + _ -> ioError (err `ioeSetErrorString` "not a directory") where err = mkIOError InappropriateType "" Nothing (Just path) @@ -534,11 +432,11 @@ removePathRecursive :: FilePath -> IO () removePathRecursive path = (`ioeAddLocation` "removePathRecursive") `modifyIOError` do - dirType <- getDirectoryType path - case dirType of - NotDirectory -> removeFile path + m <- getSymbolicLinkMetadata path + case fileTypeFromMetadata m of Directory -> removeContentsRecursive path DirectoryLink -> removeDirectory path + _ -> removeFile path -- | @'removeContentsRecursive' dir@ removes the contents of the directory -- /dir/ recursively. Symbolic links are removed without affecting their the @@ -573,15 +471,15 @@ (`ioeAddLocation` "removePathForcibly") `modifyIOError` do makeRemovable path `catchIOError` \ _ -> return () ignoreDoesNotExistError $ do - dirType <- getDirectoryType path - case dirType of - NotDirectory -> removeFile path + m <- getSymbolicLinkMetadata path + case fileTypeFromMetadata m of DirectoryLink -> removeDirectory path Directory -> do names <- listDirectory path sequenceWithIOErrors_ $ [ removePathForcibly (path name) | name <- names ] ++ [ removeDirectory path ] + _ -> removeFile path where ignoreDoesNotExistError :: IO () -> IO () @@ -650,7 +548,9 @@ removeFile :: FilePath -> IO () removeFile path = #ifdef mingw32_HOST_OS - Win32.deleteFile path + (`ioeSetFileName` path) `modifyIOError` do + path' <- toExtendedLengthPath <$> prependCurrentDirectory path + Win32.deleteFile path' #else Posix.removeLink path #endif @@ -706,20 +606,13 @@ renameDirectory :: FilePath -> FilePath -> IO () renameDirectory opath npath = - -- XXX this test isn't performed atomically with the following rename -#ifdef mingw32_HOST_OS - -- ToDo: use Win32 API - withFileStatus "renameDirectory" opath $ \st -> do - is_dir <- isDirectory st -#else - do - stat <- Posix.getFileStatus opath - let is_dir = Posix.fileMode stat .&. Posix.directoryMode /= 0 -#endif - when (not is_dir) $ do - ioError . (`ioeSetErrorString` "not a directory") $ - (mkIOError InappropriateType "renameDirectory" Nothing (Just opath)) - renamePath opath npath + (`ioeAddLocation` "renameDirectory") `modifyIOError` do + -- XXX this test isn't performed atomically with the following rename + isDir <- pathIsDirectory opath + when (not isDir) $ do + ioError . (`ioeSetErrorString` "not a directory") $ + (mkIOError InappropriateType "renameDirectory" Nothing (Just opath)) + renamePath opath npath {- |@'renameFile' old new@ changes the name of an existing file system object from /old/ to /new/. If the /new/ object already @@ -780,12 +673,11 @@ checkNotDir npath ioError err where checkNotDir path = do - dirType <- getDirectoryType path - `catchIOError` \ _ -> return NotDirectory - case dirType of - Directory -> errIsDir path - DirectoryLink -> errIsDir path - NotDirectory -> return () + m <- tryIOError (getSymbolicLinkMetadata path) + case fileTypeFromMetadata <$> m of + Right Directory -> errIsDir path + Right DirectoryLink -> errIsDir path + _ -> return () errIsDir path = ioError . (`ioeSetErrorString` "is a directory") $ mkIOError InappropriateType "" Nothing (Just path) @@ -836,7 +728,10 @@ -> IO () renamePath opath npath = (`ioeAddLocation` "renamePath") `modifyIOError` do #ifdef mingw32_HOST_OS - Win32.moveFileEx opath npath Win32.mOVEFILE_REPLACE_EXISTING + (`ioeSetFileName` opath) `modifyIOError` do + opath' <- toExtendedLengthPath <$> prependCurrentDirectory opath + npath' <- toExtendedLengthPath <$> prependCurrentDirectory npath + Win32.moveFileEx opath' npath' Win32.mOVEFILE_REPLACE_EXISTING #else Posix.rename opath npath #endif @@ -956,7 +851,10 @@ (`ioeAddLocation` "copyFileWithMetadata") `modifyIOError` doCopy where #ifdef mingw32_HOST_OS - doCopy = Win32.copyFile src dst False + doCopy = (`ioeSetFileName` src) `modifyIOError` do + src' <- toExtendedLengthPath <$> prependCurrentDirectory src + dst' <- toExtendedLengthPath <$> prependCurrentDirectory dst + Win32.copyFile src' dst' False #else doCopy = do st <- Posix.getFileStatus src @@ -968,7 +866,7 @@ copyMetadataFromStatus :: Posix.FileStatus -> FilePath -> IO () copyMetadataFromStatus st dst = do tryCopyOwnerAndGroupFromStatus st dst - copyPermissionsFromStatus st dst + copyPermissionsFromMetadata st dst copyFileTimesFromStatus st dst #endif @@ -994,7 +892,8 @@ #ifndef mingw32_HOST_OS copyFileTimesFromStatus :: Posix.FileStatus -> FilePath -> IO () copyFileTimesFromStatus st dst = do - let (atime, mtime) = fileTimesFromStatus st + let atime = accessTimeFromMetadata st + let mtime = modificationTimeFromMetadata st setFileTimes dst (Just atime, Just mtime) #endif @@ -1074,7 +973,8 @@ transform = attemptRealpath getFinalPathName simplify path = - Win32.getFullPathName path + (fromExtendedLengthPath <$> + Win32.getFullPathName (toExtendedLengthPath path)) `catchIOError` \ _ -> return path #else @@ -1163,23 +1063,6 @@ (`ioeSetFileName` path)) $ matchTrailingSeparator path . normalise <$> prependCurrentDirectory path --- | Convert a path into an absolute path. If the given path is relative, the --- current directory is prepended. If the path is already absolute, the path --- is returned unchanged. The function preserves the presence or absence of --- the trailing path separator. --- --- If the path is already absolute, the operation never fails. Otherwise, the --- operation may fail with the same exceptions as 'getCurrentDirectory'. --- --- (internal API) -prependCurrentDirectory :: FilePath -> IO FilePath -prependCurrentDirectory path = - modifyIOError ((`ioeAddLocation` "prependCurrentDirectory") . - (`ioeSetFileName` path)) $ - if isRelative path -- avoid the call to `getCurrentDirectory` if we can - then ( path) <$> getCurrentDirectory - else return path - -- | Add or remove the trailing path separator in the second path so as to -- match its presence in the first path. -- @@ -1380,8 +1263,9 @@ then return (acc []) else loop (acc . (e:)) #else + query <- toExtendedLengthPath <$> prependCurrentDirectory (path "*") bracket - (Win32.findFirstFile (path "*")) + (Win32.findFirstFile query) (\(h,_) -> Win32.findClose h) (\(h,fdat) -> loop h fdat []) where @@ -1433,47 +1317,6 @@ (filter f) <$> (getDirectoryContents path) where f filename = filename /= "." && filename /= ".." --- | Obtain the current working directory as an absolute path. --- --- In a multithreaded program, the current working directory is a global state --- shared among all threads of the process. Therefore, when performing --- filesystem operations from multiple threads, it is highly recommended to --- use absolute rather than relative paths (see: 'makeAbsolute'). --- --- The operation may fail with: --- --- * 'HardwareFault' --- A physical I\/O error has occurred. --- @[EIO]@ --- --- * 'isDoesNotExistError' or 'NoSuchThing' --- There is no path referring to the working directory. --- @[EPERM, ENOENT, ESTALE...]@ --- --- * 'isPermissionError' or 'PermissionDenied' --- The process has insufficient privileges to perform the operation. --- @[EACCES]@ --- --- * 'ResourceExhausted' --- Insufficient resources are available to perform the operation. --- --- * 'UnsupportedOperation' --- The operating system has no notion of current working directory. --- -getCurrentDirectory :: IO FilePath -getCurrentDirectory = - modifyIOError (`ioeAddLocation` "getCurrentDirectory") $ - specializeErrorString - "Current working directory no longer exists" - isDoesNotExistError - getCwd - where -#ifdef mingw32_HOST_OS - getCwd = Win32.getCurrentDirectory -#else - getCwd = Posix.getWorkingDirectory -#endif - -- | Change the working directory to the given path. -- -- In a multithreaded program, the current working directory is a global state @@ -1508,11 +1351,13 @@ -- @[ENOTDIR]@ -- setCurrentDirectory :: FilePath -> IO () -setCurrentDirectory = +setCurrentDirectory path = do #ifdef mingw32_HOST_OS - Win32.setCurrentDirectory + -- SetCurrentDirectory does not support long paths even with the \\?\ prefix + -- https://ghc.haskell.org/trac/ghc/ticket/13373#comment:6 + Win32.setCurrentDirectory path #else - Posix.changeWorkingDirectory + Posix.changeWorkingDirectory path #endif -- | Run an 'IO' action with the given working directory and restore the @@ -1538,11 +1383,7 @@ getFileSize :: FilePath -> IO Integer getFileSize path = (`ioeAddLocation` "getFileSize") `modifyIOError` do -#ifdef mingw32_HOST_OS - fromIntegral <$> withFileStatus "" path st_size -#else - fromIntegral . Posix.fileSize <$> Posix.getFileStatus path -#endif + fileSizeFromMetadata <$> getFileMetadata path -- | Test whether the given path points to an existing filesystem object. If -- the user lacks necessary permissions to search the parent directories, this @@ -1550,13 +1391,10 @@ -- -- @since 1.2.7.0 doesPathExist :: FilePath -> IO Bool -doesPathExist path = -#ifdef mingw32_HOST_OS - (withFileStatus "" path $ \ _ -> return True) -#else - (Posix.getFileStatus path >> return True) -#endif - `catchIOError` \ _ -> return False +doesPathExist path = do + (True <$ getFileMetadata path) + `catchIOError` \ _ -> + return False {- |The operation 'doesDirectoryExist' returns 'True' if the argument file exists and is either a directory or a symbolic link to a directory, @@ -1564,29 +1402,29 @@ -} doesDirectoryExist :: FilePath -> IO Bool -doesDirectoryExist name = -#ifdef mingw32_HOST_OS - (withFileStatus "doesDirectoryExist" name $ \st -> isDirectory st) -#else - (do stat <- Posix.getFileStatus name - return (Posix.isDirectory stat)) -#endif - `catchIOError` \ _ -> return False +doesDirectoryExist path = do + pathIsDirectory path + `catchIOError` \ _ -> + return False {- |The operation 'doesFileExist' returns 'True' if the argument file exists and is not a directory, and 'False' otherwise. -} doesFileExist :: FilePath -> IO Bool -doesFileExist name = -#ifdef mingw32_HOST_OS - (withFileStatus "doesFileExist" name $ \st -> do b <- isDirectory st; return (not b)) -#else - (do stat <- Posix.getFileStatus name - return (not (Posix.isDirectory stat))) -#endif - `catchIOError` \ _ -> return False +doesFileExist path = do + (not <$> pathIsDirectory path) + `catchIOError` \ _ -> + return False +pathIsDirectory :: FilePath -> IO Bool +pathIsDirectory path = (`ioeAddLocation` "pathIsDirectory") `modifyIOError` do + m <- getFileMetadata path + case fileTypeFromMetadata m of + Directory -> return True + DirectoryLink -> return True + _ -> return False + -- | Create a /file/ symbolic link. The target path can be either absolute or -- relative and need not refer to an existing file. The order of arguments -- follows the POSIX convention. @@ -1688,14 +1526,14 @@ -- @since 1.3.0.0 pathIsSymbolicLink :: FilePath -> IO Bool pathIsSymbolicLink path = - (`ioeAddLocation` "pathIsSymbolicLink") `modifyIOError` do -#ifdef mingw32_HOST_OS - isReparsePoint <$> Win32.getFileAttributes path - where - isReparsePoint attr = attr .&. win32_fILE_ATTRIBUTE_REPARSE_POINT /= 0 -#else - Posix.isSymbolicLink <$> Posix.getSymbolicLinkStatus path -#endif + ((`ioeAddLocation` "pathIsSymbolicLink") . + (`ioeSetFileName` path)) `modifyIOError` do + m <- getSymbolicLinkMetadata path + return $ + case fileTypeFromMetadata m of + DirectoryLink -> True + SymbolicLink -> True + _ -> False {-# DEPRECATED isSymbolicLink "Use 'pathIsSymbolicLink' instead" #-} isSymbolicLink :: FilePath -> IO Bool @@ -1726,12 +1564,12 @@ #ifdef mingw32_HOST_OS -- | Open the handle of an existing file or directory. openFileHandle :: String -> Win32.AccessMode -> IO Win32.HANDLE -openFileHandle path mode = Win32.createFile path mode share Nothing - Win32.oPEN_EXISTING flags Nothing - where share = win32_fILE_SHARE_DELETE - .|. Win32.fILE_SHARE_READ - .|. Win32.fILE_SHARE_WRITE - flags = Win32.fILE_ATTRIBUTE_NORMAL +openFileHandle path mode = + (`ioeSetFileName` path) `modifyIOError` do + path' <- toExtendedLengthPath <$> prependCurrentDirectory path + Win32.createFile path' mode maxShareMode Nothing + Win32.oPEN_EXISTING flags Nothing + where flags = Win32.fILE_ATTRIBUTE_NORMAL .|. Win32.fILE_FLAG_BACKUP_SEMANTICS -- required for directories #endif @@ -1751,8 +1589,9 @@ -- @since 1.2.3.0 -- getAccessTime :: FilePath -> IO UTCTime -getAccessTime = modifyIOError (`ioeAddLocation` "getAccessTime") . - (fst <$>) . getFileTimes +getAccessTime path = + modifyIOError (`ioeAddLocation` "getAccessTime") $ do + accessTimeFromMetadata <$> getFileMetadata path -- | Obtain the time at which the file or directory was last modified. -- @@ -1768,42 +1607,9 @@ -- and the underlying filesystem supports them. -- getModificationTime :: FilePath -> IO UTCTime -getModificationTime = modifyIOError (`ioeAddLocation` "getModificationTime") . - (snd <$>) . getFileTimes - -getFileTimes :: FilePath -> IO (UTCTime, UTCTime) -getFileTimes path = - modifyIOError (`ioeAddLocation` "getFileTimes") . - modifyIOError (`ioeSetFileName` path) $ - getTimes - where - path' = normalise path -- handle empty paths -#ifdef mingw32_HOST_OS - getTimes = - bracket (openFileHandle path' Win32.gENERIC_READ) - Win32.closeHandle $ \ handle -> - alloca $ \ atime -> - alloca $ \ mtime -> do - Win32.failIf_ not "" $ - Win32.c_GetFileTime handle nullPtr atime mtime - ((,) `on` posixSecondsToUTCTime . windowsToPosixTime) - <$> peek atime - <*> peek mtime -#else - getTimes = fileTimesFromStatus <$> Posix.getFileStatus path' -#endif - -#ifndef mingw32_HOST_OS -fileTimesFromStatus :: Posix.FileStatus -> (UTCTime, UTCTime) -fileTimesFromStatus st = -# if MIN_VERSION_unix(2, 6, 0) - ( posixSecondsToUTCTime (Posix.accessTimeHiRes st) - , posixSecondsToUTCTime (Posix.modificationTimeHiRes st) ) -# else - ( posixSecondsToUTCTime (realToFrac (Posix.accessTime st)) - , posixSecondsToUTCTime (realToFrac (Posix.modificationTime st)) ) -# endif -#endif +getModificationTime path = + modifyIOError (`ioeAddLocation` "getModificationTime") $ do + modificationTimeFromMetadata <$> getFileMetadata path -- | Change the time at which the file or directory was last accessed. -- @@ -1889,7 +1695,9 @@ #else setTimes (Just atime', Just mtime') = setFileTimes' path' atime' mtime' setTimes (atime', mtime') = do - (atimeOld, mtimeOld) <- fileTimesFromStatus <$> Posix.getFileStatus path' + m <- getFileMetadata path' + let atimeOld = accessTimeFromMetadata m + let mtimeOld = modificationTimeFromMetadata m setFileTimes' path' (fromMaybe (utcTimeToPOSIXSeconds atimeOld) atime') (fromMaybe (utcTimeToPOSIXSeconds mtimeOld) mtime') @@ -1905,48 +1713,6 @@ # endif #endif -#ifdef mingw32_HOST_OS --- | Difference between the Windows and POSIX epochs in units of 100ns. -windowsPosixEpochDifference :: Num a => a -windowsPosixEpochDifference = 116444736000000000 - --- | Convert from Windows time to POSIX time. -windowsToPosixTime :: Win32.FILETIME -> POSIXTime -windowsToPosixTime (Win32.FILETIME t) = - (fromIntegral t - windowsPosixEpochDifference) / 10000000 - --- | Convert from POSIX time to Windows time. This is lossy as Windows time --- has a resolution of only 100ns. -posixToWindowsTime :: POSIXTime -> Win32.FILETIME -posixToWindowsTime t = Win32.FILETIME $ - truncate (t * 10000000 + windowsPosixEpochDifference) -#endif - -#ifdef mingw32_HOST_OS -withFileStatus :: String -> FilePath -> (Ptr CStat -> IO a) -> IO a -withFileStatus loc name f = - modifyIOError (`ioeSetFileName` name) $ do - name' <- getFinalPathName name - withSymbolicLinkStatus loc name' f - -withSymbolicLinkStatus :: String -> FilePath -> (Ptr CStat -> IO a) -> IO a -withSymbolicLinkStatus loc name f = do - modifyIOError (`ioeSetFileName` name) $ do - allocaBytes sizeof_stat $ \p -> - withFilePath (fileNameEndClean name) $ \s -> do - throwErrnoIfMinus1Retry_ loc (c_stat s p) - f p - -isDirectory :: Ptr CStat -> IO Bool -isDirectory stat = do - mode <- st_mode stat - return (s_isdir mode) - -fileNameEndClean :: String -> String -fileNameEndClean name = if isDrive name then addTrailingPathSeparator name - else dropTrailingPathSeparator name -#endif - {- | Returns the current user's home directory. The directory returned is expected to be writable by the current user, @@ -2062,22 +1828,6 @@ Right value -> return (Just value) #endif --- | Similar to 'try' but only catches a specify kind of 'IOError' as --- specified by the predicate. -tryIOErrorType :: (IOError -> Bool) -> IO a -> IO (Either IOError a) -tryIOErrorType check action = do - result <- tryIOError action - case result of - Left err -> if check err then return (Left err) else ioError err - Right val -> return (Right val) - -specializeErrorString :: String -> (IOError -> Bool) -> IO a -> IO a -specializeErrorString str errType action = do - mx <- tryIOErrorType errType action - case mx of - Left e -> ioError (ioeSetErrorString e str) - Right x -> return x - -- | Obtain the path to a special directory for storing user-specific -- application data (traditional Unix location). Newer applications may -- prefer the the XDG-conformant location provided by 'getXdgDirectory' @@ -2180,10 +1930,3 @@ getEnv "TMPDIR" `catchIOError` \ err -> if isDoesNotExistError err then return "/tmp" else ioError err #endif - -ioeAddLocation :: IOError -> String -> IOError -ioeAddLocation e loc = do - ioeSetLocation e newLoc - where - newLoc = loc <> if null oldLoc then "" else ":" <> oldLoc - oldLoc = ioeGetLocation e diff --git a/System/Directory/Internal.hs b/System/Directory/Internal.hs --- a/System/Directory/Internal.hs +++ b/System/Directory/Internal.hs @@ -11,12 +11,12 @@ #include module System.Directory.Internal - ( + ( module System.Directory.Internal.Common #ifdef mingw32_HOST_OS - module System.Directory.Internal.Windows + , module System.Directory.Internal.Windows #else - module System.Directory.Internal.Posix + , module System.Directory.Internal.Posix #endif #ifdef HAVE_UTIMENSAT @@ -25,12 +25,14 @@ ) where -#ifdef HAVE_UTIMENSAT -import System.Directory.Internal.C_utimensat -#endif +import System.Directory.Internal.Common #ifdef mingw32_HOST_OS import System.Directory.Internal.Windows #else import System.Directory.Internal.Posix +#endif + +#ifdef HAVE_UTIMENSAT +import System.Directory.Internal.C_utimensat #endif diff --git a/System/Directory/Internal/Common.hs b/System/Directory/Internal/Common.hs new file mode 100644 --- /dev/null +++ b/System/Directory/Internal/Common.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE CPP #-} +module System.Directory.Internal.Common where +import Prelude () +import System.Directory.Internal.Prelude +import System.FilePath ((), isPathSeparator, isRelative, + pathSeparator, splitDrive, takeDrive) +#ifdef mingw32_HOST_OS +import qualified System.Win32 as Win32 +#else +import qualified System.Posix as Posix +#endif + +-- | Similar to 'try' but only catches a specify kind of 'IOError' as +-- specified by the predicate. +tryIOErrorType :: (IOError -> Bool) -> IO a -> IO (Either IOError a) +tryIOErrorType check action = do + result <- tryIOError action + case result of + Left err -> if check err then return (Left err) else ioError err + Right val -> return (Right val) + +specializeErrorString :: String -> (IOError -> Bool) -> IO a -> IO a +specializeErrorString str errType action = do + mx <- tryIOErrorType errType action + case mx of + Left e -> ioError (ioeSetErrorString e str) + Right x -> return x + +ioeAddLocation :: IOError -> String -> IOError +ioeAddLocation e loc = do + ioeSetLocation e newLoc + where + newLoc = loc <> if null oldLoc then "" else ":" <> oldLoc + oldLoc = ioeGetLocation e + +data FileType = File + | SymbolicLink -- ^ POSIX: either file or directory link; Windows: file link + | Directory + | DirectoryLink -- ^ Windows only + deriving (Bounded, Enum, Eq, Ord, Read, Show) + +-- | Check whether the given 'FileType' is considered a directory by the +-- operating system. This affects the choice of certain functions +-- e.g. `removeDirectory` vs `removeFile`. +fileTypeIsDirectory :: FileType -> Bool +fileTypeIsDirectory Directory = True +fileTypeIsDirectory DirectoryLink = True +fileTypeIsDirectory _ = False + +data Permissions + = Permissions + { readable :: Bool + , writable :: Bool + , executable :: Bool + , searchable :: Bool + } deriving (Eq, Ord, Read, Show) + +-- | Obtain the current working directory as an absolute path. +-- +-- In a multithreaded program, the current working directory is a global state +-- shared among all threads of the process. Therefore, when performing +-- filesystem operations from multiple threads, it is highly recommended to +-- use absolute rather than relative paths (see: 'makeAbsolute'). +-- +-- The operation may fail with: +-- +-- * 'HardwareFault' +-- A physical I\/O error has occurred. +-- @[EIO]@ +-- +-- * 'isDoesNotExistError' or 'NoSuchThing' +-- There is no path referring to the working directory. +-- @[EPERM, ENOENT, ESTALE...]@ +-- +-- * 'isPermissionError' or 'PermissionDenied' +-- The process has insufficient privileges to perform the operation. +-- @[EACCES]@ +-- +-- * 'ResourceExhausted' +-- Insufficient resources are available to perform the operation. +-- +-- * 'UnsupportedOperation' +-- The operating system has no notion of current working directory. +-- +getCurrentDirectory :: IO FilePath +getCurrentDirectory = (`ioeAddLocation` "getCurrentDirectory") `modifyIOError` + specializeErrorString + "Current working directory no longer exists" + isDoesNotExistError +#ifdef mingw32_HOST_OS + Win32.getCurrentDirectory +#else + Posix.getWorkingDirectory +#endif + +-- | Convert a path into an absolute path. If the given path is relative, the +-- current directory is prepended. If the path is already absolute, the path +-- is returned unchanged. The function preserves the presence or absence of +-- the trailing path separator. +-- +-- If the path is already absolute, the operation never fails. Otherwise, the +-- operation may fail with the same exceptions as 'getCurrentDirectory'. +-- +-- (internal API) +prependCurrentDirectory :: FilePath -> IO FilePath +prependCurrentDirectory path = + modifyIOError ((`ioeAddLocation` "prependCurrentDirectory") . + (`ioeSetFileName` path)) $ + if isRelative path -- avoid the call to `getCurrentDirectory` if we can + then do + cwd <- getCurrentDirectory + let curDrive = takeWhile (not . isPathSeparator) (takeDrive cwd) + let (drive, subpath) = splitDrive path + -- handle drive-relative paths (Windows only) + return . ( subpath) $ + case drive of + _ : _ | (toUpper <$> drive) /= (toUpper <$> curDrive) -> + drive <> [pathSeparator] + _ -> cwd + else return path 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 @@ -6,6 +6,11 @@ #endif import Prelude () import System.Directory.Internal.Prelude +import System.Directory.Internal.Common +import Data.Time (UTCTime) +import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime) +import System.FilePath (normalise) +import qualified System.Posix as Posix -- we use the 'free' from the standard library here since it's not entirely -- clear whether Haskell's 'free' corresponds to the same one @@ -34,5 +39,95 @@ -- allocate one extra just to be safe allocaBytes (pathMax + 1) (realpath >=> action) where realpath = throwErrnoIfNull "" . c_realpath path + +type Metadata = Posix.FileStatus + +-- note: normalise is needed to handle empty paths + +getSymbolicLinkMetadata :: FilePath -> IO Metadata +getSymbolicLinkMetadata = Posix.getSymbolicLinkStatus . normalise + +getFileMetadata :: FilePath -> IO Metadata +getFileMetadata = Posix.getFileStatus . normalise + +fileTypeFromMetadata :: Metadata -> FileType +fileTypeFromMetadata stat + | isLink = SymbolicLink + | isDir = Directory + | otherwise = File + where + isLink = Posix.isSymbolicLink stat + isDir = Posix.isDirectory stat + +fileSizeFromMetadata :: Metadata -> Integer +fileSizeFromMetadata = fromIntegral . Posix.fileSize + +accessTimeFromMetadata :: Metadata -> UTCTime +accessTimeFromMetadata = + posixSecondsToUTCTime . posix_accessTimeHiRes + +modificationTimeFromMetadata :: Metadata -> UTCTime +modificationTimeFromMetadata = + posixSecondsToUTCTime . posix_modificationTimeHiRes + +posix_accessTimeHiRes, posix_modificationTimeHiRes + :: Posix.FileStatus -> POSIXTime +#if MIN_VERSION_unix(2, 6, 0) +posix_accessTimeHiRes = Posix.accessTimeHiRes +posix_modificationTimeHiRes = Posix.modificationTimeHiRes +#else +posix_accessTimeHiRes = realToFrac . Posix.accessTime +posix_modificationTimeHiRes = realToFrac . Posix.modificationTime +#endif + +type Mode = Posix.FileMode + +modeFromMetadata :: Metadata -> Mode +modeFromMetadata = Posix.fileMode + +allWriteMode :: Posix.FileMode +allWriteMode = + Posix.ownerWriteMode .|. + Posix.groupWriteMode .|. + Posix.otherWriteMode + +hasWriteMode :: Mode -> Bool +hasWriteMode m = m .&. allWriteMode /= 0 + +setWriteMode :: Bool -> Mode -> Mode +setWriteMode False m = m .&. complement allWriteMode +setWriteMode True m = m .|. allWriteMode + +setFileMode :: FilePath -> Mode -> IO () +setFileMode = Posix.setFileMode + +setFilePermissions :: FilePath -> Mode -> IO () +setFilePermissions = setFileMode + +getAccessPermissions :: FilePath -> IO Permissions +getAccessPermissions path = do + m <- getFileMetadata path + let isDir = fileTypeIsDirectory (fileTypeFromMetadata m) + r <- Posix.fileAccess path True False False + w <- Posix.fileAccess path False True False + x <- Posix.fileAccess path False False True + return Permissions + { readable = r + , writable = w + , executable = x && not isDir + , searchable = x && isDir + } + +setAccessPermissions :: FilePath -> Permissions -> IO () +setAccessPermissions path (Permissions r w e s) = do + m <- getFileMetadata path + setFileMode path (modifyBit (e || s) Posix.ownerExecuteMode . + modifyBit w Posix.ownerWriteMode . + modifyBit r Posix.ownerReadMode . + modeFromMetadata $ m) + where + modifyBit :: Bool -> Posix.FileMode -> Posix.FileMode -> Posix.FileMode + modifyBit False b m = m .&. complement b + modifyBit True b m = m .|. b #endif 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 @@ -69,7 +69,7 @@ ) import Control.Monad ((>=>), (<=<), unless, when, replicateM_) import Data.Bits ((.&.), (.|.), complement) -import Data.Char (isAlpha, isAscii, toLower) +import Data.Char (isAlpha, isAscii, toLower, toUpper) import Data.Foldable (for_, traverse_) import Data.Function (on) import Data.Maybe (catMaybes, fromMaybe, maybeToList) @@ -161,16 +161,8 @@ , tryIOError , userError ) -import System.Posix.Internals - ( CStat - , c_stat - , withFilePath - , s_isdir - , sizeof_stat - , st_mode - , st_size - ) -import System.Posix.Types (CMode(..), EpochTime, FileMode) +import System.Posix.Internals (withFilePath) +import System.Posix.Types (EpochTime) import System.Timeout (timeout) #if !MIN_VERSION_base(4, 8, 0) diff --git a/System/Directory/Internal/Windows.hsc b/System/Directory/Internal/Windows.hsc --- a/System/Directory/Internal/Windows.hsc +++ b/System/Directory/Internal/Windows.hsc @@ -11,15 +11,17 @@ ##endif #include #include -#ifdef HAVE_SYS_STAT_H -# include -#endif #include #include import Prelude () import System.Directory.Internal.Prelude -import System.FilePath (isPathSeparator, isRelative, normalise, - pathSeparator, splitDirectories) +import System.Directory.Internal.Common +import Data.Time (UTCTime) +import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime) +import System.FilePath (addTrailingPathSeparator, hasTrailingPathSeparator, + isPathSeparator, isRelative, joinDrive, joinPath, + normalise, pathSeparator, pathSeparators, + splitDirectories, splitDrive, takeExtension) import qualified Data.List as List import qualified System.Win32 as Win32 @@ -34,7 +36,11 @@ win32_eRROR_INVALID_FUNCTION = 0x1 win32_fILE_ATTRIBUTE_REPARSE_POINT :: Win32.FileAttributeOrFlag +#if MIN_VERSION_Win32(2, 4, 0) +win32_fILE_ATTRIBUTE_REPARSE_POINT = Win32.fILE_ATTRIBUTE_REPARSE_POINT +#else win32_fILE_ATTRIBUTE_REPARSE_POINT = (#const FILE_ATTRIBUTE_REPARSE_POINT) +#endif win32_fILE_SHARE_DELETE :: Win32.ShareMode #if MIN_VERSION_Win32(2, 3, 1) @@ -43,6 +49,12 @@ win32_fILE_SHARE_DELETE = (#const FILE_SHARE_DELETE) #endif +maxShareMode :: Win32.ShareMode +maxShareMode = + win32_fILE_SHARE_DELETE .|. + Win32.fILE_SHARE_READ .|. + Win32.fILE_SHARE_WRITE + win32_getLongPathName, win32_getShortPathName :: FilePath -> IO FilePath #if MIN_VERSION_Win32(2, 4, 0) win32_getLongPathName = Win32.getLongPathName @@ -102,14 +114,10 @@ where #ifdef HAVE_GETFINALPATHNAMEBYHANDLEW rawGetFinalPathName path = do - let open = Win32.createFile path 0 shareMode Nothing + let open = Win32.createFile path 0 maxShareMode Nothing Win32.oPEN_EXISTING Win32.fILE_FLAG_BACKUP_SEMANTICS Nothing bracket open Win32.closeHandle $ \ h -> do win32_getFinalPathNameByHandle h 0 - shareMode = - win32_fILE_SHARE_DELETE .|. - Win32.fILE_SHARE_READ .|. - Win32.fILE_SHARE_WRITE #else rawGetFinalPathName = win32_getLongPathName <=< win32_getShortPathName #endif @@ -221,10 +229,10 @@ readSymbolicLink :: FilePath -> IO FilePath readSymbolicLink path = modifyIOError (`ioeSetFileName` path) $ do - let open = Win32.createFile (toExtendedLengthPath path) - 0 shareMode Nothing Win32.oPEN_EXISTING - (Win32.fILE_FLAG_BACKUP_SEMANTICS .|. - win32_fILE_FLAG_OPEN_REPARSE_POINT) Nothing + path' <- toExtendedLengthPath <$> prependCurrentDirectory path + let open = Win32.createFile path' 0 maxShareMode Nothing Win32.oPEN_EXISTING + (Win32.fILE_FLAG_BACKUP_SEMANTICS .|. + win32_fILE_FLAG_OPEN_REPARSE_POINT) Nothing bracket open Win32.closeHandle $ \ h -> do win32_alloca_REPARSE_DATA_BUFFER $ \ ptrAndSize@(ptr, _) -> do result <- deviceIoControl h win32_fSCTL_GET_REPARSE_POINT @@ -245,31 +253,81 @@ _ -> throwIO (mkIOError InappropriateType "readSymbolicLink" Nothing Nothing) where - shareMode = - win32_fILE_SHARE_DELETE .|. - Win32.fILE_SHARE_READ .|. - Win32.fILE_SHARE_WRITE strip sn = fromMaybe sn (List.stripPrefix "\\??\\" sn) +-- | Given a list of path segments, expand @.@ and @..@. The path segments +-- must not contain path separators. +expandDots :: [FilePath] -> [FilePath] +expandDots = reverse . go [] + where + go ys' xs' = + case xs' of + [] -> ys' + x : xs -> + case x of + "." -> go ys' xs + ".." -> + case ys' of + _ : ys -> go ys xs + [] -> go (x : ys') xs + _ -> go (x : ys') xs + +-- | Remove redundant trailing slashes and pick the right kind of slash. +normaliseTrailingSep :: FilePath -> FilePath +normaliseTrailingSep path = do + let path' = reverse path + let (sep, path'') = span isPathSeparator path' + let addSep = if null sep then id else (pathSeparator :) + reverse (addSep path'') + +-- | A variant of 'normalise' to handle Windows paths a little better. It +-- +-- * deduplicates trailing slashes after the drive, +-- * expands parent dirs (@..@), and +-- * preserves paths with @\\\\?\\@. +normaliseW :: FilePath -> FilePath +normaliseW path@('\\' : '\\' : '?' : '\\' : _) = path +normaliseW path = normalise (joinDrive drive' subpath') + where + (drive, subpath) = splitDrive path + drive' = normaliseTrailingSep drive + subpath' = appendSep . prependSep . joinPath . + stripPardirs . expandDots . skipSeps . + splitDirectories $ subpath + + skipSeps = filter (not . (`elem` (pure <$> pathSeparators))) + stripPardirs | not (isRelative path) = dropWhile (== "..") + | otherwise = id + prependSep | any isPathSeparator (take 1 subpath) = (pathSeparator :) + | otherwise = id + appendSep | hasTrailingPathSeparator subpath = addTrailingPathSeparator + | otherwise = id + +-- | Like 'toExtendedLengthPath' but normalises relative paths too. +-- This is needed to make sure e.g. getModificationTime works on empty paths. +toNormalisedExtendedLengthPath :: FilePath -> FilePath +toNormalisedExtendedLengthPath path + | isRelative path = normalise path + | otherwise = toExtendedLengthPath path + -- | Normalise the path separators and prepend the @"\\\\?\\"@ prefix if --- necessary or possible. +-- necessary or possible. This is used for symbolic links targets because +-- they can't handle forward slashes. normaliseSeparators :: FilePath -> FilePath normaliseSeparators path | isRelative path = normaliseSep <$> path | otherwise = toExtendedLengthPath path where normaliseSep c = if isPathSeparator c then pathSeparator else c --- | Add the @"\\\\?\\"@ prefix if necessary or possible. --- The path remains unchanged if the prefix is not added. +-- | Add the @"\\\\?\\"@ prefix if necessary or possible. The path remains +-- unchanged if the prefix is not added. This function can sometimes be used +-- to bypass the @MAX_PATH@ length restriction in Windows API calls. toExtendedLengthPath :: FilePath -> FilePath toExtendedLengthPath path | isRelative path = path | otherwise = - case normalise path of - -- note: as of filepath-1.4.1.0 normalise doesn't honor \\?\ - -- https://github.com/haskell/filepath/issues/56 - -- this means we cannot trust the result of normalise on - -- paths that start with \\?\ + case normaliseW path of + '\\' : '?' : '?' : '\\' : _ -> path '\\' : '\\' : '?' : '\\' : _ -> path '\\' : '\\' : '.' : '\\' : _ -> path '\\' : subpath@('\\' : _) -> "\\\\?\\UNC" <> subpath @@ -358,24 +416,112 @@ where unsupportedErrorMsg = "Not supported on Windows XP or older" #endif -createSymbolicLink :: Bool -> String -> String -> IO () -createSymbolicLink isDir target link = do - -- toExtendedLengthPath ensures the target gets normalised properly - win32_createSymbolicLink link (normaliseSeparators target) isDir +createSymbolicLink :: Bool -> FilePath -> FilePath -> IO () +createSymbolicLink isDir target link = + (`ioeSetFileName` link) `modifyIOError` do + -- normaliseSeparators ensures the target gets normalised properly + link' <- toExtendedLengthPath <$> prependCurrentDirectory link + win32_createSymbolicLink link' (normaliseSeparators target) isDir -foreign import ccall unsafe "_wchmod" - c_wchmod :: CWString -> CMode -> IO CInt +type Metadata = Win32.BY_HANDLE_FILE_INFORMATION -s_IRUSR :: CMode -s_IRUSR = (#const S_IRUSR) +getSymbolicLinkMetadata :: FilePath -> IO Metadata +getSymbolicLinkMetadata path = + (`ioeSetFileName` path) `modifyIOError` do + path' <- toNormalisedExtendedLengthPath <$> prependCurrentDirectory path + let open = Win32.createFile path' 0 maxShareMode Nothing Win32.oPEN_EXISTING + (Win32.fILE_FLAG_BACKUP_SEMANTICS .|. + win32_fILE_FLAG_OPEN_REPARSE_POINT) Nothing + bracket open Win32.closeHandle $ \ h -> do + Win32.getFileInformationByHandle h -s_IWUSR :: CMode -s_IWUSR = (#const S_IWUSR) +getFileMetadata :: FilePath -> IO Metadata +getFileMetadata path = + (`ioeSetFileName` path) `modifyIOError` do + path' <- toNormalisedExtendedLengthPath <$> prependCurrentDirectory path + let open = Win32.createFile path' 0 maxShareMode Nothing Win32.oPEN_EXISTING + Win32.fILE_FLAG_BACKUP_SEMANTICS Nothing + bracket open Win32.closeHandle $ \ h -> do + Win32.getFileInformationByHandle h -s_IXUSR :: CMode -s_IXUSR = (#const S_IXUSR) +fileTypeFromMetadata :: Metadata -> FileType +fileTypeFromMetadata info + | isLink = if isDir then DirectoryLink else SymbolicLink + | isDir = Directory + | otherwise = File + where + isLink = attrs .&. win32_fILE_ATTRIBUTE_REPARSE_POINT /= 0 + isDir = attrs .&. Win32.fILE_ATTRIBUTE_DIRECTORY /= 0 + attrs = Win32.bhfiFileAttributes info -s_IFDIR :: CMode -s_IFDIR = (#const S_IFDIR) +fileSizeFromMetadata :: Metadata -> Integer +fileSizeFromMetadata = fromIntegral . Win32.bhfiSize + +accessTimeFromMetadata :: Metadata -> UTCTime +accessTimeFromMetadata = + posixSecondsToUTCTime . windowsToPosixTime . Win32.bhfiLastAccessTime + +modificationTimeFromMetadata :: Metadata -> UTCTime +modificationTimeFromMetadata = + posixSecondsToUTCTime . windowsToPosixTime . Win32.bhfiLastWriteTime + +-- | Difference between the Windows and POSIX epochs in units of 100ns. +windowsPosixEpochDifference :: Num a => a +windowsPosixEpochDifference = 116444736000000000 + +-- | Convert from Windows time to POSIX time. +windowsToPosixTime :: Win32.FILETIME -> POSIXTime +windowsToPosixTime (Win32.FILETIME t) = + (fromIntegral t - windowsPosixEpochDifference) / 10000000 + +-- | Convert from POSIX time to Windows time. This is lossy as Windows time +-- has a resolution of only 100ns. +posixToWindowsTime :: POSIXTime -> Win32.FILETIME +posixToWindowsTime t = Win32.FILETIME $ + truncate (t * 10000000 + windowsPosixEpochDifference) + +type Mode = Win32.FileAttributeOrFlag + +modeFromMetadata :: Metadata -> Mode +modeFromMetadata = Win32.bhfiFileAttributes + +hasWriteMode :: Mode -> Bool +hasWriteMode m = m .&. Win32.fILE_ATTRIBUTE_READONLY == 0 + +setWriteMode :: Bool -> Mode -> Mode +setWriteMode False m = m .|. Win32.fILE_ATTRIBUTE_READONLY +setWriteMode True m = m .&. complement Win32.fILE_ATTRIBUTE_READONLY + +setFileMode :: FilePath -> Mode -> IO () +setFileMode path mode = + (`ioeSetFileName` path) `modifyIOError` do + path' <- toNormalisedExtendedLengthPath <$> prependCurrentDirectory path + Win32.setFileAttributes path' mode + +-- | A restricted form of 'setFileMode' that only sets the permission bits. +-- For Windows, this means only the "read-only" attribute is affected. +setFilePermissions :: FilePath -> Mode -> IO () +setFilePermissions path m = do + m' <- modeFromMetadata <$> getFileMetadata path + setFileMode path ((m' .&. complement Win32.fILE_ATTRIBUTE_READONLY) .|. + (m .&. Win32.fILE_ATTRIBUTE_READONLY)) + +getAccessPermissions :: FilePath -> IO Permissions +getAccessPermissions path = do + m <- getFileMetadata path + let isDir = fileTypeIsDirectory (fileTypeFromMetadata m) + let w = hasWriteMode (modeFromMetadata m) + let x = (toLower <$> takeExtension path) + `elem` [".bat", ".cmd", ".com", ".exe"] + return Permissions + { readable = True + , writable = w + , executable = x && not isDir + , searchable = isDir + } + +setAccessPermissions :: FilePath -> Permissions -> IO () +setAccessPermissions path Permissions{writable = w} = do + setFilePermissions path (setWriteMode w 0) #endif diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,6 +1,19 @@ Changelog for the [`directory`][1] package ========================================== +## 1.3.1.1 (March 2017) + + * Fix a bug where `createFileLink` and `createDirectoryLink` failed to + handle `..` in absolute paths. + + * Improve support (partially) for paths longer than 260 characters on + Windows. To achieve this, many functions will now automatically prepend + `\\?\` before calling the Windows API. As a side effect, the `\\?\` + prefix may show up in the error messages of the affected functions. + + * `makeAbsolute` can now handle drive-relative paths on Windows such as + `C:foobar` + ## 1.3.1.0 (March 2017) * `findFile` (and similar functions): when an absolute path is given, the diff --git a/directory.cabal b/directory.cabal --- a/directory.cabal +++ b/directory.cabal @@ -1,5 +1,5 @@ name: directory -version: 1.3.1.0 +version: 1.3.1.1 -- NOTE: Don't forget to update ./changelog.md license: BSD3 license-file: LICENSE @@ -47,6 +47,7 @@ System.Directory.Internal.Prelude other-modules: System.Directory.Internal.C_utimensat + System.Directory.Internal.Common System.Directory.Internal.Config System.Directory.Internal.Posix System.Directory.Internal.Windows @@ -97,6 +98,7 @@ GetFileSize GetHomeDirectory001 GetPermissions001 + LongPaths MakeAbsolute PathIsSymbolicLink RemoveDirectoryRecursive001 diff --git a/tests/CanonicalizePath.hs b/tests/CanonicalizePath.hs --- a/tests/CanonicalizePath.hs +++ b/tests/CanonicalizePath.hs @@ -64,6 +64,11 @@ T(expectEq) () fooNon fooNon7 T(expectEq) () fooNon fooNon8 + -- make sure ".." gets expanded properly by 'toExtendedLengthPath' + -- (turns out this test won't detect the problem because GetFullPathName + -- would expand them for us if we don't, but leaving it here anyway) + T(expectEq) () foo =<< canonicalizePath (foo ".." "foo") + supportsSymbolicLinks <- supportsSymlinks when supportsSymbolicLinks $ do @@ -81,10 +86,18 @@ T(expectEq) () bar =<< canonicalizePath "lfoo/bar" T(expectEq) () barQux =<< canonicalizePath "lfoo/bar/qux" + -- create a haphazard chain of links + createDirectoryLink "./../foo/../foo/." "./foo/./somelink3" + createDirectoryLink ".././foo/somelink3" "foo/somelink2" + createDirectoryLink "./foo/somelink2" "somelink" + T(expectEq) () foo =<< canonicalizePath "somelink" + -- regression test for #64 createFileLink "../foo/non-existent" "foo/qux" + removeDirectoryLink "foo/somelink3" -- break the chain made earlier qux <- canonicalizePath "foo/qux" T(expectEq) () qux =<< canonicalizePath "foo/non-existent" + T(expectEq) () (foo "somelink3") =<< canonicalizePath "somelink" -- make sure it can handle loops createFileLink "loop1" "loop2" @@ -93,6 +106,11 @@ loop2 <- canonicalizePath "loop2" T(expectEq) () loop1 (normalise (dot "loop1")) T(expectEq) () loop2 (normalise (dot "loop2")) + + -- make sure ".." gets expanded properly by 'toExtendedLengthPath' + createDirectoryLink (foo ".." "foo") "foolink" + _ <- listDirectory "foolink" -- make sure directory is accessible + T(expectEq) () foo =<< canonicalizePath "foolink" caseInsensitive <- (False <$ createDirectory "FOO") diff --git a/tests/GetPermissions001.hs b/tests/GetPermissions001.hs --- a/tests/GetPermissions001.hs +++ b/tests/GetPermissions001.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} module GetPermissions001 where #include "util.inl" +import TestUtils main :: TestEnv -> IO () main _t = do @@ -9,6 +10,20 @@ checkExecutable checkOrdinary checkTrailingSlash + + -- 'writable' is the only permission that can be changed on Windows + writeFile "foo.txt" "" + foo <- makeAbsolute "foo.txt" + modifyPermissions "foo.txt" (\ p -> p { writable = False }) + T(expect) () =<< not . writable <$> getPermissions "foo.txt" + modifyPermissions "foo.txt" (\ p -> p { writable = True }) + T(expect) () =<< writable <$> getPermissions "foo.txt" + modifyPermissions "foo.txt" (\ p -> p { writable = False }) + T(expect) () =<< not . writable <$> getPermissions "foo.txt" + modifyPermissions foo (\ p -> p { writable = True }) + T(expect) () =<< writable <$> getPermissions foo + modifyPermissions foo (\ p -> p { writable = False }) + T(expect) () =<< not . writable <$> getPermissions foo where diff --git a/tests/LongPaths.hs b/tests/LongPaths.hs new file mode 100644 --- /dev/null +++ b/tests/LongPaths.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE CPP #-} +module LongPaths where +#include "util.inl" +import TestUtils +import System.FilePath (()) + +main :: TestEnv -> IO () +main _t = do + let longName = mconcat (replicate 10 "its_very_long") + longDir <- makeAbsolute (longName longName) + + supportsLongPaths <- do + -- create 2 dirs because 1 path segment by itself can't exceed MAX_PATH + -- tests: [createDirectory] + createDirectory =<< makeAbsolute longName + createDirectory longDir + return True + `catchIOError` \ _ -> + return False + + -- skip tests on file systems that do not support long paths + when supportsLongPaths $ do + + -- test relative paths + let relDir = longName mconcat (replicate 8 "yeah_its_long") + createDirectory relDir + T(expect) () =<< doesDirectoryExist relDir + T(expectEq) () [] =<< listDirectory relDir + setPermissions relDir emptyPermissions + T(expectEq) () False =<< writable <$> getPermissions relDir + + writeFile "foobar.txt" "^.^" -- writeFile does not support long paths yet + + -- tests: [renamePath], [copyFileWithMetadata] + renamePath "foobar.txt" (longDir "foobar_tmp.txt") + renamePath (longDir "foobar_tmp.txt") (longDir "foobar.txt") + copyFileWithMetadata (longDir "foobar.txt") + (longDir "foobar_copy.txt") + + -- tests: [doesDirectoryExist], [doesFileExist], [doesPathExist] + T(expect) () =<< doesDirectoryExist longDir + T(expect) () =<< doesFileExist (longDir "foobar.txt") + T(expect) () =<< doesPathExist longDir + T(expect) () =<< doesPathExist (longDir "foobar.txt") + + -- tests: [getFileSize], [getModificationTime] + T(expectEq) () 3 =<< getFileSize (longDir "foobar.txt") + _ <- getModificationTime (longDir "foobar.txt") + + supportsSymbolicLinks <- supportsSymlinks + when supportsSymbolicLinks $ do + + -- tests: [createDirectoryLink], [getSymbolicLinkTarget], [listDirectory] + -- also tests expansion of "." and ".." + createDirectoryLink "." (longDir "link") + _ <- listDirectory (longDir ".." longName "link") + T(expectEq) () "." =<< getSymbolicLinkTarget (longDir "." "link") + + return () + + -- [removeFile], [removeDirectory] are automatically tested by the cleanup diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -17,6 +17,7 @@ import qualified GetFileSize import qualified GetHomeDirectory001 import qualified GetPermissions001 +import qualified LongPaths import qualified MakeAbsolute import qualified PathIsSymbolicLink import qualified RemoveDirectoryRecursive001 @@ -47,6 +48,7 @@ T.isolatedRun _t "GetFileSize" GetFileSize.main T.isolatedRun _t "GetHomeDirectory001" GetHomeDirectory001.main T.isolatedRun _t "GetPermissions001" GetPermissions001.main + T.isolatedRun _t "LongPaths" LongPaths.main T.isolatedRun _t "MakeAbsolute" MakeAbsolute.main T.isolatedRun _t "PathIsSymbolicLink" PathIsSymbolicLink.main T.isolatedRun _t "RemoveDirectoryRecursive001" RemoveDirectoryRecursive001.main diff --git a/tests/MakeAbsolute.hs b/tests/MakeAbsolute.hs --- a/tests/MakeAbsolute.hs +++ b/tests/MakeAbsolute.hs @@ -3,6 +3,9 @@ #include "util.inl" import System.FilePath ((), addTrailingPathSeparator, dropTrailingPathSeparator, normalise) +#ifdef mingw32_HOST_OS +import System.FilePath (takeDrive) +#endif main :: TestEnv -> IO () main _t = do @@ -31,3 +34,13 @@ T(expectEq) () sfoo (normalise (dot "foo/")) T(expectEq) () sfoo sfoo2 T(expectEq) () sfoo sfoo3 + +#ifdef mingw32_HOST_OS + cwd <- getCurrentDirectory + let driveLetter = toUpper (head (takeDrive cwd)) + let driveLetter' = if driveLetter == 'Z' then 'A' else succ driveLetter + drp1 <- makeAbsolute (driveLetter : ":foobar") + drp2 <- makeAbsolute (driveLetter' : ":foobar") + T(expectEq) () drp1 =<< makeAbsolute "foobar" + T(expectEq) () drp2 (driveLetter' : ":\\foobar") +#endif