{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Test.Cardano.Ledger.Examples.AlonzoBBODY (tests) where

import Cardano.Crypto.Hash.Class (sizeHash)
import Cardano.Ledger.Address (Addr (..), RewardAccount (..))
import Cardano.Ledger.Alonzo.Rules (AlonzoBbodyPredFailure (..))
import Cardano.Ledger.Alonzo.Scripts (ExUnits (..))
import Cardano.Ledger.Alonzo.TxWits (Redeemers (..))
import Cardano.Ledger.BHeaderView (BHeaderView (..))
import Cardano.Ledger.BaseTypes (
  BlocksMade (..),
  Network (..),
  StrictMaybe (..),
  natVersion,
  textToUrl,
 )
import Cardano.Ledger.Block (Block (..))
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Conway.Rules (ConwayCertsPredFailure (..), ConwayLedgerPredFailure (..))
import qualified Cardano.Ledger.Conway.Rules as Conway (
  ConwayBbodyPredFailure (..),
  ConwayCertPredFailure (..),
 )
import Cardano.Ledger.Credential (
  Credential (..),
  StakeCredential,
  StakeReference (..),
 )
import Cardano.Ledger.Keys (coerceKeyRole)
import Cardano.Ledger.Mary.Value (MaryValue (..), MultiAsset (..))
import Cardano.Ledger.Plutus.Data (Data (..), hashData)
import Cardano.Ledger.Plutus.Language (Language (..))
import Cardano.Ledger.PoolParams (PoolMetadata (..))
import Cardano.Ledger.Shelley.API (
  CertState (..),
  DState (..),
  GenDelegs (..),
  LedgerState (..),
  PoolParams (..),
  ProtVer (..),
  UTxO (..),
 )
import Cardano.Ledger.Shelley.Core hiding (TranslationError)
import Cardano.Ledger.Shelley.LedgerState (smartUTxOState)
import Cardano.Ledger.Shelley.Rules (
  ShelleyBbodyPredFailure (..),
  ShelleyBbodyState (..),
  ShelleyDelegsPredFailure (..),
  ShelleyDelplPredFailure (..),
  ShelleyLedgerPredFailure (..),
  ShelleyLedgersPredFailure (..),
  ShelleyPoolPredFailure (..),
 )
import Cardano.Ledger.TxIn (TxIn (..))
import Cardano.Ledger.UMap (UView (RewDepUView))
import qualified Cardano.Ledger.UMap as UM
import Cardano.Ledger.Val (inject, (<->))
import Cardano.Protocol.Crypto (hashVerKeyVRF)
import Cardano.Slotting.Slot (SlotNo (..))
import Control.State.Transition.Extended (STS (..))
import qualified Data.ByteString as BS (replicate)
import Data.Default (Default (..))
import qualified Data.Map.Strict as Map
import Data.Maybe (fromJust)
import qualified Data.Sequence.Strict as StrictSeq
import qualified PlutusLedgerApi.V1 as PV1
import Test.Cardano.Ledger.Core.KeyPair (KeyPair (..), mkWitnessVKey)
import Test.Cardano.Ledger.Examples.AlonzoValidTxUTXOW (mkSingleRedeemer)
import Test.Cardano.Ledger.Examples.STSTestUtils (
  alwaysFailsHash,
  alwaysSucceedsHash,
  initUTxO,
  mkGenesisTxIn,
  mkTxDats,
  someAddr,
  someKeys,
  someScriptAddr,
  testBBODY,
  trustMeP,
 )
import Test.Cardano.Ledger.Generic.Fields (
  PParamsField (..),
  TxBodyField (..),
  TxField (..),
  TxOutField (..),
  WitnessesField (..),
 )
import Test.Cardano.Ledger.Generic.GenState (PlutusPurposeTag (..))
import Test.Cardano.Ledger.Generic.PrettyCore ()
import Test.Cardano.Ledger.Generic.Proof
import Test.Cardano.Ledger.Generic.Scriptic (
  HasTokens (..),
  PostShelley,
  Scriptic (..),
  after,
  matchkey,
 )
import Test.Cardano.Ledger.Generic.Updaters
import Test.Cardano.Ledger.Plutus (zeroTestingCostModels)
import Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (MockCrypto)
import Test.Cardano.Ledger.Shelley.Utils (
  RawSeed (..),
  mkKeyPair,
  mkVRFKeyPair,
 )
import Test.Cardano.Protocol.TPraos.Create (VRFKeyPair (..))
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (testCase)

tests :: TestTree
tests :: TestTree
tests =
  TestName -> [TestTree] -> TestTree
testGroup
    TestName
"Generic Tests, testing Alonzo PredicateFailures, in postAlonzo eras."
    [ forall era.
(HasTokens era, PostShelley era, Value era ~ MaryValue,
 EraSegWits era, Reflect era,
 State (EraRule "LEDGERS" era) ~ LedgerState era) =>
Proof era -> TestTree
alonzoBBODYexamplesP Proof AlonzoEra
Alonzo
    , forall era.
(HasTokens era, PostShelley era, Value era ~ MaryValue,
 EraSegWits era, Reflect era,
 State (EraRule "LEDGERS" era) ~ LedgerState era) =>
Proof era -> TestTree
alonzoBBODYexamplesP Proof BabbageEra
Babbage
    , forall era.
(HasTokens era, PostShelley era, Value era ~ MaryValue,
 EraSegWits era, Reflect era,
 State (EraRule "LEDGERS" era) ~ LedgerState era) =>
Proof era -> TestTree
alonzoBBODYexamplesP Proof ConwayEra
Conway
    ]

alonzoBBODYexamplesP ::
  forall era.
  ( HasTokens era
  , PostShelley era
  , Value era ~ MaryValue
  , EraSegWits era
  , Reflect era
  , State (EraRule "LEDGERS" era) ~ LedgerState era
  ) =>
  Proof era ->
  TestTree
alonzoBBODYexamplesP :: forall era.
(HasTokens era, PostShelley era, Value era ~ MaryValue,
 EraSegWits era, Reflect era,
 State (EraRule "LEDGERS" era) ~ LedgerState era) =>
Proof era -> TestTree
alonzoBBODYexamplesP Proof era
proof =
  TestName -> [TestTree] -> TestTree
testGroup
    (forall a. Show a => a -> TestName
show Proof era
proof forall a. [a] -> [a] -> [a]
++ TestName
" BBODY examples")
    [ TestName -> Assertion -> TestTree
testCase TestName
"eight plutus scripts cases" forall a b. (a -> b) -> a -> b
$
        forall era.
(Reflect era, HasCallStack) =>
WitRule "BBODY" era
-> ShelleyBbodyState era
-> Block BHeaderView era
-> Either
     (NonEmpty (PredicateFailure (EraRule "BBODY" era)))
     (ShelleyBbodyState era)
-> PParams era
-> Assertion
testBBODY
          (forall e. Proof e -> WitRule "BBODY" e
BBODY Proof era
proof)
          (forall era.
(EraTxOut era, PostShelley era, EraGov era,
 State (EraRule "LEDGERS" era) ~ LedgerState era) =>
Proof era -> UTxO era -> ShelleyBbodyState era
initialBBodyState Proof era
proof (forall era.
(EraTxOut era, PostShelley era) =>
Proof era -> UTxO era
initUTxO Proof era
proof))
          (forall era.
(HasTokens era, Scriptic era, EraSegWits era,
 Value era ~ MaryValue, ShelleyEraTxCert era) =>
Proof era -> Block BHeaderView era
testAlonzoBlock Proof era
proof)
          (forall a b. b -> Either a b
Right (forall era.
(HasTokens era, PostShelley era, EraTxBody era,
 Value era ~ MaryValue, EraGov era,
 State (EraRule "LEDGERS" era) ~ LedgerState era,
 ShelleyEraTxCert era) =>
Proof era -> ShelleyBbodyState era
testBBodyState Proof era
proof))
          (forall era. EraPParams era => Proof era -> PParams era
pp Proof era
proof)
    , TestName -> Assertion -> TestTree
testCase TestName
"block with bad pool md hash in tx" forall a b. (a -> b) -> a -> b
$
        forall era.
(Reflect era, HasCallStack) =>
WitRule "BBODY" era
-> ShelleyBbodyState era
-> Block BHeaderView era
-> Either
     (NonEmpty (PredicateFailure (EraRule "BBODY" era)))
     (ShelleyBbodyState era)
-> PParams era
-> Assertion
testBBODY
          (forall e. Proof e -> WitRule "BBODY" e
BBODY Proof era
proof)
          (forall era.
(EraTxOut era, PostShelley era, EraGov era,
 State (EraRule "LEDGERS" era) ~ LedgerState era) =>
Proof era -> UTxO era -> ShelleyBbodyState era
initialBBodyState Proof era
proof (forall era.
(EraTxOut era, PostShelley era) =>
Proof era -> UTxO era
initUTxO Proof era
proof))
          (forall era. Proof era -> Block BHeaderView era
testAlonzoBadPMDHBlock Proof era
proof)
          (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall era. Proof era -> PredicateFailure (EraRule "BBODY" era)
makeTooBig Proof era
proof)
          (forall era. EraPParams era => Proof era -> PParams era
pp Proof era
proof)
    ]

initialBBodyState ::
  forall era.
  ( EraTxOut era
  , PostShelley era
  , EraGov era
  , State (EraRule "LEDGERS" era) ~ LedgerState era
  ) =>
  Proof era ->
  UTxO era ->
  ShelleyBbodyState era
initialBBodyState :: forall era.
(EraTxOut era, PostShelley era, EraGov era,
 State (EraRule "LEDGERS" era) ~ LedgerState era) =>
Proof era -> UTxO era -> ShelleyBbodyState era
initialBBodyState Proof era
pf UTxO era
utxo =
  forall era.
State (EraRule "LEDGERS" era)
-> BlocksMade -> ShelleyBbodyState era
BbodyState (forall era. UTxOState era -> CertState era -> LedgerState era
LedgerState UTxOState era
initialUtxoSt CertState era
dpstate) (Map (KeyHash 'StakePool) Natural -> BlocksMade
BlocksMade forall a. Monoid a => a
mempty)
  where
    initialUtxoSt :: UTxOState era
initialUtxoSt =
      forall era.
EraTxOut era =>
PParams era
-> UTxO era
-> Coin
-> Coin
-> GovState era
-> Coin
-> UTxOState era
smartUTxOState (forall era. EraPParams era => Proof era -> PParams era
pp Proof era
pf) UTxO era
utxo (forall a. Compactible a => CompactForm a -> a
UM.fromCompact CompactForm Coin
successDeposit) (Integer -> Coin
Coin Integer
0) forall a. Default a => a
def forall a. Monoid a => a
mempty
    dpstate :: CertState era
dpstate =
      forall a. Default a => a
def
        { certDState :: DState era
certDState =
            DState
              { dsUnified :: UMap
dsUnified =
                  forall k v. k -> v -> UView k v -> UMap
UM.insert
                    (forall era. Scriptic era => Proof era -> StakeCredential
scriptStakeCredSuceed Proof era
pf)
                    (CompactForm Coin -> CompactForm Coin -> RDPair
UM.RDPair (Word64 -> CompactForm Coin
UM.CompactCoin Word64
1000) CompactForm Coin
successDeposit)
                    (UMap -> UView StakeCredential RDPair
RewDepUView UMap
UM.empty)
              , dsFutureGenDelegs :: Map FutureGenDeleg GenDelegPair
dsFutureGenDelegs = forall k a. Map k a
Map.empty
              , dsGenDelegs :: GenDelegs
dsGenDelegs = Map (KeyHash 'Genesis) GenDelegPair -> GenDelegs
GenDelegs forall k a. Map k a
Map.empty
              , dsIRewards :: InstantaneousRewards
dsIRewards = forall a. Default a => a
def
              }
        }

testAlonzoBlock ::
  ( HasTokens era
  , Scriptic era
  , EraSegWits era
  , Value era ~ MaryValue
  , ShelleyEraTxCert era
  ) =>
  Proof era ->
  Block BHeaderView era
testAlonzoBlock :: forall era.
(HasTokens era, Scriptic era, EraSegWits era,
 Value era ~ MaryValue, ShelleyEraTxCert era) =>
Proof era -> Block BHeaderView era
testAlonzoBlock Proof era
pf =
  forall era. EraSegWits era => [Tx era] -> Block BHeaderView era
makeNaiveBlock
    [ forall era. Proof era -> Bool -> Tx era -> Tx era
trustMeP Proof era
pf Bool
True forall a b. (a -> b) -> a -> b
$ forall era. (Scriptic era, EraTx era) => Proof era -> Tx era
validatingTx Proof era
pf
    , forall era. Proof era -> Bool -> Tx era -> Tx era
trustMeP Proof era
pf Bool
False forall a b. (a -> b) -> a -> b
$ forall era. (Scriptic era, EraTx era) => Proof era -> Tx era
notValidatingTx Proof era
pf
    , forall era. Proof era -> Bool -> Tx era -> Tx era
trustMeP Proof era
pf Bool
True forall a b. (a -> b) -> a -> b
$ forall era. (Scriptic era, EraTx era) => Proof era -> Tx era
validatingTxWithWithdrawal Proof era
pf
    , forall era. Proof era -> Bool -> Tx era -> Tx era
trustMeP Proof era
pf Bool
False forall a b. (a -> b) -> a -> b
$ forall era. (Scriptic era, EraTx era) => Proof era -> Tx era
notValidatingTxWithWithdrawal Proof era
pf
    , forall era. Proof era -> Bool -> Tx era -> Tx era
trustMeP Proof era
pf Bool
True forall a b. (a -> b) -> a -> b
$ forall era.
(Scriptic era, EraTx era, ShelleyEraTxCert era) =>
Proof era -> Tx era
validatingTxWithCert Proof era
pf
    , forall era. Proof era -> Bool -> Tx era -> Tx era
trustMeP Proof era
pf Bool
False forall a b. (a -> b) -> a -> b
$ forall era.
(Scriptic era, EraTx era, ShelleyEraTxCert era) =>
Proof era -> Tx era
notValidatingTxWithCert Proof era
pf
    , forall era. Proof era -> Bool -> Tx era -> Tx era
trustMeP Proof era
pf Bool
True forall a b. (a -> b) -> a -> b
$ forall era.
(Scriptic era, HasTokens era, EraTx era, Value era ~ MaryValue) =>
Proof era -> Tx era
validatingTxWithMint Proof era
pf
    , forall era. Proof era -> Bool -> Tx era -> Tx era
trustMeP Proof era
pf Bool
False forall a b. (a -> b) -> a -> b
$ forall era.
(Scriptic era, HasTokens era, EraTx era, Value era ~ MaryValue) =>
Proof era -> Tx era
notValidatingTxWithMint Proof era
pf
    ]

testAlonzoBadPMDHBlock ::
  Proof era -> Block BHeaderView era
testAlonzoBadPMDHBlock :: forall era. Proof era -> Block BHeaderView era
testAlonzoBadPMDHBlock pf :: Proof era
pf@Proof era
Alonzo = forall era. EraSegWits era => [Tx era] -> Block BHeaderView era
makeNaiveBlock [forall era. Proof era -> Bool -> Tx era -> Tx era
trustMeP Proof era
pf Bool
True forall a b. (a -> b) -> a -> b
$ forall era. (Scriptic era, EraTxBody era) => Proof era -> Tx era
poolMDHTooBigTx Proof era
pf]
testAlonzoBadPMDHBlock pf :: Proof era
pf@Proof era
Babbage = forall era. EraSegWits era => [Tx era] -> Block BHeaderView era
makeNaiveBlock [forall era. Proof era -> Bool -> Tx era -> Tx era
trustMeP Proof era
pf Bool
True forall a b. (a -> b) -> a -> b
$ forall era. (Scriptic era, EraTxBody era) => Proof era -> Tx era
poolMDHTooBigTx Proof era
pf]
testAlonzoBadPMDHBlock pf :: Proof era
pf@Proof era
Conway = forall era. EraSegWits era => [Tx era] -> Block BHeaderView era
makeNaiveBlock [forall era. Proof era -> Bool -> Tx era -> Tx era
trustMeP Proof era
pf Bool
True forall a b. (a -> b) -> a -> b
$ forall era. (Scriptic era, EraTxBody era) => Proof era -> Tx era
poolMDHTooBigTx Proof era
pf]
testAlonzoBadPMDHBlock Proof era
other = forall a. HasCallStack => TestName -> a
error (TestName
"testAlonzoBadPMDHBlock does not work in era " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> TestName
show Proof era
other)

-- ============================== DATA ===============================

someDatum :: Era era => Data era
someDatum :: forall era. Era era => Data era
someDatum = forall era. Era era => Data -> Data era
Data (Integer -> Data
PV1.I Integer
123)

anotherDatum :: Era era => Data era
anotherDatum :: forall era. Era era => Data era
anotherDatum = forall era. Era era => Data -> Data era
Data (Integer -> Data
PV1.I Integer
0)

validatingTx ::
  forall era.
  ( Scriptic era
  , EraTx era
  ) =>
  Proof era ->
  Tx era
validatingTx :: forall era. (Scriptic era, EraTx era) => Proof era -> Tx era
validatingTx Proof era
pf =
  forall era. Proof era -> [TxField era] -> Tx era
newTx
    Proof era
pf
    [ forall era. TxBody era -> TxField era
Body (forall era.
(Scriptic era, EraTxBody era) =>
Proof era -> TxBody era
validatingBody Proof era
pf)
    , forall era. [WitnessesField era] -> TxField era
WitnessesI
        [ forall era. Era era => [WitVKey 'Witness] -> WitnessesField era
AddrWits' [forall (kr :: KeyRole).
SafeHash EraIndependentTxBody -> KeyPair kr -> WitVKey 'Witness
mkWitnessVKey (forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated (forall era.
(Scriptic era, EraTxBody era) =>
Proof era -> TxBody era
validatingBody Proof era
pf)) (forall era. Proof era -> KeyPair 'Payment
someKeys Proof era
pf)]
        , forall era. EraScript era => [Script era] -> WitnessesField era
ScriptWits' [forall era. Scriptic era => Natural -> Proof era -> Script era
always Natural
3 Proof era
pf]
        , forall era. Era era => [Data era] -> WitnessesField era
DataWits' [forall era. Era era => Data era
someDatum]
        , forall era. Redeemers era -> WitnessesField era
RdmrWits forall a b. (a -> b) -> a -> b
$ forall era. Era era => Proof era -> Redeemers era
validatingRedeemers Proof era
pf
        ]
    ]

validatingBody :: (Scriptic era, EraTxBody era) => Proof era -> TxBody era
validatingBody :: forall era.
(Scriptic era, EraTxBody era) =>
Proof era -> TxBody era
validatingBody Proof era
pf =
  forall era.
EraTxBody era =>
Proof era -> [TxBodyField era] -> TxBody era
newTxBody
    Proof era
pf
    [ forall era. [TxIn] -> TxBodyField era
Inputs' [HasCallStack => Integer -> TxIn
mkGenesisTxIn Integer
1]
    , forall era. [TxIn] -> TxBodyField era
Collateral' [HasCallStack => Integer -> TxIn
mkGenesisTxIn Integer
11]
    , forall era. [TxOut era] -> TxBodyField era
Outputs' [forall era. EraTxOut era => Proof era -> TxOut era
validatingTxOut Proof era
pf]
    , forall era. Coin -> TxBodyField era
Txfee (Integer -> Coin
Coin Integer
5)
    , forall era. StrictMaybe ScriptIntegrityHash -> TxBodyField era
WppHash
        ( forall era.
Proof era
-> PParams era
-> [Language]
-> Redeemers era
-> TxDats era
-> StrictMaybe ScriptIntegrityHash
newScriptIntegrityHash
            Proof era
pf
            (forall era. EraPParams era => Proof era -> PParams era
pp Proof era
pf)
            [Language
PlutusV1]
            (forall era. Era era => Proof era -> Redeemers era
validatingRedeemers Proof era
pf)
            (forall era. Era era => Data era -> TxDats era
mkTxDats forall era. Era era => Data era
someDatum)
        )
    ]

validatingRedeemers :: Era era => Proof era -> Redeemers era
validatingRedeemers :: forall era. Era era => Proof era -> Redeemers era
validatingRedeemers Proof era
pf = forall era.
Proof era -> PlutusPurposeTag -> Data era -> Redeemers era
mkSingleRedeemer Proof era
pf PlutusPurposeTag
Spending (forall era. Era era => Data -> Data era
Data (Integer -> Data
PV1.I Integer
42))

validatingTxOut :: EraTxOut era => Proof era -> TxOut era
validatingTxOut :: forall era. EraTxOut era => Proof era -> TxOut era
validatingTxOut Proof era
pf = forall era. Proof era -> [TxOutField era] -> TxOut era
newTxOut Proof era
pf [forall era. Addr -> TxOutField era
Address (forall era. Proof era -> Addr
someAddr Proof era
pf), forall era. Value era -> TxOutField era
Amount (forall t s. Inject t s => t -> s
inject forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
4995)]

notValidatingTx ::
  ( Scriptic era
  , EraTx era
  ) =>
  Proof era ->
  Tx era
notValidatingTx :: forall era. (Scriptic era, EraTx era) => Proof era -> Tx era
notValidatingTx Proof era
pf =
  forall era. Proof era -> [TxField era] -> Tx era
newTx
    Proof era
pf
    [ forall era. TxBody era -> TxField era
Body TxBody era
notValidatingBody
    , forall era. [WitnessesField era] -> TxField era
WitnessesI
        [ forall era. Era era => [WitVKey 'Witness] -> WitnessesField era
AddrWits' [forall (kr :: KeyRole).
SafeHash EraIndependentTxBody -> KeyPair kr -> WitVKey 'Witness
mkWitnessVKey (forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated TxBody era
notValidatingBody) (forall era. Proof era -> KeyPair 'Payment
someKeys Proof era
pf)]
        , forall era. EraScript era => [Script era] -> WitnessesField era
ScriptWits' [forall era. Scriptic era => Natural -> Proof era -> Script era
never Natural
0 Proof era
pf]
        , forall era. Era era => [Data era] -> WitnessesField era
DataWits' [forall era. Era era => Data era
anotherDatum]
        , forall era. Redeemers era -> WitnessesField era
RdmrWits Redeemers era
notValidatingRedeemers
        ]
    ]
  where
    notValidatingBody :: TxBody era
notValidatingBody =
      forall era.
EraTxBody era =>
Proof era -> [TxBodyField era] -> TxBody era
newTxBody
        Proof era
pf
        [ forall era. [TxIn] -> TxBodyField era
Inputs' [HasCallStack => Integer -> TxIn
mkGenesisTxIn Integer
2]
        , forall era. [TxIn] -> TxBodyField era
Collateral' [HasCallStack => Integer -> TxIn
mkGenesisTxIn Integer
12]
        , forall era. [TxOut era] -> TxBodyField era
Outputs' [forall era. Proof era -> [TxOutField era] -> TxOut era
newTxOut Proof era
pf [forall era. Addr -> TxOutField era
Address (forall era. Proof era -> Addr
someAddr Proof era
pf), forall era. Value era -> TxOutField era
Amount (forall t s. Inject t s => t -> s
inject forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
2995)]]
        , forall era. Coin -> TxBodyField era
Txfee (Integer -> Coin
Coin Integer
5)
        , forall era. StrictMaybe ScriptIntegrityHash -> TxBodyField era
WppHash
            ( forall era.
Proof era
-> PParams era
-> [Language]
-> Redeemers era
-> TxDats era
-> StrictMaybe ScriptIntegrityHash
newScriptIntegrityHash
                Proof era
pf
                (forall era. EraPParams era => Proof era -> PParams era
pp Proof era
pf)
                [Language
PlutusV1]
                Redeemers era
notValidatingRedeemers
                (forall era. Era era => Data era -> TxDats era
mkTxDats forall era. Era era => Data era
anotherDatum)
            )
        ]
    notValidatingRedeemers :: Redeemers era
notValidatingRedeemers = forall era.
Proof era -> PlutusPurposeTag -> Data era -> Redeemers era
mkSingleRedeemer Proof era
pf PlutusPurposeTag
Spending (forall era. Era era => Data -> Data era
Data (Integer -> Data
PV1.I Integer
1))

validatingTxWithWithdrawal ::
  forall era.
  ( Scriptic era
  , EraTx era
  ) =>
  Proof era ->
  Tx era
validatingTxWithWithdrawal :: forall era. (Scriptic era, EraTx era) => Proof era -> Tx era
validatingTxWithWithdrawal Proof era
pf =
  forall era. Proof era -> [TxField era] -> Tx era
newTx
    Proof era
pf
    [ forall era. TxBody era -> TxField era
Body (forall era.
(EraTxBody era, Scriptic era) =>
Proof era -> TxBody era
validatingBodyWithWithdrawal Proof era
pf)
    , forall era. [WitnessesField era] -> TxField era
WitnessesI
        [ forall era. Era era => [WitVKey 'Witness] -> WitnessesField era
AddrWits' [forall (kr :: KeyRole).
SafeHash EraIndependentTxBody -> KeyPair kr -> WitVKey 'Witness
mkWitnessVKey (forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated (forall era.
(EraTxBody era, Scriptic era) =>
Proof era -> TxBody era
validatingBodyWithWithdrawal Proof era
pf)) (forall era. Proof era -> KeyPair 'Payment
someKeys Proof era
pf)]
        , forall era. EraScript era => [Script era] -> WitnessesField era
ScriptWits' [forall era. Scriptic era => Natural -> Proof era -> Script era
always Natural
2 Proof era
pf]
        , forall era. Redeemers era -> WitnessesField era
RdmrWits forall a b. (a -> b) -> a -> b
$ forall era. Era era => Proof era -> Redeemers era
validatingWithWithdrawalRedeemers Proof era
pf
        ]
    ]

validatingBodyWithWithdrawal :: (EraTxBody era, Scriptic era) => Proof era -> TxBody era
validatingBodyWithWithdrawal :: forall era.
(EraTxBody era, Scriptic era) =>
Proof era -> TxBody era
validatingBodyWithWithdrawal Proof era
pf =
  forall era.
EraTxBody era =>
Proof era -> [TxBodyField era] -> TxBody era
newTxBody
    Proof era
pf
    [ forall era. [TxIn] -> TxBodyField era
Inputs' [HasCallStack => Integer -> TxIn
mkGenesisTxIn Integer
5]
    , forall era. [TxIn] -> TxBodyField era
Collateral' [HasCallStack => Integer -> TxIn
mkGenesisTxIn Integer
15]
    , forall era. [TxOut era] -> TxBodyField era
Outputs' [forall era. EraTxOut era => Proof era -> TxOut era
validatingTxWithWithdrawalOut Proof era
pf]
    , forall era. Coin -> TxBodyField era
Txfee (Integer -> Coin
Coin Integer
5)
    , forall era. Withdrawals -> TxBodyField era
Withdrawals'
        ( Map RewardAccount Coin -> Withdrawals
Withdrawals forall a b. (a -> b) -> a -> b
$
            forall k a. k -> a -> Map k a
Map.singleton
              (Network -> StakeCredential -> RewardAccount
RewardAccount Network
Testnet (forall era. Scriptic era => Proof era -> StakeCredential
scriptStakeCredSuceed Proof era
pf))
              (Integer -> Coin
Coin Integer
1000)
        )
    , forall era. StrictMaybe ScriptIntegrityHash -> TxBodyField era
WppHash
        ( forall era.
Proof era
-> PParams era
-> [Language]
-> Redeemers era
-> TxDats era
-> StrictMaybe ScriptIntegrityHash
newScriptIntegrityHash
            Proof era
pf
            (forall era. EraPParams era => Proof era -> PParams era
pp Proof era
pf)
            [Language
PlutusV1]
            (forall era. Era era => Proof era -> Redeemers era
validatingWithWithdrawalRedeemers Proof era
pf)
            forall a. Monoid a => a
mempty
        )
    ]

validatingWithWithdrawalRedeemers :: Era era => Proof era -> Redeemers era
validatingWithWithdrawalRedeemers :: forall era. Era era => Proof era -> Redeemers era
validatingWithWithdrawalRedeemers Proof era
pf = forall era.
Proof era -> PlutusPurposeTag -> Data era -> Redeemers era
mkSingleRedeemer Proof era
pf PlutusPurposeTag
Rewarding (forall era. Era era => Data -> Data era
Data (Integer -> Data
PV1.I Integer
42))

validatingTxWithWithdrawalOut :: EraTxOut era => Proof era -> TxOut era
validatingTxWithWithdrawalOut :: forall era. EraTxOut era => Proof era -> TxOut era
validatingTxWithWithdrawalOut Proof era
pf = forall era. Proof era -> [TxOutField era] -> TxOut era
newTxOut Proof era
pf [forall era. Addr -> TxOutField era
Address (forall era. Proof era -> Addr
someAddr Proof era
pf), forall era. Value era -> TxOutField era
Amount (forall t s. Inject t s => t -> s
inject forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
1995)]

notValidatingTxWithWithdrawal ::
  forall era.
  ( Scriptic era
  , EraTx era
  ) =>
  Proof era ->
  Tx era
notValidatingTxWithWithdrawal :: forall era. (Scriptic era, EraTx era) => Proof era -> Tx era
notValidatingTxWithWithdrawal Proof era
pf =
  forall era. Proof era -> [TxField era] -> Tx era
newTx
    Proof era
pf
    [ forall era. TxBody era -> TxField era
Body TxBody era
notValidatingBodyWithWithdrawal
    , forall era. [WitnessesField era] -> TxField era
WitnessesI
        [ forall era. Era era => [WitVKey 'Witness] -> WitnessesField era
AddrWits' [forall (kr :: KeyRole).
SafeHash EraIndependentTxBody -> KeyPair kr -> WitVKey 'Witness
mkWitnessVKey (forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated TxBody era
notValidatingBodyWithWithdrawal) (forall era. Proof era -> KeyPair 'Payment
someKeys Proof era
pf)]
        , forall era. EraScript era => [Script era] -> WitnessesField era
ScriptWits' [forall era. Scriptic era => Natural -> Proof era -> Script era
never Natural
1 Proof era
pf]
        , forall era. Redeemers era -> WitnessesField era
RdmrWits Redeemers era
notValidatingRedeemers
        ]
    ]
  where
    notValidatingBodyWithWithdrawal :: TxBody era
notValidatingBodyWithWithdrawal =
      forall era.
EraTxBody era =>
Proof era -> [TxBodyField era] -> TxBody era
newTxBody
        Proof era
pf
        [ forall era. [TxIn] -> TxBodyField era
Inputs' [HasCallStack => Integer -> TxIn
mkGenesisTxIn Integer
6]
        , forall era. [TxIn] -> TxBodyField era
Collateral' [HasCallStack => Integer -> TxIn
mkGenesisTxIn Integer
16]
        , forall era. [TxOut era] -> TxBodyField era
Outputs' [forall era. Proof era -> [TxOutField era] -> TxOut era
newTxOut Proof era
pf [forall era. Addr -> TxOutField era
Address (forall era. Proof era -> Addr
someAddr Proof era
pf), forall era. Value era -> TxOutField era
Amount (forall t s. Inject t s => t -> s
inject forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
1995)]]
        , forall era. Coin -> TxBodyField era
Txfee (Integer -> Coin
Coin Integer
5)
        , forall era. Withdrawals -> TxBodyField era
Withdrawals'
            ( Map RewardAccount Coin -> Withdrawals
Withdrawals forall a b. (a -> b) -> a -> b
$
                forall k a. k -> a -> Map k a
Map.singleton
                  (Network -> StakeCredential -> RewardAccount
RewardAccount Network
Testnet (forall era. Scriptic era => Proof era -> StakeCredential
scriptStakeCredFail Proof era
pf))
                  (Integer -> Coin
Coin Integer
1000)
            )
        , forall era. StrictMaybe ScriptIntegrityHash -> TxBodyField era
WppHash (forall era.
Proof era
-> PParams era
-> [Language]
-> Redeemers era
-> TxDats era
-> StrictMaybe ScriptIntegrityHash
newScriptIntegrityHash Proof era
pf (forall era. EraPParams era => Proof era -> PParams era
pp Proof era
pf) [Language
PlutusV1] Redeemers era
notValidatingRedeemers forall a. Monoid a => a
mempty)
        ]
    notValidatingRedeemers :: Redeemers era
notValidatingRedeemers = forall era.
Proof era -> PlutusPurposeTag -> Data era -> Redeemers era
mkSingleRedeemer Proof era
pf PlutusPurposeTag
Rewarding (forall era. Era era => Data -> Data era
Data (Integer -> Data
PV1.I Integer
0))

validatingTxWithCert ::
  forall era.
  ( Scriptic era
  , EraTx era
  , ShelleyEraTxCert era
  ) =>
  Proof era ->
  Tx era
validatingTxWithCert :: forall era.
(Scriptic era, EraTx era, ShelleyEraTxCert era) =>
Proof era -> Tx era
validatingTxWithCert Proof era
pf =
  forall era. Proof era -> [TxField era] -> Tx era
newTx
    Proof era
pf
    [ forall era. TxBody era -> TxField era
Body (forall era.
(Scriptic era, EraTxBody era, ShelleyEraTxCert era) =>
Proof era -> TxBody era
validatingBodyWithCert Proof era
pf)
    , forall era. [WitnessesField era] -> TxField era
WitnessesI
        [ forall era. Era era => [WitVKey 'Witness] -> WitnessesField era
AddrWits' [forall (kr :: KeyRole).
SafeHash EraIndependentTxBody -> KeyPair kr -> WitVKey 'Witness
mkWitnessVKey (forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated (forall era.
(Scriptic era, EraTxBody era, ShelleyEraTxCert era) =>
Proof era -> TxBody era
validatingBodyWithCert Proof era
pf)) (forall era. Proof era -> KeyPair 'Payment
someKeys Proof era
pf)]
        , forall era. EraScript era => [Script era] -> WitnessesField era
ScriptWits' [forall era. Scriptic era => Natural -> Proof era -> Script era
always Natural
2 Proof era
pf]
        , forall era. Redeemers era -> WitnessesField era
RdmrWits forall a b. (a -> b) -> a -> b
$ forall era. Era era => Proof era -> Redeemers era
validatingRedeemrsWithCert Proof era
pf
        ]
    ]

validatingBodyWithCert ::
  (Scriptic era, EraTxBody era, ShelleyEraTxCert era) => Proof era -> TxBody era
validatingBodyWithCert :: forall era.
(Scriptic era, EraTxBody era, ShelleyEraTxCert era) =>
Proof era -> TxBody era
validatingBodyWithCert Proof era
pf =
  forall era.
EraTxBody era =>
Proof era -> [TxBodyField era] -> TxBody era
newTxBody
    Proof era
pf
    [ forall era. [TxIn] -> TxBodyField era
Inputs' [HasCallStack => Integer -> TxIn
mkGenesisTxIn Integer
3]
    , forall era. [TxIn] -> TxBodyField era
Collateral' [HasCallStack => Integer -> TxIn
mkGenesisTxIn Integer
13]
    , forall era. [TxOut era] -> TxBodyField era
Outputs' [forall era. EraTxOut era => Proof era -> TxOut era
validatingTxWithCertOut Proof era
pf]
    , forall era. [TxCert era] -> TxBodyField era
Certs' [forall era. ShelleyEraTxCert era => StakeCredential -> TxCert era
UnRegTxCert (forall era. Scriptic era => Proof era -> StakeCredential
scriptStakeCredSuceed Proof era
pf)]
    , forall era. Coin -> TxBodyField era
Txfee (Integer -> Coin
Coin Integer
5)
    , forall era. StrictMaybe ScriptIntegrityHash -> TxBodyField era
WppHash (forall era.
Proof era
-> PParams era
-> [Language]
-> Redeemers era
-> TxDats era
-> StrictMaybe ScriptIntegrityHash
newScriptIntegrityHash Proof era
pf (forall era. EraPParams era => Proof era -> PParams era
pp Proof era
pf) [Language
PlutusV1] (forall era. Era era => Proof era -> Redeemers era
validatingRedeemrsWithCert Proof era
pf) forall a. Monoid a => a
mempty)
    ]

validatingRedeemrsWithCert :: Era era => Proof era -> Redeemers era
validatingRedeemrsWithCert :: forall era. Era era => Proof era -> Redeemers era
validatingRedeemrsWithCert Proof era
pf = forall era.
Proof era -> PlutusPurposeTag -> Data era -> Redeemers era
mkSingleRedeemer Proof era
pf PlutusPurposeTag
Certifying (forall era. Era era => Data -> Data era
Data (Integer -> Data
PV1.I Integer
42))

validatingTxWithCertOut :: EraTxOut era => Proof era -> TxOut era
validatingTxWithCertOut :: forall era. EraTxOut era => Proof era -> TxOut era
validatingTxWithCertOut Proof era
pf =
  forall era. Proof era -> [TxOutField era] -> TxOut era
newTxOut
    Proof era
pf
    [ forall era. Addr -> TxOutField era
Address (forall era. Proof era -> Addr
someAddr Proof era
pf)
    , forall era. Value era -> TxOutField era
Amount (forall t s. Inject t s => t -> s
inject forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
995 forall a. Semigroup a => a -> a -> a
<> forall a. Compactible a => CompactForm a -> a
UM.fromCompact CompactForm Coin
successDeposit)
    ]

notValidatingTxWithCert ::
  forall era.
  ( Scriptic era
  , EraTx era
  , ShelleyEraTxCert era
  ) =>
  Proof era ->
  Tx era
notValidatingTxWithCert :: forall era.
(Scriptic era, EraTx era, ShelleyEraTxCert era) =>
Proof era -> Tx era
notValidatingTxWithCert Proof era
pf =
  forall era. Proof era -> [TxField era] -> Tx era
newTx
    Proof era
pf
    [ forall era. TxBody era -> TxField era
Body TxBody era
notValidatingBodyWithCert
    , forall era. [WitnessesField era] -> TxField era
WitnessesI
        [ forall era. Era era => [WitVKey 'Witness] -> WitnessesField era
AddrWits' [forall (kr :: KeyRole).
SafeHash EraIndependentTxBody -> KeyPair kr -> WitVKey 'Witness
mkWitnessVKey (forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated TxBody era
notValidatingBodyWithCert) (forall era. Proof era -> KeyPair 'Payment
someKeys Proof era
pf)]
        , forall era. EraScript era => [Script era] -> WitnessesField era
ScriptWits' [forall era. Scriptic era => Natural -> Proof era -> Script era
never Natural
1 Proof era
pf]
        , forall era. Redeemers era -> WitnessesField era
RdmrWits Redeemers era
notValidatingRedeemersWithCert
        ]
    ]
  where
    notValidatingBodyWithCert :: TxBody era
notValidatingBodyWithCert =
      forall era.
EraTxBody era =>
Proof era -> [TxBodyField era] -> TxBody era
newTxBody
        Proof era
pf
        [ forall era. [TxIn] -> TxBodyField era
Inputs' [HasCallStack => Integer -> TxIn
mkGenesisTxIn Integer
4]
        , forall era. [TxIn] -> TxBodyField era
Collateral' [HasCallStack => Integer -> TxIn
mkGenesisTxIn Integer
14]
        , forall era. [TxOut era] -> TxBodyField era
Outputs' [forall era. Proof era -> [TxOutField era] -> TxOut era
newTxOut Proof era
pf [forall era. Addr -> TxOutField era
Address (forall era. Proof era -> Addr
someAddr Proof era
pf), forall era. Value era -> TxOutField era
Amount (forall t s. Inject t s => t -> s
inject forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
995)]]
        , forall era. [TxCert era] -> TxBodyField era
Certs' [forall era. ShelleyEraTxCert era => StakeCredential -> TxCert era
UnRegTxCert (forall era. Scriptic era => Proof era -> StakeCredential
scriptStakeCredFail Proof era
pf)]
        , forall era. Coin -> TxBodyField era
Txfee (Integer -> Coin
Coin Integer
5)
        , forall era. StrictMaybe ScriptIntegrityHash -> TxBodyField era
WppHash (forall era.
Proof era
-> PParams era
-> [Language]
-> Redeemers era
-> TxDats era
-> StrictMaybe ScriptIntegrityHash
newScriptIntegrityHash Proof era
pf (forall era. EraPParams era => Proof era -> PParams era
pp Proof era
pf) [Language
PlutusV1] Redeemers era
notValidatingRedeemersWithCert forall a. Monoid a => a
mempty)
        ]
    notValidatingRedeemersWithCert :: Redeemers era
notValidatingRedeemersWithCert = forall era.
Proof era -> PlutusPurposeTag -> Data era -> Redeemers era
mkSingleRedeemer Proof era
pf PlutusPurposeTag
Certifying (forall era. Era era => Data -> Data era
Data (Integer -> Data
PV1.I Integer
0))

validatingTxWithMint ::
  forall era.
  ( Scriptic era
  , HasTokens era
  , EraTx era
  , Value era ~ MaryValue
  ) =>
  Proof era ->
  Tx era
validatingTxWithMint :: forall era.
(Scriptic era, HasTokens era, EraTx era, Value era ~ MaryValue) =>
Proof era -> Tx era
validatingTxWithMint Proof era
pf =
  forall era. Proof era -> [TxField era] -> Tx era
newTx
    Proof era
pf
    [ forall era. TxBody era -> TxField era
Body (forall era.
(HasTokens era, EraTxBody era, Scriptic era,
 Value era ~ MaryValue) =>
Proof era -> TxBody era
validatingBodyWithMint Proof era
pf)
    , forall era. [WitnessesField era] -> TxField era
WitnessesI
        [ forall era. Era era => [WitVKey 'Witness] -> WitnessesField era
AddrWits' [forall (kr :: KeyRole).
SafeHash EraIndependentTxBody -> KeyPair kr -> WitVKey 'Witness
mkWitnessVKey (forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated (forall era.
(HasTokens era, EraTxBody era, Scriptic era,
 Value era ~ MaryValue) =>
Proof era -> TxBody era
validatingBodyWithMint Proof era
pf)) (forall era. Proof era -> KeyPair 'Payment
someKeys Proof era
pf)]
        , forall era. EraScript era => [Script era] -> WitnessesField era
ScriptWits' [forall era. Scriptic era => Natural -> Proof era -> Script era
always Natural
2 Proof era
pf]
        , forall era. Redeemers era -> WitnessesField era
RdmrWits forall a b. (a -> b) -> a -> b
$ forall era. Era era => Proof era -> Redeemers era
validatingRedeemersWithMint Proof era
pf
        ]
    ]

validatingBodyWithMint ::
  (HasTokens era, EraTxBody era, Scriptic era, Value era ~ MaryValue) =>
  Proof era ->
  TxBody era
validatingBodyWithMint :: forall era.
(HasTokens era, EraTxBody era, Scriptic era,
 Value era ~ MaryValue) =>
Proof era -> TxBody era
validatingBodyWithMint Proof era
pf =
  forall era.
EraTxBody era =>
Proof era -> [TxBodyField era] -> TxBody era
newTxBody
    Proof era
pf
    [ forall era. [TxIn] -> TxBodyField era
Inputs' [HasCallStack => Integer -> TxIn
mkGenesisTxIn Integer
7]
    , forall era. [TxIn] -> TxBodyField era
Collateral' [HasCallStack => Integer -> TxIn
mkGenesisTxIn Integer
17]
    , forall era. [TxOut era] -> TxBodyField era
Outputs' [forall era.
(HasTokens era, Scriptic era, Value era ~ MaryValue) =>
Proof era -> TxOut era
validatingTxWithMintOut Proof era
pf]
    , forall era. Coin -> TxBodyField era
Txfee (Integer -> Coin
Coin Integer
5)
    , forall era. MultiAsset -> TxBodyField era
Mint (forall era.
(Scriptic era, HasTokens era) =>
Proof era -> MultiAsset
multiAsset Proof era
pf)
    , forall era. StrictMaybe ScriptIntegrityHash -> TxBodyField era
WppHash (forall era.
Proof era
-> PParams era
-> [Language]
-> Redeemers era
-> TxDats era
-> StrictMaybe ScriptIntegrityHash
newScriptIntegrityHash Proof era
pf (forall era. EraPParams era => Proof era -> PParams era
pp Proof era
pf) [Language
PlutusV1] (forall era. Era era => Proof era -> Redeemers era
validatingRedeemersWithMint Proof era
pf) forall a. Monoid a => a
mempty)
    ]

validatingRedeemersWithMint :: Era era => Proof era -> Redeemers era
validatingRedeemersWithMint :: forall era. Era era => Proof era -> Redeemers era
validatingRedeemersWithMint Proof era
pf = forall era.
Proof era -> PlutusPurposeTag -> Data era -> Redeemers era
mkSingleRedeemer Proof era
pf PlutusPurposeTag
Minting (forall era. Era era => Data -> Data era
Data (Integer -> Data
PV1.I Integer
42))

multiAsset :: forall era. (Scriptic era, HasTokens era) => Proof era -> MultiAsset
multiAsset :: forall era.
(Scriptic era, HasTokens era) =>
Proof era -> MultiAsset
multiAsset Proof era
pf = forall era. HasTokens era => Integer -> Script era -> MultiAsset
forge @era Integer
1 (forall era. Scriptic era => Natural -> Proof era -> Script era
always Natural
2 Proof era
pf)

validatingTxWithMintOut ::
  forall era.
  ( HasTokens era
  , Scriptic era
  , Value era ~ MaryValue
  ) =>
  Proof era ->
  TxOut era
validatingTxWithMintOut :: forall era.
(HasTokens era, Scriptic era, Value era ~ MaryValue) =>
Proof era -> TxOut era
validatingTxWithMintOut Proof era
pf =
  forall era. Proof era -> [TxOutField era] -> TxOut era
newTxOut Proof era
pf [forall era. Addr -> TxOutField era
Address (forall era. Proof era -> Addr
someAddr Proof era
pf), forall era. Value era -> TxOutField era
Amount (Coin -> MultiAsset -> MaryValue
MaryValue (Integer -> Coin
Coin Integer
995) (forall era.
(Scriptic era, HasTokens era) =>
Proof era -> MultiAsset
multiAsset Proof era
pf))]

notValidatingTxWithMint ::
  forall era.
  ( Scriptic era
  , HasTokens era
  , EraTx era
  , Value era ~ MaryValue
  ) =>
  Proof era ->
  Tx era
notValidatingTxWithMint :: forall era.
(Scriptic era, HasTokens era, EraTx era, Value era ~ MaryValue) =>
Proof era -> Tx era
notValidatingTxWithMint Proof era
pf =
  forall era. Proof era -> [TxField era] -> Tx era
newTx
    Proof era
pf
    [ forall era. TxBody era -> TxField era
Body TxBody era
notValidatingBodyWithMint
    , forall era. [WitnessesField era] -> TxField era
WitnessesI
        [ forall era. Era era => [WitVKey 'Witness] -> WitnessesField era
AddrWits' [forall (kr :: KeyRole).
SafeHash EraIndependentTxBody -> KeyPair kr -> WitVKey 'Witness
mkWitnessVKey (forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated TxBody era
notValidatingBodyWithMint) (forall era. Proof era -> KeyPair 'Payment
someKeys Proof era
pf)]
        , forall era. EraScript era => [Script era] -> WitnessesField era
ScriptWits' [forall era. Scriptic era => Natural -> Proof era -> Script era
never Natural
1 Proof era
pf]
        , forall era. Redeemers era -> WitnessesField era
RdmrWits Redeemers era
notValidatingRedeemersWithMint
        ]
    ]
  where
    notValidatingBodyWithMint :: TxBody era
notValidatingBodyWithMint =
      forall era.
EraTxBody era =>
Proof era -> [TxBodyField era] -> TxBody era
newTxBody
        Proof era
pf
        [ forall era. [TxIn] -> TxBodyField era
Inputs' [HasCallStack => Integer -> TxIn
mkGenesisTxIn Integer
8]
        , forall era. [TxIn] -> TxBodyField era
Collateral' [HasCallStack => Integer -> TxIn
mkGenesisTxIn Integer
18]
        , forall era. [TxOut era] -> TxBodyField era
Outputs' [forall era. Proof era -> [TxOutField era] -> TxOut era
newTxOut Proof era
pf [forall era. Addr -> TxOutField era
Address (forall era. Proof era -> Addr
someAddr Proof era
pf), forall era. Value era -> TxOutField era
Amount (Coin -> MultiAsset -> MaryValue
MaryValue (Integer -> Coin
Coin Integer
995) MultiAsset
ma)]]
        , forall era. Coin -> TxBodyField era
Txfee (Integer -> Coin
Coin Integer
5)
        , forall era. MultiAsset -> TxBodyField era
Mint MultiAsset
ma
        , forall era. StrictMaybe ScriptIntegrityHash -> TxBodyField era
WppHash (forall era.
Proof era
-> PParams era
-> [Language]
-> Redeemers era
-> TxDats era
-> StrictMaybe ScriptIntegrityHash
newScriptIntegrityHash Proof era
pf (forall era. EraPParams era => Proof era -> PParams era
pp Proof era
pf) [Language
PlutusV1] Redeemers era
notValidatingRedeemersWithMint forall a. Monoid a => a
mempty)
        ]
    notValidatingRedeemersWithMint :: Redeemers era
notValidatingRedeemersWithMint = forall era.
Proof era -> PlutusPurposeTag -> Data era -> Redeemers era
mkSingleRedeemer Proof era
pf PlutusPurposeTag
Minting (forall era. Era era => Data -> Data era
Data (Integer -> Data
PV1.I Integer
0))
    ma :: MultiAsset
ma = forall era. HasTokens era => Integer -> Script era -> MultiAsset
forge @era Integer
1 (forall era. Scriptic era => Natural -> Proof era -> Script era
never Natural
1 Proof era
pf)

poolMDHTooBigTx ::
  forall era.
  ( Scriptic era
  , EraTxBody era
  ) =>
  Proof era ->
  Tx era
poolMDHTooBigTx :: forall era. (Scriptic era, EraTxBody era) => Proof era -> Tx era
poolMDHTooBigTx Proof era
pf =
  -- Note that the UTXOW rule will no trigger the expected predicate failure,
  -- since it is checked in the POOL rule. BBODY will trigger it, however.
  forall era. Proof era -> [TxField era] -> Tx era
newTx
    Proof era
pf
    [ forall era. TxBody era -> TxField era
Body TxBody era
poolMDHTooBigTxBody
    , forall era. [WitnessesField era] -> TxField era
WitnessesI
        [ forall era. Era era => [WitVKey 'Witness] -> WitnessesField era
AddrWits' [forall (kr :: KeyRole).
SafeHash EraIndependentTxBody -> KeyPair kr -> WitVKey 'Witness
mkWitnessVKey (forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated TxBody era
poolMDHTooBigTxBody) (forall era. Proof era -> KeyPair 'Payment
someKeys Proof era
pf)]
        ]
    ]
  where
    poolMDHTooBigTxBody :: TxBody era
poolMDHTooBigTxBody =
      forall era.
EraTxBody era =>
Proof era -> [TxBodyField era] -> TxBody era
newTxBody
        Proof era
pf
        [ forall era. [TxIn] -> TxBodyField era
Inputs' [HasCallStack => Integer -> TxIn
mkGenesisTxIn Integer
3]
        , forall era. [TxOut era] -> TxBodyField era
Outputs' [forall era. Proof era -> [TxOutField era] -> TxOut era
newTxOut Proof era
pf [forall era. Addr -> TxOutField era
Address forall a b. (a -> b) -> a -> b
$ forall era. Proof era -> Addr
someAddr Proof era
pf, forall era. Value era -> TxOutField era
Amount (forall t s. Inject t s => t -> s
inject forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
995 forall t. Val t => t -> t -> t
<-> Coin
poolDeposit)]]
        , forall era. [TxCert era] -> TxBodyField era
Certs' [forall era. EraTxCert era => PoolParams -> TxCert era
RegPoolTxCert PoolParams
poolParams]
        , forall era. Coin -> TxBodyField era
Txfee (Integer -> Coin
Coin Integer
5)
        ]
      where
        tooManyBytes :: ByteString
tooManyBytes = Int -> Word8 -> ByteString
BS.replicate (Int
hashsize forall a. Num a => a -> a -> a
+ Int
1) Word8
0
        poolParams :: PoolParams
poolParams =
          PoolParams
            { ppId :: KeyHash 'StakePool
ppId = forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey forall a b. (a -> b) -> a -> b
$ forall era. Proof era -> KeyPair 'Payment
someKeys Proof era
pf
            , ppVrf :: VRFVerKeyHash 'StakePoolVRF
ppVrf =
                forall c (r :: KeyRoleVRF).
Crypto c =>
VerKeyVRF (VRF c) -> VRFVerKeyHash r
hashVerKeyVRF @MockCrypto forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. VRFKeyPair c -> VerKeyVRF (VRF c)
vrfVerKey @MockCrypto forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. Crypto c => RawSeed -> VRFKeyPair c
mkVRFKeyPair @MockCrypto forall a b. (a -> b) -> a -> b
$
                  Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> RawSeed
RawSeed Word64
0 Word64
0 Word64
0 Word64
0 Word64
0
            , ppPledge :: Coin
ppPledge = Integer -> Coin
Coin Integer
0
            , ppCost :: Coin
ppCost = Integer -> Coin
Coin Integer
0
            , ppMargin :: UnitInterval
ppMargin = forall a. Bounded a => a
minBound
            , ppRewardAccount :: RewardAccount
ppRewardAccount = Network -> StakeCredential -> RewardAccount
RewardAccount Network
Testnet (forall era. Scriptic era => Proof era -> StakeCredential
scriptStakeCredSuceed Proof era
pf)
            , ppOwners :: Set (KeyHash 'Staking)
ppOwners = forall a. Monoid a => a
mempty
            , ppRelays :: StrictSeq StakePoolRelay
ppRelays = forall a. Monoid a => a
mempty
            , ppMetadata :: StrictMaybe PoolMetadata
ppMetadata = forall a. a -> StrictMaybe a
SJust forall a b. (a -> b) -> a -> b
$ Url -> ByteString -> PoolMetadata
PoolMetadata (forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadFail m => Int -> Text -> m Url
textToUrl Int
64 Text
"") ByteString
tooManyBytes
            }

-- ============================== Expected UTXO  ===============================

testBBodyState ::
  forall era.
  ( HasTokens era
  , PostShelley era
  , EraTxBody era
  , Value era ~ MaryValue
  , EraGov era
  , State (EraRule "LEDGERS" era) ~ LedgerState era
  , ShelleyEraTxCert era
  ) =>
  Proof era ->
  ShelleyBbodyState era
testBBodyState :: forall era.
(HasTokens era, PostShelley era, EraTxBody era,
 Value era ~ MaryValue, EraGov era,
 State (EraRule "LEDGERS" era) ~ LedgerState era,
 ShelleyEraTxCert era) =>
Proof era -> ShelleyBbodyState era
testBBodyState Proof era
pf =
  let utxo :: UTxO era
utxo =
        forall era. Map TxIn (TxOut era) -> UTxO era
UTxO forall a b. (a -> b) -> a -> b
$
          forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
            [ (TxId -> TxIx -> TxIn
TxIn (forall era. EraTxBody era => TxBody era -> TxId
txIdTxBody (forall era.
(Scriptic era, EraTxBody era) =>
Proof era -> TxBody era
validatingBody Proof era
pf)) forall a. Bounded a => a
minBound, forall era. EraTxOut era => Proof era -> TxOut era
validatingTxOut Proof era
pf)
            , (TxId -> TxIx -> TxIn
TxIn (forall era. EraTxBody era => TxBody era -> TxId
txIdTxBody (forall era.
(Scriptic era, EraTxBody era, ShelleyEraTxCert era) =>
Proof era -> TxBody era
validatingBodyWithCert Proof era
pf)) forall a. Bounded a => a
minBound, forall era. EraTxOut era => Proof era -> TxOut era
validatingTxWithCertOut Proof era
pf)
            , (TxId -> TxIx -> TxIn
TxIn (forall era. EraTxBody era => TxBody era -> TxId
txIdTxBody (forall era.
(EraTxBody era, Scriptic era) =>
Proof era -> TxBody era
validatingBodyWithWithdrawal Proof era
pf)) forall a. Bounded a => a
minBound, forall era. EraTxOut era => Proof era -> TxOut era
validatingTxWithWithdrawalOut Proof era
pf)
            , (TxId -> TxIx -> TxIn
TxIn (forall era. EraTxBody era => TxBody era -> TxId
txIdTxBody (forall era.
(HasTokens era, EraTxBody era, Scriptic era,
 Value era ~ MaryValue) =>
Proof era -> TxBody era
validatingBodyWithMint Proof era
pf)) forall a. Bounded a => a
minBound, forall era.
(HasTokens era, Scriptic era, Value era ~ MaryValue) =>
Proof era -> TxOut era
validatingTxWithMintOut Proof era
pf)
            , (HasCallStack => Integer -> TxIn
mkGenesisTxIn Integer
11, forall era. Proof era -> [TxOutField era] -> TxOut era
newTxOut Proof era
pf [forall era. Addr -> TxOutField era
Address forall a b. (a -> b) -> a -> b
$ forall era. Proof era -> Addr
someAddr Proof era
pf, forall era. Value era -> TxOutField era
Amount (forall t s. Inject t s => t -> s
inject forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
5)])
            , (HasCallStack => Integer -> TxIn
mkGenesisTxIn Integer
2, TxOut era
alwaysFailsOutput)
            , (HasCallStack => Integer -> TxIn
mkGenesisTxIn Integer
13, forall era. Proof era -> [TxOutField era] -> TxOut era
newTxOut Proof era
pf [forall era. Addr -> TxOutField era
Address forall a b. (a -> b) -> a -> b
$ forall era. Proof era -> Addr
someAddr Proof era
pf, forall era. Value era -> TxOutField era
Amount (forall t s. Inject t s => t -> s
inject forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
5)])
            , (HasCallStack => Integer -> TxIn
mkGenesisTxIn Integer
4, forall era. Proof era -> [TxOutField era] -> TxOut era
newTxOut Proof era
pf [forall era. Addr -> TxOutField era
Address forall a b. (a -> b) -> a -> b
$ forall era. Proof era -> Addr
someAddr Proof era
pf, forall era. Value era -> TxOutField era
Amount (forall t s. Inject t s => t -> s
inject forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
1000)])
            , (HasCallStack => Integer -> TxIn
mkGenesisTxIn Integer
15, forall era. Proof era -> [TxOutField era] -> TxOut era
newTxOut Proof era
pf [forall era. Addr -> TxOutField era
Address forall a b. (a -> b) -> a -> b
$ forall era. Proof era -> Addr
someAddr Proof era
pf, forall era. Value era -> TxOutField era
Amount (forall t s. Inject t s => t -> s
inject forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
5)])
            , (HasCallStack => Integer -> TxIn
mkGenesisTxIn Integer
6, forall era. Proof era -> [TxOutField era] -> TxOut era
newTxOut Proof era
pf [forall era. Addr -> TxOutField era
Address forall a b. (a -> b) -> a -> b
$ forall era. Proof era -> Addr
someAddr Proof era
pf, forall era. Value era -> TxOutField era
Amount (forall t s. Inject t s => t -> s
inject forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
1000)])
            , (HasCallStack => Integer -> TxIn
mkGenesisTxIn Integer
17, forall era. Proof era -> [TxOutField era] -> TxOut era
newTxOut Proof era
pf [forall era. Addr -> TxOutField era
Address forall a b. (a -> b) -> a -> b
$ forall era. Proof era -> Addr
someAddr Proof era
pf, forall era. Value era -> TxOutField era
Amount (forall t s. Inject t s => t -> s
inject forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
5)])
            , (HasCallStack => Integer -> TxIn
mkGenesisTxIn Integer
8, forall era. Proof era -> [TxOutField era] -> TxOut era
newTxOut Proof era
pf [forall era. Addr -> TxOutField era
Address forall a b. (a -> b) -> a -> b
$ forall era. Proof era -> Addr
someAddr Proof era
pf, forall era. Value era -> TxOutField era
Amount (forall t s. Inject t s => t -> s
inject forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
1000)])
            , (HasCallStack => Integer -> TxIn
mkGenesisTxIn Integer
100, TxOut era
timelockOut)
            , (HasCallStack => Integer -> TxIn
mkGenesisTxIn Integer
101, TxOut era
unspendableOut)
            , (HasCallStack => Integer -> TxIn
mkGenesisTxIn Integer
102, TxOut era
alwaysSucceedsOutputV1)
            , (HasCallStack => Integer -> TxIn
mkGenesisTxIn Integer
103, TxOut era
nonScriptOutWithDatum)
            ]
      alwaysFailsOutput :: TxOut era
alwaysFailsOutput =
        forall era. Proof era -> [TxOutField era] -> TxOut era
newTxOut
          Proof era
pf
          [ forall era. Addr -> TxOutField era
Address (forall era. Scriptic era => Script era -> Addr
someScriptAddr (forall era. Scriptic era => Natural -> Proof era -> Script era
never Natural
0 Proof era
pf))
          , forall era. Value era -> TxOutField era
Amount (forall t s. Inject t s => t -> s
inject forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
3000)
          , forall era. [DataHash] -> TxOutField era
DHash' [forall era. Data era -> DataHash
hashData forall a b. (a -> b) -> a -> b
$ forall era. Era era => Data era
anotherDatum @era]
          ]
      timelockOut :: TxOut era
timelockOut = forall era. Proof era -> [TxOutField era] -> TxOut era
newTxOut Proof era
pf [forall era. Addr -> TxOutField era
Address forall a b. (a -> b) -> a -> b
$ Addr
timelockAddr, forall era. Value era -> TxOutField era
Amount (forall t s. Inject t s => t -> s
inject forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
1)]
      timelockAddr :: Addr
timelockAddr = Network -> PaymentCredential -> StakeReference -> Addr
Addr Network
Testnet PaymentCredential
pCred StakeReference
sCred
        where
          (SignKeyDSIGN DSIGN
_ssk, VKey kd
svk) = forall (kd :: KeyRole). RawSeed -> (SignKeyDSIGN DSIGN, VKey kd)
mkKeyPair (Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> RawSeed
RawSeed Word64
0 Word64
0 Word64
0 Word64
0 Word64
2)
          pCred :: PaymentCredential
pCred = forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
timelockHash
          sCred :: StakeReference
sCred = StakeCredential -> StakeReference
StakeRefBase forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey forall a b. (a -> b) -> a -> b
$ forall {kd :: KeyRole}. VKey kd
svk
          timelockHash :: ScriptHash
timelockHash = forall era. EraScript era => Script era -> ScriptHash
hashScript @era forall a b. (a -> b) -> a -> b
$ forall era. EraScript era => NativeScript era -> Script era
fromNativeScript forall a b. (a -> b) -> a -> b
$ forall era.
Scriptic era =>
[Proof era -> NativeScript era] -> Proof era -> NativeScript era
allOf [forall era. Scriptic era => Int -> Proof era -> NativeScript era
matchkey Int
1, forall era. PostShelley era => Int -> Proof era -> NativeScript era
after Int
100] Proof era
pf
      -- This output is unspendable since it is locked by a plutus script,
      -- but has no datum hash.
      unspendableOut :: TxOut era
unspendableOut =
        forall era. Proof era -> [TxOutField era] -> TxOut era
newTxOut
          Proof era
pf
          [ forall era. Addr -> TxOutField era
Address (forall era. Scriptic era => Script era -> Addr
someScriptAddr (forall era. Scriptic era => Natural -> Proof era -> Script era
always Natural
3 Proof era
pf))
          , forall era. Value era -> TxOutField era
Amount (forall t s. Inject t s => t -> s
inject forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
5000)
          ]
      alwaysSucceedsOutputV1 :: TxOut era
alwaysSucceedsOutputV1 =
        forall era. Proof era -> [TxOutField era] -> TxOut era
newTxOut
          Proof era
pf
          [ forall era. Addr -> TxOutField era
Address (forall era. Scriptic era => Script era -> Addr
someScriptAddr (forall era. Scriptic era => Natural -> Proof era -> Script era
always Natural
3 Proof era
pf))
          , forall era. Value era -> TxOutField era
Amount (forall t s. Inject t s => t -> s
inject forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
5000)
          , forall era. [DataHash] -> TxOutField era
DHash' [forall era. Data era -> DataHash
hashData forall a b. (a -> b) -> a -> b
$ forall era. Era era => Data era
someDatum @era]
          ]
      nonScriptOutWithDatum :: TxOut era
nonScriptOutWithDatum =
        forall era. Proof era -> [TxOutField era] -> TxOut era
newTxOut
          Proof era
pf
          [ forall era. Addr -> TxOutField era
Address (forall era. Proof era -> Addr
someAddr Proof era
pf)
          , forall era. Value era -> TxOutField era
Amount (forall t s. Inject t s => t -> s
inject forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
1221)
          , forall era. [DataHash] -> TxOutField era
DHash' [forall era. Data era -> DataHash
hashData forall a b. (a -> b) -> a -> b
$ forall era. Era era => Data era
someDatum @era]
          ]
      poolID :: KeyHash kd
poolID = forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole forall a b. (a -> b) -> a -> b
$ KeyPair 'BlockIssuer
coldKeys
      example1UtxoSt :: UTxOState era
example1UtxoSt =
        forall era.
EraTxOut era =>
PParams era
-> UTxO era
-> Coin
-> Coin
-> GovState era
-> Coin
-> UTxOState era
smartUTxOState (forall era. EraPParams era => Proof era -> PParams era
pp Proof era
pf) UTxO era
utxo Coin
totalDeposits (Integer -> Coin
Coin Integer
40) forall a. Default a => a
def forall a. Monoid a => a
mempty
      -- the default CertState 'def' means that the 'totalDeposits' must be 0
      totalDeposits :: Coin
totalDeposits = Integer -> Coin
Coin Integer
0
   in forall era.
State (EraRule "LEDGERS" era)
-> BlocksMade -> ShelleyBbodyState era
BbodyState
        (forall era. UTxOState era -> CertState era -> LedgerState era
LedgerState UTxOState era
example1UtxoSt forall a. Default a => a
def)
        (Map (KeyHash 'StakePool) Natural -> BlocksMade
BlocksMade forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton forall {kd :: KeyRole}. KeyHash kd
poolID Natural
1)

-- ============================== Helper functions ===============================

makeTooBig :: Proof era -> PredicateFailure (EraRule "BBODY" era)
makeTooBig :: forall era. Proof era -> PredicateFailure (EraRule "BBODY" era)
makeTooBig proof :: Proof era
proof@Proof era
Alonzo =
  forall era.
ShelleyBbodyPredFailure era -> AlonzoBbodyPredFailure era
ShelleyInAlonzoBbodyPredFailure
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
PredicateFailure (EraRule "LEDGERS" era)
-> ShelleyBbodyPredFailure era
LedgersFailure
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
PredicateFailure (EraRule "LEDGER" era)
-> ShelleyLedgersPredFailure era
LedgerFailure
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
PredicateFailure (EraRule "DELEGS" era)
-> ShelleyLedgerPredFailure era
DelegsFailure
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
PredicateFailure (EraRule "DELPL" era)
-> ShelleyDelegsPredFailure era
DelplFailure
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
PredicateFailure (EraRule "POOL" era)
-> ShelleyDelplPredFailure era
PoolFailure
    forall a b. (a -> b) -> a -> b
$ forall era. KeyHash 'StakePool -> Int -> ShelleyPoolPredFailure era
PoolMedataHashTooBig (forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey forall a b. (a -> b) -> a -> b
$ forall era. Proof era -> KeyPair 'Payment
someKeys Proof era
proof) (Int
hashsize forall a. Num a => a -> a -> a
+ Int
1)
makeTooBig proof :: Proof era
proof@Proof era
Babbage =
  forall era.
ShelleyBbodyPredFailure era -> AlonzoBbodyPredFailure era
ShelleyInAlonzoBbodyPredFailure
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
PredicateFailure (EraRule "LEDGERS" era)
-> ShelleyBbodyPredFailure era
LedgersFailure
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
PredicateFailure (EraRule "LEDGER" era)
-> ShelleyLedgersPredFailure era
LedgerFailure
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
PredicateFailure (EraRule "DELEGS" era)
-> ShelleyLedgerPredFailure era
DelegsFailure
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
PredicateFailure (EraRule "DELPL" era)
-> ShelleyDelegsPredFailure era
DelplFailure
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
PredicateFailure (EraRule "POOL" era)
-> ShelleyDelplPredFailure era
PoolFailure
    forall a b. (a -> b) -> a -> b
$ forall era. KeyHash 'StakePool -> Int -> ShelleyPoolPredFailure era
PoolMedataHashTooBig (forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey forall a b. (a -> b) -> a -> b
$ forall era. Proof era -> KeyPair 'Payment
someKeys Proof era
proof) (Int
hashsize forall a. Num a => a -> a -> a
+ Int
1)
makeTooBig proof :: Proof era
proof@Proof era
Conway =
  forall era.
PredicateFailure (EraRule "LEDGERS" era)
-> ConwayBbodyPredFailure era
Conway.LedgersFailure
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
PredicateFailure (EraRule "LEDGER" era)
-> ShelleyLedgersPredFailure era
LedgerFailure
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
PredicateFailure (EraRule "CERTS" era)
-> ConwayLedgerPredFailure era
ConwayCertsFailure
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
PredicateFailure (EraRule "CERT" era) -> ConwayCertsPredFailure era
CertFailure
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
PredicateFailure (EraRule "POOL" era) -> ConwayCertPredFailure era
Conway.PoolFailure
    forall a b. (a -> b) -> a -> b
$ forall era. KeyHash 'StakePool -> Int -> ShelleyPoolPredFailure era
PoolMedataHashTooBig (forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey forall a b. (a -> b) -> a -> b
$ forall era. Proof era -> KeyPair 'Payment
someKeys Proof era
proof) (Int
hashsize forall a. Num a => a -> a -> a
+ Int
1)
makeTooBig Proof era
proof = forall a. HasCallStack => TestName -> a
error (TestName
"makeTooBig does not work in era " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> TestName
show Proof era
proof)

coldKeys :: KeyPair 'BlockIssuer
coldKeys :: KeyPair 'BlockIssuer
coldKeys = forall (kd :: KeyRole). VKey kd -> SignKeyDSIGN DSIGN -> KeyPair kd
KeyPair forall {kd :: KeyRole}. VKey kd
vk SignKeyDSIGN DSIGN
sk
  where
    (SignKeyDSIGN DSIGN
sk, VKey kd
vk) = forall (kd :: KeyRole). RawSeed -> (SignKeyDSIGN DSIGN, VKey kd)
mkKeyPair (Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> RawSeed
RawSeed Word64
1 Word64
2 Word64
3 Word64
2 Word64
1)

makeNaiveBlock ::
  forall era. EraSegWits era => [Tx era] -> Block BHeaderView era
makeNaiveBlock :: forall era. EraSegWits era => [Tx era] -> Block BHeaderView era
makeNaiveBlock [Tx era]
txs = forall h era. h -> TxSeq era -> Block h era
UnsafeUnserialisedBlock BHeaderView
bhView TxSeq era
txSeq
  where
    bhView :: BHeaderView
bhView =
      BHeaderView
        { bhviewID :: KeyHash 'BlockIssuer
bhviewID = forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey (forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey KeyPair 'BlockIssuer
coldKeys)
        , bhviewBSize :: Word32
bhviewBSize = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall era. EraSegWits era => ProtVer -> TxSeq era -> Int
bBodySize (Version -> Natural -> ProtVer
ProtVer (forall era. Era era => Version
eraProtVerLow @era) Natural
0) TxSeq era
txSeq
        , bhviewHSize :: Int
bhviewHSize = Int
0
        , bhviewBHash :: Hash HASH EraIndependentBlockBody
bhviewBHash = forall era.
EraSegWits era =>
TxSeq era -> Hash HASH EraIndependentBlockBody
hashTxSeq TxSeq era
txSeq
        , bhviewSlot :: SlotNo
bhviewSlot = Word64 -> SlotNo
SlotNo Word64
0
        }
    txSeq :: TxSeq era
txSeq = forall era. EraSegWits era => StrictSeq (Tx era) -> TxSeq era
toTxSeq forall a b. (a -> b) -> a -> b
$ forall a. [a] -> StrictSeq a
StrictSeq.fromList [Tx era]
txs

scriptStakeCredFail :: forall era. Scriptic era => Proof era -> StakeCredential
scriptStakeCredFail :: forall era. Scriptic era => Proof era -> StakeCredential
scriptStakeCredFail Proof era
pf = forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj (forall era. Scriptic era => Natural -> Proof era -> ScriptHash
alwaysFailsHash Natural
1 Proof era
pf)

scriptStakeCredSuceed :: forall era. Scriptic era => Proof era -> StakeCredential
scriptStakeCredSuceed :: forall era. Scriptic era => Proof era -> StakeCredential
scriptStakeCredSuceed Proof era
pf = forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj (forall era. Scriptic era => Natural -> Proof era -> ScriptHash
alwaysSucceedsHash Natural
2 Proof era
pf)

-- | The deposit made when 'scriptStakeCredSuceed' was registered. It is also
--   The Refund when 'scriptStakeCredSuceed' is de-registered.
successDeposit :: UM.CompactForm Coin
successDeposit :: CompactForm Coin
successDeposit = Word64 -> CompactForm Coin
UM.CompactCoin Word64
7

hashsize :: Int
hashsize :: Int
hashsize = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall h (proxy :: * -> *). HashAlgorithm h => proxy h -> Word
sizeHash ([] @HASH)

-- ============================== PParams ===============================

defaultPPs :: [PParamsField era]
defaultPPs :: forall era. [PParamsField era]
defaultPPs =
  [ forall era. CostModels -> PParamsField era
Costmdls forall a b. (a -> b) -> a -> b
$ HasCallStack => [Language] -> CostModels
zeroTestingCostModels [Language
PlutusV1]
  , forall era. Natural -> PParamsField era
MaxValSize Natural
1000000000
  , forall era. ExUnits -> PParamsField era
MaxTxExUnits forall a b. (a -> b) -> a -> b
$ Natural -> Natural -> ExUnits
ExUnits Natural
1000000 Natural
1000000
  , forall era. ExUnits -> PParamsField era
MaxBlockExUnits forall a b. (a -> b) -> a -> b
$ Natural -> Natural -> ExUnits
ExUnits Natural
1000000 Natural
1000000
  , forall era. ProtVer -> PParamsField era
ProtocolVersion forall a b. (a -> b) -> a -> b
$ Version -> Natural -> ProtVer
ProtVer (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @5) Natural
0
  , forall era. Natural -> PParamsField era
CollateralPercentage Natural
100
  , forall era. Coin -> PParamsField era
KeyDeposit (Integer -> Coin
Coin Integer
2)
  , forall era. Coin -> PParamsField era
PoolDeposit Coin
poolDeposit
  ]

poolDeposit :: Coin
poolDeposit :: Coin
poolDeposit = Integer -> Coin
Coin Integer
5

pp :: EraPParams era => Proof era -> PParams era
pp :: forall era. EraPParams era => Proof era -> PParams era
pp Proof era
pf = forall era.
EraPParams era =>
Proof era -> [PParamsField era] -> PParams era
newPParams Proof era
pf forall era. [PParamsField era]
defaultPPs