cborg 0.2.0.0 → 0.2.1.0
raw patch · 21 files changed
+3770/−335 lines, 21 filesdep +QuickCheckdep +aesondep +base16-bytestringdep ~basedep ~containersdep ~failPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: QuickCheck, aeson, base16-bytestring, base64-bytestring, cborg, deepseq, scientific, tasty, tasty-hunit, tasty-quickcheck, vector
Dependency ranges changed: base, containers, fail
API changes (from Hackage documentation)
- Codec.CBOR.Encoding: instance Data.Semigroup.Semigroup Codec.CBOR.Encoding.Encoding
+ Codec.CBOR.Decoding: ConsumeByteArrayCanonical :: (ByteArray -> ST s (DecodeAction s a)) -> DecodeAction s a
+ Codec.CBOR.Decoding: ConsumeBytesCanonical :: (ByteString -> ST s (DecodeAction s a)) -> DecodeAction s a
+ Codec.CBOR.Decoding: ConsumeStringCanonical :: (Text -> ST s (DecodeAction s a)) -> DecodeAction s a
+ Codec.CBOR.Decoding: ConsumeUtf8ByteArrayCanonical :: (ByteArray -> ST s (DecodeAction s a)) -> DecodeAction s a
+ Codec.CBOR.Decoding: decodeByteArrayCanonical :: Decoder s ByteArray
+ Codec.CBOR.Decoding: decodeBytesCanonical :: Decoder s ByteString
+ Codec.CBOR.Decoding: decodeStringCanonical :: Decoder s Text
+ Codec.CBOR.Decoding: decodeUtf8ByteArrayCanonical :: Decoder s ByteArray
+ Codec.CBOR.Encoding: instance GHC.Base.Semigroup Codec.CBOR.Encoding.Encoding
+ Codec.CBOR.Magic: intToInt64 :: Int -> Int64
+ Codec.CBOR.Magic: word16ToInt :: Word16 -> Int
+ Codec.CBOR.Magic: word16ToWord :: Word16 -> Word
+ Codec.CBOR.Magic: word32ToInt :: Word32 -> Int
+ Codec.CBOR.Magic: word32ToWord :: Word32 -> Word
+ Codec.CBOR.Magic: word64ToInt :: Word64 -> Maybe Int
+ Codec.CBOR.Magic: word64ToWord :: Word64 -> Word
+ Codec.CBOR.Magic: word8ToInt :: Word8 -> Int
+ Codec.CBOR.Magic: word8ToWord :: Word8 -> Word
+ Codec.CBOR.Read: instance Control.DeepSeq.NFData Codec.CBOR.Read.DeserialiseFailure
+ Codec.CBOR.Read: instance GHC.Classes.Eq Codec.CBOR.Read.DeserialiseFailure
- Codec.CBOR.Magic: eatTailWord16 :: ByteString -> Word
+ Codec.CBOR.Magic: eatTailWord16 :: ByteString -> Word16
- Codec.CBOR.Magic: eatTailWord32 :: ByteString -> Word
+ Codec.CBOR.Magic: eatTailWord32 :: ByteString -> Word32
- Codec.CBOR.Magic: eatTailWord8 :: ByteString -> Word
+ Codec.CBOR.Magic: eatTailWord8 :: ByteString -> Word8
- Codec.CBOR.Magic: grabWord16 :: Ptr () -> Word
+ Codec.CBOR.Magic: grabWord16 :: Ptr () -> Word16
- Codec.CBOR.Magic: grabWord32 :: Ptr () -> Word
+ Codec.CBOR.Magic: grabWord32 :: Ptr () -> Word32
- Codec.CBOR.Magic: grabWord8 :: Ptr () -> Word
+ Codec.CBOR.Magic: grabWord8 :: Ptr () -> Word8
- Codec.CBOR.Magic: wordToFloat16 :: Word -> Float
+ Codec.CBOR.Magic: wordToFloat16 :: Word16 -> Float
- Codec.CBOR.Magic: wordToFloat32 :: Word -> Float
+ Codec.CBOR.Magic: wordToFloat32 :: Word32 -> Float
Files
- ChangeLog.md +20/−0
- cborg.cabal +52/−4
- src/Codec/CBOR/ByteArray/Internal.hs +2/−7
- src/Codec/CBOR/Decoding.hs +112/−30
- src/Codec/CBOR/FlatTerm.hs +17/−8
- src/Codec/CBOR/Magic.hs +169/−28
- src/Codec/CBOR/Read.hs +543/−258
- src/Codec/CBOR/Write.hs +4/−0
- tests/Main.hs +22/−0
- tests/Tests/Boundary.hs +181/−0
- tests/Tests/CBOR.hs +284/−0
- tests/Tests/Reference.hs +293/−0
- tests/Tests/Reference/Implementation.hs +1074/−0
- tests/Tests/Regress.hs +19/−0
- tests/Tests/Regress/FlatTerm.hs +47/−0
- tests/Tests/Regress/Issue160.hs +47/−0
- tests/Tests/Regress/Issue162.hs +94/−0
- tests/Tests/UTF8.hs +56/−0
- tests/Tests/Util.hs +83/−0
- tests/test-vectors/README.md +27/−0
- tests/test-vectors/appendix_a.json +624/−0
+ ChangeLog.md view
@@ -0,0 +1,20 @@+# Revision history for cborg++## 0.2.1.0 -- 2018-10-11++* Bounds bumps and GHC 8.6 compatibility++## 0.2.0.0 -- 2017-11-30++* Improved robustness of non-UTF-8 strings++* Add encoders and decoders for `ByteArray`++* Add decoding variants that check for canonical encodings++* Expose `Codec.CBOR.Read.deserialiseFromBytesWithSize`++## 0.1.0.0 -- 2017-06-28++* First version. Released on an unsuspecting world.+
cborg.cabal view
@@ -1,5 +1,5 @@ name: cborg-version: 0.2.0.0+version: 0.2.1.0 synopsis: Concise Binary Object Representation license: BSD3 license-file: LICENSE.txt@@ -14,6 +14,9 @@ cabal-version: >= 1.10 tested-with: GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1 +extra-source-files:+ ChangeLog.md+ description: This package (formerly @binary-serialise-cbor@) provides an efficient implementation of the Concise Binary Object Representation (CBOR), as@@ -28,6 +31,8 @@ for a convenient command-line utility for working with CBOR data. extra-source-files: src/cbits/cbor.h+ tests/test-vectors/appendix_a.json+ tests/test-vectors/README.md source-repository head type: git@@ -75,9 +80,10 @@ array >= 0.4 && < 0.6, base >= 4.6 && < 5.0, bytestring >= 0.10.4 && < 0.11,- containers >= 0.5 && < 0.6,- ghc-prim >= 0.3 && < 0.6,- half >= 0.2.2.3 && < 0.3,+ containers >= 0.5 && < 0.7,+ deepseq >= 1.0 && < 1.5,+ ghc-prim >= 0.3.1.0 && < 0.6,+ half >= 0.2.2.3 && < 0.4, primitive >= 0.5 && < 0.7, text >= 1.1 && < 1.3 @@ -91,3 +97,45 @@ else -- provide/emulate `Control.Monad.Fail` and `Data.Semigroups` API for pre-GHC8 build-depends: fail == 4.9.*, semigroups == 0.18.*++test-suite tests+ type: exitcode-stdio-1.0+ hs-source-dirs: tests+ main-is: Main.hs++ default-language: Haskell2010+ ghc-options:+ -Wall -fno-warn-orphans+ -threaded -rtsopts "-with-rtsopts=-N2"++ other-modules:+ Tests.CBOR+ Tests.Boundary+ Tests.Regress+ Tests.Regress.Issue160+ Tests.Regress.Issue162+ Tests.Regress.FlatTerm+ Tests.Reference+ Tests.Reference.Implementation+ Tests.UTF8+ Tests.Util++ build-depends:+ array >= 0.4 && < 0.6,+ base >= 4.6 && < 5.0,+ bytestring >= 0.10.4 && < 0.11,+ text >= 1.1 && < 1.3,+ cborg,+ aeson >= 0.7 && < 1.5,+ base64-bytestring >= 1.0 && < 1.1,+ base16-bytestring >= 0.1 && < 0.2,+ deepseq >= 1.0 && < 1.5,+ fail >= 4.9.0.0 && < 4.10,+ half >= 0.2.2.3 && < 0.4,+ QuickCheck >= 2.9 && < 2.13,+ scientific >= 0.3 && < 0.4,+ tasty >= 0.11 && < 1.2,+ tasty-hunit >= 0.9 && < 0.11,+ tasty-quickcheck >= 0.8 && < 0.11,+ vector >= 0.10 && < 0.13+
src/Codec/CBOR/ByteArray/Internal.hs view
@@ -52,11 +52,6 @@ IO (\s -> case copyByteArrayToAddr# ba off addr len s of s' -> (# s', () #)) -#if __GLASGOW_HASKELL__ < 706-isTrue# :: Bool -> Bool-isTrue# = id-#endif- sameByteArray :: Prim.ByteArray -> Prim.ByteArray -> Bool sameByteArray (Prim.ByteArray ba1#) (Prim.ByteArray ba2#) = case reallyUnsafePtrEquality# (unsafeCoerce# ba1# :: ()) (unsafeCoerce# ba2# :: ()) of@@ -72,9 +67,9 @@ -- | A conservative estimate of pinned-ness. isByteArrayPinned :: Prim.ByteArray -> Bool-isByteArrayPinned (Prim.ByteArray ba) =+isByteArrayPinned (Prim.ByteArray _ba) = #if __GLASGOW_HASKELL__ > 800- case isByteArrayPinned# ba of+ case isByteArrayPinned# _ba of 0# -> False _ -> True #else
src/Codec/CBOR/Decoding.hs view
@@ -36,18 +36,6 @@ , decodeInt16 -- :: Decoder s Int16 , decodeInt32 -- :: Decoder s Int32 , decodeInt64 -- :: Decoder s Int64- , decodeWordCanonical -- :: Decoder s Word- , decodeWord8Canonical -- :: Decoder s Word8- , decodeWord16Canonical -- :: Decoder s Word16- , decodeWord32Canonical -- :: Decoder s Word32- , decodeWord64Canonical -- :: Decoder s Word64- , decodeNegWordCanonical -- :: Decoder s Word- , decodeNegWord64Canonical -- :: Decoder s Word64- , decodeIntCanonical -- :: Decoder s Int- , decodeInt8Canonical -- :: Decoder s Int8- , decodeInt16Canonical -- :: Decoder s Int16- , decodeInt32Canonical -- :: Decoder s Int32- , decodeInt64Canonical -- :: Decoder s Int64 , decodeInteger -- :: Decoder s Integer , decodeFloat -- :: Decoder s Float , decodeDouble -- :: Decoder s Double@@ -58,29 +46,18 @@ , decodeStringIndef -- :: Decoder s () , decodeUtf8ByteArray -- :: Decoder s ByteArray , decodeListLen -- :: Decoder s Int- , decodeListLenCanonical -- :: Decoder s Int , decodeListLenIndef -- :: Decoder s () , decodeMapLen -- :: Decoder s Int- , decodeMapLenCanonical -- :: Decoder s Int , decodeMapLenIndef -- :: Decoder s () , decodeTag -- :: Decoder s Word , decodeTag64 -- :: Decoder s Word64- , decodeTagCanonical -- :: Decoder s Word- , decodeTag64Canonical -- :: Decoder s Word64 , decodeBool -- :: Decoder s Bool , decodeNull -- :: Decoder s () , decodeSimple -- :: Decoder s Word8- , decodeIntegerCanonical -- :: Decoder s Integer- , decodeFloat16Canonical -- :: Decoder s Float- , decodeFloatCanonical -- :: Decoder s Float- , decodeDoubleCanonical -- :: Decoder s Double- , decodeSimpleCanonical -- :: Decoder s Word8 -- ** Specialised Read input token operations , decodeWordOf -- :: Word -> Decoder s () , decodeListLenOf -- :: Int -> Decoder s ()- , decodeWordCanonicalOf -- :: Word -> Decoder s ()- , decodeListLenCanonicalOf -- :: Int -> Decoder s () -- ** Branching operations --, decodeBytesOrIndef@@ -94,9 +71,41 @@ , peekAvailable -- :: Decoder s Int , TokenType(..) + -- ** Canonical CBOR+ -- $canonical+ , decodeWordCanonical -- :: Decoder s Word+ , decodeWord8Canonical -- :: Decoder s Word8+ , decodeWord16Canonical -- :: Decoder s Word16+ , decodeWord32Canonical -- :: Decoder s Word32+ , decodeWord64Canonical -- :: Decoder s Word64+ , decodeNegWordCanonical -- :: Decoder s Word+ , decodeNegWord64Canonical -- :: Decoder s Word64+ , decodeIntCanonical -- :: Decoder s Int+ , decodeInt8Canonical -- :: Decoder s Int8+ , decodeInt16Canonical -- :: Decoder s Int16+ , decodeInt32Canonical -- :: Decoder s Int32+ , decodeInt64Canonical -- :: Decoder s Int64+ , decodeBytesCanonical -- :: Decoder s ByteString+ , decodeByteArrayCanonical -- :: Decoder s ByteArray+ , decodeStringCanonical -- :: Decoder s Text+ , decodeUtf8ByteArrayCanonical -- :: Decoder s ByteArray+ , decodeListLenCanonical -- :: Decoder s Int+ , decodeMapLenCanonical -- :: Decoder s Int+ , decodeTagCanonical -- :: Decoder s Word+ , decodeTag64Canonical -- :: Decoder s Word64+ , decodeIntegerCanonical -- :: Decoder s Integer+ , decodeFloat16Canonical -- :: Decoder s Float+ , decodeFloatCanonical -- :: Decoder s Float+ , decodeDoubleCanonical -- :: Decoder s Double+ , decodeSimpleCanonical -- :: Decoder s Word8+ , decodeWordCanonicalOf -- :: Word -> Decoder s ()+ , decodeListLenCanonicalOf -- :: Int -> Decoder s ()++{- -- ** Special operations---, ignoreTerms---, decodeTrace+ , ignoreTerms+ , decodeTrace+-} -- * Sequence operations , decodeSequenceLenIndef -- :: ...@@ -188,11 +197,15 @@ | ConsumeBool (Bool -> ST s (DecodeAction s a)) | ConsumeSimple (Word# -> ST s (DecodeAction s a)) - | ConsumeIntegerCanonical (Integer -> ST s (DecodeAction s a))- | ConsumeFloat16Canonical (Float# -> ST s (DecodeAction s a))- | ConsumeFloatCanonical (Float# -> ST s (DecodeAction s a))- | ConsumeDoubleCanonical (Double# -> ST s (DecodeAction s a))- | ConsumeSimpleCanonical (Word# -> ST s (DecodeAction s a))+ | ConsumeIntegerCanonical (Integer -> ST s (DecodeAction s a))+ | ConsumeFloat16Canonical (Float# -> ST s (DecodeAction s a))+ | ConsumeFloatCanonical (Float# -> ST s (DecodeAction s a))+ | ConsumeDoubleCanonical (Double# -> ST s (DecodeAction s a))+ | ConsumeBytesCanonical (ByteString-> ST s (DecodeAction s a))+ | ConsumeByteArrayCanonical (ByteArray -> ST s (DecodeAction s a))+ | ConsumeStringCanonical (Text -> ST s (DecodeAction s a))+ | ConsumeUtf8ByteArrayCanonical (ByteArray -> ST s (DecodeAction s a))+ | ConsumeSimpleCanonical (Word# -> ST s (DecodeAction s a)) | ConsumeBytesIndef (ST s (DecodeAction s a)) | ConsumeStringIndef (ST s (DecodeAction s a))@@ -289,6 +302,38 @@ getDecodeAction (Decoder k) = k (\x -> return (Done x)) +-- $canonical+--+-- <https://tools.ietf.org/html/rfc7049#section-3.9>+--+-- In general in CBOR there can be multiple representations for the same value,+-- for example the integer @0@ represented in 8, 16, 32 or 64 bits. This+-- library always encodeds values in the shortest representation but on+-- decoding allows any valid encoding. For some applications it is useful or+-- important to only decode the canonical encoding. The decoder primitves here+-- are to allow applications to implement canonical decoding.+--+-- It is important to note that achieving a canonical representation is /not/+-- simply about using these primitives. For example consider a typical CBOR+-- encoding of a Haskell @Set@ data type. This will be encoded as a CBOR list+-- of the set elements. A typical implementation might be:+--+-- > encodeSet = encodeList . Set.toList+-- > decodeSet = fmap Set.fromList . decodeList+--+-- This /does not/ enforce a canonical encoding. The decoder above will allow+-- set elements in any order. The use of @Set.fromList@ forgets the order.+-- To enforce that the decoder only accepts the canonical encoding it will+-- have to check that the elemets in the list are /strictly/ increasing.+-- Similar issues arise in many other data types, wherever there is redundancy+-- in the external representation.+--+-- The decoder primitives in this section are not much more expensive than+-- their normal counterparts. If checking the canonical encoding property is+-- critical then a technique that is more expensive but easier to implement and+-- test is to decode normally, re-encode and check the serialised bytes are the+-- same.+ --------------------------------------- -- Read input tokens of various types --@@ -519,6 +564,13 @@ decodeBytes = Decoder (\k -> return (ConsumeBytes (\bs -> k bs))) {-# INLINE decodeBytes #-} +-- | Decode canonical representation of a string of bytes as a @'ByteString'@.+--+-- @since 0.2.1.0+decodeBytesCanonical :: Decoder s ByteString+decodeBytesCanonical = Decoder (\k -> return (ConsumeBytesCanonical (\bs -> k bs)))+{-# INLINE decodeBytesCanonical #-}+ -- | Decode a token marking the beginning of an indefinite length -- set of bytes. --@@ -538,6 +590,17 @@ decodeByteArray = Decoder (\k -> return (ConsumeByteArray k)) {-# INLINE decodeByteArray #-} +-- | Decode canonical representation of a string of bytes as a 'ByteArray'.+--+-- Also note that this will eagerly copy the content out of the input+-- to ensure that the input does not leak in the event that the 'ByteArray' is+-- live but not forced.+--+-- @since 0.2.1.0+decodeByteArrayCanonical :: Decoder s ByteArray+decodeByteArrayCanonical = Decoder (\k -> return (ConsumeByteArrayCanonical k))+{-# INLINE decodeByteArrayCanonical #-}+ -- | Decode a textual string as a piece of @'Text'@. -- -- @since 0.2.0.0@@ -545,6 +608,13 @@ decodeString = Decoder (\k -> return (ConsumeString (\str -> k str))) {-# INLINE decodeString #-} +-- | Decode canonical representation of a textual string as a piece of @'Text'@.+--+-- @since 0.2.1.0+decodeStringCanonical :: Decoder s Text+decodeStringCanonical = Decoder (\k -> return (ConsumeStringCanonical (\str -> k str)))+{-# INLINE decodeStringCanonical #-}+ -- | Decode a token marking the beginning of an indefinite length -- string. --@@ -564,6 +634,18 @@ decodeUtf8ByteArray :: Decoder s ByteArray decodeUtf8ByteArray = Decoder (\k -> return (ConsumeUtf8ByteArray k)) {-# INLINE decodeUtf8ByteArray #-}++-- | Decode canonical representation of a textual string as UTF-8 encoded+-- 'ByteArray'. Note that the result is not validated to be well-formed UTF-8.+--+-- Also note that this will eagerly copy the content out of the input+-- to ensure that the input does not leak in the event that the 'ByteArray' is+-- live but not forced.+--+-- @since 0.2.1.0+decodeUtf8ByteArrayCanonical :: Decoder s ByteArray+decodeUtf8ByteArrayCanonical = Decoder (\k -> return (ConsumeUtf8ByteArrayCanonical k))+{-# INLINE decodeUtf8ByteArrayCanonical #-} -- | Decode the length of a list. --
src/Codec/CBOR/FlatTerm.hs view
@@ -301,10 +301,15 @@ go (TkBool b : ts) (ConsumeBool k) = k b >>= go ts go (TkSimple n : ts) (ConsumeSimple k) = k (unW8# n) >>= go ts - go (TkFloat16 f : ts) (ConsumeFloat16Canonical k) = k (unF# f) >>= go ts- go (TkFloat32 f : ts) (ConsumeFloatCanonical k) = k (unF# f) >>= go ts- go (TkFloat64 f : ts) (ConsumeDoubleCanonical k) = k (unD# f) >>= go ts- go (TkSimple n : ts) (ConsumeSimpleCanonical k) = k (unW8# n) >>= go ts+ go (TkFloat16 f : ts) (ConsumeFloat16Canonical k) = k (unF# f) >>= go ts+ go (TkFloat32 f : ts) (ConsumeFloatCanonical k) = k (unF# f) >>= go ts+ go (TkFloat64 f : ts) (ConsumeDoubleCanonical k) = k (unD# f) >>= go ts+ go (TkBytes bs : ts) (ConsumeBytesCanonical k) = k bs >>= go ts+ go (TkBytes bs : ts) (ConsumeByteArrayCanonical k) = k (BA.fromByteString bs) >>= go ts+ go (TkString st : ts) (ConsumeStringCanonical k) = k st >>= go ts+ go (TkString st : ts) (ConsumeUtf8ByteArrayCanonical k) = k (BA.fromByteString $ TE.encodeUtf8 st)+ >>= go ts+ go (TkSimple n : ts) (ConsumeSimpleCanonical k) = k (unW8# n) >>= go ts go (TkBytesBegin : ts) (ConsumeBytesIndef da) = da >>= go ts go (TkStringBegin : ts) (ConsumeStringIndef da) = da >>= go ts@@ -371,10 +376,14 @@ go ts (ConsumeBool _) = unexpected "decodeBool" ts go ts (ConsumeSimple _) = unexpected "decodeSimple" ts - go ts (ConsumeFloat16Canonical _) = unexpected "decodeFloat16Canonical" ts- go ts (ConsumeFloatCanonical _) = unexpected "decodeFloatCanonical" ts- go ts (ConsumeDoubleCanonical _) = unexpected "decodeDoubleCanonical" ts- go ts (ConsumeSimpleCanonical _) = unexpected "decodeSimpleCanonical" ts+ go ts (ConsumeFloat16Canonical _) = unexpected "decodeFloat16Canonical" ts+ go ts (ConsumeFloatCanonical _) = unexpected "decodeFloatCanonical" ts+ go ts (ConsumeDoubleCanonical _) = unexpected "decodeDoubleCanonical" ts+ go ts (ConsumeBytesCanonical _) = unexpected "decodeBytesCanonical" ts+ go ts (ConsumeByteArrayCanonical _) = unexpected "decodeByteArrayCanonical" ts+ go ts (ConsumeStringCanonical _) = unexpected "decodeStringCanonical" ts+ go ts (ConsumeUtf8ByteArrayCanonical _) = unexpected "decodeUtf8ByteArrayCanonical" ts+ go ts (ConsumeSimpleCanonical _) = unexpected "decodeSimpleCanonical" ts #if defined(ARCH_32bit) -- 64bit variants for 32bit machines
src/Codec/CBOR/Magic.hs view
@@ -5,6 +5,8 @@ {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE ScopedTypeVariables #-} +#include "cbor.h"+ -- | -- Module : Codec.CBOR.Magic -- Copyright : (c) Duncan Coutts 2015-2017@@ -38,6 +40,31 @@ , wordToFloat32 -- :: Word -> Float , wordToFloat64 -- :: Word64 -> Double + -- * Int and Word explicit conversions+ , word8ToWord -- :: Word8 -> Word+ , word16ToWord -- :: Word16 -> Word+ , word32ToWord -- :: Word32 -> Word+ , word64ToWord -- :: Word64 -> Word++ -- int*ToInt conversions are missing because they are not needed.++ , word8ToInt -- :: Int8 -> Int+ , word16ToInt -- :: Int16 -> Int+ , word32ToInt -- :: Int32 -> Int+ , word64ToInt -- :: Int64 -> Int++ , intToInt64 -- :: Int -> Int64+#if defined(ARCH_32bit)+ , word8ToInt64 -- :: Word8 -> Int64+ , word16ToInt64 -- :: Word16 -> Int64+ , word32ToInt64 -- :: Word32 -> Int64+ , word64ToInt64 -- :: Word64 -> Maybe Int64++ , word8ToWord64 -- :: Word8 -> Word64+ , word16ToWord64 -- :: Word16 -> Word64+ , word32ToWord64 -- :: Word32 -> Word64+#endif+ -- * @'Integer'@ utilities , nintegerFromBytes -- :: ByteString -> Integer , uintegerFromBytes -- :: ByteString -> Integer@@ -55,12 +82,11 @@ , copyByteArrayToByteString ) where -#include "cbor.h"- import GHC.Exts import GHC.ST (ST(ST)) import GHC.IO (IO(IO), unsafeDupablePerformIO) import GHC.Word+import GHC.Int import Foreign.Ptr #if defined(OPTIMIZE_GMP)@@ -74,29 +100,33 @@ import Data.Primitive.ByteArray as Prim import Foreign.ForeignPtr (withForeignPtr)+import Foreign.C (CUShort) import qualified Numeric.Half as Half #if !defined(HAVE_BYTESWAP_PRIMOPS) || !defined(MEM_UNALIGNED_OPS) import Data.Bits ((.|.), unsafeShiftL)+#endif #if defined(ARCH_32bit)-import GHC.IntWord64 (wordToWord64#)-#endif+import GHC.IntWord64 (wordToWord64#, word64ToWord#,+ intToInt64#, int64ToInt#,+ leWord64#, ltWord64#, word64ToInt64#)+ #endif -------------------------------------------------------------------------------- -- | Grab a 8-bit @'Word'@ given a @'Ptr'@ to some address.-grabWord8 :: Ptr () -> Word+grabWord8 :: Ptr () -> Word8 {-# INLINE grabWord8 #-} -- | Grab a 16-bit @'Word'@ given a @'Ptr'@ to some address.-grabWord16 :: Ptr () -> Word+grabWord16 :: Ptr () -> Word16 {-# INLINE grabWord16 #-} -- | Grab a 32-bit @'Word'@ given a @'Ptr'@ to some address.-grabWord32 :: Ptr () -> Word+grabWord32 :: Ptr () -> Word32 {-# INLINE grabWord32 #-} -- | Grab a 64-bit @'Word64'@ given a @'Ptr'@ to some address.@@ -108,7 +138,7 @@ -- -- 8-bit word case is always the same...-grabWord8 (Ptr ip#) = W# (indexWord8OffAddr# ip# 0#)+grabWord8 (Ptr ip#) = W8# (indexWord8OffAddr# ip# 0#) -- ... but the remaining cases arent #if defined(HAVE_BYTESWAP_PRIMOPS) && \@@ -117,8 +147,8 @@ -- On x86 machines with GHC 7.10, we have byteswap primitives -- available to make this conversion very fast. -grabWord16 (Ptr ip#) = W# (narrow16Word# (byteSwap16# (indexWord16OffAddr# ip# 0#)))-grabWord32 (Ptr ip#) = W# (narrow32Word# (byteSwap32# (indexWord32OffAddr# ip# 0#)))+grabWord16 (Ptr ip#) = W16# (narrow16Word# (byteSwap16# (indexWord16OffAddr# ip# 0#)))+grabWord32 (Ptr ip#) = W32# (narrow32Word# (byteSwap32# (indexWord32OffAddr# ip# 0#))) #if defined(ARCH_64bit) grabWord64 (Ptr ip#) = W64# (byteSwap# (indexWord64OffAddr# ip# 0#)) #else@@ -131,8 +161,8 @@ -- accesses on the machine, but it is also big-endian, we need to be -- able to decode these numbers efficiently, still. -grabWord16 (Ptr ip#) = W# (indexWord16OffAddr# ip# 0#)-grabWord32 (Ptr ip#) = W# (indexWord32OffAddr# ip# 0#)+grabWord16 (Ptr ip#) = W16# (indexWord16OffAddr# ip# 0#)+grabWord32 (Ptr ip#) = W32# (indexWord32OffAddr# ip# 0#) grabWord64 (Ptr ip#) = W64# (indexWord64OffAddr# ip# 0#) #else@@ -144,8 +174,8 @@ case indexWord8OffAddr# ip# 0# of w0# -> case indexWord8OffAddr# ip# 1# of- w1# -> W# w0# `unsafeShiftL` 8 .|.- W# w1#+ w1# -> W16# w0# `unsafeShiftL` 8 .|.+ W16# w1# grabWord32 (Ptr ip#) = case indexWord8OffAddr# ip# 0# of@@ -155,10 +185,10 @@ case indexWord8OffAddr# ip# 2# of w2# -> case indexWord8OffAddr# ip# 3# of- w3# -> W# w0# `unsafeShiftL` 24 .|.- W# w1# `unsafeShiftL` 16 .|.- W# w2# `unsafeShiftL` 8 .|.- W# w3#+ w3# -> W32# w0# `unsafeShiftL` 24 .|.+ W32# w1# `unsafeShiftL` 16 .|.+ W32# w2# `unsafeShiftL` 8 .|.+ W32# w3# grabWord64 (Ptr ip#) = case indexWord8OffAddr# ip# 0# of@@ -201,7 +231,7 @@ -- least 2 bytes long: one byte to drop from the front, and one to read as a -- @'Word'@ value. This is not checked, and failure to ensure this will result -- in undefined behavior.-eatTailWord8 :: ByteString -> Word+eatTailWord8 :: ByteString -> Word8 eatTailWord8 xs = withBsPtr grabWord8 (BS.unsafeTail xs) {-# INLINE eatTailWord8 #-} @@ -210,7 +240,7 @@ -- least 3 bytes long: one byte to drop from the front, and two to read as a -- 16-bit @'Word'@ value. This is not checked, and failure to ensure this will -- result in undefined behavior.-eatTailWord16 :: ByteString -> Word+eatTailWord16 :: ByteString -> Word16 eatTailWord16 xs = withBsPtr grabWord16 (BS.unsafeTail xs) {-# INLINE eatTailWord16 #-} @@ -219,7 +249,7 @@ -- least 5 bytes long: one byte to drop from the front, and four to read as a -- 32-bit @'Word'@ value. This is not checked, and failure to ensure this will -- result in undefined behavior.-eatTailWord32 :: ByteString -> Word+eatTailWord32 :: ByteString -> Word32 eatTailWord32 xs = withBsPtr grabWord32 (BS.unsafeTail xs) {-# INLINE eatTailWord32 #-} @@ -243,14 +273,20 @@ -------------------------------------------------------------------------------- -- Half floats --- | Convert a @'Word'@ to a half-sized @'Float'@.-wordToFloat16 :: Word -> Float-wordToFloat16 = \x -> Half.fromHalf (Half.Half (fromIntegral x))+-- | Convert a @'Word16'@ to a half-sized @'Float'@.+wordToFloat16 :: Word16 -> Float+wordToFloat16 = \x -> Half.fromHalf (Half.Half (cast x))+ where+ cast :: Word16 -> CUShort+ cast = fromIntegral {-# INLINE wordToFloat16 #-} -- | Convert a half-sized @'Float'@ to a @'Word'@. floatToWord16 :: Float -> Word16-floatToWord16 = \x -> fromIntegral (Half.getHalf (Half.toHalf x))+floatToWord16 = \x -> cast (Half.getHalf (Half.toHalf x))+ where+ cast :: CUShort -> Word16+ cast = fromIntegral {-# INLINE floatToWord16 #-} --------------------------------------------------------------------------------@@ -269,9 +305,9 @@ -- floated out and shared and aliased across multiple concurrent calls. So we -- do manual worker/wrapper with the worker not being inlined. --- | Cast a @'Word'@ to a @'Float'@.-wordToFloat32 :: Word -> Float-wordToFloat32 (W# w#) = F# (wordToFloat32# w#)+-- | Cast a @'Word32'@ to a @'Float'@.+wordToFloat32 :: Word32 -> Float+wordToFloat32 (W32# w#) = F# (wordToFloat32# w#) {-# INLINE wordToFloat32 #-} -- | Cast a @'Word64'@ to a @'Float'@.@@ -304,6 +340,111 @@ case readDoubleArray# mba# 0# s'' of (# _, f# #) -> f# {-# NOINLINE wordToFloat64# #-}++--------------------------------------------------------------------------------+-- Casting words and ints++word8ToWord :: Word8 -> Word+word16ToWord :: Word16 -> Word+word32ToWord :: Word32 -> Word+#if defined(ARCH_64bit)+word64ToWord :: Word64 -> Word+#else+word64ToWord :: Word64 -> Maybe Word+#endif++word8ToInt :: Word8 -> Int+word16ToInt :: Word16 -> Int+#if defined(ARCH_64bit)+word32ToInt :: Word32 -> Int+#else+word32ToInt :: Word32 -> Maybe Int+#endif+word64ToInt :: Word64 -> Maybe Int++#if defined(ARCH_32bit)+word8ToInt64 :: Word8 -> Int64+word16ToInt64 :: Word16 -> Int64+word32ToInt64 :: Word32 -> Int64+word64ToInt64 :: Word64 -> Maybe Int64++word8ToWord64 :: Word8 -> Word64+word16ToWord64 :: Word16 -> Word64+word32ToWord64 :: Word32 -> Word64+#endif++intToInt64 :: Int -> Int64+intToInt64 = fromIntegral+{-# INLINE intToInt64 #-}++word8ToWord (W8# w#) = W# w#+word16ToWord (W16# w#) = W# w#+word32ToWord (W32# w#) = W# w#+#if defined(ARCH_64bit)+word64ToWord (W64# w#) = W# w#+#else+word64ToWord (W64# w64#) =+ case isTrue# (w64# `leWord64#` wordToWord64# 0xffffffff##) of+ True -> Just (W# (word64ToWord# w64#))+ False -> Nothing+#endif++{-# INLINE word8ToWord #-}+{-# INLINE word16ToWord #-}+{-# INLINE word32ToWord #-}+{-# INLINE word64ToWord #-}++word8ToInt (W8# w#) = I# (word2Int# w#)+word16ToInt (W16# w#) = I# (word2Int# w#)++#if defined(ARCH_64bit)+word32ToInt (W32# w#) = I# (word2Int# w#)+#else+word32ToInt (W32# w#) =+ case isTrue# (w# `ltWord#` 0x80000000##) of+ True -> Just (I# (word2Int# w#))+ False -> Nothing+#endif++#if defined(ARCH_64bit)+word64ToInt (W64# w#) =+ case isTrue# (w# `ltWord#` 0x8000000000000000##) of+ True -> Just (I# (word2Int# w#))+ False -> Nothing+#else+word64ToInt (W64# w#) =+ case isTrue# (w# `ltWord64#` wordToWord64# 0x80000000##) of+ True -> Just (I# (int64ToInt# (word64ToInt64# w#)))+ False -> Nothing+#endif++{-# INLINE word8ToInt #-}+{-# INLINE word16ToInt #-}+{-# INLINE word32ToInt #-}+{-# INLINE word64ToInt #-}++#if defined(ARCH_32bit)+word8ToInt64 (W8# w#) = I64# (intToInt64# (word2Int# w#))+word16ToInt64 (W16# w#) = I64# (intToInt64# (word2Int# w#))+word32ToInt64 (W32# w#) = I64# (word64ToInt64# (wordToWord64# w#))+word64ToInt64 (W64# w#) =+ case isTrue# (w# `ltWord64#` uncheckedShiftL64# (wordToWord64# 1##) 63#) of+ True -> Just (I64# (word64ToInt64# w#))+ False -> Nothing++word8ToWord64 (W8# w#) = W64# (wordToWord64# w#)+word16ToWord64 (W16# w#) = W64# (wordToWord64# w#)+word32ToWord64 (W32# w#) = W64# (wordToWord64# w#)++{-# INLINE word8ToInt64 #-}+{-# INLINE word16ToInt64 #-}+{-# INLINE word32ToInt64 #-}+{-# INLINE word64ToInt64 #-}++{-# INLINE word8ToWord64 #-}+{-# INLINE word16ToWord64 #-}+{-# INLINE word32ToWord64 #-}+#endif -------------------------------------------------------------------------------- -- Integer utilities
src/Codec/CBOR/Read.hs view
@@ -1,15 +1,17 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-} -#if __GLASGOW_HASKELL__ > 706 -- Bump up from the default 1.5, otherwise our decoder fast path is no good. -- We went over the threshold when we switched to using ST. {-# OPTIONS_GHC -funfolding-keeness-factor=2.0 #-}-#endif -- | -- Module : Codec.CBOR.Read@@ -39,6 +41,7 @@ #endif import GHC.Int +import Control.DeepSeq import Control.Monad (ap) import Control.Monad.ST import Data.Array.IArray@@ -63,6 +66,9 @@ import Data.Typeable import Control.Exception +-- We do all numeric conversions explicitly to be careful about overflows.+import Prelude hiding (fromIntegral)+ import qualified Codec.CBOR.ByteArray as BA import Codec.CBOR.Decoding hiding (DecodeAction(Done, Fail)) import Codec.CBOR.Decoding (DecodeAction)@@ -76,8 +82,11 @@ -- -- @since 0.2.0.0 data DeserialiseFailure = DeserialiseFailure ByteOffset String- deriving (Show, Typeable)+ deriving (Eq, Show, Typeable) +instance NFData DeserialiseFailure where+ rnf (DeserialiseFailure offset msg) = rnf offset `seq` rnf msg `seq` ()+ instance Exception DeserialiseFailure where #if MIN_VERSION_base(4,8,0) displayException (DeserialiseFailure off msg) =@@ -369,6 +378,7 @@ 0# | isWordCanonical sz w# -> k w# >>= go_fast (BS.unsafeDrop sz bs) _ -> go_fast_end bs da where+ w_out_of_range :: Word# -> Int# w_out_of_range _w# = #if defined(ARCH_32bit) 0#@@ -414,6 +424,7 @@ 0# | isIntCanonical sz n# -> k n# >>= go_fast (BS.unsafeDrop sz bs) _ -> go_fast_end bs da where+ n_out_of_range :: Int# -> Int# n_out_of_range _n# = #if defined(ARCH_32bit) 0#@@ -479,8 +490,8 @@ case tryConsumeWord64 (BS.unsafeHead bs) bs of DecodeFailure -> go_fast_end bs da DecodedToken sz (W64# w#)- | isWord64Canonical -> k w# >>= go_fast (BS.unsafeDrop sz bs)- | otherwise -> go_fast_end bs da+ | isWord64Canonical sz w# -> k w# >>= go_fast (BS.unsafeDrop sz bs)+ | otherwise -> go_fast_end bs da go_fast !bs da@(ConsumeNegWord64Canonical k) = case tryConsumeNegWord64 (BS.unsafeHead bs) bs of@@ -501,16 +512,16 @@ DecodeFailure -> go_fast_end bs da DecodedToken sz (I64# i#) -- List length can't be negative, cast it to Word64#.- | isWord64Canonical sz (int64ToWord64 i#) -> k i# >>= go_fast (BS.unsafeDrop sz bs)- | otherwise -> go_fast_end bs da+ | isWord64Canonical sz (int64ToWord64# i#) -> k i# >>= go_fast (BS.unsafeDrop sz bs)+ | otherwise -> go_fast_end bs da go_fast !bs da@(ConsumeMapLen64Canonical k) = case tryConsumeMapLen64 (BS.unsafeHead bs) bs of DecodeFailure -> go_fast_end bs da DecodedToken sz (I64# i#) -- Map length can't be negative, cast it to Word64#.- | isWord64Canonical sz (int64ToWord64 i#) -> k i# >>= go_fast (BS.unsafeDrop sz bs)- | otherwise -> go_fast_end bs da+ | isWord64Canonical sz (int64ToWord64# i#) -> k i# >>= go_fast (BS.unsafeDrop sz bs)+ | otherwise -> go_fast_end bs da go_fast !bs da@(ConsumeTag64Canonical k) = case tryConsumeTag64 (BS.unsafeHead bs) bs of@@ -537,29 +548,34 @@ go_fast !bs da@(ConsumeBytes k) = case tryConsumeBytes (BS.unsafeHead bs) bs of- DecodeFailure -> go_fast_end bs da- DecodedToken sz (Fits bstr) -> k bstr >>= go_fast (BS.unsafeDrop sz bs)- DecodedToken sz (TooLong len) -> return $! SlowConsumeTokenBytes (BS.unsafeDrop sz bs) k len+ DecodeFailure -> go_fast_end bs da+ DecodedToken sz (Fits _ bstr) -> k bstr >>= go_fast (BS.unsafeDrop sz bs)+ DecodedToken sz (TooLong _ len) -> return $! SlowConsumeTokenBytes+ (BS.unsafeDrop sz bs) k len go_fast !bs da@(ConsumeByteArray k) = case tryConsumeBytes (BS.unsafeHead bs) bs of DecodeFailure -> go_fast_end bs da- DecodedToken sz (Fits str) -> k (BA.fromByteString str) >>= go_fast (BS.unsafeDrop sz bs)- DecodedToken sz (TooLong len) -> return $! SlowConsumeTokenByteArray (BS.unsafeDrop sz bs) k len+ DecodedToken sz (Fits _ str) -> k (BA.fromByteString str) >>= go_fast (BS.unsafeDrop sz bs)+ DecodedToken sz (TooLong _ len) -> return $! SlowConsumeTokenByteArray+ (BS.unsafeDrop sz bs) k len go_fast !bs da@(ConsumeString k) = case tryConsumeString (BS.unsafeHead bs) bs of- DecodeFailure -> go_fast_end bs da- DecodedToken sz (Fits str) -> case T.decodeUtf8' str of- Right t -> k t >>= go_fast (BS.unsafeDrop sz bs)- Left e -> return $! SlowFail bs (show e)- DecodedToken sz (TooLong len) -> return $! SlowConsumeTokenString (BS.unsafeDrop sz bs) k len+ DecodeFailure -> go_fast_end bs da+ DecodedToken sz (Fits _ str) -> case T.decodeUtf8' str of+ Right t -> k t >>= go_fast (BS.unsafeDrop sz bs)+ Left _e -> return $! SlowFail bs "invalid UTF8"+ DecodedToken sz (TooLong _ len) -> return $! SlowConsumeTokenString+ (BS.unsafeDrop sz bs) k len go_fast !bs da@(ConsumeUtf8ByteArray k) = case tryConsumeString (BS.unsafeHead bs) bs of- DecodeFailure -> go_fast_end bs da- DecodedToken sz (Fits str) -> k (BA.fromByteString str) >>= go_fast (BS.unsafeDrop sz bs)- DecodedToken sz (TooLong len) -> return $! SlowConsumeTokenUtf8ByteArray (BS.unsafeDrop sz bs) k len+ DecodeFailure -> go_fast_end bs da+ DecodedToken sz (Fits _ str) -> k (BA.fromByteString str)+ >>= go_fast (BS.unsafeDrop sz bs)+ DecodedToken sz (TooLong _ len) -> return $! SlowConsumeTokenUtf8ByteArray+ (BS.unsafeDrop sz bs) k len go_fast !bs da@(ConsumeBool k) = case tryConsumeBool (BS.unsafeHead bs) of@@ -598,6 +614,38 @@ | isDoubleCanonical sz bs f -> k f# >>= go_fast (BS.unsafeDrop sz bs) | otherwise -> go_fast_end bs da +go_fast !bs da@(ConsumeBytesCanonical k) =+ case tryConsumeBytes (BS.unsafeHead bs) bs of+ DecodedToken sz (Fits True bstr) -> k bstr >>= go_fast (BS.unsafeDrop sz bs)+ DecodedToken sz (TooLong True len) ->+ return $! SlowConsumeTokenBytes (BS.unsafeDrop sz bs) k len+ _ -> go_fast_end bs da++go_fast !bs da@(ConsumeByteArrayCanonical k) =+ case tryConsumeBytes (BS.unsafeHead bs) bs of+ DecodedToken sz (Fits True str) ->+ k (BA.fromByteString str) >>= go_fast (BS.unsafeDrop sz bs)+ DecodedToken sz (TooLong True len) ->+ return $! SlowConsumeTokenByteArray (BS.unsafeDrop sz bs) k len+ _ -> go_fast_end bs da++go_fast !bs da@(ConsumeStringCanonical k) =+ case tryConsumeString (BS.unsafeHead bs) bs of+ DecodedToken sz (Fits True str) -> case T.decodeUtf8' str of+ Right t -> k t >>= go_fast (BS.unsafeDrop sz bs)+ Left _e -> return $! SlowFail bs "invalid UTF8"+ DecodedToken sz (TooLong True len) ->+ return $! SlowConsumeTokenString (BS.unsafeDrop sz bs) k len+ _ -> go_fast_end bs da++go_fast !bs da@(ConsumeUtf8ByteArrayCanonical k) =+ case tryConsumeString (BS.unsafeHead bs) bs of+ DecodedToken sz (Fits True str) ->+ k (BA.fromByteString str) >>= go_fast (BS.unsafeDrop sz bs)+ DecodedToken sz (TooLong True len) ->+ return $! SlowConsumeTokenUtf8ByteArray (BS.unsafeDrop sz bs) k len+ _ -> go_fast_end bs da+ go_fast !bs da@(ConsumeSimpleCanonical k) = case tryConsumeSimple (BS.unsafeHead bs) bs of DecodeFailure -> go_fast_end bs da@@ -647,7 +695,7 @@ go_fast !bs (PeekTokenType k) = let !hdr = BS.unsafeHead bs- !tkty = decodeTokenTypeTable `A.unsafeAt` fromIntegral hdr+ !tkty = decodeTokenTypeTable `A.unsafeAt` word8ToInt hdr in k tkty >>= go_fast bs go_fast !bs (PeekAvailable k) = k (case BS.length bs of I# len# -> len#) >>= go_fast bs@@ -681,7 +729,7 @@ go_fast_end !bs (PeekTokenType k) = let !hdr = BS.unsafeHead bs- !tkty = decodeTokenTypeTable `A.unsafeAt` fromIntegral hdr+ !tkty = decodeTokenTypeTable `A.unsafeAt` word8ToInt hdr in k tkty >>= go_fast_end bs -- all the remaining cases have to decode the current token@@ -808,6 +856,7 @@ | otherwise -> return $! SlowFail bs "non-canonical word32" _ -> return $! SlowFail bs "expected word32" where+ w_out_of_range :: Word# -> Int# w_out_of_range _w# = #if defined(ARCH_32bit) 0#@@ -856,6 +905,7 @@ | otherwise -> return $! SlowFail bs "non-canonical int32" _ -> return $! SlowFail bs "expected int32" where+ n_out_of_range :: Int# -> Int# n_out_of_range _n# = #if defined(ARCH_32bit) 0#@@ -894,7 +944,7 @@ go_fast_end !bs (ConsumeNegWord64 k) = case tryConsumeNegWord64 (BS.unsafeHead bs) bs of- DecodeFailure -> return $! SlowFail bs "expected negative word64"+ DecodeFailure -> return $! SlowFail bs "expected negative int" DecodedToken sz (W64# w#) -> k w# >>= go_fast_end (BS.unsafeDrop sz bs) go_fast_end !bs (ConsumeInt64 k) =@@ -916,14 +966,63 @@ case tryConsumeTag64 (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected tag64" DecodedToken sz (W64# w#) -> k w# >>= go_fast_end (BS.unsafeDrop sz bs)++go_fast_end !bs (ConsumeWord64Canonical k) =+ case tryConsumeWord64 (BS.unsafeHead bs) bs of+ DecodeFailure -> return $! SlowFail bs "expected word64"+ DecodedToken sz (W64# w#)+ | isWord64Canonical sz w# -> k w# >>= go_fast_end (BS.unsafeDrop sz bs)+ | otherwise -> return $! SlowFail bs "non-canonical word64"++go_fast_end !bs (ConsumeNegWord64Canonical k) =+ case tryConsumeNegWord64 (BS.unsafeHead bs) bs of+ DecodeFailure -> return $! SlowFail bs "expected negative int"+ DecodedToken sz (W64# w#)+ | isWord64Canonical sz w# -> k w# >>= go_fast_end (BS.unsafeDrop sz bs)+ | otherwise -> return $! SlowFail bs "non-canonical negative int"++go_fast_end !bs (ConsumeInt64Canonical k) =+ case tryConsumeInt64 (BS.unsafeHead bs) bs of+ DecodeFailure -> return $! SlowFail bs "expected int64"+ DecodedToken sz (I64# i#)+ | isInt64Canonical sz i# -> k i# >>= go_fast_end (BS.unsafeDrop sz bs)+ | otherwise -> return $! SlowFail bs "non-canonical int64"++go_fast_end !bs (ConsumeListLen64Canonical k) =+ case tryConsumeListLen64 (BS.unsafeHead bs) bs of+ DecodeFailure -> return $! SlowFail bs "expected list len 64"+ DecodedToken sz (I64# i#)+ -- List length can't be negative, cast it to Word64#.+ | isWord64Canonical sz (int64ToWord64# i#) ->+ k i# >>= go_fast_end (BS.unsafeDrop sz bs)+ | otherwise ->+ return $! SlowFail bs "non-canonical list len 64"++go_fast_end !bs (ConsumeMapLen64Canonical k) =+ case tryConsumeMapLen64 (BS.unsafeHead bs) bs of+ DecodeFailure -> return $! SlowFail bs "expected map len 64"+ DecodedToken sz (I64# i#)+ -- Map length can't be negative, cast it to Word64#.+ | isWord64Canonical sz (int64ToWord64# i#) ->+ k i# >>= go_fast_end (BS.unsafeDrop sz bs)+ | otherwise ->+ return $! SlowFail bs "non-canonical map len 64"++go_fast_end !bs (ConsumeTag64Canonical k) =+ case tryConsumeTag64 (BS.unsafeHead bs) bs of+ DecodeFailure -> return $! SlowFail bs "expected tag64"+ DecodedToken sz (W64# w#)+ | isWord64Canonical sz w# -> k w# >>= go_fast_end (BS.unsafeDrop sz bs)+ | otherwise -> return $! SlowFail bs "non-canonical tag64"+ #endif go_fast_end !bs (ConsumeInteger k) = case tryConsumeInteger (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected integer" DecodedToken sz (BigIntToken _ n) -> k n >>= go_fast_end (BS.unsafeDrop sz bs)- DecodedToken sz (BigUIntNeedBody len) -> return $! SlowConsumeTokenBytes (BS.unsafeDrop sz bs) (adjustContBigUIntNeedBody k) len- DecodedToken sz (BigNIntNeedBody len) -> return $! SlowConsumeTokenBytes (BS.unsafeDrop sz bs) (adjustContBigNIntNeedBody k) len+ DecodedToken sz (BigUIntNeedBody _ len) -> return $! SlowConsumeTokenBytes (BS.unsafeDrop sz bs) (adjustContBigUIntNeedBody k) len+ DecodedToken sz (BigNIntNeedBody _ len) -> return $! SlowConsumeTokenBytes (BS.unsafeDrop sz bs) (adjustContBigNIntNeedBody k) len DecodedToken sz BigUIntNeedHeader -> return $! SlowDecodeAction (BS.unsafeDrop sz bs) (adjustContBigUIntNeedHeader k) DecodedToken sz BigNIntNeedHeader -> return $! SlowDecodeAction (BS.unsafeDrop sz bs) (adjustContBigNIntNeedHeader k) @@ -939,29 +1038,35 @@ go_fast_end !bs (ConsumeBytes k) = case tryConsumeBytes (BS.unsafeHead bs) bs of- DecodeFailure -> return $! SlowFail bs "expected bytes"- DecodedToken sz (Fits bstr) -> k bstr >>= go_fast_end (BS.unsafeDrop sz bs)- DecodedToken sz (TooLong len) -> return $! SlowConsumeTokenBytes (BS.unsafeDrop sz bs) k len+ DecodeFailure -> return $! SlowFail bs "expected bytes"+ DecodedToken sz (Fits _ bstr) -> k bstr >>= go_fast_end (BS.unsafeDrop sz bs)+ DecodedToken sz (TooLong _ len) -> return $! SlowConsumeTokenBytes+ (BS.unsafeDrop sz bs) k len go_fast_end !bs (ConsumeByteArray k) = case tryConsumeBytes (BS.unsafeHead bs) bs of- DecodeFailure -> return $! SlowFail bs "expected string"- DecodedToken sz (Fits str) -> (k $! BA.fromByteString str) >>= go_fast_end (BS.unsafeDrop sz bs)- DecodedToken sz (TooLong len) -> return $! SlowConsumeTokenByteArray (BS.unsafeDrop sz bs) k len+ DecodeFailure -> return $! SlowFail bs "expected string"+ DecodedToken sz (Fits _ str) -> (k $! BA.fromByteString str)+ >>= go_fast_end (BS.unsafeDrop sz bs)+ DecodedToken sz (TooLong _ len) -> return $! SlowConsumeTokenByteArray+ (BS.unsafeDrop sz bs) k len go_fast_end !bs (ConsumeString k) = case tryConsumeString (BS.unsafeHead bs) bs of- DecodeFailure -> return $! SlowFail bs "expected string"- DecodedToken sz (Fits str) -> case T.decodeUtf8' str of- Right t -> k t >>= go_fast_end (BS.unsafeDrop sz bs)- Left e -> return $! SlowFail bs (show e)- DecodedToken sz (TooLong len) -> return $! SlowConsumeTokenString (BS.unsafeDrop sz bs) k len+ DecodeFailure -> return $! SlowFail bs "expected string"+ DecodedToken sz (Fits _ str) -> case T.decodeUtf8' str of+ Right t -> k t >>= go_fast_end (BS.unsafeDrop sz bs)+ Left _e -> return $! SlowFail bs "invalid UTF8"+ DecodedToken sz (TooLong _ len) -> return $! SlowConsumeTokenString+ (BS.unsafeDrop sz bs) k len go_fast_end !bs (ConsumeUtf8ByteArray k) = case tryConsumeString (BS.unsafeHead bs) bs of- DecodeFailure -> return $! SlowFail bs "expected string"- DecodedToken sz (Fits str) -> (k $! BA.fromByteString str) >>= go_fast_end (BS.unsafeDrop sz bs)- DecodedToken sz (TooLong len) -> return $! SlowConsumeTokenUtf8ByteArray (BS.unsafeDrop sz bs) k len+ DecodeFailure -> return $! SlowFail bs "expected string"+ DecodedToken sz (Fits _ str) -> (k $! BA.fromByteString str)+ >>= go_fast_end (BS.unsafeDrop sz bs)+ DecodedToken sz (TooLong _ len) -> return $! SlowConsumeTokenUtf8ByteArray+ (BS.unsafeDrop sz bs) k len go_fast_end !bs (ConsumeBool k) = case tryConsumeBool (BS.unsafeHead bs) of@@ -976,13 +1081,16 @@ go_fast_end !bs (ConsumeIntegerCanonical k) = case tryConsumeInteger (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected integer"- DecodedToken sz (BigIntToken canonical n)- | canonical -> k n >>= go_fast_end (BS.unsafeDrop sz bs)- | otherwise -> return $! SlowFail bs "non-canonical integer"- DecodedToken sz (BigUIntNeedBody len) -> return $! SlowConsumeTokenBytes (BS.unsafeDrop sz bs) (adjustContBigUIntNeedBody k) len- DecodedToken sz (BigNIntNeedBody len) -> return $! SlowConsumeTokenBytes (BS.unsafeDrop sz bs) (adjustContBigNIntNeedBody k) len- DecodedToken sz BigUIntNeedHeader -> return $! SlowDecodeAction (BS.unsafeDrop sz bs) (adjustContBigUIntNeedHeader k)- DecodedToken sz BigNIntNeedHeader -> return $! SlowDecodeAction (BS.unsafeDrop sz bs) (adjustContBigNIntNeedHeader k)+ DecodedToken sz (BigIntToken True n) -> k n >>= go_fast_end (BS.unsafeDrop sz bs)+ DecodedToken sz (BigUIntNeedBody True len) -> return $! SlowConsumeTokenBytes+ (BS.unsafeDrop sz bs) (adjustContCanonicalBigUIntNeedBody k) len+ DecodedToken sz (BigNIntNeedBody True len) -> return $! SlowConsumeTokenBytes+ (BS.unsafeDrop sz bs) (adjustContCanonicalBigNIntNeedBody k) len+ DecodedToken sz BigUIntNeedHeader -> return $! SlowDecodeAction+ (BS.unsafeDrop sz bs) (adjustContCanonicalBigUIntNeedHeader k)+ DecodedToken sz BigNIntNeedHeader -> return $! SlowDecodeAction+ (BS.unsafeDrop sz bs) (adjustContCanonicalBigNIntNeedHeader k)+ _ -> return $! SlowFail bs "non-canonical integer" go_fast_end !bs (ConsumeFloat16Canonical k) = case tryConsumeFloat (BS.unsafeHead bs) bs of@@ -1005,6 +1113,45 @@ | isDoubleCanonical sz bs f -> k f# >>= go_fast_end (BS.unsafeDrop sz bs) | otherwise -> return $! SlowFail bs "non-canonical double" +go_fast_end !bs (ConsumeBytesCanonical k) =+ case tryConsumeBytes (BS.unsafeHead bs) bs of+ DecodeFailure -> return $! SlowFail bs "expected bytes"+ DecodedToken sz token -> case token of+ Fits True bstr -> k bstr >>= go_fast_end (BS.unsafeDrop sz bs)+ TooLong True len -> return $! SlowConsumeTokenBytes (BS.unsafeDrop sz bs) k len+ _ -> return $! SlowFail bs "non-canonical length prefix"++go_fast_end !bs (ConsumeByteArrayCanonical k) =+ case tryConsumeBytes (BS.unsafeHead bs) bs of+ DecodeFailure -> return $! SlowFail bs "expected string"+ DecodedToken sz token -> case token of+ Fits True str ->+ (k $! BA.fromByteString str) >>= go_fast_end (BS.unsafeDrop sz bs)+ TooLong True len ->+ return $! SlowConsumeTokenByteArray (BS.unsafeDrop sz bs) k len+ _ -> return $! SlowFail bs "non-canonical length prefix"++go_fast_end !bs (ConsumeStringCanonical k) =+ case tryConsumeString (BS.unsafeHead bs) bs of+ DecodeFailure -> return $! SlowFail bs "expected string"+ DecodedToken sz token -> case token of+ Fits True str -> case T.decodeUtf8' str of+ Right t -> k t >>= go_fast_end (BS.unsafeDrop sz bs)+ Left _e -> return $! SlowFail bs "invalid UTF8"+ TooLong True len -> return $! SlowConsumeTokenString (BS.unsafeDrop sz bs) k len+ _ -> return $! SlowFail bs "non-canonical length prefix"++go_fast_end !bs (ConsumeUtf8ByteArrayCanonical k) =+ case tryConsumeString (BS.unsafeHead bs) bs of+ DecodeFailure -> return $! SlowFail bs "expected string"+ DecodedToken sz token -> case token of+ Fits True str ->+ (k $! BA.fromByteString str) >>= go_fast_end (BS.unsafeDrop sz bs)+ TooLong True len ->+ return $! SlowConsumeTokenUtf8ByteArray (BS.unsafeDrop sz bs) k len+ _ ->+ return $! SlowFail bs "non-canonical length prefix"+ go_fast_end !bs (ConsumeSimpleCanonical k) = case tryConsumeSimple (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected simple"@@ -1062,34 +1209,36 @@ case slowpath of FastDone bs' x -> return (bs', offset', x) where- !offset' = offset + fromIntegral (BS.length bs - BS.length bs')+ !offset' = offset + intToInt64 (BS.length bs - BS.length bs') SlowConsumeTokenBytes bs' k len -> do (bstr, bs'') <- getTokenVarLen len bs' offset'- lift (k bstr) >>= \daz -> go_slow daz bs'' (offset' + fromIntegral len)+ lift (k bstr) >>= \daz -> go_slow daz bs'' (offset' + intToInt64 len) where- !offset' = offset + fromIntegral (BS.length bs - BS.length bs')+ !offset' = offset + intToInt64 (BS.length bs - BS.length bs') SlowConsumeTokenByteArray bs' k len -> do (bstr, bs'') <- getTokenVarLen len bs' offset' let !str = BA.fromByteString bstr- lift (k str) >>= \daz -> go_slow daz bs'' (offset' + fromIntegral len)+ lift (k str) >>= \daz -> go_slow daz bs'' (offset' + intToInt64 len) where- !offset' = offset + fromIntegral (BS.length bs - BS.length bs')+ !offset' = offset + intToInt64 (BS.length bs - BS.length bs') SlowConsumeTokenString bs' k len -> do (bstr, bs'') <- getTokenVarLen len bs' offset'- let !str = T.decodeUtf8 bstr -- TODO FIXME: utf8 validation- lift (k str) >>= \daz -> go_slow daz bs'' (offset' + fromIntegral len)+ case T.decodeUtf8' bstr of+ Right str -> lift (k str) >>= \daz ->+ go_slow daz bs'' (offset' + intToInt64 len)+ Left _e -> decodeFail bs' offset' "invalid UTF8" where- !offset' = offset + fromIntegral (BS.length bs - BS.length bs')+ !offset' = offset + intToInt64 (BS.length bs - BS.length bs') SlowConsumeTokenUtf8ByteArray bs' k len -> do (bstr, bs'') <- getTokenVarLen len bs' offset' let !str = BA.fromByteString bstr- lift (k str) >>= \daz -> go_slow daz bs'' (offset' + fromIntegral len)+ lift (k str) >>= \daz -> go_slow daz bs'' (offset' + intToInt64 len) where- !offset' = offset + fromIntegral (BS.length bs - BS.length bs')+ !offset' = offset + intToInt64 (BS.length bs - BS.length bs') -- we didn't have enough input in the buffer SlowDecodeAction bs' da' | BS.null bs' -> do@@ -1100,7 +1249,7 @@ Nothing -> decodeFail bs' offset' "end of input" Just bs'' -> go_slow da' bs'' offset' where- !offset' = offset + fromIntegral (BS.length bs - BS.length bs')+ !offset' = offset + intToInt64 (BS.length bs - BS.length bs') SlowDecodeAction bs' da' -> -- of course we should only end up here when we really are out of@@ -1108,11 +1257,11 @@ assert (BS.length bs' < tokenSize (BS.head bs')) $ go_slow_fixup da' bs' offset' where- !offset' = offset + fromIntegral (BS.length bs - BS.length bs')+ !offset' = offset + intToInt64 (BS.length bs - BS.length bs') SlowFail bs' msg -> decodeFail bs' offset' msg where- !offset' = offset + fromIntegral (BS.length bs - BS.length bs')+ !offset' = offset + intToInt64 (BS.length bs - BS.length bs') -- The complicated case is when a token spans a chunk boundary. --@@ -1160,7 +1309,7 @@ let bs_tok = bs_cur <> BS.unsafeTake (sz - BS.length bs_cur) bs_next bs' = BS.unsafeDrop (sz - BS.length bs_cur) bs_next- offset' = offset + fromIntegral sz in+ offset' = offset + intToInt64 sz in -- so the token chunk should be exactly the right size assert (BS.length bs_tok == sz) $@@ -1182,37 +1331,46 @@ assert (BS.null bs_empty) $ return (bs', offset', x) - SlowConsumeTokenBytes bs_empty k len -> consume id bs' offset' bs_empty k len+ SlowConsumeTokenBytes bs_empty k len ->+ assert (BS.null bs_empty) $ do+ (bstr, bs'') <- getTokenShortOrVarLen bs' offset' len+ lift (k bstr) >>= \daz -> go_slow daz bs'' (offset' + intToInt64 len) - SlowConsumeTokenByteArray bs_empty k len -> consume BA.fromByteString bs' offset' bs_empty k len+ SlowConsumeTokenByteArray bs_empty k len ->+ assert (BS.null bs_empty) $ do+ (bstr, bs'') <- getTokenShortOrVarLen bs' offset' len+ let !ba = BA.fromByteString bstr+ lift (k ba) >>= \daz -> go_slow daz bs'' (offset' + intToInt64 len) - SlowConsumeTokenString bs_empty k len -> consume T.decodeUtf8 bs' offset' bs_empty k len- -- TODO FIXME: utf8 validation+ SlowConsumeTokenString bs_empty k len ->+ assert (BS.null bs_empty) $ do+ (bstr, bs'') <- getTokenShortOrVarLen bs' offset' len+ case T.decodeUtf8' bstr of+ Right str -> lift (k str) >>= \daz ->+ go_slow daz bs'' (offset' + intToInt64 len)+ Left _e -> decodeFail bs' offset' "invalid UTF8" - SlowConsumeTokenUtf8ByteArray bs_empty k len -> consume BA.fromByteString bs' offset' bs_empty k len+ SlowConsumeTokenUtf8ByteArray bs_empty k len ->+ assert (BS.null bs_empty) $ do+ (bstr, bs'') <- getTokenShortOrVarLen bs' offset' len+ let !ba = BA.fromByteString bstr+ lift (k ba) >>= \daz -> go_slow daz bs'' (offset' + intToInt64 len) SlowFail bs_unconsumed msg -> decodeFail (bs_unconsumed <> bs') offset'' msg where- !offset'' = offset + fromIntegral (sz - BS.length bs_unconsumed)+ !offset'' = offset + intToInt64 (sz - BS.length bs_unconsumed) where- {-# INLINE consume #-}- consume :: (BS.ByteString -> a)- -> BS.ByteString -- bs'- -> Int64 -- offset'- -> BS.ByteString -- bs_empty- -> (a -> ST s (DecodeAction s r)) -- continuation- -> Int -- length- -> IncrementalDecoder s (ByteString, ByteOffset, r)- consume pack bs' offset' bs_empty k len =- assert (BS.null bs_empty) $ do- (bstr, bs'') <- if BS.length bs' < len- then getTokenVarLen len bs' offset'- else let !bstr = BS.take len bs'- !bs'' = BS.drop len bs'- in return (bstr, bs'')- let !str = pack bstr- lift (k str) >>= \daz -> go_slow daz bs'' (offset' + fromIntegral len)+ {-# INLINE getTokenShortOrVarLen #-}+ getTokenShortOrVarLen :: BS.ByteString+ -> ByteOffset+ -> Int+ -> IncrementalDecoder s (ByteString, ByteString)+ getTokenShortOrVarLen bs' offset' len+ | BS.length bs' < len = getTokenVarLen len bs' offset'+ | otherwise = let !bstr = BS.take len bs'+ !bs'' = BS.drop len bs'+ in return (bstr, bs'') -- TODO FIXME: we can do slightly better here. If we're returning a@@ -1257,8 +1415,8 @@ tokenSize :: Word8 -> Int tokenSize hdr =- fromIntegral $- decodeTableSz `A.unsafeAt` (fromIntegral hdr .&. 0x1f)+ word8ToInt $+ decodeTableSz `A.unsafeAt` (word8ToInt hdr .&. 0x1f) decodeTableSz :: UArray Word8 Word8 decodeTableSz =@@ -1310,13 +1468,18 @@ ++ [ (encodeHeader mt n, TypeInvalid) | mt <- [0..7], n <- [28..30] ] -encodeHeader :: Word -> Word -> Word8-encodeHeader mt ai = fromIntegral (mt `shiftL` 5 .|. ai)+encodeHeader :: Word8 -> Word8 -> Word8+encodeHeader mt ai = mt `shiftL` 5 .|. ai data DecodedToken a = DecodedToken !Int !a | DecodeFailure deriving Show+-- TODO add classification for DecodeFailure -data LongToken a = Fits !a | TooLong !Int+-- | Note that canonicity information is calculated lazily. This way we don't+-- need to concern ourselves with two distinct paths, while according to+-- benchmarks it doesn't affect performance in the non-canonical case.+data LongToken a = Fits Bool {- canonical? -} !a+ | TooLong Bool {- canonical? -} !Int deriving Show {-# INLINE isFloat16Canonical #-}@@ -1340,11 +1503,11 @@ {-# INLINE isWordCanonical #-} isWordCanonical :: Int -> Word# -> Bool isWordCanonical sz w#- | sz == 2 && isTrue# (w# `leWord#` 0x17##) = False- | sz == 3 && isTrue# (w# `leWord#` 0xff##) = False- | sz == 5 && isTrue# (w# `leWord#` 0xffff##) = False- | sz == 9 && isTrue# (w# `leWord#` 0xffffffff##) = False- | otherwise = True+ | sz == 2 = isTrue# (w# `gtWord#` 0x17##)+ | sz == 3 = isTrue# (w# `gtWord#` 0xff##)+ | sz == 5 = isTrue# (w# `gtWord#` 0xffff##)+ | sz == 9 = isTrue# (w# `gtWord#` 0xffffffff##)+ | otherwise = True {-# INLINE isIntCanonical #-} isIntCanonical :: Int -> Int# -> Bool@@ -1358,17 +1521,17 @@ {-# INLINE isWord64Canonical #-} isWord64Canonical :: Int -> Word64# -> Bool isWord64Canonical sz w#- | sz == 2 && isTrue# (w# `leWord64#` 0x17##) = False- | sz == 3 && isTrue# (w# `leWord64#` 0xff##) = False- | sz == 5 && isTrue# (w# `leWord64#` 0xffff##) = False- | sz == 9 && isTrue# (w# `leWord64#` 0xffffffff##) = False- | otherwise = True+ | sz == 2 = isTrue# (w# `gtWord64#` wordToWord64# 0x17##)+ | sz == 3 = isTrue# (w# `gtWord64#` wordToWord64# 0xff##)+ | sz == 5 = isTrue# (w# `gtWord64#` wordToWord64# 0xffff##)+ | sz == 9 = isTrue# (w# `gtWord64#` wordToWord64# 0xffffffff##)+ | otherwise = True {-# INLINE isInt64Canonical #-} isInt64Canonical :: Int -> Int64# -> Bool isInt64Canonical sz i#- | isTrue# (i# <# 0#) = isWord64Canonical sz (not64# w#)- | otherwise = isWord64Canonical sz w#+ | isTrue# (i# `ltInt64#` intToInt64# 0#) = isWord64Canonical sz (not64# w#)+ | otherwise = isWord64Canonical sz w# where w# = int64ToWord64# i# #endif@@ -1380,7 +1543,7 @@ {-# INLINE tryConsumeWord #-} tryConsumeWord :: Word8 -> ByteString -> DecodedToken Word-tryConsumeWord hdr !bs = case fromIntegral hdr :: Word of+tryConsumeWord hdr !bs = case word8ToWord hdr of -- Positive integers (type 0) 0x00 -> DecodedToken 1 0 0x01 -> DecodedToken 1 1@@ -1406,16 +1569,22 @@ 0x15 -> DecodedToken 1 21 0x16 -> DecodedToken 1 22 0x17 -> DecodedToken 1 23- 0x18 -> DecodedToken 2 (eatTailWord8 bs)- 0x19 -> DecodedToken 3 (eatTailWord16 bs)- 0x1a -> DecodedToken 5 (eatTailWord32 bs)- 0x1b -> DecodedToken 9 (fromIntegral $ eatTailWord64 bs) -- TODO FIXME: overflow+ 0x18 -> DecodedToken 2 (word8ToWord (eatTailWord8 bs))+ 0x19 -> DecodedToken 3 (word16ToWord (eatTailWord16 bs))+ 0x1a -> DecodedToken 5 (word32ToWord (eatTailWord32 bs))+#if defined(ARCH_64bit)+ 0x1b -> DecodedToken 9 (word64ToWord (eatTailWord64 bs))+#else+ 0x1b -> case word64ToWord (eatTailWord64 bs) of+ Just n -> DecodedToken 9 n+ Nothing -> DecodeFailure+#endif _ -> DecodeFailure {-# INLINE tryConsumeNegWord #-} tryConsumeNegWord :: Word8 -> ByteString -> DecodedToken Word-tryConsumeNegWord hdr !bs = case fromIntegral hdr :: Word of+tryConsumeNegWord hdr !bs = case word8ToWord hdr of -- Positive integers (type 0) 0x20 -> DecodedToken 1 0 0x21 -> DecodedToken 1 1@@ -1441,16 +1610,22 @@ 0x35 -> DecodedToken 1 21 0x36 -> DecodedToken 1 22 0x37 -> DecodedToken 1 23- 0x38 -> DecodedToken 2 (eatTailWord8 bs)- 0x39 -> DecodedToken 3 (eatTailWord16 bs)- 0x3a -> DecodedToken 5 (eatTailWord32 bs)- 0x3b -> DecodedToken 9 (fromIntegral $ eatTailWord64 bs) -- TODO FIXME: overflow+ 0x38 -> DecodedToken 2 (word8ToWord (eatTailWord8 bs))+ 0x39 -> DecodedToken 3 (word16ToWord (eatTailWord16 bs))+ 0x3a -> DecodedToken 5 (word32ToWord (eatTailWord32 bs))+#if defined(ARCH_64bit)+ 0x3b -> DecodedToken 9 (word64ToWord (eatTailWord64 bs))+#else+ 0x3b -> case word64ToWord (eatTailWord64 bs) of+ Just n -> DecodedToken 9 n+ Nothing -> DecodeFailure+#endif _ -> DecodeFailure {-# INLINE tryConsumeInt #-} tryConsumeInt :: Word8 -> ByteString -> DecodedToken Int-tryConsumeInt hdr !bs = case fromIntegral hdr :: Word of+tryConsumeInt hdr !bs = case word8ToWord hdr of -- Positive integers (type 0) 0x00 -> DecodedToken 1 0 0x01 -> DecodedToken 1 1@@ -1476,10 +1651,18 @@ 0x15 -> DecodedToken 1 21 0x16 -> DecodedToken 1 22 0x17 -> DecodedToken 1 23- 0x18 -> DecodedToken 2 (fromIntegral (eatTailWord8 bs))- 0x19 -> DecodedToken 3 (fromIntegral (eatTailWord16 bs))- 0x1a -> DecodedToken 5 (fromIntegral (eatTailWord32 bs)) -- TODO FIXME: overflow- 0x1b -> DecodedToken 9 (fromIntegral (eatTailWord64 bs)) -- TODO FIXME: overflow+ 0x18 -> DecodedToken 2 (word8ToInt (eatTailWord8 bs))+ 0x19 -> DecodedToken 3 (word16ToInt (eatTailWord16 bs))+#if defined(ARCH_64bit)+ 0x1a -> DecodedToken 5 (word32ToInt (eatTailWord32 bs))+#else+ 0x1a -> case word32ToInt (eatTailWord32 bs) of+ Just n -> DecodedToken 5 n+ Nothing -> DecodeFailure+#endif+ 0x1b -> case word64ToInt (eatTailWord64 bs) of+ Just n -> DecodedToken 9 n+ Nothing -> DecodeFailure -- Negative integers (type 1) 0x20 -> DecodedToken 1 (-1)@@ -1506,16 +1689,24 @@ 0x35 -> DecodedToken 1 (-22) 0x36 -> DecodedToken 1 (-23) 0x37 -> DecodedToken 1 (-24)- 0x38 -> DecodedToken 2 (-1 - fromIntegral (eatTailWord8 bs))- 0x39 -> DecodedToken 3 (-1 - fromIntegral (eatTailWord16 bs))- 0x3a -> DecodedToken 5 (-1 - fromIntegral (eatTailWord32 bs)) -- TODO FIXME: overflow- 0x3b -> DecodedToken 9 (-1 - fromIntegral (eatTailWord64 bs)) -- TODO FIXME: overflow+ 0x38 -> DecodedToken 2 (-1 - word8ToInt (eatTailWord8 bs))+ 0x39 -> DecodedToken 3 (-1 - word16ToInt (eatTailWord16 bs))+#if defined(ARCH_64bit)+ 0x3a -> DecodedToken 5 (-1 - word32ToInt (eatTailWord32 bs))+#else+ 0x3a -> case word32ToInt (eatTailWord32 bs) of+ Just n -> DecodedToken 5 (-1 - n)+ Nothing -> DecodeFailure+#endif+ 0x3b -> case word64ToInt (eatTailWord64 bs) of+ Just n -> DecodedToken 9 (-1 - n)+ Nothing -> DecodeFailure _ -> DecodeFailure {-# INLINE tryConsumeInteger #-} tryConsumeInteger :: Word8 -> ByteString -> DecodedToken (BigIntToken Integer)-tryConsumeInteger hdr !bs = case fromIntegral hdr :: Word of+tryConsumeInteger hdr !bs = case word8ToWord hdr of -- Positive integers (type 0) 0x00 -> DecodedToken 1 (BigIntToken True 0)@@ -1543,21 +1734,21 @@ 0x16 -> DecodedToken 1 (BigIntToken True 22) 0x17 -> DecodedToken 1 (BigIntToken True 23) - 0x18 -> let !w@(W# w#) = eatTailWord8 bs+ 0x18 -> let !w@(W8# w#) = eatTailWord8 bs sz = 2- in DecodedToken sz (BigIntToken (isWordCanonical sz w#) (fromIntegral w))- 0x19 -> let !w@(W# w#) = eatTailWord16 bs+ in DecodedToken sz (BigIntToken (isWordCanonical sz w#) (toInteger w))+ 0x19 -> let !w@(W16# w#) = eatTailWord16 bs sz = 3- in DecodedToken sz (BigIntToken (isWordCanonical sz w#) (fromIntegral w))- 0x1a -> let !w@(W# w#) = eatTailWord32 bs+ in DecodedToken sz (BigIntToken (isWordCanonical sz w#) (toInteger w))+ 0x1a -> let !w@(W32# w#) = eatTailWord32 bs sz = 5- in DecodedToken sz (BigIntToken (isWordCanonical sz w#) (fromIntegral w))+ in DecodedToken sz (BigIntToken (isWordCanonical sz w#) (toInteger w)) 0x1b -> let !w@(W64# w#) = eatTailWord64 bs sz = 9 #if defined(ARCH_32bit)- in DecodedToken sz (BigIntToken (isWord64Canonical sz w#) (fromIntegral w))+ in DecodedToken sz (BigIntToken (isWord64Canonical sz w#) (toInteger w)) #else- in DecodedToken sz (BigIntToken (isWordCanonical sz w#) (fromIntegral w))+ in DecodedToken sz (BigIntToken (isWordCanonical sz w#) (toInteger w)) #endif -- Negative integers (type 1)@@ -1585,21 +1776,21 @@ 0x35 -> DecodedToken 1 (BigIntToken True (-22)) 0x36 -> DecodedToken 1 (BigIntToken True (-23)) 0x37 -> DecodedToken 1 (BigIntToken True (-24))- 0x38 -> let !w@(W# w#) = eatTailWord8 bs+ 0x38 -> let !w@(W8# w#) = eatTailWord8 bs sz = 2- in DecodedToken sz (BigIntToken (isWordCanonical sz w#) (-1 - fromIntegral w))- 0x39 -> let !w@(W# w#) = eatTailWord16 bs+ in DecodedToken sz (BigIntToken (isWordCanonical sz w#) (-1 - toInteger w))+ 0x39 -> let !w@(W16# w#) = eatTailWord16 bs sz = 3- in DecodedToken sz (BigIntToken (isWordCanonical sz w#) (-1 - fromIntegral w))- 0x3a -> let !w@(W# w#) = eatTailWord32 bs+ in DecodedToken sz (BigIntToken (isWordCanonical sz w#) (-1 - toInteger w))+ 0x3a -> let !w@(W32# w#) = eatTailWord32 bs sz = 5- in DecodedToken sz (BigIntToken (isWordCanonical sz w#) (-1 - fromIntegral w))+ in DecodedToken sz (BigIntToken (isWordCanonical sz w#) (-1 - toInteger w)) 0x3b -> let !w@(W64# w#) = eatTailWord64 bs sz = 9 #if defined(ARCH_32bit)- in DecodedToken sz (BigIntToken (isWord64Canonical sz w#) (-1 - fromIntegral w))+ in DecodedToken sz (BigIntToken (isWord64Canonical sz w#) (-1 - toInteger w)) #else- in DecodedToken sz (BigIntToken (isWordCanonical sz w#) (-1 - fromIntegral w))+ in DecodedToken sz (BigIntToken (isWordCanonical sz w#) (-1 - toInteger w)) #endif 0xc2 -> readBigUInt bs@@ -1610,7 +1801,7 @@ {-# INLINE tryConsumeBytes #-} tryConsumeBytes :: Word8 -> ByteString -> DecodedToken (LongToken ByteString)-tryConsumeBytes hdr !bs = case fromIntegral hdr :: Word of+tryConsumeBytes hdr !bs = case word8ToWord hdr of -- Bytes (type 2) 0x40 -> readBytesSmall 0 bs@@ -1645,8 +1836,8 @@ {-# INLINE tryConsumeString #-}-tryConsumeString :: Word8 -> ByteString -> DecodedToken (LongToken BS.ByteString)-tryConsumeString hdr !bs = case fromIntegral hdr :: Word of+tryConsumeString :: Word8 -> ByteString -> DecodedToken (LongToken ByteString)+tryConsumeString hdr !bs = case word8ToWord hdr of -- Strings (type 3) 0x60 -> readBytesSmall 0 bs@@ -1682,7 +1873,7 @@ {-# INLINE tryConsumeListLen #-} tryConsumeListLen :: Word8 -> ByteString -> DecodedToken Int-tryConsumeListLen hdr !bs = case fromIntegral hdr :: Word of+tryConsumeListLen hdr !bs = case word8ToWord hdr of -- List structures (type 4) 0x80 -> DecodedToken 1 0 0x81 -> DecodedToken 1 1@@ -1708,16 +1899,24 @@ 0x95 -> DecodedToken 1 21 0x96 -> DecodedToken 1 22 0x97 -> DecodedToken 1 23- 0x98 -> DecodedToken 2 (fromIntegral (eatTailWord8 bs))- 0x99 -> DecodedToken 3 (fromIntegral (eatTailWord16 bs))- 0x9a -> DecodedToken 5 (fromIntegral (eatTailWord32 bs)) -- TODO FIXME: overflow- 0x9b -> DecodedToken 9 (fromIntegral (eatTailWord64 bs)) -- TODO FIXME: overflow+ 0x98 -> DecodedToken 2 (word8ToInt (eatTailWord8 bs))+ 0x99 -> DecodedToken 3 (word16ToInt (eatTailWord16 bs))+#if defined(ARCH_64bit)+ 0x9a -> DecodedToken 5 (word32ToInt (eatTailWord32 bs))+#else+ 0x9a -> case word32ToInt (eatTailWord32 bs) of+ Just n -> DecodedToken 5 n+ Nothing -> DecodeFailure+#endif+ 0x9b -> case word64ToInt (eatTailWord64 bs) of+ Just n -> DecodedToken 9 n+ Nothing -> DecodeFailure _ -> DecodeFailure {-# INLINE tryConsumeMapLen #-} tryConsumeMapLen :: Word8 -> ByteString -> DecodedToken Int-tryConsumeMapLen hdr !bs = case fromIntegral hdr :: Word of+tryConsumeMapLen hdr !bs = case word8ToWord hdr of -- Map structures (type 5) 0xa0 -> DecodedToken 1 0 0xa1 -> DecodedToken 1 1@@ -1743,30 +1942,38 @@ 0xb5 -> DecodedToken 1 21 0xb6 -> DecodedToken 1 22 0xb7 -> DecodedToken 1 23- 0xb8 -> DecodedToken 2 (fromIntegral (eatTailWord8 bs))- 0xb9 -> DecodedToken 3 (fromIntegral (eatTailWord16 bs))- 0xba -> DecodedToken 5 (fromIntegral (eatTailWord32 bs)) -- TODO FIXME: overflow- 0xbb -> DecodedToken 9 (fromIntegral (eatTailWord64 bs)) -- TODO FIXME: overflow+ 0xb8 -> DecodedToken 2 (word8ToInt (eatTailWord8 bs))+ 0xb9 -> DecodedToken 3 (word16ToInt (eatTailWord16 bs))+#if defined(ARCH_64bit)+ 0xba -> DecodedToken 5 (word32ToInt (eatTailWord32 bs))+#else+ 0xba -> case word32ToInt (eatTailWord32 bs) of+ Just n -> DecodedToken 5 n+ Nothing -> DecodeFailure+#endif+ 0xbb -> case word64ToInt (eatTailWord64 bs) of+ Just n -> DecodedToken 9 n+ Nothing -> DecodeFailure _ -> DecodeFailure {-# INLINE tryConsumeListLenIndef #-} tryConsumeListLenIndef :: Word8 -> DecodedToken ()-tryConsumeListLenIndef hdr = case fromIntegral hdr :: Word of+tryConsumeListLenIndef hdr = case word8ToWord hdr of 0x9f -> DecodedToken 1 () _ -> DecodeFailure {-# INLINE tryConsumeMapLenIndef #-} tryConsumeMapLenIndef :: Word8 -> DecodedToken ()-tryConsumeMapLenIndef hdr = case fromIntegral hdr :: Word of+tryConsumeMapLenIndef hdr = case word8ToWord hdr of 0xbf -> DecodedToken 1 () _ -> DecodeFailure {-# INLINE tryConsumeListLenOrIndef #-} tryConsumeListLenOrIndef :: Word8 -> ByteString -> DecodedToken Int-tryConsumeListLenOrIndef hdr !bs = case fromIntegral hdr :: Word of+tryConsumeListLenOrIndef hdr !bs = case word8ToWord hdr of -- List structures (type 4) 0x80 -> DecodedToken 1 0@@ -1793,17 +2000,25 @@ 0x95 -> DecodedToken 1 21 0x96 -> DecodedToken 1 22 0x97 -> DecodedToken 1 23- 0x98 -> DecodedToken 2 (fromIntegral (eatTailWord8 bs))- 0x99 -> DecodedToken 3 (fromIntegral (eatTailWord16 bs))- 0x9a -> DecodedToken 5 (fromIntegral (eatTailWord32 bs)) -- TODO FIXME: overflow- 0x9b -> DecodedToken 9 (fromIntegral (eatTailWord64 bs)) -- TODO FIXME: overflow+ 0x98 -> DecodedToken 2 (word8ToInt (eatTailWord8 bs))+ 0x99 -> DecodedToken 3 (word16ToInt (eatTailWord16 bs))+#if defined(ARCH_64bit)+ 0x9a -> DecodedToken 5 (word32ToInt (eatTailWord32 bs))+#else+ 0x9a -> case word32ToInt (eatTailWord32 bs) of+ Just n -> DecodedToken 5 n+ Nothing -> DecodeFailure+#endif+ 0x9b -> case word64ToInt (eatTailWord64 bs) of+ Just n -> DecodedToken 9 n+ Nothing -> DecodeFailure 0x9f -> DecodedToken 1 (-1) -- indefinite length _ -> DecodeFailure {-# INLINE tryConsumeMapLenOrIndef #-} tryConsumeMapLenOrIndef :: Word8 -> ByteString -> DecodedToken Int-tryConsumeMapLenOrIndef hdr !bs = case fromIntegral hdr :: Word of+tryConsumeMapLenOrIndef hdr !bs = case word8ToWord hdr of -- Map structures (type 5) 0xa0 -> DecodedToken 1 0@@ -1830,17 +2045,25 @@ 0xb5 -> DecodedToken 1 21 0xb6 -> DecodedToken 1 22 0xb7 -> DecodedToken 1 23- 0xb8 -> DecodedToken 2 (fromIntegral (eatTailWord8 bs))- 0xb9 -> DecodedToken 3 (fromIntegral (eatTailWord16 bs))- 0xba -> DecodedToken 5 (fromIntegral (eatTailWord32 bs)) -- TODO FIXME: overflow- 0xbb -> DecodedToken 9 (fromIntegral (eatTailWord64 bs)) -- TODO FIXME: overflow+ 0xb8 -> DecodedToken 2 (word8ToInt (eatTailWord8 bs))+ 0xb9 -> DecodedToken 3 (word16ToInt (eatTailWord16 bs))+#if defined(ARCH_64bit)+ 0xba -> DecodedToken 5 (word32ToInt (eatTailWord32 bs))+#else+ 0xba -> case word32ToInt (eatTailWord32 bs) of+ Just n -> DecodedToken 5 n+ Nothing -> DecodeFailure+#endif+ 0xbb -> case word64ToInt (eatTailWord64 bs) of+ Just n -> DecodedToken 9 n+ Nothing -> DecodeFailure 0xbf -> DecodedToken 1 (-1) -- indefinite length _ -> DecodeFailure {-# INLINE tryConsumeTag #-} tryConsumeTag :: Word8 -> ByteString -> DecodedToken Word-tryConsumeTag hdr !bs = case fromIntegral hdr :: Word of+tryConsumeTag hdr !bs = case word8ToWord hdr of -- Tagged values (type 6) 0xc0 -> DecodedToken 1 0@@ -1867,10 +2090,16 @@ 0xd5 -> DecodedToken 1 21 0xd6 -> DecodedToken 1 22 0xd7 -> DecodedToken 1 23- 0xd8 -> DecodedToken 2 (eatTailWord8 bs)- 0xd9 -> DecodedToken 3 (eatTailWord16 bs)- 0xda -> DecodedToken 5 (eatTailWord32 bs)- 0xdb -> DecodedToken 9 (fromIntegral (eatTailWord64 bs)) -- TODO FIXME: overflow+ 0xd8 -> DecodedToken 2 (word8ToWord (eatTailWord8 bs))+ 0xd9 -> DecodedToken 3 (word16ToWord (eatTailWord16 bs))+ 0xda -> DecodedToken 5 (word32ToWord (eatTailWord32 bs))+#if defined(ARCH_64bit)+ 0xdb -> DecodedToken 9 (word64ToWord (eatTailWord64 bs))+#else+ 0xdb -> case word64ToWord (eatTailWord64 bs) of+ Just n -> DecodedToken 9 n+ Nothing -> DecodeFailure+#endif _ -> DecodeFailure --@@ -1879,7 +2108,7 @@ #if defined(ARCH_32bit) tryConsumeWord64 :: Word8 -> ByteString -> DecodedToken Word64-tryConsumeWord64 hdr !bs = case fromIntegral hdr :: Word of+tryConsumeWord64 hdr !bs = case word8ToWord hdr of -- Positive integers (type 0) 0x00 -> DecodedToken 1 0 0x01 -> DecodedToken 1 1@@ -1905,15 +2134,15 @@ 0x15 -> DecodedToken 1 21 0x16 -> DecodedToken 1 22 0x17 -> DecodedToken 1 23- 0x18 -> DecodedToken 2 (fromIntegral (eatTailWord8 bs))- 0x19 -> DecodedToken 3 (fromIntegral (eatTailWord16 bs))- 0x1a -> DecodedToken 5 (fromIntegral (eatTailWord32 bs))- 0x1b -> DecodedToken 9 (fromIntegral (eatTailWord64 bs)) -- TODO FIXME: overflow+ 0x18 -> DecodedToken 2 (word8ToWord64 (eatTailWord8 bs))+ 0x19 -> DecodedToken 3 (word16ToWord64 (eatTailWord16 bs))+ 0x1a -> DecodedToken 5 (word32ToWord64 (eatTailWord32 bs))+ 0x1b -> DecodedToken 9 (eatTailWord64 bs) _ -> DecodeFailure {-# INLINE tryConsumeWord64 #-} tryConsumeNegWord64 :: Word8 -> ByteString -> DecodedToken Word64-tryConsumeNegWord64 hdr !bs = case fromIntegral hdr :: Word of+tryConsumeNegWord64 hdr !bs = case word8ToWord hdr of -- Positive integers (type 0) 0x20 -> DecodedToken 1 0 0x21 -> DecodedToken 1 1@@ -1939,15 +2168,15 @@ 0x35 -> DecodedToken 1 21 0x36 -> DecodedToken 1 22 0x37 -> DecodedToken 1 23- 0x38 -> DecodedToken 2 (fromIntegral (eatTailWord8 bs))- 0x39 -> DecodedToken 3 (fromIntegral (eatTailWord16 bs))- 0x3a -> DecodedToken 5 (fromIntegral (eatTailWord32 bs))- 0x3b -> DecodedToken 9 (fromIntegral (eatTailWord64 bs)) -- TODO FIXME: overflow+ 0x38 -> DecodedToken 2 (word8ToWord64 (eatTailWord8 bs))+ 0x39 -> DecodedToken 3 (word16ToWord64 (eatTailWord16 bs))+ 0x3a -> DecodedToken 5 (word32ToWord64 (eatTailWord32 bs))+ 0x3b -> DecodedToken 9 (eatTailWord64 bs) _ -> DecodeFailure {-# INLINE tryConsumeNegWord64 #-} tryConsumeInt64 :: Word8 -> ByteString -> DecodedToken Int64-tryConsumeInt64 hdr !bs = case fromIntegral hdr :: Word of+tryConsumeInt64 hdr !bs = case word8ToWord hdr of -- Positive integers (type 0) 0x00 -> DecodedToken 1 0 0x01 -> DecodedToken 1 1@@ -1973,10 +2202,12 @@ 0x15 -> DecodedToken 1 21 0x16 -> DecodedToken 1 22 0x17 -> DecodedToken 1 23- 0x18 -> DecodedToken 2 (fromIntegral (eatTailWord8 bs))- 0x19 -> DecodedToken 3 (fromIntegral (eatTailWord16 bs))- 0x1a -> DecodedToken 5 (fromIntegral (eatTailWord32 bs)) -- TODO FIXME: overflow- 0x1b -> DecodedToken 9 (fromIntegral (eatTailWord64 bs)) -- TODO FIXME: overflow+ 0x18 -> DecodedToken 2 (word8ToInt64 (eatTailWord8 bs))+ 0x19 -> DecodedToken 3 (word16ToInt64 (eatTailWord16 bs))+ 0x1a -> DecodedToken 5 (word32ToInt64 (eatTailWord32 bs))+ 0x1b -> case word64ToInt64 (eatTailWord64 bs) of+ Just n -> DecodedToken 9 n+ Nothing -> DecodeFailure -- Negative integers (type 1) 0x20 -> DecodedToken 1 (-1)@@ -2003,15 +2234,17 @@ 0x35 -> DecodedToken 1 (-22) 0x36 -> DecodedToken 1 (-23) 0x37 -> DecodedToken 1 (-24)- 0x38 -> DecodedToken 2 (-1 - fromIntegral (eatTailWord8 bs))- 0x39 -> DecodedToken 3 (-1 - fromIntegral (eatTailWord16 bs))- 0x3a -> DecodedToken 5 (-1 - fromIntegral (eatTailWord32 bs)) -- TODO FIXME: overflow- 0x3b -> DecodedToken 9 (-1 - fromIntegral (eatTailWord64 bs)) -- TODO FIXME: overflow+ 0x38 -> DecodedToken 2 (-1 - word8ToInt64 (eatTailWord8 bs))+ 0x39 -> DecodedToken 3 (-1 - word16ToInt64 (eatTailWord16 bs))+ 0x3a -> DecodedToken 5 (-1 - word32ToInt64 (eatTailWord32 bs))+ 0x3b -> case word64ToInt64 (eatTailWord64 bs) of+ Just n -> DecodedToken 9 (-1 - n)+ Nothing -> DecodeFailure _ -> DecodeFailure {-# INLINE tryConsumeInt64 #-} tryConsumeListLen64 :: Word8 -> ByteString -> DecodedToken Int64-tryConsumeListLen64 hdr !bs = case fromIntegral hdr :: Word of+tryConsumeListLen64 hdr !bs = case word8ToWord hdr of -- List structures (type 4) 0x80 -> DecodedToken 1 0 0x81 -> DecodedToken 1 1@@ -2037,15 +2270,17 @@ 0x95 -> DecodedToken 1 21 0x96 -> DecodedToken 1 22 0x97 -> DecodedToken 1 23- 0x98 -> DecodedToken 2 (fromIntegral (eatTailWord8 bs))- 0x99 -> DecodedToken 3 (fromIntegral (eatTailWord16 bs))- 0x9a -> DecodedToken 5 (fromIntegral (eatTailWord32 bs)) -- TODO FIXME: overflow- 0x9b -> DecodedToken 9 (fromIntegral (eatTailWord64 bs)) -- TODO FIXME: overflow+ 0x98 -> DecodedToken 2 (word8ToInt64 (eatTailWord8 bs))+ 0x99 -> DecodedToken 3 (word16ToInt64 (eatTailWord16 bs))+ 0x9a -> DecodedToken 5 (word32ToInt64 (eatTailWord32 bs))+ 0x9b -> case word64ToInt64 (eatTailWord64 bs) of+ Just n -> DecodedToken 9 n+ Nothing -> DecodeFailure _ -> DecodeFailure {-# INLINE tryConsumeListLen64 #-} tryConsumeMapLen64 :: Word8 -> ByteString -> DecodedToken Int64-tryConsumeMapLen64 hdr !bs = case fromIntegral hdr :: Word of+tryConsumeMapLen64 hdr !bs = case word8ToWord hdr of -- Map structures (type 5) 0xa0 -> DecodedToken 1 0 0xa1 -> DecodedToken 1 1@@ -2071,15 +2306,17 @@ 0xb5 -> DecodedToken 1 21 0xb6 -> DecodedToken 1 22 0xb7 -> DecodedToken 1 23- 0xb8 -> DecodedToken 2 (fromIntegral (eatTailWord8 bs))- 0xb9 -> DecodedToken 3 (fromIntegral (eatTailWord16 bs))- 0xba -> DecodedToken 5 (fromIntegral (eatTailWord32 bs)) -- TODO FIXME: overflow- 0xbb -> DecodedToken 9 (fromIntegral (eatTailWord64 bs)) -- TODO FIXME: overflow+ 0xb8 -> DecodedToken 2 (word8ToInt64 (eatTailWord8 bs))+ 0xb9 -> DecodedToken 3 (word16ToInt64 (eatTailWord16 bs))+ 0xba -> DecodedToken 5 (word32ToInt64 (eatTailWord32 bs))+ 0xbb -> case word64ToInt64 (eatTailWord64 bs) of+ Just n -> DecodedToken 9 n+ Nothing -> DecodeFailure _ -> DecodeFailure {-# INLINE tryConsumeMapLen64 #-} tryConsumeTag64 :: Word8 -> ByteString -> DecodedToken Word64-tryConsumeTag64 hdr !bs = case fromIntegral hdr :: Word of+tryConsumeTag64 hdr !bs = case word8ToWord hdr of -- Tagged values (type 6) 0xc0 -> DecodedToken 1 0 0xc1 -> DecodedToken 1 1@@ -2105,17 +2342,17 @@ 0xd5 -> DecodedToken 1 21 0xd6 -> DecodedToken 1 22 0xd7 -> DecodedToken 1 23- 0xd8 -> DecodedToken 2 (fromIntegral (eatTailWord8 bs))- 0xd9 -> DecodedToken 3 (fromIntegral (eatTailWord16 bs))- 0xda -> DecodedToken 5 (fromIntegral (eatTailWord32 bs))- 0xdb -> DecodedToken 9 (fromIntegral (eatTailWord64 bs)) -- TODO FIXME: overflow+ 0xd8 -> DecodedToken 2 (word8ToWord64 (eatTailWord8 bs))+ 0xd9 -> DecodedToken 3 (word16ToWord64 (eatTailWord16 bs))+ 0xda -> DecodedToken 5 (word32ToWord64 (eatTailWord32 bs))+ 0xdb -> DecodedToken 9 (eatTailWord64 bs) _ -> DecodeFailure {-# INLINE tryConsumeTag64 #-} #endif {-# INLINE tryConsumeFloat #-} tryConsumeFloat :: Word8 -> ByteString -> DecodedToken Float-tryConsumeFloat hdr !bs = case fromIntegral hdr :: Word of+tryConsumeFloat hdr !bs = case word8ToWord hdr of 0xf9 -> DecodedToken 3 (wordToFloat16 (eatTailWord16 bs)) 0xfa -> DecodedToken 5 (wordToFloat32 (eatTailWord32 bs)) _ -> DecodeFailure@@ -2123,7 +2360,7 @@ {-# INLINE tryConsumeDouble #-} tryConsumeDouble :: Word8 -> ByteString -> DecodedToken Double-tryConsumeDouble hdr !bs = case fromIntegral hdr :: Word of+tryConsumeDouble hdr !bs = case word8ToWord hdr of 0xf9 -> DecodedToken 3 (float2Double $ wordToFloat16 (eatTailWord16 bs)) 0xfa -> DecodedToken 5 (float2Double $ wordToFloat32 (eatTailWord32 bs)) 0xfb -> DecodedToken 9 (wordToFloat64 (eatTailWord64 bs))@@ -2132,7 +2369,7 @@ {-# INLINE tryConsumeBool #-} tryConsumeBool :: Word8 -> DecodedToken Bool-tryConsumeBool hdr = case fromIntegral hdr :: Word of+tryConsumeBool hdr = case word8ToWord hdr of 0xf4 -> DecodedToken 1 False 0xf5 -> DecodedToken 1 True _ -> DecodeFailure@@ -2140,7 +2377,7 @@ {-# INLINE tryConsumeSimple #-} tryConsumeSimple :: Word8 -> ByteString -> DecodedToken Word-tryConsumeSimple hdr !bs = case fromIntegral hdr :: Word of+tryConsumeSimple hdr !bs = case word8ToWord hdr of -- Simple and floats (type 7) 0xe0 -> DecodedToken 1 0@@ -2167,103 +2404,115 @@ 0xf5 -> DecodedToken 1 21 0xf6 -> DecodedToken 1 22 0xf7 -> DecodedToken 1 23- 0xf8 -> DecodedToken 2 (eatTailWord8 bs)+ 0xf8 -> DecodedToken 2 (word8ToWord (eatTailWord8 bs)) _ -> DecodeFailure {-# INLINE tryConsumeBytesIndef #-} tryConsumeBytesIndef :: Word8 -> DecodedToken ()-tryConsumeBytesIndef hdr = case fromIntegral hdr :: Word of+tryConsumeBytesIndef hdr = case word8ToWord hdr of 0x5f -> DecodedToken 1 () _ -> DecodeFailure {-# INLINE tryConsumeStringIndef #-} tryConsumeStringIndef :: Word8 -> DecodedToken ()-tryConsumeStringIndef hdr = case fromIntegral hdr :: Word of+tryConsumeStringIndef hdr = case word8ToWord hdr of 0x7f -> DecodedToken 1 () _ -> DecodeFailure {-# INLINE tryConsumeNull #-} tryConsumeNull :: Word8 -> DecodedToken ()-tryConsumeNull hdr = case fromIntegral hdr :: Word of+tryConsumeNull hdr = case word8ToWord hdr of 0xf6 -> DecodedToken 1 () _ -> DecodeFailure {-# INLINE tryConsumeBreakOr #-} tryConsumeBreakOr :: Word8 -> DecodedToken ()-tryConsumeBreakOr hdr = case fromIntegral hdr :: Word of+tryConsumeBreakOr hdr = case word8ToWord hdr of 0xff -> DecodedToken 1 () _ -> DecodeFailure -+{-# INLINE readBytesSmall #-} readBytesSmall :: Int -> ByteString -> DecodedToken (LongToken ByteString) readBytesSmall n bs -- if n <= bound then ok return it all | n + hdrsz <= BS.length bs- = DecodedToken (n+hdrsz) $ Fits $+ = DecodedToken (n+hdrsz) $ Fits True $ BS.unsafeTake n (BS.unsafeDrop hdrsz bs) -- if n > bound then slow path, multi-chunk | otherwise- = DecodedToken hdrsz $ TooLong n+ = DecodedToken hdrsz $ TooLong True n where hdrsz = 1 +{-# INLINE readBytes8 #-}+{-# INLINE readBytes16 #-}+{-# INLINE readBytes32 #-}+{-# INLINE readBytes64 #-} readBytes8, readBytes16, readBytes32, readBytes64 :: ByteString -> DecodedToken (LongToken ByteString) readBytes8 bs | n <= BS.length bs - hdrsz- = DecodedToken (n+hdrsz) $ Fits $+ = DecodedToken (n+hdrsz) $ Fits lengthCanonical $ BS.unsafeTake n (BS.unsafeDrop hdrsz bs) -- if n > bound then slow path, multi-chunk | otherwise- = DecodedToken hdrsz $ TooLong n+ = DecodedToken hdrsz $ TooLong lengthCanonical n where- hdrsz = 2- n = fromIntegral (eatTailWord8 bs)+ hdrsz = 2+ !n@(I# n#) = word8ToInt (eatTailWord8 bs)+ lengthCanonical = isIntCanonical hdrsz n# readBytes16 bs | n <= BS.length bs - hdrsz- = DecodedToken (n+hdrsz) $ Fits $+ = DecodedToken (n+hdrsz) $ Fits lengthCanonical $ BS.unsafeTake n (BS.unsafeDrop hdrsz bs) -- if n > bound then slow path, multi-chunk | otherwise- = DecodedToken hdrsz $ TooLong n+ = DecodedToken hdrsz $ TooLong lengthCanonical n where- hdrsz = 3- n = fromIntegral (eatTailWord16 bs)+ hdrsz = 3+ !n@(I# n#) = word16ToInt (eatTailWord16 bs)+ lengthCanonical = isIntCanonical hdrsz n# -readBytes32 bs- | n <= BS.length bs - hdrsz- = DecodedToken (n+hdrsz) $ Fits $- BS.unsafeTake n (BS.unsafeDrop hdrsz bs)+readBytes32 bs = case word32ToInt (eatTailWord32 bs) of+#if defined(ARCH_32bit)+ Just n@(I# n#)+#else+ n@(I# n#)+#endif+ | n <= BS.length bs - hdrsz+ -> DecodedToken (n+hdrsz) $ Fits (isIntCanonical hdrsz n#) $+ BS.unsafeTake n (BS.unsafeDrop hdrsz bs) - -- if n > bound then slow path, multi-chunk- | otherwise- = DecodedToken hdrsz $ TooLong n+ -- if n > bound then slow path, multi-chunk+ | otherwise -> DecodedToken hdrsz $ TooLong (isIntCanonical hdrsz n#) n++#if defined(ARCH_32bit)+ Nothing -> DecodeFailure+#endif where hdrsz = 5- -- TODO FIXME: int overflow- n = fromIntegral (eatTailWord32 bs) -readBytes64 bs- | n <= BS.length bs - hdrsz- = DecodedToken (n+hdrsz) $ Fits $- BS.unsafeTake n (BS.unsafeDrop hdrsz bs)+readBytes64 bs = case word64ToInt (eatTailWord64 bs) of+ Just n@(I# n#)+ | n <= BS.length bs - hdrsz+ -> DecodedToken (n+hdrsz) $ Fits (isIntCanonical hdrsz n#) $+ BS.unsafeTake n (BS.unsafeDrop hdrsz bs) - -- if n > bound then slow path, multi-chunk- | otherwise- = DecodedToken hdrsz $ TooLong n+ -- if n > bound then slow path, multi-chunk+ | otherwise -> DecodedToken hdrsz $ TooLong (isIntCanonical hdrsz n#) n++ Nothing -> DecodeFailure where- hdrsz = 5- -- TODO FIXME: int overflow- n = fromIntegral (eatTailWord64 bs)+ hdrsz = 9 ------------------------------------------------------------------------------ -- Reading big integers@@ -2293,10 +2542,14 @@ -- closures. This seems a reasonable price to pay to reduce complexity since -- decoding a big int across an input buffer boundary ought to be rare, and -- allocating a new continuation closure isn't that expensive.+--+-- Note that canonicity information is calculated lazily. This way we don't need+-- to concern ourselves with two distinct paths, while according to benchmarks+-- it doesn't affect performance in the non-canonical case. -data BigIntToken a = BigIntToken Bool {- canonical? -} Integer- | BigUIntNeedBody Int- | BigNIntNeedBody Int+data BigIntToken a = BigIntToken Bool {- canonical? -} Integer+ | BigUIntNeedBody Bool {- canonical? -} Int+ | BigNIntNeedBody Bool {- canonical? -} Int | BigUIntNeedHeader | BigNIntNeedHeader @@ -2312,6 +2565,20 @@ adjustContBigUIntNeedBody k = \bs -> k $! uintegerFromBytes bs adjustContBigNIntNeedBody k = \bs -> k $! nintegerFromBytes bs +adjustContCanonicalBigUIntNeedBody, adjustContCanonicalBigNIntNeedBody+ :: (Integer -> ST s (DecodeAction s a))+ -> (ByteString -> ST s (DecodeAction s a))++adjustContCanonicalBigUIntNeedBody k = \bs ->+ if isBigIntRepCanonical bs+ then k $! uintegerFromBytes bs+ else pure $! D.Fail ("non-canonical integer")++adjustContCanonicalBigNIntNeedBody k = \bs ->+ if isBigIntRepCanonical bs+ then k $! nintegerFromBytes bs+ else pure $! D.Fail ("non-canonical integer")+ -- And when we have to break out because we can't read the bytes token header -- in one go then we need to use SlowDecodeAction but we have to make two -- adjustments. When we resume we need to read a bytes token, not a big int.@@ -2328,6 +2595,20 @@ adjustContBigUIntNeedHeader k = ConsumeBytes (\bs -> k $! uintegerFromBytes bs) adjustContBigNIntNeedHeader k = ConsumeBytes (\bs -> k $! nintegerFromBytes bs) +adjustContCanonicalBigUIntNeedHeader, adjustContCanonicalBigNIntNeedHeader+ :: (Integer -> ST s (DecodeAction s a))+ -> DecodeAction s a++adjustContCanonicalBigUIntNeedHeader k = ConsumeBytesCanonical $ \bs ->+ if isBigIntRepCanonical bs+ then k $! uintegerFromBytes bs+ else pure $! D.Fail ("non-canonical integer")++adjustContCanonicalBigNIntNeedHeader k = ConsumeBytesCanonical $ \bs ->+ if isBigIntRepCanonical bs+ then k $! nintegerFromBytes bs+ else pure $! D.Fail ("non-canonical integer")+ -- So finally when reading the input buffer we check if we have enough space -- to read the header of the bytes token and then try to read the bytes body, -- using the appropriate break-out codes as above.@@ -2340,10 +2621,12 @@ , let !hdr = BS.unsafeHead bs' , BS.length bs' >= tokenSize hdr = case tryConsumeBytes hdr bs' of- DecodeFailure -> DecodeFailure- DecodedToken sz (Fits bstr) -> DecodedToken (1+sz)- (BigIntToken (isBigIntRepCanonical bstr) (uintegerFromBytes bstr))- DecodedToken sz (TooLong len) -> DecodedToken (1+sz) (BigUIntNeedBody len)+ DecodeFailure -> DecodeFailure+ DecodedToken sz (Fits canonical bstr) -> DecodedToken (1+sz)+ (BigIntToken (canonical && isBigIntRepCanonical bstr)+ (uintegerFromBytes bstr))+ DecodedToken sz (TooLong canonical len) ->+ DecodedToken (1+sz) (BigUIntNeedBody canonical len) | otherwise = DecodedToken 1 BigUIntNeedHeader@@ -2356,10 +2639,12 @@ , let !hdr = BS.unsafeHead bs' , BS.length bs' >= tokenSize hdr = case tryConsumeBytes hdr bs' of- DecodeFailure -> DecodeFailure- DecodedToken sz (Fits bstr) -> DecodedToken (1+sz)- (BigIntToken (isBigIntRepCanonical bstr) (nintegerFromBytes bstr))- DecodedToken sz (TooLong len) -> DecodedToken (1+sz) (BigNIntNeedBody len)+ DecodeFailure -> DecodeFailure+ DecodedToken sz (Fits canonical bstr) -> DecodedToken (1+sz)+ (BigIntToken (canonical && isBigIntRepCanonical bstr)+ (nintegerFromBytes bstr))+ DecodedToken sz (TooLong canonical len) ->+ DecodedToken (1+sz) (BigNIntNeedBody canonical len) | otherwise = DecodedToken 1 BigNIntNeedHeader
src/Codec/CBOR/Write.hs view
@@ -27,7 +27,11 @@ import Data.Bits import Data.Int++#if ! MIN_VERSION_base(4,11,0) import Data.Monoid+#endif+ import Data.Word import Foreign.Ptr
+ tests/Main.hs view
@@ -0,0 +1,22 @@+module Main+ ( main -- :: IO ()+ ) where+import Test.Tasty (defaultMain, testGroup)++import qualified Tests.CBOR as CBOR+import qualified Tests.Boundary as Boundary+import qualified Tests.Regress as Regress+import qualified Tests.Reference as Reference+import qualified Tests.UTF8 as UTF8++main :: IO ()+main =+ Reference.loadTestCases >>= \tcs ->+ defaultMain $+ testGroup "CBOR tests"+ [ CBOR.testTree tcs+ , Reference.testTree tcs+ , Boundary.testTree+ , Regress.testTree+ , UTF8.testTree+ ]
+ tests/Tests/Boundary.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+module Tests.Boundary+ ( testTree -- :: TestTree+ ) where++import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import Data.Either+import Data.Int+import Data.Word+import qualified Data.Text as T++import Codec.CBOR.Decoding+import Codec.CBOR.Encoding+import Codec.CBOR.Read+import Codec.CBOR.Write+import Tests.Util++import Test.Tasty+import Test.Tasty.QuickCheck++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif++-- | CBOR can represent 64 bit negative and positive integers, hence we need+-- wrapper for Integer to represent the whole range.+newtype Int65 = Int65 Integer+ deriving (Eq, Ord, Enum, Num, Integral, Real, Show)++instance Bounded Int65 where+ maxBound = Int65 (2^(64 :: Int) - 1)+ minBound = Int65 (-2^(64 :: Int))++instance Arbitrary Int65 where+ arbitrary = arbitraryBoundedIntegral++encodeInt65 :: Int65 -> Encoding+encodeInt65 (Int65 n) = encodeInteger n+++-- | Wrapper for bounded, integral type 'a' that potentially contains values+-- outside of range of 'a'.+newtype B a = B { unB :: BRep a }++type family BRep a where+ BRep Word = Word64+ BRep Word8 = Word64+ BRep Word16 = Word64+ BRep Word32 = Word64+ BRep Word64 = Word64+ BRep Int = Int65+ BRep Int8 = Int64+ BRep Int16 = Int64+ BRep Int32 = Int64+ BRep Int64 = Int65++instance Show (BRep a) => Show (B a) where+ showsPrec p = showsPrec p . unB++instance (Arbitrary (BRep a), Num (BRep a), Bounded a, Integral a+ ) => Arbitrary (B a) where+ arbitrary = B <$> arbitraryWithBounds (undefined::a)++-- | Check if deserialisation of values of type 'a' deals properly with the ones+-- out of range, i.e. fails to decode them.+boundaryTest+ :: forall a rep. (Bounded a, Integral a, Show a, rep ~ BRep a,+ Ord rep, Num rep)+ => (rep -> Encoding) -- ^ encode+ -> (forall s. Decoder s a) -- ^ decode+ -> B a+ -> Property+boundaryTest enc dec a = if outsideRange+ then collect "outside" $ isLeft a'+ else collect "inside" $ isRight a'+ where+ a' = deserialiseFromBytes dec . toLazyByteString . enc $ unB a++ -- Note that this is always true for a ~ rep.+ outsideRange = unB a < fromIntegral (minBound :: a)+ || unB a > fromIntegral (maxBound :: a)++mkBoundaryTest+ :: forall a rep. (Bounded a, Integral a, Show a, rep ~ BRep a,+ Arbitrary rep, Ord rep, Show rep, Num rep)+ => String+ -> (rep -> Encoding)+ -> (forall s. Decoder s a)+ -> (forall s. Decoder s a)+ -> [TestTree]+mkBoundaryTest aName enc dec decCan =+ [ testProperty aName $ boundaryTest enc dec+ , testProperty (aName ++ " (canonical)") $ boundaryTest enc decCan+ ]++----------------------------------------++-- | Check if deserialisation of map/list length deals properly with the ones+-- out of range, i.e. fails to decode them.+lenBoundaryTest+ :: (Word -> Encoding)+ -> (forall s. Decoder s Int)+ -> Length+ -> Property+lenBoundaryTest enc dec a = if outsideRange+ then collect "outside" $ isLeft a'+ else collect "inside" $ isRight a'+ where+ a' = deserialiseFromBytes dec . toLazyByteString . enc $ unLength a++ outsideRange = fromIntegral (unLength a) < (0::Int)++mkLenBoundaryTest+ :: String+ -> (Word -> Encoding)+ -> (forall s. Decoder s Int)+ -> (forall s. Decoder s Int)+ -> [TestTree]+mkLenBoundaryTest aName enc dec decCan =+ [ testProperty aName $ lenBoundaryTest enc dec+ , testProperty (aName ++ " (canonical)") $ lenBoundaryTest enc decCan+ ]++----------------------------------------++data StringLengthPrefix = StringLP Word BSL.ByteString+ deriving Show+instance Arbitrary StringLengthPrefix where+ arbitrary = (\l -> StringLP (unLength l) (mkLengthPrefix True l)) <$> arbitrary++data BytesLengthPrefix = BytesLP Word BSL.ByteString+ deriving Show+instance Arbitrary BytesLengthPrefix where+ arbitrary = (\l -> BytesLP (unLength l) (mkLengthPrefix False l)) <$> arbitrary++-- | Test that positive length prefixes of string/bytes are parsed successfully,+-- whereas negative are not.+stringBytesBoundaryTest :: [TestTree]+stringBytesBoundaryTest =+ [ testProperty "String" $ \(StringLP w bs) ->+ case deserialiseFromBytes decodeString bs of+ Right (_rest, string) -> w == 0 && T.length string == 0+ Left (DeserialiseFailure _ msg) -> if fromIntegral w < (0::Int)+ then msg == "expected string"+ else msg == "end of input"+ , testProperty "Bytes" $ \(BytesLP w bs) ->+ case deserialiseFromBytes decodeBytes bs of+ Right (_rest, bytes) -> w == 0 && BS.length bytes == 0+ Left (DeserialiseFailure _ msg) -> if fromIntegral w < (0::Int)+ then msg == "expected bytes"+ else msg == "end of input"+ ]++----------------------------------------++testTree :: TestTree+testTree = localOption (QuickCheckTests 1000) . testGroup "Boundary checks" $ concat+ [ mkBoundaryTest "Word" encodeWord64 decodeWord decodeWordCanonical+ , mkBoundaryTest "Word8" encodeWord64 decodeWord8 decodeWord8Canonical+ , mkBoundaryTest "Word16" encodeWord64 decodeWord16 decodeWord16Canonical+ , mkBoundaryTest "Word32" encodeWord64 decodeWord32 decodeWord32Canonical+ , mkBoundaryTest "Word64" encodeWord64 decodeWord64 decodeWord64Canonical+ , mkBoundaryTest "Int" encodeInt65 decodeInt decodeIntCanonical+ , mkBoundaryTest "Int8" encodeInt64 decodeInt8 decodeInt8Canonical+ , mkBoundaryTest "Int16" encodeInt64 decodeInt16 decodeInt16Canonical+ , mkBoundaryTest "Int32" encodeInt64 decodeInt32 decodeInt32Canonical+ , mkBoundaryTest "Int64" encodeInt65 decodeInt64 decodeInt64Canonical++ , mkLenBoundaryTest "ListLen" encodeListLen decodeListLen decodeListLenCanonical+ , mkLenBoundaryTest "MapLen" encodeMapLen decodeMapLen decodeMapLenCanonical++ , stringBytesBoundaryTest+ ]
+ tests/Tests/CBOR.hs view
@@ -0,0 +1,284 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Tests.CBOR+ ( testTree -- :: TestTree+ ) where++import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Text as T+import qualified Data.Text.Lazy as LT+import Data.Word+import qualified Numeric.Half as Half++import Codec.CBOR.Term+import Codec.CBOR.Read+import Codec.CBOR.Write++import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck++import qualified Tests.Reference.Implementation as RefImpl+import qualified Tests.Reference as TestVector+import Tests.Reference (TestCase(..))+import Tests.Util++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif+import Control.Exception (throw)+++externalTestCase :: TestCase -> Assertion+externalTestCase TestCase { encoded, decoded = Left expectedJson } = do+ let term = deserialise encoded+ actualJson = TestVector.termToJson (toRefTerm term)+ reencoded = serialise term++ expectedJson `TestVector.equalJson` actualJson+ encoded @=? reencoded++externalTestCase TestCase { encoded, decoded = Right expectedDiagnostic } = do+ let term = deserialise encoded+ actualDiagnostic = RefImpl.diagnosticNotation (toRefTerm term)+ reencoded = serialise term++ expectedDiagnostic @=? actualDiagnostic+ encoded @=? reencoded++expectedDiagnosticNotation :: String -> [Word8] -> Assertion+expectedDiagnosticNotation expectedDiagnostic encoded = do+ let term = deserialise (LBS.pack encoded)+ actualDiagnostic = RefImpl.diagnosticNotation (toRefTerm term)++ expectedDiagnostic @=? actualDiagnostic+++-- | The reference implementation satisfies the roundtrip property for most+-- examples (all the ones from Appendix A). It does not satisfy the roundtrip+-- property in general however, non-canonical over-long int encodings for+-- example.+--+--+encodedRoundtrip :: String -> [Word8] -> Assertion+encodedRoundtrip expectedDiagnostic encoded = do+ let term = deserialise (LBS.pack encoded)+ reencoded = LBS.unpack (serialise term)++ assertEqual ("for CBOR: " ++ expectedDiagnostic) encoded reencoded++prop_encodeDecodeTermRoundtrip :: Term -> Bool+prop_encodeDecodeTermRoundtrip term =+ (deserialise . serialise) term `eqTerm` term++prop_encodeDecodeTermRoundtrip_splits2 :: Term -> Bool+prop_encodeDecodeTermRoundtrip_splits2 term =+ and [ deserialise thedata' `eqTerm` term+ | let thedata = serialise term+ , thedata' <- splits2 thedata ]++prop_encodeDecodeTermRoundtrip_splits3 :: Term -> Bool+prop_encodeDecodeTermRoundtrip_splits3 term =+ and [ deserialise thedata' `eqTerm` term+ | let thedata = serialise term+ , thedata' <- splits3 thedata ]++prop_encodeTermMatchesRefImpl :: RefImpl.Term -> Bool+prop_encodeTermMatchesRefImpl term =+ let encoded = serialise (fromRefTerm term)+ encoded' = RefImpl.serialise (RefImpl.canonicaliseTerm term)+ in encoded == encoded'++prop_encodeTermMatchesRefImpl2 :: Term -> Bool+prop_encodeTermMatchesRefImpl2 term =+ let encoded = serialise term+ encoded' = RefImpl.serialise (toRefTerm term)+ in encoded == encoded'++prop_decodeTermMatchesRefImpl :: RefImpl.Term -> Bool+prop_decodeTermMatchesRefImpl term0 =+ let encoded = RefImpl.serialise (RefImpl.canonicaliseTerm term0)+ term = RefImpl.deserialise encoded+ term' = deserialise encoded+ in term' `eqTerm` fromRefTerm term++------------------------------------------------------------------------------++serialise :: Term -> LBS.ByteString+serialise = toLazyByteString . encodeTerm++deserialise :: LBS.ByteString -> Term+deserialise = either throw snd . deserialiseFromBytes decodeTerm++------------------------------------------------------------------------------++toRefTerm :: Term -> RefImpl.Term+toRefTerm (TInt n)+ | n >= 0 = RefImpl.TUInt (RefImpl.toUInt (fromIntegral n))+ | otherwise = RefImpl.TNInt (RefImpl.toUInt (fromIntegral (-1 - n)))+toRefTerm (TInteger n) -- = RefImpl.TBigInt n+ | n >= 0 && n <= fromIntegral (maxBound :: Word64)+ = RefImpl.TUInt (RefImpl.toUInt (fromIntegral n))+ | n < 0 && n >= -1 - fromIntegral (maxBound :: Word64)+ = RefImpl.TNInt (RefImpl.toUInt (fromIntegral (-1 - n)))+ | otherwise = RefImpl.TBigInt n+toRefTerm (TBytes bs) = RefImpl.TBytes (BS.unpack bs)+toRefTerm (TBytesI bs) = RefImpl.TBytess (map BS.unpack (LBS.toChunks bs))+toRefTerm (TString st) = RefImpl.TString (T.unpack st)+toRefTerm (TStringI st) = RefImpl.TStrings (map T.unpack (LT.toChunks st))+toRefTerm (TList ts) = RefImpl.TArray (map toRefTerm ts)+toRefTerm (TListI ts) = RefImpl.TArrayI (map toRefTerm ts)+toRefTerm (TMap ts) = RefImpl.TMap [ (toRefTerm x, toRefTerm y)+ | (x,y) <- ts ]+toRefTerm (TMapI ts) = RefImpl.TMapI [ (toRefTerm x, toRefTerm y)+ | (x,y) <- ts ]+toRefTerm (TTagged w t) = RefImpl.TTagged (RefImpl.toUInt (fromIntegral w))+ (toRefTerm t)+toRefTerm (TBool False) = RefImpl.TFalse+toRefTerm (TBool True) = RefImpl.TTrue+toRefTerm TNull = RefImpl.TNull+toRefTerm (TSimple 23) = RefImpl.TUndef+toRefTerm (TSimple w) = RefImpl.TSimple (fromIntegral w)+toRefTerm (THalf f) = if isNaN f+ then RefImpl.TFloat16 RefImpl.canonicalNaN+ else RefImpl.TFloat16 (Half.toHalf f)+toRefTerm (TFloat f) = if isNaN f+ then RefImpl.TFloat16 RefImpl.canonicalNaN+ else RefImpl.TFloat32 f+toRefTerm (TDouble f) = if isNaN f+ then RefImpl.TFloat16 RefImpl.canonicalNaN+ else RefImpl.TFloat64 f+++fromRefTerm :: RefImpl.Term -> Term+fromRefTerm (RefImpl.TUInt u)+ | n <= fromIntegral (maxBound :: Int) = TInt (fromIntegral n)+ | otherwise = TInteger (fromIntegral n)+ where n = RefImpl.fromUInt u++fromRefTerm (RefImpl.TNInt u)+ | n <= fromIntegral (maxBound :: Int) = TInt (-1 - fromIntegral n)+ | otherwise = TInteger (-1 - fromIntegral n)+ where n = RefImpl.fromUInt u++fromRefTerm (RefImpl.TBigInt n) = TInteger n+fromRefTerm (RefImpl.TBytes bs) = TBytes (BS.pack bs)+fromRefTerm (RefImpl.TBytess bs) = TBytesI (LBS.fromChunks (map BS.pack bs))+fromRefTerm (RefImpl.TString st) = TString (T.pack st)+fromRefTerm (RefImpl.TStrings st) = TStringI (LT.fromChunks (map T.pack st))++fromRefTerm (RefImpl.TArray ts) = TList (map fromRefTerm ts)+fromRefTerm (RefImpl.TArrayI ts) = TListI (map fromRefTerm ts)+fromRefTerm (RefImpl.TMap ts) = TMap [ (fromRefTerm x, fromRefTerm y)+ | (x,y) <- ts ]+fromRefTerm (RefImpl.TMapI ts) = TMapI [ (fromRefTerm x, fromRefTerm y)+ | (x,y) <- ts ]+fromRefTerm (RefImpl.TTagged w t) = TTagged (RefImpl.fromUInt w)+ (fromRefTerm t)+fromRefTerm (RefImpl.TFalse) = TBool False+fromRefTerm (RefImpl.TTrue) = TBool True+fromRefTerm RefImpl.TNull = TNull+fromRefTerm RefImpl.TUndef = TSimple 23+fromRefTerm (RefImpl.TSimple w) = TSimple w+fromRefTerm (RefImpl.TFloat16 f) = THalf (Half.fromHalf f)+fromRefTerm (RefImpl.TFloat32 f) = if isNaN f+ then THalf (Half.fromHalf RefImpl.canonicalNaN)+ else TFloat f+fromRefTerm (RefImpl.TFloat64 f) = if isNaN f+ then THalf (Half.fromHalf RefImpl.canonicalNaN)+ else TDouble f++-- NaNs are so annoying...+eqTerm :: Term -> Term -> Bool+eqTerm (TInt n) (TInteger n') = fromIntegral n == n'+eqTerm (TList ts) (TList ts') = and (zipWith eqTerm ts ts')+eqTerm (TListI ts) (TListI ts') = and (zipWith eqTerm ts ts')+eqTerm (TMap ts) (TMap ts') = and (zipWith eqTermPair ts ts')+eqTerm (TMapI ts) (TMapI ts') = and (zipWith eqTermPair ts ts')+eqTerm (TTagged w t) (TTagged w' t') = w == w' && eqTerm t t'+eqTerm (THalf f) (THalf f') | isNaN f && isNaN f' = True+eqTerm (TFloat f) (TFloat f') | isNaN f && isNaN f' = True+eqTerm (TDouble f) (TDouble f') | isNaN f && isNaN f' = True+eqTerm a b = a == b++eqTermPair :: (Term, Term) -> (Term, Term) -> Bool+eqTermPair (a,b) (a',b') = eqTerm a a' && eqTerm b b'+++prop_fromToRefTerm :: RefImpl.Term -> Bool+prop_fromToRefTerm term = toRefTerm (fromRefTerm term)+ `RefImpl.eqTerm` RefImpl.canonicaliseTerm term++prop_toFromRefTerm :: Term -> Bool+prop_toFromRefTerm term = fromRefTerm (toRefTerm term) `eqTerm` term++instance Arbitrary Term where+ arbitrary = fromRefTerm <$> arbitrary++ shrink (TInt n) = [ TInt n' | n' <- shrink n ]+ shrink (TInteger n) = [ TInteger n' | n' <- shrink n ]++ shrink (TBytes ws) = [ TBytes (BS.pack ws') | ws' <- shrink (BS.unpack ws) ]+ shrink (TBytesI wss) = [ TBytesI (LBS.fromChunks (map BS.pack wss'))+ | wss' <- shrink (map BS.unpack (LBS.toChunks wss)) ]+ shrink (TString cs) = [ TString (T.pack cs') | cs' <- shrink (T.unpack cs) ]+ shrink (TStringI css) = [ TStringI (LT.fromChunks (map T.pack css'))+ | css' <- shrink (map T.unpack (LT.toChunks css)) ]++ shrink (TList xs@[x]) = x : [ TList xs' | xs' <- shrink xs ]+ shrink (TList xs) = [ TList xs' | xs' <- shrink xs ]+ shrink (TListI xs@[x]) = x : [ TListI xs' | xs' <- shrink xs ]+ shrink (TListI xs) = [ TListI xs' | xs' <- shrink xs ]++ shrink (TMap xys@[(x,y)]) = x : y : [ TMap xys' | xys' <- shrink xys ]+ shrink (TMap xys) = [ TMap xys' | xys' <- shrink xys ]+ shrink (TMapI xys@[(x,y)]) = x : y : [ TMapI xys' | xys' <- shrink xys ]+ shrink (TMapI xys) = [ TMapI xys' | xys' <- shrink xys ]++ shrink (TTagged w t) = [ TTagged w' t' | (w', t') <- shrink (w, t)+ , not (RefImpl.reservedTag (fromIntegral w')) ]++ shrink (TBool _) = []+ shrink TNull = []++ shrink (TSimple w) = [ TSimple w' | w' <- shrink w+ , not (RefImpl.reservedSimple (fromIntegral w)) ]+ shrink (THalf _f) = []+ shrink (TFloat f) = [ TFloat f' | f' <- shrink f ]+ shrink (TDouble f) = [ TDouble f' | f' <- shrink f ]++--------------------------------------------------------------------------------+-- TestTree API++testTree :: [TestCase] -> TestTree+testTree testCases =+ testGroup "Main implementation"+ [ testCase "external test vector" $+ mapM_ externalTestCase testCases++ , testCase "internal test vector" $ do+ sequence_ [ do expectedDiagnosticNotation d e+ encodedRoundtrip d e+ | (d,e) <- TestVector.specTestVector ]++ , --localOption (QuickCheckTests 5000) $+ localOption (QuickCheckMaxSize 150) $+ testGroup "properties"+ [ testProperty "from/to reference terms" prop_fromToRefTerm+ , testProperty "to/from reference terms" prop_toFromRefTerm+ , testProperty "rountrip de/encoding terms" prop_encodeDecodeTermRoundtrip+ -- TODO FIXME: need to fix the generation of terms to give+ -- better size distribution some get far too big for the+ -- splits properties.+ , localOption (QuickCheckMaxSize 30) $+ testProperty "decoding with all 2-chunks" prop_encodeDecodeTermRoundtrip_splits2+ , localOption (QuickCheckMaxSize 20) $+ testProperty "decoding with all 3-chunks" prop_encodeDecodeTermRoundtrip_splits3+ , testProperty "encode term matches ref impl 1" prop_encodeTermMatchesRefImpl+ , testProperty "encode term matches ref impl 2" prop_encodeTermMatchesRefImpl2+ , testProperty "decoding term matches ref impl" prop_decodeTermMatchesRefImpl+ ]+ ]
+ tests/Tests/Reference.hs view
@@ -0,0 +1,293 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+module Tests.Reference+ ( TestCase(..) -- :: *+ , termToJson -- ::+ , equalJson -- ::+ , loadTestCases -- ::+ , specTestVector -- ::+ , testTree -- :: TestTree+ ) where++import Test.Tasty+import Test.Tasty.QuickCheck++import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.Base64 as Base64+import qualified Data.ByteString.Base64.URL as Base64url+import qualified Data.ByteString.Base16 as Base16+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Vector as V+import Data.Scientific (fromFloatDigits, toRealFloat)+import Data.Aeson as Aeson+import Control.Applicative+import Control.Monad+import Data.Word+import qualified Numeric.Half as Half++import Test.Tasty.HUnit++import Tests.Reference.Implementation as CBOR+++data TestCase = TestCase {+ encoded :: !LBS.ByteString,+ decoded :: !(Either Aeson.Value String),+ roundTrip :: !Bool+ }+ deriving Show++instance FromJSON TestCase where+ parseJSON =+ withObject "cbor test" $ \obj -> do+ encoded64 <- T.encodeUtf8 <$> obj .: "cbor"+ encoded <- either (fail "invalid base64") return $+ Base64.decode encoded64+ encoded16 <- T.encodeUtf8 <$> obj .: "hex"+ let encoded' = fst (Base16.decode encoded16)+ when (encoded /= encoded') $+ fail "hex and cbor encoding mismatch in input"+ roundTrip <- obj .: "roundtrip"+ decoded <- Left <$> obj .: "decoded"+ <|> Right <$> obj .: "diagnostic"+ return $! TestCase {+ encoded = LBS.fromStrict encoded,+ roundTrip,+ decoded+ }++loadTestCases :: IO [TestCase]+loadTestCases = do+ content <- LBS.readFile "tests/test-vectors/appendix_a.json"+ either fail return (Aeson.eitherDecode' content)++externalTestCase :: TestCase -> Assertion+externalTestCase TestCase { encoded, decoded = Left expectedJson } = do+ let term = deserialise encoded+ actualJson = termToJson term+ reencoded = serialise term++ expectedJson `equalJson` actualJson+ encoded @=? reencoded++externalTestCase TestCase { encoded, decoded = Right expectedDiagnostic } = do+ let term = deserialise encoded+ actualDiagnostic = diagnosticNotation term+ reencoded = serialise term++ expectedDiagnostic @=? actualDiagnostic+ encoded @=? reencoded++equalJson :: Aeson.Value -> Aeson.Value -> Assertion+equalJson (Aeson.Number expected) (Aeson.Number actual)+ | toRealFloat expected == promoteDouble (toRealFloat actual)+ = return ()+ where+ -- This is because the expected JSON output is always using double precision+ -- where as Aeson's Scientific type preserves the precision of the input.+ -- So for tests using Float, we're more precise than the reference values.+ promoteDouble :: Float -> Double+ promoteDouble = realToFrac++equalJson expected actual = expected @=? actual+++termToJson :: CBOR.Term -> Aeson.Value+termToJson (TUInt n) = Aeson.Number (fromIntegral (fromUInt n))+termToJson (TNInt n) = Aeson.Number (-1 - fromIntegral (fromUInt n))+termToJson (TBigInt n) = Aeson.Number (fromIntegral n)+termToJson (TBytes ws) = Aeson.String (bytesToBase64Text ws)+termToJson (TBytess wss) = Aeson.String (bytesToBase64Text (concat wss))+termToJson (TString cs) = Aeson.String (T.pack cs)+termToJson (TStrings css) = Aeson.String (T.pack (concat css))+termToJson (TArray ts) = Aeson.Array (V.fromList (map termToJson ts))+termToJson (TArrayI ts) = Aeson.Array (V.fromList (map termToJson ts))+termToJson (TMap kvs) = Aeson.object [ (T.pack k, termToJson v)+ | (TString k,v) <- kvs ]+termToJson (TMapI kvs) = Aeson.object [ (T.pack k, termToJson v)+ | (TString k,v) <- kvs ]+termToJson (TTagged _ t) = termToJson t+termToJson TTrue = Aeson.Bool True+termToJson TFalse = Aeson.Bool False+termToJson TNull = Aeson.Null+termToJson TUndef = Aeson.Null -- replacement value+termToJson (TSimple _) = Aeson.Null -- replacement value+termToJson (TFloat16 f) = Aeson.Number (fromFloatDigits (Half.fromHalf f))+termToJson (TFloat32 f) = Aeson.Number (fromFloatDigits f)+termToJson (TFloat64 f) = Aeson.Number (fromFloatDigits f)++bytesToBase64Text :: [Word8] -> T.Text+bytesToBase64Text = T.decodeLatin1 . Base64url.encode . BS.pack++expectedDiagnosticNotation :: String -> [Word8] -> Assertion+expectedDiagnosticNotation expectedDiagnostic encoded = do+ let Just (term, []) = runDecoder decodeTerm encoded+ actualDiagnostic = diagnosticNotation term++ expectedDiagnostic @=? actualDiagnostic++-- | The reference implementation satisfies the roundtrip property for most+-- examples (all the ones from Appendix A). It does not satisfy the roundtrip+-- property in general however, non-canonical over-long int encodings for+-- example.+--+--+encodedRoundtrip :: String -> [Word8] -> Assertion+encodedRoundtrip expectedDiagnostic encoded = do+ let Just (term, []) = runDecoder decodeTerm encoded+ reencoded = encodeTerm term++ assertEqual ("for CBOR: " ++ expectedDiagnostic) encoded reencoded++-- | The examples from the CBOR spec RFC7049 Appendix A.+-- The diagnostic notation and encoded bytes.+--+specTestVector :: [(String, [Word8])]+specTestVector =+ [ ("0", [0x00])+ , ("1", [0x01])+ , ("10", [0x0a])+ , ("23", [0x17])+ , ("24", [0x18, 0x18])+ , ("25", [0x18, 0x19])+ , ("100", [0x18, 0x64])+ , ("1000", [0x19, 0x03, 0xe8])+ , ("1000000", [0x1a, 0x00, 0x0f, 0x42, 0x40])+ , ("1000000000000", [0x1b, 0x00, 0x00, 0x00, 0xe8, 0xd4, 0xa5, 0x10, 0x00])++ , ("18446744073709551615", [0x1b, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff])+ , ("18446744073709551616", [0xc2, 0x49, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00])+ , ("-18446744073709551616", [0x3b, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff])+ , ("-18446744073709551617", [0xc3, 0x49, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00])++ , ("-1", [0x20])+ , ("-10", [0x29])+ , ("-100", [0x38, 0x63])+ , ("-1000", [0x39, 0x03, 0xe7])++ , ("0.0", [0xf9, 0x00, 0x00])+ , ("-0.0", [0xf9, 0x80, 0x00])+ , ("1.0", [0xf9, 0x3c, 0x00])+ , ("1.1", [0xfb, 0x3f, 0xf1, 0x99, 0x99, 0x99, 0x99, 0x99, 0x9a])+ , ("1.5", [0xf9, 0x3e, 0x00])+ , ("65504.0", [0xf9, 0x7b, 0xff])+ , ("100000.0", [0xfa, 0x47, 0xc3, 0x50, 0x00])+ , ("3.4028234663852886e38", [0xfa, 0x7f, 0x7f, 0xff, 0xff])+ , ("1.0e300", [0xfb, 0x7e, 0x37, 0xe4, 0x3c, 0x88, 0x00, 0x75, 0x9c])+ , ("5.960464477539063e-8", [0xf9, 0x00, 0x01])+ , ("0.00006103515625", [0xf9, 0x04, 0x00])+ , ("-4.0", [0xf9, 0xc4, 0x00])+ , ("-4.1", [0xfb, 0xc0, 0x10, 0x66, 0x66, 0x66, 0x66, 0x66, 0x66])++ , ("Infinity", [0xf9, 0x7c, 0x00])+ , ("NaN", [0xf9, 0x7e, 0x00])+ , ("-Infinity", [0xf9, 0xfc, 0x00])+ , ("Infinity", [0xfa, 0x7f, 0x80, 0x00, 0x00])+ , ("-Infinity", [0xfa, 0xff, 0x80, 0x00, 0x00])+ , ("Infinity", [0xfb, 0x7f, 0xf0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00])+ , ("-Infinity", [0xfb, 0xff, 0xf0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00])++ , ("false", [0xf4])+ , ("true", [0xf5])+ , ("null", [0xf6])+ , ("undefined", [0xf7])+ , ("simple(16)", [0xf0])+ , ("simple(24)", [0xf8, 0x18])+ , ("simple(255)", [0xf8, 0xff])++ , ("0(\"2013-03-21T20:04:00Z\")",+ [0xc0, 0x74, 0x32, 0x30, 0x31, 0x33, 0x2d, 0x30, 0x33, 0x2d, 0x32, 0x31,+ 0x54, 0x32, 0x30, 0x3a, 0x30, 0x34, 0x3a, 0x30, 0x30, 0x5a])+ , ("1(1363896240)", [0xc1, 0x1a, 0x51, 0x4b, 0x67, 0xb0])+ , ("1(1363896240.5)", [0xc1, 0xfb, 0x41, 0xd4, 0x52, 0xd9, 0xec, 0x20, 0x00, 0x00])+ , ("23(h'01020304')", [0xd7, 0x44, 0x01, 0x02, 0x03, 0x04])+ , ("24(h'6449455446')", [0xd8, 0x18, 0x45, 0x64, 0x49, 0x45, 0x54, 0x46])+ , ("32(\"http://www.example.com\")",+ [0xd8, 0x20, 0x76, 0x68, 0x74, 0x74, 0x70, 0x3a, 0x2f, 0x2f, 0x77, 0x77,+ 0x77, 0x2e, 0x65, 0x78, 0x61, 0x6d, 0x70, 0x6c, 0x65, 0x2e, 0x63, 0x6f, 0x6d])++ , ("h''", [0x40])+ , ("h'01020304'", [0x44, 0x01, 0x02, 0x03, 0x04])+ , ("\"\"", [0x60])+ , ("\"a\"", [0x61, 0x61])+ , ("\"IETF\"", [0x64, 0x49, 0x45, 0x54, 0x46])+ , ("\"\\\"\\\\\"", [0x62, 0x22, 0x5c])+ , ("\"\\252\"", [0x62, 0xc3, 0xbc])+ , ("\"\\27700\"", [0x63, 0xe6, 0xb0, 0xb4])+ , ("\"\\65873\"", [0x64, 0xf0, 0x90, 0x85, 0x91])++ , ("[]", [0x80])+ , ("[1, 2, 3]", [0x83, 0x01, 0x02, 0x03])+ , ("[1, [2, 3], [4, 5]]", [0x83, 0x01, 0x82, 0x02, 0x03, 0x82, 0x04, 0x05])+ , ("[1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25]",+ [0x98, 0x19, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, 0x08, 0x09, 0x0a,+ 0x0b, 0x0c, 0x0d, 0x0e, 0x0f, 0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16,+ 0x17, 0x18, 0x18, 0x18, 0x19])++ , ("{}", [0xa0])+ , ("{1: 2, 3: 4}", [0xa2, 0x01, 0x02, 0x03, 0x04])+ , ("{\"a\": 1, \"b\": [2, 3]}", [0xa2, 0x61, 0x61, 0x01, 0x61, 0x62, 0x82, 0x02, 0x03])+ , ("[\"a\", {\"b\": \"c\"}]", [0x82, 0x61, 0x61, 0xa1, 0x61, 0x62, 0x61, 0x63])+ , ("{\"a\": \"A\", \"b\": \"B\", \"c\": \"C\", \"d\": \"D\", \"e\": \"E\"}",+ [0xa5, 0x61, 0x61, 0x61, 0x41, 0x61, 0x62, 0x61, 0x42, 0x61, 0x63, 0x61,+ 0x43, 0x61, 0x64, 0x61, 0x44, 0x61, 0x65, 0x61, 0x45])++ , ("(_ h'0102', h'030405')", [0x5f, 0x42, 0x01, 0x02, 0x43, 0x03, 0x04, 0x05, 0xff])+ , ("(_ \"strea\", \"ming\")", [0x7f, 0x65, 0x73, 0x74, 0x72, 0x65, 0x61, 0x64, 0x6d, 0x69, 0x6e, 0x67, 0xff])++ , ("[_ ]", [0x9f, 0xff])+ , ("[_ 1, [2, 3], [_ 4, 5]]", [0x9f, 0x01, 0x82, 0x02, 0x03, 0x9f, 0x04, 0x05, 0xff, 0xff])+ , ("[_ 1, [2, 3], [4, 5]]", [0x9f, 0x01, 0x82, 0x02, 0x03, 0x82, 0x04, 0x05, 0xff])+ , ("[1, [2, 3], [_ 4, 5]]", [0x83, 0x01, 0x82, 0x02, 0x03, 0x9f, 0x04, 0x05, 0xff])+ , ("[1, [_ 2, 3], [4, 5]]", [0x83, 0x01, 0x9f, 0x02, 0x03, 0xff, 0x82, 0x04, 0x05])+ , ("[_ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25]",+ [0x9f, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, 0x08, 0x09, 0x0a, 0x0b,+ 0x0c, 0x0d, 0x0e, 0x0f, 0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17,+ 0x18, 0x18, 0x18, 0x19, 0xff])+ , ("{_ \"a\": 1, \"b\": [_ 2, 3]}", [0xbf, 0x61, 0x61, 0x01, 0x61, 0x62, 0x9f, 0x02, 0x03, 0xff, 0xff])++ , ("[\"a\", {_ \"b\": \"c\"}]", [0x82, 0x61, 0x61, 0xbf, 0x61, 0x62, 0x61, 0x63, 0xff])+ , ("{_ \"Fun\": true, \"Amt\": -2}", [0xbf, 0x63, 0x46, 0x75, 0x6e, 0xf5, 0x63, 0x41, 0x6d, 0x74, 0x21, 0xff])+ ]++-- TODO FIXME: test redundant encodings e.g.+-- bigint with zero-length bytestring+-- bigint with leading zeros+-- bigint using indefinate bytestring encoding+-- larger than necessary ints, lengths, tags, simple etc++--------------------------------------------------------------------------------+-- TestTree API++testTree :: [TestCase] -> TestTree+testTree testCases =+ testGroup "Reference implementation"+ [ testCase "external test vector" $+ mapM_ externalTestCase testCases++ , testCase "internal test vector" $ do+ sequence_ [ do expectedDiagnosticNotation d e+ encodedRoundtrip d e+ | (d,e) <- specTestVector ]++ , testGroup "properties"+ [ testProperty "encoding/decoding initial byte" prop_InitialByte+ , testProperty "encoding/decoding additional info" prop_AdditionalInfo+ , testProperty "encoding/decoding token header" prop_TokenHeader+ , testProperty "encoding/decoding token header 2" prop_TokenHeader2+ , testProperty "encoding/decoding tokens" prop_Token+ , --localOption (QuickCheckTests 1000) $+ localOption (QuickCheckMaxSize 150) $+ testProperty "encoding/decoding terms" prop_Term+ ]++ , testGroup "internal properties"+ [ testProperty "Integer to/from bytes" prop_integerToFromBytes+ , testProperty "Word16 to/from network byte order" prop_word16ToFromNet+ , testProperty "Word32 to/from network byte order" prop_word32ToFromNet+ , testProperty "Word64 to/from network byte order" prop_word64ToFromNet+ , testProperty "Numeric.Half to/from Float" prop_halfToFromFloat+ ]+ ]
+ tests/Tests/Reference/Implementation.hs view
@@ -0,0 +1,1074 @@+{-# LANGUAGE CPP, BangPatterns, MagicHash, UnboxedTuples, RankNTypes, ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-----------------------------------------------------------------------------+-- |+-- Module : Codec.CBOR+-- Copyright : 2013 Simon Meier <iridcode@gmail.com>,+-- 2013-2014 Duncan Coutts,+-- License : BSD3-style (see LICENSE.txt)+--+-- Maintainer : Duncan Coutts+-- Stability :+-- Portability : portable+--+-- CBOR format support.+--+-----------------------------------------------------------------------------++module Tests.Reference.Implementation (+ serialise,+ deserialise,++ Term(..),+ reservedTag,+ reservedSimple,+ eqTerm,+ canonicaliseTerm,++ UInt(..),+ fromUInt,+ toUInt,+ canonicaliseUInt,++ Decoder,+ runDecoder,+ testDecode,++ decodeTerm,+ decodeTokens,+ decodeToken,++ canonicalNaN,++ diagnosticNotation,++ encodeTerm,+ encodeToken,++ prop_InitialByte,+ prop_AdditionalInfo,+ prop_TokenHeader,+ prop_TokenHeader2,+ prop_Token,+ prop_Term,++ -- properties of internal helpers+ prop_integerToFromBytes,+ prop_word16ToFromNet,+ prop_word32ToFromNet,+ prop_word64ToFromNet,+ prop_halfToFromFloat,++ arbitraryFullRangeIntegral,+ ) where+++import qualified Control.Monad.Fail as Fail+import Data.Bits+import Data.Word+import Data.Int+import Numeric.Half (Half(..))+import qualified Numeric.Half as Half+import Data.List+import Numeric+import GHC.Float (float2Double)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Monoid ((<>))+import Foreign+import System.IO.Unsafe+import Control.Monad (ap)++import Test.QuickCheck.Arbitrary+import Test.QuickCheck.Gen++#if !MIN_VERSION_base(4,8,0)+import Data.Monoid (Monoid(..))+import Control.Applicative+#endif+++serialise :: Term -> LBS.ByteString+serialise = LBS.pack . encodeTerm++deserialise :: LBS.ByteString -> Term+deserialise bytes =+ case runDecoder decodeTerm (LBS.unpack bytes) of+ Just (term, []) -> term+ Just _ -> error "ReferenceImpl.deserialise: trailing data"+ Nothing -> error "ReferenceImpl.deserialise: decoding failed"+++------------------------------------------------------------------------++newtype Decoder a = Decoder { runDecoder :: [Word8] -> Maybe (a, [Word8]) }++instance Functor Decoder where+ fmap f a = a >>= return . f++instance Applicative Decoder where+ pure = return+ (<*>) = ap++instance Monad Decoder where+ return x = Decoder (\ws -> Just (x, ws))+ d >>= f = Decoder (\ws -> case runDecoder d ws of+ Nothing -> Nothing+ Just (x, ws') -> runDecoder (f x) ws')+ fail = Fail.fail++instance Fail.MonadFail Decoder where+ fail _ = Decoder (\_ -> Nothing)++getByte :: Decoder Word8+getByte =+ Decoder $ \ws ->+ case ws of+ w:ws' -> Just (w, ws')+ _ -> Nothing++getBytes :: Integral n => n -> Decoder [Word8]+getBytes n =+ Decoder $ \ws ->+ case genericSplitAt n ws of+ (ws', []) | genericLength ws' == n -> Just (ws', [])+ | otherwise -> Nothing+ (ws', ws'') -> Just (ws', ws'')++eof :: Decoder Bool+eof = Decoder $ \ws -> Just (null ws, ws)++type Encoder a = a -> [Word8]++-- The initial byte of each data item contains both information about+-- the major type (the high-order 3 bits, described in Section 2.1) and+-- additional information (the low-order 5 bits).++data MajorType = MajorType0 | MajorType1 | MajorType2 | MajorType3+ | MajorType4 | MajorType5 | MajorType6 | MajorType7+ deriving (Show, Eq, Ord, Enum)++instance Arbitrary MajorType where+ arbitrary = elements [MajorType0 .. MajorType7]++encodeInitialByte :: MajorType -> Word -> Word8+encodeInitialByte mt ai+ | ai < 2^(5 :: Int)+ = fromIntegral (fromIntegral (fromEnum mt) `shiftL` 5 .|. ai)++ | otherwise+ = error "encodeInitialByte: invalid additional info value"++decodeInitialByte :: Word8 -> (MajorType, Word)+decodeInitialByte ib = ( toEnum $ fromIntegral $ ib `shiftR` 5+ , fromIntegral $ ib .&. 0x1f)++prop_InitialByte :: Bool+prop_InitialByte =+ and [ (uncurry encodeInitialByte . decodeInitialByte) w8 == w8+ | w8 <- [minBound..maxBound] ]++-- When the value of the+-- additional information is less than 24, it is directly used as a+-- small unsigned integer. When it is 24 to 27, the additional bytes+-- for a variable-length integer immediately follow; the values 24 to 27+-- of the additional information specify that its length is a 1-, 2-,+-- 4-, or 8-byte unsigned integer, respectively. Additional information+-- value 31 is used for indefinite-length items, described in+-- Section 2.2. Additional information values 28 to 30 are reserved for+-- future expansion.+--+-- In all additional information values, the resulting integer is+-- interpreted depending on the major type. It may represent the actual+-- data: for example, in integer types, the resulting integer is used+-- for the value itself. It may instead supply length information: for+-- example, in byte strings it gives the length of the byte string data+-- that follows.++data UInt =+ UIntSmall Word+ | UInt8 Word8+ | UInt16 Word16+ | UInt32 Word32+ | UInt64 Word64+ deriving (Eq, Show)++data AdditionalInformation =+ AiValue UInt+ | AiIndefLen+ | AiReserved Word+ deriving (Eq, Show)++instance Arbitrary UInt where+ arbitrary =+ sized $ \n ->+ oneof $ take (1 + n `div` 2)+ [ UIntSmall <$> choose (0, 23)+ , UInt8 <$> arbitraryBoundedIntegral+ , UInt16 <$> arbitraryBoundedIntegral+ , UInt32 <$> arbitraryBoundedIntegral+ , UInt64 <$> arbitraryBoundedIntegral+ ]++instance Arbitrary AdditionalInformation where+ arbitrary =+ frequency+ [ (7, AiValue <$> arbitrary)+ , (2, pure AiIndefLen)+ , (1, AiReserved <$> choose (28, 30))+ ]++decodeAdditionalInfo :: Word -> Decoder AdditionalInformation+decodeAdditionalInfo = dec+ where+ dec n+ | n < 24 = return (AiValue (UIntSmall n))+ dec 24 = do w <- getByte+ return (AiValue (UInt8 w))+ dec 25 = do [w1,w0] <- getBytes (2 :: Int)+ let w = word16FromNet w1 w0+ return (AiValue (UInt16 w))+ dec 26 = do [w3,w2,w1,w0] <- getBytes (4 :: Int)+ let w = word32FromNet w3 w2 w1 w0+ return (AiValue (UInt32 w))+ dec 27 = do [w7,w6,w5,w4,w3,w2,w1,w0] <- getBytes (8 :: Int)+ let w = word64FromNet w7 w6 w5 w4 w3 w2 w1 w0+ return (AiValue (UInt64 w))+ dec 31 = return AiIndefLen+ dec n+ | n < 31 = return (AiReserved n)+ dec _ = fail ""++encodeAdditionalInfo :: AdditionalInformation -> (Word, [Word8])+encodeAdditionalInfo = enc+ where+ enc (AiValue (UIntSmall n))+ | n < 24 = (n, [])+ | otherwise = error "invalid UIntSmall value"+ enc (AiValue (UInt8 w)) = (24, [w])+ enc (AiValue (UInt16 w)) = (25, [w1, w0])+ where (w1, w0) = word16ToNet w+ enc (AiValue (UInt32 w)) = (26, [w3, w2, w1, w0])+ where (w3, w2, w1, w0) = word32ToNet w+ enc (AiValue (UInt64 w)) = (27, [w7, w6, w5, w4,+ w3, w2, w1, w0])+ where (w7, w6, w5, w4,+ w3, w2, w1, w0) = word64ToNet w+ enc AiIndefLen = (31, [])+ enc (AiReserved n)+ | n >= 28 && n < 31 = (n, [])+ | otherwise = error "invalid AiReserved value"++prop_AdditionalInfo :: AdditionalInformation -> Bool+prop_AdditionalInfo ai =+ let (w, ws) = encodeAdditionalInfo ai+ Just (ai', _) = runDecoder (decodeAdditionalInfo w) ws+ in ai == ai'+++data TokenHeader = TokenHeader MajorType AdditionalInformation+ deriving (Show, Eq)++instance Arbitrary TokenHeader where+ arbitrary = TokenHeader <$> arbitrary <*> arbitrary++decodeTokenHeader :: Decoder TokenHeader+decodeTokenHeader = do+ b <- getByte+ let (mt, ai) = decodeInitialByte b+ ai' <- decodeAdditionalInfo ai+ return (TokenHeader mt ai')++encodeTokenHeader :: Encoder TokenHeader+encodeTokenHeader (TokenHeader mt ai) =+ let (w, ws) = encodeAdditionalInfo ai+ in encodeInitialByte mt w : ws++prop_TokenHeader :: TokenHeader -> Bool+prop_TokenHeader header =+ let ws = encodeTokenHeader header+ Just (header', _) = runDecoder decodeTokenHeader ws+ in header == header'++prop_TokenHeader2 :: Bool+prop_TokenHeader2 =+ and [ w8 : extraused == encoded+ | w8 <- [minBound..maxBound]+ , let extra = [1..8]+ Just (header, unused) = runDecoder decodeTokenHeader (w8 : extra)+ encoded = encodeTokenHeader header+ extraused = take (8 - length unused) extra+ ]++data Token =+ MT0_UnsignedInt UInt+ | MT1_NegativeInt UInt+ | MT2_ByteString UInt [Word8]+ | MT2_ByteStringIndef+ | MT3_String UInt [Word8]+ | MT3_StringIndef+ | MT4_ArrayLen UInt+ | MT4_ArrayLenIndef+ | MT5_MapLen UInt+ | MT5_MapLenIndef+ | MT6_Tag UInt+ | MT7_Simple Word8+ | MT7_Float16 Half+ | MT7_Float32 Float+ | MT7_Float64 Double+ | MT7_Break+ deriving (Show, Eq)++instance Arbitrary Token where+ arbitrary =+ oneof+ [ MT0_UnsignedInt <$> arbitrary+ , MT1_NegativeInt <$> arbitrary+ , do ws <- arbitrary+ MT2_ByteString <$> arbitraryLengthUInt ws <*> pure ws+ , pure MT2_ByteStringIndef+ , do cs <- arbitrary+ let ws = encodeUTF8 cs+ MT3_String <$> arbitraryLengthUInt ws <*> pure ws+ , pure MT3_StringIndef+ , MT4_ArrayLen <$> arbitrary+ , pure MT4_ArrayLenIndef+ , MT5_MapLen <$> arbitrary+ , pure MT5_MapLenIndef+ , MT6_Tag <$> arbitrary+ , MT7_Simple <$> arbitrary+ , MT7_Float16 . getFloatSpecials <$> arbitrary+ , MT7_Float32 . getFloatSpecials <$> arbitrary+ , MT7_Float64 . getFloatSpecials <$> arbitrary+ , pure MT7_Break+ ]+ where+ arbitraryLengthUInt xs =+ let n = length xs in+ elements $+ [ UIntSmall (fromIntegral n) | n < 24 ]+ ++ [ UInt8 (fromIntegral n) | n < 255 ]+ ++ [ UInt16 (fromIntegral n) | n < 65536 ]+ ++ [ UInt32 (fromIntegral n)+ , UInt64 (fromIntegral n) ]++testDecode :: [Word8] -> Term+testDecode ws =+ case runDecoder decodeTerm ws of+ Just (x, []) -> x+ _ -> error "testDecode: parse error"++decodeTokens :: Decoder [Token]+decodeTokens = do+ done <- eof+ if done+ then return []+ else do tok <- decodeToken+ toks <- decodeTokens+ return (tok:toks)++decodeToken :: Decoder Token+decodeToken = do+ header <- decodeTokenHeader+ extra <- getBytes (tokenExtraLen header)+ either fail return (packToken header extra)++tokenExtraLen :: TokenHeader -> Word64+tokenExtraLen (TokenHeader MajorType2 (AiValue n)) = fromUInt n -- bytestrings+tokenExtraLen (TokenHeader MajorType3 (AiValue n)) = fromUInt n -- unicode strings+tokenExtraLen _ = 0++packToken :: TokenHeader -> [Word8] -> Either String Token+packToken (TokenHeader mt ai) extra = case (mt, ai) of+ -- Major type 0: an unsigned integer. The 5-bit additional information+ -- is either the integer itself (for additional information values 0+ -- through 23) or the length of additional data.+ (MajorType0, AiValue n) -> return (MT0_UnsignedInt n)++ -- Major type 1: a negative integer. The encoding follows the rules+ -- for unsigned integers (major type 0), except that the value is+ -- then -1 minus the encoded unsigned integer.+ (MajorType1, AiValue n) -> return (MT1_NegativeInt n)++ -- Major type 2: a byte string. The string's length in bytes is+ -- represented following the rules for positive integers (major type 0).+ (MajorType2, AiValue n) -> return (MT2_ByteString n extra)+ (MajorType2, AiIndefLen) -> return MT2_ByteStringIndef++ -- Major type 3: a text string, specifically a string of Unicode+ -- characters that is encoded as UTF-8 [RFC3629]. The format of this+ -- type is identical to that of byte strings (major type 2), that is,+ -- as with major type 2, the length gives the number of bytes.+ (MajorType3, AiValue n) -> return (MT3_String n extra)+ (MajorType3, AiIndefLen) -> return MT3_StringIndef++ -- Major type 4: an array of data items. The array's length follows the+ -- rules for byte strings (major type 2), except that the length+ -- denotes the number of data items, not the length in bytes that the+ -- array takes up.+ (MajorType4, AiValue n) -> return (MT4_ArrayLen n)+ (MajorType4, AiIndefLen) -> return MT4_ArrayLenIndef++ -- Major type 5: a map of pairs of data items. A map is comprised of+ -- pairs of data items, each pair consisting of a key that is+ -- immediately followed by a value. The map's length follows the+ -- rules for byte strings (major type 2), except that the length+ -- denotes the number of pairs, not the length in bytes that the map+ -- takes up.+ (MajorType5, AiValue n) -> return (MT5_MapLen n)+ (MajorType5, AiIndefLen) -> return MT5_MapLenIndef++ -- Major type 6: optional semantic tagging of other major types.+ -- The initial bytes of the tag follow the rules for positive integers+ -- (major type 0).+ (MajorType6, AiValue n) -> return (MT6_Tag n)++ -- Major type 7 is for two types of data: floating-point numbers and+ -- "simple values" that do not need any content. Each value of the+ -- 5-bit additional information in the initial byte has its own separate+ -- meaning, as defined in Table 1.+ -- | 0..23 | Simple value (value 0..23) |+ -- | 24 | Simple value (value 32..255 in following byte) |+ -- | 25 | IEEE 754 Half-Precision Float (16 bits follow) |+ -- | 26 | IEEE 754 Single-Precision Float (32 bits follow) |+ -- | 27 | IEEE 754 Double-Precision Float (64 bits follow) |+ -- | 28-30 | (Unassigned) |+ -- | 31 | "break" stop code for indefinite-length items |+ (MajorType7, AiValue (UIntSmall w)) -> return (MT7_Simple (fromIntegral w))+ (MajorType7, AiValue (UInt8 w)) -> return (MT7_Simple (fromIntegral w))+ (MajorType7, AiValue (UInt16 w)) -> return (MT7_Float16 (wordToHalf w))+ (MajorType7, AiValue (UInt32 w)) -> return (MT7_Float32 (wordToFloat w))+ (MajorType7, AiValue (UInt64 w)) -> return (MT7_Float64 (wordToDouble w))+ (MajorType7, AiIndefLen) -> return (MT7_Break)+ _ -> fail "invalid token header"+++encodeToken :: Encoder Token+encodeToken tok =+ let (header, extra) = unpackToken tok+ in encodeTokenHeader header ++ extra+++unpackToken :: Token -> (TokenHeader, [Word8])+unpackToken tok = (\(mt, ai, ws) -> (TokenHeader mt ai, ws)) $ case tok of+ (MT0_UnsignedInt n) -> (MajorType0, AiValue n, [])+ (MT1_NegativeInt n) -> (MajorType1, AiValue n, [])+ (MT2_ByteString n ws) -> (MajorType2, AiValue n, ws)+ MT2_ByteStringIndef -> (MajorType2, AiIndefLen, [])+ (MT3_String n ws) -> (MajorType3, AiValue n, ws)+ MT3_StringIndef -> (MajorType3, AiIndefLen, [])+ (MT4_ArrayLen n) -> (MajorType4, AiValue n, [])+ MT4_ArrayLenIndef -> (MajorType4, AiIndefLen, [])+ (MT5_MapLen n) -> (MajorType5, AiValue n, [])+ MT5_MapLenIndef -> (MajorType5, AiIndefLen, [])+ (MT6_Tag n) -> (MajorType6, AiValue n, [])+ (MT7_Simple n)+ | n <= 23 -> (MajorType7, AiValue (UIntSmall (fromIntegral n)), [])+ | otherwise -> (MajorType7, AiValue (UInt8 n), [])+ (MT7_Float16 f) -> (MajorType7, AiValue (UInt16 (halfToWord f)), [])+ (MT7_Float32 f) -> (MajorType7, AiValue (UInt32 (floatToWord f)), [])+ (MT7_Float64 f) -> (MajorType7, AiValue (UInt64 (doubleToWord f)), [])+ MT7_Break -> (MajorType7, AiIndefLen, [])+++fromUInt :: UInt -> Word64+fromUInt (UIntSmall w) = fromIntegral w+fromUInt (UInt8 w) = fromIntegral w+fromUInt (UInt16 w) = fromIntegral w+fromUInt (UInt32 w) = fromIntegral w+fromUInt (UInt64 w) = fromIntegral w++toUInt :: Word64 -> UInt+toUInt n+ | n < 24 = UIntSmall (fromIntegral n)+ | n <= fromIntegral (maxBound :: Word8) = UInt8 (fromIntegral n)+ | n <= fromIntegral (maxBound :: Word16) = UInt16 (fromIntegral n)+ | n <= fromIntegral (maxBound :: Word32) = UInt32 (fromIntegral n)+ | otherwise = UInt64 n++lengthUInt :: [a] -> UInt+lengthUInt = toUInt . fromIntegral . length++decodeUTF8 :: [Word8] -> Either String [Char]+decodeUTF8 = either (fail . show) (return . T.unpack) . T.decodeUtf8' . BS.pack++encodeUTF8 :: [Char] -> [Word8]+encodeUTF8 = BS.unpack . T.encodeUtf8 . T.pack++reservedSimple :: Word8 -> Bool+reservedSimple w = w >= 20 && w <= 31++reservedTag :: Word64 -> Bool+reservedTag w = w <= 5++prop_Token :: Token -> Bool+prop_Token token =+ let ws = encodeToken token+ Just (token', []) = runDecoder decodeToken ws+ in token `eqToken` token'++-- NaNs are so annoying...+eqToken :: Token -> Token -> Bool+eqToken (MT7_Float16 f) (MT7_Float16 f') | isNaN f && isNaN f' = True+eqToken (MT7_Float32 f) (MT7_Float32 f') | isNaN f && isNaN f' = True+eqToken (MT7_Float64 f) (MT7_Float64 f') | isNaN f && isNaN f' = True+eqToken a b = a == b++data Term = TUInt UInt+ | TNInt UInt+ | TBigInt Integer+ | TBytes [Word8]+ | TBytess [[Word8]]+ | TString [Char]+ | TStrings [[Char]]+ | TArray [Term]+ | TArrayI [Term]+ | TMap [(Term, Term)]+ | TMapI [(Term, Term)]+ | TTagged UInt Term+ | TTrue+ | TFalse+ | TNull+ | TUndef+ | TSimple Word8+ | TFloat16 Half+ | TFloat32 Float+ | TFloat64 Double+ deriving (Show, Eq)++instance Arbitrary Term where+ arbitrary =+ frequency+ [ (1, TUInt <$> arbitrary)+ , (1, TNInt <$> arbitrary)+ , (1, TBigInt . getLargeInteger <$> arbitrary)+ , (1, TBytes <$> arbitrary)+ , (1, TBytess <$> arbitrary)+ , (1, TString <$> arbitrary)+ , (1, TStrings <$> arbitrary)+ , (2, TArray <$> listOfSmaller arbitrary)+ , (2, TArrayI <$> listOfSmaller arbitrary)+ , (2, TMap <$> listOfSmaller ((,) <$> arbitrary <*> arbitrary))+ , (2, TMapI <$> listOfSmaller ((,) <$> arbitrary <*> arbitrary))+ , (1, TTagged <$> arbitraryTag <*> sized (\sz -> resize (max 0 (sz-1)) arbitrary))+ , (1, pure TFalse)+ , (1, pure TTrue)+ , (1, pure TNull)+ , (1, pure TUndef)+ , (1, TSimple <$> arbitrary `suchThat` (not . reservedSimple))+ , (1, TFloat16 <$> arbitrary)+ , (1, TFloat32 <$> arbitrary)+ , (1, TFloat64 <$> arbitrary)+ ]+ where+ listOfSmaller :: Gen a -> Gen [a]+ listOfSmaller gen =+ sized $ \n -> do+ k <- choose (0,n)+ vectorOf k (resize (n `div` (k+1)) gen)++ arbitraryTag = arbitrary `suchThat` (not . reservedTag . fromUInt)++ shrink (TUInt n) = [ TUInt n' | n' <- shrink n ]+ shrink (TNInt n) = [ TNInt n' | n' <- shrink n ]+ shrink (TBigInt n) = [ TBigInt n' | n' <- shrink n ]++ shrink (TBytes ws) = [ TBytes ws' | ws' <- shrink ws ]+ shrink (TBytess wss) = [ TBytess wss' | wss' <- shrink wss ]+ shrink (TString ws) = [ TString ws' | ws' <- shrink ws ]+ shrink (TStrings wss) = [ TStrings wss' | wss' <- shrink wss ]++ shrink (TArray xs@[x]) = x : [ TArray xs' | xs' <- shrink xs ]+ shrink (TArray xs) = [ TArray xs' | xs' <- shrink xs ]+ shrink (TArrayI xs@[x]) = x : [ TArrayI xs' | xs' <- shrink xs ]+ shrink (TArrayI xs) = [ TArrayI xs' | xs' <- shrink xs ]++ shrink (TMap xys@[(x,y)]) = x : y : [ TMap xys' | xys' <- shrink xys ]+ shrink (TMap xys) = [ TMap xys' | xys' <- shrink xys ]+ shrink (TMapI xys@[(x,y)]) = x : y : [ TMapI xys' | xys' <- shrink xys ]+ shrink (TMapI xys) = [ TMapI xys' | xys' <- shrink xys ]++ shrink (TTagged w t) = [ TTagged w' t' | (w', t') <- shrink (w, t)+ , not (reservedTag (fromUInt w')) ]++ shrink TFalse = []+ shrink TTrue = []+ shrink TNull = []+ shrink TUndef = []++ shrink (TSimple w) = [ TSimple w' | w' <- shrink w, not (reservedSimple w) ]+ shrink (TFloat16 f) = [ TFloat16 f' | f' <- shrink f ]+ shrink (TFloat32 f) = [ TFloat32 f' | f' <- shrink f ]+ shrink (TFloat64 f) = [ TFloat64 f' | f' <- shrink f ]+++decodeTerm :: Decoder Term+decodeTerm = decodeToken >>= decodeTermFrom++decodeTermFrom :: Token -> Decoder Term+decodeTermFrom tk =+ case tk of+ MT0_UnsignedInt n -> return (TUInt n)+ MT1_NegativeInt n -> return (TNInt n)++ MT2_ByteString _ bs -> return (TBytes bs)+ MT2_ByteStringIndef -> decodeBytess []++ MT3_String _ ws -> either fail (return . TString) (decodeUTF8 ws)+ MT3_StringIndef -> decodeStrings []++ MT4_ArrayLen len -> decodeArrayN (fromUInt len) []+ MT4_ArrayLenIndef -> decodeArray []++ MT5_MapLen len -> decodeMapN (fromUInt len) []+ MT5_MapLenIndef -> decodeMap []++ MT6_Tag tag -> decodeTagged tag++ MT7_Simple 20 -> return TFalse+ MT7_Simple 21 -> return TTrue+ MT7_Simple 22 -> return TNull+ MT7_Simple 23 -> return TUndef+ MT7_Simple w -> return (TSimple w)+ MT7_Float16 f -> return (TFloat16 f)+ MT7_Float32 f -> return (TFloat32 f)+ MT7_Float64 f -> return (TFloat64 f)+ MT7_Break -> fail "unexpected"+++decodeBytess :: [[Word8]] -> Decoder Term+decodeBytess acc = do+ tk <- decodeToken+ case tk of+ MT7_Break -> return $! TBytess (reverse acc)+ MT2_ByteString _ bs -> decodeBytess (bs : acc)+ _ -> fail "unexpected"++decodeStrings :: [String] -> Decoder Term+decodeStrings acc = do+ tk <- decodeToken+ case tk of+ MT7_Break -> return $! TStrings (reverse acc)+ MT3_String _ ws -> do cs <- either fail return (decodeUTF8 ws)+ decodeStrings (cs : acc)+ _ -> fail "unexpected"++decodeArrayN :: Word64 -> [Term] -> Decoder Term+decodeArrayN n acc =+ case n of+ 0 -> return $! TArray (reverse acc)+ _ -> do t <- decodeTerm+ decodeArrayN (n-1) (t : acc)++decodeArray :: [Term] -> Decoder Term+decodeArray acc = do+ tk <- decodeToken+ case tk of+ MT7_Break -> return $! TArrayI (reverse acc)+ _ -> do+ tm <- decodeTermFrom tk+ decodeArray (tm : acc)++decodeMapN :: Word64 -> [(Term, Term)] -> Decoder Term+decodeMapN n acc =+ case n of+ 0 -> return $! TMap (reverse acc)+ _ -> do+ tm <- decodeTerm+ tm' <- decodeTerm+ decodeMapN (n-1) ((tm, tm') : acc)++decodeMap :: [(Term, Term)] -> Decoder Term+decodeMap acc = do+ tk <- decodeToken+ case tk of+ MT7_Break -> return $! TMapI (reverse acc)+ _ -> do+ tm <- decodeTermFrom tk+ tm' <- decodeTerm+ decodeMap ((tm, tm') : acc)++decodeTagged :: UInt -> Decoder Term+decodeTagged tag | fromUInt tag == 2 = do+ MT2_ByteString _ bs <- decodeToken+ let !n = integerFromBytes bs+ return (TBigInt n)+decodeTagged tag | fromUInt tag == 3 = do+ MT2_ByteString _ bs <- decodeToken+ let !n = integerFromBytes bs+ return (TBigInt (-1 - n))+decodeTagged tag = do+ tm <- decodeTerm+ return (TTagged tag tm)++integerFromBytes :: [Word8] -> Integer+integerFromBytes [] = 0+integerFromBytes (w0:ws0) = go (fromIntegral w0) ws0+ where+ go !acc [] = acc+ go !acc (w:ws) = go (acc `shiftL` 8 + fromIntegral w) ws++integerToBytes :: Integer -> [Word8]+integerToBytes n0+ | n0 == 0 = [0]+ | n0 < 0 = reverse (go (-n0))+ | otherwise = reverse (go n0)+ where+ go n | n == 0 = []+ | otherwise = narrow n : go (n `shiftR` 8)++ narrow :: Integer -> Word8+ narrow = fromIntegral++prop_integerToFromBytes :: LargeInteger -> Bool+prop_integerToFromBytes (LargeInteger n)+ | n >= 0 =+ let ws = integerToBytes n+ n' = integerFromBytes ws+ in n == n'+ | otherwise =+ let ws = integerToBytes n+ n' = integerFromBytes ws+ in n == -n'++-------------------------------------------------------------------------------++encodeTerm :: Encoder Term+encodeTerm (TUInt n) = encodeToken (MT0_UnsignedInt n)+encodeTerm (TNInt n) = encodeToken (MT1_NegativeInt n)+encodeTerm (TBigInt n)+ | n >= 0 = encodeToken (MT6_Tag (UIntSmall 2))+ <> let ws = integerToBytes n+ len = lengthUInt ws in+ encodeToken (MT2_ByteString len ws)+ | otherwise = encodeToken (MT6_Tag (UIntSmall 3))+ <> let ws = integerToBytes (-1 - n)+ len = lengthUInt ws in+ encodeToken (MT2_ByteString len ws)+encodeTerm (TBytes ws) = let len = lengthUInt ws in+ encodeToken (MT2_ByteString len ws)+encodeTerm (TBytess wss) = encodeToken MT2_ByteStringIndef+ <> mconcat [ encodeToken (MT2_ByteString len ws)+ | ws <- wss+ , let len = lengthUInt ws ]+ <> encodeToken MT7_Break+encodeTerm (TString cs) = let ws = encodeUTF8 cs+ len = lengthUInt ws in+ encodeToken (MT3_String len ws)+encodeTerm (TStrings css) = encodeToken MT3_StringIndef+ <> mconcat [ encodeToken (MT3_String len ws)+ | cs <- css+ , let ws = encodeUTF8 cs+ len = lengthUInt ws ]+ <> encodeToken MT7_Break+encodeTerm (TArray ts) = let len = lengthUInt ts in+ encodeToken (MT4_ArrayLen len)+ <> mconcat (map encodeTerm ts)+encodeTerm (TArrayI ts) = encodeToken MT4_ArrayLenIndef+ <> mconcat (map encodeTerm ts)+ <> encodeToken MT7_Break+encodeTerm (TMap kvs) = let len = lengthUInt kvs in+ encodeToken (MT5_MapLen len)+ <> mconcat [ encodeTerm k <> encodeTerm v+ | (k,v) <- kvs ]+encodeTerm (TMapI kvs) = encodeToken MT5_MapLenIndef+ <> mconcat [ encodeTerm k <> encodeTerm v+ | (k,v) <- kvs ]+ <> encodeToken MT7_Break+encodeTerm (TTagged tag t) = encodeToken (MT6_Tag tag)+ <> encodeTerm t+encodeTerm TFalse = encodeToken (MT7_Simple 20)+encodeTerm TTrue = encodeToken (MT7_Simple 21)+encodeTerm TNull = encodeToken (MT7_Simple 22)+encodeTerm TUndef = encodeToken (MT7_Simple 23)+encodeTerm (TSimple w) = encodeToken (MT7_Simple w)+encodeTerm (TFloat16 f) = encodeToken (MT7_Float16 f)+encodeTerm (TFloat32 f) = encodeToken (MT7_Float32 f)+encodeTerm (TFloat64 f) = encodeToken (MT7_Float64 f)+++-------------------------------------------------------------------------------++prop_Term :: Term -> Bool+prop_Term term =+ let ws = encodeTerm term+ Just (term', []) = runDecoder decodeTerm ws+ in term `eqTerm` term'++-- NaNs are so annoying...+eqTerm :: Term -> Term -> Bool+eqTerm (TArray ts) (TArray ts') = and (zipWith eqTerm ts ts')+eqTerm (TArrayI ts) (TArrayI ts') = and (zipWith eqTerm ts ts')+eqTerm (TMap ts) (TMap ts') = and (zipWith eqTermPair ts ts')+eqTerm (TMapI ts) (TMapI ts') = and (zipWith eqTermPair ts ts')+eqTerm (TTagged w t) (TTagged w' t') = w == w' && eqTerm t t'+eqTerm (TFloat16 f) (TFloat16 f') | isNaN f && isNaN f' = True+eqTerm (TFloat32 f) (TFloat32 f') | isNaN f && isNaN f' = True+eqTerm (TFloat64 f) (TFloat64 f') | isNaN f && isNaN f' = True+eqTerm a b = a == b++eqTermPair :: (Term, Term) -> (Term, Term) -> Bool+eqTermPair (a,b) (a',b') = eqTerm a a' && eqTerm b b'++canonicaliseTerm :: Term -> Term+canonicaliseTerm (TUInt n) = TUInt (canonicaliseUInt n)+canonicaliseTerm (TNInt n) = TNInt (canonicaliseUInt n)+canonicaliseTerm (TBigInt n)+ | n >= 0 && n <= fromIntegral (maxBound :: Word64)+ = TUInt (toUInt (fromIntegral n))+ | n < 0 && n >= -1 - fromIntegral (maxBound :: Word64)+ = TNInt (toUInt (fromIntegral (-1 - n)))+ | otherwise = TBigInt n+canonicaliseTerm (TFloat16 f) = TFloat16 (canonicaliseHalf f)+canonicaliseTerm (TFloat32 f) = if isNaN f+ then TFloat16 canonicalNaN+ else TFloat32 f+canonicaliseTerm (TFloat64 f) = if isNaN f+ then TFloat16 canonicalNaN+ else TFloat64 f+canonicaliseTerm (TBytess wss) = TBytess (filter (not . null) wss)+canonicaliseTerm (TStrings css) = TStrings (filter (not . null) css)+canonicaliseTerm (TArray ts) = TArray (map canonicaliseTerm ts)+canonicaliseTerm (TArrayI ts) = TArrayI (map canonicaliseTerm ts)+canonicaliseTerm (TMap ts) = TMap (map canonicaliseTermPair ts)+canonicaliseTerm (TMapI ts) = TMapI (map canonicaliseTermPair ts)+canonicaliseTerm (TTagged tag t) = TTagged (canonicaliseUInt tag) (canonicaliseTerm t)+canonicaliseTerm t = t++canonicaliseUInt :: UInt -> UInt+canonicaliseUInt = toUInt . fromUInt++canonicaliseHalf :: Half -> Half+canonicaliseHalf f+ | isNaN f = canonicalNaN+ | otherwise = f++canonicaliseTermPair :: (Term, Term) -> (Term, Term)+canonicaliseTermPair (x,y) = (canonicaliseTerm x, canonicaliseTerm y)++canonicalNaN :: Half+canonicalNaN = Half 0x7e00++-------------------------------------------------------------------------------++diagnosticNotation :: Term -> String+diagnosticNotation = \t -> showsTerm t ""+ where+ showsTerm tm = case tm of+ TUInt n -> shows (fromUInt n)+ TNInt n -> shows (-1 - fromIntegral (fromUInt n) :: Integer)+ TBigInt n -> shows n+ TBytes bs -> showsBytes bs+ TBytess bss -> surround '(' ')' (underscoreSpace . commaSep showsBytes bss)+ TString cs -> shows cs+ TStrings css -> surround '(' ')' (underscoreSpace . commaSep shows css)+ TArray ts -> surround '[' ']' (commaSep showsTerm ts)+ TArrayI ts -> surround '[' ']' (underscoreSpace . commaSep showsTerm ts)+ TMap ts -> surround '{' '}' (commaSep showsMapElem ts)+ TMapI ts -> surround '{' '}' (underscoreSpace . commaSep showsMapElem ts)+ TTagged tag t -> shows (fromUInt tag) . surround '(' ')' (showsTerm t)+ TTrue -> showString "true"+ TFalse -> showString "false"+ TNull -> showString "null"+ TUndef -> showString "undefined"+ TSimple n -> showString "simple" . surround '(' ')' (shows n)+ -- convert to float to work around https://github.com/ekmett/half/issues/2+ TFloat16 f -> showFloatCompat (float2Double (Half.fromHalf f))+ TFloat32 f -> showFloatCompat (float2Double f)+ TFloat64 f -> showFloatCompat f++ surround a b x = showChar a . x . showChar b++ commaSpace = showChar ',' . showChar ' '+ underscoreSpace = showChar '_' . showChar ' '++ showsMapElem (k,v) = showsTerm k . showChar ':' . showChar ' ' . showsTerm v++ catShows :: (a -> ShowS) -> [a] -> ShowS+ catShows f xs = \s -> foldr (\x r -> f x . r) id xs s++ sepShows :: ShowS -> (a -> ShowS) -> [a] -> ShowS+ sepShows sep f xs = foldr (.) id (intersperse sep (map f xs))++ commaSep = sepShows commaSpace++ showsBytes :: [Word8] -> ShowS+ showsBytes bs = showChar 'h' . showChar '\''+ . catShows showFHex bs+ . showChar '\''++ showFHex n | n < 16 = showChar '0' . showHex n+ | otherwise = showHex n++ showFloatCompat n+ | exponent' >= -5 && exponent' <= 15 = showFFloat Nothing n+ | otherwise = showEFloat Nothing n+ where exponent' = snd (floatToDigits 10 n)+++word16FromNet :: Word8 -> Word8 -> Word16+word16FromNet w1 w0 =+ fromIntegral w1 `shiftL` (8*1)+ .|. fromIntegral w0 `shiftL` (8*0)++word16ToNet :: Word16 -> (Word8, Word8)+word16ToNet w =+ ( fromIntegral ((w `shiftR` (8*1)) .&. 0xff)+ , fromIntegral ((w `shiftR` (8*0)) .&. 0xff)+ )++word32FromNet :: Word8 -> Word8 -> Word8 -> Word8 -> Word32+word32FromNet w3 w2 w1 w0 =+ fromIntegral w3 `shiftL` (8*3)+ .|. fromIntegral w2 `shiftL` (8*2)+ .|. fromIntegral w1 `shiftL` (8*1)+ .|. fromIntegral w0 `shiftL` (8*0)++word32ToNet :: Word32 -> (Word8, Word8, Word8, Word8)+word32ToNet w =+ ( fromIntegral ((w `shiftR` (8*3)) .&. 0xff)+ , fromIntegral ((w `shiftR` (8*2)) .&. 0xff)+ , fromIntegral ((w `shiftR` (8*1)) .&. 0xff)+ , fromIntegral ((w `shiftR` (8*0)) .&. 0xff)+ )++word64FromNet :: Word8 -> Word8 -> Word8 -> Word8 ->+ Word8 -> Word8 -> Word8 -> Word8 -> Word64+word64FromNet w7 w6 w5 w4 w3 w2 w1 w0 =+ fromIntegral w7 `shiftL` (8*7)+ .|. fromIntegral w6 `shiftL` (8*6)+ .|. fromIntegral w5 `shiftL` (8*5)+ .|. fromIntegral w4 `shiftL` (8*4)+ .|. fromIntegral w3 `shiftL` (8*3)+ .|. fromIntegral w2 `shiftL` (8*2)+ .|. fromIntegral w1 `shiftL` (8*1)+ .|. fromIntegral w0 `shiftL` (8*0)++word64ToNet :: Word64 -> (Word8, Word8, Word8, Word8,+ Word8, Word8, Word8, Word8)+word64ToNet w =+ ( fromIntegral ((w `shiftR` (8*7)) .&. 0xff)+ , fromIntegral ((w `shiftR` (8*6)) .&. 0xff)+ , fromIntegral ((w `shiftR` (8*5)) .&. 0xff)+ , fromIntegral ((w `shiftR` (8*4)) .&. 0xff)+ , fromIntegral ((w `shiftR` (8*3)) .&. 0xff)+ , fromIntegral ((w `shiftR` (8*2)) .&. 0xff)+ , fromIntegral ((w `shiftR` (8*1)) .&. 0xff)+ , fromIntegral ((w `shiftR` (8*0)) .&. 0xff)+ )++prop_word16ToFromNet :: Word8 -> Word8 -> Bool+prop_word16ToFromNet w1 w0 =+ word16ToNet (word16FromNet w1 w0) == (w1, w0)++prop_word32ToFromNet :: Word8 -> Word8 -> Word8 -> Word8 -> Bool+prop_word32ToFromNet w3 w2 w1 w0 =+ word32ToNet (word32FromNet w3 w2 w1 w0) == (w3, w2, w1, w0)++prop_word64ToFromNet :: Word8 -> Word8 -> Word8 -> Word8 ->+ Word8 -> Word8 -> Word8 -> Word8 -> Bool+prop_word64ToFromNet w7 w6 w5 w4 w3 w2 w1 w0 =+ word64ToNet (word64FromNet w7 w6 w5 w4 w3 w2 w1 w0)+ == (w7, w6, w5, w4, w3, w2, w1, w0)++wordToHalf :: Word16 -> Half+wordToHalf = Half.Half . fromIntegral++wordToFloat :: Word32 -> Float+wordToFloat = toFloat++wordToDouble :: Word64 -> Double+wordToDouble = toFloat++toFloat :: (Storable word, Storable float) => word -> float+toFloat w =+ unsafeDupablePerformIO $ alloca $ \buf -> do+ poke (castPtr buf) w+ peek buf++halfToWord :: Half -> Word16+halfToWord (Half.Half w) = fromIntegral w++floatToWord :: Float -> Word32+floatToWord = fromFloat++doubleToWord :: Double -> Word64+doubleToWord = fromFloat++fromFloat :: (Storable word, Storable float) => float -> word+fromFloat float =+ unsafeDupablePerformIO $ alloca $ \buf -> do+ poke (castPtr buf) float+ peek buf++-- Note: some NaNs do not roundtrip https://github.com/ekmett/half/issues/3+-- but all the others had better+prop_halfToFromFloat :: Bool+prop_halfToFromFloat =+ all (\w -> roundTrip w || isNaN (Half.Half w)) [minBound..maxBound]+ where+ roundTrip w =+ w == (Half.getHalf . Half.toHalf . Half.fromHalf . Half.Half $ w)++instance Arbitrary Half where+ arbitrary = Half.Half . fromIntegral <$> (arbitrary :: Gen Word16)++newtype FloatSpecials n = FloatSpecials { getFloatSpecials :: n }+ deriving (Show, Eq)++instance (Arbitrary n, RealFloat n) => Arbitrary (FloatSpecials n) where+ arbitrary =+ frequency+ [ (7, FloatSpecials <$> arbitrary)+ , (1, pure (FloatSpecials (1/0)) ) -- +Infinity+ , (1, pure (FloatSpecials (0/0)) ) -- NaN+ , (1, pure (FloatSpecials (-1/0)) ) -- -Infinity+ ]++newtype LargeInteger = LargeInteger { getLargeInteger :: Integer }+ deriving (Show, Eq)++instance Arbitrary LargeInteger where+ arbitrary =+ sized $ \n ->+ oneof $ take (1 + n `div` 10)+ [ LargeInteger . fromIntegral <$> (arbitrary :: Gen Int8)+ , LargeInteger . fromIntegral <$> choose (minBound, maxBound :: Int64)+ , LargeInteger . bigger . fromIntegral <$> choose (minBound, maxBound :: Int64)+ ]+ where+ bigger n = n * abs n+++arbitraryFullRangeIntegral :: forall a. (Bounded a,+#if MIN_VERSION_base(4,7,0)+ FiniteBits a,+#else+ Bits a,+#endif+ Integral a) => Gen a+arbitraryFullRangeIntegral+ | isSigned (undefined :: a)+ = let maxBits = bitSize' (undefined :: a) - 1+ in sized $ \s ->+ let bound = fromIntegral (maxBound :: a)+ `shiftR` ((maxBits - s) `max` 0)+ in fmap fromInteger $ choose (-bound, bound)++ | otherwise+ = let maxBits = bitSize' (undefined :: a)+ in sized $ \s ->+ let bound = fromIntegral (maxBound :: a)+ `shiftR` ((maxBits - s) `max` 0)+ in fmap fromInteger $ choose (0, bound)++ where+ bitSize' =+#if MIN_VERSION_base(4,7,0)+ finiteBitSize+#else+ bitSize+#endif+
+ tests/Tests/Regress.hs view
@@ -0,0 +1,19 @@+module Tests.Regress+ ( testTree -- :: TestTree+ ) where++import Test.Tasty++import qualified Tests.Regress.Issue160 as Issue160+import qualified Tests.Regress.Issue162 as Issue162+import qualified Tests.Regress.FlatTerm as FlatTerm++--------------------------------------------------------------------------------+-- Tests and properties++testTree :: TestTree+testTree = testGroup "Regression tests"+ [ FlatTerm.testTree+ , Issue160.testTree+ , Issue162.testTree+ ]
+ tests/Tests/Regress/FlatTerm.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE CPP #-}+module Tests.Regress.FlatTerm+ ( testTree -- :: TestTree+ ) where++import Data.Int+#if !MIN_VERSION_base(4,8,0)+import Data.Word+#endif++import Test.Tasty+import Test.Tasty.HUnit++import Codec.CBOR.Encoding+import Codec.CBOR.Decoding+import Codec.CBOR.FlatTerm++--------------------------------------------------------------------------------+-- Tests and properties++-- | Test an edge case in the FlatTerm implementation: when encoding a word+-- larger than @'maxBound' :: 'Int'@, we store it as an @'Integer'@, and+-- need to remember to handle this case when we decode.+largeWordTest :: Either String Word+largeWordTest = fromFlatTerm decodeWord $ toFlatTerm (encodeWord largeWord)++largeWord :: Word+largeWord = fromIntegral (maxBound :: Int) + 1++-- | Test an edge case in the FlatTerm implementation: when encoding an+-- Int64 that is less than @'minBound' :: 'Int'@, make sure we use an+-- @'Integer'@ to store the result, because sticking it into an @'Int'@+-- will result in overflow otherwise.+smallInt64Test :: Either String Int64+smallInt64Test = fromFlatTerm decodeInt64 $ toFlatTerm (encodeInt64 smallInt64)++smallInt64 :: Int64+smallInt64 = fromIntegral (minBound :: Int) - 1++--------------------------------------------------------------------------------+-- TestTree API++testTree :: TestTree+testTree = testGroup "FlatTerm regressions"+ [ testCase "Decoding of large-ish words" (Right largeWord @=? largeWordTest)+ , testCase "Encoding of Int64s on 32bit" (Right smallInt64 @=? smallInt64Test)+ ]
+ tests/Tests/Regress/Issue160.hs view
@@ -0,0 +1,47 @@+module Tests.Regress.Issue160 ( testTree ) where++import Codec.CBOR.Decoding+import Codec.CBOR.Read+import Control.DeepSeq+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import Data.Text (Text)+import Test.Tasty+import Test.Tasty.HUnit++testTree :: TestTree+testTree = testGroup "Issue 160 - decoder checks"+ [ nonUtf8FailureTest "fast path" (BSL.fromStrict $ BS.pack [0x61, 128])+ , nonUtf8FailureTest "slow path" (BSL.fromChunks $ map BS.singleton [0x61, 128])+ , testCase "decodeListLen doesn't produce negative lengths using a Word64" $ do+ let bs = BSL.fromStrict $+ BS.pack [0x9b, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff]+ case deserialiseFromBytes decodeListLen bs of+ Left err -> deepseq err $ pure ()+ Right (rest, t) -> deepseq rest $ assertBool "Length is not negative" (t >= 0)+ , testCase "decodeMapLen doesn't produce negative lengths using a Word64" $ do+ let bs = BSL.fromStrict $+ BS.pack [0xbb, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff]+ case deserialiseFromBytes decodeMapLen bs of+ Left err -> deepseq err $ pure ()+ Right (rest, t) -> deepseq rest $ assertBool "Length is not negative" (t >= 0)+ , testCase "decodeBytes doesn't create bytestrings that cause segfaults or worse" $ do+ let bs = BSL.fromStrict $ BS.pack $+ [0x5b, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff] +++ replicate 100 0x00+ case deserialiseFromBytes decodeBytes bs of+ Left err -> deepseq err $ pure ()+ Right (rest, t) -> deepseq rest $+ assertBool "Length is not negative" (BS.length t >= 0)+ ]+ where+ nonUtf8FailureTest pathType bs =+ let title = mconcat+ ["decodeString fails on non-utf8 bytes instead of crashing ("+ , pathType+ , ")"+ ]+ in testCase title $ do+ case deserialiseFromBytes decodeString bs of+ Left err -> deepseq err $ pure ()+ Right (rest, t) -> deepseq (rest, t :: Text) $ pure ()
+ tests/Tests/Regress/Issue162.hs view
@@ -0,0 +1,94 @@+module Tests.Regress.Issue162 ( testTree ) where++import Control.Monad (void)+import Data.Word+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as LBS+import Codec.CBOR.Decoding+import Codec.CBOR.Read+import Test.Tasty+import Test.Tasty.HUnit++-- This example demonstrates a bug in cborg canonical decoding.+-- The bytes used here were drawn from a real application.++-- Decodes bigBytes x assuming x is a canonical integer encoding.+bigBytesDecoder :: Decoder s ()+bigBytesDecoder = ()+ <$ decodeListLenCanonical+ <* decodeMapLenCanonical+ <* decodeListLenCanonical+ <* decodeListLenCanonical+ <* decodeWord16Canonical+ <* decodeWord16Canonical+ <* decodeWord8Canonical+ <* decodeMapLenCanonical+ <* decodeMapLenCanonical+ <* decodeMapLenCanonical+ <* decodeListLenCanonical+ <* decodeWord8Canonical+ <* decodeListLenCanonical+ <* decodeListLenCanonical+ <* decodeMapLenCanonical+ <* decodeWord8Canonical+ <* decodeListLenCanonical+ <* decodeIntegerCanonical+ <* decodeWord32Canonical+ <* decodeWord8Canonical+ <* decodeListLenCanonical+ <* decodeIntegerCanonical+ <* decodeWord32Canonical++-- Encoding of 592033 :: BigInteger+-- 0xc2 means bignum, 0x43 means a 3-byte sequence+bigBytes :: [Word8] -> ByteString+bigBytes someEncodedInteger = LBS.pack $+ [ -- list of length 7+ 0x87+ -- empty map+ , 0xa0+ -- Just+ , 0x81+ -- list of length 3, all items are 0+ , 0x83+ , 0x00, 0x00, 0x00+ -- empty maps+ , 0xa0+ , 0xa0+ , 0xa0+ -- singleton list (encoded Just)+ , 0x81+ , 0x00+ , 0x80+ -- singleton list (encoded Just)+ , 0x81+ , 0xa2+ -- key 0+ , 0x00+ -- value 0: a pair of numbers.+ , 0x82+ , 0x1a, 0x00, 0x04, 0xec, 0xf9+ , 0x1a, 0x1a, 0xeb, 0x97, 0x7a+ -- key 1+ , 0x01+ -- value 1: a pair of numbers.+ , 0x82 + ] ++ someEncodedInteger +++ [ 0x1a, 0x05, 0xee, 0x4d, 0x20+ ]++nonCanonicalInteger :: [Word8]+nonCanonicalInteger = [0xc2, 0x43, 0x09, 0x08, 0xa1]++shouldFailSimple :: Either DeserialiseFailure (LBS.ByteString, ())+shouldFailSimple = deserialiseFromBytes (void decodeIntegerCanonical) (LBS.pack nonCanonicalInteger)++shouldFailComposite :: Either DeserialiseFailure (LBS.ByteString, ())+shouldFailComposite = deserialiseFromBytes bigBytesDecoder (bigBytes nonCanonicalInteger)++testTree :: TestTree+testTree =+ testGroup "Issue 162 - canonical decoding"+ [ testCase "simple" (Left (DeserialiseFailure 0 "non-canonical integer") @=? shouldFailSimple)+ , testCase "composite" (Left (DeserialiseFailure 34 "non-canonical integer") @=? shouldFailComposite)+ ]
+ tests/Tests/UTF8.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE CPP #-}+module Tests.UTF8+ ( testTree -- :: TestTree+ ) where++import Control.DeepSeq+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL++#if ! MIN_VERSION_base(4,11,0)+import Data.Monoid+#endif++import qualified Data.Text.Encoding as T++import Codec.CBOR.Decoding+import Codec.CBOR.Read+import Tests.Util++import Test.Tasty+import Test.Tasty.QuickCheck++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif++-- | Wrapper for ByteString with Arbitrary instance that might produce a valid+-- UTF-8 encoding of a string.+newtype MaybeText = MaybeText BS.ByteString+ deriving Show+instance Arbitrary MaybeText where+ arbitrary = MaybeText . BS.pack <$> arbitrary++-- | Test that decoding of both valid and invalid CBOR strings produces output+-- without exceptions hidden within.+utf8DecodingTest :: MaybeText -> Property+utf8DecodingTest (MaybeText bs) = case T.decodeUtf8' bs of+ Right _ -> collect "valid utf8" $ (and splitsOk)+ Left _ -> collect "invalid utf8" $ not (or splitsOk)+ where+ -- We test 2-splits to check all decoder paths.+ splitsOk = [ok $ deserialiseFromBytes decodeString v | v <- splits2 s]+ where+ ok (Right v) = deepseq v True+ ok (Left v) = deepseq v False++ s = mkLengthPrefix True (Length . fromIntegral $ BS.length bs)+ <> BSL.fromStrict bs++----------------------------------------++testTree :: TestTree+testTree = localOption (QuickCheckTests 1000) . testGroup "UTF8" $+ [testProperty+ "Decoding of UTF8 encoded Text works and properly handles decoding failures" utf8DecodingTest+ ]
+ tests/Tests/Util.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Tests.Util+ ( splits2+ , splits3+ , arbitraryWithBounds+ , Length(..)+ , mkLengthPrefix+ ) where++import Data.Bits+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import Data.Word++import Test.Tasty.QuickCheck++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif++-- | Generate all 2-splits of a serialised CBOR value.+splits2 :: BSL.ByteString -> [BSL.ByteString]+splits2 bs = zipWith (\a b -> BSL.fromChunks [a,b]) (BS.inits sbs) (BS.tails sbs)+ where+ sbs = BSL.toStrict bs++-- | Generate all 3-splits of a serialised CBOR value.+splits3 :: BSL.ByteString -> [BSL.ByteString]+splits3 bs =+ [ BSL.fromChunks [a,b,c]+ | (a,x) <- zip (BS.inits sbs) (BS.tails sbs)+ , (b,c) <- zip (BS.inits x) (BS.tails x) ]+ where+ sbs = BSL.toStrict bs++----------------------------------------++-- | Generate values of type 'a' embedded within (usually larger) type 'r' with+-- upped probabilities of getting neighbourhood of bounds of 'a'.+arbitraryWithBounds+ :: forall a r. (Bounded a, Integral a, Num r, Arbitrary r)+ => a -> Gen r+arbitraryWithBounds _ = frequency+ [ (70, arbitrary)+ -- Boundaries+ , (5, pure $ fromIntegral (minBound :: a))+ , (5, pure $ fromIntegral (maxBound :: a))+ -- Near boundaries, in range+ , (5, pure $ fromIntegral (minBound + 1 :: a))+ , (5, pure $ fromIntegral (maxBound - 1 :: a))+ -- Near boundaries, out of range (assuming there is no overflow). It overflows+ -- if a ~ r, but it's fine as then we just get a value within range.+ , (5, pure $ fromIntegral (minBound :: a) - 1)+ , (5, pure $ fromIntegral (maxBound :: a) + 1)+ ]++----------------------------------------++-- | Wrapper for list/map length.+newtype Length = Length { unLength :: Word }++instance Show Length where+ showsPrec p = showsPrec p . unLength++instance Arbitrary Length where+ arbitrary = Length <$> arbitraryWithBounds (undefined::Int)++-- | Generate CBOR prefix of non-empty string/bytes containing its length.+mkLengthPrefix :: Bool -> Length -> BSL.ByteString+mkLengthPrefix string (Length w)+ | w <= 23 = BSL.pack $ [64 + stringBit + fromIntegral w]+ | w <= 0xff = BSL.pack $ [88 + stringBit] ++ f 1 w []+ | w <= 0xffff = BSL.pack $ [89 + stringBit] ++ f 2 w []+ | w <= 0xffffffff = BSL.pack $ [90 + stringBit] ++ f 4 w []+ | otherwise = BSL.pack $ [91 + stringBit] ++ f 8 w []+ where+ stringBit :: Word8+ stringBit = if string then 32 else 0++ f :: Int -> Word -> [Word8] -> [Word8]+ f 0 _ acc = acc+ f k n acc = f (k - 1) (n `shiftR` 8) (fromIntegral n : acc)
+ tests/test-vectors/README.md view
@@ -0,0 +1,27 @@+test-vectors+============++This repo collects some simple test vectors in machine-processable form.++appendix_a.json+---------------++All examples in Appendix A of RFC 7049, encoded as a JSON array.++Each element of the test vector is a map (JSON object) with the keys:++- cbor: a base-64 encoded CBOR data item+- hex: the same CBOR data item in hex encoding+- roundtrip: a boolean that indicates whether a generic CBOR encoder+ would _typically_ produce identical CBOR on re-encoding the decoded+ data item (your mileage may vary)+- decoded: the decoded data item if it can be represented in JSON+- diagnostic: the representation of the data item in CBOR diagnostic notation, otherwise++To make use of the cases that need diagnostic notation, a diagnostic+notation printer is usually all that is needed: decode the CBOR, print+the decoded data item in diagnostic notation, and compare.++(Note that the diagnostic notation uses full decoration for the+indefinite length byte string, while the decoded indefinite length+text string represented in JSON necessarily doesn't.)
+ tests/test-vectors/appendix_a.json view
@@ -0,0 +1,624 @@+[+ {+ "cbor": "AA==",+ "hex": "00",+ "roundtrip": true,+ "decoded": 0+ },+ {+ "cbor": "AQ==",+ "hex": "01",+ "roundtrip": true,+ "decoded": 1+ },+ {+ "cbor": "Cg==",+ "hex": "0a",+ "roundtrip": true,+ "decoded": 10+ },+ {+ "cbor": "Fw==",+ "hex": "17",+ "roundtrip": true,+ "decoded": 23+ },+ {+ "cbor": "GBg=",+ "hex": "1818",+ "roundtrip": true,+ "decoded": 24+ },+ {+ "cbor": "GBk=",+ "hex": "1819",+ "roundtrip": true,+ "decoded": 25+ },+ {+ "cbor": "GGQ=",+ "hex": "1864",+ "roundtrip": true,+ "decoded": 100+ },+ {+ "cbor": "GQPo",+ "hex": "1903e8",+ "roundtrip": true,+ "decoded": 1000+ },+ {+ "cbor": "GgAPQkA=",+ "hex": "1a000f4240",+ "roundtrip": true,+ "decoded": 1000000+ },+ {+ "cbor": "GwAAAOjUpRAA",+ "hex": "1b000000e8d4a51000",+ "roundtrip": true,+ "decoded": 1000000000000+ },+ {+ "cbor": "G///////////",+ "hex": "1bffffffffffffffff",+ "roundtrip": true,+ "decoded": 18446744073709551615+ },+ {+ "cbor": "wkkBAAAAAAAAAAA=",+ "hex": "c249010000000000000000",+ "roundtrip": true,+ "decoded": 18446744073709551616+ },+ {+ "cbor": "O///////////",+ "hex": "3bffffffffffffffff",+ "roundtrip": true,+ "decoded": -18446744073709551616+ },+ {+ "cbor": "w0kBAAAAAAAAAAA=",+ "hex": "c349010000000000000000",+ "roundtrip": true,+ "decoded": -18446744073709551617+ },+ {+ "cbor": "IA==",+ "hex": "20",+ "roundtrip": true,+ "decoded": -1+ },+ {+ "cbor": "KQ==",+ "hex": "29",+ "roundtrip": true,+ "decoded": -10+ },+ {+ "cbor": "OGM=",+ "hex": "3863",+ "roundtrip": true,+ "decoded": -100+ },+ {+ "cbor": "OQPn",+ "hex": "3903e7",+ "roundtrip": true,+ "decoded": -1000+ },+ {+ "cbor": "+QAA",+ "hex": "f90000",+ "roundtrip": true,+ "decoded": 0.0+ },+ {+ "cbor": "+YAA",+ "hex": "f98000",+ "roundtrip": true,+ "decoded": -0.0+ },+ {+ "cbor": "+TwA",+ "hex": "f93c00",+ "roundtrip": true,+ "decoded": 1.0+ },+ {+ "cbor": "+z/xmZmZmZma",+ "hex": "fb3ff199999999999a",+ "roundtrip": true,+ "decoded": 1.1+ },+ {+ "cbor": "+T4A",+ "hex": "f93e00",+ "roundtrip": true,+ "decoded": 1.5+ },+ {+ "cbor": "+Xv/",+ "hex": "f97bff",+ "roundtrip": true,+ "decoded": 65504.0+ },+ {+ "cbor": "+kfDUAA=",+ "hex": "fa47c35000",+ "roundtrip": true,+ "decoded": 100000.0+ },+ {+ "cbor": "+n9///8=",+ "hex": "fa7f7fffff",+ "roundtrip": true,+ "decoded": 3.4028234663852886e+38+ },+ {+ "cbor": "+3435DyIAHWc",+ "hex": "fb7e37e43c8800759c",+ "roundtrip": true,+ "decoded": 1.0e+300+ },+ {+ "cbor": "+QAB",+ "hex": "f90001",+ "roundtrip": true,+ "decoded": 5.960464477539063e-08+ },+ {+ "cbor": "+QQA",+ "hex": "f90400",+ "roundtrip": true,+ "decoded": 6.103515625e-05+ },+ {+ "cbor": "+cQA",+ "hex": "f9c400",+ "roundtrip": true,+ "decoded": -4.0+ },+ {+ "cbor": "+8AQZmZmZmZm",+ "hex": "fbc010666666666666",+ "roundtrip": true,+ "decoded": -4.1+ },+ {+ "cbor": "+XwA",+ "hex": "f97c00",+ "roundtrip": true,+ "diagnostic": "Infinity"+ },+ {+ "cbor": "+X4A",+ "hex": "f97e00",+ "roundtrip": true,+ "diagnostic": "NaN"+ },+ {+ "cbor": "+fwA",+ "hex": "f9fc00",+ "roundtrip": true,+ "diagnostic": "-Infinity"+ },+ {+ "cbor": "+n+AAAA=",+ "hex": "fa7f800000",+ "roundtrip": false,+ "diagnostic": "Infinity"+ },+ {+ "cbor": "+v+AAAA=",+ "hex": "faff800000",+ "roundtrip": false,+ "diagnostic": "-Infinity"+ },+ {+ "cbor": "+3/wAAAAAAAA",+ "hex": "fb7ff0000000000000",+ "roundtrip": false,+ "diagnostic": "Infinity"+ },+ {+ "cbor": "+//wAAAAAAAA",+ "hex": "fbfff0000000000000",+ "roundtrip": false,+ "diagnostic": "-Infinity"+ },+ {+ "cbor": "9A==",+ "hex": "f4",+ "roundtrip": true,+ "decoded": false+ },+ {+ "cbor": "9Q==",+ "hex": "f5",+ "roundtrip": true,+ "decoded": true+ },+ {+ "cbor": "9g==",+ "hex": "f6",+ "roundtrip": true,+ "decoded": null+ },+ {+ "cbor": "9w==",+ "hex": "f7",+ "roundtrip": true,+ "diagnostic": "undefined"+ },+ {+ "cbor": "8A==",+ "hex": "f0",+ "roundtrip": true,+ "diagnostic": "simple(16)"+ },+ {+ "cbor": "+Bg=",+ "hex": "f818",+ "roundtrip": true,+ "diagnostic": "simple(24)"+ },+ {+ "cbor": "+P8=",+ "hex": "f8ff",+ "roundtrip": true,+ "diagnostic": "simple(255)"+ },+ {+ "cbor": "wHQyMDEzLTAzLTIxVDIwOjA0OjAwWg==",+ "hex": "c074323031332d30332d32315432303a30343a30305a",+ "roundtrip": true,+ "diagnostic": "0(\"2013-03-21T20:04:00Z\")"+ },+ {+ "cbor": "wRpRS2ew",+ "hex": "c11a514b67b0",+ "roundtrip": true,+ "diagnostic": "1(1363896240)"+ },+ {+ "cbor": "wftB1FLZ7CAAAA==",+ "hex": "c1fb41d452d9ec200000",+ "roundtrip": true,+ "diagnostic": "1(1363896240.5)"+ },+ {+ "cbor": "10QBAgME",+ "hex": "d74401020304",+ "roundtrip": true,+ "diagnostic": "23(h'01020304')"+ },+ {+ "cbor": "2BhFZElFVEY=",+ "hex": "d818456449455446",+ "roundtrip": true,+ "diagnostic": "24(h'6449455446')"+ },+ {+ "cbor": "2CB2aHR0cDovL3d3dy5leGFtcGxlLmNvbQ==",+ "hex": "d82076687474703a2f2f7777772e6578616d706c652e636f6d",+ "roundtrip": true,+ "diagnostic": "32(\"http://www.example.com\")"+ },+ {+ "cbor": "QA==",+ "hex": "40",+ "roundtrip": true,+ "diagnostic": "h''"+ },+ {+ "cbor": "RAECAwQ=",+ "hex": "4401020304",+ "roundtrip": true,+ "diagnostic": "h'01020304'"+ },+ {+ "cbor": "YA==",+ "hex": "60",+ "roundtrip": true,+ "decoded": ""+ },+ {+ "cbor": "YWE=",+ "hex": "6161",+ "roundtrip": true,+ "decoded": "a"+ },+ {+ "cbor": "ZElFVEY=",+ "hex": "6449455446",+ "roundtrip": true,+ "decoded": "IETF"+ },+ {+ "cbor": "YiJc",+ "hex": "62225c",+ "roundtrip": true,+ "decoded": "\"\\"+ },+ {+ "cbor": "YsO8",+ "hex": "62c3bc",+ "roundtrip": true,+ "decoded": "ü"+ },+ {+ "cbor": "Y+awtA==",+ "hex": "63e6b0b4",+ "roundtrip": true,+ "decoded": "水"+ },+ {+ "cbor": "ZPCQhZE=",+ "hex": "64f0908591",+ "roundtrip": true,+ "decoded": "𐅑"+ },+ {+ "cbor": "gA==",+ "hex": "80",+ "roundtrip": true,+ "decoded": [++ ]+ },+ {+ "cbor": "gwECAw==",+ "hex": "83010203",+ "roundtrip": true,+ "decoded": [+ 1,+ 2,+ 3+ ]+ },+ {+ "cbor": "gwGCAgOCBAU=",+ "hex": "8301820203820405",+ "roundtrip": true,+ "decoded": [+ 1,+ [+ 2,+ 3+ ],+ [+ 4,+ 5+ ]+ ]+ },+ {+ "cbor": "mBkBAgMEBQYHCAkKCwwNDg8QERITFBUWFxgYGBk=",+ "hex": "98190102030405060708090a0b0c0d0e0f101112131415161718181819",+ "roundtrip": true,+ "decoded": [+ 1,+ 2,+ 3,+ 4,+ 5,+ 6,+ 7,+ 8,+ 9,+ 10,+ 11,+ 12,+ 13,+ 14,+ 15,+ 16,+ 17,+ 18,+ 19,+ 20,+ 21,+ 22,+ 23,+ 24,+ 25+ ]+ },+ {+ "cbor": "oA==",+ "hex": "a0",+ "roundtrip": true,+ "decoded": {+ }+ },+ {+ "cbor": "ogECAwQ=",+ "hex": "a201020304",+ "roundtrip": true,+ "diagnostic": "{1: 2, 3: 4}"+ },+ {+ "cbor": "omFhAWFiggID",+ "hex": "a26161016162820203",+ "roundtrip": true,+ "decoded": {+ "a": 1,+ "b": [+ 2,+ 3+ ]+ }+ },+ {+ "cbor": "gmFhoWFiYWM=",+ "hex": "826161a161626163",+ "roundtrip": true,+ "decoded": [+ "a",+ {+ "b": "c"+ }+ ]+ },+ {+ "cbor": "pWFhYUFhYmFCYWNhQ2FkYURhZWFF",+ "hex": "a56161614161626142616361436164614461656145",+ "roundtrip": true,+ "decoded": {+ "a": "A",+ "b": "B",+ "c": "C",+ "d": "D",+ "e": "E"+ }+ },+ {+ "cbor": "X0IBAkMDBAX/",+ "hex": "5f42010243030405ff",+ "roundtrip": false,+ "diagnostic": "(_ h'0102', h'030405')"+ },+ {+ "cbor": "f2VzdHJlYWRtaW5n/w==",+ "hex": "7f657374726561646d696e67ff",+ "roundtrip": false,+ "decoded": "streaming"+ },+ {+ "cbor": "n/8=",+ "hex": "9fff",+ "roundtrip": false,+ "decoded": [++ ]+ },+ {+ "cbor": "nwGCAgOfBAX//w==",+ "hex": "9f018202039f0405ffff",+ "roundtrip": false,+ "decoded": [+ 1,+ [+ 2,+ 3+ ],+ [+ 4,+ 5+ ]+ ]+ },+ {+ "cbor": "nwGCAgOCBAX/",+ "hex": "9f01820203820405ff",+ "roundtrip": false,+ "decoded": [+ 1,+ [+ 2,+ 3+ ],+ [+ 4,+ 5+ ]+ ]+ },+ {+ "cbor": "gwGCAgOfBAX/",+ "hex": "83018202039f0405ff",+ "roundtrip": false,+ "decoded": [+ 1,+ [+ 2,+ 3+ ],+ [+ 4,+ 5+ ]+ ]+ },+ {+ "cbor": "gwGfAgP/ggQF",+ "hex": "83019f0203ff820405",+ "roundtrip": false,+ "decoded": [+ 1,+ [+ 2,+ 3+ ],+ [+ 4,+ 5+ ]+ ]+ },+ {+ "cbor": "nwECAwQFBgcICQoLDA0ODxAREhMUFRYXGBgYGf8=",+ "hex": "9f0102030405060708090a0b0c0d0e0f101112131415161718181819ff",+ "roundtrip": false,+ "decoded": [+ 1,+ 2,+ 3,+ 4,+ 5,+ 6,+ 7,+ 8,+ 9,+ 10,+ 11,+ 12,+ 13,+ 14,+ 15,+ 16,+ 17,+ 18,+ 19,+ 20,+ 21,+ 22,+ 23,+ 24,+ 25+ ]+ },+ {+ "cbor": "v2FhAWFinwID//8=",+ "hex": "bf61610161629f0203ffff",+ "roundtrip": false,+ "decoded": {+ "a": 1,+ "b": [+ 2,+ 3+ ]+ }+ },+ {+ "cbor": "gmFhv2FiYWP/",+ "hex": "826161bf61626163ff",+ "roundtrip": false,+ "decoded": [+ "a",+ {+ "b": "c"+ }+ ]+ },+ {+ "cbor": "v2NGdW71Y0FtdCH/",+ "hex": "bf6346756ef563416d7421ff",+ "roundtrip": false,+ "decoded": {+ "Fun": true,+ "Amt": -2+ }+ }+]