    -----------------------------------------------------------------------------
    -- |
    -- 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 ([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]
    ++ [FileSize -> Word8 -> ByteString
    LBS.replicate (FileSize
    512FileSize -> FileSize -> FileSize
    forall 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, FileSize -> ByteString
    forall {p}. Integral p => p -> ByteString
    padding FileSize
    size ]
      OtherEntryType TypeCode
    _ ByteString
    content FileSize
    size -> [ByteString] -> ByteString
    LBS.concat [ ByteString
    header, ByteString
    content, FileSize -> ByteString
    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 = p -> FileSize
    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 =
         [TypeCode] -> ByteString
    LBS.Char8.pack
       ([TypeCode] -> ByteString) -> [TypeCode] -> ByteString
    forall a b. (a -> b) -> a -> b
    $ FieldWidth -> [TypeCode] -> [TypeCode]
    forall a. FieldWidth -> [a] -> [a]
    take FieldWidth
    148 [TypeCode]
    block
      [TypeCode] -> [TypeCode] -> [TypeCode]
    forall a. [a] -> [a] -> [a]
    ++ FieldWidth -> FieldWidth -> [TypeCode]
    forall a. (Integral a, Show a) => FieldWidth -> a -> [TypeCode]
    putOct FieldWidth
    7 FieldWidth
    checksum
      [TypeCode] -> [TypeCode] -> [TypeCode]
    forall a. [a] -> [a] -> [a]
    ++ TypeCode
    ' ' TypeCode -> [TypeCode] -> [TypeCode]
    forall a. a -> [a] -> [a]
    : FieldWidth -> [TypeCode] -> [TypeCode]
    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 = (FieldWidth -> TypeCode -> FieldWidth)
    -> FieldWidth -> [TypeCode] -> FieldWidth
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' (\FieldWidth
    x TypeCode
    y -> FieldWidth
    x FieldWidth -> FieldWidth -> FieldWidth
    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
      } =

      [[TypeCode]] -> [TypeCode]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat
        [ FieldWidth -> ByteString -> [TypeCode]
    putBString FieldWidth
    100 (ByteString -> [TypeCode]) -> ByteString -> [TypeCode]
    forall a b. (a -> b) -> a -> b
    $ ByteString
    name
        , FieldWidth -> Permissions -> [TypeCode]
    forall a. (Integral a, Show a) => FieldWidth -> a -> [TypeCode]
    putOct       FieldWidth
    8 (Permissions -> [TypeCode]) -> Permissions -> [TypeCode]
    forall a b. (a -> b) -> a -> b
    $ Permissions
    permissions
        , FieldWidth -> FieldWidth -> [TypeCode]
    forall a. (Integral a, Show a) => FieldWidth -> a -> [TypeCode]
    putOct       FieldWidth
    8 (FieldWidth -> [TypeCode]) -> FieldWidth -> [TypeCode]
    forall a b. (a -> b) -> a -> b
    $ Ownership -> FieldWidth
    ownerId Ownership
    ownership
        , FieldWidth -> FieldWidth -> [TypeCode]
    forall a. (Integral a, Show a) => FieldWidth -> a -> [TypeCode]
    putOct       FieldWidth
    8 (FieldWidth -> [TypeCode]) -> FieldWidth -> [TypeCode]
    forall a b. (a -> b) -> a -> b
    $ Ownership -> FieldWidth
    groupId Ownership
    ownership
        , FieldWidth -> FileSize -> [TypeCode]
    forall a. (Integral a, Show a) => FieldWidth -> a -> [TypeCode]
    putOct      FieldWidth
    12 (FileSize -> [TypeCode]) -> FileSize -> [TypeCode]
    forall a b. (a -> b) -> a -> b
    $ FileSize
    contentSize
        , FieldWidth -> FileSize -> [TypeCode]
    forall a. (Integral a, Show a) => FieldWidth -> a -> [TypeCode]
    putOct      FieldWidth
    12 (FileSize -> [TypeCode]) -> FileSize -> [TypeCode]
    forall a b. (a -> b) -> a -> b
    $ FileSize
    modTime
        , FieldWidth -> TypeCode -> [TypeCode]
    fill         FieldWidth
    8 (TypeCode -> [TypeCode]) -> TypeCode -> [TypeCode]
    forall a b. (a -> b) -> a -> b
    $ TypeCode
    ' ' -- dummy checksum
        , TypeCode -> [TypeCode]
    putChar8       (TypeCode -> [TypeCode]) -> TypeCode -> [TypeCode]
    forall a b. (a -> b) -> a -> b
    $ TypeCode
    typeCode
        , FieldWidth -> ByteString -> [TypeCode]
    putBString FieldWidth
    100 (ByteString -> [TypeCode]) -> ByteString -> [TypeCode]
    forall a b. (a -> b) -> a -> b
    $ ByteString
    linkTarget
        ] [TypeCode] -> [TypeCode] -> [TypeCode]
    forall a. [a] -> [a] -> [a]
    ++
      case Format
    format of
      Format
    V7Format    ->
          FieldWidth -> TypeCode -> [TypeCode]
    fill FieldWidth
    255 TypeCode
    '\NUL'
      Format
    UstarFormat -> [[TypeCode]] -> [TypeCode]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat
        [ FieldWidth -> ByteString -> [TypeCode]
    putBString   FieldWidth
    8 (ByteString -> [TypeCode]) -> ByteString -> [TypeCode]
    forall a b. (a -> b) -> a -> b
    $ ByteString
    ustarMagic
        , FieldWidth -> [TypeCode] -> [TypeCode]
    putString   FieldWidth
    32 ([TypeCode] -> [TypeCode]) -> [TypeCode] -> [TypeCode]
    forall a b. (a -> b) -> a -> b
    $ Ownership -> [TypeCode]
    ownerName Ownership
    ownership
        , FieldWidth -> [TypeCode] -> [TypeCode]
    putString   FieldWidth
    32 ([TypeCode] -> [TypeCode]) -> [TypeCode] -> [TypeCode]
    forall a b. (a -> b) -> a -> b
    $ Ownership -> [TypeCode]
    groupName Ownership
    ownership
        , FieldWidth -> FieldWidth -> [TypeCode]
    forall a. (Integral a, Show a) => FieldWidth -> a -> [TypeCode]
    putOct       FieldWidth
    8 (FieldWidth -> [TypeCode]) -> FieldWidth -> [TypeCode]
    forall a b. (a -> b) -> a -> b
    $ FieldWidth
    deviceMajor
        , FieldWidth -> FieldWidth -> [TypeCode]
    forall a. (Integral a, Show a) => FieldWidth -> a -> [TypeCode]
    putOct       FieldWidth
    8 (FieldWidth -> [TypeCode]) -> FieldWidth -> [TypeCode]
    forall a b. (a -> b) -> a -> b
    $ FieldWidth
    deviceMinor
        , FieldWidth -> ByteString -> [TypeCode]
    putBString FieldWidth
    155 (ByteString -> [TypeCode]) -> ByteString -> [TypeCode]
    forall a b. (a -> b) -> a -> b
    $ ByteString
    prefix
        , FieldWidth -> TypeCode -> [TypeCode]
    fill        FieldWidth
    12 (TypeCode -> [TypeCode]) -> TypeCode -> [TypeCode]
    forall a b. (a -> b) -> a -> b
    $ TypeCode
    '\NUL'
        ]
      Format
    GnuFormat -> [[TypeCode]] -> [TypeCode]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat
        [ FieldWidth -> ByteString -> [TypeCode]
    putBString   FieldWidth
    8 (ByteString -> [TypeCode]) -> ByteString -> [TypeCode]
    forall a b. (a -> b) -> a -> b
    $ ByteString
    gnuMagic
        , FieldWidth -> [TypeCode] -> [TypeCode]
    putString   FieldWidth
    32 ([TypeCode] -> [TypeCode]) -> [TypeCode] -> [TypeCode]
    forall a b. (a -> b) -> a -> b
    $ Ownership -> [TypeCode]
    ownerName Ownership
    ownership
        , FieldWidth -> [TypeCode] -> [TypeCode]
    putString   FieldWidth
    32 ([TypeCode] -> [TypeCode]) -> [TypeCode] -> [TypeCode]
    forall a b. (a -> b) -> a -> b
    $ Ownership -> [TypeCode]
    groupName Ownership
    ownership
        , FieldWidth -> FieldWidth -> [TypeCode]
    forall a. (Integral a, Show a) => FieldWidth -> a -> [TypeCode]
    putGnuDev    FieldWidth
    8 (FieldWidth -> [TypeCode]) -> FieldWidth -> [TypeCode]
    forall a b. (a -> b) -> a -> b
    $ FieldWidth
    deviceMajor
        , FieldWidth -> FieldWidth -> [TypeCode]
    forall a. (Integral a, Show a) => FieldWidth -> a -> [TypeCode]
    putGnuDev    FieldWidth
    8 (FieldWidth -> [TypeCode]) -> FieldWidth -> [TypeCode]
    forall a b. (a -> b) -> a -> b
    $ FieldWidth
    deviceMinor
        , FieldWidth -> ByteString -> [TypeCode]
    putBString FieldWidth
    155 (ByteString -> [TypeCode]) -> ByteString -> [TypeCode]
    forall a b. (a -> b) -> a -> b
    $ ByteString
    prefix
        , FieldWidth -> TypeCode -> [TypeCode]
    fill        FieldWidth
    12 (TypeCode -> [TypeCode]) -> TypeCode -> [TypeCode]
    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, ByteString
    forall a. Monoid a => a
    mempty, FieldWidth
    0,     FieldWidth
    0)
           EntryContent
    Directory                         -> (TypeCode
    '5' , FileSize
    0,    ByteString
    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,    ByteString
    forall a. Monoid a => a
    mempty, FieldWidth
    major, FieldWidth
    minor)
           BlockDevice     FieldWidth
    major FieldWidth
    minor       -> (TypeCode
    '4' , FileSize
    0,    ByteString
    forall a. Monoid a => a
    mempty, FieldWidth
    major, FieldWidth
    minor)
           EntryContent
    NamedPipe                         -> (TypeCode
    '6' , FileSize
    0,    ByteString
    forall a. Monoid a => a
    mempty, FieldWidth
    0,     FieldWidth
    0)
           OtherEntryType  TypeCode
    code ByteString
    _ FileSize
    size       -> (TypeCode
    code, FileSize
    size, ByteString
    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
    _ -> FieldWidth -> a -> [TypeCode]
    forall a. (Integral a, Show a) => FieldWidth -> a -> [TypeCode]
    putOct FieldWidth
    w a
    n
          BlockDevice     FieldWidth
    _ FieldWidth
    _ -> FieldWidth -> a -> [TypeCode]
    forall a. (Integral a, Show a) => FieldWidth -> a -> [TypeCode]
    putOct FieldWidth
    w a
    n
          EntryContent
    _                   -> FieldWidth -> TypeCode -> [TypeCode]
    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) [TypeCode] -> [TypeCode] -> [TypeCode]
    forall a. [a] -> [a] -> [a]
    ++ FieldWidth -> TypeCode -> [TypeCode]
    fill (FieldWidth
    n FieldWidth -> FieldWidth -> FieldWidth
    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 = FieldWidth -> [TypeCode] -> [TypeCode]
    forall a. FieldWidth -> [a] -> [a]
    take FieldWidth
    n [TypeCode]
    s [TypeCode] -> [TypeCode] -> [TypeCode]
    forall a. [a] -> [a] -> [a]
    ++ FieldWidth -> TypeCode -> [TypeCode]
    fill (FieldWidth
    n FieldWidth -> FieldWidth -> FieldWidth
    forall a. Num a => a -> a -> a
    - [TypeCode] -> FieldWidth
    forall a. [a] -> FieldWidth
    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 = FieldWidth -> [TypeCode] -> [TypeCode]
    forall a. FieldWidth -> [a] -> [a]
    take (FieldWidth
    nFieldWidth -> FieldWidth -> FieldWidth
    forall a. Num a => a -> a -> a
    -FieldWidth
    1) ([TypeCode] -> [TypeCode]) -> [TypeCode] -> [TypeCode]
    forall a b. (a -> b) -> a -> b
    $ a -> [TypeCode] -> [TypeCode]
    forall a. Integral a => a -> [TypeCode] -> [TypeCode]
    showOct a
    x [TypeCode]
    ""
       in FieldWidth -> TypeCode -> [TypeCode]
    fill (FieldWidth
    n FieldWidth -> FieldWidth -> FieldWidth
    forall a. Num a => a -> a -> a
    - [TypeCode] -> FieldWidth
    forall a. [a] -> FieldWidth
    forall (t :: * -> *) a. Foldable t => t a -> FieldWidth
    length [TypeCode]
    octStr FieldWidth -> FieldWidth -> FieldWidth
    forall a. Num a => a -> a -> a
    - FieldWidth
    1) TypeCode
    '0'
       [TypeCode] -> [TypeCode] -> [TypeCode]
    forall a. [a] -> [a] -> [a]
    ++ [TypeCode]
    octStr
       [TypeCode] -> [TypeCode] -> [TypeCode]
    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 = FieldWidth -> TypeCode -> [TypeCode]
    forall a. FieldWidth -> a -> [a]
    replicate FieldWidth
    n TypeCode
    c