{-# 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.Alonzo.Scripts (eraLanguages)
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 (
  PlutusLanguage,
  SLanguage,
  hashPlutusScript,
  withSLanguage,
 )
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 = String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"UTXOW" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
  String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it 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
    lang <- [Language] -> ImpM (LedgerSpec era) Language
forall (m :: * -> *) a. MonadGen m => [a] -> m a
elements ([Language] -> ImpM (LedgerSpec era) Language)
-> [Language] -> ImpM (LedgerSpec era) Language
forall a b. (a -> b) -> a -> b
$ forall era. AlonzoEraScript era => [Language]
eraLanguages @era
    fixedTx <- fixupTx =<< withSLanguage lang 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
              }
        ]
  -- https://github.com/IntersectMBO/formal-ledger-specifications/issues/1086
  -- 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 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
      lang <- [Language] -> ImpM (LedgerSpec era) Language
forall (m :: * -> *) a. MonadGen m => [a] -> m a
elements ([Language] -> ImpM (LedgerSpec era) Language)
-> [Language] -> ImpM (LedgerSpec era) Language
forall a b. (a -> b) -> a -> b
$ forall era. AlonzoEraScript era => [Language]
eraLanguages @era
      fixedTx <- fixupTx =<< withSLanguage lang 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
lang]
        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 l.
  ( ConwayEraImp era
  , PlutusLanguage l
  ) =>
  SLanguage l ->
  ImpTestM era (Tx TopTx era)
setupBadPPViewHashTx :: forall era (l :: Language).
(ConwayEraImp era, PlutusLanguage l) =>
SLanguage l -> ImpTestM era (Tx TopTx era)
setupBadPPViewHashTx SLanguage l
slang = 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 l -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus l -> ScriptHash) -> Plutus l -> ScriptHash
forall a b. (a -> b) -> a -> b
$ SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsWithDatum SLanguage l
slang))
              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