+{-# OPTIONS_GHC -w #-}
+-- XXX We get some warnings on Windows
+
-----------------------------------------------------------------------------
-- |
-- Module : System.Directory
-- * Actions on directories
createDirectory -- :: FilePath -> IO ()
+ , createDirectoryIfMissing -- :: Bool -> FilePath -> IO ()
, removeDirectory -- :: FilePath -> IO ()
+ , removeDirectoryRecursive -- :: FilePath -> IO ()
, renameDirectory -- :: FilePath -> FilePath -> IO ()
, getDirectoryContents -- :: FilePath -> IO [FilePath]
, copyFile -- :: FilePath -> FilePath -> IO ()
, canonicalizePath
+ , makeRelativeToCurrentDirectory
, findExecutable
-- * Existence tests
, getModificationTime -- :: FilePath -> IO ClockTime
) where
+import Prelude hiding ( catch )
+import qualified Prelude
+
import System.Environment ( getEnv )
import System.FilePath
-import System.IO.Error
+import System.IO
+import System.IO.Error hiding ( catch, try )
+import Control.Monad ( when, unless )
+import Control.Exception.Base
#ifdef __NHC__
import Directory
-import NHC.FFI
+import System (system)
#endif /* __NHC__ */
#ifdef __HUGS__
import Hugs.Directory
#endif /* __HUGS__ */
-#ifdef __GLASGOW_HASKELL__
-import Prelude
+import Foreign
+import Foreign.C
-import Control.Exception ( bracket )
-import Control.Monad ( when )
+{-# CFILES cbits/directory.c #-}
+
+#ifdef __GLASGOW_HASKELL__
import System.Posix.Types
import System.Posix.Internals
import System.Time ( ClockTime(..) )
-import System.IO
-import Foreign
-import Foreign.C
import GHC.IOBase ( IOException(..), IOErrorType(..), ioException )
+#ifdef mingw32_HOST_OS
+import qualified System.Win32
+#else
+import qualified System.Posix
+#endif
+
{- $intro
A directory contains a series of entries, each of which is a named
reference to a file system object (file, directory etc.). Some
entries may be hidden, inaccessible, or have some administrative
function (e.g. `.' or `..' under POSIX
-<http://www.opengroup.org/onlinepubs/007904975/toc.htm>), but in
+<http://www.opengroup.org/onlinepubs/009695399/>), but in
this standard all such entries are considered to form part of the
directory contents. Entries in sub-directories are not, however,
considered to form part of the directory contents.
getPermissions :: FilePath -> IO Permissions
getPermissions name = do
withCString name $ \s -> do
- read <- c_access s r_OK
- write <- c_access s w_OK
- exec <- c_access s x_OK
+#ifdef mingw32_HOST_OS
+ -- 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
+ read_ok <- c_access s r_OK
+ write_ok <- c_access s w_OK
+ exec_ok <- c_access s x_OK
withFileStatus "getPermissions" name $ \st -> do
is_dir <- isDirectory st
return (
Permissions {
- readable = read == 0,
- writable = write == 0,
- executable = not is_dir && exec == 0,
- searchable = is_dir && exec == 0
+ readable = read_ok == 0,
+ writable = write_ok == 0,
+ executable = not is_dir && exec_ok == 0,
+ searchable = is_dir && exec_ok == 0
}
)
+#endif
{- |The 'setPermissions' operation sets the
permissions for the file or directory.
modifyBit False m b = m .&. (complement b)
modifyBit True m b = m .|. b
+
+copyPermissions :: FilePath -> FilePath -> IO ()
+copyPermissions source dest = do
+ allocaBytes sizeof_stat $ \ p_stat -> do
+ withCString source $ \p_source -> do
+ withCString dest $ \p_dest -> do
+ throwErrnoIfMinus1_ "copyPermissions" $ c_stat p_source p_stat
+ mode <- st_mode p_stat
+ throwErrnoIfMinus1_ "copyPermissions" $ c_chmod p_dest mode
+
-----------------------------------------------------------------------------
-- Implementation
createDirectory :: FilePath -> IO ()
createDirectory path = do
- withCString path $ \s -> do
- throwErrnoIfMinus1Retry_ "createDirectory" $
- mkdir s 0o777
+#ifdef mingw32_HOST_OS
+ System.Win32.createDirectory path Nothing
+#else
+ System.Posix.createDirectory path 0o777
+#endif
+
+#else /* !__GLASGOW_HASKELL__ */
+
+copyPermissions :: FilePath -> FilePath -> IO ()
+copyPermissions fromFPath toFPath
+ = getPermissions fromFPath >>= setPermissions toFPath
+
+#endif
+-- | @'createDirectoryIfMissing' parents dir@ creates a new directory
+-- @dir@ if it doesn\'t exist. If the first argument is 'True'
+-- the function will also create all parent directories if they are missing.
+createDirectoryIfMissing :: Bool -- ^ Create its parents too?
+ -> FilePath -- ^ The path to the directory you want to make
+ -> IO ()
+createDirectoryIfMissing parents file = do
+ b <- doesDirectoryExist file
+ case (b,parents, file) of
+ (_, _, "") -> return ()
+ (True, _, _) -> return ()
+ (_, True, _) -> mapM_ (createDirectoryIfMissing False) $ mkParents file
+ (_, False, _) -> createDirectory file
+ where mkParents = scanl1 (</>) . splitDirectories . normalise
+
+#if __GLASGOW_HASKELL__
{- | @'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
-}
removeDirectory :: FilePath -> IO ()
-removeDirectory path = do
- modifyIOError (`ioeSetFileName` path) $
- withCString path $ \s ->
- throwErrnoIfMinus1Retry_ "removeDirectory" (c_rmdir s)
+removeDirectory path =
+#ifdef mingw32_HOST_OS
+ System.Win32.removeDirectory path
+#else
+ System.Posix.removeDirectory path
+#endif
+
+#endif
+-- | @'removeDirectoryRecursive' dir@ removes an existing directory /dir/
+-- together with its content and all subdirectories. Be careful,
+-- if the directory contains symlinks, the function will follow them.
+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
+ -- If f is not a directory, re-throw the error
+ unless isDir $ throw (e :: SomeException)
+ removeDirectoryRecursive f
+ Right _ -> return ()
+
+#if __GLASGOW_HASKELL__
{- |'removeFile' /file/ removes the directory entry for an existing file
/file/, where /file/ is not itself a directory. The
implementation may specify additional constraints which must be
-}
removeFile :: FilePath -> IO ()
-removeFile path = do
- modifyIOError (`ioeSetFileName` path) $
- withCString path $ \s ->
- throwErrnoIfMinus1Retry_ "removeFile" (c_unlink s)
+removeFile path =
+#if mingw32_HOST_OS
+ System.Win32.deleteFile path
+#else
+ System.Posix.removeLink path
+#endif
{- |@'renameDirectory' old new@ changes the name of an existing
directory from /old/ to /new/. If the /new/ directory
renameDirectory :: FilePath -> FilePath -> IO ()
renameDirectory opath npath =
+ -- XXX this test isn't performed atomically with the following rename
withFileStatus "renameDirectory" opath $ \st -> do
is_dir <- isDirectory st
if (not is_dir)
then ioException (IOError Nothing InappropriateType "renameDirectory"
("not a directory") (Just opath))
else do
-
- withCString opath $ \s1 ->
- withCString npath $ \s2 ->
- throwErrnoIfMinus1Retry_ "renameDirectory" (c_rename s1 s2)
+#ifdef mingw32_HOST_OS
+ System.Win32.moveFileEx opath npath System.Win32.mOVEFILE_REPLACE_EXISTING
+#else
+ System.Posix.rename opath npath
+#endif
{- |@'renameFile' old new@ changes the name of an existing file system
object from /old/ to /new/. If the /new/ object already
renameFile :: FilePath -> FilePath -> IO ()
renameFile opath npath =
+ -- XXX this test isn't performed atomically with the following rename
withFileOrSymlinkStatus "renameFile" opath $ \st -> do
is_dir <- isDirectory st
if is_dir
then ioException (IOError Nothing InappropriateType "renameFile"
"is a directory" (Just opath))
else do
-
- withCString opath $ \s1 ->
- withCString npath $ \s2 ->
- throwErrnoIfMinus1Retry_ "renameFile" (c_rename s1 s2)
+#ifdef mingw32_HOST_OS
+ System.Win32.moveFileEx opath npath System.Win32.mOVEFILE_REPLACE_EXISTING
+#else
+ System.Posix.rename opath npath
+#endif
#endif /* __GLASGOW_HASKELL__ */
{- |@'copyFile' old new@ copies the existing file from /old/ to /new/.
If the /new/ file already exists, it is atomically replaced by the /old/ file.
-Neither path may refer to an existing directory.
+Neither path may refer to an existing directory. The permissions of /old/ are
+copied to /new/, if possible.
-}
+
copyFile :: FilePath -> FilePath -> IO ()
+#ifdef __NHC__
copyFile fromFPath toFPath =
-#if (!(defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 600))
- do readFile fromFPath >>= writeFile toFPath
- try (getPermissions fromFPath >>= setPermissions toFPath)
- return ()
+ do readFile fromFPath >>= writeFile toFPath
+ Prelude.catch (copyPermissions fromFPath toFPath)
+ (\_ -> return ())
#else
- (bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom ->
- bracket (openBinaryFile toFPath WriteMode) hClose $ \hTo ->
- allocaBytes bufferSize $ \buffer -> do
- copyContents hFrom hTo buffer
- try (getPermissions fromFPath >>= setPermissions toFPath)
- return ()) `catch` (ioError . changeFunName)
- where
- bufferSize = 1024
-
- changeFunName (IOError h iot fun str mb_fp) = IOError h iot "copyFile" str mb_fp
-
- copyContents hFrom hTo buffer = do
- count <- hGetBuf hFrom buffer bufferSize
- when (count > 0) $ do
- hPutBuf hTo buffer count
- copyContents hFrom hTo buffer
+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 ()
#endif
-#ifdef __GLASGOW_HASKELL__
-- | Given path referring to a file or directory, returns a
-- canonicalized path, with the intent that two paths referring
-- to the same file\/directory will map to the same canonicalized
-- path. Note that it is impossible to guarantee that the
--- implication (same file\/dir <=> same canonicalizedPath) holds
+-- implication (same file\/dir \<=\> same canonicalizedPath) holds
-- in either direction: this function can make only a best-effort
-- attempt.
canonicalizePath :: FilePath -> IO FilePath
canonicalizePath fpath =
withCString fpath $ \pInPath ->
allocaBytes long_path_size $ \pOutPath ->
-#if defined(mingw32_TARGET_OS)
+#if defined(mingw32_HOST_OS)
alloca $ \ppFilePart ->
do c_GetFullPathName pInPath (fromIntegral long_path_size) pOutPath ppFilePart
#else
do c_realpath pInPath pOutPath
#endif
- peekCString pOutPath
+ path <- peekCString pOutPath
+ return (normalise path)
+ -- normalise does more stuff, like upper-casing the drive letter
-#if defined(mingw32_TARGET_OS)
-foreign import stdcall unsafe "GetFullPathName"
+#if defined(mingw32_HOST_OS)
+foreign import stdcall unsafe "GetFullPathNameA"
c_GetFullPathName :: CString
-> CInt
-> CString
-> CString
-> IO CString
#endif
-#else /* !__GLASGOW_HASKELL__ */
--- dummy implementation
-canonicalizePath :: FilePath -> IO FilePath
-canonicalizePath fpath = return fpath
-#endif /* !__GLASGOW_HASKELL__ */
+
+-- | 'makeRelative' the current directory.
+makeRelativeToCurrentDirectory :: FilePath -> IO FilePath
+makeRelativeToCurrentDirectory x = do
+ cur <- getCurrentDirectory
+ return $ makeRelative cur x
-- | Given an executable file name, searches for such file
-- in the directories listed in system PATH. The returned value
-- such executable. For example (findExecutable \"ghc\")
-- gives you the path to GHC.
findExecutable :: String -> IO (Maybe FilePath)
-findExecutable binary = do
+findExecutable binary =
+#if defined(mingw32_HOST_OS)
+ withCString binary $ \c_binary ->
+ withCString ('.':exeExtension) $ \c_ext ->
+ allocaBytes long_path_size $ \pOutPath ->
+ alloca $ \ppFilePart -> do
+ res <- c_SearchPath nullPtr c_binary c_ext (fromIntegral long_path_size) pOutPath ppFilePart
+ if res > 0 && res < fromIntegral long_path_size
+ then do fpath <- peekCString pOutPath
+ return (Just fpath)
+ else return Nothing
+
+foreign import stdcall unsafe "SearchPathA"
+ c_SearchPath :: CString
+ -> CString
+ -> CString
+ -> CInt
+ -> CString
+ -> Ptr CString
+ -> IO CInt
+#else
+ do
path <- getEnv "PATH"
- search (parseSearchPath path)
+ search (splitSearchPath path)
where
- fileName = binary `joinFileExt` exeExtension
+ fileName = binary <.> exeExtension
search :: [FilePath] -> IO (Maybe FilePath)
search [] = return Nothing
search (d:ds) = do
- let path = d `joinFileName` fileName
- b <- doesFileExist path
- if b then return (Just path)
+ let path = d </> fileName
+ b <- doesFileExist path
+ if b then return (Just path)
else search ds
+#endif
+
#ifdef __GLASGOW_HASKELL__
{- |@'getDirectoryContents' dir@ returns a list of /all/ entries
getCurrentDirectory :: IO FilePath
getCurrentDirectory = do
+#ifdef mingw32_HOST_OS
+ -- XXX: should use something from Win32
p <- mallocBytes long_path_size
go p long_path_size
where go p bytes = do
else do errno <- getErrno
if errno == eRANGE
then do let bytes' = bytes * 2
- p' <- reallocBytes p bytes'
- go p' bytes'
+ p'' <- reallocBytes p bytes'
+ go p'' bytes'
else throwErrno "getCurrentDirectory"
+#else
+ System.Posix.getWorkingDirectory
+#endif
+
+#ifdef mingw32_HOST_OS
+foreign import ccall unsafe "getcwd"
+ c_getcwd :: Ptr CChar -> CSize -> IO (Ptr CChar)
+#endif
{- |If the operating system has a notion of current directories,
@'setCurrentDirectory' dir@ changes the current
-}
setCurrentDirectory :: FilePath -> IO ()
-setCurrentDirectory path = do
- modifyIOError (`ioeSetFileName` path) $
- withCString path $ \s ->
- throwErrnoIfMinus1Retry_ "setCurrentDirectory" (c_chdir s)
- -- ToDo: add path to error
+setCurrentDirectory path =
+#ifdef mingw32_HOST_OS
+ System.Win32.setCurrentDirectory path
+#else
+ System.Posix.changeWorkingDirectory path
+#endif
{- |The operation 'doesDirectoryExist' returns 'True' if the argument file
exists and is a directory, and 'False' otherwise.
-}
doesDirectoryExist :: FilePath -> IO Bool
-doesDirectoryExist name =
- catch
+doesDirectoryExist name =
(withFileStatus "doesDirectoryExist" name $ \st -> isDirectory st)
- (\ _ -> return False)
+ `catch` ((\ _ -> return False) :: IOException -> IO Bool)
{- |The operation 'doesFileExist' returns 'True'
if the argument file exists and is not a directory, and 'False' otherwise.
-}
doesFileExist :: FilePath -> IO Bool
-doesFileExist name = do
- catch
+doesFileExist name =
(withFileStatus "doesFileExist" name $ \st -> do b <- isDirectory st; return (not b))
- (\ _ -> return False)
+ `catch` ((\ _ -> return False) :: IOException -> IO Bool)
{- |The 'getModificationTime' operation returns the
clock time at which the file or directory was last modified.
return (s_isdir mode)
fileNameEndClean :: String -> String
-fileNameEndClean name =
- if i > 0 && (ec == '\\' || ec == '/') then
- fileNameEndClean (take i name)
- else
- name
- where
- i = (length name) - 1
- ec = name !! i
-
-foreign import ccall unsafe "__hscore_long_path_size"
- long_path_size :: Int
+fileNameEndClean name = if isDrive name then addTrailingPathSeparator name
+ else dropTrailingPathSeparator name
-foreign import ccall unsafe "__hscore_R_OK" r_OK :: CMode
-foreign import ccall unsafe "__hscore_W_OK" w_OK :: CMode
-foreign import ccall unsafe "__hscore_X_OK" x_OK :: CMode
+foreign import ccall unsafe "__hscore_R_OK" r_OK :: CInt
+foreign import ccall unsafe "__hscore_W_OK" w_OK :: CInt
+foreign import ccall unsafe "__hscore_X_OK" x_OK :: CInt
foreign import ccall unsafe "__hscore_S_IRUSR" s_IRUSR :: CMode
foreign import ccall unsafe "__hscore_S_IWUSR" s_IWUSR :: CMode
foreign import ccall unsafe "__hscore_S_IXUSR" s_IXUSR :: CMode
+#ifdef mingw32_HOST_OS
+foreign import ccall unsafe "__hscore_S_IFDIR" s_IFDIR :: CMode
+#endif
+
+foreign import ccall unsafe "__hscore_long_path_size"
+ long_path_size :: Int
+
+#else
+long_path_size :: Int
+long_path_size = 2048 -- // guess?
#endif /* __GLASGOW_HASKELL__ */
-}
getHomeDirectory :: IO FilePath
getHomeDirectory =
-#if __GLASGOW_HASKELL__ && defined(mingw32_TARGET_OS)
+#if defined(mingw32_HOST_OS)
allocaBytes long_path_size $ \pPath -> do
- r <- c_SHGetFolderPath nullPtr csidl_PROFILE nullPtr 0 pPath
- if (r < 0)
- then c_SHGetFolderPath nullPtr csidl_WINDOWS nullPtr 0 pPath
- else return 0
+ r0 <- c_SHGetFolderPath nullPtr csidl_PROFILE nullPtr 0 pPath
+ if (r0 < 0)
+ then do
+ r1 <- c_SHGetFolderPath nullPtr csidl_WINDOWS nullPtr 0 pPath
+ when (r1 < 0) (raiseUnsupported "System.Directory.getHomeDirectory")
+ else return ()
peekCString pPath
#else
getEnv "HOME"
-}
getAppUserDataDirectory :: String -> IO FilePath
getAppUserDataDirectory appName = do
-#if __GLASGOW_HASKELL__ && defined(mingw32_TARGET_OS)
+#if defined(mingw32_HOST_OS)
allocaBytes long_path_size $ \pPath -> do
r <- c_SHGetFolderPath nullPtr csidl_APPDATA nullPtr 0 pPath
+ when (r<0) (raiseUnsupported "System.Directory.getAppUserDataDirectory")
s <- peekCString pPath
return (s++'\\':appName)
#else
-}
getUserDocumentsDirectory :: IO FilePath
getUserDocumentsDirectory = do
-#if __GLASGOW_HASKELL__ && defined(mingw32_TARGET_OS)
+#if defined(mingw32_HOST_OS)
allocaBytes long_path_size $ \pPath -> do
r <- c_SHGetFolderPath nullPtr csidl_PERSONAL nullPtr 0 pPath
+ when (r<0) (raiseUnsupported "System.Directory.getUserDocumentsDirectory")
peekCString pPath
#else
getEnv "HOME"
-}
getTemporaryDirectory :: IO FilePath
getTemporaryDirectory = do
-#if __GLASGOW_HASKELL__ && defined(mingw32_TARGET_OS)
+#if defined(mingw32_HOST_OS)
allocaBytes long_path_size $ \pPath -> do
- r <- c_GetTempPath (fromIntegral long_path_size) pPath
+ _r <- c_GetTempPath (fromIntegral long_path_size) pPath
peekCString pPath
#else
- catch (getEnv "TMPDIR") (\ex -> return "/tmp")
+ getEnv "TMPDIR"
+#if !__NHC__
+ `Prelude.catch` \e -> if isDoesNotExistError e then return "/tmp"
+ else throw e
+#else
+ `Prelude.catch` (\ex -> return "/tmp")
+#endif
#endif
-#if __GLASGOW_HASKELL__ && defined(mingw32_TARGET_OS)
-foreign import stdcall unsafe "SHGetFolderPath"
+#if defined(mingw32_HOST_OS)
+foreign import ccall unsafe "__hscore_getFolderPath"
c_SHGetFolderPath :: Ptr ()
-> CInt
-> Ptr ()
foreign import ccall unsafe "__hscore_CSIDL_WINDOWS" csidl_WINDOWS :: CInt
foreign import ccall unsafe "__hscore_CSIDL_PERSONAL" csidl_PERSONAL :: CInt
-foreign import stdcall unsafe "GetTempPath" c_GetTempPath :: CInt -> CString -> IO CInt
+foreign import stdcall unsafe "GetTempPathA" c_GetTempPath :: CInt -> CString -> IO CInt
+
+raiseUnsupported :: String -> IO ()
+raiseUnsupported loc =
+ ioException (IOError Nothing UnsupportedOperation loc "unsupported operation" Nothing)
+
#endif
+
+-- ToDo: This should be determined via autoconf (AC_EXEEXT)
+-- | Extension for executable files
+-- (typically @\"\"@ on Unix and @\"exe\"@ on Windows or OS\/2)
+exeExtension :: String
+#ifdef mingw32_HOST_OS
+exeExtension = "exe"
+#else
+exeExtension = ""
+#endif
+
projects / haskell-directory.git / blobdiff