{-# 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.Crypto (Crypto)
import Cardano.Ledger.Keys (KeyHash, KeyRole (..), asWitness)
import Cardano.Ledger.Mary.UTxO (getConsumedMaryValue, getProducedMaryValue)
import Cardano.Ledger.Mary.Value (MaryValue)
import Cardano.Ledger.SafeHash (SafeToHash (..))
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 (EraCrypto era))]
-> 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 (EraCrypto era))
getScriptWitnessTxCert TxCert era
txCert

    votingScriptsNeeded :: AlonzoScriptsNeeded era
votingScriptsNeeded =
      forall era.
[(PlutusPurpose AsIxItem era, ScriptHash (EraCrypto era))]
-> 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 (EraCrypto era))
     (Map (GovActionId (EraCrypto era)) (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 (EraCrypto era))
asIxItem@(AsIxItem Word32
_ Voter (EraCrypto era)
voter) ->
              (forall era (f :: * -> * -> *).
ConwayEraScript era =>
f Word32 (Voter (EraCrypto era)) -> PlutusPurpose f era
VotingPurpose AsIxItem Word32 (Voter (EraCrypto era))
asIxItem,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {c}. Voter c -> Maybe (ScriptHash c)
getVoterScriptHash Voter (EraCrypto era)
voter
      where
        getVoterScriptHash :: Voter c -> Maybe (ScriptHash c)
getVoterScriptHash = \case
          CommitteeVoter Credential 'HotCommitteeRole c
cred -> forall (kr :: KeyRole) c. Credential kr c -> Maybe (ScriptHash c)
credScriptHash Credential 'HotCommitteeRole c
cred
          DRepVoter Credential 'DRepRole c
cred -> forall (kr :: KeyRole) c. Credential kr c -> Maybe (ScriptHash c)
credScriptHash Credential 'DRepRole c
cred
          StakePoolVoter KeyHash 'StakePool c
_ -> forall a. Maybe a
Nothing

    proposingScriptsNeeded :: AlonzoScriptsNeeded era
proposingScriptsNeeded =
      forall era.
[(PlutusPurpose AsIxItem era, ScriptHash (EraCrypto era))]
-> 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 (EraCrypto era))
getProposalScriptHash ProposalProcedure era
proposal
      where
        getProposalScriptHash :: ProposalProcedure era -> Maybe (ScriptHash (EraCrypto era))
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 (EraCrypto era)
govPolicyHash) -> forall a. a -> Maybe a
Just ScriptHash (EraCrypto era)
govPolicyHash
            TreasuryWithdrawals Map (RewardAccount (EraCrypto era)) Coin
_ (SJust ScriptHash (EraCrypto era)
govPolicyHash) -> forall a. a -> Maybe a
Just ScriptHash (EraCrypto era)
govPolicyHash
            GovAction era
_ -> forall a. Maybe a
Nothing

conwayProducedValue ::
  (ConwayEraTxBody era, Value era ~ MaryValue (EraCrypto era)) =>
  PParams era ->
  (KeyHash 'StakePool (EraCrypto era) -> Bool) ->
  TxBody era ->
  Value era
conwayProducedValue :: forall era.
(ConwayEraTxBody era, Value era ~ MaryValue (EraCrypto era)) =>
PParams era
-> (KeyHash 'StakePool (EraCrypto era) -> Bool)
-> TxBody era
-> Value era
conwayProducedValue PParams era
pp KeyHash 'StakePool (EraCrypto era) -> Bool
isStakePool TxBody era
txBody =
  forall era.
(MaryEraTxBody era, Value era ~ MaryValue (EraCrypto era)) =>
PParams era
-> (KeyHash 'StakePool (EraCrypto era) -> Bool)
-> TxBody era
-> MaryValue (EraCrypto era)
getProducedMaryValue PParams era
pp KeyHash 'StakePool (EraCrypto era) -> 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 Crypto c => EraUTxO (ConwayEra c) where
  type ScriptsNeeded (ConwayEra c) = AlonzoScriptsNeeded (ConwayEra c)

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

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

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

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

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

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

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

  getSpendingDatum :: UTxO (ConwayEra c)
-> Tx (ConwayEra c)
-> PlutusPurpose AsItem (ConwayEra c)
-> Maybe (Data (ConwayEra c))
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 (EraCrypto era), Script era)]
refScripts
  where
    inputs :: Set (TxIn (EraCrypto era))
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 (EraCrypto era)))
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 (EraCrypto era)))
inputsTxBodyL)
    refScripts :: [(ScriptHash (EraCrypto era), Script era)]
refScripts = forall era.
BabbageEraTxOut era =>
UTxO era
-> Set (TxIn (EraCrypto era))
-> [(ScriptHash (EraCrypto era), Script era)]
getReferenceScriptsNonDistinct UTxO era
utxo Set (TxIn (EraCrypto era))
inputs

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

voterWitnesses ::
  ConwayEraTxBody era =>
  TxBody era ->
  Set.Set (KeyHash 'Witness (EraCrypto era))
voterWitnesses :: forall era.
ConwayEraTxBody era =>
TxBody era -> Set (KeyHash 'Witness (EraCrypto era))
voterWitnesses TxBody era
txb =
  forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey' forall {c} {p}.
Voter c
-> p -> Set (KeyHash 'Witness c) -> Set (KeyHash 'Witness c)
accum forall a. Monoid a => a
mempty (forall era.
VotingProcedures era
-> Map
     (Voter (EraCrypto era))
     (Map (GovActionId (EraCrypto era)) (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 c
-> p -> Set (KeyHash 'Witness c) -> Set (KeyHash 'Witness c)
accum Voter c
voter p
_ Set (KeyHash 'Witness c)
khs =
      forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set (KeyHash 'Witness c)
khs (forall a. Ord a => a -> Set a -> Set a
`Set.insert` Set (KeyHash 'Witness c)
khs) forall a b. (a -> b) -> a -> b
$
        case Voter c
voter of
          CommitteeVoter Credential 'HotCommitteeRole c
cred -> forall (r :: KeyRole) c.
Credential r c -> Maybe (KeyHash 'Witness c)
credKeyHashWitness Credential 'HotCommitteeRole c
cred
          DRepVoter Credential 'DRepRole c
cred -> forall (r :: KeyRole) c.
Credential r c -> Maybe (KeyHash 'Witness c)
credKeyHashWitness Credential 'DRepRole c
cred
          StakePoolVoter KeyHash 'StakePool c
poolId -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness KeyHash 'StakePool c
poolId