{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# 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 (..))
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 =
  String -> Property -> TestTree
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> TestTree
TQC.testProperty
    String
"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 TopTx era]
      blockTxs :: Block (BHeader MockCrypto) era -> [Tx TopTx era]
blockTxs Block {BlockBody era
blockBody :: BlockBody era
blockBody :: forall h era. Block h era -> BlockBody era
blockBody} = StrictSeq (Tx TopTx era) -> [Tx TopTx era]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (StrictSeq (Tx TopTx era) -> [Tx TopTx era])
-> StrictSeq (Tx TopTx era) -> [Tx TopTx era]
forall a b. (a -> b) -> a -> b
$ BlockBody era
blockBody BlockBody era
-> Getting
     (StrictSeq (Tx TopTx era))
     (BlockBody era)
     (StrictSeq (Tx TopTx era))
-> StrictSeq (Tx TopTx era)
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictSeq (Tx TopTx era))
  (BlockBody era)
  (StrictSeq (Tx TopTx era))
forall era.
EraBlockBody era =>
Lens' (BlockBody era) (StrictSeq (Tx TopTx era))
Lens' (BlockBody era) (StrictSeq (Tx TopTx era))
txSeqBlockBodyL
      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 TopTx era]
txs = (Block (BHeader MockCrypto) era -> [Tx TopTx era])
-> [Block (BHeader MockCrypto) era] -> [Tx TopTx era]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Block (BHeader MockCrypto) era -> [Tx TopTx era]
blockTxs [Block (BHeader MockCrypto) era]
[Signal (CHAIN era)]
bs
      certsByTx_ :: [[TxCert era]]
certsByTx_ = forall era.
(ShelleyEraTxBody era, EraTx era) =>
[Tx TopTx era] -> [[TxCert era]]
certsByTx @era [Tx TopTx era]
txs
      certs_ :: [TxCert era]
certs_ = [[TxCert era]] -> [TxCert era]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[TxCert era]]
certsByTx_

      classifications :: [(String, Bool, Double)]
classifications =
        [
          ( String
"there is at least 1 certificate for every 2 transactions"
          , [Tx TopTx era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx TopTx 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
          )
        ,
          ( String
"there is at least 1 RegKey certificate for every 10 transactions"
          , [Tx TopTx era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx TopTx 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
          )
        ,
          ( String
"there is at least 1 DeRegKey certificate for every 20 transactions"
          , [Tx TopTx era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx TopTx 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
          )
        ,
          ( String
"there is at least 1 Delegation certificate for every 10 transactions"
          , [Tx TopTx era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx TopTx 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
          )
        ,
          ( String
"there is at least 1 Genesis Delegation certificate for every 20 transactions"
          , [Tx TopTx era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx TopTx 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, AtMostEra "Babbage" era) =>
TxCert era -> Bool
isGenesisDelegation [TxCert era]
certs_)
          , Double
60
          )
        ,
          ( String
"there is at least 1 RetirePool certificate for every 10 transactions"
          , [Tx TopTx era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx TopTx 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
          )
        ,
          ( String
"there is at least 1 MIR certificate (spending Reserves) for every 60 transactions"
          , [Tx TopTx era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx TopTx 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, AtMostEra "Babbage" era) =>
TxCert era -> Bool
isReservesMIRCert [TxCert era]
certs_)
          , Double
40
          )
        ,
          ( String
"there is at least 1 MIR certificate (spending Treasury) for every 60 transactions"
          , [Tx TopTx era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx TopTx 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, AtMostEra "Babbage" era) =>
TxCert era -> Bool
isTreasuryMIRCert [TxCert era]
certs_)
          , Double
40
          )
        ,
          ( String
"there is at least 1 RegPool certificate for every 10 transactions"
          , [Tx TopTx era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx TopTx 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
          )
        ,
          ( String
"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 TopTx era) (StrictSeq (TxOut era))
-> TxBody TopTx era -> StrictSeq (TxOut era)
forall a s. Getting a s a -> s -> a
view Getting
  (StrictSeq (TxOut era)) (TxBody TopTx era) (StrictSeq (TxOut era))
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel). Lens' (TxBody l era) (StrictSeq (TxOut era))
outputsTxBodyL (TxBody TopTx era -> StrictSeq (TxOut era))
-> (Tx TopTx era -> TxBody TopTx era)
-> Tx TopTx era
-> StrictSeq (TxOut era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (TxBody TopTx era) (Tx TopTx era) (TxBody TopTx era)
-> Tx TopTx era -> TxBody TopTx era
forall a s. Getting a s a -> s -> a
view Getting (TxBody TopTx era) (Tx TopTx era) (TxBody TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL (Tx TopTx era -> StrictSeq (TxOut era))
-> [Tx TopTx era] -> [StrictSeq (TxOut era)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Tx TopTx era]
txs)
          , Double
20
          )
        ,
          ( String
"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
          )
        ,
          ( String
"at least 1 in 10 transactions have a reward withdrawal"
          , [Tx TopTx era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx TopTx 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 TopTx era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Tx TopTx era -> Bool) -> [Tx TopTx era] -> [Tx TopTx era]
forall a. (a -> Bool) -> [a] -> [a]
filter (forall era.
(ShelleyEraTxBody era, EraTx era) =>
Tx TopTx era -> Bool
hasWithdrawal @era) [Tx TopTx era]
txs)
          , Double
60
          )
        ,
          ( String
"at least 1 in 20 transactions have non-trivial protocol param updates"
          , [Tx TopTx era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx TopTx 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 TopTx era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Tx TopTx era -> Bool) -> [Tx TopTx era] -> [Tx TopTx era]
forall a. (a -> Bool) -> [a] -> [a]
filter (forall era.
(ShelleyEraTxBody era, EraTx era) =>
Tx TopTx era -> Bool
hasPParamUpdate @era) [Tx TopTx era]
txs)
          , Double
60
          )
        ,
          ( String
"at least 1 in 20 transactions have metadata"
          , [Tx TopTx era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx TopTx 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 TopTx era] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Tx TopTx era -> Bool) -> [Tx TopTx era] -> [Tx TopTx era]
forall a. (a -> Bool) -> [a] -> [a]
filter (forall era. EraTx era => Tx TopTx era -> Bool
hasMetadata @era) [Tx TopTx era]
txs)
          , Double
60
          )
        ,
          ( String
"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
$ (String, Bool, Double) -> Property
cover_ ((String, Bool, Double) -> Property)
-> [(String, Bool, Double)] -> [Property]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(String, Bool, Double)]
classifications
  where
    cover_ :: (String, Bool, Double) -> Property
cover_ (String
label, Bool
predicate, Double
coveragePc) =
      Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
coveragePc Bool
predicate String
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 TopTx era] ->
  [[TxCert era]]
certsByTx :: forall era.
(ShelleyEraTxBody era, EraTx era) =>
[Tx TopTx era] -> [[TxCert era]]
certsByTx [Tx TopTx 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 TopTx era -> StrictSeq (TxCert era))
-> Tx TopTx era
-> [TxCert era]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting
  (StrictSeq (TxCert era))
  (TxBody TopTx era)
  (StrictSeq (TxCert era))
-> TxBody TopTx era -> StrictSeq (TxCert era)
forall a s. Getting a s a -> s -> a
view Getting
  (StrictSeq (TxCert era))
  (TxBody TopTx era)
  (StrictSeq (TxCert era))
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxCert era))
forall (l :: TxLevel).
Lens' (TxBody l era) (StrictSeq (TxCert era))
certsTxBodyL (TxBody TopTx era -> StrictSeq (TxCert era))
-> (Tx TopTx era -> TxBody TopTx era)
-> Tx TopTx era
-> StrictSeq (TxCert era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (TxBody TopTx era) (Tx TopTx era) (TxBody TopTx era)
-> Tx TopTx era -> TxBody TopTx era
forall a s. Getting a s a -> s -> a
view Getting (TxBody TopTx era) (Tx TopTx era) (TxBody TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL (Tx TopTx era -> [TxCert era]) -> [Tx TopTx era] -> [[TxCert era]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Tx TopTx 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 TopTx era -> Bool
hasWithdrawal :: forall era.
(ShelleyEraTxBody era, EraTx era) =>
Tx TopTx era -> Bool
hasWithdrawal Tx TopTx 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 TopTx era
tx Tx TopTx era
-> Getting Withdrawals (Tx TopTx era) Withdrawals -> Withdrawals
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx era -> Const Withdrawals (TxBody TopTx era))
-> Tx TopTx era -> Const Withdrawals (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Const Withdrawals (TxBody TopTx era))
 -> Tx TopTx era -> Const Withdrawals (Tx TopTx era))
-> ((Withdrawals -> Const Withdrawals Withdrawals)
    -> TxBody TopTx era -> Const Withdrawals (TxBody TopTx era))
-> Getting Withdrawals (Tx TopTx era) Withdrawals
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Withdrawals -> Const Withdrawals Withdrawals)
-> TxBody TopTx era -> Const Withdrawals (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) Withdrawals
forall (l :: TxLevel). Lens' (TxBody l era) Withdrawals
withdrawalsTxBodyL)

hasPParamUpdate :: (ShelleyEraTxBody era, EraTx era) => Tx TopTx era -> Bool
hasPParamUpdate :: forall era.
(ShelleyEraTxBody era, EraTx era) =>
Tx TopTx era -> Bool
hasPParamUpdate Tx TopTx era
tx = StrictMaybe (Update era) -> Bool
forall {era}. StrictMaybe (Update era) -> Bool
ppUpdates (Tx TopTx era
tx Tx TopTx era
-> Getting
     (StrictMaybe (Update era))
     (Tx TopTx era)
     (StrictMaybe (Update era))
-> StrictMaybe (Update era)
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx era
 -> Const (StrictMaybe (Update era)) (TxBody TopTx era))
-> Tx TopTx era -> Const (StrictMaybe (Update era)) (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era
  -> Const (StrictMaybe (Update era)) (TxBody TopTx era))
 -> Tx TopTx era -> Const (StrictMaybe (Update era)) (Tx TopTx era))
-> ((StrictMaybe (Update era)
     -> Const (StrictMaybe (Update era)) (StrictMaybe (Update era)))
    -> TxBody TopTx era
    -> Const (StrictMaybe (Update era)) (TxBody TopTx era))
-> Getting
     (StrictMaybe (Update era))
     (Tx TopTx 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 TopTx era
-> Const (StrictMaybe (Update era)) (TxBody TopTx era)
forall era.
ShelleyEraTxBody era =>
Lens' (TxBody TopTx era) (StrictMaybe (Update era))
Lens' (TxBody TopTx era) (StrictMaybe (Update era))
updateTxBodyL)
  where
    ppUpdates :: StrictMaybe (Update era) -> Bool
ppUpdates StrictMaybe (Update era)
SNothing = Bool
False
    ppUpdates (SJust (Update (ProposedPPUpdates Map (KeyHash GenesisRole) (PParamsUpdate era)
ppUpd) EpochNo
_)) = Map (KeyHash GenesisRole) (PParamsUpdate era) -> Int
forall k a. Map k a -> Int
Map.size Map (KeyHash GenesisRole) (PParamsUpdate era)
ppUpd Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0

hasMetadata :: EraTx era => Tx TopTx era -> Bool
hasMetadata :: forall era. EraTx era => Tx TopTx era -> Bool
hasMetadata Tx TopTx era
tx = StrictMaybe TxAuxDataHash -> Bool
forall {a}. StrictMaybe a -> Bool
f (Tx TopTx era
tx Tx TopTx era
-> Getting
     (StrictMaybe TxAuxDataHash)
     (Tx TopTx era)
     (StrictMaybe TxAuxDataHash)
-> StrictMaybe TxAuxDataHash
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx era
 -> Const (StrictMaybe TxAuxDataHash) (TxBody TopTx era))
-> Tx TopTx era -> Const (StrictMaybe TxAuxDataHash) (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era
  -> Const (StrictMaybe TxAuxDataHash) (TxBody TopTx era))
 -> Tx TopTx era
 -> Const (StrictMaybe TxAuxDataHash) (Tx TopTx era))
-> ((StrictMaybe TxAuxDataHash
     -> Const (StrictMaybe TxAuxDataHash) (StrictMaybe TxAuxDataHash))
    -> TxBody TopTx era
    -> Const (StrictMaybe TxAuxDataHash) (TxBody TopTx era))
-> Getting
     (StrictMaybe TxAuxDataHash)
     (Tx TopTx era)
     (StrictMaybe TxAuxDataHash)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe TxAuxDataHash
 -> Const (StrictMaybe TxAuxDataHash) (StrictMaybe TxAuxDataHash))
-> TxBody TopTx era
-> Const (StrictMaybe TxAuxDataHash) (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictMaybe TxAuxDataHash)
forall (l :: TxLevel).
Lens' (TxBody l 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 =
  String -> Property -> TestTree
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> TestTree
TQC.testProperty String
"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 TopTx era -> Integer
numBytes = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer)
-> (Tx TopTx era -> Int) -> Tx TopTx era -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int
BS.length (ByteString -> Int)
-> (Tx TopTx era -> ByteString) -> Tx TopTx era -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx TopTx 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 TopTx era]
          txs :: [Tx TopTx era]
txs = TraceOrder
-> Trace (ShelleyLEDGER era) -> [Signal (ShelleyLEDGER era)]
forall s. TraceOrder -> Trace s -> [Signal s]
traceSignals TraceOrder
OldestFirst Trace (ShelleyLEDGER era)
tr
      (Tx TopTx era -> Bool) -> [Tx TopTx era] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Tx TopTx era
tx -> Tx TopTx era -> Integer
forall era. EraTx era => Tx TopTx era -> Integer
txSizeBound Tx TopTx era
tx Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Tx TopTx era -> Integer
numBytes Tx TopTx era
tx) [Tx TopTx 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 TopTx era -> Integer
numBytes = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer)
-> (Tx TopTx era -> Int) -> Tx TopTx era -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int
BS.length (ByteString -> Int)
-> (Tx TopTx era -> ByteString) -> Tx TopTx era -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx TopTx era -> ByteString
forall a. ToCBOR a => a -> ByteString
Plain.serialize'
      notTooBig :: Tx TopTx era -> Bool
notTooBig Tx TopTx era
tx = Tx TopTx era -> Integer
forall era. EraTx era => Tx TopTx era -> Integer
txSizeBound Tx TopTx 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 TopTx era -> Integer
numBytes Tx TopTx 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 TopTx era]
          txs :: [Tx TopTx era]
txs = TraceOrder
-> Trace (ShelleyLEDGER era) -> [Signal (ShelleyLEDGER era)]
forall s. TraceOrder -> Trace s -> [Signal s]
traceSignals TraceOrder
OldestFirst Trace (ShelleyLEDGER era)
tr
      (Tx TopTx era -> Bool) -> [Tx TopTx era] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Tx TopTx era -> Bool
notTooBig [Tx TopTx 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 =
  String -> Property -> TestTree
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> TestTree
TQC.testProperty String
"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
$
            String -> EpochNo
forall a. HasCallStack => String -> a
error String
"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
blockHeader
        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 TopTx era ->
  Integer
txSizeBound :: forall era. EraTx era => Tx TopTx era -> Integer
txSizeBound Tx TopTx 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
+ Word32 -> Integer
forall a. Integral a => a -> Integer
toInteger Word32
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 TopTx era
txBody = Tx TopTx era
tx Tx TopTx era
-> Getting (TxBody TopTx era) (Tx TopTx era) (TxBody TopTx era)
-> TxBody TopTx era
forall s a. s -> Getting a s a -> a
^. Getting (TxBody TopTx era) (Tx TopTx era) (TxBody TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l 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 TopTx era
txBody TxBody TopTx era
-> Getting (Set TxIn) (TxBody TopTx era) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. Getting (Set TxIn) (TxBody TopTx era) (Set TxIn)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l 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 TopTx era
txBody TxBody TopTx era
-> Getting
     (StrictSeq (TxOut era)) (TxBody TopTx era) (StrictSeq (TxOut era))
-> StrictSeq (TxOut era)
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictSeq (TxOut era)) (TxBody TopTx era) (StrictSeq (TxOut era))
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel). Lens' (TxBody l 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 :: Word32
rest = Tx TopTx era
tx Tx TopTx era -> Getting Word32 (Tx TopTx era) Word32 -> Word32
forall s a. s -> Getting a s a -> a
^. Getting Word32 (Tx TopTx era) Word32
forall era (l :: TxLevel).
(EraTx era, HasCallStack) =>
SimpleGetter (Tx l era) Word32
SimpleGetter (Tx TopTx era) Word32
forall (l :: TxLevel).
HasCallStack =>
SimpleGetter (Tx l era) Word32
sizeTxF