{-# 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 lbi targetPath files = do
  (arProg, _) <- requireProgram verbosity arProgram progDb

  let (targetDir0, targetName0) = splitFileName $ getSymbolicPath targetPath
      targetDir = makeSymbolicPath targetDir0
      targetName = makeRelativePathEx targetName0
      mbWorkDir = mbWorkDirLBI lbi
      -- See Note [Symbolic paths] in Distribution.Utils.Path
      i = interpretSymbolicPath mbWorkDir
      u :: SymbolicPath Pkg to -> FilePath
      u = interpretSymbolicPathCWD
  withTempDirectoryCwd verbosity mbWorkDir targetDir "objs" $ \tmpDir -> do
    let tmpPath = tmpDir </> 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 = case hostOS of
          OSX -> ["-r", "-s"]
          _ | dashLSupported -> ["-qL"]
          _ -> ["-r"]

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

        extraArgs = verbosityOpts verbosity ++ [u tmpPath]

        ar = programInvocationCwd mbWorkDir arProg
        simple = ar (simpleArgs ++ extraArgs)
        initial = ar (initialArgs ++ extraArgs)
        middle = initial
        final = ar (finalArgs ++ extraArgs)

        oldVersionManualOverride =
          fromFlagOrDefault False $ configUseResponseFiles $ configFlags lbi
        responseArgumentsNotSupported =
          not (arResponseFilesSupported (compiler lbi))
        dashLSupported =
          arDashLSupported (compiler lbi)

        invokeWithResponseFile :: FilePath -> ProgramInvocation
        invokeWithResponseFile atFile =
          (ar $ simpleArgs ++ extraArgs ++ ['@' : atFile])

    if oldVersionManualOverride || responseArgumentsNotSupported
      then
        sequence_
          [ runProgramInvocation verbosity inv
          | inv <-
              multiStageProgramInvocation
                simple
                (initial, middle, final)
                (map getSymbolicPath files)
          ]
      else withResponseFile verbosity defaultTempFileOptions mbWorkDir tmpDir "ar.rsp" Nothing (map getSymbolicPath files) $
        \path -> runProgramInvocation verbosity $ invokeWithResponseFile path

    unless
      ( hostArch == Arm -- See #1537
          || hostOS == AIX
      )
      $ wipeMetadata verbosity (i tmpPath) -- AIX uses its own "ar" format variant
    equal <- filesEqual (i tmpPath) (i targetPath)
    unless equal $ renameFile (i tmpPath) (i targetPath)
  where
    progDb = withPrograms lbi
    Platform hostArch hostOS = hostPlatform lbi
    verbosityOpts v
      | v >= deafening = ["-v"]
      | v >= verbose = []
      | otherwise = ["-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 path = do
  -- Check for existence first (ReadWriteMode would create one otherwise)
  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" -- global magic, 8 bytes
    x60LF = "\x60\x0a" -- header magic, 2 bytes
    metadata =
      BS.concat
        [ "0           " -- mtime, 12 bytes
        , "0     " -- UID, 6 bytes
        , "0     " -- GID, 6 bytes
        , "0644    " -- mode, 8 bytes
        ]
    headerSize :: Int
    headerSize = 60

    -- http://en.wikipedia.org/wiki/Ar_(Unix)#File_format_details
    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
                    +
                    -- Odd objects are padded with an extra '\x0a'
                    if odd objSize then objSize + 1 else objSize
            hSeek h AbsoluteSeek nextHeader
            wipeHeader nextHeader
          where
            atOffset msg = msg ++ " at offset " ++ show offset
