diff options
author | Ben Gamari <ben@smart-cactus.org> | 2021-09-13 16:05:43 -0400 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-09-17 09:42:30 -0400 |
commit | ef8a3fbf1363ba512d6d2c1a508473d6144e3d72 (patch) | |
tree | b23a6f83d704134e21618d572eea8837436f45b0 | |
parent | 987180d46d47abd17b920f594c76cdcf9ec87b2b (diff) | |
download | haskell-ef8a3fbf1363ba512d6d2c1a508473d6144e3d72.tar.gz |
ghc-boot: Fix metadata handling of writeFileAtomic
Previously the implementation of writeFileAtomic (which was stolen from
Cabal) failed to preserve file mode, user and group, resulting
in #14017.
Fixes #14017.
-rw-r--r-- | libraries/ghc-boot/GHC/Unit/Database.hs | 25 | ||||
-rw-r--r-- | libraries/ghc-boot/ghc-boot.cabal.in | 3 |
2 files changed, 28 insertions, 0 deletions
diff --git a/libraries/ghc-boot/GHC/Unit/Database.hs b/libraries/ghc-boot/GHC/Unit/Database.hs index cdef39e362..084ba226db 100644 --- a/libraries/ghc-boot/GHC/Unit/Database.hs +++ b/libraries/ghc-boot/GHC/Unit/Database.hs @@ -87,6 +87,10 @@ import Data.List (intersperse) import Control.Exception as Exception import Control.Monad (when) import System.FilePath as FilePath +#if !defined(mingw32_HOST_OS) +import System.Posix.Files +import GHC.IO.Exception (ioe_type, IOErrorType(NoSuchThing)) +#endif import System.IO import System.IO.Error import GHC.IO.Exception (IOErrorType(InappropriateType)) @@ -503,6 +507,26 @@ 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") @@ -510,6 +534,7 @@ writeFileAtomic targetPath content = do (\(tmpPath, handle) -> do BS.Lazy.hPut handle content hClose handle + set_metadata tmpPath renameFile tmpPath targetPath) instance Binary DbUnitInfo where diff --git a/libraries/ghc-boot/ghc-boot.cabal.in b/libraries/ghc-boot/ghc-boot.cabal.in index 8f62723d20..fa86241b62 100644 --- a/libraries/ghc-boot/ghc-boot.cabal.in +++ b/libraries/ghc-boot/ghc-boot.cabal.in @@ -74,3 +74,6 @@ Library filepath >= 1.3 && < 1.5, deepseq >= 1.4 && < 1.5, ghc-boot-th == @ProjectVersionMunged@ + if !os(windows) + build-depends: + unix >= 2.7 && < 2.8 |