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]
++ [FileSize -> Word8 -> ByteString
LBS.replicate (FileSize
512FileSize -> FileSize -> FileSize
forall a. Num a => a -> a -> a
*FileSize
2) Word8
0]
putEntry :: Entry -> LBS.ByteString
putEntry :: Entry -> ByteString
putEntry Entry
entry = case Entry -> EntryContent
entryContent Entry
entry of
NormalFile ByteString
content FileSize
size -> [ByteString] -> ByteString
LBS.concat [ ByteString
header, ByteString
content, FileSize -> ByteString
forall {p}. Integral p => p -> ByteString
padding FileSize
size ]
OtherEntryType TypeCode
_ ByteString
content FileSize
size -> [ByteString] -> ByteString
LBS.concat [ ByteString
header, ByteString
content, FileSize -> ByteString
forall {p}. Integral p => p -> ByteString
padding FileSize
size ]
EntryContent
_ -> ByteString
header
where
header :: ByteString
header = Entry -> ByteString
putHeader Entry
entry
padding :: p -> ByteString
padding p
size = FileSize -> Word8 -> ByteString
LBS.replicate FileSize
paddingSize Word8
0
where paddingSize :: FileSize
paddingSize = p -> FileSize
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 =
[TypeCode] -> ByteString
LBS.Char8.pack
([TypeCode] -> ByteString) -> [TypeCode] -> ByteString
forall a b. (a -> b) -> a -> b
$ FieldWidth -> [TypeCode] -> [TypeCode]
forall a. FieldWidth -> [a] -> [a]
take FieldWidth
148 [TypeCode]
block
[TypeCode] -> [TypeCode] -> [TypeCode]
forall a. [a] -> [a] -> [a]
++ FieldWidth -> FieldWidth -> [TypeCode]
forall a. (Integral a, Show a) => FieldWidth -> a -> [TypeCode]
putOct FieldWidth
7 FieldWidth
checksum
[TypeCode] -> [TypeCode] -> [TypeCode]
forall a. [a] -> [a] -> [a]
++ TypeCode
' ' TypeCode -> [TypeCode] -> [TypeCode]
forall a. a -> [a] -> [a]
: FieldWidth -> [TypeCode] -> [TypeCode]
forall a. FieldWidth -> [a] -> [a]
drop FieldWidth
156 [TypeCode]
block
where
block :: [TypeCode]
block = Entry -> [TypeCode]
putHeaderNoChkSum Entry
entry
checksum :: FieldWidth
checksum = (FieldWidth -> TypeCode -> FieldWidth)
-> FieldWidth -> [TypeCode] -> FieldWidth
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\FieldWidth
x TypeCode
y -> FieldWidth
x FieldWidth -> FieldWidth -> FieldWidth
forall a. Num a => a -> a -> a
+ TypeCode -> FieldWidth
ord TypeCode
y) FieldWidth
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 -> FileSize
entryTime = FileSize
modTime,
entryFormat :: Entry -> Format
entryFormat = Format
format
} =
[[TypeCode]] -> [TypeCode]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ FieldWidth -> ByteString -> [TypeCode]
putBString FieldWidth
100 (ByteString -> [TypeCode]) -> ByteString -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ ByteString
name
, FieldWidth -> Permissions -> [TypeCode]
forall a. (Integral a, Show a) => FieldWidth -> a -> [TypeCode]
putOct FieldWidth
8 (Permissions -> [TypeCode]) -> Permissions -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ Permissions
permissions
, FieldWidth -> FieldWidth -> [TypeCode]
forall a. (Integral a, Show a) => FieldWidth -> a -> [TypeCode]
putOct FieldWidth
8 (FieldWidth -> [TypeCode]) -> FieldWidth -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ Ownership -> FieldWidth
ownerId Ownership
ownership
, FieldWidth -> FieldWidth -> [TypeCode]
forall a. (Integral a, Show a) => FieldWidth -> a -> [TypeCode]
putOct FieldWidth
8 (FieldWidth -> [TypeCode]) -> FieldWidth -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ Ownership -> FieldWidth
groupId Ownership
ownership
, FieldWidth -> FileSize -> [TypeCode]
forall a. (Integral a, Show a) => FieldWidth -> a -> [TypeCode]
putOct FieldWidth
12 (FileSize -> [TypeCode]) -> FileSize -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ FileSize
contentSize
, FieldWidth -> FileSize -> [TypeCode]
forall a. (Integral a, Show a) => FieldWidth -> a -> [TypeCode]
putOct FieldWidth
12 (FileSize -> [TypeCode]) -> FileSize -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ FileSize
modTime
, FieldWidth -> TypeCode -> [TypeCode]
fill FieldWidth
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
, FieldWidth -> ByteString -> [TypeCode]
putBString FieldWidth
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 ->
FieldWidth -> TypeCode -> [TypeCode]
fill FieldWidth
255 TypeCode
'\NUL'
Format
UstarFormat -> [[TypeCode]] -> [TypeCode]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ FieldWidth -> ByteString -> [TypeCode]
putBString FieldWidth
8 (ByteString -> [TypeCode]) -> ByteString -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ ByteString
ustarMagic
, FieldWidth -> [TypeCode] -> [TypeCode]
putString FieldWidth
32 ([TypeCode] -> [TypeCode]) -> [TypeCode] -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ Ownership -> [TypeCode]
ownerName Ownership
ownership
, FieldWidth -> [TypeCode] -> [TypeCode]
putString FieldWidth
32 ([TypeCode] -> [TypeCode]) -> [TypeCode] -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ Ownership -> [TypeCode]
groupName Ownership
ownership
, FieldWidth -> FieldWidth -> [TypeCode]
forall a. (Integral a, Show a) => FieldWidth -> a -> [TypeCode]
putOct FieldWidth
8 (FieldWidth -> [TypeCode]) -> FieldWidth -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ FieldWidth
deviceMajor
, FieldWidth -> FieldWidth -> [TypeCode]
forall a. (Integral a, Show a) => FieldWidth -> a -> [TypeCode]
putOct FieldWidth
8 (FieldWidth -> [TypeCode]) -> FieldWidth -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ FieldWidth
deviceMinor
, FieldWidth -> ByteString -> [TypeCode]
putBString FieldWidth
155 (ByteString -> [TypeCode]) -> ByteString -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ ByteString
prefix
, FieldWidth -> TypeCode -> [TypeCode]
fill FieldWidth
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
[ FieldWidth -> ByteString -> [TypeCode]
putBString FieldWidth
8 (ByteString -> [TypeCode]) -> ByteString -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ ByteString
gnuMagic
, FieldWidth -> [TypeCode] -> [TypeCode]
putString FieldWidth
32 ([TypeCode] -> [TypeCode]) -> [TypeCode] -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ Ownership -> [TypeCode]
ownerName Ownership
ownership
, FieldWidth -> [TypeCode] -> [TypeCode]
putString FieldWidth
32 ([TypeCode] -> [TypeCode]) -> [TypeCode] -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ Ownership -> [TypeCode]
groupName Ownership
ownership
, FieldWidth -> FieldWidth -> [TypeCode]
forall a. (Integral a, Show a) => FieldWidth -> a -> [TypeCode]
putGnuDev FieldWidth
8 (FieldWidth -> [TypeCode]) -> FieldWidth -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ FieldWidth
deviceMajor
, FieldWidth -> FieldWidth -> [TypeCode]
forall a. (Integral a, Show a) => FieldWidth -> a -> [TypeCode]
putGnuDev FieldWidth
8 (FieldWidth -> [TypeCode]) -> FieldWidth -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ FieldWidth
deviceMinor
, FieldWidth -> ByteString -> [TypeCode]
putBString FieldWidth
155 (ByteString -> [TypeCode]) -> ByteString -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ ByteString
prefix
, FieldWidth -> TypeCode -> [TypeCode]
fill FieldWidth
12 (TypeCode -> [TypeCode]) -> TypeCode -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ TypeCode
'\NUL'
]
where
(TypeCode
typeCode, FileSize
contentSize, ByteString
linkTarget,
FieldWidth
deviceMajor, FieldWidth
deviceMinor) = case EntryContent
content of
NormalFile ByteString
_ FileSize
size -> (TypeCode
'0' , FileSize
size, ByteString
forall a. Monoid a => a
mempty, FieldWidth
0, FieldWidth
0)
EntryContent
Directory -> (TypeCode
'5' , FileSize
0, ByteString
forall a. Monoid a => a
mempty, FieldWidth
0, FieldWidth
0)
SymbolicLink (LinkTarget ByteString
link) -> (TypeCode
'2' , FileSize
0, ByteString
link, FieldWidth
0, FieldWidth
0)
HardLink (LinkTarget ByteString
link) -> (TypeCode
'1' , FileSize
0, ByteString
link, FieldWidth
0, FieldWidth
0)
CharacterDevice FieldWidth
major FieldWidth
minor -> (TypeCode
'3' , FileSize
0, ByteString
forall a. Monoid a => a
mempty, FieldWidth
major, FieldWidth
minor)
BlockDevice FieldWidth
major FieldWidth
minor -> (TypeCode
'4' , FileSize
0, ByteString
forall a. Monoid a => a
mempty, FieldWidth
major, FieldWidth
minor)
EntryContent
NamedPipe -> (TypeCode
'6' , FileSize
0, ByteString
forall a. Monoid a => a
mempty, FieldWidth
0, FieldWidth
0)
OtherEntryType TypeCode
code ByteString
_ FileSize
size -> (TypeCode
code, FileSize
size, ByteString
forall a. Monoid a => a
mempty, FieldWidth
0, FieldWidth
0)
putGnuDev :: FieldWidth -> a -> [TypeCode]
putGnuDev FieldWidth
w a
n = case EntryContent
content of
CharacterDevice FieldWidth
_ FieldWidth
_ -> FieldWidth -> a -> [TypeCode]
forall a. (Integral a, Show a) => FieldWidth -> a -> [TypeCode]
putOct FieldWidth
w a
n
BlockDevice FieldWidth
_ FieldWidth
_ -> FieldWidth -> a -> [TypeCode]
forall a. (Integral a, Show a) => FieldWidth -> a -> [TypeCode]
putOct FieldWidth
w a
n
EntryContent
_ -> FieldWidth -> TypeCode -> [TypeCode]
forall a. FieldWidth -> a -> [a]
replicate FieldWidth
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 :: FieldWidth -> ByteString -> [TypeCode]
putBString FieldWidth
n ByteString
s = ByteString -> [TypeCode]
BS.Char8.unpack (FieldWidth -> ByteString -> ByteString
BS.take FieldWidth
n ByteString
s) [TypeCode] -> [TypeCode] -> [TypeCode]
forall a. [a] -> [a] -> [a]
++ FieldWidth -> TypeCode -> [TypeCode]
fill (FieldWidth
n FieldWidth -> FieldWidth -> FieldWidth
forall a. Num a => a -> a -> a
- ByteString -> FieldWidth
BS.length ByteString
s) TypeCode
'\NUL'
putString :: FieldWidth -> String -> String
putString :: FieldWidth -> [TypeCode] -> [TypeCode]
putString FieldWidth
n [TypeCode]
s = FieldWidth -> [TypeCode] -> [TypeCode]
forall a. FieldWidth -> [a] -> [a]
take FieldWidth
n [TypeCode]
s [TypeCode] -> [TypeCode] -> [TypeCode]
forall a. [a] -> [a] -> [a]
++ FieldWidth -> TypeCode -> [TypeCode]
fill (FieldWidth
n FieldWidth -> FieldWidth -> FieldWidth
forall a. Num a => a -> a -> a
- [TypeCode] -> FieldWidth
forall (t :: * -> *) a. Foldable t => t a -> FieldWidth
length [TypeCode]
s) TypeCode
'\NUL'
putOct :: (Integral a, Show a) => FieldWidth -> a -> String
putOct :: forall a. (Integral a, Show a) => FieldWidth -> a -> [TypeCode]
putOct FieldWidth
n a
x =
let octStr :: [TypeCode]
octStr = FieldWidth -> [TypeCode] -> [TypeCode]
forall a. FieldWidth -> [a] -> [a]
take (FieldWidth
nFieldWidth -> FieldWidth -> FieldWidth
forall a. Num a => a -> a -> a
-FieldWidth
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 FieldWidth -> TypeCode -> [TypeCode]
fill (FieldWidth
n FieldWidth -> FieldWidth -> FieldWidth
forall a. Num a => a -> a -> a
- [TypeCode] -> FieldWidth
forall (t :: * -> *) a. Foldable t => t a -> FieldWidth
length [TypeCode]
octStr FieldWidth -> FieldWidth -> FieldWidth
forall a. Num a => a -> a -> a
- FieldWidth
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 :: FieldWidth -> TypeCode -> [TypeCode]
fill FieldWidth
n TypeCode
c = FieldWidth -> TypeCode -> [TypeCode]
forall a. FieldWidth -> a -> [a]
replicate FieldWidth
n TypeCode
c