-----------------------------------------------------------------------------
-- |
-- 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]
++ [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
putHeader :: Entry -> ByteString
putHeader 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
--  ++ putOct 8 checksum
--  ++ drop 156 block
  where
    block :: [TypeCode]
block    = Entry -> [TypeCode]
putHeaderNoChkSum Entry
entry
    checksum :: FieldWidth
checksum = (FieldWidth -> TypeCode -> FieldWidth)
-> FieldWidth -> [TypeCode] -> FieldWidth
forall b a. (b -> a -> b) -> b -> [a] -> b
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
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 -> 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
' ' -- dummy checksum
    , 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"

-- * TAR format primitive output

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 a. [a] -> FieldWidth
forall (t :: * -> *) a. Foldable t => t a -> FieldWidth
length [TypeCode]
s) TypeCode
'\NUL'

--TODO: check integer widths, eg for large file sizes
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 => 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 a. [a] -> 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