1{-# LANGUAGE CPP               #-}
2{-# LANGUAGE NamedFieldPuns    #-}
3{-# OPTIONS_GHC -fno-warn-orphans #-}
4module Tests.UnitTests (testTree) where
5
6import qualified Data.ByteString.Lazy as LBS
7
8import           Test.Tasty (TestTree, testGroup)
9import           Test.Tasty.HUnit (Assertion, testCase, assertEqual, (@=?))
10
11import qualified Tests.Reference.Implementation as Ref
12import           Tests.Reference.TestVectors
13import           Tests.Reference (termToJson, equalJson)
14import           Tests.Term as Term (toRefTerm, serialise, deserialise)
15
16#if !MIN_VERSION_base(4,8,0)
17import           Control.Applicative
18#endif
19
20
21-------------------------------------------------------------------------------
22-- Unit tests for test vector from CBOR spec RFC7049 Appendix A
23--
24
25unit_externalTestVector :: [ExternalTestCase] -> Assertion
26unit_externalTestVector = mapM_ unit_externalTestCase
27
28unit_externalTestCase :: ExternalTestCase -> Assertion
29unit_externalTestCase ExternalTestCase {
30                        encoded,
31                        decoded = Left expectedJson
32                      } = do
33  let term       = Term.deserialise encoded
34      actualJson = termToJson (toRefTerm term)
35      reencoded  = Term.serialise term
36
37  expectedJson `equalJson` actualJson
38  encoded @=? reencoded
39
40unit_externalTestCase ExternalTestCase {
41                        encoded,
42                        decoded = Right expectedDiagnostic
43                      } = do
44  let term             = Term.deserialise encoded
45      actualDiagnostic = Ref.diagnosticNotation (toRefTerm term)
46      reencoded        = Term.serialise term
47
48  expectedDiagnostic @=? actualDiagnostic
49  encoded @=? reencoded
50
51
52-------------------------------------------------------------------------------
53-- Unit tests for test vector from CBOR spec RFC7049 Appendix A
54--
55
56unit_expectedDiagnosticNotation :: RFC7049TestCase -> Assertion
57unit_expectedDiagnosticNotation RFC7049TestCase {
58                                  expectedDiagnostic,
59                                  encodedBytes
60                                } = do
61  let term             = Term.deserialise (LBS.pack encodedBytes)
62      actualDiagnostic = Ref.diagnosticNotation (toRefTerm term)
63
64  expectedDiagnostic @=? actualDiagnostic
65
66-- | The reference implementation satisfies the roundtrip property for most
67-- examples (all the ones from Appendix A). It does not satisfy the roundtrip
68-- property in general however, non-canonical over-long int encodings for
69-- example.
70--
71unit_encodedRoundtrip :: RFC7049TestCase -> Assertion
72unit_encodedRoundtrip RFC7049TestCase {
73                        expectedDiagnostic,
74                        encodedBytes
75                      } = do
76  let term           = Term.deserialise (LBS.pack encodedBytes)
77      reencodedBytes = LBS.unpack (Term.serialise term)
78
79  assertEqual ("for CBOR: " ++ expectedDiagnostic) encodedBytes reencodedBytes
80
81
82--------------------------------------------------------------------------------
83-- TestTree API
84
85testTree :: TestTree
86testTree =
87  testGroup "unit tests"
88    [ testCase "RFC7049 test vector: decode" $
89        mapM_ unit_expectedDiagnosticNotation rfc7049TestVector
90
91    , testCase "RFC7049 test vector: roundtrip" $
92        mapM_ unit_encodedRoundtrip rfc7049TestVector
93
94    , withExternalTestVector $ \getTestVector ->
95      testCase "external test vector" $
96        getTestVector >>= unit_externalTestVector
97    ]
98