main/Ar.hs

    {-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, CPP #-}
    {- Note: [The need for Ar.hs]
    Building `-staticlib` required the presence of libtool, and was a such
    restricted to mach-o only. As libtool on macOS and gnu libtool are very
    different, there was no simple portable way to support this.

    libtool for static archives does essentially: concatinate the input archives,
    add the input objects, and create a symbol index. Using `ar` for this task
    fails as even `ar` (bsd and gnu, llvm, ...) do not provide the same
    features across platforms (e.g. index prefixed retrieval of objects with
    the same name.)

    As Archives are rather simple structurally, we can just build the archives
    with Haskell directly and use ranlib on the final result to get the symbol
    index. This should allow us to work around with the differences/abailability
    of libtool across differet platforms.
    -}
    module Ar
      (ArchiveEntry(..)
      ,Archive(..)
      ,afilter

      ,parseAr

      ,loadAr
      ,loadObj
      ,writeBSDAr
      ,writeGNUAr

      ,isBSDSymdef
      ,isGNUSymdef
      )
       where

    import GhcPrelude

    import Data.List (mapAccumL, isPrefixOf)
    import Data.Monoid ((<>))
    import Data.Binary.Get
    import Data.Binary.Put
    import Control.Monad
    import Control.Applicative
    import qualified Data.ByteString as B
    import qualified Data.ByteString.Char8 as C
    import qualified Data.ByteString.Lazy as L
    #if !defined(mingw32_HOST_OS)
    import qualified System.Posix.Files as POSIX
    #endif
    import System.FilePath (takeFileName)

    data ArchiveEntry = ArchiveEntry
        { filename :: String       -- ^ File name.
        , filetime :: Int          -- ^ File modification time.
        , fileown  :: Int          -- ^ File owner.
        , filegrp  :: Int          -- ^ File group.
        , filemode :: Int          -- ^ File mode.
        , filesize :: Int          -- ^ File size.
        , filedata :: B.ByteString -- ^ File bytes.
        } deriving (Eq, Show)

    newtype Archive = Archive [ArchiveEntry]
            deriving (Eq, Show, Semigroup, Monoid)

    afilter :: (ArchiveEntry -> Bool) -> Archive -> Archive
    afilter f (Archive xs) = Archive (filter f xs)

    isBSDSymdef, isGNUSymdef :: ArchiveEntry -> Bool
    isBSDSymdef a = "__.SYMDEF" `isPrefixOf` (filename a)
    isGNUSymdef a = "/" == (filename a)

    -- | Archives have numeric values padded with '\x20' to the right.
    getPaddedInt :: B.ByteString -> Int
    getPaddedInt = read . C.unpack . C.takeWhile (/= '\x20')

    putPaddedInt :: Int -> Int -> Put
    putPaddedInt padding i = putPaddedString '\x20' padding (show i)

    putPaddedString :: Char -> Int -> String -> Put
    putPaddedString pad padding s = putByteString . C.pack . take padding $ s `mappend` (repeat pad)

    getBSDArchEntries :: Get [ArchiveEntry]
    getBSDArchEntries = do
        empty <- isEmpty
        if empty then
            return []
         else do
            name    <- getByteString 16
            when ('/' `C.elem` name && C.take 3 name /= "#1/") $
              fail "Looks like GNU Archive"
            time    <- getPaddedInt <$> getByteString 12
            own     <- getPaddedInt <$> getByteString 6
            grp     <- getPaddedInt <$> getByteString 6
            mode    <- getPaddedInt <$> getByteString 8
            st_size <- getPaddedInt <$> getByteString 10
            end     <- getByteString 2
            when (end /= "\x60\x0a") $
              fail ("[BSD Archive] Invalid archive header end marker for name: " ++
                    C.unpack name)
            off1    <- liftM fromIntegral bytesRead :: Get Int
            -- BSD stores extended filenames, by writing #1/<length> into the
            -- name field, the first @length@ bytes then represent the file name
            -- thus the payload size is filesize + file name length.
            name    <- if C.unpack (C.take 3 name) == "#1/" then
                            liftM (C.unpack . C.takeWhile (/= '\0')) (getByteString $ read $ C.unpack $ C.drop 3 name)
                        else
                            return $ C.unpack $ C.takeWhile (/= ' ') name
            off2    <- liftM fromIntegral bytesRead :: Get Int
            file    <- getByteString (st_size - (off2 - off1))
            -- data sections are two byte aligned (see #15396)
            when (odd st_size) $
              void (getByteString 1)

            rest    <- getBSDArchEntries
            return $ (ArchiveEntry name time own grp mode (st_size - (off2 - off1)) file) : rest

    -- | GNU Archives feature a special '//' entry that contains the
    -- extended names. Those are referred to as /<num>, where num is the
    -- offset into the '//' entry.
    -- In addition, filenames are terminated with '/' in the archive.
    getGNUArchEntries :: Maybe ArchiveEntry -> Get [ArchiveEntry]
    getGNUArchEntries extInfo = do
      empty <- isEmpty
      if empty
        then return []
        else
        do
          name    <- getByteString 16
          time    <- getPaddedInt <$> getByteString 12
          own     <- getPaddedInt <$> getByteString 6
          grp     <- getPaddedInt <$> getByteString 6
          mode    <- getPaddedInt <$> getByteString 8
          st_size <- getPaddedInt <$> getByteString 10
          end     <- getByteString 2
          when (end /= "\x60\x0a") $
            fail ("[BSD Archive] Invalid archive header end marker for name: " ++
                  C.unpack name)
          file <- getByteString st_size
          -- data sections are two byte aligned (see #15396)
          when (odd st_size) $
            void (getByteString 1)
          name <- return . C.unpack $
            if C.unpack (C.take 1 name) == "/"
            then case C.takeWhile (/= ' ') name of
                   name@"/"  -> name               -- symbol table
                   name@"//" -> name               -- extendedn file names table
                   name      -> getExtName extInfo (read . C.unpack $ C.drop 1 name)
            else C.takeWhile (/= '/') name
          case name of
            "/"  -> getGNUArchEntries extInfo
            "//" -> getGNUArchEntries (Just (ArchiveEntry name time own grp mode st_size file))
            _    -> (ArchiveEntry name time own grp mode st_size file :) <$> getGNUArchEntries extInfo

      where
       getExtName :: Maybe ArchiveEntry -> Int -> B.ByteString
       getExtName Nothing _ = error "Invalid extended filename reference."
       getExtName (Just info) offset = C.takeWhile (/= '/') . C.drop offset $ filedata info

    -- | put an Archive Entry. This assumes that the entries
    -- have been preprocessed to account for the extenden file name
    -- table section "//" e.g. for GNU Archives. Or that the names
    -- have been move into the payload for BSD Archives.
    putArchEntry :: ArchiveEntry -> PutM ()
    putArchEntry (ArchiveEntry name time own grp mode st_size file) = do
      putPaddedString ' '  16 name
      putPaddedInt         12 time
      putPaddedInt          6 own
      putPaddedInt          6 grp
      putPaddedInt          8 mode
      putPaddedInt         10 (st_size + pad)
      putByteString           "\x60\x0a"
      putByteString           file
      when (pad == 1) $
        putWord8              0x0a
      where
        pad         = st_size `mod` 2

    getArchMagic :: Get ()
    getArchMagic = do
      magic <- liftM C.unpack $ getByteString 8
      if magic /= "!<arch>\n"
        then fail $ "Invalid magic number " ++ show magic
        else return ()

    putArchMagic :: Put
    putArchMagic = putByteString $ C.pack "!<arch>\n"

    getArch :: Get Archive
    getArch = Archive <$> do
      getArchMagic
      getBSDArchEntries <|> getGNUArchEntries Nothing

    putBSDArch :: Archive -> PutM ()
    putBSDArch (Archive as) = do
      putArchMagic
      mapM_ putArchEntry (processEntries as)

      where
        padStr pad size str = take size $ str <> repeat pad
        nameSize name = case length name `divMod` 4 of
          (n, 0) -> 4 * n
          (n, _) -> 4 * (n + 1)
        needExt name = length name > 16 || ' ' `elem` name
        processEntry :: ArchiveEntry -> ArchiveEntry
        processEntry archive@(ArchiveEntry name _ _ _ _ st_size _)
          | needExt name = archive { filename = "#1/" <> show sz
                                   , filedata = C.pack (padStr '\0' sz name) <> filedata archive
                                   , filesize = st_size + sz }
          | otherwise    = archive

          where sz = nameSize name

        processEntries = map processEntry

    putGNUArch :: Archive -> PutM ()
    putGNUArch (Archive as) = do
      putArchMagic
      mapM_ putArchEntry (processEntries as)

      where
        processEntry :: ArchiveEntry -> ArchiveEntry -> (ArchiveEntry, ArchiveEntry)
        processEntry extInfo archive@(ArchiveEntry name _ _ _ _ _ _)
          | length name > 15 = ( extInfo { filesize = filesize extInfo + length name + 2
                                        ,  filedata = filedata extInfo <>  C.pack name <> "/\n" }
                               , archive { filename = "/" <> show (filesize extInfo) } )
          | otherwise        = ( extInfo, archive { filename = name <> "/" } )

        processEntries :: [ArchiveEntry] -> [ArchiveEntry]
        processEntries =
          uncurry (:) . mapAccumL processEntry (ArchiveEntry "//" 0 0 0 0 0 mempty)

    parseAr :: B.ByteString -> Archive
    parseAr = runGet getArch . L.fromChunks . pure

    writeBSDAr, writeGNUAr :: FilePath -> Archive -> IO ()
    writeBSDAr fp = L.writeFile fp . runPut . putBSDArch
    writeGNUAr fp = L.writeFile fp . runPut . putGNUArch

    loadAr :: FilePath -> IO Archive
    loadAr fp = parseAr <$> B.readFile fp

    loadObj :: FilePath -> IO ArchiveEntry
    loadObj fp = do
      payload <- B.readFile fp
      (modt, own, grp, mode) <- fileInfo fp
      return $ ArchiveEntry
        (takeFileName fp) modt own grp mode
        (B.length payload) payload

    -- | Take a filePath and return (mod time, own, grp, mode in decimal)
    fileInfo :: FilePath -> IO ( Int, Int, Int, Int) -- ^ mod time, own, grp, mode (in decimal)
    #if defined(mingw32_HOST_OS)
    -- on windows mod time, owner group and mode are zero.
    fileInfo _ = pure (0,0,0,0)
    #else
    fileInfo fp = go <$> POSIX.getFileStatus fp
      where go status = ( fromEnum $ POSIX.modificationTime status
                        , fromIntegral $ POSIX.fileOwner status
                        , fromIntegral $ POSIX.fileGroup status
                        , oct2dec . fromIntegral $ POSIX.fileMode status
                        )

    oct2dec :: Int -> Int
    oct2dec = foldl' (\a b -> a * 10 + b) 0 . reverse . dec 8
      where dec _ 0 = []
            dec b i = let (rest, last) = i `quotRem` b
                      in last:dec b rest

    #endif