{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, CPP #-}
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
, ArchiveEntry -> Int
filetime :: Int
, ArchiveEntry -> Int
fileown :: Int
, ArchiveEntry -> Int
filegrp :: Int
, ArchiveEntry -> Int
filemode :: Int
, ArchiveEntry -> Int
filesize :: Int
, ArchiveEntry -> ByteString
filedata :: B.ByteString
} 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 -> [Char]
(Int -> ArchiveEntry -> ShowS)
-> (ArchiveEntry -> [Char])
-> ([ArchiveEntry] -> ShowS)
-> Show ArchiveEntry
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
(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 -> [Char]
(Int -> Archive -> ShowS)
-> (Archive -> [Char]) -> ([Archive] -> ShowS) -> Show Archive
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
(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 :: 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
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
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)
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
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 Int
16
Bool -> Get () -> Get ()
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 ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"#1/") (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$
[Char] -> Get ()
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"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 Int
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 Int
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 Int
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 Int
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 Int
10
ByteString
end <- Int -> Get ByteString
getByteString Int
2
Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
end ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"\x60\x0a") (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$
[Char] -> Get ()
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"[BSD Archive] Invalid archive header end marker for name: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
ByteString -> [Char]
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
[Char]
name <- if ByteString -> [Char]
C.unpack (Int -> ByteString -> ByteString
C.take Int
3 ByteString
name) [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"#1/" then
(ByteString -> [Char]) -> Get ByteString -> Get [Char]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (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
'\0')) (Int -> Get ByteString
getByteString (Int -> Get ByteString) -> Int -> Get ByteString
forall a b. (a -> b) -> a -> b
$ [Char] -> Int
forall a. Read a => [Char] -> a
read ([Char] -> Int) -> [Char] -> Int
forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
C.unpack (ByteString -> [Char]) -> ByteString -> [Char]
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
C.drop Int
3 ByteString
name)
else
[Char] -> Get [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> Get [Char]) -> [Char] -> Get [Char]
forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
C.unpack (ByteString -> [Char]) -> ByteString -> [Char]
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> ByteString
C.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' ') 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))
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 Int
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
$ ([Char]
-> Int -> Int -> Int -> Int -> Int -> ByteString -> ArchiveEntry
ArchiveEntry [Char]
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
getGNUArchEntries :: Maybe ArchiveEntry -> Get [ArchiveEntry]
getGNUArchEntries :: Maybe ArchiveEntry -> Get [ArchiveEntry]
getGNUArchEntries 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 Int
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 Int
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 Int
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 Int
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 Int
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 Int
10
ByteString
end <- Int -> Get ByteString
getByteString Int
2
Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
end ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"\x60\x0a") (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$
[Char] -> Get ()
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"[BSD Archive] Invalid archive header end marker for name: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
ByteString -> [Char]
C.unpack ByteString
name)
ByteString
file <- Int -> Get ByteString
getByteString Int
st_size
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 Int
1)
[Char]
name <- [Char] -> Get [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> Get [Char])
-> (ByteString -> [Char]) -> ByteString -> Get [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Char]
C.unpack (ByteString -> Get [Char]) -> ByteString -> Get [Char]
forall a b. (a -> b) -> a -> b
$
if ByteString -> [Char]
C.unpack (Int -> ByteString -> ByteString
C.take Int
1 ByteString
name) [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"/"
then case (Char -> Bool) -> ByteString -> ByteString
C.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' ') ByteString
name of
name :: ByteString
name@ByteString
"/" -> ByteString
name
name :: ByteString
name@ByteString
"//" -> ByteString
name
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 (Char -> Bool) -> ByteString -> ByteString
C.takeWhile (Char -> Char -> Bool
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 (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
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
[Char]
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 [Char]
magic [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Char]
"!<arch>\n"
then [Char] -> Get ()
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Get ()) -> [Char] -> Get ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid magic number " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> [Char]
show [Char]
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
$ [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 (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 (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 (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 (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 :: [Char]
filename = [Char]
"#1/" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
sz
, filedata :: ByteString
filedata = [Char] -> ByteString
C.pack (Char -> Int -> ShowS
forall {a}. a -> Int -> [a] -> [a]
padStr Char
'\0' Int
sz [Char]
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 = [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 (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 :: Int
filesize = ArchiveEntry -> Int
filesize ArchiveEntry
extInfo Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
name Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2
, filedata :: ByteString
filedata = ArchiveEntry -> ByteString
filedata ArchiveEntry
extInfo ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> [Char] -> ByteString
C.pack [Char]
name ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"/\n" }
, ArchiveEntry
archive { filename :: [Char]
filename = [Char]
"/" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show (ArchiveEntry -> Int
filesize ArchiveEntry
extInfo) } )
| Bool
otherwise = ( ArchiveEntry
extInfo, ArchiveEntry
archive { filename :: [Char]
filename = [Char]
name [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"/" } )
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 (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
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
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
$ [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
fileInfo :: FilePath -> IO ( Int, Int, Int, Int)
#if defined(mingw32_HOST_OS)
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 (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