diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for leb128-serialize + +## 1.0 -- 2020-04-23 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2020 Joachim Breitner + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/leb128-cereal.cabal b/leb128-cereal.cabal new file mode 100644 --- /dev/null +++ b/leb128-cereal.cabal @@ -0,0 +1,46 @@ +cabal-version: >=1.10 +name: leb128-cereal +version: 1.0 +synopsis: LEB128 and SLEB128 encoding +description: + This module implements encoding and decoding of 'Natural' and 'Integer' + values according to LEB128 and SLEB128. See + for a specification. + . + This package uses the @cereal@ package, but also provides direct encoding and + decoding to 'ByteString'. +bug-reports: https://github.com/nomeata/haskell-leb128-cereal/issues +license: MIT +license-file: LICENSE +author: Joachim Breitner +maintainer: mail@joachim-breitner.de +copyright: 2020 Joachim Breitner +category: Codec +build-type: Simple +extra-source-files: CHANGELOG.md +tested-with: GHC == 8.2, GHC == 8.4, GHC == 8.6, GHC == 8.8, GHC == 8.10 + +library + exposed-modules: Data.Serialize.LEB128 + build-depends: base >=4.10 && <5 + build-depends: bytestring >= 0.10 + build-depends: cereal >= 0.5 + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall -Wno-name-shadowing + +test-suite test + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: test.hs + build-depends: base >= 4 && < 5 + build-depends: tasty >= 0.7 + build-depends: tasty-quickcheck + build-depends: tasty-hunit + build-depends: leb128-cereal + build-depends: bytestring + +source-repository head + type: git + location: https://github.com/nomeata/haskell-leb128-cereal + diff --git a/src/Data/Serialize/LEB128.hs b/src/Data/Serialize/LEB128.hs new file mode 100644 --- /dev/null +++ b/src/Data/Serialize/LEB128.hs @@ -0,0 +1,239 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-dodgy-imports #-} +{-# OPTIONS_GHC -O2 #-} +-- {-# OPTIONS_GHC -ddump-simpl -dsuppress-unfoldings -dsuppress-idinfo -dsuppress-module-prefixes -ddump-to-file #-} + +-- | +-- Module : Data.Serialize.LEB128 +-- Description : LEB128 encoding +-- License : MIT +-- Maintainer : Joachim Breitner +-- +-- | This module implements encoding and decoding of 'Natural' and 'Integer' +-- values according to LEB128 and SLEB128. See +-- https://en.wikipedia.org/wiki/LEB128 for a specification. +-- +-- The module provides conversion to and from strict bytestrings. +-- +-- Additionally, to integrate these into your own parsers and serializers, you +-- can use the interfaces based on 'B.Builder' as well as @cereal@'s 'G.Get' +-- and 'P.Put' monad. +-- +-- The decoders will fail if the input is not in canonical representation, +-- i.e. longer than necessary. +-- +-- This code is inspired by Andreas Klebinger's LEB128 implementation in GHC. +module Data.Serialize.LEB128 + ( + -- * The class of encodable and decodable types + LEB128 + , SLEB128 + -- * Bytestring-based interface + , toLEB128 + , fromLEB128 + , toSLEB128 + , fromSLEB128 + -- * Builder interface + , buildLEB128 + , buildSLEB128 + -- * Cereal interface + , getLEB128 + , getSLEB128 + , putLEB128 + , putSLEB128 + ) where + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Builder as B +import qualified Data.ByteString.Builder.Extra as B +import qualified Data.Serialize.Get as G +import qualified Data.Serialize.Put as P +import Numeric.Natural +import Control.Applicative +import Control.Monad +import Data.Bits +import Data.Word +import Data.Int +import Data.Maybe +import Data.Monoid ((<>)) +import Prelude hiding ((<>)) + +-- | Unsigned number types can be LEB128-encoded +class (Bits a, Num a, Integral a) => LEB128 a where +instance LEB128 Natural +instance LEB128 Word +instance LEB128 Word8 +instance LEB128 Word16 +instance LEB128 Word32 +instance LEB128 Word64 + +-- | Signed number types can be SLEB128-encoded +class (Bits a, Num a, Integral a) => SLEB128 a +instance SLEB128 Integer +instance SLEB128 Int +instance SLEB128 Int8 +instance SLEB128 Int16 +instance SLEB128 Int32 +instance SLEB128 Int64 + +-- | LEB128-encodes a natural number to a strict bytestring +toLEB128 :: LEB128 a => a -> BS.ByteString +toLEB128 = BSL.toStrict . B.toLazyByteStringWith (B.safeStrategy 32 32) BSL.empty . buildLEB128 + +{-# SPECIALIZE toLEB128 :: Natural -> BS.ByteString #-} +{-# SPECIALIZE toLEB128 :: Word -> BS.ByteString #-} +{-# SPECIALIZE toLEB128 :: Word8 -> BS.ByteString #-} +{-# SPECIALIZE toLEB128 :: Word16 -> BS.ByteString #-} +{-# SPECIALIZE toLEB128 :: Word32 -> BS.ByteString #-} +{-# SPECIALIZE toLEB128 :: Word64 -> BS.ByteString #-} + +-- | SLEB128-encodes an integer to a strict bytestring +toSLEB128 :: SLEB128 a => a -> BS.ByteString +toSLEB128 = BSL.toStrict . B.toLazyByteStringWith (B.safeStrategy 32 32) BSL.empty . buildSLEB128 + +{-# SPECIALIZE toSLEB128 :: Integer -> BS.ByteString #-} +{-# SPECIALIZE toSLEB128 :: Int -> BS.ByteString #-} +{-# SPECIALIZE toSLEB128 :: Int8 -> BS.ByteString #-} +{-# SPECIALIZE toSLEB128 :: Int16 -> BS.ByteString #-} +{-# SPECIALIZE toSLEB128 :: Int32 -> BS.ByteString #-} +{-# SPECIALIZE toSLEB128 :: Int64 -> BS.ByteString #-} + +-- | LEB128-encodes a natural number via a builder +buildLEB128 :: LEB128 a => a -> B.Builder +buildLEB128 = go + where + go i + | i <= 127 + = B.word8 (fromIntegral i :: Word8) + | otherwise = + -- bit 7 (8th bit) indicates more to come. + B.word8 (setBit (fromIntegral i) 7) <> go (i `unsafeShiftR` 7) + +{-# SPECIALIZE buildLEB128 :: Natural -> B.Builder #-} +{-# SPECIALIZE buildLEB128 :: Word -> B.Builder #-} +{-# SPECIALIZE buildLEB128 :: Word8 -> B.Builder #-} +{-# SPECIALIZE buildLEB128 :: Word16 -> B.Builder #-} +{-# SPECIALIZE buildLEB128 :: Word32 -> B.Builder #-} +{-# SPECIALIZE buildLEB128 :: Word64 -> B.Builder #-} + +-- This gets inlined for the specialied variants +isFinite :: forall a. Bits a => Bool +isFinite = isJust (bitSizeMaybe (undefined :: a)) + +-- | SLEB128-encodes an integer via a builder +buildSLEB128 :: SLEB128 a => a -> B.Builder +buildSLEB128 = go + where + go val = do + let !byte = fromIntegral (clearBit val 7) :: Word8 + let !val' = val `unsafeShiftR` 7 + let !signBit = testBit byte 6 + let !done = + -- Unsigned value, val' == 0 and and last value can + -- be discriminated from a negative number. + (val' == 0 && not signBit) || + -- Signed value, + (val' == -1 && signBit) + let !byte' = if done then byte else setBit byte 7 + B.word8 byte' <> if done then mempty else go val' + +{-# SPECIALIZE buildSLEB128 :: Integer -> B.Builder #-} +{-# SPECIALIZE buildSLEB128 :: Int -> B.Builder #-} +{-# SPECIALIZE buildSLEB128 :: Int8 -> B.Builder #-} +{-# SPECIALIZE buildSLEB128 :: Int16 -> B.Builder #-} +{-# SPECIALIZE buildSLEB128 :: Int32 -> B.Builder #-} +{-# SPECIALIZE buildSLEB128 :: Int64 -> B.Builder #-} + +-- | LEB128-encodes a natural number in @cereal@'s 'P.Put' monad +putLEB128 :: LEB128 a => P.Putter a +putLEB128 = P.putBuilder . buildLEB128 +{-# INLINE putLEB128 #-} + +-- | SLEB128-encodes an integer in @cereal@'s 'P.Put' monad +putSLEB128 :: SLEB128 a => P.Putter a +putSLEB128 = P.putBuilder . buildSLEB128 +{-# INLINE putSLEB128 #-} + +-- | LEB128-decodes a natural number from a strict bytestring +fromLEB128 :: LEB128 a => BS.ByteString -> Either String a +fromLEB128 = runComplete getLEB128 +{-# INLINE fromLEB128 #-} + +-- | SLEB128-decodes an integer from a strict bytestring +fromSLEB128 :: SLEB128 a => BS.ByteString -> Either String a +fromSLEB128 = runComplete getSLEB128 +{-# INLINE fromSLEB128 #-} + +runComplete :: G.Get a -> BS.ByteString -> Either String a +runComplete p bs = do + (x,r) <- G.runGetState p bs 0 + unless (BS.null r) $ Left "extra bytes in input" + return x + +-- | LEB128-decodes a natural number via @cereal@ +getLEB128 :: forall a. LEB128 a => G.Get a +getLEB128 = G.label "LEB128" $ go 0 0 + where + go :: Int -> a -> G.Get a + go !shift !w = do + byte <- G.getWord8 <|> fail "short encoding" + let !byteVal = fromIntegral (clearBit byte 7) + when (isFinite @a) $ + unless (byteVal `unsafeShiftL` shift `unsafeShiftR` shift == byteVal) $ + fail "overflow" + let !val = w .|. (byteVal `unsafeShiftL` shift) + let !shift' = shift+7 + if hasMore byte + then go shift' val + else do + when (byte == 0x00 && shift > 0) + $ fail "overlong encoding" + return $! val + + hasMore b = testBit b 7 + +{-# SPECIALIZE getLEB128 :: G.Get Natural #-} +{-# SPECIALIZE getLEB128 :: G.Get Word #-} +{-# SPECIALIZE getLEB128 :: G.Get Word8 #-} +{-# SPECIALIZE getLEB128 :: G.Get Word16 #-} +{-# SPECIALIZE getLEB128 :: G.Get Word32 #-} +{-# SPECIALIZE getLEB128 :: G.Get Word64 #-} + +-- | SLEB128-decodes an integer via @cereal@ +getSLEB128 :: forall a. SLEB128 a => G.Get a +getSLEB128 = G.label "SLEB128" $ go 0 0 0 + where + go :: Word8 -> Int -> a -> G.Get a + go !prev !shift !w = do + byte <- G.getWord8 <|> fail "short encoding" + let !byteVal = fromIntegral (clearBit byte 7) + when (isFinite @a) $ + unless ((byteVal `unsafeShiftL` shift `unsafeShiftR` shift) .&. 0x7f == byteVal) $ + fail "overflow" + let !val = w .|. (byteVal `unsafeShiftL` shift) + let !shift' = shift+7 + if hasMore byte + then go byte shift' val + else if signed byte + then do + when (byte == 0x7f && signed prev && shift > 0) + $ fail "overlong encoding" + return $! val - bit shift' + else do + when (byte == 0x00 && not (signed prev) && shift > 0) + $ fail "overlong encoding" + return $! val + + hasMore b = testBit b 7 + signed b = testBit b 6 + +{-# SPECIALIZE getSLEB128 :: G.Get Integer #-} +{-# SPECIALIZE getSLEB128 :: G.Get Int #-} +{-# SPECIALIZE getSLEB128 :: G.Get Int8 #-} +{-# SPECIALIZE getSLEB128 :: G.Get Int16 #-} +{-# SPECIALIZE getSLEB128 :: G.Get Int32 #-} +{-# SPECIALIZE getSLEB128 :: G.Get Int64 #-} diff --git a/test.hs b/test.hs new file mode 100644 --- /dev/null +++ b/test.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +import qualified Data.ByteString as B +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck +import Numeric.Natural +import Data.Word +import Data.Int +import Data.Bits +import Data.List +import Data.Typeable + +import Data.Serialize.LEB128 + +newtype LargeInteger = LargeInteger Integer + deriving (Show, Eq, Ord, Num, Bits, Real, Enum, Integral, SLEB128) +newtype LargeNatural = LargeNatural Natural + deriving (Show, Eq, Ord, Num, Bits, Real, Enum, Integral, LEB128) + +instance Arbitrary LargeNatural where + arbitrary = LargeNatural . fromWords <$> arbitrary + where + fromWords :: [Word8] -> Natural + fromWords = foldl' go 0 + go :: Natural -> Word8 -> Natural + go acc w = (acc `shiftL` 8) + fromIntegral w + +instance Arbitrary LargeInteger where + arbitrary = do + sign <- arbitrary + LargeNatural n <- arbitrary + return $ LargeInteger $ (if sign then negate else id) $ fromIntegral n + +-- Only change the default (slight hack) +-- Needed to find corner cases involving non-short encodings +moreTests (QuickCheckTests 100) = QuickCheckTests 100000 +moreTests (QuickCheckTests n) = QuickCheckTests n + +leb128Tests :: forall a. (Typeable a, Arbitrary a, Show a, LEB128 a) => TestTree +leb128Tests = testGroup (show (typeRep (Proxy @a))) + [ testCase "empty input" $ + fromLEB128 @a B.empty @=? Left "Failed reading: short encoding\nFrom:\tLEB128\n\n" + , testProperty "roundtrip" $ + \i -> Right i === fromLEB128 (toLEB128 @a i) + , testProperty "unique rep" $ + \(B.pack -> bs) -> case fromLEB128 @a bs of + Left _ -> property () + Right i -> bs === toLEB128 i + ] + +sleb128Tests :: forall a. (Typeable a, Arbitrary a, Show a, SLEB128 a) => TestTree +sleb128Tests = testGroup (show (typeRep (Proxy @a))) + [ testCase "empty input" $ + fromSLEB128 @a B.empty @=? Left "Failed reading: short encoding\nFrom:\tSLEB128\n\n" + , testProperty "roundtrip" $ + \i -> Right i === fromSLEB128 (toSLEB128 @a i) + , testProperty "unique rep" $ + \(B.pack -> bs) -> case fromSLEB128 @a bs of + Left _ -> property () + Right i -> bs === toSLEB128 i + ] + +main = defaultMain $ adjustOption moreTests $ + testGroup "tests" + [ leb128Tests @LargeNatural + , leb128Tests @Word + , leb128Tests @Word8 + , leb128Tests @Word16 + , leb128Tests @Word32 + , leb128Tests @Word64 + , sleb128Tests @LargeInteger + , sleb128Tests @Int + , sleb128Tests @Int8 + , sleb128Tests @Int16 + , sleb128Tests @Int32 + , sleb128Tests @Int64 + ]