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

module Test.Cardano.Ledger.Core.Binary where

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.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 =
  forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"upgradeTxOut is preserved through serialization" forall a b. (a -> b) -> a -> b
$ \TxOut (PreviousEra era)
prevTxOut -> do
    case 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) forall a b. (EncCBOR a, DecCBOR b) => Trip a b
cborTrip TxOut (PreviousEra era)
prevTxOut of
      Left RoundTripFailure
err ->
        HasCallStack => [Char] -> Expectation
expectationFailure forall a b. (a -> b) -> a -> b
$
          [Char]
"Expected to deserialize: =======================================================\n"
            forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show RoundTripFailure
err
      Right (TxOut era
curTxOut :: TxOut era) ->
        TxOut era
curTxOut forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` 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 =
  forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"upgradeTxCert is preserved through serialization" forall a b. (a -> b) -> a -> b
$ \TxCert (PreviousEra era)
prevTxCert -> do
    case 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) forall a b. (EncCBOR a, DecCBOR b) => Trip a b
cborTrip TxCert (PreviousEra era)
prevTxCert of
      Left RoundTripFailure
err
        | Right 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
expectationFailure forall a b. (a -> b) -> a -> b
$
              [Char]
"Expected to deserialize: =======================================================\n"
                forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show RoundTripFailure
err
        | Bool
otherwise -> 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 <- forall era.
(EraTxCert era, EraTxCert (PreviousEra era)) =>
TxCert (PreviousEra era)
-> Either (TxCertUpgradeError era) (TxCert era)
upgradeTxCert TxCert (PreviousEra era)
prevTxCert ->
            TxCert era
curTxCert forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` TxCert era
upgradedTxCert
        | Bool
otherwise -> HasCallStack => [Char] -> Expectation
expectationFailure [Char]
"Expected upgradeTxCert to succeed"

specTxAuxDataUpgrade ::
  forall era.
  ( EraTxAuxData (PreviousEra era)
  , EraTxAuxData era
  , Arbitrary (TxAuxData (PreviousEra era))
  , HasCallStack
  , ToExpr (TxAuxData era)
  ) =>
  Spec
specTxAuxDataUpgrade :: forall era.
(EraTxAuxData (PreviousEra era), EraTxAuxData era,
 Arbitrary (TxAuxData (PreviousEra era)), HasCallStack,
 ToExpr (TxAuxData era)) =>
Spec
specTxAuxDataUpgrade =
  forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"upgradeTxAuxData is preserved through serialization" forall a b. (a -> b) -> a -> b
$ \TxAuxData (PreviousEra era)
prevTxAuxData -> do
    case 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
expectationFailure forall a b. (a -> b) -> a -> b
$
          [Char]
"Expected to deserialize: =======================================================\n"
            forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show RoundTripFailure
err
      Right (TxAuxData era
curTxAuxData :: TxAuxData era) -> do
        let upgradedTxAuxData :: TxAuxData era
upgradedTxAuxData = forall era.
(EraTxAuxData era, EraTxAuxData (PreviousEra era)) =>
TxAuxData (PreviousEra era) -> TxAuxData era
upgradeTxAuxData TxAuxData (PreviousEra era)
prevTxAuxData
        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))
  , HasCallStack
  ) =>
  Spec
specScriptUpgrade :: forall era.
(EraScript (PreviousEra era), EraScript era,
 Arbitrary (Script (PreviousEra era)), HasCallStack) =>
Spec
specScriptUpgrade =
  forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"upgradeScript is preserved through serialization" forall a b. (a -> b) -> a -> b
$ \Script (PreviousEra era)
prevScript -> do
    case 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
expectationFailure forall a b. (a -> b) -> a -> b
$
          [Char]
"Expected to deserialize: =======================================================\n"
            forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show RoundTripFailure
err
      Right (Script era
curScript :: Script era) ->
        Script era
curScript forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` 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)
  ) =>
  Spec
specTxWitsUpgrade :: forall era.
(EraTxWits (PreviousEra era), EraTxWits era,
 Arbitrary (TxWits (PreviousEra era)), HasCallStack,
 ToExpr (TxWits era)) =>
Spec
specTxWitsUpgrade =
  forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"upgradeTxWits is preserved through serialization" forall a b. (a -> b) -> a -> b
$ \TxWits (PreviousEra era)
prevTxWits -> do
    case 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
expectationFailure forall a b. (a -> b) -> a -> b
$
          [Char]
"Expected to deserialize: =======================================================\n"
            forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show RoundTripFailure
err
      Right (TxWits era
curTxWits :: TxWits era) -> do
        let upgradedTxWits :: TxWits era
upgradedTxWits = forall era.
(EraTxWits era, EraTxWits (PreviousEra era)) =>
TxWits (PreviousEra era) -> TxWits era
upgradeTxWits TxWits (PreviousEra era)
prevTxWits
        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)
  ) =>
  Spec
specTxBodyUpgrade :: forall era.
(EraTxBody (PreviousEra era), EraTxBody era,
 Arbitrary (TxBody (PreviousEra era)), HasCallStack,
 ToExpr (TxBody era)) =>
Spec
specTxBodyUpgrade =
  forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"upgradeTxBody is preserved through serialization" forall a b. (a -> b) -> a -> b
$ \TxBody (PreviousEra era)
prevTxBody -> do
    case 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
_ <- 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
expectationFailure forall a b. (a -> b) -> a -> b
$
              [Char]
"Expected to deserialize: =======================================================\n"
                forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show RoundTripFailure
err
        | Bool
otherwise -> 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 <- forall era.
(EraTxBody era, EraTxBody (PreviousEra era)) =>
TxBody (PreviousEra era)
-> Either (TxBodyUpgradeError era) (TxBody era)
upgradeTxBody TxBody (PreviousEra era)
prevTxBody ->
            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
expectationFailure [Char]
"Expected upgradeTxBody to succeed"

specTxUpgrade ::
  forall era.
  ( EraTx (PreviousEra era)
  , EraTx era
  , Arbitrary (Tx (PreviousEra era))
  , HasCallStack
  , ToExpr (Tx era)
  ) =>
  Spec
specTxUpgrade :: forall era.
(EraTx (PreviousEra era), EraTx era,
 Arbitrary (Tx (PreviousEra era)), HasCallStack, ToExpr (Tx era)) =>
Spec
specTxUpgrade =
  forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"upgradeTx is preserved through serialization" forall a b. (a -> b) -> a -> b
$ \Tx (PreviousEra era)
prevTx -> do
    case 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
_ <- 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
expectationFailure forall a b. (a -> b) -> a -> b
$
              [Char]
"Expected to deserialize: =======================================================\n"
                forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show RoundTripFailure
err
        | Bool
otherwise -> 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 <- forall era.
(EraTx era, EraTx (PreviousEra era)) =>
Tx (PreviousEra era) -> Either (TxUpgradeError era) (Tx era)
upgradeTx Tx (PreviousEra era)
prevTx ->
            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
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)
  ) =>
  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)) =>
BinaryUpgradeOpts -> Spec
specUpgrade BinaryUpgradeOpts {Bool
isScriptUpgradeable :: Bool
isScriptUpgradeable :: BinaryUpgradeOpts -> Bool
isScriptUpgradeable, Bool
isTxUpgradeable :: Bool
isTxUpgradeable :: BinaryUpgradeOpts -> Bool
isTxUpgradeable} =
  forall a. HasCallStack => [Char] -> SpecWith a -> SpecWith a
describe ([Char]
"Upgrade from " forall a. [a] -> [a] -> [a]
++ forall era. Era era => [Char]
eraName @(PreviousEra era) forall a. [a] -> [a] -> [a]
++ [Char]
" to " forall a. [a] -> [a] -> [a]
++ forall era. Era era => [Char]
eraName @era) 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)) =>
Spec
specTxAuxDataUpgrade @era
    forall era.
(EraTxWits (PreviousEra era), EraTxWits era,
 Arbitrary (TxWits (PreviousEra era)), HasCallStack,
 ToExpr (TxWits era)) =>
Spec
specTxWitsUpgrade @era
    forall era.
(EraTxBody (PreviousEra era), EraTxBody era,
 Arbitrary (TxBody (PreviousEra era)), HasCallStack,
 ToExpr (TxBody era)) =>
Spec
specTxBodyUpgrade @era
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isTxUpgradeable forall a b. (a -> b) -> a -> b
$
      forall era.
(EraTx (PreviousEra era), EraTx era,
 Arbitrary (Tx (PreviousEra era)), HasCallStack, ToExpr (Tx era)) =>
Spec
specTxUpgrade @era
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isScriptUpgradeable forall a b. (a -> b) -> a -> b
$
      forall era.
(EraScript (PreviousEra era), EraScript era,
 Arbitrary (Script (PreviousEra era)), HasCallStack) =>
Spec
specScriptUpgrade @era

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