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

module Cardano.Ledger.Shelley.UTxO (
  EraUTxO (..),
  ShelleyScriptsNeeded (..),
  scriptsNeeded,
  getShelleyScriptsNeeded,
  scriptCred,
  scriptStakeCred,
  getConsumedCoin,
  shelleyProducedValue,
  consumed,
  produced,
  txup,
  getShelleyMinFeeTxUtxo,
  getShelleyWitsVKeyNeeded,
  getShelleyWitsVKeyNeededNoGov,
  module UTxO,
)
where

import Cardano.Ledger.Address (Addr (..), bootstrapKeyHash)
import Cardano.Ledger.BaseTypes (StrictMaybe (..), strictMaybeToMaybe)
import Cardano.Ledger.CertState (
  CertState (..),
  certDStateL,
  certPStateL,
  certVStateL,
  dsGenDelegs,
  lookupDepositDState,
  lookupDepositVState,
  psStakePoolParamsL,
 )
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (Credential (..), credKeyHashWitness, credScriptHash)
import Cardano.Ledger.Crypto (Crypto)
import Cardano.Ledger.Keys (
  GenDelegs (..),
  KeyHash (..),
  KeyRole (..),
  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.Tx ()
import Cardano.Ledger.Shelley.TxBody (
  ShelleyEraTxBody (..),
  Withdrawals (..),
  raCredential,
 )
import Cardano.Ledger.Shelley.TxCert (
  ShelleyEraTxCert,
  pattern DelegStakeTxCert,
  pattern RegTxCert,
  pattern UnRegTxCert,
 )
import Cardano.Ledger.TxIn (TxIn (..))
import Cardano.Ledger.UTxO as UTxO
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 ((^.))

txup :: (EraTx era, ShelleyEraTxBody era) => Tx era -> Maybe (Update era)
txup :: forall era.
(EraTx era, ShelleyEraTxBody era) =>
Tx era -> Maybe (Update era)
txup Tx era
tx = forall a. StrictMaybe a -> Maybe a
strictMaybeToMaybe (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.
ShelleyEraTxBody era =>
Lens' (TxBody era) (StrictMaybe (Update era))
updateTxBodyL)
{-# DEPRECATED txup "In favor of `updateTxBodyL`" #-}

scriptStakeCred ::
  ShelleyEraTxCert era =>
  TxCert era ->
  Maybe (ScriptHash (EraCrypto era))
scriptStakeCred :: forall era.
ShelleyEraTxCert era =>
TxCert era -> Maybe (ScriptHash (EraCrypto era))
scriptStakeCred = \case
  RegTxCert StakeCredential (EraCrypto era)
_ -> forall a. Maybe a
Nothing
  UnRegTxCert StakeCredential (EraCrypto era)
cred -> forall (kr :: KeyRole) c. Credential kr c -> Maybe (ScriptHash c)
credScriptHash StakeCredential (EraCrypto era)
cred
  DelegStakeTxCert StakeCredential (EraCrypto era)
cred KeyHash 'StakePool (EraCrypto era)
_ -> forall (kr :: KeyRole) c. Credential kr c -> Maybe (ScriptHash c)
credScriptHash StakeCredential (EraCrypto era)
cred
  TxCert era
_ -> forall a. Maybe a
Nothing
{-# DEPRECATED scriptStakeCred "In favor of `getScriptWitnessTxCert`" #-}

scriptCred :: Credential kr c -> Maybe (ScriptHash c)
scriptCred :: forall (kr :: KeyRole) c. Credential kr c -> Maybe (ScriptHash c)
scriptCred = forall (kr :: KeyRole) c. Credential kr c -> Maybe (ScriptHash c)
credScriptHash
{-# DEPRECATED scriptCred "In favor of `credScriptHash`" #-}

-- | Computes the set of script hashes required to unlock the transaction inputs
-- and the withdrawals.
scriptsNeeded ::
  forall era.
  EraTx era =>
  UTxO era ->
  Tx era ->
  Set (ScriptHash (EraCrypto era))
scriptsNeeded :: forall era.
EraTx era =>
UTxO era -> Tx era -> Set (ScriptHash (EraCrypto era))
scriptsNeeded UTxO era
u Tx era
tx =
  case forall era.
EraTxBody era =>
UTxO era -> TxBody era -> ShelleyScriptsNeeded era
getShelleyScriptsNeeded UTxO era
u (Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL) of
    ShelleyScriptsNeeded Set (ScriptHash (EraCrypto era))
sn -> Set (ScriptHash (EraCrypto era))
sn
{-# DEPRECATED scriptsNeeded "In favor of `getScriptsNeeded`" #-}

-- | 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 (EraCrypto era)) ->
  UTxO era ->
  Set (ScriptHash (EraCrypto era))
txinsScriptHashes :: forall era.
EraTxOut era =>
Set (TxIn (EraCrypto era))
-> UTxO era -> Set (ScriptHash (EraCrypto era))
txinsScriptHashes Set (TxIn (EraCrypto era))
txInps (UTxO Map (TxIn (EraCrypto era)) (TxOut era)
u) = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TxIn (EraCrypto era)
-> Set (ScriptHash (EraCrypto era))
-> Set (ScriptHash (EraCrypto era))
add forall a. Set a
Set.empty Set (TxIn (EraCrypto era))
txInps
  where
    -- to get subset, start with empty, and only insert those inputs in txInps
    -- that are locked in u
    add :: TxIn (EraCrypto era)
-> Set (ScriptHash (EraCrypto era))
-> Set (ScriptHash (EraCrypto era))
add TxIn (EraCrypto era)
input Set (ScriptHash (EraCrypto era))
ans = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TxIn (EraCrypto era)
input Map (TxIn (EraCrypto era)) (TxOut era)
u of
      Just TxOut era
txOut -> case TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era.
EraTxOut era =>
Lens' (TxOut era) (Addr (EraCrypto era))
addrTxOutL of
        Addr Network
_ (ScriptHashObj ScriptHash (EraCrypto era)
h) StakeReference (EraCrypto era)
_ -> forall a. Ord a => a -> Set a -> Set a
Set.insert ScriptHash (EraCrypto era)
h Set (ScriptHash (EraCrypto era))
ans
        Addr (EraCrypto era)
_ -> Set (ScriptHash (EraCrypto era))
ans
      Maybe (TxOut era)
Nothing -> Set (ScriptHash (EraCrypto era))
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 =
  forall era.
Set (ScriptHash (EraCrypto era)) -> ShelleyScriptsNeeded era
ShelleyScriptsNeeded
    ( Set (ScriptHash (EraCrypto era))
scriptHashes
        forall a. Ord a => Set a -> Set a -> Set a
`Set.union` forall a. Ord a => [a] -> Set a
Set.fromList
          [ScriptHash (EraCrypto era)
sh | RewardAcnt (EraCrypto era)
w <- [RewardAcnt (EraCrypto era)]
withdrawals, Just ScriptHash (EraCrypto era)
sh <- [forall (kr :: KeyRole) c. Credential kr c -> Maybe (ScriptHash c)
credScriptHash (forall c. RewardAccount c -> Credential 'Staking c
raCredential RewardAcnt (EraCrypto era)
w)]]
        forall a. Ord a => Set a -> Set a -> Set a
`Set.union` forall a. Ord a => [a] -> Set a
Set.fromList
          [ScriptHash (EraCrypto era)
sh | TxCert era
c <- [TxCert era]
certificates, Just ScriptHash (EraCrypto era)
sh <- [forall era.
EraTxCert era =>
TxCert era -> Maybe (ScriptHash (EraCrypto era))
getScriptWitnessTxCert TxCert era
c]]
    )
  where
    withdrawals :: [RewardAcnt (EraCrypto era)]
withdrawals = forall k a. Map k a -> [k]
Map.keys (forall c. Withdrawals c -> Map (RewardAcnt c) Coin
unWithdrawals (TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era.
EraTxBody era =>
Lens' (TxBody era) (Withdrawals (EraCrypto era))
withdrawalsTxBodyL))
    scriptHashes :: Set (ScriptHash (EraCrypto era))
scriptHashes = forall era.
EraTxOut era =>
Set (TxIn (EraCrypto era))
-> UTxO era -> Set (ScriptHash (EraCrypto era))
txinsScriptHashes (TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era.
EraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
inputsTxBodyL) UTxO era
u
    certificates :: [TxCert era]
certificates = forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era.
EraTxBody 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.
consumed ::
  EraUTxO era =>
  PParams era ->
  CertState era ->
  UTxO era ->
  TxBody era ->
  Value era
consumed :: forall era.
EraUTxO era =>
PParams era -> CertState era -> UTxO era -> TxBody era -> Value era
consumed PParams era
pp CertState era
certState =
  forall era.
EraUTxO era =>
PParams era
-> (Credential 'Staking (EraCrypto era) -> Maybe Coin)
-> (Credential 'DRepRole (EraCrypto era) -> Maybe Coin)
-> UTxO era
-> TxBody era
-> Value era
getConsumedValue
    PParams era
pp
    (forall era.
DState era -> StakeCredential (EraCrypto era) -> Maybe Coin
lookupDepositDState forall a b. (a -> b) -> a -> b
$ CertState era
certState forall s a. s -> Getting a s a -> a
^. forall era. Lens' (CertState era) (DState era)
certDStateL)
    (forall era.
VState era -> Credential 'DRepRole (EraCrypto era) -> Maybe Coin
lookupDepositVState forall a b. (a -> b) -> a -> b
$ CertState era
certState forall s a. s -> Getting a s a -> a
^. forall era. Lens' (CertState era) (VState era)
certVStateL)

-- | 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 =>
  PParams era ->
  CertState era ->
  TxBody era ->
  Value era
produced :: forall era.
EraUTxO era =>
PParams era -> CertState era -> TxBody era -> Value era
produced PParams era
pp CertState era
certState =
  forall era.
EraUTxO era =>
PParams era
-> (KeyHash 'StakePool (EraCrypto era) -> Bool)
-> TxBody era
-> Value era
getProducedValue PParams era
pp (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Bool
Map.member forall a b. (a -> b) -> a -> b
$ CertState era
certState forall s a. s -> Getting a s a -> a
^. forall era. Lens' (CertState era) (PState era)
certPStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Lens'
  (PState era)
  (Map
     (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era)))
psStakePoolParamsL)

shelleyProducedValue ::
  EraTxBody era =>
  PParams era ->
  -- | Check whether a pool with a supplied PoolStakeId is already registered.
  (KeyHash 'StakePool (EraCrypto era) -> Bool) ->
  TxBody era ->
  Value era
shelleyProducedValue :: forall era.
EraTxBody era =>
PParams era
-> (KeyHash 'StakePool (EraCrypto era) -> Bool)
-> TxBody era
-> Value era
shelleyProducedValue PParams era
pp KeyHash 'StakePool (EraCrypto era) -> Bool
isRegPoolId TxBody era
txBody =
  forall era (f :: * -> *).
(EraTxOut era, Foldable f) =>
f (TxOut era) -> Value era
sumAllValue (TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL)
    forall t. Val t => t -> t -> t
<+> forall t s. Inject t s => t -> s
Val.inject
      (TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era. EraTxBody era => Lens' (TxBody era) Coin
feeTxBodyL forall t. Val t => t -> t -> t
<+> forall era.
EraTxBody era =>
PParams era
-> (KeyHash 'StakePool (EraCrypto era) -> Bool)
-> TxBody era
-> Coin
getTotalDepositsTxBody PParams era
pp KeyHash 'StakePool (EraCrypto era) -> 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 (EraCrypto era) -> Maybe Coin) ->
  UTxO era ->
  TxBody era ->
  Coin
getConsumedCoin :: forall era.
EraTxBody era =>
PParams era
-> (Credential 'Staking (EraCrypto era) -> Maybe Coin)
-> UTxO era
-> TxBody era
-> Coin
getConsumedCoin PParams era
pp Credential 'Staking (EraCrypto era) -> Maybe Coin
lookupRefund UTxO era
utxo TxBody era
txBody =
  {- balance (txins tx ◁ u) + wbalance (txwdrls tx) + keyRefunds dpstate tx -}
  forall era. EraTxOut era => UTxO era -> Coin
coinBalance (forall era. UTxO era -> Set (TxIn (EraCrypto era)) -> UTxO era
txInsFilter UTxO era
utxo (TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era.
EraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
inputsTxBodyL))
    forall a. Semigroup a => a -> a -> a
<> Coin
refunds
    forall a. Semigroup a => a -> a -> a
<> Coin
withdrawals
  where
    refunds :: Coin
refunds = forall era.
EraTxBody era =>
PParams era
-> (Credential 'Staking (EraCrypto era) -> Maybe Coin)
-> (Credential 'DRepRole (EraCrypto era) -> Maybe Coin)
-> TxBody era
-> Coin
getTotalRefundsTxBody PParams era
pp Credential 'Staking (EraCrypto era) -> Maybe Coin
lookupRefund (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) TxBody era
txBody
    withdrawals :: Coin
withdrawals = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. Withdrawals c -> Map (RewardAcnt c) Coin
unWithdrawals forall a b. (a -> b) -> a -> b
$ TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era.
EraTxBody era =>
Lens' (TxBody era) (Withdrawals (EraCrypto era))
withdrawalsTxBodyL

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

instance Crypto c => EraUTxO (ShelleyEra c) where
  type ScriptsNeeded (ShelleyEra c) = ShelleyScriptsNeeded (ShelleyEra c)

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

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

  getScriptsProvided :: UTxO (ShelleyEra c)
-> Tx (ShelleyEra c) -> ScriptsProvided (ShelleyEra c)
getScriptsProvided UTxO (ShelleyEra c)
_ Tx (ShelleyEra c)
tx = forall era.
Map (ScriptHash (EraCrypto era)) (Script era)
-> ScriptsProvided era
ScriptsProvided (Tx (ShelleyEra c)
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)

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

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

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

  getMinFeeTxUtxo :: PParams (ShelleyEra c)
-> Tx (ShelleyEra c) -> UTxO (ShelleyEra c) -> Coin
getMinFeeTxUtxo PParams (ShelleyEra c)
pp Tx (ShelleyEra c)
tx UTxO (ShelleyEra c)
_ = forall era. EraTx era => PParams era -> Tx era -> Coin
getShelleyMinFeeTxUtxo PParams (ShelleyEra c)
pp Tx (ShelleyEra c)
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 = 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 (EraCrypto era) ->
  Set (KeyHash 'Witness (EraCrypto era))
witsVKeyNeededGenDelegs :: forall era.
ShelleyEraTxBody era =>
TxBody era
-> GenDelegs (EraCrypto era)
-> Set (KeyHash 'Witness (EraCrypto era))
witsVKeyNeededGenDelegs TxBody era
txBody (GenDelegs Map
  (KeyHash 'Genesis (EraCrypto era)) (GenDelegPair (EraCrypto era))
genDelegs) =
  forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness forall b a. Ord b => (a -> b) -> Set a -> Set b
`Set.map` StrictMaybe (Update era) -> Set (KeyHash 'Witness (EraCrypto era))
proposedUpdatesWitnesses (TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era.
ShelleyEraTxBody 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 (EraCrypto era))
proposedUpdatesWitnesses = \case
      StrictMaybe (Update era)
SNothing -> forall a. Set a
Set.empty
      SJust (Update (ProposedPPUpdates Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdate era)
pup) EpochNo
_) ->
        forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems Map
  (KeyHash 'Genesis (EraCrypto era))
  (KeyHash 'GenesisDelegate (EraCrypto era))
updateKeys''
        where
          updateKeys' :: Map
  (KeyHash 'Genesis (EraCrypto era)) (GenDelegPair (EraCrypto era))
updateKeys' = forall s t. Embed s t => Exp t -> s
eval (forall k a. Map k a -> Set k
Map.keysSet Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdate era)
pup 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 (EraCrypto era)) (GenDelegPair (EraCrypto era))
genDelegs)
          updateKeys'' :: Map
  (KeyHash 'Genesis (EraCrypto era))
  (KeyHash 'GenesisDelegate (EraCrypto era))
updateKeys'' = forall a b k. (a -> b) -> Map k a -> Map k b
Map.map forall c. GenDelegPair c -> KeyHash 'GenesisDelegate c
genDelegKeyHash Map
  (KeyHash 'Genesis (EraCrypto era)) (GenDelegPair (EraCrypto era))
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 (EraCrypto era))
getShelleyWitsVKeyNeededNoGov :: forall era.
EraTx era =>
UTxO era -> TxBody era -> Set (KeyHash 'Witness (EraCrypto era))
getShelleyWitsVKeyNeededNoGov UTxO era
utxo' TxBody era
txBody =
  Set (KeyHash 'Witness (EraCrypto era))
certAuthors
    forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set (KeyHash 'Witness (EraCrypto era))
inputAuthors
    forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set (KeyHash 'Witness (EraCrypto era))
owners
    forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set (KeyHash 'Witness (EraCrypto era))
wdrlAuthors
  where
    inputAuthors :: Set (KeyHash 'Witness (EraCrypto era))
    inputAuthors :: Set (KeyHash 'Witness (EraCrypto era))
inputAuthors = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr' TxIn (EraCrypto era)
-> Set (KeyHash 'Witness (EraCrypto era))
-> Set (KeyHash 'Witness (EraCrypto era))
accum forall a. Set a
Set.empty (TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era.
EraTxBody era =>
SimpleGetter (TxBody era) (Set (TxIn (EraCrypto era)))
spendableInputsTxBodyF)
      where
        accum :: TxIn (EraCrypto era)
-> Set (KeyHash 'Witness (EraCrypto era))
-> Set (KeyHash 'Witness (EraCrypto era))
accum TxIn (EraCrypto era)
txin !Set (KeyHash 'Witness (EraCrypto era))
ans =
          case forall era. TxIn (EraCrypto era) -> UTxO era -> Maybe (TxOut era)
txinLookup TxIn (EraCrypto era)
txin UTxO era
utxo' of
            Just TxOut era
txOut ->
              case TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era.
EraTxOut era =>
Lens' (TxOut era) (Addr (EraCrypto era))
addrTxOutL of
                Addr Network
_ (KeyHashObj KeyHash 'Payment (EraCrypto era)
pay) StakeReference (EraCrypto era)
_ -> forall a. Ord a => a -> Set a -> Set a
Set.insert (forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness KeyHash 'Payment (EraCrypto era)
pay) Set (KeyHash 'Witness (EraCrypto era))
ans
                AddrBootstrap BootstrapAddress (EraCrypto era)
bootAddr ->
                  forall a. Ord a => a -> Set a -> Set a
Set.insert (forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness (forall c. Crypto c => BootstrapAddress c -> KeyHash 'Payment c
bootstrapKeyHash BootstrapAddress (EraCrypto era)
bootAddr)) Set (KeyHash 'Witness (EraCrypto era))
ans
                Addr (EraCrypto era)
_ -> Set (KeyHash 'Witness (EraCrypto era))
ans
            Maybe (TxOut era)
Nothing -> Set (KeyHash 'Witness (EraCrypto era))
ans

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

getShelleyWitsVKeyNeeded ::
  forall era.
  (EraTx era, ShelleyEraTxBody era) =>
  CertState era ->
  UTxO era ->
  TxBody era ->
  Set (KeyHash 'Witness (EraCrypto era))
getShelleyWitsVKeyNeeded :: forall era.
(EraTx era, ShelleyEraTxBody era) =>
CertState era
-> UTxO era -> TxBody era -> Set (KeyHash 'Witness (EraCrypto era))
getShelleyWitsVKeyNeeded CertState era
certState 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` forall era.
ShelleyEraTxBody era =>
TxBody era
-> GenDelegs (EraCrypto era)
-> Set (KeyHash 'Witness (EraCrypto era))
witsVKeyNeededGenDelegs TxBody era
txBody (forall era. DState era -> GenDelegs (EraCrypto era)
dsGenDelegs (CertState era
certState forall s a. s -> Getting a s a -> a
^. forall era. Lens' (CertState era) (DState era)
certDStateL))