{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Ledger.Conway.UTxO (
  conwayProducedValue,
  getConwayWitsVKeyNeeded,
  txNonDistinctRefScriptsSize,
) where

import Cardano.Ledger.Alonzo.UTxO (
  AlonzoEraUTxO (..),
  AlonzoScriptsNeeded (..),
  getAlonzoScriptsHashesNeeded,
  getMintingScriptsNeeded,
  getRewardingScriptsNeeded,
  getSpendingScriptsNeeded,
  zipAsIxItem,
 )
import Cardano.Ledger.Babbage.UTxO (
  getBabbageScriptsProvided,
  getBabbageSpendingDatum,
  getBabbageSupplementalDataHashes,
  getReferenceScriptsNonDistinct,
 )
import Cardano.Ledger.BaseTypes (StrictMaybe (..))
import Cardano.Ledger.Coin (Coin)
import Cardano.Ledger.Conway.Core
import Cardano.Ledger.Conway.Era (ConwayEra)
import Cardano.Ledger.Conway.Governance.Procedures (
  GovAction (..),
  ProposalProcedure (..),
  Voter (..),
  unVotingProcedures,
 )
import Cardano.Ledger.Credential (credKeyHashWitness, credScriptHash)
import Cardano.Ledger.Keys (asWitness)
import Cardano.Ledger.Mary.UTxO (getConsumedMaryValue, getProducedMaryValue)
import Cardano.Ledger.Mary.Value (MaryValue)
import Cardano.Ledger.Shelley.UTxO (getShelleyWitsVKeyNeededNoGov)
import Cardano.Ledger.UTxO (EraUTxO (..), UTxO (..))
import Cardano.Ledger.Val (Val (..), inject)
import qualified Data.Map.Strict as Map
import Data.Maybe (catMaybes)
import Data.Monoid (Sum (..))
import qualified Data.Set as Set
import Lens.Micro ((^.))

getConwayScriptsNeeded ::
  ConwayEraTxBody era =>
  UTxO era ->
  TxBody era ->
  AlonzoScriptsNeeded era
getConwayScriptsNeeded :: forall era.
ConwayEraTxBody era =>
UTxO era -> TxBody era -> AlonzoScriptsNeeded era
getConwayScriptsNeeded UTxO era
utxo TxBody era
txBody =
  forall era.
(AlonzoEraScript era, EraTxBody era) =>
UTxO era -> TxBody era -> AlonzoScriptsNeeded era
getSpendingScriptsNeeded UTxO era
utxo TxBody era
txBody
    forall a. Semigroup a => a -> a -> a
<> forall era.
(AlonzoEraScript era, EraTxBody era) =>
TxBody era -> AlonzoScriptsNeeded era
getRewardingScriptsNeeded TxBody era
txBody
    forall a. Semigroup a => a -> a -> a
<> AlonzoScriptsNeeded era
certifyingScriptsNeeded
    forall a. Semigroup a => a -> a -> a
<> forall era.
(AlonzoEraScript era, MaryEraTxBody era) =>
TxBody era -> AlonzoScriptsNeeded era
getMintingScriptsNeeded TxBody era
txBody
    forall a. Semigroup a => a -> a -> a
<> AlonzoScriptsNeeded era
votingScriptsNeeded
    forall a. Semigroup a => a -> a -> a
<> AlonzoScriptsNeeded era
proposingScriptsNeeded
  where
    certifyingScriptsNeeded :: AlonzoScriptsNeeded era
certifyingScriptsNeeded =
      forall era.
[(PlutusPurpose AsIxItem era, ScriptHash)]
-> AlonzoScriptsNeeded era
AlonzoScriptsNeeded forall a b. (a -> b) -> a -> b
$
        forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$
          forall (f :: * -> *) it c.
Foldable f =>
f it -> (AsIxItem Word32 it -> c) -> [c]
zipAsIxItem (TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL) forall a b. (a -> b) -> a -> b
$
            \asIxItem :: AsIxItem Word32 (TxCert era)
asIxItem@(AsIxItem Word32
_ TxCert era
txCert) ->
              (forall era (f :: * -> * -> *).
AlonzoEraScript era =>
f Word32 (TxCert era) -> PlutusPurpose f era
CertifyingPurpose AsIxItem Word32 (TxCert era)
asIxItem,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era. EraTxCert era => TxCert era -> Maybe ScriptHash
getScriptWitnessTxCert TxCert era
txCert

    votingScriptsNeeded :: AlonzoScriptsNeeded era
votingScriptsNeeded =
      forall era.
[(PlutusPurpose AsIxItem era, ScriptHash)]
-> AlonzoScriptsNeeded era
AlonzoScriptsNeeded forall a b. (a -> b) -> a -> b
$
        forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$
          forall (f :: * -> *) it c.
Foldable f =>
f it -> (AsIxItem Word32 it -> c) -> [c]
zipAsIxItem (forall k a. Map k a -> [k]
Map.keys (forall era.
VotingProcedures era
-> Map Voter (Map GovActionId (VotingProcedure era))
unVotingProcedures (TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era.
ConwayEraTxBody era =>
Lens' (TxBody era) (VotingProcedures era)
votingProceduresTxBodyL))) forall a b. (a -> b) -> a -> b
$
            \asIxItem :: AsIxItem Word32 Voter
asIxItem@(AsIxItem Word32
_ Voter
voter) ->
              (forall era (f :: * -> * -> *).
ConwayEraScript era =>
f Word32 Voter -> PlutusPurpose f era
VotingPurpose AsIxItem Word32 Voter
asIxItem,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Voter -> Maybe ScriptHash
getVoterScriptHash Voter
voter
      where
        getVoterScriptHash :: Voter -> Maybe ScriptHash
getVoterScriptHash = \case
          CommitteeVoter Credential 'HotCommitteeRole
cred -> forall (kr :: KeyRole). Credential kr -> Maybe ScriptHash
credScriptHash Credential 'HotCommitteeRole
cred
          DRepVoter Credential 'DRepRole
cred -> forall (kr :: KeyRole). Credential kr -> Maybe ScriptHash
credScriptHash Credential 'DRepRole
cred
          StakePoolVoter KeyHash 'StakePool
_ -> forall a. Maybe a
Nothing

    proposingScriptsNeeded :: AlonzoScriptsNeeded era
proposingScriptsNeeded =
      forall era.
[(PlutusPurpose AsIxItem era, ScriptHash)]
-> AlonzoScriptsNeeded era
AlonzoScriptsNeeded forall a b. (a -> b) -> a -> b
$
        forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$
          forall (f :: * -> *) it c.
Foldable f =>
f it -> (AsIxItem Word32 it -> c) -> [c]
zipAsIxItem (TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era.
ConwayEraTxBody era =>
Lens' (TxBody era) (OSet (ProposalProcedure era))
proposalProceduresTxBodyL) forall a b. (a -> b) -> a -> b
$
            \asIxItem :: AsIxItem Word32 (ProposalProcedure era)
asIxItem@(AsIxItem Word32
_ ProposalProcedure era
proposal) ->
              (forall era (f :: * -> * -> *).
ConwayEraScript era =>
f Word32 (ProposalProcedure era) -> PlutusPurpose f era
ProposingPurpose AsIxItem Word32 (ProposalProcedure era)
asIxItem,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {era}. ProposalProcedure era -> Maybe ScriptHash
getProposalScriptHash ProposalProcedure era
proposal
      where
        getProposalScriptHash :: ProposalProcedure era -> Maybe ScriptHash
getProposalScriptHash ProposalProcedure {GovAction era
pProcGovAction :: forall era. ProposalProcedure era -> GovAction era
pProcGovAction :: GovAction era
pProcGovAction} =
          case GovAction era
pProcGovAction of
            ParameterChange StrictMaybe (GovPurposeId 'PParamUpdatePurpose era)
_ PParamsUpdate era
_ (SJust ScriptHash
govPolicyHash) -> forall a. a -> Maybe a
Just ScriptHash
govPolicyHash
            TreasuryWithdrawals Map RewardAccount Coin
_ (SJust ScriptHash
govPolicyHash) -> forall a. a -> Maybe a
Just ScriptHash
govPolicyHash
            GovAction era
_ -> forall a. Maybe a
Nothing

conwayProducedValue ::
  (ConwayEraTxBody era, Value era ~ MaryValue) =>
  PParams era ->
  (KeyHash 'StakePool -> Bool) ->
  TxBody era ->
  Value era
conwayProducedValue :: forall era.
(ConwayEraTxBody era, Value era ~ MaryValue) =>
PParams era
-> (KeyHash 'StakePool -> Bool) -> TxBody era -> Value era
conwayProducedValue PParams era
pp KeyHash 'StakePool -> Bool
isStakePool TxBody era
txBody =
  forall era.
(MaryEraTxBody era, Value era ~ MaryValue) =>
PParams era
-> (KeyHash 'StakePool -> Bool) -> TxBody era -> MaryValue
getProducedMaryValue PParams era
pp KeyHash 'StakePool -> Bool
isStakePool TxBody era
txBody
    forall t. Val t => t -> t -> t
<+> forall t s. Inject t s => t -> s
inject (TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era. ConwayEraTxBody era => Lens' (TxBody era) Coin
treasuryDonationTxBodyL)

instance EraUTxO ConwayEra where
  type ScriptsNeeded ConwayEra = AlonzoScriptsNeeded ConwayEra

  getConsumedValue :: PParams ConwayEra
-> (Credential 'Staking -> Maybe Coin)
-> (Credential 'DRepRole -> Maybe Coin)
-> UTxO ConwayEra
-> TxBody ConwayEra
-> Value ConwayEra
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 ConwayEra
-> (KeyHash 'StakePool -> Bool)
-> TxBody ConwayEra
-> Value ConwayEra
getProducedValue = forall era.
(ConwayEraTxBody era, Value era ~ MaryValue) =>
PParams era
-> (KeyHash 'StakePool -> Bool) -> TxBody era -> Value era
conwayProducedValue

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

  getScriptsNeeded :: UTxO ConwayEra -> TxBody ConwayEra -> ScriptsNeeded ConwayEra
getScriptsNeeded = forall era.
ConwayEraTxBody era =>
UTxO era -> TxBody era -> AlonzoScriptsNeeded era
getConwayScriptsNeeded

  getScriptsHashesNeeded :: ScriptsNeeded ConwayEra -> Set ScriptHash
getScriptsHashesNeeded = forall era. AlonzoScriptsNeeded era -> Set ScriptHash
getAlonzoScriptsHashesNeeded -- TODO: This also changes for Conway

  getWitsVKeyNeeded :: CertState ConwayEra
-> UTxO ConwayEra -> TxBody ConwayEra -> Set (KeyHash 'Witness)
getWitsVKeyNeeded CertState ConwayEra
_ = forall era.
(EraTx era, ConwayEraTxBody era) =>
UTxO era -> TxBody era -> Set (KeyHash 'Witness)
getConwayWitsVKeyNeeded

  getMinFeeTxUtxo :: PParams ConwayEra -> Tx ConwayEra -> UTxO ConwayEra -> Coin
getMinFeeTxUtxo = forall era.
(EraTx era, BabbageEraTxBody era) =>
PParams era -> Tx era -> UTxO era -> Coin
getConwayMinFeeTxUtxo

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

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

getConwayMinFeeTxUtxo ::
  ( EraTx era
  , BabbageEraTxBody era
  ) =>
  PParams era ->
  Tx era ->
  UTxO era ->
  Coin
getConwayMinFeeTxUtxo :: forall era.
(EraTx era, BabbageEraTxBody era) =>
PParams era -> Tx era -> UTxO era -> Coin
getConwayMinFeeTxUtxo PParams era
pparams Tx era
tx UTxO era
utxo =
  forall era. EraTx era => PParams era -> Tx era -> Int -> Coin
getMinFeeTx PParams era
pparams Tx era
tx forall a b. (a -> b) -> a -> b
$ forall era.
(EraTx era, BabbageEraTxBody era) =>
UTxO era -> Tx era -> Int
txNonDistinctRefScriptsSize UTxO era
utxo Tx era
tx

-- | Calculate the total size of reference scripts used by the transactions. Duplicate
-- scripts will be counted as many times as they occur, since there is never a reason to
-- include an input with the same reference script.
--
-- Any input that appears in both regular inputs and reference inputs of a transaction is
-- only used once in this computation.
txNonDistinctRefScriptsSize :: (EraTx era, BabbageEraTxBody era) => UTxO era -> Tx era -> Int
txNonDistinctRefScriptsSize :: forall era.
(EraTx era, BabbageEraTxBody era) =>
UTxO era -> Tx era -> Int
txNonDistinctRefScriptsSize UTxO era
utxo Tx era
tx = forall a. Sum a -> a
getSum forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a. a -> Sum a
Sum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. SafeToHash t => t -> Int
originalBytesSize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(ScriptHash, Script era)]
refScripts
  where
    inputs :: Set TxIn
inputs = (Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. BabbageEraTxBody era => Lens' (TxBody era) (Set TxIn)
referenceInputsTxBodyL) forall a. Ord a => Set a -> Set a -> Set a
`Set.union` (Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
inputsTxBodyL)
    refScripts :: [(ScriptHash, Script era)]
refScripts = forall era.
BabbageEraTxOut era =>
UTxO era -> Set TxIn -> [(ScriptHash, Script era)]
getReferenceScriptsNonDistinct UTxO era
utxo Set TxIn
inputs

getConwayWitsVKeyNeeded ::
  (EraTx era, ConwayEraTxBody era) =>
  UTxO era ->
  TxBody era ->
  Set.Set (KeyHash 'Witness)
getConwayWitsVKeyNeeded :: forall era.
(EraTx era, ConwayEraTxBody era) =>
UTxO era -> TxBody era -> Set (KeyHash 'Witness)
getConwayWitsVKeyNeeded UTxO era
utxo TxBody era
txBody =
  forall era.
EraTx era =>
UTxO era -> TxBody era -> Set (KeyHash 'Witness)
getShelleyWitsVKeyNeededNoGov UTxO era
utxo TxBody era
txBody
    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.
AlonzoEraTxBody era =>
Lens' (TxBody era) (Set (KeyHash 'Witness))
reqSignerHashesTxBodyL)
    forall a. Ord a => Set a -> Set a -> Set a
`Set.union` forall era.
ConwayEraTxBody era =>
TxBody era -> Set (KeyHash 'Witness)
voterWitnesses TxBody era
txBody

voterWitnesses ::
  ConwayEraTxBody era =>
  TxBody era ->
  Set.Set (KeyHash 'Witness)
voterWitnesses :: forall era.
ConwayEraTxBody era =>
TxBody era -> Set (KeyHash 'Witness)
voterWitnesses TxBody era
txb =
  forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey' forall {p}.
Voter -> p -> Set (KeyHash 'Witness) -> Set (KeyHash 'Witness)
accum forall a. Monoid a => a
mempty (forall era.
VotingProcedures era
-> Map Voter (Map GovActionId (VotingProcedure era))
unVotingProcedures (TxBody era
txb forall s a. s -> Getting a s a -> a
^. forall era.
ConwayEraTxBody era =>
Lens' (TxBody era) (VotingProcedures era)
votingProceduresTxBodyL))
  where
    accum :: Voter -> p -> Set (KeyHash 'Witness) -> Set (KeyHash 'Witness)
accum Voter
voter p
_ Set (KeyHash 'Witness)
khs =
      forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set (KeyHash 'Witness)
khs (forall a. Ord a => a -> Set a -> Set a
`Set.insert` Set (KeyHash 'Witness)
khs) forall a b. (a -> b) -> a -> b
$
        case Voter
voter of
          CommitteeVoter Credential 'HotCommitteeRole
cred -> forall (r :: KeyRole). Credential r -> Maybe (KeyHash 'Witness)
credKeyHashWitness Credential 'HotCommitteeRole
cred
          DRepVoter Credential 'DRepRole
cred -> forall (r :: KeyRole). Credential r -> Maybe (KeyHash 'Witness)
credKeyHashWitness Credential 'DRepRole
cred
          StakePoolVoter KeyHash 'StakePool
poolId -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyHash 'StakePool
poolId