[1352] Re-enable generation of multiple certs per Tx + improve Trace …

…Classifier performance

shelley/chain-and-ledger/executable-spec/test/Test/Shelley/Spec/Ledger/Generator/Constants.hs

@@ -137,7 +137,7 @@ defaultConstants = Constants
   , frequencyTxUpdates = 10
   , minGenesisUTxOouts = 10
   , maxGenesisUTxOouts = 100
-  , maxCertsPerTx = 1
+  , maxCertsPerTx = 3
   , maxTxsPerBlock = 10
   , maxNumKeyPairs = 150
   , minGenesisOutputVal = 1000000

shelley/chain-and-ledger/executable-spec/test/Test/Shelley/Spec/Ledger/Generator/Trace/DCert.hs

@@ -28,7 +28,7 @@ import           Test.QuickCheck (Gen)
 import           Control.State.Transition (BaseM, Embed, Environment, PredicateFailure, STS, Signal,
                      State, TRC (..), TransitionRule, initialRules, judgmentContext, trans,
                      transitionRules, wrapFailed)
-import           Control.State.Transition.Trace (TraceOrder (OldestFirst), traceSignals)
+import           Control.State.Transition.Trace (TraceOrder (OldestFirst), lastState, traceSignals)
 import qualified Control.State.Transition.Trace.Generator.QuickCheck as QC
 import           GHC.Generics (Generic)
 import           Shelley.Spec.Ledger.BaseTypes (Globals, ShelleyBase)
@@ -127,7 +127,7 @@ genDCerts
   -> Natural
   -> Natural
   -> Coin
-  -> Gen (StrictSeq DCert, [CertCred], Coin, Coin)
+  -> Gen (StrictSeq DCert, [CertCred], Coin, Coin, DPState)
 genDCerts
   ge@( GenEnv
          KeySpace_ {ksKeyPairsByHash}
@@ -142,11 +142,12 @@ genDCerts
   let env = (slot, txIx, pparams, reserves)
       st0 = (dpState, 0)
 
-  certsCreds <-
-    catMaybes . traceSignals OldestFirst <$>
+  certsTrace <-
       QC.traceFrom @CERTS testGlobals maxCertsPerTx ge env st0
 
-  let (certs, creds) = unzip certsCreds
+  let certsCreds = catMaybes . traceSignals OldestFirst $ certsTrace
+      (lastState_, _) = lastState certsTrace
+      (certs, creds) = unzip certsCreds
       deRegStakeCreds = filter isDeRegKey certs
       slotWithTTL = slot + SlotNo (fromIntegral ttl)
 
@@ -155,7 +156,8 @@ genDCerts
   pure ( StrictSeq.fromList certs
        , withScriptCreds
        , totalDeposits pparams (_stPools (_pstate dpState)) certs
-       , sum (certRefund slotWithTTL <$> deRegStakeCreds) )
+       , sum (certRefund slotWithTTL <$> deRegStakeCreds)
+       , lastState_)
 
   where
     (dval, dmin, lambda) = decayKey pparams

shelley/chain-and-ledger/executable-spec/test/Test/Shelley/Spec/Ledger/Generator/Utxo.hs

@@ -101,16 +101,16 @@ genTx ge@(GenEnv KeySpace_ { ksCoreNodes
   let slotWithTTL = slot + SlotNo (fromIntegral ttl)
 
   -- certificates
-  (certs, certCreds, deposits_, refunds_)
+  (certs, certCreds, deposits_, refunds_, dpState')
     <- genDCerts ge pparams dpState slot ttl txIx reserves
 
-  if spendingBalance < deposits_
+  let balance_ = spendingBalance - deposits_ + refunds_
+  if balance_ <= 0
     then QC.discard
     else do
 
     -- attempt to make provision for certificate deposits (otherwise discard this generator)
-    let balance_ = spendingBalance - deposits_ + refunds_
-        stakeScripts = Maybe.catMaybes $ map (\case
+    let stakeScripts = Maybe.catMaybes $ map (\case
                                                  ScriptCred c -> Just c
                                                  _            -> Nothing) certCreds
         genesisWitnesses = foldl (++) [] $
@@ -128,7 +128,7 @@ genTx ge@(GenEnv KeySpace_ { ksCoreNodes
 
     --- PParam + AV Updates
     (update, updateWitnesses) <-
-      genUpdate constants slot ksCoreNodes ksKeyPairsByStakeHash pparams (utxoSt, dpState)
+      genUpdate constants slot ksCoreNodes ksKeyPairsByStakeHash pparams (utxoSt, dpState')
 
     -- this is the "model" `TxBody` which is used to calculate the fees
     --

shelley/chain-and-ledger/executable-spec/test/Test/Shelley/Spec/Ledger/PropertyTests.hs

@@ -180,19 +180,15 @@ roundTripAddr =
       keyPair2 <- snd . mkKeyPairs <$> Gen.word64 Range.constantBounded
       pure $ toAddr (keyPair1, keyPair2)
 
-
 minimalPropertyTests :: TestTree
 minimalPropertyTests =
   testGroup "Minimal Property Tests"
-    [ -- TODO @uroboros
-      -- TQC.testProperty "Chain and Ledger traces cover the relevant cases" relevantCasesAreCovered
-      --, TQC.testProperty "total amount of Ada is preserved" preservationOfAda
-      --,
-      TQC.testProperty "Only valid CHAIN STS signals are generated" onlyValidChainSignalsAreGenerated
+    [ TQC.testProperty "Chain and Ledger traces cover the relevant cases" relevantCasesAreCovered
+    , TQC.testProperty "total amount of Ada is preserved" preservationOfAda
+    , TQC.testProperty "Only valid CHAIN STS signals are generated" onlyValidChainSignalsAreGenerated
     , testProperty "Roundtrip Addr serialisation Hedghog" roundTripAddr
     ]
 
-
 -- | 'TestTree' of property-based testing properties.
 propertyTests :: TestTree
 propertyTests = testGroup "Property-Based Testing"

shelley/chain-and-ledger/executable-spec/test/Test/Shelley/Spec/Ledger/Rules/ClassifyTraces.hs

@@ -16,8 +16,8 @@ import           Cardano.Binary (serialize')
 import           Cardano.Slotting.Slot (EpochSize (..))
 import           Control.State.Transition.Trace (TraceOrder (OldestFirst), traceLength,
                      traceSignals)
-import           Control.State.Transition.Trace.Generator.QuickCheck (classifyTraceLength,
-                     forAllTraceFromInitState, onlyValidSignalsAreGeneratedFromInitState)
+import           Control.State.Transition.Trace.Generator.QuickCheck (forAllTraceFromInitState,
+                     onlyValidSignalsAreGeneratedFromInitState, traceFromInitState)
 import qualified Data.ByteString as BS
 import           Data.Foldable (toList)
 import qualified Data.Map.Strict as Map
@@ -36,7 +36,8 @@ import           Shelley.Spec.Ledger.Tx (_body)
 import           Shelley.Spec.Ledger.TxData (pattern Addr, pattern DCertDeleg, pattern DeRegKey,
                      pattern Delegate, pattern Delegation, pattern RegKey, pattern ScriptHashObj,
                      pattern TxOut, Wdrl (..), _certs, _outputs, _txUpdate, _wdrls)
-import           Test.QuickCheck (Property, checkCoverage, conjoin, cover, property, withMaxSuccess)
+import           Test.QuickCheck (Property, checkCoverage, conjoin, cover, forAll, property,
+                     withMaxSuccess)
 import qualified Test.QuickCheck.Gen
 
 import qualified Control.State.Transition.Extended
@@ -73,83 +74,80 @@ genesisLedgerState
 genesisLedgerState = Just $ mkGenesisLedgerState (geConstants genEnv)
 
 relevantCasesAreCovered :: Property
-relevantCasesAreCovered = withMaxSuccess 200 . property $ do
+relevantCasesAreCovered = do
   let tl = 100
       GenEnv _ c@(Constants{maxCertsPerTx}) = genEnv
-  forAllTraceFromInitState @CHAIN testGlobals tl genEnv genesisChainState $ \tr -> do
+
+  forAll (traceFromInitState @CHAIN testGlobals tl genEnv genesisChainState) $ \tr -> do
     let blockTxs (Block _ (TxSeq txSeq)) = toList txSeq
         bs = traceSignals OldestFirst tr
         txs = concat (blockTxs <$> bs)
+        tl' = traceLength tr
         certs_ = allCerts txs
 
-    checkCoverage $ conjoin [
-       classifyTraceLength tl 5 tr
-
-     , cover_ 60
-              (traceLength tr <= 3 * length certs_)
-              "there is at least 1 certificate for every 3 transactions"
-
-     , cover_ 60
-              (traceLength tr <= 10 * length (filter isRegKey certs_))
-              "there is at least 1 RegKey certificate for every 10 transactions"
-
-     , cover_ 60
-              (traceLength tr <= 10 * length (filter isDeRegKey certs_))
-              "there is at least 1 DeRegKey certificate for every 10 transactions"
-
-     , cover_ 60
-              (traceLength tr <= 10 * length (filter isDelegation certs_))
-              "there is at least 1 Delegation certificate for every 10 transactions"
-
-     , cover_ 60
-              (traceLength tr <= 20 * length (filter isGenesisDelegation certs_))
-              "there is at least 1 Genesis Delegation certificate for every 20 transactions"
-
-     , cover_ 60
-              (traceLength tr <= 10 * length (filter isRegPool certs_))
-              "there is at least 1 RegPool certificate for every 10 transactions"
-
-     , cover_ 60
-              (traceLength tr <= 10 * length (filter isRetirePool certs_))
-              "there is at least 1 RetirePool certificate for every 10 transactions"
-
-     , cover_ 60
-              (traceLength tr <= 30 * length (filter isInstantaneousRewards certs_))
-              "there is at least 1 MIR certificate for every 30 transactions"
-
-     , cover_ 60
-              (0.6 >= noCertsRatio (certsByTx txs))
-              "at most 60% of transactions have no certificates"
-
-     , cover_ 60
-              (0.1 <= maxCertsRatio c (certsByTx txs))
-              ("at least 10% of transactions have " <> (show maxCertsPerTx) <> " certificates")
-
-     , cover_ 20
-              (0.1 <= txScriptOutputsRatio (map (_outputs . _body) txs))
-              "at least 10% of transactions have script TxOuts"
-     , cover_ 60
-              (0.1 <= scriptCredentialCertsRatio certs_)
-              "at least 10% of `DCertDeleg` certificates have script credentials"
-     , cover_ 60
-              (0.1 <= withdrawalRatio txs)
-              "at least 10% of transactions have a reward withdrawal"
-
-     , cover_ 60
-              (0.98 >= noPPUpdateRatio (ppUpdatesByTx txs))
-              "at least 2% of transactions have non-trivial protocol param updates"
-
-     , cover_ 60
-              (2 <= epochBoundariesInTrace bs)
-              "at least 2 epoch changes in trace"
-
-     , cover_ 20
-              (5 <= epochBoundariesInTrace bs)
-              "at least 5 epoch changes in trace"
-     ]
-    where
-      cover_ pc b s = cover pc b s (property ())
-
+    property $ conjoin $
+      [
+        checkCoverage $ cover 60
+          (tl' < 1 * length certs_)
+          "there is at least 1 certificate for every 3 transactions"
+          (property ())
+      , checkCoverage $ cover 60
+          (tl' < 10 * length (filter isRegKey certs_))
+          "there is at least 1 RegKey certificate for every 10 transactions"
+          (property ())
+      , checkCoverage $ cover 60
+          (tl' < 10 * length (filter isDeRegKey certs_))
+          "there is at least 1 DeRegKey certificate for every 10 transactions"
+          (property ())
+      , checkCoverage $ cover 60
+          (traceLength tr < 10 * length (filter isDelegation certs_))
+          "there is at least 1 Delegation certificate for every 10 transactions"
+          (property ())
+      , checkCoverage $ cover 60
+          (traceLength tr < 20 * length (filter isGenesisDelegation certs_))
+          "there is at least 1 Genesis Delegation certificate for every 20 transactions"
+          (property ())
+      , checkCoverage $ cover 60
+          (traceLength tr < 10 * length (filter isRetirePool certs_))
+          "there is at least 1 RetirePool certificate for every 10 transactions"
+          (property ())
+      , checkCoverage $ cover 60
+          (traceLength tr < 30 * length (filter isInstantaneousRewards certs_))
+          "there is at least 1 MIR certificate for every 30 transactions"
+          (property ())
+      , checkCoverage $ cover 60
+          (0.6 > noCertsRatio (certsByTx txs))
+          "at most 60% of transactions have no certificates"
+          (property ())
+      , checkCoverage $ cover 60
+          (0.1 < maxCertsRatio c (certsByTx txs))
+          ("at least 10% of transactions have " <> (show maxCertsPerTx) <> " certificates")
+          (property ())
+      , checkCoverage $ cover 60
+          (traceLength tr < 10 * length (filter isRegPool certs_))
+          "there is at least 1 RegPool certificate for every 10 transactions"
+          (property ())
+      , checkCoverage $ cover 20
+          (0.1 < txScriptOutputsRatio (map (_outputs . _body) txs))
+          "at least 10% of transactions have script TxOuts"
+          (property ())
+      , checkCoverage $ cover 60
+          (0.1 < scriptCredentialCertsRatio certs_)
+          "at least 10% of `DCertDeleg` certificates have script credentials"
+          (property ())
+      , checkCoverage $ cover 60
+          (0.1 < withdrawalRatio txs)
+          "at least 10% of transactions have a reward withdrawal"
+          (property ())
+      , checkCoverage $ cover 60
+          (0.98 > noPPUpdateRatio (ppUpdatesByTx txs))
+          "at least 2% of transactions have non-trivial protocol param updates"
+          (property ())
+      , checkCoverage $ cover 40
+          (2 <= epochBoundariesInTrace bs)
+          "at least 2 epoch changes in trace"
+          (property ())
+      ]
 
 -- | Ratio of certificates with script credentials to the number of certificates
 -- that could have script credentials.