diff --git a/Cabal/Distribution/Compat/CopyFile.hs b/Cabal/Distribution/Compat/CopyFile.hs index c3b3b66ce73..bd7c9946c2d 100644 --- a/Cabal/Distribution/Compat/CopyFile.hs +++ b/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 diff --git a/Cabal/Distribution/Simple/GHC.hs b/Cabal/Distribution/Simple/GHC.hs index 3b710860a29..35ebb755fc2 100644 --- a/Cabal/Distribution/Simple/GHC.hs +++ b/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 diff --git a/Cabal/Distribution/Simple/LHC.hs b/Cabal/Distribution/Simple/LHC.hs index f3ac52930f0..ff84672f051 100644 --- a/Cabal/Distribution/Simple/LHC.hs +++ b/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 diff --git a/Cabal/Distribution/Simple/Program.hs b/Cabal/Distribution/Simple/Program.hs index e630cafc4af..c6691785e13 100644 --- a/Cabal/Distribution/Simple/Program.hs +++ b/Cabal/Distribution/Simple/Program.hs @@ -100,7 +100,6 @@ module Distribution.Simple.Program ( , ffihugsProgram , uhcProgram , gccProgram - , ranlibProgram , arProgram , stripProgram , happyProgram diff --git a/Cabal/Distribution/Simple/Program/Ar.hs b/Cabal/Distribution/Simple/Program/Ar.hs index ea68dbaa3d8..662ffd9b7d9 100644 --- a/Cabal/Distribution/Simple/Program/Ar.hs +++ b/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 = "!\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 diff --git a/Cabal/Distribution/Simple/Program/Builtin.hs b/Cabal/Distribution/Simple/Program/Builtin.hs index 6ad9322508d..f31b9d564a0 100644 --- a/Cabal/Distribution/Simple/Program/Builtin.hs +++ b/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" diff --git a/Cabal/tests/PackageTests.hs b/Cabal/tests/PackageTests.hs index d515c4ed5d9..02ff82e6a14 100644 --- a/Cabal/tests/PackageTests.hs +++ b/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" diff --git a/Cabal/tests/PackageTests/DeterministicAr/Check.hs b/Cabal/tests/PackageTests/DeterministicAr/Check.hs new file mode 100644 index 00000000000..c8a30db82cf --- /dev/null +++ b/Cabal/tests/PackageTests/DeterministicAr/Check.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE OverloadedStrings #-} + +module PackageTests.DeterministicAr.Check where + +import Control.Monad +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import Data.Char (isSpace) +import Data.List +import Data.Traversable +import PackageTests.PackageTester +import System.Exit +import System.FilePath +import System.IO +import Test.HUnit (Assertion, Test (TestCase), assertFailure) + +-- Perhaps these should live in PackageTester. + +-- For a polymorphic @IO a@ rather than @Assertion = IO ()@. +assertFailure' :: String -> IO a +assertFailure' msg = assertFailure msg >> return {-unpossible!-}undefined + +ghcPkg_field :: String -> String -> FilePath -> IO [FilePath] +ghcPkg_field libraryName fieldName ghcPkgPath = do + (cmd, exitCode, raw) <- run Nothing ghcPkgPath + ["--user", "field", libraryName, fieldName] + let output = filter ('\r' /=) raw -- Windows + -- copypasta of PackageTester.requireSuccess + unless (exitCode == ExitSuccess) . assertFailure $ + "Command " ++ cmd ++ " failed.\n" ++ "output: " ++ output + + let prefix = fieldName ++ ": " + case traverse (stripPrefix prefix) (lines output) of + Nothing -> assertFailure' $ "Command " ++ cmd ++ " failed: expected " + ++ show prefix ++ " prefix on every line.\noutput: " ++ output + Just fields -> return fields + +ghcPkg_field1 :: String -> String -> FilePath -> IO FilePath +ghcPkg_field1 libraryName fieldName ghcPkgPath = do + fields <- ghcPkg_field libraryName fieldName ghcPkgPath + case fields of + [field] -> return field + _ -> assertFailure' $ "Command ghc-pkg field failed: " + ++ "output not a single line.\noutput: " ++ show fields + +------------------------------------------------------------------------ + +this :: String +this = "DeterministicAr" + +suite :: FilePath -> FilePath -> Test +suite ghcPath ghcPkgPath = TestCase $ do + let dir = "PackageTests" this + let spec = PackageSpec dir [] + + unregister this ghcPkgPath + iResult <- cabal_install spec ghcPath + assertInstallSucceeded iResult + + let distBuild = dir "dist" "build" + libdir <- ghcPkg_field1 this "library-dirs" ghcPkgPath + mapM_ checkMetadata [distBuild, libdir] + unregister this ghcPkgPath + +-- Almost a copypasta of Distribution.Simple.Program.Ar.wipeMetadata +checkMetadata :: FilePath -> Assertion +checkMetadata dir = withBinaryFile path ReadMode $ \ h -> do + hFileSize h >>= checkArchive h + where + path = dir "libHS" ++ this ++ "-0.a" + + checkError msg = assertFailure' $ + "PackageTests.DeterministicAr.checkMetadata: " ++ msg ++ + " in " ++ path + archLF = "!\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 + checkArchive :: Handle -> Integer -> IO () + checkArchive h archiveSize = do + global <- BS.hGet h (BS.length archLF) + unless (global == archLF) $ checkError "Bad global header" + checkHeader (toInteger $ BS.length archLF) + + where + checkHeader :: Integer -> IO () + checkHeader offset = case compare offset archiveSize of + EQ -> return () + GT -> checkError (atOffset "Archive truncated") + LT -> do + header <- BS.hGet h headerSize + unless (BS.length header == headerSize) $ + checkError (atOffset "Short header") + let magic = BS.drop 58 header + unless (magic == x60LF) . checkError . atOffset $ + "Bad magic " ++ show magic ++ " in header" + + unless (metadata == BS.take 32 (BS.drop 16 header)) + . checkError . atOffset $ "Metadata has changed" + + let size = BS.take 10 $ BS.drop 48 header + objSize <- case reads (BS8.unpack size) of + [(n, s)] | all isSpace s -> return n + _ -> checkError (atOffset "Bad file size in header") + + 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 + checkHeader nextHeader + + where + atOffset msg = msg ++ " at offset " ++ show offset + diff --git a/Cabal/tests/PackageTests/DeterministicAr/Lib.hs b/Cabal/tests/PackageTests/DeterministicAr/Lib.hs new file mode 100644 index 00000000000..f927d0c0510 --- /dev/null +++ b/Cabal/tests/PackageTests/DeterministicAr/Lib.hs @@ -0,0 +1,5 @@ +module Lib where + +dummy :: IO () +dummy = return () + diff --git a/Cabal/tests/PackageTests/DeterministicAr/my.cabal b/Cabal/tests/PackageTests/DeterministicAr/my.cabal new file mode 100644 index 00000000000..18bff0e3ff8 --- /dev/null +++ b/Cabal/tests/PackageTests/DeterministicAr/my.cabal @@ -0,0 +1,17 @@ +name: DeterministicAr +version: 0 +license: BSD3 +cabal-version: >= 1.9.1 +author: Liyang HU +stability: stable +category: PackageTests +build-type: Simple + +description: + Ensure our GNU ar -D emulation (#1537) works as advertised: check that + all metadata in the resulting .a archive match the default. + +Library + exposed-modules: Lib + build-depends: base +