{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Test.Cardano.Ledger.Generic.TxGen (
  genAlonzoTx,
  Box (..),
  applySTSByProof,
  assembleWits,
  coreTx,
  coreTxBody,
  coreTxOut,
  genUTxO,
)
where

import Cardano.Ledger.Allegra.Scripts (
  AllegraEraScript,
  Timelock (..),
  ValidityInterval (..),
  pattern RequireTimeExpire,
  pattern RequireTimeStart,
 )
import Cardano.Ledger.Alonzo.Scripts hiding (Script)
import Cardano.Ledger.Alonzo.Tx (IsValid (..))
import Cardano.Ledger.Alonzo.TxBody (AlonzoTxOut (..))
import Cardano.Ledger.Alonzo.TxWits (
  Redeemers (..),
  TxDats (..),
  unRedeemers,
 )
import Cardano.Ledger.Babbage.TxBody (BabbageTxOut (..))
import Cardano.Ledger.BaseTypes (EpochInterval (..), Network (..), mkTxIxPartial)
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Conway.TxCert (ConwayDelegCert (..), ConwayTxCert (..))
import Cardano.Ledger.Core
import Cardano.Ledger.Keys (coerceKeyRole)
import Cardano.Ledger.Plutus.Data (Data, Datum (..), dataToBinaryData, hashData)
import Cardano.Ledger.Shelley.API (
  Addr (..),
  Credential (..),
  PoolParams (..),
  RewardAccount (..),
  ShelleyDelegCert (..),
  StakeReference (..),
  Withdrawals (..),
 )
import Cardano.Ledger.Shelley.LedgerState (RewardAccounts)
import Cardano.Ledger.Shelley.Scripts (
  MultiSig,
  ShelleyEraScript,
  pattern RequireAllOf,
  pattern RequireAnyOf,
  pattern RequireMOf,
  pattern RequireSignature,
 )
import Cardano.Ledger.Shelley.TxCert (
  ShelleyTxCert (..),
  pattern DelegStakeTxCert,
  pattern RegTxCert,
  pattern UnRegTxCert,
 )
import Cardano.Ledger.Slot (EpochNo (EpochNo))
import Cardano.Ledger.TxIn (TxId (..), TxIn (..))
import Cardano.Ledger.UTxO (EraUTxO (..), UTxO (..))
import Cardano.Ledger.Val
import Cardano.Slotting.Slot (SlotNo (..))
import Control.Monad (forM, replicateM)
import Control.Monad.Trans.Class (MonadTrans (lift))
import Control.Monad.Trans.RWS.Strict (asks, get, gets, modify)
import Control.State.Transition.Extended hiding (Assertion)
import Data.Bifunctor (first)
import qualified Data.Foldable as F
import Data.Functor ((<&>))
import qualified Data.List as List
import Data.List.NonEmpty (NonEmpty)
import Data.Map (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (catMaybes)
import Data.Maybe.Strict (StrictMaybe (..))
import Data.Monoid (All (..))
import Data.Ratio ((%))
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Word (Word16)
import GHC.Stack
import Lens.Micro ((^.))
import Lens.Micro.Extras (view)
import Test.Cardano.Ledger.Alonzo.Serialisation.Generators ()
import Test.Cardano.Ledger.Babbage.Serialisation.Generators ()
import Test.Cardano.Ledger.Core.KeyPair (mkWitnessVKey)
import Test.Cardano.Ledger.Generic.Fields hiding (Mint)
import qualified Test.Cardano.Ledger.Generic.Fields as Generic (TxBodyField (Mint))
import Test.Cardano.Ledger.Generic.Functions
import Test.Cardano.Ledger.Generic.GenState (
  GenEnv (..),
  GenRS,
  GenSize (..),
  GenState (..),
  PlutusPurposeTag (..),
  elementsT,
  frequencyT,
  genCredential,
  genDatumWithHash,
  genFreshRegCred,
  genKeyHash,
  genNewPool,
  genPool,
  genPositiveVal,
  genRetirementHash,
  genRewards,
  genScript,
  genValidityInterval,
  getCertificateMax,
  getOldUtxoPercent,
  getRefInputsMax,
  getSpendInputsMax,
  getUtxoChoicesMax,
  getUtxoElem,
  getUtxoTest,
  mkRedeemers,
  mkRedeemersFromTags,
  modifyGenStateInitialRewards,
  modifyGenStateInitialUtxo,
  modifyModelCount,
  modifyModelIndex,
  modifyModelMutFee,
  modifyModelUTxO,
 )
import Test.Cardano.Ledger.Generic.ModelState (
  MUtxo,
  ModelNewEpochState (..),
  UtxoEntry,
 )
import Test.Cardano.Ledger.Generic.PrettyCore (PrettyA (..), ppRecord)
import Test.Cardano.Ledger.Generic.Proof hiding (lift)
import Test.Cardano.Ledger.Generic.Updaters hiding (first)
import Test.Cardano.Ledger.Shelley.Generator.Core (genNatural)
import Test.Cardano.Ledger.Shelley.Serialisation.EraIndepGenerators ()
import Test.Cardano.Ledger.Shelley.Utils (epochFromSlotNo, runShelleyBase)
import Test.QuickCheck

-- ===================================================
-- Assembing lists of Fields in to (XX era)

-- | This uses merging semantics, it expects duplicate fields, and merges them together
assembleWits :: Proof era -> [WitnessesField era] -> TxWits era
assembleWits :: forall era. Proof era -> [WitnessesField era] -> TxWits era
assembleWits Proof era
era = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (forall era.
Policy
-> Proof era -> TxWits era -> WitnessesField era -> TxWits era
updateWitnesses Policy
merge Proof era
era) (forall era. Proof era -> TxWits era
initialWitnesses Proof era
era)

coreTxOut :: Proof era -> [TxOutField era] -> TxOut era
coreTxOut :: forall era. Proof era -> [TxOutField era] -> TxOut era
coreTxOut Proof era
era = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (forall era. Proof era -> TxOut era -> TxOutField era -> TxOut era
updateTxOut Proof era
era) (forall era. Proof era -> TxOut era
initialTxOut Proof era
era)

coreTxBody :: EraTxBody era => Proof era -> [TxBodyField era] -> TxBody era
coreTxBody :: forall era.
EraTxBody era =>
Proof era -> [TxBodyField era] -> TxBody era
coreTxBody Proof era
era = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (forall era.
EraTxBody era =>
Proof era -> TxBody era -> TxBodyField era -> TxBody era
updateTxBody Proof era
era) (forall era. Proof era -> TxBody era
initialTxBody Proof era
era)

overrideTxBody :: EraTxBody era => Proof era -> TxBody era -> [TxBodyField era] -> TxBody era
overrideTxBody :: forall era.
EraTxBody era =>
Proof era -> TxBody era -> [TxBodyField era] -> TxBody era
overrideTxBody Proof era
era = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (forall era.
EraTxBody era =>
Proof era -> TxBody era -> TxBodyField era -> TxBody era
updateTxBody Proof era
era)

coreTx :: Proof era -> [TxField era] -> Tx era
coreTx :: forall era. Proof era -> [TxField era] -> Tx era
coreTx Proof era
era = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (forall era. Proof era -> Tx era -> TxField era -> Tx era
updateTx Proof era
era) (forall era. Proof era -> Tx era
initialTx Proof era
era)

-- ====================================================================

lookupByKeyM ::
  (Ord k, Show k, HasCallStack) => String -> k -> (GenState era -> Map.Map k v) -> GenRS era v
lookupByKeyM :: forall k era v.
(Ord k, Show k, HasCallStack) =>
String -> k -> (GenState era -> Map k v) -> GenRS era v
lookupByKeyM String
name k
k GenState era -> Map k v
getMap = do
  Map k v
m <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets GenState era -> Map k v
getMap
  case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
k Map k v
m of
    Maybe v
Nothing ->
      forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$
        String
"Can't find " forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
" in the test enviroment: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show k
k
    Just v
val -> forall (f :: * -> *) a. Applicative f => a -> f a
pure v
val

-- | Generate a list of specified length with randomish `ExUnit`s where the sum
--   of all values produced will not exceed the maxTxExUnits.
genExUnits :: Proof era -> Int -> GenRS era [ExUnits]
genExUnits :: forall era. Proof era -> Int -> GenRS era [ExUnits]
genExUnits Proof era
era Int
n = do
  GenEnv {PParams era
gePParams :: forall era. GenEnv era -> PParams era
gePParams :: PParams era
gePParams} <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets forall era. GenState era -> GenEnv era
gsGenEnv
  let ExUnits Natural
maxMemUnits Natural
maxStepUnits = forall era. Proof era -> PParams era -> ExUnits
maxTxExUnits' Proof era
era PParams era
gePParams
  [Natural]
memUnits <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Natural -> Gen [Natural]
genSequenceSum Natural
maxMemUnits
  [Natural]
stepUnits <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Natural -> Gen [Natural]
genSequenceSum Natural
maxStepUnits
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Natural -> Natural -> ExUnits
ExUnits [Natural]
memUnits [Natural]
stepUnits
  where
    un :: Natural
un = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n
    genUpTo :: Natural -> (Natural, [Natural]) -> Int -> Gen (Natural, [Natural])
genUpTo Natural
maxVal (!Natural
totalLeft, ![Natural]
acc) Int
_
      | Natural
totalLeft forall a. Eq a => a -> a -> Bool
== Natural
0 = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Natural
0, Natural
0 forall a. a -> [a] -> [a]
: [Natural]
acc)
      | Bool
otherwise = do
          Natural
x <- forall a. Ord a => a -> a -> a
min Natural
totalLeft forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (RealFrac a, Integral b) => a -> b
round forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Integral a => a -> a -> Ratio a
% Natural
un) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Natural -> Natural -> Gen Natural
genNatural Natural
0 Natural
maxVal
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (Natural
totalLeft forall a. Num a => a -> a -> a
- Natural
x, Natural
x forall a. a -> [a] -> [a]
: [Natural]
acc)
    genSequenceSum :: Natural -> Gen [Natural]
genSequenceSum Natural
maxVal
      | Natural
maxVal forall a. Eq a => a -> a -> Bool
== Natural
0 = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate Int
n Natural
0
      | Bool
otherwise = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
F.foldlM (Natural -> (Natural, [Natural]) -> Int -> Gen (Natural, [Natural])
genUpTo Natural
maxVal) (Natural
maxVal, []) [Int
1 .. Int
n]

lookupScript ::
  forall era.
  ScriptHash ->
  Maybe PlutusPurposeTag ->
  GenRS era (Maybe (Script era))
lookupScript :: forall era.
ScriptHash
-> Maybe PlutusPurposeTag -> GenRS era (Maybe (Script era))
lookupScript ScriptHash
scriptHash Maybe PlutusPurposeTag
mTag = do
  Map ScriptHash (Script era)
m <- forall era. GenState era -> Map ScriptHash (Script era)
gsScripts forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m s
get
  case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScriptHash
scriptHash Map ScriptHash (Script era)
m of
    Just Script era
script -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Script era
script
    Maybe (Script era)
Nothing
      | Just PlutusPurposeTag
tag <- Maybe PlutusPurposeTag
mTag ->
          forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k era v.
(Ord k, Show k, HasCallStack) =>
String -> k -> (GenState era -> Map k v) -> GenRS era v
lookupByKeyM String
"plutusScript" (ScriptHash
scriptHash, PlutusPurposeTag
tag) forall era.
GenState era
-> Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era)
gsPlutusScripts
    Maybe (Script era)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

-- =====================================

genGenericScriptWitness ::
  Reflect era =>
  Proof era ->
  Maybe PlutusPurposeTag ->
  Script era ->
  GenRS era (SafeHash EraIndependentTxBody -> [WitnessesField era])
genGenericScriptWitness :: forall era.
Reflect era =>
Proof era
-> Maybe PlutusPurposeTag
-> Script era
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
genGenericScriptWitness Proof era
proof Maybe PlutusPurposeTag
mTag Script era
script =
  case Proof era
proof of
    Proof era
Shelley -> forall era.
(ShelleyEraScript era, NativeScript era ~ MultiSig era,
 Reflect era) =>
Proof era
-> Maybe PlutusPurposeTag
-> MultiSig era
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
mkMultiSigWit Proof era
proof Maybe PlutusPurposeTag
mTag Script era
script
    Proof era
Allegra -> forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era,
 Reflect era) =>
Proof era
-> Maybe PlutusPurposeTag
-> Timelock era
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
mkTimelockWit Proof era
proof Maybe PlutusPurposeTag
mTag Script era
script
    Proof era
Mary -> forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era,
 Reflect era) =>
Proof era
-> Maybe PlutusPurposeTag
-> Timelock era
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
mkTimelockWit Proof era
proof Maybe PlutusPurposeTag
mTag Script era
script
    Proof era
Alonzo -> case Script era
script of
      TimelockScript Timelock era
timelock -> forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era,
 Reflect era) =>
Proof era
-> Maybe PlutusPurposeTag
-> Timelock era
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
mkTimelockWit Proof era
proof Maybe PlutusPurposeTag
mTag Timelock era
timelock
      PlutusScript PlutusScript AlonzoEra
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> b -> a
const [])
    Proof era
Babbage -> case Script era
script of
      TimelockScript Timelock era
timelock -> forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era,
 Reflect era) =>
Proof era
-> Maybe PlutusPurposeTag
-> Timelock era
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
mkTimelockWit Proof era
proof Maybe PlutusPurposeTag
mTag Timelock era
timelock
      PlutusScript PlutusScript BabbageEra
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> b -> a
const [])
    Proof era
Conway -> case Script era
script of
      TimelockScript Timelock era
timelock -> forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era,
 Reflect era) =>
Proof era
-> Maybe PlutusPurposeTag
-> Timelock era
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
mkTimelockWit Proof era
proof Maybe PlutusPurposeTag
mTag Timelock era
timelock
      PlutusScript PlutusScript ConwayEra
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> b -> a
const [])

-- | Generate a TxWits producing function. We handle TxWits come from Keys and Scripts
--   Because scripts vary be Era, we need some Era specific code here: genGenericScriptWitness
mkWitVKey ::
  forall era kr.
  Reflect era =>
  Proof era ->
  Maybe PlutusPurposeTag ->
  Credential kr ->
  GenRS era (SafeHash EraIndependentTxBody -> [WitnessesField era])
mkWitVKey :: forall era (kr :: KeyRole).
Reflect era =>
Proof era
-> Maybe PlutusPurposeTag
-> Credential kr
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
mkWitVKey Proof era
_ Maybe PlutusPurposeTag
_mTag (KeyHashObj KeyHash kr
keyHash) = do
  KeyPair 'Witness
keyPair <- forall k era v.
(Ord k, Show k, HasCallStack) =>
String -> k -> (GenState era -> Map k v) -> GenRS era v
lookupByKeyM String
"credential" (forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole KeyHash kr
keyHash) forall era.
GenState era -> Map (KeyHash 'Witness) (KeyPair 'Witness)
gsKeys
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ \SafeHash EraIndependentTxBody
bodyHash -> [forall era. Era era => [WitVKey 'Witness] -> WitnessesField era
AddrWits' [forall (kr :: KeyRole).
SafeHash EraIndependentTxBody -> KeyPair kr -> WitVKey 'Witness
mkWitnessVKey SafeHash EraIndependentTxBody
bodyHash KeyPair 'Witness
keyPair]]
mkWitVKey Proof era
era Maybe PlutusPurposeTag
mTag (ScriptHashObj ScriptHash
scriptHash) =
  forall era.
ScriptHash
-> Maybe PlutusPurposeTag -> GenRS era (Maybe (Script era))
lookupScript @era ScriptHash
scriptHash Maybe PlutusPurposeTag
mTag forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe (Script era)
Nothing ->
      forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Impossible: Cannot find script with hash " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ScriptHash
scriptHash
    Just Script era
script -> do
      let scriptWit :: WitnessesField era
scriptWit = forall era. EraScript era => [Script era] -> WitnessesField era
ScriptWits' [Script era
script]
      SafeHash EraIndependentTxBody -> [WitnessesField era]
otherWit <- forall era.
Reflect era =>
Proof era
-> Maybe PlutusPurposeTag
-> Script era
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
genGenericScriptWitness Proof era
era Maybe PlutusPurposeTag
mTag Script era
script
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (\SafeHash EraIndependentTxBody
hash -> WitnessesField era
scriptWit forall a. a -> [a] -> [a]
: SafeHash EraIndependentTxBody -> [WitnessesField era]
otherWit SafeHash EraIndependentTxBody
hash)

-- ========================================================================
-- Generating TxWits, here we are not adding anything to the GenState
-- only looking up things already added, and assembling the right pieces to
-- make TxWits.

-- | Used in Shelley Eras
mkMultiSigWit ::
  forall era.
  (ShelleyEraScript era, NativeScript era ~ MultiSig era, Reflect era) =>
  Proof era ->
  Maybe PlutusPurposeTag ->
  MultiSig era ->
  GenRS era (SafeHash EraIndependentTxBody -> [WitnessesField era])
mkMultiSigWit :: forall era.
(ShelleyEraScript era, NativeScript era ~ MultiSig era,
 Reflect era) =>
Proof era
-> Maybe PlutusPurposeTag
-> MultiSig era
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
mkMultiSigWit Proof era
era Maybe PlutusPurposeTag
mTag (RequireSignature KeyHash 'Witness
keyHash) = forall era (kr :: KeyRole).
Reflect era =>
Proof era
-> Maybe PlutusPurposeTag
-> Credential kr
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
mkWitVKey Proof era
era Maybe PlutusPurposeTag
mTag (forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'Witness
keyHash)
mkMultiSigWit Proof era
era Maybe PlutusPurposeTag
mTag (RequireAllOf StrictSeq (NativeScript era)
timelocks) = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
F.fold forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall era.
(ShelleyEraScript era, NativeScript era ~ MultiSig era,
 Reflect era) =>
Proof era
-> Maybe PlutusPurposeTag
-> MultiSig era
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
mkMultiSigWit Proof era
era Maybe PlutusPurposeTag
mTag) StrictSeq (NativeScript era)
timelocks
mkMultiSigWit Proof era
era Maybe PlutusPurposeTag
mTag (RequireAnyOf StrictSeq (NativeScript era)
timelocks)
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
F.null StrictSeq (NativeScript era)
timelocks = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> b -> a
const [])
  | Bool
otherwise = forall era.
(ShelleyEraScript era, NativeScript era ~ MultiSig era,
 Reflect era) =>
Proof era
-> Maybe PlutusPurposeTag
-> MultiSig era
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
mkMultiSigWit Proof era
era Maybe PlutusPurposeTag
mTag forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a. HasCallStack => [a] -> Gen a
elements (forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList StrictSeq (NativeScript era)
timelocks))
mkMultiSigWit Proof era
era Maybe PlutusPurposeTag
mTag (RequireMOf Int
m StrictSeq (NativeScript era)
timelocks) = do
  [MultiSig era]
ts <- forall a. Int -> [a] -> [a]
take Int
m forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a. [a] -> Gen [a]
shuffle (forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList StrictSeq (NativeScript era)
timelocks))
  forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
F.fold forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall era.
(ShelleyEraScript era, NativeScript era ~ MultiSig era,
 Reflect era) =>
Proof era
-> Maybe PlutusPurposeTag
-> MultiSig era
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
mkMultiSigWit Proof era
era Maybe PlutusPurposeTag
mTag) [MultiSig era]
ts
mkMultiSigWit Proof era
_ Maybe PlutusPurposeTag
_ MultiSig era
_ = forall a. HasCallStack => String -> a
error String
"Impossible: All NativeScripts should have been accounted for"

-- | Timeock scripts are used in Mary and subsequent Eras.
mkTimelockWit ::
  forall era.
  (AllegraEraScript era, NativeScript era ~ Timelock era, Reflect era) =>
  Proof era ->
  Maybe PlutusPurposeTag ->
  Timelock era ->
  GenRS era (SafeHash EraIndependentTxBody -> [WitnessesField era])
mkTimelockWit :: forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era,
 Reflect era) =>
Proof era
-> Maybe PlutusPurposeTag
-> Timelock era
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
mkTimelockWit Proof era
era Maybe PlutusPurposeTag
mTag =
  \case
    RequireSignature KeyHash 'Witness
keyHash -> forall era (kr :: KeyRole).
Reflect era =>
Proof era
-> Maybe PlutusPurposeTag
-> Credential kr
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
mkWitVKey Proof era
era Maybe PlutusPurposeTag
mTag (forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'Witness
keyHash)
    RequireAllOf StrictSeq (NativeScript era)
timelocks -> forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
F.fold forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era,
 Reflect era) =>
Proof era
-> Maybe PlutusPurposeTag
-> Timelock era
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
mkTimelockWit Proof era
era Maybe PlutusPurposeTag
mTag) StrictSeq (NativeScript era)
timelocks
    RequireAnyOf StrictSeq (NativeScript era)
timelocks
      | forall (t :: * -> *) a. Foldable t => t a -> Bool
F.null StrictSeq (NativeScript era)
timelocks -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> b -> a
const [])
      | Bool
otherwise -> forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era,
 Reflect era) =>
Proof era
-> Maybe PlutusPurposeTag
-> Timelock era
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
mkTimelockWit Proof era
era Maybe PlutusPurposeTag
mTag forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a. HasCallStack => [a] -> Gen a
elements (forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList StrictSeq (NativeScript era)
timelocks))
    RequireMOf Int
m StrictSeq (NativeScript era)
timelocks -> do
      [Timelock era]
ts <- forall a. Int -> [a] -> [a]
take Int
m forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a. [a] -> Gen [a]
shuffle (forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList StrictSeq (NativeScript era)
timelocks))
      forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
F.fold forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era,
 Reflect era) =>
Proof era
-> Maybe PlutusPurposeTag
-> Timelock era
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
mkTimelockWit Proof era
era Maybe PlutusPurposeTag
mTag) [Timelock era]
ts
    RequireTimeStart SlotNo
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> b -> a
const [])
    RequireTimeExpire SlotNo
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> b -> a
const [])

-- | Same as `genCredKeyWit`, but for `TxOuts`
genTxOutKeyWitness ::
  forall era.
  Reflect era =>
  Proof era ->
  Maybe PlutusPurposeTag ->
  TxOut era ->
  GenRS era (SafeHash EraIndependentTxBody -> [WitnessesField era])
genTxOutKeyWitness :: forall era.
Reflect era =>
Proof era
-> Maybe PlutusPurposeTag
-> TxOut era
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
genTxOutKeyWitness Proof era
era Maybe PlutusPurposeTag
mTag TxOut era
txOut =
  case TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era. EraTxOut era => Lens' (TxOut era) Addr
addrTxOutL of
    AddrBootstrap BootstrapAddress
baddr ->
      forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Can't authorize bootstrap address: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show BootstrapAddress
baddr
    Addr Network
_ PaymentCredential
payCred StakeReference
_ ->
      case forall era. Proof era -> TxOut era -> StrictMaybe (Script era)
getTxOutRefScript forall era. Reflect era => Proof era
reify TxOut era
txOut of
        StrictMaybe (Script era)
SNothing -> forall era (kr :: KeyRole).
Reflect era =>
Proof era
-> Maybe PlutusPurposeTag
-> Credential kr
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
mkWitVKey Proof era
era Maybe PlutusPurposeTag
mTag PaymentCredential
payCred
        SJust Script era
script -> do
          SafeHash EraIndependentTxBody -> [WitnessesField era]
f1 <- forall era (kr :: KeyRole).
Reflect era =>
Proof era
-> Maybe PlutusPurposeTag
-> Credential kr
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
mkWitVKey Proof era
era Maybe PlutusPurposeTag
mTag PaymentCredential
payCred
          SafeHash EraIndependentTxBody -> [WitnessesField era]
f2 <- forall era.
Reflect era =>
Proof era
-> Maybe PlutusPurposeTag
-> Script era
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
genGenericScriptWitness forall era. Reflect era => Proof era
reify (forall a. a -> Maybe a
Just PlutusPurposeTag
Spending) Script era
script
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (\SafeHash EraIndependentTxBody
safehash -> SafeHash EraIndependentTxBody -> [WitnessesField era]
f1 SafeHash EraIndependentTxBody
safehash forall a. [a] -> [a] -> [a]
++ SafeHash EraIndependentTxBody -> [WitnessesField era]
f2 SafeHash EraIndependentTxBody
safehash)

genCredKeyWit ::
  forall era k.
  Reflect era =>
  Proof era ->
  Maybe PlutusPurposeTag ->
  Credential k ->
  GenRS era (SafeHash EraIndependentTxBody -> [WitnessesField era])
genCredKeyWit :: forall era (kr :: KeyRole).
Reflect era =>
Proof era
-> Maybe PlutusPurposeTag
-> Credential kr
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
genCredKeyWit Proof era
era Maybe PlutusPurposeTag
mTag Credential k
cred = forall era (kr :: KeyRole).
Reflect era =>
Proof era
-> Maybe PlutusPurposeTag
-> Credential kr
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
mkWitVKey Proof era
era Maybe PlutusPurposeTag
mTag Credential k
cred

makeDatumWitness :: Proof era -> TxOut era -> GenRS era [WitnessesField era]
makeDatumWitness :: forall era.
Proof era -> TxOut era -> GenRS era [WitnessesField era]
makeDatumWitness Proof era
proof TxOut era
txout = case (Proof era
proof, TxOut era
txout) of
  (Proof era
Babbage, BabbageTxOut Addr
_ Value BabbageEra
_ (DatumHash DataHash
h) StrictMaybe (Script BabbageEra)
_) -> forall {era}.
Era era =>
StrictMaybe DataHash
-> RWST (GenEnv era) () (GenState era) Gen [WitnessesField era]
mkDatumWit (forall a. a -> StrictMaybe a
SJust DataHash
h)
  (Proof era
Babbage, BabbageTxOut Addr
_ Value BabbageEra
_ (Datum BinaryData BabbageEra
_) StrictMaybe (Script BabbageEra)
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  (Proof era
Babbage, BabbageTxOut Addr
_ Value BabbageEra
_ Datum BabbageEra
NoDatum StrictMaybe (Script BabbageEra)
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  (Proof era
Conway, BabbageTxOut Addr
_ Value ConwayEra
_ (DatumHash DataHash
h) StrictMaybe (Script ConwayEra)
_) -> forall {era}.
Era era =>
StrictMaybe DataHash
-> RWST (GenEnv era) () (GenState era) Gen [WitnessesField era]
mkDatumWit (forall a. a -> StrictMaybe a
SJust DataHash
h)
  (Proof era
Conway, BabbageTxOut Addr
_ Value ConwayEra
_ (Datum BinaryData ConwayEra
_) StrictMaybe (Script ConwayEra)
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  (Proof era
Conway, BabbageTxOut Addr
_ Value ConwayEra
_ Datum ConwayEra
NoDatum StrictMaybe (Script ConwayEra)
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  (Proof era
Alonzo, AlonzoTxOut Addr
_ Value AlonzoEra
_ StrictMaybe DataHash
mDatum) -> forall {era}.
Era era =>
StrictMaybe DataHash
-> RWST (GenEnv era) () (GenState era) Gen [WitnessesField era]
mkDatumWit StrictMaybe DataHash
mDatum
  (Proof era, TxOut era)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [] -- No other era has data witnesses
  where
    mkDatumWit :: StrictMaybe DataHash
-> RWST (GenEnv era) () (GenState era) Gen [WitnessesField era]
mkDatumWit StrictMaybe DataHash
SNothing = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    mkDatumWit (SJust DataHash
datumHash) = do
      Data era
datum <- forall k era v.
(Ord k, Show k, HasCallStack) =>
String -> k -> (GenState era -> Map k v) -> GenRS era v
lookupByKeyM String
"datum" DataHash
datumHash forall era. GenState era -> Map DataHash (Data era)
gsDatums
      forall (f :: * -> *) a. Applicative f => a -> f a
pure [forall era. Era era => [Data era] -> WitnessesField era
DataWits' [Data era
datum]]

-- | Does the current Credential point to a PlutusScript? If so return its IsValid and Hash
plutusScriptHashFromTag ::
  Credential k ->
  PlutusPurposeTag ->
  GenRS era (Maybe (IsValid, ScriptHash))
plutusScriptHashFromTag :: forall (k :: KeyRole) era.
Credential k
-> PlutusPurposeTag -> GenRS era (Maybe (IsValid, ScriptHash))
plutusScriptHashFromTag (KeyHashObj KeyHash k
_) PlutusPurposeTag
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
plutusScriptHashFromTag (ScriptHashObj ScriptHash
scriptHash) PlutusPurposeTag
tag =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ScriptHash
scriptHash, PlutusPurposeTag
tag) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
GenState era
-> Map (ScriptHash, PlutusPurposeTag) (IsValid, Script era)
gsPlutusScripts) forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m s
get forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
    Maybe (IsValid, Script era)
Nothing -> forall a. Maybe a
Nothing
    Just (IsValid
isValid, Script era
_) -> forall a. a -> Maybe a
Just (IsValid
isValid, ScriptHash
scriptHash)

-- | Make RdmrWits WitnessesField only if the Credential is for a Plutus Script
--  And it is in the spending inputs, not the reference inputs
redeemerWitnessMaker ::
  Proof era ->
  PlutusPurposeTag ->
  [Maybe (GenRS era (Data era), Credential k)] ->
  GenRS era (IsValid, [ExUnits -> [WitnessesField era]])
redeemerWitnessMaker :: forall era (k :: KeyRole).
Proof era
-> PlutusPurposeTag
-> [Maybe (GenRS era (Data era), Credential k)]
-> GenRS era (IsValid, [ExUnits -> [WitnessesField era]])
redeemerWitnessMaker Proof era
proof PlutusPurposeTag
tag [Maybe (GenRS era (Data era), Credential k)]
listWithCred =
  let creds :: [(Word32, GenRS era (Data era), Credential k)]
creds =
        [ (Word32
ix, GenRS era (Data era)
genDat, Credential k
cred)
        | (Word32
ix, Maybe (GenRS era (Data era), Credential k)
mCred) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Word32
0 ..] [Maybe (GenRS era (Data era), Credential k)]
listWithCred
        , Just (GenRS era (Data era)
genDat, Credential k
cred) <- [Maybe (GenRS era (Data era), Credential k)
mCred]
        ]
      allValid :: [IsValid] -> IsValid
      allValid :: [IsValid] -> IsValid
allValid = Bool -> IsValid
IsValid forall b c a. (b -> c) -> (a -> b) -> a -> c
. All -> Bool
getAll forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\(IsValid Bool
v) -> Bool -> All
All Bool
v)
   in forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first [IsValid] -> IsValid
allValid forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [(a, b)] -> ([a], [b])
unzip forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes) forall a b. (a -> b) -> a -> b
$
        forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Word32, GenRS era (Data era), Credential k)]
creds forall a b. (a -> b) -> a -> b
$ \(Word32
ix, GenRS era (Data era)
genDat, Credential k
cred) ->
          forall (k :: KeyRole) era.
Credential k
-> PlutusPurposeTag -> GenRS era (Maybe (IsValid, ScriptHash))
plutusScriptHashFromTag Credential k
cred PlutusPurposeTag
tag forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe (IsValid, ScriptHash)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
            Just (IsValid
isValid, ScriptHash
_) -> do
              Data era
datum <- GenRS era (Data era)
genDat
              let mkWit3 :: ExUnits -> [WitnessesField era]
mkWit3 ExUnits
exUnits =
                    [forall era. Redeemers era -> WitnessesField era
RdmrWits (forall era.
Proof era
-> [((PlutusPurposeTag, Word32), (Data era, ExUnits))]
-> Redeemers era
mkRedeemersFromTags Proof era
proof [((PlutusPurposeTag
tag, Word32
ix), (Data era
datum, ExUnits
exUnits))])]
              -- we should not add this if the tx turns out to be in the reference inputs.
              -- we accomplish this by not calling this function on referenceInputs
              forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (IsValid
isValid, ExUnits -> [WitnessesField era]
mkWit3)

-- ===================================================================================
-- Now we start actual generators that create things and enter them into
-- the GenState, and sometimes into the Model.

-- | Collaterals can't have scripts, this is where this generator is needed.
--   As we generate this we add to the gsKeys field of the GenState.
genNoScriptRecipient :: GenRS era Addr
genNoScriptRecipient :: forall era. GenRS era Addr
genNoScriptRecipient = do
  PaymentCredential
paymentCred <- forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era (kr :: KeyRole). GenRS era (KeyHash kr)
genKeyHash
  StakeReference
stakeCred <- StakeCredential -> StakeReference
StakeRefBase forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era (kr :: KeyRole). GenRS era (KeyHash kr)
genKeyHash
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Network -> PaymentCredential -> StakeReference -> Addr
Addr Network
Testnet PaymentCredential
paymentCred StakeReference
stakeCred)

-- | Sometimes generates new Credentials, and some times reuses old ones
genRecipient :: Reflect era => GenRS era Addr
genRecipient :: forall era. Reflect era => GenRS era Addr
genRecipient = do
  PaymentCredential
paymentCred <- forall era (kr :: KeyRole).
Reflect era =>
PlutusPurposeTag -> GenRS era (Credential kr)
genCredential PlutusPurposeTag
Spending
  StakeCredential
stakeCred <- forall era (kr :: KeyRole).
Reflect era =>
PlutusPurposeTag -> GenRS era (Credential kr)
genCredential PlutusPurposeTag
Certifying
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Network -> PaymentCredential -> StakeReference -> Addr
Addr Network
Testnet PaymentCredential
paymentCred (StakeCredential -> StakeReference
StakeRefBase StakeCredential
stakeCred))

genDatum :: Era era => GenRS era (Data era)
genDatum :: forall era. Era era => GenRS era (Data era)
genDatum = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era. Era era => GenRS era (DataHash, Data era)
genDatumWithHash

-- | Generate a Babbage Datum witness to use as a redeemer for a Plutus Script.
--   TxWits can be a ScriptHash, or an inline Datum
genBabbageDatum :: forall era. Era era => GenRS era (Datum era)
genBabbageDatum :: forall era. Era era => GenRS era (Datum era)
genBabbageDatum =
  forall (t :: (* -> *) -> * -> *) b.
(Monad (t Gen), MonadTrans t) =>
[(Int, t Gen b)] -> t Gen b
frequencyT
    [ (Int
1, forall era. DataHash -> Datum era
DatumHash forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era. Era era => GenRS era (DataHash, Data era)
genDatumWithHash)
    , (Int
4, forall era. BinaryData era -> Datum era
Datum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Era era => Data era -> BinaryData era
dataToBinaryData forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era. Era era => GenRS era (DataHash, Data era)
genDatumWithHash)
    ]

genRefScript :: Reflect era => Proof era -> GenRS era (StrictMaybe (Script era))
genRefScript :: forall era.
Reflect era =>
Proof era -> GenRS era (StrictMaybe (Script era))
genRefScript Proof era
proof = do
  ScriptHash
scripthash <- forall era.
Reflect era =>
Proof era -> PlutusPurposeTag -> GenRS era ScriptHash
genScript Proof era
proof PlutusPurposeTag
Spending
  Maybe (Script era)
mscript <- forall era.
ScriptHash
-> Maybe PlutusPurposeTag -> GenRS era (Maybe (Script era))
lookupScript ScriptHash
scripthash (forall a. a -> Maybe a
Just PlutusPurposeTag
Spending)
  case Maybe (Script era)
mscript of
    Maybe (Script era)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. StrictMaybe a
SNothing
    Just Script era
script -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> StrictMaybe a
SJust Script era
script)

-- | Gen the Datum and RefScript fields of a TxOut by Analyzing the payment credential's script
genDataHashField :: Reflect era => Proof era -> Maybe (Script era) -> GenRS era [TxOutField era]
genDataHashField :: forall era.
Reflect era =>
Proof era -> Maybe (Script era) -> GenRS era [TxOutField era]
genDataHashField Proof era
proof Maybe (Script era)
maybeCoreScript =
  case Proof era
proof of
    Proof era
Conway -> case Maybe (Script era)
maybeCoreScript of
      Just (PlutusScript PlutusScript ConwayEra
_) -> do
        Datum era
datum <- forall era. Era era => GenRS era (Datum era)
genBabbageDatum
        StrictMaybe (AlonzoScript ConwayEra)
script <- forall era.
Reflect era =>
Proof era -> GenRS era (StrictMaybe (Script era))
genRefScript Proof era
proof
        forall (f :: * -> *) a. Applicative f => a -> f a
pure [forall era. Datum era -> TxOutField era
FDatum Datum era
datum, forall era. StrictMaybe (Script era) -> TxOutField era
RefScript StrictMaybe (AlonzoScript ConwayEra)
script]
      Maybe (Script era)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    Proof era
Babbage -> case Maybe (Script era)
maybeCoreScript of
      Just (PlutusScript PlutusScript BabbageEra
_) -> do
        Datum era
datum <- forall era. Era era => GenRS era (Datum era)
genBabbageDatum
        StrictMaybe (AlonzoScript BabbageEra)
script <- forall era.
Reflect era =>
Proof era -> GenRS era (StrictMaybe (Script era))
genRefScript Proof era
proof
        forall (f :: * -> *) a. Applicative f => a -> f a
pure [forall era. Datum era -> TxOutField era
FDatum Datum era
datum, forall era. StrictMaybe (Script era) -> TxOutField era
RefScript StrictMaybe (AlonzoScript BabbageEra)
script]
      Maybe (Script era)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    Proof era
Alonzo -> case Maybe (Script era)
maybeCoreScript of
      Just (PlutusScript PlutusScript AlonzoEra
_) -> do
        (DataHash
datahash, Data era
_data) <- forall era. Era era => GenRS era (DataHash, Data era)
genDatumWithHash
        forall (f :: * -> *) a. Applicative f => a -> f a
pure [forall era. StrictMaybe DataHash -> TxOutField era
DHash (forall a. a -> StrictMaybe a
SJust DataHash
datahash)]
      Maybe (Script era)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    Proof era
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [] -- No other Era has any datum in the TxOut

-- | Generate the list of TxOutField that constitute a TxOut
genTxOut :: Reflect era => Proof era -> Value era -> GenRS era [TxOutField era]
genTxOut :: forall era.
Reflect era =>
Proof era -> Value era -> GenRS era [TxOutField era]
genTxOut Proof era
proof Value era
val = do
  Addr
addr <- forall era. Reflect era => GenRS era Addr
genRecipient
  PaymentCredential
cred <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. HasCallStack => String -> a
error String
"BootstrapAddress encountered") forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Addr -> Maybe PaymentCredential
paymentCredAddr Addr
addr
  [TxOutField era]
dataHashFields <-
    case PaymentCredential
cred of
      KeyHashObj KeyHash 'Payment
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      ScriptHashObj ScriptHash
scriptHash -> do
        Maybe (Script era)
maybeCoreScript <- forall era.
ScriptHash
-> Maybe PlutusPurposeTag -> GenRS era (Maybe (Script era))
lookupScript ScriptHash
scriptHash (forall a. a -> Maybe a
Just PlutusPurposeTag
Spending)
        forall era.
Reflect era =>
Proof era -> Maybe (Script era) -> GenRS era [TxOutField era]
genDataHashField Proof era
proof Maybe (Script era)
maybeCoreScript
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [forall era. Addr -> TxOutField era
Address Addr
addr, forall era. Value era -> TxOutField era
Amount Value era
val] forall a. [a] -> [a] -> [a]
++ [TxOutField era]
dataHashFields

-- ================================================================================

-- | Generate a TxIn whose TxIx will never clash with an Input created from a TxOut
genTxIn :: forall era. Proof era -> Int -> Gen TxIn
genTxIn :: forall era. Proof era -> Int -> Gen TxIn
genTxIn Proof era
_proof Int
numChoices = do
  TxId
txId <- forall a. HasCallStack => Int -> Gen a -> Gen a
resize Int
40 forall a. Arbitrary a => Gen a
arbitrary
  -- The TxIx for Inputs created from outputs of a TxBody, will only range from (1..numChoices)
  -- TxIx for these arbitrary Inputs range from (n+1..n+100). This makes the TxIx ranges
  -- incommensurate.
  TxIx
txIx <- (HasCallStack => Integer -> TxIx
mkTxIxPartial forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Random a => (a, a) -> Gen a
choose (Int
numChoices forall a. Num a => a -> a -> a
+ Int
1, Int
numChoices forall a. Num a => a -> a -> a
+ Int
100)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxId -> TxIx -> TxIn
TxIn TxId
txId TxIx
txIx)

-- | Generate a non-empty List of fresh TxIn. By fresh we mean TxIn's that
--   we have not generated previously. We use the current InitialUtxo to test this.
genFreshTxIn :: forall era. Reflect era => Int -> GenRS era [TxIn]
genFreshTxIn :: forall era. Reflect era => Int -> GenRS era [TxIn]
genFreshTxIn Int
tries | Int
tries forall a. Ord a => a -> a -> Bool
<= Int
0 = forall a. HasCallStack => String -> a
error String
"Could not generate a fresh TxIn after many tries."
genFreshTxIn Int
tries = do
  Map TxIn (TxOut era)
entriesInUse <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets forall era. GenState era -> Map TxIn (TxOut era)
gsInitialUtxo
  -- Max number of choices. So the UTxO will never be larger than this
  Int
numChoicesMax <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets forall era. GenState era -> Int
getUtxoChoicesMax
  Int
n <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
numChoicesMax forall a. Num a => a -> a -> a
+ Int
3)
  [TxIn]
ins <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Int -> Gen a -> Gen [a]
vectorOf Int
n (forall era. Proof era -> Int -> Gen TxIn
genTxIn @era forall era. Reflect era => Proof era
reify Int
numChoicesMax)
  case forall a. (a -> Bool) -> [a] -> [a]
filter (forall k a. Ord k => k -> Map k a -> Bool
`Map.notMember` Map TxIn (TxOut era)
entriesInUse) [TxIn]
ins of
    [] -> forall era. Reflect era => Int -> GenRS era [TxIn]
genFreshTxIn (Int
tries forall a. Num a => a -> a -> a
- Int
1)
    [TxIn]
freshTxIns -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Int -> [a] -> [a]
take Int
numChoicesMax [TxIn]
freshTxIns)

-- ====================================================================
-- Generating UTxO and associated Inputs (Set (TxIn era))

-- | Generate a somewhat arbitrary MUtxo.  Occasionally add a bit of
--   the MUtxo in the Model to the one generated.  This way the Tx we generate may
--   spend some of the old UTxo. The result has at most 1 entry from the
--   old MUtxo, and If it has only one entry, that entry is not from the old MUtxo
genUTxO :: Reflect era => GenRS era (MUtxo era, Maybe (UtxoEntry era))
genUTxO :: forall era.
Reflect era =>
GenRS era (MUtxo era, Maybe (UtxoEntry era))
genUTxO = do
  [TxIn]
ins <- forall era. Reflect era => Int -> GenRS era [TxIn]
genFreshTxIn Int
100
  [UtxoEntry era]
pairs <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (forall a b. (a -> b) -> [a] -> [b]
map (\TxIn
x -> (TxIn
x,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST (GenEnv era) () (GenState era) Gen (TxOut era)
genOut) [TxIn]
ins)
  Int
percent <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets forall era. GenState era -> Int
getOldUtxoPercent
  -- Choose a pair from the oldUTxO
  Maybe (UtxoEntry era)
maybepair <- forall (t :: (* -> *) -> * -> *) b.
(Monad (t Gen), MonadTrans t) =>
[(Int, t Gen b)] -> t Gen b
frequencyT [(Int
percent, forall era. Reflect era => GenRS era (Maybe (TxIn, TxOut era))
getUtxoElem), (Int
100 forall a. Num a => a -> a -> a
- Int
percent, forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing)]
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (forall {a}. Maybe a -> [a] -> [a]
maybeCons Maybe (UtxoEntry era)
maybepair [UtxoEntry era]
pairs), Maybe (UtxoEntry era)
maybepair)
  where
    -- Note: Never add an old pair unless there are more than 1 new pairs
    maybeCons :: Maybe a -> [a] -> [a]
maybeCons (Just a
pair) [a]
xs | forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs forall a. Ord a => a -> a -> Bool
> Int
1 = a
pair forall a. a -> [a] -> [a]
: [a]
xs
    maybeCons Maybe a
_ [a]
xs = [a]
xs
    genOut :: RWST (GenEnv era) () (GenState era) Gen (TxOut era)
genOut = do
      Value era
val <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall v. Val v => Gen v
genPositiveVal
      [TxOutField era]
fields <- forall era.
Reflect era =>
Proof era -> Value era -> GenRS era [TxOutField era]
genTxOut forall era. Reflect era => Proof era
reify Value era
val
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall era. Proof era -> [TxOutField era] -> TxOut era
coreTxOut forall era. Reflect era => Proof era
reify [TxOutField era]
fields)

-- | Generate both the spending and reference inputs and a key from the spending
--   inputs we can use to pay the fee. That key is never from the oldUTxO
genSpendReferenceInputs ::
  Map TxIn (TxOut era) ->
  GenRS
    era
    ( UtxoEntry era -- The fee key, used to pay the fee.
    , Map TxIn (TxOut era)
    , Map TxIn (TxOut era)
    , Map TxIn (TxOut era)
    )
genSpendReferenceInputs :: forall era.
Map TxIn (TxOut era)
-> GenRS
     era
     (UtxoEntry era, Map TxIn (TxOut era), Map TxIn (TxOut era),
      Map TxIn (TxOut era))
genSpendReferenceInputs Map TxIn (TxOut era)
newUTxO = do
  let pairs :: [UtxoEntry era]
pairs = forall k a. Map k a -> [(k, a)]
Map.toList Map TxIn (TxOut era)
newUTxO
  Int
maxInputs <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets forall era. GenState era -> Int
getSpendInputsMax
  Int
maxRef <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets forall era. GenState era -> Int
getRefInputsMax
  Int
numInputs <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Random a => (a, a) -> Gen a
choose (Int
1, forall a. Ord a => a -> a -> a
min (forall k a. Map k a -> Int
Map.size Map TxIn (TxOut era)
newUTxO) Int
maxInputs)
  Int
numRefInputs <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
maxRef)
  TxIn -> Bool
badTest <- forall era. GenRS era (TxIn -> Bool)
getUtxoTest
  (feepair :: UtxoEntry era
feepair@(TxIn
txin, TxOut era
txout), [UtxoEntry era]
inputPairs) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> Int -> [a] -> Gen (a, [a])
chooseGood (TxIn -> Bool
badTest forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) Int
numInputs [UtxoEntry era]
pairs
  [UtxoEntry era]
refInputPairs <- forall a. Int -> [a] -> [a]
take Int
numRefInputs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a. [a] -> Gen [a]
shuffle [UtxoEntry era]
pairs)
  let inputs :: Map TxIn (TxOut era)
inputs = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [UtxoEntry era]
inputPairs
      refInputs :: Map TxIn (TxOut era)
refInputs = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [UtxoEntry era]
refInputPairs
  -- The feepair is added to the mMutFee field
  forall era.
(Map TxIn (TxOut era) -> Map TxIn (TxOut era)) -> GenRS era ()
modifyModelMutFee (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TxIn
txin TxOut era
txout)
  let filtered :: Map TxIn (TxOut era)
filtered = forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map TxIn (TxOut era)
newUTxO (forall a. Ord a => Set a -> Set a -> Set a
Set.union (forall k a. Map k a -> Set k
Map.keysSet Map TxIn (TxOut era)
inputs) (forall k a. Map k a -> Set k
Map.keysSet Map TxIn (TxOut era)
refInputs))
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (UtxoEntry era
feepair, Map TxIn (TxOut era)
inputs, Map TxIn (TxOut era)
refInputs, Map TxIn (TxOut era)
filtered)

-- | The invariant is:
--
-- * 'xs' is a non empty list.
-- * 'xs' has at most one 'bad' element
-- * if 'xs' has length 1, then the element is guaranteed to be good.
-- * 'n' is a positive `Int`, ranging between (1 .. length xs).
-- Return a pair (good,ys) where
-- > (bad good)==False,
-- > (good `elem` ys),
-- > (length ys) == n, and
-- > all (`elem` xs) ys.
--
-- This is used to generate the spending inputs, which always contain on
-- Input we can use to pay the fee, that does not come from the oldUTxO.
chooseGood :: (a -> Bool) -> Int -> [a] -> Gen (a, [a])
chooseGood :: forall a. (a -> Bool) -> Int -> [a] -> Gen (a, [a])
chooseGood a -> Bool
bad Int
n [a]
xs = do
  let (a
good, [a]
others) =
        case [a]
xs of
          [] ->
            forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$
              String
"empty list in chooseGood, should never happen. n = "
                forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
n
                forall a. [a] -> [a] -> [a]
++ String
", length xs = "
                forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs)
          [a
x] -> (a
x, [])
          (a
x : a
y : [a]
more) -> if a -> Bool
bad a
x then (a
y, a
x forall a. a -> [a] -> [a]
: [a]
more) else (a
x, a
y forall a. a -> [a] -> [a]
: [a]
more)
  [a]
tailx <- forall a. Int -> [a] -> [a]
take (Int
n forall a. Num a => a -> a -> a
- Int
1) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> Gen [a]
shuffle [a]
others
  [a]
result <- forall a. [a] -> Gen [a]
shuffle (a
good forall a. a -> [a] -> [a]
: [a]
tailx)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
good, [a]
result)

-- ==================================================
-- Generating Certificates, May add to the Model

genShelleyDelegCert :: forall era. Reflect era => GenRS era (TxCert era)
genShelleyDelegCert :: forall era. Reflect era => GenRS era (TxCert era)
genShelleyDelegCert = do
  Int
regCertFreq <- forall w (m :: * -> *) r a s.
(Monoid w, Monad m) =>
(r -> a) -> RWST r w s m a
asks forall a b. (a -> b) -> a -> b
$ GenSize -> Int
regCertFreq forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenEnv era -> GenSize
geSize
  Int
delegCertFreq <- forall w (m :: * -> *) r a s.
(Monoid w, Monad m) =>
(r -> a) -> RWST r w s m a
asks forall a b. (a -> b) -> a -> b
$ GenSize -> Int
delegCertFreq forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenEnv era -> GenSize
geSize
  forall (t :: (* -> *) -> * -> *) b.
(Monad (t Gen), MonadTrans t) =>
[(Int, t Gen b)] -> t Gen b
frequencyT
    [ (Int
regCertFreq, GenRS era (TxCert era)
genShelleyRegCert)
    , (Int
25, GenRS era (TxCert era)
genShelleyUnRegCert)
    , (Int
delegCertFreq, GenRS era (TxCert era)
genDelegation)
    ]
  where
    genShelleyRegCert :: GenRS era (TxCert era)
genShelleyRegCert = forall era. ShelleyEraTxCert era => StakeCredential -> TxCert era
RegTxCert forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
Reflect era =>
PlutusPurposeTag -> GenRS era StakeCredential
genFreshRegCred @era PlutusPurposeTag
Certifying
    genShelleyUnRegCert :: GenRS era (TxCert era)
genShelleyUnRegCert = forall era. ShelleyEraTxCert era => StakeCredential -> TxCert era
UnRegTxCert forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era (kr :: KeyRole).
Reflect era =>
PlutusPurposeTag -> GenRS era (Credential kr)
genCredential PlutusPurposeTag
Certifying
    genDelegation :: GenRS era (TxCert era)
genDelegation = do
      StakeCredential
rewardAccount <- forall era.
Reflect era =>
PlutusPurposeTag -> GenRS era StakeCredential
genFreshRegCred PlutusPurposeTag
Certifying
      (KeyHash 'StakePool
poolId, PoolParams
_) <- forall era.
Reflect era =>
GenRS era (KeyHash 'StakePool, PoolParams)
genPool
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall era.
ShelleyEraTxCert era =>
StakeCredential -> KeyHash 'StakePool -> TxCert era
DelegStakeTxCert StakeCredential
rewardAccount KeyHash 'StakePool
poolId

genTxCertDeleg :: forall era. Reflect era => GenRS era (TxCert era)
genTxCertDeleg :: forall era. Reflect era => GenRS era (TxCert era)
genTxCertDeleg = case forall era. Reflect era => Proof era
reify @era of
  Proof era
Shelley -> forall era. Reflect era => GenRS era (TxCert era)
genShelleyDelegCert
  Proof era
Mary -> forall era. Reflect era => GenRS era (TxCert era)
genShelleyDelegCert
  Proof era
Allegra -> forall era. Reflect era => GenRS era (TxCert era)
genShelleyDelegCert
  Proof era
Alonzo -> forall era. Reflect era => GenRS era (TxCert era)
genShelleyDelegCert
  Proof era
Babbage -> forall era. Reflect era => GenRS era (TxCert era)
genShelleyDelegCert
  Proof era
Conway -> forall era. Reflect era => GenRS era (TxCert era)
genShelleyDelegCert

genTxCert :: forall era. Reflect era => SlotNo -> GenRS era (TxCert era)
genTxCert :: forall era. Reflect era => SlotNo -> GenRS era (TxCert era)
genTxCert SlotNo
slot =
  forall (t :: (* -> *) -> * -> *) b.
(Monad (t Gen), MonadTrans t) =>
[t Gen b] -> t Gen b
elementsT
    [ forall era. Reflect era => GenRS era (TxCert era)
genTxCertDeleg
    , forall (t :: (* -> *) -> * -> *) b.
(Monad (t Gen), MonadTrans t) =>
[(Int, t Gen b)] -> t Gen b
frequencyT
        [ (Int
75, forall era. EraTxCert era => PoolParams -> TxCert era
RegPoolTxCert forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST (GenEnv era) () (GenState era) Gen PoolParams
genFreshPool)
        , (Int
25, forall era.
EraTxCert era =>
KeyHash 'StakePool -> EpochNo -> TxCert era
RetirePoolTxCert forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era. Reflect era => GenRS era (KeyHash 'StakePool)
genRetirementHash forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RWST (GenEnv era) () (GenState era) Gen EpochNo
genEpoch)
        ]
    ]
  where
    genFreshPool :: RWST (GenEnv era) () (GenState era) Gen PoolParams
genFreshPool = do
      (KeyHash 'StakePool
_kh, PoolParams
pp, IndividualPoolStake
_) <- forall era.
Reflect era =>
GenRS era (KeyHash 'StakePool, PoolParams, IndividualPoolStake)
genNewPool
      forall (m :: * -> *) a. Monad m => a -> m a
return PoolParams
pp
    genEpoch :: RWST (GenEnv era) () (GenState era) Gen EpochNo
genEpoch = do
      let EpochNo Word64
txEpoch = SlotNo -> EpochNo
epochFromSlotNo SlotNo
slot
      EpochNo Word64
curEpoch <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets forall a b. (a -> b) -> a -> b
$ forall era. ModelNewEpochState era -> EpochNo
mEL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenState era -> ModelNewEpochState era
gsModel
      EpochInterval Word32
maxEpoch <- forall w (m :: * -> *) r a s.
(Monoid w, Monad m) =>
(r -> a) -> RWST r w s m a
asks forall a b. (a -> b) -> a -> b
$ forall a s. Getting a s a -> s -> a
view forall era. EraPParams era => Lens' (PParams era) EpochInterval
ppEMaxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenEnv era -> PParams era
gePParams
      let nextEpoch :: Word64
nextEpoch = Word64
1 forall a. Num a => a -> a -> a
+ (Word64
txEpoch forall a. Num a => a -> a -> a
- Word64
curEpoch) -- This will be either 1 or 2. It is 2 if the Tx is at the epoch boundary
      Word64
delta <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Random a => (a, a) -> Gen a
choose (Word64
nextEpoch, forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
maxEpoch)
      forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> EpochNo
EpochNo forall a b. (a -> b) -> a -> b
$ (Word64
curEpoch forall a. Num a => a -> a -> a
+ Word64
delta)

-- getShelleyTxCertDelegG :: forall era. Reflect era => TxCert era -> Maybe (ShelleyDelegCert )
-- getShelleyTxCertDelegG = case reify @era of
--   Shelley -> getShelleyTxCertDeleg
--   Mary -> getShelleyTxCertDeleg
--   Allegra -> getShelleyTxCertDeleg
--   Alonzo -> getShelleyTxCertDeleg
--   Babbage -> getShelleyTxCertDeleg
--   Conway -> getShelleyTxCertDeleg -- TODO write a generator for Conwayerts

-- mkShelleyTxCertDelegG :: forall era. Reflect era => ShelleyDelegCert  -> TxCert era
-- mkShelleyTxCertDelegG = case reify @era of
--   Shelley -> mkShelleyTxCertDeleg
--   Mary -> mkShelleyTxCertDeleg
--   Allegra -> mkShelleyTxCertDeleg
--   Alonzo -> mkShelleyTxCertDeleg
--   Babbage -> mkShelleyTxCertDeleg
--   Conway -> mkShelleyTxCertDeleg -- TODO write a generator for Conwayerts

genTxCerts :: forall era. Reflect era => SlotNo -> GenRS era [TxCert era]
genTxCerts :: forall era. Reflect era => SlotNo -> GenRS era [TxCert era]
genTxCerts SlotNo
slot = do
  let genUniqueScript :: ([TxCert era], Set (ScriptHash, Maybe (KeyHash 'StakePool)),
 Map StakeCredential Coin)
-> Int
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     ([TxCert era], Set (ScriptHash, Maybe (KeyHash 'StakePool)),
      Map StakeCredential Coin)
genUniqueScript (![TxCert era]
dcs, !Set (ScriptHash, Maybe (KeyHash 'StakePool))
ss, !Map StakeCredential Coin
regCreds) Int
_ = do
        Set StakeCredential
honest <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets forall era. GenState era -> Set StakeCredential
gsStableDelegators
        TxCert era
dc <- forall era. Reflect era => SlotNo -> GenRS era (TxCert era)
genTxCert SlotNo
slot
        -- Workaround a misfeature where duplicate plutus scripts in TxCert are ignored
        -- so if a duplicate might be generated, we don't do that generation
        let insertIfNotPresent :: [TxCert era]
-> Map StakeCredential Coin
-> Maybe (KeyHash 'StakePool)
-> Maybe (IsValid, ScriptHash)
-> ([TxCert era], Set (ScriptHash, Maybe (KeyHash 'StakePool)),
    Map StakeCredential Coin)
insertIfNotPresent [TxCert era]
dcs' Map StakeCredential Coin
regCreds' Maybe (KeyHash 'StakePool)
mKey Maybe (IsValid, ScriptHash)
mScriptHash
              | Just (IsValid
_, ScriptHash
scriptHash) <- Maybe (IsValid, ScriptHash)
mScriptHash =
                  if (ScriptHash
scriptHash, Maybe (KeyHash 'StakePool)
mKey) forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (ScriptHash, Maybe (KeyHash 'StakePool))
ss
                    then ([TxCert era]
dcs, Set (ScriptHash, Maybe (KeyHash 'StakePool))
ss, Map StakeCredential Coin
regCreds)
                    else (TxCert era
dc forall a. a -> [a] -> [a]
: [TxCert era]
dcs', forall a. Ord a => a -> Set a -> Set a
Set.insert (ScriptHash
scriptHash, Maybe (KeyHash 'StakePool)
mKey) Set (ScriptHash, Maybe (KeyHash 'StakePool))
ss, Map StakeCredential Coin
regCreds')
              | Bool
otherwise = (TxCert era
dc forall a. a -> [a] -> [a]
: [TxCert era]
dcs', Set (ScriptHash, Maybe (KeyHash 'StakePool))
ss, Map StakeCredential Coin
regCreds')
        -- Generate registration and de-registration delegation certificates,
        -- while ensuring the proper registered/unregistered state in DState
        case TxCert era
dc of
          RegPoolTxCert PoolParams
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxCert era
dc forall a. a -> [a] -> [a]
: [TxCert era]
dcs, Set (ScriptHash, Maybe (KeyHash 'StakePool))
ss, Map StakeCredential Coin
regCreds)
          RetirePoolTxCert KeyHash 'StakePool
kh EpochNo
_ -> do
            -- We need to make sure that the pool is registered before
            -- we try to retire it
            Map (KeyHash 'StakePool) PoolParams
modelPools <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets forall a b. (a -> b) -> a -> b
$ forall era.
ModelNewEpochState era -> Map (KeyHash 'StakePool) PoolParams
mPoolParams forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenState era -> ModelNewEpochState era
gsModel
            case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'StakePool
kh Map (KeyHash 'StakePool) PoolParams
modelPools of
              Just PoolParams
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxCert era
dc forall a. a -> [a] -> [a]
: [TxCert era]
dcs, Set (ScriptHash, Maybe (KeyHash 'StakePool))
ss, Map StakeCredential Coin
regCreds)
              Maybe PoolParams
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TxCert era]
dcs, Set (ScriptHash, Maybe (KeyHash 'StakePool))
ss, Map StakeCredential Coin
regCreds)
          RegTxCert StakeCredential
regCred ->
            if StakeCredential
regCred forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map StakeCredential Coin
regCreds -- Can't register if it is already registered
              then forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TxCert era]
dcs, Set (ScriptHash, Maybe (KeyHash 'StakePool))
ss, Map StakeCredential Coin
regCreds)
              else forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxCert era
dc forall a. a -> [a] -> [a]
: [TxCert era]
dcs, Set (ScriptHash, Maybe (KeyHash 'StakePool))
ss, forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert StakeCredential
regCred (Integer -> Coin
Coin Integer
99) Map StakeCredential Coin
regCreds) -- 99 is a NonZero Value
          UnRegTxCert StakeCredential
deregCred ->
            -- We can't make ShelleyUnRegCert certificate if deregCred is not already registered
            -- or if the Rewards balance for deregCred is not 0,
            -- or if the credential is one of the StableDelegators (which are never de-registered)
            case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup StakeCredential
deregCred Map StakeCredential Coin
regCreds of
              Maybe Coin
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TxCert era]
dcs, Set (ScriptHash, Maybe (KeyHash 'StakePool))
ss, Map StakeCredential Coin
regCreds)
              -- No credential, skip making certificate
              Just (Coin Integer
0) ->
                -- Ok to make certificate, rewards balance is 0
                if forall a. Ord a => a -> Set a -> Bool
Set.member StakeCredential
deregCred Set StakeCredential
honest
                  then forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TxCert era]
dcs, Set (ScriptHash, Maybe (KeyHash 'StakePool))
ss, Map StakeCredential Coin
regCreds)
                  else
                    [TxCert era]
-> Map StakeCredential Coin
-> Maybe (KeyHash 'StakePool)
-> Maybe (IsValid, ScriptHash)
-> ([TxCert era], Set (ScriptHash, Maybe (KeyHash 'StakePool)),
    Map StakeCredential Coin)
insertIfNotPresent [TxCert era]
dcs (forall k a. Ord k => k -> Map k a -> Map k a
Map.delete StakeCredential
deregCred Map StakeCredential Coin
regCreds) forall a. Maybe a
Nothing
                      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (k :: KeyRole) era.
Credential k
-> PlutusPurposeTag -> GenRS era (Maybe (IsValid, ScriptHash))
plutusScriptHashFromTag StakeCredential
deregCred PlutusPurposeTag
Certifying
              Just (Coin Integer
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TxCert era]
dcs, Set (ScriptHash, Maybe (KeyHash 'StakePool))
ss, Map StakeCredential Coin
regCreds)
          DelegStakeTxCert StakeCredential
delegCred KeyHash 'StakePool
delegKey ->
            let ([TxCert era]
dcs', Map StakeCredential Coin
regCreds') =
                  if StakeCredential
delegCred forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map StakeCredential Coin
regCreds
                    then ([TxCert era]
dcs, Map StakeCredential Coin
regCreds)
                    else -- In order to Delegate, the delegCred must exist in rewards.
                    -- so if it is not there, we put it there, otherwise we may
                    -- never generate a valid delegation.
                      ( (forall era. ShelleyEraTxCert era => StakeCredential -> TxCert era
RegTxCert StakeCredential
delegCred) forall a. a -> [a] -> [a]
: [TxCert era]
dcs
                      , forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert StakeCredential
delegCred (Integer -> Coin
Coin Integer
99) Map StakeCredential Coin
regCreds
                      )
             in [TxCert era]
-> Map StakeCredential Coin
-> Maybe (KeyHash 'StakePool)
-> Maybe (IsValid, ScriptHash)
-> ([TxCert era], Set (ScriptHash, Maybe (KeyHash 'StakePool)),
    Map StakeCredential Coin)
insertIfNotPresent [TxCert era]
dcs' Map StakeCredential Coin
regCreds' (forall a. a -> Maybe a
Just KeyHash 'StakePool
delegKey)
                  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (k :: KeyRole) era.
Credential k
-> PlutusPurposeTag -> GenRS era (Maybe (IsValid, ScriptHash))
plutusScriptHashFromTag StakeCredential
delegCred PlutusPurposeTag
Certifying
          TxCert era
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxCert era
dc forall a. a -> [a] -> [a]
: [TxCert era]
dcs, Set (ScriptHash, Maybe (KeyHash 'StakePool))
ss, Map StakeCredential Coin
regCreds)
  Int
maxcert <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets forall era. GenState era -> Int
getCertificateMax
  Int
n <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
maxcert)
  Map StakeCredential Coin
reward <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets (forall era. ModelNewEpochState era -> Map StakeCredential Coin
mRewards forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenState era -> ModelNewEpochState era
gsModel)
  let initSets ::
        ( [TxCert era]
        , Set (ScriptHash, Maybe (KeyHash 'StakePool))
        , Map (Credential 'Staking) Coin
        )
      initSets :: ([TxCert era], Set (ScriptHash, Maybe (KeyHash 'StakePool)),
 Map StakeCredential Coin)
initSets = ([], forall a. Set a
Set.empty, Map StakeCredential Coin
reward)
  ([TxCert era]
dcs, Set (ScriptHash, Maybe (KeyHash 'StakePool))
_, Map StakeCredential Coin
_) <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
F.foldlM ([TxCert era], Set (ScriptHash, Maybe (KeyHash 'StakePool)),
 Map StakeCredential Coin)
-> Int
-> RWST
     (GenEnv era)
     ()
     (GenState era)
     Gen
     ([TxCert era], Set (ScriptHash, Maybe (KeyHash 'StakePool)),
      Map StakeCredential Coin)
genUniqueScript ([TxCert era], Set (ScriptHash, Maybe (KeyHash 'StakePool)),
 Map StakeCredential Coin)
initSets [Int
1 :: Int .. Int
n]
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [TxCert era]
dcs

spendOnly :: EraTxOut era => TxOut era -> Bool
spendOnly :: forall era. EraTxOut era => TxOut era -> Bool
spendOnly TxOut era
txOut = case TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era. EraTxOut era => Lens' (TxOut era) Addr
addrTxOutL of
  Addr Network
_ (ScriptHashObj ScriptHash
_) StakeReference
_ -> Bool
False
  Addr
_ -> Bool
True

-- | Generate a set of Collateral inputs sufficient to pay the minimum fee ('minCollTotal') computed
--   from the fee and the collateralPercentage from the PParams. Return the new UTxO, the inputs,
--   and coin of the excess amount included in the inputs, above what is needed to pay the minimum fee.
genCollateralUTxO ::
  forall era.
  (HasCallStack, Reflect era) =>
  [Addr] ->
  Coin ->
  MUtxo era ->
  GenRS era (MUtxo era, Map.Map TxIn (TxOut era), Coin)
genCollateralUTxO :: forall era.
(HasCallStack, Reflect era) =>
[Addr]
-> Coin -> MUtxo era -> GenRS era (MUtxo era, MUtxo era, Coin)
genCollateralUTxO [Addr]
collateralAddresses (Coin Integer
fee) MUtxo era
utxo = do
  GenEnv {PParams era
gePParams :: PParams era
gePParams :: forall era. GenEnv era -> PParams era
gePParams} <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets forall era. GenState era -> GenEnv era
gsGenEnv
  let collPerc :: Natural
collPerc = forall era. Proof era -> PParams era -> Natural
collateralPercentage' forall era. Reflect era => Proof era
reify PParams era
gePParams
      minCollTotal :: Coin
minCollTotal = Integer -> Coin
Coin (forall a b. (RealFrac a, Integral b) => a -> b
ceiling ((Integer
fee forall a. Num a => a -> a -> a
* forall a. Integral a => a -> Integer
toInteger Natural
collPerc) forall a. Integral a => a -> a -> Ratio a
% Integer
100))
      -- Generate a collateral that is neither in UTxO map nor has already been generated
      genNewCollateral :: Addr
-> MUtxo era
-> MUtxo era
-> Coin
-> GenRS era (MUtxo era, MUtxo era, Coin)
genNewCollateral Addr
addr MUtxo era
coll MUtxo era
um Coin
c = do
        -- The size of the Gen computation is driven down when we generate scripts, so it can be 0 here
        -- that is really bad, because if the happens we get the same TxIn every time, and 'coll' never grows,
        -- so this function doesn't terminate. We want many choices of TxIn, so resize just this arbitrary by 30.
        MUtxo era
entriesInUse <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets forall era. GenState era -> Map TxIn (TxOut era)
gsInitialUtxo
        TxIn
txIn <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a. HasCallStack => Int -> Gen a -> Gen a
resize Int
30 (forall a. Arbitrary a => Gen a
arbitrary :: Gen TxIn))
        if forall k a. Ord k => k -> Map k a -> Bool
Map.member TxIn
txIn MUtxo era
utxo Bool -> Bool -> Bool
|| forall k a. Ord k => k -> Map k a -> Bool
Map.member TxIn
txIn MUtxo era
coll Bool -> Bool -> Bool
|| TxIn
txIn forall k a. Ord k => k -> Map k a -> Bool
`Map.member` MUtxo era
entriesInUse
          then Addr
-> MUtxo era
-> MUtxo era
-> Coin
-> GenRS era (MUtxo era, MUtxo era, Coin)
genNewCollateral Addr
addr MUtxo era
coll MUtxo era
um Coin
c
          else forall (f :: * -> *) a. Applicative f => a -> f a
pure (MUtxo era
um, forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TxIn
txIn (forall era. Proof era -> [TxOutField era] -> TxOut era
coreTxOut forall era. Reflect era => Proof era
reify [forall era. Addr -> TxOutField era
Address Addr
addr, forall era. Value era -> TxOutField era
Amount (forall t s. Inject t s => t -> s
inject Coin
c)]) MUtxo era
coll, Coin
c)
      -- Either pick a collateral from a map or generate a completely new one
      genCollateral :: Addr
-> MUtxo era -> MUtxo era -> GenRS era (MUtxo era, MUtxo era, Coin)
genCollateral Addr
addr MUtxo era
coll MUtxo era
um
        | forall k a. Map k a -> Bool
Map.null MUtxo era
um = Addr
-> MUtxo era
-> MUtxo era
-> Coin
-> GenRS era (MUtxo era, MUtxo era, Coin)
genNewCollateral Addr
addr MUtxo era
coll MUtxo era
um forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall v. Val v => Gen v
genPositiveVal
        | Bool
otherwise = do
            Int
i <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Gen Int
chooseInt (Int
0, forall k a. Map k a -> Int
Map.size MUtxo era
um forall a. Num a => a -> a -> a
- Int
1)
            let (TxIn
txIn, TxOut era
txOut) = forall k a. Int -> Map k a -> (k, a)
Map.elemAt Int
i MUtxo era
um
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall k a. Int -> Map k a -> Map k a
Map.deleteAt Int
i MUtxo era
um, forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TxIn
txIn TxOut era
txOut MUtxo era
coll, TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
coinTxOutL)
      -- Recursively either pick existing key spend only outputs or generate new ones that
      -- will be later added to the UTxO map
      go ::
        [Addr] ->
        Map TxIn (TxOut era) ->
        Coin ->
        Map TxIn (TxOut era) ->
        GenRS era (Map TxIn (TxOut era), Coin)
      go :: [Addr]
-> MUtxo era -> Coin -> MUtxo era -> GenRS era (MUtxo era, Coin)
go [Addr]
ecs !MUtxo era
coll !Coin
curCollTotal !MUtxo era
um
        | Coin
curCollTotal forall a. Ord a => a -> a -> Bool
>= Coin
minCollTotal = forall (f :: * -> *) a. Applicative f => a -> f a
pure (MUtxo era
coll, Coin
curCollTotal forall t. Val t => t -> t -> t
<-> Coin
minCollTotal)
        | [] <- [Addr]
ecs = forall a. HasCallStack => String -> a
error String
"Impossible: supplied less addresses than `maxCollateralInputs`"
        | Addr
ec : [Addr]
ecs' <- [Addr]
ecs = do
            (MUtxo era
um', MUtxo era
coll', Coin
c) <-
              if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Addr]
ecs'
                then -- This is the last input, so most of the time, put something (val > 0)
                -- extra in it or we will always have a ColReturn with zero in it.
                  do
                    Coin
excess <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall v. Val v => Gen v
genPositiveVal
                    Addr
-> MUtxo era
-> MUtxo era
-> Coin
-> GenRS era (MUtxo era, MUtxo era, Coin)
genNewCollateral Addr
ec MUtxo era
coll MUtxo era
um ((Coin
minCollTotal forall t. Val t => t -> t -> t
<-> Coin
curCollTotal) forall t. Val t => t -> t -> t
<+> Coin
excess)
                else forall (t :: (* -> *) -> * -> *) b.
(Monad (t Gen), MonadTrans t) =>
[t Gen b] -> t Gen b
elementsT [Addr
-> MUtxo era -> MUtxo era -> GenRS era (MUtxo era, MUtxo era, Coin)
genCollateral Addr
ec MUtxo era
coll forall k a. Map k a
Map.empty, Addr
-> MUtxo era -> MUtxo era -> GenRS era (MUtxo era, MUtxo era, Coin)
genCollateral Addr
ec MUtxo era
coll MUtxo era
um]
            [Addr]
-> MUtxo era -> Coin -> MUtxo era -> GenRS era (MUtxo era, Coin)
go [Addr]
ecs' MUtxo era
coll' (Coin
curCollTotal forall t. Val t => t -> t -> t
<+> Coin
c) MUtxo era
um'
  (MUtxo era
collaterals, Coin
excessColCoin) <-
    [Addr]
-> MUtxo era -> Coin -> MUtxo era -> GenRS era (MUtxo era, Coin)
go [Addr]
collateralAddresses forall k a. Map k a
Map.empty (Integer -> Coin
Coin Integer
0) forall a b. (a -> b) -> a -> b
$ forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter forall era. EraTxOut era => TxOut era -> Bool
spendOnly MUtxo era
utxo
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union MUtxo era
collaterals MUtxo era
utxo, MUtxo era
collaterals, Coin
excessColCoin)

-- | This function is used to generate the Outputs of a TxBody, It is computed by taking the
--   Outputs of the range of the (UTxO resticted by the Inputs of the TxBody),
--   as input to the function, and then making new Outputs, where the sum of the Coin is the same.
--   This way we generate a 'balanced' TxBody (modulo fees, deposits, refunds etc. which are
--   handled separately). The idea is to make sum(txOuts) == sum(genRecipientsFrom txouts), the
--   sum will be the same, but the size may be different.
genRecipientsFrom :: Reflect era => [TxOut era] -> GenRS era [TxOut era]
genRecipientsFrom :: forall era. Reflect era => [TxOut era] -> GenRS era [TxOut era]
genRecipientsFrom [TxOut era]
txOuts = do
  let outCount :: Int
outCount = forall (t :: * -> *) a. Foldable t => t a -> Int
length [TxOut era]
txOuts
  Int
approxCount <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
outCount)
  let extra :: Int
extra = Int
outCount forall a. Num a => a -> a -> a
- Int
approxCount
      avgExtra :: Int
avgExtra = forall a b. (RealFrac a, Integral b) => a -> b
ceiling (forall a. Integral a => a -> Integer
toInteger Int
extra forall a. Integral a => a -> a -> Ratio a
% forall a. Integral a => a -> Integer
toInteger Int
approxCount)
      genExtra :: Int -> RWST (GenEnv era) () (GenState era) Gen Int
genExtra Int
e
        | Int
e forall a. Ord a => a -> a -> Bool
<= Int
0 Bool -> Bool -> Bool
|| Int
avgExtra forall a. Eq a => a -> a -> Bool
== Int
0 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
0
        | Bool
otherwise = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Gen Int
chooseInt (Int
0, Int
avgExtra)
  let goNew :: Int -> [TxOut era] -> [TxOut era] -> GenRS era [TxOut era]
goNew Int
_ [] ![TxOut era]
rs = forall (f :: * -> *) a. Applicative f => a -> f a
pure [TxOut era]
rs
      goNew Int
e (TxOut era
tx : [TxOut era]
txs) ![TxOut era]
rs = do
        Int
leftToAdd <- Int -> RWST (GenEnv era) () (GenState era) Gen Int
genExtra Int
e
        Int
-> Int
-> Value era
-> TxOut era
-> [TxOut era]
-> [TxOut era]
-> GenRS era [TxOut era]
goExtra (Int
e forall a. Num a => a -> a -> a
- Int
leftToAdd) Int
leftToAdd (forall t s. Inject t s => t -> s
inject (Integer -> Coin
Coin Integer
0)) TxOut era
tx [TxOut era]
txs [TxOut era]
rs
      goExtra :: Int
-> Int
-> Value era
-> TxOut era
-> [TxOut era]
-> [TxOut era]
-> GenRS era [TxOut era]
goExtra Int
_ Int
_ Value era
s TxOut era
tx [] ![TxOut era]
rs = forall {era}.
Reflect era =>
Value era
-> TxOut era
-> [TxOut era]
-> RWST (GenEnv era) () (GenState era) Gen [TxOut era]
genWithChange Value era
s TxOut era
tx [TxOut era]
rs
      goExtra Int
e Int
0 Value era
s TxOut era
tx [TxOut era]
txs ![TxOut era]
rs = Int -> [TxOut era] -> [TxOut era] -> GenRS era [TxOut era]
goNew Int
e [TxOut era]
txs forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall {era}.
Reflect era =>
Value era
-> TxOut era
-> [TxOut era]
-> RWST (GenEnv era) () (GenState era) Gen [TxOut era]
genWithChange Value era
s TxOut era
tx [TxOut era]
rs
      goExtra Int
e Int
n !Value era
s TxOut era
txOut (TxOut era
tx : [TxOut era]
txs) ![TxOut era]
rs = Int
-> Int
-> Value era
-> TxOut era
-> [TxOut era]
-> [TxOut era]
-> GenRS era [TxOut era]
goExtra Int
e (Int
n forall a. Num a => a -> a -> a
- Int
1) (Value era
s forall t. Val t => t -> t -> t
<+> Value era
v) TxOut era
tx [TxOut era]
txs [TxOut era]
rs
        where
          v :: Value era
v = TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era. EraTxOut era => Lens' (TxOut era) (Value era)
valueTxOutL
      -- Potentially split 'txout' into two TxOuts. If the two piece path is used
      -- one of two TxOuts uses the same 'addr' as 'txout' and holds the 'change'
      -- (i.e. difference between the original and the second, non-change, TxOut).
      -- In either case whether it adds 1 or 2 TxOuts to 'rs', the coin value of
      -- the new TxOut(s), is the same as the coin value of 'txout'.
      genWithChange :: Value era
-> TxOut era
-> [TxOut era]
-> RWST (GenEnv era) () (GenState era) Gen [TxOut era]
genWithChange Value era
s TxOut era
txout [TxOut era]
rs = do
        let !(!Addr
addr, !Value era
v, ![TxOutField era]
ds) = forall era.
Proof era -> TxOut era -> (Addr, Value era, [TxOutField era])
txoutFields forall era. Reflect era => Proof era
reify TxOut era
txout
            vCoin :: Integer
vCoin = Coin -> Integer
unCoin (forall t. Val t => t -> Coin
coin Value era
v)
        if Integer
vCoin forall a. Eq a => a -> a -> Bool
== Integer
0 -- If the coin balance is 0, don't add any TxOuts to 'rs'
          then forall (f :: * -> *) a. Applicative f => a -> f a
pure [TxOut era]
rs
          else do
            Coin
c <- Integer -> Coin
Coin forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a. Random a => (a, a) -> Gen a
choose (Integer
1, Integer
vCoin))
            [TxOutField era]
fields <- forall era.
Reflect era =>
Proof era -> Value era -> GenRS era [TxOutField era]
genTxOut forall era. Reflect era => Proof era
reify (Value era
s forall t. Val t => t -> t -> t
<+> forall t s. Inject t s => t -> s
inject Coin
c)
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
              if Coin
c forall a. Ord a => a -> a -> Bool
< forall t. Val t => t -> Coin
coin Value era
v
                then
                  let !change :: TxOut era
change = forall era. Proof era -> [TxOutField era] -> TxOut era
coreTxOut forall era. Reflect era => Proof era
reify (forall era. Addr -> TxOutField era
Address Addr
addr forall a. a -> [a] -> [a]
: forall era. Value era -> TxOutField era
Amount (Value era
v forall t. Val t => t -> t -> t
<-> forall t s. Inject t s => t -> s
inject Coin
c) forall a. a -> [a] -> [a]
: [TxOutField era]
ds)
                   in forall era. Proof era -> [TxOutField era] -> TxOut era
coreTxOut forall era. Reflect era => Proof era
reify [TxOutField era]
fields forall a. a -> [a] -> [a]
: TxOut era
change forall a. a -> [a] -> [a]
: [TxOut era]
rs
                else forall era. Proof era -> [TxOutField era] -> TxOut era
coreTxOut forall era. Reflect era => Proof era
reify [TxOutField era]
fields forall a. a -> [a] -> [a]
: [TxOut era]
rs
  Int -> [TxOut era] -> [TxOut era] -> GenRS era [TxOut era]
goNew Int
extra [TxOut era]
txOuts []

getTxCertCredential ::
  forall era. Reflect era => TxCert era -> Maybe (Credential 'Staking)
getTxCertCredential :: forall era. Reflect era => TxCert era -> Maybe StakeCredential
getTxCertCredential = case forall era. Reflect era => Proof era
reify @era of
  Proof era
Shelley -> forall era. ShelleyTxCert era -> Maybe StakeCredential
getShelleyTxCertCredential
  Proof era
Mary -> forall era. ShelleyTxCert era -> Maybe StakeCredential
getShelleyTxCertCredential
  Proof era
Allegra -> forall era. ShelleyTxCert era -> Maybe StakeCredential
getShelleyTxCertCredential
  Proof era
Alonzo -> forall era. ShelleyTxCert era -> Maybe StakeCredential
getShelleyTxCertCredential
  Proof era
Babbage -> forall era. ShelleyTxCert era -> Maybe StakeCredential
getShelleyTxCertCredential
  Proof era
Conway -> forall era. ConwayTxCert era -> Maybe StakeCredential
getConwayTxCertCredential

getShelleyTxCertCredential :: ShelleyTxCert era -> Maybe (Credential 'Staking)
getShelleyTxCertCredential :: forall era. ShelleyTxCert era -> Maybe StakeCredential
getShelleyTxCertCredential = \case
  ShelleyTxCertDelegCert ShelleyDelegCert
d ->
    case ShelleyDelegCert
d of
      ShelleyRegCert StakeCredential
_rk -> forall a. Maybe a
Nothing -- we don't require witnesses for ShelleyRegCert
      ShelleyUnRegCert StakeCredential
drk -> forall a. a -> Maybe a
Just StakeCredential
drk
      ShelleyDelegCert StakeCredential
dk KeyHash 'StakePool
_ -> forall a. a -> Maybe a
Just StakeCredential
dk
  ShelleyTxCertPool PoolCert
pc ->
    case PoolCert
pc of
      RegPool PoolParams {Set (KeyHash 'Staking)
VRFVerKeyHash 'StakePoolVRF
KeyHash 'StakePool
StrictMaybe PoolMetadata
Coin
RewardAccount
StrictSeq StakePoolRelay
UnitInterval
ppId :: PoolParams -> KeyHash 'StakePool
ppVrf :: PoolParams -> VRFVerKeyHash 'StakePoolVRF
ppPledge :: PoolParams -> Coin
ppCost :: PoolParams -> Coin
ppMargin :: PoolParams -> UnitInterval
ppRewardAccount :: PoolParams -> RewardAccount
ppOwners :: PoolParams -> Set (KeyHash 'Staking)
ppRelays :: PoolParams -> StrictSeq StakePoolRelay
ppMetadata :: PoolParams -> StrictMaybe PoolMetadata
ppMetadata :: StrictMaybe PoolMetadata
ppRelays :: StrictSeq StakePoolRelay
ppOwners :: Set (KeyHash 'Staking)
ppRewardAccount :: RewardAccount
ppMargin :: UnitInterval
ppCost :: Coin
ppPledge :: Coin
ppVrf :: VRFVerKeyHash 'StakePoolVRF
ppId :: KeyHash 'StakePool
..} -> forall a. a -> Maybe a
Just 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
$ forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'StakePool
ppId
      RetirePool KeyHash 'StakePool
kh EpochNo
_ -> forall a. a -> Maybe a
Just 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
$ forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'StakePool
kh
  ShelleyTxCertGenesisDeleg GenesisDelegCert
_g -> forall a. Maybe a
Nothing
  ShelleyTxCertMir MIRCert
_m -> forall a. Maybe a
Nothing

getConwayTxCertCredential :: ConwayTxCert era -> Maybe (Credential 'Staking)
getConwayTxCertCredential :: forall era. ConwayTxCert era -> Maybe StakeCredential
getConwayTxCertCredential (ConwayTxCertPool (RegPool PoolParams {Set (KeyHash 'Staking)
VRFVerKeyHash 'StakePoolVRF
KeyHash 'StakePool
StrictMaybe PoolMetadata
Coin
RewardAccount
StrictSeq StakePoolRelay
UnitInterval
ppMetadata :: StrictMaybe PoolMetadata
ppRelays :: StrictSeq StakePoolRelay
ppOwners :: Set (KeyHash 'Staking)
ppRewardAccount :: RewardAccount
ppMargin :: UnitInterval
ppCost :: Coin
ppPledge :: Coin
ppVrf :: VRFVerKeyHash 'StakePoolVRF
ppId :: KeyHash 'StakePool
ppId :: PoolParams -> KeyHash 'StakePool
ppVrf :: PoolParams -> VRFVerKeyHash 'StakePoolVRF
ppPledge :: PoolParams -> Coin
ppCost :: PoolParams -> Coin
ppMargin :: PoolParams -> UnitInterval
ppRewardAccount :: PoolParams -> RewardAccount
ppOwners :: PoolParams -> Set (KeyHash 'Staking)
ppRelays :: PoolParams -> StrictSeq StakePoolRelay
ppMetadata :: PoolParams -> StrictMaybe PoolMetadata
..})) = forall a. a -> Maybe a
Just 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
$ forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'StakePool
ppId
getConwayTxCertCredential (ConwayTxCertPool (RetirePool KeyHash 'StakePool
kh EpochNo
_)) = forall a. a -> Maybe a
Just 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
$ forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'StakePool
kh
getConwayTxCertCredential (ConwayTxCertDeleg (ConwayRegCert StakeCredential
_ StrictMaybe Coin
_)) = forall a. Maybe a
Nothing
getConwayTxCertCredential (ConwayTxCertDeleg (ConwayUnRegCert StakeCredential
cred StrictMaybe Coin
_)) = forall a. a -> Maybe a
Just StakeCredential
cred
getConwayTxCertCredential (ConwayTxCertDeleg (ConwayDelegCert StakeCredential
cred Delegatee
_)) = forall a. a -> Maybe a
Just StakeCredential
cred
getConwayTxCertCredential (ConwayTxCertDeleg (ConwayRegDelegCert StakeCredential
cred Delegatee
_ Coin
_)) = forall a. a -> Maybe a
Just StakeCredential
cred
getConwayTxCertCredential (ConwayTxCertGov ConwayGovCert
_) = forall a. Maybe a
Nothing

genWithdrawals ::
  Reflect era => SlotNo -> GenRS era (Withdrawals, RewardAccounts)
genWithdrawals :: forall era.
Reflect era =>
SlotNo -> GenRS era (Withdrawals, Map StakeCredential Coin)
genWithdrawals SlotNo
slot =
  if SlotNo -> EpochNo
epochFromSlotNo SlotNo
slot forall a. Eq a => a -> a -> Bool
== Word64 -> EpochNo
EpochNo Word64
0
    then do
      let networkId :: Network
networkId = Network
Testnet
      Map StakeCredential Coin
newRewards <- forall era. Reflect era => GenRS era (Map StakeCredential Coin)
genRewards
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map RewardAccount Coin -> Withdrawals
Withdrawals forall a b. (a -> b) -> a -> b
$ forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys (Network -> StakeCredential -> RewardAccount
RewardAccount Network
networkId) Map StakeCredential Coin
newRewards, Map StakeCredential Coin
newRewards)
    else forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map RewardAccount Coin -> Withdrawals
Withdrawals forall k a. Map k a
Map.empty, forall k a. Map k a
Map.empty)

timeToLive :: ValidityInterval -> SlotNo
timeToLive :: ValidityInterval -> SlotNo
timeToLive (ValidityInterval StrictMaybe SlotNo
_ (SJust SlotNo
n)) = SlotNo
n
timeToLive (ValidityInterval StrictMaybe SlotNo
_ StrictMaybe SlotNo
SNothing) = Word64 -> SlotNo
SlotNo forall a. Bounded a => a
maxBound

-- ============================================================================

minus :: MUtxo era -> Maybe (UtxoEntry era) -> MUtxo era
minus :: forall era. MUtxo era -> Maybe (UtxoEntry era) -> MUtxo era
minus MUtxo era
m Maybe (UtxoEntry era)
Nothing = MUtxo era
m
minus MUtxo era
m (Just (TxIn
txin, TxOut era
_)) = forall k a. Ord k => k -> Map k a -> Map k a
Map.delete TxIn
txin MUtxo era
m

genAlonzoTx :: forall era. Reflect era => Proof era -> SlotNo -> GenRS era (UTxO era, Tx era)
genAlonzoTx :: forall era.
Reflect era =>
Proof era -> SlotNo -> GenRS era (UTxO era, Tx era)
genAlonzoTx Proof era
proof SlotNo
slot = do
  (UTxO era
utxo, Tx era
tx, (TxIn, TxOut era)
_fee, Maybe (TxIn, TxOut era)
_old) <- forall era.
Reflect era =>
Proof era
-> SlotNo
-> GenRS
     era (UTxO era, Tx era, UtxoEntry era, Maybe (UtxoEntry era))
genAlonzoTxAndInfo Proof era
proof SlotNo
slot
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTxO era
utxo, Tx era
tx)

genAlonzoTxAndInfo ::
  forall era.
  Reflect era =>
  Proof era ->
  SlotNo ->
  GenRS
    era
    ( UTxO era
    , Tx era
    , UtxoEntry era -- The fee key
    , Maybe (UtxoEntry era) -- from oldUtxO
    )
genAlonzoTxAndInfo :: forall era.
Reflect era =>
Proof era
-> SlotNo
-> GenRS
     era (UTxO era, Tx era, UtxoEntry era, Maybe (UtxoEntry era))
genAlonzoTxAndInfo Proof era
proof SlotNo
slot = do
  GenEnv {PParams era
gePParams :: PParams era
gePParams :: forall era. GenEnv era -> PParams era
gePParams} <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets forall era. GenState era -> GenEnv era
gsGenEnv
  ValidityInterval
validityInterval <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ SlotNo -> Gen ValidityInterval
genValidityInterval SlotNo
slot
  forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
(s -> s) -> RWST r w s m ()
modify (\GenState era
gs -> GenState era
gs {gsValidityInterval :: ValidityInterval
gsValidityInterval = ValidityInterval
validityInterval})

  -- 1. Produce utxos that will be spent
  (Map TxIn (TxOut era)
utxoChoices, Maybe (UtxoEntry era)
maybeoldpair) <- forall era.
Reflect era =>
GenRS era (MUtxo era, Maybe (UtxoEntry era))
genUTxO

  -- 2. Generate UTxO for spending and reference inputs
  --    Note the spending inputs and the reference inputs may overlap.
  --    feeKey is one of the inputs from the spending inputs, safe to pay the fee with.
  ( feepair :: UtxoEntry era
feepair@(TxIn
feeKey, TxOut era
_) -- One of the spending inputs, to be used to pay the fee
    , Map TxIn (TxOut era)
toSpendNoCollateral -- All of the spending inputs
    , Map TxIn (TxOut era)
refInputsUtxo -- All the reference inputs
    , Map TxIn (TxOut era)
utxoNoCollateral -- Union of all the above
    ) <-
    forall era.
Map TxIn (TxOut era)
-> GenRS
     era
     (UtxoEntry era, Map TxIn (TxOut era), Map TxIn (TxOut era),
      Map TxIn (TxOut era))
genSpendReferenceInputs Map TxIn (TxOut era)
utxoChoices

  -- 3. Check if all Plutus scripts are valid
  let toSpendNoCollateralTxOuts :: [TxOut era]
      toSpendNoCollateralTxOuts :: [TxOut era]
toSpendNoCollateralTxOuts = forall k a. Map k a -> [a]
Map.elems Map TxIn (TxOut era)
toSpendNoCollateral
      -- We use maxBound to ensure the serialized size overestimation
      maxCoin :: Coin
maxCoin = Integer -> Coin
Coin (forall a. Integral a => a -> Integer
toInteger (forall a. Bounded a => a
maxBound :: Int))
  -- 4. Generate all recipients and witnesses needed for spending Plutus scripts
  [TxOut era]
recipients <- forall era. Reflect era => [TxOut era] -> GenRS era [TxOut era]
genRecipientsFrom [TxOut era]
toSpendNoCollateralTxOuts

  --  mkPaymentWits :: ExUnits -> [WitnessesField era]
  (IsValid Bool
v1, [ExUnits -> [WitnessesField era]]
mkPaymentWits) <-
    forall era (k :: KeyRole).
Proof era
-> PlutusPurposeTag
-> [Maybe (GenRS era (Data era), Credential k)]
-> GenRS era (IsValid, [ExUnits -> [WitnessesField era]])
redeemerWitnessMaker
      Proof era
proof
      PlutusPurposeTag
Spending
      [ (\DataHash
dh PaymentCredential
cred -> (forall k era v.
(Ord k, Show k, HasCallStack) =>
String -> k -> (GenState era -> Map k v) -> GenRS era v
lookupByKeyM String
"datum" DataHash
dh forall era. GenState era -> Map DataHash (Data era)
gsDatums, PaymentCredential
cred))
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe DataHash
mDatumHash
          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. a -> Maybe a
Just PaymentCredential
credential
      | (TxIn
_, TxOut era
coretxout) <- forall k a. Map k a -> [(k, a)]
Map.toAscList Map TxIn (TxOut era)
toSpendNoCollateral
      , let ([PaymentCredential]
credentials, Maybe DataHash
mDatumHash) = forall era.
Proof era -> TxOut era -> ([PaymentCredential], Maybe DataHash)
txoutEvidence Proof era
proof TxOut era
coretxout
      , PaymentCredential
credential <- [PaymentCredential]
credentials
      ]

  -- generate Withdrawals before TxCerts, as Rewards are populated in the Model here,
  -- and we need to avoid certain TxCerts if they conflict with existing Rewards
  (withdrawals :: Withdrawals
withdrawals@(Withdrawals Map RewardAccount Coin
wdrlMap), Map StakeCredential Coin
newRewards) <- forall era.
Reflect era =>
SlotNo -> GenRS era (Withdrawals, Map StakeCredential Coin)
genWithdrawals SlotNo
slot
  let withdrawalAmount :: Coin
withdrawalAmount = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
F.fold Map RewardAccount Coin
wdrlMap

  Maybe (TxOut era)
rewardsWithdrawalTxOut <-
    if Coin
withdrawalAmount forall a. Eq a => a -> a -> Bool
== Integer -> Coin
Coin Integer
0
      then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
      else forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Proof era -> [TxOutField era] -> TxOut era
coreTxOut Proof era
proof forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
Reflect era =>
Proof era -> Value era -> GenRS era [TxOutField era]
genTxOut Proof era
proof (forall t s. Inject t s => t -> s
inject Coin
withdrawalAmount)
  let wdrlCreds :: [StakeCredential]
wdrlCreds = forall a b. (a -> b) -> [a] -> [b]
map (RewardAccount -> StakeCredential
raCredential forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toAscList Map RewardAccount Coin
wdrlMap
  (IsValid Bool
v2, [ExUnits -> [WitnessesField era]]
mkWithdrawalsWits) <-
    forall era (k :: KeyRole).
Proof era
-> PlutusPurposeTag
-> [Maybe (GenRS era (Data era), Credential k)]
-> GenRS era (IsValid, [ExUnits -> [WitnessesField era]])
redeemerWitnessMaker Proof era
proof PlutusPurposeTag
Rewarding forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) forall era. Era era => GenRS era (Data era)
genDatum) [StakeCredential]
wdrlCreds

  [TxCert era]
dcerts <- forall era. Reflect era => SlotNo -> GenRS era [TxCert era]
genTxCerts SlotNo
slot
  let dcertCreds :: [Maybe StakeCredential]
dcertCreds = forall a b. (a -> b) -> [a] -> [b]
map forall era. Reflect era => TxCert era -> Maybe StakeCredential
getTxCertCredential [TxCert era]
dcerts
  (IsValid Bool
v3, [ExUnits -> [WitnessesField era]]
mkCertsWits) <-
    forall era (k :: KeyRole).
Proof era
-> PlutusPurposeTag
-> [Maybe (GenRS era (Data era), Credential k)]
-> GenRS era (IsValid, [ExUnits -> [WitnessesField era]])
redeemerWitnessMaker Proof era
proof PlutusPurposeTag
Certifying forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ((,) forall era. Era era => GenRS era (Data era)
genDatum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) [Maybe StakeCredential]
dcertCreds

  let isValid :: IsValid
isValid = Bool -> IsValid
IsValid (Bool
v1 Bool -> Bool -> Bool
&& Bool
v2 Bool -> Bool -> Bool
&& Bool
v3)
      mkWits :: [ExUnits -> [WitnessesField era]]
      mkWits :: [ExUnits -> [WitnessesField era]]
mkWits = [ExUnits -> [WitnessesField era]]
mkPaymentWits forall a. [a] -> [a] -> [a]
++ [ExUnits -> [WitnessesField era]]
mkCertsWits forall a. [a] -> [a] -> [a]
++ [ExUnits -> [WitnessesField era]]
mkWithdrawalsWits
  [ExUnits]
exUnits <- forall era. Proof era -> Int -> GenRS era [ExUnits]
genExUnits Proof era
proof (forall (t :: * -> *) a. Foldable t => t a -> Int
length [ExUnits -> [WitnessesField era]]
mkWits)

  let redeemerWitsList :: [WitnessesField era]
      redeemerWitsList :: [WitnessesField era]
redeemerWitsList = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a b. (a -> b) -> a -> b
($) [ExUnits -> [WitnessesField era]]
mkWits [ExUnits]
exUnits)
  [WitnessesField era]
datumWitsList <- forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall era.
Proof era -> TxOut era -> GenRS era [WitnessesField era]
makeDatumWitness Proof era
proof) (forall k a. Map k a -> [a]
Map.elems Map TxIn (TxOut era)
toSpendNoCollateral)
  [SafeHash EraIndependentTxBody -> [WitnessesField era]]
keyWitsMakers <-
    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
      (forall era.
Reflect era =>
Proof era
-> Maybe PlutusPurposeTag
-> TxOut era
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
genTxOutKeyWitness Proof era
proof (forall a. a -> Maybe a
Just PlutusPurposeTag
Spending))
      ([TxOut era]
toSpendNoCollateralTxOuts forall a. [a] -> [a] -> [a]
++ forall k a. Map k a -> [a]
Map.elems Map TxIn (TxOut era)
refInputsUtxo)
  [SafeHash EraIndependentTxBody -> [WitnessesField era]]
dcertWitsMakers <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall era (kr :: KeyRole).
Reflect era =>
Proof era
-> Maybe PlutusPurposeTag
-> Credential kr
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
genCredKeyWit Proof era
proof (forall a. a -> Maybe a
Just PlutusPurposeTag
Certifying)) forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes [Maybe StakeCredential]
dcertCreds
  [SafeHash EraIndependentTxBody -> [WitnessesField era]]
rwdrsWitsMakers <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall era (kr :: KeyRole).
Reflect era =>
Proof era
-> Maybe PlutusPurposeTag
-> Credential kr
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
genCredKeyWit Proof era
proof (forall a. a -> Maybe a
Just PlutusPurposeTag
Rewarding)) [StakeCredential]
wdrlCreds

  -- 5. Estimate inputs that will be used as collateral
  Int
maxCollateralCount <-
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Gen Int
chooseInt (Int
1, forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall era. Proof era -> PParams era -> Natural
maxCollateralInputs' Proof era
proof PParams era
gePParams))
  TxId
bogusCollateralTxId <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a. Arbitrary a => Gen a
arbitrary :: Gen TxId)
  let bogusCollateralTxIns :: Set TxIn
bogusCollateralTxIns =
        forall a. Ord a => [a] -> Set a
Set.fromList
          [ TxId -> TxIx -> TxIn
TxIn TxId
bogusCollateralTxId (HasCallStack => Integer -> TxIx
mkTxIxPartial (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
i))
          | Word16
i <- [forall a. Bounded a => a
maxBound, forall a. Bounded a => a
maxBound forall a. Num a => a -> a -> a
- Word16
1 .. forall a. Bounded a => a
maxBound forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
maxCollateralCount forall a. Num a => a -> a -> a
- Word16
1] :: [Word16]
          ]
  [Addr]
collateralAddresses <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
maxCollateralCount forall era. GenRS era Addr
genNoScriptRecipient
  [SafeHash EraIndependentTxBody -> [WitnessesField era]]
bogusCollateralKeyWitsMakers <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Addr]
collateralAddresses forall a b. (a -> b) -> a -> b
$ \Addr
a ->
    forall era.
Reflect era =>
Proof era
-> Maybe PlutusPurposeTag
-> TxOut era
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
genTxOutKeyWitness Proof era
proof forall a. Maybe a
Nothing (forall era. Proof era -> [TxOutField era] -> TxOut era
coreTxOut Proof era
proof [forall era. Addr -> TxOutField era
Address Addr
a, forall era. Value era -> TxOutField era
Amount (forall t s. Inject t s => t -> s
inject Coin
maxCoin)])
  StrictMaybe Network
networkId <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => [a] -> Gen a
elements [forall a. StrictMaybe a
SNothing, forall a. a -> StrictMaybe a
SJust Network
Testnet]

  -- 6. Generate bogus collateral fields, and functions for updating them when we know their real values
  -- Add a stub for the TotalCol field
  StrictMaybe Coin
bogusTotalCol <- forall (t :: (* -> *) -> * -> *) b.
(Monad (t Gen), MonadTrans t) =>
[(Int, t Gen b)] -> t Gen b
frequencyT [(Int
1, forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. StrictMaybe a
SNothing), (Int
9, forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> StrictMaybe a
SJust (Integer -> Coin
Coin Integer
0)))] -- generate a bogus Coin, fill it in later
  let updateTotalColl :: StrictMaybe Coin -> Coin -> StrictMaybe Coin
updateTotalColl StrictMaybe Coin
SNothing Coin
_ = forall a. StrictMaybe a
SNothing
      updateTotalColl (SJust (Coin Integer
n)) (Coin Integer
m) = forall a. a -> StrictMaybe a
SJust (Integer -> Coin
Coin (Integer
n forall a. Num a => a -> a -> a
+ Integer
m))
  -- If Babbage era, or greater, add a stub for a CollateralReturn TxOut
  StrictMaybe (TxOut era)
bogusCollReturn <-
    if forall {k} (t :: k -> *) (i :: k). Singleton t => t i -> Some t
Some Proof era
proof forall a. Ord a => a -> a -> Bool
>= forall {k} (t :: k -> *) (i :: k). Singleton t => t i -> Some t
Some Proof BabbageEra
Babbage
      then
        forall (t :: (* -> *) -> * -> *) b.
(Monad (t Gen), MonadTrans t) =>
[(Int, t Gen b)] -> t Gen b
frequencyT
          [ (Int
1, forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. StrictMaybe a
SNothing)
          , (Int
9, forall a. a -> StrictMaybe a
SJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Proof era -> [TxOutField era] -> TxOut era
coreTxOut Proof era
proof forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
Reflect era =>
Proof era -> Value era -> GenRS era [TxOutField era]
genTxOut Proof era
proof (forall t s. Inject t s => t -> s
inject (Integer -> Coin
Coin Integer
0)))
          ]
      else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. StrictMaybe a
SNothing
  let updateCollReturn :: StrictMaybe (TxOut era) -> Coin -> StrictMaybe (TxOut era)
updateCollReturn StrictMaybe (TxOut era)
SNothing Coin
_ = forall a. StrictMaybe a
SNothing
      updateCollReturn (SJust TxOut era
txout) Coin
v = forall a. a -> StrictMaybe a
SJust (forall era.
EraTxOut era =>
Proof era -> Coin -> TxOut era -> TxOut era
injectFee Proof era
proof Coin
v TxOut era
txout)

  -- 7. Estimate the fee
  let redeemerDatumWits :: [WitnessesField era]
redeemerDatumWits = [WitnessesField era]
redeemerWitsList forall a. [a] -> [a] -> [a]
++ [WitnessesField era]
datumWitsList
      bogusIntegrityHash :: StrictMaybe ScriptIntegrityHash
bogusIntegrityHash = forall era.
Proof era
-> PParams era
-> [Language]
-> Redeemers era
-> TxDats era
-> StrictMaybe ScriptIntegrityHash
newScriptIntegrityHash Proof era
proof PParams era
gePParams forall a. Monoid a => a
mempty (forall era.
Proof era
-> [(PlutusPurpose AsIx era, (Data era, ExUnits))] -> Redeemers era
mkRedeemers Proof era
proof []) forall a. Monoid a => a
mempty
      inputSet :: Set TxIn
inputSet = forall k a. Map k a -> Set k
Map.keysSet Map TxIn (TxOut era)
toSpendNoCollateral
      outputList :: [TxOut era]
outputList = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [TxOut era]
recipients (forall a. a -> [a] -> [a]
: [TxOut era]
recipients) Maybe (TxOut era)
rewardsWithdrawalTxOut
      txBodyNoFee :: TxBody era
txBodyNoFee =
        forall era.
EraTxBody era =>
Proof era -> [TxBodyField era] -> TxBody era
coreTxBody
          Proof era
proof
          [ forall era. Set TxIn -> TxBodyField era
Inputs Set TxIn
inputSet
          , forall era. Set TxIn -> TxBodyField era
Collateral Set TxIn
bogusCollateralTxIns
          , forall era. Set TxIn -> TxBodyField era
RefInputs (forall k a. Map k a -> Set k
Map.keysSet Map TxIn (TxOut era)
refInputsUtxo)
          , forall era. StrictMaybe Coin -> TxBodyField era
TotalCol StrictMaybe Coin
bogusTotalCol
          , forall era. [TxOut era] -> TxBodyField era
Outputs' [TxOut era]
outputList
          , forall era. StrictMaybe (TxOut era) -> TxBodyField era
CollateralReturn StrictMaybe (TxOut era)
bogusCollReturn
          , forall era. [TxCert era] -> TxBodyField era
Certs' [TxCert era]
dcerts
          , forall era. Withdrawals -> TxBodyField era
Withdrawals' Withdrawals
withdrawals
          , forall era. Coin -> TxBodyField era
Txfee Coin
maxCoin
          , if forall {k} (t :: k -> *) (i :: k). Singleton t => t i -> Some t
Some Proof era
proof forall a. Ord a => a -> a -> Bool
>= forall {k} (t :: k -> *) (i :: k). Singleton t => t i -> Some t
Some Proof AllegraEra
Allegra
              then forall era. ValidityInterval -> TxBodyField era
Vldt ValidityInterval
validityInterval
              else forall era. SlotNo -> TxBodyField era
TTL (ValidityInterval -> SlotNo
timeToLive ValidityInterval
validityInterval)
          , forall era. [Update era] -> TxBodyField era
Update' []
          , forall era. [KeyHash 'Witness] -> TxBodyField era
ReqSignerHashes' []
          , forall era. MultiAsset -> TxBodyField era
Generic.Mint forall a. Monoid a => a
mempty
          , forall era. StrictMaybe ScriptIntegrityHash -> TxBodyField era
WppHash StrictMaybe ScriptIntegrityHash
bogusIntegrityHash
          , forall era. [TxAuxDataHash] -> TxBodyField era
AdHash' []
          , forall era. StrictMaybe Network -> TxBodyField era
Txnetworkid StrictMaybe Network
networkId
          ]
      txBodyNoFeeHash :: SafeHash EraIndependentTxBody
txBodyNoFeeHash = forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated TxBody era
txBodyNoFee
      witsMakers :: [SafeHash EraIndependentTxBody -> [WitnessesField era]]
      witsMakers :: [SafeHash EraIndependentTxBody -> [WitnessesField era]]
witsMakers = [SafeHash EraIndependentTxBody -> [WitnessesField era]]
keyWitsMakers forall a. [a] -> [a] -> [a]
++ [SafeHash EraIndependentTxBody -> [WitnessesField era]]
dcertWitsMakers forall a. [a] -> [a] -> [a]
++ [SafeHash EraIndependentTxBody -> [WitnessesField era]]
rwdrsWitsMakers
      bogusNeededScripts :: Set ScriptHash
bogusNeededScripts = forall era. Proof era -> MUtxo era -> TxBody era -> Set ScriptHash
scriptWitsNeeded' Proof era
proof Map TxIn (TxOut era)
utxoNoCollateral TxBody era
txBodyNoFee
      noFeeWits :: [WitnessesField era]
      noFeeWits :: [WitnessesField era]
noFeeWits =
        forall era.
Proof era
-> Set ScriptHash -> [WitnessesField era] -> [WitnessesField era]
onlyNecessaryScripts Proof era
proof Set ScriptHash
bogusNeededScripts forall a b. (a -> b) -> a -> b
$
          [WitnessesField era]
redeemerDatumWits
            forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a b. (a -> b) -> a -> b
$ SafeHash EraIndependentTxBody
txBodyNoFeeHash) ([SafeHash EraIndependentTxBody -> [WitnessesField era]]
witsMakers forall a. [a] -> [a] -> [a]
++ [SafeHash EraIndependentTxBody -> [WitnessesField era]]
bogusCollateralKeyWitsMakers)
      bogusTxForFeeCalc :: Tx era
bogusTxForFeeCalc =
        forall era. Proof era -> [TxField era] -> Tx era
coreTx
          Proof era
proof
          [ forall era. TxBody era -> TxField era
Body TxBody era
txBodyNoFee
          , forall era. TxWits era -> TxField era
TxWits (forall era. Proof era -> [WitnessesField era] -> TxWits era
assembleWits Proof era
proof [WitnessesField era]
noFeeWits)
          , forall era. IsValid -> TxField era
Valid IsValid
isValid
          , forall era. [TxAuxData era] -> TxField era
AuxData' []
          ]
      fee :: Coin
fee = forall era.
EraUTxO era =>
PParams era -> Tx era -> UTxO era -> Coin
getMinFeeTxUtxo PParams era
gePParams Tx era
bogusTxForFeeCalc (forall era. Map TxIn (TxOut era) -> UTxO era
UTxO Map TxIn (TxOut era)
refInputsUtxo)

  Map StakeCredential Coin
keyDeposits <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets (forall era. ModelNewEpochState era -> Map StakeCredential Coin
mKeyDeposits forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenState era -> ModelNewEpochState era
gsModel)
  let deposits :: Coin
deposits = case Proof era
proof of
        Proof era
Shelley -> forall era.
(EraPParams era, ShelleyEraTxCert era) =>
PParams era -> [TxCert era] -> Map StakeCredential Coin -> Coin
depositsAndRefunds PParams era
gePParams [TxCert era]
dcerts Map StakeCredential Coin
keyDeposits
        Proof era
Mary -> forall era.
(EraPParams era, ShelleyEraTxCert era) =>
PParams era -> [TxCert era] -> Map StakeCredential Coin -> Coin
depositsAndRefunds PParams era
gePParams [TxCert era]
dcerts Map StakeCredential Coin
keyDeposits
        Proof era
Allegra -> forall era.
(EraPParams era, ShelleyEraTxCert era) =>
PParams era -> [TxCert era] -> Map StakeCredential Coin -> Coin
depositsAndRefunds PParams era
gePParams [TxCert era]
dcerts Map StakeCredential Coin
keyDeposits
        Proof era
Alonzo -> forall era.
(EraPParams era, ShelleyEraTxCert era) =>
PParams era -> [TxCert era] -> Map StakeCredential Coin -> Coin
depositsAndRefunds PParams era
gePParams [TxCert era]
dcerts Map StakeCredential Coin
keyDeposits
        Proof era
Babbage -> forall era.
(EraPParams era, ShelleyEraTxCert era) =>
PParams era -> [TxCert era] -> Map StakeCredential Coin -> Coin
depositsAndRefunds PParams era
gePParams [TxCert era]
dcerts Map StakeCredential Coin
keyDeposits
        Proof era
Conway -> forall era.
(EraPParams era, ShelleyEraTxCert era) =>
PParams era -> [TxCert era] -> Map StakeCredential Coin -> Coin
depositsAndRefunds PParams era
gePParams [TxCert era]
dcerts Map StakeCredential Coin
keyDeposits

  -- 8. Crank up the amount in one of outputs to account for the fee and deposits. Note
  -- this is a hack that is not possible in a real life, but in the end it does produce
  -- real life like setup. We use the entry with TxIn feeKey, which we can safely overwrite.
  let utxoFeeAdjusted :: Map TxIn (TxOut era)
utxoFeeAdjusted = forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (forall era.
EraTxOut era =>
Proof era -> Coin -> TxOut era -> TxOut era
injectFee Proof era
proof (Coin
fee forall t. Val t => t -> t -> t
<+> Coin
deposits)) TxIn
feeKey Map TxIn (TxOut era)
utxoNoCollateral

  -- 9. Generate utxos that will be used as collateral
  (Map TxIn (TxOut era)
utxo, Map TxIn (TxOut era)
collMap, Coin
excessColCoin) <- forall era.
(HasCallStack, Reflect era) =>
[Addr]
-> Coin -> MUtxo era -> GenRS era (MUtxo era, MUtxo era, Coin)
genCollateralUTxO [Addr]
collateralAddresses Coin
fee Map TxIn (TxOut era)
utxoFeeAdjusted
  [SafeHash EraIndependentTxBody -> [WitnessesField era]]
collateralKeyWitsMakers <-
    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall era.
Reflect era =>
Proof era
-> Maybe PlutusPurposeTag
-> TxOut era
-> GenRS
     era (SafeHash EraIndependentTxBody -> [WitnessesField era])
genTxOutKeyWitness Proof era
proof forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems Map TxIn (TxOut era)
collMap

  -- 10. Construct the correct Tx with valid fee and collaterals
  let sNeeded :: Set ScriptHash
sNeeded = forall era. Proof era -> MUtxo era -> TxBody era -> Set ScriptHash
scriptsNeeded' Proof era
proof Map TxIn (TxOut era)
utxo TxBody era
txBodyNoFee
      langs :: [Language]
langs = forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ forall era.
Proof era -> Tx era -> UTxO era -> Set ScriptHash -> Set Language
languagesUsed Proof era
proof Tx era
bogusTxForFeeCalc (forall era. Map TxIn (TxOut era) -> UTxO era
UTxO Map TxIn (TxOut era)
utxoNoCollateral) Set ScriptHash
sNeeded
      mIntegrityHash :: StrictMaybe ScriptIntegrityHash
mIntegrityHash =
        forall era.
Proof era
-> PParams era
-> [Language]
-> Redeemers era
-> TxDats era
-> StrictMaybe ScriptIntegrityHash
newScriptIntegrityHash
          Proof era
proof
          PParams era
gePParams
          [Language]
langs
          (forall era. Proof era -> [WitnessesField era] -> Redeemers era
mkTxrdmrs Proof era
proof [WitnessesField era]
redeemerDatumWits)
          (forall era. Era era => [WitnessesField era] -> TxDats era
mkTxdats [WitnessesField era]
redeemerDatumWits)
      balance :: Coin
balance =
        case StrictMaybe (TxOut era)
bogusCollReturn of
          StrictMaybe (TxOut era)
SNothing -> forall era. EraTxOut era => Set TxIn -> MUtxo era -> Coin
txInBalance (forall k a. Map k a -> Set k
Map.keysSet Map TxIn (TxOut era)
collMap) Map TxIn (TxOut era)
utxo
          SJust TxOut era
_ -> forall era. EraTxOut era => Set TxIn -> MUtxo era -> Coin
txInBalance (forall k a. Map k a -> Set k
Map.keysSet Map TxIn (TxOut era)
collMap) Map TxIn (TxOut era)
utxo forall t. Val t => t -> t -> t
<-> Coin
excessColCoin
      txBody :: TxBody era
txBody =
        forall era.
EraTxBody era =>
Proof era -> TxBody era -> [TxBodyField era] -> TxBody era
overrideTxBody
          Proof era
proof
          TxBody era
txBodyNoFee
          [ forall era. Coin -> TxBodyField era
Txfee Coin
fee
          , forall era. Set TxIn -> TxBodyField era
Collateral (forall k a. Map k a -> Set k
Map.keysSet Map TxIn (TxOut era)
collMap)
          , forall era. StrictMaybe (TxOut era) -> TxBodyField era
CollateralReturn (StrictMaybe (TxOut era) -> Coin -> StrictMaybe (TxOut era)
updateCollReturn StrictMaybe (TxOut era)
bogusCollReturn Coin
excessColCoin)
          , forall era. StrictMaybe Coin -> TxBodyField era
TotalCol (StrictMaybe Coin -> Coin -> StrictMaybe Coin
updateTotalColl StrictMaybe Coin
bogusTotalCol Coin
balance)
          , forall era. StrictMaybe ScriptIntegrityHash -> TxBodyField era
WppHash StrictMaybe ScriptIntegrityHash
mIntegrityHash
          ]
      txBodyHash :: SafeHash EraIndependentTxBody
txBodyHash = forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated TxBody era
txBody
      neededScripts :: Set ScriptHash
neededScripts = forall era. Proof era -> MUtxo era -> TxBody era -> Set ScriptHash
scriptWitsNeeded' Proof era
proof Map TxIn (TxOut era)
utxo TxBody era
txBody
      wits :: [WitnessesField era]
wits =
        forall era.
Proof era
-> Set ScriptHash -> [WitnessesField era] -> [WitnessesField era]
onlyNecessaryScripts Proof era
proof Set ScriptHash
neededScripts forall a b. (a -> b) -> a -> b
$
          [WitnessesField era]
redeemerDatumWits
            forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a b. (a -> b) -> a -> b
$ SafeHash EraIndependentTxBody
txBodyHash) ([SafeHash EraIndependentTxBody -> [WitnessesField era]]
witsMakers forall a. [a] -> [a] -> [a]
++ [SafeHash EraIndependentTxBody -> [WitnessesField era]]
collateralKeyWitsMakers)
      validTx :: Tx era
validTx =
        forall era. Proof era -> [TxField era] -> Tx era
coreTx
          Proof era
proof
          [ forall era. TxBody era -> TxField era
Body TxBody era
txBody
          , forall era. TxWits era -> TxField era
TxWits (forall era. Proof era -> [WitnessesField era] -> TxWits era
assembleWits Proof era
proof [WitnessesField era]
wits)
          , forall era. IsValid -> TxField era
Valid IsValid
isValid
          , forall era. [TxAuxData era] -> TxField era
AuxData' []
          ]
  Int
count <- forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
gets (forall era. ModelNewEpochState era -> Int
mCount forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GenState era -> ModelNewEpochState era
gsModel)
  forall era.
(Map StakeCredential Coin -> Map StakeCredential Coin)
-> GenRS era ()
modifyGenStateInitialRewards (forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Map StakeCredential Coin
newRewards)
  forall era.
(Map TxIn (TxOut era) -> Map TxIn (TxOut era)) -> GenRS era ()
modifyGenStateInitialUtxo (forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` forall era. MUtxo era -> Maybe (UtxoEntry era) -> MUtxo era
minus Map TxIn (TxOut era)
utxo Maybe (UtxoEntry era)
maybeoldpair)
  forall era. (Int -> Int) -> GenRS era ()
modifyModelCount (forall a b. a -> b -> a
const (Int
count forall a. Num a => a -> a -> a
+ Int
1))
  forall era. (Map Int TxId -> Map Int TxId) -> GenRS era ()
modifyModelIndex (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int
count (SafeHash EraIndependentTxBody -> TxId
TxId SafeHash EraIndependentTxBody
txBodyHash))
  forall era.
(Map TxIn (TxOut era) -> Map TxIn (TxOut era)) -> GenRS era ()
modifyModelUTxO (forall a b. a -> b -> a
const Map TxIn (TxOut era)
utxo)

  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall era. Map TxIn (TxOut era) -> UTxO era
UTxO Map TxIn (TxOut era)
utxo, Tx era
validTx, UtxoEntry era
feepair, Maybe (UtxoEntry era)
maybeoldpair)

-- | Keep only Script witnesses that are neccessary in 'era',
onlyNecessaryScripts ::
  Proof era -> Set ScriptHash -> [WitnessesField era] -> [WitnessesField era]
onlyNecessaryScripts :: forall era.
Proof era
-> Set ScriptHash -> [WitnessesField era] -> [WitnessesField era]
onlyNecessaryScripts Proof era
_ Set ScriptHash
_ [] = []
onlyNecessaryScripts Proof era
proof Set ScriptHash
hashes (ScriptWits Map ScriptHash (Script era)
m : [WitnessesField era]
xs) =
  forall era. Map ScriptHash (Script era) -> WitnessesField era
ScriptWits (forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map ScriptHash (Script era)
m Set ScriptHash
hashes) forall a. a -> [a] -> [a]
: forall era.
Proof era
-> Set ScriptHash -> [WitnessesField era] -> [WitnessesField era]
onlyNecessaryScripts Proof era
proof Set ScriptHash
hashes [WitnessesField era]
xs
onlyNecessaryScripts Proof era
proof Set ScriptHash
hashes (WitnessesField era
x : [WitnessesField era]
xs) = WitnessesField era
x forall a. a -> [a] -> [a]
: forall era.
Proof era
-> Set ScriptHash -> [WitnessesField era] -> [WitnessesField era]
onlyNecessaryScripts Proof era
proof Set ScriptHash
hashes [WitnessesField era]
xs

-- | Scan though the fields unioning all the RdrmWits fields into one Redeemer map
mkTxrdmrs :: Proof era -> [WitnessesField era] -> Redeemers era
mkTxrdmrs :: forall era. Proof era -> [WitnessesField era] -> Redeemers era
mkTxrdmrs Proof era
proof [WitnessesField era]
fields = forall era.
Proof era
-> [(PlutusPurpose AsIx era, (Data era, ExUnits))] -> Redeemers era
mkRedeemers Proof era
proof forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' forall {era}.
[(PlutusPurpose AsIx era, (Data era, ExUnits))]
-> WitnessesField era
-> [(PlutusPurpose AsIx era, (Data era, ExUnits))]
accum [] [WitnessesField era]
fields
  where
    accum :: [(PlutusPurpose AsIx era, (Data era, ExUnits))]
-> WitnessesField era
-> [(PlutusPurpose AsIx era, (Data era, ExUnits))]
accum [(PlutusPurpose AsIx era, (Data era, ExUnits))]
m1 (RdmrWits Redeemers era
r2) = [(PlutusPurpose AsIx era, (Data era, ExUnits))]
m1 forall a. [a] -> [a] -> [a]
++ forall k a. Map k a -> [(k, a)]
Map.toList (forall era.
Redeemers era -> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
unRedeemers Redeemers era
r2)
    accum [(PlutusPurpose AsIx era, (Data era, ExUnits))]
m1 WitnessesField era
_ = [(PlutusPurpose AsIx era, (Data era, ExUnits))]
m1

-- | Scan though the fields unioning all the DataWits fields into one TxDat
mkTxdats :: forall era. Era era => [WitnessesField era] -> TxDats era
mkTxdats :: forall era. Era era => [WitnessesField era] -> TxDats era
mkTxdats [WitnessesField era]
fields = forall era. Era era => Map DataHash (Data era) -> TxDats era
TxDats (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' Map DataHash (Data era)
-> WitnessesField era -> Map DataHash (Data era)
accum forall k a. Map k a
Map.empty [WitnessesField era]
fields)
  where
    accum :: Map DataHash (Data era)
-> WitnessesField era -> Map DataHash (Data era)
accum Map DataHash (Data era)
m (DataWits' [Data era]
ds) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' Map DataHash (Data era) -> Data era -> Map DataHash (Data era)
accum2 Map DataHash (Data era)
m [Data era]
ds
      where
        accum2 :: Map DataHash (Data era) -> Data era -> Map DataHash (Data era)
accum2 Map DataHash (Data era)
m2 Data era
d = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (forall era. Data era -> DataHash
hashData @era Data era
d) Data era
d Map DataHash (Data era)
m2
    accum Map DataHash (Data era)
m WitnessesField era
_ = Map DataHash (Data era)
m

-- =======================================================
-- An encapsulation of the Top level types we generate,
-- but that has its own Show instance that we can control.

data Box era = Box (Proof era) (TRC (EraRule "LEDGER" era)) (GenState era)

instance
  ( Era era
  , PrettyA (State (EraRule "LEDGER" era))
  , PrettyA (Script era)
  , PrettyA (Signal (EraRule "LEDGER" era))
  , Signal (EraRule "LEDGER" era) ~ Tx era
  ) =>
  Show (Box era)
  where
  show :: Box era -> String
show (Box Proof era
_proof (TRC (Environment (EraRule "LEDGER" era)
_env, State (EraRule "LEDGER" era)
_state, Signal (EraRule "LEDGER" era)
_sig)) GenState era
_gs) =
    forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$
      Text -> [(Text, PDoc)] -> PDoc
ppRecord
        Text
"Box"
        []

-- ==============================================================================
-- How we take the generated stuff and put it through the STS rule mechanism
-- in a way that is Era Agnostic

applySTSByProof ::
  forall era.
  Era era =>
  Proof era ->
  RuleContext 'Transition (EraRule "LEDGER" era) ->
  Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) (State (EraRule "LEDGER" era))
applySTSByProof :: forall era.
Era era =>
Proof era
-> RuleContext 'Transition (EraRule "LEDGER" era)
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
     (State (EraRule "LEDGER" era))
applySTSByProof Proof era
Conway RuleContext 'Transition (EraRule "LEDGER" era)
trc = forall a. ShelleyBase a -> a
runShelleyBase forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) (rtype :: RuleType).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
RuleContext rtype s
-> m (Either (NonEmpty (PredicateFailure s)) (State s))
applySTS RuleContext 'Transition (EraRule "LEDGER" era)
trc
applySTSByProof Proof era
Babbage RuleContext 'Transition (EraRule "LEDGER" era)
trc = forall a. ShelleyBase a -> a
runShelleyBase forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) (rtype :: RuleType).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
RuleContext rtype s
-> m (Either (NonEmpty (PredicateFailure s)) (State s))
applySTS RuleContext 'Transition (EraRule "LEDGER" era)
trc
applySTSByProof Proof era
Alonzo RuleContext 'Transition (EraRule "LEDGER" era)
trc = forall a. ShelleyBase a -> a
runShelleyBase forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) (rtype :: RuleType).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
RuleContext rtype s
-> m (Either (NonEmpty (PredicateFailure s)) (State s))
applySTS RuleContext 'Transition (EraRule "LEDGER" era)
trc
applySTSByProof Proof era
Mary RuleContext 'Transition (EraRule "LEDGER" era)
trc = forall a. ShelleyBase a -> a
runShelleyBase forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) (rtype :: RuleType).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
RuleContext rtype s
-> m (Either (NonEmpty (PredicateFailure s)) (State s))
applySTS RuleContext 'Transition (EraRule "LEDGER" era)
trc
applySTSByProof Proof era
Allegra RuleContext 'Transition (EraRule "LEDGER" era)
trc = forall a. ShelleyBase a -> a
runShelleyBase forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) (rtype :: RuleType).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
RuleContext rtype s
-> m (Either (NonEmpty (PredicateFailure s)) (State s))
applySTS RuleContext 'Transition (EraRule "LEDGER" era)
trc
applySTSByProof Proof era
Shelley RuleContext 'Transition (EraRule "LEDGER" era)
trc = forall a. ShelleyBase a -> a
runShelleyBase forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) (rtype :: RuleType).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
RuleContext rtype s
-> m (Either (NonEmpty (PredicateFailure s)) (State s))
applySTS RuleContext 'Transition (EraRule "LEDGER" era)
trc