{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}

-----------------------------------------------------------------------------

-- |
-- 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 Distribution.Compat.Prelude
import Prelude ()

import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import Distribution.Compat.CopyFile (filesEqual)
import Distribution.Simple.Compiler (arDashLSupported, arResponseFilesSupported)
import Distribution.Simple.LocalBuildInfo (LocalBuildInfo (..), mbWorkDirLBI)
import Distribution.Simple.Program
  ( ProgramInvocation
  , arProgram
  , requireProgram
  )
import Distribution.Simple.Program.ResponseFile
  ( withResponseFile
  )
import Distribution.Simple.Program.Run
  ( multiStageProgramInvocation
  , programInvocationCwd
  , runProgramInvocation
  )
import Distribution.Simple.Setup.Common
import Distribution.Simple.Setup.Config
  ( configUseResponseFiles
  )
import Distribution.Simple.Utils
  ( defaultTempFileOptions
  , dieWithLocation'
  , withTempDirectoryCwd
  )
import Distribution.System
  ( Arch (..)
  , OS (..)
  , Platform (..)
  )
import Distribution.Utils.Path
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
  -> SymbolicPath Pkg File
  -> [SymbolicPath Pkg File]
  -> IO ()
createArLibArchive :: Verbosity
-> LocalBuildInfo
-> SymbolicPath Pkg 'File
-> [SymbolicPath Pkg 'File]
-> IO ()
createArLibArchive Verbosity
verbosity LocalBuildInfo
lbi SymbolicPath Pkg 'File
targetPath [SymbolicPath Pkg 'File]
files = do
  (arProg, _) <- Verbosity
-> Program -> ProgramDb -> IO (ConfiguredProgram, ProgramDb)
requireProgram Verbosity
verbosity Program
arProgram ProgramDb
progDb

  let (targetDir0, targetName0) = splitFileName $ getSymbolicPath targetPath
      targetDir = [Char] -> SymbolicPath from to
forall from (to :: FileOrDir). [Char] -> SymbolicPath from to
makeSymbolicPath [Char]
targetDir0
      targetName = [Char] -> RelativePath from to
forall from (to :: FileOrDir).
HasCallStack =>
[Char] -> RelativePath from to
makeRelativePathEx [Char]
targetName0
      mbWorkDir = LocalBuildInfo -> Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDirLBI LocalBuildInfo
lbi
      -- See Note [Symbolic paths] in Distribution.Utils.Path
      i = Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPathX allowAbsolute Pkg to -> [Char]
forall from (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
Maybe (SymbolicPath CWD ('Dir from))
-> SymbolicPathX allowAbsolute from to -> [Char]
interpretSymbolicPath Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir
      u :: SymbolicPath Pkg to -> FilePath
      u = SymbolicPathX 'AllowAbsolute Pkg to -> [Char]
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> [Char]
interpretSymbolicPathCWD
  withTempDirectoryCwd verbosity mbWorkDir targetDir "objs" $ \SymbolicPath Pkg ('Dir Response)
tmpDir -> do
    let tmpPath :: SymbolicPathX 'AllowAbsolute Pkg c3
tmpPath = SymbolicPath Pkg ('Dir Response)
tmpDir SymbolicPath Pkg ('Dir Response)
-> RelativePath Response c3 -> SymbolicPathX 'AllowAbsolute Pkg c3
forall p q r. PathLike p q r => p -> q -> r
</> RelativePath Response c3
forall {from} {to :: FileOrDir}. RelativePath from to
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, initialArgs, finalArgs :: [String]
        simpleArgs :: [[Char]]
simpleArgs = case OS
hostOS of
          OS
OSX -> [[Char]
"-r", [Char]
"-s"]
          OS
_ | Bool
dashLSupported -> [[Char]
"-qL"]
          OS
_ -> [[Char]
"-r"]

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

        extraArgs :: [[Char]]
extraArgs = Verbosity -> [[Char]]
forall {a}. IsString a => Verbosity -> [a]
verbosityOpts Verbosity
verbosity [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [SymbolicPath Pkg (ZonkAny 1) -> [Char]
forall (to :: FileOrDir). SymbolicPath Pkg to -> [Char]
u SymbolicPath Pkg (ZonkAny 1)
forall {c3 :: FileOrDir}. SymbolicPathX 'AllowAbsolute Pkg c3
tmpPath]

        ar :: [[Char]] -> ProgramInvocation
ar = Maybe (SymbolicPath CWD ('Dir Pkg))
-> ConfiguredProgram -> [[Char]] -> ProgramInvocation
forall to.
Maybe (SymbolicPath CWD ('Dir to))
-> ConfiguredProgram -> [[Char]] -> ProgramInvocation
programInvocationCwd Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir ConfiguredProgram
arProg
        simple :: ProgramInvocation
simple = [[Char]] -> ProgramInvocation
ar ([[Char]]
simpleArgs [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
extraArgs)
        initial :: ProgramInvocation
initial = [[Char]] -> ProgramInvocation
ar ([[Char]]
initialArgs [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
extraArgs)
        middle :: ProgramInvocation
middle = ProgramInvocation
initial
        final :: ProgramInvocation
final = [[Char]] -> ProgramInvocation
ar ([[Char]]
finalArgs [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
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)

        invokeWithResponseFile :: FilePath -> ProgramInvocation
        invokeWithResponseFile :: [Char] -> ProgramInvocation
invokeWithResponseFile [Char]
atFile =
          ([[Char]] -> ProgramInvocation
ar ([[Char]] -> ProgramInvocation) -> [[Char]] -> ProgramInvocation
forall a b. (a -> b) -> a -> b
$ [[Char]]
simpleArgs [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
extraArgs [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [Char
'@' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
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)
-> [[Char]]
-> [ProgramInvocation]
multiStageProgramInvocation
                ProgramInvocation
simple
                (ProgramInvocation
initial, ProgramInvocation
middle, ProgramInvocation
final)
                ((SymbolicPath Pkg 'File -> [Char])
-> [SymbolicPath Pkg 'File] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map SymbolicPath Pkg 'File -> [Char]
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> [Char]
getSymbolicPath [SymbolicPath Pkg 'File]
files)
          ]
      else Verbosity
-> TempFileOptions
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir Response)
-> [Char]
-> Maybe TextEncoding
-> [[Char]]
-> ([Char] -> IO ())
-> IO ()
forall a.
Verbosity
-> TempFileOptions
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir Response)
-> [Char]
-> Maybe TextEncoding
-> [[Char]]
-> ([Char] -> IO a)
-> IO a
withResponseFile Verbosity
verbosity TempFileOptions
defaultTempFileOptions Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir SymbolicPath Pkg ('Dir Response)
tmpDir [Char]
"ar.rsp" Maybe TextEncoding
forall a. Maybe a
Nothing ((SymbolicPath Pkg 'File -> [Char])
-> [SymbolicPath Pkg 'File] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map SymbolicPath Pkg 'File -> [Char]
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> [Char]
getSymbolicPath [SymbolicPath Pkg 'File]
files) (([Char] -> IO ()) -> IO ()) -> ([Char] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
        \[Char]
path -> Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation Verbosity
verbosity (ProgramInvocation -> IO ()) -> ProgramInvocation -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> ProgramInvocation
invokeWithResponseFile [Char]
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
$ Verbosity -> [Char] -> IO ()
wipeMetadata Verbosity
verbosity (SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 2) -> [Char]
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> [Char]
i SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 2)
forall {c3 :: FileOrDir}. SymbolicPathX 'AllowAbsolute Pkg c3
tmpPath) -- AIX uses its own "ar" format variant
    equal <- [Char] -> [Char] -> IO Bool
filesEqual (SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 3) -> [Char]
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> [Char]
i SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 3)
forall {c3 :: FileOrDir}. SymbolicPathX 'AllowAbsolute Pkg c3
tmpPath) (SymbolicPath Pkg 'File -> [Char]
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> [Char]
i SymbolicPath Pkg 'File
targetPath)
    unless equal $ renameFile (i tmpPath) (i 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 -> [Char] -> IO ()
wipeMetadata Verbosity
verbosity [Char]
path = do
  -- Check for existence first (ReadWriteMode would create one otherwise)
  exists <- [Char] -> IO Bool
doesFileExist [Char]
path
  unless exists $ wipeError "Temporary file disappeared"
  withBinaryFile path ReadWriteMode $ \Handle
h -> Handle -> IO Integer
hFileSize Handle
h IO Integer -> (Integer -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Handle -> Integer -> IO ()
wipeArchive Handle
h
  where
    wipeError :: [Char] -> IO a
wipeError [Char]
msg =
      Verbosity -> [Char] -> Maybe Int -> [Char] -> IO a
forall a. Verbosity -> [Char] -> Maybe Int -> [Char] -> IO a
dieWithLocation' Verbosity
verbosity [Char]
path Maybe Int
forall a. Maybe a
Nothing ([Char] -> IO a) -> [Char] -> IO a
forall a b. (a -> b) -> a -> b
$
        [Char]
"Distribution.Simple.Program.Ar.wipeMetadata: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
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
      global <- Handle -> Int -> IO ByteString
BS.hGet Handle
h (ByteString -> Int
BS.length ByteString
archLF)
      unless (global == archLF) $ wipeError "Bad global header"
      wipeHeader (toInteger $ BS.length 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Ordering
GT -> [Char] -> IO ()
forall {a}. [Char] -> IO a
wipeError ([Char] -> [Char]
atOffset [Char]
"Archive truncated")
          Ordering
LT -> do
            header <- Handle -> Int -> IO ByteString
BS.hGet Handle
h Int
headerSize
            unless (BS.length header == headerSize) $
              wipeError (atOffset "Short header")
            let magic = Int -> ByteString -> ByteString
BS.drop Int
58 ByteString
header
            unless (magic == x60LF) . wipeError . atOffset $
              "Bad magic " ++ show magic ++ " in header"

            let name = Int -> ByteString -> ByteString
BS.take Int
16 ByteString
header
            let 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
            objSize <- case reads (BS8.unpack size) of
              [(Integer
n, [Char]
s)] | (Char -> Bool) -> [Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace [Char]
s -> Integer -> IO Integer
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
n
              [(Integer, [Char])]
_ -> [Char] -> IO Integer
forall {a}. [Char] -> IO a
wipeError ([Char] -> [Char]
atOffset [Char]
"Bad file size in header")

            let replacement = [ByteString] -> ByteString
BS.concat [ByteString
name, ByteString
metadata, ByteString
size, ByteString
magic]
            unless (BS.length replacement == headerSize) $
              wipeError (atOffset "Something has gone terribly wrong")
            hSeek h AbsoluteSeek offset
            BS.hPut h replacement

            let 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
            hSeek h AbsoluteSeek nextHeader
            wipeHeader nextHeader
          where
            atOffset :: [Char] -> [Char]
atOffset [Char]
msg = [Char]
msg [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" at offset " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
offset