|
| 1 | +{-# LANGUAGE DataKinds #-} |
| 2 | +{-# LANGUAGE FlexibleContexts #-} |
| 3 | +{-# LANGUAGE OverloadedStrings #-} |
| 4 | +{-# LANGUAGE RecordWildCards #-} |
| 5 | + |
| 6 | +module Spec.Generated where |
| 7 | + |
| 8 | +import Control.Monad (liftM2, mzero, replicateM) |
| 9 | +import Data.List (inits) |
| 10 | +import Data.Text (Text) |
| 11 | +import LeiosConfig (leiosStageLengthSlots) |
| 12 | +import LeiosEvents |
| 13 | +import LeiosTopology (nodeInfo, nodes, stake, unNodeName) |
| 14 | +import Lib (verifyTrace) |
| 15 | +import Spec.Transition |
| 16 | +import Test.Hspec |
| 17 | +import Test.Hspec.QuickCheck |
| 18 | +import Test.QuickCheck hiding (scale) |
| 19 | + |
| 20 | +import qualified Data.Map.Strict as M |
| 21 | +import qualified Spec.Scenario as Scenario (config, idSut, topology) |
| 22 | + |
| 23 | +verify :: [TraceEvent] -> (Integer, Text) |
| 24 | +verify = |
| 25 | + let |
| 26 | + nrNodes = toInteger . M.size $ nodes Scenario.topology |
| 27 | + nodeNames = unNodeName <$> (M.keys $ nodes Scenario.topology) |
| 28 | + stakes = toInteger . stake . nodeInfo <$> (M.elems $ nodes Scenario.topology) |
| 29 | + stakeDistribution = zip nodeNames stakes |
| 30 | + stageLength' = toInteger $ leiosStageLengthSlots Scenario.config |
| 31 | + in |
| 32 | + verifyTrace nrNodes Scenario.idSut stakeDistribution stageLength' |
| 33 | + |
| 34 | +data Check |
| 35 | + = MustBeOkay |
| 36 | + | MustNotBeOkay |
| 37 | + | MustBe Text |
| 38 | + deriving (Show) |
| 39 | + |
| 40 | +check :: |
| 41 | + Maybe Integer -> |
| 42 | + Check -> |
| 43 | + [TraceEvent] -> |
| 44 | + Property |
| 45 | +check expectedActions expectedMessage events = |
| 46 | + let |
| 47 | + result = verify events |
| 48 | + checkMessage = |
| 49 | + case expectedMessage of |
| 50 | + MustBeOkay -> (=== "ok") |
| 51 | + MustNotBeOkay -> (=/= "ok") |
| 52 | + MustBe expectedMessage' -> (=== expectedMessage') |
| 53 | + in |
| 54 | + case expectedActions of |
| 55 | + Nothing -> checkMessage $ snd result |
| 56 | + Just expectedActions' -> fst result === expectedActions' .&&. checkMessage (snd result) |
| 57 | + |
| 58 | +newtype SkipProduction = SkipProduction {unSkipProduction :: [Transition]} |
| 59 | + deriving (Show) |
| 60 | + |
| 61 | +instance Arbitrary SkipProduction where |
| 62 | + arbitrary = |
| 63 | + do |
| 64 | + let gOdd = (NextSlot :) <$> shuffle [SkipIB, SkipVT] |
| 65 | + gEven = (NextSlot :) <$> shuffle [SkipIB, SkipEB, SkipVT] |
| 66 | + g = liftM2 (<>) gOdd gEven |
| 67 | + n <- choose (1, 25) |
| 68 | + SkipProduction . concat <$> replicateM n g |
| 69 | + shrink = fmap SkipProduction . init . inits . unSkipProduction |
| 70 | + |
| 71 | +newtype SporadicProduction = SporadicProduction {unSporadicProduction :: [Transition]} |
| 72 | + deriving (Show) |
| 73 | + |
| 74 | +instance Arbitrary SporadicProduction where |
| 75 | + arbitrary = |
| 76 | + do |
| 77 | + let gIB = elements [GenerateIB, SkipIB] |
| 78 | + gEB = elements [GenerateEB, SkipEB] |
| 79 | + gVT = elements [GenerateVT, SkipVT] |
| 80 | + gOdd = |
| 81 | + do |
| 82 | + ib <- gIB |
| 83 | + vt <- gVT |
| 84 | + (NextSlot :) <$> shuffle [ib, vt] |
| 85 | + gEven = |
| 86 | + do |
| 87 | + ib <- gIB |
| 88 | + eb <- gEB |
| 89 | + vt <- gVT |
| 90 | + (NextSlot :) <$> shuffle [ib, eb, vt] |
| 91 | + g = liftM2 (<>) gOdd gEven |
| 92 | + n <- choose (1, 25) |
| 93 | + SporadicProduction . concat <$> replicateM n g |
| 94 | + shrink = fmap SporadicProduction . init . inits . unSporadicProduction |
| 95 | + |
| 96 | +newtype NoisyProduction = NoisyProduction {unNoisyProduction :: [Transition]} |
| 97 | + deriving (Show) |
| 98 | + |
| 99 | +instance Arbitrary NoisyProduction where |
| 100 | + arbitrary = |
| 101 | + do |
| 102 | + let gNoise = sublistOf [GenerateRB, ReceiveRB, ReceiveIB, ReceiveEB, ReceiveVT] |
| 103 | + gIB = elements [GenerateIB, SkipIB] |
| 104 | + gEB = elements [GenerateEB, SkipEB] |
| 105 | + gVT = elements [GenerateVT, SkipVT] |
| 106 | + gOdd = |
| 107 | + do |
| 108 | + noise <- gNoise |
| 109 | + ib <- gIB |
| 110 | + vt <- gVT |
| 111 | + (NextSlot :) <$> shuffle ([ib, vt] <> noise) |
| 112 | + gEven = |
| 113 | + do |
| 114 | + noise <- gNoise |
| 115 | + ib <- gIB |
| 116 | + eb <- gEB |
| 117 | + vt <- gVT |
| 118 | + (NextSlot :) <$> shuffle ([ib, eb, vt] <> noise) |
| 119 | + g = liftM2 (<>) gOdd gEven |
| 120 | + n <- choose (1, 25) |
| 121 | + NoisyProduction . concat <$> replicateM n g |
| 122 | + shrink = fmap NoisyProduction . init . inits . unNoisyProduction |
| 123 | + |
| 124 | +newtype SporadicMisses = SporadicMisses {unSporadicMisses :: [Transition]} |
| 125 | + deriving (Show) |
| 126 | + |
| 127 | +instance Arbitrary SporadicMisses where |
| 128 | + arbitrary = |
| 129 | + do |
| 130 | + valid <- unSporadicProduction <$> arbitrary |
| 131 | + i <- choose (1, length valid - 1) |
| 132 | + pure . SporadicMisses $ take i valid <> drop (i + 1) valid <> pure NextSlot |
| 133 | + |
| 134 | +generated :: Spec |
| 135 | +generated = |
| 136 | + do |
| 137 | + let single = (modifyMaxSuccess (const 1) .) . prop |
| 138 | + describe "Positive cases" $ do |
| 139 | + single "Genesis slot" $ |
| 140 | + check mzero MustBeOkay |
| 141 | + <$> transitions [NextSlot] |
| 142 | + single "Generate RB" $ |
| 143 | + check mzero MustBeOkay |
| 144 | + <$> transitions [NextSlot, GenerateRB] |
| 145 | + single "Generate IB" $ |
| 146 | + check mzero MustBeOkay |
| 147 | + <$> transitions [NextSlot, GenerateIB] |
| 148 | + single "Generate no IB" $ |
| 149 | + check mzero MustBeOkay |
| 150 | + <$> transitions [NextSlot, SkipIB] |
| 151 | + single "Generate EB" $ |
| 152 | + check mzero MustBeOkay |
| 153 | + <$> transitions [NextSlot, SkipIB, SkipVT, NextSlot, GenerateEB] |
| 154 | + single "Generate no EB" $ |
| 155 | + check mzero MustBeOkay |
| 156 | + <$> transitions [NextSlot, SkipIB, SkipVT, NextSlot, SkipEB] |
| 157 | + single "Generate VT" $ |
| 158 | + check mzero MustBeOkay |
| 159 | + <$> transitions [NextSlot, GenerateVT] |
| 160 | + single "Generate no VT" $ |
| 161 | + check mzero MustBeOkay |
| 162 | + <$> transitions [NextSlot, SkipVT] |
| 163 | + prop "Skip block production" $ \(SkipProduction actions) -> |
| 164 | + check mzero MustBeOkay <$> transitions actions |
| 165 | + prop "Sporadic block production" $ \(SporadicProduction actions) -> |
| 166 | + check mzero MustBeOkay <$> transitions actions |
| 167 | + prop "Noisy block production" $ \(NoisyProduction actions) -> |
| 168 | + check mzero MustBeOkay <$> transitions actions |
| 169 | + describe "Negative cases" $ do |
| 170 | + single "No actions" $ |
| 171 | + check mzero (MustBe "Invalid Action: Slot Slot-Action 1") |
| 172 | + <$> transitions [NextSlot, NextSlot] |
| 173 | + single "Start after genesis" $ |
| 174 | + check mzero (MustBe "Invalid Action: Slot Base\8322b-Action 1") |
| 175 | + <$> transitions [SkipSlot, NextSlot] |
| 176 | + single "Generate equivocated IBs" $ |
| 177 | + check mzero (MustBe "Invalid Action: Slot IB-Role-Action 1") |
| 178 | + <$> transitions [NextSlot, GenerateIB, GenerateIB] |
| 179 | + single "Generate equivocated EBs" $ |
| 180 | + check mzero (MustBe "Invalid Action: Slot EB-Role-Action 2") |
| 181 | + <$> transitions [NextSlot, SkipIB, SkipVT, NextSlot, GenerateEB, GenerateEB] |
| 182 | + single "Generate equivocated VTs" $ |
| 183 | + check mzero (MustBe "Invalid Action: Slot VT-Role-Action 1") |
| 184 | + <$> transitions [NextSlot, GenerateVT, GenerateVT] |
| 185 | + prop "Sporadic gaps in production" $ \(SporadicMisses actions) -> |
| 186 | + check mzero MustNotBeOkay <$> transitions actions |
0 commit comments