[546] Coverage tests for Chain Traces + refactor Deleg Trace coverage…

… tests

byron/chain/executable-spec/test/Cardano/Spec/Chain/STS/Properties.hs

@@ -1,24 +1,31 @@
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
+
 module Cardano.Spec.Chain.STS.Properties where
 
-import           Control.Lens ((^.), (^..))
+import           Control.Arrow ((***))
+import           Control.Lens (view, (&), (^.), (^..), _1, _5)
 import           Data.Foldable (traverse_)
 import           Data.List.Ordered (nubSortBy)
 import           Data.Ord (Down (Down), comparing)
-import           Hedgehog (MonadTest, Property, assert, failure, forAll, property, withTests, (===))
+
+import           Hedgehog (MonadTest, Property, assert, cover, failure, forAll, property, withTests,
+                           (===))
 
 import           Control.State.Transition
 import           Control.State.Transition.Generator (TraceLength (Maximum), classifyTraceLength,
-                     traceSigGen)
+                                                     traceSigGen)
 import qualified Control.State.Transition.Generator as TransitionGenerator
 import           Control.State.Transition.Trace
 
+import           Ledger.Core (BlockCount (BlockCount), Epoch, Slot (unSlot))
 import           Ledger.Delegation
+import           Ledger.GlobalParams (slotsPerEpoch)
 
 import           Cardano.Spec.Chain.STS.Block
 import           Cardano.Spec.Chain.STS.Rule.Chain
-import           Ledger.Core (BlockCount (BlockCount))
+import           Cardano.Spec.Chain.STS.Rule.Epoch (sEpoch)
 
 slotsIncrease :: Property
 slotsIncrease = property $ do
@@ -72,3 +79,110 @@ signersListIsBoundedByK = property $ do
         signersListIsBoundedByKInState :: MonadTest m => BlockCount -> State CHAIN -> m ()
         signersListIsBoundedByKInState (BlockCount k') (_sLast, sgs, _h, _utxoSt, _ds, _us) =
           assert $ length sgs <= fromIntegral k'
+
+
+relevantCasesAreCovered :: Property
+relevantCasesAreCovered = withTests 400 $ property $ do
+  tr <- forAll $ traceSigGen (Maximum 250) (sigGenChain GenDelegation NoGenUTxO)
+  let certs = traceDCerts tr
+
+  -- for at least 15% of traces...
+  cover 15
+        "there are more certificates than blocks"
+        (traceLength tr <= length certs)
+
+  -- for at least 5% of traces...
+  cover 5
+        "the majority of blocks (at least 75%) have certificates"
+        (emptyDelegationPayloadRatio (traceDCertsByBlock tr) <= 0.25)
+
+  -- for at least 50% of traces...
+  cover 50
+        "some delegations (at least 15%) delegate to this epoch"
+        (0.15 <= thisEpochDelegationsRatio (epochDelegationEpoch tr))
+
+  -- for at least 50% of traces...
+  cover 50
+        "the majority of delegations (at least 50%) delegate to the next epoch"
+        (0.5 <= nextEpochDelegationsRatio (epochDelegationEpoch tr))
+
+  -- for at least 10% of traces...
+  cover 10
+       "not too many certificates (at most 25%) self-delegate"
+       (selfDelegationsRatio certs <= 0.25)
+
+  -- for at least 50% of traces...
+  cover 50
+        "some delegates (at least 25%) have multiple delegators"
+        (0.25 <= multipleDelegationsRatio certs)
+
+  -- for at least 10% of traces...
+  cover 10
+        "some delegates have at least 5 corresponding delegators"
+        (5 <= maxDelegationsTo certs)
+
+  -- for at least 8% of traces...
+  cover 8
+        "not too many delegators (at most 25%) change their delegation"
+        (changedDelegationsRatio certs <= 0.25)
+
+  -- for at least 10% of traces...
+  cover 10
+        "some delegators have changed their delegation 5 or more times"
+        (5 <= maxChangedDelegations certs)
+
+  -- for at least 20% of traces...
+  cover 20
+        "not too many delegations (at most 25%) are repeats"
+        (repeatedDelegationsRatio certs <= 0.25)
+
+  -- for at least 10% of traces...
+  cover 10
+        "some delegations are repeated 10 or more times"
+        (10 <= maxRepeatedDelegations certs)
+
+  -- for at least 10% of traces...
+  cover 10
+        "some blocks have 5 or more certificates"
+        (5 <= maxCertsPerBlock (traceDCertsByBlock tr))
+
+  -- for at least 25% of traces...
+  cover 25
+        "there is at least one change of epoch in the trace"
+        (2 <= epochBoundariesInTrace tr)
+
+  -- for at least 10% of traces...
+  cover 10
+        "there are at least 5 epoch changes in the trace"
+        (5 <= epochBoundariesInTrace tr)
+  where
+   -- Get the epoch in which the delegation certificates of the trace were
+   -- applied, paired with the epoch of the delegation certificate.
+   epochDelegationEpoch :: Trace CHAIN -> [(Epoch, Epoch)]
+   epochDelegationEpoch tr = preStatesAndSignals @CHAIN OldestFirst tr
+                           & fmap (sEpoch_ . view _1 *** (fmap depoch . (_bDCerts . _bBody)))
+                           & fmap (\(e, es) -> zip (repeat e) es)
+                           & concat
+                           where
+                             blockCount = _traceEnv tr ^. _5
+                             sEpoch_ = flip sEpoch blockCount
+
+   -- Count the number of epoch boundaries in the trace
+   epochBoundariesInTrace :: Trace CHAIN -> Int
+   epochBoundariesInTrace tr
+     = length $
+         filter (== 0) (isAtBoundary <$> slots)
+     where blocks = traceSignals NewestFirst tr
+           slots = blocks ^.. traverse . bHeader . bhSlot
+           k = _traceEnv tr ^. _5
+           isAtBoundary = (`rem` slotsPerEpoch k) . unSlot
+
+-- | Extract the delegation certificates in the blocks, in the order they would
+-- have been applied.
+traceDCertsByBlock :: Trace CHAIN -> [[DCert]]
+traceDCertsByBlock tr = _bDCerts . _bBody <$> traceSignals OldestFirst tr
+
+-- | Flattended list of DCerts for the given Trace
+traceDCerts :: Trace CHAIN -> [DCert]
+traceDCerts = concat . traceDCertsByBlock
+

byron/chain/executable-spec/test/Main.hs

@@ -19,5 +19,6 @@ main = defaultMain tests
       , testAbstractSize
       , testProperty "Only valid signals are generated" CHAIN.onlyValidSignalsAreGenerated
       , testProperty "Signers list is bounded by k " CHAIN.signersListIsBoundedByK
+      , testProperty "We are generating reasonable Chain Traces" CHAIN.relevantCasesAreCovered
       ]
     ]

byron/ledger/executable-spec/cs-ledger.cabal

@@ -41,6 +41,7 @@ library
                      , hashable
                      , hedgehog >= 1.0
                      , lens
+                     , Unique >= 0.4.7.6
                      -- Local deps
                      , small-steps
   default-language:    Haskell2010

byron/ledger/executable-spec/src/Ledger/Delegation.hs

@@ -62,6 +62,19 @@ module Ledger.Delegation
   , initialEnvFromGenesisKeys
   -- * Functions on delegation state
   , delegatorOf
+  -- * Support Functions for delegation properties
+  , delegatorDelegate
+  , emptyDelegationPayloadRatio
+  , thisEpochDelegationsRatio
+  , nextEpochDelegationsRatio
+  , selfDelegationsRatio
+  , multipleDelegationsRatio
+  , maxDelegationsTo
+  , changedDelegationsRatio
+  , maxChangedDelegations
+  , repeatedDelegationsRatio
+  , maxRepeatedDelegations
+  , maxCertsPerBlock
   )
 where
 
@@ -73,6 +86,7 @@ import qualified Data.Bimap as Bimap
 import           Data.Hashable (Hashable)
 import qualified Data.Hashable as H
 import qualified Data.List as List
+import           Data.List.Unique (count)
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import           Data.Maybe (catMaybes)
@@ -86,14 +100,14 @@ import           Hedgehog.Range (linear)
 
 
 import           Control.State.Transition (Embed, Environment, IRC (IRC), PredicateFailure, STS,
-                     Signal, State, TRC (TRC), initialRules, judgmentContext, trans,
-                     transitionRules, wrapFailed, (?!))
+                                           Signal, State, TRC (TRC), initialRules, judgmentContext,
+                                           trans, transitionRules, wrapFailed, (?!))
 import           Control.State.Transition.Generator (HasTrace, envGen, genTrace, sigGen)
 import           Control.State.Transition.Trace (TraceOrder (OldestFirst), traceSignals)
 import           Ledger.Core (BlockCount, Epoch, HasHash, Hash (Hash), Owner (Owner), Sig,
-                     Slot (Slot), SlotCount (SlotCount), VKey (VKey), VKeyGenesis (VKeyGenesis),
-                     addSlot, hash, mkVkGenesisSet, range, signWithGenesisKey, unBlockCount, (∈),
-                     (∉), (⨃))
+                              Slot (Slot), SlotCount (SlotCount), VKey (VKey),
+                              VKeyGenesis (VKeyGenesis), addSlot, hash, mkVkGenesisSet, owner,
+                              range, signWithGenesisKey, unBlockCount, (∈), (∉), (⨃))
 import           Ledger.Core.Generators (epochGen, slotGen)
 import qualified Ledger.Core.Generators as CoreGen
 
@@ -575,3 +589,124 @@ initialEnvFromGenesisKeys ngk chainLength =
     <*> epochGen 0 10
     <*> slotGen 0 100
     <*> CoreGen.k chainLength (chainLength `div` 10)
+
+--------------------------------------------------------------------------------
+-- Shared support functions for Delegation Properties
+--------------------------------------------------------------------------------
+
+delegatorDelegate :: DCert -> (VKeyGenesis, VKey)
+delegatorDelegate = delegator &&& delegate
+
+ratioInt :: Int -> Int -> Double
+ratioInt x y
+  = fromIntegral x / fromIntegral y
+
+-- | Filters the list with the predicate and returns
+-- the ratio of filtered to original list lengths.
+lenRatio :: ([a] -> [b]) -> [a] -> Double
+lenRatio p xs
+  = ratioInt (length (p xs))
+             (length xs)
+
+maxInt :: [Int] -> Int
+maxInt [] = 0
+maxInt xs = List.maximum xs
+
+-- | True if the tuple count (snd item) is >= 2
+multiple :: (a,Int) -> Bool
+multiple = (2 <=) . snd
+
+-- | Count the number of delegates in the given certificates
+delegateCounts :: [DCert] -> [(VKey, Int)]
+delegateCounts certs
+  = fmap delegatorDelegate certs
+    -- Remove duplicated elements, since we're not
+    -- interested in repeated delegations
+    & List.nub
+    -- Select the (unique) delegates
+    & fmap snd
+    -- If we have more than one occurrence of a delegate,
+    -- then we know that there were multiple delegations
+    -- to that delegate
+    & count
+
+-- | Count the number of delegators in the given certificates
+delegatorCounts :: [DCert] -> [(VKeyGenesis, Int)]
+delegatorCounts dcerts
+  = fmap delegatorDelegate dcerts
+    -- Remove duplicated elements, since we're not
+    -- interested in repeated delegations
+    & List.nub
+    -- Select the (unique) delegators
+    & fmap fst
+    -- If we have more than one occurrence of a delegator,
+    -- then we know that the delegator changed their delegation
+    & count
+
+-- | Ratio of certificate groups that are empty
+emptyDelegationPayloadRatio :: [[DCert]] -> Double
+emptyDelegationPayloadRatio
+  = lenRatio (filter null)
+
+-- | Ratio of certificates that delegate to _this_ epoch, where
+--   each certificate is represented by (current epoch,cert epoch)
+thisEpochDelegationsRatio :: [(Epoch, Epoch)] -> Double
+thisEpochDelegationsRatio
+  = lenRatio (filter thisEpoch)
+  where
+    thisEpoch = uncurry (==)
+
+-- | Ratio of certificates that delegate to the _next_ epoch, where
+--   each certificate is represented by (current epoch,cert epoch)
+nextEpochDelegationsRatio :: [(Epoch, Epoch)] -> Double
+nextEpochDelegationsRatio
+  = lenRatio (filter nextEpoch)
+  where
+    nextEpoch (e0, e1) = e0 + 1 == e1
+
+-- | Ratio of certificates that "delegate to self", that is,
+-- where the delegator and delegate are the same
+selfDelegationsRatio :: [DCert] -> Double
+selfDelegationsRatio
+  = lenRatio (filter selfDeleg . fmap delegatorDelegate)
+  where
+    selfDeleg (vks, vk) = owner vks == owner vk
+
+-- | Ratio of delegates that have multiple delegators
+-- that are delegating to them
+multipleDelegationsRatio :: [DCert] -> Double
+multipleDelegationsRatio dcerts
+  = lenRatio (filter multiple) (delegateCounts dcerts)
+
+-- | The maximum number of delegators to any particular delegate
+maxDelegationsTo :: [DCert] -> Int
+maxDelegationsTo dcerts
+  =  maxInt (snd <$> filter multiple (delegateCounts dcerts))
+
+-- | Ratio of delegators that have changed their delegations
+changedDelegationsRatio :: [DCert] -> Double
+changedDelegationsRatio dcerts
+  = lenRatio (filter multiple) (delegatorCounts dcerts)
+
+-- | The maximum number of change-of-delegate for any particular delegator
+maxChangedDelegations :: [DCert] -> Int
+maxChangedDelegations dcerts
+  = maxInt (snd <$> filter multiple (delegateCounts dcerts))
+
+-- | Ratio of repeated delegations to all delegations
+repeatedDelegationsRatio :: [DCert] -> Double
+repeatedDelegationsRatio dcerts
+  = fmap delegatorDelegate dcerts
+  & count
+  & lenRatio (filter multiple)
+
+-- | The maximum number of repeated delegations in the given certificates
+maxRepeatedDelegations :: [DCert] -> Int
+maxRepeatedDelegations dcerts
+  = maxInt (snd <$> filter multiple ds)
+  where
+    ds = count (fmap delegatorDelegate dcerts)
+
+maxCertsPerBlock :: [[DCert]] -> Int
+maxCertsPerBlock groupedCerts
+  = maxInt (map length groupedCerts)