    -----------------------------------------------------------------------------
    -- |
    -- 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