cabal-testsuite/src/Test/Cabal/CheckArMetadata.hs

   1 ----------------------------------------------------------------------------
   2 -- |
   3 -- Module      :  Test.Cabal.CheckArMetadata
   4 -- Created     :   8 July 2017
   5 --
   6 -- Check well-formedness of metadata of .a files that @ar@ command produces.
   7 -- One of the crucial properties of .a files is that they must be
   8 -- deterministic - i.e. they must not include creation date as their
   9 -- contents to facilitate deterministic builds.
  10 ----------------------------------------------------------------------------
  11
  12 {-# LANGUAGE OverloadedStrings #-}
  13
  14 module Test.Cabal.CheckArMetadata (checkMetadata) where
  15
  16 import Test.Cabal.Prelude
  17
  18 import qualified Data.ByteString as BS
  19 import qualified Data.ByteString.Char8 as BS8
  20 import Data.Char (isSpace)
  21 import System.IO
  22
  23 import Distribution.Package               (getHSLibraryName)
  24 import Distribution.Simple.LocalBuildInfo (LocalBuildInfo, localUnitId)
  25
  26 -- Almost a copypasta of Distribution.Simple.Program.Ar.wipeMetadata
  27 checkMetadata :: LocalBuildInfo -> FilePath -> IO ()
  28 checkMetadata lbi dir = withBinaryFile path ReadMode $ \ h ->
  29   hFileSize h >>= checkArchive h
  30   where
  31     path = dir </> "lib" ++ getHSLibraryName (localUnitId lbi) ++ ".a"
  32
  33     checkError msg = assertFailure (
  34         "PackageTests.DeterministicAr.checkMetadata: " ++ msg ++
  35         " in " ++ path) >> undefined
  36     archLF = "!<arch>\x0a" -- global magic, 8 bytes
  37     x60LF = "\x60\x0a" -- header magic, 2 bytes
  38     metadata = BS.concat
  39         [ "0           " -- mtime, 12 bytes
  40         , "0     " -- UID, 6 bytes
  41         , "0     " -- GID, 6 bytes
  42         , "0644    " -- mode, 8 bytes
  43         ]
  44     headerSize = 60
  45
  46     -- http://en.wikipedia.org/wiki/Ar_(Unix)#File_format_details
  47     checkArchive :: Handle -> Integer -> IO ()
  48     checkArchive h archiveSize = do
  49         global <- BS.hGet h (BS.length archLF)
  50         unless (global == archLF) $ checkError "Bad global header"
  51         checkHeader (toInteger $ BS.length archLF)
  52
  53       where
  54         checkHeader :: Integer -> IO ()
  55         checkHeader offset = case compare offset archiveSize of
  56             EQ -> return ()
  57             GT -> checkError (atOffset "Archive truncated")
  58             LT -> do
  59                 header <- BS.hGet h headerSize
  60                 unless (BS.length header == headerSize) $
  61                     checkError (atOffset "Short header")
  62                 let magic = BS.drop 58 header
  63                 unless (magic == x60LF) . checkError . atOffset $
  64                     "Bad magic " ++ show magic ++ " in header"
  65
  66                 unless (metadata == BS.take 32 (BS.drop 16 header))
  67                     . checkError . atOffset $ "Metadata has changed"
  68
  69                 let size = BS.take 10 $ BS.drop 48 header
  70                 objSize <- case reads (BS8.unpack size) of
  71                     [(n, s)] | all isSpace s -> return n
  72                     _ -> checkError (atOffset "Bad file size in header")
  73
  74                 let nextHeader = offset + toInteger headerSize +
  75                         -- Odd objects are padded with an extra '\x0a'
  76                         if odd objSize then objSize + 1 else objSize
  77                 hSeek h AbsoluteSeek nextHeader
  78                 checkHeader nextHeader
  79
  80           where
  81             atOffset msg = msg ++ " at offset " ++ show offset