Cabal-2.0.0.2: Distribution/Simple/Program/Ar.hs
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE NondecreasingIndentation #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Simple.Program.Ar
-- Copyright : Duncan Coutts 2009
--
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
--
-- This module provides an library interface to the @ar@ program.
module Distribution.Simple.Program.Ar (
createArLibArchive,
multiStageProgramInvocation
) where
import Prelude ()
import Distribution.Compat.Prelude
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import Distribution.Compat.CopyFile (filesEqual)
import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..))
import Distribution.Simple.Program
( arProgram, requireProgram )
import Distribution.Simple.Program.Run
( programInvocation, multiStageProgramInvocation
, runProgramInvocation )
import Distribution.Simple.Utils
( dieWithLocation', withTempDirectory )
import Distribution.System
( Arch(..), OS(..), Platform(..) )
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 -> LocalBuildInfo
-> FilePath -> [FilePath] -> IO ()
createArLibArchive verbosity lbi targetPath files = do
(ar, _) <- requireProgram verbosity arProgram progDb
let (targetDir, targetName) = splitFileName targetPath
withTempDirectory verbosity targetDir "objs" $ \ 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:
--
-- -- On OS X, "ar q" does not make an archive index. Archives with no
-- index cannot be used.
--
-- -- GNU "ar r" will not let us add duplicate objects, only "ar q" lets us
-- do that. We have duplicates because of modules like "A.M" and "B.M"
-- both make an object file "M.o" and ar does not consider the directory.
--
-- Our solution is to use "ar r" in the simple case when one call is enough.
-- When we need to call ar multiple times we use "ar q" and for the last
-- call on OSX we use "ar qs" so that it'll make the index.
let simpleArgs = case hostOS of
OSX -> ["-r", "-s"]
_ -> ["-r"]
initialArgs = ["-q"]
finalArgs = case hostOS of
OSX -> ["-q", "-s"]
_ -> ["-q"]
extraArgs = verbosityOpts verbosity ++ [tmpPath]
simple = programInvocation ar (simpleArgs ++ extraArgs)
initial = programInvocation ar (initialArgs ++ extraArgs)
middle = initial
final = programInvocation ar (finalArgs ++ extraArgs)
sequence_
[ runProgramInvocation verbosity inv
| inv <- multiStageProgramInvocation
simple (initial, middle, final) files ]
unless (hostArch == Arm -- See #1537
|| hostOS == AIX) $ -- AIX uses its own "ar" format variant
wipeMetadata verbosity tmpPath
equal <- filesEqual tmpPath targetPath
unless equal $ renameFile tmpPath targetPath
where
progDb = withPrograms lbi
Platform hostArch hostOS = hostPlatform lbi
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 :: Verbosity -> FilePath -> IO ()
wipeMetadata verbosity 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' verbosity 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 :: Int
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