1f1b44ed356ebd33a76a4d3cf7e688c897fef93b
[ghc.git] / compiler / main / Ar.hs
1 {-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, CPP #-}
2 {- Note: [The need for Ar.hs]
3 Building `-staticlib` required the presence of libtool, and was a such
4 restricted to mach-o only. As libtool on macOS and gnu libtool are very
5 different, there was no simple portable way to support this.
6
7 libtool for static archives does essentially: concatinate the input archives,
8 add the input objects, and create a symbol index. Using `ar` for this task
9 fails as even `ar` (bsd and gnu, llvm, ...) do not provide the same
10 features across platforms (e.g. index prefixed retrieval of objects with
11 the same name.)
12
13 As Archives are rather simple structurally, we can just build the archives
14 with Haskell directly and use ranlib on the final result to get the symbol
15 index. This should allow us to work around with the differences/abailability
16 of libtool across differet platforms.
17 -}
18 module Ar
19 (ArchiveEntry(..)
20 ,Archive(..)
21 ,afilter
22
23 ,parseAr
24
25 ,loadAr
26 ,loadObj
27 ,writeBSDAr
28 ,writeGNUAr
29
30 ,isBSDSymdef
31 ,isGNUSymdef
32 )
33 where
34
35 import GhcPrelude
36
37 import Data.List (mapAccumL, isPrefixOf)
38 import Data.Monoid ((<>))
39 import Data.Binary.Get
40 import Data.Binary.Put
41 import Control.Monad
42 import Control.Applicative
43 import qualified Data.ByteString as B
44 import qualified Data.ByteString.Char8 as C
45 import qualified Data.ByteString.Lazy as L
46 #if !defined(mingw32_HOST_OS)
47 import qualified System.Posix.Files as POSIX
48 #endif
49 import System.FilePath (takeFileName)
50
51 data ArchiveEntry = ArchiveEntry
52 { filename :: String -- ^ File name.
53 , filetime :: Int -- ^ File modification time.
54 , fileown :: Int -- ^ File owner.
55 , filegrp :: Int -- ^ File group.
56 , filemode :: Int -- ^ File mode.
57 , filesize :: Int -- ^ File size.
58 , filedata :: B.ByteString -- ^ File bytes.
59 } deriving (Eq, Show)
60
61 newtype Archive = Archive [ArchiveEntry]
62 deriving (Eq, Show, Semigroup, Monoid)
63
64 afilter :: (ArchiveEntry -> Bool) -> Archive -> Archive
65 afilter f (Archive xs) = Archive (filter f xs)
66
67 isBSDSymdef, isGNUSymdef :: ArchiveEntry -> Bool
68 isBSDSymdef a = "__.SYMDEF" `isPrefixOf` (filename a)
69 isGNUSymdef a = "/" == (filename a)
70
71 -- | Archives have numeric values padded with '\x20' to the right.
72 getPaddedInt :: B.ByteString -> Int
73 getPaddedInt = read . C.unpack . C.takeWhile (/= '\x20')
74
75 putPaddedInt :: Int -> Int -> Put
76 putPaddedInt padding i = putPaddedString '\x20' padding (show i)
77
78 putPaddedString :: Char -> Int -> String -> Put
79 putPaddedString pad padding s = putByteString . C.pack . take padding $ s `mappend` (repeat pad)
80
81 getBSDArchEntries :: Get [ArchiveEntry]
82 getBSDArchEntries = do
83 empty <- isEmpty
84 if empty then
85 return []
86 else do
87 name <- getByteString 16
88 when ('/' `C.elem` name && C.take 3 name /= "#1/") $
89 fail "Looks like GNU Archive"
90 time <- getPaddedInt <$> getByteString 12
91 own <- getPaddedInt <$> getByteString 6
92 grp <- getPaddedInt <$> getByteString 6
93 mode <- getPaddedInt <$> getByteString 8
94 st_size <- getPaddedInt <$> getByteString 10
95 end <- getByteString 2
96 when (end /= "\x60\x0a") $
97 fail ("[BSD Archive] Invalid archive header end marker for name: " ++
98 C.unpack name)
99 off1 <- liftM fromIntegral bytesRead :: Get Int
100 -- BSD stores extended filenames, by writing #1/<length> into the
101 -- name field, the first @length@ bytes then represent the file name
102 -- thus the payload size is filesize + file name length.
103 name <- if C.unpack (C.take 3 name) == "#1/" then
104 liftM (C.unpack . C.takeWhile (/= '\0')) (getByteString $ read $ C.unpack $ C.drop 3 name)
105 else
106 return $ C.unpack $ C.takeWhile (/= ' ') name
107 off2 <- liftM fromIntegral bytesRead :: Get Int
108 file <- getByteString (st_size - (off2 - off1))
109 -- data sections are two byte aligned (see Trac #15396)
110 when (odd st_size) $
111 void (getByteString 1)
112
113 rest <- getBSDArchEntries
114 return $ (ArchiveEntry name time own grp mode (st_size - (off2 - off1)) file) : rest
115
116 -- | GNU Archives feature a special '//' entry that contains the
117 -- extended names. Those are referred to as /<num>, where num is the
118 -- offset into the '//' entry.
119 -- In addition, filenames are terminated with '/' in the archive.
120 getGNUArchEntries :: Maybe ArchiveEntry -> Get [ArchiveEntry]
121 getGNUArchEntries extInfo = do
122 empty <- isEmpty
123 if empty
124 then return []
125 else
126 do
127 name <- getByteString 16
128 time <- getPaddedInt <$> getByteString 12
129 own <- getPaddedInt <$> getByteString 6
130 grp <- getPaddedInt <$> getByteString 6
131 mode <- getPaddedInt <$> getByteString 8
132 st_size <- getPaddedInt <$> getByteString 10
133 end <- getByteString 2
134 when (end /= "\x60\x0a") $
135 fail ("[BSD Archive] Invalid archive header end marker for name: " ++
136 C.unpack name)
137 file <- getByteString st_size
138 -- data sections are two byte aligned (see Trac #15396)
139 when (odd st_size) $
140 void (getByteString 1)
141 name <- return . C.unpack $
142 if C.unpack (C.take 1 name) == "/"
143 then case C.takeWhile (/= ' ') name of
144 name@"/" -> name -- symbol table
145 name@"//" -> name -- extendedn file names table
146 name -> getExtName extInfo (read . C.unpack $ C.drop 1 name)
147 else C.takeWhile (/= '/') name
148 case name of
149 "/" -> getGNUArchEntries extInfo
150 "//" -> getGNUArchEntries (Just (ArchiveEntry name time own grp mode st_size file))
151 _ -> (ArchiveEntry name time own grp mode st_size file :) <$> getGNUArchEntries extInfo
152
153 where
154 getExtName :: Maybe ArchiveEntry -> Int -> B.ByteString
155 getExtName Nothing _ = error "Invalid extended filename reference."
156 getExtName (Just info) offset = C.takeWhile (/= '/') . C.drop offset $ filedata info
157
158 -- | put an Archive Entry. This assumes that the entries
159 -- have been preprocessed to account for the extenden file name
160 -- table section "//" e.g. for GNU Archives. Or that the names
161 -- have been move into the payload for BSD Archives.
162 putArchEntry :: ArchiveEntry -> PutM ()
163 putArchEntry (ArchiveEntry name time own grp mode st_size file) = do
164 putPaddedString ' ' 16 name
165 putPaddedInt 12 time
166 putPaddedInt 6 own
167 putPaddedInt 6 grp
168 putPaddedInt 8 mode
169 putPaddedInt 10 (st_size + pad)
170 putByteString "\x60\x0a"
171 putByteString file
172 when (pad == 1) $
173 putWord8 0x0a
174 where
175 pad = st_size `mod` 2
176
177 getArchMagic :: Get ()
178 getArchMagic = do
179 magic <- liftM C.unpack $ getByteString 8
180 if magic /= "!<arch>\n"
181 then fail $ "Invalid magic number " ++ show magic
182 else return ()
183
184 putArchMagic :: Put
185 putArchMagic = putByteString $ C.pack "!<arch>\n"
186
187 getArch :: Get Archive
188 getArch = Archive <$> do
189 getArchMagic
190 getBSDArchEntries <|> getGNUArchEntries Nothing
191
192 putBSDArch :: Archive -> PutM ()
193 putBSDArch (Archive as) = do
194 putArchMagic
195 mapM_ putArchEntry (processEntries as)
196
197 where
198 padStr pad size str = take size $ str <> repeat pad
199 nameSize name = case length name `divMod` 4 of
200 (n, 0) -> 4 * n
201 (n, _) -> 4 * (n + 1)
202 needExt name = length name > 16 || ' ' `elem` name
203 processEntry :: ArchiveEntry -> ArchiveEntry
204 processEntry archive@(ArchiveEntry name _ _ _ _ st_size _)
205 | needExt name = archive { filename = "#1/" <> show sz
206 , filedata = C.pack (padStr '\0' sz name) <> filedata archive
207 , filesize = st_size + sz }
208 | otherwise = archive
209
210 where sz = nameSize name
211
212 processEntries = map processEntry
213
214 putGNUArch :: Archive -> PutM ()
215 putGNUArch (Archive as) = do
216 putArchMagic
217 mapM_ putArchEntry (processEntries as)
218
219 where
220 processEntry :: ArchiveEntry -> ArchiveEntry -> (ArchiveEntry, ArchiveEntry)
221 processEntry extInfo archive@(ArchiveEntry name _ _ _ _ _ _)
222 | length name > 15 = ( extInfo { filesize = filesize extInfo + length name + 2
223 , filedata = filedata extInfo <> C.pack name <> "/\n" }
224 , archive { filename = "/" <> show (filesize extInfo) } )
225 | otherwise = ( extInfo, archive { filename = name <> "/" } )
226
227 processEntries :: [ArchiveEntry] -> [ArchiveEntry]
228 processEntries =
229 uncurry (:) . mapAccumL processEntry (ArchiveEntry "//" 0 0 0 0 0 mempty)
230
231 parseAr :: B.ByteString -> Archive
232 parseAr = runGet getArch . L.fromChunks . pure
233
234 writeBSDAr, writeGNUAr :: FilePath -> Archive -> IO ()
235 writeBSDAr fp = L.writeFile fp . runPut . putBSDArch
236 writeGNUAr fp = L.writeFile fp . runPut . putGNUArch
237
238 loadAr :: FilePath -> IO Archive
239 loadAr fp = parseAr <$> B.readFile fp
240
241 loadObj :: FilePath -> IO ArchiveEntry
242 loadObj fp = do
243 payload <- B.readFile fp
244 (modt, own, grp, mode) <- fileInfo fp
245 return $ ArchiveEntry
246 (takeFileName fp) modt own grp mode
247 (B.length payload) payload
248
249 -- | Take a filePath and return (mod time, own, grp, mode in decimal)
250 fileInfo :: FilePath -> IO ( Int, Int, Int, Int) -- ^ mod time, own, grp, mode (in decimal)
251 #if defined(mingw32_HOST_OS)
252 -- on windows mod time, owner group and mode are zero.
253 fileInfo _ = pure (0,0,0,0)
254 #else
255 fileInfo fp = go <$> POSIX.getFileStatus fp
256 where go status = ( fromEnum $ POSIX.modificationTime status
257 , fromIntegral $ POSIX.fileOwner status
258 , fromIntegral $ POSIX.fileGroup status
259 , oct2dec . fromIntegral $ POSIX.fileMode status
260 )
261
262 oct2dec :: Int -> Int
263 oct2dec = foldl' (\a b -> a * 10 + b) 0 . reverse . dec 8
264 where dec _ 0 = []
265 dec b i = let (rest, last) = i `quotRem` b
266 in last:dec b rest
267
268 #endif