{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}

{- |
Module      : Singular.Registry.TxBuilder.Edges
Description : Booking and folding one registry-mode tree edge
License     : Apache-2.0

M1 admits insertActive and updateTerminal (#157 seven-admitted-edges), and every
processed edge rides on an approval the naming application's
mint arm certified (#157 tree-edge-admission-by-approval, approval-asset-binding). A caller that wants a fold to
land therefore needs three things this module supplies: the four policy
pins derived from the naming partition's own compiled code, a booking
transaction that carries each edge's certification — which edges get
an approval, what it is, and nothing at all for a read — and the duties
context the fold discharges its obligations from.

The state validator alone is fifteen kilobytes, so a fold that attaches
it, the request validator and a token policy does not fit in a
transaction. 'publishCageRefs' publishes them once as reference outputs
and every purpose resolves through those instead.

Every consumer of the application — the conformance rows, the devnet end-to-end
and the bounded journey — derives its pins and books its edges the same
way, so all three move together.
-}
module Singular.Registry.TxBuilder.Edges
    ( -- * Submission
      SubmitSigned

      -- * Derived identity
    , registryIdOf
    , witnessScriptOf
    , namingPins

      -- * Reference outputs
    , publishRefScript
    , publishRefScriptReserving
    , publishRefScriptTx
    , PublicationFundingError (..)
    , selectPublicationInputs
    , firstPublicationChange
    , publicationFee
    , publicationMinChange
    , publicationRefCoin
    , publishStateRef
    , publishStateRefReserving
    , stateRefIn
    , publishCageRefs
    , adaOnlyOut
    , selectFunding

      -- * Booking one edge
    , BookingApproval (..)
    , bookingApproval
    , certifyBooking
    , bookEdge
    , bookEdgeTo
    , bookEdgeWith
    , bookEdgeTx
    , bookEdgeMeasured
    , edgeDeposit
    , edgeDestinationOf
    , edgeRecordDatum

      -- * Folding
    , registryContextFor
    ) where

import Control.Monad (unless, when)
import Data.ByteString (ByteString)
import Data.ByteString.Short qualified as SBS
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 (..), serialiseAddr)
import Cardano.Ledger.Alonzo.Scripts (AsIx (..))
import Cardano.Ledger.Api.PParams (ppCoinsPerUTxOByteL, ppMaxTxSizeL)
import Cardano.Ledger.Api.Tx (bodyTxL, mkBasicTx, txIdTx, witsTxL)
import Cardano.Ledger.Api.Tx.Body
    ( collateralInputsTxBodyL
    , collateralReturnTxBodyL
    , feeTxBodyL
    , inputsTxBodyL
    , mintTxBodyL
    , mkBasicTxBody
    , outputsTxBodyL
    , referenceInputsTxBodyL
    , reqSignerHashesTxBodyL
    , scriptIntegrityHashTxBodyL
    )
import Cardano.Ledger.Api.Tx.Out
    ( TxOut
    , coinTxOutL
    , datumTxOutL
    , getMinCoinTxOut
    , mkBasicTxOut
    , referenceScriptTxOutL
    , valueTxOutL
    )
import Cardano.Ledger.Api.Tx.Wits
    ( Redeemers (..)
    , rdmrsTxWitsL
    , scriptTxWitsL
    )
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.Core (PParams, Script, hashScript)
import Cardano.Ledger.Credential
    ( Credential (..)
    , StakeReference (..)
    )
import Cardano.Ledger.Mary.Value
    ( AssetName (..)
    , MaryValue (..)
    , MultiAsset (..)
    , PolicyID (..)
    )
import Cardano.Ledger.TxIn (TxIn (..))
import Cardano.Tx.Ledger (ConwayTx)
import PlutusCore.Data qualified as PLC

import Singular.Registry.AssetName (deriveAssetName)
import Singular.Registry.Blueprint.Load (NamingCodes (..))
import Singular.Registry.Blueprint.Params
    ( applyBytesParam
    , applyDataParam
    )
import Singular.Registry.Config (CageConfig (..))
import Singular.Registry.Evidence qualified as Cage
import Singular.Registry.Ledger (Coin (..), ConwayEra, TokenId)
import Singular.Registry.LedgerProvider qualified as Cage
import Singular.Registry.SessionIO qualified as Cage
import Singular.Registry.Trace
    ( BodyBuild (..)
    , BodyEnd (..)
    , ReadEvent (..)
    , timedTrace
    )
import Singular.Registry.TxBuilder.ConnectedFold
    ( RawRedeemer (..)
    , generousUnits
    )
import Singular.Registry.TxBuilder.Internal.Edges
    ( approvalDestination
    , approvalName
    )
import Singular.Registry.TxBuilder.Internal.Identity
    ( addrKeyHashBytes
    , addrWitnessKeyHash
    , cageAddrFromCfg
    , computeScriptHash
    , mkCageScript
    , mkInlineDatum
    , mkRequestDatumWith
    , mkRequestScript
    , requestAddrFromCfg
    , scriptFromBytes
    , scriptHashBytes
    , toLedgerData
    )
import Singular.Registry.TxBuilder.Internal.Lookup
    ( computeScriptIntegrity
    , currentPosixMs
    , evaluateAndBalanceReferencing
    )
import Singular.Registry.TxBuilder.Update
    ( RegistryContext (..)
    , emptyRegistryContext
    )
import Singular.Registry.Types
    ( Edge
    , edgeInsertActive
    , edgeUpdateTerminal
    )

{- | Sign a built transaction with the payer's key, submit it, and wait
for it. The caller owns its own signing key and its own confirmation
discipline, so it supplies this rather than the module guessing either.
-}
type SubmitSigned = ConwayTx -> IO ConwayTx

{- | The registry id a witness policy is parameterized by: the state
policy plus the token name this cage's seed determined.
-}
registryIdOf :: CageConfig -> ByteString
registryIdOf :: CageConfig -> ByteString
registryIdOf CageConfig
cfg =
    ScriptHash -> ByteString
scriptHashBytes (CageConfig -> ScriptHash
cfgScriptHash CageConfig
cfg) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> OnChainTxOutRef -> ByteString
deriveAssetName (CageConfig -> OnChainTxOutRef
cageSeed CageConfig
cfg)

-- | The witness policy script of one token kind.
witnessScriptOf
    :: CageConfig -> NamingCodes -> Integer -> Script ConwayEra
witnessScriptOf :: CageConfig -> NamingCodes -> Integer -> Script ConwayEra
witnessScriptOf CageConfig
cfg NamingCodes
codes Integer
kind =
    [Char] -> ShortByteString -> Script ConwayEra
scriptFromBytes
        ([Char]
"witness-" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
kind)
        ( ByteString -> ShortByteString -> ShortByteString
applyBytesParam
            (CageConfig -> ByteString
registryIdOf CageConfig
cfg)
            (Data -> ShortByteString -> ShortByteString
applyDataParam (Integer -> Data
PLC.I Integer
kind) (NamingCodes -> ShortByteString
ncWitness NamingCodes
codes))
        )

{- | The four pins a registry identity carries (#157 genesis-policy-pins), derived
from the naming partition's own compiled code: the application validator
for the approval, and @witness(kind, registry)@ at kinds 0, 1 and 2.

The registry id the witness policies are parameterized by depends on the
state script hash and the boot seed, so this takes them directly rather
than a configuration that does not exist yet.
-}
namingPins
    :: NamingCodes
    -> ByteString
    -- ^ The registry id: state script hash then boot token name
    -> ( SBS.ShortByteString
       , SBS.ShortByteString
       , SBS.ShortByteString
       , SBS.ShortByteString
       )
    -- ^ Application, absent, active, terminal
namingPins :: NamingCodes
-> ByteString
-> (ShortByteString, ShortByteString, ShortByteString,
    ShortByteString)
namingPins NamingCodes
codes ByteString
registryId =
    ( ShortByteString -> ShortByteString
pinOf (NamingCodes -> ShortByteString
ncApplication NamingCodes
codes)
    , Integer -> ShortByteString
witnessPin Integer
0
    , Integer -> ShortByteString
witnessPin Integer
1
    , Integer -> ShortByteString
witnessPin Integer
2
    )
  where
    pinOf :: ShortByteString -> ShortByteString
pinOf = ByteString -> ShortByteString
SBS.toShort (ByteString -> ShortByteString)
-> (ShortByteString -> ByteString)
-> ShortByteString
-> ShortByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptHash -> ByteString
scriptHashBytes (ScriptHash -> ByteString)
-> (ShortByteString -> ScriptHash) -> ShortByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShortByteString -> ScriptHash
computeScriptHash
    witnessPin :: Integer -> ShortByteString
witnessPin Integer
kind =
        ShortByteString -> ShortByteString
pinOf
            ( ByteString -> ShortByteString -> ShortByteString
applyBytesParam
                ByteString
registryId
                (Data -> ShortByteString -> ShortByteString
applyDataParam (Integer -> Data
PLC.I Integer
kind) (NamingCodes -> ShortByteString
ncWitness NamingCodes
codes))
            )

{- | Can this output fund a transaction? It must hold ada and nothing
else, because it doubles as collateral, and it must not be one of the
published reference outputs, because a transaction may not both spend an
output and reference it.
-}
adaOnlyOut :: TxOut ConwayEra -> Bool
adaOnlyOut :: TxOut ConwayEra -> Bool
adaOnlyOut TxOut ConwayEra
out =
    (case TxOut ConwayEra
BabbageTxOut ConwayEra
out BabbageTxOut ConwayEra
-> Getting MaryValue (BabbageTxOut ConwayEra) MaryValue
-> MaryValue
forall s a. s -> Getting a s a -> a
^. Getting MaryValue (BabbageTxOut 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)
        Bool -> Bool -> Bool
&& ( case TxOut ConwayEra
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
                StrictMaybe (Script ConwayEra)
SNothing -> Bool
True
                SJust Script ConwayEra
_ -> Bool
False
           )

{- | The wallet output a transaction is funded and collateralised from: the
one the caller chose, which must be an ada-only output of the wallet, or else
the largest ada-only output. A caller that chose none still gets the output
least likely to leave the change under its minimum.
-}
selectFunding
    :: Maybe TxIn
    -> [(TxIn, TxOut ConwayEra)]
    -> Either String (TxIn, TxOut ConwayEra)
selectFunding :: Maybe TxIn
-> [(TxIn, TxOut ConwayEra)]
-> Either [Char] (TxIn, TxOut ConwayEra)
selectFunding Maybe TxIn
chosen [(TxIn, TxOut ConwayEra)]
utxos = case Maybe TxIn
chosen of
    Maybe TxIn
Nothing -> case ((TxIn, BabbageTxOut ConwayEra) -> Down Coin)
-> [(TxIn, BabbageTxOut ConwayEra)]
-> [(TxIn, BabbageTxOut ConwayEra)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Coin -> Down Coin
forall a. a -> Down a
Down (Coin -> Down Coin)
-> ((TxIn, BabbageTxOut ConwayEra) -> Coin)
-> (TxIn, BabbageTxOut ConwayEra)
-> Down Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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) (BabbageTxOut ConwayEra -> Coin)
-> ((TxIn, BabbageTxOut ConwayEra) -> BabbageTxOut ConwayEra)
-> (TxIn, BabbageTxOut ConwayEra)
-> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxIn, BabbageTxOut ConwayEra) -> BabbageTxOut ConwayEra
forall a b. (a, b) -> b
snd) [(TxIn, BabbageTxOut ConwayEra)]
usable of
        [] -> [Char] -> Either [Char] (TxIn, BabbageTxOut ConwayEra)
forall a b. a -> Either a b
Left [Char]
"the payer wallet has no ada-only output"
        ((TxIn, BabbageTxOut ConwayEra)
u : [(TxIn, BabbageTxOut ConwayEra)]
_) -> (TxIn, BabbageTxOut ConwayEra)
-> Either [Char] (TxIn, BabbageTxOut ConwayEra)
forall a b. b -> Either a b
Right (TxIn, BabbageTxOut ConwayEra)
u
    Just TxIn
wanted -> case [(TxIn, BabbageTxOut ConwayEra)
u | u :: (TxIn, BabbageTxOut ConwayEra)
u@(TxIn
i, BabbageTxOut ConwayEra
_) <- [(TxIn, BabbageTxOut ConwayEra)]
usable, TxIn
i TxIn -> TxIn -> Bool
forall a. Eq a => a -> a -> Bool
== TxIn
wanted] of
        ((TxIn, BabbageTxOut ConwayEra)
u : [(TxIn, BabbageTxOut ConwayEra)]
_) -> (TxIn, BabbageTxOut ConwayEra)
-> Either [Char] (TxIn, BabbageTxOut ConwayEra)
forall a b. b -> Either a b
Right (TxIn, BabbageTxOut ConwayEra)
u
        [] ->
            [Char] -> Either [Char] (TxIn, BabbageTxOut ConwayEra)
forall a b. a -> Either a b
Left
                [Char]
"the chosen funding output is not an ada-only output of the payer"
  where
    usable :: [(TxIn, BabbageTxOut ConwayEra)]
usable = ((TxIn, BabbageTxOut ConwayEra) -> Bool)
-> [(TxIn, BabbageTxOut ConwayEra)]
-> [(TxIn, BabbageTxOut ConwayEra)]
forall a. (a -> Bool) -> [a] -> [a]
filter (TxOut ConwayEra -> Bool
BabbageTxOut ConwayEra -> Bool
adaOnlyOut (BabbageTxOut ConwayEra -> Bool)
-> ((TxIn, BabbageTxOut ConwayEra) -> BabbageTxOut ConwayEra)
-> (TxIn, BabbageTxOut ConwayEra)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxIn, BabbageTxOut ConwayEra) -> BabbageTxOut ConwayEra
forall a b. (a, b) -> b
snd) [(TxIn, TxOut ConwayEra)]
[(TxIn, BabbageTxOut ConwayEra)]
utxos

{- | The flat fee a publication pays, and the change it must leave strictly
above. One owner (#406): the builder and the whole-run judgement share
these with the pure selection below, never a second copy.
-}
publicationFee :: Integer
publicationFee :: Integer
publicationFee = Integer
1_000_000

publicationMinChange :: Integer
publicationMinChange :: Integer
publicationMinChange = Integer
1_000_000

{- | The reference output a publication creates at the payer's address:
the ledger minimum for the script plus one million lovelace. One owner:
both the selection and the whole-run need share it.
-}
publicationRefCoin
    :: PParams ConwayEra -> Addr -> Script ConwayEra -> Integer
publicationRefCoin :: PParams ConwayEra -> Addr -> Script ConwayEra -> Integer
publicationRefCoin PParams ConwayEra
pp Addr
payerAddr Script ConwayEra
script =
    let probe :: TxOut ConwayEra
probe =
            Addr -> Value ConwayEra -> TxOut ConwayEra
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
payerAddr (Coin -> MultiAsset -> MaryValue
MaryValue (Integer -> Coin
Coin Integer
0) MultiAsset
forall a. Monoid a => a
mempty)
                TxOut ConwayEra
-> (TxOut ConwayEra -> TxOut ConwayEra) -> TxOut ConwayEra
forall a b. a -> (a -> b) -> b
& (StrictMaybe (Script ConwayEra)
 -> Identity (StrictMaybe (Script ConwayEra)))
-> TxOut ConwayEra -> Identity (TxOut ConwayEra)
forall era.
BabbageEraTxOut era =>
Lens' (TxOut era) (StrictMaybe (Script era))
Lens' (TxOut ConwayEra) (StrictMaybe (Script ConwayEra))
referenceScriptTxOutL ((StrictMaybe (Script ConwayEra)
  -> Identity (StrictMaybe (Script ConwayEra)))
 -> TxOut ConwayEra -> Identity (TxOut ConwayEra))
-> StrictMaybe (Script ConwayEra)
-> TxOut ConwayEra
-> TxOut ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Script ConwayEra -> StrictMaybe (Script ConwayEra)
forall a. a -> StrictMaybe a
SJust Script ConwayEra
script
        Coin Integer
minCoin = PParams ConwayEra -> TxOut ConwayEra -> Coin
forall era. EraTxOut era => PParams era -> TxOut era -> Coin
getMinCoinTxOut PParams ConwayEra
pp TxOut ConwayEra
BabbageTxOut ConwayEra
probe
    in  Integer
minCoin Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1_000_000

{- | Why one publication cannot be funded: too little in total, or a
covering prefix too large for the protocol maximum transaction size.
-}
data PublicationFundingError
    = PublicationShortfall
        { PublicationFundingError -> Integer
pfeNeeded :: Integer
        , PublicationFundingError -> Integer
pfeHeld :: Integer
        , PublicationFundingError -> Integer
pfeLargest :: Integer
        }
    | PublicationOversize
        { PublicationFundingError -> Integer
pfeSize :: Integer
        , PublicationFundingError -> Integer
pfeLimit :: Integer
        }
    deriving stock (PublicationFundingError -> PublicationFundingError -> Bool
(PublicationFundingError -> PublicationFundingError -> Bool)
-> (PublicationFundingError -> PublicationFundingError -> Bool)
-> Eq PublicationFundingError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PublicationFundingError -> PublicationFundingError -> Bool
== :: PublicationFundingError -> PublicationFundingError -> Bool
$c/= :: PublicationFundingError -> PublicationFundingError -> Bool
/= :: PublicationFundingError -> PublicationFundingError -> Bool
Eq, Int -> PublicationFundingError -> [Char] -> [Char]
[PublicationFundingError] -> [Char] -> [Char]
PublicationFundingError -> [Char]
(Int -> PublicationFundingError -> [Char] -> [Char])
-> (PublicationFundingError -> [Char])
-> ([PublicationFundingError] -> [Char] -> [Char])
-> Show PublicationFundingError
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> PublicationFundingError -> [Char] -> [Char]
showsPrec :: Int -> PublicationFundingError -> [Char] -> [Char]
$cshow :: PublicationFundingError -> [Char]
show :: PublicationFundingError -> [Char]
$cshowList :: [PublicationFundingError] -> [Char] -> [Char]
showList :: [PublicationFundingError] -> [Char] -> [Char]
Show)

{- | One owner of the publication arithmetic (#406): the shortest
largest-first prefix of the permitted outputs whose total covers the
reference output plus the fee plus a change strictly above the minimum,
with the inputs, the reference output and the change; or the shortfall
it names (needed total, held total, largest output). A covering prefix
whose transaction would exceed the protocol maximum size is refused up
front, naming size and limit, so a wallet of many dust outputs never
reaches submission.

The permitted outputs are ada-only with no reference script, the seed
withheld before the boot. A covering output spends exactly one input
and it is the largest; otherwise no output that is not needed is spent.
-}
selectPublicationInputs
    :: PParams ConwayEra
    -> Addr
    -> Script ConwayEra
    -> [(k, TxOut ConwayEra)]
    -> Either
        PublicationFundingError
        ([(k, TxOut ConwayEra)], TxOut ConwayEra, Integer)
selectPublicationInputs :: forall k.
PParams ConwayEra
-> Addr
-> Script ConwayEra
-> [(k, TxOut ConwayEra)]
-> Either
     PublicationFundingError
     ([(k, TxOut ConwayEra)], TxOut ConwayEra, Integer)
selectPublicationInputs PParams ConwayEra
pp Addr
payerAddr Script ConwayEra
script [(k, TxOut ConwayEra)]
permitted = do
    let ordered :: [(k, TxOut ConwayEra)]
ordered = ((k, TxOut ConwayEra) -> Down Coin)
-> [(k, TxOut ConwayEra)] -> [(k, TxOut ConwayEra)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Coin -> Down Coin
forall a. a -> Down a
Down (Coin -> Down Coin)
-> ((k, TxOut ConwayEra) -> Coin)
-> (k, 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)
-> ((k, TxOut ConwayEra) -> TxOut ConwayEra)
-> (k, TxOut ConwayEra)
-> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (k, TxOut ConwayEra) -> TxOut ConwayEra
forall a b. (a, b) -> b
snd) [(k, TxOut ConwayEra)]
permitted
        coins :: [Integer]
coins = [Integer
c | (k
_, BabbageTxOut ConwayEra
o) <- [(k, BabbageTxOut ConwayEra)]
ordered, 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]
        held :: Integer
held = [Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Integer]
coins
        largest :: Integer
largest = case [Integer]
coins of
            [] -> Integer
0
            (Integer
c : [Integer]
_) -> Integer
c
        refCoin :: Integer
refCoin = PParams ConwayEra -> Addr -> Script ConwayEra -> Integer
publicationRefCoin PParams ConwayEra
pp Addr
payerAddr Script ConwayEra
script
        needed :: Integer
needed = Integer
refCoin Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
publicationFee Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
publicationMinChange
        refOut :: TxOut ConwayEra
refOut =
            Addr -> Value ConwayEra -> TxOut ConwayEra
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
payerAddr (Coin -> MultiAsset -> MaryValue
MaryValue (Integer -> Coin
Coin Integer
refCoin) MultiAsset
forall a. Monoid a => a
mempty)
                TxOut ConwayEra
-> (TxOut ConwayEra -> TxOut ConwayEra) -> TxOut ConwayEra
forall a b. a -> (a -> b) -> b
& (StrictMaybe (Script ConwayEra)
 -> Identity (StrictMaybe (Script ConwayEra)))
-> TxOut ConwayEra -> Identity (TxOut ConwayEra)
forall era.
BabbageEraTxOut era =>
Lens' (TxOut era) (StrictMaybe (Script era))
Lens' (TxOut ConwayEra) (StrictMaybe (Script ConwayEra))
referenceScriptTxOutL ((StrictMaybe (Script ConwayEra)
  -> Identity (StrictMaybe (Script ConwayEra)))
 -> TxOut ConwayEra -> Identity (TxOut ConwayEra))
-> StrictMaybe (Script ConwayEra)
-> TxOut ConwayEra
-> TxOut ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Script ConwayEra -> StrictMaybe (Script ConwayEra)
forall a. a -> StrictMaybe a
SJust Script ConwayEra
script
        covering :: Maybe [(k, TxOut ConwayEra)]
covering = Integer
-> [(k, TxOut ConwayEra)]
-> Integer
-> Maybe [(k, TxOut ConwayEra)]
forall {era} {a}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTxOut era) =>
Integer -> [(a, TxOut era)] -> Integer -> Maybe [(a, TxOut era)]
takeCovering Integer
needed [(k, TxOut ConwayEra)]
[(k, BabbageTxOut ConwayEra)]
ordered Integer
0
    prefix <- case Maybe [(k, BabbageTxOut ConwayEra)]
covering of
        Maybe [(k, BabbageTxOut ConwayEra)]
Nothing -> PublicationFundingError
-> Either PublicationFundingError [(k, BabbageTxOut ConwayEra)]
forall a b. a -> Either a b
Left (Integer -> Integer -> Integer -> PublicationFundingError
PublicationShortfall Integer
needed Integer
held Integer
largest)
        Just [(k, BabbageTxOut ConwayEra)]
chosen -> [(k, BabbageTxOut ConwayEra)]
-> Either PublicationFundingError [(k, BabbageTxOut ConwayEra)]
forall a. a -> Either PublicationFundingError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(k, BabbageTxOut ConwayEra)]
chosen
    let total = [Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Integer
c | (k
_, BabbageTxOut ConwayEra
o) <- [(k, BabbageTxOut ConwayEra)]
prefix, 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]
        change = Integer
total Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
publicationFee Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
refCoin
        CoinPerByte compactPerByte = pp ^. ppCoinsPerUTxOByteL
        Coin perByte = fromCompact compactPerByte
        limit = 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)
        size =
            if Integer
perByte Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0
                then Integer
0
                else (Integer
refCoin Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
perByte) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([(k, BabbageTxOut ConwayEra)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(k, BabbageTxOut ConwayEra)]
prefix) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
40 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
300
    if limit > 0 && size > limit
        then Left (PublicationOversize size limit)
        else pure (prefix, refOut, change)
  where
    takeCovering :: Integer -> [(a, TxOut era)] -> Integer -> Maybe [(a, TxOut era)]
takeCovering Integer
_ [] Integer
_ = Maybe [(a, TxOut era)]
forall a. Maybe a
Nothing
    takeCovering Integer
need ((a
k, TxOut era
o) : [(a, TxOut era)]
rest) Integer
acc =
        let Coin Integer
c = TxOut era
o TxOut era -> Getting Coin (TxOut era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (TxOut era) Coin
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut era) Coin
coinTxOutL
            acc' :: Integer
acc' = Integer
acc Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
c
        in  if Integer
acc' Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
need
                then [(a, TxOut era)] -> Maybe [(a, TxOut era)]
forall a. a -> Maybe a
Just [(a
k, TxOut era
o)]
                else case Integer -> [(a, TxOut era)] -> Integer -> Maybe [(a, TxOut era)]
takeCovering Integer
need [(a, TxOut era)]
rest Integer
acc' of
                    Maybe [(a, TxOut era)]
Nothing -> Maybe [(a, TxOut era)]
forall a. Maybe a
Nothing
                    Just [(a, TxOut era)]
chosen -> [(a, TxOut era)] -> Maybe [(a, TxOut era)]
forall a. a -> Maybe a
Just ((a
k, TxOut era
o) (a, TxOut era) -> [(a, TxOut era)] -> [(a, TxOut era)]
forall a. a -> [a] -> [a]
: [(a, TxOut era)]
chosen)

{- | The change output a first publication makes from the whole wallet, and
the seed it becomes (#406 slice 2): the shortest largest-first prefix of
all the ada-only outputs (nothing withheld) funds the state publication,
its change at index 1 is the chained seed. The body is exactly the one
'publishRefScriptTx' builds from the same view (flat fee, no validity
interval), so the transaction id — and the token it derives — is the same
in preview and in create. The arithmetic is 'selectPublicationInputs''s;
this accessor adds only the body and its id.
-}
firstPublicationChange
    :: PParams ConwayEra
    -> Addr
    -> Script ConwayEra
    -> [(TxIn, TxOut ConwayEra)]
    -> Either
        PublicationFundingError
        (TxIn, ConwayTx, TxOut ConwayEra, [(TxIn, TxOut ConwayEra)], Integer)
firstPublicationChange :: PParams ConwayEra
-> Addr
-> Script ConwayEra
-> [(TxIn, TxOut ConwayEra)]
-> Either
     PublicationFundingError
     (TxIn, ConwayTx, TxOut ConwayEra, [(TxIn, TxOut ConwayEra)],
      Integer)
firstPublicationChange PParams ConwayEra
pp Addr
payerAddr Script ConwayEra
script [(TxIn, TxOut ConwayEra)]
wallet = do
    let permitted :: [(TxIn, BabbageTxOut ConwayEra)]
permitted = [(TxIn, BabbageTxOut ConwayEra)
u | u :: (TxIn, BabbageTxOut ConwayEra)
u@(TxIn
_, BabbageTxOut ConwayEra
o) <- [(TxIn, TxOut ConwayEra)]
[(TxIn, BabbageTxOut ConwayEra)]
wallet, TxOut ConwayEra -> Bool
adaOnlyOut TxOut ConwayEra
BabbageTxOut ConwayEra
o]
    (funds, refOut, changeCoin) <-
        PParams ConwayEra
-> Addr
-> Script ConwayEra
-> [(TxIn, TxOut ConwayEra)]
-> Either
     PublicationFundingError
     ([(TxIn, TxOut ConwayEra)], TxOut ConwayEra, Integer)
forall k.
PParams ConwayEra
-> Addr
-> Script ConwayEra
-> [(k, TxOut ConwayEra)]
-> Either
     PublicationFundingError
     ([(k, TxOut ConwayEra)], TxOut ConwayEra, Integer)
selectPublicationInputs PParams ConwayEra
pp Addr
payerAddr Script ConwayEra
script [(TxIn, TxOut ConwayEra)]
[(TxIn, BabbageTxOut ConwayEra)]
permitted
    let changeOut = Addr -> Value ConwayEra -> TxOut ConwayEra
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
payerAddr (Coin -> MultiAsset -> MaryValue
MaryValue (Integer -> Coin
Coin Integer
changeCoin) MultiAsset
forall a. Monoid a => a
mempty)
        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. 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, BabbageTxOut ConwayEra)]
funds)
                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
refOut, TxOut ConwayEra
changeOut]
                TxBody TopTx ConwayEra
-> (TxBody TopTx ConwayEra -> TxBody TopTx ConwayEra)
-> TxBody TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (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)
 -> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> Coin -> TxBody TopTx ConwayEra -> TxBody TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
publicationFee
        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
        seed = TxId -> TxIx -> TxIn
TxIn (ConwayTx -> TxId
forall era (l :: TxLevel). EraTx era => Tx l era -> TxId
txIdTx ConwayTx
tx) (Word16 -> TxIx
TxIx Word16
1)
    pure (seed, tx, refOut, funds, changeCoin)

-- | Publish one script as a reference output at the payer's own address.
publishRefScript
    :: (Cage.Network, Cage.LedgerProvider Cage.NoWitness IO)
    -> SubmitSigned
    -> Addr
    -> Script ConwayEra
    -> IO (TxIn, TxOut ConwayEra)
publishRefScript :: (Network, LedgerProvider NoWitness IO)
-> SubmitSigned
-> Addr
-> Script ConwayEra
-> IO (TxIn, TxOut ConwayEra)
publishRefScript = Set TxIn
-> (Network, LedgerProvider NoWitness IO)
-> SubmitSigned
-> Addr
-> Script ConwayEra
-> IO (TxIn, TxOut ConwayEra)
publishRefScriptReserving Set TxIn
forall a. Set a
Set.empty

{- | 'publishRefScript', never spending a reserved output (#299): a caller
that has chosen the seed of a later boot keeps it unspent while it
publishes. The largest ada-only output that is not reserved funds it.
-}
publishRefScriptReserving
    :: Set.Set TxIn
    -> (Cage.Network, Cage.LedgerProvider Cage.NoWitness IO)
    -> SubmitSigned
    -> Addr
    -> Script ConwayEra
    -> IO (TxIn, TxOut ConwayEra)
publishRefScriptReserving :: Set TxIn
-> (Network, LedgerProvider NoWitness IO)
-> SubmitSigned
-> Addr
-> Script ConwayEra
-> IO (TxIn, TxOut ConwayEra)
publishRefScriptReserving Set TxIn
reserved (Network, LedgerProvider NoWitness IO)
prov SubmitSigned
submit Addr
payerAddr Script ConwayEra
script = do
    (unsigned, refOut) <-
        (Network, LedgerProvider NoWitness IO)
-> (Session NoWitness IO -> IO (ConwayTx, BabbageTxOut ConwayEra))
-> IO (ConwayTx, BabbageTxOut ConwayEra)
forall w a.
(Network, LedgerProvider w IO) -> (Session w IO -> IO a) -> IO a
Cage.withLatest (Network, LedgerProvider NoWitness IO)
prov ((Session NoWitness IO -> IO (ConwayTx, BabbageTxOut ConwayEra))
 -> IO (ConwayTx, BabbageTxOut ConwayEra))
-> (Session NoWitness IO -> IO (ConwayTx, BabbageTxOut ConwayEra))
-> IO (ConwayTx, BabbageTxOut ConwayEra)
forall a b. (a -> b) -> a -> b
$ \Session NoWitness IO
v -> Set TxIn
-> Session NoWitness IO
-> Addr
-> Script ConwayEra
-> IO (ConwayTx, TxOut ConwayEra)
publishRefScriptTx Set TxIn
reserved Session NoWitness IO
v Addr
payerAddr Script ConwayEra
script
    signed <- submit unsigned
    pure (TxIn (txIdTx signed) (TxIx 0), refOut)

{- | The unsigned publication of one reference script, funded by the
shortest largest-first prefix of the ada-only outputs outside the
reservation, and the reference output it creates.
-}
publishRefScriptTx
    :: Set.Set TxIn
    -> Cage.Session Cage.NoWitness IO
    -> Addr
    -> Script ConwayEra
    -> IO (ConwayTx, TxOut ConwayEra)
publishRefScriptTx :: Set TxIn
-> Session NoWitness IO
-> Addr
-> Script ConwayEra
-> IO (ConwayTx, TxOut ConwayEra)
publishRefScriptTx Set TxIn
reserved Session NoWitness IO
v Addr
payerAddr Script ConwayEra
script = do
    pp <- Session NoWitness IO -> IO (PParams ConwayEra)
forall w. Session w IO -> IO (PParams ConwayEra)
Cage.parameters Session NoWitness IO
v
    utxos <- Cage.outputsAt v payerAddr
    let permitted =
            ((TxIn, BabbageTxOut ConwayEra) -> Bool)
-> [(TxIn, BabbageTxOut ConwayEra)]
-> [(TxIn, BabbageTxOut ConwayEra)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(TxIn
i, BabbageTxOut ConwayEra
o) -> TxOut ConwayEra -> Bool
adaOnlyOut TxOut ConwayEra
BabbageTxOut ConwayEra
o Bool -> Bool -> Bool
&& TxIn -> Set TxIn -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember TxIn
i Set TxIn
reserved) [(TxIn, BabbageTxOut ConwayEra)]
utxos
    (funds, refOut, changeCoin) <- case selectPublicationInputs pp payerAddr script permitted of
        Left (PublicationShortfall Integer
needed Integer
held Integer
largest) ->
            if [(TxIn, BabbageTxOut ConwayEra)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(TxIn, BabbageTxOut ConwayEra)]
permitted
                then [Char]
-> IO
     ([(TxIn, BabbageTxOut ConwayEra)], BabbageTxOut ConwayEra, Integer)
forall a. HasCallStack => [Char] -> a
error [Char]
"publishRefScript: the payer wallet has no ada-only output"
                else
                    [Char]
-> IO
     ([(TxIn, BabbageTxOut ConwayEra)], BabbageTxOut ConwayEra, Integer)
forall a. HasCallStack => [Char] -> a
error
                        ( [Char]
"publishRefScript: the funding outputs hold "
                            [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
held
                            [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
", which does not cover a reference output of "
                            [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Integer -> [Char]
forall a. Show a => a -> [Char]
show (Integer
needed Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
publicationFee Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
publicationMinChange)
                            [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" plus fees; largest holds "
                            [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
largest
                        )
        Left (PublicationOversize Integer
size Integer
limit) ->
            [Char]
-> IO
     ([(TxIn, BabbageTxOut ConwayEra)], BabbageTxOut ConwayEra, Integer)
forall a. HasCallStack => [Char] -> a
error
                ( [Char]
"publishRefScript: the funding transaction would be "
                    [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
size
                    [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" bytes, over the protocol maximum "
                    [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
limit
                )
        Right ([(TxIn, TxOut ConwayEra)], TxOut ConwayEra, Integer)
chosen -> ([(TxIn, BabbageTxOut ConwayEra)], BabbageTxOut ConwayEra, Integer)
-> IO
     ([(TxIn, BabbageTxOut ConwayEra)], BabbageTxOut ConwayEra, Integer)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(TxIn, TxOut ConwayEra)], TxOut ConwayEra, Integer)
([(TxIn, BabbageTxOut ConwayEra)], BabbageTxOut ConwayEra, Integer)
chosen
    let 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. 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, BabbageTxOut ConwayEra)]
funds)
                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.fromList
                        [ BabbageTxOut ConwayEra
refOut
                        , Addr -> Value ConwayEra -> TxOut ConwayEra
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
payerAddr (Coin -> MultiAsset -> MaryValue
MaryValue (Integer -> Coin
Coin Integer
changeCoin) MultiAsset
forall a. Monoid a => a
mempty)
                        ]
                TxBody TopTx ConwayEra
-> (TxBody TopTx ConwayEra -> TxBody TopTx ConwayEra)
-> TxBody TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (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)
 -> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> Coin -> TxBody TopTx ConwayEra -> TxBody TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
publicationFee
    pure (mkBasicTx body, refOut)

{- | Publish the state validator as a reference output, once, before any
boot (#177).

A registry boots only by reference: the boot resolves the state
validator through a publication in the payer's wallet and is refused
`StateValidatorNotPublished` without one, because that validator is
fifteen kilobytes against a sixteen-kilobyte transaction cap. A session
calls this before its first boot.

Idempotent by discovery: a wallet that already holds the publication
gets it back rather than a second one, so a harness that boots several
cages publishes once.
-}
publishStateRef
    :: CageConfig
    -> (Cage.Network, Cage.LedgerProvider Cage.NoWitness IO)
    -> SubmitSigned
    -> Addr
    -> IO (TxIn, TxOut ConwayEra)
publishStateRef :: CageConfig
-> (Network, LedgerProvider NoWitness IO)
-> SubmitSigned
-> Addr
-> IO (TxIn, TxOut ConwayEra)
publishStateRef = Set TxIn
-> CageConfig
-> (Network, LedgerProvider NoWitness IO)
-> SubmitSigned
-> Addr
-> IO (TxIn, TxOut ConwayEra)
publishStateRefReserving Set TxIn
forall a. Set a
Set.empty

{- | 'publishStateRef', never spending a reserved output (#299): an
existing publication is returned as before, and a new one is funded
outside the reservation.
-}
publishStateRefReserving
    :: Set.Set TxIn
    -> CageConfig
    -> (Cage.Network, Cage.LedgerProvider Cage.NoWitness IO)
    -> SubmitSigned
    -> Addr
    -> IO (TxIn, TxOut ConwayEra)
publishStateRefReserving :: Set TxIn
-> CageConfig
-> (Network, LedgerProvider NoWitness IO)
-> SubmitSigned
-> Addr
-> IO (TxIn, TxOut ConwayEra)
publishStateRefReserving Set TxIn
reserved CageConfig
cfg (Network, LedgerProvider NoWitness IO)
prov SubmitSigned
submit Addr
payerAddr = do
    let script :: Script ConwayEra
script = CageConfig -> Script ConwayEra
mkCageScript CageConfig
cfg
    utxos <- (Network, LedgerProvider NoWitness IO)
-> (Session NoWitness IO -> IO [(TxIn, TxOut ConwayEra)])
-> IO [(TxIn, TxOut ConwayEra)]
forall w a.
(Network, LedgerProvider w IO) -> (Session w IO -> IO a) -> IO a
Cage.withLatest (Network, LedgerProvider NoWitness IO)
prov (Session NoWitness IO -> Addr -> IO [(TxIn, TxOut ConwayEra)]
forall w. Session w IO -> Addr -> IO [(TxIn, TxOut ConwayEra)]
`Cage.outputsAt` Addr
payerAddr)
    case stateRefIn cfg utxos of
        Just (TxIn, TxOut ConwayEra)
u -> (TxIn, BabbageTxOut ConwayEra) -> IO (TxIn, BabbageTxOut ConwayEra)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxIn, TxOut ConwayEra)
(TxIn, BabbageTxOut ConwayEra)
u
        Maybe (TxIn, TxOut ConwayEra)
Nothing -> Set TxIn
-> (Network, LedgerProvider NoWitness IO)
-> SubmitSigned
-> Addr
-> Script ConwayEra
-> IO (TxIn, TxOut ConwayEra)
publishRefScriptReserving Set TxIn
reserved (Network, LedgerProvider NoWitness IO)
prov SubmitSigned
submit Addr
payerAddr AlonzoScript ConwayEra
Script ConwayEra
script

-- | An output among these that publishes this cage's state validator.
stateRefIn
    :: CageConfig
    -> [(TxIn, TxOut ConwayEra)]
    -> Maybe (TxIn, TxOut ConwayEra)
stateRefIn :: CageConfig
-> [(TxIn, TxOut ConwayEra)] -> Maybe (TxIn, TxOut ConwayEra)
stateRefIn CageConfig
cfg [(TxIn, TxOut ConwayEra)]
utxos =
    case [ (TxIn, BabbageTxOut ConwayEra)
u
         | u :: (TxIn, BabbageTxOut ConwayEra)
u@(TxIn
_, BabbageTxOut ConwayEra
out) <- [(TxIn, TxOut ConwayEra)]
[(TxIn, BabbageTxOut ConwayEra)]
utxos
         , SJust Script ConwayEra
s <- [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]
         , Script ConwayEra -> ScriptHash
forall era. EraScript era => Script era -> ScriptHash
hashScript Script ConwayEra
s ScriptHash -> ScriptHash -> Bool
forall a. Eq a => a -> a -> Bool
== Script ConwayEra -> ScriptHash
forall era. EraScript era => Script era -> ScriptHash
hashScript (CageConfig -> Script ConwayEra
mkCageScript CageConfig
cfg)
         ] of
        ((TxIn, BabbageTxOut ConwayEra)
u : [(TxIn, BabbageTxOut ConwayEra)]
_) -> (TxIn, BabbageTxOut ConwayEra)
-> Maybe (TxIn, BabbageTxOut ConwayEra)
forall a. a -> Maybe a
Just (TxIn, BabbageTxOut ConwayEra)
u
        [] -> Maybe (TxIn, TxOut ConwayEra)
Maybe (TxIn, BabbageTxOut ConwayEra)
forall a. Maybe a
Nothing

{- | Publish this cage's scripts as reference outputs: the cage, the
request validator and the three token policies.
-}
publishCageRefs
    :: CageConfig
    -> NamingCodes
    -> (Cage.Network, Cage.LedgerProvider Cage.NoWitness IO)
    -> SubmitSigned
    -> Addr
    -> TokenId
    -> IO [(TxIn, TxOut ConwayEra)]
publishCageRefs :: CageConfig
-> NamingCodes
-> (Network, LedgerProvider NoWitness IO)
-> SubmitSigned
-> Addr
-> TokenId
-> IO [(TxIn, TxOut ConwayEra)]
publishCageRefs CageConfig
cfg NamingCodes
codes (Network, LedgerProvider NoWitness IO)
prov SubmitSigned
submit Addr
payerAddr TokenId
tokenId =
    (AlonzoScript ConwayEra -> IO (TxIn, BabbageTxOut ConwayEra))
-> [AlonzoScript ConwayEra] -> IO [(TxIn, BabbageTxOut ConwayEra)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM
        ((Network, LedgerProvider NoWitness IO)
-> SubmitSigned
-> Addr
-> Script ConwayEra
-> IO (TxIn, TxOut ConwayEra)
publishRefScript (Network, LedgerProvider NoWitness IO)
prov SubmitSigned
submit Addr
payerAddr)
        ( [ CageConfig -> Script ConwayEra
mkCageScript CageConfig
cfg
          , CageConfig -> TokenId -> Script ConwayEra
mkRequestScript CageConfig
cfg TokenId
tokenId
          ]
            [AlonzoScript ConwayEra]
-> [AlonzoScript ConwayEra] -> [AlonzoScript ConwayEra]
forall a. Semigroup a => a -> a -> a
<> (Integer -> AlonzoScript ConwayEra)
-> [Integer] -> [AlonzoScript ConwayEra]
forall a b. (a -> b) -> [a] -> [b]
map (CageConfig -> NamingCodes -> Integer -> Script ConwayEra
witnessScriptOf CageConfig
cfg NamingCodes
codes) [Integer
0, Integer
1, Integer
2]
        )

{- | The record datum a booking's destination carries. The cage checks only
that the receiving output carries the datum the request carries — naming's
own validators do not run at fold time — so one datum is enough.
-}
edgeRecordDatum :: PLC.Data
edgeRecordDatum :: Data
edgeRecordDatum = ByteString -> Data
PLC.B ByteString
"singular-record"

{- | Where an edge delivers (#157 request-destination-binding). An absence names the address
its deposit comes back to and no datum; an activation names the naming
application's own address and carries the record datum the delivered
output will hold.
-}
edgeDestinationOf
    :: CageConfig
    -> NamingCodes
    -> Addr
    -> Edge
    -> (ByteString, Maybe PLC.Data)
edgeDestinationOf :: CageConfig
-> NamingCodes -> Addr -> Integer -> (ByteString, Maybe Data)
edgeDestinationOf CageConfig
cfg NamingCodes
codes Addr
payerAddr Integer
edge =
    let appHash :: ScriptHash
appHash = ShortByteString -> ScriptHash
computeScriptHash (NamingCodes -> ShortByteString
ncApplication NamingCodes
codes)
        appAddr :: Addr
appAddr = Network -> Credential Payment -> StakeReference -> Addr
Addr (CageConfig -> Network
network CageConfig
cfg) (ScriptHash -> Credential Payment
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
appHash) StakeReference
StakeRefNull
    in  if Integer
edge Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
edgeInsertActive
            then (Addr -> ByteString
serialiseAddr Addr
appAddr, Data -> Maybe Data
forall a. a -> Maybe a
Just Data
edgeRecordDatum)
            else (Addr -> ByteString
serialiseAddr Addr
payerAddr, Maybe Data
forall a. Maybe a
Nothing)

{- | The deposit a booking rides with, over and above the tip. The fold
returns it to the destination the request named, or locks it in the
custody an absence creates — it is never the folder's.
-}
edgeDeposit :: Integer
edgeDeposit :: Integer
edgeDeposit = Integer
3_000_000

{- | What a tree-edge booking carries so the naming application
certifies it (DM-1): the asset it mints, the @Approve@ redeemer the
mint arm reads, and the application script that witnesses the mint.
The asset name hashes the same @(edge, key, owner, destination)@ the
redeemer carries, so one value binds both (DM-1-BIND).
-}
data BookingApproval = BookingApproval
    { BookingApproval -> MultiAsset
baAsset :: MultiAsset
    -- ^ Exactly one asset, quantity 1, under the application policy.
    , BookingApproval -> Data
baRedeemer :: PLC.Data
    {- ^ The @Approve@ constructor over @[edge, key, owner,
    [destinationAddress, destinationDatumHash]]@.
    -}
    , BookingApproval -> Script ConwayEra
baScript :: Script ConwayEra
    -- ^ The application script, the mint's witness.
    , BookingApproval -> Maybe TxIn
baScriptReference :: Maybe TxIn
    {- ^ An output carrying the application script as a reference
    script: the booking reads the script from it instead of carrying it
    as a witness. Nothing for the naming and open applications.
    -}
    , BookingApproval -> Set TxIn
baReferenceInputs :: Set.Set TxIn
    {- ^ Outputs the application reads without spending: the registry
    state, and for a termination the live output it releases. Empty for
    the naming and open applications.
    -}
    }

{- | The booking certification decision, in one place (#240): which
edges carry an approval and what it is. A tree edge (0–5) carries the
approval 'approvalName' binds; @edgeWitnessTerminal@ carries none,
because @open.ak@ refuses to certify a read and the cage never looks
for one — a booking that minted anyway is a transaction the node can
only reject. Admissibility of @edge@ stays the caller's check.
-}
bookingApproval
    :: NamingCodes
    -> Edge
    -- ^ Admissible edge, 0..6
    -> ByteString
    -- ^ Registry key
    -> ByteString
    -- ^ Booker's key hash bytes
    -> (ByteString, ByteString)
    -- ^ Destination: address bytes, datum hash
    -> Maybe BookingApproval
bookingApproval :: NamingCodes
-> Integer
-> ByteString
-> ByteString
-> (ByteString, ByteString)
-> Maybe BookingApproval
bookingApproval NamingCodes
codes Integer
edge ByteString
key ByteString
owner (ByteString, ByteString)
dest
    | Integer
edge Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
edgeInsertActive Bool -> Bool -> Bool
&& Integer
edge Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
edgeUpdateTerminal = Maybe BookingApproval
forall a. Maybe a
Nothing
    | Bool
otherwise =
        BookingApproval -> Maybe BookingApproval
forall a. a -> Maybe a
Just
            BookingApproval
                { baAsset :: MultiAsset
baAsset =
                    Map PolicyID (Map AssetName Integer) -> MultiAsset
MultiAsset
                        ( PolicyID
-> Map AssetName Integer -> Map PolicyID (Map AssetName Integer)
forall k a. k -> a -> Map k a
Map.singleton
                            PolicyID
appPolicy
                            (AssetName -> Integer -> Map AssetName Integer
forall k a. k -> a -> Map k a
Map.singleton (ShortByteString -> AssetName
AssetName (ByteString -> ShortByteString
SBS.toShort ByteString
name)) Integer
1)
                        )
                , baRedeemer :: Data
baRedeemer =
                    Integer -> [Data] -> Data
PLC.Constr
                        Integer
0
                        [ Integer -> Data
PLC.I Integer
edge
                        , ByteString -> Data
PLC.B ByteString
key
                        , ByteString -> Data
PLC.B ByteString
owner
                        , [Data] -> Data
PLC.List [ByteString -> Data
PLC.B ByteString
destAddr, ByteString -> Data
PLC.B ByteString
destHash]
                        ]
                , baScript :: Script ConwayEra
baScript = AlonzoScript ConwayEra
Script ConwayEra
appScript
                , baScriptReference :: Maybe TxIn
baScriptReference = Maybe TxIn
forall a. Maybe a
Nothing
                , baReferenceInputs :: Set TxIn
baReferenceInputs = Set TxIn
forall a. Set a
Set.empty
                }
  where
    name :: ByteString
name = Integer
-> ByteString
-> ByteString
-> (ByteString, ByteString)
-> ByteString
approvalName Integer
edge ByteString
key ByteString
owner (ByteString, ByteString)
dest
    appScript :: Script ConwayEra
appScript = [Char] -> ShortByteString -> Script ConwayEra
scriptFromBytes [Char]
"naming-application" (NamingCodes -> ShortByteString
ncApplication NamingCodes
codes)
    appPolicy :: PolicyID
appPolicy = ScriptHash -> PolicyID
PolicyID (Script ConwayEra -> ScriptHash
forall era. EraScript era => Script era -> ScriptHash
hashScript AlonzoScript ConwayEra
Script ConwayEra
appScript)
    (ByteString
destAddr, ByteString
destHash) = (ByteString, ByteString)
dest

{- | Put a booking's certification into the transaction (DM-1b): with
an approval, the mint, its redeemer, the script witness, the collateral
and the script-integrity hash; without one, the booking unchanged — no
redeemers, no witness, no collateral, and so no script-integrity hash,
which the ledger computes for any transaction that could run a script.
-}
certifyBooking
    :: PParams ConwayEra
    -- ^ Protocol parameters, for the script-integrity hash
    -> TxIn
    -- ^ Ada-only input, collateral when an approval is present
    -> Maybe BookingApproval
    -> ConwayTx
    -- ^ The booking with inputs, outputs, fee and signers set
    -> ConwayTx
certifyBooking :: PParams ConwayEra
-> TxIn -> Maybe BookingApproval -> ConwayTx -> ConwayTx
certifyBooking PParams ConwayEra
pp TxIn
collateral Maybe BookingApproval
mApproval ConwayTx
unsigned =
    case Maybe BookingApproval
mApproval of
        Maybe BookingApproval
Nothing -> ConwayTx
unsigned
        Just BookingApproval
approval ->
            let redeemers :: Redeemers ConwayEra
redeemers =
                    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))
                            ( RawRedeemer -> Data ConwayEra
forall a. ToData a => a -> Data ConwayEra
toLedgerData (Data -> RawRedeemer
RawRedeemer (BookingApproval -> Data
baRedeemer BookingApproval
approval))
                            , ExUnits
generousUnits
                            )
                        )
            in  ConwayTx
unsigned
                    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)
-> ((MultiAsset -> Identity MultiAsset)
    -> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> (MultiAsset -> Identity MultiAsset)
-> ConwayTx
-> Identity ConwayTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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)
 -> ConwayTx -> Identity ConwayTx)
-> MultiAsset -> ConwayTx -> ConwayTx
forall s t a b. ASetter s t a b -> b -> s -> t
.~ BookingApproval -> MultiAsset
baAsset BookingApproval
approval
                    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)
-> ((Set TxIn -> Identity (Set TxIn))
    -> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> (Set TxIn -> Identity (Set TxIn))
-> ConwayTx
-> Identity ConwayTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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))
 -> ConwayTx -> Identity ConwayTx)
-> Set TxIn -> ConwayTx -> ConwayTx
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxIn -> Set TxIn
forall a. a -> Set a
Set.singleton TxIn
collateral
                    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)
-> ((Set TxIn -> Identity (Set TxIn))
    -> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> (Set TxIn -> Identity (Set TxIn))
-> ConwayTx
-> Identity ConwayTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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))
 -> ConwayTx -> Identity ConwayTx)
-> Set TxIn -> ConwayTx -> ConwayTx
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ( BookingApproval -> Set TxIn
baReferenceInputs BookingApproval
approval
                                Set TxIn -> Set TxIn -> Set TxIn
forall a. Semigroup a => a -> a -> a
<> Set TxIn -> (TxIn -> Set TxIn) -> Maybe TxIn -> Set TxIn
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set TxIn
forall a. Set a
Set.empty TxIn -> Set TxIn
forall a. a -> Set a
Set.singleton (BookingApproval -> Maybe TxIn
baScriptReference BookingApproval
approval)
                           )
                    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 ScriptIntegrityHash
     -> Identity (StrictMaybe ScriptIntegrityHash))
    -> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> (StrictMaybe ScriptIntegrityHash
    -> Identity (StrictMaybe ScriptIntegrityHash))
-> ConwayTx
-> Identity ConwayTx
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))
 -> ConwayTx -> Identity ConwayTx)
-> StrictMaybe ScriptIntegrityHash -> ConwayTx -> ConwayTx
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
redeemers
                    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
                    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)
-> ((Map ScriptHash (Script ConwayEra)
     -> Identity (Map ScriptHash (Script ConwayEra)))
    -> AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra))
-> (Map ScriptHash (Script ConwayEra)
    -> Identity (Map ScriptHash (Script ConwayEra)))
-> ConwayTx
-> Identity ConwayTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map ScriptHash (Script ConwayEra)
 -> Identity (Map ScriptHash (Script ConwayEra)))
-> AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra)
(Map ScriptHash (Script ConwayEra)
 -> Identity (Map ScriptHash (Script ConwayEra)))
-> TxWits ConwayEra -> Identity (TxWits ConwayEra)
forall era.
EraTxWits era =>
Lens' (TxWits era) (Map ScriptHash (Script era))
Lens' (TxWits ConwayEra) (Map ScriptHash (Script ConwayEra))
scriptTxWitsL
                        ((Map ScriptHash (Script ConwayEra)
  -> Identity (Map ScriptHash (Script ConwayEra)))
 -> ConwayTx -> Identity ConwayTx)
-> Map ScriptHash (Script ConwayEra) -> ConwayTx -> ConwayTx
forall s t a b. ASetter s t a b -> b -> s -> t
.~ case BookingApproval -> Maybe TxIn
baScriptReference BookingApproval
approval of
                            Just TxIn
_ -> Map ScriptHash (Script ConwayEra)
forall k a. Map k a
Map.empty
                            Maybe TxIn
Nothing ->
                                ScriptHash -> Script ConwayEra -> Map ScriptHash (Script ConwayEra)
forall k a. k -> a -> Map k a
Map.singleton
                                    (Script ConwayEra -> ScriptHash
forall era. EraScript era => Script era -> ScriptHash
hashScript (BookingApproval -> Script ConwayEra
baScript BookingApproval
approval))
                                    (BookingApproval -> Script ConwayEra
baScript BookingApproval
approval)

{- | Book an edge, routing its minted token to the destination
`edgeDestinationOf` chooses for it.
-}
bookEdge
    :: CageConfig
    -> NamingCodes
    -> (Cage.Network, Cage.LedgerProvider Cage.NoWitness IO)
    -> SubmitSigned
    -> Addr
    -> TokenId
    -> ByteString
    -> Edge
    -> IO TxIn
bookEdge :: CageConfig
-> NamingCodes
-> (Network, LedgerProvider NoWitness IO)
-> SubmitSigned
-> Addr
-> TokenId
-> ByteString
-> Integer
-> IO TxIn
bookEdge CageConfig
cfg NamingCodes
codes (Network, LedgerProvider NoWitness IO)
prov SubmitSigned
submit Addr
payerAddr TokenId
tokenId ByteString
key Integer
edge =
    CageConfig
-> NamingCodes
-> (Network, LedgerProvider NoWitness IO)
-> SubmitSigned
-> Addr
-> TokenId
-> ByteString
-> Integer
-> (ByteString, Maybe Data)
-> IO TxIn
bookEdgeTo
        CageConfig
cfg
        NamingCodes
codes
        (Network, LedgerProvider NoWitness IO)
prov
        SubmitSigned
submit
        Addr
payerAddr
        TokenId
tokenId
        ByteString
key
        Integer
edge
        (CageConfig
-> NamingCodes -> Addr -> Integer -> (ByteString, Maybe Data)
edgeDestinationOf CageConfig
cfg NamingCodes
codes Addr
payerAddr Integer
edge)

{- | Book an edge, naming the destination explicitly (#173 I4, I5).

`edgeDestinationOf` sends an `insertActive` to the APPLICATION's own
script address, because the naming application is what creates the
record the active token witnesses. The OPEN registry has no such
application: `open.ak` is a minting policy with no spending arm at all,
so a token routed there would be locked forever.

The open story therefore names a WALLET, and the request carries that
choice. Nothing on chain changes: the cage already checks the
destination the request declares, and this is the off-chain builder
learning to say something it could not say before.

Which edges carry an approval, what it is, and how the transaction
carries it is decided once, in 'bookingApproval' and 'certifyBooking':
a tree edge mints and certifies, and a read books nothing at all.
-}
bookEdgeTo
    :: CageConfig
    -> NamingCodes
    -> (Cage.Network, Cage.LedgerProvider Cage.NoWitness IO)
    -> SubmitSigned
    -> Addr
    -> TokenId
    -> ByteString
    -> Edge
    -> (ByteString, Maybe PLC.Data)
    -> IO TxIn
bookEdgeTo :: CageConfig
-> NamingCodes
-> (Network, LedgerProvider NoWitness IO)
-> SubmitSigned
-> Addr
-> TokenId
-> ByteString
-> Integer
-> (ByteString, Maybe Data)
-> IO TxIn
bookEdgeTo CageConfig
cfg NamingCodes
codes (Network, LedgerProvider NoWitness IO)
prov SubmitSigned
submit Addr
payerAddr TokenId
tokenId ByteString
key Integer
edge (ByteString, Maybe Data)
dest = do
    signed <-
        CageConfig
-> (Network, LedgerProvider NoWitness IO)
-> SubmitSigned
-> Addr
-> TokenId
-> ByteString
-> Integer
-> (ByteString, Maybe Data)
-> Integer
-> Maybe BookingApproval
-> IO ConwayTx
bookEdgeWith
            CageConfig
cfg
            (Network, LedgerProvider NoWitness IO)
prov
            SubmitSigned
submit
            Addr
payerAddr
            TokenId
tokenId
            ByteString
key
            Integer
edge
            (ByteString, Maybe Data)
dest
            Integer
edgeDeposit
            ( NamingCodes
-> Integer
-> ByteString
-> ByteString
-> (ByteString, ByteString)
-> Maybe BookingApproval
bookingApproval
                NamingCodes
codes
                Integer
edge
                ByteString
key
                (Addr -> ByteString
addrKeyHashBytes Addr
payerAddr)
                ((ByteString, Maybe Data) -> (ByteString, ByteString)
approvalDestination (ByteString, Maybe Data)
dest)
            )
    pure (TxIn (txIdTx signed) (TxIx 0))

{- | Book an edge with the certification and deposit the caller's
application decides (#299): the approval it mints, with any outputs it
reads by reference, and the deposit the request rides with over the tip.
The booker's own key is the request's owner and its required signer.
Returns the signed booking as the submission callback handed it back;
the request is its first output.
-}
bookEdgeWith
    :: CageConfig
    -> (Cage.Network, Cage.LedgerProvider Cage.NoWitness IO)
    -> SubmitSigned
    -> Addr
    -> TokenId
    -> ByteString
    -> Edge
    -> (ByteString, Maybe PLC.Data)
    -> Integer
    -- ^ The deposit, over and above the tip
    -> Maybe BookingApproval
    -> IO ConwayTx
bookEdgeWith :: CageConfig
-> (Network, LedgerProvider NoWitness IO)
-> SubmitSigned
-> Addr
-> TokenId
-> ByteString
-> Integer
-> (ByteString, Maybe Data)
-> Integer
-> Maybe BookingApproval
-> IO ConwayTx
bookEdgeWith CageConfig
cfg (Network, LedgerProvider NoWitness IO)
prov SubmitSigned
submit Addr
payerAddr TokenId
tokenId ByteString
key Integer
edge (ByteString, Maybe Data)
dest Integer
deposit Maybe BookingApproval
approval =
    (Network, LedgerProvider NoWitness IO)
-> (Session NoWitness IO -> IO ConwayTx) -> IO ConwayTx
forall w a.
(Network, LedgerProvider w IO) -> (Session w IO -> IO a) -> IO a
Cage.withLatest
        (Network, LedgerProvider NoWitness IO)
prov
        ( \Session NoWitness IO
v -> CageConfig
-> Session NoWitness IO
-> Addr
-> TokenId
-> ByteString
-> Integer
-> (ByteString, Maybe Data)
-> Integer
-> Maybe BookingApproval
-> IO ConwayTx
bookEdgeTx CageConfig
cfg Session NoWitness IO
v Addr
payerAddr TokenId
tokenId ByteString
key Integer
edge (ByteString, Maybe Data)
dest Integer
deposit Maybe BookingApproval
approval
        )
        IO ConwayTx -> SubmitSigned -> IO ConwayTx
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SubmitSigned
submit

{- | The unsigned booking of one edge, built from one view: the payer's
largest ada-only output pays the bond, the fee and the change.
-}
bookEdgeTx
    :: CageConfig
    -> Cage.Session Cage.NoWitness IO
    -> Addr
    -> TokenId
    -> ByteString
    -> Edge
    -> (ByteString, Maybe PLC.Data)
    -> Integer
    -- ^ The deposit, over and above the tip
    -> Maybe BookingApproval
    -> IO ConwayTx
bookEdgeTx :: CageConfig
-> Session NoWitness IO
-> Addr
-> TokenId
-> ByteString
-> Integer
-> (ByteString, Maybe Data)
-> Integer
-> Maybe BookingApproval
-> IO ConwayTx
bookEdgeTx CageConfig
cfg Session NoWitness IO
v Addr
payerAddr TokenId
tokenId ByteString
key Integer
edge (ByteString, Maybe Data)
dest Integer
deposit Maybe BookingApproval
approval = do
    ByteString -> Integer -> IO ()
requireAdmissible ByteString
key Integer
edge
    pp <- Session NoWitness IO -> IO (PParams ConwayEra)
forall w. Session w IO -> IO (PParams ConwayEra)
Cage.parameters Session NoWitness IO
v
    utxos <- Cage.outputsAt v payerAddr
    (feeIn, feeOut) <-
        case sortOn
            (Down . (^. coinTxOutL) . snd)
            (filter (adaOnlyOut . snd) utxos) of
            [] -> [Char] -> IO (TxIn, BabbageTxOut ConwayEra)
forall a. HasCallStack => [Char] -> a
error [Char]
"bookEdge: the payer wallet has no ada-only output"
            ((TxIn, BabbageTxOut ConwayEra)
u : [(TxIn, BabbageTxOut ConwayEra)]
_) -> (TxIn, BabbageTxOut ConwayEra) -> IO (TxIn, BabbageTxOut ConwayEra)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxIn, BabbageTxOut ConwayEra)
u
    now <- currentPosixMs
    let MaryValue (Coin feeBal) carried = feeOut ^. valueTxOutL
        (reqOut, bond) =
            requestOutput
                cfg
                pp
                tokenId
                payerAddr
                key
                edge
                dest
                deposit
                approval
                now
        fee = Integer
2_000_000
        change = Integer
feeBal Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
bond Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
fee
        owner = Addr -> ByteString
addrKeyHashBytes Addr
payerAddr
    unless (change > 0) $
        error
            ("bookEdge: the payer wallet is too small (" <> show feeBal <> ")")
    let 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
feeIn
                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.fromList
                        [ BabbageTxOut ConwayEra
reqOut
                        , Addr -> Value ConwayEra -> TxOut ConwayEra
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
payerAddr (Coin -> MultiAsset -> MaryValue
MaryValue (Integer -> Coin
Coin Integer
change) MultiAsset
carried)
                        ]
                TxBody TopTx ConwayEra
-> (TxBody TopTx ConwayEra -> TxBody TopTx ConwayEra)
-> TxBody TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (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)
 -> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> Coin -> TxBody TopTx ConwayEra -> TxBody TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
fee
                TxBody TopTx ConwayEra
-> (TxBody TopTx ConwayEra -> TxBody TopTx ConwayEra)
-> TxBody TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (Set (KeyHash Guard) -> Identity (Set (KeyHash Guard)))
-> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
(AlonzoEraTxBody era, AtMostEra "Conway" era) =>
Lens' (TxBody l era) (Set (KeyHash Guard))
forall (l :: TxLevel).
AtMostEra "Conway" ConwayEra =>
Lens' (TxBody l ConwayEra) (Set (KeyHash Guard))
Lens' (TxBody TopTx ConwayEra) (Set (KeyHash Guard))
reqSignerHashesTxBodyL
                    ((Set (KeyHash Guard) -> Identity (Set (KeyHash Guard)))
 -> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> Set (KeyHash Guard)
-> TxBody TopTx ConwayEra
-> TxBody TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ KeyHash Guard -> Set (KeyHash Guard)
forall a. a -> Set a
Set.singleton (ByteString -> KeyHash Guard
addrWitnessKeyHash ByteString
owner)
    pure (certifyBooking pp feeIn approval (mkBasicTx body))

{- | A booking's edge must be one of the seven the registry admits (#183):
the tag IS the edge. A booking states its own seven-admitted-edges row, and a row outside the
table is one only an adversarial caller wants, so it is refused here rather
than carried to a fold that would refuse it @edge-inadmissible@ anyway.
-}
requireAdmissible :: ByteString -> Edge -> IO ()
requireAdmissible :: ByteString -> Integer -> IO ()
requireAdmissible ByteString
key Integer
edge =
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
edge Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
edgeInsertActive Bool -> Bool -> Bool
&& Integer
edge Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
edgeUpdateTerminal) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error
            ( [Char]
"bookEdge: edge "
                [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
edge
                [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" on key "
                [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ByteString -> [Char]
forall a. Show a => a -> [Char]
show ByteString
key
                [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" is not supported by M1 (expected insertActive or updateTerminal)"
            )

{- | The request output a booking locks, and the bond it holds.

Issue 183: the datum binds the DEPOSIT, not the tip. The output holds @bond@ =
tip + deposit, and the fold checks @deposit == held - tip@, so the two are
the same number written once each. The min-ADA check is what keeps them
equal: a bond raised to meet min-ADA would break the equality silently, so
the booking refuses instead.
-}
requestOutput
    :: CageConfig
    -> PParams ConwayEra
    -> TokenId
    -> Addr
    -> ByteString
    -> Edge
    -> (ByteString, Maybe PLC.Data)
    -> Integer
    -> Maybe BookingApproval
    -> Integer
    -> (TxOut ConwayEra, Integer)
requestOutput :: CageConfig
-> PParams ConwayEra
-> TokenId
-> Addr
-> ByteString
-> Integer
-> (ByteString, Maybe Data)
-> Integer
-> Maybe BookingApproval
-> Integer
-> (TxOut ConwayEra, Integer)
requestOutput CageConfig
cfg PParams ConwayEra
pp TokenId
tokenId Addr
payerAddr ByteString
key Integer
edge (ByteString, Maybe Data)
dest Integer
deposit Maybe BookingApproval
approval Integer
now =
    let Coin Integer
tipVal = CageConfig -> Coin
defaultTip CageConfig
cfg
        bond :: Integer
bond = Integer
tipVal Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
deposit
        datum :: Data
datum = TokenId
-> Addr
-> ByteString
-> Integer
-> Integer
-> Integer
-> (ByteString, Maybe Data)
-> Data
mkRequestDatumWith TokenId
tokenId Addr
payerAddr ByteString
key Integer
edge Integer
deposit Integer
now (ByteString, Maybe Data)
dest
        reqOut :: BabbageTxOut ConwayEra
reqOut =
            Addr -> Value ConwayEra -> TxOut ConwayEra
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut
                (CageConfig -> TokenId -> Network -> Addr
requestAddrFromCfg CageConfig
cfg TokenId
tokenId (CageConfig -> Network
network CageConfig
cfg))
                (Coin -> MultiAsset -> MaryValue
MaryValue (Integer -> Coin
Coin Integer
bond) (MultiAsset
-> (BookingApproval -> MultiAsset)
-> Maybe BookingApproval
-> MultiAsset
forall b a. b -> (a -> b) -> Maybe a -> b
maybe MultiAsset
forall a. Monoid a => a
mempty BookingApproval -> MultiAsset
baAsset Maybe BookingApproval
approval))
                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
datum
        Coin Integer
minAda = PParams ConwayEra -> TxOut ConwayEra -> Coin
forall era. EraTxOut era => PParams era -> TxOut era -> Coin
getMinCoinTxOut PParams ConwayEra
pp TxOut ConwayEra
BabbageTxOut ConwayEra
reqOut
    in  if Integer
bond Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
minAda
            then (TxOut ConwayEra
BabbageTxOut ConwayEra
reqOut, Integer
bond)
            else [Char] -> (BabbageTxOut ConwayEra, Integer)
forall a. HasCallStack => [Char] -> a
error ([Char]
"bookEdge: the bond is under min-ADA: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
bond)

{- | 'bookEdgeWith' with its fee, units and collateral measured rather
than declared (#300).

The node's evaluator measures the booking's one purpose, the redeemer
declares exactly those units, and the balancer charges the ledger's fee for
the final body, reference scripts included — the resolved outputs the
booking reads its script from are handed to it. The funding output, the
wallet's largest ada-only output unless the caller chose one, is the
collateral input, and the transaction states its total collateral at the
protocol's percentage of the fee, rounded up, and a return carrying the rest
of the output back. Everything is read from the one view the caller holds,
and the booking is returned unsigned: the caller submits it after the view is
released, and a caller that only prepares submits nothing.
-}
bookEdgeMeasured
    :: CageConfig
    -> Cage.Session Cage.NoWitness IO
    {- ^ The one acquired view the booking is built, measured and certified
    from: its protocol parameters are the ones the caller reports and judges
    its outlay under, and nothing is submitted while it is held
    -}
    -> Addr
    -> TokenId
    -> ByteString
    -> Edge
    -> (ByteString, Maybe PLC.Data)
    -> Integer
    -- ^ The deposit, over and above the tip
    -> BookingApproval
    -> [(TxIn, TxOut ConwayEra)]
    -- ^ The resolved outputs the booking reads its scripts from
    -> Maybe TxIn
    -- ^ The wallet output the caller chose to fund and collateralise
    -> IO ConwayTx
bookEdgeMeasured :: CageConfig
-> Session NoWitness IO
-> Addr
-> TokenId
-> ByteString
-> Integer
-> (ByteString, Maybe Data)
-> Integer
-> BookingApproval
-> [(TxIn, TxOut ConwayEra)]
-> Maybe TxIn
-> IO ConwayTx
bookEdgeMeasured CageConfig
cfg Session NoWitness IO
v Addr
payerAddr TokenId
tokenId ByteString
key Integer
edge (ByteString, Maybe Data)
dest Integer
deposit BookingApproval
approval [(TxIn, TxOut ConwayEra)]
refs Maybe TxIn
chosen =
    Tracer IO ReadEvent
-> (Double -> Either ErrorClass ConwayTx -> ReadEvent)
-> IO ConwayTx
-> IO ConwayTx
forall e a.
Tracer IO e -> (Double -> Either ErrorClass a -> e) -> IO a -> IO a
timedTrace
        (Session NoWitness IO -> Tracer IO ReadEvent
forall w (m :: * -> *). Session w m -> Tracer m ReadEvent
Cage.sessionTracer Session NoWitness IO
v)
        ( \Double
ms Either ErrorClass ConwayTx
end ->
            BodyBuild -> ReadEvent
BodyBuilt
                BodyBuild
                    { bodyBuilder :: Text
bodyBuilder = Text
"bookEdgeMeasured"
                    , bodyElapsed :: Double
bodyElapsed = Double
ms
                    , bodyEnd :: BodyEnd
bodyEnd = (ErrorClass -> BodyEnd)
-> (ConwayTx -> BodyEnd) -> Either ErrorClass ConwayTx -> BodyEnd
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ErrorClass -> BodyEnd
BodyFailed (BodyEnd -> ConwayTx -> BodyEnd
forall a b. a -> b -> a
const BodyEnd
BodyReady) Either ErrorClass ConwayTx
end
                    }
        )
        ( CageConfig
-> Session NoWitness IO
-> Addr
-> TokenId
-> ByteString
-> Integer
-> (ByteString, Maybe Data)
-> Integer
-> BookingApproval
-> [(TxIn, TxOut ConwayEra)]
-> Maybe TxIn
-> IO ConwayTx
measuredBody
            CageConfig
cfg
            Session NoWitness IO
v
            Addr
payerAddr
            TokenId
tokenId
            ByteString
key
            Integer
edge
            (ByteString, Maybe Data)
dest
            Integer
deposit
            BookingApproval
approval
            [(TxIn, TxOut ConwayEra)]
refs
            Maybe TxIn
chosen
        )

-- | The measured booking, unlogged: the builder 'bookEdgeMeasured' times.
measuredBody
    :: CageConfig
    -> Cage.Session Cage.NoWitness IO
    -> Addr
    -> TokenId
    -> ByteString
    -> Edge
    -> (ByteString, Maybe PLC.Data)
    -> Integer
    -> BookingApproval
    -> [(TxIn, TxOut ConwayEra)]
    -> Maybe TxIn
    -> IO ConwayTx
measuredBody :: CageConfig
-> Session NoWitness IO
-> Addr
-> TokenId
-> ByteString
-> Integer
-> (ByteString, Maybe Data)
-> Integer
-> BookingApproval
-> [(TxIn, TxOut ConwayEra)]
-> Maybe TxIn
-> IO ConwayTx
measuredBody CageConfig
cfg Session NoWitness IO
v Addr
payerAddr TokenId
tokenId ByteString
key Integer
edge (ByteString, Maybe Data)
dest Integer
deposit BookingApproval
approval [(TxIn, TxOut ConwayEra)]
refs Maybe TxIn
chosen = do
    ByteString -> Integer -> IO ()
requireAdmissible ByteString
key Integer
edge
    pp <- Session NoWitness IO -> IO (PParams ConwayEra)
forall w. Session w IO -> IO (PParams ConwayEra)
Cage.parameters Session NoWitness IO
v
    utxos <- Cage.outputsAt v payerAddr
    funding <-
        either (error . ("bookEdge: " <>)) pure (selectFunding chosen utxos)
    now <- currentPosixMs
    let (reqOut, _) =
            requestOutput
                cfg
                pp
                tokenId
                payerAddr
                key
                edge
                dest
                deposit
                (Just approval)
                now
        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, BabbageTxOut ConwayEra) -> TxIn
forall a b. (a, b) -> a
fst (TxIn, BabbageTxOut ConwayEra)
funding)
                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
reqOut
                TxBody TopTx ConwayEra
-> (TxBody TopTx ConwayEra -> TxBody TopTx ConwayEra)
-> TxBody TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (Set (KeyHash Guard) -> Identity (Set (KeyHash Guard)))
-> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
(AlonzoEraTxBody era, AtMostEra "Conway" era) =>
Lens' (TxBody l era) (Set (KeyHash Guard))
forall (l :: TxLevel).
AtMostEra "Conway" ConwayEra =>
Lens' (TxBody l ConwayEra) (Set (KeyHash Guard))
Lens' (TxBody TopTx ConwayEra) (Set (KeyHash Guard))
reqSignerHashesTxBodyL
                    ((Set (KeyHash Guard) -> Identity (Set (KeyHash Guard)))
 -> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> Set (KeyHash Guard)
-> TxBody TopTx ConwayEra
-> TxBody TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ KeyHash Guard -> Set (KeyHash Guard)
forall a. a -> Set a
Set.singleton (ByteString -> KeyHash Guard
addrWitnessKeyHash (Addr -> ByteString
addrKeyHashBytes Addr
payerAddr))
        unsigned = PParams ConwayEra
-> TxIn -> Maybe BookingApproval -> ConwayTx -> ConwayTx
certifyBooking PParams ConwayEra
pp ((TxIn, BabbageTxOut ConwayEra) -> TxIn
forall a b. (a, b) -> a
fst (TxIn, BabbageTxOut ConwayEra)
funding) (BookingApproval -> Maybe BookingApproval
forall a. a -> Maybe a
Just BookingApproval
approval) (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)
    balanced <-
        evaluateAndBalanceReferencing
            v
            pp
            [funding]
            refs
            payerAddr
            unsigned
    requireCarriesMinimums pp balanced
    pure balanced

{- | The balancer appends a change output and a collateral return whatever
they hold. A funding output too small to leave either its minimum ada would
make a transaction the ledger refuses, so the booking refuses it first.
-}
requireCarriesMinimums :: PParams ConwayEra -> ConwayTx -> IO ()
requireCarriesMinimums :: PParams ConwayEra -> ConwayTx -> IO ()
requireCarriesMinimums PParams ConwayEra
pp ConwayTx
tx = do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((BabbageTxOut ConwayEra -> Bool)
-> [BabbageTxOut ConwayEra] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all BabbageTxOut ConwayEra -> Bool
carries [BabbageTxOut ConwayEra]
outs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error
            [Char]
"bookEdge: the funding output is too small to carry the booking, its fee, its collateral and their change"
    -- The balancer collateralises the whole input, stating no return, when
    -- what remains after the required total is under the minimum output.
    -- A booking never puts a whole funding output at risk.
    case TxBody TopTx ConwayEra
body TxBody TopTx ConwayEra
-> Getting
     (StrictMaybe (BabbageTxOut ConwayEra))
     (TxBody TopTx ConwayEra)
     (StrictMaybe (BabbageTxOut ConwayEra))
-> StrictMaybe (BabbageTxOut ConwayEra)
forall s a. s -> Getting a s a -> a
^. (StrictMaybe (TxOut ConwayEra)
 -> Const
      (StrictMaybe (BabbageTxOut ConwayEra))
      (StrictMaybe (TxOut ConwayEra)))
-> TxBody TopTx ConwayEra
-> Const
     (StrictMaybe (BabbageTxOut ConwayEra)) (TxBody TopTx ConwayEra)
Getting
  (StrictMaybe (BabbageTxOut ConwayEra))
  (TxBody TopTx ConwayEra)
  (StrictMaybe (BabbageTxOut ConwayEra))
forall era.
BabbageEraTxBody era =>
Lens' (TxBody TopTx era) (StrictMaybe (TxOut era))
Lens' (TxBody TopTx ConwayEra) (StrictMaybe (TxOut ConwayEra))
collateralReturnTxBodyL of
        StrictMaybe (BabbageTxOut ConwayEra)
SNothing ->
            [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error
                [Char]
"bookEdge: the funding output cannot leave a collateral return of its minimum, so its whole value would be collateral"
        SJust BabbageTxOut ConwayEra
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    body :: TxBody TopTx ConwayEra
body = ConwayTx
tx ConwayTx
-> Getting
     (TxBody TopTx ConwayEra) ConwayTx (TxBody TopTx ConwayEra)
-> TxBody TopTx ConwayEra
forall s a. s -> Getting a s a -> a
^. Getting (TxBody TopTx ConwayEra) ConwayTx (TxBody 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
    outs :: [BabbageTxOut ConwayEra]
outs =
        StrictSeq (BabbageTxOut ConwayEra) -> [BabbageTxOut ConwayEra]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (TxBody TopTx ConwayEra
body TxBody TopTx ConwayEra
-> Getting
     (StrictSeq (BabbageTxOut ConwayEra))
     (TxBody TopTx ConwayEra)
     (StrictSeq (BabbageTxOut ConwayEra))
-> StrictSeq (BabbageTxOut ConwayEra)
forall s a. s -> Getting a s a -> a
^. (StrictSeq (TxOut ConwayEra)
 -> Const
      (StrictSeq (BabbageTxOut ConwayEra)) (StrictSeq (TxOut ConwayEra)))
-> TxBody TopTx ConwayEra
-> Const
     (StrictSeq (BabbageTxOut ConwayEra)) (TxBody TopTx ConwayEra)
Getting
  (StrictSeq (BabbageTxOut ConwayEra))
  (TxBody TopTx ConwayEra)
  (StrictSeq (BabbageTxOut 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)
            [BabbageTxOut ConwayEra]
-> [BabbageTxOut ConwayEra] -> [BabbageTxOut ConwayEra]
forall a. Semigroup a => a -> a -> a
<> [BabbageTxOut ConwayEra
r | SJust BabbageTxOut ConwayEra
r <- [TxBody TopTx ConwayEra
body TxBody TopTx ConwayEra
-> Getting
     (StrictMaybe (BabbageTxOut ConwayEra))
     (TxBody TopTx ConwayEra)
     (StrictMaybe (BabbageTxOut ConwayEra))
-> StrictMaybe (BabbageTxOut ConwayEra)
forall s a. s -> Getting a s a -> a
^. (StrictMaybe (TxOut ConwayEra)
 -> Const
      (StrictMaybe (BabbageTxOut ConwayEra))
      (StrictMaybe (TxOut ConwayEra)))
-> TxBody TopTx ConwayEra
-> Const
     (StrictMaybe (BabbageTxOut ConwayEra)) (TxBody TopTx ConwayEra)
Getting
  (StrictMaybe (BabbageTxOut ConwayEra))
  (TxBody TopTx ConwayEra)
  (StrictMaybe (BabbageTxOut ConwayEra))
forall era.
BabbageEraTxBody era =>
Lens' (TxBody TopTx era) (StrictMaybe (TxOut era))
Lens' (TxBody TopTx ConwayEra) (StrictMaybe (TxOut ConwayEra))
collateralReturnTxBodyL]]
    carries :: TxOut ConwayEra -> Bool
carries TxOut ConwayEra
o = TxOut ConwayEra
o 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 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
o

{- | What a fold of tree edges needs in hand: the three token policies
this registry pins, the cage script custody spends run, the cage's own
UTxOs, the one destination datum a booking binds, and the reference
outputs the fold's scripts resolve through.
-}
registryContextFor
    :: CageConfig
    -> NamingCodes
    -> Cage.Session Cage.NoWitness IO
    -> [(TxIn, TxOut ConwayEra)]
    -> IO RegistryContext
registryContextFor :: CageConfig
-> NamingCodes
-> Session NoWitness IO
-> [(TxIn, TxOut ConwayEra)]
-> IO RegistryContext
registryContextFor CageConfig
cfg NamingCodes
codes Session NoWitness IO
v [(TxIn, TxOut ConwayEra)]
refs = do
    utxos <- Session NoWitness IO -> Addr -> IO [(TxIn, TxOut ConwayEra)]
forall w. Session w IO -> Addr -> IO [(TxIn, TxOut ConwayEra)]
Cage.outputsAt Session NoWitness IO
v (CageConfig -> Network -> Addr
cageAddrFromCfg CageConfig
cfg (CageConfig -> Network
network CageConfig
cfg))
    pure
        emptyRegistryContext
            { rcWitnessScripts =
                Map.fromList [(k, witnessScriptOf cfg codes k) | k <- [0, 1, 2]]
            , rcCageScript = Just (mkCageScript cfg)
            , rcCageUtxos = utxos
            , rcRefUtxos = refs
            }