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.Compiler (arResponseFilesSupported)
import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..))
import Distribution.Simple.Program
( ProgramInvocation, arProgram, requireProgram )
import Distribution.Simple.Program.ResponseFile
( withResponseFile )
import Distribution.Simple.Program.Run
( programInvocation, multiStageProgramInvocation
, runProgramInvocation )
import Distribution.Simple.Setup
( fromFlagOrDefault, configUseResponseFiles )
import Distribution.Simple.Utils
( defaultTempFileOptions, 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 )
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
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)
oldVersionManualOverride =
fromFlagOrDefault False $ configUseResponseFiles $ configFlags lbi
responseArgumentsNotSupported =
not (arResponseFilesSupported (compiler lbi))
invokeWithResponesFile :: FilePath -> ProgramInvocation
invokeWithResponesFile atFile =
programInvocation ar $
simpleArgs ++ extraArgs ++ ['@' : atFile]
if oldVersionManualOverride || responseArgumentsNotSupported
then
sequence_
[ runProgramInvocation verbosity inv
| inv <- multiStageProgramInvocation
simple (initial, middle, final) files ]
else
withResponseFile verbosity defaultTempFileOptions tmpDir "ar.rsp" Nothing files $
\path -> runProgramInvocation verbosity $ invokeWithResponesFile path
unless (hostArch == Arm
|| hostOS == AIX) $
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"]
wipeMetadata :: Verbosity -> FilePath -> IO ()
wipeMetadata verbosity path = do
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"
x60LF = "\x60\x0a"
metadata = BS.concat
[ "0 "
, "0 "
, "0 "
, "0644 "
]
headerSize :: Int
headerSize = 60
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 +
if odd objSize then objSize + 1 else objSize
hSeek h AbsoluteSeek nextHeader
wipeHeader nextHeader
where
atOffset msg = msg ++ " at offset " ++ show offset