Cabal/src/Distribution/Simple/Program/Ar.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE NondecreasingIndentation #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 {-# LANGUAGE RankNTypes #-}
   5
   6 -----------------------------------------------------------------------------
   7
   8 -- |
   9 -- Module      :  Distribution.Simple.Program.Ar
  10 -- Copyright   :  Duncan Coutts 2009
  11 --
  12 -- Maintainer  :  cabal-devel@haskell.org
  13 -- Portability :  portable
  14 --
  15 -- This module provides an library interface to the @ar@ program.
  16 module Distribution.Simple.Program.Ar
  17   ( createArLibArchive
  18   , multiStageProgramInvocation
  19   ) where
  20
  21 import Distribution.Compat.Prelude
  22 import Prelude ()
  23
  24 import qualified Data.ByteString as BS
  25 import qualified Data.ByteString.Char8 as BS8
  26 import Distribution.Compat.CopyFile (filesEqual)
  27 import Distribution.Simple.Compiler (arDashLSupported, arResponseFilesSupported)
  28 import Distribution.Simple.Flag
  29   ( fromFlagOrDefault
  30   )
  31 import Distribution.Simple.LocalBuildInfo (LocalBuildInfo (..))
  32 import Distribution.Simple.Program
  33   ( ProgramInvocation
  34   , arProgram
  35   , requireProgram
  36   )
  37 import Distribution.Simple.Program.ResponseFile
  38   ( withResponseFile
  39   )
  40 import Distribution.Simple.Program.Run
  41   ( multiStageProgramInvocation
  42   , programInvocation
  43   , runProgramInvocation
  44   )
  45 import Distribution.Simple.Setup.Config
  46   ( configUseResponseFiles
  47   )
  48 import Distribution.Simple.Utils
  49   ( defaultTempFileOptions
  50   , dieWithLocation'
  51   , withTempDirectory
  52   )
  53 import Distribution.System
  54   ( Arch (..)
  55   , OS (..)
  56   , Platform (..)
  57   )
  58 import Distribution.Verbosity
  59   ( Verbosity
  60   , deafening
  61   , verbose
  62   )
  63 import System.Directory (doesFileExist, renameFile)
  64 import System.FilePath (splitFileName, (</>))
  65 import System.IO
  66   ( Handle
  67   , IOMode (ReadWriteMode)
  68   , SeekMode (AbsoluteSeek)
  69   , hFileSize
  70   , hSeek
  71   , withBinaryFile
  72   )
  73
  74 -- | Call @ar@ to create a library archive from a bunch of object files.
  75 createArLibArchive
  76   :: Verbosity
  77   -> LocalBuildInfo
  78   -> FilePath
  79   -> [FilePath]
  80   -> IO ()
  81 createArLibArchive verbosity lbi targetPath files = do
  82   (ar, _) <- requireProgram verbosity arProgram progDb
  83
  84   let (targetDir, targetName) = splitFileName targetPath
  85   withTempDirectory verbosity targetDir "objs" $ \tmpDir -> do
  86     let tmpPath = tmpDir </> targetName
  87
  88     -- The args to use with "ar" are actually rather subtle and system-dependent.
  89     -- In particular we have the following issues:
  90     --
  91     --  -- On OS X, "ar q" does not make an archive index. Archives with no
  92     --     index cannot be used.
  93     --
  94     --  -- GNU "ar r" will not let us add duplicate objects, only "ar q" lets us
  95     --     do that. We have duplicates because of modules like "A.M" and "B.M"
  96     --     both make an object file "M.o" and ar does not consider the directory.
  97     --
  98     --  -- llvm-ar, which GHC >=9.4 uses on Windows, supports a "L" modifier
  99     --     in "q" mode which compels the archiver to add the members of an input
 100     --     archive to the output, rather than the archive itself. This is
 101     --     necessary as GHC may produce .o files that are actually archives. See
 102     --     https://gitlab.haskell.org/ghc/ghc/-/issues/21068.
 103     --
 104     -- Our solution is to use "ar r" in the simple case when one call is enough.
 105     -- When we need to call ar multiple times we use "ar q" and for the last
 106     -- call on OSX we use "ar qs" so that it'll make the index.
 107
 108     let simpleArgs = case hostOS of
 109           OSX -> ["-r", "-s"]
 110           _ | dashLSupported -> ["-qL"]
 111           _ -> ["-r"]
 112
 113         initialArgs = ["-q"]
 114         finalArgs = case hostOS of
 115           OSX -> ["-q", "-s"]
 116           _ | dashLSupported -> ["-qL"]
 117           _ -> ["-q"]
 118
 119         extraArgs = verbosityOpts verbosity ++ [tmpPath]
 120
 121         simple = programInvocation ar (simpleArgs ++ extraArgs)
 122         initial = programInvocation ar (initialArgs ++ extraArgs)
 123         middle = initial
 124         final = programInvocation ar (finalArgs ++ extraArgs)
 125
 126         oldVersionManualOverride =
 127           fromFlagOrDefault False $ configUseResponseFiles $ configFlags lbi
 128         responseArgumentsNotSupported =
 129           not (arResponseFilesSupported (compiler lbi))
 130         dashLSupported =
 131           arDashLSupported (compiler lbi)
 132
 133         invokeWithResponesFile :: FilePath -> ProgramInvocation
 134         invokeWithResponesFile atFile =
 135           programInvocation ar $
 136             simpleArgs ++ extraArgs ++ ['@' : atFile]
 137
 138     if oldVersionManualOverride || responseArgumentsNotSupported
 139       then
 140         sequence_
 141           [ runProgramInvocation verbosity inv
 142           | inv <-
 143               multiStageProgramInvocation
 144                 simple
 145                 (initial, middle, final)
 146                 files
 147           ]
 148       else withResponseFile verbosity defaultTempFileOptions tmpDir "ar.rsp" Nothing files $
 149         \path -> runProgramInvocation verbosity $ invokeWithResponesFile path
 150
 151     unless
 152       ( hostArch == Arm -- See #1537
 153           || hostOS == AIX
 154       )
 155       $ wipeMetadata verbosity tmpPath -- AIX uses its own "ar" format variant
 156     equal <- filesEqual tmpPath targetPath
 157     unless equal $ renameFile tmpPath targetPath
 158   where
 159     progDb = withPrograms lbi
 160     Platform hostArch hostOS = hostPlatform lbi
 161     verbosityOpts v
 162       | v >= deafening = ["-v"]
 163       | v >= verbose = []
 164       | otherwise = ["-c"] -- Do not warn if library had to be created.
 165
 166 -- | @ar@ by default includes various metadata for each object file in their
 167 -- respective headers, so the output can differ for the same inputs, making
 168 -- it difficult to avoid re-linking. GNU @ar@(1) has a deterministic mode
 169 -- (@-D@) flag that always writes zero for the mtime, UID and GID, and 0644
 170 -- for the file mode. However detecting whether @-D@ is supported seems
 171 -- rather harder than just re-implementing this feature.
 172 wipeMetadata :: Verbosity -> FilePath -> IO ()
 173 wipeMetadata verbosity path = do
 174   -- Check for existence first (ReadWriteMode would create one otherwise)
 175   exists <- doesFileExist path
 176   unless exists $ wipeError "Temporary file disappeared"
 177   withBinaryFile path ReadWriteMode $ \h -> hFileSize h >>= wipeArchive h
 178   where
 179     wipeError msg =
 180       dieWithLocation' verbosity path Nothing $
 181         "Distribution.Simple.Program.Ar.wipeMetadata: " ++ msg
 182     archLF = "!<arch>\x0a" -- global magic, 8 bytes
 183     x60LF = "\x60\x0a" -- header magic, 2 bytes
 184     metadata =
 185       BS.concat
 186         [ "0           " -- mtime, 12 bytes
 187         , "0     " -- UID, 6 bytes
 188         , "0     " -- GID, 6 bytes
 189         , "0644    " -- mode, 8 bytes
 190         ]
 191     headerSize :: Int
 192     headerSize = 60
 193
 194     -- http://en.wikipedia.org/wiki/Ar_(Unix)#File_format_details
 195     wipeArchive :: Handle -> Integer -> IO ()
 196     wipeArchive h archiveSize = do
 197       global <- BS.hGet h (BS.length archLF)
 198       unless (global == archLF) $ wipeError "Bad global header"
 199       wipeHeader (toInteger $ BS.length archLF)
 200       where
 201         wipeHeader :: Integer -> IO ()
 202         wipeHeader offset = case compare offset archiveSize of
 203           EQ -> return ()
 204           GT -> wipeError (atOffset "Archive truncated")
 205           LT -> do
 206             header <- BS.hGet h headerSize
 207             unless (BS.length header == headerSize) $
 208               wipeError (atOffset "Short header")
 209             let magic = BS.drop 58 header
 210             unless (magic == x60LF) . wipeError . atOffset $
 211               "Bad magic " ++ show magic ++ " in header"
 212
 213             let name = BS.take 16 header
 214             let size = BS.take 10 $ BS.drop 48 header
 215             objSize <- case reads (BS8.unpack size) of
 216               [(n, s)] | all isSpace s -> return n
 217               _ -> wipeError (atOffset "Bad file size in header")
 218
 219             let replacement = BS.concat [name, metadata, size, magic]
 220             unless (BS.length replacement == headerSize) $
 221               wipeError (atOffset "Something has gone terribly wrong")
 222             hSeek h AbsoluteSeek offset
 223             BS.hPut h replacement
 224
 225             let nextHeader =
 226                   offset
 227                     + toInteger headerSize
 228                     +
 229                     -- Odd objects are padded with an extra '\x0a'
 230                     if odd objSize then objSize + 1 else objSize
 231             hSeek h AbsoluteSeek nextHeader
 232             wipeHeader nextHeader
 233           where
 234             atOffset msg = msg ++ " at offset " ++ show offset