{-# 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 (
  CertState (..),
  DState (..),
  LedgerState (..),
  UTxOState (..),
  certDState,
  ptrsMap,
  rewards,
 )
import Cardano.Ledger.Shelley.Rules (DelplEnv, LedgerEnv (..))
import Cardano.Ledger.Shelley.TxBody (Withdrawals (..))
import Cardano.Ledger.TxIn (TxIn (..))
import qualified Cardano.Ledger.UMap as UM
import Cardano.Ledger.UTxO (
  EraUTxO,
  UTxO (..),
  getMinFeeTxUtxo,
  sumAllValue,
 )
import Cardano.Ledger.Val (Val (..), sumVal, (<+>), (<->), (<×>))
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,
  mkCred,
  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.
  ( 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
  ) =>
  GenEnv era ->
  LedgerEnv era ->
  LedgerState era ->
  Gen (Tx era)
genTx :: forall era.
(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) =>
GenEnv era -> LedgerEnv era -> LedgerState era -> Gen (Tx era)
genTx
  ge :: GenEnv era
ge@( GenEnv
        keySpace :: KeySpace era
keySpace@KeySpace_
          { KeyPairs
ksKeyPairs :: forall era. KeySpace era -> KeyPairs
ksKeyPairs :: KeyPairs
ksKeyPairs
          , [(GenesisKeyPair MockCrypto,
  AllIssuerKeys MockCrypto 'GenesisDelegate)]
ksCoreNodes :: forall era.
KeySpace era
-> [(GenesisKeyPair MockCrypto,
     AllIssuerKeys MockCrypto 'GenesisDelegate)]
ksCoreNodes :: [(GenesisKeyPair MockCrypto,
  AllIssuerKeys MockCrypto 'GenesisDelegate)]
ksCoreNodes
          , [(Script era, Script era)]
ksMSigScripts :: forall era. KeySpace era -> [(Script era, Script era)]
ksMSigScripts :: [(Script era, Script era)]
ksMSigScripts
          , Map
  (KeyHash 'GenesisDelegate)
  (AllIssuerKeys MockCrypto 'GenesisDelegate)
ksIndexedGenDelegates :: forall era.
KeySpace era
-> Map
     (KeyHash 'GenesisDelegate)
     (AllIssuerKeys MockCrypto 'GenesisDelegate)
ksIndexedGenDelegates :: Map
  (KeyHash 'GenesisDelegate)
  (AllIssuerKeys MockCrypto 'GenesisDelegate)
ksIndexedGenDelegates
          , Map (KeyHash 'Payment) (KeyPair 'Payment)
ksIndexedPaymentKeys :: forall era.
KeySpace era -> Map (KeyHash 'Payment) (KeyPair 'Payment)
ksIndexedPaymentKeys :: Map (KeyHash 'Payment) (KeyPair 'Payment)
ksIndexedPaymentKeys
          , Map (KeyHash 'Staking) (KeyPair 'Staking)
ksIndexedStakingKeys :: forall era.
KeySpace era -> Map (KeyHash 'Staking) (KeyPair 'Staking)
ksIndexedStakingKeys :: Map (KeyHash 'Staking) (KeyPair 'Staking)
ksIndexedStakingKeys
          , Map ScriptHash (Script era, Script era)
ksIndexedPayScripts :: forall era. KeySpace era -> Map ScriptHash (Script era, Script era)
ksIndexedPayScripts :: Map ScriptHash (Script era, Script era)
ksIndexedPayScripts
          , Map ScriptHash (Script era, Script era)
ksIndexedStakeScripts :: forall era. KeySpace era -> Map ScriptHash (Script era, Script era)
ksIndexedStakeScripts :: Map ScriptHash (Script era, Script era)
ksIndexedStakeScripts
          }
        ScriptSpace era
scriptspace
        Constants
constants
      )
  (LedgerEnv SlotNo
slot Maybe EpochNo
_ TxIx
txIx PParams era
pparams AccountState
reserves Bool
_)
  (LedgerState utxoSt :: UTxOState era
utxoSt@(UTxOState UTxO era
utxo Coin
_ Coin
_ GovState era
_ IncrementalStake
_ 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)) <-
        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
          ((forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (forall a. Compactible a => CompactForm a -> a
UM.fromCompact forall b c a. (b -> c) -> (a -> b) -> a -> c
. RDPair -> CompactForm Coin
UM.rdReward) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. UView k v -> Map k v
UM.unUnify forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. DState era -> UView (Credential 'Staking) RDPair
rewards forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. CertState era -> DState era
certDState) CertState era
dpState)
      (Maybe (Update era)
update, [KeyPair 'Witness]
updateWits) <-
        forall era.
EraGen era =>
Constants
-> SlotNo
-> [(GenesisKeyPair MockCrypto,
     AllIssuerKeys MockCrypto 'GenesisDelegate)]
-> Map
     (KeyHash 'GenesisDelegate)
     (AllIssuerKeys MockCrypto 'GenesisDelegate)
-> PParams era
-> (UTxOState era, CertState era)
-> Gen (Maybe (Update era), [KeyPair 'Witness])
genUpdate
          Constants
constants
          SlotNo
slot
          [(GenesisKeyPair MockCrypto,
  AllIssuerKeys MockCrypto 'GenesisDelegate)]
ksCoreNodes
          Map
  (KeyHash 'GenesisDelegate)
  (AllIssuerKeys MockCrypto '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) <-
        forall era.
(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) =>
GenEnv era
-> PParams era
-> CertState era
-> SlotNo
-> TxIx
-> AccountState
-> Gen
     ([TxCert era], Coin, Coin, CertState era, [KeyPair 'Witness],
      [(Script era, Script era)])
genTxCerts GenEnv era
ge PParams era
pparams CertState era
dpState SlotNo
slot TxIx
txIx AccountState
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 forall a. [a] -> [a] -> [a]
++ [KeyPair 'Witness]
wdrlWits forall a. [a] -> [a] -> [a]
++ [KeyPair 'Witness]
certWits 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 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, (forall era.
ScriptSpace era -> Map ScriptHash (TwoPhase3ArgInfo era)
ssHash3 ScriptSpace era
scriptspace, 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
              (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 = forall (t :: * -> *) v. (Foldable t, Val v) => t v -> v
sumVal (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(RewardAccount, Coin)]
wdrls)
          !spendingBalance :: Value era
spendingBalance =
            Value era
spendingBalanceUtxo
              forall t. Val t => t -> t -> t
<+> forall t s. Inject t s => t -> s
inject ((Coin
withdrawals forall t. Val t => t -> t -> t
<-> Coin
deposits) forall t. Val t => t -> t -> t
<+> Coin
refunds)
          n :: Int
n =
            if forall k a. Map k a -> Int
Map.size (forall era. UTxO era -> Map TxIn (TxOut era)
unUTxO UTxO era
utxo) 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 (forall (t :: * -> *) a. Foldable t => t a -> Int
length [TxIn]
inputs forall a. Num a => a -> a -> a
+ Int
n) KeyPairs
ksKeyPairs [(Script era, Script era)]
ksMSigScripts
          forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall era. DState era -> [Addr] -> Gen [Addr]
genPtrAddrs (forall era. CertState era -> DState era
certDState CertState era
dpState')

      !()
_ <-
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall t. Val t => t -> Coin
coin Value era
spendingBalance forall a. Ord a => a -> a -> Bool
< forall a. Monoid a => a
mempty) forall a b. (a -> b) -> a -> b
$
          forall a. String -> a
tracedDiscard forall a b. (a -> b) -> a -> b
$
            String
"Negative spending balance " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (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 = forall (t :: * -> *) v. (Foldable t, Val v) => t v -> v
sumVal (forall era. EraTxOut era => PParams era -> TxOut era -> Coin
getMinCoinTxOut PParams era
pparams forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictSeq (TxOut era)
draftOutputs)
      !()
_ <-
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall t. Val t => t -> Coin
coin Value era
spendingBalance forall a. Ord a => a -> a -> Bool
< Coin
enough) forall a b. (a -> b) -> a -> b
$
          forall a. String -> a
tracedDiscard forall a b. (a -> b) -> a -> b
$
            String
"No inputs left. Utxo.hs " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Coin
enough

      (TxBody era
draftTxBody, [Script era]
additionalScripts) <-
        forall era.
EraGen era =>
GenEnv 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 era
ge
          UTxO era
utxo
          PParams era
pparams
          SlotNo
slot
          (forall a. Ord a => [a] -> Set a
Set.fromList [TxIn]
inputs)
          StrictSeq (TxOut era)
draftOutputs
          (forall a. [a] -> StrictSeq a
StrictSeq.fromList [TxCert era]
certs)
          (Map RewardAccount Coin -> Withdrawals
Withdrawals (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(RewardAccount, Coin)]
wdrls))
          Coin
draftFee
          (forall a. Maybe a -> StrictMaybe a
maybeToStrictMaybe Maybe (Update era)
update)
          (forall era. EraTxAuxData era => TxAuxData era -> TxAuxDataHash
hashTxAuxData @era 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' = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ 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 <-
        forall era.
(EraGen era, EraUTxO era) =>
ScriptInfo era
-> Coin
-> [KeyPair 'Witness]
-> Map ScriptHash (Script era)
-> KeyPairs
-> [(Script era, Script era)]
-> UTxO era
-> PParams era
-> KeySpace era
-> Tx era
-> Gen (Tx era)
converge
          (forall era.
ScriptSpace era -> Map ScriptHash (TwoPhase3ArgInfo era)
ssHash3 ScriptSpace era
scriptspace, forall era.
ScriptSpace era -> Map ScriptHash (TwoPhase2ArgInfo era)
ssHash2 ScriptSpace era
scriptspace)
          Coin
remainderCoin
          [KeyPair 'Witness]
txWits
          (Map ScriptHash (Script era)
scripts 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 era
keySpace
          Tx era
draftTx
      let txOuts :: StrictSeq (TxOut era)
txOuts = Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL
      !()
_ <-
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\TxOut era
txOut -> forall era. EraTxOut era => PParams era -> TxOut era -> Coin
getMinCoinTxOut PParams era
pparams TxOut era
txOut forall a. Ord a => a -> a -> Bool
> TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
coinTxOutL) StrictSeq (TxOut era)
txOuts) forall a b. (a -> b) -> a -> b
$
          forall a. String -> a
tracedDiscard forall a b. (a -> b) -> a -> b
$
            String
"TxOut value is too small " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show StrictSeq (TxOut era)
txOuts
      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"
      forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Coin
fee
      forall a. [a] -> [a] -> [a]
++ String
" "
      forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. Set a -> Int
Set.size Set TxIn
is)
      forall a. [a] -> [a] -> [a]
++ String
" wit change "
      forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [KeyPair 'Witness]
dvs)
      forall a. [a] -> [a] -> [a]
++ String
" "
      forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Script era, Script era)]
ds)
      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 =
    forall era. Delta era -> Coin
dfees Delta era
a forall a. Eq a => a -> a -> Bool
== forall era. Delta era -> Coin
dfees Delta era
b
      Bool -> Bool -> Bool
&& forall era. Delta era -> Set TxIn
extraInputs Delta era
a forall a. Eq a => a -> a -> Bool
== forall era. Delta era -> Set TxIn
extraInputs Delta era
b
      Bool -> Bool -> Bool
&& forall era. Delta era -> TxWits era
extraWitnesses Delta era
a forall a. Eq a => a -> a -> Bool
== 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
&& forall era. Delta era -> TxOut era
change Delta era
a forall a. Eq a => a -> a -> Bool
== 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 =
  forall era.
Coin
-> Set TxIn
-> TxWits era
-> TxOut era
-> [KeyPair 'Witness]
-> [(Script era, Script era)]
-> Delta era
Delta
    (Coin
initialfee forall t. Val t => t -> t -> t
<-> TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
coinTxOutL)
    forall a. Monoid a => a
mempty
    forall a. Monoid a => a
mempty
    TxOut era
txOut
    forall a. Monoid a => a
mempty
    forall a. Monoid a => a
mempty
  where
    txOut :: TxOut era
txOut = forall era. EraTxOut era => PParams era -> TxOut era -> TxOut era
setMinCoinTxOut PParams era
pp (forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
addr 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 = forall era. EraTxOut era => PParams era -> TxOut era -> Coin
getMinCoinTxOut PParams era
pp TxOut era
txOut
          curCoin :: Coin
curCoin = TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
coinTxOutL
       in if Coin
curCoin forall a. Eq a => a -> a -> Bool
== Coin
curMinCoin
            then TxOut era
txOut
            else TxOut era -> TxOut era
go (TxOut era
txOut forall a b. a -> (a -> b) -> b
& forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
coinTxOutL 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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
BSL.length (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.
  (EraGen era, EraUTxO era) =>
  ScriptInfo era ->
  UTxO era ->
  PParams era ->
  KeySpace era ->
  Tx era ->
  Int ->
  Delta era ->
  Gen (Delta era)
genNextDelta :: forall era.
(EraGen era, EraUTxO era) =>
ScriptInfo era
-> UTxO era
-> PParams era
-> KeySpace 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 :: Map (KeyHash 'Staking) (KeyPair 'Staking)
ksIndexedStakingKeys :: forall era.
KeySpace era -> Map (KeyHash 'Staking) (KeyPair 'Staking)
ksIndexedStakingKeys
    , Map (KeyHash 'Payment) (KeyPair 'Payment)
ksIndexedPaymentKeys :: Map (KeyHash 'Payment) (KeyPair 'Payment)
ksIndexedPaymentKeys :: forall era.
KeySpace era -> Map (KeyHash 'Payment) (KeyPair 'Payment)
ksIndexedPaymentKeys
    , Map ScriptHash (Script era, Script era)
ksIndexedPayScripts :: Map ScriptHash (Script era, Script era)
ksIndexedPayScripts :: forall era. KeySpace era -> 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 = 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 =
          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 (forall a. Ord a => a -> a -> a
max Coin
dfees (Integer -> Coin
Coin Integer
0)) forall a. Num a => a -> a -> a
- Integer
1
            , (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\TxIn
a Integer
b -> Integer
b 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) 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 = 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 forall t. Val t => t -> t -> t
<+> Coin
ans
        deltaFee :: Coin
deltaFee = Integer
draftSize forall t i. (Val t, Integral i) => i -> t -> t
<×> PParams era
pparams forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) Coin
ppMinFeeAL forall t. Val t => t -> t -> t
<+> Coin
deltaScriptCost
        totalFee :: Coin
totalFee = Coin
baseTxFee forall t. Val t => t -> t -> t
<+> Coin
deltaFee :: Coin
        remainingFee :: Coin
remainingFee = Coin
totalFee forall t. Val t => t -> t -> t
<-> Coin
dfees :: Coin
        changeAmount :: Coin
changeAmount = forall {era}. EraTxOut era => TxOut era -> Coin
getChangeAmount TxOut era
change
        minAda :: Coin
minAda = forall era. EraTxOut era => PParams era -> TxOut era -> Coin
getMinCoinTxOut PParams era
pparams TxOut era
change
     in if Coin
remainingFee forall a. Ord a => a -> a -> Bool
<= Integer -> Coin
Coin Integer
0 -- we've paid for all the fees
          then 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 forall a. Ord a => a -> a -> Bool
<= (Coin
changeAmount forall t. Val t => t -> t -> t
<-> Coin
minAda)
              then
                forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
                  Delta era
delta
                    { dfees :: Coin
dfees = Coin
totalFee
                    , change :: TxOut era
change =
                        (Value era -> Value era) -> TxOut era -> TxOut era
deltaChange
                          (forall t. Val t => t -> t -> t
<-> forall t s. Inject t s => t -> s
inject Coin
remainingFee)
                          TxOut era
change
                    }
              else -- add a new input to cover the fee
                do
                  let txBody :: TxBody era
txBody = Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL
                      inputsInUse :: Set TxIn
inputsInUse = TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
inputsTxBodyL 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.
                        forall era. Map TxIn (TxOut era) -> UTxO era
UTxO forall a b. (a -> b) -> a -> b
$
                          forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey
                            ( \TxIn
k TxOut era
v ->
                                (TxIn
k forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set TxIn
inputsInUse) Bool -> Bool -> 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)
                            (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)) <-
                    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.
                  !()
_ <- forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TxIn]
inputs) forall a b. (a -> b) -> a -> b
$ forall a. String -> a
tracedDiscard forall a b. (a -> b) -> a -> b
$ String
"NoMoneyleft Utxo.hs " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (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 forall a. Monoid a => a
mempty)
                          (forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated TxBody era
txBody)
                  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
                    Delta era
delta
                      { extraWitnesses :: TxWits era
extraWitnesses = TxWits era
extraWitnesses forall a. Semigroup a => a -> a -> a
<> TxWits era
newWits
                      , extraInputs :: Set TxIn
extraInputs = Set TxIn
extraInputs forall a. Semigroup a => a -> a -> a
<> forall a. Ord a => [a] -> Set a
Set.fromList [TxIn]
inputs
                      , change :: TxOut era
change = (Value era -> Value era) -> TxOut era -> TxOut era
deltaChange (forall t. Val t => t -> t -> t
<+> Value era
value) TxOut era
change -- <+> is plus of the Val class
                      , deltaVKeys :: [KeyPair 'Witness]
deltaVKeys = [KeyPair 'Witness]
vkeyPairs forall a. Semigroup a => a -> a -> a
<> forall era. Delta era -> [KeyPair 'Witness]
deltaVKeys Delta era
delta
                      , deltaScripts :: [(Script era, Script era)]
deltaScripts = [(Script era, Script era)]
msigPairs forall a. Semigroup a => a -> a -> a
<> forall era. Delta era -> [(Script era, Script era)]
deltaScripts Delta era
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 forall a b. a -> (a -> b) -> b
& forall era. EraTxOut era => Lens' (TxOut era) (Value era)
valueTxOutL 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 forall s a. s -> Getting a s a -> a
^. forall era. (HasCallStack, EraTxOut era) => 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.
  ( EraGen era
  , EraUTxO era
  ) =>
  ScriptInfo era ->
  Coin ->
  KeyPairs ->
  [(Script era, Script era)] ->
  UTxO era ->
  PParams era ->
  KeySpace era ->
  Tx era ->
  Gen (Delta era)
genNextDeltaTilFixPoint :: forall era.
(EraGen era, EraUTxO era) =>
ScriptInfo era
-> Coin
-> KeyPairs
-> [(Script era, Script era)]
-> UTxO era
-> PParams era
-> KeySpace 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 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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. HasCallStack => String -> a
error String
"genNextDeltaTilFixPoint: empty addrs") forall a. NonEmpty a -> a
NE.head forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [Addr]
addrs
  forall d (m :: * -> *).
(Eq d, Monad m) =>
Int -> (Int -> d -> m d) -> d -> m d
fix
    Int
0
    (forall era.
(EraGen era, EraUTxO era) =>
ScriptInfo era
-> UTxO era
-> PParams era
-> KeySpace era
-> Tx era
-> Int
-> Delta era
-> Gen (Delta era)
genNextDelta ScriptInfo era
scriptinfo UTxO era
utxo PParams era
pparams KeySpace era
keySpace Tx era
tx)
    (forall era.
(EraTxOut era, Monoid (TxWits era)) =>
Coin -> PParams era -> Addr -> Delta era
deltaZero Coin
initialfee PParams era
pparams Addr
addr)

applyDelta ::
  forall era.
  EraGen era =>
  UTxO era ->
  ScriptInfo era ->
  PParams era ->
  [KeyPair 'Witness] ->
  Map ScriptHash (Script era) ->
  KeySpace era ->
  Tx era ->
  Delta era ->
  Tx era
applyDelta :: forall era.
EraGen era =>
UTxO era
-> ScriptInfo era
-> PParams era
-> [KeyPair 'Witness]
-> Map ScriptHash (Script era)
-> KeySpace 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 :: Map (KeyHash 'Payment) (KeyPair 'Payment)
ksIndexedPaymentKeys :: forall era.
KeySpace era -> Map (KeyHash 'Payment) (KeyPair 'Payment)
ksIndexedPaymentKeys, Map (KeyHash 'Staking) (KeyPair 'Staking)
ksIndexedStakingKeys :: Map (KeyHash 'Staking) (KeyPair 'Staking)
ksIndexedStakingKeys :: forall era.
KeySpace era -> 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 forall s a. s -> Getting a s a -> a
^. forall era. EraTx 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
            (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 forall a. Semigroup a => a -> a -> a
<> [KeyPair 'Witness]
extraKeys
        sw :: Map ScriptHash (Script era)
sw = Map ScriptHash (Script era)
neededScripts 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 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
            (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 forall s a. s -> Getting a s a -> a
^. forall era.
EraTx 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 forall a. Eq a => a -> a -> Bool
== d
d then forall (f :: * -> *) a. Applicative f => a -> f a
pure d
d else forall d (m :: * -> *).
(Eq d, Monad m) =>
Int -> (Int -> d -> m d) -> d -> m d
fix (Int
n forall a. Num a => a -> a -> a
+ Int
1) Int -> d -> m d
f d
d1

converge ::
  forall era.
  (EraGen era, EraUTxO era) =>
  ScriptInfo era ->
  Coin ->
  [KeyPair 'Witness] ->
  Map ScriptHash (Script era) ->
  KeyPairs ->
  [(Script era, Script era)] ->
  UTxO era ->
  PParams era ->
  KeySpace era ->
  Tx era ->
  Gen (Tx era)
converge :: forall era.
(EraGen era, EraUTxO era) =>
ScriptInfo era
-> Coin
-> [KeyPair 'Witness]
-> Map ScriptHash (Script era)
-> KeyPairs
-> [(Script era, Script era)]
-> UTxO era
-> PParams era
-> KeySpace 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 era
keySpace
  Tx era
tx = do
    Delta era
delta <- forall era.
(EraGen era, EraUTxO era) =>
ScriptInfo era
-> Coin
-> KeyPairs
-> [(Script era, Script era)]
-> UTxO era
-> PParams era
-> KeySpace 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 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
      (forall era.
EraGen era =>
UTxO era
-> ScriptInfo era
-> PParams era
-> [KeyPair 'Witness]
-> Map ScriptHash (Script era)
-> KeySpace 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 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
_ [] = 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, forall (t :: * -> *) a. Foldable t => t a -> Int
length Vector a
itemsV forall a. Num a => a -> a -> a
- Int
1)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Vector a
itemsV forall a. Vector a -> Int -> a
V.!) [Int]
indices
  where
    itemsV :: Vector a
itemsV = 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 forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
u forall a. Num a => a -> a -> a
- Int
l forall a. Num a => a -> a -> a
+ Int
1 forall a. Ord a => a -> a -> Bool
< Int
k =
      forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$
        String
"Cannot generate "
          forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
k
          forall a. [a] -> [a] -> [a]
++ String
" indices in the range ["
          forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
l
          forall a. [a] -> [a] -> [a]
++ String
", "
          forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
u
          forall a. [a] -> [a] -> [a]
++ String
"]"
  | Int
u forall a. Num a => a -> a -> a
- Int
l forall a. Ord a => a -> a -> Bool
< Int
k forall a. Num a => a -> a -> a
* Int
2 = do
      [Int]
xs <- forall a. Int -> [a] -> [a]
take Int
k forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> Gen [a]
QC.shuffle [Int
l .. Int
u]
      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 [] forall a. Monoid a => a
mempty
  where
    (Int
l, Int
u) =
      if Int
l' 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 forall a. Ord a => a -> a -> Bool
<= Int
0 = forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Int]
res, IntSet
acc)
      | Bool
otherwise = do
          Int
i <- 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 forall a. Num a => a -> a -> a
- Int
1) (Int
i forall a. a -> [a] -> [a]
: [Int]
res) 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 = 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) forall a. a -> [a] -> [a]
:)) (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 =
  forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$
    ((Script era, Script era) -> (ScriptHash, Script era)
hashPayScript forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Script era, Script era)]
payScripts)
      forall a. [a] -> [a] -> [a]
++ ((Script era, Script era) -> (ScriptHash, Script era)
hashStakeScript 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)
      ( forall (kr :: KeyRole).
SafeHash EraIndependentTxBody
-> [KeyPair kr] -> Set (WitVKey 'Witness)
mkWitnessesVKey SafeHash EraIndependentTxBody
txBodyHash [KeyPair 'Witness]
awits
          forall a. Ord a => Set a -> Set a -> Set a
`Set.union` 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
                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 =
        forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\(KeyHash 'Payment
a, KeyPair 'Payment
b) -> (forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyHash 'Payment
a, forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyPair 'Payment
b))
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toAscList
          forall a b. (a -> b) -> a -> b
$ Map (KeyHash 'Payment) (KeyPair 'Payment)
indexedPaymentKeys
      indexedStakingKeysAsWitnesses :: Map (KeyHash 'Witness) (KeyPair 'Witness)
indexedStakingKeysAsWitnesses =
        forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\(KeyHash 'Staking
a, KeyPair 'Staking
b) -> (forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyHash 'Staking
a, forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyPair 'Staking
b))
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toAscList
          forall a b. (a -> b) -> a -> b
$ Map (KeyHash 'Staking) (KeyPair 'Staking)
indexedStakingKeys
      keysLists :: [[KeyHash 'Witness]]
keysLists = forall a b. (a -> b) -> [a] -> [b]
map (forall era.
ScriptClass era =>
Proxy era -> Script era -> [KeyHash 'Witness]
scriptKeyCombination (forall {k} (t :: k). Proxy t
Proxy @era)) (forall k a. Map k a -> [a]
Map.elems Map ScriptHash (Script era)
msigs)
      msigSignatures :: Set (KeyHash 'Witness)
msigSignatures = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' forall a. Ord a => Set a -> Set a -> Set a
Set.union forall a. Set a
Set.empty forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map 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 forall t. Val t => t -> t -> t
<+> Coin
splitCoinRem
  , forall a. [a] -> StrictSeq a
StrictSeq.fromList forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith 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_ forall t. Val t => t -> t -> t
<-> forall t s. Inject t s => t -> s
inject Coin
fee
    ([Value era]
amountPerOutput, Coin
splitCoinRem) =
      forall v. Split v => v -> Integer -> ([v], Coin)
vsplit Value era
balanceAfterFee (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ 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 <- forall a. Random a => (a, a) -> Gen a
QC.choose (Int
minNumGenInputs, Int
maxNumGenInputs)
  [(TxIn, TxOut era)]
selectedUtxo <- 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) = forall a b. [(a, b)] -> ([a], [b])
unzip (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TxOut era -> Either (KeyPair 'Witness) (Script era, Script era)
witnessedInput forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(TxIn, TxOut era)]
selectedUtxo)
  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 (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(TxIn, TxOut era)]
selectedUtxo)
    , 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 forall s a. s -> Getting a s a -> a
^. forall era. EraTxOut era => Lens' (TxOut era) Addr
addrTxOutL of
        addr :: Addr
addr@(Addr Network
_ (KeyHashObj KeyHash 'Payment
_) StakeReference
_) ->
          forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness 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
_) ->
          forall a b. b -> Either a b
Right 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
_ -> 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 :: Constants -> Int
frequencyNoWithdrawals :: Int
frequencyNoWithdrawals
    , Int
frequencyAFewWithdrawals :: Constants -> Int
frequencyAFewWithdrawals :: Int
frequencyAFewWithdrawals
    , Int
frequencyPotentiallyManyWithdrawals :: Constants -> Int
frequencyPotentiallyManyWithdrawals :: Int
frequencyPotentiallyManyWithdrawals
    , Int
maxAFewWithdrawals :: Constants -> Int
maxAFewWithdrawals :: 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) <-
      forall a. HasCallStack => [(Int, Gen a)] -> Gen a
QC.frequency
        [
          ( Int
frequencyNoWithdrawals
          , forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], ([], []))
          )
        ,
          ( Int
frequencyAFewWithdrawals
          , [(Credential 'Staking, Coin)]
-> Gen
     ([(RewardAccount, Coin)],
      ([KeyPair 'Witness], [(Script era, Script era)]))
genWrdls (forall a. Int -> [a] -> [a]
take Int
maxAFewWithdrawals forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toList 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 (forall k a. Map k a -> [(k, a)]
Map.toList Map (Credential 'Staking) Coin
withdrawals)
          )
        ]
    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 <- forall a b. (a -> b) -> [a] -> [b]
map forall {b}. (Credential 'Staking, b) -> (RewardAccount, b)
toRewardAccount forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. RewardAccount -> Credential 'Staking
raCredential
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst
                forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(RewardAccount, Coin)]
selectedWrdls
        forall (m :: * -> *) a. Monad m => a -> m a
return ([(RewardAccount, Coin)]
selectedWrdls, 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
_) =
  forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$
    forall era.
Credential 'Witness
-> Map ScriptHash (Script era, Script era)
-> (Script era, Script era)
findStakeScriptFromCred @era (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
_) =
  forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
    forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness forall a b. (a -> b) -> a -> b
$
      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 <-
    forall a. Ord a => a -> a -> a
max Int
1
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. HasCallStack => [(Int, Gen a)] -> Gen a
QC.frequency
        [ (Int
1, forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
nRecipients' forall a. Num a => a -> a -> a
- Int
1)) -- contract size of UTxO
        , (Int
2, forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
nRecipients') -- keep size
        , (Int
1, forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
nRecipients' 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 <- forall a. Random a => (a, a) -> Gen a
QC.choose (Int
0, Int
nRecipients forall a. Num a => a -> a -> a
* Int
2 forall a. Integral a => a -> a -> a
`div` Int
3) -- Average is about nRecipients / 3
  let nKeys :: Int
nKeys = Int
nRecipients forall a. Num a => a -> a -> a
- Int
nScripts

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

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

  -- zip keys and scripts together as base addresses
  let payCreds :: [Credential 'Payment]
payCreds = [Credential 'Payment]
payKeys forall a. [a] -> [a] -> [a]
++ [Credential 'Payment]
payScripts
      stakeCreds :: [Credential 'Staking]
stakeCreds = [Credential 'Staking]
stakeKeys forall a. [a] -> [a] -> [a]
++ [Credential 'Staking]
stakeScripts
  let stakeCreds' :: [StakeReference]
stakeCreds' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Credential 'Staking -> StakeReference
StakeRefBase [Credential 'Staking]
stakeCreds

  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Network -> Credential 'Payment -> StakeReference -> Addr
Addr Network
Testnet) [Credential 'Payment]
payCreds [StakeReference]
stakeCreds')
  where
    scriptToCred' :: Script era -> Credential kr
    scriptToCred' :: forall (kr :: KeyRole). Script era -> Credential kr
scriptToCred' = forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraScript era => Script era -> ScriptHash
hashScript @era

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

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

  forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Addr]
addrs' forall a. [a] -> [a] -> [a]
++ 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