    {-# 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)
    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 -> [Char] -> [[Char]] -> IO ()
    createArLibArchive Verbosity
    verbosity LocalBuildInfo
    lbi [Char]
    targetPath [[Char]]
    files = do
      (ConfiguredProgram
    ar, ProgramDb
    _) <- Verbosity
    -> Program -> ProgramDb -> IO (ConfiguredProgram, ProgramDb)
    requireProgram Verbosity
    verbosity Program
    arProgram ProgramDb
    progDb

      let ([Char]
    targetDir, [Char]
    targetName) = [Char] -> ([Char], [Char])
    splitFileName [Char]
    targetPath
      Verbosity -> [Char] -> [Char] -> ([Char] -> IO ()) -> IO ()
    forall a. Verbosity -> [Char] -> [Char] -> ([Char] -> IO a) -> IO a
    withTempDirectory Verbosity
    verbosity [Char]
    targetDir [Char]
    "objs" (([Char] -> IO ()) -> IO ()) -> ([Char] -> IO ()) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ \ [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.
      --
      -- 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
    _   -> [[Char]
    "-r"]

          initialArgs :: [[Char]]
    initialArgs = [[Char]
    "-q"]
          finalArgs :: [[Char]]
    finalArgs   = case OS
    hostOS of
                 OS
    OSX -> [[Char]
    "-q", [Char]
    "-s"]
                 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))

          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
    $ -- AIX uses its own "ar" format variant
        Verbosity -> [Char] -> IO ()
    wipeMetadata Verbosity
    verbosity [Char]
    tmpPath
      Bool
    equal <- [Char] -> [Char] -> IO Bool
    filesEqual [Char]
    tmpPath [Char]
    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
    $ [Char] -> [Char] -> IO ()
    renameFile [Char]
    tmpPath [Char]
    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)
        Bool
    exists <- [Char] -> IO Bool
    doesFileExist [Char]
    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
    $ [Char] -> IO ()
    forall {a}. [Char] -> IO a
    wipeError [Char]
    "Temporary file disappeared"
        [Char] -> IOMode -> (Handle -> IO ()) -> IO ()
    forall r. [Char] -> IOMode -> (Handle -> IO r) -> IO r
    withBinaryFile [Char]
    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 :: [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
            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
    $ [Char] -> IO ()
    forall {a}. [Char] -> IO a
    wipeError [Char]
    "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 -> [Char] -> IO ()
    forall {a}. [Char] -> IO a
    wipeError ([Char] -> [Char]
    atOffset [Char]
    "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
    $
                        [Char] -> IO ()
    forall {a}. [Char] -> IO a
    wipeError ([Char] -> [Char]
    atOffset [Char]
    "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 ()) -> ([Char] -> IO ()) -> [Char] -> IO ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [Char] -> IO ()
    forall {a}. [Char] -> IO a
    wipeError ([Char] -> IO ()) -> ([Char] -> [Char]) -> [Char] -> IO ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [Char] -> [Char]
    atOffset ([Char] -> IO ()) -> [Char] -> IO ()
    forall a b. (a -> b) -> a -> b
    $
                        [Char]
    "Bad magic " [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ ByteString -> [Char]
    forall a. Show a => a -> [Char]
    show ByteString
    magic [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    " 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 -> [Char]
    BS8.unpack ByteString
    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 (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
    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
    $
                        [Char] -> IO ()
    forall {a}. [Char] -> IO a
    wipeError ([Char] -> [Char]
    atOffset [Char]
    "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 :: [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