serialise-0.1.0.0: tests/Tests/Reference.hs
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Tests.Reference
( TestCase(..) -- :: *
, termToJson -- ::
, equalJson -- ::
, loadTestCases -- ::
, specTestVector -- ::
, testTree -- :: TestTree
) where
import Test.Tasty
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
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
}
loadTestCases :: IO [TestCase]
loadTestCases = do
content <- LBS.readFile "tests/test-vectors/appendix_a.json"
either fail return (Aeson.eitherDecode' content)
externalTestCase :: TestCase -> Assertion
externalTestCase TestCase { encoded, decoded = Left expectedJson } = do
let term = deserialise encoded
actualJson = termToJson term
reencoded = serialise term
expectedJson `equalJson` actualJson
encoded @=? reencoded
externalTestCase TestCase { 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
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 [ (T.pack k, termToJson v)
| (TString k,v) <- kvs ]
termToJson (TMapI kvs) = Aeson.object [ (T.pack 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 f))
termToJson (TFloat32 f) = Aeson.Number (fromFloatDigits f)
termToJson (TFloat64 f) = Aeson.Number (fromFloatDigits 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
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.
--
--
encodedRoundtrip :: String -> [Word8] -> Assertion
encodedRoundtrip expectedDiagnostic encoded = do
let Just (term, []) = runDecoder decodeTerm encoded
reencoded = encodeTerm term
assertEqual ("for CBOR: " ++ expectedDiagnostic) encoded reencoded
-- | 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])
, ("NaN", [0xfa, 0x7f, 0xc0, 0x00, 0x00])
, ("-Infinity", [0xfa, 0xff, 0x80, 0x00, 0x00])
, ("Infinity", [0xfb, 0x7f, 0xf0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00])
, ("NaN", [0xfb, 0x7f, 0xf8, 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 =
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 "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
]
, 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
]
]