{-# 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 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ArchiveEntry -> ArchiveEntry -> Bool
$c/= :: ArchiveEntry -> ArchiveEntry -> Bool
== :: ArchiveEntry -> ArchiveEntry -> Bool
$c== :: ArchiveEntry -> ArchiveEntry -> Bool
Eq, Int -> ArchiveEntry -> ShowS
[ArchiveEntry] -> ShowS
ArchiveEntry -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ArchiveEntry] -> ShowS
$cshowList :: [ArchiveEntry] -> ShowS
show :: ArchiveEntry -> [Char]
$cshow :: ArchiveEntry -> [Char]
showsPrec :: Int -> ArchiveEntry -> ShowS
$cshowsPrec :: Int -> ArchiveEntry -> ShowS
Show)

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

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

isBSDSymdef, isGNUSymdef :: ArchiveEntry -> Bool
isBSDSymdef :: ArchiveEntry -> Bool
isBSDSymdef ArchiveEntry
a = [Char]
"__.SYMDEF" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` (ArchiveEntry -> [Char]
filename ArchiveEntry
a)
isGNUSymdef :: ArchiveEntry -> Bool
isGNUSymdef ArchiveEntry
a = [Char]
"/" 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 = forall a. Read a => [Char] -> a
read forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Char]
C.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> ByteString
C.takeWhile (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 (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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ByteString
C.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
take Int
padding forall a b. (a -> b) -> a -> b
$ [Char]
s forall a. Monoid a => a -> a -> a
`mappend` (forall a. a -> [a]
repeat Char
pad)

getBSDArchEntries :: Get [ArchiveEntry]
getBSDArchEntries :: Get [ArchiveEntry]
getBSDArchEntries = do
    Bool
empty <- Get Bool
isEmpty
    if Bool
empty then
        forall (m :: * -> *) a. Monad m => a -> m a
return []
     else do
        ByteString
name    <- Int -> Get ByteString
getByteString Int
16
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Char
'/' Char -> ByteString -> Bool
`C.elem` ByteString
name Bool -> Bool -> Bool
&& Int -> ByteString -> ByteString
C.take Int
3 ByteString
name forall a. Eq a => a -> a -> Bool
/= ByteString
"#1/") forall a b. (a -> b) -> a -> b
$
          forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Looks like GNU Archive"
        Int
time    <- ByteString -> Int
getPaddedInt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get ByteString
getByteString Int
12
        Int
own     <- ByteString -> Int
getPaddedInt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get ByteString
getByteString Int
6
        Int
grp     <- ByteString -> Int
getPaddedInt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get ByteString
getByteString Int
6
        Int
mode    <- ByteString -> Int
getPaddedInt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get ByteString
getByteString Int
8
        Int
st_size <- ByteString -> Int
getPaddedInt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get ByteString
getByteString Int
10
        ByteString
end     <- Int -> Get ByteString
getByteString Int
2
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
end forall a. Eq a => a -> a -> Bool
/= ByteString
"\x60\x0a") forall a b. (a -> b) -> a -> b
$
          forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"[BSD Archive] Invalid archive header end marker for name: " forall a. [a] -> [a] -> [a]
++
                ByteString -> [Char]
C.unpack ByteString
name)
        Int
off1    <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a b. (Integral a, Num b) => a -> b
fromIntegral Get Int64
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.
        [Char]
name    <- if ByteString -> [Char]
C.unpack (Int -> ByteString -> ByteString
C.take Int
3 ByteString
name) forall a. Eq a => a -> a -> Bool
== [Char]
"#1/" then
                        forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (ByteString -> [Char]
C.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> ByteString
C.takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
'\0')) (Int -> Get ByteString
getByteString forall a b. (a -> b) -> a -> b
$ forall a. Read a => [Char] -> a
read forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
C.unpack forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
C.drop Int
3 ByteString
name)
                    else
                        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
C.unpack forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> ByteString
C.takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
' ') ByteString
name
        Int
off2    <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a b. (Integral a, Num b) => a -> b
fromIntegral Get Int64
bytesRead :: Get Int
        ByteString
file    <- Int -> Get ByteString
getByteString (Int
st_size forall a. Num a => a -> a -> a
- (Int
off2 forall a. Num a => a -> a -> a
- Int
off1))
        -- data sections are two byte aligned (see #15396)
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Integral a => a -> Bool
odd Int
st_size) forall a b. (a -> b) -> a -> b
$
          forall (f :: * -> *) a. Functor f => f a -> f ()
void (Int -> Get ByteString
getByteString Int
1)

        [ArchiveEntry]
rest    <- Get [ArchiveEntry]
getBSDArchEntries
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ([Char]
-> Int -> Int -> Int -> Int -> Int -> ByteString -> ArchiveEntry
ArchiveEntry [Char]
name Int
time Int
own Int
grp Int
mode (Int
st_size forall a. Num a => a -> a -> a
- (Int
off2 forall a. Num a => a -> a -> a
- Int
off1)) ByteString
file) forall a. a -> [a] -> [a]
: [ArchiveEntry]
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
  Bool
empty <- Get Bool
isEmpty
  if Bool
empty
    then forall (m :: * -> *) a. Monad m => a -> m a
return []
    else
    do
      ByteString
name    <- Int -> Get ByteString
getByteString Int
16
      Int
time    <- ByteString -> Int
getPaddedInt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get ByteString
getByteString Int
12
      Int
own     <- ByteString -> Int
getPaddedInt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get ByteString
getByteString Int
6
      Int
grp     <- ByteString -> Int
getPaddedInt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get ByteString
getByteString Int
6
      Int
mode    <- ByteString -> Int
getPaddedInt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get ByteString
getByteString Int
8
      Int
st_size <- ByteString -> Int
getPaddedInt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get ByteString
getByteString Int
10
      ByteString
end     <- Int -> Get ByteString
getByteString Int
2
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
end forall a. Eq a => a -> a -> Bool
/= ByteString
"\x60\x0a") forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"[BSD Archive] Invalid archive header end marker for name: " forall a. [a] -> [a] -> [a]
++
              ByteString -> [Char]
C.unpack ByteString
name)
      ByteString
file <- Int -> Get ByteString
getByteString Int
st_size
      -- data sections are two byte aligned (see #15396)
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Integral a => a -> Bool
odd Int
st_size) forall a b. (a -> b) -> a -> b
$
        forall (f :: * -> *) a. Functor f => f a -> f ()
void (Int -> Get ByteString
getByteString Int
1)
      [Char]
name <- forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Char]
C.unpack forall a b. (a -> b) -> a -> b
$
        if ByteString -> [Char]
C.unpack (Int -> ByteString -> ByteString
C.take Int
1 ByteString
name) forall a. Eq a => a -> a -> Bool
== [Char]
"/"
        then case (Char -> Bool) -> ByteString -> ByteString
C.takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
' ') ByteString
name of
               name :: ByteString
name@ByteString
"/"  -> ByteString
name               -- symbol table
               name :: ByteString
name@ByteString
"//" -> ByteString
name               -- extendedn file names table
               ByteString
name      -> Maybe ArchiveEntry -> Int -> ByteString
getExtName Maybe ArchiveEntry
extInfo (forall a. Read a => [Char] -> a
read forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Char]
C.unpack forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
C.drop Int
1 ByteString
name)
        else (Char -> Bool) -> ByteString -> ByteString
C.takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
'/') ByteString
name
      case [Char]
name of
        [Char]
"/"  -> Maybe ArchiveEntry -> Get [ArchiveEntry]
getGNUArchEntries Maybe ArchiveEntry
extInfo
        [Char]
"//" -> Maybe ArchiveEntry -> Get [ArchiveEntry]
getGNUArchEntries (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 forall a. a -> [a] -> [a]
:) 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
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"Invalid extended filename reference."
   getExtName (Just ArchiveEntry
info) Int
offset = (Char -> Bool) -> ByteString -> ByteString
C.takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
'/') forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ByteString
C.drop Int
offset 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 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 -> 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 forall a. Num a => a -> a -> a
+ Int
pad)
  ByteString -> Put
putByteString           ByteString
"\x60\x0a"
  ByteString -> Put
putByteString           ByteString
file
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
pad forall a. Eq a => a -> a -> Bool
== Int
1) forall a b. (a -> b) -> a -> b
$
    Word8 -> Put
putWord8              Word8
0x0a
  where
    pad :: Int
pad         = Int
st_size forall a. Integral a => a -> a -> a
`mod` Int
2

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

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

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

putBSDArch :: Archive -> PutM ()
putBSDArch :: Archive -> Put
putBSDArch (Archive [ArchiveEntry]
as) = do
  Put
putArchMagic
  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 = forall a. Int -> [a] -> [a]
take Int
size forall a b. (a -> b) -> a -> b
$ [a]
str forall a. Semigroup a => a -> a -> a
<> forall a. a -> [a]
repeat a
pad
    nameSize :: t a -> Int
nameSize t a
name = case forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
name forall a. Integral a => a -> a -> (a, a)
`divMod` Int
4 of
      (Int
n, Int
0) -> Int
4 forall a. Num a => a -> a -> a
* Int
n
      (Int
n, Int
_) -> Int
4 forall a. Num a => a -> a -> a
* (Int
n forall a. Num a => a -> a -> a
+ Int
1)
    needExt :: t Char -> Bool
needExt t Char
name = forall (t :: * -> *) a. Foldable t => t a -> Int
length t Char
name forall a. Ord a => a -> a -> Bool
> Int
16 Bool -> Bool -> Bool
|| Char
' ' 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
_)
      | forall {t :: * -> *}. Foldable t => t Char -> Bool
needExt [Char]
name = ArchiveEntry
archive { filename :: [Char]
filename = [Char]
"#1/" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Int
sz
                               , filedata :: ByteString
filedata = [Char] -> ByteString
C.pack (forall {a}. a -> Int -> [a] -> [a]
padStr Char
'\0' Int
sz [Char]
name) forall a. Semigroup a => a -> a -> a
<> ArchiveEntry -> ByteString
filedata ArchiveEntry
archive
                               , filesize :: Int
filesize = Int
st_size forall a. Num a => a -> a -> a
+ Int
sz }
      | Bool
otherwise    = ArchiveEntry
archive

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

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

putGNUArch :: Archive -> PutM ()
putGNUArch :: Archive -> Put
putGNUArch (Archive [ArchiveEntry]
as) = do
  Put
putArchMagic
  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
_)
      | forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
name forall a. Ord a => a -> a -> Bool
> Int
15 = ( ArchiveEntry
extInfo { filesize :: Int
filesize = ArchiveEntry -> Int
filesize ArchiveEntry
extInfo forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
name forall a. Num a => a -> a -> a
+ Int
2
                                    ,  filedata :: ByteString
filedata = ArchiveEntry -> ByteString
filedata ArchiveEntry
extInfo forall a. Semigroup a => a -> a -> a
<>  [Char] -> ByteString
C.pack [Char]
name forall a. Semigroup a => a -> a -> a
<> ByteString
"/\n" }
                           , ArchiveEntry
archive { filename :: [Char]
filename = [Char]
"/" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show (ArchiveEntry -> Int
filesize ArchiveEntry
extInfo) } )
      | Bool
otherwise        = ( ArchiveEntry
extInfo, ArchiveEntry
archive { filename :: [Char]
filename = [Char]
name forall a. Semigroup a => a -> a -> a
<> [Char]
"/" } )

    processEntries :: [ArchiveEntry] -> [ArchiveEntry]
    processEntries :: [ArchiveEntry] -> [ArchiveEntry]
processEntries =
      forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a. Monoid a => a
mempty)

parseAr :: B.ByteString -> Archive
parseAr :: ByteString -> Archive
parseAr = forall a. Get a -> ByteString -> a
runGet Get Archive
getArch forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
L.fromChunks forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> ByteString
runPut 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> ByteString
runPut 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 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
  ByteString
payload <- [Char] -> IO ByteString
B.readFile [Char]
fp
  (Int
modt, Int
own, Int
grp, Int
mode) <- [Char] -> IO (Int, Int, Int, Int)
fileInfo [Char]
fp
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Char]
-> Int -> Int -> Int -> Int -> Int -> ByteString -> ArchiveEntry
ArchiveEntry
    (ShowS
takeFileName [Char]
fp) Int
modt Int
own Int
grp Int
mode
    (ByteString -> Int
B.length ByteString
payload) ByteString
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 = forall {b} {c}. (Num b, Num c) => FileStatus -> (Int, b, c, Int)
go 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 = ( forall a. Enum a => a -> Int
fromEnum forall a b. (a -> b) -> a -> b
$ FileStatus -> EpochTime
POSIX.modificationTime FileStatus
status
                    , forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ FileStatus -> UserID
POSIX.fileOwner FileStatus
status
                    , forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ FileStatus -> GroupID
POSIX.fileGroup FileStatus
status
                    , Int -> Int
oct2dec forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ FileStatus -> FileMode
POSIX.fileMode FileStatus
status
                    )

oct2dec :: Int -> Int
oct2dec :: Int -> Int
oct2dec = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Int
a Int
b -> Int
a forall a. Num a => a -> a -> a
* Int
10 forall a. Num a => a -> a -> a
+ Int
b) Int
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a. Integral a => a -> a -> (a, a)
`quotRem` t
b
                  in t
lastforall a. a -> [a] -> [a]
:t -> t -> [t]
dec t
b t
rest

#endif