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 <[email protected]> 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. _______________________________________________ Cvs-libraries mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-libraries
