{-# LANGUAGE ForeignFunctionInterface, NondecreasingIndentation #-}
module System.Directory
(
createDirectory
, createDirectoryIfMissing
, removeDirectory
, removeDirectoryRecursive
, renameDirectory
, getDirectoryContents
, getCurrentDirectory
, setCurrentDirectory
, getHomeDirectory
, getAppUserDataDirectory
, getUserDocumentsDirectory
, getTemporaryDirectory
, removeFile
, renameFile
, copyFile
, canonicalizePath
, makeRelativeToCurrentDirectory
, findExecutable
, doesFileExist
, doesDirectoryExist
, Permissions(
Permissions,
readable,
writable,
executable,
searchable
)
, getPermissions
, setPermissions
, copyPermissions
, getModificationTime
) where
import Prelude hiding ( catch )
import qualified Prelude
import Control.Monad (guard)
import System.Environment ( getEnv )
import System.FilePath
import System.IO
import System.IO.Error hiding ( catch, try )
import Control.Monad ( when, unless )
import Control.Exception.Base
import Foreign
import Foreign.C
import System.Time ( ClockTime(..) )
import GHC.IO.Exception ( IOException(..), IOErrorType(..), ioException )
import System.Posix.Types
import System.Posix.Internals
import qualified System.Win32 as Win32
data Permissions
= Permissions {
readable, writable,
executable, searchable :: Bool
} deriving (Eq, Ord, Read, Show)
getPermissions :: FilePath -> IO Permissions
getPermissions name = do
withFilePath name $ \s -> do
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
}
)
setPermissions :: FilePath -> Permissions -> IO ()
setPermissions name (Permissions r w e s) = do
allocaBytes sizeof_stat $ \ p_stat -> do
withFilePath name $ \p_name -> do
throwErrnoIfMinus1_ "setPermissions" $ do
c_stat p_name p_stat
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
foreign import ccall unsafe "_wchmod"
c_wchmod :: CWString -> CMode -> IO CInt
copyPermissions :: FilePath -> FilePath -> IO ()
copyPermissions source dest = do
allocaBytes sizeof_stat $ \ p_stat -> do
withFilePath source $ \p_source -> do
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
createDirectory :: FilePath -> IO ()
createDirectory path = do
Win32.createDirectory path Nothing
createDirectoryIfMissing :: Bool
-> FilePath
-> IO ()
createDirectoryIfMissing create_parents path0
| create_parents = createDirs (parents path0)
| otherwise = createDirs (take 1 (parents path0))
where
parents = reverse . scanl1 (</>) . splitDirectories . normalise
createDirs [] = return ()
createDirs (dir:[]) = createDir dir throw
createDirs (dir:dirs) =
createDir dir $ \_ -> do
createDirs dirs
createDir dir throw
createDir :: FilePath -> (IOException -> IO ()) -> IO ()
createDir dir notExistHandler = do
r <- try $ createDirectory dir
case (r :: Either IOException ()) of
Right () -> return ()
Left e
| isDoesNotExistError e -> notExistHandler e
| isAlreadyExistsError e -> (do
withFileStatus "createDirectoryIfMissing" dir $ \st -> do
isDir <- isDirectory st
if isDir then return ()
else throw e
) `catch` ((\_ -> return ()) :: IOException -> IO ())
| otherwise -> throw e
removeDirectory :: FilePath -> IO ()
removeDirectory path =
Win32.removeDirectory path
removeDirectoryRecursive :: FilePath -> IO ()
removeDirectoryRecursive startLoc = do
cont <- getDirectoryContents startLoc
sequence_ [rm (startLoc </> x) | x <- cont, x /= "." && x /= ".."]
removeDirectory startLoc
where
rm :: FilePath -> IO ()
rm f = do temp <- try (removeFile f)
case temp of
Left e -> do isDir <- doesDirectoryExist f
unless isDir $ throw (e :: SomeException)
removeDirectoryRecursive f
Right _ -> return ()
removeFile :: FilePath -> IO ()
removeFile path =
Win32.deleteFile path
renameDirectory :: FilePath -> FilePath -> IO ()
renameDirectory opath npath = do
withFileStatus "renameDirectory" opath $ \st -> do
is_dir <- isDirectory st
if (not is_dir)
then ioException (ioeSetErrorString
(mkIOError InappropriateType "renameDirectory" Nothing (Just opath))
"not a directory")
else do
Win32.moveFileEx opath npath Win32.mOVEFILE_REPLACE_EXISTING
renameFile :: FilePath -> FilePath -> IO ()
renameFile opath npath = do
withFileOrSymlinkStatus "renameFile" opath $ \st -> do
is_dir <- isDirectory st
if is_dir
then ioException (ioeSetErrorString
(mkIOError InappropriateType "renameFile" Nothing (Just opath))
"is a directory")
else do
Win32.moveFileEx opath npath Win32.mOVEFILE_REPLACE_EXISTING
copyFile :: FilePath -> FilePath -> IO ()
copyFile fromFPath toFPath =
copy `Prelude.catch` (\exc -> throw $ ioeSetLocation exc "copyFile")
where copy = bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom ->
bracketOnError openTmp cleanTmp $ \(tmpFPath, hTmp) ->
do allocaBytes bufferSize $ copyContents hFrom hTmp
hClose hTmp
ignoreIOExceptions $ copyPermissions fromFPath tmpFPath
renameFile tmpFPath toFPath
openTmp = openBinaryTempFile (takeDirectory toFPath) ".copyFile.tmp"
cleanTmp (tmpFPath, hTmp)
= do ignoreIOExceptions $ hClose hTmp
ignoreIOExceptions $ removeFile tmpFPath
bufferSize = 1024
copyContents hFrom hTo buffer = do
count <- hGetBuf hFrom buffer bufferSize
when (count > 0) $ do
hPutBuf hTo buffer count
copyContents hFrom hTo buffer
ignoreIOExceptions io = io `catch` ioExceptionIgnorer
ioExceptionIgnorer :: IOException -> IO ()
ioExceptionIgnorer _ = return ()
canonicalizePath :: FilePath -> IO FilePath
canonicalizePath fpath =
do path <- Win32.getFullPathName fpath
return (normalise path)
makeRelativeToCurrentDirectory :: FilePath -> IO FilePath
makeRelativeToCurrentDirectory x = do
cur <- getCurrentDirectory
return $ makeRelative cur x
findExecutable :: String -> IO (Maybe FilePath)
findExecutable binary =
Win32.searchPath Nothing binary ('.':exeExtension)
getDirectoryContents :: FilePath -> IO [FilePath]
getDirectoryContents path =
modifyIOError ((`ioeSetFileName` path) .
(`ioeSetLocation` "getDirectoryContents")) $ do
bracket
(Win32.findFirstFile (path </> "*"))
(\(h,_) -> Win32.findClose h)
(\(h,fdat) -> loop h fdat [])
where
loop :: Win32.HANDLE -> Win32.FindData -> [FilePath] -> IO [FilePath]
loop h fdat acc = do
filename <- Win32.getFindDataFileName fdat
more <- Win32.findNextFile h fdat
if more
then loop h fdat (filename:acc)
else return (filename:acc)
getCurrentDirectory :: IO FilePath
getCurrentDirectory = do
Win32.getCurrentDirectory
setCurrentDirectory :: FilePath -> IO ()
setCurrentDirectory path =
Win32.setCurrentDirectory path
doesDirectoryExist :: FilePath -> IO Bool
doesDirectoryExist name =
(withFileStatus "doesDirectoryExist" name $ \st -> isDirectory st)
`catch` ((\ _ -> return False) :: IOException -> IO Bool)
doesFileExist :: FilePath -> IO Bool
doesFileExist name =
(withFileStatus "doesFileExist" name $ \st -> do b <- isDirectory st; return (not b))
`catch` ((\ _ -> return False) :: IOException -> IO Bool)
getModificationTime :: FilePath -> IO ClockTime
getModificationTime name = do
withFileStatus "getModificationTime" name $ \ st -> do
modificationTime st
withFileStatus :: String -> FilePath -> (Ptr CStat -> IO a) -> IO a
withFileStatus loc name f = do
modifyIOError (`ioeSetFileName` name) $
allocaBytes sizeof_stat $ \p ->
withFilePath (fileNameEndClean name) $ \s -> do
throwErrnoIfMinus1Retry_ loc (c_stat s p)
withFileOrSymlinkStatus :: String -> FilePath -> (Ptr CStat -> IO a) -> IO a
withFileOrSymlinkStatus loc name f = do
modifyIOError (`ioeSetFileName` name) $
allocaBytes sizeof_stat $ \p ->
withFilePath name $ \s -> do
throwErrnoIfMinus1Retry_ loc (lstat s p)
modificationTime :: Ptr CStat -> IO ClockTime
modificationTime stat = do
mtime <- st_mtime stat
let realToInteger = round . realToFrac :: Real a => a -> Integer
return (TOD (realToInteger (mtime :: CTime)) 0)
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
foreign import ccall unsafe "HsDirectory.h __hscore_S_IRUSR" s_IRUSR :: CMode
foreign import ccall unsafe "HsDirectory.h __hscore_S_IWUSR" s_IWUSR :: CMode
foreign import ccall unsafe "HsDirectory.h __hscore_S_IXUSR" s_IXUSR :: CMode
foreign import ccall unsafe "__hscore_S_IFDIR" s_IFDIR :: CMode
foreign import ccall unsafe "__hscore_long_path_size"
long_path_size :: Int
getHomeDirectory :: IO FilePath
getHomeDirectory =
modifyIOError ((`ioeSetLocation` "getHomeDirectory")) $ do
r <- try $ Win32.sHGetFolderPath nullPtr Win32.cSIDL_PROFILE nullPtr 0
case (r :: Either IOException String) of
Right s -> return s
Left _ -> do
r1 <- try $ Win32.sHGetFolderPath nullPtr Win32.cSIDL_WINDOWS nullPtr 0
case r1 of
Right s -> return s
Left e -> ioError (e :: IOException)
getAppUserDataDirectory :: String -> IO FilePath
getAppUserDataDirectory appName = do
modifyIOError ((`ioeSetLocation` "getAppUserDataDirectory")) $ do
s <- Win32.sHGetFolderPath nullPtr Win32.cSIDL_APPDATA nullPtr 0
return (s++'\\':appName)
getUserDocumentsDirectory :: IO FilePath
getUserDocumentsDirectory = do
modifyIOError ((`ioeSetLocation` "getUserDocumentsDirectory")) $ do
Win32.sHGetFolderPath nullPtr Win32.cSIDL_PERSONAL nullPtr 0
getTemporaryDirectory :: IO FilePath
getTemporaryDirectory = do
Win32.getTemporaryDirectory
exeExtension :: String
exeExtension = "exe"