diff --git a/lib/Filesystem.hs b/lib/Filesystem.hs --- a/lib/Filesystem.hs +++ b/lib/Filesystem.hs @@ -3,25 +3,31 @@ -- | -- Module: Filesystem --- Copyright: 2011 John Millikin +-- Copyright: 2011-2012 John Millikin -- License: MIT -- --- Maintainer: jmillikin@gmail.com +-- Maintainer: John Millikin -- Portability: portable -- --- Simple 'FilePath'‐aware wrappers around standard "System.IO" --- computations. See the linked documentation for each computation for --- details on exceptions and operating system interaction. +-- Simple 'FilePath'‐aware wrappers around standard "System.IO" +-- computations. These wrappers are designed to work as similarly as +-- possible across various versions of GHC. +-- +-- In particular, they do not require POSIX file paths to be valid strings, +-- and can therefore open paths regardless of the current locale encoding. module Filesystem - ( IO.Handle + ( + -- * Exports from System.IO + IO.Handle , IO.IOMode(..) - , rename -- * Files , isFile , getModified , getSize , copyFile + , copyFileContent + , copyPermissions , removeFile -- ** Binary files @@ -43,11 +49,11 @@ , canonicalizePath , listDirectory - -- ** Creating + -- ** Creating directories , createDirectory , createTree - -- ** Removing + -- ** Removing directories , removeDirectory , removeTree @@ -62,24 +68,37 @@ , getAppDataDirectory , getAppCacheDirectory , getAppConfigDirectory + + -- * Other + , rename ) where +#ifndef CABAL_OS_WINDOWS +#if MIN_VERSION_base(4,2,0) +#define SYSTEMFILEIO_LOCAL_OPEN_FILE +#endif +#endif + import Prelude hiding (FilePath, readFile, writeFile, appendFile) import qualified Control.Exception as Exc +import Control.Monad (forM_, unless, when) import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL import qualified Data.Text as T import qualified Data.Text.IO as T import Foreign.Ptr (Ptr, nullPtr) -import Foreign.C (CString, withCString, peekCString) +import Foreign.C (CInt, CString, withCAString) +import qualified Foreign.C.Error as CError import qualified System.Environment as SE import Filesystem.Path (FilePath, append) -import Filesystem.Path.CurrentOS (currentOS, decodeString, encodeString) +import qualified Filesystem.Path as Path +import Filesystem.Path.CurrentOS (currentOS, encodeString, decodeString) import qualified Filesystem.Path.Rules as R import qualified System.IO as IO -import System.IO.Error (isDoesNotExistError) +import System.IO.Error (IOError) #ifdef CABAL_OS_WINDOWS @@ -88,7 +107,10 @@ , fromGregorian , secondsToDiffTime , picosecondsToDiffTime) +import Foreign.C (CWString, withCWString) import qualified System.Win32 as Win32 +import System.IO.Error (isDoesNotExistError) +import qualified System.Directory as SD #else @@ -99,48 +121,86 @@ #endif -import qualified System.Directory as SD +#ifdef SYSTEMFILEIO_LOCAL_OPEN_FILE +import Data.Bits ((.|.)) +import GHC.IO.Handle.FD (mkHandleFromFD) +import GHC.IO.FD (mkFD) +import qualified GHC.IO.Device +import qualified System.Posix.Internals +#endif -- | Check if a file exists at the given path. -- --- See: 'SD.doesFileExist' +-- Any non‐directory object, including devices and pipes, are +-- considered to be files. Symbolic links are resolved to their targets +-- before checking their type. +-- +-- This computation does not throw exceptions. isFile :: FilePath -> IO Bool +#ifdef CABAL_OS_WINDOWS isFile path = SD.doesFileExist (encodeString path) +#else +isFile path = Exc.catch + (do + stat <- posixStat "isFile" path + return (not (Posix.isDirectory stat))) + ((\_ -> return False) :: IOError -> IO Bool) +#endif -- | Check if a directory exists at the given path. -- --- See: 'SD.doesDirectoryExist' +-- Symbolic links are resolved to their targets before checking their type. +-- +-- This computation does not throw exceptions. isDirectory :: FilePath -> IO Bool +#ifdef CABAL_OS_WINDOWS isDirectory path = SD.doesDirectoryExist (encodeString path) +#else +isDirectory path = Exc.catch + (do + stat <- posixStat "isFile" path + return (Posix.isDirectory stat)) + ((\_ -> return False) :: IOError -> IO Bool) +#endif --- | Rename a filesystem object. Some operating systems have restrictions --- on what objects can be renamed; see linked documentation for details. +-- | Rename a filesystem object. -- --- See: 'SD.renameFile' and 'SD.renameDirectory' +-- This computation throws 'IOError' on failure. See “Classifying +-- I/O errors” in the "System.IO.Error" documentation for information on +-- why the failure occured. rename :: FilePath -> FilePath -> IO () rename old new = +#ifdef CABAL_OS_WINDOWS let old' = encodeString old in let new' = encodeString new in -#ifdef CABAL_OS_WINDOWS Win32.moveFileEx old' new' Win32.mOVEFILE_REPLACE_EXISTING #else - Posix.rename old' new' + withFilePath old $ \old' -> + withFilePath new $ \new' -> + throwErrnoPathIfMinus1_ "rename" old (c_rename old' new') + +foreign import ccall unsafe "rename" + c_rename :: CString -> CString -> IO CInt + #endif --- Resolve symlinks and \"..\" path elements to return a canonical path. +-- | Resolve symlinks and \"..\" path elements to return a canonical path. -- It is intended that two paths referring to the same object will always -- resolve to the same canonical path. -- -- Note that on many operating systems, it is impossible to guarantee that -- two paths to the same file will resolve to the same canonical path. -- --- See: 'SD.canonicalizePath' +-- This computation throws 'IOError' on failure. See “Classifying +-- I/O errors” in the "System.IO.Error" documentation for information on +-- why the failure occured. -- -- Since: 0.1.1 canonicalizePath :: FilePath -> IO FilePath -canonicalizePath path = fmap decodeString $ do - let path' = encodeString path +canonicalizePath path = + let path' = encodeString path in #ifdef CABAL_OS_WINDOWS + fmap decodeString $ #if MIN_VERSION_Win32(2,2,1) Win32.getFullPathName path' #else @@ -149,9 +209,11 @@ c_GetFullPathNameW c_name len buf nullPtr) 512 #endif #else - withCString path' $ \cPath -> do + withFilePath path $ \cPath -> do cOut <- Posix.throwErrnoPathIfNull "canonicalizePath" path' (c_realpath cPath nullPtr) - peekCString cOut + bytes <- B.packCString cOut + c_free cOut + return (R.decode R.posix bytes) #endif #ifdef CABAL_OS_WINDOWS @@ -170,77 +232,236 @@ -- | Create a directory at a given path. The user may choose whether it is -- an error for a directory to already exist at that path. -- --- See: 'SD.createDirectory'. +-- This computation throws 'IOError' on failure. See “Classifying +-- I/O errors” in the "System.IO.Error" documentation for information on +-- why the failure occured. createDirectory :: Bool -- ^ Succeed if the directory already exists -> FilePath -> IO () -createDirectory False path = - let path' = encodeString path in +createDirectory succeedIfExists path = #ifdef CABAL_OS_WINDOWS - Win32.createDirectory path' Nothing + let path' = encodeString path in + if succeedIfExists + then SD.createDirectoryIfMissing False path' + else Win32.createDirectory path' Nothing #else - Posix.createDirectory path' 0o777 + withFilePath path $ \cPath -> + throwErrnoPathIfMinus1Retry_ "createDirectory" path $ if succeedIfExists + then mkdirIfMissing path cPath 0o777 + else c_mkdir cPath 0o777 + +mkdirIfMissing :: FilePath -> CString -> CInt -> IO CInt +mkdirIfMissing path cPath mode = do + rc <- c_mkdir cPath mode + if rc == -1 + then do + errno <- CError.getErrno + if errno == CError.eEXIST + then do + dirExists <- isDirectory path + if dirExists + then return 0 + else return rc + else return rc + else return rc + +foreign import ccall unsafe "mkdir" + c_mkdir :: CString -> CInt -> IO CInt #endif -createDirectory True path = SD.createDirectoryIfMissing False (encodeString path) -- | Create a directory at a given path, including any parents which might -- be missing. -- --- See: 'SD.createDirectoryIfMissing' +-- This computation throws 'IOError' on failure. See “Classifying +-- I/O errors” in the "System.IO.Error" documentation for information on +-- why the failure occured. createTree :: FilePath -> IO () +#ifdef CABAL_OS_WINDOWS createTree path = SD.createDirectoryIfMissing True (encodeString path) +#else +createTree path = do + let parent = Path.parent path + parentExists <- isDirectory parent + unless parentExists (createTree parent) + withFilePath path $ \cPath -> + throwErrnoPathIfMinus1Retry_ "createTree" path (mkdirIfMissing path cPath 0o777) +#endif --- | List contents of a directory, excluding @\".\"@ and @\"..\"@. Each --- returned 'FilePath' includes the path of the directory. +-- | List objects in a directory, excluding @\".\"@ and @\"..\"@. Each +-- returned 'FilePath' includes the path of the directory. Entries are not +-- sorted. -- --- See: 'SD.getDirectoryContents' +-- This computation throws 'IOError' on failure. See “Classifying +-- I/O errors” in the "System.IO.Error" documentation for information on +-- why the failure occured. listDirectory :: FilePath -> IO [FilePath] -listDirectory path = fmap cleanup contents where - contents = SD.getDirectoryContents (encodeString path) - cleanup = map (append path) . map decodeString . filter (`notElem` [".", ".."]) +#ifdef CABAL_OS_WINDOWS +listDirectory root = fmap cleanup contents where + contents = SD.getDirectoryContents (encodeString root) + cleanup = map (append root) . map decodeString . filter (`notElem` [".", ".."]) +#else +listDirectory root = Exc.bracket alloc free list where + alloc = do + dirent <- c_alloc_dirent + dir <- openDir root + return (dirent, dir) + free (dirent, dir) = do + c_free_dirent dirent + closeDir dir + list (dirent, dir) = loop where + loop = do + next <- readDir dir dirent + case next of + Nothing -> return [] + Just bytes | ignore bytes -> loop + Just bytes -> do + let name = append root (R.decode R.posix bytes) + names <- loop + return (name:names) --- | Remove a file. +ignore :: B.ByteString -> Bool +ignore = ignore' where + dot = B.pack [46] + dotdot = B.pack [46, 46] + ignore' b = b == dot || b == dotdot + +data Dir = Dir FilePath (Ptr ()) + +openDir :: FilePath -> IO Dir +openDir root = withFilePath root $ \cRoot -> do + p <- throwErrnoPathIfNullRetry "listDirectory" root (c_opendir cRoot) + return (Dir root p) + +closeDir :: Dir -> IO () +closeDir (Dir _ p) = CError.throwErrnoIfMinus1Retry_ "listDirectory" (c_closedir p) + +readDir :: Dir -> Ptr () -> IO (Maybe B.ByteString) +readDir (Dir _ p) dirent = do + rc <- CError.throwErrnoIfMinus1Retry "listDirectory" (c_readdir p dirent) + if rc == 0 + then do + bytes <- c_dirent_name dirent >>= B.packCString + return (Just bytes) + else return Nothing + +foreign import ccall unsafe "opendir" + c_opendir :: CString -> IO (Ptr ()) + +foreign import ccall unsafe "opendir" + c_closedir :: Ptr () -> IO CInt + +foreign import ccall unsafe "hssystemfileio_alloc_dirent" + c_alloc_dirent :: IO (Ptr ()) + +foreign import ccall unsafe "hssystemfileio_free_dirent" + c_free_dirent :: Ptr () -> IO () + +foreign import ccall unsafe "hssystemfileio_readdir" + c_readdir :: Ptr () -> Ptr () -> IO CInt + +foreign import ccall unsafe "hssystemfileio_dirent_name" + c_dirent_name :: Ptr () -> IO CString + +#endif + +-- | Remove a file. This will fail if the file does not exist. -- --- See: 'SD.removeFile' +-- This computation cannot remove directories. For that, use 'removeDirectory' +-- or 'removeTree'. +-- +-- This computation throws 'IOError' on failure. See “Classifying +-- I/O errors” in the "System.IO.Error" documentation for information on +-- why the failure occured. removeFile :: FilePath -> IO () removeFile path = - let path' = encodeString path in #ifdef CABAL_OS_WINDOWS - Win32.deleteFile path' + Win32.deleteFile (encodeString path) #else - Posix.removeLink path' + withFilePath path $ \cPath -> + throwErrnoPathIfMinus1_ "removeFile" path (c_unlink cPath) + +foreign import ccall unsafe "unlink" + c_unlink :: CString -> IO CInt #endif -- | Remove an empty directory. -- --- See: 'SD.removeDirectory' +-- This computation throws 'IOError' on failure. See “Classifying +-- I/O errors” in the "System.IO.Error" documentation for information on +-- why the failure occured. removeDirectory :: FilePath -> IO () removeDirectory path = - let path' = encodeString path in #ifdef CABAL_OS_WINDOWS - Win32.removeDirectory path' + Win32.removeDirectory (encodeString path) #else - Posix.removeDirectory path' + withFilePath path $ \cPath -> + throwErrnoPathIfMinus1Retry_ "removeDirectory" path (c_rmdir cPath) + +foreign import ccall unsafe "rmdir" + c_rmdir :: CString -> IO CInt #endif -- | Recursively remove a directory tree rooted at the given path. -- --- See: 'SD.removeDirectoryRecursive' +-- This computation does not follow symlinks. If the tree contains symlinks, +-- the links themselves will be removed, but not the objects they point to. +-- +-- If the root path is a symlink, then it will be treated as if it were a +-- regular directory. +-- +-- This computation throws 'IOError' on failure. See “Classifying +-- I/O errors” in the "System.IO.Error" documentation for information on +-- why the failure occured. removeTree :: FilePath -> IO () -removeTree path = SD.removeDirectoryRecursive (encodeString path) +#ifdef CABAL_OS_WINDOWS +removeTree root = SD.removeDirectoryRecursive (encodeString root) +#else +removeTree root = do + items <- listDirectory root + forM_ items $ \item -> Exc.catch + (removeFile item) + (\exc -> do + isDir <- isRealDir item + if isDir + then removeTree item + else Exc.throwIO (exc :: IOError)) + removeDirectory root +-- Check whether a path is a directory, and not just a symlink to a directory. +-- +-- This is used in 'removeTree' to prevent recursing into symlinks if the link +-- itself cannot be deleted. +isRealDir :: FilePath -> IO Bool +isRealDir path = withFilePath path $ \cPath -> do + rc <- throwErrnoPathIfMinus1Retry "removeTree" path (c_isrealdir cPath) + return (rc == 1) + +foreign import ccall unsafe "hssystemfileio_isrealdir" + c_isrealdir :: CString -> IO CInt + +#endif + -- | Get the current working directory. -- --- See: 'SD.getCurrentDirectory' +-- This computation throws 'IOError' on failure. See “Classifying +-- I/O errors” in the "System.IO.Error" documentation for information on +-- why the failure occured. getWorkingDirectory :: IO FilePath -getWorkingDirectory = fmap decodeString $ do +getWorkingDirectory = do #ifdef CABAL_OS_WINDOWS #if MIN_VERSION_Win32(2,2,1) - Win32.getCurrentDirectory + fmap decodeString Win32.getCurrentDirectory #else - Win32.try "getCurrentDirectory" (flip c_GetCurrentDirectoryW) 512 + fmap decodeString (Win32.try "getWorkingDirectory" (flip c_GetCurrentDirectoryW) 512) #endif #else - Posix.getWorkingDirectory + buf <- CError.throwErrnoIfNull "getWorkingDirectory" c_getcwd + bytes <- B.packCString buf + c_free buf + return (R.decode R.posix bytes) + +foreign import ccall unsafe "hssystemfileio_getcwd" + c_getcwd :: IO CString + #endif #ifdef CABAL_OS_WINDOWS @@ -253,14 +474,20 @@ -- | Set the current working directory. -- --- See: 'SD.setCurrentDirectory' +-- This computation throws 'IOError' on failure. See “Classifying +-- I/O errors” in the "System.IO.Error" documentation for information on +-- why the failure occured. setWorkingDirectory :: FilePath -> IO () setWorkingDirectory path = - let path' = encodeString path in #ifdef CABAL_OS_WINDOWS - Win32.setCurrentDirectory path' + Win32.setCurrentDirectory (encodeString path) #else - Posix.changeWorkingDirectory path' + withFilePath path $ \cPath -> + throwErrnoPathIfMinus1Retry_ "setWorkingDirectory" path (c_chdir cPath) + +foreign import ccall unsafe "chdir" + c_chdir :: CString -> IO CInt + #endif -- TODO: expose all known exceptions as specific types, for users to catch @@ -275,22 +502,40 @@ -- For data files the user does not explicitly create, such as automatic -- saves, use 'getAppDataDirectory'. -- --- See: 'SD.getHomeDirectory' +-- This computation throws 'IOError' on failure. See “Classifying +-- I/O errors” in the "System.IO.Error" documentation for information on +-- why the failure occured. getHomeDirectory :: IO FilePath +#ifdef CABAL_OS_WINDOWS getHomeDirectory = fmap decodeString SD.getHomeDirectory +#else +getHomeDirectory = do + path <- getenv "HOME" + case path of + Just p -> return p + Nothing -> do + -- use getEnv to throw the right exception type + fmap decodeString (SE.getEnv "HOME") +#endif --- | Get the user’s home directory. This is a good starting point for +-- | Get the user’s desktop directory. This is a good starting point for -- file dialogs and other user queries. For data files the user does not -- explicitly create, such as automatic saves, use 'getAppDataDirectory'. +-- +-- This computation throws 'IOError' on failure. See “Classifying +-- I/O errors” in the "System.IO.Error" documentation for information on +-- why the failure occured. getDesktopDirectory :: IO FilePath getDesktopDirectory = xdg "XDG_DESKTOP_DIR" Nothing (homeSlash "Desktop") -- | Get the user’s documents directory. This is a good place to save --- user-created files. For data files the user does not explicitly create, --- such as automatic saves, use 'getAppDataDirectory'. +-- user‐created files. For data files the user does not explicitly +-- create, such as automatic saves, use 'getAppDataDirectory'. -- --- See: 'SD.getUserDocumentsDirectory' +-- This computation throws 'IOError' on failure. See “Classifying +-- I/O errors” in the "System.IO.Error" documentation for information on +-- why the failure occured. getDocumentsDirectory :: IO FilePath getDocumentsDirectory = xdg "XDG_DOCUMENTS_DIR" Nothing #ifdef CABAL_OS_WINDOWS @@ -303,7 +548,9 @@ -- label. This directory is where applications should store data the user did -- not explicitly create, such as databases and automatic saves. -- --- See: 'SD.getAppUserDataDirectory' +-- This computation throws 'IOError' on failure. See “Classifying +-- I/O errors” in the "System.IO.Error" documentation for information on +-- why the failure occured. getAppDataDirectory :: T.Text -> IO FilePath getAppDataDirectory label = xdg "XDG_DATA_HOME" (Just label) #ifdef CABAL_OS_WINDOWS @@ -315,6 +562,10 @@ -- | Get the user’s application cache directory, given an application -- label. This directory is where applications should store caches, which -- might be large and can be safely deleted. +-- +-- This computation throws 'IOError' on failure. See “Classifying +-- I/O errors” in the "System.IO.Error" documentation for information on +-- why the failure occured. getAppCacheDirectory :: T.Text -> IO FilePath getAppCacheDirectory label = xdg "XDG_CACHE_HOME" (Just label) #ifdef CABAL_OS_WINDOWS @@ -326,6 +577,10 @@ -- | Get the user’s application configuration directory, given an -- application label. This directory is where applications should store their -- configurations and settings. +-- +-- This computation throws 'IOError' on failure. See “Classifying +-- I/O errors” in the "System.IO.Error" documentation for information on +-- why the failure occured. getAppConfigDirectory :: T.Text -> IO FilePath getAppConfigDirectory label = xdg "XDG_CONFIG_HOME" (Just label) #ifdef CABAL_OS_WINDOWS @@ -339,36 +594,107 @@ home <- getHomeDirectory return (append home (decodeString path)) -getenv :: String -> IO (Maybe String) +getenv :: String -> IO (Maybe FilePath) +#ifdef CABAL_OS_WINDOWS getenv key = Exc.catch - (fmap Just (SE.getEnv key)) + (fmap (Just . decodeString) (SE.getEnv key)) (\e -> if isDoesNotExistError e then return Nothing else Exc.throwIO e) +#else +getenv key = withCAString key $ \cKey -> do + ret <- c_getenv cKey + if ret == nullPtr + then return Nothing + else do + bytes <- B.packCString ret + return (Just (R.decode R.posix bytes)) +foreign import ccall unsafe "getenv" + c_getenv :: CString -> IO CString + +#endif + xdg :: String -> Maybe T.Text -> IO FilePath -> IO FilePath xdg envkey label fallback = do env <- getenv envkey dir <- case env of - Just var -> return (decodeString var) + Just var -> return var Nothing -> fallback return $ case label of Just text -> append dir (R.fromText currentOS text) Nothing -> dir --- | Copy a file to a new entry in the filesystem. If a file already exists --- at the new location, it will be replaced. +-- | Copy the content of a file to a new entry in the filesystem. If a +-- file already exists at the new location, it will be replaced. Copying +-- a file is not atomic. -- --- See: 'SD.copyFile' +-- This computation throws 'IOError' on failure. See “Classifying +-- I/O errors” in the "System.IO.Error" documentation for information on +-- why the failure occured. -- +-- Since: 0.2.4 / 0.3.4 +copyFileContent :: FilePath -- ^ Old location + -> FilePath -- ^ New location + -> IO () +copyFileContent oldPath newPath = + withFile oldPath IO.ReadMode $ \old -> + withFile newPath IO.WriteMode $ \new -> + BL.hGetContents old >>= BL.hPut new + +-- | Copy the permissions from one path to another. Both paths must already +-- exist. +-- +-- This computation throws 'IOError' on failure. See “Classifying +-- I/O errors” in the "System.IO.Error" documentation for information on +-- why the failure occured. +-- +-- Since: 0.2.4 / 0.3.4 +copyPermissions :: FilePath -- ^ Old location + -> FilePath -- ^ New location + -> IO () +copyPermissions oldPath newPath = + withFilePath oldPath $ \cOldPath -> + withFilePath newPath $ \cNewPath -> + CError.throwErrnoIfMinus1Retry_ "copyPermissions" $ + c_copy_permissions cOldPath cNewPath + +#ifdef CABAL_OS_WINDOWS + +foreign import ccall unsafe "hssystemfileio_copy_permissions" + c_copy_permissions :: CWString -> CWString -> IO CInt + +#else + +foreign import ccall unsafe "hssystemfileio_copy_permissions" + c_copy_permissions :: CString -> CString -> IO CInt + +#endif + +-- | Copy the content and permissions of a file to a new entry in the +-- filesystem. If a file already exists at the new location, it will be +-- replaced. Copying a file is not atomic. +-- +-- This computation throws 'IOError' on failure. See “Classifying +-- I/O errors” in the "System.IO.Error" documentation for information on +-- why the failure occured. +-- -- Since: 0.1.1 copyFile :: FilePath -- ^ Old location -> FilePath -- ^ New location -> IO () -copyFile old new = SD.copyFile (encodeString old) (encodeString new) +copyFile oldPath newPath = do + copyFileContent oldPath newPath + Exc.catch + (copyPermissions oldPath newPath) + ((\_ -> return ()) :: IOError -> IO ()) -- | Get when the object at a given path was last modified. -- +-- This computation throws 'IOError' on failure. See “Classifying +-- I/O errors” in the "System.IO.Error" documentation for information on +-- why the failure occured. +-- -- Since: 0.2 getModified :: FilePath -> IO UTCTime getModified path = do @@ -392,15 +718,19 @@ return (UTCTime date (seconds + msecs)) #else - stat <- Posix.getFileStatus (encodeString path) + stat <- posixStat "getModified" path let mtime = Posix.modificationTime stat return (posixSecondsToUTCTime (realToFrac mtime)) #endif -- | Get the size of an object at a given path. For special objects like --- links or directories, the size is filesystem‐ and --- platform‐dependent. +-- links or directories, the size is filesystem‐ and +-- platform‐dependent. -- +-- This computation throws 'IOError' on failure. See “Classifying +-- I/O errors” in the "System.IO.Error" documentation for information on +-- why the failure occured. +-- -- Since: 0.2 getSize :: FilePath -> IO Integer getSize path = do @@ -408,39 +738,51 @@ info <- withHANDLE path Win32.getFileInformationByHandle return (toInteger (Win32.bhfiSize info)) #else - stat <- Posix.getFileStatus (encodeString path) + stat <- posixStat "getSize" path return (toInteger (Posix.fileSize stat)) #endif -- | Open a file in binary mode, and return an open 'Handle'. The 'Handle' --- should be 'IO.hClose'd when it is no longer needed. +-- should be closed with 'IO.hClose' when it is no longer needed. -- -- 'withFile' is easier to use, because it will handle the 'Handle'’s -- lifetime automatically. -- --- See: 'IO.openBinaryFile' +-- This computation throws 'IOError' on failure. See “Classifying +-- I/O errors” in the "System.IO.Error" documentation for information on +-- why the failure occured. openFile :: FilePath -> IO.IOMode -> IO IO.Handle +#ifdef SYSTEMFILEIO_LOCAL_OPEN_FILE +openFile path mode = openFile' "openFile" path mode Nothing +#else openFile path = IO.openBinaryFile (encodeString path) +#endif -- | Open a file in binary mode, and pass its 'Handle' to a provided -- computation. The 'Handle' will be automatically closed when the -- computation returns. -- --- See: 'IO.withBinaryFile' +-- This computation throws 'IOError' on failure. See “Classifying +-- I/O errors” in the "System.IO.Error" documentation for information on +-- why the failure occured. withFile :: FilePath -> IO.IOMode -> (IO.Handle -> IO a) -> IO a withFile path mode = Exc.bracket (openFile path mode) IO.hClose --- | Read in the entire contents of a binary file. +-- | Read in the entire content of a binary file. -- --- See: 'B.readFile' +-- This computation throws 'IOError' on failure. See “Classifying +-- I/O errors” in the "System.IO.Error" documentation for information on +-- why the failure occured. readFile :: FilePath -> IO B.ByteString readFile path = withFile path IO.ReadMode (\h -> IO.hFileSize h >>= B.hGet h . fromIntegral) --- | Replace the entire contents of a binary file with the provided +-- | Replace the entire content of a binary file with the provided -- 'B.ByteString'. -- --- See: 'B.writeFile' +-- This computation throws 'IOError' on failure. See “Classifying +-- I/O errors” in the "System.IO.Error" documentation for information on +-- why the failure occured. writeFile :: FilePath -> B.ByteString -> IO () writeFile path bytes = withFile path IO.WriteMode (\h -> B.hPut h bytes) @@ -448,39 +790,53 @@ -- | Append a 'B.ByteString' to a file. If the file does not exist, it will -- be created. -- --- See: 'B.appendFile' +-- This computation throws 'IOError' on failure. See “Classifying +-- I/O errors” in the "System.IO.Error" documentation for information on +-- why the failure occured. appendFile :: FilePath -> B.ByteString -> IO () appendFile path bytes = withFile path IO.AppendMode (\h -> B.hPut h bytes) -- | Open a file in text mode, and return an open 'Handle'. The 'Handle' --- should be 'IO.hClose'd when it is no longer needed. +-- should be closed with 'IO.hClose' when it is no longer needed. -- -- 'withTextFile' is easier to use, because it will handle the -- 'Handle'’s lifetime automatically. -- --- See: 'IO.openFile' +-- This computation throws 'IOError' on failure. See “Classifying +-- I/O errors” in the "System.IO.Error" documentation for information on +-- why the failure occured. openTextFile :: FilePath -> IO.IOMode -> IO IO.Handle +#ifdef SYSTEMFILEIO_LOCAL_OPEN_FILE +openTextFile path mode = openFile' "openTextFile" path mode (Just IO.localeEncoding) +#else openTextFile path = IO.openFile (encodeString path) +#endif -- | Open a file in text mode, and pass its 'Handle' to a provided -- computation. The 'Handle' will be automatically closed when the -- computation returns. -- --- See: 'IO.withFile' +-- This computation throws 'IOError' on failure. See “Classifying +-- I/O errors” in the "System.IO.Error" documentation for information on +-- why the failure occured. withTextFile :: FilePath -> IO.IOMode -> (IO.Handle -> IO a) -> IO a withTextFile path mode = Exc.bracket (openTextFile path mode) IO.hClose --- | Read in the entire contents of a text file. +-- | Read in the entire content of a text file. -- --- See: 'T.readFile' +-- This computation throws 'IOError' on failure. See “Classifying +-- I/O errors” in the "System.IO.Error" documentation for information on +-- why the failure occured. readTextFile :: FilePath -> IO T.Text readTextFile path = openTextFile path IO.ReadMode >>= T.hGetContents --- | Replace the entire contents of a text file with the provided +-- | Replace the entire content of a text file with the provided -- 'T.Text'. -- --- See: 'T.writeFile' +-- This computation throws 'IOError' on failure. See “Classifying +-- I/O errors” in the "System.IO.Error" documentation for information on +-- why the failure occured. writeTextFile :: FilePath -> T.Text -> IO () writeTextFile path text = withTextFile path IO.WriteMode (\h -> T.hPutStr h text) @@ -488,12 +844,42 @@ -- | Append 'T.Text' to a file. If the file does not exist, it will -- be created. -- --- See: 'T.appendFile' +-- This computation throws 'IOError' on failure. See “Classifying +-- I/O errors” in the "System.IO.Error" documentation for information on +-- why the failure occured. appendTextFile :: FilePath -> T.Text -> IO () appendTextFile path text = withTextFile path IO.AppendMode (\h -> T.hPutStr h text) +#ifdef SYSTEMFILEIO_LOCAL_OPEN_FILE +openFile' :: String -> FilePath -> IO.IOMode -> (Maybe IO.TextEncoding) -> IO IO.Handle +openFile' loc path mode codec = open where + mode_flags = case mode of + IO.ReadMode -> System.Posix.Internals.o_RDONLY + IO.WriteMode -> System.Posix.Internals.o_WRONLY + IO.ReadWriteMode -> System.Posix.Internals.o_RDWR + IO.AppendMode -> System.Posix.Internals.o_APPEND + flags = mode_flags .|. + System.Posix.Internals.o_NOCTTY .|. + System.Posix.Internals.o_NONBLOCK + + sys_c_open = System.Posix.Internals.c_open + sys_c_close = System.Posix.Internals.c_close + open = withFilePath path $ \cPath -> do + c_fd <- throwErrnoPathIfMinus1Retry loc path (sys_c_open cPath flags 0o666) + (fd, fd_type) <- Exc.onException + (mkFD c_fd mode Nothing False True) + (sys_c_close c_fd) + when (mode == IO.WriteMode && fd_type == GHC.IO.Device.RegularFile) $ do + GHC.IO.Device.setSize fd 0 + Exc.onException + (mkHandleFromFD fd fd_type (encodeString path) mode False codec) + (GHC.IO.Device.close fd) + +#endif + #ifdef CABAL_OS_WINDOWS + withHANDLE :: FilePath -> (Win32.HANDLE -> IO a) -> IO a withHANDLE path = Exc.bracket open close where open = Win32.createFile @@ -505,4 +891,61 @@ 0 Nothing close = Win32.closeHandle + +withFilePath :: FilePath -> (CWString -> IO a) -> IO a +withFilePath path = withCWString (encodeString path) + +#else + +withFilePath :: FilePath -> (CString -> IO a) -> IO a +withFilePath path = B.useAsCString (R.encode R.posix path) + +throwErrnoPathIfMinus1 :: String -> FilePath -> IO CInt -> IO CInt +throwErrnoPathIfMinus1 loc path = CError.throwErrnoPathIfMinus1 loc (encodeString path) + +throwErrnoPathIfMinus1_ :: String -> FilePath -> IO CInt -> IO () +throwErrnoPathIfMinus1_ loc path = CError.throwErrnoPathIfMinus1_ loc (encodeString path) + +throwErrnoPathIfNullRetry :: String -> FilePath -> IO (Ptr a) -> IO (Ptr a) +throwErrnoPathIfNullRetry = throwErrnoPathIfRetry (== nullPtr) + +throwErrnoPathIfMinus1Retry :: String -> FilePath -> IO CInt -> IO CInt +throwErrnoPathIfMinus1Retry = throwErrnoPathIfRetry (== -1) + +throwErrnoPathIfMinus1Retry_ :: String -> FilePath -> IO CInt -> IO () +throwErrnoPathIfMinus1Retry_ = throwErrnoPathIfRetry_ (== -1) + +throwErrnoPathIfRetry :: (a -> Bool) -> String -> FilePath -> IO a -> IO a +throwErrnoPathIfRetry failed loc path io = loop where + loop = do + a <- io + if failed a + then do + errno <- CError.getErrno + if errno == CError.eINTR + then loop + else CError.throwErrnoPath loc (encodeString path) + else return a + +throwErrnoPathIfRetry_ :: (a -> Bool) -> String -> FilePath -> IO a -> IO () +throwErrnoPathIfRetry_ failed loc path io = do + _ <- throwErrnoPathIfRetry failed loc path io + return () + +withFd :: String -> FilePath -> (Posix.Fd -> IO a) -> IO a +withFd fnName path = Exc.bracket open close where + open = withFilePath path $ \cpath -> do + fd <- throwErrnoPathIfMinus1 fnName path (c_open cpath 0) + return (Posix.Fd fd) + close = Posix.closeFd + +posixStat :: String -> FilePath -> IO Posix.FileStatus +posixStat loc path = withFd loc path Posix.getFdStatus + +foreign import ccall unsafe "open" + c_open :: CString -> CInt -> IO CInt + +foreign import ccall unsafe "free" + c_free :: Ptr a -> IO () + #endif diff --git a/lib/hssystemfileio-unix.c b/lib/hssystemfileio-unix.c new file mode 100644 --- /dev/null +++ b/lib/hssystemfileio-unix.c @@ -0,0 +1,93 @@ +#include "hssystemfileio-unix.h" + +#include +#include +#include +#include +#include + +struct dirent * +hssystemfileio_alloc_dirent() +{ + return malloc(sizeof (struct dirent)); +} + +void +hssystemfileio_free_dirent(struct dirent *p) +{ + free(p); +} + +int +hssystemfileio_readdir(DIR *dir, struct dirent *dirent) +{ + struct dirent *dirent_result; + while (1) + { + int rc = readdir_r(dir, dirent, &dirent_result); + if (rc != 0) + { return -1; } + + if (dirent_result == NULL) + { return 1; } + + return 0; + } +} + +char * +hssystemfileio_dirent_name(struct dirent *dirent) +{ + return dirent->d_name; +} + +char * +hssystemfileio_getcwd(void) +{ +#ifdef PATH_MAX + int bufsize = PATH_MAX; +#else + int bufsize = 4096; +#endif + char *buf = malloc(bufsize); + while (1) + { + char *ret = getcwd(buf, bufsize); + if (ret != NULL) + { return ret; } + + free(buf); + if (errno == ERANGE) + { + bufsize *= 2; + buf = malloc(bufsize); + continue; + } + return NULL; + } +} + +int +hssystemfileio_isrealdir(const char *path) +{ + struct stat st; + int rc = lstat(path, &st); + if (rc == -1) + { return rc; } + + if (S_ISDIR(st.st_mode)) + { return 1; } + + return 0; +} + +int +hssystemfileio_copy_permissions(const char *old_path, const char *new_path) +{ + struct stat st; + int rc = stat(old_path, &st); + if (rc == -1) + { return rc; } + + return chmod(new_path, st.st_mode); +} diff --git a/lib/hssystemfileio-win32.c b/lib/hssystemfileio-win32.c new file mode 100644 --- /dev/null +++ b/lib/hssystemfileio-win32.c @@ -0,0 +1,16 @@ +#include "hssystemfileio-win32.h" + +#include +#include +#include + +int +hssystemfileio_copy_permissions(const wchar_t *old_path, const wchar_t *new_path) +{ + struct _stat st; + int rc = _wstat(old_path, &st); + if (rc == -1) + { return rc; } + + return _wchmod(new_path, st.st_mode); +} diff --git a/system-fileio.cabal b/system-fileio.cabal --- a/system-fileio.cabal +++ b/system-fileio.cabal @@ -1,21 +1,25 @@ name: system-fileio -version: 0.3.3 -synopsis: High-level filesystem interaction +version: 0.3.4 license: MIT license-file: license.txt author: John Millikin maintainer: John Millikin -copyright: John Millikin 2011 build-type: Simple cabal-version: >= 1.6 category: System stability: experimental -homepage: https://john-millikin.com/software/hs-fileio/ +homepage: https://john-millikin.com/software/haskell-filesystem/ bug-reports: mailto:jmillikin@gmail.com +synopsis: Consistent filesystem interaction across GHC versions description: This is a small wrapper around the \"directory\", \"unix\", and \"Win32\" - packages for use with \"system-filepath\". + packages, for use with \"system-filepath\". It provides a consistent API + to the various versions of these packages distributed with different + versions of GHC. + . + In particular, this library supports working with POSIX files that have + paths which can't be decoded in the current locale encoding. extra-source-files: scripts/common.bash @@ -29,13 +33,13 @@ tests/FilesystemTests/Windows.hs source-repository head - type: bzr - location: https://john-millikin.com/software/hs-fileio/ + type: bazaar + location: https://john-millikin.com/branches/system-fileio/0.3/ source-repository this - type: bzr - location: https://john-millikin.com/branches/hs-fileio/0.3/ - tag: system-fileio_0.3.3 + type: bazaar + location: https://john-millikin.com/branches/system-fileio/0.3/ + tag: system-fileio_0.3.4 library ghc-options: -Wall -O2 @@ -44,16 +48,20 @@ build-depends: base >= 4.0 && < 5.0 , bytestring >= 0.9 && < 0.10 - , directory >= 1.0 && < 1.2 , system-filepath >= 0.3.1 && < 0.5 , text >= 0.7.1 && < 0.12 , time >= 1.0 && < 1.5 if os(windows) cpp-options: -DCABAL_OS_WINDOWS - build-depends: Win32 >= 2.2 && < 2.3 + build-depends: + Win32 >= 2.2 && < 2.3 + , directory >= 1.0 && < 1.2 + c-sources: lib/hssystemfileio-win32.c else - build-depends: unix >= 2.3 && < 2.6 + build-depends: + unix >= 2.3 && < 2.6 + c-sources: lib/hssystemfileio-unix.c exposed-modules: Filesystem diff --git a/tests/FilesystemTests/Posix.hs b/tests/FilesystemTests/Posix.hs --- a/tests/FilesystemTests/Posix.hs +++ b/tests/FilesystemTests/Posix.hs @@ -11,17 +11,30 @@ ) where import Prelude hiding (FilePath) +import Control.Exception (bracket) import Control.Monad import Control.Monad.IO.Class (liftIO) import qualified Data.ByteString +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as Char8 +import qualified Data.Text import Data.Text (Text) -import Data.Text.Encoding (encodeUtf8) +import qualified Data.Text.IO +import Data.Time.Clock (diffUTCTime, getCurrentTime) import Foreign import Foreign.C import Test.Chell +#if MIN_VERSION_base(4,2,0) +import qualified GHC.IO.Exception as GHC +#else +import qualified GHC.IOBase as GHC +#endif + import Filesystem -import Filesystem.Path.CurrentOS +import Filesystem.Path +import qualified Filesystem.Path.Rules as Rules +import qualified Filesystem.Path.CurrentOS as CurrentOS import FilesystemTests.Util (assertionsWithTemp, todo) @@ -63,40 +76,144 @@ (fromText "\xA1\xA2-b.txt") , test_CanonicalizePath "iso8859" (decode "\xA1\xA2\xA3-a.txt") +#ifdef CABAL_OS_DARWIN + (decode "%A1%A2%A3-b.txt") +#else (decode "\xA1\xA2\xA3-b.txt") +#endif ] - , todo "createDirectory" - , todo "createTree" + , suite "createDirectory" + [ test_CreateDirectory "ascii" + (decode "test.d") + , test_CreateDirectory "utf8" + (fromText "\xA1\xA2.d") + , test_CreateDirectory "iso8859" + (decode "\xA1\xA2\xA3.d") + , test_CreateDirectory_FailExists + , test_CreateDirectory_SucceedExists + , test_CreateDirectory_FailFileExists + ] + , suite "createTree" + [ test_CreateTree "ascii" + (decode "test.d") + , test_CreateTree "ascii-slash" + (decode "test.d/") + , test_CreateTree "utf8" + (fromText "\xA1\xA2.d") + , test_CreateTree "utf8-slash" + (fromText "\xA1\xA2.d/") + , test_CreateTree "iso8859" + (decode "\xA1\xA2\xA3.d") + , test_CreateTree "iso8859-slash" + (decode "\xA1\xA2\xA3.d/") + ] , test_ListDirectory - , todo "removeFile" - , todo "removeDirectory" - , todo "removeTree" - , todo "getWorkingDirectory" - , todo "setWorkingDirectory" - , todo "getHomeDirectory" - , todo "getDesktopDirectory" + , suite "removeFile" + [ test_RemoveFile "ascii" + (decode "test.txt") + , test_RemoveFile "utf8" + (fromText "\xA1\xA2.txt") + , test_RemoveFile "iso8859" + (decode "\xA1\xA2\xA3.txt") + ] + , suite "removeDirectory" + [ test_RemoveDirectory "ascii" + (decode "test.d") + , test_RemoveDirectory "utf8" + (fromText "\xA1\xA2.d") + , test_RemoveDirectory "iso8859" + (decode "\xA1\xA2\xA3.d") + ] + , suite "removeTree" + [ test_RemoveTree "ascii" + (decode "test.d") + , test_RemoveTree "utf8" + (fromText "\xA1\xA2.d") + , test_RemoveTree "iso8859" + (decode "\xA1\xA2\xA3.d") + ] + , suite "getWorkingDirectory" + [ test_GetWorkingDirectory "ascii" + (decode "test.d") + , test_GetWorkingDirectory "utf8" + (fromText "\xA1\xA2.d") + , test_GetWorkingDirectory "iso8859" + (decode "\xA1\xA2\xA3.d") + ] + , suite "setWorkingDirectory" + [ test_SetWorkingDirectory "ascii" + (decode "test.d") + , test_SetWorkingDirectory "utf8" + (fromText "\xA1\xA2.d") + , test_SetWorkingDirectory "iso8859" + (decode "\xA1\xA2\xA3.d") + ] + , suite "getHomeDirectory" + [ test_GetHomeDirectory "ascii" + (decode "/home/test.d") + , test_GetHomeDirectory "utf8" + (decode "/home/\xA1\xA2.d") + , test_GetHomeDirectory "iso8859" + (decode "/home/\xA1\xA2\xA3.d") + ] + , suite "getDesktopDirectory" + [ test_GetDesktopDirectory "ascii" + (decode "/desktop/test.d") + , test_GetDesktopDirectory "utf8" + (decode "/desktop/\xA1\xA2.d") + , test_GetDesktopDirectory "iso8859" + (decode "/desktop/\xA1\xA2\xA3.d") + ] , todo "getDocumentsDirectory" , todo "getAppDataDirectory" , todo "getAppCacheDirectory" , todo "getAppConfigDirectory" + , suite "getModified" + [ test_GetModified "ascii" + (decode "test.txt") + , test_GetModified "utf8" + (fromText "\xA1\xA2.txt") + , test_GetModified "iso8859" + (decode "\xA1\xA2\xA3.txt") + ] + , suite "getSize" + [ test_GetSize "ascii" + (decode "test.txt") + , test_GetSize "utf8" + (fromText "\xA1\xA2.txt") + , test_GetSize "iso8859" + (decode "\xA1\xA2\xA3.txt") + ] , todo "copyFile" - , todo "getModified" - , todo "getSize" , todo "openFile" - , todo "withFile" + , suite "withFile" + [ test_WithFile "ascii" + (decode "test.txt") + , test_WithFile "utf8" + (fromText "\xA1\xA2.txt") + , test_WithFile "iso8859" + (decode "\xA1\xA2\xA3.txt") + ] , todo "readFile" , todo "writeFile" , todo "appendFile" , todo "openTextFile" - , todo "withTextFile" + , suite "withTextFile" + [ test_WithTextFile "ascii" + (decode "test.txt") + , test_WithTextFile "utf8" + (fromText "\xA1\xA2.txt") + , test_WithTextFile "iso8859" + (decode "\xA1\xA2\xA3.txt") + ] , todo "readTextFile" , todo "writeTextFile" , todo "appendTextFile" ] test_IsFile :: Text -> FilePath -> Suite -test_IsFile test_name file_name = assertionsWithTemp test_name $ \dir -> do - let path = dir file_name +test_IsFile test_name file_name = assertionsWithTemp test_name $ \tmp -> do + let path = tmp file_name before <- liftIO $ Filesystem.isFile path $expect (not before) @@ -107,8 +224,8 @@ $expect after test_IsDirectory :: Text -> FilePath -> Suite -test_IsDirectory test_name dir_name = assertionsWithTemp test_name $ \dir -> do - let path = dir dir_name +test_IsDirectory test_name dir_name = assertionsWithTemp test_name $ \tmp -> do + let path = tmp dir_name before <- liftIO $ Filesystem.isDirectory path $expect (not before) @@ -119,9 +236,9 @@ $expect after test_Rename :: Text -> FilePath -> FilePath -> Suite -test_Rename test_name old_name new_name = assertionsWithTemp test_name $ \dir -> do - let old_path = dir old_name - let new_path = dir new_name +test_Rename test_name old_name new_name = assertionsWithTemp test_name $ \tmp -> do + let old_path = tmp old_name + let new_path = tmp new_name touch_ffi old_path "" @@ -137,22 +254,10 @@ $expect (not old_after) $expect new_after -test_ListDirectory :: Suite -test_ListDirectory = assertionsWithTemp "listDirectory" $ \dir -> do - let paths = - [ dir decode "test.txt" - , dir fromText "\xA1\xA2.txt" - , dir decode "\xA1\xA2\xA3.txt" - ] - forM_ paths (\path -> touch_ffi path "") - - names <- liftIO $ Filesystem.listDirectory dir - $expect $ sameItems paths names - test_CanonicalizePath :: Text -> FilePath -> FilePath -> Suite -test_CanonicalizePath test_name src_name dst_name = assertionsWithTemp test_name $ \dir -> do - let src_path = dir src_name - let subdir = dir "subdir" +test_CanonicalizePath test_name src_name dst_name = assertionsWithTemp test_name $ \tmp -> do + let src_path = tmp src_name + let subdir = tmp "subdir" -- canonicalize the directory first, to avoid false negatives if -- it gets placed in a symlinked location. @@ -167,14 +272,236 @@ canonicalized <- liftIO $ Filesystem.canonicalizePath src_path $expect $ equal canonicalized dst_path -withPathCString :: FilePath -> (CString -> IO a) -> IO a -withPathCString p = Data.ByteString.useAsCString bytes where +test_CreateDirectory :: Text -> FilePath -> Suite +test_CreateDirectory test_name dir_name = assertionsWithTemp test_name $ \tmp -> do + let dir_path = tmp dir_name + + exists_before <- liftIO $ Filesystem.isDirectory dir_path + $assert (not exists_before) + + liftIO $ Filesystem.createDirectory False dir_path + exists_after <- liftIO $ Filesystem.isDirectory dir_path + + $expect exists_after + +test_CreateDirectory_FailExists :: Suite +test_CreateDirectory_FailExists = assertionsWithTemp "fail-if-exists" $ \tmp -> do + let dir_path = tmp "subdir" + mkdir_ffi dir_path + + $expect $ throwsEq + (mkAlreadyExists "createDirectory" dir_path) + (Filesystem.createDirectory False dir_path) + +test_CreateDirectory_SucceedExists :: Suite +test_CreateDirectory_SucceedExists = assertionsWithTemp "succeed-if-exists" $ \tmp -> do + let dir_path = tmp "subdir" + mkdir_ffi dir_path + + liftIO $ Filesystem.createDirectory True dir_path + +test_CreateDirectory_FailFileExists :: Suite +test_CreateDirectory_FailFileExists = assertionsWithTemp "fail-if-file-exists" $ \tmp -> do + let dir_path = tmp "subdir" + touch_ffi dir_path "" + + $expect $ throwsEq + (mkAlreadyExists "createDirectory" dir_path) + (Filesystem.createDirectory False dir_path) + $expect $ throwsEq + (mkAlreadyExists "createDirectory" dir_path) + (Filesystem.createDirectory True dir_path) + +mkAlreadyExists :: String -> FilePath -> GHC.IOError +mkAlreadyExists loc path = GHC.IOError Nothing GHC.AlreadyExists loc "File exists" +#if MIN_VERSION_base(4,2,0) + (Just (errnoCInt eEXIST)) +#endif + (Just (CurrentOS.encodeString path)) + +test_CreateTree :: Text -> FilePath -> Suite +test_CreateTree test_name dir_name = assertionsWithTemp test_name $ \tmp -> do + let dir_path = tmp dir_name + let subdir = dir_path "subdir" + + dir_exists_before <- liftIO $ Filesystem.isDirectory dir_path + subdir_exists_before <- liftIO $ Filesystem.isDirectory subdir + $assert (not dir_exists_before) + $assert (not subdir_exists_before) + + liftIO $ Filesystem.createTree subdir + dir_exists_after <- liftIO $ Filesystem.isDirectory dir_path + subdir_exists_after <- liftIO $ Filesystem.isDirectory subdir + + $expect dir_exists_after + $expect subdir_exists_after + +test_ListDirectory :: Suite +test_ListDirectory = assertionsWithTemp "listDirectory" $ \tmp -> do + -- OSX replaces non-UTF8 filenames with http-style %XX escapes + let paths = #ifdef CABAL_OS_DARWIN - bytes = encodeUtf8 (encode p) + [ tmp decode "%A1%A2%A3.txt" + , tmp decode "test.txt" + , tmp fromText "\xA1\xA2.txt" + ] #else - bytes = encode p + [ tmp decode "test.txt" + , tmp fromText "\xA1\xA2.txt" + , tmp decode "\xA1\xA2\xA3.txt" + ] #endif + forM_ paths (\path -> touch_ffi path "") + + names <- liftIO $ Filesystem.listDirectory tmp + $expect $ sameItems paths names +test_RemoveFile :: Text -> FilePath -> Suite +test_RemoveFile test_name file_name = assertionsWithTemp test_name $ \tmp -> do + let file_path = tmp file_name + + touch_ffi file_path "contents\n" + + before <- liftIO $ Filesystem.isFile file_path + $assert before + + liftIO $ Filesystem.removeFile file_path + + after <- liftIO $ Filesystem.isFile file_path + $expect (not after) + +test_RemoveDirectory :: Text -> FilePath -> Suite +test_RemoveDirectory test_name dir_name = assertionsWithTemp test_name $ \tmp -> do + let dir_path = tmp dir_name + + mkdir_ffi dir_path + + before <- liftIO $ Filesystem.isDirectory dir_path + $assert before + + liftIO $ Filesystem.removeDirectory dir_path + + after <- liftIO $ Filesystem.isDirectory dir_path + $expect (not after) + +test_RemoveTree :: Text -> FilePath -> Suite +test_RemoveTree test_name dir_name = assertionsWithTemp test_name $ \tmp -> do + let dir_path = tmp dir_name + let subdir = dir_path "subdir" + + mkdir_ffi dir_path + mkdir_ffi subdir + + dir_before <- liftIO $ Filesystem.isDirectory dir_path + subdir_before <- liftIO $ Filesystem.isDirectory subdir + $assert dir_before + $assert subdir_before + + liftIO $ Filesystem.removeTree dir_path + + dir_after <- liftIO $ Filesystem.isDirectory dir_path + subdir_after <- liftIO $ Filesystem.isDirectory subdir + $expect (not dir_after) + $expect (not subdir_after) + +test_GetWorkingDirectory :: Text -> FilePath -> Suite +test_GetWorkingDirectory test_name dir_name = assertionsWithTemp test_name $ \tmp -> do + -- canonicalize to avoid issues with symlinked temp dirs + canon_tmp <- liftIO (Filesystem.canonicalizePath tmp) + let dir_path = canon_tmp dir_name + + mkdir_ffi dir_path + chdir_ffi dir_path + + cwd <- liftIO $ Filesystem.getWorkingDirectory + $expect (equal cwd dir_path) + +test_SetWorkingDirectory :: Text -> FilePath -> Suite +test_SetWorkingDirectory test_name dir_name = assertionsWithTemp test_name $ \tmp -> do + -- canonicalize to avoid issues with symlinked temp dirs + canon_tmp <- liftIO (Filesystem.canonicalizePath tmp) + let dir_path = canon_tmp dir_name + + mkdir_ffi dir_path + liftIO $ Filesystem.setWorkingDirectory dir_path + + cwd <- getcwd_ffi + $expect (equal cwd dir_path) + +test_GetHomeDirectory :: Text -> FilePath -> Suite +test_GetHomeDirectory test_name dir_name = assertions test_name $ do + path <- liftIO $ withEnv "HOME" (Just dir_name) Filesystem.getHomeDirectory + $expect (equal path dir_name) + +test_GetDesktopDirectory :: Text -> FilePath -> Suite +test_GetDesktopDirectory test_name dir_name = assertions test_name $ do + path <- liftIO $ + withEnv "XDG_DESKTOP_DIR" (Just dir_name) $ + Filesystem.getDesktopDirectory + $expect (equal path dir_name) + + fallback <- liftIO $ + withEnv "XDG_DESKTOP_DIR" Nothing $ + withEnv "HOME" (Just dir_name) $ + Filesystem.getDesktopDirectory + $expect (equal fallback (dir_name "Desktop")) + +test_GetModified :: Text -> FilePath -> Suite +test_GetModified test_name file_name = assertionsWithTemp test_name $ \tmp -> do + let file_path = tmp file_name + + touch_ffi file_path "" + now <- liftIO getCurrentTime + + mtime <- liftIO $ Filesystem.getModified file_path + $expect (equalWithin (diffUTCTime mtime now) 0 2) + +test_GetSize :: Text -> FilePath -> Suite +test_GetSize test_name file_name = assertionsWithTemp test_name $ \tmp -> do + let file_path = tmp file_name + let contents = "contents\n" + + touch_ffi file_path contents + + size <- liftIO $ Filesystem.getSize file_path + $expect (equal size (toInteger (Data.ByteString.length contents))) + +test_WithFile :: Text -> FilePath -> Suite +test_WithFile test_name file_name = assertionsWithTemp test_name $ \tmp -> do + let file_path = tmp file_name + let contents = "contents\n" + + touch_ffi file_path contents + + read_contents <- liftIO $ + Filesystem.withFile file_path ReadMode $ + Data.ByteString.hGetContents + $expect (equalLines contents read_contents) + +test_WithTextFile :: Text -> FilePath -> Suite +test_WithTextFile test_name file_name = assertionsWithTemp test_name $ \tmp -> do + let file_path = tmp file_name + let contents = "contents\n" + + touch_ffi file_path (Char8.pack contents) + + read_contents <- liftIO $ + Filesystem.withTextFile file_path ReadMode $ + Data.Text.IO.hGetContents + $expect (equalLines (Data.Text.pack contents) read_contents) + +withPathCString :: FilePath -> (CString -> IO a) -> IO a +withPathCString p = Data.ByteString.useAsCString (encode p) + +decode :: ByteString -> FilePath +decode = Rules.decode Rules.posix + +encode :: FilePath -> ByteString +encode = Rules.encode Rules.posix + +fromText :: Text -> FilePath +fromText = Rules.fromText Rules.posix + -- | Create a file using the raw POSIX API, via FFI touch_ffi :: FilePath -> Data.ByteString.ByteString -> Assertions () touch_ffi path contents = do @@ -208,6 +535,47 @@ $assert (ret == 0) +getcwd_ffi :: Assertions FilePath +getcwd_ffi = do + buf <- liftIO $ c_getcwd nullPtr 0 + $assert (buf /= nullPtr) + bytes <- liftIO $ Data.ByteString.packCString buf + liftIO $ c_free buf + return (decode bytes) + +chdir_ffi :: FilePath -> Assertions () +chdir_ffi path = do + ret <- liftIO $ + withPathCString path $ \path_p -> + c_chdir path_p + $assert (ret == 0) + +errnoCInt :: Errno -> CInt +errnoCInt (Errno x) = x + +withEnv :: ByteString -> Maybe FilePath -> IO a -> IO a +withEnv name val io = bracket set unset (\_ -> io) where + set = do + old <- getEnv name + setEnv name (fmap encode val) + return old + unset = setEnv name + +getEnv :: ByteString -> IO (Maybe ByteString) +getEnv name = Data.ByteString.useAsCString name $ \cName -> do + ret <- liftIO (c_getenv cName) + if ret == nullPtr + then return Nothing + else fmap Just (Data.ByteString.packCString ret) + +setEnv :: ByteString -> Maybe ByteString -> IO () +setEnv name Nothing = throwErrnoIfMinus1_ "setEnv" $ + Data.ByteString.useAsCString name c_unsetenv +setEnv name (Just val) = throwErrnoIfMinus1_ "setEnv" $ + Data.ByteString.useAsCString name $ \cName -> + Data.ByteString.useAsCString val $ \cVal -> + c_setenv cName cVal 1 + foreign import ccall unsafe "fopen" c_fopen :: CString -> CString -> IO (Ptr ()) @@ -222,3 +590,21 @@ foreign import ccall unsafe "symlink" c_symlink :: CString -> CString -> IO CInt + +foreign import ccall unsafe "getcwd" + c_getcwd :: CString -> CSize -> IO CString + +foreign import ccall unsafe "chdir" + c_chdir :: CString -> IO CInt + +foreign import ccall unsafe "free" + c_free :: Ptr a -> IO () + +foreign import ccall unsafe "getenv" + c_getenv :: CString -> IO CString + +foreign import ccall unsafe "setenv" + c_setenv :: CString -> CString -> CInt -> IO CInt + +foreign import ccall unsafe "unsetenv" + c_unsetenv :: CString -> IO CInt diff --git a/tests/FilesystemTests/Util.hs b/tests/FilesystemTests/Util.hs --- a/tests/FilesystemTests/Util.hs +++ b/tests/FilesystemTests/Util.hs @@ -10,19 +10,28 @@ ) where import Prelude hiding (FilePath) + +import Control.Exception (finally) import Data.Text (Text, unpack) import System.IO.Temp (withSystemTempDirectory) import Test.Chell +import Filesystem (removeTree) import Filesystem.Path.CurrentOS (FilePath, decodeString) assertionsWithTemp :: Text -> (FilePath -> Assertions a) -> Suite assertionsWithTemp name io = test (Test name impl) where - impl options = withSystemTempDirectory ("tests." ++ unpack name ++ ".") $ \dir -> do - let dirPath = decodeString dir - case suiteTests (assertions name (io dirPath)) of + impl options = withTempDir name $ \dir -> do + case suiteTests (assertions name (io dir)) of [(Test _ io')] -> io' options _ -> error "assertionsWithTemp: use in place of 'assertions' only." + +withTempDir :: Text -> (FilePath -> IO a) -> IO a +withTempDir name io = withSystemTempDirectory + ("tests." ++ unpack name ++ ".") + (\dir -> + let dir' = decodeString dir in + finally (io dir') (removeTree dir')) todo :: Text -> Suite todo name = skipIf True (assertions name (return ())) diff --git a/tests/system-fileio-tests.cabal b/tests/system-fileio-tests.cabal --- a/tests/system-fileio-tests.cabal +++ b/tests/system-fileio-tests.cabal @@ -19,7 +19,6 @@ base >= 4.0 && < 5.0 , bytestring >= 0.9 && < 0.10 , chell >= 0.2 && < 0.3 - , directory >= 1.0 && < 1.2 , system-filepath >= 0.3 && < 0.5 , temporary >= 1.1 && < 2.0 , text >= 0.1 && < 0.12 @@ -33,6 +32,11 @@ cpp-options: -DCABAL_OS_DARWIN if os(windows) - build-depends: Win32 >= 2.2 && < 2.3 + build-depends: + Win32 >= 2.2 && < 2.3 + , directory >= 1.0 && < 1.2 + c-sources: ../lib/hssystemfileio-win32.c else - build-depends: unix >= 2.3 && < 2.6 + build-depends: + unix >= 2.3 && < 2.6 + c-sources: ../lib/hssystemfileio-unix.c