{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE NondecreasingIndentation #-}
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, arDashLSupported)
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 )
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
let simpleArgs :: [[Char]]
simpleArgs = case OS
hostOS of
OS
OSX -> [[Char]
"-r", [Char]
"-s"]
OS
_ | Bool
dashLSupported -> [[Char]
"-qL"]
OS
_ -> [[Char]
"-r"]
initialArgs :: [[Char]]
initialArgs = [[Char]
"-q"]
finalArgs :: [[Char]]
finalArgs = case OS
hostOS of
OS
OSX -> [[Char]
"-q", [Char]
"-s"]
OS
_ | Bool
dashLSupported -> [[Char]
"-qL"]
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))
dashLSupported :: Bool
dashLSupported =
Compiler -> Bool
arDashLSupported (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
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
$
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"]
wipeMetadata :: Verbosity -> FilePath -> IO ()
wipeMetadata :: Verbosity -> [Char] -> IO ()
wipeMetadata Verbosity
verbosity [Char]
path = do
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 a b. IO a -> (a -> IO b) -> IO b
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"
x60LF :: ByteString
x60LF = ByteString
"\x60\x0a"
metadata :: ByteString
metadata = [ByteString] -> ByteString
BS.concat
[ ByteString
"0 "
, ByteString
"0 "
, ByteString
"0 "
, ByteString
"0644 "
]
headerSize :: Int
headerSize :: Int
headerSize = Int
60
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 a. a -> IO a
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 a. a -> IO a
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
+
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