{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Ledger.Shelley.UTxO (
  EraUTxO (..),
  ShelleyScriptsNeeded (..),
  getShelleyScriptsNeeded,
  getConsumedCoin,
  shelleyProducedValue,
  shelleyConsumed,
  produced,
  getShelleyMinFeeTxUtxo,
  getShelleyWitsVKeyNeeded,
  getShelleyWitsVKeyNeededNoGov,
  module UTxO,
) where

import Cardano.Ledger.Address (Addr (..), bootstrapKeyHash)
import Cardano.Ledger.BaseTypes (StrictMaybe (..))
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (Credential (..), credKeyHashWitness, credScriptHash)
import Cardano.Ledger.Keys (
  GenDelegs (..),
  asWitness,
  genDelegKeyHash,
 )
import Cardano.Ledger.PoolParams (PoolParams (..))
import Cardano.Ledger.Shelley.Era (ShelleyEra)
import Cardano.Ledger.Shelley.PParams (ProposedPPUpdates (ProposedPPUpdates), Update (..))
import Cardano.Ledger.Shelley.State ()
import Cardano.Ledger.Shelley.Tx ()
import Cardano.Ledger.Shelley.TxBody (
  ShelleyEraTxBody (..),
  Withdrawals (..),
  raCredential,
 )
import Cardano.Ledger.State (
  EraCertState (..),
  dsGenDelegs,
  lookupDepositDState,
  psStakePoolParamsL,
 )
import Cardano.Ledger.State as UTxO (
  CanGetUTxO (..),
  CanSetUTxO (..),
  EraUTxO (..),
  ScriptsProvided (..),
  UTxO (..),
  areAllAdaOnly,
  getScriptHash,
  sumAllCoin,
  sumAllValue,
  sumCoinUTxO,
  sumUTxO,
  txInsFilter,
  txinLookup,
  txins,
  txouts,
  verifyWitVKey,
 )
import Cardano.Ledger.TxIn (TxIn (..))
import Cardano.Ledger.Val ((<+>))
import qualified Cardano.Ledger.Val as Val
import Control.SetAlgebra (eval, (◁))
import Data.Foldable (Foldable (fold), foldr', toList)
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Lens.Micro ((^.))

-- | Compute the subset of inputs of the set 'txIns' for which each input is
-- locked by a script in the UTxO 'u'.
txinsScriptHashes ::
  EraTxOut era =>
  Set TxIn ->
  UTxO era ->
  Set ScriptHash
txinsScriptHashes :: forall era. EraTxOut era => Set TxIn -> UTxO era -> Set ScriptHash
txinsScriptHashes Set TxIn
txInps (UTxO Map TxIn (TxOut era)
u) = (TxIn -> Set ScriptHash -> Set ScriptHash)
-> Set ScriptHash -> Set TxIn -> Set ScriptHash
forall a b. (a -> b -> b) -> b -> Set a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TxIn -> Set ScriptHash -> Set ScriptHash
add Set ScriptHash
forall a. Set a
Set.empty Set TxIn
txInps
  where
    -- to get subset, start with empty, and only insert those inputs in txInps
    -- that are locked in u
    add :: TxIn -> Set ScriptHash -> Set ScriptHash
add TxIn
input Set ScriptHash
ans = case TxIn -> Map TxIn (TxOut era) -> Maybe (TxOut era)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TxIn
input Map TxIn (TxOut era)
u of
      Just TxOut era
txOut -> case TxOut era
txOut TxOut era -> Getting Addr (TxOut era) Addr -> Addr
forall s a. s -> Getting a s a -> a
^. Getting Addr (TxOut era) Addr
forall era. EraTxOut era => Lens' (TxOut era) Addr
Lens' (TxOut era) Addr
addrTxOutL of
        Addr Network
_ (ScriptHashObj ScriptHash
h) StakeReference
_ -> ScriptHash -> Set ScriptHash -> Set ScriptHash
forall a. Ord a => a -> Set a -> Set a
Set.insert ScriptHash
h Set ScriptHash
ans
        Addr
_ -> Set ScriptHash
ans
      Maybe (TxOut era)
Nothing -> Set ScriptHash
ans

getShelleyScriptsNeeded ::
  EraTxBody era =>
  UTxO era ->
  TxBody era ->
  ShelleyScriptsNeeded era
getShelleyScriptsNeeded :: forall era.
EraTxBody era =>
UTxO era -> TxBody era -> ShelleyScriptsNeeded era
getShelleyScriptsNeeded UTxO era
u TxBody era
txBody =
  Set ScriptHash -> ShelleyScriptsNeeded era
forall era. Set ScriptHash -> ShelleyScriptsNeeded era
ShelleyScriptsNeeded
    ( Set ScriptHash
scriptHashes
        Set ScriptHash -> Set ScriptHash -> Set ScriptHash
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` [ScriptHash] -> Set ScriptHash
forall a. Ord a => [a] -> Set a
Set.fromList
          [ScriptHash
sh | RewardAccount
w <- [RewardAccount]
withdrawals, Just ScriptHash
sh <- [Credential 'Staking -> Maybe ScriptHash
forall (kr :: KeyRole). Credential kr -> Maybe ScriptHash
credScriptHash (RewardAccount -> Credential 'Staking
raCredential RewardAccount
w)]]
        Set ScriptHash -> Set ScriptHash -> Set ScriptHash
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` [ScriptHash] -> Set ScriptHash
forall a. Ord a => [a] -> Set a
Set.fromList
          [ScriptHash
sh | TxCert era
c <- [TxCert era]
certificates, Just ScriptHash
sh <- [TxCert era -> Maybe ScriptHash
forall era. EraTxCert era => TxCert era -> Maybe ScriptHash
getScriptWitnessTxCert TxCert era
c]]
    )
  where
    withdrawals :: [RewardAccount]
withdrawals = Map RewardAccount Coin -> [RewardAccount]
forall k a. Map k a -> [k]
Map.keys (Withdrawals -> Map RewardAccount Coin
unWithdrawals (TxBody era
txBody TxBody era
-> Getting Withdrawals (TxBody era) Withdrawals -> Withdrawals
forall s a. s -> Getting a s a -> a
^. Getting Withdrawals (TxBody era) Withdrawals
forall era. EraTxBody era => Lens' (TxBody era) Withdrawals
Lens' (TxBody era) Withdrawals
withdrawalsTxBodyL))
    scriptHashes :: Set ScriptHash
scriptHashes = Set TxIn -> UTxO era -> Set ScriptHash
forall era. EraTxOut era => Set TxIn -> UTxO era -> Set ScriptHash
txinsScriptHashes (TxBody era
txBody TxBody era
-> Getting (Set TxIn) (TxBody era) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. Getting (Set TxIn) (TxBody era) (Set TxIn)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL) UTxO era
u
    certificates :: [TxCert era]
certificates = StrictSeq (TxCert era) -> [TxCert era]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (TxBody era
txBody TxBody era
-> Getting
     (StrictSeq (TxCert era)) (TxBody era) (StrictSeq (TxCert era))
-> StrictSeq (TxCert era)
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictSeq (TxCert era)) (TxBody era) (StrictSeq (TxCert era))
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL)

-- | For eras before Conway, VState is expected to have an empty Map for vsDReps, and so deposit summed up is zero.
shelleyConsumed ::
  (EraUTxO era, EraCertState era) =>
  PParams era ->
  CertState era ->
  UTxO era ->
  TxBody era ->
  Value era
shelleyConsumed :: forall era.
(EraUTxO era, EraCertState era) =>
PParams era -> CertState era -> UTxO era -> TxBody era -> Value era
shelleyConsumed PParams era
pp CertState era
certState =
  PParams era
-> (Credential 'Staking -> Maybe Coin)
-> (Credential 'DRepRole -> Maybe Coin)
-> UTxO era
-> TxBody era
-> Value era
forall era.
EraUTxO era =>
PParams era
-> (Credential 'Staking -> Maybe Coin)
-> (Credential 'DRepRole -> Maybe Coin)
-> UTxO era
-> TxBody era
-> Value era
getConsumedValue
    PParams era
pp
    (DState era -> Credential 'Staking -> Maybe Coin
forall era. DState era -> Credential 'Staking -> Maybe Coin
lookupDepositDState (DState era -> Credential 'Staking -> Maybe Coin)
-> DState era -> Credential 'Staking -> Maybe Coin
forall a b. (a -> b) -> a -> b
$ CertState era
certState CertState era
-> Getting (DState era) (CertState era) (DState era) -> DState era
forall s a. s -> Getting a s a -> a
^. Getting (DState era) (CertState era) (DState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL)
    (Maybe Coin -> Credential 'DRepRole -> Maybe Coin
forall a b. a -> b -> a
const Maybe Coin
forall a. Maybe a
Nothing)

-- | Compute the lovelace which are created by the transaction
-- For eras before Conway, VState is expected to have an empty Map for vsDReps, and so deposit summed up is zero.
produced ::
  (EraUTxO era, EraCertState era) =>
  PParams era ->
  CertState era ->
  TxBody era ->
  Value era
produced :: forall era.
(EraUTxO era, EraCertState era) =>
PParams era -> CertState era -> TxBody era -> Value era
produced PParams era
pp CertState era
certState =
  PParams era
-> (KeyHash 'StakePool -> Bool) -> TxBody era -> Value era
forall era.
EraUTxO era =>
PParams era
-> (KeyHash 'StakePool -> Bool) -> TxBody era -> Value era
getProducedValue PParams era
pp ((KeyHash 'StakePool -> Map (KeyHash 'StakePool) PoolParams -> Bool)
-> Map (KeyHash 'StakePool) PoolParams
-> KeyHash 'StakePool
-> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip KeyHash 'StakePool -> Map (KeyHash 'StakePool) PoolParams -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member (Map (KeyHash 'StakePool) PoolParams -> KeyHash 'StakePool -> Bool)
-> Map (KeyHash 'StakePool) PoolParams
-> KeyHash 'StakePool
-> Bool
forall a b. (a -> b) -> a -> b
$ CertState era
certState CertState era
-> Getting
     (Map (KeyHash 'StakePool) PoolParams)
     (CertState era)
     (Map (KeyHash 'StakePool) PoolParams)
-> Map (KeyHash 'StakePool) PoolParams
forall s a. s -> Getting a s a -> a
^. (PState era
 -> Const (Map (KeyHash 'StakePool) PoolParams) (PState era))
-> CertState era
-> Const (Map (KeyHash 'StakePool) PoolParams) (CertState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL ((PState era
  -> Const (Map (KeyHash 'StakePool) PoolParams) (PState era))
 -> CertState era
 -> Const (Map (KeyHash 'StakePool) PoolParams) (CertState era))
-> ((Map (KeyHash 'StakePool) PoolParams
     -> Const
          (Map (KeyHash 'StakePool) PoolParams)
          (Map (KeyHash 'StakePool) PoolParams))
    -> PState era
    -> Const (Map (KeyHash 'StakePool) PoolParams) (PState era))
-> Getting
     (Map (KeyHash 'StakePool) PoolParams)
     (CertState era)
     (Map (KeyHash 'StakePool) PoolParams)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (KeyHash 'StakePool) PoolParams
 -> Const
      (Map (KeyHash 'StakePool) PoolParams)
      (Map (KeyHash 'StakePool) PoolParams))
-> PState era
-> Const (Map (KeyHash 'StakePool) PoolParams) (PState era)
forall era (f :: * -> *).
Functor f =>
(Map (KeyHash 'StakePool) PoolParams
 -> f (Map (KeyHash 'StakePool) PoolParams))
-> PState era -> f (PState era)
psStakePoolParamsL)

shelleyProducedValue ::
  EraTxBody era =>
  PParams era ->
  -- | Check whether a pool with a supplied PoolStakeId is already registered.
  (KeyHash 'StakePool -> Bool) ->
  TxBody era ->
  Value era
shelleyProducedValue :: forall era.
EraTxBody era =>
PParams era
-> (KeyHash 'StakePool -> Bool) -> TxBody era -> Value era
shelleyProducedValue PParams era
pp KeyHash 'StakePool -> Bool
isRegPoolId TxBody era
txBody =
  StrictSeq (TxOut era) -> Value era
forall era (f :: * -> *).
(EraTxOut era, Foldable f) =>
f (TxOut era) -> Value era
sumAllValue (TxBody era
txBody TxBody era
-> Getting
     (StrictSeq (TxOut era)) (TxBody era) (StrictSeq (TxOut era))
-> StrictSeq (TxOut era)
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictSeq (TxOut era)) (TxBody era) (StrictSeq (TxOut era))
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL)
    Value era -> Value era -> Value era
forall t. Val t => t -> t -> t
<+> Coin -> Value era
forall t s. Inject t s => t -> s
Val.inject
      (TxBody era
txBody TxBody era -> Getting Coin (TxBody era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (TxBody era) Coin
forall era. EraTxBody era => Lens' (TxBody era) Coin
Lens' (TxBody era) Coin
feeTxBodyL Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> PParams era -> (KeyHash 'StakePool -> Bool) -> TxBody era -> Coin
forall era.
EraTxBody era =>
PParams era -> (KeyHash 'StakePool -> Bool) -> TxBody era -> Coin
getTotalDepositsTxBody PParams era
pp KeyHash 'StakePool -> Bool
isRegPoolId TxBody era
txBody)

-- | Compute the lovelace which are destroyed by the transaction. This implementation is
-- suitable for Shelley and Allegra only.
getConsumedCoin ::
  EraTxBody era =>
  PParams era ->
  (Credential 'Staking -> Maybe Coin) ->
  UTxO era ->
  TxBody era ->
  Coin
getConsumedCoin :: forall era.
EraTxBody era =>
PParams era
-> (Credential 'Staking -> Maybe Coin)
-> UTxO era
-> TxBody era
-> Coin
getConsumedCoin PParams era
pp Credential 'Staking -> Maybe Coin
lookupRefund UTxO era
utxo TxBody era
txBody =
  {- balance (txins tx ◁ u) + wbalance (txwdrls tx) + keyRefunds dpstate tx -}
  UTxO era -> Coin
forall era. EraTxOut era => UTxO era -> Coin
sumCoinUTxO (UTxO era -> Set TxIn -> UTxO era
forall era. UTxO era -> Set TxIn -> UTxO era
txInsFilter UTxO era
utxo (TxBody era
txBody TxBody era
-> Getting (Set TxIn) (TxBody era) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. Getting (Set TxIn) (TxBody era) (Set TxIn)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL))
    Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
refunds
    Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
withdrawals
  where
    refunds :: Coin
refunds = PParams era
-> (Credential 'Staking -> Maybe Coin)
-> (Credential 'DRepRole -> Maybe Coin)
-> TxBody era
-> Coin
forall era.
EraTxBody era =>
PParams era
-> (Credential 'Staking -> Maybe Coin)
-> (Credential 'DRepRole -> Maybe Coin)
-> TxBody era
-> Coin
getTotalRefundsTxBody PParams era
pp Credential 'Staking -> Maybe Coin
lookupRefund (Maybe Coin -> Credential 'DRepRole -> Maybe Coin
forall a b. a -> b -> a
const Maybe Coin
forall a. Maybe a
Nothing) TxBody era
txBody
    withdrawals :: Coin
withdrawals = Map RewardAccount Coin -> Coin
forall m. Monoid m => Map RewardAccount m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Map RewardAccount Coin -> Coin)
-> (Withdrawals -> Map RewardAccount Coin) -> Withdrawals -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Withdrawals -> Map RewardAccount Coin
unWithdrawals (Withdrawals -> Coin) -> Withdrawals -> Coin
forall a b. (a -> b) -> a -> b
$ TxBody era
txBody TxBody era
-> Getting Withdrawals (TxBody era) Withdrawals -> Withdrawals
forall s a. s -> Getting a s a -> a
^. Getting Withdrawals (TxBody era) Withdrawals
forall era. EraTxBody era => Lens' (TxBody era) Withdrawals
Lens' (TxBody era) Withdrawals
withdrawalsTxBodyL

newtype ShelleyScriptsNeeded era = ShelleyScriptsNeeded (Set ScriptHash)
  deriving (ShelleyScriptsNeeded era -> ShelleyScriptsNeeded era -> Bool
(ShelleyScriptsNeeded era -> ShelleyScriptsNeeded era -> Bool)
-> (ShelleyScriptsNeeded era -> ShelleyScriptsNeeded era -> Bool)
-> Eq (ShelleyScriptsNeeded era)
forall era.
ShelleyScriptsNeeded era -> ShelleyScriptsNeeded era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall era.
ShelleyScriptsNeeded era -> ShelleyScriptsNeeded era -> Bool
== :: ShelleyScriptsNeeded era -> ShelleyScriptsNeeded era -> Bool
$c/= :: forall era.
ShelleyScriptsNeeded era -> ShelleyScriptsNeeded era -> Bool
/= :: ShelleyScriptsNeeded era -> ShelleyScriptsNeeded era -> Bool
Eq, Int -> ShelleyScriptsNeeded era -> ShowS
[ShelleyScriptsNeeded era] -> ShowS
ShelleyScriptsNeeded era -> String
(Int -> ShelleyScriptsNeeded era -> ShowS)
-> (ShelleyScriptsNeeded era -> String)
-> ([ShelleyScriptsNeeded era] -> ShowS)
-> Show (ShelleyScriptsNeeded era)
forall era. Int -> ShelleyScriptsNeeded era -> ShowS
forall era. [ShelleyScriptsNeeded era] -> ShowS
forall era. ShelleyScriptsNeeded era -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall era. Int -> ShelleyScriptsNeeded era -> ShowS
showsPrec :: Int -> ShelleyScriptsNeeded era -> ShowS
$cshow :: forall era. ShelleyScriptsNeeded era -> String
show :: ShelleyScriptsNeeded era -> String
$cshowList :: forall era. [ShelleyScriptsNeeded era] -> ShowS
showList :: [ShelleyScriptsNeeded era] -> ShowS
Show)

instance EraUTxO ShelleyEra where
  type ScriptsNeeded ShelleyEra = ShelleyScriptsNeeded ShelleyEra

  consumed :: PParams ShelleyEra
-> CertState ShelleyEra
-> UTxO ShelleyEra
-> TxBody ShelleyEra
-> Value ShelleyEra
consumed = PParams ShelleyEra
-> CertState ShelleyEra
-> UTxO ShelleyEra
-> TxBody ShelleyEra
-> Value ShelleyEra
forall era.
(EraUTxO era, EraCertState era) =>
PParams era -> CertState era -> UTxO era -> TxBody era -> Value era
shelleyConsumed

  getConsumedValue :: PParams ShelleyEra
-> (Credential 'Staking -> Maybe Coin)
-> (Credential 'DRepRole -> Maybe Coin)
-> UTxO ShelleyEra
-> TxBody ShelleyEra
-> Value ShelleyEra
getConsumedValue PParams ShelleyEra
pp Credential 'Staking -> Maybe Coin
lookupKeyDeposit Credential 'DRepRole -> Maybe Coin
_ = PParams ShelleyEra
-> (Credential 'Staking -> Maybe Coin)
-> UTxO ShelleyEra
-> TxBody ShelleyEra
-> Coin
forall era.
EraTxBody era =>
PParams era
-> (Credential 'Staking -> Maybe Coin)
-> UTxO era
-> TxBody era
-> Coin
getConsumedCoin PParams ShelleyEra
pp Credential 'Staking -> Maybe Coin
lookupKeyDeposit

  getProducedValue :: PParams ShelleyEra
-> (KeyHash 'StakePool -> Bool)
-> TxBody ShelleyEra
-> Value ShelleyEra
getProducedValue = PParams ShelleyEra
-> (KeyHash 'StakePool -> Bool)
-> TxBody ShelleyEra
-> Value ShelleyEra
forall era.
EraTxBody era =>
PParams era
-> (KeyHash 'StakePool -> Bool) -> TxBody era -> Value era
shelleyProducedValue

  getScriptsProvided :: UTxO ShelleyEra -> Tx ShelleyEra -> ScriptsProvided ShelleyEra
getScriptsProvided UTxO ShelleyEra
_ Tx ShelleyEra
tx = Map ScriptHash (Script ShelleyEra) -> ScriptsProvided ShelleyEra
forall era. Map ScriptHash (Script era) -> ScriptsProvided era
ScriptsProvided (Tx ShelleyEra
ShelleyTx ShelleyEra
tx ShelleyTx ShelleyEra
-> Getting
     (Map ScriptHash (MultiSig ShelleyEra))
     (ShelleyTx ShelleyEra)
     (Map ScriptHash (MultiSig ShelleyEra))
-> Map ScriptHash (MultiSig ShelleyEra)
forall s a. s -> Getting a s a -> a
^. (TxWits ShelleyEra
 -> Const
      (Map ScriptHash (MultiSig ShelleyEra)) (TxWits ShelleyEra))
-> Tx ShelleyEra
-> Const (Map ScriptHash (MultiSig ShelleyEra)) (Tx ShelleyEra)
(TxWits ShelleyEra
 -> Const
      (Map ScriptHash (MultiSig ShelleyEra)) (TxWits ShelleyEra))
-> ShelleyTx ShelleyEra
-> Const
     (Map ScriptHash (MultiSig ShelleyEra)) (ShelleyTx ShelleyEra)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx ShelleyEra) (TxWits ShelleyEra)
witsTxL ((TxWits ShelleyEra
  -> Const
       (Map ScriptHash (MultiSig ShelleyEra)) (TxWits ShelleyEra))
 -> ShelleyTx ShelleyEra
 -> Const
      (Map ScriptHash (MultiSig ShelleyEra)) (ShelleyTx ShelleyEra))
-> ((Map ScriptHash (MultiSig ShelleyEra)
     -> Const
          (Map ScriptHash (MultiSig ShelleyEra))
          (Map ScriptHash (MultiSig ShelleyEra)))
    -> TxWits ShelleyEra
    -> Const
         (Map ScriptHash (MultiSig ShelleyEra)) (TxWits ShelleyEra))
-> Getting
     (Map ScriptHash (MultiSig ShelleyEra))
     (ShelleyTx ShelleyEra)
     (Map ScriptHash (MultiSig ShelleyEra))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map ScriptHash (Script ShelleyEra)
 -> Const
      (Map ScriptHash (MultiSig ShelleyEra))
      (Map ScriptHash (Script ShelleyEra)))
-> TxWits ShelleyEra
-> Const (Map ScriptHash (MultiSig ShelleyEra)) (TxWits ShelleyEra)
(Map ScriptHash (MultiSig ShelleyEra)
 -> Const
      (Map ScriptHash (MultiSig ShelleyEra))
      (Map ScriptHash (MultiSig ShelleyEra)))
-> TxWits ShelleyEra
-> Const (Map ScriptHash (MultiSig ShelleyEra)) (TxWits ShelleyEra)
forall era.
EraTxWits era =>
Lens' (TxWits era) (Map ScriptHash (Script era))
Lens' (TxWits ShelleyEra) (Map ScriptHash (Script ShelleyEra))
scriptTxWitsL)

  getScriptsNeeded :: UTxO ShelleyEra -> TxBody ShelleyEra -> ScriptsNeeded ShelleyEra
getScriptsNeeded = UTxO ShelleyEra -> TxBody ShelleyEra -> ScriptsNeeded ShelleyEra
UTxO ShelleyEra
-> TxBody ShelleyEra -> ShelleyScriptsNeeded ShelleyEra
forall era.
EraTxBody era =>
UTxO era -> TxBody era -> ShelleyScriptsNeeded era
getShelleyScriptsNeeded

  getScriptsHashesNeeded :: ScriptsNeeded ShelleyEra -> Set ScriptHash
getScriptsHashesNeeded (ShelleyScriptsNeeded Set ScriptHash
scriptsHashes) = Set ScriptHash
scriptsHashes

  getWitsVKeyNeeded :: CertState ShelleyEra
-> UTxO ShelleyEra -> TxBody ShelleyEra -> Set (KeyHash 'Witness)
getWitsVKeyNeeded = CertState ShelleyEra
-> UTxO ShelleyEra -> TxBody ShelleyEra -> Set (KeyHash 'Witness)
forall era.
(EraTx era, ShelleyEraTxBody era, EraCertState era) =>
CertState era -> UTxO era -> TxBody era -> Set (KeyHash 'Witness)
getShelleyWitsVKeyNeeded

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

-- We don't consider the reference scripts in the calculation before Conway
getShelleyMinFeeTxUtxo :: EraTx era => PParams era -> Tx era -> Coin
getShelleyMinFeeTxUtxo :: forall era. EraTx era => PParams era -> Tx era -> Coin
getShelleyMinFeeTxUtxo PParams era
pparams Tx era
tx = PParams era -> Tx era -> Int -> Coin
forall era. EraTx era => PParams era -> Tx era -> Int -> Coin
getMinFeeTx PParams era
pparams Tx era
tx Int
0

-- | Collect the set of hashes of keys that needs to sign a
--  given transaction. This set consists of the txin owners,
--  certificate authors, and withdrawal reward accounts.
witsVKeyNeededGenDelegs ::
  forall era.
  ShelleyEraTxBody era =>
  TxBody era ->
  GenDelegs ->
  Set (KeyHash 'Witness)
witsVKeyNeededGenDelegs :: forall era.
ShelleyEraTxBody era =>
TxBody era -> GenDelegs -> Set (KeyHash 'Witness)
witsVKeyNeededGenDelegs TxBody era
txBody (GenDelegs Map (KeyHash 'Genesis) GenDelegPair
genDelegs) =
  KeyHash 'Witness -> KeyHash 'Witness
forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness (KeyHash 'Witness -> KeyHash 'Witness)
-> Set (KeyHash 'Witness) -> Set (KeyHash 'Witness)
forall b a. Ord b => (a -> b) -> Set a -> Set b
`Set.map` StrictMaybe (Update era) -> Set (KeyHash 'Witness)
proposedUpdatesWitnesses (TxBody era
txBody TxBody era
-> Getting
     (StrictMaybe (Update era)) (TxBody era) (StrictMaybe (Update era))
-> StrictMaybe (Update era)
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictMaybe (Update era)) (TxBody era) (StrictMaybe (Update era))
forall era.
ShelleyEraTxBody era =>
Lens' (TxBody era) (StrictMaybe (Update era))
Lens' (TxBody era) (StrictMaybe (Update era))
updateTxBodyL)
  where
    -- Calculate the set of hash keys of the required witnesses for update
    -- proposals.
    proposedUpdatesWitnesses :: StrictMaybe (Update era) -> Set (KeyHash 'Witness)
proposedUpdatesWitnesses = \case
      StrictMaybe (Update era)
SNothing -> Set (KeyHash 'Witness)
forall a. Set a
Set.empty
      SJust (Update (ProposedPPUpdates Map (KeyHash 'Genesis) (PParamsUpdate era)
pup) EpochNo
_) ->
        (KeyHash 'GenesisDelegate -> KeyHash 'Witness)
-> Set (KeyHash 'GenesisDelegate) -> Set (KeyHash 'Witness)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map KeyHash 'GenesisDelegate -> KeyHash 'Witness
forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness (Set (KeyHash 'GenesisDelegate) -> Set (KeyHash 'Witness))
-> ([KeyHash 'GenesisDelegate] -> Set (KeyHash 'GenesisDelegate))
-> [KeyHash 'GenesisDelegate]
-> Set (KeyHash 'Witness)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [KeyHash 'GenesisDelegate] -> Set (KeyHash 'GenesisDelegate)
forall a. Ord a => [a] -> Set a
Set.fromList ([KeyHash 'GenesisDelegate] -> Set (KeyHash 'Witness))
-> [KeyHash 'GenesisDelegate] -> Set (KeyHash 'Witness)
forall a b. (a -> b) -> a -> b
$ Map (KeyHash 'Genesis) (KeyHash 'GenesisDelegate)
-> [KeyHash 'GenesisDelegate]
forall k a. Map k a -> [a]
Map.elems Map (KeyHash 'Genesis) (KeyHash 'GenesisDelegate)
updateKeys''
        where
          updateKeys' :: Map (KeyHash 'Genesis) GenDelegPair
updateKeys' = Exp (Map (KeyHash 'Genesis) GenDelegPair)
-> Map (KeyHash 'Genesis) GenDelegPair
forall s t. Embed s t => Exp t -> s
eval (Map (KeyHash 'Genesis) (PParamsUpdate era)
-> Set (KeyHash 'Genesis)
forall k a. Map k a -> Set k
Map.keysSet Map (KeyHash 'Genesis) (PParamsUpdate era)
pup Set (KeyHash 'Genesis)
-> Map (KeyHash 'Genesis) GenDelegPair
-> Exp (Map (KeyHash 'Genesis) GenDelegPair)
forall k s1 s2 (f :: * -> * -> *) v.
(Ord k, HasExp s1 (Sett k ()), HasExp s2 (f k v)) =>
s1 -> s2 -> Exp (f k v)
◁ Map (KeyHash 'Genesis) GenDelegPair
genDelegs)
          updateKeys'' :: Map (KeyHash 'Genesis) (KeyHash 'GenesisDelegate)
updateKeys'' = (GenDelegPair -> KeyHash 'GenesisDelegate)
-> Map (KeyHash 'Genesis) GenDelegPair
-> Map (KeyHash 'Genesis) (KeyHash 'GenesisDelegate)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map GenDelegPair -> KeyHash 'GenesisDelegate
genDelegKeyHash Map (KeyHash 'Genesis) GenDelegPair
updateKeys'

-- | Extract witnesses from UTxO and TxBody. Does not enforce witnesses for governance
-- related Keys, i.e. `GenDelegs`
getShelleyWitsVKeyNeededNoGov ::
  forall era.
  EraTx era =>
  UTxO era ->
  TxBody era ->
  Set (KeyHash 'Witness)
getShelleyWitsVKeyNeededNoGov :: forall era.
EraTx era =>
UTxO era -> TxBody era -> Set (KeyHash 'Witness)
getShelleyWitsVKeyNeededNoGov UTxO era
utxo' TxBody era
txBody =
  Set (KeyHash 'Witness)
certAuthors
    Set (KeyHash 'Witness)
-> Set (KeyHash 'Witness) -> Set (KeyHash 'Witness)
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set (KeyHash 'Witness)
inputAuthors
    Set (KeyHash 'Witness)
-> Set (KeyHash 'Witness) -> Set (KeyHash 'Witness)
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set (KeyHash 'Witness)
owners
    Set (KeyHash 'Witness)
-> Set (KeyHash 'Witness) -> Set (KeyHash 'Witness)
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set (KeyHash 'Witness)
wdrlAuthors
  where
    inputAuthors :: Set (KeyHash 'Witness)
    inputAuthors :: Set (KeyHash 'Witness)
inputAuthors = (TxIn -> Set (KeyHash 'Witness) -> Set (KeyHash 'Witness))
-> Set (KeyHash 'Witness) -> Set TxIn -> Set (KeyHash 'Witness)
forall a b. (a -> b -> b) -> b -> Set a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr' TxIn -> Set (KeyHash 'Witness) -> Set (KeyHash 'Witness)
accum Set (KeyHash 'Witness)
forall a. Set a
Set.empty (TxBody era
txBody TxBody era
-> Getting (Set TxIn) (TxBody era) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. Getting (Set TxIn) (TxBody era) (Set TxIn)
forall era. EraTxBody era => SimpleGetter (TxBody era) (Set TxIn)
SimpleGetter (TxBody era) (Set TxIn)
spendableInputsTxBodyF)
      where
        accum :: TxIn -> Set (KeyHash 'Witness) -> Set (KeyHash 'Witness)
accum TxIn
txin !Set (KeyHash 'Witness)
ans =
          case TxIn -> UTxO era -> Maybe (TxOut era)
forall era. TxIn -> UTxO era -> Maybe (TxOut era)
txinLookup TxIn
txin UTxO era
utxo' of
            Just TxOut era
txOut ->
              case TxOut era
txOut TxOut era -> Getting Addr (TxOut era) Addr -> Addr
forall s a. s -> Getting a s a -> a
^. Getting Addr (TxOut era) Addr
forall era. EraTxOut era => Lens' (TxOut era) Addr
Lens' (TxOut era) Addr
addrTxOutL of
                Addr Network
_ (KeyHashObj KeyHash 'Payment
pay) StakeReference
_ -> KeyHash 'Witness
-> Set (KeyHash 'Witness) -> Set (KeyHash 'Witness)
forall a. Ord a => a -> Set a -> Set a
Set.insert (KeyHash 'Payment -> KeyHash 'Witness
forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyHash 'Payment
pay) Set (KeyHash 'Witness)
ans
                AddrBootstrap BootstrapAddress
bootAddr ->
                  KeyHash 'Witness
-> Set (KeyHash 'Witness) -> Set (KeyHash 'Witness)
forall a. Ord a => a -> Set a -> Set a
Set.insert (KeyHash 'Payment -> KeyHash 'Witness
forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness (BootstrapAddress -> KeyHash 'Payment
bootstrapKeyHash BootstrapAddress
bootAddr)) Set (KeyHash 'Witness)
ans
                Addr
_ -> Set (KeyHash 'Witness)
ans
            Maybe (TxOut era)
Nothing -> Set (KeyHash 'Witness)
ans

    wdrlAuthors :: Set (KeyHash 'Witness)
    wdrlAuthors :: Set (KeyHash 'Witness)
wdrlAuthors = (RewardAccount
 -> Coin -> Set (KeyHash 'Witness) -> Set (KeyHash 'Witness))
-> Set (KeyHash 'Witness)
-> Map RewardAccount Coin
-> Set (KeyHash 'Witness)
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey' RewardAccount
-> Coin -> Set (KeyHash 'Witness) -> Set (KeyHash 'Witness)
forall {p}.
RewardAccount
-> p -> Set (KeyHash 'Witness) -> Set (KeyHash 'Witness)
accum Set (KeyHash 'Witness)
forall a. Set a
Set.empty (Withdrawals -> Map RewardAccount Coin
unWithdrawals (TxBody era
txBody TxBody era
-> Getting Withdrawals (TxBody era) Withdrawals -> Withdrawals
forall s a. s -> Getting a s a -> a
^. Getting Withdrawals (TxBody era) Withdrawals
forall era. EraTxBody era => Lens' (TxBody era) Withdrawals
Lens' (TxBody era) Withdrawals
withdrawalsTxBodyL))
      where
        accum :: RewardAccount
-> p -> Set (KeyHash 'Witness) -> Set (KeyHash 'Witness)
accum RewardAccount
key p
_ !Set (KeyHash 'Witness)
ans =
          case Credential 'Staking -> Maybe (KeyHash 'Witness)
forall (r :: KeyRole). Credential r -> Maybe (KeyHash 'Witness)
credKeyHashWitness (RewardAccount -> Credential 'Staking
raCredential RewardAccount
key) of
            Maybe (KeyHash 'Witness)
Nothing -> Set (KeyHash 'Witness)
ans
            Just KeyHash 'Witness
vkeyWit -> KeyHash 'Witness
-> Set (KeyHash 'Witness) -> Set (KeyHash 'Witness)
forall a. Ord a => a -> Set a -> Set a
Set.insert KeyHash 'Witness
vkeyWit Set (KeyHash 'Witness)
ans
    owners :: Set (KeyHash 'Witness)
    owners :: Set (KeyHash 'Witness)
owners = (TxCert era -> Set (KeyHash 'Witness) -> Set (KeyHash 'Witness))
-> Set (KeyHash 'Witness)
-> StrictSeq (TxCert era)
-> Set (KeyHash 'Witness)
forall a b. (a -> b -> b) -> b -> StrictSeq a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr' TxCert era -> Set (KeyHash 'Witness) -> Set (KeyHash 'Witness)
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTxCert era) =>
TxCert era -> Set (KeyHash 'Witness) -> Set (KeyHash 'Witness)
accum Set (KeyHash 'Witness)
forall a. Set a
Set.empty (TxBody era
txBody TxBody era
-> Getting
     (StrictSeq (TxCert era)) (TxBody era) (StrictSeq (TxCert era))
-> StrictSeq (TxCert era)
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictSeq (TxCert era)) (TxBody era) (StrictSeq (TxCert era))
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL)
      where
        accum :: TxCert era -> Set (KeyHash 'Witness) -> Set (KeyHash 'Witness)
accum (RegPoolTxCert PoolParams
pool) !Set (KeyHash 'Witness)
ans =
          Set (KeyHash 'Witness)
-> Set (KeyHash 'Witness) -> Set (KeyHash 'Witness)
forall a. Ord a => Set a -> Set a -> Set a
Set.union
            ((KeyHash 'Staking -> KeyHash 'Witness)
-> Set (KeyHash 'Staking) -> Set (KeyHash 'Witness)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map KeyHash 'Staking -> KeyHash 'Witness
forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness (PoolParams -> Set (KeyHash 'Staking)
ppOwners PoolParams
pool))
            Set (KeyHash 'Witness)
ans
        accum TxCert era
_cert Set (KeyHash 'Witness)
ans = Set (KeyHash 'Witness)
ans
    certAuthors :: Set (KeyHash 'Witness)
    certAuthors :: Set (KeyHash 'Witness)
certAuthors = (TxCert era -> Set (KeyHash 'Witness) -> Set (KeyHash 'Witness))
-> Set (KeyHash 'Witness)
-> StrictSeq (TxCert era)
-> Set (KeyHash 'Witness)
forall a b. (a -> b -> b) -> b -> StrictSeq a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr' TxCert era -> Set (KeyHash 'Witness) -> Set (KeyHash 'Witness)
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTxCert era) =>
TxCert era -> Set (KeyHash 'Witness) -> Set (KeyHash 'Witness)
accum Set (KeyHash 'Witness)
forall a. Set a
Set.empty (TxBody era
txBody TxBody era
-> Getting
     (StrictSeq (TxCert era)) (TxBody era) (StrictSeq (TxCert era))
-> StrictSeq (TxCert era)
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictSeq (TxCert era)) (TxBody era) (StrictSeq (TxCert era))
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL)
      where
        accum :: TxCert era -> Set (KeyHash 'Witness) -> Set (KeyHash 'Witness)
accum TxCert era
cert !Set (KeyHash 'Witness)
ans =
          case TxCert era -> Maybe (KeyHash 'Witness)
forall era. EraTxCert era => TxCert era -> Maybe (KeyHash 'Witness)
getVKeyWitnessTxCert TxCert era
cert of
            Maybe (KeyHash 'Witness)
Nothing -> Set (KeyHash 'Witness)
ans
            Just KeyHash 'Witness
vkeyWit -> KeyHash 'Witness
-> Set (KeyHash 'Witness) -> Set (KeyHash 'Witness)
forall a. Ord a => a -> Set a -> Set a
Set.insert KeyHash 'Witness
vkeyWit Set (KeyHash 'Witness)
ans

getShelleyWitsVKeyNeeded ::
  forall era.
  (EraTx era, ShelleyEraTxBody era, EraCertState era) =>
  CertState era ->
  UTxO era ->
  TxBody era ->
  Set (KeyHash 'Witness)
getShelleyWitsVKeyNeeded :: forall era.
(EraTx era, ShelleyEraTxBody era, EraCertState era) =>
CertState era -> UTxO era -> TxBody era -> Set (KeyHash 'Witness)
getShelleyWitsVKeyNeeded CertState era
certState UTxO era
utxo TxBody era
txBody =
  UTxO era -> TxBody era -> Set (KeyHash 'Witness)
forall era.
EraTx era =>
UTxO era -> TxBody era -> Set (KeyHash 'Witness)
getShelleyWitsVKeyNeededNoGov UTxO era
utxo TxBody era
txBody
    Set (KeyHash 'Witness)
-> Set (KeyHash 'Witness) -> Set (KeyHash 'Witness)
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` TxBody era -> GenDelegs -> Set (KeyHash 'Witness)
forall era.
ShelleyEraTxBody era =>
TxBody era -> GenDelegs -> Set (KeyHash 'Witness)
witsVKeyNeededGenDelegs TxBody era
txBody (DState era -> GenDelegs
forall era. DState era -> GenDelegs
dsGenDelegs (CertState era
certState CertState era
-> Getting (DState era) (CertState era) (DState era) -> DState era
forall s a. s -> Getting a s a -> a
^. Getting (DState era) (CertState era) (DState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL))