[commit: Cabal] master: Decompress the repo index atomically. (08bd3b0)

[Ian Lynagh]

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

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/08bd3b0479856933019462858be1690ac0267405

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

commit 08bd3b0479856933019462858be1690ac0267405
Author: Duncan Coutts <duncan at haskell.org>
Date:   Fri Aug 22 23:00:33 2008 +0000

    Decompress the repo index atomically.
    So if decompression fails (eg if the index is corrupt) then
    the decompressed file does not get (partially) written.

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

 cabal-install/Distribution/Client/Update.hs |    8 ++++++--
 cabal-install/Distribution/Client/Utils.hs  |   26 ++++++++++++++++++++++++++
 2 files changed, 32 insertions(+), 2 deletions(-)

diff --git a/cabal-install/Distribution/Client/Update.hs b/cabal-install/Distribution/Client/Update.hs
index cf8a1d9..1c42661 100644
--- a/cabal-install/Distribution/Client/Update.hs
+++ b/cabal-install/Distribution/Client/Update.hs
@@ -15,7 +15,11 @@ module Distribution.Client.Update
     ) where
 
 import Distribution.Client.Types
+         ( Repo(..), RemoteRepo(..), LocalRepo(..) )
 import Distribution.Client.Fetch
+         ( downloadIndex )
+import qualified Distribution.Client.Utils as BS
+         ( writeFileAtomic )
 
 import Distribution.Simple.Utils (notice)
 import Distribution.Verbosity (Verbosity)
@@ -35,5 +39,5 @@ updateRepo verbosity repo = case repoKind repo of
     notice verbosity $ "Downloading package list from server '"
                     ++ show (remoteRepoURI remoteRepo) ++ "'"
     indexPath <- downloadIndex verbosity remoteRepo (repoLocalDir repo)
-    BS.writeFile (dropExtension indexPath) . GZip.decompress
-                                         =<< BS.readFile indexPath
+    BS.writeFileAtomic (dropExtension indexPath) . GZip.decompress
+                                               =<< BS.readFile indexPath
diff --git a/cabal-install/Distribution/Client/Utils.hs b/cabal-install/Distribution/Client/Utils.hs
index 3094f9b..30c68bf 100644
--- a/cabal-install/Distribution/Client/Utils.hs
+++ b/cabal-install/Distribution/Client/Utils.hs
@@ -2,6 +2,15 @@ module Distribution.Client.Utils where
 
 import Data.List
          ( sortBy, groupBy )
+import qualified Data.ByteString.Lazy as BS
+import System.FilePath
+         ( (<.>), splitFileName )
+import System.IO
+         ( openBinaryTempFile, hClose )
+import System.Directory
+         ( removeFile, renameFile )
+import qualified Control.Exception as Exception
+         ( handle, throwIO )
 
 -- | Generic merging utility. For sorted input lists this is a full outer join.
 --
@@ -31,3 +40,20 @@ duplicatesBy cmp = filter moreThanOne . groupBy eq . sortBy cmp
                _  -> False
     moreThanOne (_:_:_) = True
     moreThanOne _       = False
+
+writeFileAtomic :: FilePath -> BS.ByteString -> IO ()
+writeFileAtomic targetFile content = do
+  (tmpFile, tmpHandle) <- openBinaryTempFile targetDir template
+  Exception.handle (\err -> do hClose tmpHandle
+                               removeFile tmpFile
+                               Exception.throwIO err) $ do
+      BS.hPut tmpHandle content
+      hClose tmpHandle
+      renameFile tmpFile targetFile
+  where
+    template = targetName <.> "tmp"
+    targetDir | null targetDir_ = "."
+              | otherwise       = targetDir_
+    --TODO: remove this when takeDirectory/splitFileName is fixed
+    --      to always return a valid dir
+    (targetDir_,targetName) = splitFileName targetFile