{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Test.Cardano.Ledger.Shelley.Generator.Utxo (
  genTx,
  Delta (..),
  encodedLen,
  pickRandomFromMap,
) where

import Cardano.Ledger.Address (
  Addr (..),
  RewardAccount (..),
 )
import Cardano.Ledger.BaseTypes (
  Network (..),
  inject,
  maybeToStrictMaybe,
 )
import Cardano.Ledger.Binary (EncCBOR, serialize)
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (Credential (..), StakeReference (..))
import Cardano.Ledger.Keys (asWitness)
import Cardano.Ledger.Shelley.LedgerState (
  DState (..),
  LedgerState (..),
  UTxOState (..),
  ptrsMap,
  rewards,
 )
import Cardano.Ledger.Shelley.Rules (DelplEnv, LedgerEnv (..))
import Cardano.Ledger.Shelley.TxBody (Withdrawals (..))
import Cardano.Ledger.State (
  EraCertState (..),
  EraUTxO,
  UTxO (..),
  getMinFeeTxUtxo,
  sumAllValue,
 )
import Cardano.Ledger.TxIn (TxIn (..))
import qualified Cardano.Ledger.UMap as UM
import Cardano.Ledger.Val (Val (..), sumVal, (<+>), (<->), (<×>))
import Cardano.Protocol.Crypto (Crypto)
import Control.Monad (when)
import Control.State.Transition
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Either as Either (partitionEithers)
import Data.Foldable as F (foldl')
import qualified Data.IntSet as IntSet
import Data.List.NonEmpty (nonEmpty)
import qualified Data.List.NonEmpty as NE
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Proxy (Proxy (..))
import Data.Sequence.Strict (StrictSeq)
import qualified Data.Sequence.Strict as StrictSeq
import qualified Data.Set as Set
import qualified Data.Vector as V
import Lens.Micro
import NoThunks.Class ()
import Test.Cardano.Ledger.Binary.Random (QC (..))
import Test.Cardano.Ledger.Common (tracedDiscard)
import Test.Cardano.Ledger.Core.Arbitrary (uniformSubMapElems)
import Test.Cardano.Ledger.Core.KeyPair (
  KeyPair,
  KeyPairs,
  makeWitnessesFromScriptKeys,
  mkAddr,
  mkCredential,
  mkWitnessesVKey,
 )
import Test.Cardano.Ledger.Shelley.Constants (Constants (..), defaultConstants)
import Test.Cardano.Ledger.Shelley.Generator.Core (
  GenEnv (..),
  KeySpace (..),
  ScriptInfo,
  ScriptSpace (..),
  findPayKeyPairAddr,
  findPayKeyPairCred,
  findPayScriptFromAddr,
  findStakeScriptFromCred,
 )
import Test.Cardano.Ledger.Shelley.Generator.EraGen (EraGen (..))
import Test.Cardano.Ledger.Shelley.Generator.ScriptClass (scriptKeyCombination)
import Test.Cardano.Ledger.Shelley.Generator.Trace.TxCert (CERTS, genTxCerts)
import Test.Cardano.Ledger.Shelley.Generator.Update (genUpdate)
import Test.Cardano.Ledger.Shelley.Utils (Split (..))
import Test.QuickCheck (Gen)
import qualified Test.QuickCheck as QC

-- Instances only

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

-- | Generates a transaction in the context of the LEDGER STS environment
-- and state.
--
--  A generated transaction may not have sufficient spending balance and
-- need to be discarded. In that case we try to compute a Delta, that when
-- added (applyDelta) to the transaction, repairs it. The repair is made
-- by adding additional inputs from which more Ada can flow into the fee.
-- If that doesn't fix it, we add more inputs to the Delta.
-- Experience shows that this converges quite quickly (in traces we never saw
-- more than 3 iterations).

-- Note: the spending balance emerges from inputs, refund withdrawals,
-- certificate deposits and fees (which in turn depend on number of
-- inputs, outputs, witnesses, metadata etc.). It's hard to avoid this
-- completely, but in practice it is relatively easy to calibrate
-- the generator 'Constants' so that there is sufficient spending balance.

genTx ::
  forall era c.
  ( EraGen era
  , EraUTxO era
  , Embed (EraRule "DELPL" era) (CERTS era)
  , Environment (EraRule "DELPL" era) ~ DelplEnv era
  , State (EraRule "DELPL" era) ~ CertState era
  , Signal (EraRule "DELPL" era) ~ TxCert era
  , Crypto c
  ) =>
  GenEnv c era ->
  LedgerEnv era ->
  LedgerState era ->
  Gen (Tx era)
genTx :: forall era c.
(EraGen era, EraUTxO era, Embed (EraRule "DELPL" era) (CERTS era),
 Environment (EraRule "DELPL" era) ~ DelplEnv era,
 State (EraRule "DELPL" era) ~ CertState era,
 Signal (EraRule "DELPL" era) ~ TxCert era, Crypto c) =>
GenEnv c era -> LedgerEnv era -> LedgerState era -> Gen (Tx era)
genTx
  ge :: GenEnv c era
ge@( GenEnv
         keySpace :: KeySpace c era
keySpace@KeySpace_
           { KeyPairs
ksKeyPairs :: KeyPairs
ksKeyPairs :: forall c era. KeySpace c era -> KeyPairs
ksKeyPairs
           , [(GenesisKeyPair c, AllIssuerKeys c 'GenesisDelegate)]
ksCoreNodes :: [(GenesisKeyPair c, AllIssuerKeys c 'GenesisDelegate)]
ksCoreNodes :: forall c era.
KeySpace c era
-> [(GenesisKeyPair c, AllIssuerKeys c 'GenesisDelegate)]
ksCoreNodes
           , [(Script era, Script era)]
ksMSigScripts :: [(Script era, Script era)]
ksMSigScripts :: forall c era. KeySpace c era -> [(Script era, Script era)]
ksMSigScripts
           , Map (KeyHash 'GenesisDelegate) (AllIssuerKeys c 'GenesisDelegate)
ksIndexedGenDelegates :: Map (KeyHash 'GenesisDelegate) (AllIssuerKeys c 'GenesisDelegate)
ksIndexedGenDelegates :: forall c era.
KeySpace c era
-> Map
     (KeyHash 'GenesisDelegate) (AllIssuerKeys c 'GenesisDelegate)
ksIndexedGenDelegates
           , Map (KeyHash 'Payment) (KeyPair 'Payment)
ksIndexedPaymentKeys :: Map (KeyHash 'Payment) (KeyPair 'Payment)
ksIndexedPaymentKeys :: forall c era.
KeySpace c era -> Map (KeyHash 'Payment) (KeyPair 'Payment)
ksIndexedPaymentKeys
           , Map (KeyHash 'Staking) (KeyPair 'Staking)
ksIndexedStakingKeys :: Map (KeyHash 'Staking) (KeyPair 'Staking)
ksIndexedStakingKeys :: forall c era.
KeySpace c era -> Map (KeyHash 'Staking) (KeyPair 'Staking)
ksIndexedStakingKeys
           , Map ScriptHash (Script era, Script era)
ksIndexedPayScripts :: Map ScriptHash (Script era, Script era)
ksIndexedPayScripts :: forall c era.
KeySpace c era -> Map ScriptHash (Script era, Script era)
ksIndexedPayScripts
           , Map ScriptHash (Script era, Script era)
ksIndexedStakeScripts :: Map ScriptHash (Script era, Script era)
ksIndexedStakeScripts :: forall c era.
KeySpace c era -> Map ScriptHash (Script era, Script era)
ksIndexedStakeScripts
           }
         ScriptSpace era
scriptspace
         Constants
constants
       )
  (LedgerEnv SlotNo
slot Maybe EpochNo
_ TxIx
txIx PParams era
pparams ChainAccountState
reserves)
  (LedgerState utxoSt :: UTxOState era
utxoSt@(UTxOState UTxO era
utxo Coin
_ Coin
_ GovState era
_ InstantStake era
_ Coin
_) CertState era
dpState) =
    do
      -------------------------------------------------------------------------
      -- Generate the building blocks of a TxBody
      -------------------------------------------------------------------------
      ([TxIn]
inputs, Value era
spendingBalanceUtxo, ([KeyPair 'Witness]
spendWits, [(Script era, Script era)]
spendScripts)) <-
        (Int, Int)
-> Map (KeyHash 'Payment) (KeyPair 'Payment)
-> Map ScriptHash (Script era, Script era)
-> UTxO era
-> Gen
     ([TxIn], Value era,
      ([KeyPair 'Witness], [(Script era, Script era)]))
forall era.
EraTxOut era =>
(Int, Int)
-> Map (KeyHash 'Payment) (KeyPair 'Payment)
-> Map ScriptHash (Script era, Script era)
-> UTxO era
-> Gen
     ([TxIn], Value era,
      ([KeyPair 'Witness], [(Script era, Script era)]))
genInputs
          (Constants -> Int
minNumGenInputs Constants
constants, Constants -> Int
maxNumGenInputs Constants
constants)
          Map (KeyHash 'Payment) (KeyPair 'Payment)
ksIndexedPaymentKeys
          Map ScriptHash (Script era, Script era)
ksIndexedPayScripts
          UTxO era
utxo
      ([(RewardAccount, Coin)]
wdrls, ([KeyPair 'Witness]
wdrlWits, [(Script era, Script era)]
wdrlScripts)) <-
        forall era.
Constants
-> Map ScriptHash (Script era, Script era)
-> Map (KeyHash 'Staking) (KeyPair 'Staking)
-> Map (Credential 'Staking) Coin
-> Gen
     ([(RewardAccount, Coin)],
      ([KeyPair 'Witness], [(Script era, Script era)]))
genWithdrawals
          @era
          Constants
constants
          Map ScriptHash (Script era, Script era)
ksIndexedStakeScripts
          Map (KeyHash 'Staking) (KeyPair 'Staking)
ksIndexedStakingKeys
          (((RDPair -> Coin)
-> Map (Credential 'Staking) RDPair
-> Map (Credential 'Staking) Coin
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
UM.fromCompact (CompactForm Coin -> Coin)
-> (RDPair -> CompactForm Coin) -> RDPair -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RDPair -> CompactForm Coin
UM.rdReward) (Map (Credential 'Staking) RDPair
 -> Map (Credential 'Staking) Coin)
-> (DState era -> Map (Credential 'Staking) RDPair)
-> DState era
-> Map (Credential 'Staking) Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UView (Credential 'Staking) RDPair
-> Map (Credential 'Staking) RDPair
forall k v. UView k v -> Map k v
UM.unUnify (UView (Credential 'Staking) RDPair
 -> Map (Credential 'Staking) RDPair)
-> (DState era -> UView (Credential 'Staking) RDPair)
-> DState era
-> Map (Credential 'Staking) RDPair
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DState era -> UView (Credential 'Staking) RDPair
forall era. DState era -> UView (Credential 'Staking) RDPair
rewards) (DState era -> Map (Credential 'Staking) Coin)
-> DState era -> Map (Credential 'Staking) Coin
forall a b. (a -> b) -> a -> b
$ CertState era
dpState CertState era
-> Getting (DState era) (CertState era) (DState era) -> DState era
forall s a. s -> Getting a s a -> a
^. Getting (DState era) (CertState era) (DState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL)
      (Maybe (Update era)
update, [KeyPair 'Witness]
updateWits) <-
        Constants
-> SlotNo
-> [(GenesisKeyPair c, AllIssuerKeys c 'GenesisDelegate)]
-> Map
     (KeyHash 'GenesisDelegate) (AllIssuerKeys c 'GenesisDelegate)
-> PParams era
-> (UTxOState era, CertState era)
-> Gen (Maybe (Update era), [KeyPair 'Witness])
forall era c.
EraGen era =>
Constants
-> SlotNo
-> [(GenesisKeyPair c, AllIssuerKeys c 'GenesisDelegate)]
-> Map
     (KeyHash 'GenesisDelegate) (AllIssuerKeys c 'GenesisDelegate)
-> PParams era
-> (UTxOState era, CertState era)
-> Gen (Maybe (Update era), [KeyPair 'Witness])
genUpdate
          Constants
constants
          SlotNo
slot
          [(GenesisKeyPair c, AllIssuerKeys c 'GenesisDelegate)]
ksCoreNodes
          Map (KeyHash 'GenesisDelegate) (AllIssuerKeys c 'GenesisDelegate)
ksIndexedGenDelegates
          PParams era
pparams
          (UTxOState era
utxoSt, CertState era
dpState)
      ([TxCert era]
certs, Coin
deposits, Coin
refunds, CertState era
dpState', [KeyPair 'Witness]
certWits, [(Script era, Script era)]
certScripts) <-
        GenEnv c era
-> PParams era
-> CertState era
-> SlotNo
-> TxIx
-> ChainAccountState
-> Gen
     ([TxCert era], Coin, Coin, CertState era, [KeyPair 'Witness],
      [(Script era, Script era)])
forall era c.
(EraGen era, Embed (EraRule "DELPL" era) (CERTS era),
 Environment (EraRule "DELPL" era) ~ DelplEnv era,
 State (EraRule "DELPL" era) ~ CertState era,
 Signal (EraRule "DELPL" era) ~ TxCert era, Crypto c) =>
GenEnv c era
-> PParams era
-> CertState era
-> SlotNo
-> TxIx
-> ChainAccountState
-> Gen
     ([TxCert era], Coin, Coin, CertState era, [KeyPair 'Witness],
      [(Script era, Script era)])
genTxCerts GenEnv c era
ge PParams era
pparams CertState era
dpState SlotNo
slot TxIx
txIx ChainAccountState
reserves
      StrictMaybe (TxAuxData era)
metadata <- forall era.
EraGen era =>
Constants -> Gen (StrictMaybe (TxAuxData era))
genEraAuxiliaryData @era Constants
constants
      -------------------------------------------------------------------------
      -- Gather Key TxWits and Scripts, prepare a constructor for Tx Wits
      -------------------------------------------------------------------------
      let txWits :: [KeyPair 'Witness]
txWits = [KeyPair 'Witness]
spendWits [KeyPair 'Witness] -> [KeyPair 'Witness] -> [KeyPair 'Witness]
forall a. [a] -> [a] -> [a]
++ [KeyPair 'Witness]
wdrlWits [KeyPair 'Witness] -> [KeyPair 'Witness] -> [KeyPair 'Witness]
forall a. [a] -> [a] -> [a]
++ [KeyPair 'Witness]
certWits [KeyPair 'Witness] -> [KeyPair 'Witness] -> [KeyPair 'Witness]
forall a. [a] -> [a] -> [a]
++ [KeyPair 'Witness]
updateWits
          scripts :: Map ScriptHash (Script era)
scripts = forall era.
EraGen era =>
[(Script era, Script era)]
-> [(Script era, Script era)] -> Map ScriptHash (Script era)
mkScriptWits @era [(Script era, Script era)]
spendScripts ([(Script era, Script era)]
certScripts [(Script era, Script era)]
-> [(Script era, Script era)] -> [(Script era, Script era)]
forall a. [a] -> [a] -> [a]
++ [(Script era, Script era)]
wdrlScripts)
          mkTxWits' :: TxBody era -> TxWits era
mkTxWits' TxBody era
txbody =
            forall era.
EraGen era =>
(UTxO era, TxBody era, ScriptInfo era)
-> Map (KeyHash 'Payment) (KeyPair 'Payment)
-> Map (KeyHash 'Staking) (KeyPair 'Staking)
-> [KeyPair 'Witness]
-> Map ScriptHash (Script era)
-> SafeHash EraIndependentTxBody
-> TxWits era
mkTxWits @era
              (UTxO era
utxo, TxBody era
txbody, (ScriptSpace era -> Map ScriptHash (TwoPhase3ArgInfo era)
forall era.
ScriptSpace era -> Map ScriptHash (TwoPhase3ArgInfo era)
ssHash3 ScriptSpace era
scriptspace, ScriptSpace era -> Map ScriptHash (TwoPhase2ArgInfo era)
forall era.
ScriptSpace era -> Map ScriptHash (TwoPhase2ArgInfo era)
ssHash2 ScriptSpace era
scriptspace))
              Map (KeyHash 'Payment) (KeyPair 'Payment)
ksIndexedPaymentKeys
              Map (KeyHash 'Staking) (KeyPair 'Staking)
ksIndexedStakingKeys
              [KeyPair 'Witness]
txWits
              Map ScriptHash (Script era)
scripts
              (TxBody era -> SafeHash EraIndependentTxBody
forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated TxBody era
txbody)
      -------------------------------------------------------------------------
      -- SpendingBalance, Output Addresses (including some Pointer addresses)
      -- and a Outputs builder that distributes the given balance over
      -- addresses.
      -------------------------------------------------------------------------
      let withdrawals :: Coin
withdrawals = [Coin] -> Coin
forall (t :: * -> *) v. (Foldable t, Val v) => t v -> v
sumVal ((RewardAccount, Coin) -> Coin
forall a b. (a, b) -> b
snd ((RewardAccount, Coin) -> Coin)
-> [(RewardAccount, Coin)] -> [Coin]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(RewardAccount, Coin)]
wdrls)
          !spendingBalance :: Value era
spendingBalance =
            Value era
spendingBalanceUtxo
              Value era -> Value era -> Value era
forall t. Val t => t -> t -> t
<+> Coin -> Value era
forall t s. Inject t s => t -> s
inject ((Coin
withdrawals Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> Coin
deposits) Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> Coin
refunds)
          n :: Int
n =
            if Map TxIn (TxOut era) -> Int
forall k a. Map k a -> Int
Map.size (UTxO era -> Map TxIn (TxOut era)
forall era. UTxO era -> Map TxIn (TxOut era)
unUTxO UTxO era
utxo) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Constants -> Int
genTxStableUtxoSize Constants
defaultConstants
              then -- something moderate 80-120 ^
                Constants -> Int
genTxUtxoIncrement Constants
defaultConstants -- something small 2-5
              else Int
0 -- no change at all
              -- This algorithm has an instability in that if we don't balance
              -- genTxStableUtxoSize and genTxUtxoIncrement correctly the size
              -- of the UTxO gradually shrinks so small we cannot support
              -- generating a transaction. If we get unexplained failures one
              -- might investigate changing these constants.

      -- !_ = occaisionally (length inputs * length ksKeyPairs * length ksMSigScripts) 10000 ("UTxOSize = "++show (Map.size (unUTxO utxo)))

      [Addr]
outputAddrs <-
        forall era.
EraGen era =>
Int -> KeyPairs -> [(Script era, Script era)] -> Gen [Addr]
genRecipients @era ([TxIn] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TxIn]
inputs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n) KeyPairs
ksKeyPairs [(Script era, Script era)]
ksMSigScripts
          Gen [Addr] -> ([Addr] -> Gen [Addr]) -> Gen [Addr]
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DState era -> [Addr] -> Gen [Addr]
forall era. DState era -> [Addr] -> Gen [Addr]
genPtrAddrs (CertState era
dpState' CertState era
-> Getting (DState era) (CertState era) (DState era) -> DState era
forall s a. s -> Getting a s a -> a
^. Getting (DState era) (CertState era) (DState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL)

      !()
_ <-
        Bool -> Gen () -> Gen ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Value era -> Coin
forall t. Val t => t -> Coin
coin Value era
spendingBalance Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
< Coin
forall a. Monoid a => a
mempty) (Gen () -> Gen ()) -> Gen () -> Gen ()
forall a b. (a -> b) -> a -> b
$
          String -> Gen ()
forall a. String -> a
tracedDiscard (String -> Gen ()) -> String -> Gen ()
forall a b. (a -> b) -> a -> b
$
            String
"Negative spending balance " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Coin -> String
forall a. Show a => a -> String
show (Value era -> Coin
forall t. Val t => t -> Coin
coin Value era
spendingBalance)

      -------------------------------------------------------------------------
      -- Build a Draft Tx and repeatedly add to Delta until all fees are
      -- accounted for.
      -------------------------------------------------------------------------
      let draftFee :: Coin
draftFee = Integer -> Coin
Coin Integer
0
          (Coin
remainderCoin, StrictSeq (TxOut era)
draftOutputs) =
            forall era.
(EraTxOut era, Split (Value era)) =>
Value era -> [Addr] -> Coin -> (Coin, StrictSeq (TxOut era))
calcOutputsFromBalance @era
              Value era
spendingBalance
              [Addr]
outputAddrs
              Coin
draftFee

      -- Occasionally we have a transaction generated with insufficient inputs
      -- to cover the deposits. In this case we discard the test case.
      let enough :: Coin
enough = StrictSeq Coin -> Coin
forall (t :: * -> *) v. (Foldable t, Val v) => t v -> v
sumVal (PParams era -> TxOut era -> Coin
forall era. EraTxOut era => PParams era -> TxOut era -> Coin
getMinCoinTxOut PParams era
pparams (TxOut era -> Coin) -> StrictSeq (TxOut era) -> StrictSeq Coin
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictSeq (TxOut era)
draftOutputs)
      !()
_ <-
        Bool -> Gen () -> Gen ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Value era -> Coin
forall t. Val t => t -> Coin
coin Value era
spendingBalance Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
< Coin
enough) (Gen () -> Gen ()) -> Gen () -> Gen ()
forall a b. (a -> b) -> a -> b
$
          String -> Gen ()
forall a. String -> a
tracedDiscard (String -> Gen ()) -> String -> Gen ()
forall a b. (a -> b) -> a -> b
$
            String
"No inputs left. Utxo.hs " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Coin -> String
forall a. Show a => a -> String
show Coin
enough

      (TxBody era
draftTxBody, [Script era]
additionalScripts) <-
        GenEnv c era
-> UTxO era
-> PParams era
-> SlotNo
-> Set TxIn
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals
-> Coin
-> StrictMaybe (Update era)
-> StrictMaybe TxAuxDataHash
-> Gen (TxBody era, [Script era])
forall c.
GenEnv c era
-> UTxO era
-> PParams era
-> SlotNo
-> Set TxIn
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals
-> Coin
-> StrictMaybe (Update era)
-> StrictMaybe TxAuxDataHash
-> Gen (TxBody era, [Script era])
forall era c.
EraGen era =>
GenEnv c era
-> UTxO era
-> PParams era
-> SlotNo
-> Set TxIn
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals
-> Coin
-> StrictMaybe (Update era)
-> StrictMaybe TxAuxDataHash
-> Gen (TxBody era, [Script era])
genEraTxBody
          GenEnv c era
ge
          UTxO era
utxo
          PParams era
pparams
          SlotNo
slot
          ([TxIn] -> Set TxIn
forall a. Ord a => [a] -> Set a
Set.fromList [TxIn]
inputs)
          StrictSeq (TxOut era)
draftOutputs
          ([TxCert era] -> StrictSeq (TxCert era)
forall a. [a] -> StrictSeq a
StrictSeq.fromList [TxCert era]
certs)
          (Map RewardAccount Coin -> Withdrawals
Withdrawals ([(RewardAccount, Coin)] -> Map RewardAccount Coin
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(RewardAccount, Coin)]
wdrls))
          Coin
draftFee
          (Maybe (Update era) -> StrictMaybe (Update era)
forall a. Maybe a -> StrictMaybe a
maybeToStrictMaybe Maybe (Update era)
update)
          (forall era. EraTxAuxData era => TxAuxData era -> TxAuxDataHash
hashTxAuxData @era (TxAuxData era -> TxAuxDataHash)
-> StrictMaybe (TxAuxData era) -> StrictMaybe TxAuxDataHash
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictMaybe (TxAuxData era)
metadata)
      let draftTx :: Tx era
draftTx =
            forall era.
EraGen era =>
TxBody era -> TxWits era -> StrictMaybe (TxAuxData era) -> Tx era
constructTx @era
              TxBody era
draftTxBody
              (TxBody era -> TxWits era
mkTxWits' TxBody era
draftTxBody)
              StrictMaybe (TxAuxData era)
metadata
          scripts' :: Map ScriptHash (Script era)
scripts' = [(ScriptHash, Script era)] -> Map ScriptHash (Script era)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ScriptHash, Script era)] -> Map ScriptHash (Script era))
-> [(ScriptHash, Script era)] -> Map ScriptHash (Script era)
forall a b. (a -> b) -> a -> b
$ (Script era -> (ScriptHash, Script era))
-> [Script era] -> [(ScriptHash, Script era)]
forall a b. (a -> b) -> [a] -> [b]
map (\Script era
s -> (forall era. EraScript era => Script era -> ScriptHash
hashScript @era Script era
s, Script era
s)) [Script era]
additionalScripts
      -- We add now repeatedly add inputs until the process converges.
      Tx era
tx <-
        ScriptInfo era
-> Coin
-> [KeyPair 'Witness]
-> Map ScriptHash (Script era)
-> KeyPairs
-> [(Script era, Script era)]
-> UTxO era
-> PParams era
-> KeySpace c era
-> Tx era
-> Gen (Tx era)
forall era c.
(EraGen era, EraUTxO era) =>
ScriptInfo era
-> Coin
-> [KeyPair 'Witness]
-> Map ScriptHash (Script era)
-> KeyPairs
-> [(Script era, Script era)]
-> UTxO era
-> PParams era
-> KeySpace c era
-> Tx era
-> Gen (Tx era)
converge
          (ScriptSpace era -> Map ScriptHash (TwoPhase3ArgInfo era)
forall era.
ScriptSpace era -> Map ScriptHash (TwoPhase3ArgInfo era)
ssHash3 ScriptSpace era
scriptspace, ScriptSpace era -> Map ScriptHash (TwoPhase2ArgInfo era)
forall era.
ScriptSpace era -> Map ScriptHash (TwoPhase2ArgInfo era)
ssHash2 ScriptSpace era
scriptspace)
          Coin
remainderCoin
          [KeyPair 'Witness]
txWits
          (Map ScriptHash (Script era)
scripts Map ScriptHash (Script era)
-> Map ScriptHash (Script era) -> Map ScriptHash (Script era)
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Map ScriptHash (Script era)
scripts')
          KeyPairs
ksKeyPairs
          [(Script era, Script era)]
ksMSigScripts
          UTxO era
utxo
          PParams era
pparams
          KeySpace c era
keySpace
          Tx era
draftTx
      let txOuts :: StrictSeq (TxOut era)
txOuts = Tx era
tx Tx era
-> Getting (StrictSeq (TxOut era)) (Tx era) (StrictSeq (TxOut era))
-> StrictSeq (TxOut era)
forall s a. s -> Getting a s a -> a
^. (TxBody era -> Const (StrictSeq (TxOut era)) (TxBody era))
-> Tx era -> Const (StrictSeq (TxOut era)) (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Const (StrictSeq (TxOut era)) (TxBody era))
 -> Tx era -> Const (StrictSeq (TxOut era)) (Tx era))
-> ((StrictSeq (TxOut era)
     -> Const (StrictSeq (TxOut era)) (StrictSeq (TxOut era)))
    -> TxBody era -> Const (StrictSeq (TxOut era)) (TxBody era))
-> Getting (StrictSeq (TxOut era)) (Tx era) (StrictSeq (TxOut era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut era)
 -> Const (StrictSeq (TxOut era)) (StrictSeq (TxOut era)))
-> TxBody era -> Const (StrictSeq (TxOut era)) (TxBody era)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL
      !()
_ <-
        Bool -> Gen () -> Gen ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((TxOut era -> Bool) -> StrictSeq (TxOut era) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\TxOut era
txOut -> PParams era -> TxOut era -> Coin
forall era. EraTxOut era => PParams era -> TxOut era -> Coin
getMinCoinTxOut PParams era
pparams TxOut era
txOut Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
> TxOut era
txOut TxOut era -> Getting Coin (TxOut era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (TxOut era) Coin
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut era) Coin
coinTxOutL) StrictSeq (TxOut era)
txOuts) (Gen () -> Gen ()) -> Gen () -> Gen ()
forall a b. (a -> b) -> a -> b
$
          String -> Gen ()
forall a. String -> a
tracedDiscard (String -> Gen ()) -> String -> Gen ()
forall a b. (a -> b) -> a -> b
$
            String
"TxOut value is too small " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> StrictSeq (TxOut era) -> String
forall a. Show a => a -> String
show StrictSeq (TxOut era)
txOuts
      Tx era -> Gen (Tx era)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx era
tx

-- | Collect additional inputs (and witnesses and keys and scripts) to make
-- the transaction balance.
data Delta era = Delta
  { forall era. Delta era -> Coin
dfees :: Coin
  , forall era. Delta era -> Set TxIn
extraInputs :: Set.Set TxIn
  , forall era. Delta era -> TxWits era
extraWitnesses :: TxWits era
  , forall era. Delta era -> TxOut era
change :: TxOut era
  , forall era. Delta era -> [KeyPair 'Witness]
deltaVKeys :: [KeyPair 'Witness]
  , forall era. Delta era -> [(Script era, Script era)]
deltaScripts :: [(Script era, Script era)]
  }

instance Show (Delta era) where
  show :: Delta era -> String
show (Delta Coin
fee Set TxIn
is TxWits era
_wit TxOut era
_change [KeyPair 'Witness]
dvs [(Script era, Script era)]
ds) =
    String
"(Delta"
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ Coin -> String
forall a. Show a => a -> String
show Coin
fee
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Set TxIn -> Int
forall a. Set a -> Int
Set.size Set TxIn
is)
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" wit change "
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([KeyPair 'Witness] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [KeyPair 'Witness]
dvs)
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([(Script era, Script era)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Script era, Script era)]
ds)
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"

-- | - We need this instance to know when delta has stopped growing. We don't
--  actually need to compare all the fields, because if the extraInputs has not
--  changed then the Scripts and keys will not have changed.
instance
  ( EraTxOut era
  , Eq (TxWits era)
  ) =>
  Eq (Delta era)
  where
  Delta era
a == :: Delta era -> Delta era -> Bool
== Delta era
b =
    Delta era -> Coin
forall era. Delta era -> Coin
dfees Delta era
a Coin -> Coin -> Bool
forall a. Eq a => a -> a -> Bool
== Delta era -> Coin
forall era. Delta era -> Coin
dfees Delta era
b
      Bool -> Bool -> Bool
&& Delta era -> Set TxIn
forall era. Delta era -> Set TxIn
extraInputs Delta era
a Set TxIn -> Set TxIn -> Bool
forall a. Eq a => a -> a -> Bool
== Delta era -> Set TxIn
forall era. Delta era -> Set TxIn
extraInputs Delta era
b
      Bool -> Bool -> Bool
&& Delta era -> TxWits era
forall era. Delta era -> TxWits era
extraWitnesses Delta era
a TxWits era -> TxWits era -> Bool
forall a. Eq a => a -> a -> Bool
== Delta era -> TxWits era
forall era. Delta era -> TxWits era
extraWitnesses Delta era
b
      -- deltaVKeys and deltaScripts equality are implied by extraWitnesses
      -- equality, at least in the use case below.
      Bool -> Bool -> Bool
&& Delta era -> TxOut era
forall era. Delta era -> TxOut era
change Delta era
a TxOut era -> TxOut era -> Bool
forall a. Eq a => a -> a -> Bool
== Delta era -> TxOut era
forall era. Delta era -> TxOut era
change Delta era
b

deltaZero ::
  forall era.
  ( EraTxOut era
  , Monoid (TxWits era)
  ) =>
  Coin ->
  PParams era ->
  Addr ->
  Delta era
deltaZero :: forall era.
(EraTxOut era, Monoid (TxWits era)) =>
Coin -> PParams era -> Addr -> Delta era
deltaZero Coin
initialfee PParams era
pp Addr
addr =
  Coin
-> Set TxIn
-> TxWits era
-> TxOut era
-> [KeyPair 'Witness]
-> [(Script era, Script era)]
-> Delta era
forall era.
Coin
-> Set TxIn
-> TxWits era
-> TxOut era
-> [KeyPair 'Witness]
-> [(Script era, Script era)]
-> Delta era
Delta
    (Coin
initialfee Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> TxOut era
txOut TxOut era -> Getting Coin (TxOut era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (TxOut era) Coin
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut era) Coin
coinTxOutL)
    Set TxIn
forall a. Monoid a => a
mempty
    TxWits era
forall a. Monoid a => a
mempty
    TxOut era
txOut
    [KeyPair 'Witness]
forall a. Monoid a => a
mempty
    [(Script era, Script era)]
forall a. Monoid a => a
mempty
  where
    txOut :: TxOut era
txOut = PParams era -> TxOut era -> TxOut era
forall era. EraTxOut era => PParams era -> TxOut era -> TxOut era
setMinCoinTxOut PParams era
pp (Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
addr Value era
forall a. Monoid a => a
mempty)

-- Same function as in cardano-ledger-api. We don't want to depend on the api though,
-- because it will be problematic for dependencies (cardano-ledger-api test suite depends
-- on this package)
setMinCoinTxOut :: EraTxOut era => PParams era -> TxOut era -> TxOut era
setMinCoinTxOut :: forall era. EraTxOut era => PParams era -> TxOut era -> TxOut era
setMinCoinTxOut PParams era
pp = TxOut era -> TxOut era
go
  where
    go :: TxOut era -> TxOut era
go TxOut era
txOut =
      let curMinCoin :: Coin
curMinCoin = PParams era -> TxOut era -> Coin
forall era. EraTxOut era => PParams era -> TxOut era -> Coin
getMinCoinTxOut PParams era
pp TxOut era
txOut
          curCoin :: Coin
curCoin = TxOut era
txOut TxOut era -> Getting Coin (TxOut era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (TxOut era) Coin
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut era) Coin
coinTxOutL
       in if Coin
curCoin Coin -> Coin -> Bool
forall a. Eq a => a -> a -> Bool
== Coin
curMinCoin
            then TxOut era
txOut
            else TxOut era -> TxOut era
go (TxOut era
txOut TxOut era -> (TxOut era -> TxOut era) -> TxOut era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin) -> TxOut era -> Identity (TxOut era)
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut era) Coin
coinTxOutL ((Coin -> Identity Coin) -> TxOut era -> Identity (TxOut era))
-> Coin -> TxOut era -> TxOut era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
curMinCoin)

encodedLen :: forall era t. (Era era, EncCBOR t) => t -> Integer
encodedLen :: forall era t. (Era era, EncCBOR t) => t -> Integer
encodedLen t
x = Int64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Integer) -> Int64 -> Integer
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
BSL.length (Version -> t -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
serialize (forall era. Era era => Version
eraProtVerHigh @era) t
x)

-- | Do the work of computing what additioanl inputs we need to 'fix-up' the transaction
-- so that it will balance.
genNextDelta ::
  forall era c.
  (EraGen era, EraUTxO era) =>
  ScriptInfo era ->
  UTxO era ->
  PParams era ->
  KeySpace c era ->
  Tx era ->
  Int ->
  Delta era ->
  Gen (Delta era)
genNextDelta :: forall era c.
(EraGen era, EraUTxO era) =>
ScriptInfo era
-> UTxO era
-> PParams era
-> KeySpace c era
-> Tx era
-> Int
-> Delta era
-> Gen (Delta era)
genNextDelta
  ScriptInfo era
scriptinfo
  UTxO era
utxo
  PParams era
pparams
  KeySpace_
    { Map (KeyHash 'Staking) (KeyPair 'Staking)
ksIndexedStakingKeys :: forall c era.
KeySpace c era -> Map (KeyHash 'Staking) (KeyPair 'Staking)
ksIndexedStakingKeys :: Map (KeyHash 'Staking) (KeyPair 'Staking)
ksIndexedStakingKeys
    , Map (KeyHash 'Payment) (KeyPair 'Payment)
ksIndexedPaymentKeys :: forall c era.
KeySpace c era -> Map (KeyHash 'Payment) (KeyPair 'Payment)
ksIndexedPaymentKeys :: Map (KeyHash 'Payment) (KeyPair 'Payment)
ksIndexedPaymentKeys
    , Map ScriptHash (Script era, Script era)
ksIndexedPayScripts :: forall c era.
KeySpace c era -> Map ScriptHash (Script era, Script era)
ksIndexedPayScripts :: Map ScriptHash (Script era, Script era)
ksIndexedPayScripts
    }
  Tx era
tx
  Int
_count -- the counter of the fix loop
  delta :: Delta era
delta@(Delta Coin
dfees Set TxIn
extraInputs TxWits era
extraWitnesses TxOut era
change [KeyPair 'Witness]
_ [(Script era, Script era)]
extraScripts) =
    let !baseTxFee :: Coin
baseTxFee = PParams era -> Tx era -> UTxO era -> Coin
forall era.
EraUTxO era =>
PParams era -> Tx era -> UTxO era -> Coin
getMinFeeTxUtxo PParams era
pparams Tx era
tx UTxO era
utxo
        -- based on the current contents of delta, how much will the fee
        -- increase when we add the delta to the tx?
        draftSize :: Integer
draftSize =
          [Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum
            [ Integer
11000 :: Integer -- safety net in case the coin or a list prefix rolls over into a
            -- larger encoding, or some other fudge factor occurs. Sometimes we need extra buffer
            -- when minting tokens. 1100 has been empirically determined to make non-failing Txs
            , forall era t. (Era era, EncCBOR t) => t -> Integer
encodedLen @era (Coin -> Coin -> Coin
forall a. Ord a => a -> a -> a
max Coin
dfees (Integer -> Coin
Coin Integer
0)) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1
            , ((TxIn -> Integer -> Integer) -> Integer -> Set TxIn -> Integer
forall a b. (a -> b -> b) -> b -> Set a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\TxIn
a Integer
b -> Integer
b Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ forall era t. (Era era, EncCBOR t) => t -> Integer
encodedLen @era TxIn
a) Integer
0 Set TxIn
extraInputs) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
2
            , --  inputs end up in collateral as well, so we ^ multiply by 2
              forall era t. (Era era, EncCBOR t) => t -> Integer
encodedLen @era TxOut era
change
            , forall era t. (Era era, EncCBOR t) => t -> Integer
encodedLen @era TxWits era
extraWitnesses
            ]
        deltaScriptCost :: Coin
deltaScriptCost = ((Script era, Script era) -> Coin -> Coin)
-> Coin -> [(Script era, Script era)] -> Coin
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Script era, Script era) -> Coin -> Coin
accum (Integer -> Coin
Coin Integer
0) [(Script era, Script era)]
extraScripts
          where
            accum :: (Script era, Script era) -> Coin -> Coin
accum (Script era
s1, Script era
_) Coin
ans = forall era. EraGen era => PParams era -> Script era -> Coin
genEraScriptCost @era PParams era
pparams Script era
s1 Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> Coin
ans
        deltaFee :: Coin
deltaFee = Integer
draftSize Integer -> Coin -> Coin
forall i. Integral i => i -> Coin -> Coin
forall t i. (Val t, Integral i) => i -> t -> t
<×> PParams era
pparams PParams era -> Getting Coin (PParams era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (PParams era) Coin
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppMinFeeAL Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> Coin
deltaScriptCost
        totalFee :: Coin
totalFee = Coin
baseTxFee Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> Coin
deltaFee :: Coin
        remainingFee :: Coin
remainingFee = Coin
totalFee Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> Coin
dfees :: Coin
        changeAmount :: Coin
changeAmount = TxOut era -> Coin
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTxOut era) =>
TxOut era -> Coin
getChangeAmount TxOut era
change
        minAda :: Coin
minAda = PParams era -> TxOut era -> Coin
forall era. EraTxOut era => PParams era -> TxOut era -> Coin
getMinCoinTxOut PParams era
pparams TxOut era
change
     in if Coin
remainingFee Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer -> Coin
Coin Integer
0 -- we've paid for all the fees
          then Delta era -> Gen (Delta era)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Delta era
delta -- we're done
          else -- the change covers what we need, so shift Coin from change to dfees.
            if Coin
remainingFee Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
<= (Coin
changeAmount Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> Coin
minAda)
              then
                Delta era -> Gen (Delta era)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Delta era -> Gen (Delta era)) -> Delta era -> Gen (Delta era)
forall a b. (a -> b) -> a -> b
$
                  Delta era
delta
                    { dfees = totalFee
                    , change =
                        deltaChange
                          (<-> inject remainingFee)
                          change
                    }
              else -- add a new input to cover the fee
                do
                  let txBody :: TxBody era
txBody = Tx era
tx Tx era -> Getting (TxBody era) (Tx era) (TxBody era) -> TxBody era
forall s a. s -> Getting a s a -> a
^. Getting (TxBody era) (Tx era) (TxBody era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL
                      inputsInUse :: Set TxIn
inputsInUse = TxBody era
txBody TxBody era
-> Getting (Set TxIn) (TxBody era) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. Getting (Set TxIn) (TxBody era) (Set TxIn)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL Set TxIn -> Set TxIn -> Set TxIn
forall a. Semigroup a => a -> a -> a
<> Set TxIn
extraInputs
                      utxo' :: UTxO era
                      utxo' :: UTxO era
utxo' =
                        -- Remove possible inputs from Utxo, if they already
                        -- appear in inputs.
                        Map TxIn (TxOut era) -> UTxO era
forall era. Map TxIn (TxOut era) -> UTxO era
UTxO (Map TxIn (TxOut era) -> UTxO era)
-> Map TxIn (TxOut era) -> UTxO era
forall a b. (a -> b) -> a -> b
$
                          (TxIn -> TxOut era -> Bool)
-> Map TxIn (TxOut era) -> Map TxIn (TxOut era)
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey
                            ( \TxIn
k TxOut era
v ->
                                (TxIn
k TxIn -> Set TxIn -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set TxIn
inputsInUse) Bool -> Bool -> Bool
&& TxOut era -> Bool
forall era. EraGen era => TxOut era -> Bool
genEraGoodTxOut TxOut era
v
                            )
                            -- filter out UTxO entries where the TxOut are not
                            -- appropriate for this Era (i.e. Keylocked in
                            -- AlonzoEra)
                            (UTxO era -> Map TxIn (TxOut era)
forall era. UTxO era -> Map TxIn (TxOut era)
unUTxO UTxO era
utxo)
                  ([TxIn]
inputs, Value era
value, ([KeyPair 'Witness]
vkeyPairs, [(Script era, Script era)]
msigPairs)) <-
                    (Int, Int)
-> Map (KeyHash 'Payment) (KeyPair 'Payment)
-> Map ScriptHash (Script era, Script era)
-> UTxO era
-> Gen
     ([TxIn], Value era,
      ([KeyPair 'Witness], [(Script era, Script era)]))
forall era.
EraTxOut era =>
(Int, Int)
-> Map (KeyHash 'Payment) (KeyPair 'Payment)
-> Map ScriptHash (Script era, Script era)
-> UTxO era
-> Gen
     ([TxIn], Value era,
      ([KeyPair 'Witness], [(Script era, Script era)]))
genInputs (Int
1, Int
1) Map (KeyHash 'Payment) (KeyPair 'Payment)
ksIndexedPaymentKeys Map ScriptHash (Script era, Script era)
ksIndexedPayScripts UTxO era
utxo'
                  -- It is possible that the Utxo has no possible inputs left, so
                  -- fail. We try and keep this from happening by using feedback:
                  -- adding to the number of ouputs (in the call to genRecipients)
                  -- in genTx above. Adding to the outputs means in the next cycle
                  -- the size of the UTxO will grow. In rare cases, this cannot be avoided
                  -- So we discard this test case. This should happen very rarely.
                  -- If it does happen, It is NOT a test failure, but an inadequacy in the
                  -- testing framework to generate almost-random transactions that always succeed every time.
                  -- Experience suggests that this happens less than 1% of the time, and does not lead to backtracking.
                  !()
_ <- Bool -> Gen () -> Gen ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([TxIn] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TxIn]
inputs) (Gen () -> Gen ()) -> Gen () -> Gen ()
forall a b. (a -> b) -> a -> b
$ String -> Gen ()
forall a. String -> a
tracedDiscard (String -> Gen ()) -> String -> Gen ()
forall a b. (a -> b) -> a -> b
$ String
"NoMoneyleft Utxo.hs " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Coin -> String
forall a. Show a => a -> String
show (Value era -> Coin
forall t. Val t => t -> Coin
coin Value era
value)
                  let newWits :: TxWits era
newWits =
                        forall era.
EraGen era =>
(UTxO era, TxBody era, ScriptInfo era)
-> Map (KeyHash 'Payment) (KeyPair 'Payment)
-> Map (KeyHash 'Staking) (KeyPair 'Staking)
-> [KeyPair 'Witness]
-> Map ScriptHash (Script era)
-> SafeHash EraIndependentTxBody
-> TxWits era
mkTxWits @era
                          (UTxO era
utxo, TxBody era
txBody, ScriptInfo era
scriptinfo)
                          Map (KeyHash 'Payment) (KeyPair 'Payment)
ksIndexedPaymentKeys
                          Map (KeyHash 'Staking) (KeyPair 'Staking)
ksIndexedStakingKeys
                          [KeyPair 'Witness]
vkeyPairs
                          (forall era.
EraGen era =>
[(Script era, Script era)]
-> [(Script era, Script era)] -> Map ScriptHash (Script era)
mkScriptWits @era [(Script era, Script era)]
msigPairs [(Script era, Script era)]
forall a. Monoid a => a
mempty)
                          (TxBody era -> SafeHash EraIndependentTxBody
forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated TxBody era
txBody)
                  Delta era -> Gen (Delta era)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Delta era -> Gen (Delta era)) -> Delta era -> Gen (Delta era)
forall a b. (a -> b) -> a -> b
$
                    Delta era
delta
                      { extraWitnesses = extraWitnesses <> newWits
                      , extraInputs = extraInputs <> Set.fromList inputs
                      , change = deltaChange (<+> value) change -- <+> is plus of the Val class
                      , deltaVKeys = vkeyPairs <> deltaVKeys delta
                      , deltaScripts = msigPairs <> deltaScripts delta
                      }
    where
      deltaChange ::
        (Value era -> Value era) ->
        TxOut era ->
        TxOut era
      deltaChange :: (Value era -> Value era) -> TxOut era -> TxOut era
deltaChange Value era -> Value era
f TxOut era
txOut = TxOut era
txOut TxOut era -> (TxOut era -> TxOut era) -> TxOut era
forall a b. a -> (a -> b) -> b
& (Value era -> Identity (Value era))
-> TxOut era -> Identity (TxOut era)
forall era. EraTxOut era => Lens' (TxOut era) (Value era)
Lens' (TxOut era) (Value era)
valueTxOutL ((Value era -> Identity (Value era))
 -> TxOut era -> Identity (TxOut era))
-> (Value era -> Value era) -> TxOut era -> TxOut era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Value era -> Value era
f
      getChangeAmount :: TxOut era -> Coin
getChangeAmount TxOut era
txOut = TxOut era
txOut TxOut era -> Getting Coin (TxOut era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (TxOut era) Coin
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut era) Coin
coinTxOutL

-- calculates fixed point of getNextDelta such that
-- reqFees (tx + delta) = dfees delta
-- start with zero delta
-- genNextDelta repeatedly until genNextDelta delta = delta

genNextDeltaTilFixPoint ::
  forall era c.
  ( EraGen era
  , EraUTxO era
  ) =>
  ScriptInfo era ->
  Coin ->
  KeyPairs ->
  [(Script era, Script era)] ->
  UTxO era ->
  PParams era ->
  KeySpace c era ->
  Tx era ->
  Gen (Delta era)
genNextDeltaTilFixPoint :: forall era c.
(EraGen era, EraUTxO era) =>
ScriptInfo era
-> Coin
-> KeyPairs
-> [(Script era, Script era)]
-> UTxO era
-> PParams era
-> KeySpace c era
-> Tx era
-> Gen (Delta era)
genNextDeltaTilFixPoint ScriptInfo era
scriptinfo Coin
initialfee KeyPairs
keys [(Script era, Script era)]
scripts UTxO era
utxo PParams era
pparams KeySpace c era
keySpace Tx era
tx = do
  [Addr]
addrs <- forall era.
EraGen era =>
Int -> KeyPairs -> [(Script era, Script era)] -> Gen [Addr]
genRecipients @era Int
1 KeyPairs
keys [(Script era, Script era)]
scripts
  let addr :: Addr
addr = Addr -> (NonEmpty Addr -> Addr) -> Maybe (NonEmpty Addr) -> Addr
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Addr
forall a. HasCallStack => String -> a
error String
"genNextDeltaTilFixPoint: empty addrs") NonEmpty Addr -> Addr
forall a. NonEmpty a -> a
NE.head (Maybe (NonEmpty Addr) -> Addr) -> Maybe (NonEmpty Addr) -> Addr
forall a b. (a -> b) -> a -> b
$ [Addr] -> Maybe (NonEmpty Addr)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [Addr]
addrs
  Int
-> (Int -> Delta era -> Gen (Delta era))
-> Delta era
-> Gen (Delta era)
forall d (m :: * -> *).
(Eq d, Monad m) =>
Int -> (Int -> d -> m d) -> d -> m d
fix
    Int
0
    (ScriptInfo era
-> UTxO era
-> PParams era
-> KeySpace c era
-> Tx era
-> Int
-> Delta era
-> Gen (Delta era)
forall era c.
(EraGen era, EraUTxO era) =>
ScriptInfo era
-> UTxO era
-> PParams era
-> KeySpace c era
-> Tx era
-> Int
-> Delta era
-> Gen (Delta era)
genNextDelta ScriptInfo era
scriptinfo UTxO era
utxo PParams era
pparams KeySpace c era
keySpace Tx era
tx)
    (Coin -> PParams era -> Addr -> Delta era
forall era.
(EraTxOut era, Monoid (TxWits era)) =>
Coin -> PParams era -> Addr -> Delta era
deltaZero Coin
initialfee PParams era
pparams Addr
addr)

applyDelta ::
  forall era c.
  EraGen era =>
  UTxO era ->
  ScriptInfo era ->
  PParams era ->
  [KeyPair 'Witness] ->
  Map ScriptHash (Script era) ->
  KeySpace c era ->
  Tx era ->
  Delta era ->
  Tx era
applyDelta :: forall era c.
EraGen era =>
UTxO era
-> ScriptInfo era
-> PParams era
-> [KeyPair 'Witness]
-> Map ScriptHash (Script era)
-> KeySpace c era
-> Tx era
-> Delta era
-> Tx era
applyDelta
  UTxO era
utxo
  ScriptInfo era
scriptinfo
  PParams era
pparams
  [KeyPair 'Witness]
neededKeys
  Map ScriptHash (Script era)
neededScripts
  KeySpace_ {Map (KeyHash 'Payment) (KeyPair 'Payment)
ksIndexedPaymentKeys :: forall c era.
KeySpace c era -> Map (KeyHash 'Payment) (KeyPair 'Payment)
ksIndexedPaymentKeys :: Map (KeyHash 'Payment) (KeyPair 'Payment)
ksIndexedPaymentKeys, Map (KeyHash 'Staking) (KeyPair 'Staking)
ksIndexedStakingKeys :: forall c era.
KeySpace c era -> Map (KeyHash 'Staking) (KeyPair 'Staking)
ksIndexedStakingKeys :: Map (KeyHash 'Staking) (KeyPair 'Staking)
ksIndexedStakingKeys}
  Tx era
tx
  (Delta Coin
deltafees Set TxIn
extraIn TxWits era
_extraWits TxOut era
change [KeyPair 'Witness]
extraKeys [(Script era, Script era)]
extraScripts) =
    -- fix up the witnesses here?
    -- Adds extraInputs, extraWitnesses, and change from delta to tx
    let txBody :: TxBody era
txBody = Tx era
tx Tx era -> Getting (TxBody era) (Tx era) (TxBody era) -> TxBody era
forall s a. s -> Getting a s a -> a
^. Getting (TxBody era) (Tx era) (TxBody era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL
        oldWitnessSet :: TxWits era
oldWitnessSet =
          forall era.
EraGen era =>
(UTxO era, TxBody era, ScriptInfo era)
-> Map (KeyHash 'Payment) (KeyPair 'Payment)
-> Map (KeyHash 'Staking) (KeyPair 'Staking)
-> [KeyPair 'Witness]
-> Map ScriptHash (Script era)
-> SafeHash EraIndependentTxBody
-> TxWits era
mkTxWits @era
            (UTxO era
utxo, forall era. EraGen era => TxBody era -> Set TxIn -> TxBody era
addInputs @era TxBody era
txBody Set TxIn
extraIn, ScriptInfo era
scriptinfo)
            Map (KeyHash 'Payment) (KeyPair 'Payment)
ksIndexedPaymentKeys
            Map (KeyHash 'Staking) (KeyPair 'Staking)
ksIndexedStakingKeys
            [KeyPair 'Witness]
kw
            Map ScriptHash (Script era)
sw
            (TxBody era -> SafeHash EraIndependentTxBody
forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated TxBody era
txBody)
        body2 :: TxBody era
body2 =
          (forall era.
EraGen era =>
UTxO era
-> PParams era
-> TxWits era
-> TxBody era
-> Coin
-> Set TxIn
-> TxOut era
-> TxBody era
updateEraTxBody @era)
            UTxO era
utxo
            PParams era
pparams
            TxWits era
oldWitnessSet
            TxBody era
txBody
            Coin
deltafees -- Override the existing fee
            Set TxIn
extraIn -- Union with existing inputs
            TxOut era
change -- Append to end of the existing outputs
        kw :: [KeyPair 'Witness]
kw = [KeyPair 'Witness]
neededKeys [KeyPair 'Witness] -> [KeyPair 'Witness] -> [KeyPair 'Witness]
forall a. Semigroup a => a -> a -> a
<> [KeyPair 'Witness]
extraKeys
        sw :: Map ScriptHash (Script era)
sw = Map ScriptHash (Script era)
neededScripts Map ScriptHash (Script era)
-> Map ScriptHash (Script era) -> Map ScriptHash (Script era)
forall a. Semigroup a => a -> a -> a
<> forall era.
EraGen era =>
[(Script era, Script era)]
-> [(Script era, Script era)] -> Map ScriptHash (Script era)
mkScriptWits @era [(Script era, Script era)]
extraScripts [(Script era, Script era)]
forall a. Monoid a => a
mempty
        newWitnessSet :: TxWits era
newWitnessSet =
          forall era.
EraGen era =>
(UTxO era, TxBody era, ScriptInfo era)
-> Map (KeyHash 'Payment) (KeyPair 'Payment)
-> Map (KeyHash 'Staking) (KeyPair 'Staking)
-> [KeyPair 'Witness]
-> Map ScriptHash (Script era)
-> SafeHash EraIndependentTxBody
-> TxWits era
mkTxWits @era
            (UTxO era
utxo, TxBody era
body2, ScriptInfo era
scriptinfo)
            Map (KeyHash 'Payment) (KeyPair 'Payment)
ksIndexedPaymentKeys
            Map (KeyHash 'Staking) (KeyPair 'Staking)
ksIndexedStakingKeys
            [KeyPair 'Witness]
kw
            Map ScriptHash (Script era)
sw
            (TxBody era -> SafeHash EraIndependentTxBody
forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated TxBody era
body2)
     in forall era.
EraGen era =>
TxBody era -> TxWits era -> StrictMaybe (TxAuxData era) -> Tx era
constructTx @era TxBody era
body2 TxWits era
newWitnessSet (Tx era
tx Tx era
-> Getting
     (StrictMaybe (TxAuxData era))
     (Tx era)
     (StrictMaybe (TxAuxData era))
-> StrictMaybe (TxAuxData era)
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictMaybe (TxAuxData era))
  (Tx era)
  (StrictMaybe (TxAuxData era))
forall era.
EraTx era =>
Lens' (Tx era) (StrictMaybe (TxAuxData era))
Lens' (Tx era) (StrictMaybe (TxAuxData era))
auxDataTxL)

fix :: (Eq d, Monad m) => Int -> (Int -> d -> m d) -> d -> m d
fix :: forall d (m :: * -> *).
(Eq d, Monad m) =>
Int -> (Int -> d -> m d) -> d -> m d
fix Int
n Int -> d -> m d
f d
d = do d
d1 <- Int -> d -> m d
f Int
n d
d; if d
d1 d -> d -> Bool
forall a. Eq a => a -> a -> Bool
== d
d then d -> m d
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure d
d else Int -> (Int -> d -> m d) -> d -> m d
forall d (m :: * -> *).
(Eq d, Monad m) =>
Int -> (Int -> d -> m d) -> d -> m d
fix (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int -> d -> m d
f d
d1

converge ::
  forall era c.
  (EraGen era, EraUTxO era) =>
  ScriptInfo era ->
  Coin ->
  [KeyPair 'Witness] ->
  Map ScriptHash (Script era) ->
  KeyPairs ->
  [(Script era, Script era)] ->
  UTxO era ->
  PParams era ->
  KeySpace c era ->
  Tx era ->
  Gen (Tx era)
converge :: forall era c.
(EraGen era, EraUTxO era) =>
ScriptInfo era
-> Coin
-> [KeyPair 'Witness]
-> Map ScriptHash (Script era)
-> KeyPairs
-> [(Script era, Script era)]
-> UTxO era
-> PParams era
-> KeySpace c era
-> Tx era
-> Gen (Tx era)
converge
  ScriptInfo era
scriptinfo
  Coin
initialfee
  [KeyPair 'Witness]
neededKeys
  Map ScriptHash (Script era)
neededScripts
  KeyPairs
keys
  [(Script era, Script era)]
scripts
  UTxO era
utxo
  PParams era
pparams
  KeySpace c era
keySpace
  Tx era
tx = do
    Delta era
delta <- ScriptInfo era
-> Coin
-> KeyPairs
-> [(Script era, Script era)]
-> UTxO era
-> PParams era
-> KeySpace c era
-> Tx era
-> Gen (Delta era)
forall era c.
(EraGen era, EraUTxO era) =>
ScriptInfo era
-> Coin
-> KeyPairs
-> [(Script era, Script era)]
-> UTxO era
-> PParams era
-> KeySpace c era
-> Tx era
-> Gen (Delta era)
genNextDeltaTilFixPoint ScriptInfo era
scriptinfo Coin
initialfee KeyPairs
keys [(Script era, Script era)]
scripts UTxO era
utxo PParams era
pparams KeySpace c era
keySpace Tx era
tx
    forall era.
EraGen era =>
UTxO era -> PParams era -> Tx era -> Gen (Tx era)
genEraDone @era
      UTxO era
utxo
      PParams era
pparams
      (UTxO era
-> ScriptInfo era
-> PParams era
-> [KeyPair 'Witness]
-> Map ScriptHash (Script era)
-> KeySpace c era
-> Tx era
-> Delta era
-> Tx era
forall era c.
EraGen era =>
UTxO era
-> ScriptInfo era
-> PParams era
-> [KeyPair 'Witness]
-> Map ScriptHash (Script era)
-> KeySpace c era
-> Tx era
-> Delta era
-> Tx era
applyDelta UTxO era
utxo ScriptInfo era
scriptinfo PParams era
pparams [KeyPair 'Witness]
neededKeys Map ScriptHash (Script era)
neededScripts KeySpace c era
keySpace Tx era
tx Delta era
delta)

-- | Return up to /k/ random elements from /items/
-- (instead of the less efficient /take k <$> QC.shuffle items/)
ruffle :: Int -> [a] -> Gen [a]
ruffle :: forall a. Int -> [a] -> Gen [a]
ruffle Int
_ [] = [a] -> Gen [a]
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
ruffle Int
k [a]
items = do
  ([Int]
indices, IntSet
_) <- Int -> (Int, Int) -> Gen ([Int], IntSet)
genIndices Int
k (Int
0, Vector a -> Int
forall a. Vector a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Vector a
itemsV Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
  [a] -> Gen [a]
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a] -> Gen [a]) -> [a] -> Gen [a]
forall a b. (a -> b) -> a -> b
$ (Int -> a) -> [Int] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (Vector a
itemsV Vector a -> Int -> a
forall a. Vector a -> Int -> a
V.!) [Int]
indices
  where
    itemsV :: Vector a
itemsV = [a] -> Vector a
forall a. [a] -> Vector a
V.fromList [a]
items

-- | Generate @k@ number of unique `Int`s in the supplied range.
genIndices :: Int -> (Int, Int) -> Gen ([Int], IntSet.IntSet)
genIndices :: Int -> (Int, Int) -> Gen ([Int], IntSet)
genIndices Int
k (Int
l', Int
u')
  | Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
u Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
k =
      String -> Gen ([Int], IntSet)
forall a. HasCallStack => String -> a
error (String -> Gen ([Int], IntSet)) -> String -> Gen ([Int], IntSet)
forall a b. (a -> b) -> a -> b
$
        String
"Cannot generate "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
k
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" indices in the range ["
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
l
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
u
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"
  | Int
u Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2 = do
      [Int]
xs <- Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
k ([Int] -> [Int]) -> Gen [Int] -> Gen [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int] -> Gen [Int]
forall a. [a] -> Gen [a]
QC.shuffle [Int
l .. Int
u]
      ([Int], IntSet) -> Gen ([Int], IntSet)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Int]
xs, [Int] -> IntSet
IntSet.fromList [Int]
xs)
  | Bool
otherwise = Int -> [Int] -> IntSet -> Gen ([Int], IntSet)
go Int
k [] IntSet
forall a. Monoid a => a
mempty
  where
    (Int
l, Int
u) =
      if Int
l' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
u'
        then (Int
l', Int
u')
        else (Int
u', Int
l')
    go :: Int -> [Int] -> IntSet -> Gen ([Int], IntSet)
go Int
n ![Int]
res !IntSet
acc
      | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = ([Int], IntSet) -> Gen ([Int], IntSet)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Int]
res, IntSet
acc)
      | Bool
otherwise = do
          Int
i <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
QC.choose (Int
l, Int
u)
          if Int -> IntSet -> Bool
IntSet.member Int
i IntSet
acc
            then Int -> [Int] -> IntSet -> Gen ([Int], IntSet)
go Int
n [Int]
res IntSet
acc
            else Int -> [Int] -> IntSet -> Gen ([Int], IntSet)
go (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int
i Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
res) (IntSet -> Gen ([Int], IntSet)) -> IntSet -> Gen ([Int], IntSet)
forall a b. (a -> b) -> a -> b
$ Int -> IntSet -> IntSet
IntSet.insert Int
i IntSet
acc

-- | Select @n@ random key value pairs from the supplied map. Order of keys with
-- respect to each other will also be random, i.e. not sorted.
pickRandomFromMap :: Int -> Map.Map k t -> Gen [(k, t)]
pickRandomFromMap :: forall k t. Int -> Map k t -> Gen [(k, t)]
pickRandomFromMap Int
n Map k t
initMap = (k -> t -> [(k, t)] -> [(k, t)])
-> Maybe Int -> Map k t -> QC -> Gen [(k, t)]
forall g (m :: * -> *) f k v.
(StatefulGen g m, Monoid f) =>
(k -> v -> f -> f) -> Maybe Int -> Map k v -> g -> m f
uniformSubMapElems (\k
k t
v -> ((k
k, t
v) (k, t) -> [(k, t)] -> [(k, t)]
forall a. a -> [a] -> [a]
:)) (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n) Map k t
initMap QC
QC

mkScriptWits ::
  forall era.
  EraGen era =>
  [(Script era, Script era)] ->
  [(Script era, Script era)] ->
  Map ScriptHash (Script era)
mkScriptWits :: forall era.
EraGen era =>
[(Script era, Script era)]
-> [(Script era, Script era)] -> Map ScriptHash (Script era)
mkScriptWits [(Script era, Script era)]
payScripts [(Script era, Script era)]
stakeScripts =
  [(ScriptHash, Script era)] -> Map ScriptHash (Script era)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ScriptHash, Script era)] -> Map ScriptHash (Script era))
-> [(ScriptHash, Script era)] -> Map ScriptHash (Script era)
forall a b. (a -> b) -> a -> b
$
    ((Script era, Script era) -> (ScriptHash, Script era)
hashPayScript ((Script era, Script era) -> (ScriptHash, Script era))
-> [(Script era, Script era)] -> [(ScriptHash, Script era)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Script era, Script era)]
payScripts)
      [(ScriptHash, Script era)]
-> [(ScriptHash, Script era)] -> [(ScriptHash, Script era)]
forall a. [a] -> [a] -> [a]
++ ((Script era, Script era) -> (ScriptHash, Script era)
hashStakeScript ((Script era, Script era) -> (ScriptHash, Script era))
-> [(Script era, Script era)] -> [(ScriptHash, Script era)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Script era, Script era)]
stakeScripts)
  where
    hashPayScript ::
      (Script era, Script era) ->
      (ScriptHash, Script era)
    hashPayScript :: (Script era, Script era) -> (ScriptHash, Script era)
hashPayScript (Script era
payScript, Script era
_) =
      (forall era. EraScript era => Script era -> ScriptHash
hashScript @era Script era
payScript, Script era
payScript)

    hashStakeScript ::
      (Script era, Script era) ->
      (ScriptHash, Script era)
    hashStakeScript :: (Script era, Script era) -> (ScriptHash, Script era)
hashStakeScript (Script era
_, Script era
sScript) =
      (forall era. EraScript era => Script era -> ScriptHash
hashScript @era Script era
sScript, Script era
sScript)

mkTxWits ::
  forall era.
  EraGen era =>
  (UTxO era, TxBody era, ScriptInfo era) ->
  Map (KeyHash 'Payment) (KeyPair 'Payment) ->
  Map (KeyHash 'Staking) (KeyPair 'Staking) ->
  [KeyPair 'Witness] ->
  Map ScriptHash (Script era) ->
  SafeHash EraIndependentTxBody ->
  TxWits era
mkTxWits :: forall era.
EraGen era =>
(UTxO era, TxBody era, ScriptInfo era)
-> Map (KeyHash 'Payment) (KeyPair 'Payment)
-> Map (KeyHash 'Staking) (KeyPair 'Staking)
-> [KeyPair 'Witness]
-> Map ScriptHash (Script era)
-> SafeHash EraIndependentTxBody
-> TxWits era
mkTxWits
  (UTxO era
utxo, TxBody era
txbody, ScriptInfo era
scriptinfo)
  Map (KeyHash 'Payment) (KeyPair 'Payment)
indexedPaymentKeys
  Map (KeyHash 'Staking) (KeyPair 'Staking)
indexedStakingKeys
  [KeyPair 'Witness]
awits
  Map ScriptHash (Script era)
msigs
  SafeHash EraIndependentTxBody
txBodyHash =
    forall era.
EraGen era =>
(UTxO era, TxBody era, ScriptInfo era)
-> Set (WitVKey 'Witness)
-> Map ScriptHash (Script era)
-> TxWits era
genEraTxWits @era
      (UTxO era
utxo, TxBody era
txbody, ScriptInfo era
scriptinfo)
      ( SafeHash EraIndependentTxBody
-> [KeyPair 'Witness] -> Set (WitVKey 'Witness)
forall (kr :: KeyRole).
SafeHash EraIndependentTxBody
-> [KeyPair kr] -> Set (WitVKey 'Witness)
mkWitnessesVKey SafeHash EraIndependentTxBody
txBodyHash [KeyPair 'Witness]
awits
          Set (WitVKey 'Witness)
-> Set (WitVKey 'Witness) -> Set (WitVKey 'Witness)
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` SafeHash EraIndependentTxBody
-> Map (KeyHash 'Witness) (KeyPair 'Witness)
-> Set (KeyHash 'Witness)
-> Set (WitVKey 'Witness)
forall (kr :: KeyRole).
SafeHash EraIndependentTxBody
-> Map (KeyHash kr) (KeyPair kr)
-> Set (KeyHash kr)
-> Set (WitVKey 'Witness)
makeWitnessesFromScriptKeys
            SafeHash EraIndependentTxBody
txBodyHash
            ( Map (KeyHash 'Witness) (KeyPair 'Witness)
indexedPaymentKeysAsWitnesses
                Map (KeyHash 'Witness) (KeyPair 'Witness)
-> Map (KeyHash 'Witness) (KeyPair 'Witness)
-> Map (KeyHash 'Witness) (KeyPair 'Witness)
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Map (KeyHash 'Witness) (KeyPair 'Witness)
indexedStakingKeysAsWitnesses
            )
            Set (KeyHash 'Witness)
msigSignatures
      )
      Map ScriptHash (Script era)
msigs
    where
      indexedPaymentKeysAsWitnesses :: Map (KeyHash 'Witness) (KeyPair 'Witness)
indexedPaymentKeysAsWitnesses =
        [(KeyHash 'Witness, KeyPair 'Witness)]
-> Map (KeyHash 'Witness) (KeyPair 'Witness)
forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList
          ([(KeyHash 'Witness, KeyPair 'Witness)]
 -> Map (KeyHash 'Witness) (KeyPair 'Witness))
-> (Map (KeyHash 'Payment) (KeyPair 'Payment)
    -> [(KeyHash 'Witness, KeyPair 'Witness)])
-> Map (KeyHash 'Payment) (KeyPair 'Payment)
-> Map (KeyHash 'Witness) (KeyPair 'Witness)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((KeyHash 'Payment, KeyPair 'Payment)
 -> (KeyHash 'Witness, KeyPair 'Witness))
-> [(KeyHash 'Payment, KeyPair 'Payment)]
-> [(KeyHash 'Witness, KeyPair 'Witness)]
forall a b. (a -> b) -> [a] -> [b]
map (\(KeyHash 'Payment
a, KeyPair 'Payment
b) -> (KeyHash 'Payment -> KeyHash 'Witness
forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyHash 'Payment
a, KeyPair 'Payment -> KeyPair 'Witness
forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyPair 'Payment
b))
          ([(KeyHash 'Payment, KeyPair 'Payment)]
 -> [(KeyHash 'Witness, KeyPair 'Witness)])
-> (Map (KeyHash 'Payment) (KeyPair 'Payment)
    -> [(KeyHash 'Payment, KeyPair 'Payment)])
-> Map (KeyHash 'Payment) (KeyPair 'Payment)
-> [(KeyHash 'Witness, KeyPair 'Witness)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (KeyHash 'Payment) (KeyPair 'Payment)
-> [(KeyHash 'Payment, KeyPair 'Payment)]
forall k a. Map k a -> [(k, a)]
Map.toAscList
          (Map (KeyHash 'Payment) (KeyPair 'Payment)
 -> Map (KeyHash 'Witness) (KeyPair 'Witness))
-> Map (KeyHash 'Payment) (KeyPair 'Payment)
-> Map (KeyHash 'Witness) (KeyPair 'Witness)
forall a b. (a -> b) -> a -> b
$ Map (KeyHash 'Payment) (KeyPair 'Payment)
indexedPaymentKeys
      indexedStakingKeysAsWitnesses :: Map (KeyHash 'Witness) (KeyPair 'Witness)
indexedStakingKeysAsWitnesses =
        [(KeyHash 'Witness, KeyPair 'Witness)]
-> Map (KeyHash 'Witness) (KeyPair 'Witness)
forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList
          ([(KeyHash 'Witness, KeyPair 'Witness)]
 -> Map (KeyHash 'Witness) (KeyPair 'Witness))
-> (Map (KeyHash 'Staking) (KeyPair 'Staking)
    -> [(KeyHash 'Witness, KeyPair 'Witness)])
-> Map (KeyHash 'Staking) (KeyPair 'Staking)
-> Map (KeyHash 'Witness) (KeyPair 'Witness)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((KeyHash 'Staking, KeyPair 'Staking)
 -> (KeyHash 'Witness, KeyPair 'Witness))
-> [(KeyHash 'Staking, KeyPair 'Staking)]
-> [(KeyHash 'Witness, KeyPair 'Witness)]
forall a b. (a -> b) -> [a] -> [b]
map (\(KeyHash 'Staking
a, KeyPair 'Staking
b) -> (KeyHash 'Staking -> KeyHash 'Witness
forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyHash 'Staking
a, KeyPair 'Staking -> KeyPair 'Witness
forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyPair 'Staking
b))
          ([(KeyHash 'Staking, KeyPair 'Staking)]
 -> [(KeyHash 'Witness, KeyPair 'Witness)])
-> (Map (KeyHash 'Staking) (KeyPair 'Staking)
    -> [(KeyHash 'Staking, KeyPair 'Staking)])
-> Map (KeyHash 'Staking) (KeyPair 'Staking)
-> [(KeyHash 'Witness, KeyPair 'Witness)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (KeyHash 'Staking) (KeyPair 'Staking)
-> [(KeyHash 'Staking, KeyPair 'Staking)]
forall k a. Map k a -> [(k, a)]
Map.toAscList
          (Map (KeyHash 'Staking) (KeyPair 'Staking)
 -> Map (KeyHash 'Witness) (KeyPair 'Witness))
-> Map (KeyHash 'Staking) (KeyPair 'Staking)
-> Map (KeyHash 'Witness) (KeyPair 'Witness)
forall a b. (a -> b) -> a -> b
$ Map (KeyHash 'Staking) (KeyPair 'Staking)
indexedStakingKeys
      keysLists :: [[KeyHash 'Witness]]
keysLists = (Script era -> [KeyHash 'Witness])
-> [Script era] -> [[KeyHash 'Witness]]
forall a b. (a -> b) -> [a] -> [b]
map (Proxy era -> Script era -> [KeyHash 'Witness]
forall era.
ScriptClass era =>
Proxy era -> Script era -> [KeyHash 'Witness]
scriptKeyCombination (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @era)) (Map ScriptHash (Script era) -> [Script era]
forall k a. Map k a -> [a]
Map.elems Map ScriptHash (Script era)
msigs)
      msigSignatures :: Set (KeyHash 'Witness)
msigSignatures = (Set (KeyHash 'Witness)
 -> Set (KeyHash 'Witness) -> Set (KeyHash 'Witness))
-> Set (KeyHash 'Witness)
-> [Set (KeyHash 'Witness)]
-> Set (KeyHash 'Witness)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' Set (KeyHash 'Witness)
-> Set (KeyHash 'Witness) -> Set (KeyHash 'Witness)
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set (KeyHash 'Witness)
forall a. Set a
Set.empty ([Set (KeyHash 'Witness)] -> Set (KeyHash 'Witness))
-> [Set (KeyHash 'Witness)] -> Set (KeyHash 'Witness)
forall a b. (a -> b) -> a -> b
$ ([KeyHash 'Witness] -> Set (KeyHash 'Witness))
-> [[KeyHash 'Witness]] -> [Set (KeyHash 'Witness)]
forall a b. (a -> b) -> [a] -> [b]
map [KeyHash 'Witness] -> Set (KeyHash 'Witness)
forall a. Ord a => [a] -> Set a
Set.fromList [[KeyHash 'Witness]]
keysLists

-- | Distribute the sum of `balance_` and `fee` over the addresses, return the
-- sum of `fee` and the remainder of the equal distribution and the list ouf
-- transaction outputs that cover the balance and fees.
--
-- The idea is to have an specified spending balance and fees that must be paid
-- by the selected addresses.
-- TODO need right splitting of v!
calcOutputsFromBalance ::
  forall era.
  ( EraTxOut era
  , Split (Value era)
  ) =>
  Value era ->
  [Addr] ->
  Coin ->
  (Coin, StrictSeq (TxOut era))
calcOutputsFromBalance :: forall era.
(EraTxOut era, Split (Value era)) =>
Value era -> [Addr] -> Coin -> (Coin, StrictSeq (TxOut era))
calcOutputsFromBalance Value era
balance_ [Addr]
addrs Coin
fee =
  ( Coin
fee Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> Coin
splitCoinRem
  , [TxOut era] -> StrictSeq (TxOut era)
forall a. [a] -> StrictSeq a
StrictSeq.fromList ([TxOut era] -> StrictSeq (TxOut era))
-> [TxOut era] -> StrictSeq (TxOut era)
forall a b. (a -> b) -> a -> b
$ (Addr -> Value era -> TxOut era)
-> [Addr] -> [Value era] -> [TxOut era]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut [Addr]
addrs [Value era]
amountPerOutput
  )
  where
    -- split the available balance into equal portions (one for each address),
    -- if there is a remainder, then add it to the fee.
    balanceAfterFee :: Value era
balanceAfterFee = Value era
balance_ Value era -> Value era -> Value era
forall t. Val t => t -> t -> t
<-> Coin -> Value era
forall t s. Inject t s => t -> s
inject Coin
fee
    ([Value era]
amountPerOutput, Coin
splitCoinRem) =
      Value era -> Integer -> ([Value era], Coin)
forall v. Split v => v -> Integer -> ([v], Coin)
vsplit Value era
balanceAfterFee (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ [Addr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Addr]
addrs)

-- | Select unspent output(s) to serve as inputs for a new transaction
--
-- Returns the inputs, paired with the KeyPair or multi-sig script required to
-- witness the spending of the input.
-- Also returns the total spendable balance.

-- NOTE: this function needs access to the keys and multi-sig scripts that the
-- given UTxO originated from (in order to produce the appropriate witnesses to
-- spend these outputs). If this is not the case, `findPayKeyPairAddr` /
-- `findPayScriptFromAddr` will fail by not finding the matching keys or scripts.
genInputs ::
  forall era.
  EraTxOut era =>
  (Int, Int) ->
  Map (KeyHash 'Payment) (KeyPair 'Payment) ->
  Map ScriptHash (Script era, Script era) ->
  UTxO era ->
  Gen
    ( [TxIn]
    , Value era
    , ([KeyPair 'Witness], [(Script era, Script era)])
    )
genInputs :: forall era.
EraTxOut era =>
(Int, Int)
-> Map (KeyHash 'Payment) (KeyPair 'Payment)
-> Map ScriptHash (Script era, Script era)
-> UTxO era
-> Gen
     ([TxIn], Value era,
      ([KeyPair 'Witness], [(Script era, Script era)]))
genInputs (Int
minNumGenInputs, Int
maxNumGenInputs) Map (KeyHash 'Payment) (KeyPair 'Payment)
keyHashMap Map ScriptHash (Script era, Script era)
payScriptMap (UTxO Map TxIn (TxOut era)
utxo) = do
  Int
numInputs <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
QC.choose (Int
minNumGenInputs, Int
maxNumGenInputs)
  [(TxIn, TxOut era)]
selectedUtxo <- Int -> Map TxIn (TxOut era) -> Gen [(TxIn, TxOut era)]
forall k t. Int -> Map k t -> Gen [(k, t)]
pickRandomFromMap Int
numInputs Map TxIn (TxOut era)
utxo
  let ([TxIn]
inputs, [Either (KeyPair 'Witness) (Script era, Script era)]
witnesses) = [(TxIn, Either (KeyPair 'Witness) (Script era, Script era))]
-> ([TxIn], [Either (KeyPair 'Witness) (Script era, Script era)])
forall a b. [(a, b)] -> ([a], [b])
unzip ((TxOut era -> Either (KeyPair 'Witness) (Script era, Script era))
-> (TxIn, TxOut era)
-> (TxIn, Either (KeyPair 'Witness) (Script era, Script era))
forall a b. (a -> b) -> (TxIn, a) -> (TxIn, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TxOut era -> Either (KeyPair 'Witness) (Script era, Script era)
witnessedInput ((TxIn, TxOut era)
 -> (TxIn, Either (KeyPair 'Witness) (Script era, Script era)))
-> [(TxIn, TxOut era)]
-> [(TxIn, Either (KeyPair 'Witness) (Script era, Script era))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(TxIn, TxOut era)]
selectedUtxo)
  ([TxIn], Value era,
 ([KeyPair 'Witness], [(Script era, Script era)]))
-> Gen
     ([TxIn], Value era,
      ([KeyPair 'Witness], [(Script era, Script era)]))
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return
    ( [TxIn]
inputs
    , forall era (f :: * -> *).
(EraTxOut era, Foldable f) =>
f (TxOut era) -> Value era
sumAllValue @era ((TxIn, TxOut era) -> TxOut era
forall a b. (a, b) -> b
snd ((TxIn, TxOut era) -> TxOut era)
-> [(TxIn, TxOut era)] -> [TxOut era]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(TxIn, TxOut era)]
selectedUtxo)
    , [Either (KeyPair 'Witness) (Script era, Script era)]
-> ([KeyPair 'Witness], [(Script era, Script era)])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either (KeyPair 'Witness) (Script era, Script era)]
witnesses
    )
  where
    witnessedInput :: TxOut era -> Either (KeyPair 'Witness) (Script era, Script era)
witnessedInput TxOut era
output =
      case TxOut era
output TxOut era -> Getting Addr (TxOut era) Addr -> Addr
forall s a. s -> Getting a s a -> a
^. Getting Addr (TxOut era) Addr
forall era. EraTxOut era => Lens' (TxOut era) Addr
Lens' (TxOut era) Addr
addrTxOutL of
        addr :: Addr
addr@(Addr Network
_ (KeyHashObj KeyHash 'Payment
_) StakeReference
_) ->
          KeyPair 'Witness
-> Either (KeyPair 'Witness) (Script era, Script era)
forall a b. a -> Either a b
Left (KeyPair 'Witness
 -> Either (KeyPair 'Witness) (Script era, Script era))
-> (KeyPair 'Payment -> KeyPair 'Witness)
-> KeyPair 'Payment
-> Either (KeyPair 'Witness) (Script era, Script era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyPair 'Payment -> KeyPair 'Witness
forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness (KeyPair 'Payment
 -> Either (KeyPair 'Witness) (Script era, Script era))
-> KeyPair 'Payment
-> Either (KeyPair 'Witness) (Script era, Script era)
forall a b. (a -> b) -> a -> b
$ Addr
-> Map (KeyHash 'Payment) (KeyPair 'Payment) -> KeyPair 'Payment
findPayKeyPairAddr Addr
addr Map (KeyHash 'Payment) (KeyPair 'Payment)
keyHashMap
        addr :: Addr
addr@(Addr Network
_ (ScriptHashObj ScriptHash
_) StakeReference
_) ->
          (Script era, Script era)
-> Either (KeyPair 'Witness) (Script era, Script era)
forall a b. b -> Either a b
Right ((Script era, Script era)
 -> Either (KeyPair 'Witness) (Script era, Script era))
-> (Script era, Script era)
-> Either (KeyPair 'Witness) (Script era, Script era)
forall a b. (a -> b) -> a -> b
$ forall era.
Addr
-> Map ScriptHash (Script era, Script era)
-> (Script era, Script era)
findPayScriptFromAddr @era Addr
addr Map ScriptHash (Script era, Script era)
payScriptMap
        Addr
_ -> String -> Either (KeyPair 'Witness) (Script era, Script era)
forall a. HasCallStack => String -> a
error String
"unsupported address"

-- | Select a subset of the reward accounts to use for reward withdrawals.
genWithdrawals ::
  forall era.
  Constants ->
  Map ScriptHash (Script era, Script era) ->
  Map (KeyHash 'Staking) (KeyPair 'Staking) ->
  Map (Credential 'Staking) Coin ->
  Gen
    ( [(RewardAccount, Coin)]
    , ([KeyPair 'Witness], [(Script era, Script era)])
    )
genWithdrawals :: forall era.
Constants
-> Map ScriptHash (Script era, Script era)
-> Map (KeyHash 'Staking) (KeyPair 'Staking)
-> Map (Credential 'Staking) Coin
-> Gen
     ([(RewardAccount, Coin)],
      ([KeyPair 'Witness], [(Script era, Script era)]))
genWithdrawals
  Constants
    { Int
frequencyNoWithdrawals :: Int
frequencyNoWithdrawals :: Constants -> Int
frequencyNoWithdrawals
    , Int
frequencyAFewWithdrawals :: Int
frequencyAFewWithdrawals :: Constants -> Int
frequencyAFewWithdrawals
    , Int
frequencyPotentiallyManyWithdrawals :: Int
frequencyPotentiallyManyWithdrawals :: Constants -> Int
frequencyPotentiallyManyWithdrawals
    , Int
maxAFewWithdrawals :: Int
maxAFewWithdrawals :: Constants -> Int
maxAFewWithdrawals
    }
  Map ScriptHash (Script era, Script era)
ksIndexedStakeScripts
  Map (KeyHash 'Staking) (KeyPair 'Staking)
ksIndexedStakingKeys
  Map (Credential 'Staking) Coin
withdrawals = do
    ([(RewardAccount, Coin)]
a, ([KeyPair 'Witness], [(Script era, Script era)])
b) <-
      [(Int,
  Gen
    ([(RewardAccount, Coin)],
     ([KeyPair 'Witness], [(Script era, Script era)])))]
-> Gen
     ([(RewardAccount, Coin)],
      ([KeyPair 'Witness], [(Script era, Script era)]))
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
QC.frequency
        [
          ( Int
frequencyNoWithdrawals
          , ([(RewardAccount, Coin)],
 ([KeyPair 'Witness], [(Script era, Script era)]))
-> Gen
     ([(RewardAccount, Coin)],
      ([KeyPair 'Witness], [(Script era, Script era)]))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], ([], []))
          )
        ,
          ( Int
frequencyAFewWithdrawals
          , [(Credential 'Staking, Coin)]
-> Gen
     ([(RewardAccount, Coin)],
      ([KeyPair 'Witness], [(Script era, Script era)]))
genWrdls (Int
-> [(Credential 'Staking, Coin)] -> [(Credential 'Staking, Coin)]
forall a. Int -> [a] -> [a]
take Int
maxAFewWithdrawals ([(Credential 'Staking, Coin)] -> [(Credential 'Staking, Coin)])
-> (Map (Credential 'Staking) Coin
    -> [(Credential 'Staking, Coin)])
-> Map (Credential 'Staking) Coin
-> [(Credential 'Staking, Coin)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (Credential 'Staking) Coin -> [(Credential 'Staking, Coin)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map (Credential 'Staking) Coin -> [(Credential 'Staking, Coin)])
-> Map (Credential 'Staking) Coin -> [(Credential 'Staking, Coin)]
forall a b. (a -> b) -> a -> b
$ Map (Credential 'Staking) Coin
withdrawals)
          )
        ,
          ( Int
frequencyPotentiallyManyWithdrawals
          , [(Credential 'Staking, Coin)]
-> Gen
     ([(RewardAccount, Coin)],
      ([KeyPair 'Witness], [(Script era, Script era)]))
genWrdls (Map (Credential 'Staking) Coin -> [(Credential 'Staking, Coin)]
forall k a. Map k a -> [(k, a)]
Map.toList Map (Credential 'Staking) Coin
withdrawals)
          )
        ]
    ([(RewardAccount, Coin)],
 ([KeyPair 'Witness], [(Script era, Script era)]))
-> Gen
     ([(RewardAccount, Coin)],
      ([KeyPair 'Witness], [(Script era, Script era)]))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(RewardAccount, Coin)]
a, ([KeyPair 'Witness], [(Script era, Script era)])
b)
    where
      toRewardAccount :: (Credential 'Staking, b) -> (RewardAccount, b)
toRewardAccount (Credential 'Staking
rwd, b
coinx) = (Network -> Credential 'Staking -> RewardAccount
RewardAccount Network
Testnet Credential 'Staking
rwd, b
coinx)
      genWrdls :: [(Credential 'Staking, Coin)]
-> Gen
     ([(RewardAccount, Coin)],
      ([KeyPair 'Witness], [(Script era, Script era)]))
genWrdls [(Credential 'Staking, Coin)]
withdrawals_ = do
        [(RewardAccount, Coin)]
selectedWrdls <- ((Credential 'Staking, Coin) -> (RewardAccount, Coin))
-> [(Credential 'Staking, Coin)] -> [(RewardAccount, Coin)]
forall a b. (a -> b) -> [a] -> [b]
map (Credential 'Staking, Coin) -> (RewardAccount, Coin)
forall {b}. (Credential 'Staking, b) -> (RewardAccount, b)
toRewardAccount ([(Credential 'Staking, Coin)] -> [(RewardAccount, Coin)])
-> Gen [(Credential 'Staking, Coin)] -> Gen [(RewardAccount, Coin)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Credential 'Staking, Coin)] -> Gen [(Credential 'Staking, Coin)]
forall a. [a] -> Gen [a]
QC.sublistOf [(Credential 'Staking, Coin)]
withdrawals_
        let txwits :: [Either (KeyPair 'Witness) (Script era, Script era)]
txwits =
              forall era.
Map ScriptHash (Script era, Script era)
-> Map (KeyHash 'Staking) (KeyPair 'Staking)
-> Credential 'Staking
-> Either (KeyPair 'Witness) (Script era, Script era)
mkWithdrawalsWits @era Map ScriptHash (Script era, Script era)
ksIndexedStakeScripts Map (KeyHash 'Staking) (KeyPair 'Staking)
ksIndexedStakingKeys
                (Credential 'Staking
 -> Either (KeyPair 'Witness) (Script era, Script era))
-> ((RewardAccount, Coin) -> Credential 'Staking)
-> (RewardAccount, Coin)
-> Either (KeyPair 'Witness) (Script era, Script era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RewardAccount -> Credential 'Staking
raCredential
                (RewardAccount -> Credential 'Staking)
-> ((RewardAccount, Coin) -> RewardAccount)
-> (RewardAccount, Coin)
-> Credential 'Staking
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RewardAccount, Coin) -> RewardAccount
forall a b. (a, b) -> a
fst
                ((RewardAccount, Coin)
 -> Either (KeyPair 'Witness) (Script era, Script era))
-> [(RewardAccount, Coin)]
-> [Either (KeyPair 'Witness) (Script era, Script era)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(RewardAccount, Coin)]
selectedWrdls
        ([(RewardAccount, Coin)],
 ([KeyPair 'Witness], [(Script era, Script era)]))
-> Gen
     ([(RewardAccount, Coin)],
      ([KeyPair 'Witness], [(Script era, Script era)]))
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(RewardAccount, Coin)]
selectedWrdls, [Either (KeyPair 'Witness) (Script era, Script era)]
-> ([KeyPair 'Witness], [(Script era, Script era)])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either (KeyPair 'Witness) (Script era, Script era)]
txwits)

-- | Collect witnesses needed for reward withdrawals.
mkWithdrawalsWits ::
  forall era.
  Map ScriptHash (Script era, Script era) ->
  Map (KeyHash 'Staking) (KeyPair 'Staking) ->
  Credential 'Staking ->
  Either (KeyPair 'Witness) (Script era, Script era)
mkWithdrawalsWits :: forall era.
Map ScriptHash (Script era, Script era)
-> Map (KeyHash 'Staking) (KeyPair 'Staking)
-> Credential 'Staking
-> Either (KeyPair 'Witness) (Script era, Script era)
mkWithdrawalsWits Map ScriptHash (Script era, Script era)
scriptsByStakeHash Map (KeyHash 'Staking) (KeyPair 'Staking)
_ c :: Credential 'Staking
c@(ScriptHashObj ScriptHash
_) =
  (Script era, Script era)
-> Either (KeyPair 'Witness) (Script era, Script era)
forall a b. b -> Either a b
Right ((Script era, Script era)
 -> Either (KeyPair 'Witness) (Script era, Script era))
-> (Script era, Script era)
-> Either (KeyPair 'Witness) (Script era, Script era)
forall a b. (a -> b) -> a -> b
$
    forall era.
Credential 'Witness
-> Map ScriptHash (Script era, Script era)
-> (Script era, Script era)
findStakeScriptFromCred @era (Credential 'Staking -> Credential 'Witness
forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness Credential 'Staking
c) Map ScriptHash (Script era, Script era)
scriptsByStakeHash
mkWithdrawalsWits Map ScriptHash (Script era, Script era)
_ Map (KeyHash 'Staking) (KeyPair 'Staking)
keyHashMap c :: Credential 'Staking
c@(KeyHashObj KeyHash 'Staking
_) =
  KeyPair 'Witness
-> Either (KeyPair 'Witness) (Script era, Script era)
forall a b. a -> Either a b
Left (KeyPair 'Witness
 -> Either (KeyPair 'Witness) (Script era, Script era))
-> KeyPair 'Witness
-> Either (KeyPair 'Witness) (Script era, Script era)
forall a b. (a -> b) -> a -> b
$
    KeyPair 'Staking -> KeyPair 'Witness
forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness (KeyPair 'Staking -> KeyPair 'Witness)
-> KeyPair 'Staking -> KeyPair 'Witness
forall a b. (a -> b) -> a -> b
$
      Credential 'Staking
-> Map (KeyHash 'Staking) (KeyPair 'Staking) -> KeyPair 'Staking
forall (kr :: KeyRole).
Credential kr -> Map (KeyHash kr) (KeyPair kr) -> KeyPair kr
findPayKeyPairCred Credential 'Staking
c Map (KeyHash 'Staking) (KeyPair 'Staking)
keyHashMap

-- | Select recipient addresses that will serve as output targets for a new
-- transaction.
genRecipients ::
  forall era.
  EraGen era =>
  Int ->
  KeyPairs ->
  [(Script era, Script era)] ->
  Gen [Addr]
genRecipients :: forall era.
EraGen era =>
Int -> KeyPairs -> [(Script era, Script era)] -> Gen [Addr]
genRecipients Int
nRecipients' KeyPairs
keys [(Script era, Script era)]
scripts = do
  Int
nRecipients <-
    Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1
      (Int -> Int) -> Gen Int -> Gen Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, Gen Int)] -> Gen Int
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
QC.frequency
        [ (Int
1, Int -> Gen Int
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
nRecipients' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) -- contract size of UTxO
        , (Int
2, Int -> Gen Int
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
nRecipients') -- keep size
        , (Int
1, Int -> Gen Int
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
nRecipients' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) -- expand size of UTxO
        ]

  -- We want to choose more Keys than Scripts by a factor of 2 or more.
  Int
nScripts <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
QC.choose (Int
0, Int
nRecipients Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
3) -- Average is about nRecipients / 3
  let nKeys :: Int
nKeys = Int
nRecipients Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
nScripts

  KeyPairs
recipientKeys <- Int -> KeyPairs -> Gen KeyPairs
forall a. Int -> [a] -> Gen [a]
ruffle Int
nKeys KeyPairs
keys
  [(Script era, Script era)]
recipientScripts <- Int -> [(Script era, Script era)] -> Gen [(Script era, Script era)]
forall a. Int -> [a] -> Gen [a]
ruffle Int
nScripts [(Script era, Script era)]
scripts

  let payKeys :: [Credential 'Payment]
payKeys = KeyPair 'Payment -> Credential 'Payment
forall c (r :: KeyRole). MakeCredential c r => c -> Credential r
mkCredential (KeyPair 'Payment -> Credential 'Payment)
-> ((KeyPair 'Payment, KeyPair 'Staking) -> KeyPair 'Payment)
-> (KeyPair 'Payment, KeyPair 'Staking)
-> Credential 'Payment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KeyPair 'Payment, KeyPair 'Staking) -> KeyPair 'Payment
forall a b. (a, b) -> a
fst ((KeyPair 'Payment, KeyPair 'Staking) -> Credential 'Payment)
-> KeyPairs -> [Credential 'Payment]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyPairs
recipientKeys
      stakeKeys :: [Credential 'Staking]
stakeKeys = KeyPair 'Staking -> Credential 'Staking
forall c (r :: KeyRole). MakeCredential c r => c -> Credential r
mkCredential (KeyPair 'Staking -> Credential 'Staking)
-> ((KeyPair 'Payment, KeyPair 'Staking) -> KeyPair 'Staking)
-> (KeyPair 'Payment, KeyPair 'Staking)
-> Credential 'Staking
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KeyPair 'Payment, KeyPair 'Staking) -> KeyPair 'Staking
forall a b. (a, b) -> b
snd ((KeyPair 'Payment, KeyPair 'Staking) -> Credential 'Staking)
-> KeyPairs -> [Credential 'Staking]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyPairs
recipientKeys
      payScripts :: [Credential 'Payment]
payScripts = ScriptHash -> Credential 'Payment
forall c (r :: KeyRole). MakeCredential c r => c -> Credential r
mkCredential (ScriptHash -> Credential 'Payment)
-> ((Script era, Script era) -> ScriptHash)
-> (Script era, Script era)
-> Credential 'Payment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Script era -> ScriptHash
forall era. EraScript era => Script era -> ScriptHash
hashScript (Script era -> ScriptHash)
-> ((Script era, Script era) -> Script era)
-> (Script era, Script era)
-> ScriptHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Script era, Script era) -> Script era
forall a b. (a, b) -> a
fst ((Script era, Script era) -> Credential 'Payment)
-> [(Script era, Script era)] -> [Credential 'Payment]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Script era, Script era)]
recipientScripts
      stakeScripts :: [Credential 'Staking]
stakeScripts = ScriptHash -> Credential 'Staking
forall c (r :: KeyRole). MakeCredential c r => c -> Credential r
mkCredential (ScriptHash -> Credential 'Staking)
-> ((Script era, Script era) -> ScriptHash)
-> (Script era, Script era)
-> Credential 'Staking
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Script era -> ScriptHash
forall era. EraScript era => Script era -> ScriptHash
hashScript (Script era -> ScriptHash)
-> ((Script era, Script era) -> Script era)
-> (Script era, Script era)
-> ScriptHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Script era, Script era) -> Script era
forall a b. (a, b) -> b
snd ((Script era, Script era) -> Credential 'Staking)
-> [(Script era, Script era)] -> [Credential 'Staking]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Script era, Script era)]
recipientScripts

  -- zip keys and scripts together as base addresses
  let payCreds :: [Credential 'Payment]
      payCreds :: [Credential 'Payment]
payCreds = [Credential 'Payment]
payKeys [Credential 'Payment]
-> [Credential 'Payment] -> [Credential 'Payment]
forall a. [a] -> [a] -> [a]
++ [Credential 'Payment]
payScripts
      stakeCreds :: [Credential 'Staking]
      stakeCreds :: [Credential 'Staking]
stakeCreds = [Credential 'Staking]
stakeKeys [Credential 'Staking]
-> [Credential 'Staking] -> [Credential 'Staking]
forall a. [a] -> [a] -> [a]
++ [Credential 'Staking]
stakeScripts

  [Addr] -> Gen [Addr]
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Credential 'Payment -> Credential 'Staking -> Addr)
-> [Credential 'Payment] -> [Credential 'Staking] -> [Addr]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Credential 'Payment -> Credential 'Staking -> Addr
forall p s.
(MakeCredential p 'Payment, MakeStakeReference s) =>
p -> s -> Addr
mkAddr [Credential 'Payment]
payCreds [Credential 'Staking]
stakeCreds)

genPtrAddrs :: DState era -> [Addr] -> Gen [Addr]
genPtrAddrs :: forall era. DState era -> [Addr] -> Gen [Addr]
genPtrAddrs DState era
ds [Addr]
addrs = do
  let pointers :: Map Ptr (Credential 'Staking)
pointers = DState era -> Map Ptr (Credential 'Staking)
forall era. DState era -> Map Ptr (Credential 'Staking)
ptrsMap DState era
ds
  Int
n <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
QC.choose (Int
0, Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Map Ptr (Credential 'Staking) -> Int
forall k a. Map k a -> Int
Map.size Map Ptr (Credential 'Staking)
pointers) ([Addr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Addr]
addrs))
  [Ptr]
pointerList <- ((Ptr, Credential 'Staking) -> Ptr)
-> [(Ptr, Credential 'Staking)] -> [Ptr]
forall a b. (a -> b) -> [a] -> [b]
map (Ptr, Credential 'Staking) -> Ptr
forall a b. (a, b) -> a
fst ([(Ptr, Credential 'Staking)] -> [Ptr])
-> Gen [(Ptr, Credential 'Staking)] -> Gen [Ptr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> Map Ptr (Credential 'Staking)
-> Gen [(Ptr, Credential 'Staking)]
forall k t. Int -> Map k t -> Gen [(k, t)]
pickRandomFromMap Int
n Map Ptr (Credential 'Staking)
pointers

  let addrs' :: [Addr]
addrs' = (Addr -> Ptr -> Addr) -> [Addr] -> [Ptr] -> [Addr]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Addr -> Ptr -> Addr
baseAddrToPtrAddr (Int -> [Addr] -> [Addr]
forall a. Int -> [a] -> [a]
take Int
n [Addr]
addrs) [Ptr]
pointerList

  [Addr] -> Gen [Addr]
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Addr]
addrs' [Addr] -> [Addr] -> [Addr]
forall a. [a] -> [a] -> [a]
++ Int -> [Addr] -> [Addr]
forall a. Int -> [a] -> [a]
drop Int
n [Addr]
addrs)
  where
    baseAddrToPtrAddr :: Addr -> Ptr -> Addr
baseAddrToPtrAddr Addr
a Ptr
p = case Addr
a of
      Addr Network
n Credential 'Payment
pay StakeReference
_ -> Network -> Credential 'Payment -> StakeReference -> Addr
Addr Network
n Credential 'Payment
pay (Ptr -> StakeReference
StakeRefPtr Ptr
p)
      Addr
_ -> Addr
a