{-# 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 UndecidableInstances #-}

module Cardano.Ledger.Shelley.Rules.Utxow
  ( UTXOW,
    UtxowPredicateFailure (..),
    UtxowEvent (..),
    PredicateFailure,
    transitionRulesUTXOW,
    ShelleyStyleWitnessNeeds,

    -- * Individual validation steps
    validateFailedScripts,
    validateMissingScripts,
    validateVerifiedWits,
    validateMetadata,
    validateMIRInsufficientGenesisSigs,
    validateNeededWitnesses,
  )
where

import Cardano.Binary
  ( FromCBOR (..),
    ToCBOR (..),
    encodeListLen,
  )
import Cardano.Ledger.Address (Addr (..), bootstrapKeyHash)
import Cardano.Ledger.AuxiliaryData
  ( AuxiliaryDataHash,
    ValidateAuxiliaryData (..),
    hashAuxiliaryData,
  )
import Cardano.Ledger.BaseTypes
  ( ProtVer,
    ShelleyBase,
    StrictMaybe (..),
    invalidKey,
    quorum,
    strictMaybeToMaybe,
    (==>),
  )
import qualified Cardano.Ledger.Core as Core
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.Era (Era (..))
import Cardano.Ledger.Keys
  ( DSignable,
    GenDelegPair (..),
    GenDelegs (..),
    Hash,
    KeyHash,
    KeyRole (..),
    VKey,
    asWitness,
  )
import Cardano.Ledger.Rules.ValidationMode
  ( Inject (..),
    Test,
    runTest,
    runTestOnSignal,
  )
import Cardano.Ledger.SafeHash (extractHash, hashAnnotated)
import Cardano.Ledger.Serialization
  ( decodeList,
    decodeRecordSum,
    decodeSet,
    encodeFoldable,
  )
import Cardano.Ledger.Shelley.Address.Bootstrap (BootstrapWitness, bwKey, verifyBootstrapWit)
import Cardano.Ledger.Shelley.Delegation.Certificates
  ( delegCWitness,
    genesisCWitness,
    isInstantaneousRewards,
    poolCWitness,
    requiresVKeyWitness,
  )
import qualified Cardano.Ledger.Shelley.HardForks as HardForks
import Cardano.Ledger.Shelley.LedgerState
  ( UTxOState (..),
    WitHashes (..),
    diffWitHashes,
    nullWitHashes,
    propWits,
    witsFromTxWitnesses,
  )
import Cardano.Ledger.Shelley.PParams (Update)
import Cardano.Ledger.Shelley.Rules.Utxo (UTXO, UtxoEnv (..), UtxoEvent, UtxoPredicateFailure)
import Cardano.Ledger.Shelley.Scripts (ScriptHash)
import qualified Cardano.Ledger.Shelley.SoftForks as SoftForks
import Cardano.Ledger.Shelley.Tx
  ( Tx,
    ValidateScript,
    WitVKey,
    extractKeyHashWitnessSet,
    hashScript,
    validateScript,
  )
import Cardano.Ledger.Shelley.TxBody
  ( DCert (..),
    EraIndependentTxBody,
    PoolCert (..),
    PoolParams (..),
    Wdrl,
    WitVKey (..),
    getRwdCred,
    unWdrl,
  )
import Cardano.Ledger.Shelley.UTxO (UTxO, scriptsNeeded, txinLookup, verifyWitVKey)
import Cardano.Ledger.TxIn (TxIn)
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 Data.Sequence.Strict (StrictSeq)
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 GHC.Records (HasField, getField)
import NoThunks.Class (NoThunks (..))
import Validation

-- =========================================

data UTXOW era

data UtxowPredicateFailure era
  = InvalidWitnessesUTXOW
      ![VKey 'Witness (Crypto era)]
  | -- witnesses which failed in verifiedWits function
    MissingVKeyWitnessesUTXOW
      !(WitHashes (Crypto era)) -- witnesses which were needed and not supplied
  | MissingScriptWitnessesUTXOW
      !(Set (ScriptHash (Crypto era))) -- missing scripts
  | ScriptWitnessNotValidatingUTXOW
      !(Set (ScriptHash (Crypto era))) -- failed scripts
  | UtxoFailure (PredicateFailure (Core.EraRule "UTXO" era))
  | MIRInsufficientGenesisSigsUTXOW (Set (KeyHash 'Witness (Crypto era)))
  | MissingTxBodyMetadataHash
      !(AuxiliaryDataHash (Crypto era)) -- hash of the full metadata
  | MissingTxMetadata
      !(AuxiliaryDataHash (Crypto era)) -- hash of the metadata included in the transaction body
  | ConflictingMetadataHash
      !(AuxiliaryDataHash (Crypto era)) -- hash of the metadata included in the transaction body
      !(AuxiliaryDataHash (Crypto era)) -- hash of the full metadata
      -- Contains out of range values (strings too long)
  | InvalidMetadata
  | ExtraneousScriptWitnessesUTXOW
      !(Set (ScriptHash (Crypto era))) -- extraneous scripts
  deriving ((forall x.
 UtxowPredicateFailure era -> Rep (UtxowPredicateFailure era) x)
-> (forall x.
    Rep (UtxowPredicateFailure era) x -> UtxowPredicateFailure era)
-> Generic (UtxowPredicateFailure era)
forall x.
Rep (UtxowPredicateFailure era) x -> UtxowPredicateFailure era
forall x.
UtxowPredicateFailure era -> Rep (UtxowPredicateFailure era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x.
Rep (UtxowPredicateFailure era) x -> UtxowPredicateFailure era
forall era x.
UtxowPredicateFailure era -> Rep (UtxowPredicateFailure era) x
$cto :: forall era x.
Rep (UtxowPredicateFailure era) x -> UtxowPredicateFailure era
$cfrom :: forall era x.
UtxowPredicateFailure era -> Rep (UtxowPredicateFailure era) x
Generic)

newtype UtxowEvent era
  = UtxoEvent (Event (Core.EraRule "UTXO" era))

instance
  ( NoThunks (PredicateFailure (Core.EraRule "UTXO" era)),
    Era era
  ) =>
  NoThunks (UtxowPredicateFailure era)

deriving stock instance
  ( Eq (PredicateFailure (Core.EraRule "UTXO" era)),
    Era era
  ) =>
  Eq (UtxowPredicateFailure era)

deriving stock instance
  ( Show (PredicateFailure (Core.EraRule "UTXO" era)),
    Era era
  ) =>
  Show (UtxowPredicateFailure era)

instance
  ( Era era,
    Typeable (Core.Script era),
    Typeable (Core.AuxiliaryData era),
    ToCBOR (PredicateFailure (Core.EraRule "UTXO" era))
  ) =>
  ToCBOR (UtxowPredicateFailure era)
  where
  toCBOR :: UtxowPredicateFailure era -> Encoding
toCBOR = \case
    InvalidWitnessesUTXOW [VKey 'Witness (Crypto era)]
wits ->
      Word -> Encoding
encodeListLen Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Word8
0 :: Word8) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> [VKey 'Witness (Crypto era)] -> Encoding
forall a (f :: * -> *). (ToCBOR a, Foldable f) => f a -> Encoding
encodeFoldable [VKey 'Witness (Crypto era)]
wits
    MissingVKeyWitnessesUTXOW (WitHashes Set (KeyHash 'Witness (Crypto era))
missing) ->
      Word -> Encoding
encodeListLen Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Word8
1 :: Word8) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Set (KeyHash 'Witness (Crypto era)) -> Encoding
forall a (f :: * -> *). (ToCBOR a, Foldable f) => f a -> Encoding
encodeFoldable Set (KeyHash 'Witness (Crypto era))
missing
    MissingScriptWitnessesUTXOW Set (ScriptHash (Crypto era))
ss ->
      Word -> Encoding
encodeListLen Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Word8
2 :: Word8)
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Set (ScriptHash (Crypto era)) -> Encoding
forall a (f :: * -> *). (ToCBOR a, Foldable f) => f a -> Encoding
encodeFoldable Set (ScriptHash (Crypto era))
ss
    ScriptWitnessNotValidatingUTXOW Set (ScriptHash (Crypto era))
ss ->
      Word -> Encoding
encodeListLen Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Word8
3 :: Word8)
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Set (ScriptHash (Crypto era)) -> Encoding
forall a (f :: * -> *). (ToCBOR a, Foldable f) => f a -> Encoding
encodeFoldable Set (ScriptHash (Crypto era))
ss
    (UtxoFailure PredicateFailure (EraRule "UTXO" era)
a) ->
      Word -> Encoding
encodeListLen Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Word8
4 :: Word8)
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> PredicateFailure (EraRule "UTXO" era) -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR PredicateFailure (EraRule "UTXO" era)
a
    MIRInsufficientGenesisSigsUTXOW Set (KeyHash 'Witness (Crypto era))
sigs ->
      Word -> Encoding
encodeListLen Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Word8
5 :: Word8)
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Set (KeyHash 'Witness (Crypto era)) -> Encoding
forall a (f :: * -> *). (ToCBOR a, Foldable f) => f a -> Encoding
encodeFoldable Set (KeyHash 'Witness (Crypto era))
sigs
    MissingTxBodyMetadataHash AuxiliaryDataHash (Crypto era)
h ->
      Word -> Encoding
encodeListLen Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Word8
6 :: Word8) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> AuxiliaryDataHash (Crypto era) -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR AuxiliaryDataHash (Crypto era)
h
    MissingTxMetadata AuxiliaryDataHash (Crypto era)
h ->
      Word -> Encoding
encodeListLen Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Word8
7 :: Word8) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> AuxiliaryDataHash (Crypto era) -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR AuxiliaryDataHash (Crypto era)
h
    ConflictingMetadataHash AuxiliaryDataHash (Crypto era)
bodyHash AuxiliaryDataHash (Crypto era)
fullMDHash ->
      Word -> Encoding
encodeListLen Word
3 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Word8
8 :: Word8) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> AuxiliaryDataHash (Crypto era) -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR AuxiliaryDataHash (Crypto era)
bodyHash Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> AuxiliaryDataHash (Crypto era) -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR AuxiliaryDataHash (Crypto era)
fullMDHash
    UtxowPredicateFailure era
InvalidMetadata ->
      Word -> Encoding
encodeListLen Word
1 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Word8
9 :: Word8)
    ExtraneousScriptWitnessesUTXOW Set (ScriptHash (Crypto era))
ss ->
      Word -> Encoding
encodeListLen Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Word8
10 :: Word8)
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Set (ScriptHash (Crypto era)) -> Encoding
forall a (f :: * -> *). (ToCBOR a, Foldable f) => f a -> Encoding
encodeFoldable Set (ScriptHash (Crypto era))
ss

instance
  ( Era era,
    FromCBOR (PredicateFailure (Core.EraRule "UTXO" era)),
    Typeable (Core.Script era),
    Typeable (Core.AuxiliaryData era)
  ) =>
  FromCBOR (UtxowPredicateFailure era)
  where
  fromCBOR :: Decoder s (UtxowPredicateFailure era)
fromCBOR = String
-> (Word -> Decoder s (Int, UtxowPredicateFailure era))
-> Decoder s (UtxowPredicateFailure era)
forall s a. String -> (Word -> Decoder s (Int, a)) -> Decoder s a
decodeRecordSum String
"PredicateFailure (UTXOW era)" ((Word -> Decoder s (Int, UtxowPredicateFailure era))
 -> Decoder s (UtxowPredicateFailure era))
-> (Word -> Decoder s (Int, UtxowPredicateFailure era))
-> Decoder s (UtxowPredicateFailure era)
forall a b. (a -> b) -> a -> b
$
    \case
      Word
0 -> do
        [VKey 'Witness (Crypto era)]
wits <- Decoder s (VKey 'Witness (Crypto era))
-> Decoder s [VKey 'Witness (Crypto era)]
forall s a. Decoder s a -> Decoder s [a]
decodeList Decoder s (VKey 'Witness (Crypto era))
forall a s. FromCBOR a => Decoder s a
fromCBOR
        (Int, UtxowPredicateFailure era)
-> Decoder s (Int, UtxowPredicateFailure era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
2, [VKey 'Witness (Crypto era)] -> UtxowPredicateFailure era
forall era.
[VKey 'Witness (Crypto era)] -> UtxowPredicateFailure era
InvalidWitnessesUTXOW [VKey 'Witness (Crypto era)]
wits)
      Word
1 -> do
        Set (KeyHash 'Witness (Crypto era))
missing <- Decoder s (KeyHash 'Witness (Crypto era))
-> Decoder s (Set (KeyHash 'Witness (Crypto era)))
forall a s. Ord a => Decoder s a -> Decoder s (Set a)
decodeSet Decoder s (KeyHash 'Witness (Crypto era))
forall a s. FromCBOR a => Decoder s a
fromCBOR
        (Int, UtxowPredicateFailure era)
-> Decoder s (Int, UtxowPredicateFailure era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
2, WitHashes (Crypto era) -> UtxowPredicateFailure era
forall era. WitHashes (Crypto era) -> UtxowPredicateFailure era
MissingVKeyWitnessesUTXOW (WitHashes (Crypto era) -> UtxowPredicateFailure era)
-> WitHashes (Crypto era) -> UtxowPredicateFailure era
forall a b. (a -> b) -> a -> b
$ Set (KeyHash 'Witness (Crypto era)) -> WitHashes (Crypto era)
forall crypto. Set (KeyHash 'Witness crypto) -> WitHashes crypto
WitHashes Set (KeyHash 'Witness (Crypto era))
missing)
      Word
2 -> do
        Set (ScriptHash (Crypto era))
ss <- Decoder s (ScriptHash (Crypto era))
-> Decoder s (Set (ScriptHash (Crypto era)))
forall a s. Ord a => Decoder s a -> Decoder s (Set a)
decodeSet Decoder s (ScriptHash (Crypto era))
forall a s. FromCBOR a => Decoder s a
fromCBOR
        (Int, UtxowPredicateFailure era)
-> Decoder s (Int, UtxowPredicateFailure era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
2, Set (ScriptHash (Crypto era)) -> UtxowPredicateFailure era
forall era.
Set (ScriptHash (Crypto era)) -> UtxowPredicateFailure era
MissingScriptWitnessesUTXOW Set (ScriptHash (Crypto era))
ss)
      Word
3 -> do
        Set (ScriptHash (Crypto era))
ss <- Decoder s (ScriptHash (Crypto era))
-> Decoder s (Set (ScriptHash (Crypto era)))
forall a s. Ord a => Decoder s a -> Decoder s (Set a)
decodeSet Decoder s (ScriptHash (Crypto era))
forall a s. FromCBOR a => Decoder s a
fromCBOR
        (Int, UtxowPredicateFailure era)
-> Decoder s (Int, UtxowPredicateFailure era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
2, Set (ScriptHash (Crypto era)) -> UtxowPredicateFailure era
forall era.
Set (ScriptHash (Crypto era)) -> UtxowPredicateFailure era
ScriptWitnessNotValidatingUTXOW Set (ScriptHash (Crypto era))
ss)
      Word
4 -> do
        PredicateFailure (EraRule "UTXO" era)
a <- Decoder s (PredicateFailure (EraRule "UTXO" era))
forall a s. FromCBOR a => Decoder s a
fromCBOR
        (Int, UtxowPredicateFailure era)
-> Decoder s (Int, UtxowPredicateFailure era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
2, PredicateFailure (EraRule "UTXO" era) -> UtxowPredicateFailure era
forall era.
PredicateFailure (EraRule "UTXO" era) -> UtxowPredicateFailure era
UtxoFailure PredicateFailure (EraRule "UTXO" era)
a)
      Word
5 -> do
        Set (KeyHash 'Witness (Crypto era))
s <- Decoder s (KeyHash 'Witness (Crypto era))
-> Decoder s (Set (KeyHash 'Witness (Crypto era)))
forall a s. Ord a => Decoder s a -> Decoder s (Set a)
decodeSet Decoder s (KeyHash 'Witness (Crypto era))
forall a s. FromCBOR a => Decoder s a
fromCBOR
        (Int, UtxowPredicateFailure era)
-> Decoder s (Int, UtxowPredicateFailure era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
2, Set (KeyHash 'Witness (Crypto era)) -> UtxowPredicateFailure era
forall era.
Set (KeyHash 'Witness (Crypto era)) -> UtxowPredicateFailure era
MIRInsufficientGenesisSigsUTXOW Set (KeyHash 'Witness (Crypto era))
s)
      Word
6 -> do
        AuxiliaryDataHash (Crypto era)
h <- Decoder s (AuxiliaryDataHash (Crypto era))
forall a s. FromCBOR a => Decoder s a
fromCBOR
        (Int, UtxowPredicateFailure era)
-> Decoder s (Int, UtxowPredicateFailure era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
2, AuxiliaryDataHash (Crypto era) -> UtxowPredicateFailure era
forall era.
AuxiliaryDataHash (Crypto era) -> UtxowPredicateFailure era
MissingTxBodyMetadataHash AuxiliaryDataHash (Crypto era)
h)
      Word
7 -> do
        AuxiliaryDataHash (Crypto era)
h <- Decoder s (AuxiliaryDataHash (Crypto era))
forall a s. FromCBOR a => Decoder s a
fromCBOR
        (Int, UtxowPredicateFailure era)
-> Decoder s (Int, UtxowPredicateFailure era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
2, AuxiliaryDataHash (Crypto era) -> UtxowPredicateFailure era
forall era.
AuxiliaryDataHash (Crypto era) -> UtxowPredicateFailure era
MissingTxMetadata AuxiliaryDataHash (Crypto era)
h)
      Word
8 -> do
        AuxiliaryDataHash (Crypto era)
bodyHash <- Decoder s (AuxiliaryDataHash (Crypto era))
forall a s. FromCBOR a => Decoder s a
fromCBOR
        AuxiliaryDataHash (Crypto era)
fullMDHash <- Decoder s (AuxiliaryDataHash (Crypto era))
forall a s. FromCBOR a => Decoder s a
fromCBOR
        (Int, UtxowPredicateFailure era)
-> Decoder s (Int, UtxowPredicateFailure era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
3, AuxiliaryDataHash (Crypto era)
-> AuxiliaryDataHash (Crypto era) -> UtxowPredicateFailure era
forall era.
AuxiliaryDataHash (Crypto era)
-> AuxiliaryDataHash (Crypto era) -> UtxowPredicateFailure era
ConflictingMetadataHash AuxiliaryDataHash (Crypto era)
bodyHash AuxiliaryDataHash (Crypto era)
fullMDHash)
      Word
9 -> (Int, UtxowPredicateFailure era)
-> Decoder s (Int, UtxowPredicateFailure era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
1, UtxowPredicateFailure era
forall era. UtxowPredicateFailure era
InvalidMetadata)
      Word
10 -> do
        Set (ScriptHash (Crypto era))
ss <- Decoder s (ScriptHash (Crypto era))
-> Decoder s (Set (ScriptHash (Crypto era)))
forall a s. Ord a => Decoder s a -> Decoder s (Set a)
decodeSet Decoder s (ScriptHash (Crypto era))
forall a s. FromCBOR a => Decoder s a
fromCBOR
        (Int, UtxowPredicateFailure era)
-> Decoder s (Int, UtxowPredicateFailure era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
2, Set (ScriptHash (Crypto era)) -> UtxowPredicateFailure era
forall era.
Set (ScriptHash (Crypto era)) -> UtxowPredicateFailure era
ExtraneousScriptWitnessesUTXOW Set (ScriptHash (Crypto era))
ss)
      Word
k -> Word -> Decoder s (Int, UtxowPredicateFailure era)
forall s a. Word -> Decoder s a
invalidKey Word
k

-- =================================================
--  State Transition System Instances

type ShelleyStyleWitnessNeeds era =
  ( HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))),
    HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))),
    HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)),
    HasField "addrWits" (Core.Tx era) (Set (WitVKey 'Witness (Crypto era))),
    HasField "bootWits" (Core.Tx era) (Set (BootstrapWitness (Crypto era))),
    HasField "update" (Core.TxBody era) (StrictMaybe (Update era)),
    HasField "_protocolVersion" (Core.PParams era) ProtVer,
    ValidateAuxiliaryData era (Crypto era),
    ValidateScript era,
    DSignable (Crypto era) (Hash (Crypto era) EraIndependentTxBody)
  )

initialLedgerStateUTXOW ::
  forall era.
  ( Embed (Core.EraRule "UTXO" era) (UTXOW era),
    Environment (Core.EraRule "UTXO" era) ~ UtxoEnv era,
    State (Core.EraRule "UTXO" era) ~ UTxOState era
  ) =>
  InitialRule (UTXOW era)
initialLedgerStateUTXOW :: InitialRule (UTXOW era)
initialLedgerStateUTXOW = do
  IRC (UtxoEnv slots pp stakepools genDelegs) <- F (Clause (UTXOW era) 'Initial) (IRC (UTXOW era))
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)
forall super (rtype :: RuleType).
Embed (EraRule "UTXO" era) super =>
RuleContext rtype (EraRule "UTXO" era)
-> Rule super rtype (State (EraRule "UTXO" era))
trans @(Core.EraRule "UTXO" era) (RuleContext 'Initial (EraRule "UTXO" era)
 -> Rule (UTXOW era) 'Initial (State (EraRule "UTXO" era)))
-> RuleContext 'Initial (EraRule "UTXO" era)
-> Rule (UTXOW era) 'Initial (State (EraRule "UTXO" era))
forall a b. (a -> b) -> a -> b
$ Environment (EraRule "UTXO" era) -> IRC (EraRule "UTXO" era)
forall sts. Environment sts -> IRC sts
IRC (SlotNo
-> PParams era
-> Map (KeyHash 'StakePool (Crypto era)) (PoolParams (Crypto era))
-> GenDelegs (Crypto era)
-> UtxoEnv era
forall era.
SlotNo
-> PParams era
-> Map (KeyHash 'StakePool (Crypto era)) (PoolParams (Crypto era))
-> GenDelegs (Crypto era)
-> UtxoEnv era
UtxoEnv SlotNo
slots PParams era
pp Map (KeyHash 'StakePool (Crypto era)) (PoolParams (Crypto era))
stakepools GenDelegs (Crypto era)
genDelegs)

-- | A generic Utxow witnessing function designed to be use across many Eras.
--   Note the 'embed' argument lifts from the simple Shelley (UtxowPredicateFailure) to
--   the PredicateFailure (type family) of the context of where it is called.
transitionRulesUTXOW ::
  forall era utxow.
  ( Era era,
    BaseM (utxow era) ~ ShelleyBase,
    Embed (Core.EraRule "UTXO" era) (utxow era),
    Environment (Core.EraRule "UTXO" era) ~ UtxoEnv era,
    State (Core.EraRule "UTXO" era) ~ UTxOState era,
    Signal (Core.EraRule "UTXO" era) ~ Core.Tx era,
    Environment (utxow era) ~ UtxoEnv era,
    State (utxow era) ~ UTxOState era,
    Signal (utxow era) ~ Core.Tx era,
    PredicateFailure (utxow era) ~ UtxowPredicateFailure era,
    STS (utxow era),
    ShelleyStyleWitnessNeeds era
  ) =>
  TransitionRule (utxow era)
transitionRulesUTXOW :: TransitionRule (utxow era)
transitionRulesUTXOW = do
  (TRC (UtxoEnv slot pp stakepools genDelegs, State (utxow era)
u, Signal (utxow era)
tx)) <- F (Clause (utxow era) 'Transition) (TRC (utxow era))
forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext

  {-  (utxo,_,_,_ ) := utxoSt  -}
  {-  witsKeyHashes := { hashKey vk | vk ∈ dom(txwitsVKey txw) }  -}
  let utxo :: UTxO era
utxo = UTxOState era -> UTxO era
forall era. UTxOState era -> UTxO era
_utxo State (utxow era)
UTxOState era
u
      witsKeyHashes :: WitHashes (Crypto era)
witsKeyHashes = Tx era -> WitHashes (Crypto era)
forall era tx.
(Era era,
 HasField "addrWits" tx (Set (WitVKey 'Witness (Crypto era))),
 HasField "bootWits" tx (Set (BootstrapWitness (Crypto era)))) =>
tx -> WitHashes (Crypto era)
witsFromTxWitnesses @era Tx era
Signal (utxow era)
tx

  -- check scripts
  {-  ∀ s ∈ range(txscripts txw) ∩ Scriptnative), runNativeScript s tx   -}

  Test (UtxowPredicateFailure era) -> Rule (utxow era) 'Transition ()
forall t sts (ctx :: RuleType).
Inject t (PredicateFailure sts) =>
Test t -> Rule sts ctx ()
runTestOnSignal (Test (UtxowPredicateFailure era)
 -> Rule (utxow era) 'Transition ())
-> Test (UtxowPredicateFailure era)
-> Rule (utxow era) 'Transition ()
forall a b. (a -> b) -> a -> b
$ Tx era -> Test (UtxowPredicateFailure era)
forall era.
ValidateScript era =>
Tx era -> Test (UtxowPredicateFailure era)
validateFailedScripts Tx era
Signal (utxow era)
tx

  {-  { s | (_,s) ∈ scriptsNeeded utxo tx} = dom(txscripts txw)          -}
  Test (UtxowPredicateFailure era) -> Rule (utxow era) 'Transition ()
forall t sts (ctx :: RuleType).
Inject t (PredicateFailure sts) =>
Test t -> Rule sts ctx ()
runTest (Test (UtxowPredicateFailure era)
 -> Rule (utxow era) 'Transition ())
-> Test (UtxowPredicateFailure era)
-> Rule (utxow era) 'Transition ()
forall a b. (a -> b) -> a -> b
$ PParams era
-> Set (ScriptHash (Crypto era))
-> Set (ScriptHash (Crypto era))
-> Test (UtxowPredicateFailure era)
forall era.
HasField "_protocolVersion" (PParams era) ProtVer =>
PParams era
-> Set (ScriptHash (Crypto era))
-> Set (ScriptHash (Crypto era))
-> Test (UtxowPredicateFailure era)
validateMissingScripts PParams era
pp (UTxO era -> Tx era -> Set (ScriptHash (Crypto era))
forall era tx.
(Era era, HasField "body" tx (TxBody era),
 HasField "certs" (TxBody era) (StrictSeq (DCert (Crypto era))),
 HasField "wdrls" (TxBody era) (Wdrl (Crypto era)),
 HasField "inputs" (TxBody era) (Set (TxIn (Crypto era)))) =>
UTxO era -> tx -> Set (ScriptHash (Crypto era))
scriptsNeeded UTxO era
utxo Tx era
Signal (utxow era)
tx) (Map (ScriptHash (Crypto era)) (Script era)
-> Set (ScriptHash (Crypto era))
forall k a. Map k a -> Set k
Map.keysSet (Tx era -> Map (ScriptHash (Crypto era)) (Script era)
forall k (x :: k) r a. HasField x r a => r -> a
getField @"scriptWits" Tx era
Signal (utxow era)
tx))

  -- check VKey witnesses
  {-  ∀ (vk ↦ σ) ∈ (txwitsVKey txw), V_vk⟦ txbodyHash ⟧_σ                -}
  Test (UtxowPredicateFailure era) -> Rule (utxow era) 'Transition ()
forall t sts (ctx :: RuleType).
Inject t (PredicateFailure sts) =>
Test t -> Rule sts ctx ()
runTestOnSignal (Test (UtxowPredicateFailure era)
 -> Rule (utxow era) 'Transition ())
-> Test (UtxowPredicateFailure era)
-> Rule (utxow era) 'Transition ()
forall a b. (a -> b) -> a -> b
$ Tx era -> Test (UtxowPredicateFailure era)
forall era.
(Era era,
 HasField "addrWits" (Tx era) (Set (WitVKey 'Witness (Crypto era))),
 HasField "bootWits" (Tx era) (Set (BootstrapWitness (Crypto era))),
 DSignable (Crypto era) (Hash (Crypto era) EraIndependentTxBody)) =>
Tx era -> Test (UtxowPredicateFailure era)
validateVerifiedWits Tx era
Signal (utxow era)
tx

  {-  witsVKeyNeeded utxo tx genDelegs ⊆ witsKeyHashes                   -}
  Test (UtxowPredicateFailure era) -> Rule (utxow era) 'Transition ()
forall t sts (ctx :: RuleType).
Inject t (PredicateFailure sts) =>
Test t -> Rule sts ctx ()
runTest (Test (UtxowPredicateFailure era)
 -> Rule (utxow era) 'Transition ())
-> Test (UtxowPredicateFailure era)
-> Rule (utxow era) 'Transition ()
forall a b. (a -> b) -> a -> b
$ (UTxO era
 -> Tx era -> GenDelegs (Crypto era) -> WitHashes (Crypto era))
-> GenDelegs (Crypto era)
-> UTxO era
-> Tx era
-> WitHashes (Crypto era)
-> Test (UtxowPredicateFailure era)
forall era.
(UTxO era
 -> Tx era -> GenDelegs (Crypto era) -> WitHashes (Crypto era))
-> GenDelegs (Crypto era)
-> UTxO era
-> Tx era
-> WitHashes (Crypto era)
-> Test (UtxowPredicateFailure era)
validateNeededWitnesses UTxO era
-> Tx era -> GenDelegs (Crypto era) -> WitHashes (Crypto era)
forall era tx.
(Era era, HasField "body" tx (TxBody era),
 HasField "wdrls" (TxBody era) (Wdrl (Crypto era)),
 HasField "certs" (TxBody era) (StrictSeq (DCert (Crypto era))),
 HasField "inputs" (TxBody era) (Set (TxIn (Crypto era))),
 HasField "update" (TxBody era) (StrictMaybe (Update era))) =>
UTxO era -> tx -> GenDelegs (Crypto era) -> WitHashes (Crypto era)
witsVKeyNeeded GenDelegs (Crypto era)
genDelegs UTxO era
utxo Tx era
Signal (utxow era)
tx WitHashes (Crypto era)
witsKeyHashes

  -- check metadata hash
  {-  ((adh = ◇) ∧ (ad= ◇)) ∨ (adh = hashAD ad)                          -}
  Test (UtxowPredicateFailure era) -> Rule (utxow era) 'Transition ()
forall t sts (ctx :: RuleType).
Inject t (PredicateFailure sts) =>
Test t -> Rule sts ctx ()
runTestOnSignal (Test (UtxowPredicateFailure era)
 -> Rule (utxow era) 'Transition ())
-> Test (UtxowPredicateFailure era)
-> Rule (utxow era) 'Transition ()
forall a b. (a -> b) -> a -> b
$ PParams era -> Tx era -> Test (UtxowPredicateFailure era)
forall era.
(Era era, HasField "_protocolVersion" (PParams era) ProtVer,
 ValidateAuxiliaryData era (Crypto era)) =>
PParams era -> Tx era -> Test (UtxowPredicateFailure era)
validateMetadata PParams era
pp Tx era
Signal (utxow era)
tx

  -- check genesis keys signatures for instantaneous rewards certificates
  {-  genSig := { hashKey gkey | gkey ∈ dom(genDelegs)} ∩ witsKeyHashes  -}
  {-  { c ∈ txcerts txb ∩ DCert_mir} ≠ ∅  ⇒ (|genSig| ≥ Quorum) ∧ (d pp > 0)  -}
  Word64
coreNodeQuorum <- BaseM (utxow era) Word64 -> Rule (utxow era) 'Transition Word64
forall sts a (ctx :: RuleType).
STS sts =>
BaseM sts a -> Rule sts ctx a
liftSTS (BaseM (utxow era) Word64 -> Rule (utxow era) 'Transition Word64)
-> BaseM (utxow era) Word64 -> Rule (utxow era) 'Transition Word64
forall a b. (a -> b) -> a -> b
$ (Globals -> Word64) -> ReaderT Globals Identity Word64
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Globals -> Word64
quorum
  Test (UtxowPredicateFailure era) -> Rule (utxow era) 'Transition ()
forall t sts (ctx :: RuleType).
Inject t (PredicateFailure sts) =>
Test t -> Rule sts ctx ()
runTest (Test (UtxowPredicateFailure era)
 -> Rule (utxow era) 'Transition ())
-> Test (UtxowPredicateFailure era)
-> Rule (utxow era) 'Transition ()
forall a b. (a -> b) -> a -> b
$
    GenDelegs (Crypto era)
-> Word64
-> WitHashes (Crypto era)
-> Tx era
-> Test (UtxowPredicateFailure era)
forall era crypto.
(HasField "body" (Tx era) (TxBody era),
 HasField "certs" (TxBody era) (StrictSeq (DCert crypto))) =>
GenDelegs (Crypto era)
-> Word64
-> WitHashes (Crypto era)
-> Tx era
-> Test (UtxowPredicateFailure era)
validateMIRInsufficientGenesisSigs GenDelegs (Crypto era)
genDelegs Word64
coreNodeQuorum WitHashes (Crypto era)
witsKeyHashes Tx era
Signal (utxow era)
tx

  forall sub super (rtype :: RuleType).
Embed sub super =>
RuleContext rtype sub -> Rule super rtype (State sub)
forall super (rtype :: RuleType).
Embed (EraRule "UTXO" era) super =>
RuleContext rtype (EraRule "UTXO" era)
-> Rule super rtype (State (EraRule "UTXO" era))
trans @(Core.EraRule "UTXO" era) (RuleContext 'Transition (EraRule "UTXO" era)
 -> Rule (utxow era) 'Transition (State (EraRule "UTXO" era)))
-> RuleContext 'Transition (EraRule "UTXO" era)
-> Rule (utxow era) 'Transition (State (EraRule "UTXO" era))
forall a b. (a -> b) -> a -> b
$
    (Environment (EraRule "UTXO" era), State (EraRule "UTXO" era),
 Signal (EraRule "UTXO" era))
-> TRC (EraRule "UTXO" era)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (SlotNo
-> PParams era
-> Map (KeyHash 'StakePool (Crypto era)) (PoolParams (Crypto era))
-> GenDelegs (Crypto era)
-> UtxoEnv era
forall era.
SlotNo
-> PParams era
-> Map (KeyHash 'StakePool (Crypto era)) (PoolParams (Crypto era))
-> GenDelegs (Crypto era)
-> UtxoEnv era
UtxoEnv SlotNo
slot PParams era
pp Map (KeyHash 'StakePool (Crypto era)) (PoolParams (Crypto era))
stakepools GenDelegs (Crypto era)
genDelegs, State (utxow era)
State (EraRule "UTXO" era)
u, Signal (utxow era)
Signal (EraRule "UTXO" era)
tx)

instance
  ( Era era,
    STS (UTXO era),
    PredicateFailure (Core.EraRule "UTXO" era) ~ UtxoPredicateFailure era,
    Event (Core.EraRule "UTXO" era) ~ UtxoEvent era
  ) =>
  Embed (UTXO era) (UTXOW era)
  where
  wrapFailed :: PredicateFailure (UTXO era) -> PredicateFailure (UTXOW era)
wrapFailed = PredicateFailure (UTXO era) -> PredicateFailure (UTXOW era)
forall era.
PredicateFailure (EraRule "UTXO" era) -> UtxowPredicateFailure era
UtxoFailure
  wrapEvent :: Event (UTXO era) -> Event (UTXOW era)
wrapEvent = Event (UTXO era) -> Event (UTXOW era)
forall era. Event (EraRule "UTXO" era) -> UtxowEvent era
UtxoEvent

instance
  ( Era era,
    Core.Tx era ~ Tx era,
    DSignable (Crypto era) (Hash (Crypto era) EraIndependentTxBody),
    HasField "_protocolVersion" (Core.PParams era) ProtVer,
    -- Allow UTXOW to call UTXO
    Embed (Core.EraRule "UTXO" era) (UTXOW era),
    Environment (Core.EraRule "UTXO" era) ~ UtxoEnv era,
    State (Core.EraRule "UTXO" era) ~ UTxOState era,
    Signal (Core.EraRule "UTXO" era) ~ Core.Tx era,
    ShelleyStyleWitnessNeeds era
  ) =>
  STS (UTXOW era)
  where
  type State (UTXOW era) = UTxOState era
  type Signal (UTXOW era) = Tx era
  type Environment (UTXOW era) = UtxoEnv era
  type BaseM (UTXOW era) = ShelleyBase
  type PredicateFailure (UTXOW era) = UtxowPredicateFailure era
  type Event _ = UtxowEvent era
  transitionRules :: [TransitionRule (UTXOW era)]
transitionRules = [TransitionRule (UTXOW era)
forall era (utxow :: * -> *).
(Era era, BaseM (utxow era) ~ ShelleyBase,
 Embed (EraRule "UTXO" era) (utxow era),
 Environment (EraRule "UTXO" era) ~ UtxoEnv era,
 State (EraRule "UTXO" era) ~ UTxOState era,
 Signal (EraRule "UTXO" era) ~ Tx era,
 Environment (utxow era) ~ UtxoEnv era,
 State (utxow era) ~ UTxOState era, Signal (utxow era) ~ Tx era,
 PredicateFailure (utxow era) ~ UtxowPredicateFailure era,
 STS (utxow era), ShelleyStyleWitnessNeeds era) =>
TransitionRule (utxow era)
transitionRulesUTXOW]
  initialRules :: [InitialRule (UTXOW era)]
initialRules = [InitialRule (UTXOW era)
forall era.
(Embed (EraRule "UTXO" era) (UTXOW era),
 Environment (EraRule "UTXO" era) ~ UtxoEnv era,
 State (EraRule "UTXO" era) ~ UTxOState era) =>
InitialRule (UTXOW era)
initialLedgerStateUTXOW]

{-  ∀ s ∈ range(txscripts txw) ∩ Scriptnative), runNativeScript s tx   -}
validateFailedScripts ::
  forall era.
  ValidateScript era =>
  Core.Tx era ->
  Test (UtxowPredicateFailure era)
validateFailedScripts :: Tx era -> Test (UtxowPredicateFailure era)
validateFailedScripts Tx era
tx = do
  let failedScripts :: Map (ScriptHash (Crypto era)) (Script era)
failedScripts =
        (ScriptHash (Crypto era) -> Script era -> Bool)
-> Map (ScriptHash (Crypto era)) (Script era)
-> Map (ScriptHash (Crypto era)) (Script era)
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey
          ( \ScriptHash (Crypto era)
hs Script era
validator ->
              Script era -> ScriptHash (Crypto era)
forall era.
ValidateScript era =>
Script era -> ScriptHash (Crypto era)
hashScript @era Script era
validator ScriptHash (Crypto era) -> ScriptHash (Crypto era) -> Bool
forall a. Eq a => a -> a -> Bool
/= ScriptHash (Crypto era)
hs Bool -> Bool -> Bool
|| Bool -> Bool
not (Script era -> Tx era -> Bool
forall era. ValidateScript era => Script era -> Tx era -> Bool
validateScript @era Script era
validator Tx era
tx)
          )
          (Tx era -> Map (ScriptHash (Crypto era)) (Script era)
forall k (x :: k) r a. HasField x r a => r -> a
getField @"scriptWits" Tx era
tx)
  Bool
-> UtxowPredicateFailure era -> Test (UtxowPredicateFailure era)
forall e. Bool -> e -> Validation (NonEmpty e) ()
failureUnless (Map (ScriptHash (Crypto era)) (Script era) -> Bool
forall k a. Map k a -> Bool
Map.null Map (ScriptHash (Crypto era)) (Script era)
failedScripts) (UtxowPredicateFailure era -> Test (UtxowPredicateFailure era))
-> UtxowPredicateFailure era -> Test (UtxowPredicateFailure era)
forall a b. (a -> b) -> a -> b
$
    Set (ScriptHash (Crypto era)) -> UtxowPredicateFailure era
forall era.
Set (ScriptHash (Crypto era)) -> UtxowPredicateFailure era
ScriptWitnessNotValidatingUTXOW (Map (ScriptHash (Crypto era)) (Script era)
-> Set (ScriptHash (Crypto era))
forall k a. Map k a -> Set k
Map.keysSet Map (ScriptHash (Crypto era)) (Script era)
failedScripts)

{-  { s | (_,s) ∈ scriptsNeeded utxo tx} = dom(txscripts txw)    -}
{-  sNeeded := scriptsNeeded utxo tx                             -}
{-  sReceived := Map.keysSet (getField @"scriptWits" tx)         -}
validateMissingScripts ::
  forall era.
  ( HasField "_protocolVersion" (Core.PParams era) ProtVer
  ) =>
  Core.PParams era ->
  Set (ScriptHash (Crypto era)) ->
  Set (ScriptHash (Crypto era)) ->
  Test (UtxowPredicateFailure era)
validateMissingScripts :: PParams era
-> Set (ScriptHash (Crypto era))
-> Set (ScriptHash (Crypto era))
-> Test (UtxowPredicateFailure era)
validateMissingScripts PParams era
pp Set (ScriptHash (Crypto era))
sNeeded Set (ScriptHash (Crypto era))
sReceived =
  if PParams era -> Bool
forall pp. HasField "_protocolVersion" pp ProtVer => pp -> Bool
HardForks.missingScriptsSymmetricDifference PParams era
pp
    then
      [Test (UtxowPredicateFailure era)]
-> Test (UtxowPredicateFailure era)
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Applicative f) =>
t (f a) -> f ()
sequenceA_
        [ Bool
-> UtxowPredicateFailure era -> Test (UtxowPredicateFailure era)
forall e. Bool -> e -> Validation (NonEmpty e) ()
failureUnless (Set (ScriptHash (Crypto era))
sNeeded Set (ScriptHash (Crypto era))
-> Set (ScriptHash (Crypto era)) -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set (ScriptHash (Crypto era))
sReceived) (UtxowPredicateFailure era -> Test (UtxowPredicateFailure era))
-> UtxowPredicateFailure era -> Test (UtxowPredicateFailure era)
forall a b. (a -> b) -> a -> b
$
            Set (ScriptHash (Crypto era)) -> UtxowPredicateFailure era
forall era.
Set (ScriptHash (Crypto era)) -> UtxowPredicateFailure era
MissingScriptWitnessesUTXOW (Set (ScriptHash (Crypto era))
sNeeded Set (ScriptHash (Crypto era))
-> Set (ScriptHash (Crypto era)) -> Set (ScriptHash (Crypto era))
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set (ScriptHash (Crypto era))
sReceived),
          Bool
-> UtxowPredicateFailure era -> Test (UtxowPredicateFailure era)
forall e. Bool -> e -> Validation (NonEmpty e) ()
failureUnless (Set (ScriptHash (Crypto era))
sReceived Set (ScriptHash (Crypto era))
-> Set (ScriptHash (Crypto era)) -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set (ScriptHash (Crypto era))
sNeeded) (UtxowPredicateFailure era -> Test (UtxowPredicateFailure era))
-> UtxowPredicateFailure era -> Test (UtxowPredicateFailure era)
forall a b. (a -> b) -> a -> b
$
            Set (ScriptHash (Crypto era)) -> UtxowPredicateFailure era
forall era.
Set (ScriptHash (Crypto era)) -> UtxowPredicateFailure era
ExtraneousScriptWitnessesUTXOW (Set (ScriptHash (Crypto era))
sReceived Set (ScriptHash (Crypto era))
-> Set (ScriptHash (Crypto era)) -> Set (ScriptHash (Crypto era))
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set (ScriptHash (Crypto era))
sNeeded)
        ]
    else
      Bool
-> UtxowPredicateFailure era -> Test (UtxowPredicateFailure era)
forall e. Bool -> e -> Validation (NonEmpty e) ()
failureUnless (Set (ScriptHash (Crypto era))
sNeeded Set (ScriptHash (Crypto era))
-> Set (ScriptHash (Crypto era)) -> Bool
forall a. Eq a => a -> a -> Bool
== Set (ScriptHash (Crypto era))
sReceived) (UtxowPredicateFailure era -> Test (UtxowPredicateFailure era))
-> UtxowPredicateFailure era -> Test (UtxowPredicateFailure era)
forall a b. (a -> b) -> a -> b
$
        Set (ScriptHash (Crypto era)) -> UtxowPredicateFailure era
forall era.
Set (ScriptHash (Crypto era)) -> UtxowPredicateFailure era
MissingScriptWitnessesUTXOW (Set (ScriptHash (Crypto era))
sNeeded Set (ScriptHash (Crypto era))
-> Set (ScriptHash (Crypto era)) -> Set (ScriptHash (Crypto era))
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set (ScriptHash (Crypto era))
sReceived)

-- | Given a ledger state, determine if the UTxO witnesses in a given
--  transaction are correct.
validateVerifiedWits ::
  forall era.
  ( Era era,
    HasField "addrWits" (Core.Tx era) (Set (WitVKey 'Witness (Crypto era))),
    HasField "bootWits" (Core.Tx era) (Set (BootstrapWitness (Crypto era))),
    DSignable (Crypto era) (Hash (Crypto era) EraIndependentTxBody)
  ) =>
  Core.Tx era ->
  Test (UtxowPredicateFailure era)
validateVerifiedWits :: Tx era -> Test (UtxowPredicateFailure era)
validateVerifiedWits Tx era
tx =
  case [VKey 'Witness (Crypto era)]
failed [VKey 'Witness (Crypto era)]
-> [VKey 'Witness (Crypto era)] -> [VKey 'Witness (Crypto era)]
forall a. Semigroup a => a -> a -> a
<> [VKey 'Witness (Crypto era)]
failedBootstrap of
    [] -> () -> Test (UtxowPredicateFailure era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    [VKey 'Witness (Crypto era)]
nonEmpty -> UtxowPredicateFailure era -> Test (UtxowPredicateFailure era)
forall e a. e -> Validation (NonEmpty e) a
failure (UtxowPredicateFailure era -> Test (UtxowPredicateFailure era))
-> UtxowPredicateFailure era -> Test (UtxowPredicateFailure era)
forall a b. (a -> b) -> a -> b
$ [VKey 'Witness (Crypto era)] -> UtxowPredicateFailure era
forall era.
[VKey 'Witness (Crypto era)] -> UtxowPredicateFailure era
InvalidWitnessesUTXOW [VKey 'Witness (Crypto era)]
nonEmpty
  where
    txBody :: TxBody era
txBody = Tx era -> TxBody era
forall k (x :: k) r a. HasField x r a => r -> a
getField @"body" Tx era
tx
    txBodyHash :: Hash (HASH (Crypto era)) EraIndependentTxBody
txBodyHash = SafeHash (Crypto era) EraIndependentTxBody
-> Hash (HASH (Crypto era)) EraIndependentTxBody
forall crypto i. SafeHash crypto i -> Hash (HASH crypto) i
extractHash (TxBody era -> SafeHash (Crypto era) EraIndependentTxBody
forall c i x.
(HasAlgorithm c, HashAnnotated x i c) =>
x -> SafeHash c i
hashAnnotated @(Crypto era) TxBody era
txBody)
    wvkKey :: WitVKey kr crypto -> VKey kr crypto
wvkKey (WitVKey VKey kr crypto
k SignedDSIGN crypto (Hash crypto EraIndependentTxBody)
_) = VKey kr crypto
k
    failed :: [VKey 'Witness (Crypto era)]
failed =
      WitVKey 'Witness (Crypto era) -> VKey 'Witness (Crypto era)
forall crypto (kr :: KeyRole).
(Crypto crypto, Typeable kr) =>
WitVKey kr crypto -> VKey kr crypto
wvkKey
        (WitVKey 'Witness (Crypto era) -> VKey 'Witness (Crypto era))
-> [WitVKey 'Witness (Crypto era)] -> [VKey 'Witness (Crypto era)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (WitVKey 'Witness (Crypto era) -> Bool)
-> [WitVKey 'Witness (Crypto era)]
-> [WitVKey 'Witness (Crypto era)]
forall a. (a -> Bool) -> [a] -> [a]
filter
          (Bool -> Bool
not (Bool -> Bool)
-> (WitVKey 'Witness (Crypto era) -> Bool)
-> WitVKey 'Witness (Crypto era)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash (HASH (Crypto era)) EraIndependentTxBody
-> WitVKey 'Witness (Crypto era) -> Bool
forall (kr :: KeyRole) crypto.
(Typeable kr, Crypto crypto,
 DSignable crypto (Hash crypto EraIndependentTxBody)) =>
Hash crypto EraIndependentTxBody -> WitVKey kr crypto -> Bool
verifyWitVKey Hash (HASH (Crypto era)) EraIndependentTxBody
txBodyHash)
          (Set (WitVKey 'Witness (Crypto era))
-> [WitVKey 'Witness (Crypto era)]
forall a. Set a -> [a]
Set.toList (Set (WitVKey 'Witness (Crypto era))
 -> [WitVKey 'Witness (Crypto era)])
-> Set (WitVKey 'Witness (Crypto era))
-> [WitVKey 'Witness (Crypto era)]
forall a b. (a -> b) -> a -> b
$ Tx era -> Set (WitVKey 'Witness (Crypto era))
forall k (x :: k) r a. HasField x r a => r -> a
getField @"addrWits" Tx era
tx)
    failedBootstrap :: [VKey 'Witness (Crypto era)]
failedBootstrap =
      BootstrapWitness (Crypto era) -> VKey 'Witness (Crypto era)
forall crypto.
BootstrapWitness crypto -> Crypto crypto => VKey 'Witness crypto
bwKey
        (BootstrapWitness (Crypto era) -> VKey 'Witness (Crypto era))
-> [BootstrapWitness (Crypto era)] -> [VKey 'Witness (Crypto era)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (BootstrapWitness (Crypto era) -> Bool)
-> [BootstrapWitness (Crypto era)]
-> [BootstrapWitness (Crypto era)]
forall a. (a -> Bool) -> [a] -> [a]
filter
          (Bool -> Bool
not (Bool -> Bool)
-> (BootstrapWitness (Crypto era) -> Bool)
-> BootstrapWitness (Crypto era)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash (HASH (Crypto era)) EraIndependentTxBody
-> BootstrapWitness (Crypto era) -> Bool
forall crypto.
(Crypto crypto,
 Signable (DSIGN crypto) (Hash crypto EraIndependentTxBody)) =>
Hash crypto EraIndependentTxBody -> BootstrapWitness crypto -> Bool
verifyBootstrapWit Hash (HASH (Crypto era)) EraIndependentTxBody
txBodyHash)
          (Set (BootstrapWitness (Crypto era))
-> [BootstrapWitness (Crypto era)]
forall a. Set a -> [a]
Set.toList (Set (BootstrapWitness (Crypto era))
 -> [BootstrapWitness (Crypto era)])
-> Set (BootstrapWitness (Crypto era))
-> [BootstrapWitness (Crypto era)]
forall a b. (a -> b) -> a -> b
$ Tx era -> Set (BootstrapWitness (Crypto era))
forall k (x :: k) r a. HasField x r a => r -> a
getField @"bootWits" Tx era
tx)

{-
validateNeededWitnesses ::
  ( Era era,
    HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)),
    HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))),
    HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))),
    HasField "update" (Core.TxBody era) (StrictMaybe (Update era))
  ) =>
  GenDelegs (Crypto era) ->
  UTxO era ->
  Core.Tx era ->
  WitHashes (Crypto era) ->
  Test (UtxowPredicateFailure era)
validateNeededWitnesses genDelegs utxo tx witsKeyHashes =
  let needed = witsVKeyNeeded utxo tx genDelegs
      missingWitnesses = diffWitHashes needed witsKeyHashes
   in failureUnless (nullWitHashes missingWitnesses) $
        MissingVKeyWitnessesUTXOW missingWitnesses
-}

-- How to compute the set of witnessed needed (witsvkeyneeded) varies
-- from Era to Era, so we parameterise over that function in this test.
-- That allows it to be used in many Eras.
validateNeededWitnesses ::
  (UTxO era -> Core.Tx era -> GenDelegs (Crypto era) -> WitHashes (Crypto era)) ->
  GenDelegs (Crypto era) ->
  UTxO era ->
  Core.Tx era ->
  WitHashes (Crypto era) ->
  Test (UtxowPredicateFailure era)
validateNeededWitnesses :: (UTxO era
 -> Tx era -> GenDelegs (Crypto era) -> WitHashes (Crypto era))
-> GenDelegs (Crypto era)
-> UTxO era
-> Tx era
-> WitHashes (Crypto era)
-> Test (UtxowPredicateFailure era)
validateNeededWitnesses UTxO era
-> Tx era -> GenDelegs (Crypto era) -> WitHashes (Crypto era)
witsvkeyneeded GenDelegs (Crypto era)
genDelegs UTxO era
utxo Tx era
tx WitHashes (Crypto era)
witsKeyHashes =
  let needed :: WitHashes (Crypto era)
needed = UTxO era
-> Tx era -> GenDelegs (Crypto era) -> WitHashes (Crypto era)
witsvkeyneeded UTxO era
utxo Tx era
tx GenDelegs (Crypto era)
genDelegs
      missingWitnesses :: WitHashes (Crypto era)
missingWitnesses = WitHashes (Crypto era)
-> WitHashes (Crypto era) -> WitHashes (Crypto era)
forall crypto.
WitHashes crypto -> WitHashes crypto -> WitHashes crypto
diffWitHashes WitHashes (Crypto era)
needed WitHashes (Crypto era)
witsKeyHashes
   in Bool
-> UtxowPredicateFailure era -> Test (UtxowPredicateFailure era)
forall e. Bool -> e -> Validation (NonEmpty e) ()
failureUnless (WitHashes (Crypto era) -> Bool
forall crypto. WitHashes crypto -> Bool
nullWitHashes WitHashes (Crypto era)
missingWitnesses) (UtxowPredicateFailure era -> Test (UtxowPredicateFailure era))
-> UtxowPredicateFailure era -> Test (UtxowPredicateFailure era)
forall a b. (a -> b) -> a -> b
$
        WitHashes (Crypto era) -> UtxowPredicateFailure era
forall era. WitHashes (Crypto era) -> UtxowPredicateFailure era
MissingVKeyWitnessesUTXOW WitHashes (Crypto era)
missingWitnesses

-- | 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.
witsVKeyNeeded ::
  forall era tx.
  ( Era era,
    HasField "body" tx (Core.TxBody era),
    HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)),
    HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))),
    HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))),
    HasField "update" (Core.TxBody era) (StrictMaybe (Update era))
  ) =>
  UTxO era ->
  tx ->
  GenDelegs (Crypto era) ->
  WitHashes (Crypto era)
witsVKeyNeeded :: UTxO era -> tx -> GenDelegs (Crypto era) -> WitHashes (Crypto era)
witsVKeyNeeded UTxO era
utxo' tx
tx GenDelegs (Crypto era)
genDelegs =
  Set (KeyHash 'Witness (Crypto era)) -> WitHashes (Crypto era)
forall crypto. Set (KeyHash 'Witness crypto) -> WitHashes crypto
WitHashes (Set (KeyHash 'Witness (Crypto era)) -> WitHashes (Crypto era))
-> Set (KeyHash 'Witness (Crypto era)) -> WitHashes (Crypto era)
forall a b. (a -> b) -> a -> b
$
    Set (KeyHash 'Witness (Crypto era))
certAuthors
      Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set (KeyHash 'Witness (Crypto era))
inputAuthors
      Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set (KeyHash 'Witness (Crypto era))
owners
      Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set (KeyHash 'Witness (Crypto era))
wdrlAuthors
      Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set (KeyHash 'Witness (Crypto era))
updateKeys
  where
    txbody :: TxBody era
txbody = tx -> TxBody era
forall k (x :: k) r a. HasField x r a => r -> a
getField @"body" tx
tx
    inputAuthors :: Set (KeyHash 'Witness (Crypto era))
    inputAuthors :: Set (KeyHash 'Witness (Crypto era))
inputAuthors = (TxIn (Crypto era)
 -> Set (KeyHash 'Witness (Crypto era))
 -> Set (KeyHash 'Witness (Crypto era)))
-> Set (KeyHash 'Witness (Crypto era))
-> Set (TxIn (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TxIn (Crypto era)
-> Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
accum Set (KeyHash 'Witness (Crypto era))
forall a. Set a
Set.empty (TxBody era -> Set (TxIn (Crypto era))
forall k (x :: k) r a. HasField x r a => r -> a
getField @"inputs" TxBody era
txbody)
      where
        accum :: TxIn (Crypto era)
-> Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
accum TxIn (Crypto era)
txin Set (KeyHash 'Witness (Crypto era))
ans =
          case TxIn (Crypto era) -> UTxO era -> Maybe (TxOut era)
forall era. TxIn (Crypto era) -> UTxO era -> Maybe (TxOut era)
txinLookup TxIn (Crypto era)
txin UTxO era
utxo' of
            Just TxOut era
out ->
              case TxOut era -> Addr (Crypto era)
forall e. Era e => TxOut e -> Addr (Crypto e)
getTxOutAddr TxOut era
out of
                Addr Network
_ (KeyHashObj KeyHash 'Payment (Crypto era)
pay) StakeReference (Crypto era)
_ -> KeyHash 'Witness (Crypto era)
-> Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
forall a. Ord a => a -> Set a -> Set a
Set.insert (KeyHash 'Payment (Crypto era) -> KeyHash 'Witness (Crypto era)
forall (a :: KeyRole -> * -> *) (r :: KeyRole) crypto.
HasKeyRole a =>
a r crypto -> a 'Witness crypto
asWitness KeyHash 'Payment (Crypto era)
pay) Set (KeyHash 'Witness (Crypto era))
ans
                AddrBootstrap BootstrapAddress (Crypto era)
bootAddr ->
                  KeyHash 'Witness (Crypto era)
-> Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
forall a. Ord a => a -> Set a -> Set a
Set.insert (KeyHash 'Payment (Crypto era) -> KeyHash 'Witness (Crypto era)
forall (a :: KeyRole -> * -> *) (r :: KeyRole) crypto.
HasKeyRole a =>
a r crypto -> a 'Witness crypto
asWitness (BootstrapAddress (Crypto era) -> KeyHash 'Payment (Crypto era)
forall crypto.
Crypto crypto =>
BootstrapAddress crypto -> KeyHash 'Payment crypto
bootstrapKeyHash BootstrapAddress (Crypto era)
bootAddr)) Set (KeyHash 'Witness (Crypto era))
ans
                Addr (Crypto era)
_ -> Set (KeyHash 'Witness (Crypto era))
ans
            Maybe (TxOut era)
Nothing -> Set (KeyHash 'Witness (Crypto era))
ans

    wdrlAuthors :: Set (KeyHash 'Witness (Crypto era))
    wdrlAuthors :: Set (KeyHash 'Witness (Crypto era))
wdrlAuthors = (RewardAcnt (Crypto era)
 -> Coin
 -> Set (KeyHash 'Witness (Crypto era))
 -> Set (KeyHash 'Witness (Crypto era)))
-> Set (KeyHash 'Witness (Crypto era))
-> Map (RewardAcnt (Crypto era)) Coin
-> Set (KeyHash 'Witness (Crypto era))
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey RewardAcnt (Crypto era)
-> Coin
-> Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
forall crypto p.
RewardAcnt crypto
-> p
-> Set (KeyHash 'Witness crypto)
-> Set (KeyHash 'Witness crypto)
accum Set (KeyHash 'Witness (Crypto era))
forall a. Set a
Set.empty (Wdrl (Crypto era) -> Map (RewardAcnt (Crypto era)) Coin
forall crypto. Wdrl crypto -> Map (RewardAcnt crypto) Coin
unWdrl (TxBody era -> Wdrl (Crypto era)
forall k (x :: k) r a. HasField x r a => r -> a
getField @"wdrls" TxBody era
txbody))
      where
        accum :: RewardAcnt crypto
-> p
-> Set (KeyHash 'Witness crypto)
-> Set (KeyHash 'Witness crypto)
accum RewardAcnt crypto
key p
_ Set (KeyHash 'Witness crypto)
ans = Set (KeyHash 'Witness crypto)
-> Set (KeyHash 'Witness crypto) -> Set (KeyHash 'Witness crypto)
forall a. Ord a => Set a -> Set a -> Set a
Set.union ([Credential 'Staking crypto] -> Set (KeyHash 'Witness crypto)
forall (r :: KeyRole) crypto.
[Credential r crypto] -> Set (KeyHash 'Witness crypto)
extractKeyHashWitnessSet [RewardAcnt crypto -> Credential 'Staking crypto
forall crypto. RewardAcnt crypto -> Credential 'Staking crypto
getRwdCred RewardAcnt crypto
key]) Set (KeyHash 'Witness crypto)
ans
    owners :: Set (KeyHash 'Witness (Crypto era))
    owners :: Set (KeyHash 'Witness (Crypto era))
owners = (DCert (Crypto era)
 -> Set (KeyHash 'Witness (Crypto era))
 -> Set (KeyHash 'Witness (Crypto era)))
-> Set (KeyHash 'Witness (Crypto era))
-> StrictSeq (DCert (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr DCert (Crypto era)
-> Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
forall crypto.
DCert crypto
-> Set (KeyHash 'Witness crypto) -> Set (KeyHash 'Witness crypto)
accum Set (KeyHash 'Witness (Crypto era))
forall a. Set a
Set.empty (TxBody era -> StrictSeq (DCert (Crypto era))
forall k (x :: k) r a. HasField x r a => r -> a
getField @"certs" TxBody era
txbody)
      where
        accum :: DCert crypto
-> Set (KeyHash 'Witness crypto) -> Set (KeyHash 'Witness crypto)
accum (DCertPool (RegPool PoolParams crypto
pool)) Set (KeyHash 'Witness crypto)
ans =
          Set (KeyHash 'Witness crypto)
-> Set (KeyHash 'Witness crypto) -> Set (KeyHash 'Witness crypto)
forall a. Ord a => Set a -> Set a -> Set a
Set.union
            ((KeyHash 'Staking crypto -> KeyHash 'Witness crypto)
-> Set (KeyHash 'Staking crypto) -> Set (KeyHash 'Witness crypto)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map KeyHash 'Staking crypto -> KeyHash 'Witness crypto
forall (a :: KeyRole -> * -> *) (r :: KeyRole) crypto.
HasKeyRole a =>
a r crypto -> a 'Witness crypto
asWitness (PoolParams crypto -> Set (KeyHash 'Staking crypto)
forall crypto. PoolParams crypto -> Set (KeyHash 'Staking crypto)
_poolOwners PoolParams crypto
pool))
            Set (KeyHash 'Witness crypto)
ans
        accum DCert crypto
_cert Set (KeyHash 'Witness crypto)
ans = Set (KeyHash 'Witness crypto)
ans
    cwitness :: DCert crypto -> Set (KeyHash 'Witness crypto)
cwitness (DCertDeleg DelegCert crypto
dc) = [Credential 'Staking crypto] -> Set (KeyHash 'Witness crypto)
forall (r :: KeyRole) crypto.
[Credential r crypto] -> Set (KeyHash 'Witness crypto)
extractKeyHashWitnessSet [DelegCert crypto -> Credential 'Staking crypto
forall crypto. DelegCert crypto -> Credential 'Staking crypto
delegCWitness DelegCert crypto
dc]
    cwitness (DCertPool PoolCert crypto
pc) = [Credential 'StakePool crypto] -> Set (KeyHash 'Witness crypto)
forall (r :: KeyRole) crypto.
[Credential r crypto] -> Set (KeyHash 'Witness crypto)
extractKeyHashWitnessSet [PoolCert crypto -> Credential 'StakePool crypto
forall crypto. PoolCert crypto -> Credential 'StakePool crypto
poolCWitness PoolCert crypto
pc]
    cwitness (DCertGenesis GenesisDelegCert crypto
gc) = KeyHash 'Witness crypto -> Set (KeyHash 'Witness crypto)
forall a. a -> Set a
Set.singleton (KeyHash 'Genesis crypto -> KeyHash 'Witness crypto
forall (a :: KeyRole -> * -> *) (r :: KeyRole) crypto.
HasKeyRole a =>
a r crypto -> a 'Witness crypto
asWitness (KeyHash 'Genesis crypto -> KeyHash 'Witness crypto)
-> KeyHash 'Genesis crypto -> KeyHash 'Witness crypto
forall a b. (a -> b) -> a -> b
$ GenesisDelegCert crypto -> KeyHash 'Genesis crypto
forall crypto. GenesisDelegCert crypto -> KeyHash 'Genesis crypto
genesisCWitness GenesisDelegCert crypto
gc)
    cwitness DCert crypto
c = String -> Set (KeyHash 'Witness crypto)
forall a. HasCallStack => String -> a
error (String -> Set (KeyHash 'Witness crypto))
-> String -> Set (KeyHash 'Witness crypto)
forall a b. (a -> b) -> a -> b
$ DCert crypto -> String
forall a. Show a => a -> String
show DCert crypto
c String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" does not have a witness"
    -- key reg requires no witness but this is already filtered outby requiresVKeyWitness
    -- before the call to `cwitness`, so this error should never be reached.

    certAuthors :: Set (KeyHash 'Witness (Crypto era))
    certAuthors :: Set (KeyHash 'Witness (Crypto era))
certAuthors = (DCert (Crypto era)
 -> Set (KeyHash 'Witness (Crypto era))
 -> Set (KeyHash 'Witness (Crypto era)))
-> Set (KeyHash 'Witness (Crypto era))
-> StrictSeq (DCert (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr DCert (Crypto era)
-> Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
forall crypto.
DCert crypto
-> Set (KeyHash 'Witness crypto) -> Set (KeyHash 'Witness crypto)
accum Set (KeyHash 'Witness (Crypto era))
forall a. Set a
Set.empty (TxBody era -> StrictSeq (DCert (Crypto era))
forall k (x :: k) r a. HasField x r a => r -> a
getField @"certs" TxBody era
txbody)
      where
        accum :: DCert crypto
-> Set (KeyHash 'Witness crypto) -> Set (KeyHash 'Witness crypto)
accum DCert crypto
cert Set (KeyHash 'Witness crypto)
ans | DCert crypto -> Bool
forall crypto. DCert crypto -> Bool
requiresVKeyWitness DCert crypto
cert = Set (KeyHash 'Witness crypto)
-> Set (KeyHash 'Witness crypto) -> Set (KeyHash 'Witness crypto)
forall a. Ord a => Set a -> Set a -> Set a
Set.union (DCert crypto -> Set (KeyHash 'Witness crypto)
forall crypto. DCert crypto -> Set (KeyHash 'Witness crypto)
cwitness DCert crypto
cert) Set (KeyHash 'Witness crypto)
ans
        accum DCert crypto
_cert Set (KeyHash 'Witness crypto)
ans = Set (KeyHash 'Witness crypto)
ans
    updateKeys :: Set (KeyHash 'Witness (Crypto era))
    updateKeys :: Set (KeyHash 'Witness (Crypto era))
updateKeys =
      KeyHash 'Witness (Crypto era) -> KeyHash 'Witness (Crypto era)
forall (a :: KeyRole -> * -> *) (r :: KeyRole) crypto.
HasKeyRole a =>
a r crypto -> a 'Witness crypto
asWitness
        (KeyHash 'Witness (Crypto era) -> KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
forall b a. Ord b => (a -> b) -> Set a -> Set b
`Set.map` Maybe (Update era)
-> GenDelegs (Crypto era) -> Set (KeyHash 'Witness (Crypto era))
forall era.
Maybe (Update era)
-> GenDelegs (Crypto era) -> Set (KeyHash 'Witness (Crypto era))
propWits
          ( StrictMaybe (Update era) -> Maybe (Update era)
forall a. StrictMaybe a -> Maybe a
strictMaybeToMaybe (StrictMaybe (Update era) -> Maybe (Update era))
-> StrictMaybe (Update era) -> Maybe (Update era)
forall a b. (a -> b) -> a -> b
$
              TxBody era -> StrictMaybe (Update era)
forall k (x :: k) r a. HasField x r a => r -> a
getField @"update" TxBody era
txbody
          )
          GenDelegs (Crypto era)
genDelegs

-- | check metadata hash
--   ((adh = ◇) ∧ (ad= ◇)) ∨ (adh = hashAD ad)
validateMetadata ::
  forall era.
  ( Era era,
    HasField "_protocolVersion" (Core.PParams era) ProtVer,
    ValidateAuxiliaryData era (Crypto era)
  ) =>
  Core.PParams era ->
  Core.Tx era ->
  Test (UtxowPredicateFailure era)
validateMetadata :: PParams era -> Tx era -> Test (UtxowPredicateFailure era)
validateMetadata PParams era
pp Tx era
tx =
  let txbody :: TxBody era
txbody = Tx era -> TxBody era
forall k (x :: k) r a. HasField x r a => r -> a
getField @"body" Tx era
tx
      pv :: ProtVer
pv = PParams era -> ProtVer
forall k (x :: k) r a. HasField x r a => r -> a
getField @"_protocolVersion" PParams era
pp
   in case (TxBody era -> StrictMaybe (AuxiliaryDataHash (Crypto era))
forall k (x :: k) r a. HasField x r a => r -> a
getField @"adHash" TxBody era
txbody, Tx era -> StrictMaybe (AuxiliaryData era)
forall k (x :: k) r a. HasField x r a => r -> a
getField @"auxiliaryData" Tx era
tx) of
        (StrictMaybe (AuxiliaryDataHash (Crypto era))
SNothing, StrictMaybe (AuxiliaryData era)
SNothing) -> () -> Test (UtxowPredicateFailure era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        (SJust AuxiliaryDataHash (Crypto era)
mdh, StrictMaybe (AuxiliaryData era)
SNothing) -> UtxowPredicateFailure era -> Test (UtxowPredicateFailure era)
forall e a. e -> Validation (NonEmpty e) a
failure (UtxowPredicateFailure era -> Test (UtxowPredicateFailure era))
-> UtxowPredicateFailure era -> Test (UtxowPredicateFailure era)
forall a b. (a -> b) -> a -> b
$ AuxiliaryDataHash (Crypto era) -> UtxowPredicateFailure era
forall era.
AuxiliaryDataHash (Crypto era) -> UtxowPredicateFailure era
MissingTxMetadata AuxiliaryDataHash (Crypto era)
mdh
        (StrictMaybe (AuxiliaryDataHash (Crypto era))
SNothing, SJust AuxiliaryData era
md') ->
          UtxowPredicateFailure era -> Test (UtxowPredicateFailure era)
forall e a. e -> Validation (NonEmpty e) a
failure (UtxowPredicateFailure era -> Test (UtxowPredicateFailure era))
-> UtxowPredicateFailure era -> Test (UtxowPredicateFailure era)
forall a b. (a -> b) -> a -> b
$ AuxiliaryDataHash (Crypto era) -> UtxowPredicateFailure era
forall era.
AuxiliaryDataHash (Crypto era) -> UtxowPredicateFailure era
MissingTxBodyMetadataHash (AuxiliaryData era -> AuxiliaryDataHash (Crypto era)
forall era c.
ValidateAuxiliaryData era c =>
AuxiliaryData era -> AuxiliaryDataHash c
hashAuxiliaryData @era AuxiliaryData era
md')
        (SJust AuxiliaryDataHash (Crypto era)
mdh, SJust AuxiliaryData era
md') ->
          [Test (UtxowPredicateFailure era)]
-> Test (UtxowPredicateFailure era)
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Applicative f) =>
t (f a) -> f ()
sequenceA_
            [ Bool
-> UtxowPredicateFailure era -> Test (UtxowPredicateFailure era)
forall e. Bool -> e -> Validation (NonEmpty e) ()
failureUnless (AuxiliaryData era -> AuxiliaryDataHash (Crypto era)
forall era c.
ValidateAuxiliaryData era c =>
AuxiliaryData era -> AuxiliaryDataHash c
hashAuxiliaryData @era AuxiliaryData era
md' AuxiliaryDataHash (Crypto era)
-> AuxiliaryDataHash (Crypto era) -> Bool
forall a. Eq a => a -> a -> Bool
== AuxiliaryDataHash (Crypto era)
mdh) (UtxowPredicateFailure era -> Test (UtxowPredicateFailure era))
-> UtxowPredicateFailure era -> Test (UtxowPredicateFailure era)
forall a b. (a -> b) -> a -> b
$
                AuxiliaryDataHash (Crypto era)
-> AuxiliaryDataHash (Crypto era) -> UtxowPredicateFailure era
forall era.
AuxiliaryDataHash (Crypto era)
-> AuxiliaryDataHash (Crypto era) -> UtxowPredicateFailure era
ConflictingMetadataHash AuxiliaryDataHash (Crypto era)
mdh (AuxiliaryData era -> AuxiliaryDataHash (Crypto era)
forall era c.
ValidateAuxiliaryData era c =>
AuxiliaryData era -> AuxiliaryDataHash c
hashAuxiliaryData @era AuxiliaryData era
md'),
              -- check metadata value sizes
              Bool
-> Test (UtxowPredicateFailure era)
-> Test (UtxowPredicateFailure era)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PParams era -> Bool
forall pp. HasField "_protocolVersion" pp ProtVer => pp -> Bool
SoftForks.validMetadata PParams era
pp) (Test (UtxowPredicateFailure era)
 -> Test (UtxowPredicateFailure era))
-> Test (UtxowPredicateFailure era)
-> Test (UtxowPredicateFailure era)
forall a b. (a -> b) -> a -> b
$
                Bool
-> UtxowPredicateFailure era -> Test (UtxowPredicateFailure era)
forall e. Bool -> e -> Validation (NonEmpty e) ()
failureUnless (ProtVer -> AuxiliaryData era -> Bool
forall era c.
ValidateAuxiliaryData era c =>
ProtVer -> AuxiliaryData era -> Bool
validateAuxiliaryData @era ProtVer
pv AuxiliaryData era
md') UtxowPredicateFailure era
forall era. UtxowPredicateFailure era
InvalidMetadata
            ]

-- | check genesis keys signatures for instantaneous rewards certificates
--
-- genSig := { hashKey gkey | gkey ∈ dom(genDelegs)} ∩ witsKeyHashes
-- { c ∈ txcerts txb ∩ DCert_mir} ≠ ∅  ⇒ |genSig| ≥ Quorum
validateMIRInsufficientGenesisSigs ::
  ( HasField "body" (Core.Tx era) (Core.TxBody era),
    HasField "certs" (Core.TxBody era) (StrictSeq (DCert crypto))
  ) =>
  GenDelegs (Crypto era) ->
  Word64 ->
  WitHashes (Crypto era) ->
  Core.Tx era ->
  Test (UtxowPredicateFailure era)
validateMIRInsufficientGenesisSigs :: GenDelegs (Crypto era)
-> Word64
-> WitHashes (Crypto era)
-> Tx era
-> Test (UtxowPredicateFailure era)
validateMIRInsufficientGenesisSigs (GenDelegs Map (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era))
genMapping) Word64
coreNodeQuorum WitHashes (Crypto era)
witsKeyHashes Tx era
tx =
  let genDelegates :: Set (KeyHash 'Witness (Crypto era))
genDelegates =
        [KeyHash 'Witness (Crypto era)]
-> Set (KeyHash 'Witness (Crypto era))
forall a. Ord a => [a] -> Set a
Set.fromList ([KeyHash 'Witness (Crypto era)]
 -> Set (KeyHash 'Witness (Crypto era)))
-> [KeyHash 'Witness (Crypto era)]
-> Set (KeyHash 'Witness (Crypto era))
forall a b. (a -> b) -> a -> b
$ KeyHash 'GenesisDelegate (Crypto era)
-> KeyHash 'Witness (Crypto era)
forall (a :: KeyRole -> * -> *) (r :: KeyRole) crypto.
HasKeyRole a =>
a r crypto -> a 'Witness crypto
asWitness (KeyHash 'GenesisDelegate (Crypto era)
 -> KeyHash 'Witness (Crypto era))
-> (GenDelegPair (Crypto era)
    -> KeyHash 'GenesisDelegate (Crypto era))
-> GenDelegPair (Crypto era)
-> KeyHash 'Witness (Crypto era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenDelegPair (Crypto era) -> KeyHash 'GenesisDelegate (Crypto era)
forall crypto.
GenDelegPair crypto -> KeyHash 'GenesisDelegate crypto
genDelegKeyHash (GenDelegPair (Crypto era) -> KeyHash 'Witness (Crypto era))
-> [GenDelegPair (Crypto era)] -> [KeyHash 'Witness (Crypto era)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era))
-> [GenDelegPair (Crypto era)]
forall k a. Map k a -> [a]
Map.elems Map (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era))
genMapping
      WitHashes Set (KeyHash 'Witness (Crypto era))
khAsSet = WitHashes (Crypto era)
witsKeyHashes
      genSig :: Set (KeyHash 'Witness (Crypto era))
genSig = Exp (Sett (KeyHash 'Witness (Crypto era)) ())
-> Set (KeyHash 'Witness (Crypto era))
forall s t. Embed s t => Exp t -> s
eval (Set (KeyHash 'Witness (Crypto era))
genDelegates Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
-> Exp (Sett (KeyHash 'Witness (Crypto era)) ())
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 (Crypto era))
khAsSet)
      txBody :: TxBody era
txBody = Tx era -> TxBody era
forall k (x :: k) r a. HasField x r a => r -> a
getField @"body" Tx era
tx
      mirCerts :: StrictSeq (DCert crypto)
mirCerts =
        Seq (DCert crypto) -> StrictSeq (DCert crypto)
forall a. Seq a -> StrictSeq a
StrictSeq.forceToStrict
          (Seq (DCert crypto) -> StrictSeq (DCert crypto))
-> (StrictSeq (DCert crypto) -> Seq (DCert crypto))
-> StrictSeq (DCert crypto)
-> StrictSeq (DCert crypto)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DCert crypto -> Bool) -> Seq (DCert crypto) -> Seq (DCert crypto)
forall a. (a -> Bool) -> Seq a -> Seq a
Seq.filter DCert crypto -> Bool
forall crypto. DCert crypto -> Bool
isInstantaneousRewards
          (Seq (DCert crypto) -> Seq (DCert crypto))
-> (StrictSeq (DCert crypto) -> Seq (DCert crypto))
-> StrictSeq (DCert crypto)
-> Seq (DCert crypto)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrictSeq (DCert crypto) -> Seq (DCert crypto)
forall a. StrictSeq a -> Seq a
StrictSeq.fromStrict
          (StrictSeq (DCert crypto) -> StrictSeq (DCert crypto))
-> StrictSeq (DCert crypto) -> StrictSeq (DCert crypto)
forall a b. (a -> b) -> a -> b
$ TxBody era -> StrictSeq (DCert crypto)
forall k (x :: k) r a. HasField x r a => r -> a
getField @"certs" TxBody era
txBody
   in Bool
-> UtxowPredicateFailure era -> Test (UtxowPredicateFailure era)
forall e. Bool -> e -> Validation (NonEmpty e) ()
failureUnless
        (Bool -> Bool
not (StrictSeq (DCert crypto) -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null StrictSeq (DCert crypto)
mirCerts) Bool -> Bool -> Bool
==> Set (KeyHash 'Witness (Crypto era)) -> Int
forall a. Set a -> Int
Set.size Set (KeyHash 'Witness (Crypto era))
genSig Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
coreNodeQuorum)
        (UtxowPredicateFailure era -> Test (UtxowPredicateFailure era))
-> UtxowPredicateFailure era -> Test (UtxowPredicateFailure era)
forall a b. (a -> b) -> a -> b
$ Set (KeyHash 'Witness (Crypto era)) -> UtxowPredicateFailure era
forall era.
Set (KeyHash 'Witness (Crypto era)) -> UtxowPredicateFailure era
MIRInsufficientGenesisSigsUTXOW Set (KeyHash 'Witness (Crypto era))
genSig

-- ===================================================
-- Inject Instances

instance Inject (UtxowPredicateFailure era) (UtxowPredicateFailure era) where
  inject :: UtxowPredicateFailure era -> UtxowPredicateFailure era
inject = UtxowPredicateFailure era -> UtxowPredicateFailure era
forall a. a -> a
id

instance
  PredicateFailure (Core.EraRule "UTXO" era) ~ UtxoPredicateFailure era =>
  Inject (UtxoPredicateFailure era) (UtxowPredicateFailure era)
  where
  inject :: UtxoPredicateFailure era -> UtxowPredicateFailure era
inject = UtxoPredicateFailure era -> UtxowPredicateFailure era
forall era.
PredicateFailure (EraRule "UTXO" era) -> UtxowPredicateFailure era
UtxoFailure