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
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
|
{-# LANGUAGE CPP #-}
{-# LANGUAGE NamedFieldPuns #-}
module Tests.Reference (
testTree
, termToJson
, equalJson
) where
import Test.Tasty as Tasty
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64.URL as Base64url
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
#if MIN_VERSION_aeson(2,0,0)
import Data.Aeson.Key as Aeson.Key
#endif
import Data.Word
import qualified Numeric.Half as Half
import Tests.Reference.Implementation as CBOR
import Tests.Reference.Generators
( HalfSpecials(..), FloatSpecials(..), DoubleSpecials(..) )
import Tests.Reference.TestVectors
-------------------------------------------------------------------------------
-- Unit tests for test vector from https://github.com/cbor/test-vectors/
--
unit_externalTestVector :: [ExternalTestCase] -> Assertion
unit_externalTestVector = mapM_ unit_externalTestCase
unit_externalTestCase :: ExternalTestCase -> Assertion
unit_externalTestCase ExternalTestCase {
encoded,
decoded = Left expectedJson
} = do
let term = deserialise encoded
actualJson = termToJson term
reencoded = serialise term
expectedJson `equalJson` actualJson
encoded @=? reencoded
unit_externalTestCase ExternalTestCase {
encoded,
decoded = Right expectedDiagnostic
} = do
let term = deserialise encoded
actualDiagnostic = diagnosticNotation term
reencoded = serialise term
expectedDiagnostic @=? actualDiagnostic
encoded @=? reencoded
equalJson :: Aeson.Value -> Aeson.Value -> Assertion
equalJson (Aeson.Number expected) (Aeson.Number actual)
| toRealFloat expected == promoteDouble (toRealFloat actual)
= return ()
where
-- This is because the expected JSON output is always using double precision
-- where as Aeson's Scientific type preserves the precision of the input.
-- So for tests using Float, we're more precise than the reference values.
promoteDouble :: Float -> Double
promoteDouble = realToFrac
equalJson expected actual = expected @=? actual
#if MIN_VERSION_aeson(2,0,0)
stringToJsonKey :: String -> Aeson.Key.Key
stringToJsonKey = Aeson.Key.fromString
#else
stringToJsonKey :: String -> T.Text
stringToJsonKey = T.pack
#endif
termToJson :: CBOR.Term -> Aeson.Value
termToJson (TUInt n) = Aeson.Number (fromIntegral (fromUInt n))
termToJson (TNInt n) = Aeson.Number (-1 - fromIntegral (fromUInt n))
termToJson (TBigInt n) = Aeson.Number (fromIntegral n)
termToJson (TBytes ws) = Aeson.String (bytesToBase64Text ws)
termToJson (TBytess wss) = Aeson.String (bytesToBase64Text (concat wss))
termToJson (TString cs) = Aeson.String (T.pack cs)
termToJson (TStrings css) = Aeson.String (T.pack (concat css))
termToJson (TArray ts) = Aeson.Array (V.fromList (map termToJson ts))
termToJson (TArrayI ts) = Aeson.Array (V.fromList (map termToJson ts))
termToJson (TMap kvs) = Aeson.object [ (stringToJsonKey k, termToJson v)
| (TString k,v) <- kvs ]
termToJson (TMapI kvs) = Aeson.object [ (stringToJsonKey k, termToJson v)
| (TString k,v) <- kvs ]
termToJson (TTagged _ t) = termToJson t
termToJson TTrue = Aeson.Bool True
termToJson TFalse = Aeson.Bool False
termToJson TNull = Aeson.Null
termToJson TUndef = Aeson.Null -- replacement value
termToJson (TSimple _) = Aeson.Null -- replacement value
termToJson (TFloat16 f) = Aeson.Number (fromFloatDigits (Half.fromHalf (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
-------------------------------------------------------------------------------
-- 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
-- | 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 Just (term, []) = runDecoder decodeTerm encodedBytes
reencodedBytes = encodeTerm term
assertEqual ("for CBOR: " ++ expectedDiagnostic) encodedBytes reencodedBytes
--------------------------------------------------------------------------------
-- TestTree API
testTree :: TestTree
testTree =
testGroup "Reference implementation"
[ 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
, testProperty "encoding/decoding additional info" prop_AdditionalInfo
, testProperty "encoding/decoding token header" prop_TokenHeader
, testProperty "encoding/decoding token header 2" prop_TokenHeader2
, testProperty "encoding/decoding tokens" prop_Token
, --localOption (QuickCheckTests 1000) $
localOption (QuickCheckMaxSize 150) $
testProperty "encoding/decoding terms" prop_Term
]
, 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
]
|
