-- |
-- Tagged data structures are an extensible way of serialising data in a
-- platform independent way for transmission across a network etc. This package
-- implements the tagged structures from libevent 1.4.0-beta.
--
-- A tagged structure is described in a text file and might look like this:
--
-- > struct foo {
-- >   required int count = 1;
-- >   optional struct[bar] names = 2;
-- > }
-- >
-- > struct bar {
-- >   repeated string s = 1;
-- > }
--
-- The numbers after the equals signs are the tag numbers for each element of
-- a structure. The tag numbers must be unique within a structure and should
-- be sequenctial (but are not required to be).
--
-- The tag numbers must also be fixed for all time. When deserialising,
-- unknown tags are ignored. Thus one can add a new (non-required) element to
-- @foo@ in the future and still interoperate with older code which knows
-- nothing of the new element.
--
-- Each element in the description looks like:
--
-- > <presence> <type> <name> = <tag number> ;
--
-- The possible presence values are: @required@, @optional@ and @repeated@. The
-- types are (currently): @int@, @string@, @struct[NAME]@ and @bytes@.
--
-- Other modules in this package parse these descriptions and automatically
-- generate Haskell code for them. You should have a binary called
-- @codec-libevent-generate@ which does this. See the documentation for
-- "Codec.Libevent.Generate" about the structure of the generated code.
--
-- Once you have generated the code, you can import it as a regular Haskell
-- module and serialise\/deserialise these structures. You can also use
-- the libevent library to process them in C.
--
-- This module contains helper functions and is imported by the code generated
-- by "Codec.Libevent.Generate". Apart from the @TaggedStructure@ class, there's
-- probably not anything generally useful here.
module Codec.Libevent where

import Data.List (unfoldr)
import Data.Bits
import Data.Char (ord, chr)
import Data.Maybe (fromJust)
import Data.Word
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL

import Data.Binary.Put
import Data.Binary.Strict.Get

import Test.QuickCheck

-- | Decode a base128 encoded integer. This is a variable length encoded int
--   where the last byte has the MSB set to 0.
getBase128 :: Get Word32
getBase128 = f 0 0 where
  f n x = do v <- getWord8
             if v .&. 0x80 == 0
                then return $ x .|. (fromIntegral (v `shiftL` (7 * n)))
                else f (n + 1) $ x .|. (fromIntegral ((v .&. 0x7f) `shiftL` (7 * n)))

-- | Encode a integer in Base128 form
putBase128 :: Word32 -> Put
putBase128 n = do
  let next = n `shiftR` 7
  if next == 0
     then putWord8 (fromIntegral n)
     else putWord8 (fromIntegral ((n .&. 0x7f) .|. 0x80)) >> putBase128 next

-- | Decode a number where the first nibble of the first byte is the number
--   of nibbles in the number. The remaining nibbles appear in little-endian
--   order following, with 0 padding to the nearest byte.
getLengthPrefixed :: Get Word32
getLengthPrefixed = do
  i <- getWord8
  let numNibbles = (i `shiftR` 4) + 1
      numBytes = (numNibbles `shiftR` 1) + 1
      numExtraBytes = fromIntegral $ numBytes - 1
      toNibbles = concatMap (\x -> [x `shiftR` 4, x .&. 0x0f]) . BS.unpack
      firstNibble = i .&. 0x0f

      f :: Word32 -> Word8 -> Word32
      f acc x = (acc `shiftL` 4) .|. (fromIntegral x)

  rest <- getByteString numExtraBytes
  let nibbles = reverse $ take (fromIntegral numNibbles) $ firstNibble : toNibbles rest
  return $ foldl f 0 nibbles

-- | Return the number of nibbles, n, required to encode a given number. n >= 1
nibbleLength :: Word32 -> Int
nibbleLength 0 = 1
nibbleLength n = f n where
  f 0 = 0
  f n = 1 + f (n `shiftR` 4)

-- | Encode a Word32 by prefixing the number of nibbles and following with the
--   nibbles of the number in little-endian order
putLengthPrefixed :: Word32 -> Put
putLengthPrefixed n = do
  let nibbles = fromIntegral $ nibbleLength n
      firstNibble = fromIntegral $ n .&. 0xf
      rest = BS.unfoldr f (n `shiftR` 4)

      f :: Word32 -> Maybe (Word8, Word32)
      f 0 = Nothing
      f n = Just ((fromIntegral $ n `shiftL` 4) .|. (fromIntegral $ n `shiftR` 4), n `shiftR` 8)

  putWord8 ((nibbles - 1) `shiftL` 4 .|. firstNibble)
  putByteString rest

-- | Return the length of the length-prefixed representation of a Word32
lengthPrefixedLength :: Word32 -> Int
lengthPrefixedLength n = (numNibbles + 1) `div` 2 where
  numNibbles = nibbleLength n

putTaggedWord32 :: Word32 -> Word32 -> Put
putTaggedWord32 tag v =
  putBase128 tag >> putWord8 (fromIntegral $ lengthPrefixedLength v) >> putLengthPrefixed v

putTaggedString :: Word32 -> String -> Put
putTaggedString tag s = do
  putBase128 tag
  putLengthPrefixed (fromIntegral $ length s)
  putByteString (BS.pack $ map (fromIntegral . ord) s)

putTaggedVarBytes :: Word32 -> BS.ByteString -> Put
putTaggedVarBytes tag s =
  putBase128 tag >> putLengthPrefixed (fromIntegral $ BS.length s) >> putByteString s

decodeString :: BS.ByteString -> String
decodeString = map (chr . fromIntegral) . BS.unpack

-- | Properties that check that (encode . decode) is the identity function
prop_lengthPrefixed :: Int -> Property
prop_lengthPrefixed n =
  (n >= 0) ==>
  (fst $ runGet getLengthPrefixed $
    BS.concat $ BSL.toChunks $ runPut $ putLengthPrefixed $ fromIntegral n) == Right (fromIntegral n)

prop_base128 :: Int -> Property
prop_base128 n =
  (n >= 0) ==>
  (fst $ runGet getBase128 $
    BS.concat $ BSL.toChunks $ runPut $ putBase128 $ fromIntegral n) == Right (fromIntegral n)