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