module Codec.Archive.Tar.Write (write) where
import Codec.Archive.Tar.Types
import Data.Char (ord)
import Data.List (foldl')
import Numeric (showOct)
import qualified Data.ByteString.Lazy as BS
import qualified Data.ByteString.Lazy.Char8 as BS.Char8
import Data.ByteString.Lazy (ByteString)
write :: [Entry] -> ByteString
write es = BS.concat $ map putEntry es ++ [BS.replicate (512*2) 0]
putEntry :: Entry -> ByteString
putEntry entry = case entryContent entry of
NormalFile content size -> BS.concat [ header, content, padding size ]
OtherEntryType _ content size -> BS.concat [ header, content, padding size ]
_ -> header
where
header = putHeader entry
padding size = BS.replicate paddingSize 0
where paddingSize = fromIntegral (negate size `mod` 512)
putHeader :: Entry -> ByteString
putHeader entry =
BS.Char8.pack $ take 148 block
++ putOct 7 checksum
++ ' ' : drop 156 block
where
block = putHeaderNoChkSum entry
checksum = foldl' (\x y -> x + ord y) 0 block
putHeaderNoChkSum :: Entry -> String
putHeaderNoChkSum Entry {
entryTarPath = TarPath name prefix,
entryContent = content,
entryPermissions = permissions,
entryOwnership = ownership,
entryTime = modTime,
entryFormat = format
} =
concat
[ putString 100 $ name
, putOct 8 $ permissions
, putOct 8 $ ownerId ownership
, putOct 8 $ groupId ownership
, putOct 12 $ contentSize
, putOct 12 $ modTime
, fill 8 $ ' '
, putChar8 $ typeCode
, putString 100 $ linkTarget
] ++
case format of
V7Format ->
fill 255 '\NUL'
UstarFormat -> concat
[ putString 8 $ "ustar\NUL00"
, putString 32 $ ownerName ownership
, putString 32 $ groupName ownership
, putOct 8 $ deviceMajor
, putOct 8 $ deviceMinor
, putString 155 $ prefix
, fill 12 $ '\NUL'
]
GnuFormat -> concat
[ putString 8 $ "ustar \NUL"
, putString 32 $ ownerName ownership
, putString 32 $ groupName ownership
, putGnuDev 8 $ deviceMajor
, putGnuDev 8 $ deviceMinor
, putString 155 $ prefix
, fill 12 $ '\NUL'
]
where
(typeCode, contentSize, linkTarget,
deviceMajor, deviceMinor) = case content of
NormalFile _ size -> ('0' , size, [], 0, 0)
Directory -> ('5' , 0, [], 0, 0)
SymbolicLink (LinkTarget link) -> ('2' , 0, link, 0, 0)
HardLink (LinkTarget link) -> ('1' , 0, link, 0, 0)
CharacterDevice major minor -> ('3' , 0, [], major, minor)
BlockDevice major minor -> ('4' , 0, [], major, minor)
NamedPipe -> ('6' , 0, [], 0, 0)
OtherEntryType code _ size -> (code, size, [], 0, 0)
putGnuDev w n = case content of
CharacterDevice _ _ -> putOct w n
BlockDevice _ _ -> putOct w n
_ -> replicate w '\NUL'
type FieldWidth = Int
putString :: FieldWidth -> String -> String
putString n s = take n s ++ fill (n length s) '\NUL'
putOct :: (Integral a, Show a) => FieldWidth -> a -> String
putOct n x =
let octStr = take (n1) $ showOct x ""
in fill (n length octStr 1) '0'
++ octStr
++ putChar8 '\NUL'
putChar8 :: Char -> String
putChar8 c = [c]
fill :: FieldWidth -> Char -> String
fill n c = replicate n c