{-# 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.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
  , ChainProperty era
  , QC.HasTrace (CHAIN era) (GenEnv era)
  ) =>
  Int ->
  TestTree
relevantCasesAreCovered :: forall era.
(EraGen era, ChainProperty era,
 HasTrace (CHAIN era) (GenEnv era)) =>
Int -> TestTree
relevantCasesAreCovered Int
n =
  forall a. Testable a => TestName -> a -> TestTree
TQC.testProperty
    TestName
"Chain and Ledger traces cover the relevant cases"
    (forall prop. Testable prop => Int -> prop -> Property
TQC.withMaxSuccess Int
n Property
prop)
  where
    prop :: Property
prop = do
      let tl :: Word64
tl = Word64
100
      forall prop. Testable prop => Confidence -> prop -> Property
checkCoverageWith Confidence
stdConfidence {certainty :: Integer
certainty = Integer
1_000_000} forall a b. (a -> b) -> a -> b
$
        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
testGlobals Word64
tl (forall era. EraGen era => Proxy era -> Constants -> GenEnv era
genEnv Proxy era
p Constants
defaultConstants) Maybe
  (IRC (CHAIN era)
   -> Gen
        (Either
           (NonEmpty (TestChainPredicateFailure era)) (ChainState era)))
genesisChainSt)
          forall era.
(ChainProperty era, EraSegWits era, ShelleyEraTxBody era) =>
Trace (CHAIN era) -> Property
relevantCasesAreCoveredForTrace
    p :: Proxy era
    p :: Proxy era
p = forall {k} (t :: k). Proxy t
Proxy
    genesisChainSt :: Maybe
  (IRC (CHAIN era)
   -> Gen
        (Either
           (NonEmpty (TestChainPredicateFailure era)) (ChainState era)))
genesisChainSt = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall era a.
(EraGen era, EraGov era) =>
GenEnv era -> IRC (CHAIN era) -> Gen (Either a (ChainState era))
mkGenesisChainState (forall era. EraGen era => Proxy era -> Constants -> GenEnv era
genEnv Proxy era
p Constants
defaultConstants)

relevantCasesAreCoveredForTrace ::
  forall era.
  ( ChainProperty era
  , EraSegWits era
  , ShelleyEraTxBody era
  ) =>
  Trace (CHAIN era) ->
  Property
relevantCasesAreCoveredForTrace :: forall era.
(ChainProperty era, EraSegWits 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 (UnserialisedBlock BHeader MockCrypto
_ TxSeq era
txSeq) = 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 = forall s. TraceOrder -> Trace s -> [Signal s]
traceSignals TraceOrder
OldestFirst Trace (CHAIN era)
tr
      txs :: [Tx era]
txs = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Block (BHeader MockCrypto) era -> [Tx era]
blockTxs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [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_ = 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"
          , forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx era]
txs forall a. Ord a => a -> a -> Bool
< Int
2 forall a. Num a => a -> a -> a
* 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"
          , forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx era]
txs forall a. Ord a => a -> a -> Bool
< Int
10 forall a. Num a => a -> a -> a
* forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. (a -> Bool) -> [a] -> [a]
filter 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"
          , forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx era]
txs forall a. Ord a => a -> a -> Bool
< Int
20 forall a. Num a => a -> a -> a
* forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. (a -> Bool) -> [a] -> [a]
filter 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"
          , forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx era]
txs forall a. Ord a => a -> a -> Bool
< Int
10 forall a. Num a => a -> a -> a
* forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. (a -> Bool) -> [a] -> [a]
filter 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"
          , forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx era]
txs forall a. Ord a => a -> a -> Bool
< Int
20 forall a. Num a => a -> a -> a
* forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. (a -> Bool) -> [a] -> [a]
filter 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"
          , forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx era]
txs forall a. Ord a => a -> a -> Bool
< Int
10 forall a. Num a => a -> a -> a
* forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. (a -> Bool) -> [a] -> [a]
filter 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"
          , forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx era]
txs forall a. Ord a => a -> a -> Bool
< Int
60 forall a. Num a => a -> a -> a
* forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. (a -> Bool) -> [a] -> [a]
filter 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"
          , forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx era]
txs forall a. Ord a => a -> a -> Bool
< Int
60 forall a. Num a => a -> a -> a
* forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. (a -> Bool) -> [a] -> [a]
filter 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"
          , forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx era]
txs forall a. Ord a => a -> a -> Bool
< Int
10 forall a. Num a => a -> a -> a
* forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. (a -> Bool) -> [a] -> [a]
filter forall era. EraTxCert era => TxCert era -> Bool
isRegPool [TxCert era]
certs_)
          , Double
60
          )
        ,
          ( TestName
"at least 10% of TxOuts are scripts"
          , Double
0.1 forall a. Ord a => a -> a -> Bool
< forall era. EraTxOut era => [StrictSeq (TxOut era)] -> Double
txScriptOutputsRatio (forall a s. Getting a s a -> s -> a
view forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. Getting a s a -> s -> a
view forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL 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 forall a. Ord a => a -> a -> Bool
< forall c. ShelleyEraTxCert c => [TxCert c] -> Double
scriptCredentialCertsRatio [TxCert era]
certs_
          , Double
60
          )
        ,
          ( TestName
"at least 1 in 10 transactions have a reward withdrawal"
          , forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx era]
txs forall a. Ord a => a -> a -> Bool
< Int
10 forall a. Num a => a -> a -> a
* forall (t :: * -> *) a. Foldable t => t a -> Int
length (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"
          , forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx era]
txs forall a. Ord a => a -> a -> Bool
< Int
20 forall a. Num a => a -> a -> a
* forall (t :: * -> *) a. Foldable t => t a -> Int
length (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"
          , forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx era]
txs forall a. Ord a => a -> a -> Bool
< Int
20 forall a. Num a => a -> a -> a
* forall (t :: * -> *) a. Foldable t => t a -> Int
length (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 forall a. Ord a => a -> a -> Bool
<= forall era. [Block (BHeader MockCrypto) era] -> Int
epochsInTrace [Signal (CHAIN era)]
bs
          , Double
20
          )
        ]

  forall prop. Testable prop => [prop] -> Property
conjoin forall a b. (a -> b) -> a -> b
$ (TestName, Bool, Double) -> Property
cover_ 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) =
      forall prop.
Testable prop =>
Double -> Bool -> TestName -> prop -> Property
cover Double
coveragePc Bool
predicate TestName
label (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 =
      forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$
        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 =
      forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$
        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 = forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. Getting a s a -> s -> a
view forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. Getting a s a -> s -> a
view forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL 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 =
  forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x forall a. Fractional a => a -> a -> a
/ 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
    (forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall a b. (a -> b) -> [a] -> [b]
map StrictSeq (TxOut era) -> Int
countScriptOuts [StrictSeq (TxOut era)]
txoutsList))
    (forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall a b. (a -> b) -> [a] -> [b]
map 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 StrictSeq (TxOut era)
txouts =
      forall a. Sum a -> a
getSum forall a b. (a -> b) -> a -> b
$
        forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap'
          ( \TxOut era
out -> case TxOut era
out forall s a. s -> Getting a s a -> a
^. forall era. EraTxOut era => Lens' (TxOut era) Addr
addrTxOutL of
              Addr Network
_ (ScriptHashObj ScriptHash
_) StakeReference
_ -> forall a. a -> Sum a
Sum Int
1
              Addr
_ -> forall a. a -> Sum a
Sum Int
0
          )
          StrictSeq (TxOut era)
txouts

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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ Withdrawals -> Map RewardAccount Coin
unWithdrawals (Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraTxBody era => 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 = forall {era}. StrictMaybe (Update era) -> Bool
ppUpdates (Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ShelleyEraTxBody era =>
Lens' (TxBody era) (StrictMaybe (Update era))
updateTxBodyL)
  where
    ppUpdates :: StrictMaybe (Update era) -> Bool
ppUpdates StrictMaybe (Update era)
SNothing = Bool
False
    ppUpdates (SJust (Update (ProposedPPUpdates Map (KeyHash 'Genesis) (PParamsUpdate era)
ppUpd) EpochNo
_)) = forall k a. Map k a -> Int
Map.size Map (KeyHash 'Genesis) (PParamsUpdate era)
ppUpd 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 = forall {a}. StrictMaybe a -> Bool
f (Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
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
  , QC.HasTrace ledger (GenEnv era)
  , QC.BaseEnv ledger ~ Globals
  , State ledger ~ LedgerState era
  , Show (Environment ledger)
  , Show (Signal ledger)
  , EraGov era
  ) =>
  TestTree
onlyValidLedgerSignalsAreGenerated :: forall era ledger.
(EraGen era, HasTrace ledger (GenEnv era),
 BaseEnv ledger ~ Globals, State ledger ~ LedgerState era,
 Show (Environment ledger), Show (Signal ledger), EraGov era) =>
TestTree
onlyValidLedgerSignalsAreGenerated =
  forall a. Testable a => TestName -> a -> TestTree
TQC.testProperty TestName
"Only valid Ledger STS signals are generated" Property
prop
  where
    prop :: Property
prop =
      forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
200 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
testGlobals
          Word64
100
          GenEnv era
ge
          Maybe
  (IRC ledger
   -> Gen
        (Either (NonEmpty (PredicateFailure ledger)) (LedgerState era)))
genesisLedgerSt
    p :: Proxy era
    p :: Proxy era
p = forall {k} (t :: k). Proxy t
Proxy
    ge :: GenEnv era
ge = forall era. EraGen era => Proxy era -> Constants -> GenEnv era
genEnv Proxy era
p Constants
defaultConstants
    genesisLedgerSt :: Maybe
  (IRC ledger
   -> Gen
        (Either (NonEmpty (PredicateFailure ledger)) (LedgerState era)))
genesisLedgerSt = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a era ledger.
(EraGen era, EraGov era) =>
GenEnv era -> IRC ledger -> Gen (Either a (LedgerState era))
mkGenesisLedgerState GenEnv era
ge

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

onlyValidChainSignalsAreGenerated ::
  forall era.
  ( EraGen era
  , QC.HasTrace (CHAIN era) (GenEnv era)
  , EraGov era
  ) =>
  TestTree
onlyValidChainSignalsAreGenerated :: forall era.
(EraGen era, HasTrace (CHAIN era) (GenEnv era), EraGov era) =>
TestTree
onlyValidChainSignalsAreGenerated =
  forall a. Testable a => TestName -> a -> TestTree
TQC.testProperty TestName
"Only valid CHAIN STS signals are generated" Property
prop
  where
    prop :: Property
prop =
      forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
100 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
testGlobals
          Word64
100
          (forall era. EraGen era => Proxy era -> Constants -> GenEnv era
genEnv Proxy era
p Constants
defaultConstants)
          Maybe
  (IRC (CHAIN era)
   -> Gen
        (Either
           (NonEmpty (TestChainPredicateFailure era)) (ChainState era)))
genesisChainSt
    p :: Proxy era
    p :: Proxy era
p = forall {k} (t :: k). Proxy t
Proxy
    genesisChainSt :: Maybe
  (IRC (CHAIN era)
   -> Gen
        (Either
           (NonEmpty (TestChainPredicateFailure era)) (ChainState era)))
genesisChainSt = forall a. a -> Maybe a
Just (forall era a.
(EraGen era, EraGov era) =>
GenEnv era -> IRC (CHAIN era) -> Gen (Either a (ChainState era))
mkGenesisChainState (forall era. EraGen era => Proxy era -> Constants -> GenEnv era
genEnv 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 <- forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [Block (BHeader MockCrypto) era]
bs' =
      let
        fromEpoch :: Word64
fromEpoch = SlotNo -> Word64
atEpoch forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {era}. Block (BHeader MockCrypto) era -> SlotNo
blockSlot forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> a
NE.head NonEmpty (Block (BHeader MockCrypto) era)
bs
        toEpoch :: Word64
toEpoch = SlotNo -> Word64
atEpoch forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {era}. Block (BHeader MockCrypto) era -> SlotNo
blockSlot forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> a
NE.last NonEmpty (Block (BHeader MockCrypto) era)
bs
        EpochSize Word64
slotsPerEpoch =
          HasCallStack => EpochInfo Identity -> EpochNo -> EpochSize
epochInfoSize (Globals -> EpochInfo Identity
epochInfoPure Globals
testGlobals) forall a b. (a -> b) -> a -> b
$
            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 = forall c. BHBody c -> SlotNo
bheaderSlotNo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. Crypto c => BHeader c -> BHBody c
bhbody forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall h era. Block h era -> h
bheader
        atEpoch :: SlotNo -> Word64
atEpoch (SlotNo Word64
s) = Word64
s forall a. Integral a => a -> a -> a
`div` Word64
slotsPerEpoch
       in
        forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Word64
toEpoch forall a. Num a => a -> a -> a
- Word64
fromEpoch 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 forall a. Num a => a -> a -> a
* Integer
inputSize forall a. Num a => a -> a -> a
+ Integer
numOutputs forall a. Num a => a -> a -> a
* Integer
outputSize 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 forall a. Num a => a -> a -> a
+ Integer
hashLen
    addrHashLen :: Integer
addrHashLen = Integer
28
    addrHeader :: Integer
addrHeader = Integer
1
    address :: Integer
address = Integer
2 forall a. Num a => a -> a -> a
+ Integer
addrHeader forall a. Num a => a -> a -> a
+ Integer
2 forall a. Num a => a -> a -> a
* Integer
addrHashLen
    txBody :: TxBody era
txBody = Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL
    numInputs :: Integer
numInputs = forall a. Integral a => a -> Integer
toInteger forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
inputsTxBodyL
    inputSize :: Integer
inputSize = Integer
smallArray forall a. Num a => a -> a -> a
+ Integer
uint forall a. Num a => a -> a -> a
+ Integer
hashObj
    numOutputs :: Integer
numOutputs = forall a. Integral a => a -> Integer
toInteger forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL
    outputSize :: Integer
outputSize = Integer
smallArray forall a. Num a => a -> a -> a
+ Integer
uint forall a. Num a => a -> a -> a
+ Integer
address
    rest :: Integer
rest = Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => SimpleGetter (Tx era) Integer
sizeTxF