{-# LANGUAGE PackageImports #-}
{-# OPTIONS_HADDOCK hide #-}
-----------------------------------------------------------------------------
-- |
-- 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.PackAscii
import Codec.Archive.Tar.Types

import Data.Bits
import Data.Char     (chr,ord)
import Data.Int
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
import "os-string" System.OsString.Posix (PosixString)
import qualified "os-string" System.OsString.Posix as PS

-- | 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 -> GenEntryContent LinkTarget
forall tarPath linkTarget.
GenEntry tarPath linkTarget -> GenEntryContent linkTarget
entryContent Entry
entry of
  NormalFile       ByteString
content Int64
size
    -- size field is 12 bytes long, so in octal format (see 'putOct')
    -- it can hold numbers up to 8Gb
    | Int64
size Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Int64
1 Int64 -> Int -> Int64
forall a. Bits a => a -> Int -> a
`shiftL` (Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
12 Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1))
    , Entry -> Format
forall tarPath linkTarget. GenEntry tarPath linkTarget -> Format
entryFormat Entry
entry Format -> Format -> Bool
forall a. Eq a => a -> a -> Bool
== Format
V7Format
    -> [Char] -> ByteString
forall a. HasCallStack => [Char] -> a
error [Char]
"putEntry: support for files over 8Gb is a Ustar extension"
    | Bool
otherwise -> [ByteString] -> ByteString
LBS.concat [ ByteString
header, ByteString
content, Int64 -> ByteString
forall {p}. Integral p => p -> ByteString
padding Int64
size ]
  OtherEntryType Char
'K' ByteString
_ Int64
_
    | Entry -> Format
forall tarPath linkTarget. GenEntry tarPath linkTarget -> Format
entryFormat Entry
entry Format -> Format -> Bool
forall a. Eq a => a -> a -> Bool
/= Format
GnuFormat -> [Char] -> ByteString
forall a. HasCallStack => [Char] -> a
error [Char]
"putEntry: long symlink support is a GNU extension"
  OtherEntryType Char
'L' ByteString
_ Int64
_
    | Entry -> Format
forall tarPath linkTarget. GenEntry tarPath linkTarget -> Format
entryFormat Entry
entry Format -> Format -> Bool
forall a. Eq a => a -> a -> Bool
/= Format
GnuFormat -> [Char] -> ByteString
forall a. HasCallStack => [Char] -> a
error [Char]
"putEntry: long filename support is a GNU extension"
  OtherEntryType Char
_ ByteString
content Int64
size -> [ByteString] -> ByteString
LBS.concat [ ByteString
header, ByteString
content, Int64 -> ByteString
forall {p}. Integral p => p -> ByteString
padding Int64
size ]
  GenEntryContent LinkTarget
_                             -> ByteString
header
  where
    header :: ByteString
header       = Entry -> ByteString
putHeader Entry
entry
    padding :: p -> ByteString
padding p
size = Int64 -> Word8 -> ByteString
LBS.replicate Int64
paddingSize Word8
0
      where paddingSize :: Int64
paddingSize = p -> Int64
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 =
     [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 Int
148 [Char]
block
  [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> Int -> [Char]
forall a. (Integral a, Show a) => Int -> a -> [Char]
putOct Int
7 Int
checksum
  [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Char
' ' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop Int
156 [Char]
block
  where
    block :: [Char]
block    = Entry -> [Char]
putHeaderNoChkSum Entry
entry
    checksum :: Int
checksum = (Int -> Char -> Int) -> Int -> [Char] -> Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Int
x Char
y -> Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
ord Char
y) Int
0 [Char]
block

putHeaderNoChkSum :: Entry -> String
putHeaderNoChkSum :: Entry -> [Char]
putHeaderNoChkSum Entry {
    entryTarPath :: forall tarPath linkTarget. GenEntry tarPath linkTarget -> tarPath
entryTarPath     = TarPath PosixString
name PosixString
prefix,
    entryContent :: forall tarPath linkTarget.
GenEntry tarPath linkTarget -> GenEntryContent linkTarget
entryContent     = GenEntryContent LinkTarget
content,
    entryPermissions :: forall tarPath linkTarget.
GenEntry tarPath linkTarget -> Permissions
entryPermissions = Permissions
permissions,
    entryOwnership :: forall tarPath linkTarget. GenEntry tarPath linkTarget -> Ownership
entryOwnership   = Ownership
ownership,
    entryTime :: forall tarPath linkTarget. GenEntry tarPath linkTarget -> Int64
entryTime        = Int64
modTime,
    entryFormat :: forall tarPath linkTarget. GenEntry tarPath linkTarget -> Format
entryFormat      = Format
format
  } =

  [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ Int -> PosixString -> [Char]
putPosixString Int
100 PosixString
name
    , Int -> Permissions -> [Char]
forall a. (Integral a, Show a) => Int -> a -> [Char]
putOct       Int
8 Permissions
permissions
    , Int -> Int -> [Char]
forall a. (Integral a, Show a) => Int -> a -> [Char]
putOct       Int
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       Int
8 (Int -> [Char]) -> Int -> [Char]
forall a b. (a -> b) -> a -> b
$ Ownership -> Int
groupId Ownership
ownership
    , Int -> Int64 -> [Char]
numField    Int
12 Int64
contentSize
    , Int -> Int64 -> [Char]
forall a. (Integral a, Show a) => Int -> a -> [Char]
putOct      Int
12 Int64
modTime
    , Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate    Int
8 Char
' ' -- dummy checksum
    , Char -> [Char]
putChar8       Char
typeCode
    , Int -> PosixString -> [Char]
putPosixString Int
100 PosixString
linkTarget
    ] [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
  case Format
format of
  Format
V7Format    ->
      Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate Int
255 Char
'\NUL'
  Format
UstarFormat -> [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ Int -> ByteString -> [Char]
putBString   Int
8 ByteString
ustarMagic
    , Int -> [Char] -> [Char]
putString   Int
32 ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ Ownership -> [Char]
ownerName Ownership
ownership
    , Int -> [Char] -> [Char]
putString   Int
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       Int
8 Int
deviceMajor
    , Int -> Int -> [Char]
forall a. (Integral a, Show a) => Int -> a -> [Char]
putOct       Int
8 Int
deviceMinor
    , Int -> PosixString -> [Char]
putPosixString Int
155 PosixString
prefix
    , Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate   Int
12 Char
'\NUL'
    ]
  Format
GnuFormat -> [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ Int -> ByteString -> [Char]
putBString   Int
8 ByteString
gnuMagic
    , Int -> [Char] -> [Char]
putString   Int
32 ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ Ownership -> [Char]
ownerName Ownership
ownership
    , Int -> [Char] -> [Char]
putString   Int
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    Int
8 Int
deviceMajor
    , Int -> Int -> [Char]
forall a. (Integral a, Show a) => Int -> a -> [Char]
putGnuDev    Int
8 Int
deviceMinor
    , Int -> PosixString -> [Char]
putPosixString Int
155 PosixString
prefix
    , Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate   Int
12 Char
'\NUL'
    ]
  where
    numField :: FieldWidth -> Int64 -> String
    numField :: Int -> Int64 -> [Char]
numField Int
w Int64
n
      | Int64
n Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Int64
0 Bool -> Bool -> Bool
&& Int64
n Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64
1 Int64 -> Int -> Int64
forall a. Bits a => a -> Int -> a
`shiftL` (Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
      = Int -> Int64 -> [Char]
forall a. (Integral a, Show a) => Int -> a -> [Char]
putOct Int
w Int64
n
      | Bool
otherwise
      = Int -> Int64 -> [Char]
forall a. (Bits a, Integral a) => Int -> a -> [Char]
putLarge Int
w Int64
n

    (Char
typeCode, Int64
contentSize, PosixString
linkTarget,
     Int
deviceMajor, Int
deviceMinor) = case GenEntryContent LinkTarget
content of
       NormalFile      ByteString
_ Int64
size            -> (Char
'0' , Int64
size, PosixString
forall a. Monoid a => a
mempty, Int
0,     Int
0)
       GenEntryContent LinkTarget
Directory                         -> (Char
'5' , Int64
0,    PosixString
forall a. Monoid a => a
mempty, Int
0,     Int
0)
       SymbolicLink    (LinkTarget PosixString
link) -> (Char
'2' , Int64
0,    PosixString
link,   Int
0,     Int
0)
       HardLink        (LinkTarget PosixString
link) -> (Char
'1' , Int64
0,    PosixString
link,   Int
0,     Int
0)
       CharacterDevice Int
major Int
minor       -> (Char
'3' , Int64
0,    PosixString
forall a. Monoid a => a
mempty, Int
major, Int
minor)
       BlockDevice     Int
major Int
minor       -> (Char
'4' , Int64
0,    PosixString
forall a. Monoid a => a
mempty, Int
major, Int
minor)
       GenEntryContent LinkTarget
NamedPipe                         -> (Char
'6' , Int64
0,    PosixString
forall a. Monoid a => a
mempty, Int
0,     Int
0)
       OtherEntryType  Char
code ByteString
_ Int64
size       -> (Char
code, Int64
size, PosixString
forall a. Monoid a => a
mempty, Int
0,     Int
0)

    putGnuDev :: Int -> a -> [Char]
putGnuDev Int
w a
n = case GenEntryContent LinkTarget
content of
      CharacterDevice Int
_ Int
_ -> Int -> a -> [Char]
forall a. (Integral a, Show a) => Int -> a -> [Char]
putOct Int
w a
n
      BlockDevice     Int
_ Int
_ -> Int -> a -> [Char]
forall a. (Integral a, Show a) => Int -> a -> [Char]
putOct Int
w a
n
      GenEntryContent LinkTarget
_                   -> Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate Int
w Char
'\NUL'

ustarMagic, gnuMagic :: BS.ByteString
ustarMagic :: ByteString
ustarMagic = [Char] -> ByteString
BS.Char8.pack [Char]
"ustar\NUL00"
gnuMagic :: ByteString
gnuMagic   = [Char] -> ByteString
BS.Char8.pack [Char]
"ustar  \NUL"

-- * TAR format primitive output

type FieldWidth = Int

putBString :: FieldWidth -> BS.ByteString -> String
putBString :: Int -> ByteString -> [Char]
putBString Int
n 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]
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- ByteString -> Int
BS.length ByteString
s) Char
'\NUL'

putPosixString :: FieldWidth -> PosixString -> String
putPosixString :: Int -> PosixString -> [Char]
putPosixString Int
n PosixString
s = PosixString -> [Char]
fromPosixString (Int -> PosixString -> PosixString
PS.take Int
n PosixString
s) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- PosixString -> Int
PS.length PosixString
s) Char
'\NUL'

putString :: FieldWidth -> String -> String
putString :: Int -> [Char] -> [Char]
putString Int
n [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]
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
s) Char
'\NUL'

{-# SPECIALISE putLarge :: FieldWidth -> Int64 -> String #-}
putLarge :: (Bits a, Integral a) => FieldWidth -> a -> String
putLarge :: forall a. (Bits a, Integral a) => Int -> a -> [Char]
putLarge Int
n0 a
x0 = Char
'\x80' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char] -> [Char]
forall a. [a] -> [a]
reverse (Int -> a -> [Char]
forall {t} {t}.
(Integral t, Bits t, Num t, Eq t) =>
t -> t -> [Char]
go (Int
n0Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) a
x0)
  where go :: t -> t -> [Char]
go t
0 t
_ = []
        go t
n t
x = Int -> Char
chr (t -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (t
x t -> t -> t
forall a. Bits a => a -> a -> a
.&. t
0xff)) Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: t -> t -> [Char]
go (t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1) (t
x t -> Int -> t
forall a. Bits a => a -> Int -> a
`shiftR` Int
8)

putOct :: (Integral a, Show a) => FieldWidth -> a -> String
putOct :: forall a. (Integral a, Show a) => Int -> a -> [Char]
putOct Int
n 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
-Int
1) ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ a -> [Char] -> [Char]
forall a. Integral a => a -> [Char] -> [Char]
showOct a
x [Char]
""
   in Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
octStr Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Char
'0'
   [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
octStr
   [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Char -> [Char]
putChar8 Char
'\NUL'

putChar8 :: Char -> String
putChar8 :: Char -> [Char]
putChar8 Char
c = [Char
c]