{-# LANGUAGE NumericUnderscores #-}

{- |
Module      : Singular.Registry.TxBuilder.Boot
Description : Boot token minting transaction
License     : Apache-2.0

Builds the minting transaction for a new cage
token. Picks a wallet UTxO as seed for asset-name
derivation, mints +1 token at the cage policy, and
creates a State UTxO with empty root and configured
default parameters. The state validator is resolved
through its published reference output; a wallet
without one is refused 'StateValidatorNotPublished'.
-}
module Singular.Registry.TxBuilder.Boot
    ( bootTokenImpl
    , bootTokenFrom
    , bootCostBound
    , BootRefusal (..)
    ) where

import Control.Exception (Exception (..), throwIO)
import Data.ByteString.Short qualified as SBS
import Data.Map.Strict qualified as Map
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.Alonzo.TxBody
    ( scriptIntegrityHashTxBodyL
    )
import Cardano.Ledger.Api.PParams (PParams, ppCollateralPercentageL)
import Cardano.Ledger.Api.Tx
    ( bodyTxL
    , estimateMinFeeTx
    , mkBasicTx
    , witsTxL
    )
import Cardano.Ledger.Api.Tx.Body
    ( collateralInputsTxBodyL
    , collateralReturnTxBodyL
    , feeTxBodyL
    , inputsTxBodyL
    , mintTxBodyL
    , mkBasicTxBody
    , outputsTxBodyL
    , referenceInputsTxBodyL
    , totalCollateralTxBodyL
    )
import Cardano.Ledger.Api.Tx.Out
    ( coinTxOutL
    , datumTxOutL
    , mkBasicTxOut
    , referenceScriptTxOutL
    , valueTxOutL
    )
import Cardano.Ledger.Api.Tx.Wits
    ( Redeemers (..)
    , rdmrsTxWitsL
    )
import Cardano.Ledger.BaseTypes (Inject (inject), StrictMaybe (..))
import Cardano.Ledger.Conway.Scripts
    ( ConwayPlutusPurpose (..)
    )
import Cardano.Ledger.Core (TxOut, hashScript)
import Cardano.Ledger.Mary.Value
    ( MaryValue (..)
    , MultiAsset (..)
    )
import Cardano.Ledger.TxIn (TxIn)
import Data.Foldable (toList)
import Data.List (find, sortOn)
import Data.Ord (Down (..))

import Cardano.Tx.Ledger (ConwayTx)
import Singular.Registry.AssetName (deriveAssetName)
import Singular.Registry.Config
    ( CageConfig (..)
    , bootStateFromCfg
    )
import Singular.Registry.Evidence (NoWitness)
import Singular.Registry.Ledger
    ( AssetName (..)
    , Coin (..)
    , ConwayEra
    )
import Singular.Registry.LedgerProvider (Session)
import Singular.Registry.Lifecycle (protocolFeeReserve)
import Singular.Registry.SessionIO (outputsAt, parameters)
import Singular.Registry.TxBuilder.Internal.Identity
import Singular.Registry.TxBuilder.Internal.Lookup
import Singular.Registry.Types
    ( CageDatum (..)
    , MintRedeemer (..)
    , OnChainRoot (..)
    , OnChainTxOutRef
    )

-- | Locate the wallet UTxO whose on-chain reference matches @cageSeed@.
lookupSeed
    :: OnChainTxOutRef
    -> [(TxIn, TxOut ConwayEra)]
    -> Maybe (TxIn, TxOut ConwayEra)
lookupSeed :: OnChainTxOutRef
-> [(TxIn, TxOut ConwayEra)] -> Maybe (TxIn, TxOut ConwayEra)
lookupSeed OnChainTxOutRef
target =
    ((TxIn, BabbageTxOut ConwayEra) -> Bool)
-> [(TxIn, BabbageTxOut ConwayEra)]
-> Maybe (TxIn, BabbageTxOut ConwayEra)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(TxIn
tin, BabbageTxOut ConwayEra
_) -> TxIn -> OnChainTxOutRef
txInToRef TxIn
tin OnChainTxOutRef -> OnChainTxOutRef -> Bool
forall a. Eq a => a -> a -> Bool
== OnChainTxOutRef
target)

{- | The state validator, published as a reference output at the payer's
own address, if one is already there (#177).

A registry boots only by reference. The state validator is fifteen
kilobytes against a sixteen-kilobyte transaction cap, so a boot that
carried it inline would leave the registry no room to grow; no
transaction carries it.

Discovery rather than a new argument, because every caller of
`bootTokenImpl` boots from a wallet the publisher writes to. A session
publishes once — `publishStateRef` — and every boot after it references.
-}
lookupStateRef
    :: CageConfig
    -> [(TxIn, TxOut ConwayEra)]
    -> Maybe (TxIn, TxOut ConwayEra)
lookupStateRef :: CageConfig
-> [(TxIn, TxOut ConwayEra)] -> Maybe (TxIn, TxOut ConwayEra)
lookupStateRef CageConfig
cfg =
    ((TxIn, BabbageTxOut ConwayEra) -> Bool)
-> [(TxIn, BabbageTxOut ConwayEra)]
-> Maybe (TxIn, BabbageTxOut ConwayEra)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find
        ( \(TxIn
_, BabbageTxOut ConwayEra
out) -> case BabbageTxOut ConwayEra
out BabbageTxOut ConwayEra
-> Getting
     (StrictMaybe (Script ConwayEra))
     (BabbageTxOut ConwayEra)
     (StrictMaybe (Script ConwayEra))
-> StrictMaybe (Script ConwayEra)
forall s a. s -> Getting a s a -> a
^. (StrictMaybe (Script ConwayEra)
 -> Const
      (StrictMaybe (Script ConwayEra)) (StrictMaybe (Script ConwayEra)))
-> TxOut ConwayEra
-> Const (StrictMaybe (Script ConwayEra)) (TxOut ConwayEra)
Getting
  (StrictMaybe (Script ConwayEra))
  (BabbageTxOut ConwayEra)
  (StrictMaybe (Script ConwayEra))
forall era.
BabbageEraTxOut era =>
Lens' (TxOut era) (StrictMaybe (Script era))
Lens' (TxOut ConwayEra) (StrictMaybe (Script ConwayEra))
referenceScriptTxOutL of
            SJust Script ConwayEra
s -> Script ConwayEra -> ScriptHash
forall era. EraScript era => Script era -> ScriptHash
hashScript Script ConwayEra
s ScriptHash -> ScriptHash -> Bool
forall a. Eq a => a -> a -> Bool
== CageConfig -> ScriptHash
cfgScriptHash CageConfig
cfg
            StrictMaybe (Script ConwayEra)
SNothing -> Bool
False
        )

{- | Why a boot is refused before any transaction is built.

'StateValidatorNotPublished': the payer's wallet holds no reference
output carrying this configuration's state validator. The boot resolves
that validator through the publication and never carries it inline, so
the caller publishes it first (`publishStateRef`) and boots again.
-}
data BootRefusal = StateValidatorNotPublished
    deriving (BootRefusal -> BootRefusal -> Bool
(BootRefusal -> BootRefusal -> Bool)
-> (BootRefusal -> BootRefusal -> Bool) -> Eq BootRefusal
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BootRefusal -> BootRefusal -> Bool
== :: BootRefusal -> BootRefusal -> Bool
$c/= :: BootRefusal -> BootRefusal -> Bool
/= :: BootRefusal -> BootRefusal -> Bool
Eq, Int -> BootRefusal -> ShowS
[BootRefusal] -> ShowS
BootRefusal -> String
(Int -> BootRefusal -> ShowS)
-> (BootRefusal -> String)
-> ([BootRefusal] -> ShowS)
-> Show BootRefusal
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BootRefusal -> ShowS
showsPrec :: Int -> BootRefusal -> ShowS
$cshow :: BootRefusal -> String
show :: BootRefusal -> String
$cshowList :: [BootRefusal] -> ShowS
showList :: [BootRefusal] -> ShowS
Show)

instance Exception BootRefusal where
    displayException :: BootRefusal -> String
displayException BootRefusal
StateValidatorNotPublished =
        String
"StateValidatorNotPublished: the payer's wallet holds no\
        \ reference output carrying the state validator; publish the\
        \ state validator first (publishStateRef) and boot again"

{- | Build a boot-token minting transaction.

Refuses 'StateValidatorNotPublished' when the payer's wallet holds no
publication of the state validator.
-}
bootTokenImpl
    :: CageConfig
    -> Session NoWitness IO
    -> Addr
    -> IO ConwayTx
bootTokenImpl :: CageConfig -> Session NoWitness IO -> Addr -> IO ConwayTx
bootTokenImpl CageConfig
cfg Session NoWitness IO
view Addr
addr = do
    pp <- Session NoWitness IO -> IO (PParams ConwayEra)
forall w. Session w IO -> IO (PParams ConwayEra)
parameters Session NoWitness IO
view
    utxos <- outputsAt view addr
    stateRef <-
        maybe
            (throwIO StateValidatorNotPublished)
            pure
            (lookupStateRef cfg utxos)
    bootFrom cfg pp utxos stateRef view addr

{- | Build a boot-token minting transaction that resolves the state validator
through this reference output, wherever it sits: the caller found it and
checked the script it carries. The seed and the funding still come from the
payer's wallet.
-}
bootTokenFrom
    :: CageConfig
    -> (TxIn, TxOut ConwayEra)
    -> Session NoWitness IO
    -> Addr
    -> IO ConwayTx
bootTokenFrom :: CageConfig
-> (TxIn, TxOut ConwayEra)
-> Session NoWitness IO
-> Addr
-> IO ConwayTx
bootTokenFrom CageConfig
cfg (TxIn, TxOut ConwayEra)
stateRef Session NoWitness IO
view Addr
addr = do
    pp <- Session NoWitness IO -> IO (PParams ConwayEra)
forall w. Session w IO -> IO (PParams ConwayEra)
parameters Session NoWitness IO
view
    utxos <- outputsAt view addr
    bootFrom cfg pp utxos stateRef view addr

-- | The boot, from the parameters and the payer's outputs already read.
bootFrom
    :: CageConfig
    -> PParams ConwayEra
    -> [(TxIn, TxOut ConwayEra)]
    -> (TxIn, TxOut ConwayEra)
    -> Session NoWitness IO
    -> Addr
    -> IO ConwayTx
bootFrom :: CageConfig
-> PParams ConwayEra
-> [(TxIn, TxOut ConwayEra)]
-> (TxIn, TxOut ConwayEra)
-> Session NoWitness IO
-> Addr
-> IO ConwayTx
bootFrom CageConfig
cfg PParams ConwayEra
pp [(TxIn, TxOut ConwayEra)]
utxos (TxIn, TxOut ConwayEra)
stateRef Session NoWitness IO
view Addr
addr = do
    -- The seed UTxO is carried in the mint redeemer. We MUST consume
    -- that exact UTxO -- any other input would fail the validator's
    -- `find_input(inputs, seed)` check. Locate it in the caller's
    -- wallet and use it as the seed input.
    let seedRefOnChain :: OnChainTxOutRef
seedRefOnChain = CageConfig -> OnChainTxOutRef
cageSeed CageConfig
cfg
    seedUtxo <- case OnChainTxOutRef
-> [(TxIn, TxOut ConwayEra)] -> Maybe (TxIn, TxOut ConwayEra)
lookupSeed OnChainTxOutRef
seedRefOnChain [(TxIn, TxOut ConwayEra)]
utxos of
        Just (TxIn, TxOut ConwayEra)
u -> (TxIn, TxOut ConwayEra) -> IO (TxIn, TxOut ConwayEra)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxIn, TxOut ConwayEra)
u
        Maybe (TxIn, TxOut ConwayEra)
Nothing ->
            String -> IO (TxIn, TxOut ConwayEra)
forall a. HasCallStack => String -> a
error
                String
"bootToken: cfg's cageSeed UTxO is not in the\
                \ caller's wallet — cfg may have been built for\
                \ a different seed than the wallet currently\
                \ holds"
    let (seedRef, _seedOut) = seedUtxo
        -- A shared wallet also holds persistent reference publications.
        -- Extra funding inputs must leave those outputs available to runners.
        -- #177 A-003: the boot references a fifteen-kilobyte script and
        -- pays Conway's size tier for it, so its fee is an order of
        -- magnitude larger than before and its collateral must cover
        -- 150% of that. Fund from the wallet's LARGEST spendable
        -- output rather than whichever happens to come first.
        -- The funding input doubles as COLLATERAL, and collateral must
        -- be ada-only: an approval returned by an earlier fold rides in
        -- this wallet, and a boot that collateralised with it is refused
        -- `CollateralContainsNonADA`. It must also not be the reference
        -- publication, which this transaction reads.
        spendable u :: (TxIn, TxOut ConwayEra)
u@(TxIn
_, TxOut ConwayEra
out) =
            (TxIn, TxOut ConwayEra)
u (TxIn, TxOut ConwayEra) -> (TxIn, TxOut ConwayEra) -> Bool
forall a. Eq a => a -> a -> Bool
/= (TxIn, TxOut ConwayEra)
seedUtxo
                Bool -> Bool -> Bool
&& TxOut ConwayEra
out TxOut ConwayEra
-> ((StrictMaybe (Script ConwayEra)
     -> Const
          (StrictMaybe (Script ConwayEra)) (StrictMaybe (Script ConwayEra)))
    -> TxOut ConwayEra
    -> Const (StrictMaybe (Script ConwayEra)) (TxOut ConwayEra))
-> StrictMaybe (Script ConwayEra)
forall s a. s -> Getting a s a -> a
^. (StrictMaybe (Script ConwayEra)
 -> Const
      (StrictMaybe (Script ConwayEra)) (StrictMaybe (Script ConwayEra)))
-> TxOut ConwayEra
-> Const (StrictMaybe (Script ConwayEra)) (TxOut ConwayEra)
forall era.
BabbageEraTxOut era =>
Lens' (TxOut era) (StrictMaybe (Script era))
Lens' (TxOut ConwayEra) (StrictMaybe (Script ConwayEra))
referenceScriptTxOutL StrictMaybe (Script ConwayEra)
-> StrictMaybe (Script ConwayEra) -> Bool
forall a. Eq a => a -> a -> Bool
== StrictMaybe (Script ConwayEra)
forall a. StrictMaybe a
SNothing
                Bool -> Bool -> Bool
&& (case TxOut ConwayEra
out TxOut ConwayEra
-> Getting MaryValue (TxOut ConwayEra) MaryValue -> MaryValue
forall s a. s -> Getting a s a -> a
^. Getting MaryValue (TxOut ConwayEra) MaryValue
(Value ConwayEra -> Const MaryValue (Value ConwayEra))
-> TxOut ConwayEra -> Const MaryValue (TxOut ConwayEra)
forall era. EraTxOut era => Lens' (TxOut era) (Value era)
Lens' (TxOut ConwayEra) (Value ConwayEra)
valueTxOutL of MaryValue Coin
_ (MultiAsset Map PolicyID (Map AssetName Integer)
m) -> Map PolicyID (Map AssetName Integer) -> Bool
forall k a. Map k a -> Bool
Map.null Map PolicyID (Map AssetName Integer)
m)
        rest =
            ((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 -> Getting Coin (TxOut ConwayEra) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (TxOut ConwayEra) Coin
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) -> Bool)
-> [(TxIn, TxOut ConwayEra)] -> [(TxIn, TxOut ConwayEra)]
forall a. (a -> Bool) -> [a] -> [a]
filter (TxIn, TxOut ConwayEra) -> Bool
spendable [(TxIn, TxOut ConwayEra)]
utxos)
        allInputUtxos = case [(TxIn, BabbageTxOut ConwayEra)]
rest of
            [] -> [(TxIn, TxOut ConwayEra)
(TxIn, BabbageTxOut ConwayEra)
seedUtxo]
            ((TxIn, BabbageTxOut ConwayEra)
u : [(TxIn, BabbageTxOut ConwayEra)]
_) -> [(TxIn, TxOut ConwayEra)
(TxIn, BabbageTxOut ConwayEra)
seedUtxo, (TxIn, BabbageTxOut ConwayEra)
u]
        assetNameBs =
            OnChainTxOutRef -> ByteString
deriveAssetName OnChainTxOutRef
seedRefOnChain
        assetName =
            ShortByteString -> AssetName
AssetName
                (ByteString -> ShortByteString
SBS.toShort ByteString
assetNameBs)
    let policyId =
            CageConfig -> PolicyID
cagePolicyIdFromCfg CageConfig
cfg
        mintMA =
            Map PolicyID (Map AssetName Integer) -> MultiAsset
MultiAsset
                (Map PolicyID (Map AssetName Integer) -> MultiAsset)
-> Map PolicyID (Map AssetName Integer) -> MultiAsset
forall a b. (a -> b) -> a -> b
$ PolicyID
-> Map AssetName Integer -> Map PolicyID (Map AssetName Integer)
forall k a. k -> a -> Map k a
Map.singleton
                    PolicyID
policyId
                (Map AssetName Integer -> Map PolicyID (Map AssetName Integer))
-> Map AssetName Integer -> Map PolicyID (Map AssetName Integer)
forall a b. (a -> b) -> a -> b
$ AssetName -> Integer -> Map AssetName Integer
forall k a. k -> a -> Map k a
Map.singleton
                    AssetName
assetName
                    Integer
1
    -- Ownerless registry (ruling NOTE-028/A-003): the state datum carries
    -- no owner and no stake script. Issue #77 E-001 repair: it carries the
    -- expected representative policy from the cage configuration (honest
    -- applied hash for naming cages, zeros for registry-only cages).
    let stateDatum = OnChainTokenState -> CageDatum
StateDatum (CageConfig -> OnChainRoot -> OnChainTokenState
bootStateFromCfg CageConfig
cfg (ByteString -> OnChainRoot
OnChainRoot ByteString
emptyRoot))
        datumData = CageDatum -> Data
forall a. ToData a => a -> Data
toPlcData CageDatum
stateDatum
    let scriptAddr =
            CageConfig -> Network -> Addr
cageAddrFromCfg
                CageConfig
cfg
                (CageConfig -> Network
network CageConfig
cfg)
        outValue =
            Coin -> MultiAsset -> MaryValue
MaryValue
                (Integer -> Coin
Coin Integer
bootStateLovelace)
                MultiAsset
mintMA
        txOut =
            Addr -> Value ConwayEra -> TxOut ConwayEra
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut
                Addr
scriptAddr
                MaryValue
Value ConwayEra
outValue
                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
                        Data
datumData
    let redeemer = OnChainTxOutRef -> MintRedeemer
Minting OnChainTxOutRef
seedRefOnChain
        mintPurpose =
            AsIx Word32 PolicyID -> ConwayPlutusPurpose AsIx era
forall (f :: * -> * -> *) era.
f Word32 PolicyID -> ConwayPlutusPurpose f era
ConwayMinting (Word32 -> AsIx Word32 PolicyID
forall ix it. ix -> AsIx ix it
AsIx Word32
0)
        redeemers =
            Map (PlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
-> Redeemers ConwayEra
forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era
Redeemers (Map (PlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
 -> Redeemers ConwayEra)
-> Map (PlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
-> Redeemers ConwayEra
forall a b. (a -> b) -> a -> b
$
                PlutusPurpose AsIx ConwayEra
-> (Data ConwayEra, ExUnits)
-> Map (PlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
forall k a. k -> a -> Map k a
Map.singleton
                    PlutusPurpose AsIx ConwayEra
ConwayPlutusPurpose AsIx ConwayEra
forall {era}. ConwayPlutusPurpose AsIx era
mintPurpose
                    ( MintRedeemer -> Data ConwayEra
forall a. ToData a => a -> Data ConwayEra
toLedgerData MintRedeemer
redeemer
                    , ExUnits
placeholderExUnits
                    )
    let integrity =
            PParams ConwayEra
-> Redeemers ConwayEra -> StrictMaybe ScriptIntegrityHash
computeScriptIntegrity
                PParams ConwayEra
pp
                Redeemers ConwayEra
redeemers
        body =
            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
& (Set TxIn -> Identity (Set TxIn))
-> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l ConwayEra) (Set TxIn)
inputsTxBodyL
                    ((Set TxIn -> Identity (Set TxIn))
 -> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> Set TxIn -> TxBody TopTx ConwayEra -> TxBody TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxIn -> Set TxIn
forall a. a -> Set a
Set.singleton
                        TxIn
seedRef
                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)
(StrictSeq (TxOut ConwayEra)
 -> Identity (StrictSeq (BabbageTxOut 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 (BabbageTxOut ConwayEra)))
 -> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> StrictSeq (BabbageTxOut ConwayEra)
-> TxBody TopTx ConwayEra
-> TxBody TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ BabbageTxOut ConwayEra -> StrictSeq (BabbageTxOut ConwayEra)
forall a. a -> StrictSeq a
StrictSeq.singleton
                        BabbageTxOut ConwayEra
txOut
                TxBody TopTx ConwayEra
-> (TxBody TopTx ConwayEra -> TxBody TopTx ConwayEra)
-> TxBody TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (MultiAsset -> Identity MultiAsset)
-> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
MaryEraTxBody era =>
Lens' (TxBody l era) MultiAsset
forall (l :: TxLevel). Lens' (TxBody l ConwayEra) MultiAsset
mintTxBodyL ((MultiAsset -> Identity MultiAsset)
 -> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> MultiAsset -> TxBody TopTx ConwayEra -> TxBody TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ MultiAsset
mintMA
                TxBody TopTx ConwayEra
-> (TxBody TopTx ConwayEra -> TxBody TopTx ConwayEra)
-> TxBody TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra)
forall era.
AlonzoEraTxBody era =>
Lens' (TxBody TopTx era) (Set TxIn)
Lens' (TxBody TopTx ConwayEra) (Set TxIn)
collateralInputsTxBodyL
                    ((Set TxIn -> Identity (Set TxIn))
 -> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> Set TxIn -> TxBody TopTx ConwayEra -> TxBody TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxIn -> Set TxIn
forall a. a -> Set a
Set.singleton
                        ( (TxIn, BabbageTxOut ConwayEra) -> TxIn
forall a b. (a, b) -> a
fst ((TxIn, BabbageTxOut ConwayEra) -> TxIn)
-> (TxIn, BabbageTxOut ConwayEra) -> TxIn
forall a b. (a -> b) -> a -> b
$
                            [(TxIn, BabbageTxOut ConwayEra)] -> (TxIn, BabbageTxOut ConwayEra)
forall a. HasCallStack => [a] -> a
last
                                [(TxIn, BabbageTxOut ConwayEra)]
allInputUtxos
                        )
                TxBody TopTx ConwayEra
-> (TxBody TopTx ConwayEra -> TxBody TopTx ConwayEra)
-> TxBody TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (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))
 -> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> StrictMaybe ScriptIntegrityHash
-> TxBody TopTx ConwayEra
-> TxBody TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ StrictMaybe ScriptIntegrityHash
integrity
                TxBody TopTx ConwayEra
-> (TxBody TopTx ConwayEra -> TxBody TopTx ConwayEra)
-> TxBody TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
BabbageEraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l ConwayEra) (Set TxIn)
referenceInputsTxBodyL
                    ((Set TxIn -> Identity (Set TxIn))
 -> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> Set TxIn -> TxBody TopTx ConwayEra -> TxBody TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxIn -> Set TxIn
forall a. a -> Set a
Set.singleton ((TxIn, BabbageTxOut ConwayEra) -> TxIn
forall a b. (a, b) -> a
fst (TxIn, TxOut ConwayEra)
(TxIn, BabbageTxOut ConwayEra)
stateRef)
        tx =
            TxBody TopTx ConwayEra -> ConwayTx
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
body
                ConwayTx -> (ConwayTx -> ConwayTx) -> ConwayTx
forall a b. a -> (a -> b) -> b
& (AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra))
-> ConwayTx -> Identity ConwayTx
(TxWits ConwayEra -> Identity (TxWits ConwayEra))
-> ConwayTx -> Identity ConwayTx
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))
 -> ConwayTx -> Identity ConwayTx)
-> ((Redeemers ConwayEra -> Identity (Redeemers ConwayEra))
    -> AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra))
-> (Redeemers ConwayEra -> Identity (Redeemers ConwayEra))
-> ConwayTx
-> Identity ConwayTx
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))
 -> ConwayTx -> Identity ConwayTx)
-> Redeemers ConwayEra -> ConwayTx -> ConwayTx
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Redeemers ConwayEra
redeemers
    balanced <-
        evaluateAndBalance
            view
            pp
            allInputUtxos
            addr
            tx
    -- #177 A-003: the balancer estimates with zero reference-script
    -- bytes, which under-pays a boot that references fifteen kilobytes
    -- of state validator.
    pure
        ( declareCollateral
            pp
            allInputUtxos
            addr
            (payForReferenceScripts pp (SBS.length (cageScriptBytes cfg)) balanced)
        )

-- | The lovelace a boot locks in the state output it creates.
bootStateLovelace :: Integer
bootStateLovelace :: Integer
bootStateLovelace = Integer
2_000_000

{- | The most a boot takes from the payer's spending inputs: the lovelace its
state output locks, and a fee allowance for one maximum-size transaction at
the execution limit referencing this state carrier ('protocolFeeReserve').
A create checks its publications against what the boot leaves with it,
before anything is submitted.
-}
bootCostBound
    :: PParams ConwayEra -> (TxIn, TxOut ConwayEra) -> Integer
bootCostBound :: PParams ConwayEra -> (TxIn, TxOut ConwayEra) -> Integer
bootCostBound PParams ConwayEra
pp (TxIn, TxOut ConwayEra)
carrier =
    let Coin Integer
allowance = PParams ConwayEra -> [(TxIn, TxOut ConwayEra)] -> Coin
protocolFeeReserve PParams ConwayEra
pp [(TxIn, TxOut ConwayEra)
carrier]
    in  Integer
bootStateLovelace Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
allowance

{- | Pay for the reference script the boot now resolves through (#177
A-003).

Conway charges a size tier for every byte of script a transaction
REFERENCES, on top of the ordinary fee. The balancer this builder uses
estimates with zero reference-script bytes — a reasonable default for a
transaction that references none — so a boot that references fifteen
kilobytes of state validator under-pays and the ledger refuses it
`FeeTooSmallUTxO`.

The balanced transaction is therefore re-costed against the bytes it
actually references, and the difference is moved out of the change
output into the fee. The change output is the last one, because that is
where the balancer appends it.

Nothing here invents a fee: `estimateMinFeeTx` is the ledger's own
estimator, given the byte count this transaction's own reference inputs
carry.
-}
payForReferenceScripts
    :: PParams ConwayEra
    -> Int
    -- ^ the compiled bytes of the script this boot references
    -> ConwayTx
    -> ConwayTx
payForReferenceScripts :: PParams ConwayEra -> Int -> ConwayTx -> ConwayTx
payForReferenceScripts PParams ConwayEra
pp Int
stateBytes ConwayTx
tx =
    let Coin Integer
currentFee = ConwayTx
tx ConwayTx -> Getting Coin ConwayTx Coin -> Coin
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx ConwayEra -> Const Coin (TxBody TopTx ConwayEra))
-> ConwayTx -> Const Coin ConwayTx
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 Coin (TxBody TopTx ConwayEra))
 -> ConwayTx -> Const Coin ConwayTx)
-> ((Coin -> Const Coin Coin)
    -> TxBody TopTx ConwayEra -> Const Coin (TxBody TopTx ConwayEra))
-> Getting Coin ConwayTx Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const Coin Coin)
-> TxBody TopTx ConwayEra -> Const Coin (TxBody TopTx ConwayEra)
forall era. EraTxBody era => Lens' (TxBody TopTx era) Coin
Lens' (TxBody TopTx ConwayEra) Coin
feeTxBodyL
        Coin Integer
needed = PParams ConwayEra -> ConwayTx -> Int -> Int -> Int -> Coin
forall era.
EraTx era =>
PParams era -> Tx TopTx era -> Int -> Int -> Int -> Coin
estimateMinFeeTx PParams ConwayEra
pp ConwayTx
tx Int
1 Int
0 Int
stateBytes
        delta :: Integer
delta = Integer
needed Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
currentFee
    in  if Integer
delta Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0
            then ConwayTx
tx
            else
                let outs :: [BabbageTxOut ConwayEra]
outs = StrictSeq (BabbageTxOut ConwayEra) -> [BabbageTxOut ConwayEra]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (ConwayTx
tx ConwayTx
-> Getting
     (StrictSeq (BabbageTxOut ConwayEra))
     ConwayTx
     (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))
-> ConwayTx -> Const (StrictSeq (BabbageTxOut ConwayEra)) ConwayTx
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))
 -> ConwayTx -> Const (StrictSeq (BabbageTxOut ConwayEra)) ConwayTx)
-> ((StrictSeq (BabbageTxOut ConwayEra)
     -> Const
          (StrictSeq (BabbageTxOut ConwayEra))
          (StrictSeq (BabbageTxOut ConwayEra)))
    -> TxBody TopTx ConwayEra
    -> Const
         (StrictSeq (BabbageTxOut ConwayEra)) (TxBody TopTx ConwayEra))
-> Getting
     (StrictSeq (BabbageTxOut ConwayEra))
     ConwayTx
     (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)
                in  case [BabbageTxOut ConwayEra] -> [BabbageTxOut ConwayEra]
forall a. [a] -> [a]
reverse [BabbageTxOut ConwayEra]
outs of
                        [] -> ConwayTx
tx
                        (BabbageTxOut ConwayEra
change : [BabbageTxOut ConwayEra]
earlier) ->
                            let Coin Integer
changeCoin = BabbageTxOut ConwayEra
change BabbageTxOut ConwayEra
-> Getting Coin (BabbageTxOut ConwayEra) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (TxOut ConwayEra) Coin
Getting Coin (BabbageTxOut ConwayEra) Coin
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut ConwayEra) Coin
coinTxOutL
                                changePaid :: BabbageTxOut ConwayEra
changePaid =
                                    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
changeCoin Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
delta)
                            in  ConwayTx
tx
                                    ConwayTx -> (ConwayTx -> ConwayTx) -> ConwayTx
forall a b. a -> (a -> b) -> b
& (TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> ConwayTx -> Identity ConwayTx
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))
 -> ConwayTx -> Identity ConwayTx)
-> ((Coin -> Identity Coin)
    -> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> (Coin -> Identity Coin)
-> ConwayTx
-> Identity ConwayTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Identity Coin)
-> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra)
forall era. EraTxBody era => Lens' (TxBody TopTx era) Coin
Lens' (TxBody TopTx ConwayEra) Coin
feeTxBodyL ((Coin -> Identity Coin) -> ConwayTx -> Identity ConwayTx)
-> Coin -> ConwayTx -> ConwayTx
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
needed
                                    ConwayTx -> (ConwayTx -> ConwayTx) -> ConwayTx
forall a b. a -> (a -> b) -> b
& (TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> ConwayTx -> Identity ConwayTx
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))
 -> ConwayTx -> Identity ConwayTx)
-> ((StrictSeq (BabbageTxOut ConwayEra)
     -> Identity (StrictSeq (BabbageTxOut ConwayEra)))
    -> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> (StrictSeq (BabbageTxOut ConwayEra)
    -> Identity (StrictSeq (BabbageTxOut ConwayEra)))
-> ConwayTx
-> Identity ConwayTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut ConwayEra)
 -> Identity (StrictSeq (TxOut ConwayEra)))
-> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra)
(StrictSeq (BabbageTxOut ConwayEra)
 -> Identity (StrictSeq (BabbageTxOut 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 (BabbageTxOut ConwayEra)
  -> Identity (StrictSeq (BabbageTxOut ConwayEra)))
 -> ConwayTx -> Identity ConwayTx)
-> StrictSeq (BabbageTxOut ConwayEra) -> ConwayTx -> ConwayTx
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [BabbageTxOut ConwayEra] -> StrictSeq (BabbageTxOut ConwayEra)
forall a. [a] -> StrictSeq a
StrictSeq.fromList
                                            ([BabbageTxOut ConwayEra] -> [BabbageTxOut ConwayEra]
forall a. [a] -> [a]
reverse (BabbageTxOut ConwayEra
changePaid BabbageTxOut ConwayEra
-> [BabbageTxOut ConwayEra] -> [BabbageTxOut ConwayEra]
forall a. a -> [a] -> [a]
: [BabbageTxOut ConwayEra]
earlier))

{- | Declare the collateral this boot actually needs (#177 A-003).

Conway sizes required collateral as a percentage of the FEE, and the
reference-script tier raised this boot's fee by roughly 700 kilolovelace.
The collateral the builder had already committed was sized for the
earlier, smaller fee, so the ledger refused with `InsufficientCollateral`
even though the input backing it holds the wallet's whole balance.

Rather than leave the amount implicit, the transaction now SAYS what it
is putting up: `totalCollateral` at the ledger's own requirement, and a
collateral return carrying the rest of the input back. Both are derived
from the fee this transaction actually pays and the protocol's own
percentage — nothing here is a chosen number.
-}
declareCollateral
    :: PParams ConwayEra
    -> [(TxIn, TxOut ConwayEra)]
    -> Addr
    -> ConwayTx
    -> ConwayTx
declareCollateral :: PParams ConwayEra
-> [(TxIn, TxOut ConwayEra)] -> Addr -> ConwayTx -> ConwayTx
declareCollateral PParams ConwayEra
pp [(TxIn, TxOut ConwayEra)]
resolvable Addr
changeAddr ConwayTx
tx =
    let collateral :: Set TxIn
collateral = ConwayTx
tx ConwayTx -> Getting (Set TxIn) ConwayTx (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx ConwayEra
 -> Const (Set TxIn) (TxBody TopTx ConwayEra))
-> ConwayTx -> Const (Set TxIn) ConwayTx
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 (Set TxIn) (TxBody TopTx ConwayEra))
 -> ConwayTx -> Const (Set TxIn) ConwayTx)
-> ((Set TxIn -> Const (Set TxIn) (Set TxIn))
    -> TxBody TopTx ConwayEra
    -> Const (Set TxIn) (TxBody TopTx ConwayEra))
-> Getting (Set TxIn) ConwayTx (Set TxIn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Const (Set TxIn) (Set TxIn))
-> TxBody TopTx ConwayEra
-> Const (Set TxIn) (TxBody TopTx ConwayEra)
forall era.
AlonzoEraTxBody era =>
Lens' (TxBody TopTx era) (Set TxIn)
Lens' (TxBody TopTx ConwayEra) (Set TxIn)
collateralInputsTxBodyL
        backing :: Integer
backing =
            [Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum
                [ Integer
c
                | (TxIn
i, BabbageTxOut ConwayEra
o) <- [(TxIn, TxOut ConwayEra)]
[(TxIn, BabbageTxOut ConwayEra)]
resolvable
                , TxIn -> Set TxIn -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member TxIn
i Set TxIn
collateral
                , let Coin Integer
c = BabbageTxOut ConwayEra
o BabbageTxOut ConwayEra
-> Getting Coin (BabbageTxOut ConwayEra) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (TxOut ConwayEra) Coin
Getting Coin (BabbageTxOut ConwayEra) Coin
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut ConwayEra) Coin
coinTxOutL
                ]
        Coin Integer
fee = ConwayTx
tx ConwayTx -> Getting Coin ConwayTx Coin -> Coin
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx ConwayEra -> Const Coin (TxBody TopTx ConwayEra))
-> ConwayTx -> Const Coin ConwayTx
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 Coin (TxBody TopTx ConwayEra))
 -> ConwayTx -> Const Coin ConwayTx)
-> ((Coin -> Const Coin Coin)
    -> TxBody TopTx ConwayEra -> Const Coin (TxBody TopTx ConwayEra))
-> Getting Coin ConwayTx Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const Coin Coin)
-> TxBody TopTx ConwayEra -> Const Coin (TxBody TopTx ConwayEra)
forall era. EraTxBody era => Lens' (TxBody TopTx era) Coin
Lens' (TxBody TopTx ConwayEra) Coin
feeTxBodyL
        percent :: Integer
percent = Word16 -> Integer
forall a. Integral a => a -> Integer
toInteger (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)
        required :: Integer
required = (Integer
fee Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
percent 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
        back :: Integer
back = Integer
backing Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
required
    in  if Set TxIn -> Bool
forall a. Set a -> Bool
Set.null Set TxIn
collateral Bool -> Bool -> Bool
|| Integer
backing Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
required
            then ConwayTx
tx
            else
                ConwayTx
tx
                    ConwayTx -> (ConwayTx -> ConwayTx) -> ConwayTx
forall a b. a -> (a -> b) -> b
& (TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> ConwayTx -> Identity ConwayTx
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))
 -> ConwayTx -> Identity ConwayTx)
-> ((StrictMaybe Coin -> Identity (StrictMaybe Coin))
    -> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> (StrictMaybe Coin -> Identity (StrictMaybe Coin))
-> ConwayTx
-> Identity ConwayTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe Coin -> Identity (StrictMaybe Coin))
-> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra)
forall era.
BabbageEraTxBody era =>
Lens' (TxBody TopTx era) (StrictMaybe Coin)
Lens' (TxBody TopTx ConwayEra) (StrictMaybe Coin)
totalCollateralTxBodyL ((StrictMaybe Coin -> Identity (StrictMaybe Coin))
 -> ConwayTx -> Identity ConwayTx)
-> StrictMaybe Coin -> ConwayTx -> ConwayTx
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin -> StrictMaybe Coin
forall a. a -> StrictMaybe a
SJust (Integer -> Coin
Coin Integer
required)
                    ConwayTx -> (ConwayTx -> ConwayTx) -> ConwayTx
forall a b. a -> (a -> b) -> b
& (TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> ConwayTx -> Identity ConwayTx
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))
 -> ConwayTx -> Identity ConwayTx)
-> ((StrictMaybe (BabbageTxOut ConwayEra)
     -> Identity (StrictMaybe (BabbageTxOut ConwayEra)))
    -> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> (StrictMaybe (BabbageTxOut ConwayEra)
    -> Identity (StrictMaybe (BabbageTxOut ConwayEra)))
-> ConwayTx
-> Identity ConwayTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe (TxOut ConwayEra)
 -> Identity (StrictMaybe (TxOut ConwayEra)))
-> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra)
(StrictMaybe (BabbageTxOut ConwayEra)
 -> Identity (StrictMaybe (BabbageTxOut ConwayEra)))
-> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra)
forall era.
BabbageEraTxBody era =>
Lens' (TxBody TopTx era) (StrictMaybe (TxOut era))
Lens' (TxBody TopTx ConwayEra) (StrictMaybe (TxOut ConwayEra))
collateralReturnTxBodyL
                        ((StrictMaybe (BabbageTxOut ConwayEra)
  -> Identity (StrictMaybe (BabbageTxOut ConwayEra)))
 -> ConwayTx -> Identity ConwayTx)
-> StrictMaybe (BabbageTxOut ConwayEra) -> ConwayTx -> ConwayTx
forall s t a b. ASetter s t a b -> b -> s -> t
.~ BabbageTxOut ConwayEra -> StrictMaybe (BabbageTxOut ConwayEra)
forall a. a -> StrictMaybe a
SJust (Addr -> Value ConwayEra -> TxOut ConwayEra
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
changeAddr (Coin -> MaryValue
forall t s. Inject t s => t -> s
inject (Integer -> Coin
Coin Integer
back)))