{-# 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.Crypto
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 Crypto c => EraUTxO (BabbageEra c) where
  {-# SPECIALIZE instance EraUTxO (BabbageEra StandardCrypto) #-}
  type ScriptsNeeded (BabbageEra c) = AlonzoScriptsNeeded (BabbageEra c)

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

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

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

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

  getScriptsHashesNeeded :: ScriptsNeeded (BabbageEra c)
-> Set (ScriptHash (EraCrypto (BabbageEra c)))
getScriptsHashesNeeded = forall era.
AlonzoScriptsNeeded era -> Set (ScriptHash (EraCrypto era))
getAlonzoScriptsHashesNeeded

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

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

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

  getSpendingDatum :: UTxO (BabbageEra c)
-> Tx (BabbageEra c)
-> PlutusPurpose AsItem (BabbageEra c)
-> Maybe (Data (BabbageEra c))
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 (EraCrypto era))
getBabbageSupplementalDataHashes :: forall era.
BabbageEraTxBody era =>
UTxO era -> TxBody era -> Set (DataHash (EraCrypto era))
getBabbageSupplementalDataHashes (UTxO Map (TxIn (EraCrypto era)) (TxOut era)
utxo) TxBody era
txBody =
  forall a. Ord a => [a] -> Set a
Set.fromList [DataHash (EraCrypto era)
dh | TxOut era
txOut <- [TxOut era]
outs, SJust DataHash (EraCrypto era)
dh <- [TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era.
AlonzoEraTxOut era =>
Lens' (TxOut era) (StrictMaybe (DataHash (EraCrypto era)))
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 (EraCrypto era)) (TxOut era)
utxo (TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era.
BabbageEraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
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 (EraCrypto era)) (TxOut era)
utxo) Tx era
tx PlutusPurpose AsItem era
sp = do
  AsItem TxIn (EraCrypto era)
txIn <- forall era (f :: * -> * -> *).
AlonzoEraScript era =>
PlutusPurpose f era -> Maybe (f Word32 (TxIn (EraCrypto era)))
toSpendingPurpose PlutusPurpose AsItem era
sp
  TxOut era
txOut <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TxIn (EraCrypto era)
txIn Map (TxIn (EraCrypto era)) (TxOut era)
utxo
  let txOutDataFromWits :: Maybe (Data era)
txOutDataFromWits = do
        DataHash (EraCrypto era)
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 (EraCrypto era)))
dataHashTxOutL)
        forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup DataHash (EraCrypto era)
dataHash (forall era. TxDats era -> Map (DataHash (EraCrypto era)) (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 (EraCrypto era)) (Script era)
-> ScriptsProvided era
ScriptsProvided Map (ScriptHash (EraCrypto era)) (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 (EraCrypto era))
ins = (TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era.
BabbageEraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
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 (EraCrypto era)))
inputsTxBodyL)
    ans :: Map (ScriptHash (EraCrypto era)) (Script era)
ans = forall era.
BabbageEraTxOut era =>
UTxO era
-> Set (TxIn (EraCrypto era))
-> Map (ScriptHash (EraCrypto era)) (Script era)
getReferenceScripts UTxO era
utxo Set (TxIn (EraCrypto era))
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 (EraCrypto era)) (Script era))
scriptTxWitsL)

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

getReferenceScriptsNonDistinct ::
  BabbageEraTxOut era =>
  UTxO era ->
  Set (TxIn (EraCrypto era)) ->
  [(ScriptHash (EraCrypto era), Script era)]
getReferenceScriptsNonDistinct :: forall era.
BabbageEraTxOut era =>
UTxO era
-> Set (TxIn (EraCrypto era))
-> [(ScriptHash (EraCrypto era), Script era)]
getReferenceScriptsNonDistinct (UTxO Map (TxIn (EraCrypto era)) (TxOut era)
mp) Set (TxIn (EraCrypto era))
inputs =
  [ (forall era.
EraScript era =>
Script era -> ScriptHash (EraCrypto era)
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 (EraCrypto era))
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 (EraCrypto era)) (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]
  ]