[commit: Cabal] master: Reimplement createDirectoryIfMissingVerbose to use sensible file permissions (237cfe1)

[Duncan Coutts]

Repository : ssh://darcs.haskell.org//srv/darcs/packages/Cabal

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/237cfe101bccb6929fea2c53c4d2300b4f53c598

>---------------------------------------------------------------

commit 237cfe101bccb6929fea2c53c4d2300b4f53c598
Author: Duncan Coutts <duncan at community.haskell.org>
Date:   Tue May 17 11:23:44 2011 +0000

    Reimplement createDirectoryIfMissingVerbose to use sensible file permissions
    Hopefully should fix ghc ticket #4982.
    The problem was permissions on directories: previously we used ordinary
    createDirectory and on unix this creates dirs using the current user's
    umask. If the root user has a silly umask then someone doing sudo
    install will end up with dirs that are not readable by non-root users.
    
    So the solution is to do the same as we do with files: override the
    umask and explicitly set the file permissions based on the kind of
    file: ordinary file, executable file and now also directory.
    
    Sadly we also had to re-implement createDirectoryIfMissing to use our
    new createDirectory wrapper function.

>---------------------------------------------------------------

 Distribution/Compat/CopyFile.hs  |    5 ++-
 Distribution/Compat/Exception.hs |   11 +++++--
 Distribution/Simple/Utils.hs     |   59 +++++++++++++++++++++++++++++++------
 3 files changed, 61 insertions(+), 14 deletions(-)

diff --git a/Distribution/Compat/CopyFile.hs b/Distribution/Compat/CopyFile.hs
index c8a5be0..3d96d72 100644
--- a/Distribution/Compat/CopyFile.hs
+++ b/Distribution/Compat/CopyFile.hs
@@ -11,6 +11,7 @@ module Distribution.Compat.CopyFile (
   copyExecutableFile,
   setFileOrdinary,
   setFileExecutable,
+  setDirOrdinary,
   ) where
 
 #ifdef __GLASGOW_HASKELL__
@@ -62,7 +63,7 @@ copyOrdinaryFile, copyExecutableFile :: FilePath -> FilePath -> IO ()
 copyOrdinaryFile   src dest = copyFile src dest >> setFileOrdinary   dest
 copyExecutableFile src dest = copyFile src dest >> setFileExecutable dest
 
-setFileOrdinary,  setFileExecutable  :: FilePath -> IO ()
+setFileOrdinary,  setFileExecutable, setDirOrdinary  :: FilePath -> IO ()
 #ifndef mingw32_HOST_OS
 setFileOrdinary   path = setFileMode path 0o644 -- file perms -rw-r--r--
 setFileExecutable path = setFileMode path 0o755 -- file perms -rwxr-xr-x
@@ -83,6 +84,8 @@ setFileMode name m =
 setFileOrdinary   _ = return ()
 setFileExecutable _ = return ()
 #endif
+-- This happens to be true on Unix and currently on Windows too:
+setDirOrdinary = setFileExecutable
 
 copyFile :: FilePath -> FilePath -> IO ()
 #ifdef __GLASGOW_HASKELL__
diff --git a/Distribution/Compat/Exception.hs b/Distribution/Compat/Exception.hs
index 54ec356..ae8d9d5 100644
--- a/Distribution/Compat/Exception.hs
+++ b/Distribution/Compat/Exception.hs
@@ -9,9 +9,14 @@
 #define NEW_EXCEPTION
 #endif
 
-module Distribution.Compat.Exception
-    (onException, catchIO, catchExit, throwIOIO, tryIO)
-    where
+module Distribution.Compat.Exception (
+     Exception.IOException,
+     onException,
+     catchIO,
+     catchExit,
+     throwIOIO,
+     tryIO,
+  ) where
 
 import System.Exit
 import qualified Control.Exception as Exception
diff --git a/Distribution/Simple/Utils.hs b/Distribution/Simple/Utils.hs
index 65149ee..1981096 100644
--- a/Distribution/Simple/Utils.hs
+++ b/Distribution/Simple/Utils.hs
@@ -158,14 +158,15 @@ import System.Exit
     ( exitWith, ExitCode(..) )
 import System.FilePath
     ( normalise, (</>), (<.>), takeDirectory, splitFileName
-    , splitExtension, splitExtensions )
+    , splitExtension, splitExtensions, splitDirectories )
 import System.Directory
-    ( createDirectoryIfMissing, renameFile, removeDirectoryRecursive )
+    ( createDirectory, renameFile, removeDirectoryRecursive )
 import System.IO
     ( Handle, openFile, openBinaryFile, IOMode(ReadMode), hSetBinaryMode
     , hGetContents, stderr, stdout, hPutStr, hFlush, hClose )
 import System.IO.Error as IO.Error
-    ( isDoesNotExistError, ioeSetFileName, ioeGetFileName, ioeGetErrorString )
+    ( isDoesNotExistError, isAlreadyExistsError
+    , ioeSetFileName, ioeGetFileName, ioeGetErrorString )
 #if !(defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 608))
 import System.IO.Error
     ( ioeSetLocation, ioeGetLocation )
@@ -196,11 +197,11 @@ import System.Directory (getTemporaryDirectory)
 
 import Distribution.Compat.CopyFile
          ( copyFile, copyOrdinaryFile, copyExecutableFile
-         , setFileOrdinary, setFileExecutable )
+         , setFileOrdinary, setFileExecutable, setDirOrdinary )
 import Distribution.Compat.TempFile
          ( openTempFile, openNewBinaryFile, createTempDirectory )
 import Distribution.Compat.Exception
-         ( catchIO, catchExit, onException )
+         ( IOException, throwIOIO, tryIO, catchIO, catchExit, onException )
 import Distribution.Verbosity
 
 #ifdef VERSION_base
@@ -706,11 +707,49 @@ matchDirFileGlob dir filepath = case parseFileGlob filepath of
 
 -- | Same as 'createDirectoryIfMissing' but logs at higher verbosity levels.
 --
-createDirectoryIfMissingVerbose :: Verbosity -> Bool -> FilePath -> IO ()
-createDirectoryIfMissingVerbose verbosity parentsToo dir = do
-  let msgParents = if parentsToo then " (and its parents)" else ""
-  info verbosity ("Creating " ++ dir ++ msgParents)
-  createDirectoryIfMissing parentsToo dir
+createDirectoryIfMissingVerbose :: Verbosity
+                                -> Bool     -- ^ Create its parents too?
+                                -> FilePath
+                                -> IO ()
+createDirectoryIfMissingVerbose verbosity 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 throwIOIO
+    createDirs (dir:dirs) =
+      createDir dir $ \_ -> do
+        createDirs dirs
+        createDir dir throwIOIO
+
+    createDir :: FilePath -> (IOException -> IO ()) -> IO ()
+    createDir dir notExistHandler = do
+      r <- tryIO $ createDirectoryVerbose verbosity dir
+      case (r :: Either IOException ()) of
+        Right ()                   -> return ()
+        Left  e
+          | isDoesNotExistError  e -> notExistHandler e
+          -- createDirectory (and indeed POSIX mkdir) does not distinguish
+          -- between a dir already existing and a file already existing. So we
+          -- check for it here. Unfortunately there is a slight race condition
+          -- here, but we think it is benign. It could report an exeption in
+          -- the case that the dir did exist but another process deletes the
+          -- directory and creates a file in its place before we can check
+          -- that the directory did indeed exist.
+          | isAlreadyExistsError e -> (do
+              isDir <- doesDirectoryExist dir
+              if isDir then return ()
+                       else throwIOIO e
+              ) `catch` ((\_ -> return ()) :: IOException -> IO ())
+          | otherwise              -> throwIOIO e
+
+createDirectoryVerbose :: Verbosity -> FilePath -> IO ()
+createDirectoryVerbose verbosity dir = do
+  info verbosity $ "creating " ++ dir
+  createDirectory dir
+  setDirOrdinary dir
 
 -- | Copies a file without copying file permissions. The target file is created
 -- with default permissions. Any existing target file is replaced.