-----------------------------------------------------------------------------
-- |
-- 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 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
putHeader :: Entry -> ByteString
putHeader 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
--  ++ putOct 8 checksum
--  ++ drop 156 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
putHeaderNoChkSum :: Entry -> [Char]
putHeaderNoChkSum 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
$ ' ' -- dummy checksum
    , 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"

-- * TAR format primitive output

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'

--TODO: check integer widths, eg for large file sizes
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