-----------------------------------------------------------------------------
-- |
-- Module      :  Codec.Archive.Tar.Write
-- Copyright   :  (c) 2007 Bjorn Bringert,
--                    2008 Andrea Vezzosi,
--                    2008-2009 Duncan Coutts
-- License     :  BSD3
--
-- Maintainer  :  duncan@community.haskell.org
-- Portability :  portable
--
-----------------------------------------------------------------------------
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


-- | Create the external representation of a tar archive by serialising a list
-- of tar entries.
--
-- * The conversion is done lazily.
--
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 -> EntryContent
entryContent Entry
entry of
  NormalFile       ByteString
content Int64
size -> [ByteString] -> ByteString
LBS.concat [ ByteString
header, ByteString
content, Int64 -> ByteString
forall a. Integral a => a -> ByteString
padding Int64
size ]
  OtherEntryType TypeCode
_ ByteString
content Int64
size -> [ByteString] -> ByteString
LBS.concat [ ByteString
header, ByteString
content, Int64 -> ByteString
forall a. Integral a => a -> ByteString
padding Int64
size ]
  EntryContent
_                             -> ByteString
header
  where
    header :: ByteString
header       = Entry -> ByteString
putHeader Entry
entry
    padding :: a -> ByteString
padding a
size = Int64 -> Word8 -> ByteString
LBS.replicate Int64
paddingSize Word8
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` a
512)

putHeader :: Entry -> LBS.ByteString
putHeader :: Entry -> ByteString
putHeader Entry
entry =
     [TypeCode] -> ByteString
LBS.Char8.pack
   ([TypeCode] -> ByteString) -> [TypeCode] -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> [TypeCode] -> [TypeCode]
forall a. Int -> [a] -> [a]
take Int
148 [TypeCode]
block
  [TypeCode] -> [TypeCode] -> [TypeCode]
forall a. [a] -> [a] -> [a]
++ Int -> Int -> [TypeCode]
forall a. (Integral a, Show a) => Int -> a -> [TypeCode]
putOct Int
7 Int
checksum
  [TypeCode] -> [TypeCode] -> [TypeCode]
forall a. [a] -> [a] -> [a]
++ TypeCode
' ' TypeCode -> [TypeCode] -> [TypeCode]
forall a. a -> [a] -> [a]
: Int -> [TypeCode] -> [TypeCode]
forall a. Int -> [a] -> [a]
drop Int
156 [TypeCode]
block
--  ++ putOct 8 checksum
--  ++ drop 156 block
  where
    block :: [TypeCode]
block    = Entry -> [TypeCode]
putHeaderNoChkSum Entry
entry
    checksum :: Int
checksum = (Int -> TypeCode -> Int) -> Int -> [TypeCode] -> Int
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Int
x TypeCode
y -> Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ TypeCode -> Int
ord TypeCode
y) Int
0 [TypeCode]
block

putHeaderNoChkSum :: Entry -> String
putHeaderNoChkSum :: Entry -> [TypeCode]
putHeaderNoChkSum 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 -> Int64
entryTime        = Int64
modTime,
    entryFormat :: Entry -> Format
entryFormat      = Format
format
  } =

  [[TypeCode]] -> [TypeCode]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ Int -> ByteString -> [TypeCode]
putBString Int
100 (ByteString -> [TypeCode]) -> ByteString -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ ByteString
name
    , Int -> Permissions -> [TypeCode]
forall a. (Integral a, Show a) => Int -> a -> [TypeCode]
putOct       Int
8 (Permissions -> [TypeCode]) -> Permissions -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ Permissions
permissions
    , Int -> Int -> [TypeCode]
forall a. (Integral a, Show a) => Int -> a -> [TypeCode]
putOct       Int
8 (Int -> [TypeCode]) -> Int -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ Ownership -> Int
ownerId Ownership
ownership
    , Int -> Int -> [TypeCode]
forall a. (Integral a, Show a) => Int -> a -> [TypeCode]
putOct       Int
8 (Int -> [TypeCode]) -> Int -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ Ownership -> Int
groupId Ownership
ownership
    , Int -> Int64 -> [TypeCode]
forall a. (Integral a, Show a) => Int -> a -> [TypeCode]
putOct      Int
12 (Int64 -> [TypeCode]) -> Int64 -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ Int64
contentSize
    , Int -> Int64 -> [TypeCode]
forall a. (Integral a, Show a) => Int -> a -> [TypeCode]
putOct      Int
12 (Int64 -> [TypeCode]) -> Int64 -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ Int64
modTime
    , Int -> TypeCode -> [TypeCode]
fill         Int
8 (TypeCode -> [TypeCode]) -> TypeCode -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ TypeCode
' ' -- dummy checksum
    , TypeCode -> [TypeCode]
putChar8       (TypeCode -> [TypeCode]) -> TypeCode -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ TypeCode
typeCode
    , Int -> ByteString -> [TypeCode]
putBString Int
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    ->
      Int -> TypeCode -> [TypeCode]
fill Int
255 TypeCode
'\NUL'
  Format
UstarFormat -> [[TypeCode]] -> [TypeCode]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ Int -> ByteString -> [TypeCode]
putBString   Int
8 (ByteString -> [TypeCode]) -> ByteString -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ ByteString
ustarMagic
    , Int -> [TypeCode] -> [TypeCode]
putString   Int
32 ([TypeCode] -> [TypeCode]) -> [TypeCode] -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ Ownership -> [TypeCode]
ownerName Ownership
ownership
    , Int -> [TypeCode] -> [TypeCode]
putString   Int
32 ([TypeCode] -> [TypeCode]) -> [TypeCode] -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ Ownership -> [TypeCode]
groupName Ownership
ownership
    , Int -> Int -> [TypeCode]
forall a. (Integral a, Show a) => Int -> a -> [TypeCode]
putOct       Int
8 (Int -> [TypeCode]) -> Int -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ Int
deviceMajor
    , Int -> Int -> [TypeCode]
forall a. (Integral a, Show a) => Int -> a -> [TypeCode]
putOct       Int
8 (Int -> [TypeCode]) -> Int -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ Int
deviceMinor
    , Int -> ByteString -> [TypeCode]
putBString Int
155 (ByteString -> [TypeCode]) -> ByteString -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ ByteString
prefix
    , Int -> TypeCode -> [TypeCode]
fill        Int
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
    [ Int -> ByteString -> [TypeCode]
putBString   Int
8 (ByteString -> [TypeCode]) -> ByteString -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ ByteString
gnuMagic
    , Int -> [TypeCode] -> [TypeCode]
putString   Int
32 ([TypeCode] -> [TypeCode]) -> [TypeCode] -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ Ownership -> [TypeCode]
ownerName Ownership
ownership
    , Int -> [TypeCode] -> [TypeCode]
putString   Int
32 ([TypeCode] -> [TypeCode]) -> [TypeCode] -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ Ownership -> [TypeCode]
groupName Ownership
ownership
    , Int -> Int -> [TypeCode]
forall a. (Integral a, Show a) => Int -> a -> [TypeCode]
putGnuDev    Int
8 (Int -> [TypeCode]) -> Int -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ Int
deviceMajor
    , Int -> Int -> [TypeCode]
forall a. (Integral a, Show a) => Int -> a -> [TypeCode]
putGnuDev    Int
8 (Int -> [TypeCode]) -> Int -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ Int
deviceMinor
    , Int -> ByteString -> [TypeCode]
putBString Int
155 (ByteString -> [TypeCode]) -> ByteString -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ ByteString
prefix
    , Int -> TypeCode -> [TypeCode]
fill        Int
12 (TypeCode -> [TypeCode]) -> TypeCode -> [TypeCode]
forall a b. (a -> b) -> a -> b
$ TypeCode
'\NUL'
    ]
  where
    (TypeCode
typeCode, Int64
contentSize, ByteString
linkTarget,
     Int
deviceMajor, Int
deviceMinor) = case EntryContent
content of
       NormalFile      ByteString
_ Int64
size            -> (TypeCode
'0' , Int64
size, ByteString
forall a. Monoid a => a
mempty, Int
0,     Int
0)
       EntryContent
Directory                         -> (TypeCode
'5' , Int64
0,    ByteString
forall a. Monoid a => a
mempty, Int
0,     Int
0)
       SymbolicLink    (LinkTarget ByteString
link) -> (TypeCode
'2' , Int64
0,    ByteString
link,   Int
0,     Int
0)
       HardLink        (LinkTarget ByteString
link) -> (TypeCode
'1' , Int64
0,    ByteString
link,   Int
0,     Int
0)
       CharacterDevice Int
major Int
minor       -> (TypeCode
'3' , Int64
0,    ByteString
forall a. Monoid a => a
mempty, Int
major, Int
minor)
       BlockDevice     Int
major Int
minor       -> (TypeCode
'4' , Int64
0,    ByteString
forall a. Monoid a => a
mempty, Int
major, Int
minor)
       EntryContent
NamedPipe                         -> (TypeCode
'6' , Int64
0,    ByteString
forall a. Monoid a => a
mempty, Int
0,     Int
0)
       OtherEntryType  TypeCode
code ByteString
_ Int64
size       -> (TypeCode
code, Int64
size, ByteString
forall a. Monoid a => a
mempty, Int
0,     Int
0)

    putGnuDev :: Int -> a -> [TypeCode]
putGnuDev Int
w a
n = case EntryContent
content of
      CharacterDevice Int
_ Int
_ -> Int -> a -> [TypeCode]
forall a. (Integral a, Show a) => Int -> a -> [TypeCode]
putOct Int
w a
n
      BlockDevice     Int
_ Int
_ -> Int -> a -> [TypeCode]
forall a. (Integral a, Show a) => Int -> a -> [TypeCode]
putOct Int
w a
n
      EntryContent
_                   -> Int -> TypeCode -> [TypeCode]
forall a. Int -> a -> [a]
replicate Int
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"

-- * TAR format primitive output

type FieldWidth = Int

putBString :: FieldWidth -> BS.ByteString -> String
putBString :: Int -> ByteString -> [TypeCode]
putBString Int
n ByteString
s = ByteString -> [TypeCode]
BS.Char8.unpack (Int -> ByteString -> ByteString
BS.take Int
n ByteString
s) [TypeCode] -> [TypeCode] -> [TypeCode]
forall a. [a] -> [a] -> [a]
++ Int -> TypeCode -> [TypeCode]
fill (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- ByteString -> Int
BS.length ByteString
s) TypeCode
'\NUL'

putString :: FieldWidth -> String -> String
putString :: Int -> [TypeCode] -> [TypeCode]
putString Int
n [TypeCode]
s = Int -> [TypeCode] -> [TypeCode]
forall a. Int -> [a] -> [a]
take Int
n [TypeCode]
s [TypeCode] -> [TypeCode] -> [TypeCode]
forall a. [a] -> [a] -> [a]
++ Int -> TypeCode -> [TypeCode]
fill (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- [TypeCode] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TypeCode]
s) TypeCode
'\NUL'

--TODO: check integer widths, eg for large file sizes
putOct :: (Integral a, Show a) => FieldWidth -> a -> String
putOct :: Int -> a -> [TypeCode]
putOct Int
n a
x =
  let octStr :: [TypeCode]
octStr = Int -> [TypeCode] -> [TypeCode]
forall a. Int -> [a] -> [a]
take (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
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 Int -> TypeCode -> [TypeCode]
fill (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- [TypeCode] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TypeCode]
octStr Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
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 :: Int -> TypeCode -> [TypeCode]
fill Int
n TypeCode
c = Int -> TypeCode -> [TypeCode]
forall a. Int -> a -> [a]
replicate Int
n TypeCode
c