    {-# 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.Flag
      ( fromFlagOrDefault
      )
    import Distribution.Simple.LocalBuildInfo (LocalBuildInfo (..))
    import Distribution.Simple.Program
      ( ProgramInvocation
      , arProgram
      , requireProgram
      )
    import Distribution.Simple.Program.ResponseFile
      ( withResponseFile
      )
    import Distribution.Simple.Program.Run
      ( multiStageProgramInvocation
      , programInvocation
      , runProgramInvocation
      )
    import Distribution.Simple.Setup.Config
      ( 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 -> [Char] -> [[Char]] -> IO ()
    createArLibArchive Verbosity
    verbosity LocalBuildInfo
    lbi [Char]
    targetPath [[Char]]
    files = do
      (ar, _) <- Verbosity
    -> Program -> ProgramDb -> IO (ConfiguredProgram, ProgramDb)
    requireProgram Verbosity
    verbosity Program
    arProgram ProgramDb
    progDb

      let (targetDir, targetName) = splitFileName targetPath
      withTempDirectory verbosity targetDir "objs" $ \[Char]
    tmpDir -> do
        let tmpPath :: [Char]
    tmpPath = [Char]
    tmpDir [Char] -> [Char] -> [Char]
    </> [Char]
    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 :: [[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]
    ++ [[Char]
    tmpPath]

            simple :: ProgramInvocation
    simple = ConfiguredProgram -> [[Char]] -> ProgramInvocation
    programInvocation ConfiguredProgram
    ar ([[Char]]
    simpleArgs [[Char]] -> [[Char]] -> [[Char]]
    forall a. [a] -> [a] -> [a]
    ++ [[Char]]
    extraArgs)
            initial :: ProgramInvocation
    initial = ConfiguredProgram -> [[Char]] -> ProgramInvocation
    programInvocation ConfiguredProgram
    ar ([[Char]]
    initialArgs [[Char]] -> [[Char]] -> [[Char]]
    forall a. [a] -> [a] -> [a]
    ++ [[Char]]
    extraArgs)
            middle :: ProgramInvocation
    middle = ProgramInvocation
    initial
            final :: ProgramInvocation
    final = ConfiguredProgram -> [[Char]] -> ProgramInvocation
    programInvocation ConfiguredProgram
    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)

            invokeWithResponesFile :: FilePath -> ProgramInvocation
            invokeWithResponesFile :: [Char] -> ProgramInvocation
    invokeWithResponesFile [Char]
    atFile =
              ConfiguredProgram -> [[Char]] -> ProgramInvocation
    programInvocation ConfiguredProgram
    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)
                    [[Char]]
    files
              ]
          else Verbosity
    -> TempFileOptions
    -> [Char]
    -> [Char]
    -> Maybe TextEncoding
    -> [[Char]]
    -> ([Char] -> IO ())
    -> IO ()
    forall a.
    Verbosity
    -> TempFileOptions
    -> [Char]
    -> [Char]
    -> Maybe TextEncoding
    -> [[Char]]
    -> ([Char] -> IO a)
    -> IO a
    withResponseFile Verbosity
    verbosity TempFileOptions
    defaultTempFileOptions [Char]
    tmpDir [Char]
    "ar.rsp" Maybe TextEncoding
    forall a. Maybe a
    Nothing [[Char]]
    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
    invokeWithResponesFile [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 [Char]
    tmpPath -- AIX uses its own "ar" format variant
        equal <- [Char] -> [Char] -> IO Bool
    filesEqual [Char]
    tmpPath [Char]
    targetPath
        unless equal $ renameFile tmpPath 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