{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Test.Cardano.Ledger.Conway.Binary.Regression where

import Cardano.Ledger.BaseTypes (Inject (..), StrictMaybe (..), TxIx (..))
import Cardano.Ledger.Binary (
  EncCBOR (..),
  decCBOR,
  decodeFull,
  decodeFullAnnotatorFromHexText,
  mkVersion,
  serialize,
 )
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Conway (Conway)
import Cardano.Ledger.Conway.Core (
  BabbageEraTxBody (..),
  EraTx (..),
  EraTxBody (..),
  EraTxOut (..),
  EraTxWits (..),
  coinTxOutL,
  eraProtVerLow,
  txIdTx,
 )
import Cardano.Ledger.Conway.Rules (
  ConwayLedgerPredFailure (..),
  ConwayUtxoPredFailure (..),
  ConwayUtxowPredFailure (..),
 )
import Cardano.Ledger.Plutus.Language (SLanguage (..), hashPlutusScript)
import Cardano.Ledger.TxIn (TxIn (..))
import Control.Monad ((<=<))
import qualified Data.Sequence.Strict as SSeq
import qualified Data.Set as Set
import Lens.Micro ((%~), (&), (.~))
import Test.Cardano.Ledger.Conway.ImpTest
import Test.Cardano.Ledger.Core.KeyPair (mkScriptAddr)
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Plutus.Examples (redeemerSameAsDatum)

spec ::
  forall era.
  ( EraTx era
  , NFData (Tx era)
  ) =>
  Spec
spec :: forall era. (EraTx era, NFData (Tx era)) => Spec
spec = forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Regression" forall a b. (a -> b) -> a -> b
$ do
  forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"DeserialiseFailure on resubmitting Conway Tx with invalid plutus script #4198" forall a b. (a -> b) -> a -> b
$ do
    forall a. IO a -> IO a
io forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b (m :: * -> *).
(HasCallStack, Show a, NFData b, MonadIO m) =>
Either a b -> m ()
expectRightDeep_ forall a b. (a -> b) -> a -> b
$
      forall a.
Version
-> Text
-> (forall s. Decoder s (Annotator a))
-> Text
-> Either DecoderError a
decodeFullAnnotatorFromHexText @(Tx era) (forall era. Era era => Version
eraProtVerLow @era) Text
"Unwitnessed Tx" forall a s. DecCBOR a => Decoder s a
decCBOR forall a b. (a -> b) -> a -> b
$
        forall a. Monoid a => [a] -> a
mconcat
          [ Text
"84a700d9010282825820745f04573e7429be1404f9b936d208b81159f3fc4b300"
          , Text
"37b9d630187eec1875600825820745f04573e7429be1404f9b936d208b81159f3"
          , Text
"fc4b30037b9d630187eec18756020dd9010281825820745f04573e7429be1404f"
          , Text
"9b936d208b81159f3fc4b30037b9d630187eec1875601018282581d60fdfaa525"
          , Text
"1e9ed2186a52eeea05ac1d39834eeef09b3e41dc151577a01a001e848082581d6"
          , Text
"0fe920c980dbc1113a01db0156955479f3b91f6fb6a51bdc0c383c1b91a3b586d"
          , Text
"e61082581d60fe920c980dbc1113a01db0156955479f3b91f6fb6a51bdc0c383c"
          , Text
"1b91a001a65b0111a00041ed0021a0002bf350b5820878c73eb6ec7171b23396f"
          , Text
"71d7e5adee98b3f72cfc1c0662453ea724a4e27ad5a303d9010281581e581c010"
          , Text
"0003322323222235004007123500235300300149849848004800504d9010281d8"
          , Text
"799f182aff0581840000d8799f182aff820000f4f6"
          ]
    forall a b (m :: * -> *).
(HasCallStack, Show a, NFData b, MonadIO m) =>
Either a b -> m ()
expectRightDeep_ forall a b. (a -> b) -> a -> b
$
      forall a.
Version
-> Text
-> (forall s. Decoder s (Annotator a))
-> Text
-> Either DecoderError a
decodeFullAnnotatorFromHexText @(Tx era) (forall era. Era era => Version
eraProtVerLow @era) Text
"Witnessed Tx" forall a s. DecCBOR a => Decoder s a
decCBOR forall a b. (a -> b) -> a -> b
$
        forall a. Monoid a => [a] -> a
mconcat
          [ Text
"84a700d9010282825820745f04573e7429be1404f9b936d208b81159f3fc4b300"
          , Text
"37b9d630187eec1875600825820745f04573e7429be1404f9b936d208b81159f3"
          , Text
"fc4b30037b9d630187eec18756020dd9010281825820745f04573e7429be1404f"
          , Text
"9b936d208b81159f3fc4b30037b9d630187eec1875601018282581d60fdfaa525"
          , Text
"1e9ed2186a52eeea05ac1d39834eeef09b3e41dc151577a01a001e848082581d6"
          , Text
"0fe920c980dbc1113a01db0156955479f3b91f6fb6a51bdc0c383c1b91a3b586d"
          , Text
"e61082581d60fe920c980dbc1113a01db0156955479f3b91f6fb6a51bdc0c383c"
          , Text
"1b91a001a65b0111a00041ed0021a0002bf350b5820878c73eb6ec7171b23396f"
          , Text
"71d7e5adee98b3f72cfc1c0662453ea724a4e27ad5a400d9010282825820119ca"
          , Text
"69d7aadd28f1e182176cbaa35f4e08d580b79ee749103f4106768594343584057"
          , Text
"de8c067f7b806001e94f740c9c96c51f884e264dd0b2d0cff501ad67f1d269b7a"
          , Text
"7af5adf92148f4a10855fe3b2090bc88f045603cfe14c8a5f3fed6c4008038258"
          , Text
"20468ed75ae68f72233e33b0a869ae5f00cfabe477f186184782e5a1994d189a9"
          , Text
"b58408395b8e91540804ce1860272ac72b4ecc682f567a33c33da8e835d736f1f"
          , Text
"c039ff86ee5aae0ac0e9c9d50506132e209f62a02fe04906b66a3392d48d4d627"
          , Text
"d0403d9010281581e581c01000033223232222350040071235002353003001498"
          , Text
"49848004800504d9010281d8799f182aff0581840000d8799f182aff820000f4f6"
          ]
  forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"ImpTest" forall a b. (a -> b) -> a -> b
$
    forall era.
ShelleyEraImp era =>
SpecWith (ImpTestState era) -> Spec
withImpState @Conway forall a b. (a -> b) -> a -> b
$
      forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"InsufficientCollateral is not encoded with negative coin #4198" forall a b. (a -> b) -> a -> b
$ do
        Addr (EraCrypto Conway)
collateralAddress <- forall s c (m :: * -> *).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) m) =>
m (Addr c)
freshKeyAddr_
        (KeyHash 'Staking (EraCrypto Conway)
_, KeyPair 'Staking (EraCrypto Conway)
skp) <- forall s c (m :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) m) =>
m (KeyHash r c, KeyPair r c)
freshKeyPair
        let
          plutusVersion :: SLanguage 'PlutusV2
plutusVersion = SLanguage 'PlutusV2
SPlutusV2
          scriptHash :: ScriptHash (EraCrypto Conway)
scriptHash = forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
Plutus l -> ScriptHash c
hashPlutusScript forall a b. (a -> b) -> a -> b
$ forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage 'PlutusV2
plutusVersion
          lockScriptAddress :: Addr (EraCrypto Conway)
lockScriptAddress = forall c. Crypto c => ScriptHash c -> KeyPair 'Staking c -> Addr c
mkScriptAddr ScriptHash (EraCrypto Conway)
scriptHash KeyPair 'Staking (EraCrypto Conway)
skp
        Addr StandardCrypto
collateralReturnAddr <- forall s c (m :: * -> *).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) m) =>
m (Addr c)
freshKeyAddr_
        AlonzoTx Conway
lockedTx <-
          forall era.
(HasCallStack, ShelleyEraImp era) =>
String -> Tx era -> ImpTestM era (Tx era)
submitTxAnn @Conway String
"Script locked tx" forall a b. (a -> b) -> a -> b
$
            forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
              forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL
                forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. [a] -> StrictSeq a
SSeq.fromList
                  [ forall era.
(EraTxOut era, HasCallStack) =>
Addr (EraCrypto era) -> Value era -> TxOut era
mkBasicTxOut Addr (EraCrypto Conway)
lockScriptAddress forall a. Monoid a => a
mempty
                  , forall era.
(EraTxOut era, HasCallStack) =>
Addr (EraCrypto era) -> Value era -> TxOut era
mkBasicTxOut Addr (EraCrypto Conway)
collateralAddress forall a. Monoid a => a
mempty
                  ]
              forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
BabbageEraTxBody era =>
Lens' (TxBody era) (StrictMaybe (TxOut era))
collateralReturnTxBodyL
                forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictMaybe a
SJust (forall era.
(EraTxOut era, HasCallStack) =>
Addr (EraCrypto era) -> Value era -> TxOut era
mkBasicTxOut Addr StandardCrypto
collateralReturnAddr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t s. Inject t s => t -> s
inject forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
849070)
        let
          modifyRootCoin :: TxOut Conway -> TxOut Conway
modifyRootCoin = forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
coinTxOutL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
989482376
          modifyRootTxOut :: StrictSeq (TxOut Conway) -> StrictSeq (TxOut Conway)
modifyRootTxOut (TxOut Conway
x SSeq.:<| StrictSeq (TxOut Conway)
SSeq.Empty) =
            TxOut Conway -> TxOut Conway
modifyRootCoin TxOut Conway
x forall a. a -> StrictSeq a -> StrictSeq a
SSeq.:<| forall a. StrictSeq a
SSeq.Empty
          modifyRootTxOut (TxOut Conway
x SSeq.:<| StrictSeq (TxOut Conway)
xs) = TxOut Conway
x forall a. a -> StrictSeq a -> StrictSeq a
SSeq.:<| StrictSeq (TxOut Conway) -> StrictSeq (TxOut Conway)
modifyRootTxOut StrictSeq (TxOut Conway)
xs
          modifyRootTxOut (StrictSeq (TxOut Conway)
xs SSeq.:|> TxOut Conway
x) = StrictSeq (TxOut Conway)
xs forall a. StrictSeq a -> a -> StrictSeq a
SSeq.:|> TxOut Conway -> TxOut Conway
modifyRootCoin TxOut Conway
x
          modifyRootTxOut StrictSeq (TxOut Conway)
SSeq.Empty = forall a. StrictSeq a
SSeq.Empty
          breakCollaterals :: Tx Conway -> ImpTestM Conway (Tx Conway)
breakCollaterals Tx Conway
tx =
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
              Tx Conway
tx
                forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
BabbageEraTxBody era =>
Lens' (TxBody era) (StrictMaybe (TxOut era))
collateralReturnTxBodyL
                  forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictMaybe a
SJust (forall era.
(EraTxOut era, HasCallStack) =>
Addr (EraCrypto era) -> Value era -> TxOut era
mkBasicTxOut Addr StandardCrypto
collateralReturnAddr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t s. Inject t s => t -> s
inject forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
1_000_000_000)
                forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraTxBody era => Lens' (TxBody era) Coin
feeTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
178349
                forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ StrictSeq (TxOut Conway) -> StrictSeq (TxOut Conway)
modifyRootTxOut
                forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (WitVKey 'Witness (EraCrypto era)))
addrTxWitsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. Monoid a => a
mempty
        Either
  (NonEmpty (ConwayLedgerPredFailure Conway), AlonzoTx Conway)
  (AlonzoTx Conway)
res <-
          forall a era.
NFData a =>
String -> ImpTestM era a -> ImpTestM era a
impAnn String
"Consume the script locked output" forall a b. (a -> b) -> a -> b
$
            forall era a.
(Tx era -> ImpTestM era (Tx era))
-> ImpTestM era a -> ImpTestM era a
withPostFixup (forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era (Tx era)
updateAddrTxWits forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Tx Conway -> ImpTestM Conway (Tx Conway)
breakCollaterals) forall a b. (a -> b) -> a -> b
$ do
              forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
        (Tx era))
trySubmitTx @Conway forall a b. (a -> b) -> a -> b
$
                forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
                  forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> Set a
Set.singleton (forall c. TxId c -> TxIx -> TxIn c
TxIn (forall era. EraTx era => Tx era -> TxId (EraCrypto era)
txIdTx AlonzoTx Conway
lockedTx) forall a b. (a -> b) -> a -> b
$ Word64 -> TxIx
TxIx Word64
0)
        (NonEmpty (ConwayLedgerPredFailure Conway)
pFailure, AlonzoTx Conway
_) <- forall a era.
NFData a =>
String -> ImpTestM era a -> ImpTestM era a
impAnn String
"Expecting failure" forall a b. (a -> b) -> a -> b
$ forall b a (m :: * -> *).
(HasCallStack, ToExpr b, NFData a, MonadIO m) =>
Either a b -> m a
expectLeftDeepExpr Either
  (NonEmpty (ConwayLedgerPredFailure Conway), AlonzoTx Conway)
  (AlonzoTx Conway)
res
        let
          hasInsufficientCollateral :: ConwayLedgerPredFailure era -> Bool
hasInsufficientCollateral
            (ConwayUtxowFailure (UtxoFailure (InsufficientCollateral DeltaCoin
_ Coin
_))) = Bool
True
          hasInsufficientCollateral ConwayLedgerPredFailure era
_ = Bool
False
        forall a era.
NFData a =>
String -> ImpTestM era a -> ImpTestM era a
impAnn String
"Fails with InsufficientCollateral" forall a b. (a -> b) -> a -> b
$
          NonEmpty (ConwayLedgerPredFailure Conway)
pFailure forall (m :: * -> *) a.
(HasCallStack, MonadIO m, ToExpr a) =>
a -> (a -> Bool) -> m ()
`shouldSatisfyExpr` forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall {era} {era} {era}.
(PredicateFailure (EraRule "UTXO" era) ~ ConwayUtxoPredFailure era,
 PredicateFailure (EraRule "UTXOW" era)
 ~ ConwayUtxowPredFailure era) =>
ConwayLedgerPredFailure era -> Bool
hasInsufficientCollateral
        let encoding :: Encoding
encoding = forall a. EncCBOR a => a -> Encoding
encCBOR NonEmpty (ConwayLedgerPredFailure Conway)
pFailure
        Version
version <- forall i (m :: * -> *). (Integral i, MonadFail m) => i -> m Version
mkVersion (Int
11 :: Int)
        let
          bs :: ByteString
bs = forall a. EncCBOR a => Version -> a -> ByteString
serialize Version
version Encoding
encoding
          decoded :: Either DecoderError (NonEmpty (ConwayLedgerPredFailure Conway))
decoded = forall a.
DecCBOR a =>
Version -> ByteString -> Either DecoderError a
decodeFull Version
version ByteString
bs
        forall a era.
NFData a =>
String -> ImpTestM era a -> ImpTestM era a
impAnn String
"Expecting deserialization of predicate failure to succeed" forall a b. (a -> b) -> a -> b
$
          Either DecoderError (NonEmpty (ConwayLedgerPredFailure Conway))
decoded forall a (m :: * -> *).
(HasCallStack, Show a, Eq a, MonadIO m) =>
a -> a -> m ()
`shouldBe` forall a b. b -> Either a b
Right NonEmpty (ConwayLedgerPredFailure Conway)
pFailure