    {-# 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
    <> Word8 -> ByteString -> ByteString
    BS.cons Word8
    0x20 (Int -> ByteString -> ByteString
    BS.drop Int
    156 ByteString
    block)
      where
        block :: ByteString
    block    = Entry -> ByteString
    putHeaderNoChkSum Entry
    entry
        checksum :: Int
        checksum :: Int
    checksum = (Int -> Word8 -> Int) -> Int -> ByteString -> Int
    forall a. (a -> Word8 -> a) -> a -> ByteString -> a
    BS.foldl' (\Int
    x Word8
    y -> Int
    x Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Word8 -> Int
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Word8
    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 -> Word8 -> ByteString
    BS.replicate Int
    8 Word8
    0x20 -- 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 -> Word8 -> ByteString
    BS.replicate Int
    255 Word8
    0x00
      Format
    UstarFormat -> [ByteString] -> ByteString
    BS.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 -> Word8 -> ByteString
    BS.replicate   Int
    12 Word8
    0x00
        ]
      Format
    GnuFormat -> [ByteString] -> ByteString
    BS.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 -> Word8 -> ByteString
    BS.replicate   Int
    12 Word8
    0x00
        ]
      where
        numField :: FieldWidth -> Int64 -> BS.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 -> Word8 -> ByteString
    BS.replicate Int
    w Word8
    0x00

    ustarMagic, gnuMagic :: BS.ByteString
    ustarMagic :: ByteString
    ustarMagic = [Word8] -> ByteString
    BS.pack [Word8
    0x75, Word8
    0x73, Word8
    0x74, Word8
    0x61, Word8
    0x72, Word8
    0x00, Word8
    0x30, Word8
    0x30]  -- ustar\NUL00
    gnuMagic :: ByteString
    gnuMagic   = [Word8] -> ByteString
    BS.pack [Word8
    0x75, Word8
    0x73, Word8
    0x74, Word8
    0x61, Word8
    0x72, Word8
    0x20, Word8
    0x20, Word8
    0x00]  -- 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 -> Word8 -> ByteString
    BS.replicate (Int
    n Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - ByteString -> Int
    BS.length ByteString
    s) Word8
    0x00

    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 -> Word8 -> ByteString
    BS.replicate (Int
    n Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - PosixString -> Int
    PS.length PosixString
    s) Word8
    0x00

    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 -> Word8 -> ByteString
    BS.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) Word8
    0x00

    {-# 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 -> Word8 -> ByteString
    BS.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) Word8
    0x30
       ByteString -> ByteString -> ByteString
    forall a. Semigroup a => a -> a -> a
    <> ByteString
    octStr
       ByteString -> ByteString -> ByteString
    forall a. Semigroup a => a -> a -> a
    <> Word8 -> ByteString
    BS.singleton Word8
    0x00

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