{-# LANGUAGE DataKinds #-}

{- |
Module      : Singular.Registry.TxBuilder.Internal.Lookup
Description : UTxO lookup, balancing, script integrity and time helpers
License     : Apache-2.0

One owner for where a builder finds its inputs and closes its
transaction: UTxO lookup by input, state and request
('findUtxoByTxIn', 'findStateUtxo', 'findRequestUtxos'), spending-index
computation, script evaluation and balancing ('evaluateAndBalance'),
script-integrity hashing, rejected-row refund outputs
('computeRefund'), and POSIX-time to slot conversion
('currentPosixMs', 'trySlots').

This is the lookup-and-balance owner extracted from
@Singular.Registry.TxBuilder.Internal@; the public module re-exports
it and is its only intended consumer surface.
-}
module Singular.Registry.TxBuilder.Internal.Lookup
    ( -- * UTxO lookup
      findUtxoByTxIn
    , findStateUtxo
    , findRequestUtxos

      -- * Indexing
    , spendingIndex

      -- * Script integrity
    , computeScriptIntegrity

      -- * Evaluate and balance
    , evaluateAndBalance
    , evaluateAndBalanceReferencing
    , placeholderExUnits

      -- * Time and slot helpers
    , currentPosixMs
    , trySlots
    , tryUpperSlots
    , trySync

      -- * Refund computation
    , computeRefund
    ) where

import Cardano.Ledger.Address (Addr)
import Cardano.Ledger.Alonzo.PParams
    ( LangDepView
    , getLanguageView
    )
import Cardano.Ledger.Alonzo.Tx
    ( ScriptIntegrity (..)
    , ScriptIntegrityHash
    , hashScriptIntegrity
    )
import Cardano.Ledger.Alonzo.TxBody
    ( scriptIntegrityHashTxBodyL
    )
import Cardano.Ledger.Alonzo.TxWits
    ( Redeemers (..)
    , TxDats (..)
    )
import Cardano.Ledger.Api.Tx
    ( bodyTxL
    , witsTxL
    )
import Cardano.Ledger.Api.Tx.Body
    ( inputsTxBodyL
    )
import Cardano.Ledger.Api.Tx.Out
    ( TxOut
    , coinTxOutL
    , getMinCoinTxOut
    , mkBasicTxOut
    , valueTxOutL
    )
import Cardano.Ledger.Api.Tx.Wits
    ( rdmrsTxWitsL
    )
import Cardano.Ledger.BaseTypes
    ( Inject (..)
    , Network
    , StrictMaybe (..)
    )
import Cardano.Ledger.Mary.Value
    ( MaryValue (..)
    , MultiAsset (..)
    , PolicyID (..)
    )
import Cardano.Ledger.Plutus.ExUnits (ExUnits (..))
import Cardano.Ledger.Plutus.Language (Language (PlutusV3))
import Cardano.Ledger.TxIn (TxIn)
import Cardano.Slotting.Slot (SlotNo)
import Cardano.Tx.Balance
    ( BalanceResult (..)
    , balanceTx
    )
import Cardano.Tx.Ledger (ConwayTx)
import Control.Exception (SomeException)
import Data.ByteString.Short qualified as SBS
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Data.Time.Clock.POSIX (getPOSIXTime)
import Data.Word (Word32)
import Lens.Micro ((&), (.~), (^.))
import PlutusTx.Builtins.Internal (BuiltinByteString (..))
import Singular.Registry.Evidence (NoWitness)
import Singular.Registry.Ledger
    ( AssetName (..)
    , Coin (..)
    , ConwayEra
    , PParams
    , TokenId (..)
    )
import Singular.Registry.LedgerProvider (Session)
import Singular.Registry.SessionIO qualified as Services
import Singular.Registry.TxBuilder.Internal.Identity
    ( addrFromKeyHashBytes
    , extractCageDatum
    , extractOwnerBytes
    )
import Singular.Registry.Types
    ( CageDatum (..)
    , OnChainRequest (..)
    , OnChainTokenId (..)
    )
import Singular.Registry.Wait qualified as Wait

{- | Placeholder execution units used in the initial
unbalanced transaction.
-}
placeholderExUnits :: ExUnits
placeholderExUnits :: ExUnits
placeholderExUnits = Nat -> Nat -> ExUnits
ExUnits Nat
0 Nat
0

{- | Evaluate script execution units and balance
a transaction.
-}
evaluateAndBalance
    :: Session NoWitness IO
    -> PParams ConwayEra
    -> [(TxIn, TxOut ConwayEra)]
    -- ^ All input UTxOs (fee + script)
    -> Addr
    -- ^ Change address
    -> ConwayTx
    -- ^ Unbalanced tx with placeholder ExUnits
    -> IO ConwayTx
evaluateAndBalance :: Session NoWitness IO
-> PParams ConwayEra
-> [(TxIn, TxOut ConwayEra)]
-> Addr
-> ConwayTx
-> IO ConwayTx
evaluateAndBalance Session NoWitness IO
prov PParams ConwayEra
pp [(TxIn, TxOut ConwayEra)]
inputUtxos =
    Session NoWitness IO
-> PParams ConwayEra
-> [(TxIn, TxOut ConwayEra)]
-> [(TxIn, TxOut ConwayEra)]
-> Addr
-> ConwayTx
-> IO ConwayTx
evaluateAndBalanceReferencing Session NoWitness IO
prov PParams ConwayEra
pp [(TxIn, TxOut ConwayEra)]
inputUtxos []

{- | 'evaluateAndBalance' for a transaction that reads scripts from
reference outputs (#300): the resolved outputs are handed to the balancer,
which charges the ledger's per-byte tier for every reference-script byte the
transaction references, exactly as the node will.
-}
evaluateAndBalanceReferencing
    :: Session NoWitness IO
    -> PParams ConwayEra
    -> [(TxIn, TxOut ConwayEra)]
    -- ^ All input UTxOs (fee + script)
    -> [(TxIn, TxOut ConwayEra)]
    -- ^ The resolved reference outputs
    -> Addr
    -- ^ Change address
    -> ConwayTx
    -- ^ Unbalanced tx with placeholder ExUnits
    -> IO ConwayTx
evaluateAndBalanceReferencing :: Session NoWitness IO
-> PParams ConwayEra
-> [(TxIn, TxOut ConwayEra)]
-> [(TxIn, TxOut ConwayEra)]
-> Addr
-> ConwayTx
-> IO ConwayTx
evaluateAndBalanceReferencing Session NoWitness IO
prov PParams ConwayEra
pp [(TxIn, TxOut ConwayEra)]
inputUtxos [(TxIn, TxOut ConwayEra)]
refUtxos Addr
changeAddr ConwayTx
tx =
    ConwayTx -> IO (Map (ConwayPlutusPurpose AsIx ConwayEra) ExUnits)
measure ConwayTx
withInputs IO (Map (ConwayPlutusPurpose AsIx ConwayEra) ExUnits)
-> (Map (ConwayPlutusPurpose AsIx ConwayEra) ExUnits
    -> IO ConwayTx)
-> IO ConwayTx
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int
-> Map (ConwayPlutusPurpose AsIx ConwayEra) ExUnits -> IO ConwayTx
forall {t}.
(Eq t, Num t) =>
t
-> Map (ConwayPlutusPurpose AsIx ConwayEra) ExUnits -> IO ConwayTx
settle (Int
6 :: Int)
  where
    withInputs :: ConwayTx
withInputs =
        ConwayTx
tx
            ConwayTx -> (ConwayTx -> ConwayTx) -> ConwayTx
forall a b. a -> (a -> b) -> b
& (TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> ConwayTx -> Identity 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 -> Identity (TxBody TopTx ConwayEra))
 -> ConwayTx -> Identity ConwayTx)
-> ((Set TxIn -> Identity (Set TxIn))
    -> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> (Set TxIn -> Identity (Set TxIn))
-> ConwayTx
-> Identity ConwayTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Identity (Set TxIn))
-> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l ConwayEra) (Set TxIn)
inputsTxBodyL
                ((Set TxIn -> Identity (Set TxIn))
 -> ConwayTx -> Identity ConwayTx)
-> Set TxIn -> ConwayTx -> ConwayTx
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Set TxIn -> (TxIn, BabbageTxOut ConwayEra) -> Set TxIn)
-> Set TxIn -> [(TxIn, BabbageTxOut ConwayEra)] -> Set TxIn
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
                    (\Set TxIn
s (TxIn
tin, BabbageTxOut ConwayEra
_) -> TxIn -> Set TxIn -> Set TxIn
forall a. Ord a => a -> Set a -> Set a
Set.insert TxIn
tin Set TxIn
s)
                    (ConwayTx
tx ConwayTx -> Getting (Set TxIn) ConwayTx (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx ConwayEra
 -> Const (Set TxIn) (TxBody TopTx ConwayEra))
-> ConwayTx -> Const (Set TxIn) 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 (Set TxIn) (TxBody TopTx ConwayEra))
 -> ConwayTx -> Const (Set TxIn) ConwayTx)
-> ((Set TxIn -> Const (Set TxIn) (Set TxIn))
    -> TxBody TopTx ConwayEra
    -> Const (Set TxIn) (TxBody TopTx ConwayEra))
-> Getting (Set TxIn) ConwayTx (Set TxIn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Const (Set TxIn) (Set TxIn))
-> TxBody TopTx ConwayEra
-> Const (Set TxIn) (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l ConwayEra) (Set TxIn)
inputsTxBodyL)
                    [(TxIn, TxOut ConwayEra)]
[(TxIn, BabbageTxOut ConwayEra)]
inputUtxos

    -- What the common ledger evaluator computes every redeemer costs; a failing script
    -- stops the build, it is never declared.
    measure :: ConwayTx -> IO (Map (ConwayPlutusPurpose AsIx ConwayEra) ExUnits)
measure ConwayTx
t = do
        evalResult <- Session NoWitness IO -> ConwayTx -> IO (EvaluateTxResult ConwayEra)
forall w.
Session w IO -> ConwayTx -> IO (EvaluateTxResult ConwayEra)
Services.evaluateTx Session NoWitness IO
prov ConwayTx
t
        case [(p, e) | (p, Left e) <- Map.toList evalResult] of
            [] ->
                Map (ConwayPlutusPurpose AsIx ConwayEra) ExUnits
-> IO (Map (ConwayPlutusPurpose AsIx ConwayEra) ExUnits)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(ConwayPlutusPurpose AsIx ConwayEra, ExUnits)]
-> Map (ConwayPlutusPurpose AsIx ConwayEra) ExUnits
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(ConwayPlutusPurpose AsIx ConwayEra
p, ExUnits
eu) | (ConwayPlutusPurpose AsIx ConwayEra
p, Right ExUnits
eu) <- Map
  (ConwayPlutusPurpose AsIx ConwayEra)
  (Either (TransactionScriptFailure ConwayEra) ExUnits)
-> [(ConwayPlutusPurpose AsIx ConwayEra,
     Either (TransactionScriptFailure ConwayEra) ExUnits)]
forall k a. Map k a -> [(k, a)]
Map.toList Map
  (ConwayPlutusPurpose AsIx ConwayEra)
  (Either (TransactionScriptFailure ConwayEra) ExUnits)
evalResult])
            [(ConwayPlutusPurpose AsIx ConwayEra,
  TransactionScriptFailure ConwayEra)]
failures ->
                [Char] -> IO (Map (ConwayPlutusPurpose AsIx ConwayEra) ExUnits)
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO (Map (ConwayPlutusPurpose AsIx ConwayEra) ExUnits))
-> [Char] -> IO (Map (ConwayPlutusPurpose AsIx ConwayEra) ExUnits)
forall a b. (a -> b) -> a -> b
$
                    [Char]
"evaluateAndBalance: script eval failed: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [(ConwayPlutusPurpose AsIx ConwayEra,
  TransactionScriptFailure ConwayEra)]
-> [Char]
forall a. Show a => a -> [Char]
show [(ConwayPlutusPurpose AsIx ConwayEra,
  TransactionScriptFailure ConwayEra)]
failures

    -- The transaction with these units declared and its fee and change
    -- balanced for them.
    balanced :: Map (ConwayPlutusPurpose AsIx ConwayEra) ExUnits -> ConwayTx
balanced Map (ConwayPlutusPurpose AsIx ConwayEra) ExUnits
units =
        let Redeemers Map (PlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
declared = ConwayTx
tx ConwayTx
-> Getting (Redeemers ConwayEra) ConwayTx (Redeemers ConwayEra)
-> Redeemers ConwayEra
forall s a. s -> Getting a s a -> a
^. (AlonzoTxWits ConwayEra
 -> Const (Redeemers ConwayEra) (AlonzoTxWits ConwayEra))
-> ConwayTx -> Const (Redeemers ConwayEra) ConwayTx
(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 ((AlonzoTxWits ConwayEra
  -> Const (Redeemers ConwayEra) (AlonzoTxWits ConwayEra))
 -> ConwayTx -> Const (Redeemers ConwayEra) ConwayTx)
-> ((Redeemers ConwayEra
     -> Const (Redeemers ConwayEra) (Redeemers ConwayEra))
    -> AlonzoTxWits ConwayEra
    -> Const (Redeemers ConwayEra) (AlonzoTxWits ConwayEra))
-> Getting (Redeemers ConwayEra) ConwayTx (Redeemers ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redeemers ConwayEra
 -> Const (Redeemers ConwayEra) (Redeemers ConwayEra))
-> AlonzoTxWits ConwayEra
-> Const (Redeemers ConwayEra) (AlonzoTxWits ConwayEra)
(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
            newRedeemers :: Redeemers ConwayEra
newRedeemers =
                Map (PlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
-> Redeemers ConwayEra
forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era
Redeemers
                    ( (ConwayPlutusPurpose AsIx ConwayEra
 -> (Data ConwayEra, ExUnits) -> (Data ConwayEra, ExUnits))
-> Map
     (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
-> Map
     (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey
                        (\ConwayPlutusPurpose AsIx ConwayEra
purpose (Data ConwayEra
dat, ExUnits
eu) -> (Data ConwayEra
dat, ExUnits
-> ConwayPlutusPurpose AsIx ConwayEra
-> Map (ConwayPlutusPurpose AsIx ConwayEra) ExUnits
-> ExUnits
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault ExUnits
eu ConwayPlutusPurpose AsIx ConwayEra
purpose Map (ConwayPlutusPurpose AsIx ConwayEra) ExUnits
units))
                        Map (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
declared
                    )
            patched :: ConwayTx
patched =
                ConwayTx
tx
                    ConwayTx -> (ConwayTx -> ConwayTx) -> ConwayTx
forall a b. a -> (a -> b) -> b
& (AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra))
-> ConwayTx -> Identity ConwayTx
(TxWits ConwayEra -> Identity (TxWits ConwayEra))
-> ConwayTx -> Identity ConwayTx
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxWits ConwayEra)
witsTxL ((AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra))
 -> ConwayTx -> Identity ConwayTx)
-> ((Redeemers ConwayEra -> Identity (Redeemers ConwayEra))
    -> AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra))
-> (Redeemers ConwayEra -> Identity (Redeemers ConwayEra))
-> ConwayTx
-> Identity ConwayTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redeemers ConwayEra -> Identity (Redeemers ConwayEra))
-> AlonzoTxWits ConwayEra -> Identity (AlonzoTxWits ConwayEra)
(Redeemers ConwayEra -> Identity (Redeemers ConwayEra))
-> TxWits ConwayEra -> Identity (TxWits ConwayEra)
forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
Lens' (TxWits ConwayEra) (Redeemers ConwayEra)
rdmrsTxWitsL ((Redeemers ConwayEra -> Identity (Redeemers ConwayEra))
 -> ConwayTx -> Identity ConwayTx)
-> Redeemers ConwayEra -> ConwayTx -> ConwayTx
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Redeemers ConwayEra
newRedeemers
                    ConwayTx -> (ConwayTx -> ConwayTx) -> ConwayTx
forall a b. a -> (a -> b) -> b
& (TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> ConwayTx -> Identity 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 -> Identity (TxBody TopTx ConwayEra))
 -> ConwayTx -> Identity ConwayTx)
-> ((StrictMaybe ScriptIntegrityHash
     -> Identity (StrictMaybe ScriptIntegrityHash))
    -> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> (StrictMaybe ScriptIntegrityHash
    -> Identity (StrictMaybe ScriptIntegrityHash))
-> ConwayTx
-> Identity ConwayTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe ScriptIntegrityHash
 -> Identity (StrictMaybe ScriptIntegrityHash))
-> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
AlonzoEraTxBody era =>
Lens' (TxBody l era) (StrictMaybe ScriptIntegrityHash)
forall (l :: TxLevel).
Lens' (TxBody l ConwayEra) (StrictMaybe ScriptIntegrityHash)
scriptIntegrityHashTxBodyL
                        ((StrictMaybe ScriptIntegrityHash
  -> Identity (StrictMaybe ScriptIntegrityHash))
 -> ConwayTx -> Identity ConwayTx)
-> StrictMaybe ScriptIntegrityHash -> ConwayTx -> ConwayTx
forall s t a b. ASetter s t a b -> b -> s -> t
.~ PParams ConwayEra
-> Redeemers ConwayEra -> StrictMaybe ScriptIntegrityHash
computeScriptIntegrity PParams ConwayEra
pp Redeemers ConwayEra
newRedeemers
        in  case PParams ConwayEra
-> [(TxIn, TxOut ConwayEra)]
-> [(TxIn, TxOut ConwayEra)]
-> Addr
-> ConwayTx
-> Either BalanceError BalanceResult
balanceTx PParams ConwayEra
pp [(TxIn, TxOut ConwayEra)]
inputUtxos [(TxIn, TxOut ConwayEra)]
refUtxos Addr
changeAddr ConwayTx
patched of
                Left BalanceError
err -> [Char] -> ConwayTx
forall a. HasCallStack => [Char] -> a
error ([Char] -> ConwayTx) -> [Char] -> ConwayTx
forall a b. (a -> b) -> a -> b
$ [Char]
"evaluateAndBalance: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> BalanceError -> [Char]
forall a. Show a => a -> [Char]
show BalanceError
err
                Right BalanceResult
br -> BalanceResult -> ConwayTx
balancedTx BalanceResult
br

    {- A script reads its own transaction: the fee and the change it is
    balanced to are part of what it is evaluated on, and the fee in turn
    depends on the units declared. The units measured on the body before
    balancing can therefore fall short of what the balanced body needs, and a
    node that re-runs the script refuses a declaration that is a few units too
    small. The balanced body is measured again, and the declaration raised
    and the body balanced again until the body the node will see is one its
    own measurement fits inside. -}
    settle :: t
-> Map (ConwayPlutusPurpose AsIx ConwayEra) ExUnits -> IO ConwayTx
settle t
0 Map (ConwayPlutusPurpose AsIx ConwayEra) ExUnits
_ =
        [Char] -> IO ConwayTx
forall a. HasCallStack => [Char] -> a
error
            [Char]
"evaluateAndBalance: the declared units did not settle on the balanced body"
    settle t
n Map (ConwayPlutusPurpose AsIx ConwayEra) ExUnits
units = do
        let candidate :: ConwayTx
candidate = Map (ConwayPlutusPurpose AsIx ConwayEra) ExUnits -> ConwayTx
balanced Map (ConwayPlutusPurpose AsIx ConwayEra) ExUnits
units
        seen <- ConwayTx -> IO (Map (ConwayPlutusPurpose AsIx ConwayEra) ExUnits)
measure ConwayTx
candidate
        if Map.isSubmapOfBy fits seen units
            then pure candidate
            else settle (n - 1) (Map.unionWith raise units seen)

    fits :: ExUnits -> ExUnits -> Bool
fits (ExUnits Nat
m Nat
s) (ExUnits Nat
m' Nat
s') = Nat
m Nat -> Nat -> Bool
forall a. Ord a => a -> a -> Bool
<= Nat
m' Bool -> Bool -> Bool
&& Nat
s Nat -> Nat -> Bool
forall a. Ord a => a -> a -> Bool
<= Nat
s'
    raise :: ExUnits -> ExUnits -> ExUnits
raise (ExUnits Nat
m Nat
s) (ExUnits Nat
m' Nat
s') = Nat -> Nat -> ExUnits
ExUnits (Nat -> Nat -> Nat
forall a. Ord a => a -> a -> a
max Nat
m Nat
m') (Nat -> Nat -> Nat
forall a. Ord a => a -> a -> a
max Nat
s Nat
s')

-- | Find a UTxO by its 'TxIn'.
findUtxoByTxIn
    :: TxIn
    -> [(TxIn, TxOut ConwayEra)]
    -> Maybe (TxIn, TxOut ConwayEra)
findUtxoByTxIn :: TxIn -> [(TxIn, TxOut ConwayEra)] -> Maybe (TxIn, TxOut ConwayEra)
findUtxoByTxIn TxIn
needle =
    ((TxIn, BabbageTxOut ConwayEra) -> Bool)
-> [(TxIn, BabbageTxOut ConwayEra)]
-> Maybe (TxIn, BabbageTxOut ConwayEra)
forall {a}. (a -> Bool) -> [a] -> Maybe a
find' (\(TxIn
tin, BabbageTxOut ConwayEra
_) -> TxIn
tin TxIn -> TxIn -> Bool
forall a. Eq a => a -> a -> Bool
== TxIn
needle)
  where
    find' :: (a -> Bool) -> [a] -> Maybe a
find' a -> Bool
_ [] = Maybe a
forall a. Maybe a
Nothing
    find' a -> Bool
p (a
x : [a]
xs)
        | a -> Bool
p a
x = a -> Maybe a
forall a. a -> Maybe a
Just a
x
        | Bool
otherwise = (a -> Bool) -> [a] -> Maybe a
find' a -> Bool
p [a]
xs

-- | Find the state UTxO for a token.
findStateUtxo
    :: PolicyID
    -> TokenId
    -> [(TxIn, TxOut ConwayEra)]
    -> Maybe (TxIn, TxOut ConwayEra)
findStateUtxo :: PolicyID
-> TokenId
-> [(TxIn, TxOut ConwayEra)]
-> Maybe (TxIn, TxOut ConwayEra)
findStateUtxo PolicyID
policyId TokenId
tid = ((TxIn, BabbageTxOut ConwayEra) -> Bool)
-> [(TxIn, BabbageTxOut ConwayEra)]
-> Maybe (TxIn, BabbageTxOut ConwayEra)
forall {a}. (a -> Bool) -> [a] -> Maybe a
find' (TxIn, TxOut ConwayEra) -> Bool
(TxIn, BabbageTxOut ConwayEra) -> Bool
forall {era} {a}.
(Value era ~ MaryValue,
 Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTxOut era) =>
(a, TxOut era) -> Bool
isState
  where
    assetName :: AssetName
assetName = TokenId -> AssetName
unTokenId TokenId
tid
    isState :: (a, TxOut era) -> Bool
isState (a
_, TxOut era
txOut) =
        case TxOut era
txOut TxOut era -> Getting MaryValue (TxOut era) MaryValue -> MaryValue
forall s a. s -> Getting a s a -> a
^. Getting MaryValue (TxOut era) MaryValue
(Value era -> Const MaryValue (Value era))
-> TxOut era -> Const MaryValue (TxOut era)
forall era. EraTxOut era => Lens' (TxOut era) (Value era)
Lens' (TxOut era) (Value era)
valueTxOutL of
            MaryValue Coin
_ (MultiAsset Map PolicyID (Map AssetName Integer)
ma) ->
                case PolicyID
-> Map PolicyID (Map AssetName Integer)
-> Maybe (Map AssetName Integer)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PolicyID
policyId Map PolicyID (Map AssetName Integer)
ma of
                    Just Map AssetName Integer
assets ->
                        AssetName -> Map AssetName Integer -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member AssetName
assetName Map AssetName Integer
assets
                    Maybe (Map AssetName Integer)
Nothing -> Bool
False
    find' :: (a -> Bool) -> [a] -> Maybe a
find' a -> Bool
_ [] = Maybe a
forall a. Maybe a
Nothing
    find' a -> Bool
p (a
x : [a]
xs)
        | a -> Bool
p a
x = a -> Maybe a
forall a. a -> Maybe a
Just a
x
        | Bool
otherwise = (a -> Bool) -> [a] -> Maybe a
find' a -> Bool
p [a]
xs

-- | Find all request UTxOs for a token.
findRequestUtxos
    :: TokenId
    -> [(TxIn, TxOut ConwayEra)]
    -> [(TxIn, TxOut ConwayEra)]
findRequestUtxos :: TokenId -> [(TxIn, TxOut ConwayEra)] -> [(TxIn, TxOut ConwayEra)]
findRequestUtxos TokenId
tid = ((TxIn, BabbageTxOut ConwayEra) -> Bool)
-> [(TxIn, BabbageTxOut ConwayEra)]
-> [(TxIn, BabbageTxOut ConwayEra)]
forall a. (a -> Bool) -> [a] -> [a]
filter (TxIn, BabbageTxOut ConwayEra) -> Bool
forall {a}. (a, BabbageTxOut ConwayEra) -> Bool
isRequest
  where
    targetName :: AssetName
targetName = TokenId -> AssetName
unTokenId TokenId
tid
    isRequest :: (a, BabbageTxOut ConwayEra) -> Bool
isRequest (a
_, BabbageTxOut ConwayEra
txOut) =
        case TxOut ConwayEra -> Maybe CageDatum
extractCageDatum TxOut ConwayEra
BabbageTxOut ConwayEra
txOut of
            Just (RequestDatum OnChainRequest
req) ->
                let OnChainRequest
                        { requestToken :: OnChainRequest -> OnChainTokenId
requestToken =
                            OnChainTokenId
                                (BuiltinByteString ByteString
bs)
                        } = OnChainRequest
req
                in  ShortByteString -> AssetName
AssetName (ByteString -> ShortByteString
SBS.toShort ByteString
bs)
                        AssetName -> AssetName -> Bool
forall a. Eq a => a -> a -> Bool
== AssetName
targetName
            Maybe CageDatum
_ -> Bool
False

-- | Compute the spending index of a 'TxIn'.
spendingIndex :: TxIn -> Set.Set TxIn -> Word32
spendingIndex :: TxIn -> Set TxIn -> Word32
spendingIndex TxIn
needle Set TxIn
inputs =
    let sorted :: [TxIn]
sorted = Set TxIn -> [TxIn]
forall a. Set a -> [a]
Set.toAscList Set TxIn
inputs
    in  Word32 -> [TxIn] -> Word32
forall {t}. Num t => t -> [TxIn] -> t
go Word32
0 [TxIn]
sorted
  where
    go :: t -> [TxIn] -> t
go t
_ [] =
        [Char] -> t
forall a. HasCallStack => [Char] -> a
error [Char]
"spendingIndex: TxIn not in set"
    go t
n (TxIn
x : [TxIn]
xs)
        | TxIn
x TxIn -> TxIn -> Bool
forall a. Eq a => a -> a -> Bool
== TxIn
needle = t
n
        | Bool
otherwise = t -> [TxIn] -> t
go (t
n t -> t -> t
forall a. Num a => a -> a -> a
+ t
1) [TxIn]
xs

-- | Compute the 'ScriptIntegrityHash'.
computeScriptIntegrity
    :: PParams ConwayEra
    -> Redeemers ConwayEra
    -> StrictMaybe ScriptIntegrityHash
computeScriptIntegrity :: PParams ConwayEra
-> Redeemers ConwayEra -> StrictMaybe ScriptIntegrityHash
computeScriptIntegrity PParams ConwayEra
pp Redeemers ConwayEra
rdmrs =
    let langViews :: Set.Set LangDepView
        langViews :: Set LangDepView
langViews =
            LangDepView -> Set LangDepView
forall a. a -> Set a
Set.singleton
                (PParams ConwayEra -> Language -> LangDepView
forall era.
AlonzoEraPParams era =>
PParams era -> Language -> LangDepView
getLanguageView PParams ConwayEra
pp Language
PlutusV3)
        emptyDats :: TxDats ConwayEra
        emptyDats :: TxDats ConwayEra
emptyDats = Map DataHash (Data ConwayEra) -> TxDats ConwayEra
forall era. Era era => Map DataHash (Data era) -> TxDats era
TxDats Map DataHash (Data ConwayEra)
forall a. Monoid a => a
mempty
    in  ScriptIntegrityHash -> StrictMaybe ScriptIntegrityHash
forall a. a -> StrictMaybe a
SJust
            ( ScriptIntegrity ConwayEra -> ScriptIntegrityHash
forall era. Era era => ScriptIntegrity era -> ScriptIntegrityHash
hashScriptIntegrity
                (Redeemers ConwayEra
-> TxDats ConwayEra -> Set LangDepView -> ScriptIntegrity ConwayEra
forall era.
Redeemers era
-> TxDats era -> Set LangDepView -> ScriptIntegrity era
ScriptIntegrity Redeemers ConwayEra
rdmrs TxDats ConwayEra
emptyDats Set LangDepView
langViews)
            )

-- | Get current POSIX time in milliseconds.
currentPosixMs :: IO Integer
currentPosixMs :: IO Integer
currentPosixMs = do
    t <- IO POSIXTime
getPOSIXTime
    pure $ floor (t * 1000)

{- | Try converting successive POSIX ms values to
slots, returning the first that succeeds.
-}
trySlots
    :: Session NoWitness IO -> [Integer] -> IO SlotNo
trySlots :: Session NoWitness IO -> [Integer] -> IO SlotNo
trySlots Session NoWitness IO
_ [] =
    [Char] -> IO SlotNo
forall a. HasCallStack => [Char] -> a
error
        [Char]
"posixMsToSlot: all fallbacks \
        \past horizon"
trySlots Session NoWitness IO
p (Integer
ms : [Integer]
rest) = do
    r <-
        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.ceilingSlot Session NoWitness IO
p Integer
ms)
    case r 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
_ -> Session NoWitness IO -> [Integer] -> IO SlotNo
trySlots Session NoWitness IO
p [Integer]
rest

{- | Compute a rejected row's refund output (NOTE-014 item A2, delegated
routing): exactly `input lovelace − tip`, floored at min-UTxO with the
top-up funded visibly. No fee share is deducted here and none is
invented (fees ride funding inputs; the validator pins per-owner floors
and exact lock accumulation instead of an aggregate envelope). THE shared
helper for every rejected-refund emission — `Reject` and manual paths
call it; processed rows emit no refunds at all (their bond locks).
-}
computeRefund
    :: PParams ConwayEra
    -> Network
    -> Integer
    -> TxOut ConwayEra
    -> TxOut ConwayEra
computeRefund :: PParams ConwayEra
-> Network -> Integer -> TxOut ConwayEra -> TxOut ConwayEra
computeRefund PParams ConwayEra
pp Network
net Integer
tipAmount TxOut ConwayEra
reqOut =
    let Coin Integer
reqVal = TxOut ConwayEra
BabbageTxOut ConwayEra
reqOut BabbageTxOut ConwayEra
-> Getting Coin (BabbageTxOut ConwayEra) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. (Coin -> Const Coin Coin)
-> TxOut ConwayEra -> Const Coin (TxOut ConwayEra)
Getting Coin (BabbageTxOut ConwayEra) Coin
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut ConwayEra) Coin
coinTxOutL
        rawRefund :: Coin
rawRefund =
            Integer -> Coin
Coin (Integer
reqVal Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
tipAmount)
        refundAddr :: Addr
refundAddr =
            Network -> ByteString -> Addr
addrFromKeyHashBytes
                Network
net
                (TxOut ConwayEra -> ByteString
extractOwnerBytes TxOut ConwayEra
reqOut)
        draft :: TxOut ConwayEra
draft =
            Addr -> Value ConwayEra -> TxOut ConwayEra
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut
                Addr
refundAddr
                (Coin -> Value ConwayEra
forall t s. Inject t s => t -> s
inject Coin
rawRefund)
        minCoin :: Coin
minCoin = PParams ConwayEra -> TxOut ConwayEra -> Coin
forall era. EraTxOut era => PParams era -> TxOut era -> Coin
getMinCoinTxOut PParams ConwayEra
pp TxOut ConwayEra
draft
    in  Addr -> Value ConwayEra -> TxOut ConwayEra
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut
            Addr
refundAddr
            (Coin -> MaryValue
forall t s. Inject t s => t -> s
inject (Coin -> Coin -> Coin
forall a. Ord a => a -> a -> a
max Coin
rawRefund Coin
minCoin))

{- | Try converting successive POSIX ms values to slots, rounding down, and
return the first that succeeds: an upper validity bound.

'trySlots' rounds up, which is right for a lower bound but not for an upper
one. Rounding down never puts the upper bound later than its chosen POSIX
candidate. NOTE030 opens the pinned final era, preserving this rounding rule
and the caller's candidate windows. Synchronous conversion failures still
try the next candidate; cancellation escapes.
-}
tryUpperSlots
    :: Session NoWitness IO -> [Integer] -> IO SlotNo
tryUpperSlots :: Session NoWitness IO -> [Integer] -> IO SlotNo
tryUpperSlots Session NoWitness IO
_ [] =
    [Char] -> IO SlotNo
forall a. HasCallStack => [Char] -> a
error
        [Char]
"posixMsToSlot: all fallbacks \
        \past horizon"
tryUpperSlots Session NoWitness IO
p (Integer
ms : [Integer]
rest) = do
    r <- 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
p Integer
ms)
    case r 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
_ -> Session NoWitness IO -> [Integer] -> IO SlotNo
tryUpperSlots Session NoWitness IO
p [Integer]
rest

{- | Run an action, returning its synchronous failure; an asynchronous
exception — a cancellation, a timeout — is rethrown, never taken for a
conversion that failed and so never answered by a fallback.
-}
trySync :: IO a -> IO (Either SomeException a)
trySync :: forall a. IO a -> IO (Either SomeException a)
trySync = IO a -> IO (Either SomeException a)
forall a. IO a -> IO (Either SomeException a)
Wait.tryOutcome