{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Test.Cardano.Ledger.Conway.Imp.UtxowSpec (spec) where

import Cardano.Ledger.Address (Addr (..))
import Cardano.Ledger.Babbage.Tx (ScriptIntegrity (..), getLanguageView)
import Cardano.Ledger.BaseTypes (
  Inject (..),
  Mismatch (..),
  Network (..),
  StrictMaybe (..),
  TxIx (..),
 )
import Cardano.Ledger.Coin (Coin (..), CompactForm (..))
import Cardano.Ledger.Conway.Core (
  AlonzoEraTxBody (..),
  AlonzoEraTxWits (..),
  CoinPerByte (..),
  EraIndependentScriptIntegrity,
  EraTx (..),
  EraTxBody (..),
  EraTxOut (..),
  EraTxWits (..),
  InjectRuleFailure (..),
  SafeHash,
  SafeToHash (..),
  TxLevel (..),
  ppCoinsPerUTxOByteL,
  txIdTx,
 )
import Cardano.Ledger.Conway.Governance
import Cardano.Ledger.Conway.Rules (ConwayUtxowPredFailure (..))
import Cardano.Ledger.Conway.TxBody
import Cardano.Ledger.Credential (Credential (..), StakeReference)
import Cardano.Ledger.Keys (asWitness, witVKeyHash)
import Cardano.Ledger.Plutus (Language (..), SLanguage (..), hashPlutusScript)
import Cardano.Ledger.TxIn (TxIn (..))
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Set.NonEmpty as NES
import Lens.Micro ((%~), (&), (.~), (^.))
import Test.Cardano.Ledger.Conway.ImpTest
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Plutus.Examples (alwaysSucceedsWithDatum)

spec ::
  forall era.
  ConwayEraImp era =>
  SpecWith (ImpInit (LedgerSpec era))
spec :: forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
spec = do
  -- https://github.com/IntersectMBO/formal-ledger-specifications/issues/1029
  -- TODO: Re-enable after issue is resolved, by removing this override
  String -> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
forall era.
ShelleyEraImp era =>
String -> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
disableInConformanceIt String
"Fails with PPViewHashesDontMatch before PV 11" (ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era)))
-> (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era ()
-> SpecWith (ImpInit (LedgerSpec era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: Natural) era.
(EraGov era, KnownNat v, MinVersion <= v, v <= MaxVersion) =>
ImpTestM era () -> ImpTestM era ()
whenMajorVersionAtMost @10 (ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era)))
-> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
    fixedTx <- Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
fixupTx (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> ImpTestM era (Tx TopTx era) -> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ImpTestM era (Tx TopTx era)
forall era. ConwayEraImp era => ImpTestM era (Tx TopTx era)
setupBadPPViewHashTx
    badScriptIntegrityHash <- arbitrary
    tx <- substituteIntegrityHashAndFixWits badScriptIntegrityHash fixedTx
    scriptIntegrityHash <- computeScriptIntegrityHash tx
    impAnn "Submit a transaction with an invalid script integrity hash"
      . withNoFixup
      $ submitFailingTx
        tx
        [ injectFailure . PPViewHashesDontMatch $
            Mismatch
              { mismatchSupplied = badScriptIntegrityHash
              , mismatchExpected = scriptIntegrityHash
              }
        ]
  String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Fails with PPViewHashesDontMatchInformative after PV 11" (ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era)))
-> (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era ()
-> SpecWith (ImpInit (LedgerSpec era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: Natural) era.
(EraGov era, KnownNat v, MinVersion <= v, v <= MaxVersion) =>
ImpTestM era () -> ImpTestM era ()
whenMajorVersionAtLeast @11 (ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era)))
-> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
    fixedTx <- Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
fixupTx (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> ImpTestM era (Tx TopTx era) -> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ImpTestM era (Tx TopTx era)
forall era. ConwayEraImp era => ImpTestM era (Tx TopTx era)
setupBadPPViewHashTx
    pp <- getsPParams id
    badScriptIntegrityHash <- arbitrary
    let
      langView = [PParams era -> Language -> LangDepView
forall era.
AlonzoEraPParams era =>
PParams era -> Language -> LangDepView
getLanguageView PParams era
pp Language
PlutusV2]
      scriptIntegrity = forall era.
Redeemers era
-> TxDats era -> Set LangDepView -> ScriptIntegrity era
ScriptIntegrity @era Redeemers era
redeemers TxDats era
dats Set LangDepView
langView
      redeemers = Tx TopTx era
fixedTx Tx TopTx era
-> Getting (Redeemers era) (Tx TopTx era) (Redeemers era)
-> Redeemers era
forall s a. s -> Getting a s a -> a
^. (TxWits era -> Const (Redeemers era) (TxWits era))
-> Tx TopTx era -> Const (Redeemers era) (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l era) (TxWits era)
witsTxL ((TxWits era -> Const (Redeemers era) (TxWits era))
 -> Tx TopTx era -> Const (Redeemers era) (Tx TopTx era))
-> ((Redeemers era -> Const (Redeemers era) (Redeemers era))
    -> TxWits era -> Const (Redeemers era) (TxWits era))
-> Getting (Redeemers era) (Tx TopTx era) (Redeemers era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redeemers era -> Const (Redeemers era) (Redeemers era))
-> TxWits era -> Const (Redeemers era) (TxWits era)
forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
Lens' (TxWits era) (Redeemers era)
rdmrsTxWitsL
      dats = Tx TopTx era
fixedTx Tx TopTx era
-> Getting (TxDats era) (Tx TopTx era) (TxDats era) -> TxDats era
forall s a. s -> Getting a s a -> a
^. (TxWits era -> Const (TxDats era) (TxWits era))
-> Tx TopTx era -> Const (TxDats era) (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l era) (TxWits era)
witsTxL ((TxWits era -> Const (TxDats era) (TxWits era))
 -> Tx TopTx era -> Const (TxDats era) (Tx TopTx era))
-> ((TxDats era -> Const (TxDats era) (TxDats era))
    -> TxWits era -> Const (TxDats era) (TxWits era))
-> Getting (TxDats era) (Tx TopTx era) (TxDats era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxDats era -> Const (TxDats era) (TxDats era))
-> TxWits era -> Const (TxDats era) (TxWits era)
forall era. AlonzoEraTxWits era => Lens' (TxWits era) (TxDats era)
Lens' (TxWits era) (TxDats era)
datsTxWitsL
    tx <- substituteIntegrityHashAndFixWits badScriptIntegrityHash fixedTx
    scriptIntegrityHash <- computeScriptIntegrityHash tx
    let
      mismatch =
        Mismatch
          { mismatchSupplied :: StrictMaybe (SafeHash EraIndependentScriptIntegrity)
mismatchSupplied = StrictMaybe (SafeHash EraIndependentScriptIntegrity)
badScriptIntegrityHash
          , mismatchExpected :: StrictMaybe (SafeHash EraIndependentScriptIntegrity)
mismatchExpected = StrictMaybe (SafeHash EraIndependentScriptIntegrity)
scriptIntegrityHash
          }
    impAnn "Submit a transaction with an invalid script integrity hash"
      . withNoFixup
      $ submitFailingTx
        tx
        [ injectFailure $ ScriptIntegrityHashMismatch mismatch (SJust $ originalBytes scriptIntegrity)
        ]
  String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Transaction containing SPO vote but no witness for it fails" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ do
    spoKh <- ImpM (LedgerSpec era) (KeyHash StakePool)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
    registerPool spoKh
    gaId <- mkProposal InfoAction >>= submitProposal
    submitVote_ @era VoteYes (StakePoolVoter spoKh) gaId
    let tx =
          TxBody TopTx era -> Tx TopTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx TxBody TopTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
            Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxBody TopTx era -> Identity (TxBody TopTx era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Identity (TxBody TopTx era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> ((VotingProcedures era -> Identity (VotingProcedures era))
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (VotingProcedures era -> Identity (VotingProcedures era))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VotingProcedures era -> Identity (VotingProcedures era))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
ConwayEraTxBody era =>
Lens' (TxBody l era) (VotingProcedures era)
forall (l :: TxLevel). Lens' (TxBody l era) (VotingProcedures era)
votingProceduresTxBodyL
              ((VotingProcedures era -> Identity (VotingProcedures era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> VotingProcedures era -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map Voter (Map GovActionId (VotingProcedure era))
-> VotingProcedures era
forall era.
Map Voter (Map GovActionId (VotingProcedure era))
-> VotingProcedures era
VotingProcedures
                ( Voter
-> Map GovActionId (VotingProcedure era)
-> Map Voter (Map GovActionId (VotingProcedure era))
forall k a. k -> a -> Map k a
Map.singleton
                    (KeyHash StakePool -> Voter
StakePoolVoter KeyHash StakePool
spoKh)
                    ( GovActionId
-> VotingProcedure era -> Map GovActionId (VotingProcedure era)
forall k a. k -> a -> Map k a
Map.singleton
                        GovActionId
gaId
                        ( VotingProcedure
                            { vProcVote :: Vote
vProcVote = Vote
VoteYes
                            , vProcAnchor :: StrictMaybe Anchor
vProcAnchor = StrictMaybe Anchor
forall a. StrictMaybe a
SNothing
                            }
                        )
                    )
                )
    let isSPOWitness WitVKey kr
wit = WitVKey kr -> KeyHash Witness
forall (kr :: KeyRole). WitVKey kr -> KeyHash Witness
witVKeyHash WitVKey kr
wit KeyHash Witness -> KeyHash Witness -> Bool
forall a. Eq a => a -> a -> Bool
== KeyHash StakePool -> KeyHash Witness
forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a Witness
asWitness KeyHash StakePool
spoKh
    withPostFixup (pure . (witsTxL . addrTxWitsL %~ Set.filter (not . isSPOWitness))) $
      submitFailingTx
        tx
        [ injectFailure $
            MissingVKeyWitnessesUTXOW $
              NES.singleton $
                asWitness spoKh
        ]

setupBadPPViewHashTx ::
  forall era.
  ConwayEraImp era =>
  ImpTestM era (Tx TopTx era)
setupBadPPViewHashTx :: forall era. ConwayEraImp era => ImpTestM era (Tx TopTx era)
setupBadPPViewHashTx = do
  (PParams era -> PParams era) -> ImpTestM era ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpTestM era ())
-> (PParams era -> PParams era) -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ (CoinPerByte -> Identity CoinPerByte)
-> PParams era -> Identity (PParams era)
forall era.
BabbageEraPParams era =>
Lens' (PParams era) CoinPerByte
Lens' (PParams era) CoinPerByte
ppCoinsPerUTxOByteL ((CoinPerByte -> Identity CoinPerByte)
 -> PParams era -> Identity (PParams era))
-> CoinPerByte -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ CompactForm Coin -> CoinPerByte
CoinPerByte (Word64 -> CompactForm Coin
CompactCoin Word64
1)
  someKeyHash <- forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary @StakeReference
  let scriptTxOut =
        Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut
          ( Network -> Credential Payment -> StakeReference -> Addr
Addr
              Network
Testnet
              (ScriptHash -> Credential Payment
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj (Plutus 'PlutusV2 -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus 'PlutusV2 -> ScriptHash) -> Plutus 'PlutusV2 -> ScriptHash
forall a b. (a -> b) -> a -> b
$ SLanguage 'PlutusV2 -> Plutus 'PlutusV2
forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsWithDatum SLanguage 'PlutusV2
SPlutusV2))
              StakeReference
someKeyHash
          )
          (Coin -> Value era
forall t s. Inject t s => t -> s
inject (Coin -> Value era) -> Coin -> Value era
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
1_000_000)
  scriptTxIn <-
    impAnn "Submit a transaction that has a script output"
      . submitTx
      $ mkBasicTx mkBasicTxBody
        & bodyTxL . outputsTxBodyL .~ [scriptTxOut]
  pure $
    mkBasicTx mkBasicTxBody
      & bodyTxL . inputsTxBodyL .~ [TxIn (txIdTx scriptTxIn) (TxIx 0)]

substituteIntegrityHashAndFixWits ::
  forall era.
  ConwayEraImp era =>
  StrictMaybe (SafeHash EraIndependentScriptIntegrity) ->
  Tx TopTx era ->
  ImpTestM era (Tx TopTx era)
substituteIntegrityHashAndFixWits :: forall era.
ConwayEraImp era =>
StrictMaybe (SafeHash EraIndependentScriptIntegrity)
-> Tx TopTx era -> ImpTestM era (Tx TopTx era)
substituteIntegrityHashAndFixWits StrictMaybe (SafeHash EraIndependentScriptIntegrity)
hash Tx TopTx era
tx =
  let txWithNewHash :: Tx TopTx era
txWithNewHash =
        Tx TopTx era
tx
          Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxBody TopTx era -> Identity (TxBody TopTx era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Identity (TxBody TopTx era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> ((StrictMaybe (SafeHash EraIndependentScriptIntegrity)
     -> Identity (StrictMaybe (SafeHash EraIndependentScriptIntegrity)))
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (StrictMaybe (SafeHash EraIndependentScriptIntegrity)
    -> Identity (StrictMaybe (SafeHash EraIndependentScriptIntegrity)))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe (SafeHash EraIndependentScriptIntegrity)
 -> Identity (StrictMaybe (SafeHash EraIndependentScriptIntegrity)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
AlonzoEraTxBody era =>
Lens'
  (TxBody l era)
  (StrictMaybe (SafeHash EraIndependentScriptIntegrity))
forall (l :: TxLevel).
Lens'
  (TxBody l era)
  (StrictMaybe (SafeHash EraIndependentScriptIntegrity))
scriptIntegrityHashTxBodyL ((StrictMaybe (SafeHash EraIndependentScriptIntegrity)
  -> Identity (StrictMaybe (SafeHash EraIndependentScriptIntegrity)))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> StrictMaybe (SafeHash EraIndependentScriptIntegrity)
-> Tx TopTx era
-> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ StrictMaybe (SafeHash EraIndependentScriptIntegrity)
hash
          Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxWits era -> Identity (TxWits era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l era) (TxWits era)
witsTxL ((TxWits era -> Identity (TxWits era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> TxWits era -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxWits era
forall era. EraTxWits era => TxWits era
mkBasicTxWits
   in Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era (l :: TxLevel).
AlonzoEraImp era =>
Tx l era -> ImpTestM era (Tx l era)
fixupScriptWits Tx TopTx era
txWithNewHash
        ImpTestM era (Tx TopTx era)
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> ImpTestM era (Tx TopTx era)
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era (l :: TxLevel).
(HasCallStack, AlonzoEraImp era) =>
Tx l era -> ImpTestM era (Tx l era)
fixupDatums
        ImpTestM era (Tx TopTx era)
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> ImpTestM era (Tx TopTx era)
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era.
(AlonzoEraImp era, HasCallStack) =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
fixupRedeemers
        ImpTestM era (Tx TopTx era)
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> ImpTestM era (Tx TopTx era)
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era (l :: TxLevel).
(HasCallStack, ShelleyEraImp era) =>
Tx l era -> ImpTestM era (Tx l era)
updateAddrTxWits