{-# 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])
  , ("-Infinity", [0xfa, 0xff, 0x80, 0x00, 0x00])
  , ("Infinity",  [0xfb, 0x7f, 0xf0, 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
        ]
    ]
