{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Cardano.Ledger.Shelley.Rules.Utxow (
ShelleyUTXOW,
ShelleyUtxowPredFailure (..),
ShelleyUtxowEvent (..),
PredicateFailure,
transitionRulesUTXOW,
shelleyWitsVKeyNeeded,
witsVKeyNeededGov,
witsVKeyNeededNoGov,
validateFailedNativeScripts,
validateMissingScripts,
validateVerifiedWits,
validateMetadata,
validateMIRInsufficientGenesisSigs,
validateNeededWitnesses,
propWits,
)
where
import Cardano.Crypto.DSIGN.Class (DSIGNAlgorithm (VerKeyDSIGN))
import Cardano.Ledger.AuxiliaryData (AuxiliaryDataHash)
import Cardano.Ledger.BaseTypes (
Mismatch (..),
Relation (..),
ShelleyBase,
StrictMaybe (..),
invalidKey,
maybeToStrictMaybe,
quorum,
(==>),
)
import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..), decodeRecordSum, encodeListLen)
import Cardano.Ledger.CertState (CertState, certDState, dsGenDelegs)
import Cardano.Ledger.Core
import Cardano.Ledger.Crypto (Crypto (DSIGN))
import Cardano.Ledger.Keys (
DSignable,
GenDelegPair (..),
GenDelegs (..),
Hash,
KeyHash,
KeyRole (..),
VKey,
WitVKey (..),
asWitness,
bwKey,
verifyBootstrapWit,
)
import Cardano.Ledger.Rules.ValidationMode (
Test,
runTest,
runTestOnSignal,
)
import Cardano.Ledger.SafeHash (extractHash, hashAnnotated)
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.Shelley.Era (ShelleyEra, ShelleyUTXOW)
import Cardano.Ledger.Shelley.LedgerState.Types (UTxOState (..))
import Cardano.Ledger.Shelley.PParams (ProposedPPUpdates (ProposedPPUpdates), Update (..))
import Cardano.Ledger.Shelley.Rules.Ppup (ShelleyPpupPredFailure)
import Cardano.Ledger.Shelley.Rules.Utxo (
ShelleyUTXO,
ShelleyUtxoPredFailure,
UtxoEnv (..),
UtxoEvent,
)
import qualified Cardano.Ledger.Shelley.SoftForks as SoftForks
import Cardano.Ledger.Shelley.Tx (witsFromTxWitnesses)
import Cardano.Ledger.Shelley.TxCert (isInstantaneousRewards)
import Cardano.Ledger.Shelley.UTxO (
EraUTxO (..),
ScriptsProvided (..),
ShelleyScriptsNeeded (..),
UTxO,
getShelleyWitsVKeyNeededNoGov,
verifyWitVKey,
)
import Control.DeepSeq
import Control.Monad (when)
import Control.Monad.Trans.Reader (asks)
import Control.SetAlgebra (eval, (∩), (◁))
import Control.State.Transition (
Embed,
IRC (..),
InitialRule,
STS (..),
TRC (..),
TransitionRule,
judgmentContext,
liftSTS,
trans,
wrapEvent,
wrapFailed,
)
import Data.Foldable (sequenceA_)
import qualified Data.Map.Strict as Map
import qualified Data.Sequence as Seq (filter)
import qualified Data.Sequence.Strict as StrictSeq
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Typeable (Typeable)
import Data.Word (Word64, Word8)
import GHC.Generics (Generic)
import Lens.Micro
import NoThunks.Class (NoThunks (..))
import Validation
data ShelleyUtxowPredFailure era
= InvalidWitnessesUTXOW
![VKey 'Witness (EraCrypto era)]
|
MissingVKeyWitnessesUTXOW
!(Set (KeyHash 'Witness (EraCrypto era)))
| MissingScriptWitnessesUTXOW
!(Set (ScriptHash (EraCrypto era)))
| ScriptWitnessNotValidatingUTXOW
!(Set (ScriptHash (EraCrypto era)))
| UtxoFailure (PredicateFailure (EraRule "UTXO" era))
| MIRInsufficientGenesisSigsUTXOW (Set (KeyHash 'Witness (EraCrypto era)))
| MissingTxBodyMetadataHash
!(AuxiliaryDataHash (EraCrypto era))
| MissingTxMetadata
!(AuxiliaryDataHash (EraCrypto era))
| ConflictingMetadataHash
!(Mismatch 'RelEQ (AuxiliaryDataHash (EraCrypto era)))
|
InvalidMetadata
|
!(Set (ScriptHash (EraCrypto era)))
deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x.
Rep (ShelleyUtxowPredFailure era) x -> ShelleyUtxowPredFailure era
forall era x.
ShelleyUtxowPredFailure era -> Rep (ShelleyUtxowPredFailure era) x
$cto :: forall era x.
Rep (ShelleyUtxowPredFailure era) x -> ShelleyUtxowPredFailure era
$cfrom :: forall era x.
ShelleyUtxowPredFailure era -> Rep (ShelleyUtxowPredFailure era) x
Generic)
type instance EraRuleFailure "UTXOW" (ShelleyEra c) = ShelleyUtxowPredFailure (ShelleyEra c)
instance InjectRuleFailure "UTXOW" ShelleyUtxowPredFailure (ShelleyEra c)
instance InjectRuleFailure "UTXOW" ShelleyUtxoPredFailure (ShelleyEra c) where
injectFailure :: ShelleyUtxoPredFailure (ShelleyEra c)
-> EraRuleFailure "UTXOW" (ShelleyEra c)
injectFailure = forall era.
PredicateFailure (EraRule "UTXO" era)
-> ShelleyUtxowPredFailure era
UtxoFailure
instance InjectRuleFailure "UTXOW" ShelleyPpupPredFailure (ShelleyEra c) where
injectFailure :: ShelleyPpupPredFailure (ShelleyEra c)
-> EraRuleFailure "UTXOW" (ShelleyEra c)
injectFailure = forall era.
PredicateFailure (EraRule "UTXO" era)
-> ShelleyUtxowPredFailure era
UtxoFailure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure
newtype ShelleyUtxowEvent era
= UtxoEvent (Event (EraRule "UTXO" era))
deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x.
Rep (ShelleyUtxowEvent era) x -> ShelleyUtxowEvent era
forall era x.
ShelleyUtxowEvent era -> Rep (ShelleyUtxowEvent era) x
$cto :: forall era x.
Rep (ShelleyUtxowEvent era) x -> ShelleyUtxowEvent era
$cfrom :: forall era x.
ShelleyUtxowEvent era -> Rep (ShelleyUtxowEvent era) x
Generic)
deriving instance Eq (Event (EraRule "UTXO" era)) => Eq (ShelleyUtxowEvent era)
instance NFData (Event (EraRule "UTXO" era)) => NFData (ShelleyUtxowEvent era)
instance
( NoThunks (PredicateFailure (EraRule "UTXO" era))
, Era era
) =>
NoThunks (ShelleyUtxowPredFailure era)
instance
( NFData (PredicateFailure (EraRule "UTXO" era))
, NFData (VerKeyDSIGN (DSIGN (EraCrypto era)))
, Era era
) =>
NFData (ShelleyUtxowPredFailure era)
deriving stock instance
( Eq (PredicateFailure (EraRule "UTXO" era))
, Era era
) =>
Eq (ShelleyUtxowPredFailure era)
deriving stock instance
( Show (PredicateFailure (EraRule "UTXO" era))
, Era era
) =>
Show (ShelleyUtxowPredFailure era)
instance
( Era era
, Typeable (Script era)
, Typeable (TxAuxData era)
, EncCBOR (PredicateFailure (EraRule "UTXO" era))
) =>
EncCBOR (ShelleyUtxowPredFailure era)
where
encCBOR :: ShelleyUtxowPredFailure era -> Encoding
encCBOR = \case
InvalidWitnessesUTXOW [VKey 'Witness (EraCrypto era)]
wits ->
Word -> Encoding
encodeListLen Word
2 forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (Word8
0 :: Word8) forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR [VKey 'Witness (EraCrypto era)]
wits
MissingVKeyWitnessesUTXOW Set (KeyHash 'Witness (EraCrypto era))
missing ->
Word -> Encoding
encodeListLen Word
2 forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (Word8
1 :: Word8) forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR Set (KeyHash 'Witness (EraCrypto era))
missing
MissingScriptWitnessesUTXOW Set (ScriptHash (EraCrypto era))
ss ->
Word -> Encoding
encodeListLen Word
2
forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (Word8
2 :: Word8)
forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR Set (ScriptHash (EraCrypto era))
ss
ScriptWitnessNotValidatingUTXOW Set (ScriptHash (EraCrypto era))
ss ->
Word -> Encoding
encodeListLen Word
2
forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (Word8
3 :: Word8)
forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR Set (ScriptHash (EraCrypto era))
ss
UtxoFailure PredicateFailure (EraRule "UTXO" era)
a ->
Word -> Encoding
encodeListLen Word
2
forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (Word8
4 :: Word8)
forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR PredicateFailure (EraRule "UTXO" era)
a
MIRInsufficientGenesisSigsUTXOW Set (KeyHash 'Witness (EraCrypto era))
sigs ->
Word -> Encoding
encodeListLen Word
2
forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (Word8
5 :: Word8)
forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR Set (KeyHash 'Witness (EraCrypto era))
sigs
MissingTxBodyMetadataHash AuxiliaryDataHash (EraCrypto era)
h ->
Word -> Encoding
encodeListLen Word
2 forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (Word8
6 :: Word8) forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR AuxiliaryDataHash (EraCrypto era)
h
MissingTxMetadata AuxiliaryDataHash (EraCrypto era)
h ->
Word -> Encoding
encodeListLen Word
2 forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (Word8
7 :: Word8) forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR AuxiliaryDataHash (EraCrypto era)
h
ConflictingMetadataHash Mismatch 'RelEQ (AuxiliaryDataHash (EraCrypto era))
mm ->
Word -> Encoding
encodeListLen Word
2 forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (Word8
8 :: Word8) forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR Mismatch 'RelEQ (AuxiliaryDataHash (EraCrypto era))
mm
ShelleyUtxowPredFailure era
InvalidMetadata ->
Word -> Encoding
encodeListLen Word
1 forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (Word8
9 :: Word8)
ExtraneousScriptWitnessesUTXOW Set (ScriptHash (EraCrypto era))
ss ->
Word -> Encoding
encodeListLen Word
2
forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (Word8
10 :: Word8)
forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR Set (ScriptHash (EraCrypto era))
ss
instance
( Era era
, DecCBOR (PredicateFailure (EraRule "UTXO" era))
, Typeable (Script era)
, Typeable (TxAuxData era)
) =>
DecCBOR (ShelleyUtxowPredFailure era)
where
decCBOR :: forall s. Decoder s (ShelleyUtxowPredFailure era)
decCBOR = forall s a. Text -> (Word -> Decoder s (Int, a)) -> Decoder s a
decodeRecordSum Text
"PredicateFailure (UTXOW era)" forall a b. (a -> b) -> a -> b
$
\case
Word
0 -> do
[VKey 'Witness (EraCrypto era)]
wits <- forall a s. DecCBOR a => Decoder s a
decCBOR
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
2, forall era.
[VKey 'Witness (EraCrypto era)] -> ShelleyUtxowPredFailure era
InvalidWitnessesUTXOW [VKey 'Witness (EraCrypto era)]
wits)
Word
1 -> do
Set (KeyHash 'Witness (EraCrypto era))
missing <- forall a s. DecCBOR a => Decoder s a
decCBOR
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
2, forall era.
Set (KeyHash 'Witness (EraCrypto era))
-> ShelleyUtxowPredFailure era
MissingVKeyWitnessesUTXOW Set (KeyHash 'Witness (EraCrypto era))
missing)
Word
2 -> do
Set (ScriptHash (EraCrypto era))
ss <- forall a s. DecCBOR a => Decoder s a
decCBOR
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
2, forall era.
Set (ScriptHash (EraCrypto era)) -> ShelleyUtxowPredFailure era
MissingScriptWitnessesUTXOW Set (ScriptHash (EraCrypto era))
ss)
Word
3 -> do
Set (ScriptHash (EraCrypto era))
ss <- forall a s. DecCBOR a => Decoder s a
decCBOR
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
2, forall era.
Set (ScriptHash (EraCrypto era)) -> ShelleyUtxowPredFailure era
ScriptWitnessNotValidatingUTXOW Set (ScriptHash (EraCrypto era))
ss)
Word
4 -> do
PredicateFailure (EraRule "UTXO" era)
a <- forall a s. DecCBOR a => Decoder s a
decCBOR
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
2, forall era.
PredicateFailure (EraRule "UTXO" era)
-> ShelleyUtxowPredFailure era
UtxoFailure PredicateFailure (EraRule "UTXO" era)
a)
Word
5 -> do
Set (KeyHash 'Witness (EraCrypto era))
s <- forall a s. DecCBOR a => Decoder s a
decCBOR
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
2, forall era.
Set (KeyHash 'Witness (EraCrypto era))
-> ShelleyUtxowPredFailure era
MIRInsufficientGenesisSigsUTXOW Set (KeyHash 'Witness (EraCrypto era))
s)
Word
6 -> do
AuxiliaryDataHash (EraCrypto era)
h <- forall a s. DecCBOR a => Decoder s a
decCBOR
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
2, forall era.
AuxiliaryDataHash (EraCrypto era) -> ShelleyUtxowPredFailure era
MissingTxBodyMetadataHash AuxiliaryDataHash (EraCrypto era)
h)
Word
7 -> do
AuxiliaryDataHash (EraCrypto era)
h <- forall a s. DecCBOR a => Decoder s a
decCBOR
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
2, forall era.
AuxiliaryDataHash (EraCrypto era) -> ShelleyUtxowPredFailure era
MissingTxMetadata AuxiliaryDataHash (EraCrypto era)
h)
Word
8 -> do
Mismatch 'RelEQ (AuxiliaryDataHash (EraCrypto era))
mm <- forall a s. DecCBOR a => Decoder s a
decCBOR
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
2, forall era.
Mismatch 'RelEQ (AuxiliaryDataHash (EraCrypto era))
-> ShelleyUtxowPredFailure era
ConflictingMetadataHash Mismatch 'RelEQ (AuxiliaryDataHash (EraCrypto era))
mm)
Word
9 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
1, forall era. ShelleyUtxowPredFailure era
InvalidMetadata)
Word
10 -> do
Set (ScriptHash (EraCrypto era))
ss <- forall a s. DecCBOR a => Decoder s a
decCBOR
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
2, forall era.
Set (ScriptHash (EraCrypto era)) -> ShelleyUtxowPredFailure era
ExtraneousScriptWitnessesUTXOW Set (ScriptHash (EraCrypto era))
ss)
Word
k -> forall (m :: * -> *) a. MonadFail m => Word -> m a
invalidKey Word
k
initialLedgerStateUTXOW ::
forall era.
( Embed (EraRule "UTXO" era) (ShelleyUTXOW era)
, Environment (EraRule "UTXO" era) ~ UtxoEnv era
, State (EraRule "UTXO" era) ~ UTxOState era
) =>
InitialRule (ShelleyUTXOW era)
initialLedgerStateUTXOW :: forall era.
(Embed (EraRule "UTXO" era) (ShelleyUTXOW era),
Environment (EraRule "UTXO" era) ~ UtxoEnv era,
State (EraRule "UTXO" era) ~ UTxOState era) =>
InitialRule (ShelleyUTXOW era)
initialLedgerStateUTXOW = do
IRC (UtxoEnv SlotNo
slots PParams era
pp CertState era
certState) <- forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
forall sub super (rtype :: RuleType).
Embed sub super =>
RuleContext rtype sub -> Rule super rtype (State sub)
trans @(EraRule "UTXO" era) forall a b. (a -> b) -> a -> b
$ forall sts. Environment sts -> IRC sts
IRC (forall era. SlotNo -> PParams era -> CertState era -> UtxoEnv era
UtxoEnv SlotNo
slots PParams era
pp CertState era
certState)
transitionRulesUTXOW ::
forall era.
( EraUTxO era
, ShelleyEraTxBody era
, ScriptsNeeded era ~ ShelleyScriptsNeeded era
, BaseM (EraRule "UTXOW" era) ~ ShelleyBase
, Embed (EraRule "UTXO" era) (EraRule "UTXOW" era)
, Environment (EraRule "UTXO" era) ~ UtxoEnv era
, State (EraRule "UTXO" era) ~ UTxOState era
, Signal (EraRule "UTXO" era) ~ Tx era
, Environment (EraRule "UTXOW" era) ~ UtxoEnv era
, State (EraRule "UTXOW" era) ~ UTxOState era
, Signal (EraRule "UTXOW" era) ~ Tx era
, InjectRuleFailure "UTXOW" ShelleyUtxowPredFailure era
, STS (EraRule "UTXOW" era)
, DSignable (EraCrypto era) (Hash (EraCrypto era) EraIndependentTxBody)
) =>
TransitionRule (EraRule "UTXOW" era)
transitionRulesUTXOW :: forall era.
(EraUTxO era, ShelleyEraTxBody era,
ScriptsNeeded era ~ ShelleyScriptsNeeded era,
BaseM (EraRule "UTXOW" era) ~ ShelleyBase,
Embed (EraRule "UTXO" era) (EraRule "UTXOW" era),
Environment (EraRule "UTXO" era) ~ UtxoEnv era,
State (EraRule "UTXO" era) ~ UTxOState era,
Signal (EraRule "UTXO" era) ~ Tx era,
Environment (EraRule "UTXOW" era) ~ UtxoEnv era,
State (EraRule "UTXOW" era) ~ UTxOState era,
Signal (EraRule "UTXOW" era) ~ Tx era,
InjectRuleFailure "UTXOW" ShelleyUtxowPredFailure era,
STS (EraRule "UTXOW" era),
DSignable
(EraCrypto era) (Hash (EraCrypto era) EraIndependentTxBody)) =>
TransitionRule (EraRule "UTXOW" era)
transitionRulesUTXOW = do
(TRC (utxoEnv :: Environment (EraRule "UTXOW" era)
utxoEnv@(UtxoEnv SlotNo
_ PParams era
pp CertState era
certState), State (EraRule "UTXOW" era)
u, Signal (EraRule "UTXOW" era)
tx)) <- forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
let utxo :: UTxO era
utxo = forall era. UTxOState era -> UTxO era
utxosUtxo State (EraRule "UTXOW" era)
u
witsKeyHashes :: Set (KeyHash 'Witness (EraCrypto era))
witsKeyHashes = forall era.
EraTx era =>
Tx era -> Set (KeyHash 'Witness (EraCrypto era))
witsFromTxWitnesses Signal (EraRule "UTXOW" era)
tx
scriptsProvided :: ScriptsProvided era
scriptsProvided = forall era.
EraUTxO era =>
UTxO era -> Tx era -> ScriptsProvided era
getScriptsProvided UTxO era
utxo Signal (EraRule "UTXOW" era)
tx
forall (rule :: Symbol) (f :: * -> *) era (ctx :: RuleType).
InjectRuleFailure rule f era =>
Test (f era) -> Rule (EraRule rule era) ctx ()
runTestOnSignal forall a b. (a -> b) -> a -> b
$ forall era.
EraTx era =>
ScriptsProvided era -> Tx era -> Test (ShelleyUtxowPredFailure era)
validateFailedNativeScripts ScriptsProvided era
scriptsProvided Signal (EraRule "UTXOW" era)
tx
let scriptsNeeded :: ScriptsNeeded era
scriptsNeeded = forall era.
EraUTxO era =>
UTxO era -> TxBody era -> ScriptsNeeded era
getScriptsNeeded UTxO era
utxo (Signal (EraRule "UTXOW" era)
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL)
forall (rule :: Symbol) (f :: * -> *) era (ctx :: RuleType).
InjectRuleFailure rule f era =>
Test (f era) -> Rule (EraRule rule era) ctx ()
runTest forall a b. (a -> b) -> a -> b
$ forall era.
ShelleyScriptsNeeded era
-> ScriptsProvided era -> Test (ShelleyUtxowPredFailure era)
validateMissingScripts ScriptsNeeded era
scriptsNeeded ScriptsProvided era
scriptsProvided
forall (rule :: Symbol) (f :: * -> *) era (ctx :: RuleType).
InjectRuleFailure rule f era =>
Test (f era) -> Rule (EraRule rule era) ctx ()
runTestOnSignal forall a b. (a -> b) -> a -> b
$ forall era.
(EraTx era,
DSignable
(EraCrypto era) (Hash (EraCrypto era) EraIndependentTxBody)) =>
Tx era -> Test (ShelleyUtxowPredFailure era)
validateVerifiedWits Signal (EraRule "UTXOW" era)
tx
forall (rule :: Symbol) (f :: * -> *) era (ctx :: RuleType).
InjectRuleFailure rule f era =>
Test (f era) -> Rule (EraRule rule era) ctx ()
runTest forall a b. (a -> b) -> a -> b
$ forall era.
EraUTxO era =>
Set (KeyHash 'Witness (EraCrypto era))
-> CertState era
-> UTxO era
-> TxBody era
-> Test (ShelleyUtxowPredFailure era)
validateNeededWitnesses Set (KeyHash 'Witness (EraCrypto era))
witsKeyHashes CertState era
certState UTxO era
utxo (Signal (EraRule "UTXOW" era)
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL)
forall (rule :: Symbol) (f :: * -> *) era (ctx :: RuleType).
InjectRuleFailure rule f era =>
Test (f era) -> Rule (EraRule rule era) ctx ()
runTestOnSignal forall a b. (a -> b) -> a -> b
$ forall era.
EraTx era =>
PParams era -> Tx era -> Test (ShelleyUtxowPredFailure era)
validateMetadata PParams era
pp Signal (EraRule "UTXOW" era)
tx
let genDelegs :: GenDelegs (EraCrypto era)
genDelegs = forall era. DState era -> GenDelegs (EraCrypto era)
dsGenDelegs (forall era. CertState era -> DState era
certDState CertState era
certState)
Word64
coreNodeQuorum <- forall sts a (ctx :: RuleType).
STS sts =>
BaseM sts a -> Rule sts ctx a
liftSTS forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Globals -> Word64
quorum
forall (rule :: Symbol) (f :: * -> *) era (ctx :: RuleType).
InjectRuleFailure rule f era =>
Test (f era) -> Rule (EraRule rule era) ctx ()
runTest forall a b. (a -> b) -> a -> b
$
forall era.
(EraTx era, ShelleyEraTxBody era) =>
GenDelegs (EraCrypto era)
-> Word64
-> Set (KeyHash 'Witness (EraCrypto era))
-> Tx era
-> Test (ShelleyUtxowPredFailure era)
validateMIRInsufficientGenesisSigs GenDelegs (EraCrypto era)
genDelegs Word64
coreNodeQuorum Set (KeyHash 'Witness (EraCrypto era))
witsKeyHashes Signal (EraRule "UTXOW" era)
tx
forall sub super (rtype :: RuleType).
Embed sub super =>
RuleContext rtype sub -> Rule super rtype (State sub)
trans @(EraRule "UTXO" era) forall a b. (a -> b) -> a -> b
$ forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (Environment (EraRule "UTXOW" era)
utxoEnv, State (EraRule "UTXOW" era)
u, Signal (EraRule "UTXOW" era)
tx)
instance
( Era era
, STS (ShelleyUTXO era)
, PredicateFailure (EraRule "UTXO" era) ~ ShelleyUtxoPredFailure era
, Event (EraRule "UTXO" era) ~ UtxoEvent era
) =>
Embed (ShelleyUTXO era) (ShelleyUTXOW era)
where
wrapFailed :: PredicateFailure (ShelleyUTXO era)
-> PredicateFailure (ShelleyUTXOW era)
wrapFailed = forall era.
PredicateFailure (EraRule "UTXO" era)
-> ShelleyUtxowPredFailure era
UtxoFailure
wrapEvent :: Event (ShelleyUTXO era) -> Event (ShelleyUTXOW era)
wrapEvent = forall era. Event (EraRule "UTXO" era) -> ShelleyUtxowEvent era
UtxoEvent
instance
( EraTx era
, EraUTxO era
, ShelleyEraTxBody era
, ScriptsNeeded era ~ ShelleyScriptsNeeded era
, DSignable (EraCrypto era) (Hash (EraCrypto era) EraIndependentTxBody)
,
Embed (EraRule "UTXO" era) (ShelleyUTXOW era)
, Environment (EraRule "UTXO" era) ~ UtxoEnv era
, State (EraRule "UTXO" era) ~ UTxOState era
, Signal (EraRule "UTXO" era) ~ Tx era
, EraRule "UTXOW" era ~ ShelleyUTXOW era
, InjectRuleFailure "UTXOW" ShelleyUtxowPredFailure era
, DSignable (EraCrypto era) (Hash (EraCrypto era) EraIndependentTxBody)
, EraGov era
) =>
STS (ShelleyUTXOW era)
where
type State (ShelleyUTXOW era) = UTxOState era
type Signal (ShelleyUTXOW era) = Tx era
type Environment (ShelleyUTXOW era) = UtxoEnv era
type BaseM (ShelleyUTXOW era) = ShelleyBase
type PredicateFailure (ShelleyUTXOW era) = ShelleyUtxowPredFailure era
type Event (ShelleyUTXOW era) = ShelleyUtxowEvent era
transitionRules :: [TransitionRule (ShelleyUTXOW era)]
transitionRules = [forall era.
(EraUTxO era, ShelleyEraTxBody era,
ScriptsNeeded era ~ ShelleyScriptsNeeded era,
BaseM (EraRule "UTXOW" era) ~ ShelleyBase,
Embed (EraRule "UTXO" era) (EraRule "UTXOW" era),
Environment (EraRule "UTXO" era) ~ UtxoEnv era,
State (EraRule "UTXO" era) ~ UTxOState era,
Signal (EraRule "UTXO" era) ~ Tx era,
Environment (EraRule "UTXOW" era) ~ UtxoEnv era,
State (EraRule "UTXOW" era) ~ UTxOState era,
Signal (EraRule "UTXOW" era) ~ Tx era,
InjectRuleFailure "UTXOW" ShelleyUtxowPredFailure era,
STS (EraRule "UTXOW" era),
DSignable
(EraCrypto era) (Hash (EraCrypto era) EraIndependentTxBody)) =>
TransitionRule (EraRule "UTXOW" era)
transitionRulesUTXOW]
initialRules :: [InitialRule (ShelleyUTXOW era)]
initialRules = [forall era.
(Embed (EraRule "UTXO" era) (ShelleyUTXOW era),
Environment (EraRule "UTXO" era) ~ UtxoEnv era,
State (EraRule "UTXO" era) ~ UTxOState era) =>
InitialRule (ShelleyUTXOW era)
initialLedgerStateUTXOW]
validateFailedNativeScripts ::
EraTx era => ScriptsProvided era -> Tx era -> Test (ShelleyUtxowPredFailure era)
validateFailedNativeScripts :: forall era.
EraTx era =>
ScriptsProvided era -> Tx era -> Test (ShelleyUtxowPredFailure era)
validateFailedNativeScripts (ScriptsProvided Map (ScriptHash (EraCrypto era)) (Script era)
scriptsProvided) Tx era
tx = do
let failedScripts :: Map (ScriptHash (EraCrypto era)) (Script era)
failedScripts =
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter
(forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraTx era => Tx era -> NativeScript era -> Bool
validateNativeScript Tx era
tx) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraScript era => Script era -> Maybe (NativeScript era)
getNativeScript)
Map (ScriptHash (EraCrypto era)) (Script era)
scriptsProvided
forall e. Bool -> e -> Validation (NonEmpty e) ()
failureUnless (forall k a. Map k a -> Bool
Map.null Map (ScriptHash (EraCrypto era)) (Script era)
failedScripts) forall a b. (a -> b) -> a -> b
$
forall era.
Set (ScriptHash (EraCrypto era)) -> ShelleyUtxowPredFailure era
ScriptWitnessNotValidatingUTXOW (forall k a. Map k a -> Set k
Map.keysSet Map (ScriptHash (EraCrypto era)) (Script era)
failedScripts)
validateMissingScripts ::
ShelleyScriptsNeeded era ->
ScriptsProvided era ->
Test (ShelleyUtxowPredFailure era)
validateMissingScripts :: forall era.
ShelleyScriptsNeeded era
-> ScriptsProvided era -> Test (ShelleyUtxowPredFailure era)
validateMissingScripts (ShelleyScriptsNeeded Set (ScriptHash (EraCrypto era))
sNeeded) ScriptsProvided era
scriptsprovided =
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Applicative f) =>
t (f a) -> f ()
sequenceA_
[ forall e. Bool -> e -> Validation (NonEmpty e) ()
failureUnless (Set (ScriptHash (EraCrypto era))
sNeeded forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set (ScriptHash (EraCrypto era))
sProvided) forall a b. (a -> b) -> a -> b
$
forall era.
Set (ScriptHash (EraCrypto era)) -> ShelleyUtxowPredFailure era
MissingScriptWitnessesUTXOW (Set (ScriptHash (EraCrypto era))
sNeeded forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set (ScriptHash (EraCrypto era))
sProvided)
, forall e. Bool -> e -> Validation (NonEmpty e) ()
failureUnless (Set (ScriptHash (EraCrypto era))
sProvided forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set (ScriptHash (EraCrypto era))
sNeeded) forall a b. (a -> b) -> a -> b
$
forall era.
Set (ScriptHash (EraCrypto era)) -> ShelleyUtxowPredFailure era
ExtraneousScriptWitnessesUTXOW (Set (ScriptHash (EraCrypto era))
sProvided forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set (ScriptHash (EraCrypto era))
sNeeded)
]
where
sProvided :: Set (ScriptHash (EraCrypto era))
sProvided = forall k a. Map k a -> Set k
Map.keysSet forall a b. (a -> b) -> a -> b
$ forall era.
ScriptsProvided era
-> Map (ScriptHash (EraCrypto era)) (Script era)
unScriptsProvided ScriptsProvided era
scriptsprovided
validateVerifiedWits ::
( EraTx era
, DSignable (EraCrypto era) (Hash (EraCrypto era) EraIndependentTxBody)
) =>
Tx era ->
Test (ShelleyUtxowPredFailure era)
validateVerifiedWits :: forall era.
(EraTx era,
DSignable
(EraCrypto era) (Hash (EraCrypto era) EraIndependentTxBody)) =>
Tx era -> Test (ShelleyUtxowPredFailure era)
validateVerifiedWits Tx era
tx =
case [VKey 'Witness (EraCrypto era)]
failed forall a. Semigroup a => a -> a -> a
<> [VKey 'Witness (EraCrypto era)]
failedBootstrap of
[] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
[VKey 'Witness (EraCrypto era)]
nonEmpty -> forall e a. e -> Validation (NonEmpty e) a
failure forall a b. (a -> b) -> a -> b
$ forall era.
[VKey 'Witness (EraCrypto era)] -> ShelleyUtxowPredFailure era
InvalidWitnessesUTXOW [VKey 'Witness (EraCrypto era)]
nonEmpty
where
txBody :: TxBody era
txBody = Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL
txBodyHash :: Hash (EraCrypto era) EraIndependentTxBody
txBodyHash = forall c i. SafeHash c i -> Hash (HASH c) i
extractHash (forall x index c.
(HashAnnotated x index c, HashAlgorithm (HASH c)) =>
x -> SafeHash c index
hashAnnotated TxBody era
txBody)
wvkKey :: WitVKey kr c -> VKey kr c
wvkKey (WitVKey VKey kr c
k SignedDSIGN c (Hash c EraIndependentTxBody)
_) = VKey kr c
k
failed :: [VKey 'Witness (EraCrypto era)]
failed =
forall {c} {kr :: KeyRole}.
(Crypto c, Typeable kr) =>
WitVKey kr c -> VKey kr c
wvkKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (a -> Bool) -> [a] -> [a]
filter
(Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kr :: KeyRole) c.
(Typeable kr, Crypto c,
DSignable c (Hash c EraIndependentTxBody)) =>
Hash c EraIndependentTxBody -> WitVKey kr c -> Bool
verifyWitVKey Hash (EraCrypto era) EraIndependentTxBody
txBodyHash)
(forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (WitVKey 'Witness (EraCrypto era)))
addrTxWitsL)
failedBootstrap :: [VKey 'Witness (EraCrypto era)]
failedBootstrap =
forall c. Crypto c => BootstrapWitness c -> VKey 'Witness c
bwKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (a -> Bool) -> [a] -> [a]
filter
(Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c.
(Crypto c, Signable (DSIGN c) (Hash c EraIndependentTxBody)) =>
Hash c EraIndependentTxBody -> BootstrapWitness c -> Bool
verifyBootstrapWit Hash (EraCrypto era) EraIndependentTxBody
txBodyHash)
(forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (BootstrapWitness (EraCrypto era)))
bootAddrTxWitsL)
validateNeededWitnesses ::
EraUTxO era =>
Set (KeyHash 'Witness (EraCrypto era)) ->
CertState era ->
UTxO era ->
TxBody era ->
Test (ShelleyUtxowPredFailure era)
validateNeededWitnesses :: forall era.
EraUTxO era =>
Set (KeyHash 'Witness (EraCrypto era))
-> CertState era
-> UTxO era
-> TxBody era
-> Test (ShelleyUtxowPredFailure era)
validateNeededWitnesses Set (KeyHash 'Witness (EraCrypto era))
witsKeyHashes CertState era
certState UTxO era
utxo TxBody era
txBody =
let needed :: Set (KeyHash 'Witness (EraCrypto era))
needed = forall era.
EraUTxO era =>
CertState era
-> UTxO era -> TxBody era -> Set (KeyHash 'Witness (EraCrypto era))
getWitsVKeyNeeded CertState era
certState UTxO era
utxo TxBody era
txBody
missingWitnesses :: Set (KeyHash 'Witness (EraCrypto era))
missingWitnesses = forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set (KeyHash 'Witness (EraCrypto era))
needed Set (KeyHash 'Witness (EraCrypto era))
witsKeyHashes
in forall e. Bool -> e -> Validation (NonEmpty e) ()
failureUnless (forall a. Set a -> Bool
Set.null Set (KeyHash 'Witness (EraCrypto era))
missingWitnesses) forall a b. (a -> b) -> a -> b
$
forall era.
Set (KeyHash 'Witness (EraCrypto era))
-> ShelleyUtxowPredFailure era
MissingVKeyWitnessesUTXOW Set (KeyHash 'Witness (EraCrypto era))
missingWitnesses
witsVKeyNeededGov ::
forall era.
ShelleyEraTxBody era =>
TxBody era ->
GenDelegs (EraCrypto era) ->
Set (KeyHash 'Witness (EraCrypto era))
witsVKeyNeededGov :: forall era.
ShelleyEraTxBody era =>
TxBody era
-> GenDelegs (EraCrypto era)
-> Set (KeyHash 'Witness (EraCrypto era))
witsVKeyNeededGov TxBody era
txBody GenDelegs (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` forall era.
StrictMaybe (Update era)
-> GenDelegs (EraCrypto 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) GenDelegs (EraCrypto era)
genDelegs
{-# DEPRECATED witsVKeyNeededGov "As unnecessary. Use `getWitsVKeyNeeded` instead" #-}
witsVKeyNeededNoGov ::
forall era.
EraTx era =>
UTxO era ->
TxBody era ->
Set (KeyHash 'Witness (EraCrypto era))
witsVKeyNeededNoGov :: forall era.
EraTx era =>
UTxO era -> TxBody era -> Set (KeyHash 'Witness (EraCrypto era))
witsVKeyNeededNoGov = forall era.
EraTx era =>
UTxO era -> TxBody era -> Set (KeyHash 'Witness (EraCrypto era))
getShelleyWitsVKeyNeededNoGov
{-# DEPRECATED witsVKeyNeededNoGov "Use `getShelleyWitsVKeyNeededNoGov` instead" #-}
shelleyWitsVKeyNeeded ::
forall era.
(EraTx era, ShelleyEraTxBody era) =>
UTxO era ->
TxBody era ->
GenDelegs (EraCrypto era) ->
Set (KeyHash 'Witness (EraCrypto era))
shelleyWitsVKeyNeeded :: forall era.
(EraTx era, ShelleyEraTxBody era) =>
UTxO era
-> TxBody era
-> GenDelegs (EraCrypto era)
-> Set (KeyHash 'Witness (EraCrypto era))
shelleyWitsVKeyNeeded UTxO era
utxo TxBody era
txBody GenDelegs (EraCrypto era)
genDelegs =
forall era.
EraTx era =>
UTxO era -> TxBody era -> Set (KeyHash 'Witness (EraCrypto era))
witsVKeyNeededNoGov 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))
witsVKeyNeededGov TxBody era
txBody GenDelegs (EraCrypto era)
genDelegs
{-# DEPRECATED shelleyWitsVKeyNeeded "Use `getShelleyWitsVKeyNeeded` instead" #-}
validateMetadata :: EraTx era => PParams era -> Tx era -> Test (ShelleyUtxowPredFailure era)
validateMetadata :: forall era.
EraTx era =>
PParams era -> Tx era -> Test (ShelleyUtxowPredFailure era)
validateMetadata PParams era
pp Tx era
tx =
let txBody :: TxBody era
txBody = Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL
pv :: ProtVer
pv = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) ProtVer
ppProtocolVersionL
in case (TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era.
EraTxBody era =>
Lens'
(TxBody era) (StrictMaybe (AuxiliaryDataHash (EraCrypto era)))
auxDataHashTxBodyL, Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era.
EraTx era =>
Lens' (Tx era) (StrictMaybe (AuxiliaryData era))
auxDataTxL) of
(StrictMaybe (AuxiliaryDataHash (EraCrypto era))
SNothing, StrictMaybe (TxAuxData era)
SNothing) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
(SJust AuxiliaryDataHash (EraCrypto era)
mdh, StrictMaybe (TxAuxData era)
SNothing) -> forall e a. e -> Validation (NonEmpty e) a
failure forall a b. (a -> b) -> a -> b
$ forall era.
AuxiliaryDataHash (EraCrypto era) -> ShelleyUtxowPredFailure era
MissingTxMetadata AuxiliaryDataHash (EraCrypto era)
mdh
(StrictMaybe (AuxiliaryDataHash (EraCrypto era))
SNothing, SJust TxAuxData era
md') ->
forall e a. e -> Validation (NonEmpty e) a
failure forall a b. (a -> b) -> a -> b
$ forall era.
AuxiliaryDataHash (EraCrypto era) -> ShelleyUtxowPredFailure era
MissingTxBodyMetadataHash (forall era.
EraTxAuxData era =>
TxAuxData era -> AuxiliaryDataHash (EraCrypto era)
hashTxAuxData TxAuxData era
md')
(SJust AuxiliaryDataHash (EraCrypto era)
mdh, SJust TxAuxData era
md') ->
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Applicative f) =>
t (f a) -> f ()
sequenceA_
[ forall e. Bool -> e -> Validation (NonEmpty e) ()
failureUnless (forall era.
EraTxAuxData era =>
TxAuxData era -> AuxiliaryDataHash (EraCrypto era)
hashTxAuxData TxAuxData era
md' forall a. Eq a => a -> a -> Bool
== AuxiliaryDataHash (EraCrypto era)
mdh) forall a b. (a -> b) -> a -> b
$
forall era.
Mismatch 'RelEQ (AuxiliaryDataHash (EraCrypto era))
-> ShelleyUtxowPredFailure era
ConflictingMetadataHash forall a b. (a -> b) -> a -> b
$
Mismatch {mismatchSupplied :: AuxiliaryDataHash (EraCrypto era)
mismatchSupplied = AuxiliaryDataHash (EraCrypto era)
mdh, mismatchExpected :: AuxiliaryDataHash (EraCrypto era)
mismatchExpected = forall era.
EraTxAuxData era =>
TxAuxData era -> AuxiliaryDataHash (EraCrypto era)
hashTxAuxData TxAuxData era
md'}
,
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ProtVer -> Bool
SoftForks.validMetadata ProtVer
pv) forall a b. (a -> b) -> a -> b
$
forall e. Bool -> e -> Validation (NonEmpty e) ()
failureUnless (forall era. EraTxAuxData era => ProtVer -> TxAuxData era -> Bool
validateTxAuxData ProtVer
pv TxAuxData era
md') forall era. ShelleyUtxowPredFailure era
InvalidMetadata
]
validateMIRInsufficientGenesisSigs ::
( EraTx era
, ShelleyEraTxBody era
) =>
GenDelegs (EraCrypto era) ->
Word64 ->
Set (KeyHash 'Witness (EraCrypto era)) ->
Tx era ->
Test (ShelleyUtxowPredFailure era)
validateMIRInsufficientGenesisSigs :: forall era.
(EraTx era, ShelleyEraTxBody era) =>
GenDelegs (EraCrypto era)
-> Word64
-> Set (KeyHash 'Witness (EraCrypto era))
-> Tx era
-> Test (ShelleyUtxowPredFailure era)
validateMIRInsufficientGenesisSigs (GenDelegs Map
(KeyHash 'Genesis (EraCrypto era)) (GenDelegPair (EraCrypto era))
genMapping) Word64
coreNodeQuorum Set (KeyHash 'Witness (EraCrypto era))
witsKeyHashes Tx era
tx =
let genDelegates :: Set (KeyHash 'Witness (EraCrypto era))
genDelegates =
forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ 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 c. GenDelegPair c -> KeyHash 'GenesisDelegate c
genDelegKeyHash forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Map k a -> [a]
Map.elems Map
(KeyHash 'Genesis (EraCrypto era)) (GenDelegPair (EraCrypto era))
genMapping
khAsSet :: Set (KeyHash 'Witness (EraCrypto era))
khAsSet = Set (KeyHash 'Witness (EraCrypto era))
witsKeyHashes
genSig :: Set (KeyHash 'Witness (EraCrypto era))
genSig = forall s t. Embed s t => Exp t -> s
eval (Set (KeyHash 'Witness (EraCrypto era))
genDelegates forall k (f :: * -> * -> *) (g :: * -> * -> *) s1 v s2 u.
(Ord k, Iter f, Iter g, HasExp s1 (f k v), HasExp s2 (g k u)) =>
s1 -> s2 -> Exp (Sett k ())
∩ Set (KeyHash 'Witness (EraCrypto era))
khAsSet)
txBody :: TxBody era
txBody = Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL
mirCerts :: StrictSeq (TxCert era)
mirCerts =
forall a. Seq a -> StrictSeq a
StrictSeq.forceToStrict
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> Seq a -> Seq a
Seq.filter forall era.
(ShelleyEraTxCert era, ProtVerAtMost era 8) =>
TxCert era -> Bool
isInstantaneousRewards
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. StrictSeq a -> Seq a
StrictSeq.fromStrict
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) (StrictSeq (TxCert era))
certsTxBodyL
in forall e. Bool -> e -> Validation (NonEmpty e) ()
failureUnless
(Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null StrictSeq (TxCert era)
mirCerts) Bool -> Bool -> Bool
==> forall a. Set a -> Int
Set.size Set (KeyHash 'Witness (EraCrypto era))
genSig forall a. Ord a => a -> a -> Bool
>= forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
coreNodeQuorum)
forall a b. (a -> b) -> a -> b
$ forall era.
Set (KeyHash 'Witness (EraCrypto era))
-> ShelleyUtxowPredFailure era
MIRInsufficientGenesisSigsUTXOW Set (KeyHash 'Witness (EraCrypto era))
genSig
proposedUpdatesWitnesses ::
StrictMaybe (Update era) ->
GenDelegs (EraCrypto era) ->
Set (KeyHash 'Witness (EraCrypto era))
proposedUpdatesWitnesses :: forall era.
StrictMaybe (Update era)
-> GenDelegs (EraCrypto era)
-> Set (KeyHash 'Witness (EraCrypto era))
proposedUpdatesWitnesses StrictMaybe (Update era)
SNothing GenDelegs (EraCrypto era)
_ = forall a. Set a
Set.empty
proposedUpdatesWitnesses (SJust (Update (ProposedPPUpdates Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdate era)
pup) EpochNo
_)) (GenDelegs Map
(KeyHash 'Genesis (EraCrypto era)) (GenDelegPair (EraCrypto era))
genDelegs) =
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'
propWits ::
Maybe (Update era) ->
GenDelegs (EraCrypto era) ->
Set (KeyHash 'Witness (EraCrypto era))
propWits :: forall era.
Maybe (Update era)
-> GenDelegs (EraCrypto era)
-> Set (KeyHash 'Witness (EraCrypto era))
propWits Maybe (Update era)
mu = forall era.
StrictMaybe (Update era)
-> GenDelegs (EraCrypto era)
-> Set (KeyHash 'Witness (EraCrypto era))
proposedUpdatesWitnesses (forall a. Maybe a -> StrictMaybe a
maybeToStrictMaybe Maybe (Update era)
mu)
{-# DEPRECATED
propWits
"This will become an internal function in the future. \
\ Submit an issue if you still need it. "
#-}