module Codec.Archive.Tar.Write (write) where
import Codec.Archive.Tar.Types
import Data.Char (ord)
import Data.List (foldl')
import Data.Monoid (mempty)
import Numeric (showOct)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS.Char8
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Lazy.Char8 as LBS.Char8
write :: [Entry] -> LBS.ByteString
write :: [Entry] -> ByteString
write [Entry]
es = [ByteString] -> ByteString
LBS.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ (Entry -> ByteString) -> [Entry] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map Entry -> ByteString
putEntry [Entry]
es [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [Int64 -> Word8 -> ByteString
LBS.replicate (Int64
512Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
*Int64
2) Word8
0]
putEntry :: Entry -> LBS.ByteString
putEntry :: Entry -> ByteString
putEntry Entry
entry = case Entry -> EntryContent
entryContent Entry
entry of
NormalFile ByteString
content Int64
size -> [ByteString] -> ByteString
LBS.concat [ ByteString
header, ByteString
content, Int64 -> ByteString
forall a. Integral a => a -> ByteString
padding Int64
size ]
OtherEntryType TypeCode
_ ByteString
content Int64
size -> [ByteString] -> ByteString
LBS.concat [ ByteString
header, ByteString
content, Int64 -> ByteString
forall a. Integral a => a -> ByteString
padding Int64
size ]
EntryContent
_ -> ByteString
header
where
header :: ByteString
header = Entry -> ByteString
putHeader Entry
entry
padding :: a -> ByteString
padding a
size = Int64 -> Word8 -> ByteString
LBS.replicate Int64
paddingSize Word8
0
where paddingSize :: Int64
paddingSize = a -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> a
forall a. Num a => a -> a
negate a
size a -> a -> a
forall a. Integral a => a -> a -> a
`mod` a
512)
putHeader :: Entry -> LBS.ByteString
Entry
entry =
[TypeCode] -> ByteString
LBS.Char8.pack
([TypeCode] -> ByteString) -> [TypeCode] -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> [TypeCode] -> [TypeCode]
forall a. Int -> [a] -> [a]
take Int
148 [TypeCode]
block
[TypeCode] -> [TypeCode] -> [TypeCode]
forall a. [a] -> [a] -> [a]
++ Int -> Int -> [TypeCode]
forall a. (Integral a, Show a) => Int -> a -> [TypeCode]
putOct Int
7 Int
checksum
[TypeCode] -> [TypeCode] -> [TypeCode]
forall a. [a] -> [a] -> [a]
++ TypeCode
' ' TypeCode -> [TypeCode] -> [TypeCode]
forall a. a -> [a] -> [a]
: Int -> [TypeCode] -> [TypeCode]
forall a. Int -> [a] -> [a]
drop Int
156 [TypeCode]
block
where
block :: [TypeCode]
block = Entry -> [TypeCode]
putHeaderNoChkSum Entry
entry
checksum :: Int
checksum = (Int -> TypeCode -> Int) -> Int -> [TypeCode] -> Int
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Int
x TypeCode
y -> Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ TypeCode -> Int
ord TypeCode
y) Int
0 [TypeCode]
block
putHeaderNoChkSum :: Entry -> String
Entry {
entryTarPath :: Entry -> TarPath
entryTarPath = TarPath ByteString
name ByteString
prefix,
entryContent :: Entry -> EntryContent
entryContent = EntryContent
content,
entryPermissions :: Entry -> Permissions
entryPermissions = Permissions
permissions,
entryOwnership :: Entry -> Ownership
entryOwnership = Ownership
ownership,
entryTime :: Entry -> Int64
entryTime = Int64
modTime,
entryFormat :: Entry -> Format
entryFormat = Format
format
} =
[[TypeCode]] -> [TypeCode]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ Int -> ByteString -> [TypeCode]
putBString Int
100 (ByteString -> [TypeCode]) -> ByteString -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ ByteString
name
, Int -> Permissions -> [TypeCode]
forall a. (Integral a, Show a) => Int -> a -> [TypeCode]
putOct Int
8 (Permissions -> [TypeCode]) -> Permissions -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ Permissions
permissions
, Int -> Int -> [TypeCode]
forall a. (Integral a, Show a) => Int -> a -> [TypeCode]
putOct Int
8 (Int -> [TypeCode]) -> Int -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ Ownership -> Int
ownerId Ownership
ownership
, Int -> Int -> [TypeCode]
forall a. (Integral a, Show a) => Int -> a -> [TypeCode]
putOct Int
8 (Int -> [TypeCode]) -> Int -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ Ownership -> Int
groupId Ownership
ownership
, Int -> Int64 -> [TypeCode]
forall a. (Integral a, Show a) => Int -> a -> [TypeCode]
putOct Int
12 (Int64 -> [TypeCode]) -> Int64 -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ Int64
contentSize
, Int -> Int64 -> [TypeCode]
forall a. (Integral a, Show a) => Int -> a -> [TypeCode]
putOct Int
12 (Int64 -> [TypeCode]) -> Int64 -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ Int64
modTime
, Int -> TypeCode -> [TypeCode]
fill Int
8 (TypeCode -> [TypeCode]) -> TypeCode -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ TypeCode
' '
, TypeCode -> [TypeCode]
putChar8 (TypeCode -> [TypeCode]) -> TypeCode -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ TypeCode
typeCode
, Int -> ByteString -> [TypeCode]
putBString Int
100 (ByteString -> [TypeCode]) -> ByteString -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ ByteString
linkTarget
] [TypeCode] -> [TypeCode] -> [TypeCode]
forall a. [a] -> [a] -> [a]
++
case Format
format of
Format
V7Format ->
Int -> TypeCode -> [TypeCode]
fill Int
255 TypeCode
'\NUL'
Format
UstarFormat -> [[TypeCode]] -> [TypeCode]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ Int -> ByteString -> [TypeCode]
putBString Int
8 (ByteString -> [TypeCode]) -> ByteString -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ ByteString
ustarMagic
, Int -> [TypeCode] -> [TypeCode]
putString Int
32 ([TypeCode] -> [TypeCode]) -> [TypeCode] -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ Ownership -> [TypeCode]
ownerName Ownership
ownership
, Int -> [TypeCode] -> [TypeCode]
putString Int
32 ([TypeCode] -> [TypeCode]) -> [TypeCode] -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ Ownership -> [TypeCode]
groupName Ownership
ownership
, Int -> Int -> [TypeCode]
forall a. (Integral a, Show a) => Int -> a -> [TypeCode]
putOct Int
8 (Int -> [TypeCode]) -> Int -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ Int
deviceMajor
, Int -> Int -> [TypeCode]
forall a. (Integral a, Show a) => Int -> a -> [TypeCode]
putOct Int
8 (Int -> [TypeCode]) -> Int -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ Int
deviceMinor
, Int -> ByteString -> [TypeCode]
putBString Int
155 (ByteString -> [TypeCode]) -> ByteString -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ ByteString
prefix
, Int -> TypeCode -> [TypeCode]
fill Int
12 (TypeCode -> [TypeCode]) -> TypeCode -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ TypeCode
'\NUL'
]
Format
GnuFormat -> [[TypeCode]] -> [TypeCode]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ Int -> ByteString -> [TypeCode]
putBString Int
8 (ByteString -> [TypeCode]) -> ByteString -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ ByteString
gnuMagic
, Int -> [TypeCode] -> [TypeCode]
putString Int
32 ([TypeCode] -> [TypeCode]) -> [TypeCode] -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ Ownership -> [TypeCode]
ownerName Ownership
ownership
, Int -> [TypeCode] -> [TypeCode]
putString Int
32 ([TypeCode] -> [TypeCode]) -> [TypeCode] -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ Ownership -> [TypeCode]
groupName Ownership
ownership
, Int -> Int -> [TypeCode]
forall a. (Integral a, Show a) => Int -> a -> [TypeCode]
putGnuDev Int
8 (Int -> [TypeCode]) -> Int -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ Int
deviceMajor
, Int -> Int -> [TypeCode]
forall a. (Integral a, Show a) => Int -> a -> [TypeCode]
putGnuDev Int
8 (Int -> [TypeCode]) -> Int -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ Int
deviceMinor
, Int -> ByteString -> [TypeCode]
putBString Int
155 (ByteString -> [TypeCode]) -> ByteString -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ ByteString
prefix
, Int -> TypeCode -> [TypeCode]
fill Int
12 (TypeCode -> [TypeCode]) -> TypeCode -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ TypeCode
'\NUL'
]
where
(TypeCode
typeCode, Int64
contentSize, ByteString
linkTarget,
Int
deviceMajor, Int
deviceMinor) = case EntryContent
content of
NormalFile ByteString
_ Int64
size -> (TypeCode
'0' , Int64
size, ByteString
forall a. Monoid a => a
mempty, Int
0, Int
0)
EntryContent
Directory -> (TypeCode
'5' , Int64
0, ByteString
forall a. Monoid a => a
mempty, Int
0, Int
0)
SymbolicLink (LinkTarget ByteString
link) -> (TypeCode
'2' , Int64
0, ByteString
link, Int
0, Int
0)
HardLink (LinkTarget ByteString
link) -> (TypeCode
'1' , Int64
0, ByteString
link, Int
0, Int
0)
CharacterDevice Int
major Int
minor -> (TypeCode
'3' , Int64
0, ByteString
forall a. Monoid a => a
mempty, Int
major, Int
minor)
BlockDevice Int
major Int
minor -> (TypeCode
'4' , Int64
0, ByteString
forall a. Monoid a => a
mempty, Int
major, Int
minor)
EntryContent
NamedPipe -> (TypeCode
'6' , Int64
0, ByteString
forall a. Monoid a => a
mempty, Int
0, Int
0)
OtherEntryType TypeCode
code ByteString
_ Int64
size -> (TypeCode
code, Int64
size, ByteString
forall a. Monoid a => a
mempty, Int
0, Int
0)
putGnuDev :: Int -> a -> [TypeCode]
putGnuDev Int
w a
n = case EntryContent
content of
CharacterDevice Int
_ Int
_ -> Int -> a -> [TypeCode]
forall a. (Integral a, Show a) => Int -> a -> [TypeCode]
putOct Int
w a
n
BlockDevice Int
_ Int
_ -> Int -> a -> [TypeCode]
forall a. (Integral a, Show a) => Int -> a -> [TypeCode]
putOct Int
w a
n
EntryContent
_ -> Int -> TypeCode -> [TypeCode]
forall a. Int -> a -> [a]
replicate Int
w TypeCode
'\NUL'
ustarMagic, gnuMagic :: BS.ByteString
ustarMagic :: ByteString
ustarMagic = [TypeCode] -> ByteString
BS.Char8.pack [TypeCode]
"ustar\NUL00"
gnuMagic :: ByteString
gnuMagic = [TypeCode] -> ByteString
BS.Char8.pack [TypeCode]
"ustar \NUL"
type FieldWidth = Int
putBString :: FieldWidth -> BS.ByteString -> String
putBString :: Int -> ByteString -> [TypeCode]
putBString Int
n ByteString
s = ByteString -> [TypeCode]
BS.Char8.unpack (Int -> ByteString -> ByteString
BS.take Int
n ByteString
s) [TypeCode] -> [TypeCode] -> [TypeCode]
forall a. [a] -> [a] -> [a]
++ Int -> TypeCode -> [TypeCode]
fill (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- ByteString -> Int
BS.length ByteString
s) TypeCode
'\NUL'
putString :: FieldWidth -> String -> String
putString :: Int -> [TypeCode] -> [TypeCode]
putString Int
n [TypeCode]
s = Int -> [TypeCode] -> [TypeCode]
forall a. Int -> [a] -> [a]
take Int
n [TypeCode]
s [TypeCode] -> [TypeCode] -> [TypeCode]
forall a. [a] -> [a] -> [a]
++ Int -> TypeCode -> [TypeCode]
fill (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- [TypeCode] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TypeCode]
s) TypeCode
'\NUL'
putOct :: (Integral a, Show a) => FieldWidth -> a -> String
putOct :: Int -> a -> [TypeCode]
putOct Int
n a
x =
let octStr :: [TypeCode]
octStr = Int -> [TypeCode] -> [TypeCode]
forall a. Int -> [a] -> [a]
take (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) ([TypeCode] -> [TypeCode]) -> [TypeCode] -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ a -> [TypeCode] -> [TypeCode]
forall a. (Integral a, Show a) => a -> [TypeCode] -> [TypeCode]
showOct a
x [TypeCode]
""
in Int -> TypeCode -> [TypeCode]
fill (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- [TypeCode] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TypeCode]
octStr Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) TypeCode
'0'
[TypeCode] -> [TypeCode] -> [TypeCode]
forall a. [a] -> [a] -> [a]
++ [TypeCode]
octStr
[TypeCode] -> [TypeCode] -> [TypeCode]
forall a. [a] -> [a] -> [a]
++ TypeCode -> [TypeCode]
putChar8 TypeCode
'\NUL'
putChar8 :: Char -> String
putChar8 :: TypeCode -> [TypeCode]
putChar8 TypeCode
c = [TypeCode
c]
fill :: FieldWidth -> Char -> String
fill :: Int -> TypeCode -> [TypeCode]
fill Int
n TypeCode
c = Int -> TypeCode -> [TypeCode]
forall a. Int -> a -> [a]
replicate Int
n TypeCode
c