{-# LANGUAGE NumericUnderscores #-}

{- |
Module      : Singular.Registry.TxBuilder.Request
Description : Request transactions, one per seven-admitted-edges edge
License     : Apache-2.0

Builds the request transaction for one seven-admitted-edges edge (#183). No script
execution occurs -- the transaction simply pays to the per-cage
request address with an inline 'RequestDatum' naming the edge.

The locked ADA includes the token's @tip@ plus a fee buffer for the
oracle's update transaction, and the datum's deposit is exactly that
lovelace less the tip, which is what the fold checks.
-}
module Singular.Registry.TxBuilder.Request
    ( requestEdgeImpl
    , requestLockedAda
    , settleRequestOutput
    ) where

import Data.ByteString (ByteString)
import Data.List (sortOn)
import Data.Ord (Down (..))
import Data.Sequence.Strict qualified as StrictSeq
import Lens.Micro ((&), (.~), (^.))

import Cardano.Ledger.Address (Addr)
import Cardano.Ledger.Api.Tx
    ( mkBasicTx
    )
import Cardano.Ledger.Api.Tx.Body
    ( mkBasicTxBody
    , outputsTxBodyL
    )
import Cardano.Ledger.Api.Tx.Out
    ( TxOut
    , coinTxOutL
    , datumTxOutL
    , getMinCoinTxOut
    , mkBasicTxOut
    , valueTxOutL
    )
import Cardano.Ledger.BaseTypes (Inject (..))

import Cardano.Tx.Balance
    ( BalanceResult (..)
    , balanceTx
    )
import Cardano.Tx.Ledger (ConwayTx)
import Singular.Registry.Config
    ( CageConfig (..)
    )
import Singular.Registry.Evidence (NoWitness)
import Singular.Registry.Ledger
    ( Coin (..)
    , ConwayEra
    , PParams
    , TokenId
    )
import Singular.Registry.LedgerProvider (Session)
import Singular.Registry.SessionIO (outputsAt, parameters)
import Singular.Registry.TxBuilder.Internal.Identity
import Singular.Registry.TxBuilder.Internal.Lookup
import Singular.Registry.Types
    ( Edge
    )

{- | Build the request transaction for one seven-admitted-edges edge (#183).

The edge is the whole shape of the request: it names the trie move and
its leaf bytes, so no value travels here. The datum's deposit is the
output's lovelace less the tip, settled with the sizing below because
the deposit is itself a datum field.
-}
requestEdgeImpl
    :: CageConfig
    -> Session NoWitness IO
    -> Coin
    -- ^ Token tip (lovelace)
    -> TokenId
    -> ByteString
    -- ^ Key the edge moves
    -> Edge
    -- ^ The seven-admitted-edges row index (0-6)
    -> Addr
    -> IO ConwayTx
requestEdgeImpl :: CageConfig
-> Session NoWitness IO
-> Coin
-> TokenId
-> ByteString
-> Edge
-> Addr
-> IO ConwayTx
requestEdgeImpl CageConfig
cfg Session NoWitness IO
view (Coin Edge
mf) TokenId
tid ByteString
key Edge
edge Addr
addr = do
    pp <- Session NoWitness IO -> IO (PParams ConwayEra)
forall w. Session w IO -> IO (PParams ConwayEra)
parameters Session NoWitness IO
view
    utxos <- outputsAt view addr
    feeUtxo <- case sortOn
        (Down . (^. coinTxOutL) . snd)
        utxos of
        [] -> [Char] -> IO (TxIn, BabbageTxOut ConwayEra)
forall a. HasCallStack => [Char] -> a
error [Char]
"requestEdgeImpl: no UTxOs"
        ((TxIn, BabbageTxOut ConwayEra)
u : [(TxIn, BabbageTxOut ConwayEra)]
_) -> (TxIn, BabbageTxOut ConwayEra) -> IO (TxIn, BabbageTxOut ConwayEra)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxIn, BabbageTxOut ConwayEra)
u
    now <- currentPosixMs
    let scriptAddr =
            CageConfig -> TokenId -> Network -> Addr
requestAddrFromCfg CageConfig
cfg TokenId
tid (CageConfig -> Network
network CageConfig
cfg)
        refundDraft =
            Addr -> Value ConwayEra -> TxOut ConwayEra
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
addr (Coin -> Value ConwayEra
forall t s. Inject t s => t -> s
inject (Edge -> Coin
Coin Edge
0))
        build Edge
locked Edge
deposit =
            Addr -> Value ConwayEra -> TxOut ConwayEra
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut
                Addr
scriptAddr
                (Coin -> Value ConwayEra
forall t s. Inject t s => t -> s
inject (Edge -> Coin
Coin Edge
locked))
                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
                        ( TokenId -> Addr -> ByteString -> Edge -> Edge -> Edge -> Data
mkRequestDatum
                            TokenId
tid
                            Addr
addr
                            ByteString
key
                            Edge
edge
                            Edge
deposit
                            Edge
now
                        )
        Coin start =
            requestLockedAda
                pp
                (build 0 0)
                refundDraft
                mf
        txOut = PParams ConwayEra
-> Edge
-> (Edge -> Edge -> TxOut ConwayEra)
-> Edge
-> TxOut ConwayEra
settleRequestOutput PParams ConwayEra
pp Edge
mf Edge -> Edge -> TxOut ConwayEra
Edge -> Edge -> BabbageTxOut ConwayEra
build Edge
start
        body =
            TxBody TopTx ConwayEra
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l ConwayEra
mkBasicTxBody
                TxBody TopTx ConwayEra
-> (TxBody TopTx ConwayEra -> TxBody TopTx ConwayEra)
-> TxBody TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxOut ConwayEra)
 -> Identity (StrictSeq (TxOut ConwayEra)))
-> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra)
(StrictSeq (TxOut ConwayEra)
 -> Identity (StrictSeq (BabbageTxOut ConwayEra)))
-> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel).
Lens' (TxBody l ConwayEra) (StrictSeq (TxOut ConwayEra))
outputsTxBodyL
                    ((StrictSeq (TxOut ConwayEra)
  -> Identity (StrictSeq (BabbageTxOut ConwayEra)))
 -> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> StrictSeq (BabbageTxOut ConwayEra)
-> TxBody TopTx ConwayEra
-> TxBody TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ BabbageTxOut ConwayEra -> StrictSeq (BabbageTxOut ConwayEra)
forall a. a -> StrictSeq a
StrictSeq.singleton BabbageTxOut ConwayEra
txOut
        tx = TxBody TopTx ConwayEra -> ConwayTx
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l ConwayEra -> Tx l ConwayEra
mkBasicTx TxBody TopTx ConwayEra
body
    case balanceTx pp [feeUtxo] [] addr tx of
        Left BalanceError
err ->
            [Char] -> IO ConwayTx
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO ConwayTx) -> [Char] -> IO ConwayTx
forall a b. (a -> b) -> a -> b
$
                [Char]
"requestEdgeImpl: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> BalanceError -> [Char]
forall a. Show a => a -> [Char]
show BalanceError
err
        Right BalanceResult
br -> ConwayTx -> IO ConwayTx
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BalanceResult -> ConwayTx
balancedTx BalanceResult
br)

{- | Settle a request output against the invariant the fold checks: the
datum's deposit is exactly the output's lovelace less the tip.

Writing the deposit into the datum can itself raise the output's
minimum ada, so the two are a fixpoint rather than one computation.
Each round rebuilds the output at the minimum the previous round
demanded; the minimum is monotone in the lovelace and the datum grows
by at most a few bytes, so it settles in one or two rounds. The bound
is there so that a ledger whose minimum never stabilises fails loudly
instead of looping.
-}
settleRequestOutput
    :: PParams ConwayEra
    -> Integer
    -- ^ Token tip (lovelace)
    -> (Integer -> Integer -> TxOut ConwayEra)
    -- ^ Output for a given (locked lovelace, deposit)
    -> Integer
    -- ^ Starting locked lovelace
    -> TxOut ConwayEra
settleRequestOutput :: PParams ConwayEra
-> Edge
-> (Edge -> Edge -> TxOut ConwayEra)
-> Edge
-> TxOut ConwayEra
settleRequestOutput PParams ConwayEra
pp Edge
tip Edge -> Edge -> TxOut ConwayEra
build = Int -> Edge -> BabbageTxOut ConwayEra
forall {t}. (Ord t, Num t) => t -> Edge -> BabbageTxOut ConwayEra
go (Int
8 :: Int)
  where
    go :: t -> Edge -> BabbageTxOut ConwayEra
go t
rounds Edge
locked =
        let out :: TxOut ConwayEra
out = Edge -> Edge -> TxOut ConwayEra
build Edge
locked (Edge
locked Edge -> Edge -> Edge
forall a. Num a => a -> a -> a
- Edge
tip)
            Coin Edge
need = PParams ConwayEra -> TxOut ConwayEra -> Coin
forall era. EraTxOut era => PParams era -> TxOut era -> Coin
getMinCoinTxOut PParams ConwayEra
pp TxOut ConwayEra
BabbageTxOut ConwayEra
out
        in  if Edge
need Edge -> Edge -> Bool
forall a. Ord a => a -> a -> Bool
<= Edge
locked
                then BabbageTxOut ConwayEra
out
                else
                    if t
rounds t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<= t
0
                        then
                            [Char] -> BabbageTxOut ConwayEra
forall a. HasCallStack => [Char] -> a
error
                                [Char]
"settleRequestOutput: the minimum ada\
                                \ for a request output did not settle"
                        else t -> Edge -> BabbageTxOut ConwayEra
go (t
rounds t -> t -> t
forall a. Num a => a -> a -> a
- t
1) Edge
need

-- | Compute the ADA to lock in a request output.
requestLockedAda
    :: PParams ConwayEra
    -> TxOut ConwayEra
    -> TxOut ConwayEra
    -> Integer
    -> Coin
requestLockedAda :: PParams ConwayEra
-> TxOut ConwayEra -> TxOut ConwayEra -> Edge -> Coin
requestLockedAda PParams ConwayEra
pp TxOut ConwayEra
reqDraft TxOut ConwayEra
refDraft Edge
tip =
    let Coin Edge
refMin =
            PParams ConwayEra -> TxOut ConwayEra -> Coin
forall era. EraTxOut era => PParams era -> TxOut era -> Coin
getMinCoinTxOut PParams ConwayEra
pp TxOut ConwayEra
refDraft
        feeBuffer :: Edge
feeBuffer = Edge
1_000_000
        locked :: Edge
locked = Edge
tip Edge -> Edge -> Edge
forall a. Num a => a -> a -> a
+ Edge
feeBuffer Edge -> Edge -> Edge
forall a. Num a => a -> a -> a
+ Edge
refMin
        adjusted :: Coin
adjusted =
            PParams ConwayEra -> TxOut ConwayEra -> Coin
forall era. EraTxOut era => PParams era -> TxOut era -> Coin
getMinCoinTxOut
                PParams ConwayEra
pp
                ( TxOut ConwayEra
BabbageTxOut ConwayEra
reqDraft
                    BabbageTxOut ConwayEra
-> (BabbageTxOut ConwayEra -> BabbageTxOut ConwayEra)
-> BabbageTxOut ConwayEra
forall a b. a -> (a -> b) -> b
& (Value ConwayEra -> Identity (Value ConwayEra))
-> TxOut ConwayEra -> Identity (TxOut ConwayEra)
(Value ConwayEra -> Identity (Value ConwayEra))
-> BabbageTxOut ConwayEra -> Identity (BabbageTxOut ConwayEra)
forall era. EraTxOut era => Lens' (TxOut era) (Value era)
Lens' (TxOut ConwayEra) (Value ConwayEra)
valueTxOutL
                        ((Value ConwayEra -> Identity (Value ConwayEra))
 -> BabbageTxOut ConwayEra -> Identity (BabbageTxOut ConwayEra))
-> Value ConwayEra
-> BabbageTxOut ConwayEra
-> BabbageTxOut ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin -> Value ConwayEra
forall t s. Inject t s => t -> s
inject (Edge -> Coin
Coin Edge
locked)
                )
    in  Coin -> Coin -> Coin
forall a. Ord a => a -> a -> a
max Coin
adjusted (Edge -> Coin
Coin Edge
locked)