CheckArMetadata.hs

----------------------------------------------------------------------------
-- |
-- Module      :  Test.Cabal.CheckArMetadata
-- Created     :   8 July 2017
--
-- Check well-formedness of metadata of .a files that @ar@ command produces.
-- One of the crucial properties of .a files is that they must be
-- deterministic - i.e. they must not include creation date as their
-- contents to facilitate deterministic builds.
----------------------------------------------------------------------------

{-# LANGUAGE OverloadedStrings #-}

module Test.Cabal.CheckArMetadata (checkMetadata) where

import Test.Cabal.Prelude

import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import Data.Char (isSpace)
import System.IO

import Distribution.Package               (getHSLibraryName)
import Distribution.Simple.LocalBuildInfo (LocalBuildInfo, localUnitId)

-- Almost a copypasta of Distribution.Simple.Program.Ar.wipeMetadata
checkMetadata :: LocalBuildInfo -> FilePath -> IO ()
checkMetadata lbi dir = withBinaryFile path ReadMode $ \ h ->
  hFileSize h >>= checkArchive h
  where
    path = dir </> "lib" ++ getHSLibraryName (localUnitId lbi) ++ ".a"

    checkError msg = assertFailure (
        "PackageTests.DeterministicAr.checkMetadata: " ++ msg ++
        " in " ++ path) >> undefined
    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