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

{- |
Module      : Singular.Registry.TxBuilder.Update.Build
Description : Fold transaction assembly — one story language program
License     : Apache-2.0

The transaction side of a fold: the empty query generalized algebraic data type the fold's story language
programs run under, the evaluation adapter that turns the provider's
script budgets into the shape the story language consumes, and the one program
that assembles the update transaction — spends, mints, outputs,
signatures, scripts or references, collateral and validity — from the
prepared context and the decided duties.

This module owns no queries and no duty decisions; see
"Singular.Registry.TxBuilder.Update.Context" and
"Singular.Registry.TxBuilder.Update.Duties". The public surface stays
"Singular.Registry.TxBuilder.Update" (#267).
-}
module Singular.Registry.TxBuilder.Update.Build
    ( NoCtx
    , mkEvalTx
    , buildProgram
    ) where

import Data.Map.Strict qualified as Map
import Data.Void (Void)
import Lens.Micro ((^.))

import Cardano.Ledger.Alonzo.Scripts (AsIx)
import Cardano.Ledger.Api.Tx
    ( bodyTxL
    )
import Cardano.Ledger.Api.Tx.Body
    ( feeTxBodyL
    )
import Cardano.Ledger.Api.Tx.Out
    ( TxOut
    , referenceScriptTxOutL
    )
import Cardano.Ledger.BaseTypes (StrictMaybe (..))
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Conway.Scripts
    ( ConwayPlutusPurpose
    )
import Cardano.Ledger.Core
    ( Script
    , hashScript
    )
import Cardano.Ledger.Plutus.ExUnits (ExUnits)
import Cardano.Slotting.Slot (SlotNo)
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
    , PParams
    , TxIn
    )
import Singular.Registry.LedgerProvider (Session)
import Singular.Registry.SessionIO qualified as Services
import Singular.Registry.TxBuilder.ConnectedFold
    ( ConnectedMint (..)
    , ConnectedSpend (..)
    )
import Singular.Registry.TxBuilder.Internal.Identity
import Singular.Registry.TxBuilder.Update.Duties
    ( RegistryDuties (..)
    )
import Singular.Registry.Types
    ( OnChainTokenState
    , ProofStep
    , RequestAction (..)
    , UpdateRedeemer (..)
    )

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

-- | Wrap the view's script evaluation for the story language.
mkEvalTx
    :: Session NoWitness IO
    -> ConwayTx
    -> IO
        ( Map.Map
            ( ConwayPlutusPurpose
                AsIx
                ConwayEra
            )
            (Either String ExUnits)
        )
mkEvalTx :: Session NoWitness IO
-> ConwayTx
-> IO
     (Map (ConwayPlutusPurpose AsIx ConwayEra) (Either String ExUnits))
mkEvalTx Session NoWitness IO
view 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 -> String -> Either String ExUnits
forall a b. a -> Either a b
Left (TransactionScriptFailure ConwayEra -> String
forall a. Show a => a -> String
show TransactionScriptFailure ConwayEra
e)
                Right ExUnits
eu -> ExUnits -> Either String ExUnits
forall a b. b -> Either a b
Right ExUnits
eu
            )
            r

-- | The TxBuild story language program for an update tx.
buildProgram
    :: 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)]
    -> Tx.TxBuild NoCtx Void ()
buildProgram :: 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
_stateOut
    [(TxIn, TxOut ConwayEra)]
reqUtxos
    (TxIn, TxOut ConwayEra)
feeUtxo
    OnChainTokenState
_oldState
    TxOut ConwayEra
newStateOut
    Script ConwayEra
script
    Script ConwayEra
requestScript
    [[ProofStep]]
proofs
    SlotNo
upperSlot
    RegistryDuties
duties
    [(TxIn, TxOut ConwayEra)]
refUtxos = do
        let stateRef :: OnChainTxOutRef
stateRef = TxIn -> OnChainTxOutRef
txInToRef TxIn
stateIn
        let 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
        _ <- 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
        -- #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.
        -- #157 C5/C6/T1-T6: what the edges owe. The custody an edge
        -- consumes is spent, the tokens it moves are minted or burned
        -- under the registry's own three policies, and the carriers it
        -- owes — registration destination or retirement deposit return — are created.
        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))
            (rdSpends duties)
        -- #177 I177-BUILDER: the burn source of a retirement or of an
        -- active deletion. It is an ordinary input, not a script spend:
        -- the active witness sits at the holder's own address, and the
        -- key that signs the fold is the key that owns it.
        mapM_ (Tx.spend . fst) (rdInputs duties)
        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))
            (rdMints duties)
        mapM_ Tx.output (rdOutputs duties)
        mapM_ Tx.requireSignature (rdSigners duties)
        if null refUtxos
            then do
                Tx.attachScript script
                Tx.attachScript requestScript
                mapM_ (Tx.attachScript . csScript) (rdSpends duties)
                mapM_ (Tx.attachScript . cmScript) (rdMints duties)
            else do
                mapM_ (Tx.reference . fst) refUtxos
                -- #299: a script no reference output carries — an
                -- application's release spend when its script was not
                -- published — is attached, so every purpose resolves.
                -- The registry's own scripts are all referenced, so for
                -- them this attaches nothing.
                let carried =
                        [ Script ConwayEra -> ScriptHash
forall era. EraScript era => Script era -> ScriptHash
hashScript Script ConwayEra
s
                        | (TxIn
_, BabbageTxOut ConwayEra
o) <- [(TxIn, TxOut ConwayEra)]
[(TxIn, BabbageTxOut ConwayEra)]
refUtxos
                        , SJust Script ConwayEra
s <- [BabbageTxOut ConwayEra
o 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]
                        ]
                    uncarried Script era
s = Script era -> ScriptHash
forall era. EraScript era => Script era -> ScriptHash
hashScript Script era
s ScriptHash -> [ScriptHash] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [ScriptHash]
carried
                mapM_
                    Tx.attachScript
                    ( filter
                        uncarried
                        (map csScript (rdSpends duties) <> map cmScript (rdMints duties))
                    )
        Tx.collateral (fst feeUtxo)
        Tx.validTo upperSlot