-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Machine.Codec.Tar.Write
-- Copyright   :  (c) 2007 Bjorn Bringert,
--                    2008 Andrea Vezzosi,
--                    2008-2009 Duncan Coutts
--                    2019 davean
-- License     :  BSD3
--
-- Maintainer  :  davean
-- Portability :  portable
--
-----------------------------------------------------------------------------
module Data.Machine.Codec.Tar.Write (write) where

import qualified Data.ByteString             as BS
import qualified Data.ByteString.Builder     as BB
import qualified Data.ByteString.Char8       as BS.Char8
import qualified Data.ByteString.Lazy        as BL
import Data.Char     (ord)
import Data.List     (foldl')
import Data.Machine
import Data.Machine.Codec.Tar.Types
import Data.Monoid   (mempty)
import Data.Semigroup
import Numeric       (showOct)

-- | Create the external representation of a tar archive by serialising a list
--   of tar entries. One builder is produced per Entry.
write :: Monad m => ProcessT m Entry BB.Builder
write = (auto putEntry) <> (source [BB.byteString $ BS.replicate (512*2) 0])

putEntry :: Entry -> BB.Builder
putEntry entry =
  case entryContent entry of
    NormalFile       content size -> mconcat [ header, BB.lazyByteString content, padding size ]
    OtherEntryType _ content size -> mconcat [ header, BB.lazyByteString content, padding size ]
    _                             -> header
  where
    header       = putHeader entry
    padding size = nullFill paddingSize
      where paddingSize = fromIntegral (negate size `mod` 512)

putHeader :: Entry -> BB.Builder
putHeader entry = mconcat
   [ BB.lazyByteString $ BL.take 148 block
   , putOct 7 checksum
   , BB.char7 ' ', BB.lazyByteString $ BL.drop 156 block
   ]
  where
    block    = BB.toLazyByteString $ putHeaderNoChkSum entry
    checksum = foldl' (\x y -> x + (fromIntegral y)) 0 . BL.unpack $ block

putHeaderNoChkSum :: Entry -> BB.Builder
putHeaderNoChkSum Entry {
    entryTarPath     = TarPath name prefix,
    entryContent     = content,
    entryPermissions = permissions,
    entryOwnership   = ownership,
    entryTime        = modTime,
    entryFormat      = format
  } =
  mconcat
    [ putBString 100 $ name
    , putOct       8 $ permissions
    , putOct       8 $ ownerId ownership
    , putOct       8 $ groupId ownership
    , putOct      12 $ contentSize
    , putOct      12 $ modTime
    , stimes       8 $ (BB.char7 ' ') -- dummy checksum
    , BB.char8       $ typeCode
    , putBString 100 $ linkTarget
    , case format of
        V7Format    ->
          nullFill 255
        UstarFormat -> mconcat
          [ putBString   8 $ ustarMagic
          , putString   32 $ ownerName ownership
          , putString   32 $ groupName ownership
          , putOct       8 $ deviceMajor
          , putOct       8 $ deviceMinor
          , putBString 155 $ prefix
          , nullFill    12
          ]
        GnuFormat -> mconcat
          [ putBString   8 $ gnuMagic
          , putString   32 $ ownerName ownership
          , putString   32 $ groupName ownership
          , putGnuDev    8 $ deviceMajor
          , putGnuDev    8 $ deviceMinor
          , putBString 155 $ prefix
          , nullFill    12
          ]
    ]
  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
      _                   -> nullFill w

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 -> BB.Builder
putBString n s = BB.byteString (BS.take n s) <> nullFill (n - BS.length s)

-- Tar headers are ASCII
putString :: FieldWidth -> String -> BB.Builder
putString n s = BB.string7 (take n s) <> nullFill (n - length s)

--TODO: check integer widths, eg for large file sizes
putOct :: (Integral a, Show a) => FieldWidth -> a -> BB.Builder
putOct n x =
  let octStr = take (n-1) $ showOct x ""
      pad = n - length octStr - 1
   in mconcat
      [ if pad > 0 then stimes pad (BB.char7 '0') else mempty
      , BB.string7 octStr
      , nullByte
      ]

nullByte :: BB.Builder
nullByte = BB.char8 '\NUL'

nullFill :: FieldWidth -> BB.Builder
nullFill n | n > 0 = stimes n nullByte
nullFill _         = mempty