diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -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. + diff --git a/cborg.cabal b/cborg.cabal --- a/cborg.cabal +++ b/cborg.cabal @@ -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 + diff --git a/src/Codec/CBOR/ByteArray/Internal.hs b/src/Codec/CBOR/ByteArray/Internal.hs --- a/src/Codec/CBOR/ByteArray/Internal.hs +++ b/src/Codec/CBOR/ByteArray/Internal.hs @@ -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 diff --git a/src/Codec/CBOR/Decoding.hs b/src/Codec/CBOR/Decoding.hs --- a/src/Codec/CBOR/Decoding.hs +++ b/src/Codec/CBOR/Decoding.hs @@ -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 +-- +-- +-- +-- 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. -- diff --git a/src/Codec/CBOR/FlatTerm.hs b/src/Codec/CBOR/FlatTerm.hs --- a/src/Codec/CBOR/FlatTerm.hs +++ b/src/Codec/CBOR/FlatTerm.hs @@ -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 diff --git a/src/Codec/CBOR/Magic.hs b/src/Codec/CBOR/Magic.hs --- a/src/Codec/CBOR/Magic.hs +++ b/src/Codec/CBOR/Magic.hs @@ -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 diff --git a/src/Codec/CBOR/Read.hs b/src/Codec/CBOR/Read.hs --- a/src/Codec/CBOR/Read.hs +++ b/src/Codec/CBOR/Read.hs @@ -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 diff --git a/src/Codec/CBOR/Write.hs b/src/Codec/CBOR/Write.hs --- a/src/Codec/CBOR/Write.hs +++ b/src/Codec/CBOR/Write.hs @@ -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 diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -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 + ] diff --git a/tests/Tests/Boundary.hs b/tests/Tests/Boundary.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Boundary.hs @@ -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 + ] diff --git a/tests/Tests/CBOR.hs b/tests/Tests/CBOR.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/CBOR.hs @@ -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 + ] + ] diff --git a/tests/Tests/Reference.hs b/tests/Tests/Reference.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Reference.hs @@ -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 + ] + ] diff --git a/tests/Tests/Reference/Implementation.hs b/tests/Tests/Reference/Implementation.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Reference/Implementation.hs @@ -0,0 +1,1074 @@ +{-# LANGUAGE CPP, BangPatterns, MagicHash, UnboxedTuples, RankNTypes, ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +----------------------------------------------------------------------------- +-- | +-- Module : Codec.CBOR +-- Copyright : 2013 Simon Meier , +-- 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 + diff --git a/tests/Tests/Regress.hs b/tests/Tests/Regress.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Regress.hs @@ -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 + ] diff --git a/tests/Tests/Regress/FlatTerm.hs b/tests/Tests/Regress/FlatTerm.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Regress/FlatTerm.hs @@ -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) + ] diff --git a/tests/Tests/Regress/Issue160.hs b/tests/Tests/Regress/Issue160.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Regress/Issue160.hs @@ -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 () diff --git a/tests/Tests/Regress/Issue162.hs b/tests/Tests/Regress/Issue162.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Regress/Issue162.hs @@ -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) + ] diff --git a/tests/Tests/UTF8.hs b/tests/Tests/UTF8.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/UTF8.hs @@ -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 + ] diff --git a/tests/Tests/Util.hs b/tests/Tests/Util.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Util.hs @@ -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) diff --git a/tests/test-vectors/README.md b/tests/test-vectors/README.md new file mode 100644 --- /dev/null +++ b/tests/test-vectors/README.md @@ -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.) diff --git a/tests/test-vectors/appendix_a.json b/tests/test-vectors/appendix_a.json new file mode 100644 --- /dev/null +++ b/tests/test-vectors/appendix_a.json @@ -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 + } + } +]