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
|
{-# 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
]
|
