-----------------------------------------------------------------------------
-- |
-- 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 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
putHeader :: Entry -> ByteString
putHeader 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
--  ++ putOct 8 checksum
--  ++ drop 156 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
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
  } =

  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
' ' -- dummy checksum
    , 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"

-- * 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) 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'

--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 = 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