{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}

module Test.Cardano.Ledger.Shelley.Rules.ClassifyTraces (
  onlyValidLedgerSignalsAreGenerated,
  onlyValidChainSignalsAreGenerated,
  relevantCasesAreCovered,
  propAbstractSizeBoundsBytes,
  propAbstractSizeNotTooBig,
) where

import Cardano.Ledger.BaseTypes (Globals, StrictMaybe (..), epochInfoPure)
import Cardano.Ledger.Binary.Plain as Plain (serialize')
import Cardano.Ledger.Block (Block (..), bheader)
import Cardano.Ledger.Shelley.API (
  Addr (..),
  Credential (..),
  ShelleyLEDGER,
 )
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.Shelley.LedgerState (LedgerState)
import Cardano.Ledger.Shelley.PParams (
  Update (..),
  pattern ProposedPPUpdates,
  pattern Update,
 )
import Cardano.Ledger.Shelley.State
import Cardano.Ledger.Shelley.TxCert (
  isDelegation,
  isGenesisDelegation,
  isRegPool,
  isReservesMIRCert,
  isRetirePool,
  isTreasuryMIRCert,
 )
import Cardano.Ledger.Slot (SlotNo (..), epochInfoSize)
import Cardano.Protocol.TPraos.BHeader (
  BHeader,
  bhbody,
  bheaderSlotNo,
 )
import Cardano.Slotting.Slot (EpochSize (..))
import Control.State.Transition (STS (State))
import Control.State.Transition.Extended (Environment, Signal)
import qualified Data.ByteString as BS
import Data.Foldable (foldMap', toList)
import Data.List.NonEmpty (nonEmpty)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import Data.Proxy
import Data.Semigroup (Sum (..))
import Data.Sequence.Strict (StrictSeq)
import Lens.Micro
import Lens.Micro.Extras (view)
import Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (MockCrypto)
import Test.Cardano.Ledger.Shelley.Constants (defaultConstants)
import Test.Cardano.Ledger.Shelley.Generator.Core (GenEnv)
import Test.Cardano.Ledger.Shelley.Generator.EraGen (EraGen)
import Test.Cardano.Ledger.Shelley.Generator.Presets (genEnv)
import Test.Cardano.Ledger.Shelley.Generator.ShelleyEraGen ()
import Test.Cardano.Ledger.Shelley.Generator.Trace.Chain (mkGenesisChainState)
import Test.Cardano.Ledger.Shelley.Generator.Trace.Ledger (mkGenesisLedgerState)
import Test.Cardano.Ledger.Shelley.Rules.Chain (CHAIN)
import Test.Cardano.Ledger.Shelley.Utils
import Test.Control.State.Transition.Trace (
  Trace,
  TraceOrder (OldestFirst),
  traceSignals,
 )
import Test.Control.State.Transition.Trace.Generator.QuickCheck (
  forAllTraceFromInitState,
  onlyValidSignalsAreGeneratedFromInitState,
  traceFromInitState,
 )
import qualified Test.Control.State.Transition.Trace.Generator.QuickCheck as QC
import Test.QuickCheck (
  Confidence (certainty),
  Property,
  checkCoverageWith,
  conjoin,
  cover,
  forAllBlind,
  property,
  stdConfidence,
  withMaxSuccess,
 )
import Test.Tasty (TestTree)
import qualified Test.Tasty.QuickCheck as TQC

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

relevantCasesAreCovered ::
  forall era.
  ( EraGen era
  , EraStake era
  , ChainProperty era
  , QC.HasTrace (CHAIN era) (GenEnv MockCrypto era)
  ) =>
  Int ->
  TestTree
relevantCasesAreCovered :: forall era.
(EraGen era, EraStake era, ChainProperty era,
 HasTrace (CHAIN era) (GenEnv MockCrypto era)) =>
Int -> TestTree
relevantCasesAreCovered Int
n =
  TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
TQC.testProperty
    TestName
"Chain and Ledger traces cover the relevant cases"
    (Int -> Property -> Property
forall prop. Testable prop => Int -> prop -> Property
TQC.withMaxSuccess Int
n Property
prop)
  where
    prop :: Property
prop = do
      let tl :: Word64
tl = Word64
100
      Confidence -> Property -> Property
forall prop. Testable prop => Confidence -> prop -> Property
checkCoverageWith Confidence
stdConfidence {certainty = 1_000_000} (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
        Gen (Trace (CHAIN era))
-> (Trace (CHAIN era) -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind
          ( forall sts traceGenEnv.
(HasTrace sts traceGenEnv, Show (Environment sts), HasCallStack) =>
BaseEnv sts
-> Word64
-> traceGenEnv
-> Maybe
     (IRC sts
      -> Gen (Either (NonEmpty (PredicateFailure sts)) (State sts)))
-> Gen (Trace sts)
traceFromInitState @(CHAIN era)
              Globals
BaseEnv (CHAIN era)
testGlobals
              Word64
tl
              (forall era c.
(EraGen era, Crypto c) =>
Proxy era -> Constants -> GenEnv c era
genEnv @era @MockCrypto Proxy era
p Constants
defaultConstants)
              Maybe
  (IRC (CHAIN era)
   -> Gen
        (Either
           (NonEmpty (PredicateFailure (CHAIN era))) (State (CHAIN era))))
Maybe
  (IRC (CHAIN era)
   -> Gen
        (Either
           (NonEmpty (TestChainPredicateFailure era)) (ChainState era)))
genesisChainSt
          )
          Trace (CHAIN era) -> Property
forall era.
(ChainProperty era, ShelleyEraTxBody era) =>
Trace (CHAIN era) -> Property
relevantCasesAreCoveredForTrace
    p :: Proxy era
    p :: Proxy era
p = Proxy era
forall {k} (t :: k). Proxy t
Proxy
    genesisChainSt :: Maybe
  (IRC (CHAIN era)
   -> Gen
        (Either
           (NonEmpty (TestChainPredicateFailure era)) (ChainState era)))
genesisChainSt = (IRC (CHAIN era)
 -> Gen
      (Either
         (NonEmpty (TestChainPredicateFailure era)) (ChainState era)))
-> Maybe
     (IRC (CHAIN era)
      -> Gen
           (Either
              (NonEmpty (TestChainPredicateFailure era)) (ChainState era)))
forall a. a -> Maybe a
Just ((IRC (CHAIN era)
  -> Gen
       (Either
          (NonEmpty (TestChainPredicateFailure era)) (ChainState era)))
 -> Maybe
      (IRC (CHAIN era)
       -> Gen
            (Either
               (NonEmpty (TestChainPredicateFailure era)) (ChainState era))))
-> (IRC (CHAIN era)
    -> Gen
         (Either
            (NonEmpty (TestChainPredicateFailure era)) (ChainState era)))
-> Maybe
     (IRC (CHAIN era)
      -> Gen
           (Either
              (NonEmpty (TestChainPredicateFailure era)) (ChainState era)))
forall a b. (a -> b) -> a -> b
$ GenEnv MockCrypto era
-> IRC (CHAIN era)
-> Gen
     (Either
        (NonEmpty (TestChainPredicateFailure era)) (ChainState era))
forall era a c.
(EraGen era, EraGov era, EraStake era) =>
GenEnv c era -> IRC (CHAIN era) -> Gen (Either a (ChainState era))
mkGenesisChainState (forall era c.
(EraGen era, Crypto c) =>
Proxy era -> Constants -> GenEnv c era
genEnv @era @MockCrypto Proxy era
p Constants
defaultConstants)

relevantCasesAreCoveredForTrace ::
  forall era.
  ( ChainProperty era
  , ShelleyEraTxBody era
  ) =>
  Trace (CHAIN era) ->
  Property
relevantCasesAreCoveredForTrace :: forall era.
(ChainProperty era, ShelleyEraTxBody era) =>
Trace (CHAIN era) -> Property
relevantCasesAreCoveredForTrace Trace (CHAIN era)
tr = do
  let blockTxs :: Block (BHeader MockCrypto) era -> [Tx era]
      blockTxs :: Block (BHeader MockCrypto) era -> [Tx era]
blockTxs (Block BHeader MockCrypto
_ TxSeq era
txSeq) = StrictSeq (Tx era) -> [Tx era]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (forall era. EraSegWits era => TxSeq era -> StrictSeq (Tx era)
fromTxSeq @era TxSeq era
txSeq)
      bs :: [Signal (CHAIN era)]
bs = TraceOrder -> Trace (CHAIN era) -> [Signal (CHAIN era)]
forall s. TraceOrder -> Trace s -> [Signal s]
traceSignals TraceOrder
OldestFirst Trace (CHAIN era)
tr
      txs :: [Tx era]
txs = [[Tx era]] -> [Tx era]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Block (BHeader MockCrypto) era -> [Tx era]
blockTxs (Block (BHeader MockCrypto) era -> [Tx era])
-> [Block (BHeader MockCrypto) era] -> [[Tx era]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Block (BHeader MockCrypto) era]
[Signal (CHAIN era)]
bs)
      certsByTx_ :: [[TxCert era]]
certsByTx_ = forall era.
(ShelleyEraTxBody era, EraTx era) =>
[Tx era] -> [[TxCert era]]
certsByTx @era [Tx era]
txs
      certs_ :: [TxCert era]
certs_ = [[TxCert era]] -> [TxCert era]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[TxCert era]]
certsByTx_

      classifications :: [(TestName, Bool, Double)]
classifications =
        [
          ( TestName
"there is at least 1 certificate for every 2 transactions"
          , [Tx era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx era]
txs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* [TxCert era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TxCert era]
certs_
          , Double
60
          )
        ,
          ( TestName
"there is at least 1 RegKey certificate for every 10 transactions"
          , [Tx era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx era]
txs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
* [TxCert era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((TxCert era -> Bool) -> [TxCert era] -> [TxCert era]
forall a. (a -> Bool) -> [a] -> [a]
filter TxCert era -> Bool
forall era. EraTxCert era => TxCert era -> Bool
isRegStakeTxCert [TxCert era]
certs_)
          , Double
60
          )
        ,
          ( TestName
"there is at least 1 DeRegKey certificate for every 20 transactions"
          , [Tx era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx era]
txs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
20 Int -> Int -> Int
forall a. Num a => a -> a -> a
* [TxCert era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((TxCert era -> Bool) -> [TxCert era] -> [TxCert era]
forall a. (a -> Bool) -> [a] -> [a]
filter TxCert era -> Bool
forall era. EraTxCert era => TxCert era -> Bool
isUnRegStakeTxCert [TxCert era]
certs_)
          , Double
60
          )
        ,
          ( TestName
"there is at least 1 Delegation certificate for every 10 transactions"
          , [Tx era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx era]
txs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
* [TxCert era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((TxCert era -> Bool) -> [TxCert era] -> [TxCert era]
forall a. (a -> Bool) -> [a] -> [a]
filter TxCert era -> Bool
forall era. ShelleyEraTxCert era => TxCert era -> Bool
isDelegation [TxCert era]
certs_)
          , Double
60
          )
        ,
          ( TestName
"there is at least 1 Genesis Delegation certificate for every 20 transactions"
          , [Tx era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx era]
txs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
20 Int -> Int -> Int
forall a. Num a => a -> a -> a
* [TxCert era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((TxCert era -> Bool) -> [TxCert era] -> [TxCert era]
forall a. (a -> Bool) -> [a] -> [a]
filter TxCert era -> Bool
forall era.
(ShelleyEraTxCert era, ProtVerAtMost era 8) =>
TxCert era -> Bool
isGenesisDelegation [TxCert era]
certs_)
          , Double
60
          )
        ,
          ( TestName
"there is at least 1 RetirePool certificate for every 10 transactions"
          , [Tx era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx era]
txs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
* [TxCert era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((TxCert era -> Bool) -> [TxCert era] -> [TxCert era]
forall a. (a -> Bool) -> [a] -> [a]
filter TxCert era -> Bool
forall era. EraTxCert era => TxCert era -> Bool
isRetirePool [TxCert era]
certs_)
          , Double
60
          )
        ,
          ( TestName
"there is at least 1 MIR certificate (spending Reserves) for every 60 transactions"
          , [Tx era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx era]
txs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
60 Int -> Int -> Int
forall a. Num a => a -> a -> a
* [TxCert era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((TxCert era -> Bool) -> [TxCert era] -> [TxCert era]
forall a. (a -> Bool) -> [a] -> [a]
filter TxCert era -> Bool
forall era.
(ShelleyEraTxCert era, ProtVerAtMost era 8) =>
TxCert era -> Bool
isReservesMIRCert [TxCert era]
certs_)
          , Double
40
          )
        ,
          ( TestName
"there is at least 1 MIR certificate (spending Treasury) for every 60 transactions"
          , [Tx era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx era]
txs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
60 Int -> Int -> Int
forall a. Num a => a -> a -> a
* [TxCert era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((TxCert era -> Bool) -> [TxCert era] -> [TxCert era]
forall a. (a -> Bool) -> [a] -> [a]
filter TxCert era -> Bool
forall era.
(ShelleyEraTxCert era, ProtVerAtMost era 8) =>
TxCert era -> Bool
isTreasuryMIRCert [TxCert era]
certs_)
          , Double
40
          )
        ,
          ( TestName
"there is at least 1 RegPool certificate for every 10 transactions"
          , [Tx era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx era]
txs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
* [TxCert era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((TxCert era -> Bool) -> [TxCert era] -> [TxCert era]
forall a. (a -> Bool) -> [a] -> [a]
filter TxCert era -> Bool
forall era. EraTxCert era => TxCert era -> Bool
isRegPool [TxCert era]
certs_)
          , Double
60
          )
        ,
          ( TestName
"at least 10% of TxOuts are scripts"
          , Double
0.1 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< [StrictSeq (TxOut era)] -> Double
forall era. EraTxOut era => [StrictSeq (TxOut era)] -> Double
txScriptOutputsRatio (Getting
  (StrictSeq (TxOut era)) (TxBody era) (StrictSeq (TxOut era))
-> TxBody era -> StrictSeq (TxOut era)
forall a s. Getting a s a -> s -> a
view Getting
  (StrictSeq (TxOut era)) (TxBody era) (StrictSeq (TxOut era))
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL (TxBody era -> StrictSeq (TxOut era))
-> (Tx era -> TxBody era) -> Tx era -> StrictSeq (TxOut era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (TxBody era) (Tx era) (TxBody era) -> Tx era -> TxBody era
forall a s. Getting a s a -> s -> a
view Getting (TxBody era) (Tx era) (TxBody era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL (Tx era -> StrictSeq (TxOut era))
-> [Tx era] -> [StrictSeq (TxOut era)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Tx era]
txs)
          , Double
20
          )
        ,
          ( TestName
"at least 10% of `ShelleyTxCertDeleg` certificates have script credentials"
          , Double
0.1 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< [TxCert era] -> Double
forall c. ShelleyEraTxCert c => [TxCert c] -> Double
scriptCredentialCertsRatio [TxCert era]
certs_
          , Double
60
          )
        ,
          ( TestName
"at least 1 in 10 transactions have a reward withdrawal"
          , [Tx era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx era]
txs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
* [Tx era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Tx era -> Bool) -> [Tx era] -> [Tx era]
forall a. (a -> Bool) -> [a] -> [a]
filter (forall era. (ShelleyEraTxBody era, EraTx era) => Tx era -> Bool
hasWithdrawal @era) [Tx era]
txs)
          , Double
60
          )
        ,
          ( TestName
"at least 1 in 20 transactions have non-trivial protocol param updates"
          , [Tx era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx era]
txs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
20 Int -> Int -> Int
forall a. Num a => a -> a -> a
* [Tx era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Tx era -> Bool) -> [Tx era] -> [Tx era]
forall a. (a -> Bool) -> [a] -> [a]
filter (forall era. (ShelleyEraTxBody era, EraTx era) => Tx era -> Bool
hasPParamUpdate @era) [Tx era]
txs)
          , Double
60
          )
        ,
          ( TestName
"at least 1 in 20 transactions have metadata"
          , [Tx era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx era]
txs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
20 Int -> Int -> Int
forall a. Num a => a -> a -> a
* [Tx era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Tx era -> Bool) -> [Tx era] -> [Tx era]
forall a. (a -> Bool) -> [a] -> [a]
filter (forall era. EraTx era => Tx era -> Bool
hasMetadata @era) [Tx era]
txs)
          , Double
60
          )
        ,
          ( TestName
"at least 5 epochs in a trace, 20% of the time"
          , Int
5 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= [Block (BHeader MockCrypto) era] -> Int
forall era. [Block (BHeader MockCrypto) era] -> Int
epochsInTrace [Block (BHeader MockCrypto) era]
[Signal (CHAIN era)]
bs
          , Double
20
          )
        ]

  [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin ([Property] -> Property) -> [Property] -> Property
forall a b. (a -> b) -> a -> b
$ (TestName, Bool, Double) -> Property
cover_ ((TestName, Bool, Double) -> Property)
-> [(TestName, Bool, Double)] -> [Property]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(TestName, Bool, Double)]
classifications
  where
    cover_ :: (TestName, Bool, Double) -> Property
cover_ (TestName
label, Bool
predicate, Double
coveragePc) =
      Double -> Bool -> TestName -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> TestName -> prop -> Property
cover Double
coveragePc Bool
predicate TestName
label (() -> Property
forall prop. Testable prop => prop -> Property
property ())

-- | Ratio of certificates with script credentials to the number of certificates
-- that could have script credentials.
scriptCredentialCertsRatio :: ShelleyEraTxCert c => [TxCert c] -> Double
scriptCredentialCertsRatio :: forall c. ShelleyEraTxCert c => [TxCert c] -> Double
scriptCredentialCertsRatio [TxCert c]
certs =
  Int -> Int -> Double
ratioInt Int
haveScriptCerts Int
couldhaveScriptCerts
  where
    haveScriptCerts :: Int
haveScriptCerts =
      [TxCert c] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([TxCert c] -> Int) -> [TxCert c] -> Int
forall a b. (a -> b) -> a -> b
$
        (TxCert c -> Bool) -> [TxCert c] -> [TxCert c]
forall a. (a -> Bool) -> [a] -> [a]
filter
          ( \case
              RegTxCert (ScriptHashObj ScriptHash
_) -> Bool
True
              UnRegTxCert (ScriptHashObj ScriptHash
_) -> Bool
True
              DelegStakeTxCert (ScriptHashObj ScriptHash
_) KeyHash 'StakePool
_ -> Bool
True
              TxCert c
_ -> Bool
False
          )
          [TxCert c]
certs
    couldhaveScriptCerts :: Int
couldhaveScriptCerts =
      [TxCert c] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([TxCert c] -> Int) -> [TxCert c] -> Int
forall a b. (a -> b) -> a -> b
$
        (TxCert c -> Bool) -> [TxCert c] -> [TxCert c]
forall a. (a -> Bool) -> [a] -> [a]
filter
          ( \case
              RegTxCert Credential 'Staking
_ -> Bool
True
              UnRegTxCert Credential 'Staking
_ -> Bool
True
              DelegStakeTxCert Credential 'Staking
_ KeyHash 'StakePool
_ -> Bool
True
              TxCert c
_ -> Bool
False
          )
          [TxCert c]
certs

-- | Extract the certificates from the transactions
certsByTx ::
  ( ShelleyEraTxBody era
  , EraTx era
  ) =>
  [Tx era] ->
  [[TxCert era]]
certsByTx :: forall era.
(ShelleyEraTxBody era, EraTx era) =>
[Tx era] -> [[TxCert era]]
certsByTx [Tx era]
txs = StrictSeq (TxCert era) -> [TxCert era]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (StrictSeq (TxCert era) -> [TxCert era])
-> (Tx era -> StrictSeq (TxCert era)) -> Tx era -> [TxCert era]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting
  (StrictSeq (TxCert era)) (TxBody era) (StrictSeq (TxCert era))
-> TxBody era -> StrictSeq (TxCert era)
forall a s. Getting a s a -> s -> a
view Getting
  (StrictSeq (TxCert era)) (TxBody era) (StrictSeq (TxCert era))
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL (TxBody era -> StrictSeq (TxCert era))
-> (Tx era -> TxBody era) -> Tx era -> StrictSeq (TxCert era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (TxBody era) (Tx era) (TxBody era) -> Tx era -> TxBody era
forall a s. Getting a s a -> s -> a
view Getting (TxBody era) (Tx era) (TxBody era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL (Tx era -> [TxCert era]) -> [Tx era] -> [[TxCert era]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Tx era]
txs

ratioInt :: Int -> Int -> Double
ratioInt :: Int -> Int -> Double
ratioInt Int
x Int
y =
  Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y

-- | Transaction has script locked TxOuts
txScriptOutputsRatio ::
  forall era.
  EraTxOut era =>
  [StrictSeq (TxOut era)] ->
  Double
txScriptOutputsRatio :: forall era. EraTxOut era => [StrictSeq (TxOut era)] -> Double
txScriptOutputsRatio [StrictSeq (TxOut era)]
txoutsList =
  Int -> Int -> Double
ratioInt
    ([Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((StrictSeq (TxOut era) -> Int) -> [StrictSeq (TxOut era)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map StrictSeq (TxOut era) -> Int
countScriptOuts [StrictSeq (TxOut era)]
txoutsList))
    ([Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((StrictSeq (TxOut era) -> Int) -> [StrictSeq (TxOut era)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map StrictSeq (TxOut era) -> Int
forall a. StrictSeq a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [StrictSeq (TxOut era)]
txoutsList))
  where
    countScriptOuts :: StrictSeq (TxOut era) -> Int
    countScriptOuts :: StrictSeq (TxOut era) -> Int
countScriptOuts =
      Sum Int -> Int
forall a. Sum a -> a
getSum
        (Sum Int -> Int)
-> (StrictSeq (TxOut era) -> Sum Int)
-> StrictSeq (TxOut era)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxOut era -> Sum Int) -> StrictSeq (TxOut era) -> Sum Int
forall m a. Monoid m => (a -> m) -> StrictSeq a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap'
          ( \TxOut era
out -> case TxOut era
out TxOut era -> Getting Addr (TxOut era) Addr -> Addr
forall s a. s -> Getting a s a -> a
^. Getting Addr (TxOut era) Addr
forall era. EraTxOut era => Lens' (TxOut era) Addr
Lens' (TxOut era) Addr
addrTxOutL of
              Addr Network
_ (ScriptHashObj ScriptHash
_) StakeReference
_ -> Int -> Sum Int
forall a. a -> Sum a
Sum Int
1
              Addr
_ -> Int -> Sum Int
forall a. a -> Sum a
Sum Int
0
          )

hasWithdrawal :: (ShelleyEraTxBody era, EraTx era) => Tx era -> Bool
hasWithdrawal :: forall era. (ShelleyEraTxBody era, EraTx era) => Tx era -> Bool
hasWithdrawal Tx era
tx = Bool -> Bool
not (Bool -> Bool)
-> (Map RewardAccount Coin -> Bool)
-> Map RewardAccount Coin
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map RewardAccount Coin -> Bool
forall a. Map RewardAccount a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Map RewardAccount Coin -> Bool) -> Map RewardAccount Coin -> Bool
forall a b. (a -> b) -> a -> b
$ Withdrawals -> Map RewardAccount Coin
unWithdrawals (Tx era
tx Tx era -> Getting Withdrawals (Tx era) Withdrawals -> Withdrawals
forall s a. s -> Getting a s a -> a
^. (TxBody era -> Const Withdrawals (TxBody era))
-> Tx era -> Const Withdrawals (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Const Withdrawals (TxBody era))
 -> Tx era -> Const Withdrawals (Tx era))
-> ((Withdrawals -> Const Withdrawals Withdrawals)
    -> TxBody era -> Const Withdrawals (TxBody era))
-> Getting Withdrawals (Tx era) Withdrawals
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Withdrawals -> Const Withdrawals Withdrawals)
-> TxBody era -> Const Withdrawals (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) Withdrawals
Lens' (TxBody era) Withdrawals
withdrawalsTxBodyL)

hasPParamUpdate :: (ShelleyEraTxBody era, EraTx era) => Tx era -> Bool
hasPParamUpdate :: forall era. (ShelleyEraTxBody era, EraTx era) => Tx era -> Bool
hasPParamUpdate Tx era
tx = StrictMaybe (Update era) -> Bool
forall {era}. StrictMaybe (Update era) -> Bool
ppUpdates (Tx era
tx Tx era
-> Getting
     (StrictMaybe (Update era)) (Tx era) (StrictMaybe (Update era))
-> StrictMaybe (Update era)
forall s a. s -> Getting a s a -> a
^. (TxBody era -> Const (StrictMaybe (Update era)) (TxBody era))
-> Tx era -> Const (StrictMaybe (Update era)) (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Const (StrictMaybe (Update era)) (TxBody era))
 -> Tx era -> Const (StrictMaybe (Update era)) (Tx era))
-> ((StrictMaybe (Update era)
     -> Const (StrictMaybe (Update era)) (StrictMaybe (Update era)))
    -> TxBody era -> Const (StrictMaybe (Update era)) (TxBody era))
-> Getting
     (StrictMaybe (Update era)) (Tx era) (StrictMaybe (Update era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe (Update era)
 -> Const (StrictMaybe (Update era)) (StrictMaybe (Update era)))
-> TxBody era -> Const (StrictMaybe (Update era)) (TxBody era)
forall era.
ShelleyEraTxBody era =>
Lens' (TxBody era) (StrictMaybe (Update era))
Lens' (TxBody era) (StrictMaybe (Update era))
updateTxBodyL)
  where
    ppUpdates :: StrictMaybe (Update era) -> Bool
ppUpdates StrictMaybe (Update era)
SNothing = Bool
False
    ppUpdates (SJust (Update (ProposedPPUpdates Map (KeyHash 'Genesis) (PParamsUpdate era)
ppUpd) EpochNo
_)) = Map (KeyHash 'Genesis) (PParamsUpdate era) -> Int
forall k a. Map k a -> Int
Map.size Map (KeyHash 'Genesis) (PParamsUpdate era)
ppUpd Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0

hasMetadata :: EraTx era => Tx era -> Bool
hasMetadata :: forall era. EraTx era => Tx era -> Bool
hasMetadata Tx era
tx = StrictMaybe TxAuxDataHash -> Bool
forall {a}. StrictMaybe a -> Bool
f (Tx era
tx Tx era
-> Getting
     (StrictMaybe TxAuxDataHash) (Tx era) (StrictMaybe TxAuxDataHash)
-> StrictMaybe TxAuxDataHash
forall s a. s -> Getting a s a -> a
^. (TxBody era -> Const (StrictMaybe TxAuxDataHash) (TxBody era))
-> Tx era -> Const (StrictMaybe TxAuxDataHash) (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Const (StrictMaybe TxAuxDataHash) (TxBody era))
 -> Tx era -> Const (StrictMaybe TxAuxDataHash) (Tx era))
-> ((StrictMaybe TxAuxDataHash
     -> Const (StrictMaybe TxAuxDataHash) (StrictMaybe TxAuxDataHash))
    -> TxBody era -> Const (StrictMaybe TxAuxDataHash) (TxBody era))
-> Getting
     (StrictMaybe TxAuxDataHash) (Tx era) (StrictMaybe TxAuxDataHash)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe TxAuxDataHash
 -> Const (StrictMaybe TxAuxDataHash) (StrictMaybe TxAuxDataHash))
-> TxBody era -> Const (StrictMaybe TxAuxDataHash) (TxBody era)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictMaybe TxAuxDataHash)
Lens' (TxBody era) (StrictMaybe TxAuxDataHash)
auxDataHashTxBodyL)
  where
    f :: StrictMaybe a -> Bool
f StrictMaybe a
SNothing = Bool
False
    f (SJust a
_) = Bool
True

onlyValidLedgerSignalsAreGenerated ::
  forall era ledger.
  ( EraGen era
  , EraStake era
  , QC.HasTrace ledger (GenEnv MockCrypto era)
  , QC.BaseEnv ledger ~ Globals
  , State ledger ~ LedgerState era
  , Show (Environment ledger)
  , Show (Signal ledger)
  , EraGov era
  ) =>
  TestTree
onlyValidLedgerSignalsAreGenerated :: forall era ledger.
(EraGen era, EraStake era, HasTrace ledger (GenEnv MockCrypto era),
 BaseEnv ledger ~ Globals, State ledger ~ LedgerState era,
 Show (Environment ledger), Show (Signal ledger), EraGov era) =>
TestTree
onlyValidLedgerSignalsAreGenerated =
  TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
TQC.testProperty TestName
"Only valid Ledger STS signals are generated" Property
prop
  where
    prop :: Property
prop =
      Int -> Property -> Property
forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
200 (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
        forall sts traceGenEnv.
(HasTrace sts traceGenEnv, Show (Environment sts),
 Show (Signal sts)) =>
BaseEnv sts
-> Word64
-> traceGenEnv
-> Maybe
     (IRC sts
      -> Gen (Either (NonEmpty (PredicateFailure sts)) (State sts)))
-> Property
onlyValidSignalsAreGeneratedFromInitState
          @ledger
          Globals
BaseEnv ledger
testGlobals
          Word64
100
          GenEnv MockCrypto era
ge
          Maybe
  (IRC ledger
   -> Gen
        (Either (NonEmpty (PredicateFailure ledger)) (State ledger)))
Maybe
  (IRC ledger
   -> Gen
        (Either (NonEmpty (PredicateFailure ledger)) (LedgerState era)))
genesisLedgerSt
    p :: Proxy era
    p :: Proxy era
p = Proxy era
forall {k} (t :: k). Proxy t
Proxy
    ge :: GenEnv MockCrypto era
ge = forall era c.
(EraGen era, Crypto c) =>
Proxy era -> Constants -> GenEnv c era
genEnv @era @MockCrypto Proxy era
p Constants
defaultConstants
    genesisLedgerSt :: Maybe
  (IRC ledger
   -> Gen
        (Either (NonEmpty (PredicateFailure ledger)) (LedgerState era)))
genesisLedgerSt = (IRC ledger
 -> Gen
      (Either (NonEmpty (PredicateFailure ledger)) (LedgerState era)))
-> Maybe
     (IRC ledger
      -> Gen
           (Either (NonEmpty (PredicateFailure ledger)) (LedgerState era)))
forall a. a -> Maybe a
Just ((IRC ledger
  -> Gen
       (Either (NonEmpty (PredicateFailure ledger)) (LedgerState era)))
 -> Maybe
      (IRC ledger
       -> Gen
            (Either (NonEmpty (PredicateFailure ledger)) (LedgerState era))))
-> (IRC ledger
    -> Gen
         (Either (NonEmpty (PredicateFailure ledger)) (LedgerState era)))
-> Maybe
     (IRC ledger
      -> Gen
           (Either (NonEmpty (PredicateFailure ledger)) (LedgerState era)))
forall a b. (a -> b) -> a -> b
$ GenEnv MockCrypto era
-> IRC ledger
-> Gen
     (Either (NonEmpty (PredicateFailure ledger)) (LedgerState era))
forall a era ledger c.
(EraGen era, EraGov era, EraStake era) =>
GenEnv c era -> IRC ledger -> Gen (Either a (LedgerState era))
mkGenesisLedgerState GenEnv MockCrypto era
ge

-- | Check that the abstract transaction size function
-- actually bounds the number of bytes in the serialized transaction.
propAbstractSizeBoundsBytes ::
  forall era.
  ( EraGen era
  , EraGov era
  , EraStake era
  , QC.HasTrace (ShelleyLEDGER era) (GenEnv MockCrypto era)
  ) =>
  Property
propAbstractSizeBoundsBytes :: forall era.
(EraGen era, EraGov era, EraStake era,
 HasTrace (ShelleyLEDGER era) (GenEnv MockCrypto era)) =>
Property
propAbstractSizeBoundsBytes = Property -> Property
forall prop. Testable prop => prop -> Property
property (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ do
  let tl :: Word64
tl = Word64
100
      numBytes :: Tx era -> Integer
numBytes = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> (Tx era -> Int) -> Tx era -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int
BS.length (ByteString -> Int) -> (Tx era -> ByteString) -> Tx era -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx era -> ByteString
forall a. ToCBOR a => a -> ByteString
Plain.serialize'
  forall sts traceGenEnv prop.
(HasTrace sts traceGenEnv, Testable prop,
 Show (Environment sts)) =>
BaseEnv sts
-> Word64
-> traceGenEnv
-> Maybe
     (IRC sts
      -> Gen (Either (NonEmpty (PredicateFailure sts)) (State sts)))
-> (Trace sts -> prop)
-> Property
forAllTraceFromInitState @(ShelleyLEDGER era)
    Globals
BaseEnv (ShelleyLEDGER era)
testGlobals
    Word64
tl
    (forall era c.
(EraGen era, Crypto c) =>
Proxy era -> Constants -> GenEnv c era
genEnv @era @MockCrypto Proxy era
p Constants
defaultConstants)
    Maybe
  (IRC (ShelleyLEDGER era)
   -> Gen
        (Either
           (NonEmpty (PredicateFailure (ShelleyLEDGER era)))
           (State (ShelleyLEDGER era))))
Maybe
  (IRC (ShelleyLEDGER era)
   -> Gen
        (Either
           (NonEmpty (ShelleyLedgerPredFailure era)) (LedgerState era)))
genesisLedgerSt
    ((Trace (ShelleyLEDGER era) -> Bool) -> Property)
-> (Trace (ShelleyLEDGER era) -> Bool) -> Property
forall a b. (a -> b) -> a -> b
$ \Trace (ShelleyLEDGER era)
tr -> do
      let txs :: [Tx era]
          txs :: [Tx era]
txs = TraceOrder
-> Trace (ShelleyLEDGER era) -> [Signal (ShelleyLEDGER era)]
forall s. TraceOrder -> Trace s -> [Signal s]
traceSignals TraceOrder
OldestFirst Trace (ShelleyLEDGER era)
tr
      (Tx era -> Bool) -> [Tx era] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Tx era
tx -> Tx era -> Integer
forall era. EraTx era => Tx era -> Integer
txSizeBound Tx era
tx Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Tx era -> Integer
numBytes Tx era
tx) [Tx era]
txs
  where
    p :: Proxy era
    p :: Proxy era
p = Proxy era
forall {k} (t :: k). Proxy t
Proxy
    genesisLedgerSt :: Maybe
  (IRC (ShelleyLEDGER era)
   -> Gen
        (Either
           (NonEmpty (ShelleyLedgerPredFailure era)) (LedgerState era)))
genesisLedgerSt = (IRC (ShelleyLEDGER era)
 -> Gen
      (Either
         (NonEmpty (ShelleyLedgerPredFailure era)) (LedgerState era)))
-> Maybe
     (IRC (ShelleyLEDGER era)
      -> Gen
           (Either
              (NonEmpty (ShelleyLedgerPredFailure era)) (LedgerState era)))
forall a. a -> Maybe a
Just ((IRC (ShelleyLEDGER era)
  -> Gen
       (Either
          (NonEmpty (ShelleyLedgerPredFailure era)) (LedgerState era)))
 -> Maybe
      (IRC (ShelleyLEDGER era)
       -> Gen
            (Either
               (NonEmpty (ShelleyLedgerPredFailure era)) (LedgerState era))))
-> (IRC (ShelleyLEDGER era)
    -> Gen
         (Either
            (NonEmpty (ShelleyLedgerPredFailure era)) (LedgerState era)))
-> Maybe
     (IRC (ShelleyLEDGER era)
      -> Gen
           (Either
              (NonEmpty (ShelleyLedgerPredFailure era)) (LedgerState era)))
forall a b. (a -> b) -> a -> b
$ GenEnv MockCrypto era
-> IRC (ShelleyLEDGER era)
-> Gen
     (Either
        (NonEmpty (ShelleyLedgerPredFailure era)) (LedgerState era))
forall a era ledger c.
(EraGen era, EraGov era, EraStake era) =>
GenEnv c era -> IRC ledger -> Gen (Either a (LedgerState era))
mkGenesisLedgerState (forall era c.
(EraGen era, Crypto c) =>
Proxy era -> Constants -> GenEnv c era
genEnv @era @MockCrypto Proxy era
p Constants
defaultConstants)

-- | Check that the abstract transaction size function
-- is not off by an acceptable order of magnitude.
propAbstractSizeNotTooBig ::
  forall era.
  ( EraGen era
  , EraGov era
  , EraStake era
  , QC.HasTrace (ShelleyLEDGER era) (GenEnv MockCrypto era)
  ) =>
  Property
propAbstractSizeNotTooBig :: forall era.
(EraGen era, EraGov era, EraStake era,
 HasTrace (ShelleyLEDGER era) (GenEnv MockCrypto era)) =>
Property
propAbstractSizeNotTooBig = Property -> Property
forall prop. Testable prop => prop -> Property
property (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ do
  let tl :: Word64
tl = Word64
100
      -- The below acceptable order of magnitude may not actually be large enough.
      -- For small transactions, estimating the size of an encoded uint as 5
      -- may mean that our size is more like five times too big.
      -- It will be interesting to see the test fail with
      -- an acceptableMagnitude of three, though.
      acceptableMagnitude :: Integer
acceptableMagnitude = (Integer
3 :: Integer)
      numBytes :: Tx era -> Integer
numBytes = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> (Tx era -> Int) -> Tx era -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int
BS.length (ByteString -> Int) -> (Tx era -> ByteString) -> Tx era -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx era -> ByteString
forall a. ToCBOR a => a -> ByteString
Plain.serialize'
      notTooBig :: Tx era -> Bool
notTooBig Tx era
tx = Tx era -> Integer
forall era. EraTx era => Tx era -> Integer
txSizeBound Tx era
tx Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
acceptableMagnitude Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Tx era -> Integer
numBytes Tx era
tx
  forall sts traceGenEnv prop.
(HasTrace sts traceGenEnv, Testable prop,
 Show (Environment sts)) =>
BaseEnv sts
-> Word64
-> traceGenEnv
-> Maybe
     (IRC sts
      -> Gen (Either (NonEmpty (PredicateFailure sts)) (State sts)))
-> (Trace sts -> prop)
-> Property
forAllTraceFromInitState @(ShelleyLEDGER era)
    Globals
BaseEnv (ShelleyLEDGER era)
testGlobals
    Word64
tl
    (forall era c.
(EraGen era, Crypto c) =>
Proxy era -> Constants -> GenEnv c era
genEnv @era @MockCrypto Proxy era
p Constants
defaultConstants)
    Maybe
  (IRC (ShelleyLEDGER era)
   -> Gen
        (Either
           (NonEmpty (PredicateFailure (ShelleyLEDGER era)))
           (State (ShelleyLEDGER era))))
Maybe
  (IRC (ShelleyLEDGER era)
   -> Gen
        (Either
           (NonEmpty (ShelleyLedgerPredFailure era)) (LedgerState era)))
genesisLedgerSt
    ((Trace (ShelleyLEDGER era) -> Bool) -> Property)
-> (Trace (ShelleyLEDGER era) -> Bool) -> Property
forall a b. (a -> b) -> a -> b
$ \Trace (ShelleyLEDGER era)
tr -> do
      let txs :: [Tx era]
          txs :: [Tx era]
txs = TraceOrder
-> Trace (ShelleyLEDGER era) -> [Signal (ShelleyLEDGER era)]
forall s. TraceOrder -> Trace s -> [Signal s]
traceSignals TraceOrder
OldestFirst Trace (ShelleyLEDGER era)
tr
      (Tx era -> Bool) -> [Tx era] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Tx era -> Bool
notTooBig [Tx era]
txs
  where
    p :: Proxy era
    p :: Proxy era
p = Proxy era
forall {k} (t :: k). Proxy t
Proxy
    genesisLedgerSt :: Maybe
  (IRC (ShelleyLEDGER era)
   -> Gen
        (Either
           (NonEmpty (ShelleyLedgerPredFailure era)) (LedgerState era)))
genesisLedgerSt = (IRC (ShelleyLEDGER era)
 -> Gen
      (Either
         (NonEmpty (ShelleyLedgerPredFailure era)) (LedgerState era)))
-> Maybe
     (IRC (ShelleyLEDGER era)
      -> Gen
           (Either
              (NonEmpty (ShelleyLedgerPredFailure era)) (LedgerState era)))
forall a. a -> Maybe a
Just ((IRC (ShelleyLEDGER era)
  -> Gen
       (Either
          (NonEmpty (ShelleyLedgerPredFailure era)) (LedgerState era)))
 -> Maybe
      (IRC (ShelleyLEDGER era)
       -> Gen
            (Either
               (NonEmpty (ShelleyLedgerPredFailure era)) (LedgerState era))))
-> (IRC (ShelleyLEDGER era)
    -> Gen
         (Either
            (NonEmpty (ShelleyLedgerPredFailure era)) (LedgerState era)))
-> Maybe
     (IRC (ShelleyLEDGER era)
      -> Gen
           (Either
              (NonEmpty (ShelleyLedgerPredFailure era)) (LedgerState era)))
forall a b. (a -> b) -> a -> b
$ GenEnv MockCrypto era
-> IRC (ShelleyLEDGER era)
-> Gen
     (Either
        (NonEmpty (ShelleyLedgerPredFailure era)) (LedgerState era))
forall a era ledger c.
(EraGen era, EraGov era, EraStake era) =>
GenEnv c era -> IRC ledger -> Gen (Either a (LedgerState era))
mkGenesisLedgerState (forall era c.
(EraGen era, Crypto c) =>
Proxy era -> Constants -> GenEnv c era
genEnv @era @MockCrypto Proxy era
p Constants
defaultConstants)

onlyValidChainSignalsAreGenerated ::
  forall era.
  ( EraGen era
  , EraGov era
  , EraStake era
  , QC.HasTrace (CHAIN era) (GenEnv MockCrypto era)
  ) =>
  TestTree
onlyValidChainSignalsAreGenerated :: forall era.
(EraGen era, EraGov era, EraStake era,
 HasTrace (CHAIN era) (GenEnv MockCrypto era)) =>
TestTree
onlyValidChainSignalsAreGenerated =
  TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
TQC.testProperty TestName
"Only valid CHAIN STS signals are generated" Property
prop
  where
    prop :: Property
prop =
      Int -> Property -> Property
forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
100 (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
        forall sts traceGenEnv.
(HasTrace sts traceGenEnv, Show (Environment sts),
 Show (Signal sts)) =>
BaseEnv sts
-> Word64
-> traceGenEnv
-> Maybe
     (IRC sts
      -> Gen (Either (NonEmpty (PredicateFailure sts)) (State sts)))
-> Property
onlyValidSignalsAreGeneratedFromInitState @(CHAIN era)
          Globals
BaseEnv (CHAIN era)
testGlobals
          Word64
100
          (forall era c.
(EraGen era, Crypto c) =>
Proxy era -> Constants -> GenEnv c era
genEnv @era @MockCrypto Proxy era
p Constants
defaultConstants)
          Maybe
  (IRC (CHAIN era)
   -> Gen
        (Either
           (NonEmpty (PredicateFailure (CHAIN era))) (State (CHAIN era))))
Maybe
  (IRC (CHAIN era)
   -> Gen
        (Either
           (NonEmpty (TestChainPredicateFailure era)) (ChainState era)))
genesisChainSt
    p :: Proxy era
    p :: Proxy era
p = Proxy era
forall {k} (t :: k). Proxy t
Proxy
    genesisChainSt :: Maybe
  (IRC (CHAIN era)
   -> Gen
        (Either
           (NonEmpty (TestChainPredicateFailure era)) (ChainState era)))
genesisChainSt = (IRC (CHAIN era)
 -> Gen
      (Either
         (NonEmpty (TestChainPredicateFailure era)) (ChainState era)))
-> Maybe
     (IRC (CHAIN era)
      -> Gen
           (Either
              (NonEmpty (TestChainPredicateFailure era)) (ChainState era)))
forall a. a -> Maybe a
Just (GenEnv MockCrypto era
-> IRC (CHAIN era)
-> Gen
     (Either
        (NonEmpty (TestChainPredicateFailure era)) (ChainState era))
forall era a c.
(EraGen era, EraGov era, EraStake era) =>
GenEnv c era -> IRC (CHAIN era) -> Gen (Either a (ChainState era))
mkGenesisChainState (forall era c.
(EraGen era, Crypto c) =>
Proxy era -> Constants -> GenEnv c era
genEnv @era @MockCrypto Proxy era
p Constants
defaultConstants))

-- | Counts the epochs spanned by this trace
epochsInTrace :: forall era. [Block (BHeader MockCrypto) era] -> Int
epochsInTrace :: forall era. [Block (BHeader MockCrypto) era] -> Int
epochsInTrace [Block (BHeader MockCrypto) era]
bs'
  | Just NonEmpty (Block (BHeader MockCrypto) era)
bs <- [Block (BHeader MockCrypto) era]
-> Maybe (NonEmpty (Block (BHeader MockCrypto) era))
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [Block (BHeader MockCrypto) era]
bs' =
      let
        fromEpoch :: Word64
fromEpoch = SlotNo -> Word64
atEpoch (SlotNo -> Word64)
-> (Block (BHeader MockCrypto) era -> SlotNo)
-> Block (BHeader MockCrypto) era
-> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block (BHeader MockCrypto) era -> SlotNo
forall {era}. Block (BHeader MockCrypto) era -> SlotNo
blockSlot (Block (BHeader MockCrypto) era -> Word64)
-> Block (BHeader MockCrypto) era -> Word64
forall a b. (a -> b) -> a -> b
$ NonEmpty (Block (BHeader MockCrypto) era)
-> Block (BHeader MockCrypto) era
forall a. NonEmpty a -> a
NE.head NonEmpty (Block (BHeader MockCrypto) era)
bs
        toEpoch :: Word64
toEpoch = SlotNo -> Word64
atEpoch (SlotNo -> Word64)
-> (Block (BHeader MockCrypto) era -> SlotNo)
-> Block (BHeader MockCrypto) era
-> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block (BHeader MockCrypto) era -> SlotNo
forall {era}. Block (BHeader MockCrypto) era -> SlotNo
blockSlot (Block (BHeader MockCrypto) era -> Word64)
-> Block (BHeader MockCrypto) era -> Word64
forall a b. (a -> b) -> a -> b
$ NonEmpty (Block (BHeader MockCrypto) era)
-> Block (BHeader MockCrypto) era
forall a. NonEmpty a -> a
NE.last NonEmpty (Block (BHeader MockCrypto) era)
bs
        EpochSize Word64
slotsPerEpoch =
          HasCallStack => EpochInfo Identity -> EpochNo -> EpochSize
EpochInfo Identity -> EpochNo -> EpochSize
epochInfoSize (Globals -> EpochInfo Identity
epochInfoPure Globals
testGlobals) (EpochNo -> EpochSize) -> EpochNo -> EpochSize
forall a b. (a -> b) -> a -> b
$
            TestName -> EpochNo
forall a. HasCallStack => TestName -> a
error TestName
"Impossible: Fixed epoch size does not care about current epoch number"
        blockSlot :: Block (BHeader MockCrypto) era -> SlotNo
blockSlot = BHBody MockCrypto -> SlotNo
forall c. BHBody c -> SlotNo
bheaderSlotNo (BHBody MockCrypto -> SlotNo)
-> (Block (BHeader MockCrypto) era -> BHBody MockCrypto)
-> Block (BHeader MockCrypto) era
-> SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BHeader MockCrypto -> BHBody MockCrypto
forall c. Crypto c => BHeader c -> BHBody c
bhbody (BHeader MockCrypto -> BHBody MockCrypto)
-> (Block (BHeader MockCrypto) era -> BHeader MockCrypto)
-> Block (BHeader MockCrypto) era
-> BHBody MockCrypto
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block (BHeader MockCrypto) era -> BHeader MockCrypto
forall h era. Block h era -> h
bheader
        atEpoch :: SlotNo -> Word64
atEpoch (SlotNo Word64
s) = Word64
s Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`div` Word64
slotsPerEpoch
       in
        Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int) -> Word64 -> Int
forall a b. (a -> b) -> a -> b
$ Word64
toEpoch Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
fromEpoch Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1
  | Bool
otherwise = Int
0

-- | Convenience Function to bound the txsize function.
-- | It can be helpful for coin selection.
txSizeBound ::
  forall era.
  EraTx era =>
  Tx era ->
  Integer
txSizeBound :: forall era. EraTx era => Tx era -> Integer
txSizeBound Tx era
tx = Integer
numInputs Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
inputSize Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
numOutputs Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
outputSize Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
rest
  where
    uint :: Integer
uint = Integer
5
    smallArray :: Integer
smallArray = Integer
1
    hashLen :: Integer
hashLen = Integer
32
    hashObj :: Integer
hashObj = Integer
2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
hashLen
    addrHashLen :: Integer
addrHashLen = Integer
28
    addrHeader :: Integer
addrHeader = Integer
1
    address :: Integer
address = Integer
2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
addrHeader Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
addrHashLen
    txBody :: TxBody era
txBody = Tx era
tx Tx era -> Getting (TxBody era) (Tx era) (TxBody era) -> TxBody era
forall s a. s -> Getting a s a -> a
^. Getting (TxBody era) (Tx era) (TxBody era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL
    numInputs :: Integer
numInputs = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> (Set TxIn -> Int) -> Set TxIn -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set TxIn -> Int
forall a. Set a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Set TxIn -> Integer) -> Set TxIn -> Integer
forall a b. (a -> b) -> a -> b
$ TxBody era
txBody TxBody era
-> Getting (Set TxIn) (TxBody era) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. Getting (Set TxIn) (TxBody era) (Set TxIn)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL
    inputSize :: Integer
inputSize = Integer
smallArray Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
uint Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
hashObj
    numOutputs :: Integer
numOutputs = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer)
-> (StrictSeq (TxOut era) -> Int)
-> StrictSeq (TxOut era)
-> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrictSeq (TxOut era) -> Int
forall a. StrictSeq a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (StrictSeq (TxOut era) -> Integer)
-> StrictSeq (TxOut era) -> Integer
forall a b. (a -> b) -> a -> b
$ TxBody era
txBody TxBody era
-> Getting
     (StrictSeq (TxOut era)) (TxBody era) (StrictSeq (TxOut era))
-> StrictSeq (TxOut era)
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictSeq (TxOut era)) (TxBody era) (StrictSeq (TxOut era))
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL
    outputSize :: Integer
outputSize = Integer
smallArray Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
uint Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
address
    rest :: Integer
rest = Tx era
tx Tx era -> Getting Integer (Tx era) Integer -> Integer
forall s a. s -> Getting a s a -> a
^. Getting Integer (Tx era) Integer
forall era. EraTx era => SimpleGetter (Tx era) Integer
SimpleGetter (Tx era) Integer
sizeTxF