ghc-boot: Simplify writePackageDb permissions handling

Commit ef8a3fbf1 ("ghc-boot: Fix metadata handling of writeFileAtomic")
introduced a somewhat over-engineered fix for #14017 by trying to preserve
the current permissions if the target file already exists.

The problem in the issue is simply that the package db cache file should be
world readable but isn't if umask is too restrictive. In fact the previous
fix only handles part of this problem. If the file isn't already there in a
readable configuration it wont make it so which isn't really ideal either.

Rather than all that we now simply always force all the read access bits to
allow access while leaving the owner at the system default as it's just not
our business to mess with it.

1 files changed, 16 insertions, 23 deletions

diff --git a/libraries/ghc-boot/GHC/Unit/Database.hs b/libraries/ghc-boot/GHC/Unit/Database.hs
index 9a182941d7..ac68476156 100644
--- a/libraries/ghc-boot/GHC/Unit/Database.hs
+++ b/libraries/ghc-boot/GHC/Unit/Database.hs
@@ -88,8 +88,9 @@ import Control.Exception as Exception
 import Control.Monad (when)
 import System.FilePath as FilePath
 #if !defined(mingw32_HOST_OS)
+import Data.Bits ((.|.))
 import System.Posix.Files
-import GHC.IO.Exception (ioe_type, IOErrorType(NoSuchThing))
+import System.Posix.Types (FileMode)
 #endif
 import System.IO
 import System.IO.Error
@@ -413,8 +414,14 @@ readPackageDbForGhcPkg file mode =
 -- | Write the whole of the package DB, both parts.
 --
 writePackageDb :: Binary pkgs => FilePath -> [DbUnitInfo] -> pkgs -> IO ()
-writePackageDb file ghcPkgs ghcPkgPart =
+writePackageDb file ghcPkgs ghcPkgPart = do
   writeFileAtomic file (runPut putDbForGhcPkg)
+#if !defined(mingw32_HOST_OS)
+  addFileMode file 0o444
+  --  ^ In case the current umask is too restrictive force all read bits to
+  --  allow access.
+#endif
+  return ()
   where
     putDbForGhcPkg = do
         putHeader
@@ -426,6 +433,13 @@ writePackageDb file ghcPkgs ghcPkgPart =
         ghcPartLen = fromIntegral (BS.Lazy.length ghcPart)
         ghcPart    = encode ghcPkgs
 
+#if !defined(mingw32_HOST_OS)
+addFileMode :: FilePath -> FileMode -> IO ()
+addFileMode file m = do
+  o <- fileMode <$> getFileStatus file
+  setFileMode file (m .|. o)
+#endif
+
 getHeader :: Get (Word32, Word32)
 getHeader = do
     magic <- getByteString (BS.length headerMagic)
@@ -508,26 +522,6 @@ decodeFromFile file mode decoder = case mode of
 -- Copied from Cabal's Distribution.Simple.Utils.
 writeFileAtomic :: FilePath -> BS.Lazy.ByteString -> IO ()
 writeFileAtomic targetPath content = do
-  -- Figure out how to update the file mode after we create the temporary file
-  let no_update _path = return ()
-#if !defined(mingw32_HOST_OS)
-  let on_error ioe =
-          -- If the file doesn't yet exist then just use the default owner and
-          -- mode.
-          case ioe_type ioe of
-            NoSuchThing -> return no_update
-            _ -> ioError ioe
-  let handleIO :: (IOException -> IO a) -> IO a -> IO a
-      handleIO = flip catch
-  set_metadata <- handleIO on_error $ do
-      status <- getFileStatus targetPath
-      return $ \path -> do
-        setFileMode path (fileMode status)
-        setOwnerAndGroup path (fileOwner status) (fileGroup status)
-#else
-  let set_metadata = no_update
-#endif
-
   let (targetDir, targetFile) = splitFileName targetPath
   Exception.bracketOnError
     (openBinaryTempFileWithDefaultPermissions targetDir $ targetFile <.> "tmp")
@@ -535,7 +529,6 @@ writeFileAtomic targetPath content = do
     (\(tmpPath, handle) -> do
         BS.Lazy.hPut handle content
         hClose handle
-        set_metadata tmpPath
         renameFile tmpPath targetPath)
 
 instance Binary DbUnitInfo where