{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

{- |
Module      : Singular.Registry.TxBuilder.Register
Description : Consumer stake-credential registration transaction
License     : Apache-2.0

Registers a script stake credential so a later withdrawal from it does
not fail on ledger for the wrong reason.

#157 removed-consumer-encoding: the consumer-registration builder is DELETED with the pinned
consumer it registered. There is no consumer script to register and no
mandatory withdrawal left to make possible, and a function that
registers nothing would be a trap for the next reader. What remains is
the generic credential registration the exhibit controls use directly;
it authorizes nothing by itself.
-}
module Singular.Registry.TxBuilder.Register
    ( registerScriptImpl
    ) where

import Cardano.Ledger.Api.Tx.Out (coinTxOutL, referenceScriptTxOutL)
import Cardano.Ledger.BaseTypes (StrictMaybe (..))
import Data.List (sortOn)
import Data.Map.Strict qualified as Map
import Data.Ord (Down (..))
import Data.Void (Void)
import Lens.Micro ((^.))

import Cardano.Ledger.Alonzo.Scripts (AsIx)
import Cardano.Ledger.Conway.Scripts
    ( ConwayPlutusPurpose (..)
    )
import Cardano.Ledger.Hashes (ScriptHash)
import Cardano.Ledger.Plutus.ExUnits (ExUnits (..))

import Cardano.Ledger.Address (Addr)
import Cardano.Tx.Build qualified as Tx
import Cardano.Tx.Ledger (ConwayTx)
import Singular.Registry.Evidence (NoWitness)
import Singular.Registry.Ledger (ConwayEra)
import Singular.Registry.LedgerProvider (Session)
import Singular.Registry.SessionIO (outputsAt, parameters)
import Singular.Registry.SessionIO qualified as Services

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

{- | Wrap the view's script evaluation for the story language (no scripts execute
here, but the story language still calls back through this interface).
-}
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 [Char] 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 -> [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

{- | Register any script stake credential (the consumer pin above is
the common case; exhibit controls register further credentials the
same way). Registration only makes a credential withdrawable; it
authorizes nothing by itself.
-}
registerScriptImpl
    :: Session NoWitness IO
    -> Addr
    -> ScriptHash
    -> IO ConwayTx
registerScriptImpl :: Session NoWitness IO -> Addr -> ScriptHash -> IO ConwayTx
registerScriptImpl Session NoWitness IO
view Addr
fundAddr ScriptHash
credHash = do
    pp <- Session NoWitness IO -> IO (PParams ConwayEra)
forall w. Session w IO -> IO (PParams ConwayEra)
parameters Session NoWitness IO
view
    utxos <- outputsAt view fundAddr
    let funding =
            ((TxIn, TxOut ConwayEra) -> Down Coin) -> Outputs -> Outputs
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn
                (Coin -> Down Coin
forall a. a -> Down a
Down (Coin -> Down Coin)
-> ((TxIn, TxOut ConwayEra) -> Coin)
-> (TxIn, TxOut ConwayEra)
-> Down Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxOut ConwayEra -> Getting Coin (TxOut ConwayEra) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (TxOut ConwayEra) Coin
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut ConwayEra) Coin
coinTxOutL) (TxOut ConwayEra -> Coin)
-> ((TxIn, TxOut ConwayEra) -> TxOut ConwayEra)
-> (TxIn, TxOut ConwayEra)
-> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxIn, TxOut ConwayEra) -> TxOut ConwayEra
forall a b. (a, b) -> b
snd)
                [(TxIn, TxOut ConwayEra)
u | u :: (TxIn, TxOut ConwayEra)
u@(TxIn
_, TxOut ConwayEra
out) <- Outputs
[(TxIn, BabbageTxOut ConwayEra)]
utxos, TxOut ConwayEra
out TxOut ConwayEra
-> Getting
     (StrictMaybe (Script ConwayEra))
     (TxOut ConwayEra)
     (StrictMaybe (Script ConwayEra))
-> StrictMaybe (Script ConwayEra)
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictMaybe (Script ConwayEra))
  (TxOut ConwayEra)
  (StrictMaybe (Script ConwayEra))
forall era.
BabbageEraTxOut era =>
Lens' (TxOut era) (StrictMaybe (Script era))
Lens' (TxOut ConwayEra) (StrictMaybe (Script ConwayEra))
referenceScriptTxOutL StrictMaybe (Script ConwayEra)
-> StrictMaybe (Script ConwayEra) -> Bool
forall a. Eq a => a -> a -> Bool
== StrictMaybe (Script ConwayEra)
forall a. StrictMaybe a
SNothing]
    fundUtxo <- case funding of
        [] ->
            [Char] -> IO (TxIn, TxOut ConwayEra)
forall a. HasCallStack => [Char] -> a
error
                [Char]
"registerScript: funder wallet has no UTxOs"
        ((TxIn, TxOut ConwayEra)
u : Outputs
_) -> (TxIn, TxOut ConwayEra) -> IO (TxIn, TxOut ConwayEra)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxIn, TxOut ConwayEra)
u
    let evalTx = Session NoWitness IO
-> ConwayTx
-> IO
     (Map (ConwayPlutusPurpose AsIx ConwayEra) (Either [Char] ExUnits))
mkEvalTx Session NoWitness IO
view
        prog :: Tx.TxBuild NoCtx Void ()
        prog = do
            _ <- ScriptHash -> TxBuild NoCtx Void Word32
forall (q :: * -> *) e. ScriptHash -> TxBuild q e Word32
Tx.registerStakeScript ScriptHash
credHash
            pure ()
    result <-
        Tx.build
            (Tx.mkPParamsBound pp)
            (Tx.InterpretIO (const (pure undefined)))
            evalTx
            [fundUtxo]
            []
            fundAddr
            prog
    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]
"registerScript: 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
                )