module Codec.Archive.Tar.Write (write) where
import Codec.Archive.Tar.Types
import Data.Bits
import Data.Char (chr,ord)
import Data.Int
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 forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Entry -> ByteString
putEntry [Entry]
es forall a. [a] -> [a] -> [a]
++ [Int64 -> Word8 -> ByteString
LBS.replicate (Int64
512forall a. Num a => a -> a -> a
*Int64
2) Word8
0]
putEntry :: Entry -> LBS.ByteString
putEntry :: Entry -> ByteString
putEntry Entry
entry = case forall tarPath linkTarget.
GenEntry tarPath linkTarget -> GenEntryContent linkTarget
entryContent Entry
entry of
NormalFile ByteString
content Int64
size
| Int64
size forall a. Ord a => a -> a -> Bool
>= Int64
1 forall a. Bits a => a -> Int -> a
`shiftL` (Int
3 forall a. Num a => a -> a -> a
* (Int
12 forall a. Num a => a -> a -> a
-Int
1))
, forall tarPath linkTarget. GenEntry tarPath linkTarget -> Format
entryFormat Entry
entry forall a. Eq a => a -> a -> Bool
== Format
V7Format
-> forall a. HasCallStack => [Char] -> a
error [Char]
"putEntry: support for files over 8Gb is a Ustar extension"
| Bool
otherwise -> [ByteString] -> ByteString
LBS.concat [ ByteString
header, ByteString
content, forall {p}. Integral p => p -> ByteString
padding Int64
size ]
OtherEntryType Char
'K' ByteString
_ Int64
_
| forall tarPath linkTarget. GenEntry tarPath linkTarget -> Format
entryFormat Entry
entry forall a. Eq a => a -> a -> Bool
/= Format
GnuFormat -> forall a. HasCallStack => [Char] -> a
error [Char]
"putEntry: long symlink support is a GNU extension"
OtherEntryType Char
'L' ByteString
_ Int64
_
| forall tarPath linkTarget. GenEntry tarPath linkTarget -> Format
entryFormat Entry
entry forall a. Eq a => a -> a -> Bool
/= Format
GnuFormat -> forall a. HasCallStack => [Char] -> a
error [Char]
"putEntry: long filename support is a GNU extension"
OtherEntryType Char
_ ByteString
content Int64
size -> [ByteString] -> ByteString
LBS.concat [ ByteString
header, ByteString
content, forall {p}. Integral p => p -> ByteString
padding Int64
size ]
GenEntryContent LinkTarget
_ -> ByteString
header
where
header :: ByteString
header = Entry -> ByteString
putHeader Entry
entry
padding :: p -> ByteString
padding p
size = Int64 -> Word8 -> ByteString
LBS.replicate Int64
paddingSize Word8
0
where paddingSize :: Int64
paddingSize = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Num a => a -> a
negate p
size forall a. Integral a => a -> a -> a
`mod` p
512)
putHeader :: Entry -> LBS.ByteString
Entry
entry =
[Char] -> ByteString
LBS.Char8.pack
forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take Int
148 [Char]
block
forall a. [a] -> [a] -> [a]
++ forall a. (Integral a, Show a) => Int -> a -> [Char]
putOct Int
7 Int
checksum
forall a. [a] -> [a] -> [a]
++ Char
' ' forall a. a -> [a] -> [a]
: forall a. Int -> [a] -> [a]
drop Int
156 [Char]
block
where
block :: [Char]
block = Entry -> [Char]
putHeaderNoChkSum Entry
entry
checksum :: Int
checksum = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Int
x Char
y -> Int
x forall a. Num a => a -> a -> a
+ Char -> Int
ord Char
y) Int
0 [Char]
block
putHeaderNoChkSum :: Entry -> String
Entry {
entryTarPath :: forall tarPath linkTarget. GenEntry tarPath linkTarget -> tarPath
entryTarPath = TarPath ByteString
name ByteString
prefix,
entryContent :: forall tarPath linkTarget.
GenEntry tarPath linkTarget -> GenEntryContent linkTarget
entryContent = GenEntryContent LinkTarget
content,
entryPermissions :: forall tarPath linkTarget.
GenEntry tarPath linkTarget -> Permissions
entryPermissions = Permissions
permissions,
entryOwnership :: forall tarPath linkTarget. GenEntry tarPath linkTarget -> Ownership
entryOwnership = Ownership
ownership,
entryTime :: forall tarPath linkTarget. GenEntry tarPath linkTarget -> Int64
entryTime = Int64
modTime,
entryFormat :: forall tarPath linkTarget. GenEntry tarPath linkTarget -> Format
entryFormat = Format
format
} =
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ Int -> ByteString -> [Char]
putBString Int
100 ByteString
name
, forall a. (Integral a, Show a) => Int -> a -> [Char]
putOct Int
8 Permissions
permissions
, forall a. (Integral a, Show a) => Int -> a -> [Char]
putOct Int
8 forall a b. (a -> b) -> a -> b
$ Ownership -> Int
ownerId Ownership
ownership
, forall a. (Integral a, Show a) => Int -> a -> [Char]
putOct Int
8 forall a b. (a -> b) -> a -> b
$ Ownership -> Int
groupId Ownership
ownership
, Int -> Int64 -> [Char]
numField Int
12 Int64
contentSize
, forall a. (Integral a, Show a) => Int -> a -> [Char]
putOct Int
12 Int64
modTime
, forall a. Int -> a -> [a]
replicate Int
8 Char
' '
, Char -> [Char]
putChar8 Char
typeCode
, Int -> ByteString -> [Char]
putBString Int
100 ByteString
linkTarget
] forall a. [a] -> [a] -> [a]
++
case Format
format of
Format
V7Format ->
forall a. Int -> a -> [a]
replicate Int
255 Char
'\NUL'
Format
UstarFormat -> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ Int -> ByteString -> [Char]
putBString Int
8 ByteString
ustarMagic
, Int -> [Char] -> [Char]
putString Int
32 forall a b. (a -> b) -> a -> b
$ Ownership -> [Char]
ownerName Ownership
ownership
, Int -> [Char] -> [Char]
putString Int
32 forall a b. (a -> b) -> a -> b
$ Ownership -> [Char]
groupName Ownership
ownership
, forall a. (Integral a, Show a) => Int -> a -> [Char]
putOct Int
8 Int
deviceMajor
, forall a. (Integral a, Show a) => Int -> a -> [Char]
putOct Int
8 Int
deviceMinor
, Int -> ByteString -> [Char]
putBString Int
155 ByteString
prefix
, forall a. Int -> a -> [a]
replicate Int
12 Char
'\NUL'
]
Format
GnuFormat -> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ Int -> ByteString -> [Char]
putBString Int
8 ByteString
gnuMagic
, Int -> [Char] -> [Char]
putString Int
32 forall a b. (a -> b) -> a -> b
$ Ownership -> [Char]
ownerName Ownership
ownership
, Int -> [Char] -> [Char]
putString Int
32 forall a b. (a -> b) -> a -> b
$ Ownership -> [Char]
groupName Ownership
ownership
, forall a. (Integral a, Show a) => Int -> a -> [Char]
putGnuDev Int
8 Int
deviceMajor
, forall a. (Integral a, Show a) => Int -> a -> [Char]
putGnuDev Int
8 Int
deviceMinor
, Int -> ByteString -> [Char]
putBString Int
155 ByteString
prefix
, forall a. Int -> a -> [a]
replicate Int
12 Char
'\NUL'
]
where
numField :: FieldWidth -> Int64 -> String
numField :: Int -> Int64 -> [Char]
numField Int
w Int64
n
| Int64
n forall a. Ord a => a -> a -> Bool
>= Int64
0 Bool -> Bool -> Bool
&& Int64
n forall a. Ord a => a -> a -> Bool
< Int64
1 forall a. Bits a => a -> Int -> a
`shiftL` (Int
3 forall a. Num a => a -> a -> a
* (Int
w forall a. Num a => a -> a -> a
- Int
1))
= forall a. (Integral a, Show a) => Int -> a -> [Char]
putOct Int
w Int64
n
| Bool
otherwise
= forall a. (Bits a, Integral a) => Int -> a -> [Char]
putLarge Int
w Int64
n
(Char
typeCode, Int64
contentSize, ByteString
linkTarget,
Int
deviceMajor, Int
deviceMinor) = case GenEntryContent LinkTarget
content of
NormalFile ByteString
_ Int64
size -> (Char
'0' , Int64
size, forall a. Monoid a => a
mempty, Int
0, Int
0)
GenEntryContent LinkTarget
Directory -> (Char
'5' , Int64
0, forall a. Monoid a => a
mempty, Int
0, Int
0)
SymbolicLink (LinkTarget ByteString
link) -> (Char
'2' , Int64
0, ByteString
link, Int
0, Int
0)
HardLink (LinkTarget ByteString
link) -> (Char
'1' , Int64
0, ByteString
link, Int
0, Int
0)
CharacterDevice Int
major Int
minor -> (Char
'3' , Int64
0, forall a. Monoid a => a
mempty, Int
major, Int
minor)
BlockDevice Int
major Int
minor -> (Char
'4' , Int64
0, forall a. Monoid a => a
mempty, Int
major, Int
minor)
GenEntryContent LinkTarget
NamedPipe -> (Char
'6' , Int64
0, forall a. Monoid a => a
mempty, Int
0, Int
0)
OtherEntryType Char
code ByteString
_ Int64
size -> (Char
code, Int64
size, forall a. Monoid a => a
mempty, Int
0, Int
0)
putGnuDev :: Int -> a -> [Char]
putGnuDev Int
w a
n = case GenEntryContent LinkTarget
content of
CharacterDevice Int
_ Int
_ -> forall a. (Integral a, Show a) => Int -> a -> [Char]
putOct Int
w a
n
BlockDevice Int
_ Int
_ -> forall a. (Integral a, Show a) => Int -> a -> [Char]
putOct Int
w a
n
GenEntryContent LinkTarget
_ -> forall a. Int -> a -> [a]
replicate Int
w Char
'\NUL'
ustarMagic, gnuMagic :: BS.ByteString
ustarMagic :: ByteString
ustarMagic = [Char] -> ByteString
BS.Char8.pack [Char]
"ustar\NUL00"
gnuMagic :: ByteString
gnuMagic = [Char] -> ByteString
BS.Char8.pack [Char]
"ustar \NUL"
type FieldWidth = Int
putBString :: FieldWidth -> BS.ByteString -> String
putBString :: Int -> ByteString -> [Char]
putBString Int
n ByteString
s = ByteString -> [Char]
BS.Char8.unpack (Int -> ByteString -> ByteString
BS.take Int
n ByteString
s) forall a. [a] -> [a] -> [a]
++ forall a. Int -> a -> [a]
replicate (Int
n forall a. Num a => a -> a -> a
- ByteString -> Int
BS.length ByteString
s) Char
'\NUL'
putString :: FieldWidth -> String -> String
putString :: Int -> [Char] -> [Char]
putString Int
n [Char]
s = forall a. Int -> [a] -> [a]
take Int
n [Char]
s forall a. [a] -> [a] -> [a]
++ forall a. Int -> a -> [a]
replicate (Int
n forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
s) Char
'\NUL'
{-# SPECIALISE putLarge :: FieldWidth -> Int64 -> String #-}
putLarge :: (Bits a, Integral a) => FieldWidth -> a -> String
putLarge :: forall a. (Bits a, Integral a) => Int -> a -> [Char]
putLarge Int
n0 a
x0 = Char
'\x80' forall a. a -> [a] -> [a]
: forall a. [a] -> [a]
reverse (forall {t} {t}.
(Integral t, Bits t, Num t, Eq t) =>
t -> t -> [Char]
go (Int
n0forall a. Num a => a -> a -> a
-Int
1) a
x0)
where go :: t -> t -> [Char]
go t
0 t
_ = []
go t
n t
x = Int -> Char
chr (forall a b. (Integral a, Num b) => a -> b
fromIntegral (t
x forall a. Bits a => a -> a -> a
.&. t
0xff)) forall a. a -> [a] -> [a]
: t -> t -> [Char]
go (t
nforall a. Num a => a -> a -> a
-t
1) (t
x forall a. Bits a => a -> Int -> a
`shiftR` Int
8)
putOct :: (Integral a, Show a) => FieldWidth -> a -> String
putOct :: forall a. (Integral a, Show a) => Int -> a -> [Char]
putOct Int
n a
x =
let octStr :: [Char]
octStr = forall a. Int -> [a] -> [a]
take (Int
nforall a. Num a => a -> a -> a
-Int
1) forall a b. (a -> b) -> a -> b
$ forall a. (Integral a, Show a) => a -> [Char] -> [Char]
showOct a
x [Char]
""
in forall a. Int -> a -> [a]
replicate (Int
n forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
octStr forall a. Num a => a -> a -> a
- Int
1) Char
'0'
forall a. [a] -> [a] -> [a]
++ [Char]
octStr
forall a. [a] -> [a] -> [a]
++ Char -> [Char]
putChar8 Char
'\NUL'
putChar8 :: Char -> String
putChar8 :: Char -> [Char]
putChar8 Char
c = [Char
c]