{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-}
{- Note [The need for Ar.hs]
   ~~~~~~~~~~~~~~~~~~~~~~~~~
Building `-staticlib` previously 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: concatenate 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/availability
of libtool across different platforms.
-}
module GHC.SysTools.Ar
  (ArchiveEntry(..)
  ,Archive(..)
  ,afilter

  ,parseAr

  ,loadAr
  ,loadObj
  ,writeBSDAr
  ,writeGNUAr

  ,isBSDSymdef
  ,isGNUSymdef
  )
   where

import GHC.Prelude

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
    { ArchiveEntry -> [Char]
filename :: String       -- ^ File name.
    , ArchiveEntry -> Int
filetime :: Int          -- ^ File modification time.
    , ArchiveEntry -> Int
fileown  :: Int          -- ^ File owner.
    , ArchiveEntry -> Int
filegrp  :: Int          -- ^ File group.
    , ArchiveEntry -> Int
filemode :: Int          -- ^ File mode.
    , ArchiveEntry -> Int
filesize :: Int          -- ^ File size.
    , ArchiveEntry -> ByteString
filedata :: B.ByteString -- ^ File bytes.
    } deriving (ArchiveEntry -> ArchiveEntry -> Bool
(ArchiveEntry -> ArchiveEntry -> Bool)
-> (ArchiveEntry -> ArchiveEntry -> Bool) -> Eq ArchiveEntry
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ArchiveEntry -> ArchiveEntry -> Bool
== :: ArchiveEntry -> ArchiveEntry -> Bool
$c/= :: ArchiveEntry -> ArchiveEntry -> Bool
/= :: ArchiveEntry -> ArchiveEntry -> Bool
Eq, Int -> ArchiveEntry -> ShowS
[ArchiveEntry] -> ShowS
ArchiveEntry -> [Char]
(Int -> ArchiveEntry -> ShowS)
-> (ArchiveEntry -> [Char])
-> ([ArchiveEntry] -> ShowS)
-> Show ArchiveEntry
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ArchiveEntry -> ShowS
showsPrec :: Int -> ArchiveEntry -> ShowS
$cshow :: ArchiveEntry -> [Char]
show :: ArchiveEntry -> [Char]
$cshowList :: [ArchiveEntry] -> ShowS
showList :: [ArchiveEntry] -> ShowS
Show)

newtype Archive = Archive [ArchiveEntry]
        deriving (Archive -> Archive -> Bool
(Archive -> Archive -> Bool)
-> (Archive -> Archive -> Bool) -> Eq Archive
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Archive -> Archive -> Bool
== :: Archive -> Archive -> Bool
$c/= :: Archive -> Archive -> Bool
/= :: Archive -> Archive -> Bool
Eq, Int -> Archive -> ShowS
[Archive] -> ShowS
Archive -> [Char]
(Int -> Archive -> ShowS)
-> (Archive -> [Char]) -> ([Archive] -> ShowS) -> Show Archive
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Archive -> ShowS
showsPrec :: Int -> Archive -> ShowS
$cshow :: Archive -> [Char]
show :: Archive -> [Char]
$cshowList :: [Archive] -> ShowS
showList :: [Archive] -> ShowS
Show, NonEmpty Archive -> Archive
Archive -> Archive -> Archive
(Archive -> Archive -> Archive)
-> (NonEmpty Archive -> Archive)
-> (forall b. Integral b => b -> Archive -> Archive)
-> Semigroup Archive
forall b. Integral b => b -> Archive -> Archive
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: Archive -> Archive -> Archive
<> :: Archive -> Archive -> Archive
$csconcat :: NonEmpty Archive -> Archive
sconcat :: NonEmpty Archive -> Archive
$cstimes :: forall b. Integral b => b -> Archive -> Archive
stimes :: forall b. Integral b => b -> Archive -> Archive
Semigroup, Semigroup Archive
Archive
Semigroup Archive =>
Archive
-> (Archive -> Archive -> Archive)
-> ([Archive] -> Archive)
-> Monoid Archive
[Archive] -> Archive
Archive -> Archive -> Archive
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: Archive
mempty :: Archive
$cmappend :: Archive -> Archive -> Archive
mappend :: Archive -> Archive -> Archive
$cmconcat :: [Archive] -> Archive
mconcat :: [Archive] -> Archive
Monoid)

afilter :: (ArchiveEntry -> Bool) -> Archive -> Archive
afilter :: (ArchiveEntry -> Bool) -> Archive -> Archive
afilter ArchiveEntry -> Bool
f (Archive [ArchiveEntry]
xs) = [ArchiveEntry] -> Archive
Archive ((ArchiveEntry -> Bool) -> [ArchiveEntry] -> [ArchiveEntry]
forall a. (a -> Bool) -> [a] -> [a]
filter ArchiveEntry -> Bool
f [ArchiveEntry]
xs)

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

-- | Archives have numeric values padded with '\x20' to the right.
getPaddedInt :: B.ByteString -> Int
getPaddedInt :: ByteString -> Int
getPaddedInt = [Char] -> Int
forall a. Read a => [Char] -> a
read ([Char] -> Int) -> (ByteString -> [Char]) -> ByteString -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Char]
C.unpack (ByteString -> [Char])
-> (ByteString -> ByteString) -> ByteString -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> ByteString
C.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\x20')

putPaddedInt :: Int -> Int -> Put
putPaddedInt :: Int -> Int -> Put
putPaddedInt Int
padding Int
i = Char -> Int -> [Char] -> Put
putPaddedString Char
'\x20' Int
padding (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i)

putPaddedString :: Char -> Int -> String -> Put
putPaddedString :: Char -> Int -> [Char] -> Put
putPaddedString Char
pad Int
padding [Char]
s = ByteString -> Put
putByteString (ByteString -> Put) -> ([Char] -> ByteString) -> [Char] -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ByteString
C.pack ([Char] -> ByteString) -> ShowS -> [Char] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
padding ([Char] -> Put) -> [Char] -> Put
forall a b. (a -> b) -> a -> b
$ [Char]
s [Char] -> ShowS
forall a. Monoid a => a -> a -> a
`mappend` (Char -> [Char]
forall a. a -> [a]
repeat Char
pad)

getBSDArchEntries :: Get [ArchiveEntry]
getBSDArchEntries :: Get [ArchiveEntry]
getBSDArchEntries = do
    empty <- Get Bool
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 :: Maybe ArchiveEntry -> Get [ArchiveEntry]
getGNUArchEntries Maybe ArchiveEntry
extInfo = do
  empty <- Get Bool
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 :: ByteString
name@ByteString
"/"  -> ByteString
name               -- symbol table
               name :: ByteString
name@ByteString
"//" -> ByteString
name               -- extended file names table
               ByteString
name      -> Maybe ArchiveEntry -> Int -> ByteString
getExtName Maybe ArchiveEntry
extInfo ([Char] -> Int
forall a. Read a => [Char] -> a
read ([Char] -> Int) -> (ByteString -> [Char]) -> ByteString -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Char]
C.unpack (ByteString -> Int) -> ByteString -> Int
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
C.drop Int
1 ByteString
name)
        else C.takeWhile (/= '/') name
      case name of
        [Char]
"/"  -> Maybe ArchiveEntry -> Get [ArchiveEntry]
getGNUArchEntries Maybe ArchiveEntry
extInfo
        [Char]
"//" -> Maybe ArchiveEntry -> Get [ArchiveEntry]
getGNUArchEntries (ArchiveEntry -> Maybe ArchiveEntry
forall a. a -> Maybe a
Just ([Char]
-> Int -> Int -> Int -> Int -> Int -> ByteString -> ArchiveEntry
ArchiveEntry [Char]
name Int
time Int
own Int
grp Int
mode Int
st_size ByteString
file))
        [Char]
_    -> ([Char]
-> Int -> Int -> Int -> Int -> Int -> ByteString -> ArchiveEntry
ArchiveEntry [Char]
name Int
time Int
own Int
grp Int
mode Int
st_size ByteString
file ArchiveEntry -> [ArchiveEntry] -> [ArchiveEntry]
forall a. a -> [a] -> [a]
:) ([ArchiveEntry] -> [ArchiveEntry])
-> Get [ArchiveEntry] -> Get [ArchiveEntry]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ArchiveEntry -> Get [ArchiveEntry]
getGNUArchEntries Maybe ArchiveEntry
extInfo

  where
   getExtName :: Maybe ArchiveEntry -> Int -> B.ByteString
   getExtName :: Maybe ArchiveEntry -> Int -> ByteString
getExtName Maybe ArchiveEntry
Nothing Int
_ = [Char] -> ByteString
forall a. HasCallStack => [Char] -> a
error [Char]
"Invalid extended filename reference."
   getExtName (Just ArchiveEntry
info) Int
offset = (Char -> Bool) -> ByteString -> ByteString
C.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/') (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ByteString
C.drop Int
offset (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ArchiveEntry -> ByteString
filedata ArchiveEntry
info

-- | put an Archive Entry. This assumes that the entries
-- have been preprocessed to account for the extended 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 -> Put
putArchEntry (ArchiveEntry [Char]
name Int
time Int
own Int
grp Int
mode Int
st_size ByteString
file) = do
  Char -> Int -> [Char] -> Put
putPaddedString Char
' '  Int
16 [Char]
name
  Int -> Int -> Put
putPaddedInt         Int
12 Int
time
  Int -> Int -> Put
putPaddedInt          Int
6 Int
own
  Int -> Int -> Put
putPaddedInt          Int
6 Int
grp
  Int -> Int -> Put
putPaddedInt          Int
8 Int
mode
  Int -> Int -> Put
putPaddedInt         Int
10 (Int
st_size Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
pad)
  ByteString -> Put
putByteString           ByteString
"\x60\x0a"
  ByteString -> Put
putByteString           ByteString
file
  Bool -> Put -> Put
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
pad Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (Put -> Put) -> Put -> Put
forall a b. (a -> b) -> a -> b
$
    Word8 -> Put
putWord8              Word8
0x0a
  where
    pad :: Int
pad         = Int
st_size Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
2

getArchMagic :: Get ()
getArchMagic :: Get ()
getArchMagic = do
  magic <- (ByteString -> [Char]) -> Get ByteString -> Get [Char]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ByteString -> [Char]
C.unpack (Get ByteString -> Get [Char]) -> Get ByteString -> Get [Char]
forall a b. (a -> b) -> a -> b
$ Int -> Get ByteString
getByteString Int
8
  if magic /= "!<arch>\n"
    then fail $ "Invalid magic number " ++ show magic
    else return ()

putArchMagic :: Put
putArchMagic :: Put
putArchMagic = ByteString -> Put
putByteString (ByteString -> Put) -> ByteString -> Put
forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString
C.pack [Char]
"!<arch>\n"

getArch :: Get Archive
getArch :: Get Archive
getArch = [ArchiveEntry] -> Archive
Archive ([ArchiveEntry] -> Archive) -> Get [ArchiveEntry] -> Get Archive
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
  Get ()
getArchMagic
  Get [ArchiveEntry]
getBSDArchEntries Get [ArchiveEntry] -> Get [ArchiveEntry] -> Get [ArchiveEntry]
forall a. Get a -> Get a -> Get a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe ArchiveEntry -> Get [ArchiveEntry]
getGNUArchEntries Maybe ArchiveEntry
forall a. Maybe a
Nothing

putBSDArch :: Archive -> PutM ()
putBSDArch :: Archive -> Put
putBSDArch (Archive [ArchiveEntry]
as) = do
  Put
putArchMagic
  (ArchiveEntry -> Put) -> [ArchiveEntry] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ArchiveEntry -> Put
putArchEntry ([ArchiveEntry] -> [ArchiveEntry]
processEntries [ArchiveEntry]
as)

  where
    padStr :: a -> Int -> [a] -> [a]
padStr a
pad Int
size [a]
str = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
size ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ [a]
str [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
<> a -> [a]
forall a. a -> [a]
repeat a
pad
    nameSize :: t a -> Int
nameSize t a
name = case t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
name Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
4 of
      (Int
n, Int
0) -> Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
n
      (Int
n, Int
_) -> Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
    needExt :: t Char -> Bool
needExt t Char
name = t Char -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t Char
name Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
16 Bool -> Bool -> Bool
|| Char
' ' Char -> t Char -> Bool
forall a. Eq a => a -> t a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t Char
name
    processEntry :: ArchiveEntry -> ArchiveEntry
    processEntry :: ArchiveEntry -> ArchiveEntry
processEntry archive :: ArchiveEntry
archive@(ArchiveEntry [Char]
name Int
_ Int
_ Int
_ Int
_ Int
st_size ByteString
_)
      | [Char] -> Bool
forall {t :: * -> *}. Foldable t => t Char -> Bool
needExt [Char]
name = ArchiveEntry
archive { filename = "#1/" <> show sz
                               , filedata = C.pack (padStr '\0' sz name) <> filedata archive
                               , filesize = st_size + sz }
      | Bool
otherwise    = ArchiveEntry
archive

      where sz :: Int
sz = [Char] -> Int
forall {t :: * -> *} {a}. Foldable t => t a -> Int
nameSize [Char]
name

    processEntries :: [ArchiveEntry] -> [ArchiveEntry]
processEntries = (ArchiveEntry -> ArchiveEntry) -> [ArchiveEntry] -> [ArchiveEntry]
forall a b. (a -> b) -> [a] -> [b]
map ArchiveEntry -> ArchiveEntry
processEntry

putGNUArch :: Archive -> PutM ()
putGNUArch :: Archive -> Put
putGNUArch (Archive [ArchiveEntry]
as) = do
  Put
putArchMagic
  (ArchiveEntry -> Put) -> [ArchiveEntry] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ArchiveEntry -> Put
putArchEntry ([ArchiveEntry] -> [ArchiveEntry]
processEntries [ArchiveEntry]
as)

  where
    processEntry :: ArchiveEntry -> ArchiveEntry -> (ArchiveEntry, ArchiveEntry)
    processEntry :: ArchiveEntry -> ArchiveEntry -> (ArchiveEntry, ArchiveEntry)
processEntry ArchiveEntry
extInfo archive :: ArchiveEntry
archive@(ArchiveEntry [Char]
name Int
_ Int
_ Int
_ Int
_ Int
_ ByteString
_)
      | [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
name Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
15 = ( ArchiveEntry
extInfo { filesize = filesize extInfo + length name + 2
                                    ,  filedata = filedata extInfo <>  C.pack name <> "/\n" }
                           , ArchiveEntry
archive { filename = "/" <> show (filesize extInfo) } )
      | Bool
otherwise        = ( ArchiveEntry
extInfo, ArchiveEntry
archive { filename = name <> "/" } )

    processEntries :: [ArchiveEntry] -> [ArchiveEntry]
    processEntries :: [ArchiveEntry] -> [ArchiveEntry]
processEntries =
      (ArchiveEntry -> [ArchiveEntry] -> [ArchiveEntry])
-> (ArchiveEntry, [ArchiveEntry]) -> [ArchiveEntry]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (:) ((ArchiveEntry, [ArchiveEntry]) -> [ArchiveEntry])
-> ([ArchiveEntry] -> (ArchiveEntry, [ArchiveEntry]))
-> [ArchiveEntry]
-> [ArchiveEntry]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ArchiveEntry -> ArchiveEntry -> (ArchiveEntry, ArchiveEntry))
-> ArchiveEntry -> [ArchiveEntry] -> (ArchiveEntry, [ArchiveEntry])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL ArchiveEntry -> ArchiveEntry -> (ArchiveEntry, ArchiveEntry)
processEntry ([Char]
-> Int -> Int -> Int -> Int -> Int -> ByteString -> ArchiveEntry
ArchiveEntry [Char]
"//" Int
0 Int
0 Int
0 Int
0 Int
0 ByteString
forall a. Monoid a => a
mempty)

parseAr :: B.ByteString -> Archive
parseAr :: ByteString -> Archive
parseAr = Get Archive -> ByteString -> Archive
forall a. Get a -> ByteString -> a
runGet Get Archive
getArch (ByteString -> Archive)
-> (ByteString -> ByteString) -> ByteString -> Archive
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
L.fromChunks ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure

writeBSDAr, writeGNUAr :: FilePath -> Archive -> IO ()
writeBSDAr :: [Char] -> Archive -> IO ()
writeBSDAr [Char]
fp = [Char] -> ByteString -> IO ()
L.writeFile [Char]
fp (ByteString -> IO ())
-> (Archive -> ByteString) -> Archive -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> ByteString
runPut (Put -> ByteString) -> (Archive -> Put) -> Archive -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Archive -> Put
putBSDArch
writeGNUAr :: [Char] -> Archive -> IO ()
writeGNUAr [Char]
fp = [Char] -> ByteString -> IO ()
L.writeFile [Char]
fp (ByteString -> IO ())
-> (Archive -> ByteString) -> Archive -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> ByteString
runPut (Put -> ByteString) -> (Archive -> Put) -> Archive -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Archive -> Put
putGNUArch

loadAr :: FilePath -> IO Archive
loadAr :: [Char] -> IO Archive
loadAr [Char]
fp = ByteString -> Archive
parseAr (ByteString -> Archive) -> IO ByteString -> IO Archive
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO ByteString
B.readFile [Char]
fp

loadObj :: FilePath -> IO ArchiveEntry
loadObj :: [Char] -> IO ArchiveEntry
loadObj [Char]
fp = do
  payload <- [Char] -> IO ByteString
B.readFile [Char]
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 :: [Char] -> IO (Int, Int, Int, Int)
fileInfo [Char]
fp = FileStatus -> (Int, Int, Int, Int)
forall {b} {c}. (Num b, Num c) => FileStatus -> (Int, b, c, Int)
go (FileStatus -> (Int, Int, Int, Int))
-> IO FileStatus -> IO (Int, Int, Int, Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO FileStatus
POSIX.getFileStatus [Char]
fp
  where go :: FileStatus -> (Int, b, c, Int)
go FileStatus
status = ( EpochTime -> Int
forall a. Enum a => a -> Int
fromEnum (EpochTime -> Int) -> EpochTime -> Int
forall a b. (a -> b) -> a -> b
$ FileStatus -> EpochTime
POSIX.modificationTime FileStatus
status
                    , UserID -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (UserID -> b) -> UserID -> b
forall a b. (a -> b) -> a -> b
$ FileStatus -> UserID
POSIX.fileOwner FileStatus
status
                    , GroupID -> c
forall a b. (Integral a, Num b) => a -> b
fromIntegral (GroupID -> c) -> GroupID -> c
forall a b. (a -> b) -> a -> b
$ FileStatus -> GroupID
POSIX.fileGroup FileStatus
status
                    , Int -> Int
oct2dec (Int -> Int) -> (FileMode -> Int) -> FileMode -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileMode -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (FileMode -> Int) -> FileMode -> Int
forall a b. (a -> b) -> a -> b
$ FileStatus -> FileMode
POSIX.fileMode FileStatus
status
                    )

oct2dec :: Int -> Int
oct2dec :: Int -> Int
oct2dec = (Int -> Int -> Int) -> Int -> [Int] -> Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Int
a Int
b -> Int
a Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
b) Int
0 ([Int] -> Int) -> (Int -> [Int]) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [Int]
forall a. [a] -> [a]
reverse ([Int] -> [Int]) -> (Int -> [Int]) -> Int -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> [Int]
forall {t}. Integral t => t -> t -> [t]
dec Int
8
  where dec :: t -> t -> [t]
dec t
_ t
0 = []
        dec t
b t
i = let (t
rest, t
last) = t
i t -> t -> (t, t)
forall a. Integral a => a -> a -> (a, a)
`quotRem` t
b
                  in t
lastt -> [t] -> [t]
forall a. a -> [a] -> [a]
:t -> t -> [t]
dec t
b t
rest

#endif