{-# 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.Compactible (fromCompact)
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (Credential (..), StakeReference (..))
import Cardano.Ledger.Keys (asWitness)
import Cardano.Ledger.Shelley.LedgerState (LedgerState (..), UTxOState (..))
import Cardano.Ledger.Shelley.Rules (DelplEnv, LedgerEnv (..))
import Cardano.Ledger.Shelley.State
import Cardano.Ledger.Shelley.TxBody (Withdrawals (..))
import Cardano.Ledger.TxIn (TxIn (..))
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 Lens.Micro.Extras
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
  , ShelleyEraAccounts 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 TopTx era)
genTx :: forall era c.
(EraGen era, EraUTxO era, ShelleyEraAccounts 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 TopTx 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
      -------------------------------------------------------------------------
      (inputs, spendingBalanceUtxo, (spendWits, 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
      (wdrls, (wdrlWits, wdrlScripts)) <-
        genWithdrawals
          @era
          constants
          ksIndexedStakeScripts
          ksIndexedStakingKeys
          ( Map.map (fromCompact . view balanceAccountStateL) $
              dpState ^. certDStateL . accountsL . accountsMapL
          )
      (update, updateWits) <-
        genUpdate
          constants
          slot
          ksCoreNodes
          ksIndexedGenDelegates
          pparams
          (utxoSt, dpState)
      (certs, deposits, refunds, dpState', certWits, certScripts) <-
        genTxCerts ge pparams dpState slot txIx reserves
      metadata <- genEraAuxiliaryData @era constants
      -------------------------------------------------------------------------
      -- Gather Key TxWits and Scripts, prepare a constructor for Tx Wits
      -------------------------------------------------------------------------
      let 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 = 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 TopTx era
txbody =
            forall era.
EraGen era =>
(UTxO era, TxBody TopTx 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 TopTx 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 TopTx era -> SafeHash EraIndependentTxBody
forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated TxBody TopTx era
txbody)
      -------------------------------------------------------------------------
      -- SpendingBalance, Output Addresses (including some Pointer addresses)
      -- and a Outputs builder that distributes the given balance over
      -- addresses.
      -------------------------------------------------------------------------
      let 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
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 =
            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)))

      outputAddrs <-
        genRecipients @era (length inputs + n) ksKeyPairs ksMSigScripts
          >>= genPtrAddrs (dpState' ^. certDStateL)

      !_ <-
        when (coin spendingBalance < mempty) $
          tracedDiscard $
            "Negative spending balance " <> show (coin spendingBalance)

      -------------------------------------------------------------------------
      -- Build a Draft Tx and repeatedly add to Delta until all fees are
      -- accounted for.
      -------------------------------------------------------------------------
      let draftFee = Integer -> Coin
Coin Integer
0
          (remainderCoin, draftOutputs) =
            calcOutputsFromBalance @era
              spendingBalance
              outputAddrs
              draftFee

      -- Occasionally we have a transaction generated with insufficient inputs
      -- to cover the deposits. In this case we discard the test case.
      let 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)
      !_ <-
        when (coin spendingBalance < enough) $
          tracedDiscard $
            "No inputs left. Utxo.hs " <> show enough

      (draftTxBody, additionalScripts) <-
        genEraTxBody
          ge
          utxo
          pparams
          slot
          (Set.fromList inputs)
          draftOutputs
          (StrictSeq.fromList certs)
          (Withdrawals (Map.fromList wdrls))
          draftFee
          (maybeToStrictMaybe update)
          (hashTxAuxData @era <$> metadata)
      let draftTx =
            forall era.
EraGen era =>
TxBody TopTx era
-> TxWits era -> StrictMaybe (TxAuxData era) -> Tx TopTx era
constructTx @era
              TxBody TopTx era
draftTxBody
              (TxBody TopTx era -> TxWits era
mkTxWits' TxBody TopTx era
draftTxBody)
              StrictMaybe (TxAuxData era)
metadata
          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 <-
        converge
          (ssHash3 scriptspace, ssHash2 scriptspace)
          remainderCoin
          txWits
          (scripts `Map.union` scripts')
          ksKeyPairs
          ksMSigScripts
          utxo
          pparams
          keySpace
          draftTx
      let txOuts = Tx TopTx era
tx Tx TopTx era
-> Getting
     (StrictSeq (TxOut era)) (Tx TopTx era) (StrictSeq (TxOut era))
-> StrictSeq (TxOut era)
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx era
 -> Const (StrictSeq (TxOut era)) (TxBody TopTx era))
-> Tx TopTx era -> Const (StrictSeq (TxOut era)) (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era
  -> Const (StrictSeq (TxOut era)) (TxBody TopTx era))
 -> Tx TopTx era -> Const (StrictSeq (TxOut era)) (Tx TopTx era))
-> ((StrictSeq (TxOut era)
     -> Const (StrictSeq (TxOut era)) (StrictSeq (TxOut era)))
    -> TxBody TopTx era
    -> Const (StrictSeq (TxOut era)) (TxBody TopTx era))
-> Getting
     (StrictSeq (TxOut era)) (Tx TopTx 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 TopTx era
-> Const (StrictSeq (TxOut era)) (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel). Lens' (TxBody l era) (StrictSeq (TxOut era))
outputsTxBodyL
      !_ <-
        when (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) txOuts) $
          tracedDiscard $
            "TxOut value is too small " <> show txOuts
      pure 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 TopTx 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 TopTx 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 TopTx 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 TopTx era -> UTxO era -> Coin
forall era (t :: TxLevel).
EraUTxO era =>
PParams era -> Tx t era -> UTxO era -> Coin
forall (t :: TxLevel). PParams era -> Tx t era -> UTxO era -> Coin
getMinFeeTxUtxo PParams era
pparams Tx TopTx 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, HasCallStack) =>
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 TopTx era
txBody = Tx TopTx era
tx Tx TopTx era
-> Getting (TxBody TopTx era) (Tx TopTx era) (TxBody TopTx era)
-> TxBody TopTx era
forall s a. s -> Getting a s a -> a
^. Getting (TxBody TopTx era) (Tx TopTx era) (TxBody TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL
                      inputsInUse :: Set TxIn
inputsInUse = TxBody TopTx era
txBody TxBody TopTx era
-> Getting (Set TxIn) (TxBody TopTx era) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. Getting (Set TxIn) (TxBody TopTx era) (Set TxIn)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l 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)
                  (inputs, value, (vkeyPairs, 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.
                  !_ <- when (null inputs) $ tracedDiscard $ "NoMoneyleft Utxo.hs " <> show (coin value)
                  let newWits =
                        forall era.
EraGen era =>
(UTxO era, TxBody TopTx 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 TopTx 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 TopTx era -> SafeHash EraIndependentTxBody
forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated TxBody TopTx era
txBody)
                  pure $
                    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 TopTx 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 TopTx 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 TopTx era
tx = do
  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 -> (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
  fix
    0
    (genNextDelta scriptinfo utxo pparams keySpace tx)
    (deltaZero initialfee pparams addr)

applyDelta ::
  forall era c.
  EraGen era =>
  UTxO era ->
  ScriptInfo era ->
  PParams era ->
  [KeyPair Witness] ->
  Map ScriptHash (Script era) ->
  KeySpace c era ->
  Tx TopTx era ->
  Delta era ->
  Tx TopTx era
applyDelta :: forall era c.
EraGen era =>
UTxO era
-> ScriptInfo era
-> PParams era
-> [KeyPair Witness]
-> Map ScriptHash (Script era)
-> KeySpace c era
-> Tx TopTx era
-> Delta era
-> Tx TopTx 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 TopTx 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 TopTx era
txBody = Tx TopTx era
tx Tx TopTx era
-> Getting (TxBody TopTx era) (Tx TopTx era) (TxBody TopTx era)
-> TxBody TopTx era
forall s a. s -> Getting a s a -> a
^. Getting (TxBody TopTx era) (Tx TopTx era) (TxBody TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL
        oldWitnessSet :: TxWits era
oldWitnessSet =
          forall era.
EraGen era =>
(UTxO era, TxBody TopTx 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 TopTx era -> Set TxIn -> TxBody TopTx era
addInputs @era TxBody TopTx 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 TopTx era -> SafeHash EraIndependentTxBody
forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated TxBody TopTx era
txBody)
        body2 :: TxBody TopTx era
body2 =
          (forall era.
EraGen era =>
UTxO era
-> PParams era
-> TxWits era
-> TxBody TopTx era
-> Coin
-> Set TxIn
-> TxOut era
-> TxBody TopTx era
updateEraTxBody @era)
            UTxO era
utxo
            PParams era
pparams
            TxWits era
oldWitnessSet
            TxBody TopTx 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 TopTx 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 TopTx 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 TopTx era -> SafeHash EraIndependentTxBody
forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated TxBody TopTx era
body2)
     in forall era.
EraGen era =>
TxBody TopTx era
-> TxWits era -> StrictMaybe (TxAuxData era) -> Tx TopTx era
constructTx @era TxBody TopTx era
body2 TxWits era
newWitnessSet (Tx TopTx era
tx Tx TopTx era
-> Getting
     (StrictMaybe (TxAuxData era))
     (Tx TopTx era)
     (StrictMaybe (TxAuxData era))
-> StrictMaybe (TxAuxData era)
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictMaybe (TxAuxData era))
  (Tx TopTx era)
  (StrictMaybe (TxAuxData era))
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (StrictMaybe (TxAuxData era))
forall (l :: TxLevel).
Lens' (Tx l 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 d1 <- Int -> d -> m d
f Int
n d
d; if d1 == d then pure d else fix (n + 1) f 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 TopTx era ->
  Gen (Tx TopTx 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 TopTx era
-> Gen (Tx TopTx 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 TopTx era
tx = do
    delta <- ScriptInfo era
-> Coin
-> KeyPairs
-> [(Script era, Script era)]
-> UTxO era
-> PParams era
-> KeySpace c era
-> Tx TopTx 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 TopTx 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 TopTx era
tx
    genEraDone @era
      utxo
      pparams
      (applyDelta utxo scriptinfo pparams neededKeys neededScripts keySpace tx 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
  (indices, _) <- 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)
  pure $ map (itemsV V.!) 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
      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]
      pure (xs, IntSet.fromList 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
          i <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
QC.choose (Int
l, Int
u)
          if IntSet.member i acc
            then go n res acc
            else go (n - 1) (i : res) $ IntSet.insert i 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 TopTx 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 TopTx 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 TopTx 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 TopTx era, ScriptInfo era)
-> Set (WitVKey Witness)
-> Map ScriptHash (Script era)
-> TxWits era
genEraTxWits @era
      (UTxO era
utxo, TxBody TopTx 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
  numInputs <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
QC.choose (Int
minNumGenInputs, Int
maxNumGenInputs)
  selectedUtxo <- pickRandomFromMap numInputs utxo
  let (inputs, witnesses) = unzip (fmap witnessedInput <$> selectedUtxo)
  return
    ( inputs
    , sumAllValue @era (snd <$> selectedUtxo)
    , Either.partitionEithers 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
    (a, 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)
          )
        ]
    pure (a, 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
        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 =
              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
        return (selectedWrdls, Either.partitionEithers 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
  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.
  nScripts <- QC.choose (0, nRecipients * 2 `div` 3) -- Average is about nRecipients / 3
  let nKeys = Int
nRecipients Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
nScripts

  recipientKeys <- ruffle nKeys keys
  recipientScripts <- ruffle nScripts scripts

  let 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 = 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 = 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 = 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]
payKeys [Credential Payment]
-> [Credential Payment] -> [Credential Payment]
forall a. [a] -> [a] -> [a]
++ [Credential Payment]
payScripts
      stakeCreds :: [Credential Staking]
      stakeCreds = [Credential Staking]
stakeKeys [Credential Staking]
-> [Credential Staking] -> [Credential Staking]
forall a. [a] -> [a] -> [a]
++ [Credential Staking]
stakeScripts

  return (zipWith mkAddr payCreds stakeCreds)

genPtrAddrs :: ShelleyEraAccounts era => DState era -> [Addr] -> Gen [Addr]
genPtrAddrs :: forall era.
ShelleyEraAccounts era =>
DState era -> [Addr] -> Gen [Addr]
genPtrAddrs DState era
ds [Addr]
addrs = do
  let pointers :: Map Ptr (Credential Staking)
pointers = DState era
ds DState era
-> Getting
     (Map Ptr (Credential Staking))
     (DState era)
     (Map Ptr (Credential Staking))
-> Map Ptr (Credential Staking)
forall s a. s -> Getting a s a -> a
^. (Accounts era
 -> Const (Map Ptr (Credential Staking)) (Accounts era))
-> DState era -> Const (Map Ptr (Credential Staking)) (DState era)
forall era. Lens' (DState era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL ((Accounts era
  -> Const (Map Ptr (Credential Staking)) (Accounts era))
 -> DState era -> Const (Map Ptr (Credential Staking)) (DState era))
-> ((Map Ptr (Credential Staking)
     -> Const
          (Map Ptr (Credential Staking)) (Map Ptr (Credential Staking)))
    -> Accounts era
    -> Const (Map Ptr (Credential Staking)) (Accounts era))
-> Getting
     (Map Ptr (Credential Staking))
     (DState era)
     (Map Ptr (Credential Staking))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map Ptr (Credential Staking)
 -> Const
      (Map Ptr (Credential Staking)) (Map Ptr (Credential Staking)))
-> Accounts era
-> Const (Map Ptr (Credential Staking)) (Accounts era)
forall era.
ShelleyEraAccounts era =>
SimpleGetter (Accounts era) (Map Ptr (Credential Staking))
SimpleGetter (Accounts era) (Map Ptr (Credential Staking))
accountsPtrsMapG
  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))
  pointerList <- map fst <$> pickRandomFromMap n pointers

  let 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

  pure (addrs' ++ drop n 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