Tar de/serialization with Codec

tar-codec.hs

{-# LANGUAGE TemplateHaskell #-}

import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
import Codec
import Control.Monad
import Data.Word
import Data.Binary.Get
import Data.Binary.Put
import Numeric

-- stolen from tar-conduit
data Header = Header {
    headerName :: B.ByteString, -- ^ 100 bytes long
    headerMode :: Word64,
    headerOwnerUID :: Word64,
    headerOwnerGID :: Word64,
    headerFileSize :: Integer, -- ^ 12 bytes
    headerModifyTime :: Integer, -- ^ 12 bytes
    headerChecksum :: Word64,
    headerType :: Word8, -- ^ 1 byte
    headerLinkName :: B.ByteString, -- ^ 100 bytes
    headerMagic :: B.ByteString, -- ^ 6 bytes
    headerVersion :: Word16,
    headerOwnerUserName :: B.ByteString, -- ^ 32 bytes
    headerOwnerGroupName :: B.ByteString, -- ^ 32 bytes
    headerDeviceMajorNumber :: Word64,
    headerDeviceMinorNumber :: Word64,
    headerFilenamePrefix :: B.ByteString -- ^ 155 bytes
    }
    deriving (Eq, Show, Read)

genFields ''Header

-- easy peasy
headerCodec :: Codec Get PutM Header
headerCodec
  = codec Header
      $  r_headerName              >=< bytes' 100
      |> r_headerMode              >=< octal 8
      |> r_headerOwnerUID          >=< octal 8
      |> r_headerOwnerGID          >=< octal 8
      |> r_headerFileSize          >=< octal 12
      |> r_headerModifyTime        >=< octal 12
      |> r_headerChecksum          >=< octal 8
      |> r_headerType              >=< typeFlag
      |> r_headerLinkName          >=< bytes' 100
      |> r_headerMagic             >=< bytes' 6
      |> r_headerVersion           >=< octal 2
      |> r_headerOwnerUserName     >=< bytes' 32
      |> r_headerOwnerGroupName    >=< bytes' 32
      |> r_headerDeviceMajorNumber >=< octal 8
      |> r_headerDeviceMinorNumber >=< octal 8
      |> r_headerFilenamePrefix    >=< bytes' 155

-- byte field with trailing nulls stripped
bytes' :: Int -> FieldCodec Get PutM B.ByteString
bytes' n = mapCodecM trim pad (byteString n)
  where
    trim bs = return (fst $ B.spanEnd (==0) bs)
    pad bs
      | B.length bs <= n = return $ bs `B.append` B.replicate (n - B.length bs) 0
      | otherwise = fail "Serialized ByteString too large for field."

octal :: (Show i, Integral i) => Int -> FieldCodec Get PutM i
octal n = mapCodecM parseOct makeOct (byteString n)
  where
    parseOct bs
      | B.null trimmed = return 0
      | otherwise = case readOct (BC.unpack trimmed) of
          [ ( x, _ ) ] -> return x
          _ -> fail $ "Could not parse octal value: " ++ show bs
        where trimmed = BC.takeWhile (`notElem` " \NUL") bs
    makeOct x
      | B.length octBS > n - 1 = fail "Octal value too large for field."
      | otherwise = return $ BC.replicate (n - 1 - B.length octBS) '0' `B.append` octBS `B.snoc` 0
        where octBS = BC.pack $ showOct x ""

typeFlag :: FieldCodec Get PutM Word8
typeFlag = ( getWord8, putWord8 )