{-# 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 =
     ByteString -> ByteString
LBS.fromStrict
   (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.take Int
148 ByteString
block
  ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Int -> Int -> ByteString
forall a. (Integral a, Show a) => Int -> a -> ByteString
putOct Int
7 Int
checksum
  ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Char -> ByteString -> ByteString
BS.Char8.cons Char
' ' (Int -> ByteString -> ByteString
BS.drop Int
156 ByteString
block)
  where
    block :: ByteString
block    = Entry -> ByteString
putHeaderNoChkSum Entry
entry
    checksum :: Int
checksum = (Int -> Char -> Int) -> Int -> ByteString -> Int
forall a. (a -> Char -> a) -> a -> ByteString -> a
BS.Char8.foldl' (\Int
x Char
y -> Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
ord Char
y) Int
0 ByteString
block

putHeaderNoChkSum :: Entry -> BS.ByteString
putHeaderNoChkSum :: Entry -> ByteString
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
  } =

  [ByteString] -> ByteString
BS.concat
    [ Int -> PosixString -> ByteString
putPosixString Int
100 PosixString
name
    , Int -> Permissions -> ByteString
forall a. (Integral a, Show a) => Int -> a -> ByteString
putOct       Int
8 Permissions
permissions
    , Int -> Int -> ByteString
forall a. (Integral a, Show a) => Int -> a -> ByteString
putOct       Int
8 (Int -> ByteString) -> Int -> ByteString
forall a b. (a -> b) -> a -> b
$ Ownership -> Int
ownerId Ownership
ownership
    , Int -> Int -> ByteString
forall a. (Integral a, Show a) => Int -> a -> ByteString
putOct       Int
8 (Int -> ByteString) -> Int -> ByteString
forall a b. (a -> b) -> a -> b
$ Ownership -> Int
groupId Ownership
ownership
    , Int -> Int64 -> ByteString
numField    Int
12 Int64
contentSize
    , Int -> Int64 -> ByteString
forall a. (Integral a, Show a) => Int -> a -> ByteString
putOct      Int
12 Int64
modTime
    , Int -> Char -> ByteString
BS.Char8.replicate Int
8 Char
' ' -- dummy checksum
    , Char -> ByteString
putChar8       Char
typeCode
    , Int -> PosixString -> ByteString
putPosixString Int
100 PosixString
linkTarget
    ] ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>
  case Format
format of
  Format
V7Format    ->
      Int -> Char -> ByteString
BS.Char8.replicate Int
255 Char
'\NUL'
  Format
UstarFormat -> [ByteString] -> ByteString
BS.Char8.concat
    [ Int -> ByteString -> ByteString
putBString   Int
8 ByteString
ustarMagic
    , Int -> [Char] -> ByteString
putString   Int
32 ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ Ownership -> [Char]
ownerName Ownership
ownership
    , Int -> [Char] -> ByteString
putString   Int
32 ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ Ownership -> [Char]
groupName Ownership
ownership
    , Int -> Int -> ByteString
forall a. (Integral a, Show a) => Int -> a -> ByteString
putOct       Int
8 Int
deviceMajor
    , Int -> Int -> ByteString
forall a. (Integral a, Show a) => Int -> a -> ByteString
putOct       Int
8 Int
deviceMinor
    , Int -> PosixString -> ByteString
putPosixString Int
155 PosixString
prefix
    , Int -> Char -> ByteString
BS.Char8.replicate   Int
12 Char
'\NUL'
    ]
  Format
GnuFormat -> [ByteString] -> ByteString
BS.Char8.concat
    [ Int -> ByteString -> ByteString
putBString   Int
8 ByteString
gnuMagic
    , Int -> [Char] -> ByteString
putString   Int
32 ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ Ownership -> [Char]
ownerName Ownership
ownership
    , Int -> [Char] -> ByteString
putString   Int
32 ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ Ownership -> [Char]
groupName Ownership
ownership
    , Int -> Int -> ByteString
forall a. (Integral a, Show a) => Int -> a -> ByteString
putGnuDev    Int
8 Int
deviceMajor
    , Int -> Int -> ByteString
forall a. (Integral a, Show a) => Int -> a -> ByteString
putGnuDev    Int
8 Int
deviceMinor
    , Int -> PosixString -> ByteString
putPosixString Int
155 PosixString
prefix
    , Int -> Char -> ByteString
BS.Char8.replicate   Int
12 Char
'\NUL'
    ]
  where
    numField :: FieldWidth -> Int64 -> BS.Char8.ByteString
    numField :: Int -> Int64 -> ByteString
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 -> ByteString
forall a. (Integral a, Show a) => Int -> a -> ByteString
putOct Int
w Int64
n
      | Bool
otherwise
      = Int -> Int64 -> ByteString
forall a. (Bits a, Integral a) => Int -> a -> ByteString
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 -> ByteString
putGnuDev Int
w a
n = case GenEntryContent LinkTarget
content of
      CharacterDevice Int
_ Int
_ -> Int -> a -> ByteString
forall a. (Integral a, Show a) => Int -> a -> ByteString
putOct Int
w a
n
      BlockDevice     Int
_ Int
_ -> Int -> a -> ByteString
forall a. (Integral a, Show a) => Int -> a -> ByteString
putOct Int
w a
n
      GenEntryContent LinkTarget
_                   -> Int -> Char -> ByteString
BS.Char8.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 -> BS.ByteString
putBString :: Int -> ByteString -> ByteString
putBString Int
n ByteString
s = Int -> ByteString -> ByteString
BS.take Int
n ByteString
s ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Int -> Char -> ByteString
BS.Char8.replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- ByteString -> Int
BS.length ByteString
s) Char
'\NUL'

putPosixString :: FieldWidth -> PosixString -> BS.ByteString
putPosixString :: Int -> PosixString -> ByteString
putPosixString Int
n PosixString
s = PosixString -> ByteString
posixToByteString (Int -> PosixString -> PosixString
PS.take Int
n PosixString
s) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Int -> Char -> ByteString
BS.Char8.replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- PosixString -> Int
PS.length PosixString
s) Char
'\NUL'

putString :: FieldWidth -> String -> BS.ByteString
putString :: Int -> [Char] -> ByteString
putString Int
n [Char]
s = Int -> ByteString -> ByteString
BS.take Int
n (HasCallStack => [Char] -> ByteString
[Char] -> ByteString
packAscii [Char]
s) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Int -> Char -> ByteString
BS.Char8.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 -> BS.ByteString #-}
putLarge :: (Bits a, Integral a) => FieldWidth -> a -> BS.ByteString
putLarge :: forall a. (Bits a, Integral a) => Int -> a -> ByteString
putLarge Int
n0 a
x0 = [Char] -> ByteString
BS.Char8.pack ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ 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 -> BS.ByteString
putOct :: forall a. (Integral a, Show a) => Int -> a -> ByteString
putOct Int
n a
x =
  let octStr :: ByteString
octStr = Int -> ByteString -> ByteString
BS.take (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString
BS.Char8.pack ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ a -> [Char] -> [Char]
forall a. Integral a => a -> [Char] -> [Char]
showOct a
x [Char]
""
   in Int -> Char -> ByteString
BS.Char8.replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- ByteString -> Int
BS.length ByteString
octStr Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Char
'0'
   ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
octStr
   ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Char -> ByteString
putChar8 Char
'\NUL'

putChar8 :: Char -> BS.ByteString
putChar8 :: Char -> ByteString
putChar8 = Char -> ByteString
BS.Char8.singleton