{- |
Module      : Singular.Registry.TxBuilder.Update
Description : Update token transaction — the public fold facade
License     : Apache-2.0

Builds the oracle update transaction that processes
the pending requests for a token: every one, or a chosen
non-empty set of them ('updateTokenSelected'). Consumes the
State UTxO and exactly those request UTxOs, applies each
operation speculatively through the trie to generate proofs,
then outputs a new State UTxO with the updated root and
per-request refund outputs; its validity upper bound is the
earliest deadline among the requests it folds.

This module is the fold's public orchestration and its compatibility
surface: the six exports every caller imports are re-exported
unchanged, and the two entry points coordinate the three owners the
fold's work is divided into (#267):

- "Singular.Registry.TxBuilder.Update.Context" — the registry context,
  its queries, the ordered speculative proofs, the state continuation
  and the validity slot;
- "Singular.Registry.TxBuilder.Update.Duties" — what the fold's
  requests owe (mints, destinations, custody, returns, signatures);
- "Singular.Registry.TxBuilder.Update.Build" — the evaluation adapter
  and the one transaction story language program a fold submits.

No algorithm lives here; each decision has exactly one owner above.
-}
module Singular.Registry.TxBuilder.Update
    ( updateTokenImpl
    , updateTokenWithDuties
    , updateTokenWithTrieState
    , updateTokenSelected
    , emptyRegistryContext
    , RegistryDuties (..)
    , RegistryContext (..)
    , HolderRelease (..)
    , registryDuties
    , NoCtx
    , mkEvalTx
    ) where

import Cardano.Ledger.Api.Tx.Out (TxOut)
import Control.Monad (when)
import Data.List.NonEmpty qualified as NE
import Data.Void (Void)

import Cardano.Ledger.Address (Addr)
import Cardano.Tx.Build qualified as Tx
import Cardano.Tx.Ledger (ConwayTx)

import Singular.Registry.Config
    ( CageConfig (..)
    )
import Singular.Registry.Evidence (NoWitness)
import Singular.Registry.Ledger
    ( ConwayEra
    , Root (..)
    , TokenId (..)
    , TxIn
    )
import Singular.Registry.LedgerProvider (Session)
import Singular.Registry.Trie
    ( TrieManager (..)
    )
import Singular.Registry.TrieState qualified as TS
import Singular.Registry.TxBuilder.ConnectedFold
    ( ConnectedSpend (..)
    )
import Singular.Registry.TxBuilder.Internal.Identity
import Singular.Registry.TxBuilder.Update.Build
    ( NoCtx
    , buildProgram
    , mkEvalTx
    )
import Singular.Registry.TxBuilder.Update.Context
    ( HolderRelease (..)
    , RegistryContext (..)
    , completeContext
    , computeProofs
    , computeUpperSlot
    , emptyRegistryContext
    , prepareState
    , queryContext
    )
import Singular.Registry.TxBuilder.Update.Duties
    ( RegistryDuties (..)
    , registryDuties
    )
import Singular.Registry.Types
    ( CageDatum (..)
    , OnChainRequest (..)
    , OnChainRoot (..)
    , OnChainTokenState (..)
    , ProofStep
    )

-- | Build an update-token transaction (fair fee).
updateTokenImpl
    :: CageConfig
    -> Session NoWitness IO
    -> TrieManager IO
    -> TokenId
    -> Addr
    -> IO ConwayTx
updateTokenImpl :: CageConfig
-> Session NoWitness IO
-> TrieManager IO
-> TokenId
-> Addr
-> IO ConwayTx
updateTokenImpl CageConfig
cfg Session NoWitness IO
view TrieManager IO
tm TokenId
tid Addr
addr =
    CageConfig
-> Session NoWitness IO
-> TrieManager IO
-> TokenId
-> Addr
-> RegistryContext
-> IO ConwayTx
updateTokenWithDuties CageConfig
cfg Session NoWitness IO
view TrieManager IO
tm TokenId
tid Addr
addr RegistryContext
emptyRegistryContext

{- | Fold the pending requests, discharging every obligation the edges
they take create (#157 mint-matches-edge-deltas, token-destinations-and-refunds, T1-T6).
-}
updateTokenWithDuties
    :: CageConfig
    -> Session NoWitness IO
    -> TrieManager IO
    -> TokenId
    -> Addr
    -> RegistryContext
    -> IO ConwayTx
updateTokenWithDuties :: CageConfig
-> Session NoWitness IO
-> TrieManager IO
-> TokenId
-> Addr
-> RegistryContext
-> IO ConwayTx
updateTokenWithDuties CageConfig
cfg Session NoWitness IO
view TrieManager IO
tm TokenId
tid Addr
addr RegistryContext
ctx0 =
    CageConfig
-> Session NoWitness IO
-> TokenId
-> Addr
-> RegistryContext
-> Maybe (NonEmpty TxIn)
-> ((TxIn, TxOut ConwayEra)
    -> [(TxIn, TxOut ConwayEra)] -> IO ([[ProofStep]], Root))
-> IO ConwayTx
updateTokenUsing
        CageConfig
cfg
        Session NoWitness IO
view
        TokenId
tid
        Addr
addr
        RegistryContext
ctx0
        Maybe (NonEmpty TxIn)
forall a. Maybe a
Nothing
        (([(TxIn, BabbageTxOut ConwayEra)] -> IO ([[ProofStep]], Root))
-> (TxIn, BabbageTxOut ConwayEra)
-> [(TxIn, BabbageTxOut ConwayEra)]
-> IO ([[ProofStep]], Root)
forall a b. a -> b -> a
const (TrieManager IO
-> TokenId -> [(TxIn, TxOut ConwayEra)] -> IO ([[ProofStep]], Root)
computeProofs TrieManager IO
tm TokenId
tid))

{- | The current command path obtains its consumed proof bytes and new root
from the selected capability snapshot. Transaction duties and provider reads
remain in the same shared builder as the retained lower-level adapters.
-}
updateTokenWithTrieState
    :: CageConfig
    -> Session NoWitness IO
    -> TS.TrieSnapshot IO
    -> TokenId
    -> Addr
    -> RegistryContext
    -> IO ConwayTx
updateTokenWithTrieState :: CageConfig
-> Session NoWitness IO
-> TrieSnapshot IO
-> TokenId
-> Addr
-> RegistryContext
-> IO ConwayTx
updateTokenWithTrieState = Maybe (NonEmpty TxIn)
-> CageConfig
-> Session NoWitness IO
-> TrieSnapshot IO
-> TokenId
-> Addr
-> RegistryContext
-> IO ConwayTx
updateTokenFrom Maybe (NonEmpty TxIn)
forall a. Maybe a
Nothing

-- | The snapshot fold over the chosen pending requests, or over every one.
updateTokenFrom
    :: Maybe (NE.NonEmpty TxIn)
    -> CageConfig
    -> Session NoWitness IO
    -> TS.TrieSnapshot IO
    -> TokenId
    -> Addr
    -> RegistryContext
    -> IO ConwayTx
updateTokenFrom :: Maybe (NonEmpty TxIn)
-> CageConfig
-> Session NoWitness IO
-> TrieSnapshot IO
-> TokenId
-> Addr
-> RegistryContext
-> IO ConwayTx
updateTokenFrom Maybe (NonEmpty TxIn)
selected CageConfig
cfg Session NoWitness IO
view TrieSnapshot IO
snap tid :: TokenId
tid@(TokenId AssetName
name) Addr
addr RegistryContext
ctx0 =
    CageConfig
-> Session NoWitness IO
-> TokenId
-> Addr
-> RegistryContext
-> Maybe (NonEmpty TxIn)
-> ((TxIn, TxOut ConwayEra)
    -> [(TxIn, TxOut ConwayEra)] -> IO ([[ProofStep]], Root))
-> IO ConwayTx
updateTokenUsing CageConfig
cfg Session NoWitness IO
view TokenId
tid Addr
addr RegistryContext
ctx0 Maybe (NonEmpty TxIn)
selected (((TxIn, TxOut ConwayEra)
  -> [(TxIn, TxOut ConwayEra)] -> IO ([[ProofStep]], Root))
 -> IO ConwayTx)
-> ((TxIn, TxOut ConwayEra)
    -> [(TxIn, TxOut ConwayEra)] -> IO ([[ProofStep]], Root))
-> IO ConwayTx
forall a b. (a -> b) -> a -> b
$ \(TxIn
stateIn, TxOut ConwayEra
stateOut) [(TxIn, TxOut ConwayEra)]
requests -> do
        let expected :: RegistryIdentity
expected =
                StatePolicyId -> AssetName -> RegistryIdentity
TS.RegistryIdentity
                    (ByteString -> StatePolicyId
TS.StatePolicyId (ScriptHash -> ByteString
scriptHashBytes (CageConfig -> ScriptHash
cfgScriptHash CageConfig
cfg)))
                    AssetName
name
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
            (TrieSnapshot IO -> RegistryIdentity
forall (m :: * -> *). TrieSnapshot m -> RegistryIdentity
TS.trieIdentity TrieSnapshot IO
snap RegistryIdentity -> RegistryIdentity -> Bool
forall a. Eq a => a -> a -> Bool
/= RegistryIdentity
expected)
            ([Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"TrieState WrongRegistry")
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
            (StatePoint -> TxIn
TS.pointOutput (TrieSnapshot IO -> StatePoint
forall (m :: * -> *). TrieSnapshot m -> StatePoint
TS.triePoint TrieSnapshot IO
snap) TxIn -> TxIn -> Bool
forall a. Eq a => a -> a -> Bool
/= TxIn
stateIn)
            ([Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"TrieState StaleState")
        case TxOut ConwayEra -> Maybe CageDatum
extractCageDatum TxOut ConwayEra
stateOut of
            Just (StateDatum OnChainTokenState
state)
                | OnChainRoot -> ByteString
unOnChainRoot (OnChainTokenState -> OnChainRoot
stateRoot OnChainTokenState
state) ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== Root -> ByteString
unRoot (TrieSnapshot IO -> Root
forall (m :: * -> *). TrieSnapshot m -> Root
TS.trieRoot TrieSnapshot IO
snap) ->
                    () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Maybe CageDatum
_ -> [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"TrieState StaleState"
        moves <- case ((TxIn, BabbageTxOut ConwayEra) -> Maybe (ByteString, Edge))
-> [(TxIn, BabbageTxOut ConwayEra)] -> Maybe [(ByteString, Edge)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (TxIn, BabbageTxOut ConwayEra) -> Maybe (ByteString, Edge)
forall {a}. (a, BabbageTxOut ConwayEra) -> Maybe (ByteString, Edge)
requestEdgeOf [(TxIn, TxOut ConwayEra)]
[(TxIn, BabbageTxOut ConwayEra)]
requests Maybe [(ByteString, Edge)]
-> ([(ByteString, Edge)] -> Maybe (NonEmpty (ByteString, Edge)))
-> Maybe (NonEmpty (ByteString, Edge))
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [(ByteString, Edge)] -> Maybe (NonEmpty (ByteString, Edge))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty of
            Maybe (NonEmpty (ByteString, Edge))
Nothing -> [Char] -> IO (NonEmpty (ByteString, Edge))
forall a. HasCallStack => [Char] -> a
error [Char]
"TrieState UndecodableRequest"
            Just NonEmpty (ByteString, Edge)
ordered -> NonEmpty (ByteString, Edge) -> IO (NonEmpty (ByteString, Edge))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NonEmpty (ByteString, Edge)
ordered
        walked <-
            TS.speculateEdges snap moves
                >>= either (error . ("TrieState " <>) . show) pure
        pure (TS.walkProofs walked, TS.walkRoot walked)
  where
    requestEdgeOf :: (a, BabbageTxOut ConwayEra) -> Maybe (ByteString, Edge)
requestEdgeOf (a
_, BabbageTxOut ConwayEra
out) = case TxOut ConwayEra -> Maybe CageDatum
extractCageDatum TxOut ConwayEra
BabbageTxOut ConwayEra
out of
        Just (RequestDatum OnChainRequest
request) -> (ByteString, Edge) -> Maybe (ByteString, Edge)
forall a. a -> Maybe a
Just (OnChainRequest -> ByteString
requestKey OnChainRequest
request, OnChainRequest -> Edge
requestEdge OnChainRequest
request)
        Maybe CageDatum
_ -> Maybe (ByteString, Edge)
forall a. Maybe a
Nothing

{- | Fold the chosen pending requests and no other, from the selected
capability snapshot; the validity upper bound is the earliest deadline among
them.
-}
updateTokenSelected
    :: CageConfig
    -> Session NoWitness IO
    -> TS.TrieSnapshot IO
    -> TokenId
    -> Addr
    -> RegistryContext
    -> NE.NonEmpty TxIn
    -> IO ConwayTx
updateTokenSelected :: CageConfig
-> Session NoWitness IO
-> TrieSnapshot IO
-> TokenId
-> Addr
-> RegistryContext
-> NonEmpty TxIn
-> IO ConwayTx
updateTokenSelected CageConfig
cfg Session NoWitness IO
view TrieSnapshot IO
snap TokenId
tid Addr
addr RegistryContext
ctx0 NonEmpty TxIn
selected =
    Maybe (NonEmpty TxIn)
-> CageConfig
-> Session NoWitness IO
-> TrieSnapshot IO
-> TokenId
-> Addr
-> RegistryContext
-> IO ConwayTx
updateTokenFrom (NonEmpty TxIn -> Maybe (NonEmpty TxIn)
forall a. a -> Maybe a
Just NonEmpty TxIn
selected) CageConfig
cfg Session NoWitness IO
view TrieSnapshot IO
snap TokenId
tid Addr
addr RegistryContext
ctx0

updateTokenUsing
    :: CageConfig
    -> Session NoWitness IO
    -> TokenId
    -> Addr
    -> RegistryContext
    -> Maybe (NE.NonEmpty TxIn)
    -- ^ The pending requests to fold; every one when absent
    -> ( (TxIn, TxOut ConwayEra)
         -> [(TxIn, TxOut ConwayEra)]
         -> IO ([[ProofStep]], Root)
       )
    -> IO ConwayTx
updateTokenUsing :: CageConfig
-> Session NoWitness IO
-> TokenId
-> Addr
-> RegistryContext
-> Maybe (NonEmpty TxIn)
-> ((TxIn, TxOut ConwayEra)
    -> [(TxIn, TxOut ConwayEra)] -> IO ([[ProofStep]], Root))
-> IO ConwayTx
updateTokenUsing CageConfig
cfg Session NoWitness IO
view TokenId
tid Addr
addr RegistryContext
ctx0 Maybe (NonEmpty TxIn)
selected (TxIn, TxOut ConwayEra)
-> [(TxIn, TxOut ConwayEra)] -> IO ([[ProofStep]], Root)
makeProofs = do
    (stateUtxo, pending, feeUtxo, pp) <-
        Maybe (NonEmpty TxIn)
-> CageConfig
-> Session NoWitness IO
-> TokenId
-> Addr
-> IO
     ((TxIn, TxOut ConwayEra), [(TxIn, TxOut ConwayEra)],
      (TxIn, TxOut ConwayEra), PParams ConwayEra)
queryContext Maybe (NonEmpty TxIn)
selected CageConfig
cfg Session NoWitness IO
view TokenId
tid Addr
addr
    reqUtxos <- case selected of
        Maybe (NonEmpty TxIn)
Nothing -> [(TxIn, BabbageTxOut ConwayEra)]
-> IO [(TxIn, BabbageTxOut ConwayEra)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(TxIn, BabbageTxOut ConwayEra)]
pending
        Just NonEmpty TxIn
chosen -> case (TxIn -> Bool) -> [TxIn] -> [TxIn]
forall a. (a -> Bool) -> [a] -> [a]
filter (TxIn -> [TxIn] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` ((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)]
pending) (NonEmpty TxIn -> [TxIn]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty TxIn
chosen) of
            [] -> [(TxIn, BabbageTxOut ConwayEra)]
-> IO [(TxIn, BabbageTxOut ConwayEra)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((TxIn, BabbageTxOut ConwayEra) -> Bool)
-> [(TxIn, BabbageTxOut ConwayEra)]
-> [(TxIn, BabbageTxOut ConwayEra)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((TxIn -> [TxIn] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` NonEmpty TxIn -> [TxIn]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty TxIn
chosen) (TxIn -> Bool)
-> ((TxIn, BabbageTxOut ConwayEra) -> TxIn)
-> (TxIn, BabbageTxOut ConwayEra)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxIn, BabbageTxOut ConwayEra) -> TxIn
forall a b. (a, b) -> a
fst) [(TxIn, BabbageTxOut ConwayEra)]
pending)
            [TxIn]
missing ->
                [Char] -> IO [(TxIn, BabbageTxOut ConwayEra)]
forall a. HasCallStack => [Char] -> a
error
                    ( [Char]
"updateToken: selected requests not pending: "
                        [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [TxIn] -> [Char]
forall a. Show a => a -> [Char]
show [TxIn]
missing
                    )
    let (stateIn, stateOut) = stateUtxo
    (proofs, newRoot) <-
        makeProofs stateUtxo reqUtxos
    let (oldState, newStateOut, script) =
            prepareState
                cfg
                stateOut
                newRoot
        requestScript = CageConfig -> TokenId -> Script ConwayEra
mkRequestScript CageConfig
cfg TokenId
tid
    ctx <-
        completeContext cfg view addr script ctx0
    duties <- case registryDuties
        cfg
        pp
        oldState
        ctx
        reqUtxos
        (map (const True) reqUtxos) of
        Right RegistryDuties
d -> RegistryDuties -> IO RegistryDuties
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RegistryDuties
d
        Left [Char]
err -> [Char] -> IO RegistryDuties
forall a. HasCallStack => [Char] -> a
error ([Char]
"updateToken: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
err)
    upperSlot <-
        computeUpperSlot view oldState reqUtxos
    let evalTx = Session NoWitness IO
-> ConwayTx
-> IO
     (Map (ConwayPlutusPurpose AsIx ConwayEra) (Either [Char] ExUnits))
mkEvalTx Session NoWitness IO
view
        prog =
            CageConfig
-> PParams ConwayEra
-> TxIn
-> TxOut ConwayEra
-> [(TxIn, TxOut ConwayEra)]
-> (TxIn, TxOut ConwayEra)
-> OnChainTokenState
-> TxOut ConwayEra
-> Script ConwayEra
-> Script ConwayEra
-> [[ProofStep]]
-> SlotNo
-> RegistryDuties
-> [(TxIn, TxOut ConwayEra)]
-> TxBuild NoCtx Void ()
buildProgram
                CageConfig
cfg
                PParams ConwayEra
pp
                TxIn
stateIn
                TxOut ConwayEra
BabbageTxOut ConwayEra
stateOut
                [(TxIn, TxOut ConwayEra)]
[(TxIn, BabbageTxOut ConwayEra)]
reqUtxos
                (TxIn, TxOut ConwayEra)
(TxIn, BabbageTxOut ConwayEra)
feeUtxo
                OnChainTokenState
oldState
                TxOut ConwayEra
BabbageTxOut ConwayEra
newStateOut
                AlonzoScript ConwayEra
Script ConwayEra
script
                AlonzoScript ConwayEra
Script ConwayEra
requestScript
                [[ProofStep]]
proofs
                SlotNo
upperSlot
                RegistryDuties
duties
                (RegistryContext -> [(TxIn, TxOut ConwayEra)]
rcRefUtxos RegistryContext
ctx)
    result <-
        Tx.build
            (Tx.mkPParamsBound pp)
            (Tx.InterpretIO (const (pure undefined)))
            evalTx
            ( feeUtxo
                : stateUtxo
                : reqUtxos
                    <> map csUtxo (rdSpends duties)
                    <> rdInputs duties
            )
            (rcRefUtxos ctx)
            addr
            (prog :: Tx.TxBuild NoCtx Void ())
    case result of
        Right ConwayTx
tx -> ConwayTx -> IO ConwayTx
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConwayTx
tx
        Left BuildError Void
err ->
            [Char] -> IO ConwayTx
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO ConwayTx) -> [Char] -> IO ConwayTx
forall a b. (a -> b) -> a -> b
$
                [Char]
"updateToken: build failed: "
                    [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> BuildError Void -> [Char]
forall a. Show a => a -> [Char]
show BuildError Void
err