-- * Actions on directories
createDirectory -- :: FilePath -> IO ()
+ , createDirectoryIfMissing -- :: Bool -> FilePath -> IO ()
, removeDirectory -- :: FilePath -> IO ()
+ , removeDirectoryRecursive -- :: FilePath -> IO ()
, renameDirectory -- :: FilePath -> FilePath -> IO ()
, getDirectoryContents -- :: FilePath -> IO [FilePath]
, getHomeDirectory
, getAppUserDataDirectory
, getUserDocumentsDirectory
+ , getTemporaryDirectory
-- * Actions on files
, removeFile -- :: FilePath -> IO ()
, renameFile -- :: FilePath -> FilePath -> IO ()
-#ifdef __GLASGOW_HASKELL__
, copyFile -- :: FilePath -> FilePath -> IO ()
-#endif
+
+ , canonicalizePath
+ , makeRelativeToCurrentDirectory
+ , findExecutable
-- * Existence tests
, doesFileExist -- :: FilePath -> IO Bool
, getModificationTime -- :: FilePath -> IO ClockTime
) where
+import System.Directory.Internals
+import System.Environment ( getEnv )
+import System.FilePath
+import System.IO.Error
+import Control.Monad ( when, unless )
+
#ifdef __NHC__
import Directory
-import System (getEnv)
-getHomeDirectory :: IO FilePath
-getHomeDirectory = getEnv "HOME"
-getAppUserDataDirectory :: String -> IO FilePath
-getAppUserDataDirectory appName = do path <- getEnv "HOME"
- return (path++'/':'.':appName)
-getUserDocumentsDirectory :: IO FilePath
-getUserDocumentsDirectory= getEnv "HOME"
-#elif defined(__HUGS__)
+#endif /* __NHC__ */
+
+#ifdef __HUGS__
import Hugs.Directory
-#else
+#endif /* __HUGS__ */
+import Foreign
+import Foreign.C
+
+{-# CFILES cbits/directory.c #-}
+
+#ifdef __GLASGOW_HASKELL__
import Prelude
import Control.Exception ( bracket )
-import Control.Monad ( when )
import System.Posix.Types
import System.Posix.Internals
import System.Time ( ClockTime(..) )
import System.IO
-import System.IO.Error
-import Foreign
-import Foreign.C
-#ifdef __GLASGOW_HASKELL__
import GHC.IOBase ( IOException(..), IOErrorType(..), ioException )
-#endif
-
-#ifndef mingw32_TARGET_OS
-import System.Environment
-#endif
{- $intro
A directory contains a series of entries, each of which is a named
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
+ modifyIOError (`ioeSetFileName` path) $
withCString path $ \s -> do
throwErrnoIfMinus1Retry_ "createDirectory" $
mkdir s 0o777
+#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) (tail (pathParents file))
+ (_, False, _) -> createDirectory file
+
+#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
modifyIOError (`ioeSetFileName` path) $
withCString path $ \s ->
throwErrnoIfMinus1Retry_ "removeDirectory" (c_rmdir s)
+#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 `joinFileName` 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 $ ioError e
+ 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
withCString npath $ \s2 ->
throwErrnoIfMinus1Retry_ "renameFile" (c_rename s1 s2)
+#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.
+-}
+
+{- NOTES:
+
+It's tempting to try to remove the target file before opening it for
+writing. This could be useful: for example if the target file is an
+executable that is in use, writing will fail, but unlinking first
+would succeed.
+
+However, it certainly isn't always what you want.
+
+ * if the target file is hardlinked, removing it would break
+ the hard link, but just opening would preserve it.
+
+ * opening and truncating will preserve permissions and
+ ACLs on the target.
+
+ * If the destination file is read-only in a writable directory,
+ we might want copyFile to fail. Removing the target first
+ would succeed, however.
+
+ * If the destination file is special (eg. /dev/null), removing
+ it is probably not the right thing. Copying to /dev/null
+ should leave /dev/null intact, not replace it with a plain
+ file.
+
+ * There's a small race condition between removing the target and
+ opening it for writing during which time someone might
+ create it again.
-}
copyFile :: FilePath -> FilePath -> IO ()
copyFile fromFPath toFPath =
+#if (!(defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 600))
+ do readFile fromFPath >>= writeFile toFPath
+ try (copyPermissions fromFPath toFPath)
+ return ()
+#else
(bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom ->
bracket (openBinaryFile toFPath WriteMode) hClose $ \hTo ->
- allocaBytes bufferSize $ \buffer ->
- copyContents hFrom hTo buffer) `catch` (ioError . changeFunName)
+ allocaBytes bufferSize $ \buffer -> do
+ copyContents hFrom hTo buffer
+ try (copyPermissions fromFPath toFPath)
+ return ()) `catch` (ioError . changeFunName)
where
bufferSize = 1024
when (count > 0) $ do
hPutBuf hTo buffer count
copyContents hFrom hTo buffer
+#endif
+
+-- | 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
+-- 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_HOST_OS)
+ alloca $ \ppFilePart ->
+ do c_GetFullPathName pInPath (fromIntegral long_path_size) pOutPath ppFilePart
+#else
+ do c_realpath pInPath pOutPath
+#endif
+ peekCString pOutPath
+
+#if defined(mingw32_HOST_OS)
+foreign import stdcall unsafe "GetFullPathNameA"
+ c_GetFullPathName :: CString
+ -> CInt
+ -> CString
+ -> Ptr CString
+ -> IO CInt
+#else
+foreign import ccall unsafe "realpath"
+ c_realpath :: CString
+ -> CString
+ -> IO CString
+#endif
+
+-- | '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
+-- is the path to the found executable or Nothing if there isn't
+-- such executable. For example (findExecutable \"ghc\")
+-- gives you the path to GHC.
+findExecutable :: String -> IO (Maybe FilePath)
+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)
+ where
+ fileName = binary `joinFileExt` 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)
+ else search ds
+#endif
+#ifdef __GLASGOW_HASKELL__
{- |@'getDirectoryContents' dir@ returns a list of /all/ entries
in /dir/.
throwErrnoIfMinus1Retry_ "setCurrentDirectory" (c_chdir s)
-- ToDo: add path to error
+{- |The operation 'doesDirectoryExist' returns 'True' if the argument file
+exists and is a directory, and 'False' otherwise.
+-}
+
+doesDirectoryExist :: FilePath -> IO Bool
+doesDirectoryExist name =
+ catch
+ (withFileStatus "doesDirectoryExist" name $ \st -> isDirectory st)
+ (\ _ -> return False)
+
+{- |The operation 'doesFileExist' returns 'True'
+if the argument file exists and is not a directory, and 'False' otherwise.
+-}
+
+doesFileExist :: FilePath -> IO Bool
+doesFileExist name = do
+ catch
+ (withFileStatus "doesFileExist" name $ \st -> do b <- isDirectory st; return (not b))
+ (\ _ -> return False)
+
+{- |The 'getModificationTime' operation returns the
+clock time at which the file or directory was last modified.
+
+The operation may fail with:
+
+* 'isPermissionError' if the user is not permitted to access
+ the modification time; or
+
+* 'isDoesNotExistError' if the file or directory does not exist.
+
+-}
+
+getModificationTime :: FilePath -> IO ClockTime
+getModificationTime name =
+ withFileStatus "getModificationTime" name $ \ st ->
+ modificationTime st
+
+withFileStatus :: String -> FilePath -> (Ptr CStat -> IO a) -> IO a
+withFileStatus loc name f = do
+ modifyIOError (`ioeSetFileName` name) $
+ allocaBytes sizeof_stat $ \p ->
+ withCString (fileNameEndClean name) $ \s -> do
+ throwErrnoIfMinus1Retry_ loc (c_stat s p)
+ f p
+
+withFileOrSymlinkStatus :: String -> FilePath -> (Ptr CStat -> IO a) -> IO a
+withFileOrSymlinkStatus loc name f = do
+ modifyIOError (`ioeSetFileName` name) $
+ allocaBytes sizeof_stat $ \p ->
+ withCString name $ \s -> do
+ throwErrnoIfMinus1Retry_ loc (lstat s p)
+ f 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 i > 0 && (ec == '\\' || ec == '/') then
+ fileNameEndClean (take i name)
+ else
+ name
+ where
+ i = (length name) - 1
+ ec = name !! i
+
+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
+
+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__ */
+
{- | Returns the current user's home directory.
The directory returned is expected to be writable by the current user,
-}
getHomeDirectory :: IO FilePath
getHomeDirectory =
-#ifdef 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
+ then do
+ r <- c_SHGetFolderPath nullPtr csidl_WINDOWS nullPtr 0 pPath
+ when (r < 0) (raiseUnsupported "System.Directory.getHomeDirectory")
+ else return ()
peekCString pPath
#else
getEnv "HOME"
-}
getAppUserDataDirectory :: String -> IO FilePath
getAppUserDataDirectory appName = do
-#ifdef 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
-#ifdef 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"
#endif
-#ifdef mingw32_TARGET_OS
-foreign import stdcall unsafe "SHGetFolderPath"
- c_SHGetFolderPath :: Ptr ()
- -> CInt
- -> Ptr ()
- -> CInt
- -> CString
- -> IO CInt
-foreign import ccall unsafe "__hscore_CSIDL_PROFILE" csidl_PROFILE :: CInt
-foreign import ccall unsafe "__hscore_CSIDL_APPDATA" csidl_APPDATA :: CInt
-foreign import ccall unsafe "__hscore_CSIDL_WINDOWS" csidl_WINDOWS :: CInt
-foreign import ccall unsafe "__hscore_CSIDL_PERSONAL" csidl_PERSONAL :: CInt
-#endif
+{- | Returns the current directory for temporary files.
-{- |The operation 'doesDirectoryExist' returns 'True' if the argument file
-exists and is a directory, and 'False' otherwise.
--}
+On Unix, 'getTemporaryDirectory' returns the value of the @TMPDIR@
+environment variable or \"\/tmp\" if the variable isn\'t defined.
+On Windows, the function checks for the existence of environment variables in
+the following order and uses the first path found:
-doesDirectoryExist :: FilePath -> IO Bool
-doesDirectoryExist name =
- catch
- (withFileStatus "doesDirectoryExist" name $ \st -> isDirectory st)
- (\ _ -> return False)
+*
+TMP environment variable.
-{- |The operation 'doesFileExist' returns 'True'
-if the argument file exists and is not a directory, and 'False' otherwise.
--}
+*
+TEMP environment variable.
-doesFileExist :: FilePath -> IO Bool
-doesFileExist name = do
- catch
- (withFileStatus "doesFileExist" name $ \st -> do b <- isDirectory st; return (not b))
- (\ _ -> return False)
+*
+USERPROFILE environment variable.
-{- |The 'getModificationTime' operation returns the
-clock time at which the file or directory was last modified.
+*
+The Windows directory
The operation may fail with:
-* 'isPermissionError' if the user is not permitted to access
- the modification time; or
-
-* 'isDoesNotExistError' if the file or directory does not exist.
+* 'UnsupportedOperation'
+The operating system has no notion of temporary directory.
+The function doesn\'t verify whether the path exists.
-}
+getTemporaryDirectory :: IO FilePath
+getTemporaryDirectory = do
+#if defined(mingw32_HOST_OS)
+ allocaBytes long_path_size $ \pPath -> do
+ r <- c_GetTempPath (fromIntegral long_path_size) pPath
+ peekCString pPath
+#else
+ catch (getEnv "TMPDIR") (\ex -> return "/tmp")
+#endif
-getModificationTime :: FilePath -> IO ClockTime
-getModificationTime name =
- withFileStatus "getModificationTime" name $ \ st ->
- modificationTime st
-
-withFileStatus :: String -> FilePath -> (Ptr CStat -> IO a) -> IO a
-withFileStatus loc name f = do
- modifyIOError (`ioeSetFileName` name) $
- allocaBytes sizeof_stat $ \p ->
- withCString (fileNameEndClean name) $ \s -> do
- throwErrnoIfMinus1Retry_ loc (c_stat s p)
- f p
-
-withFileOrSymlinkStatus :: String -> FilePath -> (Ptr CStat -> IO a) -> IO a
-withFileOrSymlinkStatus loc name f = do
- modifyIOError (`ioeSetFileName` name) $
- allocaBytes sizeof_stat $ \p ->
- withCString name $ \s -> do
- throwErrnoIfMinus1Retry_ loc (lstat s p)
- f 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 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
+#if defined(mingw32_HOST_OS)
+foreign import ccall unsafe "__hscore_getFolderPath"
+ c_SHGetFolderPath :: Ptr ()
+ -> CInt
+ -> Ptr ()
+ -> CInt
+ -> CString
+ -> IO CInt
+foreign import ccall unsafe "__hscore_CSIDL_PROFILE" csidl_PROFILE :: CInt
+foreign import ccall unsafe "__hscore_CSIDL_APPDATA" csidl_APPDATA :: CInt
+foreign import ccall unsafe "__hscore_CSIDL_WINDOWS" csidl_WINDOWS :: CInt
+foreign import ccall unsafe "__hscore_CSIDL_PERSONAL" csidl_PERSONAL :: CInt
-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 stdcall unsafe "GetTempPathA" c_GetTempPath :: CInt -> CString -> IO 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
+raiseUnsupported loc =
+ ioException (IOError Nothing UnsupportedOperation loc "unsupported operation" Nothing)
#endif
projects / haskell-directory.git / blobdiff