{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}

module Test.Cardano.Ledger.Conway.BinarySpec (spec) where

import Cardano.Ledger.Address (CompactAddr)
import Cardano.Ledger.Alonzo.TxWits (Redeemers, TxDats)
import Cardano.Ledger.Binary
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Conway
import Cardano.Ledger.Conway.Core (AlonzoEraScript (..), AsIx)
import Cardano.Ledger.Conway.Genesis
import Cardano.Ledger.Conway.Governance
import Cardano.Ledger.Core
import Cardano.Ledger.Mary.Value (MultiAsset (..))
import Cardano.Ledger.Shelley.LedgerState (StashedAVVMAddresses)
import Cardano.Ledger.TxIn (TxIn)
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Map.Strict as Map
import Data.Proxy
import Data.Sequence.Strict (StrictSeq)
import qualified Data.Sequence.Strict as StrictSeq
import qualified Data.Set as Set
import Data.Typeable (typeRep)
import Test.Cardano.Ledger.Binary (decoderEquivalenceExpectation)
import Test.Cardano.Ledger.Binary.RoundTrip
import Test.Cardano.Ledger.Common
import Test.Cardano.Ledger.Conway.Arbitrary ()
import Test.Cardano.Ledger.Conway.Binary.Annotator ()
import Test.Cardano.Ledger.Conway.Binary.RoundTrip (roundTripConwayCommonSpec)
import Test.Cardano.Ledger.Conway.ImpTest (ConwayEraImp)
import Test.Cardano.Ledger.Conway.TreeDiff ()
import Test.Cardano.Ledger.Core.Binary as Binary (decoderEquivalenceCoreEraTypesSpec, txSizeSpec)
import Test.Cardano.Ledger.Core.Binary.RoundTrip (RuleListEra, roundTripEraSpec)

spec ::
  forall era.
  ( ConwayEraImp era
  , DecCBOR (TxAuxData era)
  , DecCBOR (TxWits era)
  , DecCBOR (TxBody era)
  , DecCBOR (Tx era)
  , Arbitrary (PlutusPurpose AsIx era)
  , RuleListEra era
  , StashedAVVMAddresses era ~ ()
  , SafeToHash (TxWits era)
  ) =>
  Spec
spec :: forall era.
(ConwayEraImp era, DecCBOR (TxAuxData era), DecCBOR (TxWits era),
 DecCBOR (TxBody era), DecCBOR (Tx era),
 Arbitrary (PlutusPurpose AsIx era), RuleListEra era,
 StashedAVVMAddresses era ~ (), SafeToHash (TxWits era)) =>
Spec
spec = do
  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"RoundTrip" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    forall t. (Show t, Eq t, Arbitrary t, EncCBOR t, DecCBOR t) => Spec
roundTripCborSpec @GovActionId
    forall t. (Show t, Eq t, Arbitrary t, EncCBOR t, DecCBOR t) => Spec
roundTripCborSpec @(GovPurposeId 'PParamUpdatePurpose)
    forall t. (Show t, Eq t, Arbitrary t, EncCBOR t, DecCBOR t) => Spec
roundTripCborSpec @(GovPurposeId 'HardForkPurpose)
    forall t. (Show t, Eq t, Arbitrary t, EncCBOR t, DecCBOR t) => Spec
roundTripCborSpec @(GovPurposeId 'CommitteePurpose)
    forall t. (Show t, Eq t, Arbitrary t, EncCBOR t, DecCBOR t) => Spec
roundTripCborSpec @(GovPurposeId 'ConstitutionPurpose)
    forall t. (Show t, Eq t, Arbitrary t, EncCBOR t, DecCBOR t) => Spec
roundTripCborSpec @Vote
    forall t. (Show t, Eq t, Arbitrary t, EncCBOR t, DecCBOR t) => Spec
roundTripCborSpec @Voter
    forall era.
(EraTx era, EraGov era, EraStake era, EraCertState era,
 AlonzoEraScript era, ConwayEraAccounts era,
 StashedAVVMAddresses era ~ (), Arbitrary (Tx era),
 Arbitrary (TxBody era), Arbitrary (TxOut era),
 Arbitrary (TxCert era), Arbitrary (TxWits era),
 Arbitrary (TxAuxData era), Arbitrary (Value era),
 Arbitrary (CompactForm (Value era)), Arbitrary (Script era),
 Arbitrary (GovState era), Arbitrary (PlutusPurpose AsIx era),
 Arbitrary (PParams era), Arbitrary (PParamsUpdate era),
 Arbitrary (PParamsHKD StrictMaybe era),
 Arbitrary (InstantStake era), Arbitrary (CertState era),
 Arbitrary (Accounts era), DecCBOR (Script era),
 DecCBOR (TxAuxData era), DecCBOR (TxWits era),
 DecCBOR (TxBody era), DecCBOR (Tx era), RuleListEra era) =>
Spec
roundTripConwayCommonSpec @era
    -- ConwayGenesis only makes sense in Conway era
    forall era t.
(Era era, Show t, Eq t, EncCBOR t, DecCBOR t, Arbitrary t,
 HasCallStack) =>
Spec
roundTripEraSpec @era @ConwayGenesis
  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"DecCBOR instances equivalence" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    forall era.
(EraTx era, Arbitrary (Tx era), Arbitrary (TxBody era),
 Arbitrary (TxWits era), Arbitrary (TxAuxData era),
 Arbitrary (Script era), HasCallStack) =>
Spec
Binary.decoderEquivalenceCoreEraTypesSpec @era
    forall t.
(Arbitrary t, Eq t, EncCBOR t, DecCBOR t, DecCBOR (Annotator t),
 Show t) =>
Spec
decoderEquivalenceLenientSpec @(TxDats era)
    forall t.
(Arbitrary t, Eq t, EncCBOR t, DecCBOR t, DecCBOR (Annotator t),
 Show t) =>
Spec
decoderEquivalenceLenientSpec @(Redeemers era)
  forall era.
(EraTx era, Arbitrary (Tx era), SafeToHash (TxWits era)) =>
Spec
Binary.txSizeSpec @era

  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"MultiAsset constraints" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"TxOut" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Completely empty MultiAsset fails deserialisation since Dijkstra" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
        -- Cannot use standard serialization because MaryValue encCBOR optimizes away
        -- completely empty MultiAssets via 'if Map.null m then encCBOR c', preventing decoder testing
        Gen CompactAddr -> (CompactAddr -> Expectation) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen CompactAddr
forall a. Arbitrary a => Gen a
arbitrary ((CompactAddr -> Expectation) -> Property)
-> (CompactAddr -> Expectation) -> Property
forall a b. (a -> b) -> a -> b
$ \(CompactAddr
addr :: CompactAddr) ->
          forall era a.
(ConwayEraImp era, DecCBOR a, Show a) =>
Version -> String -> (Version -> ByteString) -> Expectation
testMultiAssetRejection @era @(TxOut era) (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @12) String
"Dijkstra" ((Version -> ByteString) -> Expectation)
-> (Version -> ByteString) -> Expectation
forall a b. (a -> b) -> a -> b
$ \Version
version ->
            CompactAddr -> MultiAsset -> Version -> ByteString
buildTxOutCborWithMultiAsset CompactAddr
addr (Map PolicyID (Map AssetName Integer) -> MultiAsset
MultiAsset Map PolicyID (Map AssetName Integer)
forall k a. Map k a
Map.empty) Version
version

      String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Empty nested asset maps fails deserialisation since Conway" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
        -- Cannot use standard serialization because MaryValue encCBOR optimizes away
        -- empty nested maps via pruneZeroMultiAsset, preventing decoder validation testing
        Gen CompactAddr -> (CompactAddr -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen CompactAddr
forall a. Arbitrary a => Gen a
arbitrary ((CompactAddr -> Property) -> Property)
-> (CompactAddr -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(CompactAddr
addr :: CompactAddr) ->
          Gen PolicyID -> (PolicyID -> Expectation) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen PolicyID
forall a. Arbitrary a => Gen a
arbitrary ((PolicyID -> Expectation) -> Property)
-> (PolicyID -> Expectation) -> Property
forall a b. (a -> b) -> a -> b
$ \PolicyID
policyId ->
            forall era a.
(ConwayEraImp era, DecCBOR a, Show a) =>
Version -> String -> (Version -> ByteString) -> Expectation
testMultiAssetRejection @era @(TxOut era) (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @9) String
"Conway" ((Version -> ByteString) -> Expectation)
-> (Version -> ByteString) -> Expectation
forall a b. (a -> b) -> a -> b
$ \Version
version ->
              CompactAddr -> MultiAsset -> Version -> ByteString
buildTxOutCborWithMultiAsset CompactAddr
addr (Map PolicyID (Map AssetName Integer) -> MultiAsset
MultiAsset (Map PolicyID (Map AssetName Integer) -> MultiAsset)
-> Map PolicyID (Map AssetName Integer) -> MultiAsset
forall a b. (a -> b) -> a -> b
$ PolicyID
-> Map AssetName Integer -> Map PolicyID (Map AssetName Integer)
forall k a. k -> a -> Map k a
Map.singleton PolicyID
policyId Map AssetName Integer
forall k a. Map k a
Map.empty) Version
version

    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Mint field in Tx" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      String -> Expectation -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Completely empty mint MultiAsset fails deserialisation since Conway" (Expectation -> Spec) -> Expectation -> Spec
forall a b. (a -> b) -> a -> b
$
        -- Cannot use standard serialization because Conway TxBody encoder omits empty
        -- mint fields via 'Omit (== mempty) (Key 9 (To ctbrMint))', preventing decoder testing
        forall era a.
(ConwayEraImp era, DecCBOR a, Show a) =>
Version -> String -> (Version -> ByteString) -> Expectation
testMultiAssetRejection @era @(TxBody era) (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @9) String
"Conway" ((Version -> ByteString) -> Expectation)
-> (Version -> ByteString) -> Expectation
forall a b. (a -> b) -> a -> b
$ \Version
version ->
          forall era. ConwayEraImp era => MultiAsset -> Version -> ByteString
buildTxBodyCborWithMint @era (Map PolicyID (Map AssetName Integer) -> MultiAsset
MultiAsset Map PolicyID (Map AssetName Integer)
forall k a. Map k a
Map.empty) Version
version

      String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Empty nested asset maps in mint MultiAsset fails deserialisation since Conway" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
        Gen PolicyID -> (PolicyID -> Expectation) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen PolicyID
forall a. Arbitrary a => Gen a
arbitrary ((PolicyID -> Expectation) -> Property)
-> (PolicyID -> Expectation) -> Property
forall a b. (a -> b) -> a -> b
$ \PolicyID
policyId ->
          forall era a.
(ConwayEraImp era, DecCBOR a, Show a) =>
Version -> String -> (Version -> ByteString) -> Expectation
testMultiAssetRejection @era @(TxBody era) (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @9) String
"Conway" ((Version -> ByteString) -> Expectation)
-> (Version -> ByteString) -> Expectation
forall a b. (a -> b) -> a -> b
$ \Version
version ->
            forall era. ConwayEraImp era => MultiAsset -> Version -> ByteString
buildTxBodyCborWithMint @era (Map PolicyID (Map AssetName Integer) -> MultiAsset
MultiAsset (Map PolicyID (Map AssetName Integer) -> MultiAsset)
-> Map PolicyID (Map AssetName Integer) -> MultiAsset
forall a b. (a -> b) -> a -> b
$ PolicyID
-> Map AssetName Integer -> Map PolicyID (Map AssetName Integer)
forall k a. k -> a -> Map k a
Map.singleton PolicyID
policyId Map AssetName Integer
forall k a. Map k a
Map.empty) Version
version
  where
    -- The expectation used in this spec allows for the deserialization to fail, in which case
    -- it only checks that it fails for both decoders.
    -- This is necessary because for some arbitrarily generated values, the deserialization fails
    -- starting with Conway (for example: empty TxDats or Redeemers)
    decoderEquivalenceLenientSpec ::
      forall t. (Arbitrary t, Eq t, EncCBOR t, DecCBOR t, DecCBOR (Annotator t), Show t) => Spec
    decoderEquivalenceLenientSpec :: forall t.
(Arbitrary t, Eq t, EncCBOR t, DecCBOR t, DecCBOR (Annotator t),
 Show t) =>
Spec
decoderEquivalenceLenientSpec =
      String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop (TypeRep -> String
forall a. Show a => a -> String
show (Proxy t -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy t -> TypeRep) -> Proxy t -> TypeRep
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @t)) (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$ (t -> Expectation) -> Property
forall prop. Testable prop => prop -> Property
property ((t -> Expectation) -> Property) -> (t -> Expectation) -> Property
forall a b. (a -> b) -> a -> b
$ \(t
x :: t) ->
        [Version] -> (Version -> Expectation) -> Expectation
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [forall era. Era era => Version
eraProtVerLow @ConwayEra .. forall era. Era era => Version
eraProtVerHigh @ConwayEra] ((Version -> Expectation) -> Expectation)
-> (Version -> Expectation) -> Expectation
forall a b. (a -> b) -> a -> b
$ \Version
v ->
          forall t.
(Eq t, DecCBOR t, DecCBOR (Annotator t), Show t) =>
Version -> ByteString -> Expectation
decoderEquivalenceExpectation @t Version
v (Version -> t -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
serialize Version
v t
x)

-- | Test empty MultiAsset rejection across protocol versions
testMultiAssetRejection ::
  forall era a.
  ( ConwayEraImp era
  , DecCBOR a
  , Show a
  ) =>
  Version -> -- Protocol version when rejection starts
  String -> -- Era name for error messages
  (Version -> BSL.ByteString) -> -- CBOR constructor function
  Expectation
testMultiAssetRejection :: forall era a.
(ConwayEraImp era, DecCBOR a, Show a) =>
Version -> String -> (Version -> ByteString) -> Expectation
testMultiAssetRejection Version
rejectionVersion String
era Version -> ByteString
mkCborBytes =
  [Version] -> (Version -> Expectation) -> Expectation
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [forall era. Era era => Version
eraProtVerLow @era .. forall era. Era era => Version
eraProtVerHigh @era] ((Version -> Expectation) -> Expectation)
-> (Version -> Expectation) -> Expectation
forall a b. (a -> b) -> a -> b
$ \Version
version -> do
    let cborBytes :: ByteString
cborBytes = Version -> ByteString
mkCborBytes Version
version
    case forall a.
DecCBOR a =>
Version -> ByteString -> Either DecoderError a
decodeFull @a Version
version ByteString
cborBytes of
      Left DecoderError
err ->
        Bool -> Expectation -> Expectation
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Version
version Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= Version
rejectionVersion) (Expectation -> Expectation) -> Expectation -> Expectation
forall a b. (a -> b) -> a -> b
$
          HasCallStack => String -> Expectation
String -> Expectation
expectationFailure (String -> Expectation) -> String -> Expectation
forall a b. (a -> b) -> a -> b
$
            String
"Empty MultiAsset should succeed pre-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
era String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (version " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Version -> String
forall a. Show a => a -> String
show Version
version String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") | " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DecoderError -> String
forall a. Show a => a -> String
show DecoderError
err
      Right a
val ->
        Bool -> Expectation -> Expectation
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Version
version Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= Version
rejectionVersion) (Expectation -> Expectation) -> Expectation -> Expectation
forall a b. (a -> b) -> a -> b
$
          HasCallStack => String -> Expectation
String -> Expectation
expectationFailure (String -> Expectation) -> String -> Expectation
forall a b. (a -> b) -> a -> b
$
            String
"Empty MultiAsset should fail since " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
era String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (version " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Version -> String
forall a. Show a => a -> String
show Version
version String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") | " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
val

-- | Build TxOut CBOR with explicit MultiAsset inclusion
-- Bypasses MaryValue encoder that may optimize away empty MultiAssets
buildTxOutCborWithMultiAsset ::
  CompactAddr ->
  MultiAsset ->
  Version ->
  BSL.ByteString
buildTxOutCborWithMultiAsset :: CompactAddr -> MultiAsset -> Version -> ByteString
buildTxOutCborWithMultiAsset CompactAddr
addr MultiAsset
multiAsset Version
version =
  let coin :: Coin
coin = Integer -> Coin
Coin Integer
100
      maryValueMap :: (Coin, MultiAsset)
maryValueMap = (Coin
coin, MultiAsset
multiAsset)
      txOutMap :: Map Int Encoding
txOutMap =
        [(Int, Encoding)] -> Map Int Encoding
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
          [ (Int
0, CompactAddr -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR CompactAddr
addr)
          , (Int
1, Encoding -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR ((Coin, MultiAsset) -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (Coin, MultiAsset)
maryValueMap))
          ] ::
          Map.Map Int Encoding
   in Version -> Encoding -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
serialize Version
version (Map Int Encoding -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Map Int Encoding
txOutMap)

-- | Build TxBody CBOR with explicit mint field inclusion
-- Bypasses Conway TxBody encoder that omits empty mint fields
buildTxBodyCborWithMint ::
  forall era.
  ConwayEraImp era =>
  MultiAsset ->
  Version ->
  BSL.ByteString
buildTxBodyCborWithMint :: forall era. ConwayEraImp era => MultiAsset -> Version -> ByteString
buildTxBodyCborWithMint MultiAsset
mintMultiAsset Version
version =
  let emptyInputs :: Set TxIn
emptyInputs = Set TxIn
forall a. Set a
Set.empty :: Set.Set TxIn
      emptyOutputs :: StrictSeq (TxOut era)
emptyOutputs = StrictSeq (TxOut era)
forall a. StrictSeq a
StrictSeq.empty :: StrictSeq (TxOut era)
      zeroFee :: Coin
zeroFee = Integer -> Coin
Coin Integer
0
      txBodyMap :: Map Int Encoding
txBodyMap =
        [(Int, Encoding)] -> Map Int Encoding
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
          [ (Int
0, Set TxIn -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Set TxIn
emptyInputs)
          , (Int
1, StrictSeq (TxOut era) -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR StrictSeq (TxOut era)
emptyOutputs)
          , (Int
2, Coin -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Coin
zeroFee)
          , (Int
9, MultiAsset -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR MultiAsset
mintMultiAsset)
          ] ::
          Map.Map Int Encoding
   in Version -> Encoding -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
serialize Version
version (Map Int Encoding -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Map Int Encoding
txBodyMap)