{-# 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 (unTxDats)
import Cardano.Ledger.Alonzo.UTxO (
  AlonzoEraUTxO (..),
  AlonzoScriptsNeeded,
  getAlonzoScriptsHashesNeeded,
  getAlonzoScriptsNeeded,
  getAlonzoWitsVKeyNeeded,
 )
import Cardano.Ledger.Babbage.Core
import Cardano.Ledger.Babbage.Era (BabbageEra)
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)
import Cardano.Ledger.TxIn (TxIn)
import Cardano.Ledger.UTxO (EraUTxO (..), ScriptsProvided (..), UTxO (..))
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

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

  getProducedValue :: PParams BabbageEra
-> (KeyHash 'StakePool -> Bool)
-> TxBody BabbageEra
-> Value BabbageEra
getProducedValue = forall era.
(MaryEraTxBody era, Value era ~ MaryValue) =>
PParams era
-> (KeyHash 'StakePool -> Bool) -> TxBody era -> MaryValue
getProducedMaryValue

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

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

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

  getWitsVKeyNeeded :: CertState BabbageEra
-> UTxO BabbageEra -> TxBody BabbageEra -> Set (KeyHash 'Witness)
getWitsVKeyNeeded = forall era.
(EraTx era, AlonzoEraTxBody era, ShelleyEraTxBody era) =>
CertState era -> UTxO era -> TxBody era -> Set (KeyHash 'Witness)
getAlonzoWitsVKeyNeeded

  getMinFeeTxUtxo :: PParams BabbageEra -> Tx BabbageEra -> UTxO BabbageEra -> Coin
getMinFeeTxUtxo PParams BabbageEra
pp Tx BabbageEra
tx UTxO BabbageEra
_ = forall era. EraTx era => PParams era -> Tx era -> Coin
getShelleyMinFeeTxUtxo PParams BabbageEra
pp Tx BabbageEra
tx

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

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

getBabbageSupplementalDataHashes ::
  BabbageEraTxBody era =>
  UTxO era ->
  TxBody era ->
  Set.Set DataHash
getBabbageSupplementalDataHashes :: forall era.
BabbageEraTxBody era =>
UTxO era -> TxBody era -> Set DataHash
getBabbageSupplementalDataHashes (UTxO Map TxIn (TxOut era)
utxo) TxBody era
txBody =
  forall a. Ord a => [a] -> Set a
Set.fromList [DataHash
dh | TxOut era
txOut <- [TxOut era]
outs, SJust DataHash
dh <- [TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era.
AlonzoEraTxOut era =>
Lens' (TxOut era) (StrictMaybe DataHash)
dataHashTxOutL]]
  where
    newOuts :: [TxOut era]
newOuts = forall a b. (a -> b) -> [a] -> [b]
map forall a. Sized a -> a
sizedValue forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era.
BabbageEraTxBody era =>
SimpleGetter (TxBody era) (StrictSeq (Sized (TxOut era)))
allSizedOutputsTxBodyF
    referencedOuts :: [TxOut era]
referencedOuts = forall k a. Map k a -> [a]
Map.elems forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map TxIn (TxOut era)
utxo (TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era. BabbageEraTxBody era => Lens' (TxBody era) (Set TxIn)
referenceInputsTxBodyL)
    outs :: [TxOut era]
outs = [TxOut era]
newOuts 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 era ->
  PlutusPurpose AsItem era ->
  Maybe (Data era)
getBabbageSpendingDatum :: forall era.
(AlonzoEraTx era, BabbageEraTxOut era) =>
UTxO era -> Tx era -> PlutusPurpose AsItem era -> Maybe (Data era)
getBabbageSpendingDatum (UTxO Map TxIn (TxOut era)
utxo) Tx era
tx PlutusPurpose AsItem era
sp = do
  AsItem TxIn
txIn <- forall era (f :: * -> * -> *).
AlonzoEraScript era =>
PlutusPurpose f era -> Maybe (f Word32 TxIn)
toSpendingPurpose PlutusPurpose AsItem era
sp
  TxOut era
txOut <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TxIn
txIn Map TxIn (TxOut era)
utxo
  let txOutDataFromWits :: Maybe (Data era)
txOutDataFromWits = do
        DataHash
dataHash <- forall a. StrictMaybe a -> Maybe a
strictMaybeToMaybe (TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era.
AlonzoEraTxOut era =>
Lens' (TxOut era) (StrictMaybe DataHash)
dataHashTxOutL)
        forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup DataHash
dataHash (forall era. TxDats era -> Map DataHash (Data era)
unTxDats (Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. AlonzoEraTxWits era => Lens' (TxWits era) (TxDats era)
datsTxWitsL))
  forall a. StrictMaybe a -> Maybe a
strictMaybeToMaybe (TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era.
BabbageEraTxOut era =>
Lens' (TxOut era) (StrictMaybe (Data era))
dataTxOutL) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (Data era)
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 era ->
  ScriptsProvided era
getBabbageScriptsProvided :: forall era.
(EraTx era, BabbageEraTxBody era) =>
UTxO era -> Tx era -> ScriptsProvided era
getBabbageScriptsProvided UTxO era
utxo Tx era
tx = forall era. Map ScriptHash (Script era) -> ScriptsProvided era
ScriptsProvided Map ScriptHash (Script era)
ans
  where
    txBody :: TxBody era
txBody = Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL
    ins :: Set TxIn
ins = (TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era. BabbageEraTxBody era => Lens' (TxBody era) (Set TxIn)
referenceInputsTxBodyL) forall a. Ord a => Set a -> Set a -> Set a
`Set.union` (TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
inputsTxBodyL)
    ans :: Map ScriptHash (Script era)
ans = forall era.
BabbageEraTxOut era =>
UTxO era -> Set TxIn -> Map ScriptHash (Script era)
getReferenceScripts UTxO era
utxo Set TxIn
ins forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` (Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxWits 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 = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (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 =
  [ (forall era. EraScript era => Script era -> ScriptHash
hashScript Script era
script, Script era
script)
  | TxOut era
txOut <- forall k a. Map k a -> [a]
Map.elems (forall s t. Embed s t => Exp t -> s
eval (Set TxIn
inputs 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 forall s a. s -> Getting a s a -> a
^. forall era.
BabbageEraTxOut era =>
Lens' (TxOut era) (StrictMaybe (Script era))
referenceScriptTxOutL]
  ]