module Filesystem
(
IO.Handle
, IO.IOMode(..)
, isFile
, getModified
, getSize
, copyFile
, copyFileContent
, copyPermissions
, removeFile
, openFile
, withFile
, readFile
, writeFile
, appendFile
, openTextFile
, withTextFile
, readTextFile
, writeTextFile
, appendTextFile
, isDirectory
, canonicalizePath
, listDirectory
, createDirectory
, createTree
, removeDirectory
, removeTree
, getWorkingDirectory
, setWorkingDirectory
, getHomeDirectory
, getDesktopDirectory
, getDocumentsDirectory
, getAppDataDirectory
, getAppCacheDirectory
, getAppConfigDirectory
, 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 (CInt, CString, withCAString)
import qualified Foreign.C.Error as CError
import qualified System.Environment as SE
#if MIN_VERSION_system_filepath(0,4,0)
import Filesystem.Path (FilePath, append)
import qualified Filesystem.Path as Path
import Filesystem.Path.CurrentOS (currentOS, encodeString, decodeString)
import qualified Filesystem.Path.Rules as R
#else
import System.FilePath (FilePath, append)
import qualified System.FilePath as Path
import System.FilePath.CurrentOS (currentOS, encodeString, decodeString)
import qualified System.FilePath.Rules as R
#endif
import qualified System.IO as IO
import System.IO.Error (IOError)
#ifdef CABAL_OS_WINDOWS
import Data.Bits ((.|.))
import Data.Time ( UTCTime(..)
, fromGregorian
, secondsToDiffTime
, picosecondsToDiffTime)
import Foreign.C (CWString, withCWString)
import qualified System.Win32 as Win32
import System.IO.Error (isDoesNotExistError)
import qualified "directory" System.Directory as SD
#else
import Data.Time (UTCTime)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import qualified System.Posix as Posix
import qualified System.Posix.Error as Posix
#endif
#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
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
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 :: FilePath -> FilePath -> IO ()
rename old new =
#ifdef CABAL_OS_WINDOWS
let old' = encodeString old in
let new' = encodeString new in
Win32.moveFileEx old' new' Win32.mOVEFILE_REPLACE_EXISTING
#else
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
canonicalizePath :: FilePath -> IO FilePath
canonicalizePath path =
let path' = encodeString path in
#ifdef CABAL_OS_WINDOWS
fmap decodeString $
#if MIN_VERSION_Win32(2,2,1)
Win32.getFullPathName path'
#else
Win32.withTString path' $ \c_name -> do
Win32.try "getFullPathName" (\buf len ->
c_GetFullPathNameW c_name len buf nullPtr) 512
#endif
#else
withFilePath path $ \cPath -> do
cOut <- Posix.throwErrnoPathIfNull "canonicalizePath" path' (c_realpath cPath nullPtr)
bytes <- B.packCString cOut
c_free cOut
return (R.decode R.posix bytes)
#endif
#ifdef CABAL_OS_WINDOWS
#if MIN_VERSION_Win32(2,2,1)
#else
foreign import stdcall unsafe "GetFullPathNameW"
c_GetFullPathNameW :: Win32.LPCTSTR -> Win32.DWORD -> Win32.LPTSTR -> Ptr Win32.LPTSTR -> IO Win32.DWORD
#endif
#endif
#ifndef CABAL_OS_WINDOWS
foreign import ccall unsafe "realpath"
c_realpath :: CString -> CString -> IO CString
#endif
createDirectory :: Bool
-> FilePath -> IO ()
createDirectory succeedIfExists path =
#ifdef CABAL_OS_WINDOWS
let path' = encodeString path in
if succeedIfExists
then SD.createDirectoryIfMissing False path'
else Win32.createDirectory path' Nothing
#else
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
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
listDirectory :: FilePath -> IO [FilePath]
#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)
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 "closedir"
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
removeFile :: FilePath -> IO ()
removeFile path =
#ifdef CABAL_OS_WINDOWS
Win32.deleteFile (encodeString path)
#else
withFilePath path $ \cPath ->
throwErrnoPathIfMinus1_ "removeFile" path (c_unlink cPath)
foreign import ccall unsafe "unlink"
c_unlink :: CString -> IO CInt
#endif
removeDirectory :: FilePath -> IO ()
removeDirectory path =
#ifdef CABAL_OS_WINDOWS
Win32.removeDirectory (encodeString path)
#else
withFilePath path $ \cPath ->
throwErrnoPathIfMinus1Retry_ "removeDirectory" path (c_rmdir cPath)
foreign import ccall unsafe "rmdir"
c_rmdir :: CString -> IO CInt
#endif
removeTree :: FilePath -> IO ()
#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
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
getWorkingDirectory :: IO FilePath
getWorkingDirectory = do
#ifdef CABAL_OS_WINDOWS
#if MIN_VERSION_Win32(2,2,1)
fmap decodeString Win32.getCurrentDirectory
#else
fmap decodeString (Win32.try "getWorkingDirectory" (flip c_GetCurrentDirectoryW) 512)
#endif
#else
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
#if MIN_VERSION_Win32(2,2,1)
#else
foreign import stdcall unsafe "GetCurrentDirectoryW"
c_GetCurrentDirectoryW :: Win32.DWORD -> Win32.LPTSTR -> IO Win32.UINT
#endif
#endif
setWorkingDirectory :: FilePath -> IO ()
setWorkingDirectory path =
#ifdef CABAL_OS_WINDOWS
Win32.setCurrentDirectory (encodeString path)
#else
withFilePath path $ \cPath ->
throwErrnoPathIfMinus1Retry_ "setWorkingDirectory" path (c_chdir cPath)
foreign import ccall unsafe "chdir"
c_chdir :: CString -> IO CInt
#endif
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
fmap decodeString (SE.getEnv "HOME")
#endif
getDesktopDirectory :: IO FilePath
getDesktopDirectory = xdg "XDG_DESKTOP_DIR" Nothing
(homeSlash "Desktop")
getDocumentsDirectory :: IO FilePath
getDocumentsDirectory = xdg "XDG_DOCUMENTS_DIR" Nothing
#ifdef CABAL_OS_WINDOWS
(fmap decodeString SD.getUserDocumentsDirectory)
#else
(homeSlash "Documents")
#endif
getAppDataDirectory :: T.Text -> IO FilePath
getAppDataDirectory label = xdg "XDG_DATA_HOME" (Just label)
#ifdef CABAL_OS_WINDOWS
(fmap decodeString (SD.getAppUserDataDirectory ""))
#else
(homeSlash ".local/share")
#endif
getAppCacheDirectory :: T.Text -> IO FilePath
getAppCacheDirectory label = xdg "XDG_CACHE_HOME" (Just label)
#ifdef CABAL_OS_WINDOWS
(homeSlash "Local Settings\\Cache")
#else
(homeSlash ".cache")
#endif
getAppConfigDirectory :: T.Text -> IO FilePath
getAppConfigDirectory label = xdg "XDG_CONFIG_HOME" (Just label)
#ifdef CABAL_OS_WINDOWS
(homeSlash "Local Settings")
#else
(homeSlash ".config")
#endif
homeSlash :: String -> IO FilePath
homeSlash path = do
home <- getHomeDirectory
return (append home (decodeString path))
getenv :: String -> IO (Maybe FilePath)
#ifdef CABAL_OS_WINDOWS
getenv key = Exc.catch
(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 var
Nothing -> fallback
return $ case label of
Just text -> append dir (R.fromText currentOS text)
Nothing -> dir
copyFileContent :: FilePath
-> FilePath
-> IO ()
copyFileContent oldPath newPath =
withFile oldPath IO.ReadMode $ \old ->
withFile newPath IO.WriteMode $ \new ->
BL.hGetContents old >>= BL.hPut new
copyPermissions :: FilePath
-> FilePath
-> 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
copyFile :: FilePath
-> FilePath
-> IO ()
copyFile oldPath newPath = do
copyFileContent oldPath newPath
Exc.catch
(copyPermissions oldPath newPath)
((\_ -> return ()) :: IOError -> IO ())
getModified :: FilePath -> IO UTCTime
getModified path = do
#ifdef CABAL_OS_WINDOWS
info <- withHANDLE path Win32.getFileInformationByHandle
let ftime = Win32.bhfiLastWriteTime info
stime <- Win32.fileTimeToSystemTime ftime
let date = fromGregorian
(fromIntegral (Win32.wYear stime))
(fromIntegral (Win32.wMonth stime))
(fromIntegral (Win32.wDay stime))
let seconds = secondsToDiffTime $
(toInteger (Win32.wHour stime) * 3600) +
(toInteger (Win32.wMinute stime) * 60) +
(toInteger (Win32.wSecond stime))
let msecs = picosecondsToDiffTime $
(toInteger (Win32.wMilliseconds stime) * 1000000000)
return (UTCTime date (seconds + msecs))
#else
stat <- posixStat "getModified" path
let mtime = Posix.modificationTime stat
return (posixSecondsToUTCTime (realToFrac mtime))
#endif
getSize :: FilePath -> IO Integer
getSize path = do
#ifdef CABAL_OS_WINDOWS
info <- withHANDLE path Win32.getFileInformationByHandle
return (toInteger (Win32.bhfiSize info))
#else
stat <- posixStat "getSize" path
return (toInteger (Posix.fileSize stat))
#endif
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
withFile :: FilePath -> IO.IOMode -> (IO.Handle -> IO a) -> IO a
withFile path mode = Exc.bracket (openFile path mode) IO.hClose
readFile :: FilePath -> IO B.ByteString
readFile path = withFile path IO.ReadMode
(\h -> IO.hFileSize h >>= B.hGet h . fromIntegral)
writeFile :: FilePath -> B.ByteString -> IO ()
writeFile path bytes = withFile path IO.WriteMode
(\h -> B.hPut h bytes)
appendFile :: FilePath -> B.ByteString -> IO ()
appendFile path bytes = withFile path IO.AppendMode
(\h -> B.hPut h bytes)
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
withTextFile :: FilePath -> IO.IOMode -> (IO.Handle -> IO a) -> IO a
withTextFile path mode = Exc.bracket (openTextFile path mode) IO.hClose
readTextFile :: FilePath -> IO T.Text
readTextFile path = openTextFile path IO.ReadMode >>= T.hGetContents
writeTextFile :: FilePath -> T.Text -> IO ()
writeTextFile path text = withTextFile path IO.WriteMode
(\h -> T.hPutStr h text)
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
sys_c_open = System.Posix.Internals.c_open
sys_c_close = System.Posix.Internals.c_close
flags = iomodeFlags mode
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)
iomodeFlags :: IO.IOMode -> CInt
iomodeFlags mode = cased .|. commonFlags where
cased = case mode of
IO.ReadMode -> flagsR
#ifdef mingw32_HOST_OS
IO.WriteMode -> flagsW .|. System.Posix.Internals.o_TRUNC
#else
IO.WriteMode -> flagsW
#endif
IO.ReadWriteMode -> flagsRW
IO.AppendMode -> flagsA
flagsR = System.Posix.Internals.o_RDONLY
flagsW = outputFlags .|. System.Posix.Internals.o_WRONLY
flagsRW = outputFlags .|. System.Posix.Internals.o_RDWR
flagsA = flagsW .|. System.Posix.Internals.o_APPEND
commonFlags = System.Posix.Internals.o_NOCTTY .|.
System.Posix.Internals.o_NONBLOCK
outputFlags = System.Posix.Internals.o_CREAT
#endif
#ifdef CABAL_OS_WINDOWS
withHANDLE :: FilePath -> (Win32.HANDLE -> IO a) -> IO a
withHANDLE path = Exc.bracket open close where
open = Win32.createFile
(encodeString path)
Win32.gENERIC_READ
(Win32.fILE_SHARE_READ .|. Win32.fILE_SHARE_WRITE)
Nothing
Win32.oPEN_EXISTING
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