Emulate GNU ar's deterministic mode

Cabal/Distribution/Compat/CopyFile.hs

@@ -2,6 +2,7 @@
 {-# OPTIONS_HADDOCK hide #-}
 module Distribution.Compat.CopyFile (
   copyFile,
+  filesEqual,
   copyOrdinaryFile,
   copyExecutableFile,
   setFileOrdinary,
@@ -10,10 +11,13 @@ module Distribution.Compat.CopyFile (
   ) where
 
 
+import Control.Applicative
+         ( (<$>), (<*>) )
 import Control.Monad
          ( when )
 import Control.Exception
-         ( bracket, bracketOnError, throwIO )
+         ( bracket, bracketOnError, evaluate, throwIO )
+import qualified Data.ByteString.Lazy as BSL
 import Distribution.Compat.Exception
          ( catchIO )
 import System.IO.Error
@@ -25,7 +29,8 @@ import Distribution.Compat.TempFile
 import System.FilePath
          ( takeDirectory )
 import System.IO
-         ( openBinaryFile, IOMode(ReadMode), hClose, hGetBuf, hPutBuf )
+         ( openBinaryFile, IOMode(ReadMode), hClose, hGetBuf, hPutBuf
+         , withBinaryFile )
 import Foreign
          ( allocaBytes )
 
@@ -79,3 +84,11 @@ copyFile fromFPath toFPath =
                   when (count > 0) $ do
                           hPutBuf hTo buffer count
                           copyContents hFrom hTo buffer
+
+-- | Checks if two files are byte-identical.
+-- Returns False if either of the files do not exist.
+filesEqual :: FilePath -> FilePath -> IO Bool
+filesEqual f1 f2 = (`catchIO` \ _ -> return False) $ do
+  withBinaryFile f1 ReadMode $ \ h1 -> do
+  withBinaryFile f2 ReadMode $ \ h2 -> do
+  evaluate =<< (==) <$> BSL.hGetContents h1 <*> BSL.hGetContents h2

Cabal/Distribution/Simple/GHC.hs

@@ -105,7 +105,7 @@ import Distribution.Simple.Program
          , requireProgramVersion, requireProgram
          , userMaybeSpecifyPath, programPath, lookupProgram, addKnownProgram
          , ghcProgram, ghcPkgProgram, hsc2hsProgram
-         , arProgram, ranlibProgram, ldProgram
+         , arProgram, ldProgram
          , gccProgram, stripProgram )
 import qualified Distribution.Simple.Program.HcPkg as HcPkg
 import qualified Distribution.Simple.Program.Ar    as Ar
@@ -136,8 +136,7 @@ import qualified Data.Map as M  ( Map, fromList, lookup )
 import Data.Maybe               ( catMaybes, fromMaybe, maybeToList )
 import Data.Monoid              ( Monoid(..) )
 import System.Directory
-         ( removeFile, getDirectoryContents, doesFileExist
-         , getTemporaryDirectory )
+         ( getDirectoryContents, doesFileExist, getTemporaryDirectory )
 import System.FilePath          ( (</>), (<.>), takeExtension,
                                   takeDirectory, replaceExtension,
                                   splitExtension )
@@ -861,11 +860,6 @@ buildOrReplLib forRepl verbosity numJobsFlag pkg_descr lbi lib clbi = do
             else return []
 
   unless (null hObjs && null cObjs && null stubObjs) $ do
-    -- first remove library files if they exists
-    unless forRepl $ sequence_
-      [ removeFile libFilePath `catchIO` \_ -> return ()
-      | libFilePath <- [vanillaLibFilePath, profileLibFilePath
-                       ,sharedLibFilePath,  ghciLibFilePath] ]
 
     let staticObjectFiles =
                hObjs
@@ -1310,12 +1304,6 @@ installLib verbosity lbi targetDir dynlibTargetDir builtDir _pkg lib clbi = do
   whenGHCi    $ mapM_ (copy builtDir targetDir)             ghciLibNames
   whenShared  $ mapM_ (copyShared builtDir dynlibTargetDir) sharedLibNames
 
-  -- run ranlib if necessary:
-  whenVanilla $ mapM_ (updateLibArchive verbosity lbi . (targetDir </>))
-                      vanillaLibNames
-  whenProf    $ mapM_ (updateLibArchive verbosity lbi . (targetDir </>))
-                      profileLibNames
-
   where
     cid = compilerId (compiler lbi)
     libNames = componentLibraries clbi
@@ -1331,18 +1319,6 @@ installLib verbosity lbi targetDir dynlibTargetDir builtDir _pkg lib clbi = do
     whenGHCi    = when (hasLib && withGHCiLib    lbi)
     whenShared  = when (hasLib && withSharedLib  lbi)
 
--- | On MacOS X we have to call @ranlib@ to regenerate the archive index after
--- copying. This is because the silly MacOS X linker checks that the archive
--- index is not older than the file itself, which means simply
--- copying/installing the file breaks it!!
---
-updateLibArchive :: Verbosity -> LocalBuildInfo -> FilePath -> IO ()
-updateLibArchive verbosity lbi path
-  | buildOS == OSX = do
-    (ranlib, _) <- requireProgram verbosity ranlibProgram (withPrograms lbi)
-    rawSystemProgram verbosity ranlib [path]
-  | otherwise = return ()
-
 -- -----------------------------------------------------------------------------
 -- Registering
 

Cabal/Distribution/Simple/LHC.hs

@@ -96,7 +96,7 @@ import Distribution.Simple.Program
          , rawSystemProgramStdout, rawSystemProgramStdoutConf
          , requireProgramVersion
          , userMaybeSpecifyPath, programPath, lookupProgram, addKnownProgram
-         , arProgram, ranlibProgram, ldProgram
+         , arProgram, ldProgram
          , gccProgram, stripProgram
          , lhcProgram, lhcPkgProgram )
 import qualified Distribution.Simple.Program.HcPkg as HcPkg
@@ -783,12 +783,6 @@ installLib verbosity lbi targetDir dynlibTargetDir builtDir _pkg lib clbi = do
   ifGHCi    $ mapM_ (copy builtDir targetDir)       ghciLibNames
   ifShared  $ mapM_ (copy builtDir dynlibTargetDir) sharedLibNames
 
-  -- run ranlib if necessary:
-  ifVanilla $ mapM_ (updateLibArchive verbosity lbi . (targetDir </>))
-                    vanillaLibNames
-  ifProf    $ mapM_ (updateLibArchive verbosity lbi . (targetDir </>))
-                    profileLibNames
-
   where
     cid = compilerId (compiler lbi)
     libNames = componentLibraries clbi
@@ -806,20 +800,6 @@ installLib verbosity lbi targetDir dynlibTargetDir builtDir _pkg lib clbi = do
 
     runLhc    = rawSystemProgramConf verbosity lhcProgram (withPrograms lbi)
 
--- | use @ranlib@ or @ar -s@ to build an index. This is necessary on systems
--- like MacOS X. If we can't find those, don't worry too much about it.
---
-updateLibArchive :: Verbosity -> LocalBuildInfo -> FilePath -> IO ()
-updateLibArchive verbosity lbi path =
-  case lookupProgram ranlibProgram (withPrograms lbi) of
-    Just ranlib -> rawSystemProgram verbosity ranlib [path]
-    Nothing     -> case lookupProgram arProgram (withPrograms lbi) of
-      Just ar   -> rawSystemProgram verbosity ar ["-s", path]
-      Nothing   -> warn verbosity $
-                        "Unable to generate a symbol index for the static "
-                     ++ "library '" ++ path
-                     ++ "' (missing the 'ranlib' and 'ar' programs)"
-
 -- -----------------------------------------------------------------------------
 -- Registering
 

Cabal/Distribution/Simple/Program.hs

@@ -100,7 +100,6 @@ module Distribution.Simple.Program (
     , ffihugsProgram
     , uhcProgram
     , gccProgram
-    , ranlibProgram
     , arProgram
     , stripProgram
     , happyProgram

Cabal/Distribution/Simple/Program/Ar.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Distribution.Simple.Program.Ar
@@ -13,21 +15,37 @@ module Distribution.Simple.Program.Ar (
     multiStageProgramInvocation,
   ) where
 
+import Control.Monad (unless)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as BS8
+import Data.Char (isSpace)
+import Distribution.Compat.CopyFile (filesEqual)
 import Distribution.Simple.Program.Types
          ( ConfiguredProgram(..) )
 import Distribution.Simple.Program.Run
          ( programInvocation, multiStageProgramInvocation
          , runProgramInvocation )
+import Distribution.Simple.Utils
+         ( dieWithLocation, withTempDirectory )
 import Distribution.System
          ( OS(..), buildOS )
 import Distribution.Verbosity
          ( Verbosity, deafening, verbose )
+import System.Directory (doesFileExist, renameFile)
+import System.FilePath ((</>), splitFileName)
+import System.IO
+         ( Handle, IOMode(ReadWriteMode), SeekMode(AbsoluteSeek)
+         , hFileSize, hSeek, withBinaryFile )
 
 -- | Call @ar@ to create a library archive from a bunch of object files.
 --
 createArLibArchive :: Verbosity -> ConfiguredProgram
                    -> FilePath -> [FilePath] -> IO ()
-createArLibArchive verbosity ar target files =
+createArLibArchive verbosity ar targetPath files = do
+
+  let (targetDir, targetName) = splitFileName targetPath
+  withTempDirectory verbosity targetDir targetName $ \ tmpDir -> do
+  let tmpPath = tmpDir </> targetName
 
   -- The args to use with "ar" are actually rather subtle and system-dependent.
   -- In particular we have the following issues:
@@ -52,19 +70,90 @@ createArLibArchive verbosity ar target files =
              OSX -> ["-q", "-s"]
              _   -> ["-q"]
 
-      extraArgs   = verbosityOpts verbosity ++ [target]
+      extraArgs   = verbosityOpts verbosity ++ [tmpPath]
 
       simple  = programInvocation ar (simpleArgs  ++ extraArgs)
       initial = programInvocation ar (initialArgs ++ extraArgs)
       middle  = initial
       final   = programInvocation ar (finalArgs   ++ extraArgs)
 
-   in sequence_
+  sequence_
         [ runProgramInvocation verbosity inv
         | inv <- multiStageProgramInvocation
                    simple (initial, middle, final) files ]
 
+  wipeMetadata tmpPath
+  equal <- filesEqual tmpPath targetPath
+  unless equal $ renameFile tmpPath targetPath
+
   where
     verbosityOpts v | v >= deafening = ["-v"]
                     | v >= verbose   = []
                     | otherwise      = ["-c"]
+
+-- | @ar@ by default includes various metadata for each object file in their
+-- respective headers, so the output can differ for the same inputs, making
+-- it difficult to avoid re-linking. GNU @ar@(1) has a deterministic mode
+-- (@-D@) flag that always writes zero for the mtime, UID and GID, and 0644
+-- for the file mode. However detecting whether @-D@ is supported seems
+-- rather harder than just re-implementing this feature.
+wipeMetadata :: FilePath -> IO ()
+wipeMetadata path = do
+    -- Check for existence first (ReadWriteMode would create one otherwise)
+    exists <- doesFileExist path
+    unless exists $ wipeError "Temporary file disappeared"
+    withBinaryFile path ReadWriteMode $ \ h -> hFileSize h >>= wipeArchive h
+
+  where
+    wipeError msg = dieWithLocation path Nothing $
+        "Distribution.Simple.Program.Ar.wipeMetadata: " ++ msg
+    archLF = "!<arch>\x0a" -- global magic, 8 bytes
+    x60LF = "\x60\x0a" -- header magic, 2 bytes
+    metadata = BS.concat
+        [ "0           " -- mtime, 12 bytes
+        , "0     " -- UID, 6 bytes
+        , "0     " -- GID, 6 bytes
+        , "0644    " -- mode, 8 bytes
+        ]
+    headerSize = 60
+
+    -- http://en.wikipedia.org/wiki/Ar_(Unix)#File_format_details
+    wipeArchive :: Handle -> Integer -> IO ()
+    wipeArchive h archiveSize = do
+        global <- BS.hGet h (BS.length archLF)
+        unless (global == archLF) $ wipeError "Bad global header"
+        wipeHeader (toInteger $ BS.length archLF)
+
+      where
+        wipeHeader :: Integer -> IO ()
+        wipeHeader offset = case compare offset archiveSize of
+            EQ -> return ()
+            GT -> wipeError (atOffset "Archive truncated")
+            LT -> do
+                header <- BS.hGet h headerSize
+                unless (BS.length header == headerSize) $
+                    wipeError (atOffset "Short header")
+                let magic = BS.drop 58 header
+                unless (magic == x60LF) . wipeError . atOffset $
+                    "Bad magic " ++ show magic ++ " in header"
+
+                let name = BS.take 16 header
+                let size = BS.take 10 $ BS.drop 48 header
+                objSize <- case reads (BS8.unpack size) of
+                    [(n, s)] | all isSpace s -> return n
+                    _ -> wipeError (atOffset "Bad file size in header")
+
+                let replacement = BS.concat [ name, metadata, size, magic ]
+                unless (BS.length replacement == headerSize) $
+                    wipeError (atOffset "Something has gone terribly wrong")
+                hSeek h AbsoluteSeek offset
+                BS.hPut h replacement
+
+                let nextHeader = offset + toInteger headerSize +
+                        -- Odd objects are padded with an extra '\x0a'
+                        if odd objSize then objSize + 1 else objSize
+                hSeek h AbsoluteSeek nextHeader
+                wipeHeader nextHeader
+
+          where
+            atOffset msg = msg ++ " at offset " ++ show offset

Cabal/Distribution/Simple/Program/Builtin.hs

@@ -29,7 +29,6 @@ module Distribution.Simple.Program.Builtin (
     haskellSuitePkgProgram,
     uhcProgram,
     gccProgram,
-    ranlibProgram,
     arProgram,
     stripProgram,
     happyProgram,
@@ -88,7 +87,6 @@ builtinPrograms =
     , greencardProgram
     -- platform toolchain
     , gccProgram
-    , ranlibProgram
     , arProgram
     , stripProgram
     , ldProgram
@@ -237,9 +235,6 @@ gccProgram = (simpleProgram "gcc") {
     programFindVersion = findProgramVersion "-dumpversion" id
   }
 
-ranlibProgram :: Program
-ranlibProgram = simpleProgram "ranlib"
-
 arProgram :: Program
 arProgram = simpleProgram "ar"
 

Cabal/tests/PackageTests.hs

@@ -42,6 +42,7 @@ import PackageTests.PathsModule.Library.Check
 import PackageTests.PreProcess.Check
 import PackageTests.TemplateHaskell.Check
 import PackageTests.CMain.Check
+import PackageTests.DeterministicAr.Check
 import PackageTests.EmptyLib.Check
 import PackageTests.TestOptions.Check
 import PackageTests.TestStanza.Check
@@ -86,6 +87,8 @@ tests version inplaceSpec ghcPath ghcPkgPath =
     , hunit "PathsModule/Executable"
       (PackageTests.PathsModule.Executable.Check.suite ghcPath)
     , hunit "PathsModule/Library" (PackageTests.PathsModule.Library.Check.suite ghcPath)
+    , hunit "DeterministicAr"
+        (PackageTests.DeterministicAr.Check.suite ghcPath ghcPkgPath)
     , hunit "EmptyLib/emptyLib"
       (PackageTests.EmptyLib.Check.emptyLib ghcPath)
     , hunit "BuildTestSuiteDetailedV09"