{-# 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.Compiler (arResponseFilesSupported, arDashLSupported)
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 )

-- | Call @ar@ to create a library archive from a bunch of object files.
--
createArLibArchive :: Verbosity -> LocalBuildInfo
                   -> FilePath -> [FilePath] -> IO ()
createArLibArchive :: Verbosity -> LocalBuildInfo -> FilePath -> [FilePath] -> IO ()
createArLibArchive Verbosity
verbosity LocalBuildInfo
lbi FilePath
targetPath [FilePath]
files = do
  (ConfiguredProgram
ar, ProgramDb
_) <- Verbosity
-> Program -> ProgramDb -> IO (ConfiguredProgram, ProgramDb)
requireProgram Verbosity
verbosity Program
arProgram ProgramDb
progDb

  let (FilePath
targetDir, FilePath
targetName) = FilePath -> (FilePath, FilePath)
splitFileName FilePath
targetPath
  Verbosity -> FilePath -> FilePath -> (FilePath -> IO ()) -> IO ()
forall a.
Verbosity -> FilePath -> FilePath -> (FilePath -> IO a) -> IO a
withTempDirectory Verbosity
verbosity FilePath
targetDir FilePath
"objs" ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ FilePath
tmpDir -> do
  let tmpPath :: FilePath
tmpPath = FilePath
tmpDir FilePath -> FilePath -> FilePath
</> FilePath
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.
  --
  --  -- llvm-ar, which GHC >=9.4 uses on Windows, supports a "L" modifier
  --     in "q" mode which compels the archiver to add the members of an input
  --     archive to the output, rather than the archive itself. This is
  --     necessary as GHC may produce .o files that are actually archives. See
  --     https://gitlab.haskell.org/ghc/ghc/-/issues/21068.
  --
  -- 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 :: [FilePath]
simpleArgs  = case OS
hostOS of
             OS
OSX -> [FilePath
"-r", FilePath
"-s"]
             OS
_ | Bool
dashLSupported -> [FilePath
"-qL"]
             OS
_   -> [FilePath
"-r"]

      initialArgs :: [FilePath]
initialArgs = [FilePath
"-q"]
      finalArgs :: [FilePath]
finalArgs   = case OS
hostOS of
             OS
OSX -> [FilePath
"-q", FilePath
"-s"]
             OS
_ | Bool
dashLSupported -> [FilePath
"-qL"]
             OS
_   -> [FilePath
"-q"]

      extraArgs :: [FilePath]
extraArgs   = Verbosity -> [FilePath]
forall a. IsString a => Verbosity -> [a]
verbosityOpts Verbosity
verbosity [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
tmpPath]

      simple :: ProgramInvocation
simple  = ConfiguredProgram -> [FilePath] -> ProgramInvocation
programInvocation ConfiguredProgram
ar ([FilePath]
simpleArgs  [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
extraArgs)
      initial :: ProgramInvocation
initial = ConfiguredProgram -> [FilePath] -> ProgramInvocation
programInvocation ConfiguredProgram
ar ([FilePath]
initialArgs [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
extraArgs)
      middle :: ProgramInvocation
middle  = ProgramInvocation
initial
      final :: ProgramInvocation
final   = ConfiguredProgram -> [FilePath] -> ProgramInvocation
programInvocation ConfiguredProgram
ar ([FilePath]
finalArgs   [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
extraArgs)

      oldVersionManualOverride :: Bool
oldVersionManualOverride =
        Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (Flag Bool -> Bool) -> Flag Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ConfigFlags -> Flag Bool
configUseResponseFiles (ConfigFlags -> Flag Bool) -> ConfigFlags -> Flag Bool
forall a b. (a -> b) -> a -> b
$ LocalBuildInfo -> ConfigFlags
configFlags LocalBuildInfo
lbi
      responseArgumentsNotSupported :: Bool
responseArgumentsNotSupported =
        Bool -> Bool
not (Compiler -> Bool
arResponseFilesSupported (LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi))
      dashLSupported :: Bool
dashLSupported =
        Compiler -> Bool
arDashLSupported (LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi)

      invokeWithResponesFile :: FilePath -> ProgramInvocation
      invokeWithResponesFile :: FilePath -> ProgramInvocation
invokeWithResponesFile FilePath
atFile =
        ConfiguredProgram -> [FilePath] -> ProgramInvocation
programInvocation ConfiguredProgram
ar ([FilePath] -> ProgramInvocation)
-> [FilePath] -> ProgramInvocation
forall a b. (a -> b) -> a -> b
$
        [FilePath]
simpleArgs [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
extraArgs [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [Char
'@' Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath
atFile]

  if Bool
oldVersionManualOverride Bool -> Bool -> Bool
|| Bool
responseArgumentsNotSupported
    then
      [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
        [ Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation Verbosity
verbosity ProgramInvocation
inv
        | ProgramInvocation
inv <- ProgramInvocation
-> (ProgramInvocation, ProgramInvocation, ProgramInvocation)
-> [FilePath]
-> [ProgramInvocation]
multiStageProgramInvocation
                   ProgramInvocation
simple (ProgramInvocation
initial, ProgramInvocation
middle, ProgramInvocation
final) [FilePath]
files ]
    else
      Verbosity
-> TempFileOptions
-> FilePath
-> FilePath
-> Maybe TextEncoding
-> [FilePath]
-> (FilePath -> IO ())
-> IO ()
forall a.
Verbosity
-> TempFileOptions
-> FilePath
-> FilePath
-> Maybe TextEncoding
-> [FilePath]
-> (FilePath -> IO a)
-> IO a
withResponseFile Verbosity
verbosity TempFileOptions
defaultTempFileOptions FilePath
tmpDir FilePath
"ar.rsp" Maybe TextEncoding
forall a. Maybe a
Nothing [FilePath]
files ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
        \FilePath
path -> Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation Verbosity
verbosity (ProgramInvocation -> IO ()) -> ProgramInvocation -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> ProgramInvocation
invokeWithResponesFile FilePath
path

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Arch
hostArch Arch -> Arch -> Bool
forall a. Eq a => a -> a -> Bool
== Arch
Arm -- See #1537
          Bool -> Bool -> Bool
|| OS
hostOS OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
AIX) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ -- AIX uses its own "ar" format variant
    Verbosity -> FilePath -> IO ()
wipeMetadata Verbosity
verbosity FilePath
tmpPath
  Bool
equal <- FilePath -> FilePath -> IO Bool
filesEqual FilePath
tmpPath FilePath
targetPath
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
equal (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
renameFile FilePath
tmpPath FilePath
targetPath

  where
    progDb :: ProgramDb
progDb = LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi
    Platform Arch
hostArch OS
hostOS = LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi
    verbosityOpts :: Verbosity -> [a]
verbosityOpts Verbosity
v
      | Verbosity
v Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
deafening = [a
"-v"]
      | Verbosity
v Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
verbose   = []
      | Bool
otherwise      = [a
"-c"] -- Do not warn if library had to be created.

-- | @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 -> FilePath -> IO ()
wipeMetadata Verbosity
verbosity FilePath
path = do
    -- Check for existence first (ReadWriteMode would create one otherwise)
    Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
path
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
forall a. FilePath -> IO a
wipeError FilePath
"Temporary file disappeared"
    FilePath -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile FilePath
path IOMode
ReadWriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ Handle
h -> Handle -> IO Integer
hFileSize Handle
h IO Integer -> (Integer -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Handle -> Integer -> IO ()
wipeArchive Handle
h

  where
    wipeError :: FilePath -> IO a
wipeError FilePath
msg = Verbosity -> FilePath -> Maybe Int -> FilePath -> IO a
forall a. Verbosity -> FilePath -> Maybe Int -> FilePath -> IO a
dieWithLocation' Verbosity
verbosity FilePath
path Maybe Int
forall a. Maybe a
Nothing (FilePath -> IO a) -> FilePath -> IO a
forall a b. (a -> b) -> a -> b
$
        FilePath
"Distribution.Simple.Program.Ar.wipeMetadata: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
msg
    archLF :: ByteString
archLF = ByteString
"!<arch>\x0a" -- global magic, 8 bytes
    x60LF :: ByteString
x60LF = ByteString
"\x60\x0a" -- header magic, 2 bytes
    metadata :: ByteString
metadata = [ByteString] -> ByteString
BS.concat
        [ ByteString
"0           " -- mtime, 12 bytes
        , ByteString
"0     " -- UID, 6 bytes
        , ByteString
"0     " -- GID, 6 bytes
        , ByteString
"0644    " -- mode, 8 bytes
        ]
    headerSize :: Int
    headerSize :: Int
headerSize = Int
60

    -- http://en.wikipedia.org/wiki/Ar_(Unix)#File_format_details
    wipeArchive :: Handle -> Integer -> IO ()
    wipeArchive :: Handle -> Integer -> IO ()
wipeArchive Handle
h Integer
archiveSize = do
        ByteString
global <- Handle -> Int -> IO ByteString
BS.hGet Handle
h (ByteString -> Int
BS.length ByteString
archLF)
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString
global ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
archLF) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
forall a. FilePath -> IO a
wipeError FilePath
"Bad global header"
        Integer -> IO ()
wipeHeader (Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
archLF)

      where
        wipeHeader :: Integer -> IO ()
        wipeHeader :: Integer -> IO ()
wipeHeader Integer
offset = case Integer -> Integer -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Integer
offset Integer
archiveSize of
            Ordering
EQ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Ordering
GT -> FilePath -> IO ()
forall a. FilePath -> IO a
wipeError (FilePath -> FilePath
atOffset FilePath
"Archive truncated")
            Ordering
LT -> do
                ByteString
header <- Handle -> Int -> IO ByteString
BS.hGet Handle
h Int
headerSize
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Int
BS.length ByteString
header Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
headerSize) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                    FilePath -> IO ()
forall a. FilePath -> IO a
wipeError (FilePath -> FilePath
atOffset FilePath
"Short header")
                let magic :: ByteString
magic = Int -> ByteString -> ByteString
BS.drop Int
58 ByteString
header
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString
magic ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
x60LF) (IO () -> IO ()) -> (FilePath -> IO ()) -> FilePath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO ()
forall a. FilePath -> IO a
wipeError (FilePath -> IO ()) -> (FilePath -> FilePath) -> FilePath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
atOffset (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
                    FilePath
"Bad magic " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ByteString -> FilePath
forall a. Show a => a -> FilePath
show ByteString
magic FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" in header"

                let name :: ByteString
name = Int -> ByteString -> ByteString
BS.take Int
16 ByteString
header
                let size :: ByteString
size = Int -> ByteString -> ByteString
BS.take Int
10 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.drop Int
48 ByteString
header
                Integer
objSize <- case ReadS Integer
forall a. Read a => ReadS a
reads (ByteString -> FilePath
BS8.unpack ByteString
size) of
                    [(Integer
n, FilePath
s)] | (Char -> Bool) -> FilePath -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace FilePath
s -> Integer -> IO Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
n
                    [(Integer, FilePath)]
_ -> FilePath -> IO Integer
forall a. FilePath -> IO a
wipeError (FilePath -> FilePath
atOffset FilePath
"Bad file size in header")

                let replacement :: ByteString
replacement = [ByteString] -> ByteString
BS.concat [ ByteString
name, ByteString
metadata, ByteString
size, ByteString
magic ]
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Int
BS.length ByteString
replacement Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
headerSize) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                    FilePath -> IO ()
forall a. FilePath -> IO a
wipeError (FilePath -> FilePath
atOffset FilePath
"Something has gone terribly wrong")
                Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
h SeekMode
AbsoluteSeek Integer
offset
                Handle -> ByteString -> IO ()
BS.hPut Handle
h ByteString
replacement

                let nextHeader :: Integer
nextHeader = Integer
offset Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
headerSize Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+
                        -- Odd objects are padded with an extra '\x0a'
                        if Integer -> Bool
forall a. Integral a => a -> Bool
odd Integer
objSize then Integer
objSize Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1 else Integer
objSize
                Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
h SeekMode
AbsoluteSeek Integer
nextHeader
                Integer -> IO ()
wipeHeader Integer
nextHeader

          where
            atOffset :: FilePath -> FilePath
atOffset FilePath
msg = FilePath
msg FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" at offset " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Integer -> FilePath
forall a. Show a => a -> FilePath
show Integer
offset