avoid race conditions in createDirectoryIfMissing (#2808)

[haskell-directory.git] / System / Directory.hs

diff --git a/System/Directory.hs b/System/Directory.hs
index 5da67b6..afa38eb 100644 (file)
--- a/System/Directory.hs
+++ b/System/Directory.hs
@@ -72,6 +72,7 @@ module System.Directory
 import Prelude hiding ( catch )
 import qualified Prelude
 
+import Control.Monad (guard)
 import System.Environment      ( getEnv )
 import System.FilePath
 import System.IO
@@ -284,10 +285,11 @@ The path refers to an existing non-directory object.
 
 createDirectory :: FilePath -> IO ()
 createDirectory path = do
-  modifyIOError (`ioeSetFileName` path) $
-    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__ */
 
@@ -303,14 +305,23 @@ copyPermissions fromFPath toFPath
 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
+createDirectoryIfMissing create_parents "" = return ()
+createDirectoryIfMissing create_parents path0
+ = do  r <- try $ createDirectory path
+       case (r :: Either IOException ()) of
+          Right _ -> return ()
+          Left e
+             | isAlreadyExistsError e -> return ()
+             | isDoesNotExistError  e && create_parents -> do
+                 createDirectoryIfMissing True (dropFileName path)
+                 createDirectoryIfMissing True path
+             | otherwise -> throw e
+  where
+    -- we want createDirectoryIfMissing "a/" to behave like   
+    -- createDirectoryIfMissing "a".  Also, unless we apply
+    -- dropTrailingPathSeparator first, dropFileName won't drop
+    -- anything from "a/".
+    path = dropTrailingPathSeparator path0
 
 #if __GLASGOW_HASKELL__
 {- | @'removeDirectory' dir@ removes an existing directory /dir/.  The
@@ -355,10 +366,13 @@ The operand refers to an existing non-directory object.
 -}
 
 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/
@@ -415,10 +429,12 @@ The operand refers to an existing directory.
 -}
 
 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
@@ -481,7 +497,7 @@ renameDirectory opath npath =
 #ifdef mingw32_HOST_OS
    System.Win32.moveFileEx opath npath System.Win32.mOVEFILE_REPLACE_EXISTING
 #else
-   System.Posix.rename s1 s2
+   System.Posix.rename opath npath
 #endif
 
 {- |@'renameFile' old new@ changes the name of an existing file system
@@ -540,7 +556,7 @@ renameFile opath npath =
 #ifdef mingw32_HOST_OS
    System.Win32.moveFileEx opath npath System.Win32.mOVEFILE_REPLACE_EXISTING
 #else
-   System.Posix.rename s1 s2
+   System.Posix.rename opath npath
 #endif
 
 #endif /* __GLASGOW_HASKELL__ */
@@ -762,6 +778,8 @@ The operating system has no notion of current directory.
 
 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
@@ -776,6 +794,14 @@ getCurrentDirectory = do
                                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
@@ -810,11 +836,12 @@ The path refers to an existing non-directory object.
 -}
 
 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.