From a15fcc567c2206f2c2213e5563a909f97bed9dd8 Mon Sep 17 00:00:00 2001 From: Arnaud Bailly Date: Mon, 28 Oct 2024 14:09:47 +0100 Subject: [PATCH 01/11] Provide first integrated tools and tests for header validation * Provide base generator and mutations for headers, covering some parts related to KES header signature * Extract testable method from Protocol.Praos module * Add a property testing the consistency of validation logic with both valid and mutated headers * Add a command-line tool to generate JSON-formatted test vectors and validate them --- .../app/GenHeader/Parsers.hs | 46 ++ ouroboros-consensus-cardano/app/gen-header.hs | 12 + .../ouroboros-consensus-cardano.cabal | 27 +- .../Cardano/Tools/Headers.hs | 86 ++++ .../test/tools-test/Main.hs | 2 + .../tools-test/Test/Cardano/Tools/Headers.hs | 50 ++ .../ouroboros-consensus-protocol.cabal | 12 +- .../Ouroboros/Consensus/Protocol/Praos.hs | 46 +- .../Consensus/Protocol/Praos/Header.hs | 455 ++++++++++++++++++ 9 files changed, 725 insertions(+), 11 deletions(-) create mode 100644 ouroboros-consensus-cardano/app/GenHeader/Parsers.hs create mode 100644 ouroboros-consensus-cardano/app/gen-header.hs create mode 100644 ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/Headers.hs create mode 100644 ouroboros-consensus-cardano/test/tools-test/Test/Cardano/Tools/Headers.hs create mode 100644 ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs diff --git a/ouroboros-consensus-cardano/app/GenHeader/Parsers.hs b/ouroboros-consensus-cardano/app/GenHeader/Parsers.hs new file mode 100644 index 0000000000..e415ff96de --- /dev/null +++ b/ouroboros-consensus-cardano/app/GenHeader/Parsers.hs @@ -0,0 +1,46 @@ +module GenHeader.Parsers where + +import Cardano.Tools.Headers (Options (..)) +import Data.Version (showVersion) +import Options.Applicative (Parser, ParserInfo, auto, command, + execParser, help, helper, hsubparser, info, long, metavar, + option, progDesc, short, (<**>)) +import Paths_ouroboros_consensus_cardano (version) + +parseOptions :: IO Options +parseOptions = execParser argsParser + +argsParser :: ParserInfo Options +argsParser = + info + (optionsParser <**> helper) + ( progDesc $ + unlines + [ "gen-header - A utility to generate valid and invalid Praos headers for testing purpose" + , "version: " <> showVersion version + ] + ) + +optionsParser :: Parser Options +optionsParser = + hsubparser + ( command "generate" (info generateOptionsParser (progDesc "Generate Praos headers context and valid/invalid headers. Writes JSON formatted context to stdout and headers to stdout.")) + <> command "validate" (info validateOptionsParser (progDesc "Validate a sample of Praos headers within a context. Reads JSON formatted sample from stdin.")) + ) + +validateOptionsParser :: Parser Options +validateOptionsParser = pure Validate + +generateOptionsParser :: Parser Options +generateOptionsParser = + Generate <$> countParser + +countParser :: Parser Int +countParser = + option + auto + ( long "count" + <> short 'c' + <> metavar "INT" + <> help "Number of headers to generate" + ) diff --git a/ouroboros-consensus-cardano/app/gen-header.hs b/ouroboros-consensus-cardano/app/gen-header.hs new file mode 100644 index 0000000000..2a2ea76cae --- /dev/null +++ b/ouroboros-consensus-cardano/app/gen-header.hs @@ -0,0 +1,12 @@ +-- | This tool generates valid and invalid Cardano headers. +module Main (main) where + +import Cardano.Crypto.Init (cryptoInit) +import Cardano.Tools.Headers (run) +import GenHeader.Parsers (parseOptions) +import Main.Utf8 (withUtf8) + +main :: IO () +main = withUtf8 $ do + cryptoInit + parseOptions >>= run diff --git a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal index 89998def89..9991ca8654 100644 --- a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal +++ b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal @@ -356,7 +356,7 @@ test-suite shelley-test ouroboros-consensus:{ouroboros-consensus, unstable-consensus-testlib}, ouroboros-consensus-cardano, ouroboros-consensus-diffusion:unstable-diffusion-testlib, - ouroboros-consensus-protocol, + ouroboros-consensus-protocol:ouroboros-consensus-protocol, sop-core, strict-sop-core, tasty, @@ -497,6 +497,7 @@ library unstable-cardano-tools Cardano.Tools.DBTruncater.Run Cardano.Tools.DBTruncater.Types Cardano.Tools.GitRev + Cardano.Tools.Headers Cardano.Tools.ImmDBServer.Diffusion Cardano.Tools.ImmDBServer.MiniProtocols @@ -553,6 +554,7 @@ library unstable-cardano-tools ouroboros-consensus-cardano, ouroboros-consensus-diffusion ^>=0.18, ouroboros-consensus-protocol ^>=0.9, + ouroboros-consensus-protocol:unstable-protocol-testlib, ouroboros-network, ouroboros-network-api, ouroboros-network-framework ^>=0.14, @@ -662,9 +664,30 @@ test-suite tools-test hs-source-dirs: test/tools-test main-is: Main.hs build-depends: + aeson, base, ouroboros-consensus:{ouroboros-consensus, unstable-consensus-testlib}, - ouroboros-consensus-cardano, + ouroboros-consensus-cardano:{ouroboros-consensus-cardano,unstable-cardano-tools}, + ouroboros-consensus-protocol:unstable-protocol-testlib, + QuickCheck, tasty, tasty-hunit, + tasty-quickcheck, + text, unstable-cardano-tools, + other-modules: + Test.Cardano.Tools.Headers + +executable gen-header + import: common-exe + hs-source-dirs: app + main-is: gen-header.hs + build-depends: + base, + cardano-crypto-class, + optparse-applicative, + ouroboros-consensus-cardano:unstable-cardano-tools, + with-utf8, + other-modules: + GenHeader.Parsers + Paths_ouroboros_consensus_cardano diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/Headers.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/Headers.hs new file mode 100644 index 0000000000..888f70e88f --- /dev/null +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/Headers.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-missing-export-lists #-} + +-- | Tooling to generate and validate (Praos) headers. +module Cardano.Tools.Headers where + +import Cardano.Crypto.DSIGN (deriveVerKeyDSIGN) +import Cardano.Crypto.Hash (Blake2b_256, hashToBytes) +import Cardano.Crypto.VRF + (VRFAlgorithm (deriveVerKeyVRF, hashVerKeyVRF)) +import Cardano.Ledger.Api (ConwayEra, StandardCrypto, VRF) +import Cardano.Ledger.BaseTypes (BoundedRational (boundRational), + PositiveUnitInterval, mkActiveSlotCoeff) +import Cardano.Ledger.Coin (Coin (..)) +import Cardano.Ledger.Compactible (toCompact) +import Cardano.Ledger.Keys (VKey (..), hashKey) +import Cardano.Ledger.PoolDistr (IndividualPoolStake (..)) +import Cardano.Prelude (ExitCode (..), exitWith, forM_, hPutStrLn, + stderr) +import Control.Monad.Except (runExcept) +import qualified Data.Aeson as Json +import qualified Data.ByteString.Base16 as Hex +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Map as Map +import Data.Maybe (fromJust) +import Data.Text (unpack) +import Data.Text.Encoding (decodeUtf8) +import Debug.Trace (trace) +import Ouroboros.Consensus.Block (validateView) +import Ouroboros.Consensus.Protocol.Praos (Praos, + doValidateKESSignature, doValidateVRFSignature) +import qualified Ouroboros.Consensus.Protocol.Praos.Views as Views +import Ouroboros.Consensus.Shelley.HFEras () +import Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock, + mkShelleyHeader) +import Ouroboros.Consensus.Shelley.Protocol.Praos () +import Test.Ouroboros.Consensus.Protocol.Praos.Header + (GeneratorContext (..), MutatedHeader (..), Mutation (..), + Sample (..), expectedError, generateSamples, header, + mutation) + +type ConwayBlock = ShelleyBlock (Praos StandardCrypto) (ConwayEra StandardCrypto) + +-- * Running Generator +data Options + = Generate Int + | Validate + +run :: Options -> IO () +run = \case + Generate n -> do + sample <- generateSamples n + LBS.putStr $ Json.encode sample <> "\n" + Validate -> + Json.eitherDecode <$> LBS.getContents >>= \case + Left err -> hPutStrLn stderr err >> exitWith (ExitFailure 1) + Right Sample{sample} -> + forM_ sample $ \(context, mutatedHeader) -> do + print $ validate context mutatedHeader + +data ValidationResult = Valid !Mutation | Invalid !Mutation !String + deriving (Eq, Show) + +validate :: GeneratorContext -> MutatedHeader -> ValidationResult +validate context MutatedHeader{header, mutation} = + case (runExcept $ validateKES >> validateVRF, mutation) of + (Left err, mut) | expectedError mut err -> Valid mut + (Left err, mut) -> Invalid mut (show err) + (Right _, NoMutation) -> Valid NoMutation + (Right _, mut) -> Invalid mut $ "Expected error from mutation " <> show mut <> ", but validation succeeded" + where + GeneratorContext{praosSlotsPerKESPeriod, nonce, coldSignKey, vrfSignKey, ocertCounters, activeSlotCoeff} = context + -- TODO: get these from the context + maxKESEvo = 62 + coin = fromJust . toCompact . Coin + ownsAllStake vrfKey = IndividualPoolStake 1 (coin 1) vrfKey + poolDistr = Map.fromList [(poolId, ownsAllStake hashVRFKey)] + poolId = hashKey $ VKey $ deriveVerKeyDSIGN coldSignKey + hashVRFKey = hashVerKeyVRF $ deriveVerKeyVRF vrfSignKey + + headerView = validateView @ConwayBlock undefined (mkShelleyHeader header) + validateKES = doValidateKESSignature maxKESEvo praosSlotsPerKESPeriod poolDistr ocertCounters headerView + validateVRF = doValidateVRFSignature nonce poolDistr activeSlotCoeff headerView diff --git a/ouroboros-consensus-cardano/test/tools-test/Main.hs b/ouroboros-consensus-cardano/test/tools-test/Main.hs index 66e59c3d5d..0ff98843e6 100644 --- a/ouroboros-consensus-cardano/test/tools-test/Main.hs +++ b/ouroboros-consensus-cardano/test/tools-test/Main.hs @@ -8,6 +8,7 @@ import qualified Cardano.Tools.DBSynthesizer.Run as DBSynthesizer import Cardano.Tools.DBSynthesizer.Types import Ouroboros.Consensus.Block import Ouroboros.Consensus.Cardano.Block +import qualified Test.Cardano.Tools.Headers import Test.Tasty import Test.Tasty.HUnit import Test.Util.TestEnv @@ -114,6 +115,7 @@ tests :: TestTree tests = testGroup "cardano-tools" [ testCaseSteps "synthesize and analyse: blockCount\n" blockCountTest + , Test.Cardano.Tools.Headers.tests ] main :: IO () diff --git a/ouroboros-consensus-cardano/test/tools-test/Test/Cardano/Tools/Headers.hs b/ouroboros-consensus-cardano/test/tools-test/Test/Cardano/Tools/Headers.hs new file mode 100644 index 0000000000..fc2b10e505 --- /dev/null +++ b/ouroboros-consensus-cardano/test/tools-test/Test/Cardano/Tools/Headers.hs @@ -0,0 +1,50 @@ +module Test.Cardano.Tools.Headers (tests) where + +import Cardano.Tools.Headers (ValidationResult (..), validate) +import qualified Data.Aeson as Json +import Data.Function ((&)) +import qualified Data.Text.Lazy as LT +import Data.Text.Lazy.Encoding (decodeUtf8) +import Test.Ouroboros.Consensus.Protocol.Praos.Header (genContext, + genMutatedHeader, genSample) +import Test.QuickCheck (Property, counterexample, forAll, forAllBlind, + label, property, (===)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) + +tests :: TestTree +tests = + testGroup + "HeaderValidation" + [ testProperty "roundtrip To/FromJSON samples" prop_roundtrip_json_samples + , testProperty "validate legit header" prop_validate_legit_header + ] + +prop_roundtrip_json_samples :: Property +prop_roundtrip_json_samples = + forAll genSample $ \sample -> + let encoded = Json.encode sample + decoded = Json.eitherDecode encoded + in decoded === Right sample + +prop_validate_legit_header :: Property +prop_validate_legit_header = + forAllBlind genContext $ \context -> + forAllBlind (genMutatedHeader context) $ \(context', header) -> + annotate context header $ + case validate context' header of + Valid mut -> property True & label (show mut) + Invalid mut err -> property False & counterexample ("Expected: " <> show mut <> "\nError: " <> err) + where + annotate context header = + counterexample + ( unlines $ + [ "context:" + , asJson context + , "header:" + , show header + ] + ) + + asJson :: (Json.ToJSON a) => a -> String + asJson = LT.unpack . decodeUtf8 . Json.encode diff --git a/ouroboros-consensus-protocol/ouroboros-consensus-protocol.cabal b/ouroboros-consensus-protocol/ouroboros-consensus-protocol.cabal index 45fc293847..51431234cc 100644 --- a/ouroboros-consensus-protocol/ouroboros-consensus-protocol.cabal +++ b/ouroboros-consensus-protocol/ouroboros-consensus-protocol.cabal @@ -84,16 +84,26 @@ library unstable-protocol-testlib import: common-lib visibility: public hs-source-dirs: src/unstable-protocol-testlib - exposed-modules: Test.Consensus.Protocol.Serialisation.Generators + exposed-modules: + Test.Consensus.Protocol.Serialisation.Generators + Test.Ouroboros.Consensus.Protocol.Praos.Header build-depends: QuickCheck, + aeson, base, + base16-bytestring, + bytestring, cardano-crypto-class, + cardano-crypto-praos, cardano-crypto-tests, + cardano-ledger-binary, + cardano-ledger-core, cardano-ledger-shelley-test, cardano-protocol-tpraos, cardano-slotting, + containers, ouroboros-consensus-protocol, + text test-suite protocol-test import: common-test diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs index c9c54ed4cd..973daff119 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs @@ -29,6 +29,9 @@ module Ouroboros.Consensus.Protocol.Praos ( , Ticked (..) , forgePraosFields , praosCheckCanForge + -- * For testing purposes + , doValidateKESSignature + , doValidateVRFSignature ) where import Cardano.Binary (FromCBOR (..), ToCBOR (..), enforceSize) @@ -527,7 +530,20 @@ validateVRFSignature :: ActiveSlotCoeff -> Views.HeaderView c -> Except (PraosValidationErr c) () -validateVRFSignature eta0 (Views.lvPoolDistr -> SL.PoolDistr pd _) f b = do +validateVRFSignature eta0 (Views.lvPoolDistr -> SL.PoolDistr pd _) f = + doValidateVRFSignature eta0 pd f + +-- NOTE: this function is much easier to test than 'validateVRFSignature' because we don't need +-- to construct a 'PraosConfig' nor 'LedgerView' to test it. +doValidateVRFSignature :: + forall c. + PraosCrypto c => + Nonce -> + Map (KeyHash SL.StakePool c) (IndividualPoolStake c) -> + ActiveSlotCoeff -> + Views.HeaderView c -> + Except (PraosValidationErr c) () +doValidateVRFSignature eta0 pd f b = do case Map.lookup hk pd of Nothing -> throwError $ VRFKeyUnknown hk Just (IndividualPoolStake sigma _totalPoolStake vrfHK) -> do @@ -557,12 +573,25 @@ validateKESSignature :: Except (PraosValidationErr c) () validateKESSignature _cfg@( PraosConfig - PraosParams {praosMaxKESEvo, praosSlotsPerKESPeriod} - _ei - ) - Views.LedgerView {Views.lvPoolDistr} - ocertCounters - b = do + PraosParams{praosMaxKESEvo, praosSlotsPerKESPeriod} + _ei + ) + Views.LedgerView{Views.lvPoolDistr = SL.PoolDistr lvPoolDistr _totalActiveStake} + ocertCounters = + doValidateKESSignature praosMaxKESEvo praosSlotsPerKESPeriod lvPoolDistr ocertCounters + +-- NOTE: This function is much easier to test than 'validateKESSignature' because we don't need to +-- construct a 'PraosConfig' nor 'LedgerView' to test it. +doValidateKESSignature :: + PraosCrypto c => + Word64 -> + Word64 -> + Map (KeyHash SL.StakePool c) (IndividualPoolStake c) -> + Map (KeyHash BlockIssuer c) Word64 -> + Views.HeaderView c -> + Except (PraosValidationErr c) () +doValidateKESSignature praosMaxKESEvo praosSlotsPerKESPeriod stakeDistribution ocertCounters b = + do c0 <= kp ?! KESBeforeStartOCERT c0 kp kp_ < c0_ + fromIntegral praosMaxKESEvo ?! KESAfterEndOCERT kp c0 praosMaxKESEvo @@ -594,7 +623,7 @@ validateKESSignature currentIssueNo :: Maybe Word64 currentIssueNo | Map.member hk ocertCounters = Map.lookup hk ocertCounters - | Set.member (coerceKeyRole hk) (Map.keysSet $ SL.unPoolDistr lvPoolDistr) = + | Set.member (coerceKeyRole hk) (Map.keysSet stakeDistribution) = Just 0 | otherwise = Nothing @@ -727,6 +756,7 @@ instance Util -------------------------------------------------------------------------------} +-- | Check value and raise error if it is false. (?!) :: Bool -> e -> Except e () a ?! b = unless a $ throwError b diff --git a/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs b/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs new file mode 100644 index 0000000000..46e989c5d4 --- /dev/null +++ b/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs @@ -0,0 +1,455 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-missing-export-lists #-} + +module Test.Ouroboros.Consensus.Protocol.Praos.Header where + +import Cardano.Crypto.DSIGN + (DSIGNAlgorithm (SignKeyDSIGN, genKeyDSIGN, rawSerialiseSignKeyDSIGN), + Ed25519DSIGN, deriveVerKeyDSIGN, + rawDeserialiseSignKeyDSIGN) +import Cardano.Crypto.Hash (Blake2b_256, Hash, hashWith, hashFromBytes, + hashToBytes) +import qualified Cardano.Crypto.KES as KES +import Cardano.Crypto.KES.Class (genKeyKES, rawDeserialiseSignKeyKES, + rawSerialiseSignKeyKES) +import Cardano.Crypto.Seed (mkSeedFromBytes) +import Cardano.Crypto.VRF (deriveVerKeyVRF, hashVerKeyVRF, + rawDeserialiseSignKeyVRF, rawSerialiseSignKeyVRF) +import qualified Cardano.Crypto.VRF as VRF +import Cardano.Crypto.VRF.Praos (skToBatchCompat) +import qualified Cardano.Crypto.VRF.Praos as VRF +import Cardano.Ledger.BaseTypes (ActiveSlotCoeff, Nonce (..), + PositiveUnitInterval, ProtVer (..), Version, activeSlotVal, + boundRational, mkActiveSlotCoeff, natVersion) +import Cardano.Ledger.Binary (MaxVersion, decCBOR, decodeFullAnnotator, + serialize') +import Cardano.Ledger.Keys (KeyHash, KeyRole (BlockIssuer), VKey (..), + hashKey, signedDSIGN) +import Cardano.Protocol.TPraos.BHeader (HashHeader (..), + PrevHash (..), checkLeaderNatValue) +import Cardano.Protocol.TPraos.OCert (KESPeriod (..), OCert (..), + OCertSignable (..)) +import Cardano.Slotting.Block (BlockNo (..)) +import Cardano.Slotting.Slot (SlotNo (..)) +import Data.Aeson ((.:), (.=)) +import qualified Data.Aeson as Json +import Data.Bifunctor (second) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base16 as Base16 +import qualified Data.ByteString.Lazy as LBS +import Data.Coerce (coerce) +import Data.Foldable (toList) +import qualified Data.Map as Map +import Data.Maybe (fromJust, fromMaybe) +import Data.Proxy (Proxy (..)) +import Data.Ratio ((%)) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Word (Word64) +import Ouroboros.Consensus.Protocol.Praos (PraosValidationErr (..)) +import Ouroboros.Consensus.Protocol.Praos.Header (Header, + HeaderBody (..), pattern Header) +import Ouroboros.Consensus.Protocol.Praos.VRF (InputVRF, mkInputVRF, + vrfLeaderValue) +import Ouroboros.Consensus.Protocol.TPraos (StandardCrypto) +import Test.QuickCheck (Gen, arbitrary, choose, frequency, generate, + getPositive, resize, shrinkList, sized, suchThat, vectorOf) + +-- * Test Vectors + +generateSamples :: Int -> IO Sample +generateSamples n = generate (resize n genSample) + +-- FIXME: Should be defined according to some Era +testVersion :: Version +testVersion = natVersion @MaxVersion + +data Sample = Sample {sample :: ![(GeneratorContext, MutatedHeader)]} + deriving (Show, Eq) + +instance Json.ToJSON Sample where + toJSON Sample{sample} = Json.toJSON sample + +instance Json.FromJSON Sample where + parseJSON = Json.withArray "Sample" $ \arr -> do + Sample . toList <$> traverse Json.parseJSON arr + +genSample :: Gen Sample +genSample = do + context <- genContext + sample <- sized $ \n -> vectorOf n $ genMutatedHeader context + pure $ Sample{sample} + +genMutatedHeader :: GeneratorContext -> Gen (GeneratorContext, MutatedHeader) +genMutatedHeader context = do + mutation <- genMutation + header <- genHeader context + mutate context header mutation + +shrinkSample :: Sample -> [Sample] +shrinkSample Sample{sample} = Sample <$> shrinkList (const []) sample + +mutate :: GeneratorContext -> Header StandardCrypto -> Mutation -> Gen (GeneratorContext, MutatedHeader) +mutate context header mutation = + second (\h -> MutatedHeader{header = h, mutation}) <$> mutated + where + mutated = + case mutation of + NoMutation -> pure (context, header) + MutateKESKey -> do + let Header body _ = header + newKESSignKey <- newKESSigningKey <$> gen32Bytes + KESPeriod kesPeriod <- genValidKESPeriod (hbSlotNo body) praosSlotsPerKESPeriod + let sig' = KES.signKES () kesPeriod body newKESSignKey + pure (context, Header body (KES.SignedKES sig')) + MutateColdKey -> do + let Header body _ = header + newColdSignKey <- genKeyDSIGN . mkSeedFromBytes <$> gen32Bytes + (hbOCert, KESPeriod kesPeriod) <- genCert (hbSlotNo body) context{coldSignKey = newColdSignKey} + let newBody = body{hbOCert} + let sig' = KES.signKES () kesPeriod newBody kesSignKey + pure (context, Header newBody (KES.SignedKES sig')) + MutateKESPeriod -> do + let Header body _ = header + KESPeriod kesPeriod' <- genKESPeriodAfterLimit (hbSlotNo body) praosSlotsPerKESPeriod + let newKESPeriod = KESPeriod kesPeriod' + let oldOCert@OCert{ocertVkHot, ocertN} = hbOCert body + let newBody = + body + { hbOCert = + oldOCert + { ocertKESPeriod = newKESPeriod + , ocertSigma = signedDSIGN @StandardCrypto coldSignKey (OCertSignable ocertVkHot ocertN newKESPeriod) + } + } + let sig' = KES.signKES () kesPeriod' newBody kesSignKey + pure (context, Header newBody (KES.SignedKES sig')) + MutateKESPeriodBefore -> do + let Header body _ = header + let OCert{ocertKESPeriod = KESPeriod kesPeriod} = hbOCert body + newSlotNo <- genSlotAfterKESPeriod (fromIntegral kesPeriod) praosMaxKESEvo praosSlotsPerKESPeriod + let rho' = mkInputVRF newSlotNo nonce + hbVrfRes = VRF.evalCertified () rho' vrfSignKey + newBody = body{hbSlotNo = newSlotNo, hbVrfRes} + sig' = KES.signKES () kesPeriod newBody kesSignKey + pure (context, Header newBody (KES.SignedKES sig')) + MutateCounterOver1 -> do + let poolId = coerce $ hashKey $ VKey $ deriveVerKeyDSIGN coldSignKey + oldCounter = fromMaybe 0 $ Map.lookup poolId (ocertCounters context) + -- FIXME: assumes oldCounter is greater than 1, which is the case in the base generator + -- but is not guaranteed. If oldCounter == 0 then the mutation will fail + newCounter <- choose (0, oldCounter) + let context' = context{ocertCounters = Map.insert poolId newCounter (ocertCounters context)} + pure (context', header) + MutateCounterUnder -> do + let poolId = coerce $ hashKey $ VKey $ deriveVerKeyDSIGN coldSignKey + oldCounter = fromMaybe 0 $ Map.lookup poolId (ocertCounters context) + newCounter <- arbitrary `suchThat` (> oldCounter) + let context' = context{ocertCounters = Map.insert poolId newCounter (ocertCounters context)} + pure (context', header) + GeneratorContext{praosSlotsPerKESPeriod, praosMaxKESEvo, kesSignKey, vrfSignKey, coldSignKey, nonce} = context + +data Mutation + = -- | No mutation + NoMutation + | -- | Mutate the KES key, ie. sign the header with a different KES key. + MutateKESKey + | -- | Mutate the cold key, ie. sign the operational certificate with a different cold key. + MutateColdKey + | -- | Mutate the KES period in the operational certificate to be + -- after the start of the KES period. + MutateKESPeriod + | -- | Mutate KES period to be before the current KES period + MutateKESPeriodBefore + | -- | Mutate certificate counter to be greater than expected + MutateCounterOver1 + | -- | Mutate certificate counter to be lower than expected + MutateCounterUnder + deriving (Eq, Show) + +instance Json.ToJSON Mutation where + toJSON = \case + NoMutation -> "NoMutation" + MutateKESKey -> "MutateKESKey" + MutateColdKey -> "MutateColdKey" + MutateKESPeriod -> "MutateKESPeriod" + MutateKESPeriodBefore -> "MutateKESPeriodBefore" + MutateCounterOver1 -> "MutateCounterOver1" + MutateCounterUnder -> "MutateCounterUnder" + +instance Json.FromJSON Mutation where + parseJSON = \case + "NoMutation" -> pure NoMutation + "MutateKESKey" -> pure MutateKESKey + "MutateColdKey" -> pure MutateColdKey + "MutateKESPeriod" -> pure MutateKESPeriod + "MutateKESPeriodBefore" -> pure MutateKESPeriodBefore + "MutateCounterOver1" -> pure MutateCounterOver1 + "MutateCounterUnder" -> pure MutateCounterUnder + _ -> fail "Invalid mutation" + +expectedError :: Mutation -> (PraosValidationErr StandardCrypto -> Bool) +expectedError = \case + NoMutation -> const False + MutateKESKey -> \case + InvalidKesSignatureOCERT{} -> True + _ -> False + MutateColdKey -> \case + InvalidSignatureOCERT{} -> True + _ -> False + MutateKESPeriod -> \case + KESBeforeStartOCERT{} -> True + _ -> False + MutateKESPeriodBefore -> \case + KESAfterEndOCERT{} -> True + _ -> False + MutateCounterOver1 -> \case + CounterOverIncrementedOCERT{} -> True + _ -> False + MutateCounterUnder -> \case + CounterTooSmallOCERT{} -> True + _ -> False + +genMutation :: Gen Mutation +genMutation = + frequency + [ (4, pure NoMutation) + , (1, pure MutateKESKey) + , (1, pure MutateColdKey) + , (1, pure MutateKESPeriod) + , (1, pure MutateKESPeriodBefore) + , (1, pure MutateCounterOver1) + , (1, pure MutateCounterUnder) + ] + +data MutatedHeader = MutatedHeader + { header :: !(Header StandardCrypto) + , mutation :: !Mutation + } + deriving (Show, Eq) + +instance Json.ToJSON MutatedHeader where + toJSON MutatedHeader{header, mutation} = + Json.object + [ "header" .= cborHeader + , "mutation" .= mutation + ] + where + cborHeader = decodeUtf8 . Base16.encode $ serialize' testVersion header + +instance Json.FromJSON MutatedHeader where + parseJSON = Json.withObject "MutatedHeader" $ \obj -> do + cborHeader <- obj .: "header" + mutation <- obj .: "mutation" + header <- parseHeader cborHeader + pure MutatedHeader{header, mutation} + where + parseHeader cborHeader = do + let headerBytes = Base16.decodeLenient (encodeUtf8 cborHeader) + either (fail . show) pure $ decodeFullAnnotator @(Header StandardCrypto) testVersion "Header" decCBOR $ LBS.fromStrict headerBytes + +-- * Generators +type KESKey = KES.SignKeyKES (KES.Sum6KES Ed25519DSIGN Blake2b_256) + +newVRFSigningKey :: ByteString -> (VRF.SignKeyVRF VRF.PraosVRF, VRF.VerKeyVRF VRF.PraosVRF) +newVRFSigningKey = VRF.genKeyPairVRF . mkSeedFromBytes + +newKESSigningKey :: ByteString -> KESKey +newKESSigningKey = genKeyKES . mkSeedFromBytes + +data GeneratorContext = GeneratorContext + { praosSlotsPerKESPeriod :: !Word64 + , praosMaxKESEvo :: !Word64 + , kesSignKey :: !KESKey + , coldSignKey :: !(SignKeyDSIGN Ed25519DSIGN) + , vrfSignKey :: !(VRF.SignKeyVRF VRF.PraosVRF) + , nonce :: !Nonce + , ocertCounters :: !(Map.Map (KeyHash BlockIssuer StandardCrypto) Word64) + , activeSlotCoeff :: !ActiveSlotCoeff + } + deriving (Show) + +instance Eq GeneratorContext where + a == b = + praosSlotsPerKESPeriod a == praosSlotsPerKESPeriod b + && praosMaxKESEvo a == praosMaxKESEvo b + && serialize' testVersion (kesSignKey a) == serialize' testVersion (kesSignKey b) + && coldSignKey a == coldSignKey b + && vrfSignKey a == vrfSignKey b + && nonce a == nonce b + +instance Json.ToJSON GeneratorContext where + toJSON GeneratorContext{..} = + Json.object + [ "praosSlotsPerKESPeriod" .= praosSlotsPerKESPeriod + , "praosMaxKESEvo" .= praosMaxKESEvo + , "kesSignKey" .= rawKesSignKey + , "coldSignKey" .= rawColdSignKey + , "vrfSignKey" .= rawVrfSignKey + , "vrfVKeyHash" .= rawVrVKeyHash + , "nonce" .= rawNonce + , "ocertCounters" .= ocertCounters + , "activeSlotCoeff" .= activeSlotVal activeSlotCoeff + ] + where + rawKesSignKey = decodeUtf8 . Base16.encode $ rawSerialiseSignKeyKES kesSignKey + rawColdSignKey = decodeUtf8 . Base16.encode $ rawSerialiseSignKeyDSIGN coldSignKey + rawVrfSignKey = decodeUtf8 . Base16.encode $ rawSerialiseSignKeyVRF $ skToBatchCompat vrfSignKey + rawVrVKeyHash = decodeUtf8 . Base16.encode $ hashToBytes $ hashVerKeyVRF @_ @Blake2b_256 $ deriveVerKeyVRF vrfSignKey + rawNonce = case nonce of + NeutralNonce -> decodeUtf8 . Base16.encode $ BS.replicate 32 0 + Nonce hashNonce -> decodeUtf8 . Base16.encode $ hashToBytes hashNonce + +instance Json.FromJSON GeneratorContext where + parseJSON = Json.withObject "GeneratorContext" $ \obj -> do + praosSlotsPerKESPeriod <- obj .: "praosSlotsPerKESPeriod" + praosMaxKESEvo <- obj .: "praosMaxKESEvo" + rawKesSignKey <- obj .: "kesSignKey" + rawColdSignKey <- obj .: "coldSignKey" + rawVrfSignKey <- obj .: "vrfSignKey" + cborNonce <- obj .: "nonce" + ocertCounters <- obj .: "ocertCounters" + kesSignKey <- parseKesSignKey rawKesSignKey + coldSignKey <- parseColdSignKey rawColdSignKey + vrfSignKey <- parseVrfSignKey rawVrfSignKey + nonce <- parseNonce cborNonce + activeSlotCoeff <- mkActiveSlotCoeff <$> obj .: "activeSlotCoeff" + pure GeneratorContext{..} + where + parseNonce rawNonce = + case Base16.decode (encodeUtf8 rawNonce) of + Left _ -> pure NeutralNonce + Right nonceBytes -> Nonce <$> maybe (fail "invalid bytes for hash") pure (hashFromBytes nonceBytes) + parseColdSignKey rawKey = do + case Base16.decode (encodeUtf8 rawKey) of + Left err -> fail err + Right keyBytes -> + case rawDeserialiseSignKeyDSIGN keyBytes of + Nothing -> fail $ "Invalid cold key bytes: " <> show rawKey + Just key -> pure key + parseKesSignKey rawKey = do + case Base16.decode (encodeUtf8 rawKey) of + Left err -> fail err + Right keyBytes -> + case rawDeserialiseSignKeyKES keyBytes of + Nothing -> fail $ "Invalid KES key bytes: " <> show rawKey + Just key -> pure key + parseVrfSignKey rawKey = do + case Base16.decode (encodeUtf8 rawKey) of + Left err -> fail err + Right keyBytes -> + case rawDeserialiseSignKeyVRF keyBytes of + Nothing -> fail $ "Invalid VRF key bytes: " <> show rawKey + Just key -> pure key + +genContext :: Gen GeneratorContext +genContext = do + praosSlotsPerKESPeriod <- choose (100, 10000) + praosMaxKESEvo <- choose (10, 1000) + ocertCounter <- choose (10, 100) + kesSignKey <- newKESSigningKey <$> gen32Bytes + coldSignKey <- genKeyDSIGN . mkSeedFromBytes <$> gen32Bytes + vrfSignKey <- fst <$> newVRFSigningKey <$> gen32Bytes + nonce <- Nonce <$> genHash + let poolId = coerce $ hashKey $ VKey $ deriveVerKeyDSIGN coldSignKey + ocertCounters = Map.fromList [(poolId, ocertCounter)] + activeSlotCoeff <- genActiveSlotCoeff + pure $ GeneratorContext{..} + +genActiveSlotCoeff :: Gen ActiveSlotCoeff +genActiveSlotCoeff = do + choose (1, 100) >>= \n -> pure $ activeSlotCoeff (n % 100) + where + activeSlotCoeff = mkActiveSlotCoeff . fromJust . boundRational @PositiveUnitInterval + +{- | Generate a well-formed header + +The header is signed with the KES key, and all the signing keys +generated for the purpose of producing the header are returned. +-} +genHeader :: GeneratorContext -> Gen (Header StandardCrypto) +genHeader context = do + (body, KESPeriod kesPeriod) <- genHeaderBody context + let sign = KES.SignedKES $ KES.signKES () kesPeriod body kesSignKey + pure $ (Header body sign) + where + GeneratorContext{kesSignKey} = context + +genHeaderBody :: GeneratorContext -> Gen (HeaderBody StandardCrypto, KESPeriod) +genHeaderBody context = do + hbBlockNo <- BlockNo <$> arbitrary + (hbSlotNo, hbVrfRes, hbVrfVk) <- genLeadingSlot context + hbPrev <- BlockHash . HashHeader <$> genHash + let hbVk = VKey $ deriveVerKeyDSIGN coldSignKey + hbBodySize <- choose (1000, 90000) + hbBodyHash <- genHash + (hbOCert, kesPeriod) <- genCert hbSlotNo context + let hbProtVer = protocolVersionZero + headerBody = HeaderBody{..} + pure $ (headerBody, kesPeriod) + where + GeneratorContext{coldSignKey} = context + +genLeadingSlot :: GeneratorContext -> Gen (SlotNo, VRF.CertifiedVRF VRF.PraosVRF InputVRF, VRF.VerKeyVRF VRF.PraosVRF) +genLeadingSlot context = do + slotNo <- SlotNo . getPositive <$> arbitrary `suchThat` isLeader + let rho' = mkInputVRF slotNo nonce + hbVrfRes = VRF.evalCertified () rho' vrfSignKey + hbVrfVk = deriveVerKeyVRF vrfSignKey + pure (slotNo, hbVrfRes, hbVrfVk) + where + isLeader n = + let slotNo = SlotNo . getPositive $ n + rho' = mkInputVRF slotNo nonce + certified = VRF.evalCertified () rho' vrfSignKey + in checkLeaderNatValue (vrfLeaderValue (Proxy @StandardCrypto) certified) sigma activeSlotCoeff + sigma = 1 + GeneratorContext{vrfSignKey, nonce, activeSlotCoeff} = context + +protocolVersionZero :: ProtVer +protocolVersionZero = ProtVer versionZero 0 + where + versionZero :: Version + versionZero = natVersion @0 + +genCert :: SlotNo -> GeneratorContext -> Gen (OCert StandardCrypto, KESPeriod) +genCert slotNo context = do + let ocertVkHot = KES.deriveVerKeyKES kesSignKey + poolId = coerce $ hashKey $ VKey $ deriveVerKeyDSIGN coldSignKey + ocertN = fromMaybe 0 $ Map.lookup poolId ocertCounters + ocertKESPeriod <- genValidKESPeriod slotNo praosSlotsPerKESPeriod + let ocertSigma = signedDSIGN @StandardCrypto coldSignKey (OCertSignable ocertVkHot ocertN ocertKESPeriod) + pure (OCert{..}, ocertKESPeriod) + where + GeneratorContext{kesSignKey, praosSlotsPerKESPeriod, coldSignKey, ocertCounters} = context + +genValidKESPeriod :: SlotNo -> Word64 -> Gen KESPeriod +genValidKESPeriod slotNo praosSlotsPerKESPeriod = + pure $ KESPeriod $ fromIntegral $ unSlotNo slotNo `div` praosSlotsPerKESPeriod + +genKESPeriodAfterLimit :: SlotNo -> Word64 -> Gen KESPeriod +genKESPeriodAfterLimit slotNo praosSlotsPerKESPeriod = + KESPeriod . fromIntegral <$> arbitrary `suchThat` (> currentKESPeriod) + where + currentKESPeriod = unSlotNo slotNo `div` praosSlotsPerKESPeriod + +genSlotAfterKESPeriod :: Word64 -> Word64 -> Word64 -> Gen SlotNo +genSlotAfterKESPeriod ocertKESPeriod praosMaxKESEvo praosSlotsPerKESPeriod = + -- kp_ < c0_ + praosMaxKESEvo + -- ! => + -- kp >= c0_ + praosMaxKESEvo + -- c0 <= kp - praosMaxKESEvo + SlotNo <$> arbitrary `suchThat` (> (ocertKESPeriod + praosMaxKESEvo) * praosSlotsPerKESPeriod) + +genHash :: Gen (Hash Blake2b_256 a) +genHash = coerce . hashWith id <$> gen32Bytes + +gen32Bytes :: Gen ByteString +gen32Bytes = BS.pack <$> vectorOf 32 arbitrary From e3cf89b45d0d88fab28cadd86874e28efd746462 Mon Sep 17 00:00:00 2001 From: Arnaud Bailly Date: Mon, 28 Oct 2024 18:43:51 +0100 Subject: [PATCH 02/11] [wip] Make mutation depend on header to ensure consistency some mutations are not possible for some content of the header, eg. if ocertN = 0 then it's not possible to generate a smaller expected value --- .../tools-test/Test/Cardano/Tools/Headers.hs | 2 +- .../Ouroboros/Consensus/Protocol/Praos.hs | 3 +- .../Consensus/Protocol/Praos/Header.hs | 38 ++++++++++++------- 3 files changed, 27 insertions(+), 16 deletions(-) diff --git a/ouroboros-consensus-cardano/test/tools-test/Test/Cardano/Tools/Headers.hs b/ouroboros-consensus-cardano/test/tools-test/Test/Cardano/Tools/Headers.hs index fc2b10e505..d259f30c28 100644 --- a/ouroboros-consensus-cardano/test/tools-test/Test/Cardano/Tools/Headers.hs +++ b/ouroboros-consensus-cardano/test/tools-test/Test/Cardano/Tools/Headers.hs @@ -31,7 +31,7 @@ prop_validate_legit_header :: Property prop_validate_legit_header = forAllBlind genContext $ \context -> forAllBlind (genMutatedHeader context) $ \(context', header) -> - annotate context header $ + annotate context' header $ case validate context' header of Valid mut -> property True & label (show mut) Invalid mut err -> property False & counterexample ("Expected: " <> show mut <> "\nError: " <> err) diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs index 973daff119..eda30f1dbd 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs @@ -348,6 +348,7 @@ data PraosValidationErr c !Word -- current KES Period !Word -- KES start period !Word -- expected KES evolutions + !Word64 -- max KES evolutions !String -- error message given by Consensus Layer | NoCounterForKeyHashOCERT !(KeyHash 'BlockIssuer c) -- stake pool key hash @@ -602,7 +603,7 @@ doValidateKESSignature praosMaxKESEvo praosSlotsPerKESPeriod stakeDistribution o DSIGN.verifySignedDSIGN () vkcold (OCert.ocertToSignable oc) tau ?!: InvalidSignatureOCERT n c0 KES.verifySignedKES () vk_hot t (Views.hvSigned b) (Views.hvSignature b) ?!: - InvalidKesSignatureOCERT kp_ c0_ t + InvalidKesSignatureOCERT kp_ c0_ t praosMaxKESEvo case currentIssueNo of Nothing -> do diff --git a/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs b/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs index 46e989c5d4..ef63baa15a 100644 --- a/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs +++ b/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs @@ -61,6 +61,7 @@ import Ouroboros.Consensus.Protocol.Praos.VRF (InputVRF, mkInputVRF, import Ouroboros.Consensus.Protocol.TPraos (StandardCrypto) import Test.QuickCheck (Gen, arbitrary, choose, frequency, generate, getPositive, resize, shrinkList, sized, suchThat, vectorOf) +import Debug.Trace (trace) -- * Test Vectors @@ -89,8 +90,8 @@ genSample = do genMutatedHeader :: GeneratorContext -> Gen (GeneratorContext, MutatedHeader) genMutatedHeader context = do - mutation <- genMutation header <- genHeader context + mutation <- genMutation header mutate context header mutation shrinkSample :: Sample -> [Sample] @@ -133,19 +134,19 @@ mutate context header mutation = pure (context, Header newBody (KES.SignedKES sig')) MutateKESPeriodBefore -> do let Header body _ = header - let OCert{ocertKESPeriod = KESPeriod kesPeriod} = hbOCert body + OCert{ocertKESPeriod = KESPeriod kesPeriod} = hbOCert body newSlotNo <- genSlotAfterKESPeriod (fromIntegral kesPeriod) praosMaxKESEvo praosSlotsPerKESPeriod let rho' = mkInputVRF newSlotNo nonce + period' = unSlotNo newSlotNo `div` praosSlotsPerKESPeriod hbVrfRes = VRF.evalCertified () rho' vrfSignKey newBody = body{hbSlotNo = newSlotNo, hbVrfRes} - sig' = KES.signKES () kesPeriod newBody kesSignKey + sig' = KES.signKES () (fromIntegral period' - kesPeriod) newBody kesSignKey pure (context, Header newBody (KES.SignedKES sig')) MutateCounterOver1 -> do let poolId = coerce $ hashKey $ VKey $ deriveVerKeyDSIGN coldSignKey - oldCounter = fromMaybe 0 $ Map.lookup poolId (ocertCounters context) - -- FIXME: assumes oldCounter is greater than 1, which is the case in the base generator - -- but is not guaranteed. If oldCounter == 0 then the mutation will fail - newCounter <- choose (0, oldCounter) + Header body _ = header + OCert{ocertN} = hbOCert body + newCounter <- choose (0, ocertN - 2) let context' = context{ocertCounters = Map.insert poolId newCounter (ocertCounters context)} pure (context', header) MutateCounterUnder -> do @@ -217,17 +218,23 @@ expectedError = \case CounterTooSmallOCERT{} -> True _ -> False -genMutation :: Gen Mutation -genMutation = - frequency +genMutation :: Header StandardCrypto -> Gen Mutation +genMutation header = + frequency $ [ (4, pure NoMutation) , (1, pure MutateKESKey) , (1, pure MutateColdKey) , (1, pure MutateKESPeriod) , (1, pure MutateKESPeriodBefore) - , (1, pure MutateCounterOver1) , (1, pure MutateCounterUnder) - ] + ] <> maybeCounterOver1 + where + Header body _ = header + OCert{ocertN} = hbOCert body + maybeCounterOver1 = + if ocertN > 10 + then [(1, pure MutateCounterOver1)] + else [] data MutatedHeader = MutatedHeader { header :: !(Header StandardCrypto) @@ -441,12 +448,15 @@ genKESPeriodAfterLimit slotNo praosSlotsPerKESPeriod = currentKESPeriod = unSlotNo slotNo `div` praosSlotsPerKESPeriod genSlotAfterKESPeriod :: Word64 -> Word64 -> Word64 -> Gen SlotNo -genSlotAfterKESPeriod ocertKESPeriod praosMaxKESEvo praosSlotsPerKESPeriod = +genSlotAfterKESPeriod ocertKESPeriod praosMaxKESEvo praosSlotsPerKESPeriod = do -- kp_ < c0_ + praosMaxKESEvo -- ! => -- kp >= c0_ + praosMaxKESEvo -- c0 <= kp - praosMaxKESEvo - SlotNo <$> arbitrary `suchThat` (> (ocertKESPeriod + praosMaxKESEvo) * praosSlotsPerKESPeriod) + s <- SlotNo <$> arbitrary `suchThat` (> threshold) + pure $ trace ("new slot no: " <> show s <> ", threshold: " <> show threshold ) $ s + where + threshold = (ocertKESPeriod + praosMaxKESEvo + 1) * praosSlotsPerKESPeriod genHash :: Gen (Hash Blake2b_256 a) genHash = coerce . hashWith id <$> gen32Bytes From e6c5f321168a75e25205fd0b82f125a022028404 Mon Sep 17 00:00:00 2001 From: Arnaud Bailly Date: Tue, 29 Oct 2024 06:21:57 +0100 Subject: [PATCH 03/11] Add changelog entry --- .../20241029_062000_abailly_header_validation_test.md | 3 +++ 1 file changed, 3 insertions(+) create mode 100644 ouroboros-consensus-protocol/changelog.d/20241029_062000_abailly_header_validation_test.md diff --git a/ouroboros-consensus-protocol/changelog.d/20241029_062000_abailly_header_validation_test.md b/ouroboros-consensus-protocol/changelog.d/20241029_062000_abailly_header_validation_test.md new file mode 100644 index 0000000000..a26d5e6190 --- /dev/null +++ b/ouroboros-consensus-protocol/changelog.d/20241029_062000_abailly_header_validation_test.md @@ -0,0 +1,3 @@ +### Patch + +- Introduce generators and properties to test header validation logic From 86c337e72a635a1cc1219da6883c0e0f9473dbe0 Mon Sep 17 00:00:00 2001 From: Arnaud Bailly Date: Tue, 29 Oct 2024 06:23:22 +0100 Subject: [PATCH 04/11] Add Paths module to autogen section --- ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal | 2 ++ 1 file changed, 2 insertions(+) diff --git a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal index 9991ca8654..c63c275d0e 100644 --- a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal +++ b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal @@ -691,3 +691,5 @@ executable gen-header other-modules: GenHeader.Parsers Paths_ouroboros_consensus_cardano + autogen-modules: + Paths_ouroboros_consensus_cardano From 8516152832da7448942f2608e87b1fff70b4fe83 Mon Sep 17 00:00:00 2001 From: Arnaud Bailly Date: Tue, 29 Oct 2024 06:46:22 +0100 Subject: [PATCH 05/11] Remove unneeded imports and traces also remove hardcoded maxKESEvo parameter from test run --- .../Cardano/Tools/Headers.hs | 15 +++------------ .../Ouroboros/Consensus/Protocol/Praos/Header.hs | 4 +--- 2 files changed, 4 insertions(+), 15 deletions(-) diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/Headers.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/Headers.hs index 888f70e88f..ed6447969a 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/Headers.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/Headers.hs @@ -8,12 +8,9 @@ module Cardano.Tools.Headers where import Cardano.Crypto.DSIGN (deriveVerKeyDSIGN) -import Cardano.Crypto.Hash (Blake2b_256, hashToBytes) import Cardano.Crypto.VRF (VRFAlgorithm (deriveVerKeyVRF, hashVerKeyVRF)) -import Cardano.Ledger.Api (ConwayEra, StandardCrypto, VRF) -import Cardano.Ledger.BaseTypes (BoundedRational (boundRational), - PositiveUnitInterval, mkActiveSlotCoeff) +import Cardano.Ledger.Api (ConwayEra, StandardCrypto) import Cardano.Ledger.Coin (Coin (..)) import Cardano.Ledger.Compactible (toCompact) import Cardano.Ledger.Keys (VKey (..), hashKey) @@ -22,17 +19,12 @@ import Cardano.Prelude (ExitCode (..), exitWith, forM_, hPutStrLn, stderr) import Control.Monad.Except (runExcept) import qualified Data.Aeson as Json -import qualified Data.ByteString.Base16 as Hex import qualified Data.ByteString.Lazy as LBS import qualified Data.Map as Map import Data.Maybe (fromJust) -import Data.Text (unpack) -import Data.Text.Encoding (decodeUtf8) -import Debug.Trace (trace) import Ouroboros.Consensus.Block (validateView) import Ouroboros.Consensus.Protocol.Praos (Praos, doValidateKESSignature, doValidateVRFSignature) -import qualified Ouroboros.Consensus.Protocol.Praos.Views as Views import Ouroboros.Consensus.Shelley.HFEras () import Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock, mkShelleyHeader) @@ -72,9 +64,8 @@ validate context MutatedHeader{header, mutation} = (Right _, NoMutation) -> Valid NoMutation (Right _, mut) -> Invalid mut $ "Expected error from mutation " <> show mut <> ", but validation succeeded" where - GeneratorContext{praosSlotsPerKESPeriod, nonce, coldSignKey, vrfSignKey, ocertCounters, activeSlotCoeff} = context + GeneratorContext{praosSlotsPerKESPeriod, praosMaxKESEvo, nonce, coldSignKey, vrfSignKey, ocertCounters, activeSlotCoeff} = context -- TODO: get these from the context - maxKESEvo = 62 coin = fromJust . toCompact . Coin ownsAllStake vrfKey = IndividualPoolStake 1 (coin 1) vrfKey poolDistr = Map.fromList [(poolId, ownsAllStake hashVRFKey)] @@ -82,5 +73,5 @@ validate context MutatedHeader{header, mutation} = hashVRFKey = hashVerKeyVRF $ deriveVerKeyVRF vrfSignKey headerView = validateView @ConwayBlock undefined (mkShelleyHeader header) - validateKES = doValidateKESSignature maxKESEvo praosSlotsPerKESPeriod poolDistr ocertCounters headerView + validateKES = doValidateKESSignature praosMaxKESEvo praosSlotsPerKESPeriod poolDistr ocertCounters headerView validateVRF = doValidateVRFSignature nonce poolDistr activeSlotCoeff headerView diff --git a/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs b/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs index ef63baa15a..59131e6d60 100644 --- a/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs +++ b/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs @@ -61,7 +61,6 @@ import Ouroboros.Consensus.Protocol.Praos.VRF (InputVRF, mkInputVRF, import Ouroboros.Consensus.Protocol.TPraos (StandardCrypto) import Test.QuickCheck (Gen, arbitrary, choose, frequency, generate, getPositive, resize, shrinkList, sized, suchThat, vectorOf) -import Debug.Trace (trace) -- * Test Vectors @@ -453,8 +452,7 @@ genSlotAfterKESPeriod ocertKESPeriod praosMaxKESEvo praosSlotsPerKESPeriod = do -- ! => -- kp >= c0_ + praosMaxKESEvo -- c0 <= kp - praosMaxKESEvo - s <- SlotNo <$> arbitrary `suchThat` (> threshold) - pure $ trace ("new slot no: " <> show s <> ", threshold: " <> show threshold ) $ s + SlotNo <$> arbitrary `suchThat` (> threshold) where threshold = (ocertKESPeriod + praosMaxKESEvo + 1) * praosSlotsPerKESPeriod From 5bd0a37d34cc4f3d9bb7099fa9ed8dbc345e4ece Mon Sep 17 00:00:00 2001 From: Arnaud Bailly Date: Tue, 29 Oct 2024 06:58:43 +0100 Subject: [PATCH 06/11] Add missing exports --- ouroboros-consensus-cardano/app/GenHeader/Parsers.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ouroboros-consensus-cardano/app/GenHeader/Parsers.hs b/ouroboros-consensus-cardano/app/GenHeader/Parsers.hs index e415ff96de..34058a8bef 100644 --- a/ouroboros-consensus-cardano/app/GenHeader/Parsers.hs +++ b/ouroboros-consensus-cardano/app/GenHeader/Parsers.hs @@ -1,4 +1,4 @@ -module GenHeader.Parsers where +module GenHeader.Parsers (parseOptions) where import Cardano.Tools.Headers (Options (..)) import Data.Version (showVersion) From b2be80c49052d576335551e44fa35a38f93dc841 Mon Sep 17 00:00:00 2001 From: Arnaud Bailly Date: Tue, 29 Oct 2024 07:44:58 +0100 Subject: [PATCH 07/11] Format cabal files w/ cabal-gild --- .../ouroboros-consensus-cardano.cabal | 11 +++++++---- .../ouroboros-consensus-protocol.cabal | 3 ++- 2 files changed, 9 insertions(+), 5 deletions(-) diff --git a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal index c63c275d0e..df32ce0c7f 100644 --- a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal +++ b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal @@ -356,7 +356,7 @@ test-suite shelley-test ouroboros-consensus:{ouroboros-consensus, unstable-consensus-testlib}, ouroboros-consensus-cardano, ouroboros-consensus-diffusion:unstable-diffusion-testlib, - ouroboros-consensus-protocol:ouroboros-consensus-protocol, + ouroboros-consensus-protocol, sop-core, strict-sop-core, tasty, @@ -553,8 +553,8 @@ library unstable-cardano-tools ouroboros-consensus ^>=0.21, ouroboros-consensus-cardano, ouroboros-consensus-diffusion ^>=0.18, - ouroboros-consensus-protocol ^>=0.9, ouroboros-consensus-protocol:unstable-protocol-testlib, + ouroboros-consensus-protocol ^>=0.9, ouroboros-network, ouroboros-network-api, ouroboros-network-framework ^>=0.14, @@ -664,17 +664,18 @@ test-suite tools-test hs-source-dirs: test/tools-test main-is: Main.hs build-depends: + QuickCheck, aeson, base, ouroboros-consensus:{ouroboros-consensus, unstable-consensus-testlib}, - ouroboros-consensus-cardano:{ouroboros-consensus-cardano,unstable-cardano-tools}, + ouroboros-consensus-cardano:{ouroboros-consensus-cardano, unstable-cardano-tools}, ouroboros-consensus-protocol:unstable-protocol-testlib, - QuickCheck, tasty, tasty-hunit, tasty-quickcheck, text, unstable-cardano-tools, + other-modules: Test.Cardano.Tools.Headers @@ -688,8 +689,10 @@ executable gen-header optparse-applicative, ouroboros-consensus-cardano:unstable-cardano-tools, with-utf8, + other-modules: GenHeader.Parsers Paths_ouroboros_consensus_cardano + autogen-modules: Paths_ouroboros_consensus_cardano diff --git a/ouroboros-consensus-protocol/ouroboros-consensus-protocol.cabal b/ouroboros-consensus-protocol/ouroboros-consensus-protocol.cabal index 51431234cc..8e04317c92 100644 --- a/ouroboros-consensus-protocol/ouroboros-consensus-protocol.cabal +++ b/ouroboros-consensus-protocol/ouroboros-consensus-protocol.cabal @@ -87,6 +87,7 @@ library unstable-protocol-testlib exposed-modules: Test.Consensus.Protocol.Serialisation.Generators Test.Ouroboros.Consensus.Protocol.Praos.Header + build-depends: QuickCheck, aeson, @@ -103,7 +104,7 @@ library unstable-protocol-testlib cardano-slotting, containers, ouroboros-consensus-protocol, - text + text, test-suite protocol-test import: common-test From 76ceb6f04b02ee486e29f7e50a856ba7fd6f415b Mon Sep 17 00:00:00 2001 From: Arnaud Bailly Date: Tue, 29 Oct 2024 07:46:40 +0100 Subject: [PATCH 08/11] Added changelog entry for o-c-cardano --- .../20241029_062000_abailly_header_validation_test.md | 3 +++ 1 file changed, 3 insertions(+) create mode 100644 ouroboros-consensus-cardano/changelog.d/20241029_062000_abailly_header_validation_test.md diff --git a/ouroboros-consensus-cardano/changelog.d/20241029_062000_abailly_header_validation_test.md b/ouroboros-consensus-cardano/changelog.d/20241029_062000_abailly_header_validation_test.md new file mode 100644 index 0000000000..a26d5e6190 --- /dev/null +++ b/ouroboros-consensus-cardano/changelog.d/20241029_062000_abailly_header_validation_test.md @@ -0,0 +1,3 @@ +### Patch + +- Introduce generators and properties to test header validation logic From c5eeeb2b06959a3194637dca412e183978e78436 Mon Sep 17 00:00:00 2001 From: Arnaud Bailly Date: Tue, 29 Oct 2024 08:00:39 +0100 Subject: [PATCH 09/11] Run stylish haskell --- .../Test/Ouroboros/Consensus/Protocol/Praos/Header.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs b/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs index 59131e6d60..d2618d1ed3 100644 --- a/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs +++ b/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs @@ -14,8 +14,8 @@ import Cardano.Crypto.DSIGN (DSIGNAlgorithm (SignKeyDSIGN, genKeyDSIGN, rawSerialiseSignKeyDSIGN), Ed25519DSIGN, deriveVerKeyDSIGN, rawDeserialiseSignKeyDSIGN) -import Cardano.Crypto.Hash (Blake2b_256, Hash, hashWith, hashFromBytes, - hashToBytes) +import Cardano.Crypto.Hash (Blake2b_256, Hash, hashFromBytes, + hashToBytes, hashWith) import qualified Cardano.Crypto.KES as KES import Cardano.Crypto.KES.Class (genKeyKES, rawDeserialiseSignKeyKES, rawSerialiseSignKeyKES) @@ -28,8 +28,8 @@ import qualified Cardano.Crypto.VRF.Praos as VRF import Cardano.Ledger.BaseTypes (ActiveSlotCoeff, Nonce (..), PositiveUnitInterval, ProtVer (..), Version, activeSlotVal, boundRational, mkActiveSlotCoeff, natVersion) -import Cardano.Ledger.Binary (MaxVersion, decCBOR, decodeFullAnnotator, - serialize') +import Cardano.Ledger.Binary (MaxVersion, decCBOR, + decodeFullAnnotator, serialize') import Cardano.Ledger.Keys (KeyHash, KeyRole (BlockIssuer), VKey (..), hashKey, signedDSIGN) import Cardano.Protocol.TPraos.BHeader (HashHeader (..), From a0d5dd26ef8d75dd9c463fa04a458f84c090e754 Mon Sep 17 00:00:00 2001 From: Arnaud Bailly Date: Tue, 12 Nov 2024 10:08:36 +0100 Subject: [PATCH 10/11] Address review comments * remove changelog entry * add explicit export list * use generic JSON derivation --- ...9_062000_abailly_header_validation_test.md | 3 - .../Cardano/Tools/Headers.hs | 8 ++- .../Consensus/Protocol/Praos/Header.hs | 63 +++++++++---------- 3 files changed, 34 insertions(+), 40 deletions(-) delete mode 100644 ouroboros-consensus-cardano/changelog.d/20241029_062000_abailly_header_validation_test.md diff --git a/ouroboros-consensus-cardano/changelog.d/20241029_062000_abailly_header_validation_test.md b/ouroboros-consensus-cardano/changelog.d/20241029_062000_abailly_header_validation_test.md deleted file mode 100644 index a26d5e6190..0000000000 --- a/ouroboros-consensus-cardano/changelog.d/20241029_062000_abailly_header_validation_test.md +++ /dev/null @@ -1,3 +0,0 @@ -### Patch - -- Introduce generators and properties to test header validation logic diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/Headers.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/Headers.hs index ed6447969a..f98b8b60c5 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/Headers.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/Headers.hs @@ -2,10 +2,14 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -Wno-missing-export-lists #-} -- | Tooling to generate and validate (Praos) headers. -module Cardano.Tools.Headers where +module Cardano.Tools.Headers ( + Options (..) + , ValidationResult (..) + , run + , validate + ) where import Cardano.Crypto.DSIGN (deriveVerKeyDSIGN) import Cardano.Crypto.VRF diff --git a/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs b/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs index d2618d1ed3..73862735ac 100644 --- a/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs +++ b/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} @@ -6,9 +7,18 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -Wno-missing-export-lists #-} -module Test.Ouroboros.Consensus.Protocol.Praos.Header where +module Test.Ouroboros.Consensus.Protocol.Praos.Header ( + GeneratorContext (..) + , MutatedHeader (..) + , Mutation (..) + , Sample (..) + , expectedError + , genContext + , genMutatedHeader + , genSample + , generateSamples + ) where import Cardano.Crypto.DSIGN (DSIGNAlgorithm (SignKeyDSIGN, genKeyDSIGN, rawSerialiseSignKeyDSIGN), @@ -38,7 +48,7 @@ import Cardano.Protocol.TPraos.OCert (KESPeriod (..), OCert (..), OCertSignable (..)) import Cardano.Slotting.Block (BlockNo (..)) import Cardano.Slotting.Slot (SlotNo (..)) -import Data.Aeson ((.:), (.=)) +import Data.Aeson (defaultOptions, (.:), (.=)) import qualified Data.Aeson as Json import Data.Bifunctor (second) import Data.ByteString (ByteString) @@ -53,6 +63,7 @@ import Data.Proxy (Proxy (..)) import Data.Ratio ((%)) import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Word (Word64) +import GHC.Generics (Generic) import Ouroboros.Consensus.Protocol.Praos (PraosValidationErr (..)) import Ouroboros.Consensus.Protocol.Praos.Header (Header, HeaderBody (..), pattern Header) @@ -60,7 +71,7 @@ import Ouroboros.Consensus.Protocol.Praos.VRF (InputVRF, mkInputVRF, vrfLeaderValue) import Ouroboros.Consensus.Protocol.TPraos (StandardCrypto) import Test.QuickCheck (Gen, arbitrary, choose, frequency, generate, - getPositive, resize, shrinkList, sized, suchThat, vectorOf) + getPositive, resize, sized, suchThat, vectorOf) -- * Test Vectors @@ -93,9 +104,6 @@ genMutatedHeader context = do mutation <- genMutation header mutate context header mutation -shrinkSample :: Sample -> [Sample] -shrinkSample Sample{sample} = Sample <$> shrinkList (const []) sample - mutate :: GeneratorContext -> Header StandardCrypto -> Mutation -> Gen (GeneratorContext, MutatedHeader) mutate context header mutation = second (\h -> MutatedHeader{header = h, mutation}) <$> mutated @@ -172,28 +180,12 @@ data Mutation MutateCounterOver1 | -- | Mutate certificate counter to be lower than expected MutateCounterUnder - deriving (Eq, Show) + deriving (Eq, Show, Generic) instance Json.ToJSON Mutation where - toJSON = \case - NoMutation -> "NoMutation" - MutateKESKey -> "MutateKESKey" - MutateColdKey -> "MutateColdKey" - MutateKESPeriod -> "MutateKESPeriod" - MutateKESPeriodBefore -> "MutateKESPeriodBefore" - MutateCounterOver1 -> "MutateCounterOver1" - MutateCounterUnder -> "MutateCounterUnder" - -instance Json.FromJSON Mutation where - parseJSON = \case - "NoMutation" -> pure NoMutation - "MutateKESKey" -> pure MutateKESKey - "MutateColdKey" -> pure MutateColdKey - "MutateKESPeriod" -> pure MutateKESPeriod - "MutateKESPeriodBefore" -> pure MutateKESPeriodBefore - "MutateCounterOver1" -> pure MutateCounterOver1 - "MutateCounterUnder" -> pure MutateCounterUnder - _ -> fail "Invalid mutation" + toEncoding = Json.genericToEncoding defaultOptions + +instance Json.FromJSON Mutation expectedError :: Mutation -> (PraosValidationErr StandardCrypto -> Bool) expectedError = \case @@ -226,14 +218,15 @@ genMutation header = , (1, pure MutateKESPeriod) , (1, pure MutateKESPeriodBefore) , (1, pure MutateCounterUnder) - ] <> maybeCounterOver1 - where - Header body _ = header - OCert{ocertN} = hbOCert body - maybeCounterOver1 = - if ocertN > 10 - then [(1, pure MutateCounterOver1)] - else [] + ] + <> maybeCounterOver1 + where + Header body _ = header + OCert{ocertN} = hbOCert body + maybeCounterOver1 = + if ocertN > 10 + then [(1, pure MutateCounterOver1)] + else [] data MutatedHeader = MutatedHeader { header :: !(Header StandardCrypto) From 0653bac90377c2ce2b907720d1090810afe385d5 Mon Sep 17 00:00:00 2001 From: Arnaud Bailly Date: Thu, 14 Nov 2024 11:01:18 +0100 Subject: [PATCH 11/11] Address reviewers comments --- .../20241029_062000_abailly_header_validation_test.md | 3 ++- .../Ouroboros/Consensus/Protocol/Praos.hs | 4 ++-- .../Test/Ouroboros/Consensus/Protocol/Praos/Header.hs | 4 ++-- 3 files changed, 6 insertions(+), 5 deletions(-) diff --git a/ouroboros-consensus-protocol/changelog.d/20241029_062000_abailly_header_validation_test.md b/ouroboros-consensus-protocol/changelog.d/20241029_062000_abailly_header_validation_test.md index a26d5e6190..17497d3350 100644 --- a/ouroboros-consensus-protocol/changelog.d/20241029_062000_abailly_header_validation_test.md +++ b/ouroboros-consensus-protocol/changelog.d/20241029_062000_abailly_header_validation_test.md @@ -1,3 +1,4 @@ ### Patch -- Introduce generators and properties to test header validation logic +- Expose functions to simplify thorough testing of header validation + logic, and introduce generators and properties to actually test it. diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs index eda30f1dbd..3ddbcf200b 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs @@ -531,8 +531,8 @@ validateVRFSignature :: ActiveSlotCoeff -> Views.HeaderView c -> Except (PraosValidationErr c) () -validateVRFSignature eta0 (Views.lvPoolDistr -> SL.PoolDistr pd _) f = - doValidateVRFSignature eta0 pd f +validateVRFSignature eta0 (Views.lvPoolDistr -> SL.PoolDistr pd _) = + doValidateVRFSignature eta0 pd -- NOTE: this function is much easier to test than 'validateVRFSignature' because we don't need -- to construct a 'PraosConfig' nor 'LedgerView' to test it. diff --git a/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs b/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs index 73862735ac..09c9f65c6e 100644 --- a/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs +++ b/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs @@ -82,7 +82,7 @@ generateSamples n = generate (resize n genSample) testVersion :: Version testVersion = natVersion @MaxVersion -data Sample = Sample {sample :: ![(GeneratorContext, MutatedHeader)]} +newtype Sample = Sample {sample :: [(GeneratorContext, MutatedHeader)]} deriving (Show, Eq) instance Json.ToJSON Sample where @@ -187,7 +187,7 @@ instance Json.ToJSON Mutation where instance Json.FromJSON Mutation -expectedError :: Mutation -> (PraosValidationErr StandardCrypto -> Bool) +expectedError :: Mutation -> PraosValidationErr StandardCrypto -> Bool expectedError = \case NoMutation -> const False MutateKESKey -> \case