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

module Test.Cardano.Ledger.Api.Upgrade (
  BinaryUpgradeOpts (..),
  spec,
) where

import Cardano.Ledger.Api.Era (EraApi (..))
import Cardano.Ledger.Binary (DecCBOR, decNoShareCBOR, encodeMemPack)
import Cardano.Ledger.Core
import Cardano.Ledger.MemoBytes (EqRaw (eqRaw))
import Data.Default (Default (def))
import qualified Prettyprinter as Pretty
import Test.Cardano.Ledger.Binary.RoundTrip
import Test.Cardano.Ledger.Common
import Test.Cardano.Ledger.Core.Arbitrary ()
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.
  ( EraApi era
  , EraTxOut (PreviousEra era)
  , Arbitrary (TxOut (PreviousEra era))
  , HasCallStack
  ) =>
  Spec
specTxOutUpgrade :: forall era.
(EraApi era, EraTxOut (PreviousEra 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.
  ( EraApi era
  , EraTxCert (PreviousEra era)
  , Arbitrary (TxCert (PreviousEra era))
  , HasCallStack
  ) =>
  Spec
specTxCertUpgrade :: forall era.
(EraApi era, EraTxCert (PreviousEra 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.
  ( EraApi era
  , EraTxAuxData (PreviousEra era)
  , Arbitrary (TxAuxData (PreviousEra era))
  , HasCallStack
  , ToExpr (TxAuxData era)
  , DecCBOR (TxAuxData era)
  ) =>
  Spec
specTxAuxDataUpgrade :: forall era.
(EraApi era, EraTxAuxData (PreviousEra era),
 Arbitrary (TxAuxData (PreviousEra era)), HasCallStack,
 ToExpr (TxAuxData era), DecCBOR (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.
(EraApi 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.
(EraApi 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.
  ( EraApi era
  , EraScript (PreviousEra era)
  , Arbitrary (Script (PreviousEra era))
  , DecCBOR (Script era)
  , HasCallStack
  ) =>
  Spec
specScriptUpgrade :: forall era.
(EraApi era, EraScript (PreviousEra era),
 Arbitrary (Script (PreviousEra era)), DecCBOR (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.
  ( EraApi era
  , EraTxWits (PreviousEra era)
  , Arbitrary (TxWits (PreviousEra era))
  , HasCallStack
  , ToExpr (TxWits era)
  , DecCBOR (TxWits era)
  ) =>
  Spec
specTxWitsUpgrade :: forall era.
(EraApi era, EraTxWits (PreviousEra era),
 Arbitrary (TxWits (PreviousEra era)), HasCallStack,
 ToExpr (TxWits era), DecCBOR (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.
(EraApi 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.
(EraApi 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.
  ( EraApi era
  , EraTxBody (PreviousEra era)
  , Arbitrary (TxBody (PreviousEra era))
  , HasCallStack
  , ToExpr (TxBody era)
  , DecCBOR (TxBody era)
  ) =>
  Spec
specTxBodyUpgrade :: forall era.
(EraApi era, EraTxBody (PreviousEra era),
 Arbitrary (TxBody (PreviousEra era)), HasCallStack,
 ToExpr (TxBody era), DecCBOR (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.
(EraApi 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.
(EraApi 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.
(EraApi 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.
(EraApi 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.
  ( EraApi era
  , EraTx (PreviousEra era)
  , Arbitrary (Tx (PreviousEra era))
  , HasCallStack
  , ToExpr (Tx era)
  , DecCBOR (Tx era)
  ) =>
  Spec
specTxUpgrade :: forall era.
(EraApi era, EraTx (PreviousEra era),
 Arbitrary (Tx (PreviousEra era)), HasCallStack, ToExpr (Tx era),
 DecCBOR (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.
(EraApi 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.
(EraApi 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.
(EraApi 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.
(EraApi 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"

spec ::
  forall era.
  ( EraApi era
  , Arbitrary (TxOut (PreviousEra era))
  , Arbitrary (TxCert (PreviousEra era))
  , Arbitrary (TxAuxData (PreviousEra era))
  , Arbitrary (TxWits (PreviousEra era))
  , Arbitrary (TxBody (PreviousEra era))
  , EraTx (PreviousEra era)
  , Arbitrary (Tx (PreviousEra era))
  , Arbitrary (Script (PreviousEra era))
  , HasCallStack
  , ToExpr (Tx era)
  , ToExpr (TxBody era)
  , ToExpr (TxWits era)
  , ToExpr (TxAuxData era)
  , DecCBOR (TxAuxData era)
  , DecCBOR (Script era)
  , DecCBOR (TxWits era)
  , DecCBOR (TxBody era)
  , DecCBOR (Tx era)
  ) =>
  BinaryUpgradeOpts ->
  Spec
spec :: forall era.
(EraApi era, Arbitrary (TxOut (PreviousEra era)),
 Arbitrary (TxCert (PreviousEra era)),
 Arbitrary (TxAuxData (PreviousEra era)),
 Arbitrary (TxWits (PreviousEra era)),
 Arbitrary (TxBody (PreviousEra era)), EraTx (PreviousEra era),
 Arbitrary (Tx (PreviousEra era)),
 Arbitrary (Script (PreviousEra era)), HasCallStack,
 ToExpr (Tx era), ToExpr (TxBody era), ToExpr (TxWits era),
 ToExpr (TxAuxData era), DecCBOR (TxAuxData era),
 DecCBOR (Script era), DecCBOR (TxWits era), DecCBOR (TxBody era),
 DecCBOR (Tx era)) =>
BinaryUpgradeOpts -> Spec
spec 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.
(EraApi era, EraTxOut (PreviousEra era),
 Arbitrary (TxOut (PreviousEra era)), HasCallStack) =>
Spec
specTxOutUpgrade @era
    forall era.
(EraApi era, EraTxCert (PreviousEra era),
 Arbitrary (TxCert (PreviousEra era)), HasCallStack) =>
Spec
specTxCertUpgrade @era
    forall era.
(EraApi era, EraTxAuxData (PreviousEra era),
 Arbitrary (TxAuxData (PreviousEra era)), HasCallStack,
 ToExpr (TxAuxData era), DecCBOR (TxAuxData era)) =>
Spec
specTxAuxDataUpgrade @era
    forall era.
(EraApi era, EraTxWits (PreviousEra era),
 Arbitrary (TxWits (PreviousEra era)), HasCallStack,
 ToExpr (TxWits era), DecCBOR (TxWits era)) =>
Spec
specTxWitsUpgrade @era
    forall era.
(EraApi era, EraTxBody (PreviousEra era),
 Arbitrary (TxBody (PreviousEra era)), HasCallStack,
 ToExpr (TxBody era), DecCBOR (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.
(EraApi era, EraTx (PreviousEra era),
 Arbitrary (Tx (PreviousEra era)), HasCallStack, ToExpr (Tx era),
 DecCBOR (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.
(EraApi era, EraScript (PreviousEra era),
 Arbitrary (Script (PreviousEra era)), DecCBOR (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
        ]