Commit 237cfe10 authored by Duncan Coutts's avatar Duncan Coutts
Browse files

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.
parent 6ea773a7
......@@ -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__
......
......@@ -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
......
......@@ -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.
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment