diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,42 @@ # Revision history for cborg +## 0.2.2.0 -- 2019-07-31 + +* Add peekByteOffset for the current ByteOffset in the input byte sequence. + By keeping track of the byte offsets before and after decoding asubterm + (a pattern captured by decodeWithByteSpan) and if the overall input data + is retained then this is enables later retrieving the span of bytes for + the subterm. + +* Add encodePreEncoded function. This allows pre-encoded CBOR data to be + included into an Encoding. This is useful in cases where one has known-valid + encoded CBOR data, e.g. on disk, that you want to include into a larger CBOR + data stream. This makes it possible in such cases to avoid decoding and + re-encoding. + +* Improved test suite property coverage. We now have property coverering most + parts of a commuting diagram, which gives more confidence about what are + the right properties to test and what is enough. + +* Improved test coverage for decoding non-canonical terms + +* Fix a bug in the checks in the canonical decoding of float16 NaNs. There + are multiple bit representations of NaNs and while we were checking this + correctly for float32 and float64 we were not checking this correctly for + the float16 encoding. + +* Improved test coverage for special float values. We now have pretty + comprehensive coverage of round-tripping properties for special float + values, +/- infinity and non-canonical NaNs. + +* Improved the structure of the test suite + +* Use new GHC primitives castWord{32ToFloat,64ToDouble} rather than home grown + +* Support GHC built with integer-simple + +* Support GHC 8.8 + ## 0.2.1.0 -- 2018-10-11 * Bounds bumps and GHC 8.6 compatibility diff --git a/cborg.cabal b/cborg.cabal --- a/cborg.cabal +++ b/cborg.cabal @@ -1,34 +1,39 @@ name: cborg -version: 0.2.1.0 -synopsis: Concise Binary Object Representation +version: 0.2.2.0 +synopsis: Concise Binary Object Representation (CBOR) license: BSD3 license-file: LICENSE.txt author: Duncan Coutts maintainer: duncan@community.haskell.org, ben@smart-cactus.org bug-reports: https://github.com/well-typed/cborg/issues -copyright: 2015-2017 Duncan Coutts, - 2015-2017 Well-Typed LLP, +copyright: 2015-2019 Duncan Coutts, + 2015-2019 Well-Typed LLP, 2015 IRIS Connect Ltd category: Codec build-type: Simple cabal-version: >= 1.10 -tested-with: GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1 +tested-with: + GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC==8.8.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 - specified by [RFC 7049](https://tools.ietf.org/html/rfc7049). + This package provides an efficient implementation of the Concise + Binary Object Representation (CBOR), as specified by + [RFC 7049](https://tools.ietf.org/html/rfc7049). . If you are looking for a library for serialisation of Haskell values, have a look at the [serialise](/package/serialise) package, which is built upon this library. . - An implementation of the standard bijection between CBOR and JSON is provided - by the [cborg-json](/package/cborg-json) package. Also see [cbor-tool](/package/cbor-tool) - for a convenient command-line utility for working with CBOR data. + An implementation of the standard bijection between CBOR and JSON is + provided by the [cborg-json](/package/cborg-json) package. Also see + [cbor-tool](/package/cbor-tool) for a convenient command-line utility + for working with CBOR data. + . + This package was formerly known as @binary-serialise-cbor@. + extra-source-files: src/cbits/cbor.h tests/test-vectors/appendix_a.json @@ -78,13 +83,13 @@ build-depends: array >= 0.4 && < 0.6, - base >= 4.6 && < 5.0, + base >= 4.7 && < 5.0, bytestring >= 0.10.4 && < 0.11, 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, + primitive >= 0.5 && < 0.8, text >= 1.1 && < 1.3 if flag(optimize-gmp) @@ -96,7 +101,7 @@ ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances else -- provide/emulate `Control.Monad.Fail` and `Data.Semigroups` API for pre-GHC8 - build-depends: fail == 4.9.*, semigroups == 0.18.* + build-depends: fail == 4.9.*, semigroups >=0.18 && <0.20 test-suite tests type: exitcode-stdio-1.0 @@ -109,20 +114,28 @@ -threaded -rtsopts "-with-rtsopts=-N2" other-modules: - Tests.CBOR + Tests.UnitTests + Tests.Properties Tests.Boundary + Tests.ByteOffset + Tests.Canonical + Tests.PreEncoded Tests.Regress Tests.Regress.Issue160 Tests.Regress.Issue162 Tests.Regress.FlatTerm Tests.Reference Tests.Reference.Implementation + Tests.Reference.Generators + Tests.Reference.TestVectors + Tests.Term Tests.UTF8 Tests.Util build-depends: array >= 0.4 && < 0.6, - base >= 4.6 && < 5.0, + base >= 4.7 && < 5.0, + base-orphans, bytestring >= 0.10.4 && < 0.11, text >= 1.1 && < 1.3, cborg, @@ -132,9 +145,10 @@ deepseq >= 1.0 && < 1.5, fail >= 4.9.0.0 && < 4.10, half >= 0.2.2.3 && < 0.4, - QuickCheck >= 2.9 && < 2.13, + QuickCheck >= 2.9 && < 2.14, + random, scientific >= 0.3 && < 0.4, - tasty >= 0.11 && < 1.2, + tasty >= 0.11 && < 1.3, tasty-hunit >= 0.9 && < 0.11, tasty-quickcheck >= 0.8 && < 0.11, vector >= 0.10 && < 0.13 diff --git a/src/Codec/CBOR/ByteArray/Sliced.hs b/src/Codec/CBOR/ByteArray/Sliced.hs --- a/src/Codec/CBOR/ByteArray/Sliced.hs +++ b/src/Codec/CBOR/ByteArray/Sliced.hs @@ -35,7 +35,9 @@ import System.IO.Unsafe import qualified Data.Primitive.ByteArray as Prim +#if !MIN_VERSION_primitive(0,7,0) import Data.Primitive.Types (Addr(..)) +#endif import qualified Data.ByteString as BS import qualified Data.ByteString.Unsafe as BS import qualified Data.ByteString.Short as BSS @@ -66,7 +68,11 @@ $ BS.unsafePackCStringFinalizer ptr (sizeofSlicedByteArray sba) (touch pinned) where pinned = toPinned sba +#if MIN_VERSION_primitive(0,7,0) + !(Ptr addr#) = Prim.byteArrayContents pinned +#else !(Addr addr#) = Prim.byteArrayContents pinned +#endif ptr = Ptr addr# toPinned :: SlicedByteArray -> Prim.ByteArray 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 @@ -13,7 +13,7 @@ -- Portability : non-portable (GHC extensions) -- -- High level API for decoding values that were encoded with the --- "Codec.CBOR.Encoding" module, using a @'Monad'@ +-- "Codec.CBOR.Encoding" module, using a 'Monad' -- based interface. -- module Codec.CBOR.Decoding @@ -68,9 +68,14 @@ -- ** Inspecting the token type , peekTokenType -- :: Decoder s TokenType - , peekAvailable -- :: Decoder s Int , TokenType(..) + -- ** Special operations + , peekAvailable -- :: Decoder s Int + , ByteOffset + , peekByteOffset -- :: Decoder s ByteOffset + , decodeWithByteSpan + -- ** Canonical CBOR -- $canonical , decodeWordCanonical -- :: Decoder s Word @@ -101,12 +106,6 @@ , decodeWordCanonicalOf -- :: Word -> Decoder s () , decodeListLenCanonicalOf -- :: Int -> Decoder s () -{- - -- ** Special operations - , ignoreTerms - , decodeTrace --} - -- * Sequence operations , decodeSequenceLenIndef -- :: ... , decodeSequenceLenN -- :: ... @@ -130,8 +129,8 @@ -- | A continuation-based decoder, used for decoding values that were -- previously encoded using the "Codec.CBOR.Encoding" --- module. As @'Decoder'@ has a @'Monad'@ instance, you can easily --- write @'Decoder'@s monadically for building your deserialisation +-- module. As 'Decoder' has a 'Monad' instance, you can easily +-- write 'Decoder's monadically for building your deserialisation -- logic. -- -- @since 0.2.0.0 @@ -157,19 +156,6 @@ | ConsumeMapLen (Int# -> ST s (DecodeAction s a)) | ConsumeTag (Word# -> ST s (DecodeAction s a)) - | ConsumeWordCanonical (Word# -> ST s (DecodeAction s a)) - | ConsumeWord8Canonical (Word# -> ST s (DecodeAction s a)) - | ConsumeWord16Canonical (Word# -> ST s (DecodeAction s a)) - | ConsumeWord32Canonical (Word# -> ST s (DecodeAction s a)) - | ConsumeNegWordCanonical (Word# -> ST s (DecodeAction s a)) - | ConsumeIntCanonical (Int# -> ST s (DecodeAction s a)) - | ConsumeInt8Canonical (Int# -> ST s (DecodeAction s a)) - | ConsumeInt16Canonical (Int# -> ST s (DecodeAction s a)) - | ConsumeInt32Canonical (Int# -> ST s (DecodeAction s a)) - | ConsumeListLenCanonical (Int# -> ST s (DecodeAction s a)) - | ConsumeMapLenCanonical (Int# -> ST s (DecodeAction s a)) - | ConsumeTagCanonical (Word# -> ST s (DecodeAction s a)) - -- 64bit variants for 32bit machines #if defined(ARCH_32bit) | ConsumeWord64 (Word64# -> ST s (DecodeAction s a)) @@ -178,13 +164,6 @@ | ConsumeListLen64 (Int64# -> ST s (DecodeAction s a)) | ConsumeMapLen64 (Int64# -> ST s (DecodeAction s a)) | ConsumeTag64 (Word64# -> ST s (DecodeAction s a)) - - | ConsumeWord64Canonical (Word64# -> ST s (DecodeAction s a)) - | ConsumeNegWord64Canonical (Word64# -> ST s (DecodeAction s a)) - | ConsumeInt64Canonical (Int64# -> ST s (DecodeAction s a)) - | ConsumeListLen64Canonical (Int64# -> ST s (DecodeAction s a)) - | ConsumeMapLen64Canonical (Int64# -> ST s (DecodeAction s a)) - | ConsumeTag64Canonical (Word64# -> ST s (DecodeAction s a)) #endif | ConsumeInteger (Integer -> ST s (DecodeAction s a)) @@ -197,16 +176,6 @@ | 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)) - | 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)) | ConsumeListLenIndef (ST s (DecodeAction s a)) @@ -219,7 +188,45 @@ | PeekTokenType (TokenType -> ST s (DecodeAction s a)) | PeekAvailable (Int# -> ST s (DecodeAction s a)) +#if defined(ARCH_32bit) + | PeekByteOffset (Int64# -> ST s (DecodeAction s a)) +#else + | PeekByteOffset (Int# -> ST s (DecodeAction s a)) +#endif + -- All the canonical variants + | ConsumeWordCanonical (Word# -> ST s (DecodeAction s a)) + | ConsumeWord8Canonical (Word# -> ST s (DecodeAction s a)) + | ConsumeWord16Canonical (Word# -> ST s (DecodeAction s a)) + | ConsumeWord32Canonical (Word# -> ST s (DecodeAction s a)) + | ConsumeNegWordCanonical (Word# -> ST s (DecodeAction s a)) + | ConsumeIntCanonical (Int# -> ST s (DecodeAction s a)) + | ConsumeInt8Canonical (Int# -> ST s (DecodeAction s a)) + | ConsumeInt16Canonical (Int# -> ST s (DecodeAction s a)) + | ConsumeInt32Canonical (Int# -> ST s (DecodeAction s a)) + | ConsumeListLenCanonical (Int# -> ST s (DecodeAction s a)) + | ConsumeMapLenCanonical (Int# -> ST s (DecodeAction s a)) + | ConsumeTagCanonical (Word# -> ST s (DecodeAction s a)) + +#if defined(ARCH_32bit) + | ConsumeWord64Canonical (Word64# -> ST s (DecodeAction s a)) + | ConsumeNegWord64Canonical (Word64# -> ST s (DecodeAction s a)) + | ConsumeInt64Canonical (Int64# -> ST s (DecodeAction s a)) + | ConsumeListLen64Canonical (Int64# -> ST s (DecodeAction s a)) + | ConsumeMapLen64Canonical (Int64# -> ST s (DecodeAction s a)) + | ConsumeTag64Canonical (Word64# -> ST s (DecodeAction s a)) +#endif + + | 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)) + | Fail String | Done a @@ -282,7 +289,9 @@ {-# INLINE (>>) #-} (>>) = (*>) +#if !MIN_VERSION_base(4,13,0) fail = Fail.fail +#endif -- | @since 0.2.0.0 instance Fail.MonadFail (Decoder s) where @@ -295,7 +304,7 @@ liftST :: ST s a -> Decoder s a liftST m = Decoder $ \k -> m >>= k --- | Given a @'Decoder'@, give us the @'DecodeAction'@ +-- | Given a 'Decoder', give us the 'DecodeAction' -- -- @since 0.2.0.0 getDecodeAction :: Decoder s a -> ST s (DecodeAction s a) @@ -307,10 +316,10 @@ -- -- -- 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 +-- for example the integer @0@ can be represented in 8, 16, 32 or 64 bits. This +-- library always encoded 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 +-- important to only decode the canonical encoding. The decoder primitives here -- are to allow applications to implement canonical decoding. -- -- It is important to note that achieving a canonical representation is /not/ @@ -324,7 +333,7 @@ -- 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. +-- have to check that the elements in the list are /strictly/ increasing. -- Similar issues arise in many other data types, wherever there is redundancy -- in the external representation. -- @@ -338,35 +347,35 @@ -- Read input tokens of various types -- --- | Decode a @'Word'@. +-- | Decode a 'Word'. -- -- @since 0.2.0.0 decodeWord :: Decoder s Word decodeWord = Decoder (\k -> return (ConsumeWord (\w# -> k (W# w#)))) {-# INLINE decodeWord #-} --- | Decode a @'Word8'@. +-- | Decode a 'Word8'. -- -- @since 0.2.0.0 decodeWord8 :: Decoder s Word8 decodeWord8 = Decoder (\k -> return (ConsumeWord8 (\w# -> k (W8# w#)))) {-# INLINE decodeWord8 #-} --- | Decode a @'Word16'@. +-- | Decode a 'Word16'. -- -- @since 0.2.0.0 decodeWord16 :: Decoder s Word16 decodeWord16 = Decoder (\k -> return (ConsumeWord16 (\w# -> k (W16# w#)))) {-# INLINE decodeWord16 #-} --- | Decode a @'Word32'@. +-- | Decode a 'Word32'. -- -- @since 0.2.0.0 decodeWord32 :: Decoder s Word32 decodeWord32 = Decoder (\k -> return (ConsumeWord32 (\w# -> k (W32# w#)))) {-# INLINE decodeWord32 #-} --- | Decode a @'Word64'@. +-- | Decode a 'Word64'. -- -- @since 0.2.0.0 decodeWord64 :: Decoder s Word64 @@ -378,14 +387,14 @@ Decoder (\k -> return (ConsumeWord64 (\w64# -> k (W64# w64#)))) #endif --- | Decode a negative @'Word'@. +-- | Decode a negative 'Word'. -- -- @since 0.2.0.0 decodeNegWord :: Decoder s Word decodeNegWord = Decoder (\k -> return (ConsumeNegWord (\w# -> k (W# w#)))) {-# INLINE decodeNegWord #-} --- | Decode a negative @'Word64'@. +-- | Decode a negative 'Word64'. -- -- @since 0.2.0.0 decodeNegWord64 :: Decoder s Word64 @@ -397,35 +406,35 @@ Decoder (\k -> return (ConsumeNegWord64 (\w64# -> k (W64# w64#)))) #endif --- | Decode an @'Int'@. +-- | Decode an 'Int'. -- -- @since 0.2.0.0 decodeInt :: Decoder s Int decodeInt = Decoder (\k -> return (ConsumeInt (\n# -> k (I# n#)))) {-# INLINE decodeInt #-} --- | Decode an @'Int8'@. +-- | Decode an 'Int8'. -- -- @since 0.2.0.0 decodeInt8 :: Decoder s Int8 decodeInt8 = Decoder (\k -> return (ConsumeInt8 (\w# -> k (I8# w#)))) {-# INLINE decodeInt8 #-} --- | Decode an @'Int16'@. +-- | Decode an 'Int16'. -- -- @since 0.2.0.0 decodeInt16 :: Decoder s Int16 decodeInt16 = Decoder (\k -> return (ConsumeInt16 (\w# -> k (I16# w#)))) {-# INLINE decodeInt16 #-} --- | Decode an @'Int32'@. +-- | Decode an 'Int32'. -- -- @since 0.2.0.0 decodeInt32 :: Decoder s Int32 decodeInt32 = Decoder (\k -> return (ConsumeInt32 (\w# -> k (I32# w#)))) {-# INLINE decodeInt32 #-} --- | Decode an @'Int64'@. +-- | Decode an 'Int64'. -- -- @since 0.2.0.0 decodeInt64 :: Decoder s Int64 @@ -437,35 +446,35 @@ Decoder (\k -> return (ConsumeInt64 (\n64# -> k (I64# n64#)))) #endif --- | Decode canonical representation of a @'Word'@. +-- | Decode canonical representation of a 'Word'. -- -- @since 0.2.0.0 decodeWordCanonical :: Decoder s Word decodeWordCanonical = Decoder (\k -> return (ConsumeWordCanonical (\w# -> k (W# w#)))) {-# INLINE decodeWordCanonical #-} --- | Decode canonical representation of a @'Word8'@. +-- | Decode canonical representation of a 'Word8'. -- -- @since 0.2.0.0 decodeWord8Canonical :: Decoder s Word8 decodeWord8Canonical = Decoder (\k -> return (ConsumeWord8Canonical (\w# -> k (W8# w#)))) {-# INLINE decodeWord8Canonical #-} --- | Decode canonical representation of a @'Word16'@. +-- | Decode canonical representation of a 'Word16'. -- -- @since 0.2.0.0 decodeWord16Canonical :: Decoder s Word16 decodeWord16Canonical = Decoder (\k -> return (ConsumeWord16Canonical (\w# -> k (W16# w#)))) {-# INLINE decodeWord16Canonical #-} --- | Decode canonical representation of a @'Word32'@. +-- | Decode canonical representation of a 'Word32'. -- -- @since 0.2.0.0 decodeWord32Canonical :: Decoder s Word32 decodeWord32Canonical = Decoder (\k -> return (ConsumeWord32Canonical (\w# -> k (W32# w#)))) {-# INLINE decodeWord32Canonical #-} --- | Decode canonical representation of a @'Word64'@. +-- | Decode canonical representation of a 'Word64'. -- -- @since 0.2.0.0 decodeWord64Canonical :: Decoder s Word64 @@ -477,14 +486,14 @@ Decoder (\k -> return (ConsumeWord64Canonical (\w64# -> k (W64# w64#)))) #endif --- | Decode canonical representation of a negative @'Word'@. +-- | Decode canonical representation of a negative 'Word'. -- -- @since 0.2.0.0 decodeNegWordCanonical :: Decoder s Word decodeNegWordCanonical = Decoder (\k -> return (ConsumeNegWordCanonical (\w# -> k (W# w#)))) {-# INLINE decodeNegWordCanonical #-} --- | Decode canonical representation of a negative @'Word64'@. +-- | Decode canonical representation of a negative 'Word64'. -- -- @since 0.2.0.0 decodeNegWord64Canonical :: Decoder s Word64 @@ -496,35 +505,35 @@ Decoder (\k -> return (ConsumeNegWord64Canonical (\w64# -> k (W64# w64#)))) #endif --- | Decode canonical representation of an @'Int'@. +-- | Decode canonical representation of an 'Int'. -- -- @since 0.2.0.0 decodeIntCanonical :: Decoder s Int decodeIntCanonical = Decoder (\k -> return (ConsumeIntCanonical (\n# -> k (I# n#)))) {-# INLINE decodeIntCanonical #-} --- | Decode canonical representation of an @'Int8'@. +-- | Decode canonical representation of an 'Int8'. -- -- @since 0.2.0.0 decodeInt8Canonical :: Decoder s Int8 decodeInt8Canonical = Decoder (\k -> return (ConsumeInt8Canonical (\w# -> k (I8# w#)))) {-# INLINE decodeInt8Canonical #-} --- | Decode canonical representation of an @'Int16'@. +-- | Decode canonical representation of an 'Int16'. -- -- @since 0.2.0.0 decodeInt16Canonical :: Decoder s Int16 decodeInt16Canonical = Decoder (\k -> return (ConsumeInt16Canonical (\w# -> k (I16# w#)))) {-# INLINE decodeInt16Canonical #-} --- | Decode canonical representation of an @'Int32'@. +-- | Decode canonical representation of an 'Int32'. -- -- @since 0.2.0.0 decodeInt32Canonical :: Decoder s Int32 decodeInt32Canonical = Decoder (\k -> return (ConsumeInt32Canonical (\w# -> k (I32# w#)))) {-# INLINE decodeInt32Canonical #-} --- | Decode canonical representation of an @'Int64'@. +-- | Decode canonical representation of an 'Int64'. -- -- @since 0.2.0.0 decodeInt64Canonical :: Decoder s Int64 @@ -536,35 +545,35 @@ Decoder (\k -> return (ConsumeInt64Canonical (\n64# -> k (I64# n64#)))) #endif --- | Decode an @'Integer'@. +-- | Decode an 'Integer'. -- -- @since 0.2.0.0 decodeInteger :: Decoder s Integer decodeInteger = Decoder (\k -> return (ConsumeInteger (\n -> k n))) {-# INLINE decodeInteger #-} --- | Decode a @'Float'@. +-- | Decode a 'Float'. -- -- @since 0.2.0.0 decodeFloat :: Decoder s Float decodeFloat = Decoder (\k -> return (ConsumeFloat (\f# -> k (F# f#)))) {-# INLINE decodeFloat #-} --- | Decode a @'Double'@. +-- | Decode a 'Double'. -- -- @since 0.2.0.0 decodeDouble :: Decoder s Double decodeDouble = Decoder (\k -> return (ConsumeDouble (\f# -> k (D# f#)))) {-# INLINE decodeDouble #-} --- | Decode a string of bytes as a @'ByteString'@. +-- | Decode a string of bytes as a 'ByteString'. -- -- @since 0.2.0.0 decodeBytes :: Decoder s ByteString decodeBytes = Decoder (\k -> return (ConsumeBytes (\bs -> k bs))) {-# INLINE decodeBytes #-} --- | Decode canonical representation of a string of bytes as a @'ByteString'@. +-- | Decode canonical representation of a string of bytes as a 'ByteString'. -- -- @since 0.2.1.0 decodeBytesCanonical :: Decoder s ByteString @@ -601,14 +610,14 @@ decodeByteArrayCanonical = Decoder (\k -> return (ConsumeByteArrayCanonical k)) {-# INLINE decodeByteArrayCanonical #-} --- | Decode a textual string as a piece of @'Text'@. +-- | Decode a textual string as a piece of 'Text'. -- -- @since 0.2.0.0 decodeString :: Decoder s Text decodeString = Decoder (\k -> return (ConsumeString (\str -> k str))) {-# INLINE decodeString #-} --- | Decode canonical representation of a textual string as a piece of @'Text'@. +-- | Decode canonical representation of a textual string as a piece of 'Text'. -- -- @since 0.2.1.0 decodeStringCanonical :: Decoder s Text @@ -691,14 +700,14 @@ decodeMapLenIndef = Decoder (\k -> return (ConsumeMapLenIndef (k ()))) {-# INLINE decodeMapLenIndef #-} --- | Decode an arbitrary tag and return it as a @'Word'@. +-- | Decode an arbitrary tag and return it as a 'Word'. -- -- @since 0.2.0.0 decodeTag :: Decoder s Word decodeTag = Decoder (\k -> return (ConsumeTag (\w# -> k (W# w#)))) {-# INLINE decodeTag #-} --- | Decode an arbitrary 64-bit tag and return it as a @'Word64'@. +-- | Decode an arbitrary 64-bit tag and return it as a 'Word64'. -- -- @since 0.2.0.0 decodeTag64 :: Decoder s Word64 @@ -711,7 +720,7 @@ #endif -- | Decode canonical representation of an arbitrary tag and return it as a --- @'Word'@. +-- 'Word'. -- -- @since 0.2.0.0 decodeTagCanonical :: Decoder s Word @@ -719,7 +728,7 @@ {-# INLINE decodeTagCanonical #-} -- | Decode canonical representation of an arbitrary 64-bit tag and return it as --- a @'Word64'@. +-- a 'Word64'. -- -- @since 0.2.0.0 decodeTag64Canonical :: Decoder s Word64 @@ -745,7 +754,7 @@ decodeNull = Decoder (\k -> return (ConsumeNull (k ()))) {-# INLINE decodeNull #-} --- | Decode a 'simple' CBOR value and give back a @'Word8'@. You +-- | Decode a 'simple' CBOR value and give back a 'Word8'. You -- probably don't ever need to use this. -- -- @since 0.2.0.0 @@ -753,28 +762,28 @@ decodeSimple = Decoder (\k -> return (ConsumeSimple (\w# -> k (W8# w#)))) {-# INLINE decodeSimple #-} --- | Decode canonical representation of an @'Integer'@. +-- | Decode canonical representation of an 'Integer'. -- -- @since 0.2.0.0 decodeIntegerCanonical :: Decoder s Integer decodeIntegerCanonical = Decoder (\k -> return (ConsumeIntegerCanonical (\n -> k n))) {-# INLINE decodeIntegerCanonical #-} --- | Decode canonical representation of a half-precision @'Float'@. +-- | Decode canonical representation of a half-precision 'Float'. -- -- @since 0.2.0.0 decodeFloat16Canonical :: Decoder s Float decodeFloat16Canonical = Decoder (\k -> return (ConsumeFloat16Canonical (\f# -> k (F# f#)))) {-# INLINE decodeFloat16Canonical #-} --- | Decode canonical representation of a @'Float'@. +-- | Decode canonical representation of a 'Float'. -- -- @since 0.2.0.0 decodeFloatCanonical :: Decoder s Float decodeFloatCanonical = Decoder (\k -> return (ConsumeFloatCanonical (\f# -> k (F# f#)))) {-# INLINE decodeFloatCanonical #-} --- | Decode canonical representation of a @'Double'@. +-- | Decode canonical representation of a 'Double'. -- -- @since 0.2.0.0 decodeDoubleCanonical :: Decoder s Double @@ -782,7 +791,7 @@ {-# INLINE decodeDoubleCanonical #-} -- | Decode canonical representation of a 'simple' CBOR value and give back a --- @'Word8'@. You probably don't ever need to use this. +-- 'Word8'. You probably don't ever need to use this. -- -- @since 0.2.0.0 decodeSimpleCanonical :: Decoder s Word8 @@ -793,7 +802,7 @@ -- Specialised read operations: expect a token with a specific value -- --- | Attempt to decode a word with @'decodeWord'@, and ensure the word +-- | Attempt to decode a word with 'decodeWord', and ensure the word -- is exactly as expected, or fail. -- -- @since 0.2.0.0 @@ -802,7 +811,7 @@ decodeWordOf = decodeWordOfHelper decodeWord {-# INLINE decodeWordOf #-} --- | Attempt to decode a list length using @'decodeListLen'@, and +-- | Attempt to decode a list length using 'decodeListLen', and -- ensure it is exactly the specified length, or fail. -- -- @since 0.2.0.0 @@ -810,7 +819,7 @@ decodeListLenOf = decodeListLenOfHelper decodeListLen {-# INLINE decodeListLenOf #-} --- | Attempt to decode canonical representation of a word with @'decodeWordCanonical'@, +-- | Attempt to decode canonical representation of a word with 'decodeWordCanonical', -- and ensure the word is exactly as expected, or fail. -- -- @since 0.2.0.0 @@ -820,7 +829,7 @@ {-# INLINE decodeWordCanonicalOf #-} -- | Attempt to decode canonical representation of a list length using --- @'decodeListLenCanonical'@, and ensure it is exactly the specified length, or +-- 'decodeListLenCanonical', and ensure it is exactly the specified length, or -- fail. -- -- @since 0.2.0.0 @@ -828,14 +837,14 @@ decodeListLenCanonicalOf = decodeListLenOfHelper decodeListLenCanonical {-# INLINE decodeListLenCanonicalOf #-} -decodeListLenOfHelper :: (Show a, Eq a, Monad m) => m a -> a -> m () +decodeListLenOfHelper :: (Show a, Eq a, Fail.MonadFail m) => m a -> a -> m () decodeListLenOfHelper decodeFun = \len -> do len' <- decodeFun if len == len' then return () else fail $ "expected list of length " ++ show len {-# INLINE decodeListLenOfHelper #-} -decodeWordOfHelper :: (Show a, Eq a, Monad m) => m a -> a -> m () +decodeWordOfHelper :: (Show a, Eq a, Fail.MonadFail m) => m a -> a -> m () decodeWordOfHelper decodeFun = \n -> do n' <- decodeFun if n == n' then return () @@ -846,7 +855,7 @@ -- Branching operations -- | Attempt to decode a token for the length of a finite, known list, --- or an indefinite list. If @'Nothing'@ is returned, then an +-- or an indefinite list. If 'Nothing' is returned, then an -- indefinite length list occurs afterwords. If @'Just' x@ is -- returned, then a list of length @x@ is encoded. -- @@ -860,7 +869,7 @@ {-# INLINE decodeListLenOrIndef #-} -- | Attempt to decode a token for the length of a finite, known map, --- or an indefinite map. If @'Nothing'@ is returned, then an +-- or an indefinite map. If 'Nothing' is returned, then an -- indefinite length map occurs afterwords. If @'Just' x@ is returned, -- then a map of length @x@ is encoded. -- @@ -874,8 +883,8 @@ {-# INLINE decodeMapLenOrIndef #-} -- | Attempt to decode a @Break@ token, and if that was --- successful, return @'True'@. If the token was of any --- other type, return @'False'@. +-- successful, return 'True'. If the token was of any +-- other type, return 'False'. -- -- @since 0.2.0.0 decodeBreakOr :: Decoder s Bool @@ -886,7 +895,7 @@ -- Special operations -- | Peek at the current token we're about to decode, and return a --- @'TokenType'@ specifying what it is. +-- 'TokenType' specifying what it is. -- -- @since 0.2.0.0 peekTokenType :: Decoder s TokenType @@ -901,6 +910,47 @@ peekAvailable = Decoder (\k -> return (PeekAvailable (\len# -> k (I# len#)))) {-# INLINE peekAvailable #-} + +-- | A 0-based offset within the overall byte sequence that makes up the +-- input to the 'Decoder'. +-- +-- This is an 'Int64' since 'Decoder' is incremental and can decode more data +-- than fits in memory at once. This is also compatible with the result type +-- of 'Data.ByteString.Lazy.length'. +-- +type ByteOffset = Int64 + +-- | Get the current 'ByteOffset' in the input byte sequence of the 'Decoder'. +-- +-- The 'Decoder' does not provide any facility to get at the input data +-- directly (since that is tricky with an incremental decoder). The next best +-- is this primitive which can be used to keep track of the offset within the +-- input bytes that makes up the encoded form of a term. +-- +-- By keeping track of the byte offsets before and after decoding a subterm +-- (a pattern captured by 'decodeWithByteSpan') and if the overall input data +-- is retained then this is enables later retrieving the span of bytes for the +-- subterm. +-- +-- @since 0.2.2.0 +peekByteOffset :: Decoder s ByteOffset +peekByteOffset = Decoder (\k -> return (PeekByteOffset (\off# -> k (I64# off#)))) +{-# INLINE peekByteOffset #-} + +-- | This captures the pattern of getting the byte offsets before and after +-- decoding a subterm. +-- +-- > !before <- peekByteOffset +-- > x <- decode +-- > !after <- peekByteOffset +-- +decodeWithByteSpan :: Decoder s a -> Decoder s (a, ByteOffset, ByteOffset) +decodeWithByteSpan da = do + !before <- peekByteOffset + x <- da + !after <- peekByteOffset + return (x, before, after) + {- expectExactly :: Word -> Decoder (Word :#: s) s expectExactly n = expectExactly_ n done @@ -948,4 +998,3 @@ go !acc 0 = return $! g acc go !acc n = do !x <- get; go (f acc x) (n-1) {-# INLINE decodeSequenceLenN #-} - diff --git a/src/Codec/CBOR/Encoding.hs b/src/Codec/CBOR/Encoding.hs --- a/src/Codec/CBOR/Encoding.hs +++ b/src/Codec/CBOR/Encoding.hs @@ -10,14 +10,14 @@ -- Portability : non-portable (GHC extensions) -- -- High level API for encoding values, for later serialization into --- CBOR binary format, using a @'Monoid'@ based interface. +-- CBOR binary format, using a 'Monoid' based interface. -- module Codec.CBOR.Encoding ( -- * Encoding implementation Encoding(..) -- :: * , Tokens(..) -- :: * - -- * @'Encoding'@ API for serialisation + -- * 'Encoding' API for serialisation , encodeWord -- :: Word -> Encoding , encodeWord8 -- :: Word8 -> Encoding , encodeWord16 -- :: Word16 -> Encoding @@ -49,6 +49,7 @@ , encodeFloat16 -- :: Float -> Encoding , encodeFloat -- :: Float -> Encoding , encodeDouble -- :: Double -> Encoding + , encodePreEncoded -- :: B.ByteString -> Encoding ) where #include "cbor.h" @@ -67,16 +68,16 @@ import {-# SOURCE #-} qualified Codec.CBOR.FlatTerm as FlatTerm -- | An intermediate form used during serialisation, specified as a --- @'Monoid'@. It supports efficient concatenation, and is equivalent --- to a specialised @'Data.Monoid.Endo' 'Tokens'@ type. +-- 'Monoid'. It supports efficient concatenation, and is equivalent +-- to a specialised 'Data.Monoid.Endo' 'Tokens' type. -- -- It is used for the stage in serialisation where we flatten out the -- Haskell data structure but it is independent of any specific -- external binary or text format. -- --- Traditionally, to build any arbitrary @'Encoding'@ value, you specify +-- Traditionally, to build any arbitrary 'Encoding' value, you specify -- larger structures from smaller ones and append the small ones together --- using @'Data.Monoid.mconcat'@. +-- using 'Data.Monoid.mconcat'. -- -- @since 0.2.0.0 newtype Encoding = Encoding (Tokens -> Tokens) @@ -127,6 +128,9 @@ | TkFloat64 {-# UNPACK #-} !Double Tokens | TkBreak Tokens + -- Special + | TkEncoded {-# UNPACK #-} !B.ByteString Tokens + | TkEnd deriving (Show,Eq) @@ -146,55 +150,55 @@ mconcat = foldr (<>) mempty {-# INLINE mconcat #-} --- | Encode a @'Word'@ in a flattened format. +-- | Encode a 'Word' in a flattened format. -- -- @since 0.2.0.0 encodeWord :: Word -> Encoding encodeWord = Encoding . TkWord --- | Encode a @'Word8'@ in a flattened format. +-- | Encode a 'Word8' in a flattened format. -- -- @since 0.2.0.0 encodeWord8 :: Word8 -> Encoding encodeWord8 = Encoding . TkWord . fromIntegral --- | Encode a @'Word16'@ in a flattened format. +-- | Encode a 'Word16' in a flattened format. -- -- @since 0.2.0.0 encodeWord16 :: Word16 -> Encoding encodeWord16 = Encoding . TkWord . fromIntegral --- | Encode a @'Word32'@ in a flattened format. +-- | Encode a 'Word32' in a flattened format. -- -- @since 0.2.0.0 encodeWord32 :: Word32 -> Encoding encodeWord32 = Encoding . TkWord . fromIntegral --- | Encode a @'Word64'@ in a flattened format. +-- | Encode a 'Word64' in a flattened format. -- -- @since 0.2.0.0 encodeWord64 :: Word64 -> Encoding encodeWord64 = Encoding . TkWord64 --- | Encode an @'Int'@ in a flattened format. +-- | Encode an 'Int' in a flattened format. -- -- @since 0.2.0.0 encodeInt :: Int -> Encoding encodeInt = Encoding . TkInt --- | Encode an @'Int8'@ in a flattened format. +-- | Encode an 'Int8' in a flattened format. -- -- @since 0.2.0.0 encodeInt8 :: Int8 -> Encoding encodeInt8 = Encoding . TkInt . fromIntegral --- | Encode an @'Int16'@ in a flattened format. +-- | Encode an 'Int16' in a flattened format. -- -- @since 0.2.0.0 encodeInt16 :: Int16 -> Encoding encodeInt16 = Encoding . TkInt . fromIntegral --- | Encode an @'Int32'@ in a flattened format. +-- | Encode an 'Int32' in a flattened format. -- -- @since 0.2.0.0 encodeInt32 :: Int32 -> Encoding @@ -213,7 +217,7 @@ encodeInteger :: Integer -> Encoding encodeInteger n = Encoding (TkInteger n) --- | Encode an arbitrary strict @'B.ByteString'@ in +-- | Encode an arbitrary strict 'B.ByteString' in -- a flattened format. -- -- @since 0.2.0.0 @@ -230,13 +234,13 @@ -- indefinite length. In reality, this specifies a stream of many -- occurrences of `encodeBytes`, each specifying a single chunk of the -- overall string. After all the bytes desired have been encoded, you --- should follow it with a break token (see @'encodeBreak'@). +-- should follow it with a break token (see 'encodeBreak'). -- -- @since 0.2.0.0 encodeBytesIndef :: Encoding encodeBytesIndef = Encoding TkBytesBegin --- | Encode a @'T.Text'@ in a flattened format. +-- | Encode a 'T.Text' in a flattened format. -- -- @since 0.2.0.0 encodeString :: T.Text -> Encoding @@ -265,7 +269,7 @@ -- | Encode a token specifying that this is the beginning of an -- indefinite list of unknown size. Tokens representing the list are -- expected afterwords, followed by a break token (see --- @'encodeBreak'@) when the list has ended. +-- 'encodeBreak') when the list has ended. -- -- @since 0.2.0.0 encodeListLenIndef :: Encoding @@ -281,7 +285,7 @@ -- | Encode a token specifying that this is the beginning of an -- indefinite map of unknown size. Tokens representing the map are -- expected afterwords, followed by a break token (see --- @'encodeBreak'@) when the map has ended. +-- 'encodeBreak') when the map has ended. -- -- @since 0.2.0.0 encodeMapLenIndef :: Encoding @@ -294,19 +298,19 @@ encodeBreak :: Encoding encodeBreak = Encoding TkBreak --- | Encode an arbitrary @'Word'@ tag. +-- | Encode an arbitrary 'Word' tag. -- -- @since 0.2.0.0 encodeTag :: Word -> Encoding encodeTag = Encoding . TkTag --- | Encode an arbitrary 64-bit @'Word64'@ tag. +-- | Encode an arbitrary 64-bit 'Word64' tag. -- -- @since 0.2.0.0 encodeTag64 :: Word64 -> Encoding encodeTag64 = Encoding . TkTag64 --- | Encode a @'Bool'@. +-- | Encode a 'Bool'. -- -- @since 0.2.0.0 encodeBool :: Bool -> Encoding @@ -331,20 +335,35 @@ encodeSimple :: Word8 -> Encoding encodeSimple = Encoding . TkSimple --- | Encode a small 16-bit @'Float'@ in a flattened format. +-- | Encode a small 16-bit 'Float' in a flattened format. -- -- @since 0.2.0.0 encodeFloat16 :: Float -> Encoding encodeFloat16 = Encoding . TkFloat16 --- | Encode a full precision @'Float'@ in a flattened format. +-- | Encode a full precision 'Float' in a flattened format. -- -- @since 0.2.0.0 encodeFloat :: Float -> Encoding encodeFloat = Encoding . TkFloat32 --- | Encode a @'Double'@ in a flattened format. +-- | Encode a 'Double' in a flattened format. -- -- @since 0.2.0.0 encodeDouble :: Double -> Encoding encodeDouble = Encoding . TkFloat64 + +-- | Include pre-encoded valid CBOR data into the 'Encoding'. +-- +-- The data is included into the output as-is without any additional wrapper. +-- +-- This should be used with care. The data /must/ be a valid CBOR encoding, but +-- this is /not/ checked. +-- +-- This is useful when you have CBOR data that you know is already valid, e.g. +-- previously validated and stored on disk, and you wish to include it without +-- having to decode and re-encode it. +-- +-- @since 0.2.2.0 +encodePreEncoded :: B.ByteString -> Encoding +encodePreEncoded = Encoding . TkEncoded 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 @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE BangPatterns #-} -- | -- Module : Codec.CBOR.FlatTerm @@ -11,16 +12,16 @@ -- Stability : experimental -- Portability : non-portable (GHC extensions) -- --- A simpler form than CBOR for writing out @'Enc.Encoding'@ values that allows +-- A simpler form than CBOR for writing out 'Enc.Encoding' values that allows -- easier verification and testing. While this library primarily focuses --- on taking @'Enc.Encoding'@ values (independent of any underlying format) +-- on taking 'Enc.Encoding' values (independent of any underlying format) -- and serializing them into CBOR format, this module offers an alternative --- format called @'FlatTerm'@ for serializing @'Enc.Encoding'@ values. +-- format called 'FlatTerm' for serializing 'Enc.Encoding' values. -- --- The @'FlatTerm'@ form is very simple and internally mirrors the original --- @'Encoding'@ type very carefully. The intention here is that once you --- have @'Enc.Encoding'@ and @'Dec.Decoding'@ values for your types, you can --- round-trip values through @'FlatTerm'@ to catch bugs more easily and with +-- The 'FlatTerm' form is very simple and internally mirrors the original +-- 'Encoding' type very carefully. The intention here is that once you +-- have 'Enc.Encoding' and 'Dec.Decoding' values for your types, you can +-- round-trip values through 'FlatTerm' to catch bugs more easily and with -- a smaller amount of code to look through. -- -- For that reason, this module is primarily useful for client libraries, @@ -36,6 +37,7 @@ , toFlatTerm -- :: Encoding -> FlatTerm , fromFlatTerm -- :: Decoder s a -> FlatTerm -> Either String a , validFlatTerm -- :: FlatTerm -> Bool + , decodeTermToken -- Decoder s TermToken ) where #include "cbor.h" @@ -43,6 +45,7 @@ import Codec.CBOR.Encoding (Encoding(..)) import qualified Codec.CBOR.Encoding as Enc import Codec.CBOR.Decoding as Dec +import qualified Codec.CBOR.Read as Read import qualified Codec.CBOR.ByteArray as BA import qualified Codec.CBOR.ByteArray.Sliced as BAS @@ -60,19 +63,23 @@ import Data.Text (Text) import qualified Data.Text.Encoding as TE import Data.ByteString (ByteString) +import qualified Data.ByteString as BS import Control.Monad.ST +import qualified Control.Monad.ST.Lazy as ST.Lazy +import Prelude hiding (encodeFloat, decodeFloat) + -------------------------------------------------------------------------------- --- | A "flat" representation of an @'Enc.Encoding'@ value, +-- | A \"flat\" representation of an 'Enc.Encoding' value, -- useful for round-tripping and writing tests. -- -- @since 0.2.0.0 type FlatTerm = [TermToken] --- | A concrete encoding of @'Enc.Encoding'@ values, one --- which mirrors the original @'Enc.Encoding'@ type closely. +-- | A concrete encoding of 'Enc.Encoding' values, one +-- which mirrors the original 'Enc.Encoding' type closely. -- -- @since 0.2.0.0 data TermToken @@ -98,11 +105,11 @@ -------------------------------------------------------------------------------- --- | Convert an arbitrary @'Enc.Encoding'@ into a @'FlatTerm'@. +-- | Convert an arbitrary 'Enc.Encoding' into a 'FlatTerm'. -- -- @since 0.2.0.0 -toFlatTerm :: Encoding -- ^ The input @'Enc.Encoding'@. - -> FlatTerm -- ^ The resulting @'FlatTerm'@. +toFlatTerm :: Encoding -- ^ The input 'Enc.Encoding'. + -> FlatTerm -- ^ The resulting 'FlatTerm'. toFlatTerm (Encoding tb) = convFlatTerm (tb Enc.TkEnd) convFlatTerm :: Enc.Tokens -> FlatTerm @@ -141,17 +148,131 @@ convFlatTerm (Enc.TkFloat32 f ts) = TkFloat32 f : convFlatTerm ts convFlatTerm (Enc.TkFloat64 f ts) = TkFloat64 f : convFlatTerm ts convFlatTerm (Enc.TkBreak ts) = TkBreak : convFlatTerm ts +convFlatTerm (Enc.TkEncoded bs ts) = decodePreEncoded bs + ++ convFlatTerm ts convFlatTerm Enc.TkEnd = [] -------------------------------------------------------------------------------- --- | Given a @'Dec.Decoder'@, decode a @'FlatTerm'@ back into +decodePreEncoded :: BS.ByteString -> FlatTerm +decodePreEncoded bs0 = + ST.Lazy.runST (provideInput bs0) + where + provideInput :: BS.ByteString -> ST.Lazy.ST s FlatTerm + provideInput bs + | BS.null bs = return [] + | otherwise = do + next <- ST.Lazy.strictToLazyST $ do + -- This will always be a 'Partial' here because decodeTermToken + -- always starts by requesting initial input. Only decoders that + -- fail or return a value without looking at their input can give + -- a different initial result. + Read.Partial k <- Read.deserialiseIncremental decodeTermToken + k (Just bs) + collectOutput next + + collectOutput :: Read.IDecode s TermToken -> ST.Lazy.ST s FlatTerm + collectOutput (Read.Fail _ _ err) = fail $ "toFlatTerm: encodePreEncoded " + ++ "used with invalid CBOR: " + ++ show err + collectOutput (Read.Partial k) = ST.Lazy.strictToLazyST (k Nothing) + >>= collectOutput + collectOutput (Read.Done bs' _ x) = do xs <- provideInput bs' + return (x : xs) + +decodeTermToken :: Decoder s TermToken +decodeTermToken = do + tkty <- peekTokenType + case tkty of + TypeUInt -> do w <- decodeWord + return $! fromWord w + where + fromWord :: Word -> TermToken + fromWord w + | w <= fromIntegral (maxBound :: Int) + = TkInt (fromIntegral w) + | otherwise = TkInteger (fromIntegral w) + + TypeUInt64 -> do w <- decodeWord64 + return $! fromWord64 w + where + fromWord64 w + | w <= fromIntegral (maxBound :: Int) + = TkInt (fromIntegral w) + | otherwise = TkInteger (fromIntegral w) + + TypeNInt -> do w <- decodeNegWord + return $! fromNegWord w + where + fromNegWord w + | w <= fromIntegral (maxBound :: Int) + = TkInt (-1 - fromIntegral w) + | otherwise = TkInteger (-1 - fromIntegral w) + + TypeNInt64 -> do w <- decodeNegWord64 + return $! fromNegWord64 w + where + fromNegWord64 w + | w <= fromIntegral (maxBound :: Int) + = TkInt (-1 - fromIntegral w) + | otherwise = TkInteger (-1 - fromIntegral w) + + TypeInteger -> do !x <- decodeInteger + return (TkInteger x) + TypeFloat16 -> do !x <- decodeFloat + return (TkFloat16 x) + TypeFloat32 -> do !x <- decodeFloat + return (TkFloat32 x) + TypeFloat64 -> do !x <- decodeDouble + return (TkFloat64 x) + + TypeBytes -> do !x <- decodeBytes + return (TkBytes x) + TypeBytesIndef -> do decodeBytesIndef + return TkBytesBegin + TypeString -> do !x <- decodeString + return (TkString x) + TypeStringIndef -> do decodeStringIndef + return TkStringBegin + + TypeListLen -> do !x <- decodeListLen + return $! TkListLen (fromIntegral x) + TypeListLen64 -> do !x <- decodeListLen + return $! TkListLen (fromIntegral x) + TypeListLenIndef -> do decodeListLenIndef + return TkListBegin + TypeMapLen -> do !x <- decodeMapLen + return $! TkMapLen (fromIntegral x) + TypeMapLen64 -> do !x <- decodeMapLen + return $! TkMapLen (fromIntegral x) + TypeMapLenIndef -> do decodeMapLenIndef + return TkMapBegin + + TypeTag -> do !x <- decodeTag + return $! TkTag (fromIntegral x) + TypeTag64 -> do !x <- decodeTag + return $! TkTag (fromIntegral x) + + TypeBool -> do !x <- decodeBool + return (TkBool x) + TypeNull -> do decodeNull + return TkNull + TypeSimple -> do !x <- decodeSimple + return (TkSimple x) + TypeBreak -> do _ <- decodeBreakOr + return TkBreak + TypeInvalid -> fail "invalid token encoding" + + +-------------------------------------------------------------------------------- + +-- | Given a 'Dec.Decoder', decode a 'FlatTerm' back into -- an ordinary value, or return an error. -- -- @since 0.2.0.0 fromFlatTerm :: (forall s. Decoder s a) - -- ^ A @'Dec.Decoder'@ for a serialised value. - -> FlatTerm -- ^ The serialised @'FlatTerm'@. + -- ^ A 'Dec.Decoder' for a serialised value. + -> FlatTerm -- ^ The serialised 'FlatTerm'. -> Either String a -- ^ The deserialised value, or an error. fromFlatTerm decoder ft = runST (getDecodeAction decoder >>= go ft) @@ -328,7 +449,15 @@ go ts@(tk:_) (PeekTokenType k) = k (tokenTypeOf tk) >>= go ts go ts (PeekTokenType _) = unexpected "peekTokenType" ts + + -- We don't have real bytes so we have to give these two operations + -- different interpretations: remaining tokens and just 0 for offsets. go ts (PeekAvailable k) = k (unI# (length ts)) >>= go ts +#if defined(ARCH_32bit) + go ts (PeekByteOffset k)= k (unI64# 0) >>= go ts +#else + go ts (PeekByteOffset k)= k 0# >>= go ts +#endif go _ (Fail msg) = return $ Left msg go [] (Done x) = return $ Right x @@ -415,7 +544,7 @@ unexpected name [] = return $ Left $ name ++ ": unexpected end of input" unexpected name (tok:_) = return $ Left $ name ++ ": unexpected token " ++ show tok --- | Map a @'TermToken'@ to the underlying CBOR @'TokenType'@ +-- | Map a 'TermToken' to the underlying CBOR 'TokenType' tokenTypeOf :: TermToken -> TokenType tokenTypeOf (TkInt n) | n >= 0 = TypeUInt @@ -440,12 +569,12 @@ -------------------------------------------------------------------------------- --- | Ensure a @'FlatTerm'@ is internally consistent and was created in a valid +-- | Ensure a 'FlatTerm' is internally consistent and was created in a valid -- manner. -- -- @since 0.2.0.0 -validFlatTerm :: FlatTerm -- ^ The input @'FlatTerm'@ - -> Bool -- ^ @'True'@ if valid, @'False'@ otherwise. +validFlatTerm :: FlatTerm -- ^ The input 'FlatTerm' + -> Bool -- ^ 'True' if valid, 'False' otherwise. validFlatTerm ts = either (const False) (const True) $ do ts' <- validateTerm TopLevelSingle ts @@ -454,7 +583,7 @@ _ -> Left "trailing data" -- | A data type used for tracking the position we're at --- as we traverse a @'FlatTerm'@ and make sure it's valid. +-- as we traverse a 'FlatTerm' and make sure it's valid. data Loc = TopLevelSingle | TopLevelSequence | InString Int Loc @@ -468,7 +597,7 @@ | InTagged Word64 Loc deriving Show --- | Validate an arbitrary @'FlatTerm'@ at an arbitrary location. +-- | Validate an arbitrary 'FlatTerm' at an arbitrary location. validateTerm :: Loc -> FlatTerm -> Either String FlatTerm validateTerm _loc (TkInt _ : ts) = return ts validateTerm _loc (TkInteger _ : ts) = return ts @@ -562,8 +691,8 @@ minInt32 = fromIntegral (minBound :: Int32) maxWord32 = fromIntegral (maxBound :: Word32) --- | Do a careful check to ensure an @'Int'@ is in the --- range of a @'Word32'@. +-- | Do a careful check to ensure an 'Int' is in the +-- range of a 'Word32'. intIsValidWord32 :: Int -> Bool intIsValidWord32 n = b1 && b2 where 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 @@ -26,7 +26,7 @@ , grabWord32 -- :: Ptr () -> Word , grabWord64 -- :: Ptr () -> Word64 - -- * @'ByteString'@ utilities + -- * 'ByteString' utilities , eatTailWord8 -- :: ByteString -> Word , eatTailWord16 -- :: ByteString -> Word , eatTailWord32 -- :: ByteString -> Word @@ -65,7 +65,7 @@ , word32ToWord64 -- :: Word32 -> Word64 #endif - -- * @'Integer'@ utilities + -- * 'Integer' utilities , nintegerFromBytes -- :: ByteString -> Integer , uintegerFromBytes -- :: ByteString -> Integer @@ -87,6 +87,9 @@ import GHC.IO (IO(IO), unsafeDupablePerformIO) import GHC.Word import GHC.Int +#if MIN_VERSION_base(4,11,0) +import GHC.Float (castWord32ToFloat, castWord64ToDouble) +#endif import Foreign.Ptr #if defined(OPTIMIZE_GMP) @@ -104,7 +107,7 @@ import qualified Numeric.Half as Half -#if !defined(HAVE_BYTESWAP_PRIMOPS) || !defined(MEM_UNALIGNED_OPS) +#if !defined(HAVE_BYTESWAP_PRIMOPS) || !defined(MEM_UNALIGNED_OPS) || !defined(OPTIMIZE_GMP) import Data.Bits ((.|.), unsafeShiftL) #endif @@ -117,19 +120,19 @@ -------------------------------------------------------------------------------- --- | Grab a 8-bit @'Word'@ given a @'Ptr'@ to some address. +-- | Grab a 8-bit 'Word' given a 'Ptr' to some address. grabWord8 :: Ptr () -> Word8 {-# INLINE grabWord8 #-} --- | Grab a 16-bit @'Word'@ given a @'Ptr'@ to some address. +-- | Grab a 16-bit 'Word' given a 'Ptr' to some address. grabWord16 :: Ptr () -> Word16 {-# INLINE grabWord16 #-} --- | Grab a 32-bit @'Word'@ given a @'Ptr'@ to some address. +-- | Grab a 32-bit 'Word' given a 'Ptr' to some address. grabWord32 :: Ptr () -> Word32 {-# INLINE grabWord32 #-} --- | Grab a 64-bit @'Word64'@ given a @'Ptr'@ to some address. +-- | Grab a 64-bit 'Word64' given a 'Ptr' to some address. grabWord64 :: Ptr () -> Word64 {-# INLINE grabWord64 #-} @@ -226,43 +229,43 @@ -------------------------------------------------------------------------------- -- ByteString shennanigans --- | Take the tail of a @'ByteString'@ (i.e. drop the first byte) and read the --- resulting byte(s) as an 8-bit word value. The input @'ByteString'@ MUST be at +-- | Take the tail of a 'ByteString' (i.e. drop the first byte) and read the +-- resulting byte(s) as an 8-bit word value. The input 'ByteString' MUST be at -- 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 +-- 'Word' value. This is not checked, and failure to ensure this will result -- in undefined behavior. eatTailWord8 :: ByteString -> Word8 eatTailWord8 xs = withBsPtr grabWord8 (BS.unsafeTail xs) {-# INLINE eatTailWord8 #-} --- | Take the tail of a @'ByteString'@ (i.e. drop the first byte) and read the --- resulting byte(s) as a 16-bit word value. The input @'ByteString'@ MUST be at +-- | Take the tail of a 'ByteString' (i.e. drop the first byte) and read the +-- resulting byte(s) as a 16-bit word value. The input 'ByteString' MUST be at -- 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 +-- 16-bit 'Word' value. This is not checked, and failure to ensure this will -- result in undefined behavior. eatTailWord16 :: ByteString -> Word16 eatTailWord16 xs = withBsPtr grabWord16 (BS.unsafeTail xs) {-# INLINE eatTailWord16 #-} --- | Take the tail of a @'ByteString'@ (i.e. drop the first byte) and read the --- resulting byte(s) as a 32-bit word value. The input @'ByteString'@ MUST be at +-- | Take the tail of a 'ByteString' (i.e. drop the first byte) and read the +-- resulting byte(s) as a 32-bit word value. The input 'ByteString' MUST be at -- 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 +-- 32-bit 'Word' value. This is not checked, and failure to ensure this will -- result in undefined behavior. eatTailWord32 :: ByteString -> Word32 eatTailWord32 xs = withBsPtr grabWord32 (BS.unsafeTail xs) {-# INLINE eatTailWord32 #-} --- | Take the tail of a @'ByteString'@ (i.e. drop the first byte) and read the --- resulting byte(s) as a 64-bit word value. The input @'ByteString'@ MUST be at +-- | Take the tail of a 'ByteString' (i.e. drop the first byte) and read the +-- resulting byte(s) as a 64-bit word value. The input 'ByteString' MUST be at -- least 9 bytes long: one byte to drop from the front, and eight to read as a --- 64-bit @'Word64'@ value. This is not checked, and failure to ensure this will +-- 64-bit 'Word64' value. This is not checked, and failure to ensure this will -- result in undefined behavior. eatTailWord64 :: ByteString -> Word64 eatTailWord64 xs = withBsPtr grabWord64 (BS.unsafeTail xs) {-# INLINE eatTailWord64 #-} --- | Unsafely take a @'Ptr'@ to a @'ByteString'@ and do unholy things +-- | Unsafely take a 'Ptr' to a 'ByteString' and do unholy things -- with it. withBsPtr :: (Ptr b -> a) -> ByteString -> a withBsPtr f (BS.PS x off _) = @@ -273,7 +276,7 @@ -------------------------------------------------------------------------------- -- Half floats --- | Convert a @'Word16'@ to a half-sized @'Float'@. +-- | Convert a 'Word16' to a half-sized 'Float'. wordToFloat16 :: Word16 -> Float wordToFloat16 = \x -> Half.fromHalf (Half.Half (cast x)) where @@ -281,7 +284,7 @@ cast = fromIntegral {-# INLINE wordToFloat16 #-} --- | Convert a half-sized @'Float'@ to a @'Word'@. +-- | Convert a half-sized 'Float' to a 'Word'. floatToWord16 :: Float -> Word16 floatToWord16 = \x -> cast (Half.getHalf (Half.toHalf x)) where @@ -296,25 +299,23 @@ -- endian issues. A little endian machine cannot read a big-endian float direct -- from memory, so we read a word, bswap it and then convert to float. -- --- Currently there are no primops for casting word <-> float, see +-- Prior to base 4.11, there are no primops for casting word <-> float, see -- https://ghc.haskell.org/trac/ghc/ticket/4092 -- --- In this implementation, we're avoiding doing the extra indirection (and --- closure allocation) of the runSTRep stuff, but we have to be very careful --- here, we cannot allow the "constant" newByteArray# 8# realWorld# to be --- floated out and shared and aliased across multiple concurrent calls. So we --- do manual worker/wrapper with the worker not being inlined. +-- In our fallback implementation, we're avoiding doing the extra indirection +-- (and closure allocation) of the runSTRep stuff, but we have to be very +-- careful here, we cannot allow the "constant" newByteArray# 8# realWorld# to +-- be floated out and shared and aliased across multiple concurrent calls. +-- So we do manual worker/wrapper with the worker not being inlined. --- | Cast a @'Word32'@ to a @'Float'@. +-- | Cast a 'Word32' to a 'Float'. wordToFloat32 :: Word32 -> Float +#if MIN_VERSION_base(4,11,0) +wordToFloat32 = GHC.Float.castWord32ToFloat +#else wordToFloat32 (W32# w#) = F# (wordToFloat32# w#) {-# INLINE wordToFloat32 #-} --- | Cast a @'Word64'@ to a @'Float'@. -wordToFloat64 :: Word64 -> Double -wordToFloat64 (W64# w#) = D# (wordToFloat64# w#) -{-# INLINE wordToFloat64 #-} - -- | Cast an unboxed word to an unboxed float. wordToFloat32# :: Word# -> Float# wordToFloat32# w# = @@ -325,7 +326,16 @@ case readFloatArray# mba# 0# s'' of (# _, f# #) -> f# {-# NOINLINE wordToFloat32# #-} +#endif +-- | Cast a 'Word64' to a 'Float'. +wordToFloat64 :: Word64 -> Double +#if MIN_VERSION_base(4,11,0) +wordToFloat64 = GHC.Float.castWord64ToDouble +#else +wordToFloat64 (W64# w#) = D# (wordToFloat64# w#) +{-# INLINE wordToFloat64 #-} + -- | Cast an unboxed word to an unboxed double. #if defined(ARCH_64bit) wordToFloat64# :: Word# -> Double# @@ -340,6 +350,7 @@ case readDoubleArray# mba# 0# s'' of (# _, f# #) -> f# {-# NOINLINE wordToFloat64# #-} +#endif -------------------------------------------------------------------------------- -- Casting words and ints @@ -449,11 +460,11 @@ -------------------------------------------------------------------------------- -- Integer utilities --- | Create a negative @'Integer'@ out of a raw @'BS.ByteString'@. +-- | Create a negative 'Integer' out of a raw 'BS.ByteString'. nintegerFromBytes :: BS.ByteString -> Integer nintegerFromBytes bs = -1 - uintegerFromBytes bs --- | Create an @'Integer'@ out of a raw @'BS.ByteString'@. +-- | Create an 'Integer' out of a raw 'BS.ByteString'. uintegerFromBytes :: BS.ByteString -> Integer #if defined(OPTIMIZE_GMP) @@ -483,11 +494,11 @@ -- Mutable counters -- | An efficient, mutable counter. Designed to be used inside --- @'ST'@ or other primitive monads, hence it carries an abstract +-- 'ST' or other primitive monads, hence it carries an abstract -- rank-2 @s@ type parameter. data Counter s = Counter (MutableByteArray# s) --- | Create a new counter with a starting @'Int'@ value. +-- | Create a new counter with a starting 'Int' value. newCounter :: Int -> ST s (Counter s) newCounter (I# n#) = ST (\s -> @@ -497,7 +508,7 @@ s'' -> (# s'', Counter mba# #)) {-# INLINE newCounter #-} --- | Read the current value of a @'Counter'@. +-- | Read the current value of a 'Counter'. readCounter :: Counter s -> ST s Int readCounter (Counter mba#) = ST (\s -> @@ -505,7 +516,7 @@ (# s', n# #) -> (# s', I# n# #)) {-# INLINE readCounter #-} --- | Write a new value into the @'Counter'@. +-- | Write a new value into the 'Counter'. writeCounter :: Counter s -> Int -> ST s () writeCounter (Counter mba#) (I# n#) = ST (\s -> @@ -513,14 +524,14 @@ s' -> (# s', () #)) {-# INLINE writeCounter #-} --- | Increment a @'Counter'@ by one. +-- | Increment a 'Counter' by one. incCounter :: Counter s -> ST s () incCounter c = do x <- readCounter c writeCounter c (x+1) {-# INLINE incCounter #-} --- | Decrement a @'Counter'@ by one. +-- | Decrement a 'Counter' by one. decCounter :: Counter s -> ST s () decCounter c = do x <- readCounter c @@ -530,7 +541,7 @@ -------------------------------------------------------------------------------- -- Array support --- | Copy a @'BS.ByteString'@ and create a primitive @'Prim.ByteArray'@ from it. +-- | Copy a 'BS.ByteString' and create a primitive 'Prim.ByteArray' from it. copyByteStringToByteArray :: BS.ByteString -> Prim.ByteArray copyByteStringToByteArray (BS.PS fp off len) = unsafeDupablePerformIO $ @@ -542,12 +553,12 @@ -- TODO FIXME: can do better here: can do non-copying for larger pinned arrays -- or copy directly into the builder buffer --- | Copy a @'Prim.ByteArray'@ at a certain offset and length into a --- @'BS.ByteString'@. +-- | Copy a 'Prim.ByteArray' at a certain offset and length into a +-- 'BS.ByteString'. copyByteArrayToByteString :: Prim.ByteArray - -- ^ @'Prim.ByteArray'@ to copy from. + -- ^ 'Prim.ByteArray' to copy from. -> Int - -- ^ Offset into the @'Prim.ByteArray'@ to start with. + -- ^ Offset into the 'Prim.ByteArray' to start with. -> Int -- ^ Length of the data to copy. -> BS.ByteString @@ -558,11 +569,11 @@ copyByteArrayToPtr ba off ptr len return (BS.PS fp 0 len) --- | Copy the data pointed to by a @'Ptr'@ into a @'MutableByteArray'. +-- | Copy the data pointed to by a 'Ptr' into a @'MutableByteArray'. copyPtrToMutableByteArray :: Ptr a - -- ^ @'Ptr'@ to buffer to copy from. + -- ^ 'Ptr' to buffer to copy from. -> MutableByteArray RealWorld - -- ^ @'MutableByteArray'@ to copy into. + -- ^ 'MutableByteArray' to copy into. -> Int -- ^ Offset to start copying from. -> Int @@ -573,11 +584,11 @@ case copyAddrToByteArray# addr# mba# off# len# s of s' -> (# s', () #)) --- | Copy a @'ByteArray'@ into a @'Ptr'@ with a given offset and length. +-- | Copy a 'ByteArray' into a 'Ptr' with a given offset and length. copyByteArrayToPtr :: ByteArray - -- ^ @'ByteArray'@ to copy. + -- ^ 'ByteArray' to copy. -> Int - -- ^ Offset into the @'ByteArray'@ of where to start copying. + -- ^ Offset into the 'ByteArray' of where to start copying. -> Ptr a -- ^ Pointer to destination buffer. -> Int diff --git a/src/Codec/CBOR/Pretty.hs b/src/Codec/CBOR/Pretty.hs --- a/src/Codec/CBOR/Pretty.hs +++ b/src/Codec/CBOR/Pretty.hs @@ -42,7 +42,7 @@ newtype PP a = PP (Tokens -> Int -> ShowS -> Either String (Tokens,Int,ShowS,a)) --- | Pretty prints an @'Encoding'@ in an annotated, hexadecimal format +-- | Pretty prints an 'Encoding' in an annotated, hexadecimal format -- that maps CBOR values to their types. The output format is similar -- to the format used on http://cbor.me/. -- @@ -103,7 +103,9 @@ Right (toks', ind', ss', x) -> let PP g' = g x in g' toks' ind' ss' return = pure +#if !MIN_VERSION_base(4,13,0) fail = Fail.fail +#endif instance Fail.MonadFail PP where fail s = PP $ \_ _ _ -> Left s @@ -178,6 +180,7 @@ TkFloat16 f TkEnd -> ppTkFloat16 f TkFloat32 f TkEnd -> ppTkFloat32 f TkFloat64 f TkEnd -> ppTkFloat64 f + TkEncoded _ TkEnd -> ppTkEncoded TkEnd -> str "# End of input" _ -> fail $ unwords ["pprint: Unexpected token:", show term] @@ -202,6 +205,9 @@ ppTkStringBegin:: PP () ppTkStringBegin = str "# text(*)" >> inc 3 >> indef pprint +ppTkEncoded :: PP () +ppTkEncoded = str "# pre-encoded CBOR term" + ppTkListLen :: Word -> PP () ppTkListLen n = do str "# list" @@ -297,6 +303,7 @@ unconsToken (TkFloat16 f16 tks) = Just (TkFloat16 f16 TkEnd,tks) unconsToken (TkFloat32 f32 tks) = Just (TkFloat32 f32 TkEnd,tks) unconsToken (TkFloat64 f64 tks) = Just (TkFloat64 f64 TkEnd,tks) +unconsToken (TkEncoded bs tks) = Just (TkEncoded bs TkEnd,tks) unconsToken (TkBreak tks) = Just (TkBreak TkEnd,tks) hexRep :: Tokens -> PP () 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 @@ -99,8 +99,8 @@ -- of type @a@. data IDecode s a = -- | The decoder has consumed the available input and needs more - -- to continue. Provide @'Just'@ if more input is available and - -- @'Nothing'@ otherwise, and you will get a new @'IDecode'@. + -- to continue. Provide 'Just' if more input is available and + -- 'Nothing' otherwise, and you will get a new 'IDecode'. Partial (Maybe BS.ByteString -> ST s (IDecode s a)) -- | The decoder has successfully finished. Except for the output @@ -109,14 +109,14 @@ | Done !BS.ByteString {-# UNPACK #-} !ByteOffset a -- | The decoder ran into an error. The decoder either used - -- @'fail'@ or was not provided enough input. Contains any + -- 'fail' or was not provided enough input. Contains any -- unconsumed input, the number of bytes consumed, and a - -- @'DeserialiseFailure'@ exception describing the reason why the + -- 'DeserialiseFailure' exception describing the reason why the -- failure occurred. | Fail !BS.ByteString {-# UNPACK #-} !ByteOffset DeserialiseFailure --- | Given a @'Decoder'@ and some @'LBS.ByteString'@ representing --- an encoded CBOR value, return @'Either'@ the decoded CBOR value +-- | Given a 'Decoder' and some 'LBS.ByteString' representing +-- an encoded CBOR value, return 'Either' the decoded CBOR value -- or an error. In addition to the decoded value return any remaining input -- content. -- @@ -128,8 +128,8 @@ fmap f $ runIDecode (deserialiseIncremental d) lbs where f (rest, _, x) = (rest, x) --- | Given a @'Decoder'@ and some @'LBS.ByteString'@ representing --- an encoded CBOR value, return @'Either'@ the decoded CBOR value +-- | Given a 'Decoder' and some 'LBS.ByteString' representing +-- an encoded CBOR value, return 'Either' the decoded CBOR value -- or an error. In addition to the decoded value return any remaining input -- content and the number of bytes consumed. -- @@ -157,7 +157,7 @@ go LBS.Empty (Partial k) = k Nothing >>= go LBS.Empty go (LBS.Chunk bs lbs') (Partial k) = k (Just bs) >>= go lbs' --- | Run a @'Decoder'@ incrementally, returning a continuation +-- | Run a 'Decoder' incrementally, returning a continuation -- representing the result of the incremental decode. -- -- @since 0.2.0.0 @@ -170,9 +170,6 @@ -- A monad for building incremental decoders -- --- | Simple alias for @'Int64'@, used to make types more descriptive. -type ByteOffset = Int64 - newtype IncrementalDecoder s a = IncrementalDecoder { unIncrementalDecoder :: forall r. (a -> ST s (IDecode s r)) -> ST s (IDecode s r) @@ -245,6 +242,11 @@ | SlowConsumeTokenByteArray {-# UNPACK #-} !ByteString (BA.ByteArray -> ST s (DecodeAction s a)) {-# UNPACK #-} !Int | SlowConsumeTokenString {-# UNPACK #-} !ByteString (T.Text -> ST s (DecodeAction s a)) {-# UNPACK #-} !Int | SlowConsumeTokenUtf8ByteArray {-# UNPACK #-} !ByteString (BA.ByteArray -> ST s (DecodeAction s a)) {-# UNPACK #-} !Int +#if defined(ARCH_32bit) + | SlowPeekByteOffset {-# UNPACK #-} !ByteString (Int64# -> ST s (DecodeAction s a)) +#else + | SlowPeekByteOffset {-# UNPACK #-} !ByteString (Int# -> ST s (DecodeAction s a)) +#endif | SlowDecodeAction {-# UNPACK #-} !ByteString (DecodeAction s a) | SlowFail {-# UNPACK #-} !ByteString String @@ -596,9 +598,9 @@ go_fast !bs da@(ConsumeFloat16Canonical k) = case tryConsumeFloat (BS.unsafeHead bs) bs of DecodeFailure -> go_fast_end bs da - DecodedToken sz (F# f#) - | isFloat16Canonical sz -> k f# >>= go_fast (BS.unsafeDrop sz bs) - | otherwise -> go_fast_end bs da + DecodedToken sz f@(F# f#) + | isFloat16Canonical sz bs f -> k f# >>= go_fast (BS.unsafeDrop sz bs) + | otherwise -> go_fast_end bs da go_fast !bs da@(ConsumeFloatCanonical k) = case tryConsumeFloat (BS.unsafeHead bs) bs of @@ -650,8 +652,8 @@ case tryConsumeSimple (BS.unsafeHead bs) bs of DecodeFailure -> go_fast_end bs da DecodedToken sz (W# w#) - | isWordCanonical sz w# -> k w# >>= go_fast (BS.unsafeDrop sz bs) - | otherwise -> go_fast_end bs da + | isSimpleCanonical sz w# -> k w# >>= go_fast (BS.unsafeDrop sz bs) + | otherwise -> go_fast_end bs da go_fast !bs da@(ConsumeBytesIndef k) = case tryConsumeBytesIndef (BS.unsafeHead bs) of @@ -700,6 +702,7 @@ go_fast !bs (PeekAvailable k) = k (case BS.length bs of I# len# -> len#) >>= go_fast bs +go_fast !bs da@PeekByteOffset{} = go_fast_end bs da go_fast !bs da@D.Fail{} = go_fast_end bs da go_fast !bs da@D.Done{} = go_fast_end bs da @@ -719,6 +722,8 @@ go_fast_end !bs (D.Done x) = return $! FastDone bs x go_fast_end !bs (PeekAvailable k) = k (case BS.length bs of I# len# -> len#) >>= go_fast_end bs +go_fast_end !bs (PeekByteOffset k) = return $! SlowPeekByteOffset bs k + -- the next two cases only need the 1 byte token header go_fast_end !bs da | BS.null bs = return $! SlowDecodeAction bs da @@ -1095,9 +1100,9 @@ go_fast_end !bs (ConsumeFloat16Canonical k) = case tryConsumeFloat (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected float" - DecodedToken sz (F# f#) - | isFloat16Canonical sz -> k f# >>= go_fast_end (BS.unsafeDrop sz bs) - | otherwise -> return $! SlowFail bs "non-canonical float16" + DecodedToken sz f@(F# f#) + | isFloat16Canonical sz bs f -> k f# >>= go_fast_end (BS.unsafeDrop sz bs) + | otherwise -> return $! SlowFail bs "non-canonical float16" go_fast_end !bs (ConsumeFloatCanonical k) = case tryConsumeFloat (BS.unsafeHead bs) bs of @@ -1156,8 +1161,8 @@ case tryConsumeSimple (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected simple" DecodedToken sz (W# w#) - | isWordCanonical sz w# -> k w# >>= go_fast_end (BS.unsafeDrop sz bs) - | otherwise -> return $! SlowFail bs "non-canonical simple" + | isSimpleCanonical sz w# -> k w# >>= go_fast_end (BS.unsafeDrop sz bs) + | otherwise -> return $! SlowFail bs "non-canonical simple" go_fast_end !bs (ConsumeBytesIndef k) = case tryConsumeBytesIndef (BS.unsafeHead bs) of @@ -1259,6 +1264,11 @@ where !offset' = offset + intToInt64 (BS.length bs - BS.length bs') + SlowPeekByteOffset bs' k -> + lift (k off#) >>= \daz -> go_slow daz bs' offset' + where + !offset'@(I64# off#) = offset + intToInt64 (BS.length bs - BS.length bs') + SlowFail bs' msg -> decodeFail bs' offset' msg where !offset' = offset + intToInt64 (BS.length bs - BS.length bs') @@ -1356,6 +1366,12 @@ let !ba = BA.fromByteString bstr lift (k ba) >>= \daz -> go_slow daz bs'' (offset' + intToInt64 len) + SlowPeekByteOffset bs_empty k -> + assert (BS.null bs_empty) $ do + lift (k off#) >>= \daz -> go_slow daz bs' offset' + where + !(I64# off#) = offset' + SlowFail bs_unconsumed msg -> decodeFail (bs_unconsumed <> bs') offset'' msg where @@ -1482,22 +1498,32 @@ | TooLong Bool {- canonical? -} !Int deriving Show +-- Canoncal NaN floats: +-- +-- In these float/double canonical tests we check NaNs are canonical too. +-- There are lots of bit values representing NaN, for each of the flat types. +-- The rule from CBOR RFC 7049, section 3.9 is that the canonical NaN is the +-- CBOR term f97e00 which is the canonical half-float representation. We do +-- this by testing for the size being 3 (since tryConsumeFloat/Double only +-- return 3 when the header byte is 0xf9) and the 16 bytes being 0x7e00. + {-# INLINE isFloat16Canonical #-} -isFloat16Canonical :: Int -> Bool -isFloat16Canonical sz - | sz == 3 = True - | otherwise = False +isFloat16Canonical :: Int -> BS.ByteString -> Float -> Bool +isFloat16Canonical sz bs f + | sz /= 3 = False + | isNaN f = eatTailWord16 bs == 0x7e00 + | otherwise = True {-# INLINE isFloatCanonical #-} isFloatCanonical :: Int -> BS.ByteString -> Float -> Bool isFloatCanonical sz bs f - | isNaN f = sz == 3 && "\xf9\x7e\x00" `BS.isPrefixOf` bs + | isNaN f = sz == 3 && eatTailWord16 bs == 0x7e00 | otherwise = sz == 5 {-# INLINE isDoubleCanonical #-} isDoubleCanonical :: Int -> BS.ByteString -> Double -> Bool isDoubleCanonical sz bs f - | isNaN f = sz == 3 && "\xf9\x7e\x00" `BS.isPrefixOf` bs + | isNaN f = sz == 3 && eatTailWord16 bs == 0x7e00 | otherwise = sz == 9 {-# INLINE isWordCanonical #-} @@ -1535,6 +1561,12 @@ where w# = int64ToWord64# i# #endif + +{-# INLINE isSimpleCanonical #-} +isSimpleCanonical :: Int -> Word# -> Bool +isSimpleCanonical 2 w# = isTrue# (w# `gtWord#` 0x17##) +isSimpleCanonical _ _ = True -- only size 1 and 2 are possible here + -- TODO FIXME: check with 7.10 and file ticket: -- a case analysis against 0x00 .. 0xff :: Word8 turns into a huge chain diff --git a/src/Codec/CBOR/Term.hs b/src/Codec/CBOR/Term.hs --- a/src/Codec/CBOR/Term.hs +++ b/src/Codec/CBOR/Term.hs @@ -14,18 +14,18 @@ -- CBOR values (ones that, for example, may not have been generated by this -- library). -- --- Using @'decodeTerm'@, you can decode an arbitrary CBOR value given to you --- into a @'Term'@, which represents a CBOR value as an AST. +-- Using 'decodeTerm', you can decode an arbitrary CBOR value given to you +-- into a 'Term', which represents a CBOR value as an AST. -- -- Similarly, if you wanted to encode some value into a CBOR value directly, --- you can wrap it in a @'Term'@ constructor and use @'encodeTerm'@. This +-- you can wrap it in a 'Term' constructor and use 'encodeTerm'. This -- would be useful, as an example, if you needed to serialise some value into --- a CBOR term that is not compatible with that types @'Serialise'@ instance. +-- a CBOR term that is not compatible with that types 'Serialise' instance. -- -- Because this interface gives you the ability to decode or encode any -- arbitrary CBOR term, it can also be seen as an alternative interface to the --- @'Codec.CBOR.Encoding'@ and --- @'Codec.CBOR.Decoding'@ modules. +-- 'Codec.CBOR.Encoding' and +-- 'Codec.CBOR.Decoding' modules. -- module Codec.CBOR.Term ( Term(..) -- :: * @@ -56,9 +56,9 @@ -- essentially a direct reflection of the CBOR abstract syntax tree as a -- Haskell data type. -- --- The @'Term'@ type also comes with a @'Serialise'@ instance, so you can +-- The 'Term' type also comes with a 'Serialise' instance, so you can -- easily use @'decode' :: 'Decoder' 'Term'@ to directly decode any arbitrary --- CBOR value into Haskell with ease, and likewise with @'encode'@. +-- CBOR value into Haskell with ease, and likewise with 'encode'. -- -- @since 0.2.0.0 data Term @@ -84,7 +84,7 @@ -------------------------------------------------------------------------------- -- Main API --- | Encode an arbitrary @'Term'@ into an @'Encoding'@ for later serialization. +-- | Encode an arbitrary 'Term' into an 'Encoding' for later serialization. -- -- @since 0.2.0.0 encodeTerm :: Term -> Encoding @@ -120,7 +120,7 @@ encodeTerm (TFloat f) = encodeFloat f encodeTerm (TDouble f) = encodeDouble f --- | Decode some arbitrary CBOR value into a @'Term'@. +-- | Decode some arbitrary CBOR value into a 'Term'. -- -- @since 0.2.0.0 decodeTerm :: Decoder s Term 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 @@ -14,8 +14,7 @@ -- Stability : experimental -- Portability : non-portable (GHC extensions) -- --- Tools for writing out CBOR @'Encoding'@ values in --- a variety of forms. +-- Functions for writing out CBOR 'Encoding' values in a variety of forms. -- module Codec.CBOR.Write ( toBuilder -- :: Encoding -> B.Builder @@ -60,102 +59,123 @@ -------------------------------------------------------------------------------- --- | Turn an @'Encoding'@ into a lazy @'L.ByteString'@ in CBOR binary +-- | Turn an 'Encoding' into a lazy 'L.ByteString' in CBOR binary -- format. -- -- @since 0.2.0.0 -toLazyByteString :: Encoding -- ^ The @'Encoding'@ of a CBOR value. +toLazyByteString :: Encoding -- ^ The 'Encoding' of a CBOR value. -> L.ByteString -- ^ The encoded CBOR value. toLazyByteString = B.toLazyByteString . toBuilder --- | Turn an @'Encoding'@ into a strict @'S.ByteString'@ in CBOR binary +-- | Turn an 'Encoding' into a strict 'S.ByteString' in CBOR binary -- format. -- -- @since 0.2.0.0 -toStrictByteString :: Encoding -- ^ The @'Encoding'@ of a CBOR value. +toStrictByteString :: Encoding -- ^ The 'Encoding' of a CBOR value. -> S.ByteString -- ^ The encoded value. toStrictByteString = L.toStrict . B.toLazyByteString . toBuilder --- | Turn an @'Encoding'@ into a @'L.ByteString'@ @'B.Builder'@ in CBOR +-- | Turn an 'Encoding' into a 'L.ByteString' 'B.Builder' in CBOR -- binary format. -- -- @since 0.2.0.0 -toBuilder :: Encoding -- ^ The @'Encoding'@ of a CBOR value. - -> B.Builder -- ^ The encoded value as a @'B.Builder'@. +toBuilder :: Encoding -- ^ The 'Encoding' of a CBOR value. + -> B.Builder -- ^ The encoded value as a 'B.Builder'. toBuilder = - \(Encoding vs0) -> BI.builder (step (vs0 TkEnd)) + \(Encoding vs0) -> BI.builder (buildStep (vs0 TkEnd)) + +buildStep :: Tokens + -> (BI.BufferRange -> IO (BI.BuildSignal a)) + -> BI.BufferRange + -> IO (BI.BuildSignal a) +buildStep vs1 k (BI.BufferRange op0 ope0) = + go vs1 op0 where - step vs1 k (BI.BufferRange op0 ope0) = - go vs1 op0 - where - go vs !op - | op `plusPtr` bound <= ope0 = case vs of - TkWord x vs' -> PI.runB wordMP x op >>= go vs' - TkWord64 x vs' -> PI.runB word64MP x op >>= go vs' + go vs !op + | op `plusPtr` bound <= ope0 = case vs of + TkWord x vs' -> PI.runB wordMP x op >>= go vs' + TkWord64 x vs' -> PI.runB word64MP x op >>= go vs' - TkInt x vs' -> PI.runB intMP x op >>= go vs' - TkInt64 x vs' -> PI.runB int64MP x op >>= go vs' + TkInt x vs' -> PI.runB intMP x op >>= go vs' + TkInt64 x vs' -> PI.runB int64MP x op >>= go vs' - TkBytes x vs' -> BI.runBuilderWith (bytesMP x) (step vs' k) (BI.BufferRange op ope0) - TkBytesBegin vs' -> PI.runB bytesBeginMP () op >>= go vs' - TkByteArray x vs' -> BI.runBuilderWith (byteArrayMP x) (step vs' k) (BI.BufferRange op ope0) + TkBytes x vs' -> BI.runBuilderWith + (bytesMP x) (buildStep vs' k) + (BI.BufferRange op ope0) + TkByteArray x vs' -> BI.runBuilderWith + (byteArrayMP x) (buildStep vs' k) + (BI.BufferRange op ope0) - TkUtf8ByteArray x vs' -> BI.runBuilderWith (utf8ByteArrayMP x) (step vs' k) (BI.BufferRange op ope0) - TkString x vs' -> BI.runBuilderWith (stringMP x) (step vs' k) (BI.BufferRange op ope0) - TkStringBegin vs'-> PI.runB stringBeginMP () op >>= go vs' + TkUtf8ByteArray x vs' -> BI.runBuilderWith + (utf8ByteArrayMP x) (buildStep vs' k) + (BI.BufferRange op ope0) + TkString x vs' -> BI.runBuilderWith + (stringMP x) (buildStep vs' k) + (BI.BufferRange op ope0) - TkListLen x vs' -> PI.runB arrayLenMP x op >>= go vs' - TkListBegin vs' -> PI.runB arrayBeginMP () op >>= go vs' + TkBytesBegin vs' -> PI.runB bytesBeginMP () op >>= go vs' + TkStringBegin vs'-> PI.runB stringBeginMP () op >>= go vs' - TkMapLen x vs' -> PI.runB mapLenMP x op >>= go vs' - TkMapBegin vs' -> PI.runB mapBeginMP () op >>= go vs' + TkListLen x vs' -> PI.runB arrayLenMP x op >>= go vs' + TkListBegin vs' -> PI.runB arrayBeginMP () op >>= go vs' - TkTag x vs' -> PI.runB tagMP x op >>= go vs' - TkTag64 x vs' -> PI.runB tag64MP x op >>= go vs' + TkMapLen x vs' -> PI.runB mapLenMP x op >>= go vs' + TkMapBegin vs' -> PI.runB mapBeginMP () op >>= go vs' + TkTag x vs' -> PI.runB tagMP x op >>= go vs' + TkTag64 x vs' -> PI.runB tag64MP x op >>= go vs' + #if defined(OPTIMIZE_GMP) - -- This code is specialized for GMP implementation of Integer. By - -- looking directly at the constructors we can avoid some checks. - -- S# hold an Int, so we can just use intMP. - TkInteger (Gmp.S# i) vs' -> PI.runB intMP (I# i) op >>= go vs' - -- Jp# is guaranteed to be > 0. - TkInteger integer@(Gmp.Jp# bigNat) vs' - | integer <= fromIntegral (maxBound :: Word64) -> - PI.runB word64MP (fromIntegral integer) op >>= go vs' - | otherwise -> - let buffer = BI.BufferRange op ope0 - in BI.runBuilderWith (bigNatMP bigNat) (step vs' k) buffer - -- Jn# is guaranteed to be < 0. - TkInteger integer@(Gmp.Jn# bigNat) vs' - | integer >= -1 - fromIntegral (maxBound :: Word64) -> - PI.runB negInt64MP (fromIntegral (-1 - integer)) op >>= go vs' - | otherwise -> - let buffer = BI.BufferRange op ope0 - in BI.runBuilderWith (negBigNatMP bigNat) (step vs' k) buffer + -- This code is specialized for GMP implementation of Integer. By + -- looking directly at the constructors we can avoid some checks. + -- S# hold an Int, so we can just use intMP. + TkInteger (Gmp.S# i) vs' -> PI.runB intMP (I# i) op >>= go vs' + -- Jp# is guaranteed to be > 0. + TkInteger integer@(Gmp.Jp# bigNat) vs' + | integer <= fromIntegral (maxBound :: Word64) -> + PI.runB word64MP (fromIntegral integer) op >>= go vs' + | otherwise -> + let buffer = BI.BufferRange op ope0 + in BI.runBuilderWith + (bigNatMP bigNat) (buildStep vs' k) buffer + -- Jn# is guaranteed to be < 0. + TkInteger integer@(Gmp.Jn# bigNat) vs' + | integer >= -1 - fromIntegral (maxBound :: Word64) -> + PI.runB negInt64MP (fromIntegral (-1 - integer)) op >>= go vs' + | otherwise -> + let buffer = BI.BufferRange op ope0 + in BI.runBuilderWith + (negBigNatMP bigNat) (buildStep vs' k) buffer #else - TkInteger x vs' - | x >= 0 - , x <= fromIntegral (maxBound :: Word64) - -> PI.runB word64MP (fromIntegral x) op >>= go vs' - | x < 0 - , x >= -1 - fromIntegral (maxBound :: Word64) - -> PI.runB negInt64MP (fromIntegral (-1 - x)) op >>= go vs' - | otherwise -> BI.runBuilderWith (integerMP x) (step vs' k) (BI.BufferRange op ope0) + TkInteger x vs' + | x >= 0 + , x <= fromIntegral (maxBound :: Word64) + -> PI.runB word64MP (fromIntegral x) op >>= go vs' + | x < 0 + , x >= -1 - fromIntegral (maxBound :: Word64) + -> PI.runB negInt64MP (fromIntegral (-1 - x)) op >>= go vs' + | otherwise -> BI.runBuilderWith + (integerMP x) (buildStep vs' k) + (BI.BufferRange op ope0) #endif - TkBool False vs' -> PI.runB falseMP () op >>= go vs' - TkBool True vs' -> PI.runB trueMP () op >>= go vs' - TkNull vs' -> PI.runB nullMP () op >>= go vs' - TkUndef vs' -> PI.runB undefMP () op >>= go vs' - TkSimple w vs' -> PI.runB simpleMP w op >>= go vs' - TkFloat16 f vs' -> PI.runB halfMP f op >>= go vs' - TkFloat32 f vs' -> PI.runB floatMP f op >>= go vs' - TkFloat64 f vs' -> PI.runB doubleMP f op >>= go vs' - TkBreak vs' -> PI.runB breakMP () op >>= go vs' + TkBool False vs' -> PI.runB falseMP () op >>= go vs' + TkBool True vs' -> PI.runB trueMP () op >>= go vs' + TkNull vs' -> PI.runB nullMP () op >>= go vs' + TkUndef vs' -> PI.runB undefMP () op >>= go vs' + TkSimple w vs' -> PI.runB simpleMP w op >>= go vs' + TkFloat16 f vs' -> PI.runB halfMP f op >>= go vs' + TkFloat32 f vs' -> PI.runB floatMP f op >>= go vs' + TkFloat64 f vs' -> PI.runB doubleMP f op >>= go vs' + TkBreak vs' -> PI.runB breakMP () op >>= go vs' - TkEnd -> k (BI.BufferRange op ope0) + TkEncoded x vs' -> BI.runBuilderWith + (B.byteString x) (buildStep vs' k) + (BI.BufferRange op ope0) - | otherwise = return $ BI.bufferFull bound op (step vs k) + TkEnd -> k (BI.BufferRange op ope0) + + | otherwise = return $ BI.bufferFull bound op (buildStep vs k) -- The maximum size in bytes of the fixed-size encodings bound :: Int diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,22 +1,30 @@ -module Main - ( main -- :: IO () - ) where -import Test.Tasty (defaultMain, testGroup) +module Main (main) where -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 +import Test.Tasty (TestTree, defaultMain, testGroup) +import qualified Tests.Reference as Reference +import qualified Tests.UnitTests as UnitTests +import qualified Tests.Properties as Properties +import qualified Tests.Boundary as Boundary +import qualified Tests.ByteOffset as ByteOffset +import qualified Tests.Canonical as Canonical +import qualified Tests.Regress as Regress +import qualified Tests.UTF8 as UTF8 +import qualified Tests.PreEncoded as PreEncoded + main :: IO () -main = - Reference.loadTestCases >>= \tcs -> - defaultMain $ - testGroup "CBOR tests" - [ CBOR.testTree tcs - , Reference.testTree tcs +main = defaultMain tests + +tests :: TestTree +tests = + testGroup "CBOR" + [ Reference.testTree + , UnitTests.testTree + , Properties.testTree + , ByteOffset.testTree , Boundary.testTree + , Canonical.testTree , Regress.testTree , UTF8.testTree + , PreEncoded.testTree ] diff --git a/tests/Tests/ByteOffset.hs b/tests/Tests/ByteOffset.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/ByteOffset.hs @@ -0,0 +1,458 @@ +{-# LANGUAGE DeriveFunctor, BangPatterns #-} + +module Tests.ByteOffset (testTree) where + +import Data.Word +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import Control.Exception (throw) +import Control.Applicative + +import Codec.CBOR.Decoding +import Codec.CBOR.Read (deserialiseFromBytes) +import Codec.CBOR.Write (toLazyByteString) +import Codec.CBOR.Term (Term, encodeTerm, decodeTerm) +import qualified Codec.CBOR.Term as Term (Term(..)) + +import Test.Tasty (TestTree, testGroup, localOption) +import Test.Tasty.QuickCheck (testProperty, QuickCheckMaxSize(..)) +import Test.QuickCheck hiding (subterms) + +import qualified Tests.Reference.Implementation as RefImpl +import Tests.Reference.Generators (floatToWord, doubleToWord) +import Tests.Term (eqTerm, canonicaliseTerm) +import Tests.Util + +import Prelude hiding (encodeFloat, decodeFloat) + + +-- | Like a 'Term', but with an annotation on top level terms and every +-- subterm. This is used for tests of 'peekByteOffset' where we annotate a +-- decoded term with the byte range it covers. +-- +data ATerm annotation = ATerm (TermF (ATerm annotation)) annotation + deriving (Show, Eq, Functor) + +-- | Term one-level functor. +-- +data TermF t = TInt Int + | TInteger Integer + | TBytes BS.ByteString + | TBytesI LBS.ByteString + | TString T.Text + | TStringI LT.Text + | TList [t] + | TListI [t] + | TMap [(t, t)] + | TMapI [(t, t)] + | TTagged Word64 t + | TBool Bool + | TNull + | TSimple Word8 + | THalf Float + | TFloat Float + | TDouble Double + deriving (Show, Eq, Functor) + + +testTree :: TestTree +testTree = + testGroup "peekByteOffset" + [ testGroup "ATerm framework" + [ testProperty "isomorphic 1" prop_ATerm_isomorphic + , testProperty "isomorphic 2" prop_ATerm_isomorphic2 + , testProperty "isomorphic 3" prop_ATerm_isomorphic3 + ] + , testProperty "bytes deserialise" prop_peekByteOffset_deserialise + , testProperty "bytes reserialise" prop_peekByteOffset_reserialise + , testProperty "non-canonical encoding" prop_peekByteOffset_noncanonical + , localOption (QuickCheckMaxSize 30) $ + testProperty "same offsets with all 2-splits" prop_peekByteOffset_splits2 + , localOption (QuickCheckMaxSize 20) $ + testProperty "same offsets with all 3-splits" prop_peekByteOffset_splits3 + ] + + +-------------------------------------------------------------------------------- +-- Properties of the framework +-- + +-- | Basic property to check that 'ATerm' is isomorphic to the 'Term'. +-- +prop_ATerm_isomorphic :: Term -> Bool +prop_ATerm_isomorphic t = + t `eqTerm` (convertATermToTerm . convertTermToATerm) t + +-- | Variation on 'prop_ATerm_isomorphic', checking that serialising as a +-- 'Term', deserialising as an 'ATerm' and converting back gives an equivalent +-- term. +-- +prop_ATerm_isomorphic2 :: Term -> Bool +prop_ATerm_isomorphic2 t = + canonicaliseTerm t + `eqTerm` (convertATermToTerm . deserialiseATerm . serialiseTerm) t + +-- | Variation on 'prop_ATerm_isomorphic2', but where we check the terms are +-- equivalent as 'ATerm's. +-- +prop_ATerm_isomorphic3 :: Term -> Bool +prop_ATerm_isomorphic3 t = + (convertTermToATerm . canonicaliseTerm) t + `eqATerm` (fmap (const ()) . deserialiseATerm . serialiseTerm) t + + +-------------------------------------------------------------------------------- +-- Properties of peekByteOffset +-- + +-- | A key consistency property for terms annotated with their bytes: +-- taking those bytes and deserialising them gives the corresponding term +-- +prop_ATerm_deserialise :: ATerm ByteSpan -> Bool +prop_ATerm_deserialise t@(ATerm _ bs) = + deserialiseTerm bs `eqTerm` convertATermToTerm t + +-- | For the case of canonical encodings it is also true for terms annotated +-- with their bytes: taking the term and serialising it gives the bytes. +-- +-- Note this is /only/ expected to hold for canonical encodings. See +-- 'prop_peekByteOffset_noncanonical' for a demonstration of this not holding +-- for non-canonical encodings. +-- +prop_ATerm_reserialise :: ATerm ByteSpan -> Bool +prop_ATerm_reserialise t@(ATerm _ bs) = + serialiseTerm (convertATermToTerm t) == bs + +-- | For an 'ATerm' annotated with its bytes (obtained by decoding a term), +-- 'prop_ATerm_deserialise' should be true for the whole term and all subterms. +-- +prop_peekByteOffset_deserialise :: Term -> Bool +prop_peekByteOffset_deserialise t = + all prop_ATerm_deserialise (subterms t') + where + t' = deserialiseATerm (serialiseTerm t) + +-- | For an 'ATerm' annotated with its bytes (obtained by decoding a canonical +-- term), 'prop_ATerm_serialise' should be true for the whole term and all +-- subterms. +-- +prop_peekByteOffset_reserialise :: Term -> Bool +prop_peekByteOffset_reserialise t = + all prop_ATerm_reserialise (subterms t') + where + t' = deserialiseATerm (serialiseTerm t) + +-- | For an 'ATerm' annotated with its bytes obtained by decoding a +-- /non-canonical/ term, 'prop_ATerm_serialise' should not always hold. +-- +-- This is in some sense the essence of why we want 'peekByteOffset' in the +-- first place: to get the bytes corresponding to a term we have to get the +-- original input bytes since we cannot rely on re-serialising to recover the +-- bytes (at least not without relying on and checking for canonical encodings). +-- +prop_peekByteOffset_noncanonical :: RefImpl.Term -> Property +prop_peekByteOffset_noncanonical t = + not (RefImpl.isCanonicalTerm t) ==> + not (prop_ATerm_reserialise t') + where + t' = deserialiseATerm (RefImpl.serialise t) + +-- | The offsets we get when decoding a term should be the same irrespective of +-- block boundaries in the input data stream. This checks the property for all +-- possible 2-chunk splits of the input data. +-- +prop_peekByteOffset_splits2 :: Term -> Bool +prop_peekByteOffset_splits2 t = + and [ deserialiseATermOffsets lbs' `eqATerm` t' + | lbs' <- splits2 lbs ] + where + lbs = serialiseTerm t + t' = deserialiseATermOffsets lbs + +-- | The offsets we get when decoding a term should be the same irrespective of +-- block boundaries in the input data stream. This checks the property for all +-- possible 3-chunk splits of the input data. +-- +prop_peekByteOffset_splits3 :: Term -> Bool +prop_peekByteOffset_splits3 t = + and [ deserialiseATermOffsets lbs' `eqATerm` t' + | lbs' <- splits3 lbs ] + where + lbs = serialiseTerm t + t' = deserialiseATermOffsets lbs + + +------------------------------------------------------------------------------ + +subterms :: ATerm a -> [ATerm a] +subterms at@(ATerm t0 _) = at : subtermsF t0 + where + subtermsF :: TermF (ATerm a) -> [ATerm a] + subtermsF (TList ts) = concatMap subterms ts + subtermsF (TListI ts) = concatMap subterms ts + subtermsF (TMap ts) = [ t' | (x, y) <- ts + , t' <- subterms x + ++ subterms y ] + subtermsF (TMapI ts) = [ t' | (x, y) <- ts + , t' <- subterms x + ++ subterms y ] + subtermsF (TTagged _ t') = subterms t' + + subtermsF TInt {} = [] + subtermsF TInteger{} = [] + subtermsF TBytes {} = [] + subtermsF TBytesI {} = [] + subtermsF TString {} = [] + subtermsF TStringI{} = [] + subtermsF TBool {} = [] + subtermsF TNull {} = [] + subtermsF TSimple {} = [] + subtermsF THalf {} = [] + subtermsF TFloat {} = [] + subtermsF TDouble {} = [] + + +------------------------------------------------------------------------------ + +serialiseTerm :: Term -> LBS.ByteString +serialiseTerm = toLazyByteString . encodeTerm + +deserialiseTerm :: LBS.ByteString -> Term +deserialiseTerm = either throw snd . deserialiseFromBytes decodeTerm + + +-------------------------------------------------------------------------------- +-- Decoding a term, annotated with its underlying bytes +-- + +type Offsets = (ByteOffset, ByteOffset) +type ByteSpan = LBS.ByteString + +deserialiseATermOffsets :: LBS.ByteString -> ATerm Offsets +deserialiseATermOffsets = either throw snd . deserialiseFromBytes decodeATerm + +deserialiseATerm :: LBS.ByteString -> ATerm ByteSpan +deserialiseATerm lbs = atermOffsetsToBytes lbs (deserialiseATermOffsets lbs) + +atermOffsetsToBytes :: LBS.ByteString -> ATerm Offsets -> ATerm ByteSpan +atermOffsetsToBytes original = + fmap (`slice` original) + where + slice :: (ByteOffset, ByteOffset) -> LBS.ByteString -> LBS.ByteString + slice (n,m) = LBS.take (m-n) . LBS.drop n + + +decodeATerm :: Decoder s (ATerm Offsets) +decodeATerm = do + start <- peekByteOffset + t <- decodeTermFATerm + end <- peekByteOffset + return (ATerm t (start, end)) + +decodeTermFATerm :: Decoder s (TermF (ATerm Offsets)) +decodeTermFATerm = do + tkty <- peekTokenType + case tkty of + TypeUInt -> do w <- decodeWord + return $! fromWord w + where + fromWord :: Word -> TermF (ATerm Offsets) + fromWord w + | w <= fromIntegral (maxBound :: Int) + = TInt (fromIntegral w) + | otherwise = TInteger (fromIntegral w) + + TypeUInt64 -> do w <- decodeWord64 + return $! fromWord64 w + where + fromWord64 w + | w <= fromIntegral (maxBound :: Int) + = TInt (fromIntegral w) + | otherwise = TInteger (fromIntegral w) + + TypeNInt -> do w <- decodeNegWord + return $! fromNegWord w + where + fromNegWord w + | w <= fromIntegral (maxBound :: Int) + = TInt (-1 - fromIntegral w) + | otherwise = TInteger (-1 - fromIntegral w) + + TypeNInt64 -> do w <- decodeNegWord64 + return $! fromNegWord64 w + where + fromNegWord64 w + | w <= fromIntegral (maxBound :: Int) + = TInt (-1 - fromIntegral w) + | otherwise = TInteger (-1 - fromIntegral w) + + TypeInteger -> do !x <- decodeInteger + return (TInteger x) + TypeFloat16 -> do !x <- decodeFloat + return (THalf x) + TypeFloat32 -> do !x <- decodeFloat + return (TFloat x) + TypeFloat64 -> do !x <- decodeDouble + return (TDouble x) + + TypeBytes -> do !x <- decodeBytes + return (TBytes x) + TypeBytesIndef -> decodeBytesIndef >> decodeBytesIndefLen [] + TypeString -> do !x <- decodeString + return (TString x) + TypeStringIndef -> decodeStringIndef >> decodeStringIndefLen [] + + TypeListLen -> decodeListLen >>= flip decodeListN [] + TypeListLen64 -> decodeListLen >>= flip decodeListN [] + TypeListLenIndef -> decodeListLenIndef >> decodeListIndefLen [] + TypeMapLen -> decodeMapLen >>= flip decodeMapN [] + TypeMapLen64 -> decodeMapLen >>= flip decodeMapN [] + TypeMapLenIndef -> decodeMapLenIndef >> decodeMapIndefLen [] + TypeTag -> do !x <- decodeTag64 + !y <- decodeATerm + return (TTagged x y) + TypeTag64 -> do !x <- decodeTag64 + !y <- decodeATerm + return (TTagged x y) + + TypeBool -> do !x <- decodeBool + return (TBool x) + TypeNull -> TNull <$ decodeNull + TypeSimple -> do !x <- decodeSimple + return (TSimple x) + TypeBreak -> fail "unexpected break" + TypeInvalid -> fail "invalid token encoding" + + +decodeBytesIndefLen :: [BS.ByteString] -> Decoder s (TermF (ATerm Offsets)) +decodeBytesIndefLen acc = do + stop <- decodeBreakOr + if stop then return $! TBytesI (LBS.fromChunks (reverse acc)) + else do !bs <- decodeBytes + decodeBytesIndefLen (bs : acc) + + +decodeStringIndefLen :: [T.Text] -> Decoder s (TermF (ATerm Offsets)) +decodeStringIndefLen acc = do + stop <- decodeBreakOr + if stop then return $! TStringI (LT.fromChunks (reverse acc)) + else do !str <- decodeString + decodeStringIndefLen (str : acc) + + +decodeListN :: Int -> [ATerm Offsets] -> Decoder s (TermF (ATerm Offsets)) +decodeListN !n acc = + case n of + 0 -> return $! TList (reverse acc) + _ -> do !t <- decodeATerm + decodeListN (n-1) (t : acc) + + +decodeListIndefLen :: [ATerm Offsets] -> Decoder s (TermF (ATerm Offsets)) +decodeListIndefLen acc = do + stop <- decodeBreakOr + if stop then return $! TListI (reverse acc) + else do !tm <- decodeATerm + decodeListIndefLen (tm : acc) + + +decodeMapN :: Int -> [(ATerm Offsets, ATerm Offsets)] -> Decoder s (TermF (ATerm Offsets)) +decodeMapN !n acc = + case n of + 0 -> return $! TMap (reverse acc) + _ -> do !tm <- decodeATerm + !tm' <- decodeATerm + decodeMapN (n-1) ((tm, tm') : acc) + + +decodeMapIndefLen :: [(ATerm Offsets, ATerm Offsets)] -> Decoder s (TermF (ATerm Offsets)) +decodeMapIndefLen acc = do + stop <- decodeBreakOr + if stop then return $! TMapI (reverse acc) + else do !tm <- decodeATerm + !tm' <- decodeATerm + decodeMapIndefLen ((tm, tm') : acc) + + +-------------------------------------------------------------------------------- +-- Converting between terms and annotated terms + + +convertTermToATerm :: Term -> ATerm () +convertTermToATerm t = ATerm (convertTermToTermF t) () + +convertTermToTermF :: Term -> TermF (ATerm ()) +convertTermToTermF (Term.TList ts) = TList (map convertTermToATerm ts) +convertTermToTermF (Term.TListI ts) = TListI (map convertTermToATerm ts) +convertTermToTermF (Term.TMap ts) = TMap [ ( convertTermToATerm x + , convertTermToATerm y ) + | (x, y) <- ts ] +convertTermToTermF (Term.TMapI ts) = TMapI [ ( convertTermToATerm x + , convertTermToATerm y ) + | (x, y) <- ts ] +convertTermToTermF (Term.TTagged x t) = TTagged x (convertTermToATerm t) + +convertTermToTermF (Term.TInt x) = TInt x +convertTermToTermF (Term.TInteger x) = TInteger x +convertTermToTermF (Term.TBytes x) = TBytes x +convertTermToTermF (Term.TBytesI x) = TBytesI x +convertTermToTermF (Term.TString x) = TString x +convertTermToTermF (Term.TStringI x) = TStringI x +convertTermToTermF (Term.TBool x) = TBool x +convertTermToTermF Term.TNull = TNull +convertTermToTermF (Term.TSimple x) = TSimple x +convertTermToTermF (Term.THalf x) = THalf x +convertTermToTermF (Term.TFloat x) = TFloat x +convertTermToTermF (Term.TDouble x) = TDouble x + +convertATermToTerm :: ATerm a -> Term +convertATermToTerm (ATerm t _ann) = convertTermFToTerm t + +convertTermFToTerm :: TermF (ATerm a) -> Term +convertTermFToTerm (TList ts) = Term.TList (map convertATermToTerm ts) +convertTermFToTerm (TListI ts) = Term.TListI (map convertATermToTerm ts) +convertTermFToTerm (TMap ts) = Term.TMap [ ( convertATermToTerm x + , convertATermToTerm y ) + | (x, y) <- ts ] +convertTermFToTerm (TMapI ts) = Term.TMapI [ ( convertATermToTerm x + , convertATermToTerm y ) + | (x, y) <- ts ] +convertTermFToTerm (TTagged x t) = Term.TTagged x (convertATermToTerm t) +convertTermFToTerm (TInt x) = Term.TInt x +convertTermFToTerm (TInteger x) = Term.TInteger x +convertTermFToTerm (TBytes x) = Term.TBytes x +convertTermFToTerm (TBytesI x) = Term.TBytesI x +convertTermFToTerm (TString x) = Term.TString x +convertTermFToTerm (TStringI x) = Term.TStringI x +convertTermFToTerm (TBool x) = Term.TBool x +convertTermFToTerm TNull = Term.TNull +convertTermFToTerm (TSimple x) = Term.TSimple x +convertTermFToTerm (THalf x) = Term.THalf x +convertTermFToTerm (TFloat x) = Term.TFloat x +convertTermFToTerm (TDouble x) = Term.TDouble x + + +-- NaNs are so annoying... +eqATerm :: Eq a => ATerm a -> ATerm a -> Bool +eqATerm (ATerm t1 ann1) (ATerm t2 ann2) = + ann1 == ann2 && eqATermF t1 t2 + +eqATermF :: Eq a => TermF (ATerm a) -> TermF (ATerm a) -> Bool +eqATermF (TList ts) (TList ts') = and (zipWith eqATerm ts ts') +eqATermF (TListI ts) (TListI ts') = and (zipWith eqATerm ts ts') +eqATermF (TMap ts) (TMap ts') = and (zipWith eqATermPair ts ts') +eqATermF (TMapI ts) (TMapI ts') = and (zipWith eqATermPair ts ts') +eqATermF (TTagged w t) (TTagged w' t') = w == w' && eqATerm t t' +eqATermF (THalf f) (THalf f') = floatToWord f == floatToWord f' +eqATermF (TFloat f) (TFloat f') = floatToWord f == floatToWord f' +eqATermF (TDouble f) (TDouble f') = doubleToWord f == doubleToWord f' +eqATermF a b = a == b + +eqATermPair :: (Eq a, Eq b) + => (ATerm a, ATerm b) + -> (ATerm a, ATerm b) + -> Bool +eqATermPair (a,b) (a',b') = eqATerm a a' && eqATerm b b' + diff --git a/tests/Tests/CBOR.hs b/tests/Tests/CBOR.hs deleted file mode 100644 --- a/tests/Tests/CBOR.hs +++ /dev/null @@ -1,284 +0,0 @@ -{-# 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/Canonical.hs b/tests/Tests/Canonical.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Canonical.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} + +module Tests.Canonical (testTree) where + +import Prelude hiding (decodeFloat, encodeFloat) + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif + +import qualified Data.ByteString.Lazy as LBS +import Data.Proxy + +import Codec.CBOR.Read (deserialiseFromBytes) +import Codec.CBOR.Decoding + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) +import Test.QuickCheck + +import Tests.Properties hiding (testTree) + + +-- | This is a version of 'prop_decodeRefdecodeImp' but where we restrict the +-- encoded input to non-canonical forms. These forms are covered by the +-- original property. This property just ensures that we have good coverage of +-- this case. +-- +prop_decode_nonCanonical :: forall t. Token t => t -> Property +prop_decode_nonCanonical x = + let enc = serialiseRef x + y = deserialiseRef t enc + y' = deserialiseImp t enc + enc' = serialiseImp t y' + isCanonical = enc == enc' + in not isCanonical ==> + -- This property holds without this pre-condition, as demonstrated by + -- prop_decodeRefdecodeImp, but using it ensures we get good coverage + -- of the non-canonical cases + y' `eq` fromRef y + + where + eq = eqImp t + t = Proxy :: Proxy t + + +-- | Check that the special checked canonical form decoder primitives work. +-- +-- We decode with the normal and canonical decoder, and check that they agree +-- in the canonical cases, and that the canonical decoder rejects the +-- non-canonical cases. +-- +-- We have a QC coverage check to make sure we are covering enough of both +-- canonical and non-canonical cases. +-- +prop_decodeCanonical :: forall t. Token t + => (forall s. Decoder s (Imp t)) + -> t -> Property +prop_decodeCanonical decodeCanonical x = + classify isCanonical "canonical" $ + case deserialiseFromBytes decodeCanonical enc of + Left _failure -> not isCanonical + Right (trailing, y') -> isCanonical + && eqImp t y y' + && LBS.null trailing + where + enc = serialiseRef x + y = deserialiseImp t enc + -- It is canonical if it re-encodes to the same bytes we decoded + isCanonical = serialiseImp t y == enc + t = Proxy :: Proxy t + + + +prop_decodeCanonical_Word :: TokWord -> Property +prop_decodeCanonical_Word = prop_decodeCanonical decodeWordCanonical + +prop_decodeCanonical_Word8 :: TokWord8 -> Property +prop_decodeCanonical_Word8 = prop_decodeCanonical decodeWord8Canonical + +prop_decodeCanonical_Word16 :: TokWord16 -> Property +prop_decodeCanonical_Word16 = prop_decodeCanonical decodeWord16Canonical + +prop_decodeCanonical_Word32 :: TokWord32 -> Property +prop_decodeCanonical_Word32 = prop_decodeCanonical decodeWord32Canonical + +prop_decodeCanonical_Word64 :: TokWord64 -> Property +prop_decodeCanonical_Word64 = prop_decodeCanonical decodeWord64Canonical + +--prop_decodeCanonical_NegWord :: TokNegWord -> Property +--prop_decodeCanonical_NegWord = prop_decodeCanonical decodeNegWordCanonical + +prop_decodeCanonical_Int :: TokInt -> Property +prop_decodeCanonical_Int = prop_decodeCanonical decodeIntCanonical + +prop_decodeCanonical_Int8 :: TokInt8 -> Property +prop_decodeCanonical_Int8 = prop_decodeCanonical decodeInt8Canonical + +prop_decodeCanonical_Int16 :: TokInt16 -> Property +prop_decodeCanonical_Int16 = prop_decodeCanonical decodeInt16Canonical + +prop_decodeCanonical_Int32 :: TokInt32 -> Property +prop_decodeCanonical_Int32 = prop_decodeCanonical decodeInt32Canonical + +prop_decodeCanonical_Int64 :: TokInt64 -> Property +prop_decodeCanonical_Int64 = prop_decodeCanonical decodeInt64Canonical + +prop_decodeCanonical_Integer :: TokInteger -> Property +prop_decodeCanonical_Integer = prop_decodeCanonical decodeIntegerCanonical + +prop_decodeCanonical_Half :: TokHalf -> Property +prop_decodeCanonical_Half = prop_decodeCanonical decodeFloat16Canonical + +prop_decodeCanonical_Float :: TokFloat -> Property +prop_decodeCanonical_Float = prop_decodeCanonical decodeFloatCanonical + +prop_decodeCanonical_Double :: TokDouble -> Property +prop_decodeCanonical_Double = prop_decodeCanonical decodeDoubleCanonical + +prop_decodeCanonical_Tag :: TokTag -> Property +prop_decodeCanonical_Tag = prop_decodeCanonical decodeTagCanonical + +prop_decodeCanonical_Tag64 :: TokTag64 -> Property +prop_decodeCanonical_Tag64 = prop_decodeCanonical decodeTag64Canonical + +prop_decodeCanonical_Simple :: Simple -> Property +prop_decodeCanonical_Simple = prop_decodeCanonical decodeSimpleCanonical + + +{- + , decodeNegWordCanonical -- :: Decoder s Word + , decodeNegWord64Canonical -- :: Decoder s Word64 + , decodeBytesCanonical -- :: Decoder s ByteString + , decodeByteArrayCanonical -- :: Decoder s ByteArray + , decodeStringCanonical -- :: Decoder s Text + , decodeUtf8ByteArrayCanonical -- :: Decoder s ByteArray + , decodeListLenCanonical -- :: Decoder s Int + , decodeMapLenCanonical -- :: Decoder s Int +-} + +-------------------------------------------------------------------------------- +-- TestTree API + +testTree :: TestTree +testTree = + testGroup "properties" + [ testGroup "decode non-canonical encoding" + [ testProperty "Word8" (prop_decode_nonCanonical :: TokWord8 -> Property) + , testProperty "Word16" (prop_decode_nonCanonical :: TokWord16 -> Property) + , testProperty "Word32" (prop_decode_nonCanonical :: TokWord32 -> Property) + , testProperty "Word64" (prop_decode_nonCanonical :: TokWord64 -> Property) + , testProperty "Word" (prop_decode_nonCanonical :: TokWord -> Property) +-- , testProperty "NegWord" (prop_decode_nonCanonical :: TokNegWord -> Property) + , testProperty "Int8" (prop_decode_nonCanonical :: TokInt8 -> Property) + , testProperty "Int16" (prop_decode_nonCanonical :: TokInt16 -> Property) + , testProperty "Int32" (prop_decode_nonCanonical :: TokInt32 -> Property) + , testProperty "Int64" (prop_decode_nonCanonical :: TokInt64 -> Property) + , testProperty "Int" (prop_decode_nonCanonical :: TokInt -> Property) + , testProperty "Integer" (prop_decode_nonCanonical :: TokInteger -> Property) + , testProperty "Half" (prop_decode_nonCanonical :: TokHalf -> Property) + , testProperty "Float" (prop_decode_nonCanonical :: TokFloat -> Property) + , testProperty "Double" (prop_decode_nonCanonical :: TokDouble -> Property) + , testProperty "Tag" (prop_decode_nonCanonical :: TokTag -> Property) + , testProperty "Tag64" (prop_decode_nonCanonical :: TokTag64 -> Property) + , testProperty "Simple" (prop_decode_nonCanonical :: Simple -> Property) + , testProperty "Term" (prop_decode_nonCanonical :: Term -> Property) + ] + + , testGroup "canonical decoding" + [ testProperty "Word" prop_decodeCanonical_Word + , testProperty "Word8" prop_decodeCanonical_Word8 + , testProperty "Word16" prop_decodeCanonical_Word16 + , testProperty "Word32" prop_decodeCanonical_Word32 + , testProperty "Word64" prop_decodeCanonical_Word64 + , testProperty "Int" prop_decodeCanonical_Int + , testProperty "Int8" prop_decodeCanonical_Int8 + , testProperty "Int16" prop_decodeCanonical_Int16 + , testProperty "Int32" prop_decodeCanonical_Int32 + , testProperty "Int64" prop_decodeCanonical_Int64 + , testProperty "Integer" prop_decodeCanonical_Integer + , testProperty "Half" prop_decodeCanonical_Half + , testProperty "Float" prop_decodeCanonical_Float + , testProperty "Double" prop_decodeCanonical_Double + , testProperty "Tag" prop_decodeCanonical_Tag + , testProperty "Tag64" prop_decodeCanonical_Tag64 + , testProperty "Simple" prop_decodeCanonical_Simple + ] + ] + diff --git a/tests/Tests/PreEncoded.hs b/tests/Tests/PreEncoded.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/PreEncoded.hs @@ -0,0 +1,95 @@ +module Tests.PreEncoded ( + testTree + ) where + +import Data.Monoid (Monoid(mconcat)) + +import Codec.CBOR.Term (Term, encodeTerm) +import Codec.CBOR.FlatTerm (FlatTerm, toFlatTerm, TermToken(..)) +import Codec.CBOR.Write (toStrictByteString, toLazyByteString) +import Codec.CBOR.Encoding (Encoding, encodePreEncoded) + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) + +import Tests.Term () -- instance Arbitrary Term +import Tests.Reference.Generators + (canonicalNaN, floatToWord, doubleToWord) + + +-- | Use 'encodePreEncoded' but with a serialised term as the bytes. +-- +encodePreEncoded' :: Term -> Encoding +encodePreEncoded' = encodePreEncoded . toStrictByteString . encodeTerm + + +prop_preEncodedTerm_sameBytes :: Term -> Bool +prop_preEncodedTerm_sameBytes t = + sameBytes + (encodeTerm t) + (encodePreEncoded' t) + + +prop_preEncodedTerm_sameTokens :: Term -> Bool +prop_preEncodedTerm_sameTokens t = + sameTokens + (encodeTerm t) + (encodePreEncoded' t) + + +prop_preEncodedTerms_sameBytes :: [(Term, Bool)] -> Bool +prop_preEncodedTerms_sameBytes ts = + sameBytes + (mconcat [ encodeTerm t | (t, _) <- ts ]) + (mconcat [ if pre then encodePreEncoded' t + else encodeTerm t + | (t, pre) <- ts ]) + +prop_preEncodedTerms_sameTokens :: [(Term, Bool)] -> Bool +prop_preEncodedTerms_sameTokens ts = + sameTokens + (mconcat [ encodeTerm t | (t, _) <- ts ]) + (mconcat [ if pre then encodePreEncoded' t + else encodeTerm t + | (t, pre) <- ts ]) + + +sameBytes :: Encoding -> Encoding -> Bool +sameBytes e1 e2 = toLazyByteString e1 == toLazyByteString e2 + +sameTokens :: Encoding -> Encoding -> Bool +sameTokens e1 e2 = canonicaliseFlatTerm (toFlatTerm e1) + `eqFlatTerm` canonicaliseFlatTerm (toFlatTerm e2) + +canonicaliseFlatTerm :: FlatTerm -> FlatTerm +canonicaliseFlatTerm = map canonicaliseTermToken + +canonicaliseTermToken :: TermToken -> TermToken +canonicaliseTermToken (TkFloat16 f) | isNaN f = TkFloat16 canonicalNaN +canonicaliseTermToken (TkFloat32 f) | isNaN f = TkFloat16 canonicalNaN +canonicaliseTermToken (TkFloat64 f) | isNaN f = TkFloat16 canonicalNaN +canonicaliseTermToken x = x + +eqFlatTerm :: FlatTerm -> FlatTerm -> Bool +eqFlatTerm x y = and (zipWith eqTermToken x y) + +-- NaNs strike again! +eqTermToken :: TermToken -> TermToken -> Bool +eqTermToken (TkFloat16 x) (TkFloat16 y) = floatToWord x == floatToWord y +eqTermToken (TkFloat32 x) (TkFloat32 y) = floatToWord x == floatToWord y +eqTermToken (TkFloat64 x) (TkFloat64 y) = doubleToWord x == doubleToWord y +eqTermToken x y = x == y + + +-------------------------------------------------------------------------------- +-- TestTree API + +testTree :: TestTree +testTree = + testGroup "pre-encoded" + [ testProperty "single term, same bytes" prop_preEncodedTerm_sameBytes + , testProperty "single term, same tokens" prop_preEncodedTerm_sameTokens + , testProperty "list terms, same bytes" prop_preEncodedTerms_sameBytes + , testProperty "list terms, same tokens" prop_preEncodedTerms_sameTokens + ] + diff --git a/tests/Tests/Properties.hs b/tests/Tests/Properties.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Properties.hs @@ -0,0 +1,1192 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DefaultSignatures #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Tests.Properties ( + testTree + + -- * Token type class and derived functions + , Token(..) + , serialiseRef + , serialiseImp + , deserialiseRef + , deserialiseImp + + -- * Various test token types + , TokInt + , TokInt8 + , TokInt16 + , TokInt32 + , TokInt64 + , TokInteger + , TokWord + , TokWord8 + , TokWord16 + , TokWord32 + , TokWord64 + , TokHalf + , TokFloat + , TokDouble + , TokTag + , TokTag64 + , Ref.Simple + , Ref.Term + ) where + +import Prelude hiding (decodeFloat, encodeFloat) + +import qualified Data.ByteString.Lazy as LBS +import Data.Word +import Data.Int +import Data.Bits (complement) +import qualified Numeric.Half as Half +import Data.Function (on) +import Data.Proxy + +import Codec.CBOR.Term +import Codec.CBOR.Read +import Codec.CBOR.Write +import Codec.CBOR.Decoding +import Codec.CBOR.Encoding + +import Test.Tasty (TestTree, testGroup, localOption) +import Test.Tasty.QuickCheck (testProperty, QuickCheckMaxSize(..)) +import Test.QuickCheck +import System.Random (Random) + +import qualified Tests.Reference.Implementation as Ref +import Tests.Reference.Implementation (UInt(..)) +import Tests.Reference.Generators +import Tests.Term + ( fromRefTerm, toRefTerm, eqTerm, canonicaliseTerm ) +import Tests.Util + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif + + +-- | The CBOR implementation and its reference implementation satisfy all the +-- properties implied in the following commuting diagram. +-- +-- The properties in this module exercise various paths throguh this diagram, +-- and do so for various different types. +-- +-- > canon id +-- > Ref──────────▶Ref───────────▶Ref +-- > │ ▲ ╲ (ref) ╱ │ +-- > │ │ ╲enc dec╱ │ +-- > │ │ ╲ ╱ │ +-- > │from to│ ▶Enc▶ │from +-- > │ │ ╱ ╲ │ +-- > │ │ ╱enc dec╲ │ +-- > ▼ │ ╱ (imp) ╲ ▼ +-- > Imp──────────▶Imp───────────▶Imp +-- > id canon +-- +-- Key +-- +-- * Imp: Implementation token type +-- * Ref: Reference token type +-- * Enc: Encoding (ie bytes) +-- * canon: canonicaliseRef or canonicaliseImp +-- * enc: encodeRef or encodeImp +-- * dec: decodeRef or decodeImp +-- +-- We capture these types and arrows with a type class and an associated type. +-- +class (Eq t, Show t) => Token t where + type Imp t :: * + + encodeImp :: Proxy t -> Imp t -> Encoding + encodeRef :: Ref.Encoder t + + decodeImp :: forall s. Proxy t -> Decoder s (Imp t) + decodeRef :: Proxy t -> Ref.Decoder t + + canonicaliseImp :: Proxy t -> Imp t -> Imp t + canonicaliseRef :: t -> t + + eqImp :: Proxy t -> Imp t -> Imp t -> Bool + + toRef :: Proxy t -> Imp t -> t + fromRef :: t -> Imp t + + -- defaults + canonicaliseImp _ = id + canonicaliseRef = toRef t . fromRef + where + t = Proxy :: Proxy t + + default eqImp :: Eq (Imp t) => Proxy t -> Imp t -> Imp t -> Bool + eqImp _ = (==) + + +-- A few derived utils + +serialiseRef :: forall t. Token t => t -> LBS.ByteString +serialiseRef = LBS.pack . encodeRef + +serialiseImp :: forall t. Token t => Proxy t -> Imp t -> LBS.ByteString +serialiseImp _ = toLazyByteString . encodeImp t + where + t = Proxy :: Proxy t + +deserialiseRef :: forall t. Token t => Proxy t -> LBS.ByteString -> t +deserialiseRef _ bytes = + case Ref.runDecoder (decodeRef t) (LBS.unpack bytes) of + Just (x, trailing) + | null trailing -> x + | otherwise -> error "deserialiseRef: trailing bytes" + Nothing -> error "deserialiseRef: decode failure" + where + t = Proxy :: Proxy t + +deserialiseImp :: forall t. Token t => Proxy t -> LBS.ByteString -> Imp t +deserialiseImp _ bytes = + case deserialiseFromBytes (decodeImp t) bytes of + Right (trailing, x) + | LBS.null trailing -> x + | otherwise -> error "deserialiseImp: trailing data" + Left _failure -> error "deserialiseImp: decode failure" + where + t = Proxy :: Proxy t + + +-------------------------------------------------------------------------------- +-- Properties +-- + + +-- | The property corresponding to the following part of the commuting diagram. +-- +-- > canon +-- > Ref──────────▶Ref . . . . . ▷. +-- > │ ▲ . . . +-- > │ │ . . . +-- > │ │ . . . +-- > │from to│ ▷ ▷ . +-- > │ │ . . . +-- > │ │ . . . +-- > ▼ │ . . ▽ +-- > Imp──────────▶Imp . . . . . ▷. +-- > id +-- +-- > to . id . from = canon_ref +-- +prop_fromRefToRef :: Token t => Proxy t -> t -> Bool +prop_fromRefToRef _ x = + + (toRef t . fromRef) x == canonicaliseRef x + + where + t = Proxy :: Proxy t + + +-- | The property corresponding to the following part of the commuting diagram. +-- +-- > id +-- > . . . . . .▷Ref───────────▶Ref +-- > . ▲ . . │ +-- > . │ . . │ +-- > . │ . . │ +-- > . to│ ▷ ▷ │from +-- > . │ . . │ +-- > . │ . . │ +-- > ▽ │ . . ▼ +-- > . . . . . .▶Imp───────────▶Imp +-- > canon +-- +-- > from . id . to = canon_imp +-- +prop_toRefFromRef :: forall t. Token t => Proxy t -> Imp t -> Bool +prop_toRefFromRef _ x = + + (fromRef . toRef t) x `eq` canonicaliseImp t x + + where + eq = eqImp t + t = Proxy :: Proxy t + + +-- | The property corresponding to the following part of the commuting diagram. +-- +-- This is a round trip property, with the reference implementation of the +-- encoder and decoder. +-- +-- > id +-- > . . . . . .▷Ref───────────▶Ref +-- > . △ ╲ ╱ . +-- > . . ╲enc dec╱ . +-- > . . ╲ ╱ . +-- > . . ▶Enc▶ . +-- > . . . . . +-- > . . . . . +-- > ▽ . . . ▽ +-- > . . . . . . ▷.. . . . . . ▷. +-- +-- > dec_ref . enc_ref = id +-- +prop_encodeRefdecodeRef :: forall t. Token t => Proxy t -> t -> Bool +prop_encodeRefdecodeRef _ x = + + (deserialiseRef t . serialiseRef) x == x + + where + t = Proxy :: Proxy t + + +-- | The property corresponding to the following part of the commuting diagram. +-- +-- This is a round trip property, with the production implementation of the +-- encoder and decoder. +-- +-- > . . . . . . ▷. . . . . . .▷. +-- > . △ . . . +-- > . . . . . +-- > . . . . . +-- > . . ▶Enc▶ . +-- > . . ╱ ╲ . +-- > . . ╱enc dec╲ . +-- > ▽ . ╱ ╲ ▽ +-- > . . . . . .▷Imp───────────▶Imp +-- > canon +-- +-- > dec_imp . enc_imp = canon_imp +-- +prop_encodeImpdecodeImp :: forall t. Token t => Proxy t -> Imp t -> Bool +prop_encodeImpdecodeImp _ x = + + (deserialiseImp t . serialiseImp t) x `eq` canonicaliseImp t x + + where + eq = eqImp t + t = Proxy :: Proxy t + + +-- | This is the same property as 'prop_encodeImpdecodeImp' but the encoded +-- data is split into two chunks provided as input into the decoder. All +-- possible 2-chunk splits are tried. This checks that the decoder gives the +-- same result irrespective of the chunk boundaries. +-- +prop_encodeImpdecodeImp_splits2 :: forall t. Token t => Proxy t -> Imp t -> Bool +prop_encodeImpdecodeImp_splits2 _ x = + and [ deserialiseImp t enc' `eq` x' + | let enc = serialiseImp t x + x' = canonicaliseImp t x + , enc' <- splits2 enc ] + where + eq = eqImp t + t = Proxy :: Proxy t + + +-- | This is the same idea as 'prop_encodeImpdecodeImp_splits2' but with all +-- possible 3-chunk splits of the input data. This test is of course more +-- expensive and so the size of the input must be limited. +-- +prop_encodeImpdecodeImp_splits3 :: forall t. Token t => Proxy t -> Imp t -> Bool +prop_encodeImpdecodeImp_splits3 _ x = + and [ deserialiseImp t enc' `eq` x' + | let enc = serialiseImp t x + x' = canonicaliseImp t x + , enc' <- splits3 enc ] + where + eq = eqImp t + t = Proxy :: Proxy t + + +-- | The property corresponding to the following part of the commuting diagram. +-- +-- This checks that the reference and real implementation produce the same +-- encoded bytes. It starts from a value in the reference implementation. +-- +-- > canon +-- > Ref──────────▶Ref . . . . . ▷. +-- > │ △ ╲ . . +-- > │ . ╲enc . . +-- > │ . ╲ . . +-- > │from . ▶Enc▷ . +-- > │ . ╱ . . +-- > │ . ╱enc . . +-- > ▼ . ╱ . ▽ +-- > Imp──────────▶Imp . . . . . ▷. +-- > id +-- +-- > enc_imp . id . from = enc_ref . canon_ref +-- +prop_encodeRefencodeImp1 :: forall t. Token t => Proxy t -> t -> Bool +prop_encodeRefencodeImp1 _ x = + + (serialiseImp t . fromRef) x == (serialiseRef . canonicaliseRef) x + + where + t = Proxy :: Proxy t + + +-- | The property corresponding to the following part of the commuting diagram. +-- +-- This checks that the reference and real implementation produce the same +-- encoded bytes. It starts from a value in the real implementation. +-- +-- > . . . . . .▷Ref . . . . . ▷. +-- > . ▲ ╲ . . +-- > . │ ╲enc . . +-- > . │ ╲ . . +-- > . to│ ▶Enc▷ . +-- > . │ ╱ . . +-- > . │ ╱enc . . +-- > ▽ │ ╱ . ▽ +-- > . . . . . .▷Imp . . . . . ▷. +-- +-- > enc_ref . id . to = enc_imp +-- +prop_encodeRefencodeImp2 :: forall t. Token t => Proxy t -> Imp t -> Bool +prop_encodeRefencodeImp2 _ x = + + (serialiseRef . toRef t) x == serialiseImp t x + + where + t = Proxy :: Proxy t + + +-- | The property corresponding to the following part of the commuting diagram. +-- +-- This checks that starting from the same encoding, the reference and real +-- implementation deserialise to equivalent values. +-- +-- > . . . . . .▷Ref . . . . . ▶Ref +-- > . △ ╲ ╱ │ +-- > . . ╲enc dec╱ │ +-- > . . ╲ ╱ │ +-- > . . ▶Enc▶ │from +-- > . . . ╲ │ +-- > . . . dec╲ │ +-- > ▽ . . ╲ ▼ +-- > . . . . . . ▷.. . . . . . ▶Imp +-- +-- > dec_imp . enc_ref = from . dec_ref . enc_ref +-- +prop_decodeRefdecodeImp :: forall t. Token t => Proxy t -> t -> Bool +prop_decodeRefdecodeImp _ x = + + deserialiseImp t enc `eq` (fromRef . deserialiseRef t) enc + + where + enc = serialiseRef x + eq = eqImp t + t = Proxy :: Proxy t + + +-------------------------------------------------------------------------------- +-- Token class instances for unsigned types +-- + +newtype TokWord8 = TokWord8 { unTokWord8 :: UInt } + deriving (Eq, Show) + +instance Token TokWord8 where + type Imp TokWord8 = Word8 + + fromRef = fromIntegral . Ref.fromUInt . unTokWord8 + toRef _ = TokWord8 . Ref.toUInt . fromIntegral + + encodeImp _ = encodeWord8 + decodeImp _ = decodeWord8 + + encodeRef (TokWord8 n) = Ref.encodeToken (Ref.MT0_UnsignedInt n) + decodeRef _ = do Ref.MT0_UnsignedInt n <- Ref.decodeToken + return (TokWord8 n) + +instance Arbitrary TokWord8 where + arbitrary = TokWord8 <$> oneof arbitraryUInt_Word8 + +arbitraryUInt_Word8 :: [Gen UInt] +arbitraryUInt_Word8 = [ UIntSmall <$> arbitrarySmall + , UInt8 <$> arbitrarySmall + , UInt8 <$> arbitraryUInt8 + ] + + +newtype TokWord16 = TokWord16 { unTokWord16 :: UInt } + deriving (Eq, Show) + +instance Token TokWord16 where + type Imp TokWord16 = Word16 + + fromRef = fromIntegral . Ref.fromUInt . unTokWord16 + toRef _ = TokWord16 . Ref.toUInt . fromIntegral + + encodeImp _ = encodeWord16 + decodeImp _ = decodeWord16 + + encodeRef (TokWord16 n) = Ref.encodeToken (Ref.MT0_UnsignedInt n) + decodeRef _ = do Ref.MT0_UnsignedInt n <- Ref.decodeToken + return (TokWord16 n) + +instance Arbitrary TokWord16 where + arbitrary = TokWord16 <$> oneof arbitraryUInt_Word16 + +arbitraryUInt_Word16 :: [Gen UInt] +arbitraryUInt_Word16 = arbitraryUInt_Word8 + ++ [ UInt16 <$> arbitrarySmall + , UInt16 <$> arbitraryUInt8 + , UInt16 <$> arbitraryUInt16 + ] + + +newtype TokWord32 = TokWord32 { unTokWord32 :: UInt } + deriving (Eq, Show) + +instance Token TokWord32 where + type Imp TokWord32 = Word32 + + fromRef = fromIntegral . Ref.fromUInt . unTokWord32 + toRef _ = TokWord32 . Ref.toUInt . fromIntegral + + encodeImp _ = encodeWord32 + decodeImp _ = decodeWord32 + + encodeRef (TokWord32 n) = Ref.encodeToken (Ref.MT0_UnsignedInt n) + decodeRef _ = do Ref.MT0_UnsignedInt n <- Ref.decodeToken + return (TokWord32 n) + +instance Arbitrary TokWord32 where + arbitrary = TokWord32 <$> oneof arbitraryUInt_Word32 + +arbitraryUInt_Word32 :: [Gen UInt] +arbitraryUInt_Word32 = arbitraryUInt_Word16 + ++ [ UInt32 <$> arbitrarySmall + , UInt32 <$> arbitraryUInt8 + , UInt32 <$> arbitraryUInt16 + , UInt32 <$> arbitraryUInt32 + ] + +newtype TokWord64 = TokWord64 { unTokWord64 :: UInt } + deriving (Eq, Show) + +instance Token TokWord64 where + type Imp TokWord64 = Word64 + + fromRef = fromIntegral . Ref.fromUInt . unTokWord64 + toRef _ = TokWord64 . Ref.toUInt . fromIntegral + + encodeImp _ = encodeWord64 + decodeImp _ = decodeWord64 + + encodeRef (TokWord64 n) = Ref.encodeToken (Ref.MT0_UnsignedInt n) + decodeRef _ = do Ref.MT0_UnsignedInt n <- Ref.decodeToken + return (TokWord64 n) + +instance Arbitrary TokWord64 where + arbitrary = TokWord64 <$> oneof arbitraryUInt_Word64 + +arbitraryUInt_Word64 :: [Gen UInt] +arbitraryUInt_Word64 = arbitraryUInt_Word32 + ++ [ UInt64 <$> arbitrarySmall + , UInt64 <$> arbitraryUInt8 + , UInt64 <$> arbitraryUInt16 + , UInt64 <$> arbitraryUInt32 + , UInt64 <$> arbitraryUInt64 + ] + + +newtype TokWord = TokWord { unTokWord :: UInt } + deriving (Eq, Show) + +instance Arbitrary TokWord where + arbitrary = TokWord <$> oneof arbitraryUInt_Word + +arbitraryUInt_Word :: [Gen UInt] +arbitraryUInt_Word = arbitraryUInt_Word32 + ++ [ UInt64 <$> arbitrarySmall + , UInt64 <$> arbitraryUInt8 + , UInt64 <$> arbitraryUInt16 + , UInt64 <$> arbitraryUInt32 +#if defined(ARCH_64bit) + , UInt64 <$> arbitraryUInt64 +#endif + ] + +instance Token TokWord where + type Imp TokWord = Word + + fromRef = fromIntegral . Ref.fromUInt . unTokWord + toRef _ = TokWord . Ref.toUInt . fromIntegral + + encodeImp _ = encodeWord + decodeImp _ = decodeWord + + encodeRef (TokWord n) = Ref.encodeToken (Ref.MT0_UnsignedInt n) + decodeRef _ = do Ref.MT0_UnsignedInt n <- Ref.decodeToken + return (TokWord n) + + +-------------------------------------------------------------------------------- +-- Token class instances for signed types +-- + + +data TokInt8 = TokInt8 Bool UInt + deriving (Eq, Show) + +instance Token TokInt8 where + type Imp TokInt8 = Int8 + + fromRef (TokInt8 True n) = (fromIntegral . Ref.fromUInt) n + fromRef (TokInt8 False n) = (complement . fromIntegral . Ref.fromUInt) n + toRef _ n + | n >= 0 = TokInt8 True ((Ref.toUInt . fromIntegral) n) + | otherwise = TokInt8 False ((Ref.toUInt . fromIntegral . complement) n) + + encodeImp _ = encodeInt8 + decodeImp _ = decodeInt8 + + encodeRef (TokInt8 True n) = Ref.encodeToken (Ref.MT0_UnsignedInt n) + encodeRef (TokInt8 False n) = Ref.encodeToken (Ref.MT1_NegativeInt n) + + decodeRef _ = do + tok <- Ref.decodeToken + case tok of + Ref.MT0_UnsignedInt n -> return (TokInt8 True n) + Ref.MT1_NegativeInt n -> return (TokInt8 False n) + _ -> fail "decodeRef (TokInt)" + +instance Arbitrary TokInt8 where + arbitrary = TokInt8 <$> arbitrary <*> oneof arbitraryUInt_Int8 + shrink (TokInt8 sign n) = [ TokInt8 sign' n' + | (sign', n') <- shrink (sign, n) ] + +arbitraryUInt_Int8 :: [Gen UInt] +arbitraryUInt_Int8 = [ UIntSmall <$> arbitrarySmall + , UInt8 <$> arbitrarySmall + , UInt8 <$> arbitraryUInt7 + ] + + +data TokInt16 = TokInt16 Bool UInt + deriving (Eq, Show) + +instance Token TokInt16 where + type Imp TokInt16 = Int16 + + fromRef (TokInt16 True n) = (fromIntegral . Ref.fromUInt) n + fromRef (TokInt16 False n) = (complement . fromIntegral . Ref.fromUInt) n + toRef _ n + | n >= 0 = TokInt16 True ((Ref.toUInt . fromIntegral) n) + | otherwise = TokInt16 False ((Ref.toUInt . fromIntegral . complement) n) + + encodeImp _ = encodeInt16 + decodeImp _ = decodeInt16 + + encodeRef (TokInt16 True n) = Ref.encodeToken (Ref.MT0_UnsignedInt n) + encodeRef (TokInt16 False n) = Ref.encodeToken (Ref.MT1_NegativeInt n) + + decodeRef _ = do + tok <- Ref.decodeToken + case tok of + Ref.MT0_UnsignedInt n -> return (TokInt16 True n) + Ref.MT1_NegativeInt n -> return (TokInt16 False n) + _ -> fail "decodeRef (TokInt16)" + + +instance Arbitrary TokInt16 where + arbitrary = TokInt16 <$> arbitrary <*> oneof arbitraryUInt_Int16 + +arbitraryUInt_Int16 :: [Gen UInt] +arbitraryUInt_Int16 = arbitraryUInt_Int8 + ++ [ UInt16 <$> arbitrarySmall + , UInt16 <$> arbitraryUInt7 + , UInt16 <$> arbitraryUInt15 + ] + + +data TokInt32 = TokInt32 Bool UInt + deriving (Eq, Show) + +instance Token TokInt32 where + type Imp TokInt32 = Int32 + + fromRef (TokInt32 True n) = (fromIntegral . Ref.fromUInt) n + fromRef (TokInt32 False n) = (complement . fromIntegral . Ref.fromUInt) n + toRef _ n + | n >= 0 = TokInt32 True ((Ref.toUInt . fromIntegral) n) + | otherwise = TokInt32 False ((Ref.toUInt . fromIntegral . complement) n) + + encodeImp _ = encodeInt32 + decodeImp _ = decodeInt32 + + encodeRef (TokInt32 True n) = Ref.encodeToken (Ref.MT0_UnsignedInt n) + encodeRef (TokInt32 False n) = Ref.encodeToken (Ref.MT1_NegativeInt n) + + decodeRef _ = do + tok <- Ref.decodeToken + case tok of + Ref.MT0_UnsignedInt n -> return (TokInt32 True n) + Ref.MT1_NegativeInt n -> return (TokInt32 False n) + _ -> fail "decodeRef (TokInt32)" + +instance Arbitrary TokInt32 where + arbitrary = TokInt32 <$> arbitrary <*> oneof arbitraryUInt_Int32 + +arbitraryUInt_Int32 :: [Gen UInt] +arbitraryUInt_Int32 = arbitraryUInt_Int16 + ++ [ UInt32 <$> arbitrarySmall + , UInt32 <$> arbitraryUInt7 + , UInt32 <$> arbitraryUInt15 + , UInt32 <$> arbitraryUInt31 + ] + + +data TokInt64 = TokInt64 Bool UInt + deriving (Eq, Show) + +instance Token TokInt64 where + type Imp TokInt64 = Int64 + + fromRef (TokInt64 True n) = (fromIntegral . Ref.fromUInt) n + fromRef (TokInt64 False n) = (complement . fromIntegral . Ref.fromUInt) n + toRef _ n + | n >= 0 = TokInt64 True ((Ref.toUInt . fromIntegral) n) + | otherwise = TokInt64 False ((Ref.toUInt . fromIntegral . complement) n) + + encodeImp _ = encodeInt64 + decodeImp _ = decodeInt64 + + encodeRef (TokInt64 True n) = Ref.encodeToken (Ref.MT0_UnsignedInt n) + encodeRef (TokInt64 False n) = Ref.encodeToken (Ref.MT1_NegativeInt n) + + decodeRef _ = do + tok <- Ref.decodeToken + case tok of + Ref.MT0_UnsignedInt n -> return (TokInt64 True n) + Ref.MT1_NegativeInt n -> return (TokInt64 False n) + _ -> fail "decodeRef (TokInt64)" + +instance Arbitrary TokInt64 where + arbitrary = TokInt64 <$> arbitrary <*> oneof arbitraryUInt_Int64 + +arbitraryUInt_Int64 :: [Gen UInt] +arbitraryUInt_Int64 = arbitraryUInt_Int32 + ++ [ UInt64 <$> arbitrarySmall + , UInt64 <$> arbitraryUInt7 + , UInt64 <$> arbitraryUInt15 + , UInt64 <$> arbitraryUInt31 + , UInt64 <$> arbitraryUInt63 + ] + + +data TokInt = TokInt Bool UInt + deriving (Eq, Show) + +instance Token TokInt where + type Imp TokInt = Int + + fromRef (TokInt True n) = (fromIntegral . Ref.fromUInt) n + fromRef (TokInt False n) = (complement . fromIntegral . Ref.fromUInt) n + toRef _ n + | n >= 0 = TokInt True ((Ref.toUInt . fromIntegral) n) + | otherwise = TokInt False ((Ref.toUInt . fromIntegral . complement) n) + + encodeImp _ = encodeInt + decodeImp _ = decodeInt + + encodeRef (TokInt True n) = Ref.encodeToken (Ref.MT0_UnsignedInt n) + encodeRef (TokInt False n) = Ref.encodeToken (Ref.MT1_NegativeInt n) + + decodeRef _ = do + tok <- Ref.decodeToken + case tok of + Ref.MT0_UnsignedInt n -> return (TokInt True n) + Ref.MT1_NegativeInt n -> return (TokInt False n) + _ -> fail "decodeRef (TokInt)" + +instance Arbitrary TokInt where + arbitrary = TokInt <$> arbitrary <*> oneof arbitraryUInt_Int + +arbitraryUInt_Int :: [Gen UInt] +arbitraryUInt_Int = arbitraryUInt_Int32 + ++ [ UInt64 <$> arbitrarySmall + , UInt64 <$> arbitraryUInt7 + , UInt64 <$> arbitraryUInt15 + , UInt64 <$> arbitraryUInt31 +#if defined(ARCH_64bit) + , UInt64 <$> arbitraryUInt63 +#endif + ] + + +data TokInteger = TokIntegerUInt UInt + | TokIntegerNInt UInt + | TokIntegerBig LargeInteger + deriving (Eq, Show) + +instance Arbitrary TokInteger where + arbitrary = oneof [ TokIntegerUInt <$> arbitrary + , TokIntegerNInt <$> arbitrary + , TokIntegerBig <$> arbitrary + ] + + +instance Token TokInteger where + type Imp TokInteger = Integer + + fromRef (TokIntegerUInt n) = (fromIntegral . Ref.fromUInt) n + fromRef (TokIntegerNInt n) = (complement . fromIntegral . Ref.fromUInt) n + fromRef (TokIntegerBig n) = getLargeInteger n + + toRef _ n + | n >= 0 && n <= fromIntegral (maxBound :: Word64) + = TokIntegerUInt ((Ref.toUInt . fromIntegral) n) + + | n < 0 && complement n <= fromIntegral (maxBound :: Word64) + = TokIntegerNInt ((Ref.toUInt . fromIntegral . complement) n) + + | otherwise = TokIntegerBig (LargeInteger n) + + encodeImp _ = encodeInteger + decodeImp _ = decodeInteger + + encodeRef (TokIntegerUInt n) = Ref.encodeToken (Ref.MT0_UnsignedInt n) + encodeRef (TokIntegerNInt n) = Ref.encodeToken (Ref.MT1_NegativeInt n) + encodeRef (TokIntegerBig n) = Ref.encodeTerm (Ref.TBigInt (getLargeInteger n)) + + decodeRef _ = do + tok <- Ref.decodeToken + case tok of + Ref.MT0_UnsignedInt n -> return (TokIntegerUInt n) + Ref.MT1_NegativeInt n -> return (TokIntegerNInt n) + Ref.MT6_Tag tag -> do Ref.TBigInt n <- Ref.decodeTagged tag + return (TokIntegerBig (LargeInteger n)) + _ -> fail "decodeRef (TokInteger)" + + +-------------------------------------------------------------------------------- +-- Arbitrary helpers for integer types +-- + +arbitrarySmall, + arbitraryUInt8, arbitraryUInt16, arbitraryUInt32, arbitraryUInt64, + arbitraryUInt7, arbitraryUInt15, arbitraryUInt31, arbitraryUInt63 + :: (Num n, Random n) => Gen n + +arbitrarySmall = chooseZeroToBound (23 :: Word) +arbitraryUInt8 = chooseZeroToBound (maxBound :: Word8) +arbitraryUInt16 = chooseZeroToBound (maxBound :: Word16) +arbitraryUInt32 = chooseZeroToBound (maxBound :: Word32) +arbitraryUInt64 = chooseZeroToBound (maxBound :: Word64) + +arbitraryUInt7 = chooseZeroToBound (maxBound :: Int8) +arbitraryUInt15 = chooseZeroToBound (maxBound :: Int16) +arbitraryUInt31 = chooseZeroToBound (maxBound :: Int32) +arbitraryUInt63 = chooseZeroToBound (maxBound :: Int64) + +chooseZeroToBound :: (Num a, Random a, Integral a1) => a1 -> Gen a +chooseZeroToBound bound = + frequency [ (9, choose (0, bound')) + , (1, pure bound') ] + where + bound' = fromIntegral bound + + +-------------------------------------------------------------------------------- +-- Token class instances for floating point types +-- + +data TokHalf = TokHalf HalfSpecials + deriving (Eq, Show) + +instance Arbitrary TokHalf where + arbitrary = TokHalf <$> arbitrary + +instance Token TokHalf where + type Imp TokHalf = Float + + eqImp _ = (==) `on` floatToWord + + fromRef (TokHalf (HalfSpecials n)) = Half.fromHalf n + toRef _ = TokHalf + . canonicaliseNaN + . HalfSpecials + . Half.toHalf + + canonicaliseImp _ = Half.fromHalf + . canonicaliseNaN + . Half.toHalf + canonicaliseRef (TokHalf n) = TokHalf (canonicaliseNaN n) + + encodeImp _ = encodeFloat16 + decodeImp _ = decodeFloat + + encodeRef (TokHalf n) = Ref.encodeToken (Ref.MT7_Float16 n) + decodeRef _ = do Ref.MT7_Float16 n <- Ref.decodeToken + return (TokHalf n) + +data TokFloat = TokFloat FloatSpecials + | TokFloatNan + deriving (Eq, Show) + +instance Arbitrary TokFloat where + arbitrary = frequency [(19, TokFloat <$> arbitrary), (1, pure TokFloatNan)] + +instance Token TokFloat where + type Imp TokFloat = Float + + eqImp _ = (==) `on` floatToWord + + fromRef (TokFloat n) = getFloatSpecials n + fromRef TokFloatNan = canonicalNaN + toRef _ n + | isNaN n = TokFloatNan + | otherwise = TokFloat (FloatSpecials n) + + canonicaliseImp _ = canonicaliseNaN + + canonicaliseRef TokFloatNan = TokFloatNan + canonicaliseRef (TokFloat (FloatSpecials n)) + | isNaN n = TokFloatNan + | otherwise = TokFloat (FloatSpecials n) + + encodeImp _ = encodeFloat + decodeImp _ = decodeFloat + + encodeRef (TokFloat n) = Ref.encodeToken (Ref.MT7_Float32 n) + encodeRef TokFloatNan = Ref.encodeToken (Ref.MT7_Float16 canonicalNaN) + + decodeRef _ = do + tok <- Ref.decodeToken + case tok of + Ref.MT7_Float16 n | isNaN n + -> return TokFloatNan + Ref.MT7_Float32 n -> return (TokFloat n) + _ -> fail "decodeRef (TokFloat)" + + +data TokDouble = TokDouble DoubleSpecials + | TokDoubleNan + deriving (Eq, Show) + +instance Arbitrary TokDouble where + arbitrary = frequency [(19, TokDouble <$> arbitrary), (1, pure TokDoubleNan)] + +instance Token TokDouble where + type Imp TokDouble = Double + + eqImp _ = (==) `on` doubleToWord + + fromRef (TokDouble n) = getDoubleSpecials n + fromRef TokDoubleNan = canonicalNaN + toRef _ n + | isNaN n = TokDoubleNan + | otherwise = TokDouble (DoubleSpecials n) + + canonicaliseImp _ = canonicaliseNaN + canonicaliseRef TokDoubleNan = TokDoubleNan + canonicaliseRef (TokDouble (DoubleSpecials n)) + | isNaN n = TokDoubleNan + | otherwise = TokDouble (DoubleSpecials n) + + encodeImp _ = encodeDouble + decodeImp _ = decodeDouble + + encodeRef (TokDouble n) = Ref.encodeToken (Ref.MT7_Float64 n) + encodeRef TokDoubleNan = Ref.encodeToken (Ref.MT7_Float16 canonicalNaN) + + decodeRef _ = do + tok <- Ref.decodeToken + case tok of + Ref.MT7_Float16 n | isNaN n + -> return TokDoubleNan + Ref.MT7_Float64 n -> return (TokDouble n) + _ -> fail "decodeRef (TokDouble)" + + +-------------------------------------------------------------------------------- +-- Miscelaneous token class instances +-- + +data TokTag = TokTag { unTokTag :: UInt } + deriving (Eq, Show) + +instance Arbitrary TokTag where + arbitrary = TokTag <$> oneof arbitraryUInt_Word + +instance Token TokTag where + type Imp TokTag = Word + + fromRef = fromIntegral . Ref.fromUInt . unTokTag + toRef _ = TokTag . Ref.toUInt . fromIntegral + + encodeImp _ = encodeTag + decodeImp _ = decodeTag + + encodeRef (TokTag n) = Ref.encodeToken (Ref.MT6_Tag n) + decodeRef _ = do Ref.MT6_Tag n <- Ref.decodeToken + return (TokTag n) + + +data TokTag64 = TokTag64 { unTokTag64 :: UInt } + deriving (Eq, Show) + +instance Arbitrary TokTag64 where + arbitrary = TokTag64 <$> oneof arbitraryUInt_Word64 + +instance Token TokTag64 where + type Imp TokTag64 = Word64 + + fromRef = fromIntegral . Ref.fromUInt . unTokTag64 + toRef _ = TokTag64 . Ref.toUInt . fromIntegral + + encodeImp _ = encodeTag64 + decodeImp _ = decodeTag64 + + encodeRef (TokTag64 n) = Ref.encodeToken (Ref.MT6_Tag n) + decodeRef _ = do Ref.MT6_Tag n <- Ref.decodeToken + return (TokTag64 n) + + + +instance Token Ref.Simple where + type Imp Ref.Simple = Word8 + + fromRef = Ref.fromSimple + toRef _ = Ref.toSimple + + encodeImp _ = encodeSimple + decodeImp _ = decodeSimple + + encodeRef n = Ref.encodeToken (Ref.MT7_Simple n) + decodeRef _ = do Ref.MT7_Simple n <- Ref.decodeToken + return n + + +-------------------------------------------------------------------------------- +-- Token class instances for Term type +-- + +instance Token Ref.Term where + type Imp Ref.Term = Term + + eqImp _ = eqTerm + + fromRef = fromRefTerm + toRef _ = toRefTerm + + canonicaliseImp _ = canonicaliseTerm + canonicaliseRef = Ref.canonicaliseTerm + + encodeImp _ = encodeTerm + decodeImp _ = decodeTerm + + encodeRef = Ref.encodeTerm + decodeRef _ = Ref.decodeTerm + + +-------------------------------------------------------------------------------- +-- TestTree API + +testTree :: TestTree +testTree = + testGroup "properties" + [ testGroup "to . id . from = canon_ref" + [ testProperty "Word8" (prop_fromRefToRef (Proxy :: Proxy TokWord8)) + , testProperty "Word16" (prop_fromRefToRef (Proxy :: Proxy TokWord16)) + , testProperty "Word32" (prop_fromRefToRef (Proxy :: Proxy TokWord32)) + , testProperty "Word64" (prop_fromRefToRef (Proxy :: Proxy TokWord64)) + , testProperty "Word" (prop_fromRefToRef (Proxy :: Proxy TokWord)) +-- , testProperty "NegWord" (prop_fromRefToRef (Proxy :: Proxy TokNegWord)) + , testProperty "Int8" (prop_fromRefToRef (Proxy :: Proxy TokInt8)) + , testProperty "Int16" (prop_fromRefToRef (Proxy :: Proxy TokInt16)) + , testProperty "Int32" (prop_fromRefToRef (Proxy :: Proxy TokInt32)) + , testProperty "Int64" (prop_fromRefToRef (Proxy :: Proxy TokInt64)) + , testProperty "Int" (prop_fromRefToRef (Proxy :: Proxy TokInt)) + , testProperty "Integer" (prop_fromRefToRef (Proxy :: Proxy TokInteger)) + , testProperty "Half" (prop_fromRefToRef (Proxy :: Proxy TokHalf)) + , testProperty "Float" (prop_fromRefToRef (Proxy :: Proxy TokFloat)) + , testProperty "Double" (prop_fromRefToRef (Proxy :: Proxy TokDouble)) + , testProperty "Tag" (prop_fromRefToRef (Proxy :: Proxy TokTag)) + , testProperty "Tag64" (prop_fromRefToRef (Proxy :: Proxy TokTag64)) + , testProperty "Simple" (prop_fromRefToRef (Proxy :: Proxy Ref.Simple)) + , testProperty "Term" (prop_fromRefToRef (Proxy :: Proxy Ref.Term)) + ] + + , testGroup "from . id . to = canon_imp" + [ testProperty "Word8" (prop_toRefFromRef (Proxy :: Proxy TokWord8)) + , testProperty "Word16" (prop_toRefFromRef (Proxy :: Proxy TokWord16)) + , testProperty "Word32" (prop_toRefFromRef (Proxy :: Proxy TokWord32)) + , testProperty "Word64" (prop_toRefFromRef (Proxy :: Proxy TokWord64)) + , testProperty "Word" (prop_toRefFromRef (Proxy :: Proxy TokWord)) +-- , testProperty "NegWord" (prop_toRefFromRef (Proxy :: Proxy TokNegWord)) + , testProperty "Int8" (prop_toRefFromRef (Proxy :: Proxy TokInt8)) + , testProperty "Int16" (prop_toRefFromRef (Proxy :: Proxy TokInt16)) + , testProperty "Int32" (prop_toRefFromRef (Proxy :: Proxy TokInt32)) + , testProperty "Int64" (prop_toRefFromRef (Proxy :: Proxy TokInt64)) + , testProperty "Int" (prop_toRefFromRef (Proxy :: Proxy TokInt)) + , testProperty "Integer" (prop_toRefFromRef (Proxy :: Proxy TokInteger)) + , testProperty "Half" (prop_toRefFromRef (Proxy :: Proxy TokHalf)) + , testProperty "Float" (prop_toRefFromRef (Proxy :: Proxy TokFloat)) + , testProperty "Double" (prop_toRefFromRef (Proxy :: Proxy TokDouble)) + , testProperty "Tag" (prop_toRefFromRef (Proxy :: Proxy TokTag)) + , testProperty "Tag64" (prop_toRefFromRef (Proxy :: Proxy TokTag64)) + , testProperty "Simple" (prop_toRefFromRef (Proxy :: Proxy Ref.Simple)) + , testProperty "Term" (prop_toRefFromRef (Proxy :: Proxy Ref.Term)) + ] + + , testGroup "dec_ref . enc_ref = id" + [ testProperty "Word8" (prop_encodeRefdecodeRef (Proxy :: Proxy TokWord8)) + , testProperty "Word16" (prop_encodeRefdecodeRef (Proxy :: Proxy TokWord16)) + , testProperty "Word32" (prop_encodeRefdecodeRef (Proxy :: Proxy TokWord32)) + , testProperty "Word64" (prop_encodeRefdecodeRef (Proxy :: Proxy TokWord64)) + , testProperty "Word" (prop_encodeRefdecodeRef (Proxy :: Proxy TokWord)) +-- , testProperty "NegWord" (prop_encodeRefdecodeRef (Proxy :: Proxy TokNegWord)) + , testProperty "Int8" (prop_encodeRefdecodeRef (Proxy :: Proxy TokInt8)) + , testProperty "Int16" (prop_encodeRefdecodeRef (Proxy :: Proxy TokInt16)) + , testProperty "Int32" (prop_encodeRefdecodeRef (Proxy :: Proxy TokInt32)) + , testProperty "Int64" (prop_encodeRefdecodeRef (Proxy :: Proxy TokInt64)) + , testProperty "Int" (prop_encodeRefdecodeRef (Proxy :: Proxy TokInt)) + , testProperty "Integer" (prop_encodeRefdecodeRef (Proxy :: Proxy TokInteger)) + , testProperty "Half" (prop_encodeRefdecodeRef (Proxy :: Proxy TokHalf)) + , testProperty "Float" (prop_encodeRefdecodeRef (Proxy :: Proxy TokFloat)) + , testProperty "Double" (prop_encodeRefdecodeRef (Proxy :: Proxy TokDouble)) + , testProperty "Tag" (prop_encodeRefdecodeRef (Proxy :: Proxy TokTag)) + , testProperty "Tag64" (prop_encodeRefdecodeRef (Proxy :: Proxy TokTag64)) + , testProperty "Simple" (prop_encodeRefdecodeRef (Proxy :: Proxy Ref.Simple)) + , testProperty "Term" (prop_encodeRefdecodeRef (Proxy :: Proxy Ref.Term)) + ] + + , testGroup "dec_imp . enc_imp = canon_imp" + [ testProperty "Word8" (prop_encodeImpdecodeImp (Proxy :: Proxy TokWord8)) + , testProperty "Word16" (prop_encodeImpdecodeImp (Proxy :: Proxy TokWord16)) + , testProperty "Word32" (prop_encodeImpdecodeImp (Proxy :: Proxy TokWord32)) + , testProperty "Word64" (prop_encodeImpdecodeImp (Proxy :: Proxy TokWord64)) + , testProperty "Word" (prop_encodeImpdecodeImp (Proxy :: Proxy TokWord)) +-- , testProperty "NegWord" (prop_encodeImpdecodeImp (Proxy :: Proxy TokNegWord)) + , testProperty "Int8" (prop_encodeImpdecodeImp (Proxy :: Proxy TokInt8)) + , testProperty "Int16" (prop_encodeImpdecodeImp (Proxy :: Proxy TokInt16)) + , testProperty "Int32" (prop_encodeImpdecodeImp (Proxy :: Proxy TokInt32)) + , testProperty "Int64" (prop_encodeImpdecodeImp (Proxy :: Proxy TokInt64)) + , testProperty "Int" (prop_encodeImpdecodeImp (Proxy :: Proxy TokInt)) + , testProperty "Integer" (prop_encodeImpdecodeImp (Proxy :: Proxy TokInteger)) + , testProperty "Half" (prop_encodeImpdecodeImp (Proxy :: Proxy TokHalf)) + , testProperty "Float" (prop_encodeImpdecodeImp (Proxy :: Proxy TokFloat)) + , testProperty "Double" (prop_encodeImpdecodeImp (Proxy :: Proxy TokDouble)) + , testProperty "Tag" (prop_encodeImpdecodeImp (Proxy :: Proxy TokTag)) + , testProperty "Tag64" (prop_encodeImpdecodeImp (Proxy :: Proxy TokTag64)) + , testProperty "Simple" (prop_encodeImpdecodeImp (Proxy :: Proxy Ref.Simple)) + , testProperty "Term" (prop_encodeImpdecodeImp (Proxy :: Proxy Ref.Term)) + ] + + , testGroup "dec_imp . enc_imp = canon_imp (all 2-splits)" + [ testProperty "Word8" (prop_encodeImpdecodeImp_splits2 (Proxy :: Proxy TokWord8)) + , testProperty "Word16" (prop_encodeImpdecodeImp_splits2 (Proxy :: Proxy TokWord16)) + , testProperty "Word32" (prop_encodeImpdecodeImp_splits2 (Proxy :: Proxy TokWord32)) + , testProperty "Word64" (prop_encodeImpdecodeImp_splits2 (Proxy :: Proxy TokWord64)) + , testProperty "Word" (prop_encodeImpdecodeImp_splits2 (Proxy :: Proxy TokWord)) +-- , testProperty "NegWord" (prop_encodeImpdecodeImp_splits2 (Proxy :: Proxy TokNegWord)) + , testProperty "Int8" (prop_encodeImpdecodeImp_splits2 (Proxy :: Proxy TokInt8)) + , testProperty "Int16" (prop_encodeImpdecodeImp_splits2 (Proxy :: Proxy TokInt16)) + , testProperty "Int32" (prop_encodeImpdecodeImp_splits2 (Proxy :: Proxy TokInt32)) + , testProperty "Int64" (prop_encodeImpdecodeImp_splits2 (Proxy :: Proxy TokInt64)) + , testProperty "Int" (prop_encodeImpdecodeImp_splits2 (Proxy :: Proxy TokInt)) + , testProperty "Integer" (prop_encodeImpdecodeImp_splits2 (Proxy :: Proxy TokInteger)) + , testProperty "Half" (prop_encodeImpdecodeImp_splits2 (Proxy :: Proxy TokHalf)) + , testProperty "Float" (prop_encodeImpdecodeImp_splits2 (Proxy :: Proxy TokFloat)) + , testProperty "Double" (prop_encodeImpdecodeImp_splits2 (Proxy :: Proxy TokDouble)) + , testProperty "Tag" (prop_encodeImpdecodeImp_splits2 (Proxy :: Proxy TokTag)) + , testProperty "Tag64" (prop_encodeImpdecodeImp_splits2 (Proxy :: Proxy TokTag64)) + , testProperty "Simple" (prop_encodeImpdecodeImp_splits2 (Proxy :: Proxy Ref.Simple)) + , localOption (QuickCheckMaxSize 100) $ + testProperty "Term" (prop_encodeImpdecodeImp_splits2 (Proxy :: Proxy Ref.Term)) + ] + + , testGroup "dec_imp . enc_imp = canon_imp (all 3-splits)" + [ testProperty "Word8" (prop_encodeImpdecodeImp_splits3 (Proxy :: Proxy TokWord8)) + , testProperty "Word16" (prop_encodeImpdecodeImp_splits3 (Proxy :: Proxy TokWord16)) + , testProperty "Word32" (prop_encodeImpdecodeImp_splits3 (Proxy :: Proxy TokWord32)) + , testProperty "Word64" (prop_encodeImpdecodeImp_splits3 (Proxy :: Proxy TokWord64)) + , testProperty "Word" (prop_encodeImpdecodeImp_splits3 (Proxy :: Proxy TokWord)) +-- , testProperty "NegWord" (prop_encodeImpdecodeImp_splits3 (Proxy :: Proxy TokNegWord)) + , testProperty "Int8" (prop_encodeImpdecodeImp_splits3 (Proxy :: Proxy TokInt8)) + , testProperty "Int16" (prop_encodeImpdecodeImp_splits3 (Proxy :: Proxy TokInt16)) + , testProperty "Int32" (prop_encodeImpdecodeImp_splits3 (Proxy :: Proxy TokInt32)) + , testProperty "Int64" (prop_encodeImpdecodeImp_splits3 (Proxy :: Proxy TokInt64)) + , testProperty "Int" (prop_encodeImpdecodeImp_splits3 (Proxy :: Proxy TokInt)) + , testProperty "Integer" (prop_encodeImpdecodeImp_splits3 (Proxy :: Proxy TokInteger)) + , testProperty "Half" (prop_encodeImpdecodeImp_splits3 (Proxy :: Proxy TokHalf)) + , testProperty "Float" (prop_encodeImpdecodeImp_splits3 (Proxy :: Proxy TokFloat)) + , testProperty "Double" (prop_encodeImpdecodeImp_splits3 (Proxy :: Proxy TokDouble)) + , testProperty "Tag" (prop_encodeImpdecodeImp_splits3 (Proxy :: Proxy TokTag)) + , testProperty "Tag64" (prop_encodeImpdecodeImp_splits3 (Proxy :: Proxy TokTag64)) + , testProperty "Simple" (prop_encodeImpdecodeImp_splits3 (Proxy :: Proxy Ref.Simple)) + , localOption (QuickCheckMaxSize 25) $ + testProperty "Term" (prop_encodeImpdecodeImp_splits3 (Proxy :: Proxy Ref.Term)) + ] + + , testGroup "enc_imp . from = enc_ref . canon_ref" + [ testProperty "Word8" (prop_encodeRefencodeImp1 (Proxy :: Proxy TokWord8)) + , testProperty "Word16" (prop_encodeRefencodeImp1 (Proxy :: Proxy TokWord16)) + , testProperty "Word32" (prop_encodeRefencodeImp1 (Proxy :: Proxy TokWord32)) + , testProperty "Word64" (prop_encodeRefencodeImp1 (Proxy :: Proxy TokWord64)) + , testProperty "Word" (prop_encodeRefencodeImp1 (Proxy :: Proxy TokWord)) +-- , testProperty "NegWord" (prop_encodeRefencodeImp1 (Proxy :: Proxy TokNegWord)) + , testProperty "Int8" (prop_encodeRefencodeImp1 (Proxy :: Proxy TokInt8)) + , testProperty "Int16" (prop_encodeRefencodeImp1 (Proxy :: Proxy TokInt16)) + , testProperty "Int32" (prop_encodeRefencodeImp1 (Proxy :: Proxy TokInt32)) + , testProperty "Int64" (prop_encodeRefencodeImp1 (Proxy :: Proxy TokInt64)) + , testProperty "Int" (prop_encodeRefencodeImp1 (Proxy :: Proxy TokInt)) + , testProperty "Integer" (prop_encodeRefencodeImp1 (Proxy :: Proxy TokInteger)) + , testProperty "Half" (prop_encodeRefencodeImp1 (Proxy :: Proxy TokHalf)) + , testProperty "Float" (prop_encodeRefencodeImp1 (Proxy :: Proxy TokFloat)) + , testProperty "Double" (prop_encodeRefencodeImp1 (Proxy :: Proxy TokDouble)) + , testProperty "Tag" (prop_encodeRefencodeImp1 (Proxy :: Proxy TokTag)) + , testProperty "Tag64" (prop_encodeRefencodeImp1 (Proxy :: Proxy TokTag64)) + , testProperty "Simple" (prop_encodeRefencodeImp1 (Proxy :: Proxy Ref.Simple)) + , testProperty "Term" (prop_encodeRefencodeImp1 (Proxy :: Proxy Ref.Term)) + ] + + , testGroup "enc_ref . to = enc_imp" + [ testProperty "Word8" (prop_encodeRefencodeImp2 (Proxy :: Proxy TokWord8)) + , testProperty "Word16" (prop_encodeRefencodeImp2 (Proxy :: Proxy TokWord16)) + , testProperty "Word32" (prop_encodeRefencodeImp2 (Proxy :: Proxy TokWord32)) + , testProperty "Word64" (prop_encodeRefencodeImp2 (Proxy :: Proxy TokWord64)) + , testProperty "Word" (prop_encodeRefencodeImp2 (Proxy :: Proxy TokWord)) +-- , testProperty "NegWord" (prop_encodeRefencodeImp2 (Proxy :: Proxy TokNegWord)) + , testProperty "Int8" (prop_encodeRefencodeImp2 (Proxy :: Proxy TokInt8)) + , testProperty "Int16" (prop_encodeRefencodeImp2 (Proxy :: Proxy TokInt16)) + , testProperty "Int32" (prop_encodeRefencodeImp2 (Proxy :: Proxy TokInt32)) + , testProperty "Int64" (prop_encodeRefencodeImp2 (Proxy :: Proxy TokInt64)) + , testProperty "Int" (prop_encodeRefencodeImp2 (Proxy :: Proxy TokInt)) + , testProperty "Integer" (prop_encodeRefencodeImp2 (Proxy :: Proxy TokInteger)) + , testProperty "Half" (prop_encodeRefencodeImp2 (Proxy :: Proxy TokHalf)) + , testProperty "Float" (prop_encodeRefencodeImp2 (Proxy :: Proxy TokFloat)) + , testProperty "Double" (prop_encodeRefencodeImp2 (Proxy :: Proxy TokDouble)) + , testProperty "Tag" (prop_encodeRefencodeImp2 (Proxy :: Proxy TokTag)) + , testProperty "Tag64" (prop_encodeRefencodeImp2 (Proxy :: Proxy TokTag64)) + , testProperty "Simple" (prop_encodeRefencodeImp2 (Proxy :: Proxy Ref.Simple)) + , testProperty "Term" (prop_encodeRefencodeImp2 (Proxy :: Proxy Ref.Term)) + ] + + , testGroup "dec_imp . enc_ref = from . dec_ref . enc_ref" + [ testProperty "Word8" (prop_decodeRefdecodeImp (Proxy :: Proxy TokWord8)) + , testProperty "Word16" (prop_decodeRefdecodeImp (Proxy :: Proxy TokWord16)) + , testProperty "Word32" (prop_decodeRefdecodeImp (Proxy :: Proxy TokWord32)) + , testProperty "Word64" (prop_decodeRefdecodeImp (Proxy :: Proxy TokWord64)) + , testProperty "Word" (prop_decodeRefdecodeImp (Proxy :: Proxy TokWord)) +-- , testProperty "NegWord" (prop_decodeRefdecodeImp (Proxy :: Proxy TokNegWord)) + , testProperty "Int8" (prop_decodeRefdecodeImp (Proxy :: Proxy TokInt8)) + , testProperty "Int16" (prop_decodeRefdecodeImp (Proxy :: Proxy TokInt16)) + , testProperty "Int32" (prop_decodeRefdecodeImp (Proxy :: Proxy TokInt32)) + , testProperty "Int64" (prop_decodeRefdecodeImp (Proxy :: Proxy TokInt64)) + , testProperty "Int" (prop_decodeRefdecodeImp (Proxy :: Proxy TokInt)) + , testProperty "Integer" (prop_decodeRefdecodeImp (Proxy :: Proxy TokInteger)) + , testProperty "Half" (prop_decodeRefdecodeImp (Proxy :: Proxy TokHalf)) + , testProperty "Float" (prop_decodeRefdecodeImp (Proxy :: Proxy TokFloat)) + , testProperty "Double" (prop_decodeRefdecodeImp (Proxy :: Proxy TokDouble)) + , testProperty "Tag" (prop_decodeRefdecodeImp (Proxy :: Proxy TokTag)) + , testProperty "Tag64" (prop_decodeRefdecodeImp (Proxy :: Proxy TokTag64)) + , testProperty "Simple" (prop_decodeRefdecodeImp (Proxy :: Proxy Ref.Simple)) + , testProperty "Term" (prop_decodeRefdecodeImp (Proxy :: Proxy Ref.Term)) + ] + ] diff --git a/tests/Tests/Reference.hs b/tests/Tests/Reference.hs --- a/tests/Tests/Reference.hs +++ b/tests/Tests/Reference.hs @@ -1,70 +1,42 @@ {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -module Tests.Reference - ( TestCase(..) -- :: * - , termToJson -- :: - , equalJson -- :: - , loadTestCases -- :: - , specTestVector -- :: - , testTree -- :: TestTree +module Tests.Reference ( + testTree + , termToJson + , equalJson ) where -import Test.Tasty +import Test.Tasty as Tasty +import Test.Tasty.HUnit 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 +import Tests.Reference.Generators + ( HalfSpecials(..), FloatSpecials(..), DoubleSpecials(..) ) +import Tests.Reference.TestVectors -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 - } +------------------------------------------------------------------------------- +-- Unit tests for test vector from https://github.com/cbor/test-vectors/ +-- -loadTestCases :: IO [TestCase] -loadTestCases = do - content <- LBS.readFile "tests/test-vectors/appendix_a.json" - either fail return (Aeson.eitherDecode' content) +unit_externalTestVector :: [ExternalTestCase] -> Assertion +unit_externalTestVector = mapM_ unit_externalTestCase -externalTestCase :: TestCase -> Assertion -externalTestCase TestCase { encoded, decoded = Left expectedJson } = do +unit_externalTestCase :: ExternalTestCase -> Assertion +unit_externalTestCase ExternalTestCase { + encoded, + decoded = Left expectedJson + } = do let term = deserialise encoded actualJson = termToJson term reencoded = serialise term @@ -72,7 +44,10 @@ expectedJson `equalJson` actualJson encoded @=? reencoded -externalTestCase TestCase { encoded, decoded = Right expectedDiagnostic } = do +unit_externalTestCase ExternalTestCase { + encoded, + decoded = Right expectedDiagnostic + } = do let term = deserialise encoded actualDiagnostic = diagnosticNotation term reencoded = serialise term @@ -114,16 +89,24 @@ 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) +termToJson (TFloat16 f) = Aeson.Number (fromFloatDigits (Half.fromHalf (getHalfSpecials f))) +termToJson (TFloat32 f) = Aeson.Number (fromFloatDigits (getFloatSpecials f)) +termToJson (TFloat64 f) = Aeson.Number (fromFloatDigits (getDoubleSpecials 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 + +------------------------------------------------------------------------------- +-- Unit tests for test vector from CBOR spec RFC7049 Appendix A +-- + +unit_expectedDiagnosticNotation :: RFC7049TestCase -> Assertion +unit_expectedDiagnosticNotation RFC7049TestCase { + expectedDiagnostic, + encodedBytes + } = do + let Just (term, []) = runDecoder decodeTerm encodedBytes actualDiagnostic = diagnosticNotation term expectedDiagnostic @=? actualDiagnostic @@ -133,144 +116,30 @@ -- 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 +unit_encodedRoundtrip :: RFC7049TestCase -> Assertion +unit_encodedRoundtrip RFC7049TestCase { + expectedDiagnostic, + encodedBytes + } = do + let Just (term, []) = runDecoder decodeTerm encodedBytes + reencodedBytes = encodeTerm term - assertEqual ("for CBOR: " ++ expectedDiagnostic) encoded reencoded + assertEqual ("for CBOR: " ++ expectedDiagnostic) encodedBytes reencodedBytes --- | 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 = +testTree :: TestTree +testTree = 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 "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 + ] , testGroup "properties" [ testProperty "encoding/decoding initial byte" prop_InitialByte @@ -283,11 +152,13 @@ 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 - ] + , testCase "RFC7049 test vector: decode" $ + mapM_ unit_expectedDiagnosticNotation rfc7049TestVector + + , testCase "RFC7049 test vector: roundtrip" $ + mapM_ unit_encodedRoundtrip rfc7049TestVector + + , withExternalTestVector $ \getTestVector -> + testCase "external test vector" $ + getTestVector >>= unit_externalTestVector ] diff --git a/tests/Tests/Reference/Generators.hs b/tests/Tests/Reference/Generators.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Reference/Generators.hs @@ -0,0 +1,261 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Tests.Reference.Generators ( + -- * Integer with a large range + LargeInteger(..) + + -- * Floats with NaNs + , FloatNaN(..) + , canonicaliseNaN + + -- * Floats with special values + , HalfSpecials(..) + , FloatSpecials(..) + , DoubleSpecials(..) + + -- * Floating types to bit representation conversion + , halfToWord + , floatToWord + , doubleToWord + , wordToHalf + , wordToFloat + , wordToDouble + ) where + +import Data.Word +import Numeric (showHex) +import Numeric.Half as Half +import GHC.Float (float2Double) +import Data.Proxy + +import Foreign +import System.IO.Unsafe +import System.Random (Random) + +import Test.QuickCheck + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif + +-- | QuickCheck generator for large integers +-- +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 + +---------------------------------------- +-- Float <-> Integral conversions +-- + +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 + +--------------------------------------------------- +-- Floats with NaNs +-- + +class RealFloat n => FloatNaN n where + canonicalNaN :: n + +canonicaliseNaN :: FloatNaN n => n -> n +canonicaliseNaN n | isNaN n = canonicalNaN + | otherwise = n + +instance FloatNaN Half where + canonicalNaN = Half 0x7e00 + +instance FloatNaN Float where + canonicalNaN = Half.fromHalf canonicalNaN + +instance FloatNaN Double where + canonicalNaN = float2Double canonicalNaN + + +--------------------------------------------------- +-- Generators for float types with special values +-- + +instance Arbitrary Half where + arbitrary = getHalfSpecials <$> arbitrary + shrink = shrinkRealFrac + +newtype HalfSpecials = HalfSpecials { getHalfSpecials :: Half } + deriving (Ord, Num, Fractional, RealFrac, Real, Floating, RealFloat, FloatNaN) + +newtype FloatSpecials = FloatSpecials { getFloatSpecials :: Float } + deriving (Ord, Num, Fractional, RealFrac, Real, Floating, RealFloat, FloatNaN) + +newtype DoubleSpecials = DoubleSpecials { getDoubleSpecials :: Double } + deriving (Ord, Num, Fractional, RealFrac, Real, Floating, RealFloat, FloatNaN) + +instance Eq HalfSpecials where + HalfSpecials a == HalfSpecials b = halfToWord a == halfToWord b + +instance Eq FloatSpecials where + FloatSpecials a == FloatSpecials b = floatToWord a == floatToWord b + +instance Eq DoubleSpecials where + DoubleSpecials a == DoubleSpecials b = doubleToWord a == doubleToWord b + +instance Show HalfSpecials where + showsPrec p (HalfSpecials n) + | isNaN n = showString "NaN{-0x" . showHex (halfToWord n) . showString "-}" + | otherwise = showsPrec p n + +instance Show FloatSpecials where + showsPrec p (FloatSpecials n) + | isNaN n = showString "NaN{-0x" . showHex (floatToWord n) . showString "-}" + | otherwise = showsPrec p n + +instance Show DoubleSpecials where + showsPrec p (DoubleSpecials n) + | isNaN n = showString "NaN{-0x" . showHex (doubleToWord n) . showString "-}" + | otherwise = showsPrec p n + +instance Arbitrary HalfSpecials where + arbitrary = HalfSpecials <$> frequency [ (2, arbitraryFloating) + , (1, arbitraryFloatSpecials) ] + shrink (HalfSpecials n) = [ HalfSpecials n' | n' <- shrinkRealFrac n ] + +instance Arbitrary FloatSpecials where + arbitrary = FloatSpecials <$> frequency [ (2, arbitraryFloating) + , (1, arbitraryFloatSpecials) ] + shrink (FloatSpecials n) = [ FloatSpecials n' | n' <- shrinkRealFrac n ] + +instance Arbitrary DoubleSpecials where + arbitrary = DoubleSpecials <$> frequency [ (2, arbitraryFloating) + , (1, arbitraryFloatSpecials) ] + shrink (DoubleSpecials n) = [ DoubleSpecials n' | n' <- shrinkRealFrac n ] + + +-- | Generate a float from a uniformly random bit pattern +-- +arbitraryFloating :: forall n. RealFloatIEEE n => Gen n +arbitraryFloating = wordToFloating <$> arbitraryBoundedIntegral + +-- | Generate float special values, see 'IeeeSpecials', +-- +-- In particular we generate more than a single NaN bit pattern so that we can +-- test non-canonical representations. The other special values have a single +-- bit pattern. +-- +arbitraryFloatSpecials :: forall n. (RealFloatIEEE n, Random (FloatWord n)) + => Gen n +arbitraryFloatSpecials = + frequency + [ (1, pure (wordToFloating positiveInfinity)) + , (1, pure (wordToFloating negativeInfinity)) + , (1, pure (wordToFloating negativeZero)) + , (3, wordToFloating <$> choose nanRange) + ] + where + IeeeSpecials {..} = floatIeeeSpecials (Proxy :: Proxy n) + +-- | Special values for IEEE float types, including negative 0, +-- positive and negative infinity and a range of NaN values. +-- +data IeeeSpecials n = IeeeSpecials { + positiveInfinity :: n, + negativeInfinity :: n, + negativeZero :: n, + nanRange :: (n, n) + } + deriving (Eq, Functor, Show) + +-- | The 'IeeeSpecials' values for 'RealFloatIEEE' types (i.e. 'Half', 'Float' +-- and 'Double'). +-- +-- To make sense of the bit-twiddling here, see +-- +-- +-- +-- +-- +floatIeeeSpecials :: RealFloatIEEE n => Proxy n -> IeeeSpecials (FloatWord n) +floatIeeeSpecials p = + IeeeSpecials {..} + where + positiveInfinity = (setBit 0 (exponentBits p) - 1) + `shiftL` significandBits p + negativeInfinity = (setBit 0 (exponentBits p +1) - 1) + `shiftL` significandBits p + negativeZero = setBit 0 (exponentBits p + significandBits p) + nanRange = (positiveInfinity, negativeZero - 1) + +class (RealFloat n, Integral (FloatWord n), Show (FloatWord n), + Bounded (FloatWord n), Bits (FloatWord n)) + => RealFloatIEEE n where + exponentBits :: Proxy n -> Int + significandBits :: Proxy n -> Int + + type FloatWord n :: * + wordToFloating :: FloatWord n -> n +--floatingToWord :: n -> FloatWord n + +instance RealFloatIEEE Half where + exponentBits _ = 5 + significandBits _ = 10 + + type FloatWord Half = Word16 + wordToFloating = wordToHalf +--floatingToWord = halfToWord + +instance RealFloatIEEE Float where + exponentBits _ = 8 + significandBits _ = 23 + + type FloatWord Float = Word32 + wordToFloating = wordToFloat +--floatingToWord = floatToWord + +instance RealFloatIEEE Double where + exponentBits _ = 11 + significandBits _ = 52 + + type FloatWord Double = Word64 + wordToFloating = wordToDouble +--floatingToWord = doubleToWord + diff --git a/tests/Tests/Reference/Implementation.hs b/tests/Tests/Reference/Implementation.hs --- a/tests/Tests/Reference/Implementation.hs +++ b/tests/Tests/Reference/Implementation.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE CPP, BangPatterns, MagicHash, UnboxedTuples, RankNTypes, ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE CPP, BangPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Codec.CBOR @@ -20,16 +19,22 @@ deserialise, Term(..), - reservedTag, - reservedSimple, - eqTerm, + Token(..), canonicaliseTerm, + isCanonicalTerm, UInt(..), fromUInt, toUInt, canonicaliseUInt, + Simple(..), + fromSimple, + toSimple, + reservedSimple, + unassignedSimple, + reservedTag, + Decoder, runDecoder, testDecode, @@ -37,11 +42,11 @@ decodeTerm, decodeTokens, decodeToken, - - canonicalNaN, + decodeTagged, diagnosticNotation, + Encoder, encodeTerm, encodeToken, @@ -58,16 +63,12 @@ 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 @@ -77,8 +78,6 @@ 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 @@ -89,7 +88,9 @@ import Control.Applicative #endif +import Tests.Reference.Generators + serialise :: Term -> LBS.ByteString serialise = LBS.pack . encodeTerm @@ -117,7 +118,9 @@ d >>= f = Decoder (\ws -> case runDecoder d ws of Nothing -> Nothing Just (x, ws') -> runDecoder (f x) ws') +#if !MIN_VERSION_base(4,13,0) fail = Fail.fail +#endif instance Fail.MonadFail Decoder where fail _ = Decoder (\_ -> Nothing) @@ -211,6 +214,18 @@ , UInt32 <$> arbitraryBoundedIntegral , UInt64 <$> arbitraryBoundedIntegral ] + shrink (UIntSmall n) = [ UIntSmall n' | n' <- shrink n ] + shrink (UInt8 n) = [ UInt8 n' | n' <- shrink n ] + ++ [ UIntSmall (fromIntegral n) | n <= 23 ] + shrink (UInt16 n) = [ UInt16 n' | n' <- shrink n ] + ++ [ UInt8 (fromIntegral n) + | n <= fromIntegral (maxBound :: Word8) ] + shrink (UInt32 n) = [ UInt32 n' | n' <- shrink n ] + ++ [ UInt16 (fromIntegral n) + | n <= fromIntegral (maxBound :: Word16) ] + shrink (UInt64 n) = [ UInt64 n' | n' <- shrink n ] + ++ [ UInt32 (fromIntegral n) + | n <= fromIntegral (maxBound :: Word32) ] instance Arbitrary AdditionalInformation where arbitrary = @@ -302,6 +317,36 @@ extraused = take (8 - length unused) extra ] +data Simple = SimpleSmall Word -- 0 .. 23 + | SimpleLarge Word8 -- 0 .. 255, but 0..23 are non-canonical + -- and 24..31 are reserved + deriving (Eq, Show) + +fromSimple :: Simple -> Word8 +fromSimple (SimpleSmall w) = fromIntegral w +fromSimple (SimpleLarge w) = w + +toSimple :: Word8 -> Simple +toSimple w | w <= 23 = SimpleSmall (fromIntegral w) + | otherwise = SimpleLarge w + +reservedSimple :: Word8 -> Bool +reservedSimple w = w >= 24 && w <= 31 + +unassignedSimple :: Word8 -> Bool +unassignedSimple w = w < 20 || w > 31 + +instance Arbitrary Simple where + arbitrary = oneof [ SimpleSmall <$> choose (0, 23) + , SimpleLarge <$> choose (0, 31) + , SimpleLarge <$> choose (32, 255) + ] + shrink (SimpleSmall n) = [ SimpleSmall n' | n' <- shrink n ] + shrink (SimpleLarge n) = [ SimpleSmall (fromIntegral n') + | n' <- shrink n, n' <= 23 ] + ++ [ SimpleLarge n' | n' <- shrink n ] + + data Token = MT0_UnsignedInt UInt | MT1_NegativeInt UInt @@ -314,10 +359,10 @@ | MT5_MapLen UInt | MT5_MapLenIndef | MT6_Tag UInt - | MT7_Simple Word8 - | MT7_Float16 Half - | MT7_Float32 Float - | MT7_Float64 Double + | MT7_Simple Simple + | MT7_Float16 HalfSpecials + | MT7_Float32 FloatSpecials + | MT7_Float64 DoubleSpecials | MT7_Break deriving (Show, Eq) @@ -339,9 +384,9 @@ , pure MT5_MapLenIndef , MT6_Tag <$> arbitrary , MT7_Simple <$> arbitrary - , MT7_Float16 . getFloatSpecials <$> arbitrary - , MT7_Float32 . getFloatSpecials <$> arbitrary - , MT7_Float64 . getFloatSpecials <$> arbitrary + , MT7_Float16 <$> arbitrary + , MT7_Float32 <$> arbitrary + , MT7_Float64 <$> arbitrary , pure MT7_Break ] where @@ -436,11 +481,11 @@ -- | 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, AiValue (UIntSmall w)) -> return (MT7_Simple (SimpleSmall w)) + (MajorType7, AiValue (UInt8 w)) -> return (MT7_Simple (SimpleLarge w)) + (MajorType7, AiValue (UInt16 w)) -> return (MT7_Float16 (HalfSpecials (wordToHalf w))) + (MajorType7, AiValue (UInt32 w)) -> return (MT7_Float32 (FloatSpecials (wordToFloat w))) + (MajorType7, AiValue (UInt64 w)) -> return (MT7_Float64 (DoubleSpecials (wordToDouble w))) (MajorType7, AiIndefLen) -> return (MT7_Break) _ -> fail "invalid token header" @@ -464,12 +509,16 @@ (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_Simple + (SimpleSmall n)) -> (MajorType7, AiValue (UIntSmall (fromIntegral n)), []) + (MT7_Simple + (SimpleLarge n)) -> (MajorType7, AiValue (UInt8 n), []) + (MT7_Float16 + (HalfSpecials f)) -> (MajorType7, AiValue (UInt16 (halfToWord f)), []) + (MT7_Float32 + (FloatSpecials f)) -> (MajorType7, AiValue (UInt32 (floatToWord f)), []) + (MT7_Float64 + (DoubleSpecials f))-> (MajorType7, AiValue (UInt64 (doubleToWord f)), []) MT7_Break -> (MajorType7, AiIndefLen, []) @@ -497,9 +546,6 @@ 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 @@ -507,14 +553,7 @@ 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 + in token == token' data Term = TUInt UInt | TNInt UInt @@ -532,10 +571,10 @@ | TFalse | TNull | TUndef - | TSimple Word8 - | TFloat16 Half - | TFloat32 Float - | TFloat64 Double + | TSimple Simple + | TFloat16 HalfSpecials + | TFloat32 FloatSpecials + | TFloat64 DoubleSpecials deriving (Show, Eq) instance Arbitrary Term where @@ -557,7 +596,7 @@ , (1, pure TTrue) , (1, pure TNull) , (1, pure TUndef) - , (1, TSimple <$> arbitrary `suchThat` (not . reservedSimple)) + , (1, TSimple <$> arbitrary `suchThat` (unassignedSimple . fromSimple)) , (1, TFloat16 <$> arbitrary) , (1, TFloat32 <$> arbitrary) , (1, TFloat64 <$> arbitrary) @@ -598,7 +637,8 @@ shrink TNull = [] shrink TUndef = [] - shrink (TSimple w) = [ TSimple w' | w' <- shrink w, not (reservedSimple w) ] + shrink (TSimple n) = [ TSimple n' | n' <- shrink n + , unassignedSimple (fromSimple n') ] shrink (TFloat16 f) = [ TFloat16 f' | f' <- shrink f ] shrink (TFloat32 f) = [ TFloat32 f' | f' <- shrink f ] shrink (TFloat64 f) = [ TFloat64 f' | f' <- shrink f ] @@ -627,11 +667,14 @@ 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_Simple n + | n' == 20 -> return TFalse + | n' == 21 -> return TTrue + | n' == 22 -> return TNull + | n' == 23 -> return TUndef + | otherwise -> return (TSimple n) + where + n' = fromSimple n MT7_Float16 f -> return (TFloat16 f) MT7_Float32 f -> return (TFloat32 f) MT7_Float64 f -> return (TFloat64 f) @@ -779,10 +822,10 @@ <> 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 TFalse = encodeToken (MT7_Simple (SimpleSmall 20)) +encodeTerm TTrue = encodeToken (MT7_Simple (SimpleSmall 21)) +encodeTerm TNull = encodeToken (MT7_Simple (SimpleSmall 22)) +encodeTerm TUndef = encodeToken (MT7_Simple (SimpleSmall 23)) encodeTerm (TSimple w) = encodeToken (MT7_Simple w) encodeTerm (TFloat16 f) = encodeToken (MT7_Float16 f) encodeTerm (TFloat32 f) = encodeToken (MT7_Float32 f) @@ -795,22 +838,10 @@ 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 + in term == term' -eqTermPair :: (Term, Term) -> (Term, Term) -> Bool -eqTermPair (a,b) (a',b') = eqTerm a a' && eqTerm b b' +isCanonicalTerm :: Term -> Bool +isCanonicalTerm t = canonicaliseTerm t == t canonicaliseTerm :: Term -> Term canonicaliseTerm (TUInt n) = TUInt (canonicaliseUInt n) @@ -821,13 +852,10 @@ | 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 (TSimple n) = TSimple (canonicaliseSimple n) +canonicaliseTerm (TFloat16 f) = canonicaliseFloat TFloat16 f +canonicaliseTerm (TFloat32 f) = canonicaliseFloat TFloat32 f +canonicaliseTerm (TFloat64 f) = canonicaliseFloat 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) @@ -840,16 +868,17 @@ canonicaliseUInt :: UInt -> UInt canonicaliseUInt = toUInt . fromUInt -canonicaliseHalf :: Half -> Half -canonicaliseHalf f - | isNaN f = canonicalNaN - | otherwise = f +canonicaliseSimple :: Simple -> Simple +canonicaliseSimple = toSimple . fromSimple +canonicaliseFloat :: RealFloat t => (t -> Term) -> t -> Term +canonicaliseFloat tfloatNN f + | isNaN f = TFloat16 canonicalNaN + | otherwise = tfloatNN f + canonicaliseTermPair :: (Term, Term) -> (Term, Term) canonicaliseTermPair (x,y) = (canonicaliseTerm x, canonicaliseTerm y) -canonicalNaN :: Half -canonicalNaN = Half 0x7e00 ------------------------------------------------------------------------------- @@ -873,11 +902,11 @@ TFalse -> showString "false" TNull -> showString "null" TUndef -> showString "undefined" - TSimple n -> showString "simple" . surround '(' ')' (shows n) + TSimple n -> showString "simple" . surround '(' ')' (shows (fromSimple 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 + TFloat16 f -> showFloatCompat (float2Double (Half.fromHalf (getHalfSpecials f))) + TFloat32 f -> showFloatCompat (float2Double (getFloatSpecials f)) + TFloat64 f -> showFloatCompat (getDoubleSpecials f) surround a b x = showChar a . x . showChar b @@ -973,36 +1002,6 @@ 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 @@ -1011,64 +1010,4 @@ 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/Reference/TestVectors.hs b/tests/Tests/Reference/TestVectors.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Reference/TestVectors.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +module Tests.Reference.TestVectors ( + -- * RFC7049 test vector + RFC7049TestCase(..) + , rfc7049TestVector + + -- * External test vector + , ExternalTestCase(..) + , loadExternalTestVector + , withExternalTestVector + ) where + +import Test.Tasty as Tasty (TestTree, withResource) + +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Base64 as Base64 +import qualified Data.ByteString.Base16 as Base16 +import qualified Data.Text.Encoding as T +import Data.Aeson as Aeson +import Control.Applicative +import Control.Monad +import Data.Word + + +------------------------------------------------------------ +-- Test vector from https://github.com/cbor/test-vectors/ +-- + +-- | A CBOR encoding unit test case for the data from +-- +-- +data ExternalTestCase = ExternalTestCase { + encoded :: !LBS.ByteString, + decoded :: !(Either Aeson.Value String), + roundTrip :: !Bool + } + deriving Show + +instance FromJSON ExternalTestCase 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 $! ExternalTestCase { + encoded = LBS.fromStrict encoded, + roundTrip, + decoded + } + +loadExternalTestVector :: IO [ExternalTestCase] +loadExternalTestVector = do + content <- LBS.readFile "tests/test-vectors/appendix_a.json" + either fail return (Aeson.eitherDecode' content) + +withExternalTestVector :: (IO [ExternalTestCase] -> TestTree) -> TestTree +withExternalTestVector = + Tasty.withResource loadExternalTestVector (\_ -> return ()) + + +--------------------------------------------------- +-- Test vector from CBOR spec RFC7049 Appendix A +-- + +-- | A CBOR encoding unit test case consisting of the encoded bytes and +-- corresponding diagnostic notation. +-- +data RFC7049TestCase = RFC7049TestCase { + expectedDiagnostic :: String, + encodedBytes :: [Word8] + } + deriving Show + + +-- | The examples from the CBOR spec RFC7049 Appendix A. +-- +rfc7049TestVector :: [RFC7049TestCase] +rfc7049TestVector = + map (uncurry RFC7049TestCase) + [ ("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 + diff --git a/tests/Tests/Regress/FlatTerm.hs b/tests/Tests/Regress/FlatTerm.hs --- a/tests/Tests/Regress/FlatTerm.hs +++ b/tests/Tests/Regress/FlatTerm.hs @@ -19,7 +19,7 @@ -- 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 +-- 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) @@ -29,7 +29,7 @@ -- | 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'@ +-- '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) diff --git a/tests/Tests/Regress/Issue160.hs b/tests/Tests/Regress/Issue160.hs --- a/tests/Tests/Regress/Issue160.hs +++ b/tests/Tests/Regress/Issue160.hs @@ -1,11 +1,18 @@ +{-# LANGUAGE CPP #-} module Tests.Regress.Issue160 ( testTree ) where import Codec.CBOR.Decoding import Codec.CBOR.Read + import Control.DeepSeq +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +import Data.Monoid (Monoid(..)) +#endif import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL import Data.Text (Text) + import Test.Tasty import Test.Tasty.HUnit diff --git a/tests/Tests/Regress/Issue162.hs b/tests/Tests/Regress/Issue162.hs --- a/tests/Tests/Regress/Issue162.hs +++ b/tests/Tests/Regress/Issue162.hs @@ -1,6 +1,7 @@ module Tests.Regress.Issue162 ( testTree ) where import Control.Monad (void) +import Control.Applicative ((<$), (<*)) import Data.Word import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as LBS diff --git a/tests/Tests/Term.hs b/tests/Tests/Term.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Term.hs @@ -0,0 +1,220 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Tests.Term ( + Term + , serialise + , deserialise + , toRefTerm + , fromRefTerm + , eqTerm + , canonicaliseTerm + , prop_fromToRefTerm + , prop_toFromRefTerm + ) 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.QuickCheck + +import qualified Tests.Reference.Implementation as Ref +import Tests.Reference.Generators + ( floatToWord, doubleToWord, canonicalNaN + , HalfSpecials(..), FloatSpecials(..), DoubleSpecials(..) ) + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif +import Control.Exception (throw) + + +------------------------------------------------------------------------------ + +serialise :: Term -> LBS.ByteString +serialise = toLazyByteString . encodeTerm + +deserialise :: LBS.ByteString -> Term +deserialise b = + case deserialiseFromBytes decodeTerm b of + Left failure -> throw failure + Right (trailing, _) | not (LBS.null trailing) + -> error "Test.deserialise: trailing data" + Right (_, t) -> t + + +------------------------------------------------------------------------------ + +toRefTerm :: Term -> Ref.Term +toRefTerm (TInt n) + | n >= 0 = Ref.TUInt (Ref.toUInt (fromIntegral n)) + | otherwise = Ref.TNInt (Ref.toUInt (fromIntegral (-1 - n))) +toRefTerm (TInteger n) -- = Ref.TBigInt n + | n >= 0 && n <= fromIntegral (maxBound :: Word64) + = Ref.TUInt (Ref.toUInt (fromIntegral n)) + | n < 0 && n >= -1 - fromIntegral (maxBound :: Word64) + = Ref.TNInt (Ref.toUInt (fromIntegral (-1 - n))) + | otherwise = Ref.TBigInt n +toRefTerm (TBytes bs) = Ref.TBytes (BS.unpack bs) +toRefTerm (TBytesI bs) = Ref.TBytess (map BS.unpack (LBS.toChunks bs)) +toRefTerm (TString st) = Ref.TString (T.unpack st) +toRefTerm (TStringI st) = Ref.TStrings (map T.unpack (LT.toChunks st)) +toRefTerm (TList ts) = Ref.TArray (map toRefTerm ts) +toRefTerm (TListI ts) = Ref.TArrayI (map toRefTerm ts) +toRefTerm (TMap ts) = Ref.TMap [ (toRefTerm x, toRefTerm y) + | (x,y) <- ts ] +toRefTerm (TMapI ts) = Ref.TMapI [ (toRefTerm x, toRefTerm y) + | (x,y) <- ts ] +toRefTerm (TTagged w t) = Ref.TTagged (Ref.toUInt (fromIntegral w)) + (toRefTerm t) +toRefTerm (TBool False) = Ref.TFalse +toRefTerm (TBool True) = Ref.TTrue +toRefTerm TNull = Ref.TNull +toRefTerm (TSimple 23) = Ref.TUndef +toRefTerm (TSimple w) = Ref.TSimple (Ref.toSimple w) +toRefTerm (THalf f) = if isNaN f + then Ref.TFloat16 canonicalNaN + else Ref.TFloat16 (HalfSpecials (Half.toHalf f)) +toRefTerm (TFloat f) = if isNaN f + then Ref.TFloat16 canonicalNaN + else Ref.TFloat32 (FloatSpecials f) +toRefTerm (TDouble f) = if isNaN f + then Ref.TFloat16 canonicalNaN + else Ref.TFloat64 (DoubleSpecials f) + + +fromRefTerm :: Ref.Term -> Term +fromRefTerm (Ref.TUInt u) + | n <= fromIntegral (maxBound :: Int) = TInt (fromIntegral n) + | otherwise = TInteger (fromIntegral n) + where n = Ref.fromUInt u + +fromRefTerm (Ref.TNInt u) + | n <= fromIntegral (maxBound :: Int) = TInt (-1 - fromIntegral n) + | otherwise = TInteger (-1 - fromIntegral n) + where n = Ref.fromUInt u + +fromRefTerm (Ref.TBigInt n) = TInteger n +fromRefTerm (Ref.TBytes bs) = TBytes (BS.pack bs) +fromRefTerm (Ref.TBytess bs) = TBytesI (LBS.fromChunks (map BS.pack bs)) +fromRefTerm (Ref.TString st) = TString (T.pack st) +fromRefTerm (Ref.TStrings st) = TStringI (LT.fromChunks (map T.pack st)) + +fromRefTerm (Ref.TArray ts) = TList (map fromRefTerm ts) +fromRefTerm (Ref.TArrayI ts) = TListI (map fromRefTerm ts) +fromRefTerm (Ref.TMap ts) = TMap [ (fromRefTerm x, fromRefTerm y) + | (x,y) <- ts ] +fromRefTerm (Ref.TMapI ts) = TMapI [ (fromRefTerm x, fromRefTerm y) + | (x,y) <- ts ] +fromRefTerm (Ref.TTagged w t) = TTagged (Ref.fromUInt w) + (fromRefTerm t) +fromRefTerm (Ref.TFalse) = TBool False +fromRefTerm (Ref.TTrue) = TBool True +fromRefTerm Ref.TNull = TNull +fromRefTerm Ref.TUndef = TSimple 23 +fromRefTerm (Ref.TSimple w) = TSimple (Ref.fromSimple w) +fromRefTerm (Ref.TFloat16 f) = THalf (Half.fromHalf (getHalfSpecials f)) +fromRefTerm (Ref.TFloat32 f) = TFloat (getFloatSpecials f) +fromRefTerm (Ref.TFloat64 f) = TDouble (getDoubleSpecials f) + +-- | Compare terms for equality. +-- +-- It does exact bit for bit equality of floats. This means we can compare +-- NaNs, and different NaNs do not compare equal. If you need equality +-- modulo different NaNs then use 'canonicaliseTerm'. +-- +-- If you need equality modulo different representations of 'TInt' vs 'TInteger' +-- then use 'canonicaliseTerm'. +-- +eqTerm :: Term -> Term -> Bool +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') = floatToWord f == floatToWord f' +eqTerm (TFloat f) (TFloat f') = floatToWord f == floatToWord f' +eqTerm (TDouble f) (TDouble f') = doubleToWord f == doubleToWord f' +eqTerm a b = a == b + +eqTermPair :: (Term, Term) -> (Term, Term) -> Bool +eqTermPair (a,b) (a',b') = eqTerm a a' && eqTerm b b' + +-- | Both 'toRefTerm' and the encoding \/ decoding round trip canonicalises +-- NaNs. So tests involving these often need this in combination with +-- comparing for exact equality using 'eqTerm'. +-- +canonicaliseTerm :: Term -> Term +canonicaliseTerm (THalf f) | isNaN f = canonicalTermNaN +canonicaliseTerm (TFloat f) | isNaN f = canonicalTermNaN +canonicaliseTerm (TDouble f) | isNaN f = canonicalTermNaN +canonicaliseTerm (TInteger n) | n <= fromIntegral (maxBound :: Int) + , n >= fromIntegral (minBound :: Int) + = TInt (fromIntegral n) +canonicaliseTerm (TList ts) = TList (map canonicaliseTerm ts) +canonicaliseTerm (TListI ts) = TListI (map canonicaliseTerm ts) +canonicaliseTerm (TMap ts) = TMap (map canonicaliseTermPair ts) +canonicaliseTerm (TMapI ts) = TMapI (map canonicaliseTermPair ts) +canonicaliseTerm (TTagged tag t) = TTagged tag (canonicaliseTerm t) +canonicaliseTerm t = t + +canonicalTermNaN :: Term +canonicalTermNaN = THalf canonicalNaN + +canonicaliseTermPair :: (Term, Term) -> (Term, Term) +canonicaliseTermPair (a,b) = + (canonicaliseTerm a, canonicaliseTerm b) + + +prop_fromToRefTerm :: Ref.Term -> Bool +prop_fromToRefTerm term = toRefTerm (fromRefTerm term) + == Ref.canonicaliseTerm term + +prop_toFromRefTerm :: Term -> Bool +prop_toFromRefTerm term = fromRefTerm (toRefTerm term) + `eqTerm` canonicaliseTerm 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) = t : [ TTagged w' t' | (w', t') <- shrink (w, t) + , not (Ref.reservedTag (fromIntegral w')) ] + + shrink (TBool _) = [] + shrink TNull = [] + + shrink (TSimple w) = [ TSimple w' | w' <- shrink w + , Ref.unassignedSimple w || w == 23 ] + shrink (THalf _f) = [] + shrink (TFloat f) = [ TFloat f' | f' <- shrink f ] + shrink (TDouble f) = [ TDouble f' | f' <- shrink f ] + diff --git a/tests/Tests/UnitTests.hs b/tests/Tests/UnitTests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/UnitTests.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Tests.UnitTests (testTree) where + +import qualified Data.ByteString.Lazy as LBS + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, testCase, assertEqual, (@=?)) + +import qualified Tests.Reference.Implementation as Ref +import Tests.Reference.TestVectors +import Tests.Reference (termToJson, equalJson) +import Tests.Term as Term (toRefTerm, serialise, deserialise) + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif + + +------------------------------------------------------------------------------- +-- Unit tests for test vector from CBOR spec RFC7049 Appendix A +-- + +unit_externalTestVector :: [ExternalTestCase] -> Assertion +unit_externalTestVector = mapM_ unit_externalTestCase + +unit_externalTestCase :: ExternalTestCase -> Assertion +unit_externalTestCase ExternalTestCase { + encoded, + decoded = Left expectedJson + } = do + let term = Term.deserialise encoded + actualJson = termToJson (toRefTerm term) + reencoded = Term.serialise term + + expectedJson `equalJson` actualJson + encoded @=? reencoded + +unit_externalTestCase ExternalTestCase { + encoded, + decoded = Right expectedDiagnostic + } = do + let term = Term.deserialise encoded + actualDiagnostic = Ref.diagnosticNotation (toRefTerm term) + reencoded = Term.serialise term + + expectedDiagnostic @=? actualDiagnostic + encoded @=? reencoded + + +------------------------------------------------------------------------------- +-- Unit tests for test vector from CBOR spec RFC7049 Appendix A +-- + +unit_expectedDiagnosticNotation :: RFC7049TestCase -> Assertion +unit_expectedDiagnosticNotation RFC7049TestCase { + expectedDiagnostic, + encodedBytes + } = do + let term = Term.deserialise (LBS.pack encodedBytes) + actualDiagnostic = Ref.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. +-- +unit_encodedRoundtrip :: RFC7049TestCase -> Assertion +unit_encodedRoundtrip RFC7049TestCase { + expectedDiagnostic, + encodedBytes + } = do + let term = Term.deserialise (LBS.pack encodedBytes) + reencodedBytes = LBS.unpack (Term.serialise term) + + assertEqual ("for CBOR: " ++ expectedDiagnostic) encodedBytes reencodedBytes + + +-------------------------------------------------------------------------------- +-- TestTree API + +testTree :: TestTree +testTree = + testGroup "unit tests" + [ testCase "RFC7049 test vector: decode" $ + mapM_ unit_expectedDiagnosticNotation rfc7049TestVector + + , testCase "RFC7049 test vector: roundtrip" $ + mapM_ unit_encodedRoundtrip rfc7049TestVector + + , withExternalTestVector $ \getTestVector -> + testCase "external test vector" $ + getTestVector >>= unit_externalTestVector + ]