{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}

{- |
Module      : Singular.Registry.TxBuilder.Update.Duties
Description : Fold duty decisions — what each edge owes
License     : Apache-2.0

The obligations a fold's requests create, computed once, off chain:
what must move under the registry's three token policies, where a
minted token has to land, which custody has to be spent, which holder
input a burn consumes, what returns to the owner, and who has to sign
(the fold: nobody). This is one derivation; the cage computes its own
from the requests it consumes, and the two are deliberately separate.

This module owns no queries and no transaction assembly; see
"Singular.Registry.TxBuilder.Update.Context" and
"Singular.Registry.TxBuilder.Update.Build". The public surface stays
"Singular.Registry.TxBuilder.Update", which re-exports the duties
unchanged (#267).
-}
module Singular.Registry.TxBuilder.Update.Duties
    ( RegistryDuties (..)
    , registryDuties
    ) where

import Data.ByteString.Short qualified as SBS
import Data.Map.Strict qualified as Map
import Lens.Micro ((&), (.~), (^.))
import PlutusCore.Data qualified as PLC

import Cardano.Ledger.Api.Tx.Out
    ( TxOut
    , coinTxOutL
    , datumTxOutL
    , getMinCoinTxOut
    , mkBasicTxOut
    , valueTxOutL
    )
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Core (hashScript)
import Cardano.Ledger.Keys (KeyHash)
import Cardano.Ledger.Mary.Value
    ( AssetName (..)
    , MaryValue (..)
    , MultiAsset (..)
    , PolicyID (..)
    )
import Cardano.Tx.Build (Guard)
import PlutusTx.Builtins.Internal (BuiltinByteString (..))

import Singular.Registry.Config
    ( CageConfig (..)
    )
import Singular.Registry.Ledger
    ( ConwayEra
    , PParams
    , TxIn
    )
import Singular.Registry.TxBuilder.ConnectedFold
    ( ConnectedMint (..)
    , ConnectedSpend (..)
    , RawRedeemer (..)
    )
import Singular.Registry.TxBuilder.Internal.Edges
import Singular.Registry.TxBuilder.Internal.Identity
import Singular.Registry.TxBuilder.Update.Context
    ( HolderRelease (..)
    , RegistryContext (..)
    )
import Singular.Registry.Types
    ( CageDatum (..)
    , OnChainRequest (..)
    , OnChainTokenState (..)
    , edgeInsertActive
    , edgeUpdateTerminal
    )

-- ---------------------------------------------------------
-- Registry-mode obligations (#157 mint-matches-edge-deltas, token-destinations-and-refunds, T1-T6)
-- ---------------------------------------------------------

{- | Everything an edge owes a fold beyond the trie: what must move under
the active token policy, where a registration lands, and which holder
a retirement consumes.

The cage computes these from the requests it consumes (`dutiesOf`,
`dutyOk`); this recomputes them from the same requests so a fold can be
built that discharges them. The two are deliberately separate
derivations — a builder that agrees with the validator by construction
would not catch a disagreement.
-}
data RegistryDuties = RegistryDuties
    { RegistryDuties -> [ConnectedMint]
rdMints :: [ConnectedMint]
    , RegistryDuties -> [TxOut ConwayEra]
rdOutputs :: [TxOut ConwayEra]
    , RegistryDuties -> [ConnectedSpend]
rdSpends :: [ConnectedSpend]
    , RegistryDuties -> [KeyHash Guard]
rdSigners :: [KeyHash Guard]
    , RegistryDuties -> [(TxIn, TxOut ConwayEra)]
rdInputs :: [(TxIn, TxOut ConwayEra)]
    {- ^ #177 I177-BUILDER: ordinary (non-script) inputs the edge needs
    the transaction to consume. A retirement of an
    active key burns an asset it does not create, so the holder UTxO
    carrying that asset has to ride in as an input; a mint of `-1` with nothing to burn is a transaction
    whose only possible outcome is a refusal.
    -}
    }

instance Semigroup RegistryDuties where
    RegistryDuties
a <> :: RegistryDuties -> RegistryDuties -> RegistryDuties
<> RegistryDuties
b =
        [ConnectedMint]
-> [TxOut ConwayEra]
-> [ConnectedSpend]
-> [KeyHash Guard]
-> [(TxIn, TxOut ConwayEra)]
-> RegistryDuties
RegistryDuties
            (RegistryDuties -> [ConnectedMint]
rdMints RegistryDuties
a [ConnectedMint] -> [ConnectedMint] -> [ConnectedMint]
forall a. Semigroup a => a -> a -> a
<> RegistryDuties -> [ConnectedMint]
rdMints RegistryDuties
b)
            (RegistryDuties -> [TxOut ConwayEra]
rdOutputs RegistryDuties
a [BabbageTxOut ConwayEra]
-> [BabbageTxOut ConwayEra] -> [BabbageTxOut ConwayEra]
forall a. Semigroup a => a -> a -> a
<> RegistryDuties -> [TxOut ConwayEra]
rdOutputs RegistryDuties
b)
            (RegistryDuties -> [ConnectedSpend]
rdSpends RegistryDuties
a [ConnectedSpend] -> [ConnectedSpend] -> [ConnectedSpend]
forall a. Semigroup a => a -> a -> a
<> RegistryDuties -> [ConnectedSpend]
rdSpends RegistryDuties
b)
            (RegistryDuties -> [KeyHash Guard]
rdSigners RegistryDuties
a [KeyHash Guard] -> [KeyHash Guard] -> [KeyHash Guard]
forall a. Semigroup a => a -> a -> a
<> RegistryDuties -> [KeyHash Guard]
rdSigners RegistryDuties
b)
            (RegistryDuties -> [(TxIn, TxOut ConwayEra)]
rdInputs RegistryDuties
a [(TxIn, BabbageTxOut ConwayEra)]
-> [(TxIn, BabbageTxOut ConwayEra)]
-> [(TxIn, BabbageTxOut ConwayEra)]
forall a. Semigroup a => a -> a -> a
<> RegistryDuties -> [(TxIn, TxOut ConwayEra)]
rdInputs RegistryDuties
b)

instance Monoid RegistryDuties where
    mempty :: RegistryDuties
mempty = [ConnectedMint]
-> [TxOut ConwayEra]
-> [ConnectedSpend]
-> [KeyHash Guard]
-> [(TxIn, TxOut ConwayEra)]
-> RegistryDuties
RegistryDuties [] [] [] [] []

{- | The obligations this set of requests creates, or the reason they
cannot be met. A fold whose duties cannot be built is a fold that would be
refused on chain; failing here names why, in the builder, where it is
cheap.
-}
registryDuties
    :: CageConfig
    -> PParams ConwayEra
    -> OnChainTokenState
    -> RegistryContext
    -> [(TxIn, TxOut ConwayEra)]
    -> [Bool]
    {- ^ Whether each request is PROCESSED by this fold. A rejected
    request takes no edge: it owes its owner a refund, and the
    approval that certified it was never spent.
    -}
    -> Either String RegistryDuties
registryDuties :: CageConfig
-> PParams ConwayEra
-> OnChainTokenState
-> RegistryContext
-> [(TxIn, TxOut ConwayEra)]
-> [Bool]
-> Either String RegistryDuties
registryDuties CageConfig
cfg PParams ConwayEra
pp OnChainTokenState
st RegistryContext
ctx [(TxIn, TxOut ConwayEra)]
reqUtxos [Bool]
processed = do
    perRequest <- [RegistryDuties] -> RegistryDuties
forall a. Monoid a => [a] -> a
mconcat ([RegistryDuties] -> RegistryDuties)
-> Either String [RegistryDuties] -> Either String RegistryDuties
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (((TxIn, BabbageTxOut ConwayEra), Bool)
 -> Either String RegistryDuties)
-> [((TxIn, BabbageTxOut ConwayEra), Bool)]
-> Either String [RegistryDuties]
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 ((TxIn, BabbageTxOut ConwayEra), Bool)
-> Either String RegistryDuties
forall {a}.
((a, BabbageTxOut ConwayEra), Bool) -> Either String RegistryDuties
one [((TxIn, BabbageTxOut ConwayEra), Bool)]
consumed
    returns <- depositReturns (releasesIn perRequest)
    pure (perRequest <> returns)
  where
    -- Unmatched requests are NOT processed: a deficit fold has more
    -- requests than actions, and the tail of it takes no edge.
    consumed :: [((TxIn, BabbageTxOut ConwayEra), Bool)]
consumed = [(TxIn, BabbageTxOut ConwayEra)]
-> [Bool] -> [((TxIn, BabbageTxOut ConwayEra), Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(TxIn, TxOut ConwayEra)]
[(TxIn, BabbageTxOut ConwayEra)]
reqUtxos ([Bool]
processed [Bool] -> [Bool] -> [Bool]
forall a. Semigroup a => a -> a -> a
<> Bool -> [Bool]
forall a. a -> [a]
repeat Bool
False)
    net :: Network
net = CageConfig -> Network
network CageConfig
cfg
    tip :: Integer
tip = OnChainTokenState -> Integer
stateMaxFee OnChainTokenState
st
    one :: ((a, BabbageTxOut ConwayEra), Bool) -> Either String RegistryDuties
one ((a, BabbageTxOut ConwayEra)
_, Bool
isProcessed)
        | Bool -> Bool
not Bool
isProcessed = RegistryDuties -> Either String RegistryDuties
forall a b. b -> Either a b
Right RegistryDuties
forall a. Monoid a => a
mempty
    one ((a
_, BabbageTxOut ConwayEra
reqOut), Bool
_) = do
        req <- case TxOut ConwayEra -> Maybe CageDatum
extractCageDatum TxOut ConwayEra
BabbageTxOut ConwayEra
reqOut of
            Just (RequestDatum OnChainRequest
r) -> OnChainRequest -> Either String OnChainRequest
forall a b. b -> Either a b
Right OnChainRequest
r
            Maybe CageDatum
_ -> String -> Either String OnChainRequest
forall a b. a -> Either a b
Left String
"registryDuties: a request input carries no request datum"
        let key = OnChainRequest -> ByteString
requestKey OnChainRequest
req
            edge = OnChainRequest -> Integer
requestEdge OnChainRequest
req
            dest@(destAddr, _) = requestDestination req
            Coin held = reqOut ^. coinTxOutL
            floorAda = Integer
held Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
tip
        -- #183: the tag IS the edge, so admissibility is a range and
        -- nothing is derived from bytes. A tag outside the table owes
        -- the fold no mint and no destination, because the cage refuses
        -- it `edge-inadmissible` before either is read.
        if edge /= edgeInsertActive && edge /= edgeUpdateTerminal
            then
                if rcAllowInadmissible ctx
                    then
                        -- The cage will refuse this, which is the point:
                        -- a row that exists to watch the refusal needs
                        -- the transaction built, not withheld.
                        approvalReturn req reqOut
                    else
                        Left
                            ( "registryDuties: edge "
                                <> show edge
                                <> " on key "
                                <> show key
                                <> " is not supported by M1 (expected insertActive or updateTerminal)"
                            )
            else do
                mints <- mintsFor edge key
                rest <- dutiesFor edge key dest destAddr floorAda
                back <-
                    if returnsDeposit edge
                        then pure mempty
                        else approvalReturn req reqOut
                pure (mints <> rest <> back)
    {- An approval is not burned at the fold (approval-asset-binding), so it has to
    land somewhere. It goes back to the owner who booked it, in an output
    of its own: left to the balancer it would settle in the folder's
    change, and the folder's wallet would stop being able to fund a fold
    at all, because collateral must be ada-only. -}
    approvalReturn
        :: OnChainRequest -> TxOut ConwayEra -> Either String RegistryDuties
    approvalReturn :: OnChainRequest -> TxOut ConwayEra -> Either String RegistryDuties
approvalReturn OnChainRequest
req TxOut ConwayEra
reqOut = do
        let BuiltinByteString ByteString
owner = OnChainRequest -> BuiltinByteString
requestOwner OnChainRequest
req
            carried :: Map PolicyID (Map AssetName Integer)
carried = TxOut ConwayEra -> Map PolicyID (Map AssetName Integer)
forall {era}.
(Value era ~ MaryValue,
 Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTxOut era) =>
TxOut era -> Map PolicyID (Map AssetName Integer)
approvalsOn TxOut ConwayEra
reqOut
        if Map PolicyID (Map AssetName Integer) -> Bool
forall k a. Map k a -> Bool
Map.null Map PolicyID (Map AssetName Integer)
carried
            then RegistryDuties -> Either String RegistryDuties
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RegistryDuties
forall a. Monoid a => a
mempty
            else do
                addr <- case ByteString -> Maybe Addr
addrFromBytes ByteString
owner of
                    Just Addr
a -> Addr -> Either String Addr
forall a b. b -> Either a b
Right Addr
a
                    Maybe Addr
Nothing -> Addr -> Either String Addr
forall a b. b -> Either a b
Right (Network -> ByteString -> Addr
addrFromKeyHashBytes Network
net ByteString
owner)
                -- The minimum depends on the serialised size, and the coin
                -- field is part of it, so the empty probe understates it.
                -- One more pass at the answer it gives converges.
                let at Integer
c = Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
addr (Coin -> MultiAsset -> MaryValue
MaryValue (Integer -> Coin
Coin Integer
c) (Map PolicyID (Map AssetName Integer) -> MultiAsset
MultiAsset Map PolicyID (Map AssetName Integer)
carried))
                    Coin first = getMinCoinTxOut @ConwayEra pp (at 0)
                    Coin settled = getMinCoinTxOut @ConwayEra pp (at first)
                pure mempty{rdOutputs = [at settled]}
    approvalsOn :: TxOut era -> Map PolicyID (Map AssetName Integer)
approvalsOn TxOut era
reqOut = case TxOut era
reqOut TxOut era -> Getting MaryValue (TxOut era) MaryValue -> MaryValue
forall s a. s -> Getting a s a -> a
^. Getting MaryValue (TxOut era) MaryValue
(Value era -> Const MaryValue (Value era))
-> TxOut era -> Const MaryValue (TxOut era)
forall era. EraTxOut era => Lens' (TxOut era) (Value era)
Lens' (TxOut era) (Value era)
valueTxOutL of
        MaryValue Coin
_ (MultiAsset Map PolicyID (Map AssetName Integer)
m) ->
            (PolicyID -> Map AssetName Integer -> Bool)
-> Map PolicyID (Map AssetName Integer)
-> Map PolicyID (Map AssetName Integer)
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey
                (\PolicyID
p Map AssetName Integer
_ -> PolicyID
p PolicyID -> PolicyID -> Bool
forall a. Eq a => a -> a -> Bool
== ShortByteString -> PolicyID
policyIdFromPin (CageConfig -> ShortByteString
cfgApplicationPolicy CageConfig
cfg))
                Map PolicyID (Map AssetName Integer)
m
    mintsFor :: Integer -> ByteString -> Either String RegistryDuties
mintsFor Integer
edge ByteString
key =
        [RegistryDuties] -> RegistryDuties
forall a. Monoid a => [a] -> a
mconcat
            ([RegistryDuties] -> RegistryDuties)
-> Either String [RegistryDuties] -> Either String RegistryDuties
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Integer, Integer) -> Either String RegistryDuties)
-> [(Integer, Integer)] -> Either String [RegistryDuties]
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
                ( \(Integer
kind, Integer
quantity) -> do
                    script <- case Integer
-> Map Integer (AlonzoScript ConwayEra)
-> Maybe (AlonzoScript ConwayEra)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Integer
kind (RegistryContext -> Map Integer (Script ConwayEra)
rcWitnessScripts RegistryContext
ctx) of
                        Just AlonzoScript ConwayEra
s -> AlonzoScript ConwayEra -> Either String (AlonzoScript ConwayEra)
forall a b. b -> Either a b
Right AlonzoScript ConwayEra
s
                        Maybe (AlonzoScript ConwayEra)
Nothing ->
                            String -> Either String (AlonzoScript ConwayEra)
forall a b. a -> Either a b
Left
                                ( String
"registryDuties: no witness script for kind "
                                    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
kind
                                )
                    pure
                        mempty
                            { rdMints =
                                [ ConnectedMint
                                    { cmPolicy = PolicyID (hashScript script)
                                    , cmAssets = Map.singleton (AssetName (SBS.toShort key)) quantity
                                    , cmRedeemer = RawRedeemer (PLC.Constr 0 [])
                                    , cmScript = script
                                    }
                                ]
                            }
                )
                (Integer -> [(Integer, Integer)]
deltaOf Integer
edge)
    dutiesFor :: Integer
-> ByteString
-> RequestDestination
-> p
-> Integer
-> Either String RegistryDuties
dutiesFor Integer
edge ByteString
key RequestDestination
dest p
_destAddr Integer
floorAda
        | Integer
edge Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
edgeInsertActive =
            ShortByteString
-> ByteString
-> RequestDestination
-> Integer
-> Either String RegistryDuties
deliver (CageConfig -> ShortByteString
cfgActivePolicy CageConfig
cfg) ByteString
key RequestDestination
dest Integer
floorAda
        | Integer
edge Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
edgeUpdateTerminal = ShortByteString -> ByteString -> Either String RegistryDuties
burnSource (CageConfig -> ShortByteString
cfgActivePolicy CageConfig
cfg) ByteString
key
        | Bool
otherwise =
            String -> Either String RegistryDuties
forall a b. a -> Either a b
Left (String
"registryDuties: unsupported M1 edge " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
edge)
    -- \| #177 I177-BUILDER, #236: retirement burns an active token
    --    it must first hold. `deltaOf 3` is `[(active, -1)]`
    --    with no carrier output, so the
    --    asset the mint destroys has to arrive on an input — the Lean row's
    --    witness input,
    --    the witness input carrying one active token for `r.key`.
    --
    --    Selection is exact in both directions: the policy is THIS registry's
    --    active pin and the name is THIS key, so a holder of another key or
    --    another policy is not a candidate and cannot be swept in. Exactly
    --    one candidate must hold exactly one unit; none, several, or a
    --    different quantity is the state the cage refuses `token-missing`,
    --    and the builder says so here rather than emitting a transaction
    --    whose only possible outcome is that refusal.
    burnSource :: ShortByteString -> ByteString -> Either String RegistryDuties
burnSource ShortByteString
policy ByteString
key =
        let policyId :: PolicyID
policyId = ShortByteString -> PolicyID
policyIdOf ShortByteString
policy
            name :: AssetName
name = ShortByteString -> AssetName
AssetName (ByteString -> ShortByteString
SBS.toShort ByteString
key)
            held :: TxOut era -> Integer
held TxOut era
out = case TxOut era
out TxOut era -> Getting MaryValue (TxOut era) MaryValue -> MaryValue
forall s a. s -> Getting a s a -> a
^. Getting MaryValue (TxOut era) MaryValue
(Value era -> Const MaryValue (Value era))
-> TxOut era -> Const MaryValue (TxOut era)
forall era. EraTxOut era => Lens' (TxOut era) (Value era)
Lens' (TxOut era) (Value era)
valueTxOutL of
                MaryValue Coin
_ (MultiAsset Map PolicyID (Map AssetName Integer)
m) ->
                    Integer
-> (Map AssetName Integer -> Integer)
-> Maybe (Map AssetName Integer)
-> Integer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Integer
0 (Integer -> AssetName -> Map AssetName Integer -> Integer
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Integer
0 AssetName
name) (PolicyID
-> Map PolicyID (Map AssetName Integer)
-> Maybe (Map AssetName Integer)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PolicyID
policyId Map PolicyID (Map AssetName Integer)
m)
            candidates :: [((TxIn, BabbageTxOut ConwayEra), Integer)]
candidates =
                [ ((TxIn, BabbageTxOut ConwayEra)
u, Integer
q)
                | u :: (TxIn, BabbageTxOut ConwayEra)
u@(TxIn
_, BabbageTxOut ConwayEra
o) <- RegistryContext -> [(TxIn, TxOut ConwayEra)]
rcHolderUtxos RegistryContext
ctx
                , let q :: Integer
q = TxOut ConwayEra -> Integer
forall {era}.
(Value era ~ MaryValue,
 Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTxOut era) =>
TxOut era -> Integer
held TxOut ConwayEra
BabbageTxOut ConwayEra
o
                , Integer
q Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0
                ]
        in  case [((TxIn, BabbageTxOut ConwayEra), Integer)]
candidates of
                -- #299: a holder at an application script is spent with
                -- that application's witness; one at a key is a plain
                -- input, signed by the key that owns it.
                [((TxIn, BabbageTxOut ConwayEra)
u, Integer
1)] -> RegistryDuties -> Either String RegistryDuties
forall a b. b -> Either a b
Right (RegistryDuties -> Either String RegistryDuties)
-> RegistryDuties -> Either String RegistryDuties
forall a b. (a -> b) -> a -> b
$ case (TxIn, BabbageTxOut ConwayEra) -> Maybe HolderRelease
forall {b}. (TxIn, b) -> Maybe HolderRelease
holderRelease (TxIn, BabbageTxOut ConwayEra)
u of
                    Just HolderRelease
release ->
                        RegistryDuties
forall a. Monoid a => a
mempty
                            { rdSpends =
                                [ ConnectedSpend
                                    { csUtxo = u
                                    , csRedeemer = RawRedeemer (hrRedeemer release)
                                    , csScript = hrScript release
                                    }
                                ]
                            }
                    Maybe HolderRelease
Nothing -> RegistryDuties
forall a. Monoid a => a
mempty{rdInputs = [u]}
                -- A row that exists to watch the CHAIN refuse this edge
                -- needs the transaction built, not withheld: the cage
                -- refuses `key-unknown` or `not-booked` before it ever
                -- reaches the burn, and a builder failure here would
                -- substitute its own reason for the one under test.
                -- Same flag, same reason, as the inadmissible-edge arm.
                [((TxIn, BabbageTxOut ConwayEra), Integer)]
_ | RegistryContext -> Bool
rcAllowInadmissible RegistryContext
ctx -> RegistryDuties -> Either String RegistryDuties
forall a b. b -> Either a b
Right RegistryDuties
forall a. Monoid a => a
mempty
                [((TxIn, BabbageTxOut ConwayEra)
_, Integer
q)] ->
                    String -> Either String RegistryDuties
forall a b. a -> Either a b
Left
                        ( String
"registryDuties: the holder of the active witness \
                          \for key "
                            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a. Show a => a -> String
show ByteString
key
                            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" carries "
                            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
q
                            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" of it, not exactly one"
                        )
                [] ->
                    String -> Either String RegistryDuties
forall a b. a -> Either a b
Left
                        ( String
"registryDuties: no input in hand carries the \
                          \active witness for key "
                            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a. Show a => a -> String
show ByteString
key
                            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"; an edge that burns it must consume it"
                        )
                [((TxIn, BabbageTxOut ConwayEra), Integer)]
_ ->
                    String -> Either String RegistryDuties
forall a b. a -> Either a b
Left
                        ( String
"registryDuties: more than one input carries the \
                          \active witness for key "
                            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a. Show a => a -> String
show ByteString
key
                            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"; the burn must name one source"
                        )
    -- T1/T2: the minted token lands in exactly the output the request
    -- named, carrying the datum the request carries (#419).
    deliver :: ShortByteString
-> ByteString
-> RequestDestination
-> Integer
-> Either String RegistryDuties
deliver ShortByteString
policy ByteString
key (ByteString
destAddr, Maybe Data
datum) Integer
floorAda = do
        addr <- Either String Addr
destinationAddr
        let value =
                Coin -> MultiAsset -> MaryValue
MaryValue
                    (Integer -> Coin
Coin Integer
floorAda)
                    ( 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
                            (ShortByteString -> PolicyID
policyIdOf ShortByteString
policy)
                            (AssetName -> Integer -> Map AssetName Integer
forall k a. k -> a -> Map k a
Map.singleton (ShortByteString -> AssetName
AssetName (ByteString -> ShortByteString
SBS.toShort ByteString
key)) Integer
1)
                        )
                    )
            out = case Maybe Data
datum of
                Maybe Data
Nothing -> Addr -> Value ConwayEra -> TxOut ConwayEra
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
addr MaryValue
Value ConwayEra
value
                Just Data
d -> Addr -> Value ConwayEra -> TxOut ConwayEra
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
addr MaryValue
Value ConwayEra
value TxOut ConwayEra
-> (TxOut ConwayEra -> TxOut ConwayEra) -> TxOut ConwayEra
forall a b. a -> (a -> b) -> b
& (Datum ConwayEra -> Identity (Datum ConwayEra))
-> TxOut ConwayEra -> Identity (TxOut ConwayEra)
forall era. BabbageEraTxOut era => Lens' (TxOut era) (Datum era)
Lens' (TxOut ConwayEra) (Datum ConwayEra)
datumTxOutL ((Datum ConwayEra -> Identity (Datum ConwayEra))
 -> TxOut ConwayEra -> Identity (TxOut ConwayEra))
-> Datum ConwayEra -> TxOut ConwayEra -> TxOut ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Data -> Datum ConwayEra
mkInlineDatum Data
d
        requireMinAda "destination" out
        pure mempty{rdOutputs = [out]}
      where
        destinationAddr :: Either String Addr
destinationAddr = case ByteString -> Maybe Addr
addrFromBytes ByteString
destAddr of
            Just Addr
a -> Addr -> Either String Addr
forall a b. b -> Either a b
Right Addr
a
            Maybe Addr
Nothing ->
                String -> Either String Addr
forall a b. a -> Either a b
Left
                    ( String
"registryDuties: the request names an address this \
                      \builder cannot decode: "
                        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a. Show a => a -> String
show ByteString
destAddr
                    )
    requireMinAda :: String -> BabbageTxOut ConwayEra -> Either String ()
requireMinAda String
what BabbageTxOut ConwayEra
out =
        let Coin Integer
minAda = forall era. EraTxOut era => PParams era -> TxOut era -> Coin
getMinCoinTxOut @ConwayEra PParams ConwayEra
pp TxOut ConwayEra
BabbageTxOut ConwayEra
out
            Coin Integer
got = TxOut ConwayEra
BabbageTxOut ConwayEra
out 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
        in  if Integer
got Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
minAda
                then () -> Either String ()
forall a b. b -> Either a b
Right ()
                else
                    String -> Either String ()
forall a b. a -> Either a b
Left
                        ( String
"registryDuties: the "
                            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
what
                            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" output holds "
                            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
got
                            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" lovelace, under the "
                            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
minAda
                            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" minimum"
                        )
    policyIdOf :: ShortByteString -> PolicyID
policyIdOf = ShortByteString -> PolicyID
policyIdFromPin
    -- #253: retirement (edge 3), which delivers no token owes the consumed
    -- request's deposit to its owner's key. The cage sums what one fold
    -- owes one key and counts only the outputs paying that key outside the
    -- token carriers, so each owner's deposits go out together, in one
    -- output. The approvals those requests carried (approval-asset-binding: not burned)
    -- ride back in the same output, as a rejected request's refund carries
    -- its approval; an output holding them is never ada-only, so it cannot
    -- be mistaken for a custody refund of the same address and amount.
    returnsDeposit :: Integer -> Bool
returnsDeposit Integer
edge =
        Integer
edge Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
edgeUpdateTerminal
    --
    -- #299: an application holder the fold spends releases what its
    -- application owes, to its recipient's key. That is owed in the same
    -- sum, in the same output, as every deposit the fold returns to that
    -- key: one output never pays two floors.
    depositReturns :: [(ByteString, (Integer, Map PolicyID (Map AssetName Integer)))]
-> Either String RegistryDuties
depositReturns [(ByteString, (Integer, Map PolicyID (Map AssetName Integer)))]
releases = do
        outs <- ((ByteString, (Integer, Map PolicyID (Map AssetName Integer)))
 -> Either String (BabbageTxOut ConwayEra))
-> [(ByteString, (Integer, Map PolicyID (Map AssetName Integer)))]
-> Either String [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 (ByteString, (Integer, Map PolicyID (Map AssetName Integer)))
-> Either String (BabbageTxOut ConwayEra)
depositOutput (Map ByteString (Integer, Map PolicyID (Map AssetName Integer))
-> [(ByteString, (Integer, Map PolicyID (Map AssetName Integer)))]
forall k a. Map k a -> [(k, a)]
Map.toList ([(ByteString, (Integer, Map PolicyID (Map AssetName Integer)))]
-> Map ByteString (Integer, Map PolicyID (Map AssetName Integer))
owedByOwner [(ByteString, (Integer, Map PolicyID (Map AssetName Integer)))]
releases))
        pure mempty{rdOutputs = outs}
    -- A holder is looked up only when some application releases one: a
    -- key-held witness is never keyed into the map.
    holderRelease :: (TxIn, b) -> Maybe HolderRelease
holderRelease (TxIn, b)
u
        | Map TxIn HolderRelease -> Bool
forall k a. Map k a -> Bool
Map.null (RegistryContext -> Map TxIn HolderRelease
rcHolderReleases RegistryContext
ctx) = Maybe HolderRelease
forall a. Maybe a
Nothing
        | Bool
otherwise = TxIn -> Map TxIn HolderRelease -> Maybe HolderRelease
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ((TxIn, b) -> TxIn
forall a b. (a, b) -> a
fst (TxIn, b)
u) (RegistryContext -> Map TxIn HolderRelease
rcHolderReleases RegistryContext
ctx)
    -- Only a spend under an application's release script can release:
    -- custody spends run the cage script and are never looked up.
    releasesIn :: RegistryDuties -> [(ByteString, (Integer, Map k a))]
releasesIn RegistryDuties
duties =
        [ (HolderRelease -> ByteString
hrRecipient HolderRelease
release, (HolderRelease -> Integer
hrReleased HolderRelease
release, Map k a
forall k a. Map k a
Map.empty))
        | ConnectedSpend
spend <- RegistryDuties -> [ConnectedSpend]
rdSpends RegistryDuties
duties
        , Script ConwayEra -> ScriptHash
forall era. EraScript era => Script era -> ScriptHash
hashScript (ConnectedSpend -> Script ConwayEra
csScript ConnectedSpend
spend) ScriptHash -> [ScriptHash] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ScriptHash]
releaseScripts
        , Just HolderRelease
release <-
            [TxIn -> Map TxIn HolderRelease -> Maybe HolderRelease
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ((TxIn, BabbageTxOut ConwayEra) -> TxIn
forall a b. (a, b) -> a
fst (ConnectedSpend -> (TxIn, TxOut ConwayEra)
csUtxo ConnectedSpend
spend)) (RegistryContext -> Map TxIn HolderRelease
rcHolderReleases RegistryContext
ctx)]
        ]
    releaseScripts :: [ScriptHash]
releaseScripts = (HolderRelease -> ScriptHash) -> [HolderRelease] -> [ScriptHash]
forall a b. (a -> b) -> [a] -> [b]
map (Script ConwayEra -> ScriptHash
forall era. EraScript era => Script era -> ScriptHash
hashScript (Script ConwayEra -> ScriptHash)
-> (HolderRelease -> Script ConwayEra)
-> HolderRelease
-> ScriptHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HolderRelease -> Script ConwayEra
hrScript) (Map TxIn HolderRelease -> [HolderRelease]
forall k a. Map k a -> [a]
Map.elems (RegistryContext -> Map TxIn HolderRelease
rcHolderReleases RegistryContext
ctx))
    owedByOwner :: [(ByteString, (Integer, Map PolicyID (Map AssetName Integer)))]
-> Map ByteString (Integer, Map PolicyID (Map AssetName Integer))
owedByOwner [(ByteString, (Integer, Map PolicyID (Map AssetName Integer)))]
releases =
        ((Integer, Map PolicyID (Map AssetName Integer))
 -> (Integer, Map PolicyID (Map AssetName Integer))
 -> (Integer, Map PolicyID (Map AssetName Integer)))
-> [(ByteString, (Integer, Map PolicyID (Map AssetName Integer)))]
-> Map ByteString (Integer, Map PolicyID (Map AssetName Integer))
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith
            (\(Integer
a, Map PolicyID (Map AssetName Integer)
x) (Integer
b, Map PolicyID (Map AssetName Integer)
y) -> (Integer
a Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
b, (Map AssetName Integer
 -> Map AssetName Integer -> Map AssetName Integer)
-> Map PolicyID (Map AssetName Integer)
-> Map PolicyID (Map AssetName Integer)
-> Map PolicyID (Map AssetName Integer)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith ((Integer -> Integer -> Integer)
-> Map AssetName Integer
-> Map AssetName Integer
-> Map AssetName Integer
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(+)) Map PolicyID (Map AssetName Integer)
x Map PolicyID (Map AssetName Integer)
y))
            ([(ByteString, (Integer, Map PolicyID (Map AssetName Integer)))]
 -> Map ByteString (Integer, Map PolicyID (Map AssetName Integer)))
-> [(ByteString, (Integer, Map PolicyID (Map AssetName Integer)))]
-> Map ByteString (Integer, Map PolicyID (Map AssetName Integer))
forall a b. (a -> b) -> a -> b
$ [(ByteString, (Integer, Map PolicyID (Map AssetName Integer)))]
releases
                [(ByteString, (Integer, Map PolicyID (Map AssetName Integer)))]
-> [(ByteString, (Integer, Map PolicyID (Map AssetName Integer)))]
-> [(ByteString, (Integer, Map PolicyID (Map AssetName Integer)))]
forall a. Semigroup a => a -> a -> a
<> [ (ByteString
owner, (Integer
held Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
tip, TxOut ConwayEra -> Map PolicyID (Map AssetName Integer)
forall {era}.
(Value era ~ MaryValue,
 Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTxOut era) =>
TxOut era -> Map PolicyID (Map AssetName Integer)
approvalsOn TxOut ConwayEra
BabbageTxOut ConwayEra
reqOut))
                   | ((TxIn
_, BabbageTxOut ConwayEra
reqOut), Bool
True) <- [((TxIn, BabbageTxOut ConwayEra), Bool)]
consumed
                   , Just (RequestDatum OnChainRequest
req) <- [TxOut ConwayEra -> Maybe CageDatum
extractCageDatum TxOut ConwayEra
BabbageTxOut ConwayEra
reqOut]
                   , Integer -> Bool
returnsDeposit (OnChainRequest -> Integer
requestEdge OnChainRequest
req)
                   , let BuiltinByteString ByteString
owner = OnChainRequest -> BuiltinByteString
requestOwner OnChainRequest
req
                         Coin Integer
held = BabbageTxOut ConwayEra
reqOut 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
                   ]
    depositOutput :: (ByteString, (Integer, Map PolicyID (Map AssetName Integer)))
-> Either String (BabbageTxOut ConwayEra)
depositOutput (ByteString
owner, (Integer
owed, Map PolicyID (Map AssetName Integer)
approvals)) = do
        let out :: TxOut ConwayEra
out =
                Addr -> Value ConwayEra -> TxOut ConwayEra
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut
                    (Network -> ByteString -> Addr
addrFromKeyHashBytes Network
net ByteString
owner)
                    (Coin -> MultiAsset -> MaryValue
MaryValue (Integer -> Coin
Coin Integer
owed) (Map PolicyID (Map AssetName Integer) -> MultiAsset
MultiAsset Map PolicyID (Map AssetName Integer)
approvals))
        String -> BabbageTxOut ConwayEra -> Either String ()
requireMinAda String
"deposit" TxOut ConwayEra
BabbageTxOut ConwayEra
out
        BabbageTxOut ConwayEra -> Either String (BabbageTxOut ConwayEra)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TxOut ConwayEra
BabbageTxOut ConwayEra
out