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
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)))
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
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
nibbleLength :: Word32 -> Int
nibbleLength 0 = 1
nibbleLength n = f n where
f 0 = 0
f n = 1 + f (n `shiftR` 4)
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
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
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)