{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

{- | Funding and evaluation for the public-node lifecycle. The devnet row
suites keep their own fixtures; these helpers never submit a refusal probe.
-}
module Singular.Registry.Lifecycle
    ( lifecycleRequested
    , protocolFeeReserve
    , minimumCoin
    , fundedOutput
    , collateralOutput
    , requestLockedCoin
    , sizedOutput
    , verifyLifecycleBudget
    , fundingRequirement
    , fundLifecycle
    , fundingView
    , checkExecutionLimit
    , prepareLifecycleTx
    ) where

import Control.Monad (unless)
import Data.ByteString (ByteString)
import Data.Foldable (toList)
import Data.List (sortOn)
import Data.Map.Strict qualified as Map
import Data.Ord (Down (..))
import Data.Sequence.Strict qualified as StrictSeq
import Data.Set qualified as Set
import Lens.Micro ((&), (.~), (^.))

import Cardano.Ledger.Address (Addr)
import Cardano.Ledger.Alonzo.Scripts (AsIx (..))
import Cardano.Ledger.Api.PParams
    ( ppCollateralPercentageL
    , ppMaxTxExUnitsL
    , ppMaxTxSizeL
    , ppTxFeePerByteL
    )
import Cardano.Ledger.Api.Scripts.Data (Data (..))
import Cardano.Ledger.Api.Tx
    ( bodyTxL
    , estimateMinFeeTx
    , mkBasicTx
    , txIdTx
    , witsTxL
    )
import Cardano.Ledger.Api.Tx.Body
    ( feeTxBodyL
    , mkBasicTxBody
    , outputsTxBodyL
    , scriptIntegrityHashTxBodyL
    )
import Cardano.Ledger.Api.Tx.In (TxIn (..))
import Cardano.Ledger.Api.Tx.Out
    ( TxOut
    , coinTxOutL
    , datumTxOutL
    , getMinCoinTxOut
    , mkBasicTxOut
    , referenceScriptTxOutL
    , valueTxOutL
    )
import Cardano.Ledger.Api.Tx.Wits (Redeemers (..), rdmrsTxWitsL)
import Cardano.Ledger.BaseTypes (StrictMaybe (..), TxIx (..))
import Cardano.Ledger.Coin (CoinPerByte (..))
import Cardano.Ledger.Compactible (fromCompact)
import Cardano.Ledger.Conway.Scripts (ConwayPlutusPurpose (..))
import Cardano.Ledger.Mary.Value (MaryValue (..), MultiAsset (..))
import Cardano.Ledger.Plutus.ExUnits (ExUnits (..))
import Cardano.Tx.Balance
    ( BalanceResult (..)
    , balanceFeeLoop
    , balanceTx
    , refScriptsSize
    )
import Cardano.Tx.Ledger (ConwayTx)
import PlutusLedgerApi.V3 qualified as PLC

import Singular.Registry.Capabilities (Capabilities (..))
import Singular.Registry.Config (CageConfig (..))
import Singular.Registry.Evidence (Evidenced (..), NoWitness)
import Singular.Registry.Ledger
    ( Coin (..)
    , ConwayEra
    , PParams
    , TokenId
    )
import Singular.Registry.LedgerProvider
    ( Network (..)
    , OutputQuery (..)
    , Session (..)
    , SubmitResult (..)
    )
import Singular.Registry.SessionIO (outputsAt, parameters, withLatest)
import Singular.Registry.SessionIO qualified as Services
import Singular.Registry.Signing (signTx, signedTx)
import Singular.Registry.TxBuilder.Internal.Identity
    ( mkInlineDatum
    , mkRequestDatum
    , requestAddrFromCfg
    )
import Singular.Registry.TxBuilder.Internal.Lookup
    ( computeScriptIntegrity
    )
import Singular.Registry.TxBuilder.Request (requestLockedAda)
import Singular.Registry.Types (Edge)
import Singular.Registry.Wallet (Wallet (..))

{- | Public external nodes use the lifecycle automatically: a chain point
on a network other than the factory devnet (network magic 42). The
explicit flag also exercises that path on the devnet.
-}
lifecycleRequested :: Network -> [String] -> Bool
lifecycleRequested :: Network -> [String] -> Bool
lifecycleRequested (Network Word32
magic) [String]
args =
    String
"--lifecycle" String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
args Bool -> Bool -> Bool
|| Word32
magic Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word32
42

{- | A funding allowance, not the fee charged: one maximum-size transaction,
the live aggregate execution limit, and the actual reference scripts.
Each submitted transaction is subsequently evaluated and balanced exactly.
-}
protocolFeeReserve
    :: PParams ConwayEra -> [(TxIn, TxOut ConwayEra)] -> Coin
protocolFeeReserve :: PParams ConwayEra -> [(TxIn, TxOut ConwayEra)] -> Coin
protocolFeeReserve PParams ConwayEra
pp [(TxIn, TxOut ConwayEra)]
refs =
    let dummy :: Tx TopTx ConwayEra
dummy =
            TxBody TopTx ConwayEra -> Tx TopTx ConwayEra
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l ConwayEra -> Tx l ConwayEra
mkBasicTx TxBody TopTx ConwayEra
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l ConwayEra
mkBasicTxBody
                Tx TopTx ConwayEra
-> (Tx TopTx ConwayEra -> Tx TopTx ConwayEra) -> Tx TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (TxWits ConwayEra -> Identity (TxWits ConwayEra))
-> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxWits ConwayEra)
witsTxL ((TxWits ConwayEra -> Identity (TxWits ConwayEra))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> ((Redeemers ConwayEra -> Identity (Redeemers ConwayEra))
    -> TxWits ConwayEra -> Identity (TxWits ConwayEra))
-> (Redeemers ConwayEra -> Identity (Redeemers ConwayEra))
-> Tx TopTx ConwayEra
-> Identity (Tx TopTx ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redeemers ConwayEra -> Identity (Redeemers ConwayEra))
-> TxWits ConwayEra -> Identity (TxWits ConwayEra)
forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
Lens' (TxWits ConwayEra) (Redeemers ConwayEra)
rdmrsTxWitsL
                    ((Redeemers ConwayEra -> Identity (Redeemers ConwayEra))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> Redeemers ConwayEra -> Tx TopTx ConwayEra -> Tx TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map (PlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
-> Redeemers ConwayEra
forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era
Redeemers
                        ( ConwayPlutusPurpose AsIx ConwayEra
-> (Data ConwayEra, ExUnits)
-> Map
     (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
forall k a. k -> a -> Map k a
Map.singleton
                            (AsIx Word32 PolicyID -> ConwayPlutusPurpose AsIx ConwayEra
forall (f :: * -> * -> *) era.
f Word32 PolicyID -> ConwayPlutusPurpose f era
ConwayMinting (Word32 -> AsIx Word32 PolicyID
forall ix it. ix -> AsIx ix it
AsIx Word32
0))
                            (Data -> Data ConwayEra
forall era. Era era => Data -> Data era
Data (Integer -> [Data] -> Data
PLC.Constr Integer
0 []), PParams ConwayEra
pp PParams ConwayEra
-> Getting ExUnits (PParams ConwayEra) ExUnits -> ExUnits
forall s a. s -> Getting a s a -> a
^. Getting ExUnits (PParams ConwayEra) ExUnits
forall era. AlonzoEraPParams era => Lens' (PParams era) ExUnits
Lens' (PParams ConwayEra) ExUnits
ppMaxTxExUnitsL)
                        )
        Coin Integer
measured =
            PParams ConwayEra
-> Tx TopTx ConwayEra -> Int -> Int -> Int -> Coin
forall era.
EraTx era =>
PParams era -> Tx TopTx era -> Int -> Int -> Int -> Coin
estimateMinFeeTx
                PParams ConwayEra
pp
                Tx TopTx ConwayEra
dummy
                Int
2
                Int
0
                (Set TxIn -> [(TxIn, TxOut ConwayEra)] -> Int
refScriptsSize ([TxIn] -> Set TxIn
forall a. Ord a => [a] -> Set a
Set.fromList (((TxIn, BabbageTxOut ConwayEra) -> TxIn)
-> [(TxIn, BabbageTxOut ConwayEra)] -> [TxIn]
forall a b. (a -> b) -> [a] -> [b]
map (TxIn, BabbageTxOut ConwayEra) -> TxIn
forall a b. (a, b) -> a
fst [(TxIn, TxOut ConwayEra)]
[(TxIn, BabbageTxOut ConwayEra)]
refs)) [(TxIn, TxOut ConwayEra)]
refs)
        CoinPerByte CompactForm Coin
compactPerByte = PParams ConwayEra
pp PParams ConwayEra
-> Getting CoinPerByte (PParams ConwayEra) CoinPerByte
-> CoinPerByte
forall s a. s -> Getting a s a -> a
^. Getting CoinPerByte (PParams ConwayEra) CoinPerByte
forall era. EraPParams era => Lens' (PParams era) CoinPerByte
Lens' (PParams ConwayEra) CoinPerByte
ppTxFeePerByteL
        Coin Integer
perByte = CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact CompactForm Coin
compactPerByte
    in  Integer -> Coin
Coin (Integer
measured Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
perByte Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PParams ConwayEra
pp PParams ConwayEra
-> Getting Word32 (PParams ConwayEra) Word32 -> Word32
forall s a. s -> Getting a s a -> a
^. Getting Word32 (PParams ConwayEra) Word32
forall era. EraPParams era => Lens' (PParams era) Word32
Lens' (PParams ConwayEra) Word32
ppMaxTxSizeL))

-- | Ten percent above the live minimum, recomputed with the final coin width.
minimumCoin :: PParams ConwayEra -> TxOut ConwayEra -> Coin
minimumCoin :: PParams ConwayEra -> TxOut ConwayEra -> Coin
minimumCoin PParams ConwayEra
pp TxOut ConwayEra
out =
    let Coin Integer
first = PParams ConwayEra -> TxOut ConwayEra -> Coin
forall era. EraTxOut era => PParams era -> TxOut era -> Coin
getMinCoinTxOut PParams ConwayEra
pp TxOut ConwayEra
out
        Coin Integer
final =
            PParams ConwayEra -> TxOut ConwayEra -> Coin
forall era. EraTxOut era => PParams era -> TxOut era -> Coin
getMinCoinTxOut
                PParams ConwayEra
pp
                (TxOut ConwayEra
BabbageTxOut ConwayEra
out BabbageTxOut ConwayEra
-> (BabbageTxOut ConwayEra -> BabbageTxOut ConwayEra)
-> BabbageTxOut ConwayEra
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin)
-> TxOut ConwayEra -> Identity (TxOut ConwayEra)
(Coin -> Identity Coin)
-> BabbageTxOut ConwayEra -> Identity (BabbageTxOut ConwayEra)
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut ConwayEra) Coin
coinTxOutL ((Coin -> Identity Coin)
 -> BabbageTxOut ConwayEra -> Identity (BabbageTxOut ConwayEra))
-> Coin -> BabbageTxOut ConwayEra -> BabbageTxOut ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin ((Integer
first Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
110 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
99) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
100))
    in  Integer -> Coin
Coin ((Integer
final Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
110 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
99) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
100)

-- | Only the change and live fee allowance are added to actual deposits.
fundedOutput
    :: PParams ConwayEra
    -> [(TxIn, TxOut ConwayEra)]
    -> Addr
    -> Coin
    -> TxOut ConwayEra
fundedOutput :: PParams ConwayEra
-> [(TxIn, TxOut ConwayEra)] -> Addr -> Coin -> TxOut ConwayEra
fundedOutput PParams ConwayEra
pp [(TxIn, TxOut ConwayEra)]
refs Addr
addr Coin
deposit =
    let probe :: TxOut ConwayEra
probe = Addr -> Value ConwayEra -> TxOut ConwayEra
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
addr (Coin -> MultiAsset -> MaryValue
MaryValue (Integer -> Coin
Coin Integer
0) MultiAsset
forall a. Monoid a => a
mempty)
    in  TxOut ConwayEra
probe
            TxOut ConwayEra
-> (TxOut ConwayEra -> BabbageTxOut ConwayEra)
-> BabbageTxOut ConwayEra
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin)
-> TxOut ConwayEra -> Identity (TxOut ConwayEra)
(Coin -> Identity Coin)
-> TxOut ConwayEra -> Identity (BabbageTxOut ConwayEra)
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut ConwayEra) Coin
coinTxOutL
                ((Coin -> Identity Coin)
 -> TxOut ConwayEra -> Identity (BabbageTxOut ConwayEra))
-> Coin -> TxOut ConwayEra -> BabbageTxOut ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ( Coin
deposit
                        Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> PParams ConwayEra -> [(TxIn, TxOut ConwayEra)] -> Coin
protocolFeeReserve PParams ConwayEra
pp [(TxIn, TxOut ConwayEra)]
refs
                        Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> PParams ConwayEra -> TxOut ConwayEra -> Coin
minimumCoin PParams ConwayEra
pp TxOut ConwayEra
probe
                        Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> PParams ConwayEra -> TxOut ConwayEra -> Coin
minimumCoin PParams ConwayEra
pp TxOut ConwayEra
probe
                   )

collateralOutput
    :: PParams ConwayEra
    -> [(TxIn, TxOut ConwayEra)]
    -> Addr
    -> TxOut ConwayEra
collateralOutput :: PParams ConwayEra
-> [(TxIn, TxOut ConwayEra)] -> Addr -> TxOut ConwayEra
collateralOutput PParams ConwayEra
pp [(TxIn, TxOut ConwayEra)]
refs Addr
addr =
    let Coin Integer
fee = PParams ConwayEra -> [(TxIn, TxOut ConwayEra)] -> Coin
protocolFeeReserve PParams ConwayEra
pp [(TxIn, TxOut ConwayEra)]
refs
        probe :: TxOut ConwayEra
probe = Addr -> Value ConwayEra -> TxOut ConwayEra
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
addr (Coin -> MultiAsset -> MaryValue
MaryValue (Integer -> Coin
Coin Integer
0) MultiAsset
forall a. Monoid a => a
mempty)
        collateral :: Coin
collateral =
            Integer -> Coin
Coin
                ((Integer
fee Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Word16 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PParams ConwayEra
pp PParams ConwayEra
-> Getting Word16 (PParams ConwayEra) Word16 -> Word16
forall s a. s -> Getting a s a -> a
^. Getting Word16 (PParams ConwayEra) Word16
forall era. AlonzoEraPParams era => Lens' (PParams era) Word16
Lens' (PParams ConwayEra) Word16
ppCollateralPercentageL) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
99) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
100)
    in  TxOut ConwayEra
probe TxOut ConwayEra
-> (TxOut ConwayEra -> BabbageTxOut ConwayEra)
-> BabbageTxOut ConwayEra
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin)
-> TxOut ConwayEra -> Identity (TxOut ConwayEra)
(Coin -> Identity Coin)
-> TxOut ConwayEra -> Identity (BabbageTxOut ConwayEra)
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut ConwayEra) Coin
coinTxOutL ((Coin -> Identity Coin)
 -> TxOut ConwayEra -> Identity (BabbageTxOut ConwayEra))
-> Coin -> TxOut ConwayEra -> BabbageTxOut ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin -> Coin -> Coin
forall a. Ord a => a -> a -> a
max (PParams ConwayEra -> TxOut ConwayEra -> Coin
minimumCoin PParams ConwayEra
pp TxOut ConwayEra
probe) Coin
collateral

sizedOutput
    :: Bool -> PParams ConwayEra -> TxOut ConwayEra -> TxOut ConwayEra
sizedOutput :: Bool -> PParams ConwayEra -> TxOut ConwayEra -> TxOut ConwayEra
sizedOutput Bool
False PParams ConwayEra
_ TxOut ConwayEra
out = TxOut ConwayEra
out
sizedOutput Bool
True PParams ConwayEra
pp TxOut ConwayEra
out = TxOut ConwayEra
BabbageTxOut ConwayEra
out BabbageTxOut ConwayEra
-> (BabbageTxOut ConwayEra -> BabbageTxOut ConwayEra)
-> BabbageTxOut ConwayEra
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin)
-> TxOut ConwayEra -> Identity (TxOut ConwayEra)
(Coin -> Identity Coin)
-> BabbageTxOut ConwayEra -> Identity (BabbageTxOut ConwayEra)
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut ConwayEra) Coin
coinTxOutL ((Coin -> Identity Coin)
 -> BabbageTxOut ConwayEra -> Identity (BabbageTxOut ConwayEra))
-> Coin -> BabbageTxOut ConwayEra -> BabbageTxOut ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ PParams ConwayEra -> TxOut ConwayEra -> Coin
minimumCoin PParams ConwayEra
pp TxOut ConwayEra
out

{- | The lovelace one request output must lock: the tip plus the
deposit the fold returns. Named for what it locks, not for the datum
field, which is the deposit alone (#183).
-}
requestLockedCoin
    :: PParams ConwayEra
    -> CageConfig
    -> TokenId
    -> Addr
    -> ByteString
    -> Edge
    -> Integer
    -> Coin
requestLockedCoin :: PParams ConwayEra
-> CageConfig
-> TokenId
-> Addr
-> ByteString
-> Integer
-> Integer
-> Coin
requestLockedCoin PParams ConwayEra
pp CageConfig
cfg TokenId
tok Addr
addr ByteString
spelling Integer
edge Integer
now =
    let draft :: BabbageTxOut ConwayEra
draft =
            Addr -> Value ConwayEra -> TxOut ConwayEra
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut
                (CageConfig -> TokenId -> Network -> Addr
requestAddrFromCfg CageConfig
cfg TokenId
tok (CageConfig -> Network
network CageConfig
cfg))
                (Coin -> MultiAsset -> MaryValue
MaryValue (Integer -> Coin
Coin Integer
0) MultiAsset
forall a. Monoid a => a
mempty)
                TxOut ConwayEra
-> (TxOut ConwayEra -> BabbageTxOut ConwayEra)
-> BabbageTxOut ConwayEra
forall a b. a -> (a -> b) -> b
& (Datum ConwayEra -> Identity (Datum ConwayEra))
-> TxOut ConwayEra -> Identity (TxOut ConwayEra)
(Datum ConwayEra -> Identity (Datum ConwayEra))
-> TxOut ConwayEra -> Identity (BabbageTxOut ConwayEra)
forall era. BabbageEraTxOut era => Lens' (TxOut era) (Datum era)
Lens' (TxOut ConwayEra) (Datum ConwayEra)
datumTxOutL
                    ((Datum ConwayEra -> Identity (Datum ConwayEra))
 -> TxOut ConwayEra -> Identity (BabbageTxOut ConwayEra))
-> Datum ConwayEra -> TxOut ConwayEra -> BabbageTxOut ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Data -> Datum ConwayEra
mkInlineDatum (TokenId
-> Addr -> ByteString -> Integer -> Integer -> Integer -> Data
mkRequestDatum TokenId
tok Addr
addr ByteString
spelling Integer
edge Integer
1000000 Integer
now)
    in  PParams ConwayEra
-> TxOut ConwayEra -> TxOut ConwayEra -> Integer -> Coin
requestLockedAda
            PParams ConwayEra
pp
            TxOut ConwayEra
BabbageTxOut ConwayEra
draft
            (Addr -> Value ConwayEra -> TxOut ConwayEra
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
addr (Coin -> MultiAsset -> MaryValue
MaryValue (Integer -> Coin
Coin Integer
0) MultiAsset
forall a. Monoid a => a
mempty))
            Integer
1000000

{- | Connected-fold builders already balance node-evaluated budgets. Check
their aggregate before signing without changing semantic refund outputs.
-}
verifyLifecycleBudget
    :: Bool -> PParams ConwayEra -> ConwayTx -> IO ()
verifyLifecycleBudget :: Bool -> PParams ConwayEra -> Tx TopTx ConwayEra -> IO ()
verifyLifecycleBudget Bool
False PParams ConwayEra
_ Tx TopTx ConwayEra
_ = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
verifyLifecycleBudget Bool
True PParams ConwayEra
pp Tx TopTx ConwayEra
tx = do
    let Redeemers Map (PlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
redeemers = Tx TopTx ConwayEra
tx Tx TopTx ConwayEra
-> Getting
     (Redeemers ConwayEra) (Tx TopTx ConwayEra) (Redeemers ConwayEra)
-> Redeemers ConwayEra
forall s a. s -> Getting a s a -> a
^. (AlonzoTxWits ConwayEra
 -> Const (Redeemers ConwayEra) (AlonzoTxWits ConwayEra))
-> Tx TopTx ConwayEra
-> Const (Redeemers ConwayEra) (Tx TopTx ConwayEra)
(TxWits ConwayEra
 -> Const (Redeemers ConwayEra) (TxWits ConwayEra))
-> Tx TopTx ConwayEra
-> Const (Redeemers ConwayEra) (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxWits ConwayEra)
witsTxL ((AlonzoTxWits ConwayEra
  -> Const (Redeemers ConwayEra) (AlonzoTxWits ConwayEra))
 -> Tx TopTx ConwayEra
 -> Const (Redeemers ConwayEra) (Tx TopTx ConwayEra))
-> ((Redeemers ConwayEra
     -> Const (Redeemers ConwayEra) (Redeemers ConwayEra))
    -> AlonzoTxWits ConwayEra
    -> Const (Redeemers ConwayEra) (AlonzoTxWits ConwayEra))
-> Getting
     (Redeemers ConwayEra) (Tx TopTx ConwayEra) (Redeemers ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redeemers ConwayEra
 -> Const (Redeemers ConwayEra) (Redeemers ConwayEra))
-> AlonzoTxWits ConwayEra
-> Const (Redeemers ConwayEra) (AlonzoTxWits ConwayEra)
(Redeemers ConwayEra
 -> Const (Redeemers ConwayEra) (Redeemers ConwayEra))
-> TxWits ConwayEra
-> Const (Redeemers ConwayEra) (TxWits ConwayEra)
forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
Lens' (TxWits ConwayEra) (Redeemers ConwayEra)
rdmrsTxWitsL
    total <-
        (String -> IO ExUnits)
-> (ExUnits -> IO ExUnits) -> Either String ExUnits -> IO ExUnits
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
            String -> IO ExUnits
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
            ExUnits -> IO ExUnits
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
            ( ExUnits -> [ExUnits] -> Either String ExUnits
checkExecutionLimit
                (PParams ConwayEra
pp PParams ConwayEra
-> Getting ExUnits (PParams ConwayEra) ExUnits -> ExUnits
forall s a. s -> Getting a s a -> a
^. Getting ExUnits (PParams ConwayEra) ExUnits
forall era. AlonzoEraPParams era => Lens' (PParams era) ExUnits
Lens' (PParams ConwayEra) ExUnits
ppMaxTxExUnitsL)
                (((Data ConwayEra, ExUnits) -> ExUnits)
-> [(Data ConwayEra, ExUnits)] -> [ExUnits]
forall a b. (a -> b) -> [a] -> [b]
map (Data ConwayEra, ExUnits) -> ExUnits
forall a b. (a, b) -> b
snd (Map (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
-> [(Data ConwayEra, ExUnits)]
forall k a. Map k a -> [a]
Map.elems Map (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
redeemers))
            )
    putStrLn
        ( "lifecycle connected budget: "
            <> show total
            <> "; fee="
            <> show (tx ^. bodyTxL . feeTxBodyL)
        )

fundingRequirement
    :: Addr -> PParams ConwayEra -> [TxOut ConwayEra] -> Coin
fundingRequirement :: Addr -> PParams ConwayEra -> [TxOut ConwayEra] -> Coin
fundingRequirement Addr
address PParams ConwayEra
pp [TxOut ConwayEra]
outs =
    let Coin Integer
fees = PParams ConwayEra -> [(TxIn, TxOut ConwayEra)] -> Coin
protocolFeeReserve PParams ConwayEra
pp []
        Coin Integer
change =
            PParams ConwayEra -> TxOut ConwayEra -> Coin
minimumCoin PParams ConwayEra
pp (Addr -> Value ConwayEra -> TxOut ConwayEra
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
address (Coin -> MultiAsset -> MaryValue
MaryValue (Integer -> Coin
Coin Integer
0) MultiAsset
forall a. Monoid a => a
mempty))
    in  Integer -> Coin
Coin
            ([Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Integer
c | BabbageTxOut ConwayEra
o <- [TxOut ConwayEra]
[BabbageTxOut ConwayEra]
outs, let { Coin Integer
c = BabbageTxOut ConwayEra
o BabbageTxOut ConwayEra
-> Getting Coin (BabbageTxOut ConwayEra) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. (Coin -> Const Coin Coin)
-> TxOut ConwayEra -> Const Coin (TxOut ConwayEra)
Getting Coin (BabbageTxOut ConwayEra) Coin
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut ConwayEra) Coin
coinTxOutL }] Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
fees Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
change)

-- | Keep request funding away from references and inputs reserved for later steps.
fundingView :: [TxIn] -> Session NoWitness IO -> Session NoWitness IO
fundingView :: [TxIn] -> Session NoWitness IO -> Session NoWitness IO
fundingView [TxIn]
reserved Session NoWitness IO
v =
    Session NoWitness IO
v
        { outputs = \OutputQuery
query -> do
            result <- Session NoWitness IO
-> OutputQuery
-> IO
     (Either
        ReadFailure (Evidenced NoWitness [(TxIn, TxOut ConwayEra)]))
forall w (m :: * -> *).
Session w m
-> OutputQuery
-> m (Either ReadFailure (Evidenced w [(TxIn, TxOut ConwayEra)]))
outputs Session NoWitness IO
v OutputQuery
query
            pure $ case query of
                AtAddress Addr
_ -> (Evidenced NoWitness [(TxIn, BabbageTxOut ConwayEra)]
 -> Evidenced NoWitness [(TxIn, BabbageTxOut ConwayEra)])
-> Either
     ReadFailure (Evidenced NoWitness [(TxIn, BabbageTxOut ConwayEra)])
-> Either
     ReadFailure (Evidenced NoWitness [(TxIn, BabbageTxOut ConwayEra)])
forall a b.
(a -> b) -> Either ReadFailure a -> Either ReadFailure b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Evidenced NoWitness [(TxIn, BabbageTxOut ConwayEra)]
fact -> Evidenced NoWitness [(TxIn, BabbageTxOut ConwayEra)]
fact{value = filter available (value fact)}) Either
  ReadFailure (Evidenced NoWitness [(TxIn, BabbageTxOut ConwayEra)])
result
                OutputQuery
_ -> Either
  ReadFailure (Evidenced NoWitness [(TxIn, BabbageTxOut ConwayEra)])
result
        }
  where
    available :: (TxIn, TxOut era) -> Bool
available (TxIn
i, TxOut era
out) =
        TxIn
i TxIn -> [TxIn] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [TxIn]
reserved
            Bool -> Bool -> Bool
&& TxOut era
out TxOut era
-> Getting
     (StrictMaybe (Script era)) (TxOut era) (StrictMaybe (Script era))
-> StrictMaybe (Script era)
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictMaybe (Script era)) (TxOut era) (StrictMaybe (Script era))
forall era.
BabbageEraTxOut era =>
Lens' (TxOut era) (StrictMaybe (Script era))
Lens' (TxOut era) (StrictMaybe (Script era))
referenceScriptTxOutL StrictMaybe (Script era) -> StrictMaybe (Script era) -> Bool
forall a. Eq a => a -> a -> Bool
== StrictMaybe (Script era)
forall a. StrictMaybe a
SNothing
            Bool -> Bool -> Bool
&& ( let MaryValue Coin
_ (MultiAsset Map PolicyID (Map AssetName Integer)
assets) = TxOut era
out TxOut era -> Getting MaryValue (TxOut era) MaryValue -> MaryValue
forall s a. s -> Getting a s a -> a
^. Getting MaryValue (TxOut era) MaryValue
(Value era -> Const MaryValue (Value era))
-> TxOut era -> Const MaryValue (TxOut era)
forall era. EraTxOut era => Lens' (TxOut era) (Value era)
Lens' (TxOut era) (Value era)
valueTxOutL
                 in  Map PolicyID (Map AssetName Integer) -> Bool
forall k a. Map k a -> Bool
Map.null Map PolicyID (Map AssetName Integer)
assets
               )

-- | Fund exactly the requested actors, then return the confirmed output references.
fundLifecycle
    :: Wallet
    -> Capabilities NoWitness IO
    -> [TxOut ConwayEra]
    -> IO [(TxIn, TxOut ConwayEra)]
fundLifecycle :: Wallet
-> Capabilities NoWitness IO
-> [TxOut ConwayEra]
-> IO [(TxIn, TxOut ConwayEra)]
fundLifecycle Wallet
wallet Capabilities NoWitness IO
caps [TxOut ConwayEra]
outs = do
    unsigned <- (Network, LedgerProvider NoWitness IO)
-> (Session NoWitness IO -> IO (Tx TopTx ConwayEra))
-> IO (Tx TopTx ConwayEra)
forall w a.
(Network, LedgerProvider w IO) -> (Session w IO -> IO a) -> IO a
withLatest (Capabilities NoWitness IO -> (Network, LedgerProvider NoWitness IO)
forall w (m :: * -> *).
Capabilities w m -> (Network, LedgerProvider w m)
capReads Capabilities NoWitness IO
caps) ((Session NoWitness IO -> IO (Tx TopTx ConwayEra))
 -> IO (Tx TopTx ConwayEra))
-> (Session NoWitness IO -> IO (Tx TopTx ConwayEra))
-> IO (Tx TopTx ConwayEra)
forall a b. (a -> b) -> a -> b
$ \Session NoWitness IO
v -> Wallet
-> Session NoWitness IO
-> [TxOut ConwayEra]
-> IO (Tx TopTx ConwayEra)
fundingTx Wallet
wallet Session NoWitness IO
v [TxOut ConwayEra]
outs
    let signed = SignKeyDSIGN Ed25519DSIGN -> Tx TopTx ConwayEra -> SignedTx
signTx (Wallet -> SignKeyDSIGN Ed25519DSIGN
walletSignKey Wallet
wallet) Tx TopTx ConwayEra
unsigned
        tx = SignedTx -> Tx TopTx ConwayEra
signedTx SignedTx
signed
    capSubmit caps signed >>= \case
        SubmitAccepted TxId
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        SubmitRefused Text
reason -> String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"lifecycle funding rejected: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
reason)
        SubmitFailed Text
reason -> String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"lifecycle funding answer unavailable: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
reason)
        SubmitWrongNetwork Network
wanted Network
actual ->
            String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"lifecycle funding wrong network: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (Network, Network) -> String
forall a. Show a => a -> String
show (Network
wanted, Network
actual))
    capConfirm caps tx
    putStrLn ("lifecycle funding confirmed: " <> show (txIdTx tx))
    pure
        [ (TxIn (txIdTx tx) (TxIx (fromIntegral i)), o)
        | (i, o) <- zip [(0 :: Int) ..] outs
        ]

-- | The unsigned funding of the requested outputs, built from one view.
fundingTx
    :: Wallet -> Session NoWitness IO -> [TxOut ConwayEra] -> IO ConwayTx
fundingTx :: Wallet
-> Session NoWitness IO
-> [TxOut ConwayEra]
-> IO (Tx TopTx ConwayEra)
fundingTx Wallet
fundingWallet Session NoWitness IO
v [TxOut ConwayEra]
outs = do
    pp <- Session NoWitness IO -> IO (PParams ConwayEra)
forall w. Session w IO -> IO (PParams ConwayEra)
parameters Session NoWitness IO
v
    let address = Wallet -> Addr
walletAddr Wallet
fundingWallet
    wallet <- outputsAt (fundingView [] v) address
    let ordinary = ((TxIn, TxOut ConwayEra) -> Down Coin)
-> [(TxIn, TxOut ConwayEra)] -> [(TxIn, TxOut ConwayEra)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Coin -> Down Coin
forall a. a -> Down a
Down (Coin -> Down Coin)
-> ((TxIn, TxOut ConwayEra) -> Coin)
-> (TxIn, TxOut ConwayEra)
-> Down Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxOut ConwayEra
-> ((Coin -> Const Coin Coin)
    -> TxOut ConwayEra -> Const Coin (TxOut ConwayEra))
-> Coin
forall s a. s -> Getting a s a -> a
^. (Coin -> Const Coin Coin)
-> TxOut ConwayEra -> Const Coin (TxOut ConwayEra)
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut ConwayEra) Coin
coinTxOutL) (TxOut ConwayEra -> Coin)
-> ((TxIn, TxOut ConwayEra) -> TxOut ConwayEra)
-> (TxIn, TxOut ConwayEra)
-> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxIn, TxOut ConwayEra) -> TxOut ConwayEra
forall a b. (a, b) -> b
snd) [(TxIn, TxOut ConwayEra)]
[(TxIn, BabbageTxOut ConwayEra)]
wallet
        Coin available = foldMap ((^. coinTxOutL) . snd) ordinary
        Coin need = fundingRequirement address pp outs
        pick
            :: Integer -> [(TxIn, TxOut ConwayEra)] -> [(TxIn, TxOut ConwayEra)]
        pick Integer
_ [] = []
        pick Integer
remaining (u :: (TxIn, TxOut ConwayEra)
u@(TxIn
_, TxOut ConwayEra
o) : [(TxIn, TxOut ConwayEra)]
rest)
            | Integer
remaining Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0 = []
            | Bool
otherwise =
                (TxIn, TxOut ConwayEra)
(TxIn, BabbageTxOut ConwayEra)
u (TxIn, BabbageTxOut ConwayEra)
-> [(TxIn, BabbageTxOut ConwayEra)]
-> [(TxIn, BabbageTxOut ConwayEra)]
forall a. a -> [a] -> [a]
: Integer -> [(TxIn, TxOut ConwayEra)] -> [(TxIn, TxOut ConwayEra)]
pick (Integer
remaining Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- (let Coin Integer
c = TxOut ConwayEra
BabbageTxOut ConwayEra
o BabbageTxOut ConwayEra
-> Getting Coin (BabbageTxOut ConwayEra) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. (Coin -> Const Coin Coin)
-> TxOut ConwayEra -> Const Coin (TxOut ConwayEra)
Getting Coin (BabbageTxOut ConwayEra) Coin
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut ConwayEra) Coin
coinTxOutL in Integer
c)) [(TxIn, TxOut ConwayEra)]
rest
    putStrLn
        ( "lifecycle funding: requirement "
            <> show need
            <> " lovelace; spendable "
            <> show available
            <> " lovelace (reference publications excluded)"
        )
    unless (available >= need) $
        fail
            ( "lifecycle funding: requires "
                <> show need
                <> " lovelace, available "
                <> show available
            )
    let inputs = Integer -> [(TxIn, TxOut ConwayEra)] -> [(TxIn, TxOut ConwayEra)]
pick Integer
need [(TxIn, TxOut ConwayEra)]
ordinary
        draft =
            TxBody TopTx ConwayEra -> Tx TopTx ConwayEra
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l ConwayEra -> Tx l ConwayEra
mkBasicTx (TxBody TopTx ConwayEra
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l ConwayEra
mkBasicTxBody TxBody TopTx ConwayEra
-> (TxBody TopTx ConwayEra -> TxBody TopTx ConwayEra)
-> TxBody TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxOut ConwayEra)
 -> Identity (StrictSeq (TxOut ConwayEra)))
-> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel).
Lens' (TxBody l ConwayEra) (StrictSeq (TxOut ConwayEra))
outputsTxBodyL ((StrictSeq (TxOut ConwayEra)
  -> Identity (StrictSeq (TxOut ConwayEra)))
 -> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> StrictSeq (TxOut ConwayEra)
-> TxBody TopTx ConwayEra
-> TxBody TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxOut ConwayEra] -> StrictSeq (TxOut ConwayEra)
forall a. [a] -> StrictSeq a
StrictSeq.fromList [TxOut ConwayEra]
outs)
    either
        (fail . show)
        (pure . balancedTx)
        (balanceTx pp inputs [] address draft)

checkExecutionLimit :: ExUnits -> [ExUnits] -> Either String ExUnits
checkExecutionLimit :: ExUnits -> [ExUnits] -> Either String ExUnits
checkExecutionLimit (ExUnits Natural
maxMem Natural
maxSteps) [ExUnits]
costs =
    let total :: ExUnits
total@(ExUnits Natural
mem Natural
steps) = (ExUnits -> ExUnits -> ExUnits) -> ExUnits -> [ExUnits] -> ExUnits
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ExUnits -> ExUnits -> ExUnits
add (Natural -> Natural -> ExUnits
ExUnits Natural
0 Natural
0) [ExUnits]
costs
        add :: ExUnits -> ExUnits -> ExUnits
add (ExUnits Natural
a Natural
b) (ExUnits Natural
c Natural
d) = Natural -> Natural -> ExUnits
ExUnits (Natural
a Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
c) (Natural
b Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
d)
    in  if Natural
mem Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
<= Natural
maxMem Bool -> Bool -> Bool
&& Natural
steps Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
<= Natural
maxSteps
            then ExUnits -> Either String ExUnits
forall a b. b -> Either a b
Right ExUnits
total
            else
                String -> Either String ExUnits
forall a b. a -> Either a b
Left
                    ( String
"lifecycle execution limit: requires memory="
                        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Natural -> String
forall a. Show a => a -> String
show Natural
mem
                        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", steps="
                        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Natural -> String
forall a. Show a => a -> String
show Natural
steps
                        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"; live transaction limit memory="
                        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Natural -> String
forall a. Show a => a -> String
show Natural
maxMem
                        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", steps="
                        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Natural -> String
forall a. Show a => a -> String
show Natural
maxSteps
                    )

{- | Evaluate before signing, replace every declared budget with the node's
measured cost, and charge the actual fee from the final change output only.
Re-evaluate the final fee/body until both budgets and fee are stable.
-}
prepareLifecycleTx
    :: Bool
    -> Session NoWitness IO
    -> [(TxIn, TxOut ConwayEra)]
    -> Int
    -> ConwayTx
    -> IO ConwayTx
prepareLifecycleTx :: Bool
-> Session NoWitness IO
-> [(TxIn, TxOut ConwayEra)]
-> Int
-> Tx TopTx ConwayEra
-> IO (Tx TopTx ConwayEra)
prepareLifecycleTx Bool
False Session NoWitness IO
_ [(TxIn, TxOut ConwayEra)]
_ Int
_ Tx TopTx ConwayEra
tx = Tx TopTx ConwayEra -> IO (Tx TopTx ConwayEra)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx TopTx ConwayEra
tx
prepareLifecycleTx Bool
True Session NoWitness IO
v [(TxIn, TxOut ConwayEra)]
refs Int
witnesses Tx TopTx ConwayEra
initial = do
    pp <- Session NoWitness IO -> IO (PParams ConwayEra)
forall w. Session w IO -> IO (PParams ConwayEra)
parameters Session NoWitness IO
v
    go pp (4 :: Int) initial
  where
    go :: PParams ConwayEra
-> t -> Tx TopTx ConwayEra -> IO (Tx TopTx ConwayEra)
go PParams ConwayEra
_ t
0 Tx TopTx ConwayEra
_ = String -> IO (Tx TopTx ConwayEra)
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"lifecycle evaluation and fee did not converge"
    go PParams ConwayEra
pp t
rounds Tx TopTx ConwayEra
tx = do
        measured <- Session NoWitness IO
-> Tx TopTx ConwayEra -> IO (EvaluateTxResult ConwayEra)
forall w.
Session w IO
-> Tx TopTx ConwayEra -> IO (EvaluateTxResult ConwayEra)
Services.evaluateTx Session NoWitness IO
v Tx TopTx ConwayEra
tx
        let Redeemers original = tx ^. witsTxL . rdmrsTxWitsL
        unless (Map.keysSet measured == Map.keysSet original) $
            fail "lifecycle evaluation did not cover every redeemer"
        costs <-
            traverse
                (either (fail . ("lifecycle evaluation refused: " <>) . show) pure)
                measured
        total <-
            either
                fail
                pure
                (checkExecutionLimit (pp ^. ppMaxTxExUnitsL) (Map.elems costs))
        let patched =
                Map (PlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
-> Redeemers ConwayEra
forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era
Redeemers
                    ( (ConwayPlutusPurpose AsIx ConwayEra
 -> (Data ConwayEra, ExUnits) -> (Data ConwayEra, ExUnits))
-> Map
     (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
-> Map
     (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey
                        (\ConwayPlutusPurpose AsIx ConwayEra
purpose (Data ConwayEra
dat, ExUnits
_) -> (Data ConwayEra
dat, Map (ConwayPlutusPurpose AsIx ConwayEra) ExUnits
costs Map (ConwayPlutusPurpose AsIx ConwayEra) ExUnits
-> ConwayPlutusPurpose AsIx ConwayEra -> ExUnits
forall k a. Ord k => Map k a -> k -> a
Map.! ConwayPlutusPurpose AsIx ConwayEra
purpose))
                        Map (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
original
                    )
            evaluated =
                Tx TopTx ConwayEra
tx
                    Tx TopTx ConwayEra
-> (Tx TopTx ConwayEra -> Tx TopTx ConwayEra) -> Tx TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra))
-> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra)
(TxWits ConwayEra -> Identity (TxWits ConwayEra))
-> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxWits ConwayEra)
witsTxL ((AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> ((Redeemers ConwayEra -> Identity (Redeemers ConwayEra))
    -> AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra))
-> (Redeemers ConwayEra -> Identity (Redeemers ConwayEra))
-> Tx TopTx ConwayEra
-> Identity (Tx TopTx ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redeemers ConwayEra -> Identity (Redeemers ConwayEra))
-> AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra)
(Redeemers ConwayEra -> Identity (Redeemers ConwayEra))
-> TxWits ConwayEra -> Identity (TxWits ConwayEra)
forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
Lens' (TxWits ConwayEra) (Redeemers ConwayEra)
rdmrsTxWitsL ((Redeemers ConwayEra -> Identity (Redeemers ConwayEra))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> Redeemers ConwayEra -> Tx TopTx ConwayEra -> Tx TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Redeemers ConwayEra
patched
                    Tx TopTx ConwayEra
-> (Tx TopTx ConwayEra -> Tx TopTx ConwayEra) -> Tx TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxBody l ConwayEra)
bodyTxL ((TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> ((StrictMaybe ScriptIntegrityHash
     -> Identity (StrictMaybe ScriptIntegrityHash))
    -> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> (StrictMaybe ScriptIntegrityHash
    -> Identity (StrictMaybe ScriptIntegrityHash))
-> Tx TopTx ConwayEra
-> Identity (Tx TopTx ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe ScriptIntegrityHash
 -> Identity (StrictMaybe ScriptIntegrityHash))
-> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
AlonzoEraTxBody era =>
Lens' (TxBody l era) (StrictMaybe ScriptIntegrityHash)
forall (l :: TxLevel).
Lens' (TxBody l ConwayEra) (StrictMaybe ScriptIntegrityHash)
scriptIntegrityHashTxBodyL
                        ((StrictMaybe ScriptIntegrityHash
  -> Identity (StrictMaybe ScriptIntegrityHash))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> StrictMaybe ScriptIntegrityHash
-> Tx TopTx ConwayEra
-> Tx TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ PParams ConwayEra
-> Redeemers ConwayEra -> StrictMaybe ScriptIntegrityHash
computeScriptIntegrity PParams ConwayEra
pp Redeemers ConwayEra
patched
            Coin oldFee = tx ^. bodyTxL . feeTxBodyL
            outputs = StrictSeq (BabbageTxOut ConwayEra) -> [BabbageTxOut ConwayEra]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Tx TopTx ConwayEra
tx Tx TopTx ConwayEra
-> Getting
     (StrictSeq (BabbageTxOut ConwayEra))
     (Tx TopTx ConwayEra)
     (StrictSeq (BabbageTxOut ConwayEra))
-> StrictSeq (BabbageTxOut ConwayEra)
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx ConwayEra
 -> Const
      (StrictSeq (BabbageTxOut ConwayEra)) (TxBody TopTx ConwayEra))
-> Tx TopTx ConwayEra
-> Const (StrictSeq (BabbageTxOut ConwayEra)) (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxBody l ConwayEra)
bodyTxL ((TxBody TopTx ConwayEra
  -> Const
       (StrictSeq (BabbageTxOut ConwayEra)) (TxBody TopTx ConwayEra))
 -> Tx TopTx ConwayEra
 -> Const (StrictSeq (BabbageTxOut ConwayEra)) (Tx TopTx ConwayEra))
-> ((StrictSeq (BabbageTxOut ConwayEra)
     -> Const
          (StrictSeq (BabbageTxOut ConwayEra))
          (StrictSeq (BabbageTxOut ConwayEra)))
    -> TxBody TopTx ConwayEra
    -> Const
         (StrictSeq (BabbageTxOut ConwayEra)) (TxBody TopTx ConwayEra))
-> Getting
     (StrictSeq (BabbageTxOut ConwayEra))
     (Tx TopTx ConwayEra)
     (StrictSeq (BabbageTxOut ConwayEra))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut ConwayEra)
 -> Const
      (StrictSeq (BabbageTxOut ConwayEra)) (StrictSeq (TxOut ConwayEra)))
-> TxBody TopTx ConwayEra
-> Const
     (StrictSeq (BabbageTxOut ConwayEra)) (TxBody TopTx ConwayEra)
(StrictSeq (BabbageTxOut ConwayEra)
 -> Const
      (StrictSeq (BabbageTxOut ConwayEra))
      (StrictSeq (BabbageTxOut ConwayEra)))
-> TxBody TopTx ConwayEra
-> Const
     (StrictSeq (BabbageTxOut ConwayEra)) (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel).
Lens' (TxBody l ConwayEra) (StrictSeq (TxOut ConwayEra))
outputsTxBodyL)
        (fixed, change) <- case reverse outputs of
            BabbageTxOut ConwayEra
lastOut : [BabbageTxOut ConwayEra]
rest -> ([BabbageTxOut ConwayEra], BabbageTxOut ConwayEra)
-> IO ([BabbageTxOut ConwayEra], BabbageTxOut ConwayEra)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([BabbageTxOut ConwayEra] -> [BabbageTxOut ConwayEra]
forall a. [a] -> [a]
reverse [BabbageTxOut ConwayEra]
rest, BabbageTxOut ConwayEra
lastOut)
            [] -> String -> IO ([BabbageTxOut ConwayEra], BabbageTxOut ConwayEra)
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"lifecycle balancing needs a final change output"
        let Coin oldChange = change ^. coinTxOutL
            mkOutputs (Coin Integer
fee) =
                let adjusted :: BabbageTxOut ConwayEra
adjusted = BabbageTxOut ConwayEra
change BabbageTxOut ConwayEra
-> (BabbageTxOut ConwayEra -> BabbageTxOut ConwayEra)
-> BabbageTxOut ConwayEra
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin)
-> TxOut ConwayEra -> Identity (TxOut ConwayEra)
(Coin -> Identity Coin)
-> BabbageTxOut ConwayEra -> Identity (BabbageTxOut ConwayEra)
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut ConwayEra) Coin
coinTxOutL ((Coin -> Identity Coin)
 -> BabbageTxOut ConwayEra -> Identity (BabbageTxOut ConwayEra))
-> Coin -> BabbageTxOut ConwayEra -> BabbageTxOut ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin (Integer
oldChange Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
oldFee Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
fee)
                in  if BabbageTxOut ConwayEra
adjusted BabbageTxOut ConwayEra
-> Getting Coin (BabbageTxOut ConwayEra) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. (Coin -> Const Coin Coin)
-> TxOut ConwayEra -> Const Coin (TxOut ConwayEra)
Getting Coin (BabbageTxOut ConwayEra) Coin
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut ConwayEra) Coin
coinTxOutL Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
< PParams ConwayEra -> TxOut ConwayEra -> Coin
forall era. EraTxOut era => PParams era -> TxOut era -> Coin
getMinCoinTxOut PParams ConwayEra
pp TxOut ConwayEra
BabbageTxOut ConwayEra
adjusted
                        then
                            a -> Either a (StrictSeq (BabbageTxOut ConwayEra))
forall a b. a -> Either a b
Left
                                a
"lifecycle change cannot cover the evaluated fee and minimum UTxO"
                        else StrictSeq (BabbageTxOut ConwayEra)
-> Either a (StrictSeq (BabbageTxOut ConwayEra))
forall a b. b -> Either a b
Right ([BabbageTxOut ConwayEra] -> StrictSeq (BabbageTxOut ConwayEra)
forall a. [a] -> StrictSeq a
StrictSeq.fromList ([BabbageTxOut ConwayEra]
fixed [BabbageTxOut ConwayEra]
-> [BabbageTxOut ConwayEra] -> [BabbageTxOut ConwayEra]
forall a. [a] -> [a] -> [a]
++ [BabbageTxOut ConwayEra
adjusted]))
        balanced <-
            either
                (fail . show)
                pure
                (balanceFeeLoop pp mkOutputs witnesses refs evaluated)
        if patched == (tx ^. witsTxL . rdmrsTxWitsL)
            && balanced ^. bodyTxL . feeTxBodyL == tx ^. bodyTxL . feeTxBodyL
            then do
                putStrLn
                    ( "lifecycle evaluated: "
                        <> show total
                        <> "; fee="
                        <> show (balanced ^. bodyTxL . feeTxBodyL)
                    )
                pure balanced
            else go pp (rounds - 1) balanced