{-# LANGUAGE PackageImports #-}
{-# OPTIONS_HADDOCK hide #-}
module Codec.Archive.Tar.Write (write) where
import Codec.Archive.Tar.PackAscii
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
import "os-string" System.OsString.Posix (PosixString)
import qualified "os-string" System.OsString.Posix as PS
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 -> GenEntryContent LinkTarget
forall tarPath linkTarget.
GenEntry tarPath linkTarget -> GenEntryContent linkTarget
entryContent Entry
entry of
NormalFile ByteString
content Int64
size
| Int64
size Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Int64
1 Int64 -> Int -> Int64
forall a. Bits a => a -> Int -> a
`shiftL` (Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
12 Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1))
, Entry -> Format
forall tarPath linkTarget. GenEntry tarPath linkTarget -> Format
entryFormat Entry
entry Format -> Format -> Bool
forall a. Eq a => a -> a -> Bool
== Format
V7Format
-> [Char] -> ByteString
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, Int64 -> ByteString
forall {p}. Integral p => p -> ByteString
padding Int64
size ]
OtherEntryType Char
'K' ByteString
_ Int64
_
| Entry -> Format
forall tarPath linkTarget. GenEntry tarPath linkTarget -> Format
entryFormat Entry
entry Format -> Format -> Bool
forall a. Eq a => a -> a -> Bool
/= Format
GnuFormat -> [Char] -> ByteString
forall a. HasCallStack => [Char] -> a
error [Char]
"putEntry: long symlink support is a GNU extension"
OtherEntryType Char
'L' ByteString
_ Int64
_
| Entry -> Format
forall tarPath linkTarget. GenEntry tarPath linkTarget -> Format
entryFormat Entry
entry Format -> Format -> Bool
forall a. Eq a => a -> a -> Bool
/= Format
GnuFormat -> [Char] -> ByteString
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, Int64 -> ByteString
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 = p -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (p -> p
forall a. Num a => a -> a
negate p
size p -> p -> p
forall a. Integral a => a -> a -> a
`mod` p
512)
putHeader :: Entry -> LBS.ByteString
Entry
entry =
[Char] -> ByteString
LBS.Char8.pack
([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
take Int
148 [Char]
block
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> Int -> [Char]
forall a. (Integral a, Show a) => Int -> a -> [Char]
putOct Int
7 Int
checksum
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Char
' ' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop Int
156 [Char]
block
where
block :: [Char]
block = Entry -> [Char]
putHeaderNoChkSum Entry
entry
checksum :: Int
checksum = (Int -> Char -> Int) -> Int -> [Char] -> Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Int
x Char
y -> Int
x Int -> Int -> Int
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 PosixString
name PosixString
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
} =
[[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ Int -> PosixString -> [Char]
putPosixString Int
100 PosixString
name
, Int -> Permissions -> [Char]
forall a. (Integral a, Show a) => Int -> a -> [Char]
putOct Int
8 Permissions
permissions
, Int -> Int -> [Char]
forall a. (Integral a, Show a) => Int -> a -> [Char]
putOct Int
8 (Int -> [Char]) -> Int -> [Char]
forall a b. (a -> b) -> a -> b
$ Ownership -> Int
ownerId Ownership
ownership
, Int -> Int -> [Char]
forall a. (Integral a, Show a) => Int -> a -> [Char]
putOct Int
8 (Int -> [Char]) -> Int -> [Char]
forall a b. (a -> b) -> a -> b
$ Ownership -> Int
groupId Ownership
ownership
, Int -> Int64 -> [Char]
numField Int
12 Int64
contentSize
, Int -> Int64 -> [Char]
forall a. (Integral a, Show a) => Int -> a -> [Char]
putOct Int
12 Int64
modTime
, Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate Int
8 Char
' '
, Char -> [Char]
putChar8 Char
typeCode
, Int -> PosixString -> [Char]
putPosixString Int
100 PosixString
linkTarget
] [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
case Format
format of
Format
V7Format ->
Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate Int
255 Char
'\NUL'
Format
UstarFormat -> [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ Int -> ByteString -> [Char]
putBString Int
8 ByteString
ustarMagic
, Int -> [Char] -> [Char]
putString Int
32 ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ Ownership -> [Char]
ownerName Ownership
ownership
, Int -> [Char] -> [Char]
putString Int
32 ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ Ownership -> [Char]
groupName Ownership
ownership
, Int -> Int -> [Char]
forall a. (Integral a, Show a) => Int -> a -> [Char]
putOct Int
8 Int
deviceMajor
, Int -> Int -> [Char]
forall a. (Integral a, Show a) => Int -> a -> [Char]
putOct Int
8 Int
deviceMinor
, Int -> PosixString -> [Char]
putPosixString Int
155 PosixString
prefix
, Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate Int
12 Char
'\NUL'
]
Format
GnuFormat -> [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ Int -> ByteString -> [Char]
putBString Int
8 ByteString
gnuMagic
, Int -> [Char] -> [Char]
putString Int
32 ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ Ownership -> [Char]
ownerName Ownership
ownership
, Int -> [Char] -> [Char]
putString Int
32 ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ Ownership -> [Char]
groupName Ownership
ownership
, Int -> Int -> [Char]
forall a. (Integral a, Show a) => Int -> a -> [Char]
putGnuDev Int
8 Int
deviceMajor
, Int -> Int -> [Char]
forall a. (Integral a, Show a) => Int -> a -> [Char]
putGnuDev Int
8 Int
deviceMinor
, Int -> PosixString -> [Char]
putPosixString Int
155 PosixString
prefix
, Int -> Char -> [Char]
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 Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Int64
0 Bool -> Bool -> Bool
&& Int64
n Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64
1 Int64 -> Int -> Int64
forall a. Bits a => a -> Int -> a
`shiftL` (Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
= Int -> Int64 -> [Char]
forall a. (Integral a, Show a) => Int -> a -> [Char]
putOct Int
w Int64
n
| Bool
otherwise
= Int -> Int64 -> [Char]
forall a. (Bits a, Integral a) => Int -> a -> [Char]
putLarge Int
w Int64
n
(Char
typeCode, Int64
contentSize, PosixString
linkTarget,
Int
deviceMajor, Int
deviceMinor) = case GenEntryContent LinkTarget
content of
NormalFile ByteString
_ Int64
size -> (Char
'0' , Int64
size, PosixString
forall a. Monoid a => a
mempty, Int
0, Int
0)
GenEntryContent LinkTarget
Directory -> (Char
'5' , Int64
0, PosixString
forall a. Monoid a => a
mempty, Int
0, Int
0)
SymbolicLink (LinkTarget PosixString
link) -> (Char
'2' , Int64
0, PosixString
link, Int
0, Int
0)
HardLink (LinkTarget PosixString
link) -> (Char
'1' , Int64
0, PosixString
link, Int
0, Int
0)
CharacterDevice Int
major Int
minor -> (Char
'3' , Int64
0, PosixString
forall a. Monoid a => a
mempty, Int
major, Int
minor)
BlockDevice Int
major Int
minor -> (Char
'4' , Int64
0, PosixString
forall a. Monoid a => a
mempty, Int
major, Int
minor)
GenEntryContent LinkTarget
NamedPipe -> (Char
'6' , Int64
0, PosixString
forall a. Monoid a => a
mempty, Int
0, Int
0)
OtherEntryType Char
code ByteString
_ Int64
size -> (Char
code, Int64
size, PosixString
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
_ -> Int -> a -> [Char]
forall a. (Integral a, Show a) => Int -> a -> [Char]
putOct Int
w a
n
BlockDevice Int
_ Int
_ -> Int -> a -> [Char]
forall a. (Integral a, Show a) => Int -> a -> [Char]
putOct Int
w a
n
GenEntryContent LinkTarget
_ -> Int -> Char -> [Char]
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) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- ByteString -> Int
BS.length ByteString
s) Char
'\NUL'
putPosixString :: FieldWidth -> PosixString -> String
putPosixString :: Int -> PosixString -> [Char]
putPosixString Int
n PosixString
s = PosixString -> [Char]
fromPosixString (Int -> PosixString -> PosixString
PS.take Int
n PosixString
s) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- PosixString -> Int
PS.length PosixString
s) Char
'\NUL'
putString :: FieldWidth -> String -> String
putString :: Int -> [Char] -> [Char]
putString Int
n [Char]
s = Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
take Int
n [Char]
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Char] -> Int
forall a. [a] -> Int
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' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char] -> [Char]
forall a. [a] -> [a]
reverse (Int -> a -> [Char]
forall {t} {t}.
(Integral t, Bits t, Num t, Eq t) =>
t -> t -> [Char]
go (Int
n0Int -> Int -> Int
forall 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 (t -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (t
x t -> t -> t
forall a. Bits a => a -> a -> a
.&. t
0xff)) Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: t -> t -> [Char]
go (t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1) (t
x t -> Int -> t
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 = Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
take (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ a -> [Char] -> [Char]
forall a. Integral a => a -> [Char] -> [Char]
showOct a
x [Char]
""
in Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
octStr Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Char
'0'
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
octStr
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Char -> [Char]
putChar8 Char
'\NUL'
putChar8 :: Char -> String
putChar8 :: Char -> [Char]
putChar8 Char
c = [Char
c]