-----------------------------------------------------------------------------

-- |

-- 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 es = LBS.concat $ map putEntry es ++ [LBS.replicate (512*2) 0]

putEntry :: Entry -> LBS.ByteString

putEntry entry = case entryContent entry of

  NormalFile       content size -> LBS.concat [ header, content, padding size ]

  OtherEntryType _ content size -> LBS.concat [ header, content, padding size ]

  _                             -> header

  where

    header       = putHeader entry

    padding size = LBS.replicate paddingSize 0

      where paddingSize = fromIntegral (negate size `mod` 512)

putHeader :: Entry -> LBS.ByteString

putHeader entry =

     LBS.Char8.pack

   $ take 148 block

  ++ putOct 7 checksum

  ++ ' ' : drop 156 block

--  ++ putOct 8 checksum

--  ++ drop 156 block

  where

    block    = putHeaderNoChkSum entry

    checksum = foldl' (\x y -> x + ord y) 0 block

putHeaderNoChkSum :: Entry -> String

putHeaderNoChkSum Entry {

    entryTarPath     = TarPath name prefix,

    entryContent     = content,

    entryPermissions = permissions,

    entryOwnership   = ownership,

    entryTime        = modTime,

    entryFormat      = format

  } =

  concat

    [ putBString 100 $ name

    , putOct       8 $ permissions

    , putOct       8 $ ownerId ownership

    , putOct       8 $ groupId ownership

    , putOct      12 $ contentSize

    , putOct      12 $ modTime

    , fill         8 $ ' ' -- dummy checksum

    , putChar8       $ typeCode

    , putBString 100 $ linkTarget

    ] ++

  case format of

  V7Format    ->

      fill 255 '\NUL'

  UstarFormat -> concat

    [ putBString   8 $ ustarMagic

    , putString   32 $ ownerName ownership

    , putString   32 $ groupName ownership

    , putOct       8 $ deviceMajor

    , putOct       8 $ deviceMinor

    , putBString 155 $ prefix

    , fill        12 $ '\NUL'

    ]

  GnuFormat -> concat

    [ putBString   8 $ gnuMagic

    , putString   32 $ ownerName ownership

    , putString   32 $ groupName ownership

    , putGnuDev    8 $ deviceMajor

    , putGnuDev    8 $ deviceMinor

    , putBString 155 $ prefix

    , fill        12 $ '\NUL'

    ]

  where

    (typeCode, contentSize, linkTarget,

     deviceMajor, deviceMinor) = case content of

       NormalFile      _ size            -> ('0' , size, mempty, 0,     0)

       Directory                         -> ('5' , 0,    mempty, 0,     0)

       SymbolicLink    (LinkTarget link) -> ('2' , 0,    link,   0,     0)

       HardLink        (LinkTarget link) -> ('1' , 0,    link,   0,     0)

       CharacterDevice major minor       -> ('3' , 0,    mempty, major, minor)

       BlockDevice     major minor       -> ('4' , 0,    mempty, major, minor)

       NamedPipe                         -> ('6' , 0,    mempty, 0,     0)

       OtherEntryType  code _ size       -> (code, size, mempty, 0,     0)

    putGnuDev w n = case content of

      CharacterDevice _ _ -> putOct w n

      BlockDevice     _ _ -> putOct w n

      _                   -> replicate w '\NUL'

ustarMagic, gnuMagic :: BS.ByteString

ustarMagic = BS.Char8.pack "ustar\NUL00"

gnuMagic   = BS.Char8.pack "ustar  \NUL"

-- * TAR format primitive output

type FieldWidth = Int

putBString :: FieldWidth -> BS.ByteString -> String

putBString n s = BS.Char8.unpack (BS.take n s) ++ fill (n - BS.length s) '\NUL'

putString :: FieldWidth -> String -> String

putString n s = take n s ++ fill (n - length s) '\NUL'

--TODO: check integer widths, eg for large file sizes

putOct :: (Integral a, Show a) => FieldWidth -> a -> String

putOct n x =

  let octStr = take (n-1) $ showOct x ""

   in fill (n - length octStr - 1) '0'

   ++ octStr

   ++ putChar8 '\NUL'

putChar8 :: Char -> String

putChar8 c = [c]

fill :: FieldWidth -> Char -> String

fill n c = replicate n c