{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Ledger.Babbage.UTxO (
  getBabbageSupplementalDataHashes,
  getBabbageSpendingDatum,
  getBabbageScriptsProvided,
  getReferenceScripts,
  getReferenceScriptsNonDistinct,
) where

import Cardano.Ledger.Alonzo.TxWits (unTxDatsL)
import Cardano.Ledger.Alonzo.UTxO (
  AlonzoEraUTxO (..),
  AlonzoScriptsNeeded,
  getAlonzoScriptsHashesNeeded,
  getAlonzoScriptsNeeded,
  getAlonzoWitsVKeyNeeded,
 )
import Cardano.Ledger.Babbage.Core
import Cardano.Ledger.Babbage.Era (BabbageEra)
import Cardano.Ledger.Babbage.State ()
import Cardano.Ledger.BaseTypes (StrictMaybe (..), strictMaybeToMaybe)
import Cardano.Ledger.Binary (sizedValue)
import Cardano.Ledger.Mary.UTxO (getConsumedMaryValue, getProducedMaryValue)
import Cardano.Ledger.Plutus.Data (Data)
import Cardano.Ledger.Shelley.UTxO (getShelleyMinFeeTxUtxo, shelleyConsumed)
import Cardano.Ledger.State (EraUTxO (..), ScriptsProvided (..), UTxO (..))
import Cardano.Ledger.TxIn (TxIn)
import Control.Applicative
import Control.SetAlgebra (eval, (◁))
import Data.Foldable (toList)
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Lens.Micro

instance EraUTxO BabbageEra where
  type ScriptsNeeded BabbageEra = AlonzoScriptsNeeded BabbageEra

  consumed :: forall (t :: TxLevel).
PParams BabbageEra
-> CertState BabbageEra
-> UTxO BabbageEra
-> TxBody t BabbageEra
-> Value BabbageEra
consumed = PParams BabbageEra
-> CertState BabbageEra
-> UTxO BabbageEra
-> TxBody t BabbageEra
-> Value BabbageEra
forall era (l :: TxLevel).
(EraUTxO era, EraCertState era) =>
PParams era
-> CertState era -> UTxO era -> TxBody l era -> Value era
shelleyConsumed

  getConsumedValue :: forall (t :: TxLevel).
PParams BabbageEra
-> (Credential Staking -> Maybe Coin)
-> (Credential DRepRole -> Maybe Coin)
-> UTxO BabbageEra
-> TxBody t BabbageEra
-> Value BabbageEra
getConsumedValue = PParams BabbageEra
-> (Credential Staking -> Maybe Coin)
-> (Credential DRepRole -> Maybe Coin)
-> UTxO BabbageEra
-> TxBody t BabbageEra
-> Value BabbageEra
PParams BabbageEra
-> (Credential Staking -> Maybe Coin)
-> (Credential DRepRole -> Maybe Coin)
-> UTxO BabbageEra
-> TxBody t BabbageEra
-> MaryValue
forall era (l :: TxLevel).
(MaryEraTxBody era, Value era ~ MaryValue) =>
PParams era
-> (Credential Staking -> Maybe Coin)
-> (Credential DRepRole -> Maybe Coin)
-> UTxO era
-> TxBody l era
-> MaryValue
getConsumedMaryValue

  getProducedValue :: forall (t :: TxLevel).
PParams BabbageEra
-> (KeyHash StakePool -> Bool)
-> TxBody t BabbageEra
-> Value BabbageEra
getProducedValue PParams BabbageEra
pp KeyHash StakePool -> Bool
isRegPoolId TxBody t BabbageEra
txBody =
    TxBody t BabbageEra
-> (TxBody TopTx BabbageEra -> MaryValue) -> MaryValue
forall (t :: TxLevel -> * -> *) era (l :: TxLevel) a.
(HasEraTxLevel t era, STxLevel l era ~ STxTopLevel l era) =>
t l era -> (t TopTx era -> a) -> a
withTopTxLevelOnly TxBody t BabbageEra
txBody (PParams BabbageEra
-> (KeyHash StakePool -> Bool)
-> TxBody TopTx BabbageEra
-> MaryValue
forall era.
(MaryEraTxBody era, Value era ~ MaryValue) =>
PParams era
-> (KeyHash StakePool -> Bool) -> TxBody TopTx era -> MaryValue
getProducedMaryValue PParams BabbageEra
pp KeyHash StakePool -> Bool
isRegPoolId)

  getScriptsProvided :: forall (t :: TxLevel).
UTxO BabbageEra -> Tx t BabbageEra -> ScriptsProvided BabbageEra
getScriptsProvided = UTxO BabbageEra -> Tx t BabbageEra -> ScriptsProvided BabbageEra
forall era (l :: TxLevel).
(EraTx era, BabbageEraTxBody era) =>
UTxO era -> Tx l era -> ScriptsProvided era
getBabbageScriptsProvided

  getScriptsNeeded :: forall (t :: TxLevel).
UTxO BabbageEra -> TxBody t BabbageEra -> ScriptsNeeded BabbageEra
getScriptsNeeded = UTxO BabbageEra -> TxBody t BabbageEra -> ScriptsNeeded BabbageEra
UTxO BabbageEra
-> TxBody t BabbageEra -> AlonzoScriptsNeeded BabbageEra
forall era (l :: TxLevel).
(MaryEraTxBody era, AlonzoEraScript era) =>
UTxO era -> TxBody l era -> AlonzoScriptsNeeded era
getAlonzoScriptsNeeded
  {-# INLINEABLE getScriptsNeeded #-}

  getScriptsHashesNeeded :: ScriptsNeeded BabbageEra -> Set ScriptHash
getScriptsHashesNeeded = ScriptsNeeded BabbageEra -> Set ScriptHash
AlonzoScriptsNeeded BabbageEra -> Set ScriptHash
forall era. AlonzoScriptsNeeded era -> Set ScriptHash
getAlonzoScriptsHashesNeeded

  getWitsVKeyNeeded :: forall (t :: TxLevel).
CertState BabbageEra
-> UTxO BabbageEra -> TxBody t BabbageEra -> Set (KeyHash Witness)
getWitsVKeyNeeded = CertState BabbageEra
-> UTxO BabbageEra -> TxBody t BabbageEra -> Set (KeyHash Witness)
forall era (l :: TxLevel).
(EraTx era, AlonzoEraTxBody era, ShelleyEraTxBody era,
 EraCertState era, STxLevel l era ~ STxTopLevel l era) =>
CertState era -> UTxO era -> TxBody l era -> Set (KeyHash Witness)
getAlonzoWitsVKeyNeeded

  getMinFeeTxUtxo :: forall (t :: TxLevel).
PParams BabbageEra -> Tx t BabbageEra -> UTxO BabbageEra -> Coin
getMinFeeTxUtxo PParams BabbageEra
pp Tx t BabbageEra
tx UTxO BabbageEra
_ = PParams BabbageEra -> Tx t BabbageEra -> Coin
forall era (l :: TxLevel).
EraTx era =>
PParams era -> Tx l era -> Coin
getShelleyMinFeeTxUtxo PParams BabbageEra
pp Tx t BabbageEra
tx

instance AlonzoEraUTxO BabbageEra where
  getSupplementalDataHashes :: forall (l :: TxLevel).
UTxO BabbageEra -> TxBody l BabbageEra -> Set DataHash
getSupplementalDataHashes = UTxO BabbageEra -> TxBody l BabbageEra -> Set DataHash
forall era (l :: TxLevel).
BabbageEraTxBody era =>
UTxO era -> TxBody l era -> Set DataHash
getBabbageSupplementalDataHashes

  getSpendingDatum :: forall (l :: TxLevel).
UTxO BabbageEra
-> Tx l BabbageEra
-> PlutusPurpose AsItem BabbageEra
-> Maybe (Data BabbageEra)
getSpendingDatum = UTxO BabbageEra
-> Tx l BabbageEra
-> PlutusPurpose AsItem BabbageEra
-> Maybe (Data BabbageEra)
forall era (l :: TxLevel).
(AlonzoEraTx era, BabbageEraTxOut era) =>
UTxO era
-> Tx l era -> PlutusPurpose AsItem era -> Maybe (Data era)
getBabbageSpendingDatum

getBabbageSupplementalDataHashes ::
  BabbageEraTxBody era =>
  UTxO era ->
  TxBody l era ->
  Set.Set DataHash
getBabbageSupplementalDataHashes :: forall era (l :: TxLevel).
BabbageEraTxBody era =>
UTxO era -> TxBody l era -> Set DataHash
getBabbageSupplementalDataHashes (UTxO Map TxIn (TxOut era)
utxo) TxBody l era
txBody =
  [DataHash] -> Set DataHash
forall a. Ord a => [a] -> Set a
Set.fromList [DataHash
dh | TxOut era
txOut <- [TxOut era]
outs, SJust DataHash
dh <- [TxOut era
txOut TxOut era
-> Getting
     (StrictMaybe DataHash) (TxOut era) (StrictMaybe DataHash)
-> StrictMaybe DataHash
forall s a. s -> Getting a s a -> a
^. Getting (StrictMaybe DataHash) (TxOut era) (StrictMaybe DataHash)
forall era.
AlonzoEraTxOut era =>
Lens' (TxOut era) (StrictMaybe DataHash)
Lens' (TxOut era) (StrictMaybe DataHash)
dataHashTxOutL]]
  where
    newOuts :: [TxOut era]
newOuts = (Sized (TxOut era) -> TxOut era)
-> [Sized (TxOut era)] -> [TxOut era]
forall a b. (a -> b) -> [a] -> [b]
map Sized (TxOut era) -> TxOut era
forall a. Sized a -> a
sizedValue ([Sized (TxOut era)] -> [TxOut era])
-> [Sized (TxOut era)] -> [TxOut era]
forall a b. (a -> b) -> a -> b
$ StrictSeq (Sized (TxOut era)) -> [Sized (TxOut era)]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (StrictSeq (Sized (TxOut era)) -> [Sized (TxOut era)])
-> StrictSeq (Sized (TxOut era)) -> [Sized (TxOut era)]
forall a b. (a -> b) -> a -> b
$ TxBody l era
txBody TxBody l era
-> Getting
     (StrictSeq (Sized (TxOut era)))
     (TxBody l era)
     (StrictSeq (Sized (TxOut era)))
-> StrictSeq (Sized (TxOut era))
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictSeq (Sized (TxOut era)))
  (TxBody l era)
  (StrictSeq (Sized (TxOut era)))
forall era (l :: TxLevel).
BabbageEraTxBody era =>
SimpleGetter (TxBody l era) (StrictSeq (Sized (TxOut era)))
forall (l :: TxLevel).
SimpleGetter (TxBody l era) (StrictSeq (Sized (TxOut era)))
allSizedOutputsTxBodyF
    referencedOuts :: [TxOut era]
referencedOuts = Map TxIn (TxOut era) -> [TxOut era]
forall k a. Map k a -> [a]
Map.elems (Map TxIn (TxOut era) -> [TxOut era])
-> Map TxIn (TxOut era) -> [TxOut era]
forall a b. (a -> b) -> a -> b
$ Map TxIn (TxOut era) -> Set TxIn -> Map TxIn (TxOut era)
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map TxIn (TxOut era)
utxo (TxBody l era
txBody TxBody l era
-> Getting (Set TxIn) (TxBody l era) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. Getting (Set TxIn) (TxBody l era) (Set TxIn)
forall era (l :: TxLevel).
BabbageEraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l era) (Set TxIn)
referenceInputsTxBodyL)
    outs :: [TxOut era]
outs = [TxOut era]
newOuts [TxOut era] -> [TxOut era] -> [TxOut era]
forall a. Semigroup a => a -> a -> a
<> [TxOut era]
referencedOuts

-- | Extract binary data either directly from the `Tx` as an "inline datum"
-- or look it up in the witnesses by the hash.
getBabbageSpendingDatum ::
  ( AlonzoEraTx era
  , BabbageEraTxOut era
  ) =>
  UTxO era ->
  Tx l era ->
  PlutusPurpose AsItem era ->
  Maybe (Data era)
getBabbageSpendingDatum :: forall era (l :: TxLevel).
(AlonzoEraTx era, BabbageEraTxOut era) =>
UTxO era
-> Tx l era -> PlutusPurpose AsItem era -> Maybe (Data era)
getBabbageSpendingDatum (UTxO Map TxIn (TxOut era)
utxo) Tx l era
tx PlutusPurpose AsItem era
sp = do
  AsItem txIn <- PlutusPurpose AsItem era -> Maybe (AsItem Word32 TxIn)
forall era (f :: * -> * -> *).
AlonzoEraScript era =>
PlutusPurpose f era -> Maybe (f Word32 TxIn)
forall (f :: * -> * -> *).
PlutusPurpose f era -> Maybe (f Word32 TxIn)
toSpendingPurpose PlutusPurpose AsItem era
sp
  txOut <- Map.lookup txIn utxo
  let txOutDataFromWits = do
        dataHash <- StrictMaybe DataHash -> Maybe DataHash
forall a. StrictMaybe a -> Maybe a
strictMaybeToMaybe (TxOut era
txOut TxOut era
-> Getting
     (StrictMaybe DataHash) (TxOut era) (StrictMaybe DataHash)
-> StrictMaybe DataHash
forall s a. s -> Getting a s a -> a
^. Getting (StrictMaybe DataHash) (TxOut era) (StrictMaybe DataHash)
forall era.
AlonzoEraTxOut era =>
Lens' (TxOut era) (StrictMaybe DataHash)
Lens' (TxOut era) (StrictMaybe DataHash)
dataHashTxOutL)
        Map.lookup dataHash (tx ^. witsTxL . datsTxWitsL . unTxDatsL)
  strictMaybeToMaybe (txOut ^. dataTxOutL) <|> txOutDataFromWits

-- Figure 3 of the Specification
{- txscripts tx utxo = txwitscripts tx ∪ {hash s ↦ s | ( , , , s) ∈ utxo (spendInputs tx ∪ refInputs tx)} -}

-- Uses of inputs in ‘txscripts’ and ‘neededScripts’
-- There are currently 3 sets of inputs (spending, collateral, reference). A particular TxInput
-- can appear in more than one of the sets. Even in all three at the same, but that may not be
-- a really useful case.
--
-- 1) Collateral inputs are only spent if phase two fails. Their corresponding TxOut can only have
--    Key (not Script) Pay credentials, so ‘neededScripts’ does not look there.
-- 2) Reference inputs are not spent in the current Tx, unless that same input also appears in one
--    of the other sets. If that is not the case, their credentials are never needed, so anyone can
--    access the inline datums and scripts in their corresponding TxOut, without needing any
--    authorizing credentials. So ‘neededScripts’ does not look there.
-- 3) Spending inputs are always spent. So their Pay credentials are always needed.
--
-- Compute a Map of (ScriptHash -> Script) for all Scripts found in a AlonzoTx.
-- Note we are interested in the actual scripts that might be run during the Utxow
-- rule. There are two places to look:
-- 1) The Script part of the TxWits
-- 2) The reference scripts found in the TxOuts, pointed to by the spending and reference inputs
--    of the Tx.  Given such a TxOut, we look in the Pay credentials of the Addr of that TxOut.
--      A. We only look in the Pay credential of the TxOut, because the Stake credential plays
--         no role in the Utxow rule.
--      B. We don’t use the collateral inputs, because they only have key-locked Pay credentials
-- 3) Note that 'txscripts' includes both Plutus and Non-Plutus scripts
--
-- The flip side is 'ScriptsNeeded' which computes the ScriptHash of every Pay Credential
-- in spending and collateral inputs. Since reference inputs do not need to be authorized,
-- 'scriptsNeeded' does not look there.
-- It is an invariant that every such Credential points to some actual script found here.

getBabbageScriptsProvided ::
  ( EraTx era
  , BabbageEraTxBody era
  ) =>
  UTxO era ->
  Tx l era ->
  ScriptsProvided era
getBabbageScriptsProvided :: forall era (l :: TxLevel).
(EraTx era, BabbageEraTxBody era) =>
UTxO era -> Tx l era -> ScriptsProvided era
getBabbageScriptsProvided UTxO era
utxo Tx l era
tx = Map ScriptHash (Script era) -> ScriptsProvided era
forall era. Map ScriptHash (Script era) -> ScriptsProvided era
ScriptsProvided Map ScriptHash (Script era)
ans
  where
    txBody :: TxBody l era
txBody = Tx l era
tx Tx l era
-> Getting (TxBody l era) (Tx l era) (TxBody l era) -> TxBody l era
forall s a. s -> Getting a s a -> a
^. Getting (TxBody l era) (Tx l era) (TxBody l era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL
    ins :: Set TxIn
ins = (TxBody l era
txBody TxBody l era
-> Getting (Set TxIn) (TxBody l era) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. Getting (Set TxIn) (TxBody l era) (Set TxIn)
forall era (l :: TxLevel).
BabbageEraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l era) (Set TxIn)
referenceInputsTxBodyL) Set TxIn -> Set TxIn -> Set TxIn
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` (TxBody l era
txBody TxBody l era
-> Getting (Set TxIn) (TxBody l era) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. Getting (Set TxIn) (TxBody l era) (Set TxIn)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l era) (Set TxIn)
inputsTxBodyL)
    ans :: Map ScriptHash (Script era)
ans = UTxO era -> Set TxIn -> Map ScriptHash (Script era)
forall era.
BabbageEraTxOut era =>
UTxO era -> Set TxIn -> Map ScriptHash (Script era)
getReferenceScripts UTxO era
utxo Set TxIn
ins Map ScriptHash (Script era)
-> Map ScriptHash (Script era) -> Map ScriptHash (Script era)
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` (Tx l era
tx Tx l era
-> Getting
     (Map ScriptHash (Script era))
     (Tx l era)
     (Map ScriptHash (Script era))
-> Map ScriptHash (Script era)
forall s a. s -> Getting a s a -> a
^. (TxWits era -> Const (Map ScriptHash (Script era)) (TxWits era))
-> Tx l era -> Const (Map ScriptHash (Script era)) (Tx l era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l era) (TxWits era)
witsTxL ((TxWits era -> Const (Map ScriptHash (Script era)) (TxWits era))
 -> Tx l era -> Const (Map ScriptHash (Script era)) (Tx l era))
-> ((Map ScriptHash (Script era)
     -> Const
          (Map ScriptHash (Script era)) (Map ScriptHash (Script era)))
    -> TxWits era -> Const (Map ScriptHash (Script era)) (TxWits era))
-> Getting
     (Map ScriptHash (Script era))
     (Tx l era)
     (Map ScriptHash (Script era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map ScriptHash (Script era)
 -> Const
      (Map ScriptHash (Script era)) (Map ScriptHash (Script era)))
-> TxWits era -> Const (Map ScriptHash (Script era)) (TxWits era)
forall era.
EraTxWits era =>
Lens' (TxWits era) (Map ScriptHash (Script era))
Lens' (TxWits era) (Map ScriptHash (Script era))
scriptTxWitsL)

-- | Collect all the reference scripts found in the TxOuts, pointed to by some input.
getReferenceScripts ::
  BabbageEraTxOut era =>
  UTxO era ->
  Set TxIn ->
  Map.Map ScriptHash (Script era)
getReferenceScripts :: forall era.
BabbageEraTxOut era =>
UTxO era -> Set TxIn -> Map ScriptHash (Script era)
getReferenceScripts UTxO era
utxo Set TxIn
ins = [(ScriptHash, Script era)] -> Map ScriptHash (Script era)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (UTxO era -> Set TxIn -> [(ScriptHash, Script era)]
forall era.
BabbageEraTxOut era =>
UTxO era -> Set TxIn -> [(ScriptHash, Script era)]
getReferenceScriptsNonDistinct UTxO era
utxo Set TxIn
ins)

getReferenceScriptsNonDistinct ::
  BabbageEraTxOut era =>
  UTxO era ->
  Set TxIn ->
  [(ScriptHash, Script era)]
getReferenceScriptsNonDistinct :: forall era.
BabbageEraTxOut era =>
UTxO era -> Set TxIn -> [(ScriptHash, Script era)]
getReferenceScriptsNonDistinct (UTxO Map TxIn (TxOut era)
mp) Set TxIn
inputs =
  [ (Script era -> ScriptHash
forall era. EraScript era => Script era -> ScriptHash
hashScript Script era
script, Script era
script)
  | TxOut era
txOut <- Map TxIn (TxOut era) -> [TxOut era]
forall k a. Map k a -> [a]
Map.elems (Exp (Map TxIn (TxOut era)) -> Map TxIn (TxOut era)
forall s t. Embed s t => Exp t -> s
eval (Set TxIn
inputs Set TxIn -> Map TxIn (TxOut era) -> Exp (Map TxIn (TxOut era))
forall k s1 s2 (f :: * -> * -> *) v.
(Ord k, HasExp s1 (Sett k ()), HasExp s2 (f k v)) =>
s1 -> s2 -> Exp (f k v)
◁ Map TxIn (TxOut era)
mp))
  , SJust Script era
script <- [TxOut era
txOut TxOut era
-> Getting
     (StrictMaybe (Script era)) (TxOut era) (StrictMaybe (Script era))
-> StrictMaybe (Script era)
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictMaybe (Script era)) (TxOut era) (StrictMaybe (Script era))
forall era.
BabbageEraTxOut era =>
Lens' (TxOut era) (StrictMaybe (Script era))
Lens' (TxOut era) (StrictMaybe (Script era))
referenceScriptTxOutL]
  ]