content: {-# 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.LocalBuildInfo (LocalBuildInfo(..))
  import Distribution.Simple.Program
           ( arProgram, requireProgram )
  import Distribution.Simple.Program.Run
           ( programInvocation, multiStageProgramInvocation
           , runProgramInvocation )
  import Distribution.Simple.Utils
           ( 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 lbi targetPath files = do
    (ar, _) <- requireProgram verbosity arProgram progDb
  
    let (targetDir, targetName) = splitFileName targetPath
    withTempDirectory verbosity 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.
    --
    -- 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  = case hostOS of
               OSX -> ["-r", "-s"]
               _   -> ["-r"]
  
        initialArgs = ["-q"]
        finalArgs   = case hostOS of
               OSX -> ["-q", "-s"]
               _   -> ["-q"]
  
        extraArgs   = verbosityOpts verbosity ++ [tmpPath]
  
        simple  = programInvocation ar (simpleArgs  ++ extraArgs)
        initial = programInvocation ar (initialArgs ++ extraArgs)
        middle  = initial
        final   = programInvocation ar (finalArgs   ++ extraArgs)
  
    sequence_
          [ runProgramInvocation verbosity inv
          | inv <- multiStageProgramInvocation
                     simple (initial, middle, final) files ]
  
    unless (hostArch == Arm -- See #1537
            || hostOS == AIX) $ -- AIX uses its own "ar" format variant
      wipeMetadata verbosity tmpPath
    equal <- filesEqual tmpPath targetPath
    unless equal $ renameFile tmpPath targetPath
  
    where
      progDb = withPrograms lbi
      Platform hostArch hostOS = hostPlatform lbi
      verbosityOpts v | v >= deafening = ["-v"]
                      | v >= verbose   = []
                      | otherwise      = ["-c"]
  
  -- | @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
  