Commit bc0e2a4c authored by Liyang HU's avatar Liyang HU
Browse files

PackageTests.DeterministicAr.Check: ensure metadata stays wiped

parent 831b3da7
......@@ -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"
......
{-# 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 = "!<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
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
module Lib where
dummy :: IO ()
dummy = return ()
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
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment