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