{-# LANGUAGE ConstraintKinds     #-}
{-# LANGUAGE DerivingVia         #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE NumericUnderscores  #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | An index of unspent transaction outputs, and some functions for validating
--   transactions using the index.
module Ledger.Index(
    -- * Types for transaction validation based on UTXO index
    UtxoIndex(..),
    insert,
    insertCollateral,
    insertBlock,
    initialise,
    lookup,
    ValidationError(..),
    _TxOutRefNotFound,
    _ScriptFailure,
    _CardanoLedgerValidationError,
    ValidationSuccess,
    ValidationErrorInPhase,
    ValidationPhase(..),
    minFee,
    maxFee,
    adjustTxOut,
    minAdaTxOut,
    minAdaTxOutEstimated,
    maxMinAdaTxOut,
    pubKeyTxIns,
    scriptTxIns,
    PV1.ExBudget(..),
    PV1.ExCPU(..),
    PV1.ExMemory(..),
    PV1.SatInt,
    ) where

import Prelude hiding (lookup)

import Cardano.Api.Shelley qualified as C.Api
import Cardano.Ledger.Babbage qualified as Babbage
import Cardano.Ledger.Babbage.PParams qualified as Babbage
import Cardano.Ledger.Crypto (StandardCrypto)
import Cardano.Ledger.Shelley.API qualified as C.Ledger
import Control.Lens (Fold, folding, (&), (.~))
import Control.Monad.Except (MonadError (..))
import Data.Foldable (foldl')
import Data.Map qualified as Map
import Ledger.Ada (Ada, fromValue, lovelaceOf, toValue)
import Ledger.Ada qualified as Ada
import Ledger.Blockchain
import Ledger.Index.Internal
import Ledger.Orphans ()
import Ledger.Tx (CardanoTx (..), ToCardanoError, Tx, TxIn (TxIn, txInType),
                  TxInType (ConsumePublicKeyAddress, ScriptAddress), TxOut (getTxOut), TxOutRef, outValue, txOutValue,
                  updateUtxoCollateral)
import Ledger.Tx.CardanoAPI (toCardanoTxOutValue)
import Plutus.V1.Ledger.Api qualified as PV1
import Plutus.V1.Ledger.Value qualified as V
import PlutusTx.Lattice ((\/))

-- | Create an index of all UTxOs on the chain.
initialise :: Blockchain -> UtxoIndex
initialise :: Blockchain -> UtxoIndex
initialise = Map TxOutRef TxOut -> UtxoIndex
UtxoIndex (Map TxOutRef TxOut -> UtxoIndex)
-> (Blockchain -> Map TxOutRef TxOut) -> Blockchain -> UtxoIndex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Blockchain -> Map TxOutRef TxOut
unspentOutputs

-- | Update the index for the addition of a transaction.
insert :: CardanoTx -> UtxoIndex -> UtxoIndex
insert :: CardanoTx -> UtxoIndex -> UtxoIndex
insert CardanoTx
tx = Map TxOutRef TxOut -> UtxoIndex
UtxoIndex (Map TxOutRef TxOut -> UtxoIndex)
-> (UtxoIndex -> Map TxOutRef TxOut) -> UtxoIndex -> UtxoIndex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CardanoTx -> Map TxOutRef TxOut -> Map TxOutRef TxOut
updateUtxo CardanoTx
tx (Map TxOutRef TxOut -> Map TxOutRef TxOut)
-> (UtxoIndex -> Map TxOutRef TxOut)
-> UtxoIndex
-> Map TxOutRef TxOut
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UtxoIndex -> Map TxOutRef TxOut
getIndex

-- | Update the index for the addition of only the collateral inputs of a failed transaction.
insertCollateral :: CardanoTx -> UtxoIndex -> UtxoIndex
insertCollateral :: CardanoTx -> UtxoIndex -> UtxoIndex
insertCollateral CardanoTx
tx = Map TxOutRef TxOut -> UtxoIndex
UtxoIndex (Map TxOutRef TxOut -> UtxoIndex)
-> (UtxoIndex -> Map TxOutRef TxOut) -> UtxoIndex -> UtxoIndex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CardanoTx -> Map TxOutRef TxOut -> Map TxOutRef TxOut
updateUtxoCollateral CardanoTx
tx (Map TxOutRef TxOut -> Map TxOutRef TxOut)
-> (UtxoIndex -> Map TxOutRef TxOut)
-> UtxoIndex
-> Map TxOutRef TxOut
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UtxoIndex -> Map TxOutRef TxOut
getIndex

-- | Update the index for the addition of a block.
insertBlock :: Block -> UtxoIndex -> UtxoIndex
insertBlock :: Block -> UtxoIndex -> UtxoIndex
insertBlock Block
blck UtxoIndex
i = (UtxoIndex -> OnChainTx -> UtxoIndex)
-> UtxoIndex -> Block -> UtxoIndex
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((OnChainTx -> UtxoIndex -> UtxoIndex)
-> UtxoIndex -> OnChainTx -> UtxoIndex
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((CardanoTx -> UtxoIndex -> UtxoIndex)
-> (CardanoTx -> UtxoIndex -> UtxoIndex)
-> OnChainTx
-> UtxoIndex
-> UtxoIndex
forall r. (CardanoTx -> r) -> (CardanoTx -> r) -> OnChainTx -> r
eitherTx CardanoTx -> UtxoIndex -> UtxoIndex
insertCollateral CardanoTx -> UtxoIndex -> UtxoIndex
insert)) UtxoIndex
i Block
blck

-- | Find an unspent transaction output by the 'TxOutRef' that spends it.
lookup :: MonadError ValidationError m => TxOutRef -> UtxoIndex -> m TxOut
lookup :: TxOutRef -> UtxoIndex -> m TxOut
lookup TxOutRef
i UtxoIndex
index = case TxOutRef -> Map TxOutRef TxOut -> Maybe TxOut
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TxOutRef
i (Map TxOutRef TxOut -> Maybe TxOut)
-> Map TxOutRef TxOut -> Maybe TxOut
forall a b. (a -> b) -> a -> b
$ UtxoIndex -> Map TxOutRef TxOut
getIndex UtxoIndex
index of
    Just TxOut
t  -> TxOut -> m TxOut
forall (f :: * -> *) a. Applicative f => a -> f a
pure TxOut
t
    Maybe TxOut
Nothing -> ValidationError -> m TxOut
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ValidationError -> m TxOut) -> ValidationError -> m TxOut
forall a b. (a -> b) -> a -> b
$ TxOutRef -> ValidationError
TxOutRefNotFound TxOutRef
i

-- | Filter to get only the script inputs.
scriptTxIns :: Fold [TxIn] TxIn
scriptTxIns :: (TxIn -> f TxIn) -> [TxIn] -> f [TxIn]
scriptTxIns = (\[TxIn] -> [TxIn]
x -> ([TxIn] -> [TxIn]) -> Fold [TxIn] TxIn
forall (f :: * -> *) s a. Foldable f => (s -> f a) -> Fold s a
folding [TxIn] -> [TxIn]
x) (([TxIn] -> [TxIn]) -> (TxIn -> f TxIn) -> [TxIn] -> f [TxIn])
-> ((TxIn -> Bool) -> [TxIn] -> [TxIn])
-> (TxIn -> Bool)
-> (TxIn -> f TxIn)
-> [TxIn]
-> f [TxIn]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxIn -> Bool) -> [TxIn] -> [TxIn]
forall a. (a -> Bool) -> [a] -> [a]
filter ((TxIn -> Bool) -> (TxIn -> f TxIn) -> [TxIn] -> f [TxIn])
-> (TxIn -> Bool) -> (TxIn -> f TxIn) -> [TxIn] -> f [TxIn]
forall a b. (a -> b) -> a -> b
$ \case
    TxIn{ txInType :: TxIn -> Maybe TxInType
txInType = Just ScriptAddress{} } -> Bool
True
    TxIn
_                                       -> Bool
False

-- | Filter to get only the pubkey inputs.
pubKeyTxIns :: Fold [TxIn] TxIn
pubKeyTxIns :: (TxIn -> f TxIn) -> [TxIn] -> f [TxIn]
pubKeyTxIns = ([TxIn] -> [TxIn]) -> Fold [TxIn] TxIn
forall (f :: * -> *) s a. Foldable f => (s -> f a) -> Fold s a
folding ((TxIn -> Bool) -> [TxIn] -> [TxIn]
forall a. (a -> Bool) -> [a] -> [a]
filter (\TxIn{ txInType :: TxIn -> Maybe TxInType
txInType = Maybe TxInType
t } -> Maybe TxInType
t Maybe TxInType -> Maybe TxInType -> Bool
forall a. Eq a => a -> a -> Bool
== TxInType -> Maybe TxInType
forall a. a -> Maybe a
Just TxInType
ConsumePublicKeyAddress))

{- note [Minting of Ada]

'checkMintingAuthorised' will never allow a transaction that mints Ada.
Ada's currency symbol is the empty bytestring, and it can never be matched by a
validator script whose hash is its symbol.

Therefore 'checkMintingAuthorised' should not be applied to the first transaction in
the blockchain.

-}

-- | Adjust a single transaction output so it contains at least the minimum amount of Ada
-- and return the adjustment (if any) and the updated TxOut.
adjustTxOut :: (Babbage.PParams (Babbage.BabbageEra StandardCrypto)) -> TxOut -> Either ToCardanoError ([Ada.Ada], TxOut)
adjustTxOut :: PParams (BabbageEra StandardCrypto)
-> TxOut -> Either ToCardanoError ([Ada], TxOut)
adjustTxOut PParams (BabbageEra StandardCrypto)
params TxOut
txOut = do
    -- Increasing the ada amount can also increase the size in bytes, so start with a rough estimated amount of ada
    TxOutValue BabbageEra
withMinAdaValue <- Value -> Either ToCardanoError (TxOutValue BabbageEra)
toCardanoTxOutValue (Value -> Either ToCardanoError (TxOutValue BabbageEra))
-> Value -> Either ToCardanoError (TxOutValue BabbageEra)
forall a b. (a -> b) -> a -> b
$ TxOut -> Value
txOutValue TxOut
txOut Value -> Value -> Value
forall a. JoinSemiLattice a => a -> a -> a
\/ Ada -> Value
Ada.toValue (PParams (BabbageEra StandardCrypto) -> TxOut -> Ada
minAdaTxOut PParams (BabbageEra StandardCrypto)
params TxOut
txOut)
    let txOutEstimate :: TxOut
txOutEstimate = TxOut
txOut TxOut -> (TxOut -> TxOut) -> TxOut
forall a b. a -> (a -> b) -> b
& (Value -> Identity (TxOutValue BabbageEra))
-> TxOut -> Identity TxOut
Lens TxOut TxOut Value (TxOutValue BabbageEra)
outValue ((Value -> Identity (TxOutValue BabbageEra))
 -> TxOut -> Identity TxOut)
-> TxOutValue BabbageEra -> TxOut -> TxOut
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxOutValue BabbageEra
withMinAdaValue
        minAdaTxOutEstimated' :: Ada
minAdaTxOutEstimated' = PParams (BabbageEra StandardCrypto) -> TxOut -> Ada
minAdaTxOut PParams (BabbageEra StandardCrypto)
params TxOut
txOutEstimate
        missingLovelace :: Ada
missingLovelace = Ada
minAdaTxOutEstimated' Ada -> Ada -> Ada
forall a. Num a => a -> a -> a
- Value -> Ada
Ada.fromValue (TxOut -> Value
txOutValue TxOut
txOut)
    if Ada
missingLovelace Ada -> Ada -> Bool
forall a. Ord a => a -> a -> Bool
> Ada
0
    then do
      TxOutValue BabbageEra
adjustedLovelace <- Value -> Either ToCardanoError (TxOutValue BabbageEra)
toCardanoTxOutValue (Value -> Either ToCardanoError (TxOutValue BabbageEra))
-> Value -> Either ToCardanoError (TxOutValue BabbageEra)
forall a b. (a -> b) -> a -> b
$ TxOut -> Value
txOutValue TxOut
txOut Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Ada -> Value
Ada.toValue Ada
missingLovelace
      ([Ada], TxOut) -> Either ToCardanoError ([Ada], TxOut)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Ada
missingLovelace], TxOut
txOut TxOut -> (TxOut -> TxOut) -> TxOut
forall a b. a -> (a -> b) -> b
& (Value -> Identity (TxOutValue BabbageEra))
-> TxOut -> Identity TxOut
Lens TxOut TxOut Value (TxOutValue BabbageEra)
outValue ((Value -> Identity (TxOutValue BabbageEra))
 -> TxOut -> Identity TxOut)
-> TxOutValue BabbageEra -> TxOut -> TxOut
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxOutValue BabbageEra
adjustedLovelace)
    else ([Ada], TxOut) -> Either ToCardanoError ([Ada], TxOut)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], TxOut
txOut)

-- | Exact computation of the mimimum Ada required for a given TxOut.
-- TODO: Should be moved to cardano-api-extended once created
minAdaTxOut :: (Babbage.PParams (Babbage.BabbageEra StandardCrypto)) -> TxOut -> Ada
minAdaTxOut :: PParams (BabbageEra StandardCrypto) -> TxOut -> Ada
minAdaTxOut PParams (BabbageEra StandardCrypto)
params TxOut
txOut = let
  toAda :: Coin -> Ada
toAda = Integer -> Ada
lovelaceOf (Integer -> Ada) -> (Coin -> Integer) -> Coin -> Ada
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coin -> Integer
C.Ledger.unCoin
  initialValue :: Value
initialValue = TxOut -> Value
txOutValue TxOut
txOut
  fromPlutusTxOut :: TxOut -> TxOut (BabbageEra StandardCrypto)
fromPlutusTxOut = ShelleyBasedEra BabbageEra
-> TxOut CtxUTxO BabbageEra -> TxOut (BabbageEra StandardCrypto)
forall era ledgerera.
(ShelleyLedgerEra era ~ ledgerera) =>
ShelleyBasedEra era -> TxOut CtxUTxO era -> TxOut ledgerera
C.Api.toShelleyTxOut ShelleyBasedEra BabbageEra
C.Api.ShelleyBasedEraBabbage (TxOut CtxUTxO BabbageEra -> TxOut (BabbageEra StandardCrypto))
-> (TxOut -> TxOut CtxUTxO BabbageEra)
-> TxOut
-> TxOut (BabbageEra StandardCrypto)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut CtxTx BabbageEra -> TxOut CtxUTxO BabbageEra
forall era. TxOut CtxTx era -> TxOut CtxUTxO era
C.Api.toCtxUTxOTxOut (TxOut CtxTx BabbageEra -> TxOut CtxUTxO BabbageEra)
-> (TxOut -> TxOut CtxTx BabbageEra)
-> TxOut
-> TxOut CtxUTxO BabbageEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut -> TxOut CtxTx BabbageEra
getTxOut
  firstEstimate :: Ada
firstEstimate = Coin -> Ada
toAda (Coin -> Ada)
-> (TxOut (BabbageEra StandardCrypto) -> Coin)
-> TxOut (BabbageEra StandardCrypto)
-> Ada
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PParams (BabbageEra StandardCrypto)
-> TxOut (BabbageEra StandardCrypto) -> Coin
forall era. CLI era => PParams era -> TxOut era -> Coin
C.Ledger.evaluateMinLovelaceOutput PParams (BabbageEra StandardCrypto)
PParams (BabbageEra StandardCrypto)
params (TxOut (BabbageEra StandardCrypto) -> Ada)
-> TxOut (BabbageEra StandardCrypto) -> Ada
forall a b. (a -> b) -> a -> b
$ TxOut -> TxOut (BabbageEra StandardCrypto)
fromPlutusTxOut TxOut
txOut
  in -- if the estimate is above the initialValue, we run minAdaAgain, just to be sure that the
     -- new amount didn't change the TxOut size and requires more ada.
     if Ada
firstEstimate Ada -> Ada -> Bool
forall a. Ord a => a -> a -> Bool
> Value -> Ada
fromValue Value
initialValue
     then (ToCardanoError -> Ada)
-> (TxOutValue BabbageEra -> Ada)
-> Either ToCardanoError (TxOutValue BabbageEra)
-> Ada
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
            (Ada -> ToCardanoError -> Ada
forall a b. a -> b -> a
const Ada
firstEstimate)
            (PParams (BabbageEra StandardCrypto) -> TxOut -> Ada
minAdaTxOut PParams (BabbageEra StandardCrypto)
params (TxOut -> Ada)
-> (TxOutValue BabbageEra -> TxOut) -> TxOutValue BabbageEra -> Ada
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxOutValue BabbageEra -> TxOut -> TxOut)
-> TxOut -> TxOutValue BabbageEra -> TxOut
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Value -> Identity (TxOutValue BabbageEra))
-> TxOut -> Identity TxOut
Lens TxOut TxOut Value (TxOutValue BabbageEra)
outValue ((Value -> Identity (TxOutValue BabbageEra))
 -> TxOut -> Identity TxOut)
-> TxOutValue BabbageEra -> TxOut -> TxOut
forall s t a b. ASetter s t a b -> b -> s -> t
.~) TxOut
txOut)
            (Either ToCardanoError (TxOutValue BabbageEra) -> Ada)
-> Either ToCardanoError (TxOutValue BabbageEra) -> Ada
forall a b. (a -> b) -> a -> b
$ Value -> Either ToCardanoError (TxOutValue BabbageEra)
toCardanoTxOutValue (Value -> Either ToCardanoError (TxOutValue BabbageEra))
-> Value -> Either ToCardanoError (TxOutValue BabbageEra)
forall a b. (a -> b) -> a -> b
$ Ada -> Value
toValue Ada
firstEstimate Value -> Value -> Value
forall a. JoinSemiLattice a => a -> a -> a
\/ Value
initialValue
     else Ada
firstEstimate

-- minAdaTxOutParams

{-# INLINABLE minAdaTxOutEstimated #-}
{- | Provide a reasonable estimate of the mimimum of Ada required for a TxOut.

   An exact estimate of the the mimimum of Ada in a TxOut is determined by two things:
     - the `PParams`, more precisely its 'coinPerUTxOWord' parameter.
     - the size of the 'TxOut'.
 In many situations though, we need to determine a plausible value for the minimum of Ada needed for a TxOut
 without knowing much of the 'TxOut'.
 This function provides a value big enough to balance UTxOs without
 a large inlined data (larger than a hash) nor a complex val with a lot of minted values.
 It's superior to the lowest minimum needed for an UTxO, as the lowest value require no datum.
 An estimate of the minimum required Ada for each tx output.
-}
minAdaTxOutEstimated :: Ada
minAdaTxOutEstimated :: Ada
minAdaTxOutEstimated = Integer -> Ada
Ada.lovelaceOf Integer
minTxOut

{-# INLINABLE minTxOut #-}
minTxOut :: Integer
minTxOut :: Integer
minTxOut = Integer
2_000_000

{-# INLINABLE maxMinAdaTxOut #-}
{-
maxMinAdaTxOut = maxTxOutSize * coinsPerUTxOWord
coinsPerUTxOWord = 34_482
maxTxOutSize = utxoEntrySizeWithoutVal + maxValSizeInWords + dataHashSize
utxoEntrySizeWithoutVal = 27
maxValSizeInWords = 500
dataHashSize = 10

These values are partly protocol parameters-based, but since this is used in on-chain code
we want a constant to reduce code size.
-}
maxMinAdaTxOut :: Ada
maxMinAdaTxOut :: Ada
maxMinAdaTxOut = Integer -> Ada
Ada.lovelaceOf Integer
18_516_834

-- | Minimum transaction fee.
minFee :: Tx -> V.Value
minFee :: Tx -> Value
minFee = Value -> Tx -> Value
forall a b. a -> b -> a
const (Integer -> Value
Ada.lovelaceValueOf Integer
10)

-- | TODO Should be calculated based on the maximum script size permitted on
-- the Cardano blockchain.
maxFee :: Ada
maxFee :: Ada
maxFee = Integer -> Ada
Ada.lovelaceOf Integer
1_000_000