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