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