{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

module Test.Cardano.Ledger.Core.Binary (
  BinaryUpgradeOpts (..),
  specUpgrade,
  decoderEquivalenceSpec,
  decoderEquivalenceEraSpec,
  txSizeSpec,
  decoderEquivalenceCoreEraTypesSpec,
  Mem,
) where

import Cardano.Ledger.Binary (DecCBOR, decNoShareCBOR, encodeMemPack)
import Cardano.Ledger.Core
import Cardano.Ledger.MemoBytes (EqRaw (eqRaw))
import Data.Default (Default (def))
import Lens.Micro
import qualified Prettyprinter as Pretty
import Test.Cardano.Ledger.Binary (decoderEquivalenceSpec)
import Test.Cardano.Ledger.Binary.Annotator
import Test.Cardano.Ledger.Binary.RoundTrip
import Test.Cardano.Ledger.Common
import Test.Cardano.Ledger.Core.Arbitrary ()
import Test.Cardano.Ledger.Core.Binary.Annotator
import Test.Cardano.Ledger.TreeDiff (AnsiStyle, Doc)

data BinaryUpgradeOpts = BinaryUpgradeOpts
  { BinaryUpgradeOpts -> Bool
isScriptUpgradeable :: Bool
  , BinaryUpgradeOpts -> Bool
isTxUpgradeable :: Bool
  }

instance Default BinaryUpgradeOpts where
  def :: BinaryUpgradeOpts
def =
    BinaryUpgradeOpts
      { isScriptUpgradeable :: Bool
isScriptUpgradeable = Bool
True
      , isTxUpgradeable :: Bool
isTxUpgradeable = Bool
True
      }

specTxOutUpgrade ::
  forall era.
  ( EraTxOut (PreviousEra era)
  , EraTxOut era
  , Arbitrary (TxOut (PreviousEra era))
  , HasCallStack
  ) =>
  Spec
specTxOutUpgrade :: forall era.
(EraTxOut (PreviousEra era), EraTxOut era,
 Arbitrary (TxOut (PreviousEra era)), HasCallStack) =>
Spec
specTxOutUpgrade =
  [Char] -> (TxOut (PreviousEra era) -> Expectation) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"upgradeTxOut is preserved through serialization" ((TxOut (PreviousEra era) -> Expectation) -> Spec)
-> (TxOut (PreviousEra era) -> Expectation) -> Spec
forall a b. (a -> b) -> a -> b
$ \TxOut (PreviousEra era)
prevTxOut -> do
    case Version
-> Version
-> Trip (TxOut (PreviousEra era)) (TxOut era)
-> TxOut (PreviousEra era)
-> Either RoundTripFailure (TxOut era)
forall a b.
(Eq b, Typeable b) =>
Version -> Version -> Trip a b -> a -> Either RoundTripFailure b
embedTrip (forall era. Era era => Version
eraProtVerHigh @(PreviousEra era)) (forall era. Era era => Version
eraProtVerLow @era) Trip (TxOut (PreviousEra era)) (TxOut era)
forall a b. (EncCBOR a, DecCBOR b) => Trip a b
cborTrip TxOut (PreviousEra era)
prevTxOut of
      Left RoundTripFailure
err ->
        HasCallStack => [Char] -> Expectation
[Char] -> Expectation
expectationFailure ([Char] -> Expectation) -> [Char] -> Expectation
forall a b. (a -> b) -> a -> b
$
          [Char]
"Expected to deserialize: =======================================================\n"
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ RoundTripFailure -> [Char]
forall a. Show a => a -> [Char]
show RoundTripFailure
err
      Right (TxOut era
curTxOut :: TxOut era) ->
        TxOut era
curTxOut TxOut era -> TxOut era -> Expectation
forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` TxOut (PreviousEra era) -> TxOut era
forall era.
(EraTxOut era, EraTxOut (PreviousEra era)) =>
TxOut (PreviousEra era) -> TxOut era
upgradeTxOut TxOut (PreviousEra era)
prevTxOut

specTxCertUpgrade ::
  forall era.
  ( EraTxCert (PreviousEra era)
  , EraTxCert era
  , Arbitrary (TxCert (PreviousEra era))
  , HasCallStack
  ) =>
  Spec
specTxCertUpgrade :: forall era.
(EraTxCert (PreviousEra era), EraTxCert era,
 Arbitrary (TxCert (PreviousEra era)), HasCallStack) =>
Spec
specTxCertUpgrade =
  [Char] -> (TxCert (PreviousEra era) -> Expectation) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"upgradeTxCert is preserved through serialization" ((TxCert (PreviousEra era) -> Expectation) -> Spec)
-> (TxCert (PreviousEra era) -> Expectation) -> Spec
forall a b. (a -> b) -> a -> b
$ \TxCert (PreviousEra era)
prevTxCert -> do
    case Version
-> Version
-> Trip (TxCert (PreviousEra era)) (TxCert era)
-> TxCert (PreviousEra era)
-> Either RoundTripFailure (TxCert era)
forall a b.
(Eq b, Typeable b) =>
Version -> Version -> Trip a b -> a -> Either RoundTripFailure b
embedTrip (forall era. Era era => Version
eraProtVerHigh @(PreviousEra era)) (forall era. Era era => Version
eraProtVerLow @era) Trip (TxCert (PreviousEra era)) (TxCert era)
forall a b. (EncCBOR a, DecCBOR b) => Trip a b
cborTrip TxCert (PreviousEra era)
prevTxCert of
      Left RoundTripFailure
err
        | Right TxCert era
_ <- TxCert (PreviousEra era)
-> Either (TxCertUpgradeError era) (TxCert era)
forall era.
(EraTxCert era, EraTxCert (PreviousEra era)) =>
TxCert (PreviousEra era)
-> Either (TxCertUpgradeError era) (TxCert era)
upgradeTxCert TxCert (PreviousEra era)
prevTxCert ->
            -- We expect deserialization to succeed, when upgrade is possible
            HasCallStack => [Char] -> Expectation
[Char] -> Expectation
expectationFailure ([Char] -> Expectation) -> [Char] -> Expectation
forall a b. (a -> b) -> a -> b
$
              [Char]
"Expected to deserialize: =======================================================\n"
                [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ RoundTripFailure -> [Char]
forall a. Show a => a -> [Char]
show RoundTripFailure
err
        | Bool
otherwise -> () -> Expectation
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- Both upgrade and deserializer fail successfully
      Right (TxCert era
curTxCert :: TxCert era)
        | Right TxCert era
upgradedTxCert <- TxCert (PreviousEra era)
-> Either (TxCertUpgradeError era) (TxCert era)
forall era.
(EraTxCert era, EraTxCert (PreviousEra era)) =>
TxCert (PreviousEra era)
-> Either (TxCertUpgradeError era) (TxCert era)
upgradeTxCert TxCert (PreviousEra era)
prevTxCert ->
            TxCert era
curTxCert TxCert era -> TxCert era -> Expectation
forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` TxCert era
upgradedTxCert
        | Bool
otherwise -> HasCallStack => [Char] -> Expectation
[Char] -> Expectation
expectationFailure [Char]
"Expected upgradeTxCert to succeed"

specTxAuxDataUpgrade ::
  forall era.
  ( EraTxAuxData (PreviousEra era)
  , EraTxAuxData era
  , Arbitrary (TxAuxData (PreviousEra era))
  , HasCallStack
  , ToExpr (TxAuxData era)
  , DecCBOR (Annotator (TxAuxData era))
  ) =>
  Spec
specTxAuxDataUpgrade :: forall era.
(EraTxAuxData (PreviousEra era), EraTxAuxData era,
 Arbitrary (TxAuxData (PreviousEra era)), HasCallStack,
 ToExpr (TxAuxData era), DecCBOR (Annotator (TxAuxData era))) =>
Spec
specTxAuxDataUpgrade = do
  [Char] -> (TxAuxData (PreviousEra era) -> Expectation) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"upgradeTxAuxData is preserved through serialization (Annotator)" ((TxAuxData (PreviousEra era) -> Expectation) -> Spec)
-> (TxAuxData (PreviousEra era) -> Expectation) -> Spec
forall a b. (a -> b) -> a -> b
$ \TxAuxData (PreviousEra era)
prevTxAuxData -> do
    case Version
-> Version
-> TxAuxData (PreviousEra era)
-> Either RoundTripFailure (TxAuxData era)
forall a b.
(ToCBOR a, DecCBOR (Annotator b)) =>
Version -> Version -> a -> Either RoundTripFailure b
embedTripAnn (forall era. Era era => Version
eraProtVerHigh @(PreviousEra era)) (forall era. Era era => Version
eraProtVerLow @era) TxAuxData (PreviousEra era)
prevTxAuxData of
      Left RoundTripFailure
err ->
        HasCallStack => [Char] -> Expectation
[Char] -> Expectation
expectationFailure ([Char] -> Expectation) -> [Char] -> Expectation
forall a b. (a -> b) -> a -> b
$
          [Char]
"Expected to deserialize: =======================================================\n"
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ RoundTripFailure -> [Char]
forall a. Show a => a -> [Char]
show RoundTripFailure
err
      Right (TxAuxData era
curTxAuxData :: TxAuxData era) -> do
        let upgradedTxAuxData :: TxAuxData era
upgradedTxAuxData = TxAuxData (PreviousEra era) -> TxAuxData era
forall era.
(EraTxAuxData era, EraTxAuxData (PreviousEra era)) =>
TxAuxData (PreviousEra era) -> TxAuxData era
upgradeTxAuxData TxAuxData (PreviousEra era)
prevTxAuxData
        Doc AnsiStyle -> TxAuxData era -> TxAuxData era -> Expectation
forall a.
(EqRaw a, ToExpr a, HasCallStack) =>
Doc AnsiStyle -> a -> a -> Expectation
expectRawEqual Doc AnsiStyle
"TxAuxData" TxAuxData era
curTxAuxData TxAuxData era
upgradedTxAuxData
  [Char] -> (TxAuxData (PreviousEra era) -> Expectation) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"upgradeTxAuxData is preserved through serialization" ((TxAuxData (PreviousEra era) -> Expectation) -> Spec)
-> (TxAuxData (PreviousEra era) -> Expectation) -> Spec
forall a b. (a -> b) -> a -> b
$ \TxAuxData (PreviousEra era)
prevTxAuxData -> do
    case Version
-> Version
-> Trip (TxAuxData (PreviousEra era)) (TxAuxData era)
-> TxAuxData (PreviousEra era)
-> Either RoundTripFailure (TxAuxData era)
forall a b.
(Eq b, Typeable b) =>
Version -> Version -> Trip a b -> a -> Either RoundTripFailure b
embedTrip (forall era. Era era => Version
eraProtVerHigh @(PreviousEra era)) (forall era. Era era => Version
eraProtVerLow @era) Trip (TxAuxData (PreviousEra era)) (TxAuxData era)
forall a b. (EncCBOR a, DecCBOR b) => Trip a b
cborTrip TxAuxData (PreviousEra era)
prevTxAuxData of
      Left RoundTripFailure
err ->
        HasCallStack => [Char] -> Expectation
[Char] -> Expectation
expectationFailure ([Char] -> Expectation) -> [Char] -> Expectation
forall a b. (a -> b) -> a -> b
$
          [Char]
"Expected to deserialize: =======================================================\n"
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ RoundTripFailure -> [Char]
forall a. Show a => a -> [Char]
show RoundTripFailure
err
      Right (TxAuxData era
curTxAuxData :: TxAuxData era) -> do
        let upgradedTxAuxData :: TxAuxData era
upgradedTxAuxData = TxAuxData (PreviousEra era) -> TxAuxData era
forall era.
(EraTxAuxData era, EraTxAuxData (PreviousEra era)) =>
TxAuxData (PreviousEra era) -> TxAuxData era
upgradeTxAuxData TxAuxData (PreviousEra era)
prevTxAuxData
        Doc AnsiStyle -> TxAuxData era -> TxAuxData era -> Expectation
forall a.
(EqRaw a, ToExpr a, HasCallStack) =>
Doc AnsiStyle -> a -> a -> Expectation
expectRawEqual Doc AnsiStyle
"TxAuxData" TxAuxData era
curTxAuxData TxAuxData era
upgradedTxAuxData

specScriptUpgrade ::
  forall era.
  ( EraScript (PreviousEra era)
  , EraScript era
  , Arbitrary (Script (PreviousEra era))
  , DecCBOR (Annotator (Script era))
  , HasCallStack
  ) =>
  Spec
specScriptUpgrade :: forall era.
(EraScript (PreviousEra era), EraScript era,
 Arbitrary (Script (PreviousEra era)),
 DecCBOR (Annotator (Script era)), HasCallStack) =>
Spec
specScriptUpgrade = do
  [Char] -> (Script (PreviousEra era) -> Expectation) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"upgradeScript is preserved through serialization (Annotator)" ((Script (PreviousEra era) -> Expectation) -> Spec)
-> (Script (PreviousEra era) -> Expectation) -> Spec
forall a b. (a -> b) -> a -> b
$ \Script (PreviousEra era)
prevScript -> do
    case Version
-> Version
-> Script (PreviousEra era)
-> Either RoundTripFailure (Script era)
forall a b.
(ToCBOR a, DecCBOR (Annotator b)) =>
Version -> Version -> a -> Either RoundTripFailure b
embedTripAnn (forall era. Era era => Version
eraProtVerHigh @(PreviousEra era)) (forall era. Era era => Version
eraProtVerLow @era) Script (PreviousEra era)
prevScript of
      Left RoundTripFailure
err ->
        HasCallStack => [Char] -> Expectation
[Char] -> Expectation
expectationFailure ([Char] -> Expectation) -> [Char] -> Expectation
forall a b. (a -> b) -> a -> b
$
          [Char]
"Expected to deserialize: =======================================================\n"
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ RoundTripFailure -> [Char]
forall a. Show a => a -> [Char]
show RoundTripFailure
err
      Right (Script era
curScript :: Script era) ->
        Script era
curScript Script era -> Script era -> Expectation
forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` Script (PreviousEra era) -> Script era
forall era.
(EraScript era, EraScript (PreviousEra era)) =>
Script (PreviousEra era) -> Script era
upgradeScript Script (PreviousEra era)
prevScript
  [Char] -> (Script (PreviousEra era) -> Expectation) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"upgradeScript is preserved through serialization" ((Script (PreviousEra era) -> Expectation) -> Spec)
-> (Script (PreviousEra era) -> Expectation) -> Spec
forall a b. (a -> b) -> a -> b
$ \Script (PreviousEra era)
prevScript -> do
    case Version
-> Version
-> Trip (Script (PreviousEra era)) (Script era)
-> Script (PreviousEra era)
-> Either RoundTripFailure (Script era)
forall a b.
(Eq b, Typeable b) =>
Version -> Version -> Trip a b -> a -> Either RoundTripFailure b
embedTrip (forall era. Era era => Version
eraProtVerHigh @(PreviousEra era)) (forall era. Era era => Version
eraProtVerLow @era) Trip (Script (PreviousEra era)) (Script era)
forall a b. (EncCBOR a, DecCBOR b) => Trip a b
cborTrip Script (PreviousEra era)
prevScript of
      Left RoundTripFailure
err ->
        HasCallStack => [Char] -> Expectation
[Char] -> Expectation
expectationFailure ([Char] -> Expectation) -> [Char] -> Expectation
forall a b. (a -> b) -> a -> b
$
          [Char]
"Expected to deserialize: =======================================================\n"
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ RoundTripFailure -> [Char]
forall a. Show a => a -> [Char]
show RoundTripFailure
err
      Right (Script era
curScript :: Script era) ->
        Script era
curScript Script era -> Script era -> Expectation
forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` Script (PreviousEra era) -> Script era
forall era.
(EraScript era, EraScript (PreviousEra era)) =>
Script (PreviousEra era) -> Script era
upgradeScript Script (PreviousEra era)
prevScript

specTxWitsUpgrade ::
  forall era.
  ( EraTxWits (PreviousEra era)
  , EraTxWits era
  , Arbitrary (TxWits (PreviousEra era))
  , HasCallStack
  , ToExpr (TxWits era)
  , DecCBOR (Annotator (TxWits era))
  ) =>
  Spec
specTxWitsUpgrade :: forall era.
(EraTxWits (PreviousEra era), EraTxWits era,
 Arbitrary (TxWits (PreviousEra era)), HasCallStack,
 ToExpr (TxWits era), DecCBOR (Annotator (TxWits era))) =>
Spec
specTxWitsUpgrade = do
  [Char] -> (TxWits (PreviousEra era) -> Expectation) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"upgradeTxWits is preserved through serialization (Annotator)" ((TxWits (PreviousEra era) -> Expectation) -> Spec)
-> (TxWits (PreviousEra era) -> Expectation) -> Spec
forall a b. (a -> b) -> a -> b
$ \TxWits (PreviousEra era)
prevTxWits -> do
    case Version
-> Version
-> TxWits (PreviousEra era)
-> Either RoundTripFailure (TxWits era)
forall a b.
(ToCBOR a, DecCBOR (Annotator b)) =>
Version -> Version -> a -> Either RoundTripFailure b
embedTripAnn (forall era. Era era => Version
eraProtVerHigh @(PreviousEra era)) (forall era. Era era => Version
eraProtVerLow @era) TxWits (PreviousEra era)
prevTxWits of
      Left RoundTripFailure
err ->
        HasCallStack => [Char] -> Expectation
[Char] -> Expectation
expectationFailure ([Char] -> Expectation) -> [Char] -> Expectation
forall a b. (a -> b) -> a -> b
$
          [Char]
"Expected to deserialize: =======================================================\n"
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ RoundTripFailure -> [Char]
forall a. Show a => a -> [Char]
show RoundTripFailure
err
      Right (TxWits era
curTxWits :: TxWits era) -> do
        let upgradedTxWits :: TxWits era
upgradedTxWits = TxWits (PreviousEra era) -> TxWits era
forall era.
(EraTxWits era, EraTxWits (PreviousEra era)) =>
TxWits (PreviousEra era) -> TxWits era
upgradeTxWits TxWits (PreviousEra era)
prevTxWits
        Doc AnsiStyle -> TxWits era -> TxWits era -> Expectation
forall a.
(EqRaw a, ToExpr a, HasCallStack) =>
Doc AnsiStyle -> a -> a -> Expectation
expectRawEqual Doc AnsiStyle
"TxWits" TxWits era
curTxWits TxWits era
upgradedTxWits
  [Char] -> (TxWits (PreviousEra era) -> Expectation) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"upgradeTxWits is preserved through serialization" ((TxWits (PreviousEra era) -> Expectation) -> Spec)
-> (TxWits (PreviousEra era) -> Expectation) -> Spec
forall a b. (a -> b) -> a -> b
$ \TxWits (PreviousEra era)
prevTxWits -> do
    case Version
-> Version
-> Trip (TxWits (PreviousEra era)) (TxWits era)
-> TxWits (PreviousEra era)
-> Either RoundTripFailure (TxWits era)
forall a b.
(Eq b, Typeable b) =>
Version -> Version -> Trip a b -> a -> Either RoundTripFailure b
embedTrip (forall era. Era era => Version
eraProtVerHigh @(PreviousEra era)) (forall era. Era era => Version
eraProtVerLow @era) Trip (TxWits (PreviousEra era)) (TxWits era)
forall a b. (EncCBOR a, DecCBOR b) => Trip a b
cborTrip TxWits (PreviousEra era)
prevTxWits of
      Left RoundTripFailure
err ->
        HasCallStack => [Char] -> Expectation
[Char] -> Expectation
expectationFailure ([Char] -> Expectation) -> [Char] -> Expectation
forall a b. (a -> b) -> a -> b
$
          [Char]
"Expected to deserialize: =======================================================\n"
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ RoundTripFailure -> [Char]
forall a. Show a => a -> [Char]
show RoundTripFailure
err
      Right (TxWits era
curTxWits :: TxWits era) -> do
        let upgradedTxWits :: TxWits era
upgradedTxWits = TxWits (PreviousEra era) -> TxWits era
forall era.
(EraTxWits era, EraTxWits (PreviousEra era)) =>
TxWits (PreviousEra era) -> TxWits era
upgradeTxWits TxWits (PreviousEra era)
prevTxWits
        Doc AnsiStyle -> TxWits era -> TxWits era -> Expectation
forall a.
(EqRaw a, ToExpr a, HasCallStack) =>
Doc AnsiStyle -> a -> a -> Expectation
expectRawEqual Doc AnsiStyle
"TxWits" TxWits era
curTxWits TxWits era
upgradedTxWits

specTxBodyUpgrade ::
  forall era.
  ( EraTxBody (PreviousEra era)
  , EraTxBody era
  , Arbitrary (TxBody (PreviousEra era))
  , HasCallStack
  , ToExpr (TxBody era)
  , DecCBOR (Annotator (TxBody era))
  ) =>
  Spec
specTxBodyUpgrade :: forall era.
(EraTxBody (PreviousEra era), EraTxBody era,
 Arbitrary (TxBody (PreviousEra era)), HasCallStack,
 ToExpr (TxBody era), DecCBOR (Annotator (TxBody era))) =>
Spec
specTxBodyUpgrade = do
  [Char] -> (TxBody (PreviousEra era) -> Expectation) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"upgradeTxBody is preserved through serialization (Annotator)" ((TxBody (PreviousEra era) -> Expectation) -> Spec)
-> (TxBody (PreviousEra era) -> Expectation) -> Spec
forall a b. (a -> b) -> a -> b
$ \TxBody (PreviousEra era)
prevTxBody -> do
    case Version
-> Version
-> TxBody (PreviousEra era)
-> Either RoundTripFailure (TxBody era)
forall a b.
(ToCBOR a, DecCBOR (Annotator b)) =>
Version -> Version -> a -> Either RoundTripFailure b
embedTripAnn (forall era. Era era => Version
eraProtVerHigh @(PreviousEra era)) (forall era. Era era => Version
eraProtVerLow @era) TxBody (PreviousEra era)
prevTxBody of
      Left RoundTripFailure
err
        | Right TxBody era
_ <- TxBody (PreviousEra era)
-> Either (TxBodyUpgradeError era) (TxBody era)
forall era.
(EraTxBody era, EraTxBody (PreviousEra era)) =>
TxBody (PreviousEra era)
-> Either (TxBodyUpgradeError era) (TxBody era)
upgradeTxBody TxBody (PreviousEra era)
prevTxBody ->
            -- We expect deserialization to succeed, when upgrade is possible
            HasCallStack => [Char] -> Expectation
[Char] -> Expectation
expectationFailure ([Char] -> Expectation) -> [Char] -> Expectation
forall a b. (a -> b) -> a -> b
$
              [Char]
"Expected to deserialize: =======================================================\n"
                [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ RoundTripFailure -> [Char]
forall a. Show a => a -> [Char]
show RoundTripFailure
err
        | Bool
otherwise -> () -> Expectation
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- Both upgrade and deserializer fail successfully
      Right (TxBody era
curTxBody :: TxBody era)
        | Right TxBody era
upgradedTxBody <- TxBody (PreviousEra era)
-> Either (TxBodyUpgradeError era) (TxBody era)
forall era.
(EraTxBody era, EraTxBody (PreviousEra era)) =>
TxBody (PreviousEra era)
-> Either (TxBodyUpgradeError era) (TxBody era)
upgradeTxBody TxBody (PreviousEra era)
prevTxBody ->
            Doc AnsiStyle -> TxBody era -> TxBody era -> Expectation
forall a.
(EqRaw a, ToExpr a, HasCallStack) =>
Doc AnsiStyle -> a -> a -> Expectation
expectRawEqual Doc AnsiStyle
"TxBody" TxBody era
curTxBody TxBody era
upgradedTxBody
        | Bool
otherwise -> HasCallStack => [Char] -> Expectation
[Char] -> Expectation
expectationFailure [Char]
"Expected upgradeTxBody to succeed"
  [Char] -> (TxBody (PreviousEra era) -> Expectation) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"upgradeTxBody is preserved through serialization" ((TxBody (PreviousEra era) -> Expectation) -> Spec)
-> (TxBody (PreviousEra era) -> Expectation) -> Spec
forall a b. (a -> b) -> a -> b
$ \TxBody (PreviousEra era)
prevTxBody -> do
    case Version
-> Version
-> Trip (TxBody (PreviousEra era)) (TxBody era)
-> TxBody (PreviousEra era)
-> Either RoundTripFailure (TxBody era)
forall a b.
(Eq b, Typeable b) =>
Version -> Version -> Trip a b -> a -> Either RoundTripFailure b
embedTrip (forall era. Era era => Version
eraProtVerHigh @(PreviousEra era)) (forall era. Era era => Version
eraProtVerLow @era) Trip (TxBody (PreviousEra era)) (TxBody era)
forall a b. (EncCBOR a, DecCBOR b) => Trip a b
cborTrip TxBody (PreviousEra era)
prevTxBody of
      Left RoundTripFailure
err
        | Right TxBody era
_ <- TxBody (PreviousEra era)
-> Either (TxBodyUpgradeError era) (TxBody era)
forall era.
(EraTxBody era, EraTxBody (PreviousEra era)) =>
TxBody (PreviousEra era)
-> Either (TxBodyUpgradeError era) (TxBody era)
upgradeTxBody TxBody (PreviousEra era)
prevTxBody ->
            -- We expect deserialization to succeed, when upgrade is possible
            HasCallStack => [Char] -> Expectation
[Char] -> Expectation
expectationFailure ([Char] -> Expectation) -> [Char] -> Expectation
forall a b. (a -> b) -> a -> b
$
              [Char]
"Expected to deserialize: =======================================================\n"
                [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ RoundTripFailure -> [Char]
forall a. Show a => a -> [Char]
show RoundTripFailure
err
        | Bool
otherwise -> () -> Expectation
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- Both upgrade and deserializer fail successfully
      Right (TxBody era
curTxBody :: TxBody era)
        | Right TxBody era
upgradedTxBody <- TxBody (PreviousEra era)
-> Either (TxBodyUpgradeError era) (TxBody era)
forall era.
(EraTxBody era, EraTxBody (PreviousEra era)) =>
TxBody (PreviousEra era)
-> Either (TxBodyUpgradeError era) (TxBody era)
upgradeTxBody TxBody (PreviousEra era)
prevTxBody ->
            Doc AnsiStyle -> TxBody era -> TxBody era -> Expectation
forall a.
(EqRaw a, ToExpr a, HasCallStack) =>
Doc AnsiStyle -> a -> a -> Expectation
expectRawEqual Doc AnsiStyle
"TxBody" TxBody era
curTxBody TxBody era
upgradedTxBody
        | Bool
otherwise -> HasCallStack => [Char] -> Expectation
[Char] -> Expectation
expectationFailure [Char]
"Expected upgradeTxBody to succeed"

specTxUpgrade ::
  forall era.
  ( EraTx (PreviousEra era)
  , EraTx era
  , Arbitrary (Tx (PreviousEra era))
  , HasCallStack
  , ToExpr (Tx era)
  , DecCBOR (Annotator (Tx era))
  ) =>
  Spec
specTxUpgrade :: forall era.
(EraTx (PreviousEra era), EraTx era,
 Arbitrary (Tx (PreviousEra era)), HasCallStack, ToExpr (Tx era),
 DecCBOR (Annotator (Tx era))) =>
Spec
specTxUpgrade = do
  [Char] -> (Tx (PreviousEra era) -> Expectation) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"upgradeTx is preserved through serialization (Annotator)" ((Tx (PreviousEra era) -> Expectation) -> Spec)
-> (Tx (PreviousEra era) -> Expectation) -> Spec
forall a b. (a -> b) -> a -> b
$ \Tx (PreviousEra era)
prevTx -> do
    case Version
-> Version
-> Tx (PreviousEra era)
-> Either RoundTripFailure (Tx era)
forall a b.
(ToCBOR a, DecCBOR (Annotator b)) =>
Version -> Version -> a -> Either RoundTripFailure b
embedTripAnn (forall era. Era era => Version
eraProtVerHigh @(PreviousEra era)) (forall era. Era era => Version
eraProtVerLow @era) Tx (PreviousEra era)
prevTx of
      Left RoundTripFailure
err
        | Right Tx era
_ <- Tx (PreviousEra era) -> Either (TxUpgradeError era) (Tx era)
forall era.
(EraTx era, EraTx (PreviousEra era)) =>
Tx (PreviousEra era) -> Either (TxUpgradeError era) (Tx era)
upgradeTx Tx (PreviousEra era)
prevTx ->
            -- We expect deserialization to succeed, when upgrade is possible
            HasCallStack => [Char] -> Expectation
[Char] -> Expectation
expectationFailure ([Char] -> Expectation) -> [Char] -> Expectation
forall a b. (a -> b) -> a -> b
$
              [Char]
"Expected to deserialize: =======================================================\n"
                [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ RoundTripFailure -> [Char]
forall a. Show a => a -> [Char]
show RoundTripFailure
err
        | Bool
otherwise -> () -> Expectation
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- Both upgrade and deserializer fail successfully
      Right (Tx era
curTx :: Tx era)
        | Right Tx era
upgradedTx <- Tx (PreviousEra era) -> Either (TxUpgradeError era) (Tx era)
forall era.
(EraTx era, EraTx (PreviousEra era)) =>
Tx (PreviousEra era) -> Either (TxUpgradeError era) (Tx era)
upgradeTx Tx (PreviousEra era)
prevTx ->
            Doc AnsiStyle -> Tx era -> Tx era -> Expectation
forall a.
(EqRaw a, ToExpr a, HasCallStack) =>
Doc AnsiStyle -> a -> a -> Expectation
expectRawEqual Doc AnsiStyle
"Tx" Tx era
curTx Tx era
upgradedTx
        | Bool
otherwise -> HasCallStack => [Char] -> Expectation
[Char] -> Expectation
expectationFailure [Char]
"Expected upgradeTx to succeed"
  [Char] -> (Tx (PreviousEra era) -> Expectation) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"upgradeTx is preserved through serialization" ((Tx (PreviousEra era) -> Expectation) -> Spec)
-> (Tx (PreviousEra era) -> Expectation) -> Spec
forall a b. (a -> b) -> a -> b
$ \Tx (PreviousEra era)
prevTx -> do
    case Version
-> Version
-> Trip (Tx (PreviousEra era)) (Tx era)
-> Tx (PreviousEra era)
-> Either RoundTripFailure (Tx era)
forall a b.
(Eq b, Typeable b) =>
Version -> Version -> Trip a b -> a -> Either RoundTripFailure b
embedTrip (forall era. Era era => Version
eraProtVerHigh @(PreviousEra era)) (forall era. Era era => Version
eraProtVerLow @era) Trip (Tx (PreviousEra era)) (Tx era)
forall a b. (EncCBOR a, DecCBOR b) => Trip a b
cborTrip Tx (PreviousEra era)
prevTx of
      Left RoundTripFailure
err
        | Right Tx era
_ <- Tx (PreviousEra era) -> Either (TxUpgradeError era) (Tx era)
forall era.
(EraTx era, EraTx (PreviousEra era)) =>
Tx (PreviousEra era) -> Either (TxUpgradeError era) (Tx era)
upgradeTx Tx (PreviousEra era)
prevTx ->
            -- We expect deserialization to succeed, when upgrade is possible
            HasCallStack => [Char] -> Expectation
[Char] -> Expectation
expectationFailure ([Char] -> Expectation) -> [Char] -> Expectation
forall a b. (a -> b) -> a -> b
$
              [Char]
"Expected to deserialize: =======================================================\n"
                [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ RoundTripFailure -> [Char]
forall a. Show a => a -> [Char]
show RoundTripFailure
err
        | Bool
otherwise -> () -> Expectation
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- Both upgrade and deserializer fail successfully
      Right (Tx era
curTx :: Tx era)
        | Right Tx era
upgradedTx <- Tx (PreviousEra era) -> Either (TxUpgradeError era) (Tx era)
forall era.
(EraTx era, EraTx (PreviousEra era)) =>
Tx (PreviousEra era) -> Either (TxUpgradeError era) (Tx era)
upgradeTx Tx (PreviousEra era)
prevTx ->
            Doc AnsiStyle -> Tx era -> Tx era -> Expectation
forall a.
(EqRaw a, ToExpr a, HasCallStack) =>
Doc AnsiStyle -> a -> a -> Expectation
expectRawEqual Doc AnsiStyle
"Tx" Tx era
curTx Tx era
upgradedTx
        | Bool
otherwise -> HasCallStack => [Char] -> Expectation
[Char] -> Expectation
expectationFailure [Char]
"Expected upgradeTx to succeed"

specUpgrade ::
  forall era.
  ( Arbitrary (TxOut (PreviousEra era))
  , Arbitrary (TxCert (PreviousEra era))
  , Arbitrary (TxAuxData (PreviousEra era))
  , Arbitrary (TxWits (PreviousEra era))
  , Arbitrary (TxBody (PreviousEra era))
  , EraTx (PreviousEra era)
  , EraTx era
  , Arbitrary (Tx (PreviousEra era))
  , Arbitrary (Script (PreviousEra era))
  , HasCallStack
  , ToExpr (Tx era)
  , ToExpr (TxBody era)
  , ToExpr (TxWits era)
  , ToExpr (TxAuxData era)
  , DecCBOR (Annotator (TxAuxData era))
  , DecCBOR (Annotator (Script era))
  , DecCBOR (Annotator (TxWits era))
  , DecCBOR (Annotator (TxBody era))
  , DecCBOR (Annotator (Tx era))
  ) =>
  BinaryUpgradeOpts ->
  Spec
specUpgrade :: forall era.
(Arbitrary (TxOut (PreviousEra era)),
 Arbitrary (TxCert (PreviousEra era)),
 Arbitrary (TxAuxData (PreviousEra era)),
 Arbitrary (TxWits (PreviousEra era)),
 Arbitrary (TxBody (PreviousEra era)), EraTx (PreviousEra era),
 EraTx era, Arbitrary (Tx (PreviousEra era)),
 Arbitrary (Script (PreviousEra era)), HasCallStack,
 ToExpr (Tx era), ToExpr (TxBody era), ToExpr (TxWits era),
 ToExpr (TxAuxData era), DecCBOR (Annotator (TxAuxData era)),
 DecCBOR (Annotator (Script era)), DecCBOR (Annotator (TxWits era)),
 DecCBOR (Annotator (TxBody era)), DecCBOR (Annotator (Tx era))) =>
BinaryUpgradeOpts -> Spec
specUpgrade BinaryUpgradeOpts {Bool
isScriptUpgradeable :: BinaryUpgradeOpts -> Bool
isScriptUpgradeable :: Bool
isScriptUpgradeable, Bool
isTxUpgradeable :: BinaryUpgradeOpts -> Bool
isTxUpgradeable :: Bool
isTxUpgradeable} =
  [Char] -> Spec -> Spec
forall a. HasCallStack => [Char] -> SpecWith a -> SpecWith a
describe ([Char]
"Upgrade from " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ forall era. Era era => [Char]
eraName @(PreviousEra era) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" to " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ forall era. Era era => [Char]
eraName @era) (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    forall era.
(EraTxOut (PreviousEra era), EraTxOut era,
 Arbitrary (TxOut (PreviousEra era)), HasCallStack) =>
Spec
specTxOutUpgrade @era
    forall era.
(EraTxCert (PreviousEra era), EraTxCert era,
 Arbitrary (TxCert (PreviousEra era)), HasCallStack) =>
Spec
specTxCertUpgrade @era
    forall era.
(EraTxAuxData (PreviousEra era), EraTxAuxData era,
 Arbitrary (TxAuxData (PreviousEra era)), HasCallStack,
 ToExpr (TxAuxData era), DecCBOR (Annotator (TxAuxData era))) =>
Spec
specTxAuxDataUpgrade @era
    forall era.
(EraTxWits (PreviousEra era), EraTxWits era,
 Arbitrary (TxWits (PreviousEra era)), HasCallStack,
 ToExpr (TxWits era), DecCBOR (Annotator (TxWits era))) =>
Spec
specTxWitsUpgrade @era
    forall era.
(EraTxBody (PreviousEra era), EraTxBody era,
 Arbitrary (TxBody (PreviousEra era)), HasCallStack,
 ToExpr (TxBody era), DecCBOR (Annotator (TxBody era))) =>
Spec
specTxBodyUpgrade @era
    Bool -> Spec -> Spec
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isTxUpgradeable (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$
      forall era.
(EraTx (PreviousEra era), EraTx era,
 Arbitrary (Tx (PreviousEra era)), HasCallStack, ToExpr (Tx era),
 DecCBOR (Annotator (Tx era))) =>
Spec
specTxUpgrade @era
    Bool -> Spec -> Spec
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isScriptUpgradeable (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$
      forall era.
(EraScript (PreviousEra era), EraScript era,
 Arbitrary (Script (PreviousEra era)),
 DecCBOR (Annotator (Script era)), HasCallStack) =>
Spec
specScriptUpgrade @era
    -- This is a test that ensures that binary version of a TxOut is backwards compatible as it is
    -- stored in the ledger state. This property is only important for using MemPack with UTxOHD
    Version
-> Version
-> Trip (TxOut (PreviousEra era)) (TxOut era)
-> (TxOut era -> TxOut (PreviousEra era) -> Expectation)
-> Spec
forall a b.
(Show a, Typeable a, Typeable b, Arbitrary a, Eq b,
 HasCallStack) =>
Version -> Version -> Trip a b -> (b -> a -> Expectation) -> Spec
embedTripSpec
      (forall era. Era era => Version
eraProtVerHigh @(PreviousEra era))
      (forall era. Era era => Version
eraProtVerLow @era)
      ((TxOut (PreviousEra era) -> Encoding)
-> (forall s. Decoder s (TxOut era))
-> Trip (TxOut (PreviousEra era)) (TxOut era)
forall a b. (a -> Encoding) -> (forall s. Decoder s b) -> Trip a b
mkTrip TxOut (PreviousEra era) -> Encoding
forall a. MemPack a => a -> Encoding
encodeMemPack Decoder s (TxOut era)
forall s. Decoder s (TxOut era)
forall a s. DecShareCBOR a => Decoder s a
decNoShareCBOR)
      ((TxOut era -> TxOut (PreviousEra era) -> Expectation) -> Spec)
-> (TxOut era -> TxOut (PreviousEra era) -> Expectation) -> Spec
forall a b. (a -> b) -> a -> b
$ \(TxOut era
txOutCur :: TxOut era) (TxOut (PreviousEra era)
txOutPrev :: TxOut (PreviousEra era)) ->
        TxOut (PreviousEra era) -> TxOut era
forall era.
(EraTxOut era, EraTxOut (PreviousEra era)) =>
TxOut (PreviousEra era) -> TxOut era
upgradeTxOut TxOut (PreviousEra era)
txOutPrev TxOut era -> TxOut era -> Expectation
forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` TxOut era
txOutCur

expectRawEqual :: (EqRaw a, ToExpr a, HasCallStack) => Doc AnsiStyle -> a -> a -> Expectation
expectRawEqual :: forall a.
(EqRaw a, ToExpr a, HasCallStack) =>
Doc AnsiStyle -> a -> a -> Expectation
expectRawEqual Doc AnsiStyle
thing a
expected a
actual =
  Bool -> Expectation -> Expectation
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (a -> a -> Bool
forall a. EqRaw a => a -> a -> Bool
eqRaw a
expected a
actual) (Expectation -> Expectation) -> Expectation -> Expectation
forall a b. (a -> b) -> a -> b
$
    [Char] -> Expectation
forall a. HasCallStack => [Char] -> IO a
assertColorFailure ([Char] -> Expectation)
-> (Doc AnsiStyle -> [Char]) -> Doc AnsiStyle -> Expectation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc AnsiStyle -> [Char]
ansiDocToString (Doc AnsiStyle -> Expectation) -> Doc AnsiStyle -> Expectation
forall a b. (a -> b) -> a -> b
$
      [Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
Pretty.vsep
        [ [Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
Pretty.hsep [Doc AnsiStyle
"Expected raw representation of", Doc AnsiStyle
thing, Doc AnsiStyle
"to be equal:"]
        , Int -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Int -> Doc ann -> Doc ann
Pretty.indent Int
2 (Doc AnsiStyle -> Doc AnsiStyle) -> Doc AnsiStyle -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ a -> a -> Doc AnsiStyle
forall a. ToExpr a => a -> a -> Doc AnsiStyle
diffExpr a
expected a
actual
        ]

txSizeSpec ::
  forall era.
  ( EraTx era
  , Arbitrary (Tx era)
  , SafeToHash (TxWits era)
  ) =>
  Spec
txSizeSpec :: forall era.
(EraTx era, Arbitrary (Tx era), SafeToHash (TxWits era)) =>
Spec
txSizeSpec =
  [Char] -> Spec -> Spec
forall a. HasCallStack => [Char] -> SpecWith a -> SpecWith a
describe [Char]
"Transaction size" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    [Char] -> (Tx era -> Expectation) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"should match the size of the cbor encoding" ((Tx era -> Expectation) -> Spec)
-> (Tx era -> Expectation) -> Spec
forall a b. (a -> b) -> a -> b
$ \(Tx era
tx :: Tx era) -> do
      let txSize :: Integer
txSize = Tx era -> Integer
forall era.
(EraTx era, SafeToHash (TxWits era)) =>
Tx era -> Integer
sizeTxForFeeCalculation Tx era
tx
      Integer
txSize Integer -> Integer -> Expectation
forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` Tx era
tx Tx era -> Getting Integer (Tx era) Integer -> Integer
forall s a. s -> Getting a s a -> a
^. Getting Integer (Tx era) Integer
forall era. EraTx era => SimpleGetter (Tx era) Integer
SimpleGetter (Tx era) Integer
sizeTxF