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

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