{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase #-}

{- |
Module      : Singular.Registry.TxBuilder.ConnectedFold
Description : Permissionless connected fold with attached actions
License     : Apache-2.0

One transaction binding the full insert journey: the registry state
UTxO spent through @Modify@ with trie proofs, every registry request
consumed with @Contribute@, plus caller-attached spends (naming claims),
mints (approvals, representatives) and outputs (naming records). No
owner signature anywhere — the #79 permissionless repair made @Modify@
owner-free, and this builder never asks for one.

This is the single canonical permissionless-fold implementation for
issue #77's runners (register, recovery, retirement). Its lineage is
@offchain/journey/repair/Main.hs@'s @foldRequestsTx@ \/
@buildPermissionlessProgram@ (issue #79, frozen): the registry program,
proof computation, upper-slot rule and refund rule are transcribed from
there, extended with the attached naming actions. The repair runner
keeps its own copy; nothing here changes it.
-}
module Singular.Registry.TxBuilder.ConnectedFold
    ( RawRedeemer (..)
    , ConnectedSpend (..)
    , ConnectedMint (..)
    , ConnectedFoldArgs (..)
    , connectedFoldTx
    , syncFoldedRequests
    , generousUnits
    , skipEvalUnits
    ) where

import Data.Map.Strict qualified as Map
import Data.Time.Clock (getCurrentTime)
import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
import Data.Void (Void)
import Lens.Micro ((&), (.~), (^.))
import PlutusCore.Data qualified as PLC

import Cardano.Ledger.Address (Addr)
import Cardano.Ledger.Api.PParams
    ( ppMaxBlockExUnitsL
    , ppMaxTxExUnitsL
    )
import Cardano.Ledger.Api.Tx (bodyTxL, witsTxL)
import Cardano.Ledger.Api.Tx.Body (feeTxBodyL)
import Cardano.Ledger.Api.Tx.Out
    ( TxOut
    , datumTxOutL
    , mkBasicTxOut
    , valueTxOutL
    )
import Cardano.Ledger.Api.Tx.Wits (Redeemers (..), rdmrsTxWitsL)
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Core (Script)
import Cardano.Ledger.Keys (KeyHash, KeyRole (..))
import Cardano.Ledger.Mary.Value (AssetName, PolicyID)
import Cardano.Ledger.Plutus.ExUnits (ExUnits (..))
import Cardano.Slotting.Slot (SlotNo)
import PlutusTx.Builtins.Internal (BuiltinData (..))
import PlutusTx.IsData.Class (ToData (..))

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, TipObservation (..))
import Singular.Registry.SessionIO (parameters)
import Singular.Registry.SessionIO qualified as Services
import Singular.Registry.Trie
    ( Trie (..)
    , TrieManager (..)
    )
import Singular.Registry.TxBuilder.Internal.Edges
import Singular.Registry.TxBuilder.Internal.Identity
import Singular.Registry.TxBuilder.Internal.Lookup
import Singular.Registry.Types
    ( CageDatum (..)
    , OnChainRequest (..)
    , OnChainRoot (..)
    , OnChainTokenState (..)
    , ProofStep
    , RequestAction (..)
    , UpdateRedeemer (..)
    )

-- | A raw Plutus-data redeemer for attached (non-registry) purposes.
newtype RawRedeemer = RawRedeemer PLC.Data
    deriving stock (RawRedeemer -> RawRedeemer -> Bool
(RawRedeemer -> RawRedeemer -> Bool)
-> (RawRedeemer -> RawRedeemer -> Bool) -> Eq RawRedeemer
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RawRedeemer -> RawRedeemer -> Bool
== :: RawRedeemer -> RawRedeemer -> Bool
$c/= :: RawRedeemer -> RawRedeemer -> Bool
/= :: RawRedeemer -> RawRedeemer -> Bool
Eq, Int -> RawRedeemer -> ShowS
[RawRedeemer] -> ShowS
RawRedeemer -> [Char]
(Int -> RawRedeemer -> ShowS)
-> (RawRedeemer -> [Char])
-> ([RawRedeemer] -> ShowS)
-> Show RawRedeemer
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RawRedeemer -> ShowS
showsPrec :: Int -> RawRedeemer -> ShowS
$cshow :: RawRedeemer -> [Char]
show :: RawRedeemer -> [Char]
$cshowList :: [RawRedeemer] -> ShowS
showList :: [RawRedeemer] -> ShowS
Show)

instance ToData RawRedeemer where
    toBuiltinData :: RawRedeemer -> BuiltinData
toBuiltinData (RawRedeemer Data
d) = Data -> BuiltinData
BuiltinData Data
d

-- | An attached script spend (a naming claim).
data ConnectedSpend = ConnectedSpend
    { ConnectedSpend -> (TxIn, TxOut ConwayEra)
csUtxo :: (TxIn, TxOut ConwayEra)
    , ConnectedSpend -> RawRedeemer
csRedeemer :: RawRedeemer
    , ConnectedSpend -> Script ConwayEra
csScript :: Script ConwayEra
    }

-- | An attached mint or burn under a caller script.
data ConnectedMint = ConnectedMint
    { ConnectedMint -> PolicyID
cmPolicy :: PolicyID
    , ConnectedMint -> Map AssetName Integer
cmAssets :: Map.Map AssetName Integer
    , ConnectedMint -> RawRedeemer
cmRedeemer :: RawRedeemer
    , ConnectedMint -> Script ConwayEra
cmScript :: Script ConwayEra
    }

-- | Everything one connected fold binds.
data ConnectedFoldArgs = ConnectedFoldArgs
    { ConnectedFoldArgs -> CageConfig
cfaCfg :: CageConfig
    , ConnectedFoldArgs -> Session NoWitness IO
cfaSession :: Session NoWitness IO
    -- ^ The view the fold is built from: parameters, evaluation, slots
    , ConnectedFoldArgs -> TrieManager IO
cfaTrie :: TrieManager IO
    , ConnectedFoldArgs -> TokenId
cfaToken :: TokenId
    , ConnectedFoldArgs -> Addr
cfaFeeAddr :: Addr
    , ConnectedFoldArgs -> (TxIn, TxOut ConwayEra)
cfaStateUtxo :: (TxIn, TxOut ConwayEra)
    , ConnectedFoldArgs -> [(TxIn, TxOut ConwayEra)]
cfaReqUtxos :: [(TxIn, TxOut ConwayEra)]
    , ConnectedFoldArgs -> (TxIn, TxOut ConwayEra)
cfaFeeUtxo :: (TxIn, TxOut ConwayEra)
    , ConnectedFoldArgs -> [ConnectedSpend]
cfaSpends :: [ConnectedSpend]
    , ConnectedFoldArgs -> [ConnectedMint]
cfaMints :: [ConnectedMint]
    , ConnectedFoldArgs -> [TxOut ConwayEra]
cfaOutputs :: [TxOut ConwayEra]
    , ConnectedFoldArgs -> [KeyHash Guard]
cfaSigners :: [KeyHash Guard]
    , ConnectedFoldArgs -> [(TxIn, TxOut ConwayEra)]
cfaRefUtxos :: [(TxIn, TxOut ConwayEra)]
    , ConnectedFoldArgs -> [Script ConwayEra]
cfaAttachScripts :: [Script ConwayEra]
    , ConnectedFoldArgs -> Bool
cfaSkipEval :: Bool
    {- ^ Skip local script evaluation, stating generous budgets instead,
    so the LEDGER executes every purpose for real. Adversarial use
    only: the duplicate fold must be refused on-chain (attributed to
    the refusing script) rather than at local estimation.
    -}
    , ConnectedFoldArgs -> Root -> Root
cfaAdjustRoot :: Root -> Root
    }

{- | Build the connected fold transaction (unsigned), returning the
computed new root the state continuation carries.
-}
connectedFoldTx :: ConnectedFoldArgs -> IO (ConwayTx, Root)
connectedFoldTx :: ConnectedFoldArgs -> IO (ConwayTx, Root)
connectedFoldTx ConnectedFoldArgs
args = do
    let cfg :: CageConfig
cfg = ConnectedFoldArgs -> CageConfig
cfaCfg ConnectedFoldArgs
args
        view :: Session NoWitness IO
view = ConnectedFoldArgs -> Session NoWitness IO
cfaSession ConnectedFoldArgs
args
        tm :: TrieManager IO
tm = ConnectedFoldArgs -> TrieManager IO
cfaTrie ConnectedFoldArgs
args
        tid :: TokenId
tid = ConnectedFoldArgs -> TokenId
cfaToken ConnectedFoldArgs
args
        feeAddr :: Addr
feeAddr = ConnectedFoldArgs -> Addr
cfaFeeAddr ConnectedFoldArgs
args
        (TxIn
stateIn, TxOut ConwayEra
stateOut) = ConnectedFoldArgs -> (TxIn, TxOut ConwayEra)
cfaStateUtxo ConnectedFoldArgs
args
        reqUtxos :: [(TxIn, TxOut ConwayEra)]
reqUtxos = ConnectedFoldArgs -> [(TxIn, TxOut ConwayEra)]
cfaReqUtxos ConnectedFoldArgs
args
        feeUtxo :: (TxIn, TxOut ConwayEra)
feeUtxo = ConnectedFoldArgs -> (TxIn, TxOut ConwayEra)
cfaFeeUtxo ConnectedFoldArgs
args
    pp <- Session NoWitness IO -> IO (PParams ConwayEra)
forall w. Session w IO -> IO (PParams ConwayEra)
parameters Session NoWitness IO
view
    (proofs, newRoot) <- computeProofs tm tid reqUtxos
    let adjustedRoot = ConnectedFoldArgs -> Root -> Root
cfaAdjustRoot ConnectedFoldArgs
args Root
newRoot
        (oldState, newStateOut, script) =
            prepareState cfg stateOut adjustedRoot
        requestScript = CageConfig -> TokenId -> Script ConwayEra
mkRequestScript CageConfig
cfg TokenId
tid
    upperSlot <- computeUpperSlot view oldState reqUtxos
    let evalTx
            | ConnectedFoldArgs -> Bool
cfaSkipEval ConnectedFoldArgs
args = \ConwayTx
tx -> do
                let Redeemers Map (PlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
rdmrs = ConwayTx
tx ConwayTx
-> Getting (Redeemers ConwayEra) ConwayTx (Redeemers ConwayEra)
-> Redeemers ConwayEra
forall s a. s -> Getting a s a -> a
^. (TxWits ConwayEra
 -> Const (Redeemers ConwayEra) (TxWits ConwayEra))
-> ConwayTx -> Const (Redeemers ConwayEra) ConwayTx
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxWits ConwayEra)
witsTxL ((TxWits ConwayEra
  -> Const (Redeemers ConwayEra) (TxWits ConwayEra))
 -> ConwayTx -> Const (Redeemers ConwayEra) ConwayTx)
-> ((Redeemers ConwayEra
     -> Const (Redeemers ConwayEra) (Redeemers ConwayEra))
    -> TxWits ConwayEra
    -> Const (Redeemers ConwayEra) (TxWits ConwayEra))
-> Getting (Redeemers ConwayEra) ConwayTx (Redeemers ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redeemers ConwayEra
 -> Const (Redeemers ConwayEra) (Redeemers ConwayEra))
-> TxWits ConwayEra
-> Const (Redeemers ConwayEra) (TxWits ConwayEra)
forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
Lens' (TxWits ConwayEra) (Redeemers ConwayEra)
rdmrsTxWitsL
                    units :: ExUnits
units =
                        ExUnits -> ExUnits -> Int -> ExUnits
skipEvalUnits
                            (PParams ConwayEra
pp PParams ConwayEra
-> Getting ExUnits (PParams ConwayEra) ExUnits -> ExUnits
forall s a. s -> Getting a s a -> a
^. Getting ExUnits (PParams ConwayEra) ExUnits
forall era. AlonzoEraPParams era => Lens' (PParams era) ExUnits
Lens' (PParams ConwayEra) ExUnits
ppMaxTxExUnitsL)
                            (PParams ConwayEra
pp PParams ConwayEra
-> Getting ExUnits (PParams ConwayEra) ExUnits -> ExUnits
forall s a. s -> Getting a s a -> a
^. Getting ExUnits (PParams ConwayEra) ExUnits
forall era. AlonzoEraPParams era => Lens' (PParams era) ExUnits
Lens' (PParams ConwayEra) ExUnits
ppMaxBlockExUnitsL)
                            (Map (PlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits) -> Int
forall k a. Map k a -> Int
Map.size Map (PlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
rdmrs)
                Map (ConwayPlutusPurpose AsIx ConwayEra) (Either [Char] ExUnits)
-> IO
     (Map (ConwayPlutusPurpose AsIx ConwayEra) (Either [Char] ExUnits))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((Data ConwayEra, ExUnits) -> Either [Char] ExUnits)
-> Map
     (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
-> Map (ConwayPlutusPurpose AsIx ConwayEra) (Either [Char] ExUnits)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Either [Char] ExUnits
-> (Data ConwayEra, ExUnits) -> Either [Char] ExUnits
forall a b. a -> b -> a
const (ExUnits -> Either [Char] ExUnits
forall a b. b -> Either a b
Right ExUnits
units)) Map (PlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
Map (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
rdmrs)
            | Bool
otherwise = \ConwayTx
tx -> do
                r <- Session NoWitness IO -> ConwayTx -> IO (EvaluateTxResult ConwayEra)
forall w.
Session w IO -> ConwayTx -> IO (EvaluateTxResult ConwayEra)
Services.evaluateTx Session NoWitness IO
view ConwayTx
tx
                pure $
                    Map.map
                        ( \case
                            Left TransactionScriptFailure ConwayEra
e -> [Char] -> Either [Char] ExUnits
forall a b. a -> Either a b
Left (TransactionScriptFailure ConwayEra -> [Char]
forall a. Show a => a -> [Char]
show TransactionScriptFailure ConwayEra
e)
                            Right ExUnits
eu -> ExUnits -> Either [Char] ExUnits
forall a b. b -> Either a b
Right ExUnits
eu
                        )
                        r
        prog =
            CageConfig
-> TxIn
-> [(TxIn, TxOut ConwayEra)]
-> (TxIn, TxOut ConwayEra)
-> OnChainTokenState
-> TxOut ConwayEra
-> Script ConwayEra
-> Script ConwayEra
-> [[ProofStep]]
-> SlotNo
-> [ConnectedSpend]
-> [ConnectedMint]
-> [TxOut ConwayEra]
-> [KeyHash Guard]
-> [(TxIn, TxOut ConwayEra)]
-> [Script ConwayEra]
-> TxBuild NoCtx Void ()
buildProgram
                CageConfig
cfg
                TxIn
stateIn
                [(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
                (ConnectedFoldArgs -> [ConnectedSpend]
cfaSpends ConnectedFoldArgs
args)
                (ConnectedFoldArgs -> [ConnectedMint]
cfaMints ConnectedFoldArgs
args)
                (ConnectedFoldArgs -> [TxOut ConwayEra]
cfaOutputs ConnectedFoldArgs
args)
                (ConnectedFoldArgs -> [KeyHash Guard]
cfaSigners ConnectedFoldArgs
args)
                (ConnectedFoldArgs -> [(TxIn, TxOut ConwayEra)]
cfaRefUtxos ConnectedFoldArgs
args)
                (ConnectedFoldArgs -> [Script ConwayEra]
cfaAttachScripts ConnectedFoldArgs
args)
        spendUtxos = (ConnectedSpend -> (TxIn, BabbageTxOut ConwayEra))
-> [ConnectedSpend] -> [(TxIn, BabbageTxOut ConwayEra)]
forall a b. (a -> b) -> [a] -> [b]
map ConnectedSpend -> (TxIn, TxOut ConwayEra)
ConnectedSpend -> (TxIn, BabbageTxOut ConwayEra)
csUtxo (ConnectedFoldArgs -> [ConnectedSpend]
cfaSpends ConnectedFoldArgs
args)
    result <-
        Tx.build
            (Tx.mkPParamsBound pp)
            (Tx.InterpretIO (const (pure undefined)))
            evalTx
            (feeUtxo : cfaStateUtxo args : reqUtxos ++ spendUtxos)
            (cfaRefUtxos args)
            feeAddr
            (prog :: Tx.TxBuild NoCtx Void ())
    case result of
        Right ConwayTx
tx -> (ConwayTx, Root) -> IO (ConwayTx, Root)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConwayTx
tx, Root
newRoot)
        Left BuildError Void
err -> [Char] -> IO (ConwayTx, Root)
forall a. HasCallStack => [Char] -> a
error ([Char]
"connectedFold: build failed: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> BuildError Void -> [Char]
forall a. Show a => a -> [Char]
show BuildError Void
err)

{- | Generous per-purpose budget stated when local evaluation is
skipped (adversarial path only); the ledger re-executes for real.
Sized 2026-09-13 from MEASURED minima (NOTE-023): the crosswired
exhibit tx overspent 3M mem (needed 5.39M+ and counting — the error
reports the next step only, not completion) and 200M cpu (needed
200.05M+); the honest consumer measures 295M cpu on tiny Aiken
fixtures; the full-fold app script likewise exceeds 3M/200M (double
budget failure on the same tx). 14M mem / 1B steps per purpose sits
at 10% of this devnet's tx limits (140M mem / 10B steps) with ~3x
headroom over every measured minimum; stated fees (~0.9 ADA/purpose)
stay covered by folder funding (balance fails loudly otherwise).
Revisit if ledgers tighten limits or scripts grow.
-}
generousUnits :: ExUnits
generousUnits :: ExUnits
generousUnits = Natural -> Natural -> ExUnits
ExUnits Natural
14_000_000 Natural
1_000_000_000

{- | The units stated for each of @n@ purposes when local evaluation is
skipped: 'generousUnits', lowered where needed so that their sum fits both
the transaction limit and the block limit. A transaction whose stated
units exceed the block limit passes the mempool's per-transaction check
yet can never be included in a block, so it waits for ever.
-}
skipEvalUnits :: ExUnits -> ExUnits -> Int -> ExUnits
skipEvalUnits :: ExUnits -> ExUnits -> Int -> ExUnits
skipEvalUnits ExUnits
txLimit ExUnits
blockLimit Int
n =
    let share :: a -> a
share a
limit = a
limit a -> a -> a
forall a. Integral a => a -> a -> a
`div` Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 Int
n)
        ExUnits Natural
gMem Natural
gSteps = ExUnits
generousUnits
        ExUnits Natural
tMem Natural
tSteps = ExUnits
txLimit
        ExUnits Natural
bMem Natural
bSteps = ExUnits
blockLimit
    in  Natural -> Natural -> ExUnits
ExUnits
            ([Natural] -> Natural
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Natural
gMem, Natural -> Natural
forall {a}. Integral a => a -> a
share Natural
tMem, Natural -> Natural
forall {a}. Integral a => a -> a
share Natural
bMem])
            ([Natural] -> Natural
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Natural
gSteps, Natural -> Natural
forall {a}. Integral a => a -> a
share Natural
tSteps, Natural -> Natural
forall {a}. Integral a => a -> a
share Natural
bSteps])

-- | Empty query generalized algebraic data type (no context needed).
data NoCtx a

-- | Run speculative trie operations to compute proofs and the new root.
computeProofs
    :: TrieManager IO
    -> TokenId
    -> [(TxIn, TxOut ConwayEra)]
    -> IO ([[ProofStep]], Root)
computeProofs :: TrieManager IO
-> TokenId -> [(TxIn, TxOut ConwayEra)] -> IO ([[ProofStep]], Root)
computeProofs TrieManager IO
tm TokenId
tid [(TxIn, TxOut ConwayEra)]
reqUtxos =
    TrieManager IO
-> forall a.
   TokenId -> (forall (n :: * -> *). Monad n => Trie n -> n a) -> IO a
forall (m :: * -> *).
TrieManager m
-> forall a.
   TokenId -> (forall (n :: * -> *). Monad n => Trie n -> n a) -> m a
withSpeculativeTrie TrieManager IO
tm TokenId
tid ((forall (n :: * -> *).
  Monad n =>
  Trie n -> n ([[ProofStep]], Root))
 -> IO ([[ProofStep]], Root))
-> (forall (n :: * -> *).
    Monad n =>
    Trie n -> n ([[ProofStep]], Root))
-> IO ([[ProofStep]], Root)
forall a b. (a -> b) -> a -> b
$ \Trie n
trie -> do
        ps <- ((TxIn, BabbageTxOut ConwayEra) -> n [ProofStep])
-> [(TxIn, BabbageTxOut ConwayEra)] -> n [[ProofStep]]
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 (Trie n -> (TxIn, TxOut ConwayEra) -> n [ProofStep]
forall (m :: * -> *).
Monad m =>
Trie m -> (TxIn, TxOut ConwayEra) -> m [ProofStep]
processRequest Trie n
trie) [(TxIn, TxOut ConwayEra)]
[(TxIn, BabbageTxOut ConwayEra)]
reqUtxos
        r <- getRoot trie
        pure (ps, r)

-- | Process a single registry request through the speculative trie.
processRequest
    :: (Monad m)
    => Trie m
    -> (TxIn, TxOut ConwayEra)
    -> m [ProofStep]
processRequest :: forall (m :: * -> *).
Monad m =>
Trie m -> (TxIn, TxOut ConwayEra) -> m [ProofStep]
processRequest Trie m
trie (TxIn
_txIn, TxOut ConwayEra
txOut) =
    Trie m -> ByteString -> Integer -> m [ProofStep]
forall (m :: * -> *).
Monad m =>
Trie m -> ByteString -> Integer -> m [ProofStep]
walkEdge Trie m
trie (OnChainRequest -> ByteString
requestKey OnChainRequest
req) (OnChainRequest -> Integer
requestEdge OnChainRequest
req)
  where
    req :: OnChainRequest
req = case TxOut ConwayEra -> Maybe CageDatum
extractCageDatum TxOut ConwayEra
txOut of
        Just (RequestDatum OnChainRequest
r) -> OnChainRequest
r
        Maybe CageDatum
_ -> [Char] -> OnChainRequest
forall a. HasCallStack => [Char] -> a
error [Char]
"connectedFold: invalid request datum"

-- | Extract old state, build the new state output and the cage script.
prepareState
    :: CageConfig
    -> TxOut ConwayEra
    -> Root
    -> (OnChainTokenState, TxOut ConwayEra, Script ConwayEra)
prepareState :: CageConfig
-> TxOut ConwayEra
-> Root
-> (OnChainTokenState, TxOut ConwayEra, Script ConwayEra)
prepareState CageConfig
cfg TxOut ConwayEra
stateOut Root
newRoot =
    let scriptAddr :: Addr
scriptAddr = CageConfig -> Network -> Addr
cageAddrFromCfg CageConfig
cfg (CageConfig -> Network
network CageConfig
cfg)
        oldState :: OnChainTokenState
oldState = case TxOut ConwayEra -> Maybe CageDatum
extractCageDatum TxOut ConwayEra
stateOut of
            Just (StateDatum OnChainTokenState
s) -> OnChainTokenState
s
            Maybe CageDatum
_ -> [Char] -> OnChainTokenState
forall a. HasCallStack => [Char] -> a
error [Char]
"connectedFold: invalid state datum"
        newStateDatum :: CageDatum
newStateDatum =
            OnChainTokenState -> CageDatum
StateDatum OnChainTokenState
oldState{stateRoot = OnChainRoot (unRoot newRoot)}
        newStateOut :: BabbageTxOut ConwayEra
newStateOut =
            Addr -> Value ConwayEra -> TxOut ConwayEra
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut
                Addr
scriptAddr
                (TxOut ConwayEra
BabbageTxOut ConwayEra
stateOut BabbageTxOut ConwayEra
-> Getting
     (Value ConwayEra) (BabbageTxOut ConwayEra) (Value ConwayEra)
-> Value ConwayEra
forall s a. s -> Getting a s a -> a
^. (Value ConwayEra -> Const (Value ConwayEra) (Value ConwayEra))
-> TxOut ConwayEra -> Const (Value ConwayEra) (TxOut ConwayEra)
Getting
  (Value ConwayEra) (BabbageTxOut ConwayEra) (Value ConwayEra)
forall era. EraTxOut era => Lens' (TxOut era) (Value era)
Lens' (TxOut ConwayEra) (Value ConwayEra)
valueTxOutL)
                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 (CageDatum -> Data
forall a. ToData a => a -> Data
toPlcData CageDatum
newStateDatum)
        script :: Script ConwayEra
script = CageConfig -> Script ConwayEra
mkCageScript CageConfig
cfg
    in  (OnChainTokenState
oldState, TxOut ConwayEra
BabbageTxOut ConwayEra
newStateOut, AlonzoScript ConwayEra
Script ConwayEra
script)

-- | Compute the validity upper slot from the earliest request deadline.
computeUpperSlot
    :: Session NoWitness IO
    -> OnChainTokenState
    -> [(TxIn, TxOut ConwayEra)]
    -> IO SlotNo
computeUpperSlot :: Session NoWitness IO
-> OnChainTokenState -> [(TxIn, TxOut ConwayEra)] -> IO SlotNo
computeUpperSlot Session NoWitness IO
view OnChainTokenState
oldState [(TxIn, TxOut ConwayEra)]
reqUtxos = do
    let extractSubmittedAt :: (a, BabbageTxOut ConwayEra) -> Integer
extractSubmittedAt (a
_, BabbageTxOut ConwayEra
rOut) = case TxOut ConwayEra -> Maybe CageDatum
extractCageDatum TxOut ConwayEra
BabbageTxOut ConwayEra
rOut of
            Just (RequestDatum OnChainRequest
r) -> OnChainRequest -> Integer
requestSubmittedAt OnChainRequest
r
            Maybe CageDatum
_ -> Integer
0
        earliestDeadline :: Integer
earliestDeadline =
            [Integer] -> Integer
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([Integer] -> Integer) -> [Integer] -> Integer
forall a b. (a -> b) -> a -> b
$
                ((TxIn, BabbageTxOut ConwayEra) -> Integer)
-> [(TxIn, BabbageTxOut ConwayEra)] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map
                    (\(TxIn, BabbageTxOut ConwayEra)
u -> (TxIn, BabbageTxOut ConwayEra) -> Integer
forall {a}. (a, BabbageTxOut ConwayEra) -> Integer
extractSubmittedAt (TxIn, BabbageTxOut ConwayEra)
u Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ OnChainTokenState -> Integer
stateProcessTime OnChainTokenState
oldState)
                    [(TxIn, TxOut ConwayEra)]
[(TxIn, BabbageTxOut ConwayEra)]
reqUtxos
    mUpperSlot <-
        IO SlotNo -> IO (Either SomeException SlotNo)
forall a. IO a -> IO (Either SomeException a)
trySync (Session NoWitness IO -> Integer -> IO SlotNo
forall w. Session w IO -> Integer -> IO SlotNo
Services.floorSlot Session NoWitness IO
view Integer
earliestDeadline)
    candidate <- case mUpperSlot of
        Right SlotNo
s -> SlotNo -> IO SlotNo
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SlotNo
s
        Left SomeException
_ -> do
            nowUtc <- IO UTCTime
getCurrentTime
            let posixSec = UTCTime -> POSIXTime
utcTimeToPOSIXSeconds UTCTime
nowUtc
            tryUpperSlots view $
                map
                    (\POSIXTime
d -> POSIXTime -> Integer
forall b. Integral b => POSIXTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
round ((POSIXTime
posixSec POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
+ POSIXTime
d) POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
* POSIXTime
1000))
                    [30, 5, 2]
    observed <- Services.tip view
    Services.validityUpper
        view
        (observedSlot observed)
        Nothing
        candidate

{- | The TxBuild program: registry spends, attached spends and mints,
outputs, witnesses. Processed requests lock into the state output
(see `prepareState`); no refund outputs are emitted here because
connected folds only ever process (`Update`); rejected rows are built
by the reject path with `computeRefund`. No owner signature.
-}
buildProgram
    :: CageConfig
    -> TxIn
    -> [(TxIn, TxOut ConwayEra)]
    -> (TxIn, TxOut ConwayEra)
    -> OnChainTokenState
    -> TxOut ConwayEra
    -> Script ConwayEra
    -> Script ConwayEra
    -> [[ProofStep]]
    -> SlotNo
    -> [ConnectedSpend]
    -> [ConnectedMint]
    -> [TxOut ConwayEra]
    -> [KeyHash Guard]
    -> [(TxIn, TxOut ConwayEra)]
    -> [Script ConwayEra]
    -> Tx.TxBuild NoCtx Void ()
buildProgram :: CageConfig
-> TxIn
-> [(TxIn, TxOut ConwayEra)]
-> (TxIn, TxOut ConwayEra)
-> OnChainTokenState
-> TxOut ConwayEra
-> Script ConwayEra
-> Script ConwayEra
-> [[ProofStep]]
-> SlotNo
-> [ConnectedSpend]
-> [ConnectedMint]
-> [TxOut ConwayEra]
-> [KeyHash Guard]
-> [(TxIn, TxOut ConwayEra)]
-> [Script ConwayEra]
-> TxBuild NoCtx Void ()
buildProgram
    CageConfig
_cfg
    TxIn
stateIn
    [(TxIn, TxOut ConwayEra)]
reqUtxos
    (TxIn, TxOut ConwayEra)
feeUtxo
    OnChainTokenState
_oldState
    TxOut ConwayEra
newStateOut
    Script ConwayEra
script
    Script ConwayEra
requestScript
    [[ProofStep]]
proofs
    SlotNo
upperSlot
    [ConnectedSpend]
extraSpends
    [ConnectedMint]
extraMints
    [TxOut ConwayEra]
extraOutputs
    [KeyHash Guard]
extraSigners
    [(TxIn, TxOut ConwayEra)]
refUtxos
    [Script ConwayEra]
attachScripts = do
        let stateRef :: OnChainTxOutRef
stateRef = TxIn -> OnChainTxOutRef
txInToRef TxIn
stateIn
            actions :: [RequestAction]
actions = ([ProofStep] -> RequestAction) -> [[ProofStep]] -> [RequestAction]
forall a b. (a -> b) -> [a] -> [b]
map [ProofStep] -> RequestAction
Update [[ProofStep]]
proofs
        _ <- TxIn -> UpdateRedeemer -> TxBuild NoCtx Void Word32
forall r (q :: * -> *) e.
ToData r =>
TxIn -> r -> TxBuild q e Word32
Tx.spendScript TxIn
stateIn ([RequestAction] -> UpdateRedeemer
Modify [RequestAction]
actions)
        mapM_
            (\(TxIn
rIn, BabbageTxOut ConwayEra
_) -> TxIn -> UpdateRedeemer -> TxBuild NoCtx Void Word32
forall r (q :: * -> *) e.
ToData r =>
TxIn -> r -> TxBuild q e Word32
Tx.spendScript TxIn
rIn (OnChainTxOutRef -> UpdateRedeemer
Contribute OnChainTxOutRef
stateRef))
            reqUtxos
        mapM_
            (\ConnectedSpend
sp -> TxIn -> RawRedeemer -> TxBuild NoCtx Void Word32
forall r (q :: * -> *) e.
ToData r =>
TxIn -> r -> TxBuild q e Word32
Tx.spendScript ((TxIn, BabbageTxOut ConwayEra) -> TxIn
forall a b. (a, b) -> a
fst (ConnectedSpend -> (TxIn, TxOut ConwayEra)
csUtxo ConnectedSpend
sp)) (ConnectedSpend -> RawRedeemer
csRedeemer ConnectedSpend
sp))
            extraSpends
        mapM_
            (\ConnectedMint
m -> PolicyID
-> Map AssetName Integer -> RawRedeemer -> TxBuild NoCtx Void ()
forall r (q :: * -> *) e.
ToData r =>
PolicyID -> Map AssetName Integer -> r -> TxBuild q e ()
Tx.mint (ConnectedMint -> PolicyID
cmPolicy ConnectedMint
m) (ConnectedMint -> Map AssetName Integer
cmAssets ConnectedMint
m) (ConnectedMint -> RawRedeemer
cmRedeemer ConnectedMint
m))
            extraMints
        _ <- Tx.output newStateOut
        Coin _fee <- Tx.peek $ \ConwayTx
tx ->
            let f :: Coin
f = ConwayTx
tx ConwayTx -> Getting Coin ConwayTx Coin -> Coin
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx ConwayEra -> Const Coin (TxBody TopTx ConwayEra))
-> ConwayTx -> Const Coin ConwayTx
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxBody l ConwayEra)
bodyTxL ((TxBody TopTx ConwayEra -> Const Coin (TxBody TopTx ConwayEra))
 -> ConwayTx -> Const Coin ConwayTx)
-> ((Coin -> Const Coin Coin)
    -> TxBody TopTx ConwayEra -> Const Coin (TxBody TopTx ConwayEra))
-> Getting Coin ConwayTx Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const Coin Coin)
-> TxBody TopTx ConwayEra -> Const Coin (TxBody TopTx ConwayEra)
forall era. EraTxBody era => Lens' (TxBody TopTx era) Coin
Lens' (TxBody TopTx ConwayEra) Coin
feeTxBodyL
            in  if Coin
f Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
> Integer -> Coin
Coin Integer
0 then Coin -> Convergence Coin
forall a. a -> Convergence a
Tx.Ok Coin
f else Coin -> Convergence Coin
forall a. a -> Convergence a
Tx.Iterate Coin
f
        mapM_ Tx.output extraOutputs
        -- #157 removed-consumer-encoding: the pinned consumer and its mandatory withdrawal are
        -- gone. Every rule it re-walked beside the fold — request value
        -- coverage, the mint binding — is the cage's own now, checked
        -- once from the transaction's own evidence.
        -- Scripts arrive by witness or by reference, never both: with
        -- reference UTxOs every purpose resolves through them (connected
        -- folds carry four scripts and would otherwise breach the max tx
        -- size); without, every script is attached (small transactions).
        if null refUtxos
            then do
                Tx.attachScript script
                Tx.attachScript requestScript
                mapM_ (Tx.attachScript . csScript) extraSpends
                mapM_ (Tx.attachScript . cmScript) extraMints
            else mapM_ (Tx.reference . fst) refUtxos
        -- Fault hook: scripts attached unconditionally (e.g. a tampered
        -- mint script no reference output carries). Empty in honest folds.
        mapM_ Tx.attachScript attachScripts
        mapM_ Tx.requireSignature extraSigners
        Tx.collateral (fst feeUtxo)
        Tx.validTo upperSlot

{- | Replay accepted fold inputs into the manager's persistent trie so
later proof computations start from the chain's root. Call only with
inputs the ledger accepted, in fold order.
-}
syncFoldedRequests
    :: TrieManager IO
    -> TokenId
    -> [(TxIn, TxOut ConwayEra)]
    -> IO ()
syncFoldedRequests :: TrieManager IO -> TokenId -> [(TxIn, TxOut ConwayEra)] -> IO ()
syncFoldedRequests TrieManager IO
tm TokenId
tok [(TxIn, TxOut ConwayEra)]
reqUtxos =
    TrieManager IO -> forall a. TokenId -> (Trie IO -> IO a) -> IO a
forall (m :: * -> *).
TrieManager m -> forall a. TokenId -> (Trie m -> m a) -> m a
withTrie TrieManager IO
tm TokenId
tok ((Trie IO -> IO ()) -> IO ()) -> (Trie IO -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Trie IO
trie -> ((TxIn, BabbageTxOut ConwayEra) -> IO [ProofStep])
-> [(TxIn, BabbageTxOut ConwayEra)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Trie IO -> (TxIn, TxOut ConwayEra) -> IO [ProofStep]
forall (m :: * -> *).
Monad m =>
Trie m -> (TxIn, TxOut ConwayEra) -> m [ProofStep]
processRequest Trie IO
trie) [(TxIn, TxOut ConwayEra)]
[(TxIn, BabbageTxOut ConwayEra)]
reqUtxos