From 85ad9f848cdae7eab80c76a5ec2772d5f35d852b Mon Sep 17 00:00:00 2001
From: Johan Tibell <johan.tibell@gmail.com>
Date: Sat, 11 Aug 2012 09:37:16 -0700
Subject: [PATCH] Faster cabal update

Contributed by Hideyuki Tanaka.
---
 cabal-install/Distribution/Client/Update.hs |  8 +++---
 cabal-install/Distribution/Client/Utils.hs  | 30 ++++++++++++++++++---
 2 files changed, 31 insertions(+), 7 deletions(-)

diff --git a/cabal-install/Distribution/Client/Update.hs b/cabal-install/Distribution/Client/Update.hs
index 9b7d6981423..ff7b12f8547 100644
--- a/cabal-install/Distribution/Client/Update.hs
+++ b/cabal-install/Distribution/Client/Update.hs
@@ -21,6 +21,8 @@ import Distribution.Client.FetchUtils
 import qualified Distribution.Client.PackageIndex as PackageIndex
 import Distribution.Client.IndexUtils
          ( getSourcePackages, updateRepoIndexCache )
+import Distribution.Client.Utils
+         ( writeFileAtomic )
 import qualified Paths_cabal_install
          ( version )
 
@@ -29,12 +31,11 @@ import Distribution.Package
 import Distribution.Version
          ( anyVersion, withinRange )
 import Distribution.Simple.Utils
-         ( warn, notice, writeFileAtomic )
+         ( warn, notice )
 import Distribution.Verbosity
          ( Verbosity )
 
 import qualified Data.ByteString.Lazy       as BS
-import qualified Data.ByteString.Lazy.Char8 as BS.Char8
 import Distribution.Client.GZipUtils (maybeDecompress)
 import qualified Data.Map as Map
 import System.FilePath (dropExtension)
@@ -57,8 +58,7 @@ updateRepo verbosity repo = case repoKind repo of
     notice verbosity $ "Downloading the latest package list from "
                     ++ remoteRepoName remoteRepo
     indexPath <- downloadIndex verbosity remoteRepo (repoLocalDir repo)
-    writeFileAtomic (dropExtension indexPath) . BS.Char8.unpack
-                                              . maybeDecompress
+    writeFileAtomic (dropExtension indexPath) . maybeDecompress
                                             =<< BS.readFile indexPath
     updateRepoIndexCache verbosity repo
 
diff --git a/cabal-install/Distribution/Client/Utils.hs b/cabal-install/Distribution/Client/Utils.hs
index c685f80f069..710515b2c42 100644
--- a/cabal-install/Distribution/Client/Utils.hs
+++ b/cabal-install/Distribution/Client/Utils.hs
@@ -2,7 +2,8 @@
 
 module Distribution.Client.Utils ( MergeResult(..)
                                  , mergeBy, duplicates, duplicatesBy
-                                 , moreRecentFile, inDir, numberOfProcessors )
+                                 , moreRecentFile, inDir, numberOfProcessors
+                                 , writeFileAtomic )
        where
 
 import Data.List
@@ -10,10 +11,14 @@ import Data.List
 import Foreign.C.Types ( CInt(..) )
 import System.Directory
          ( doesFileExist, getModificationTime
-         , getCurrentDirectory, setCurrentDirectory )
+         , getCurrentDirectory, setCurrentDirectory
+         , renameFile, removeFile )
+import System.FilePath ( splitFileName, (<.>) )
+import System.IO ( openBinaryTempFile, hClose )
 import System.IO.Unsafe ( unsafePerformIO )
 import qualified Control.Exception as Exception
-         ( finally )
+         ( bracketOnError, finally )
+import qualified Data.ByteString.Lazy as BS
 
 -- | Generic merging utility. For sorted input lists this is a full outer join.
 --
@@ -72,3 +77,22 @@ foreign import ccall "getNumberOfProcessors" c_getNumberOfProcessors :: IO CInt
 -- program, so unsafePerformIO is safe here.
 numberOfProcessors :: Int
 numberOfProcessors = fromEnum $ unsafePerformIO c_getNumberOfProcessors
+
+-- | Writes a file atomically.
+--
+-- The file is either written sucessfully or an IO exception is raised and
+-- the original file is left unchanged.
+--
+-- On windows it is not possible to delete a file that is open by a process.
+-- This case will give an IO exception but the atomic property is not affected.
+--
+writeFileAtomic :: FilePath -> BS.ByteString -> IO ()
+writeFileAtomic targetPath content = do
+  let (targetDir, targetFile) = splitFileName targetPath
+  Exception.bracketOnError
+    (openBinaryTempFile targetDir $ targetFile <.> "tmp")
+    (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath)
+    (\(tmpPath, handle) -> do
+        BS.hPut handle content
+        hClose handle
+        renameFile tmpPath targetPath)