{-# 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
    { ArchiveEntry -> String
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
/= :: ArchiveEntry -> ArchiveEntry -> Bool
$c/= :: ArchiveEntry -> ArchiveEntry -> Bool
== :: ArchiveEntry -> ArchiveEntry -> Bool
$c== :: ArchiveEntry -> ArchiveEntry -> Bool
Eq, Int -> ArchiveEntry -> ShowS
[ArchiveEntry] -> ShowS
ArchiveEntry -> String
(Int -> ArchiveEntry -> ShowS)
-> (ArchiveEntry -> String)
-> ([ArchiveEntry] -> ShowS)
-> Show ArchiveEntry
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ArchiveEntry] -> ShowS
$cshowList :: [ArchiveEntry] -> ShowS
show :: ArchiveEntry -> String
$cshow :: ArchiveEntry -> String
showsPrec :: Int -> ArchiveEntry -> ShowS
$cshowsPrec :: Int -> 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
/= :: Archive -> Archive -> Bool
$c/= :: Archive -> Archive -> Bool
== :: Archive -> Archive -> Bool
$c== :: Archive -> Archive -> Bool
Eq, Int -> Archive -> ShowS
[Archive] -> ShowS
Archive -> String
(Int -> Archive -> ShowS)
-> (Archive -> String) -> ([Archive] -> ShowS) -> Show Archive
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Archive] -> ShowS
$cshowList :: [Archive] -> ShowS
show :: Archive -> String
$cshow :: Archive -> String
showsPrec :: Int -> Archive -> ShowS
$cshowsPrec :: Int -> Archive -> ShowS
Show, b -> Archive -> Archive
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
stimes :: 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
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
mconcat :: [Archive] -> Archive
$cmconcat :: [Archive] -> Archive
mappend :: Archive -> Archive -> Archive
$cmappend :: Archive -> Archive -> Archive
mempty :: Archive
$cmempty :: Archive
$cp1Monoid :: Semigroup Archive
Monoid)

afilter :: (ArchiveEntry -> Bool) -> Archive -> Archive
afilter :: (ArchiveEntry -> Bool) -> Archive -> Archive
afilter f :: ArchiveEntry -> Bool
f (Archive xs :: [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 a :: ArchiveEntry
a = "__.SYMDEF" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` (ArchiveEntry -> String
filename ArchiveEntry
a)
isGNUSymdef :: ArchiveEntry -> Bool
isGNUSymdef a :: ArchiveEntry
a = "/" String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== (ArchiveEntry -> String
filename ArchiveEntry
a)

-- | Archives have numeric values padded with '\x20' to the right.
getPaddedInt :: B.ByteString -> Int
getPaddedInt :: ByteString -> Int
getPaddedInt = String -> Int
forall a. Read a => String -> a
read (String -> Int) -> (ByteString -> String) -> ByteString -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
C.unpack (ByteString -> String)
-> (ByteString -> ByteString) -> ByteString -> String
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
/= '\x20')

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

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

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

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

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

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

      where sz :: Int
sz = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
nameSize String
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 as :: [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 extInfo :: ArchiveEntry
extInfo archive :: ArchiveEntry
archive@(ArchiveEntry name :: String
name _ _ _ _ _ _)
      | String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
name Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 15 = ( ArchiveEntry
extInfo { filesize :: Int
filesize = ArchiveEntry -> Int
filesize ArchiveEntry
extInfo Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
name Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 2
                                    ,  filedata :: ByteString
filedata = ArchiveEntry -> ByteString
filedata ArchiveEntry
extInfo ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>  String -> ByteString
C.pack String
name ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> "/\n" }
                           , ArchiveEntry
archive { filename :: String
filename = "/" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (ArchiveEntry -> Int
filesize ArchiveEntry
extInfo) } )
      | Bool
otherwise        = ( ArchiveEntry
extInfo, ArchiveEntry
archive { filename :: String
filename = String
name String -> ShowS
forall a. Semigroup a => a -> a -> a
<> "/" } )

    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 :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL ArchiveEntry -> ArchiveEntry -> (ArchiveEntry, ArchiveEntry)
processEntry (String
-> Int -> Int -> Int -> Int -> Int -> ByteString -> ArchiveEntry
ArchiveEntry "//" 0 0 0 0 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 (f :: * -> *) a. Applicative f => a -> f a
pure

writeBSDAr, writeGNUAr :: FilePath -> Archive -> IO ()
writeBSDAr :: String -> Archive -> IO ()
writeBSDAr fp :: String
fp = String -> ByteString -> IO ()
L.writeFile String
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 :: String -> Archive -> IO ()
writeGNUAr fp :: String
fp = String -> ByteString -> IO ()
L.writeFile String
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 :: String -> IO Archive
loadAr fp :: String
fp = ByteString -> Archive
parseAr (ByteString -> Archive) -> IO ByteString -> IO Archive
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
B.readFile String
fp

loadObj :: FilePath -> IO ArchiveEntry
loadObj :: String -> IO ArchiveEntry
loadObj fp :: String
fp = do
  ByteString
payload <- String -> IO ByteString
B.readFile String
fp
  (modt :: Int
modt, own :: Int
own, grp :: Int
grp, mode :: Int
mode) <- String -> IO (Int, Int, Int, Int)
fileInfo String
fp
  ArchiveEntry -> IO ArchiveEntry
forall (m :: * -> *) a. Monad m => a -> m a
return (ArchiveEntry -> IO ArchiveEntry)
-> ArchiveEntry -> IO ArchiveEntry
forall a b. (a -> b) -> a -> b
$ String
-> Int -> Int -> Int -> Int -> Int -> ByteString -> ArchiveEntry
ArchiveEntry
    (ShowS
takeFileName String
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 :: String -> IO (Int, Int, Int, Int)
fileInfo fp :: String
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
<$> String -> IO FileStatus
POSIX.getFileStatus String
fp
  where go :: FileStatus -> (Int, b, c, Int)
go status :: 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 (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\a :: Int
a b :: Int
b -> Int
a Int -> Int -> Int
forall a. Num a => a -> a -> a
* 10 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
b) 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 a. Integral a => a -> a -> [a]
dec 8
  where dec :: a -> a -> [a]
dec _ 0 = []
        dec b :: a
b i :: a
i = let (rest :: a
rest, last :: a
last) = a
i a -> a -> (a, a)
forall a. Integral a => a -> a -> (a, a)
`quotRem` a
b
                  in a
lasta -> [a] -> [a]
forall a. a -> [a] -> [a]
:a -> a -> [a]
dec a
b a
rest

#endif