Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Praos headers validation properties and generators #1285

Merged
merged 11 commits into from
Nov 14, 2024
46 changes: 46 additions & 0 deletions ouroboros-consensus-cardano/app/GenHeader/Parsers.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,46 @@
module GenHeader.Parsers (parseOptions) 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"
)
12 changes: 12 additions & 0 deletions ouroboros-consensus-cardano/app/gen-header.hs
Original file line number Diff line number Diff line change
@@ -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
30 changes: 29 additions & 1 deletion ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand Down Expand Up @@ -552,6 +553,7 @@ library unstable-cardano-tools
ouroboros-consensus ^>=0.21,
ouroboros-consensus-cardano,
ouroboros-consensus-diffusion ^>=0.18,
ouroboros-consensus-protocol:unstable-protocol-testlib,
ouroboros-consensus-protocol ^>=0.9,
ouroboros-network,
ouroboros-network-api,
Expand Down Expand Up @@ -662,9 +664,35 @@ 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:{ouroboros-consensus-cardano, unstable-cardano-tools},
ouroboros-consensus-protocol:unstable-protocol-testlib,
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

autogen-modules:
Paths_ouroboros_consensus_cardano
abailly marked this conversation as resolved.
Show resolved Hide resolved
Original file line number Diff line number Diff line change
@@ -0,0 +1,81 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}

-- | Tooling to generate and validate (Praos) headers.
module Cardano.Tools.Headers (
Options (..)
, ValidationResult (..)
, run
, validate
) where

import Cardano.Crypto.DSIGN (deriveVerKeyDSIGN)
import Cardano.Crypto.VRF
(VRFAlgorithm (deriveVerKeyVRF, hashVerKeyVRF))
import Cardano.Ledger.Api (ConwayEra, StandardCrypto)
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.Lazy as LBS
import qualified Data.Map as Map
import Data.Maybe (fromJust)
import Ouroboros.Consensus.Block (validateView)
import Ouroboros.Consensus.Protocol.Praos (Praos,
doValidateKESSignature, doValidateVRFSignature)
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
abailly marked this conversation as resolved.
Show resolved Hide resolved
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, praosMaxKESEvo, nonce, coldSignKey, vrfSignKey, ocertCounters, activeSlotCoeff} = context
-- TODO: get these from the context
coin = fromJust . toCompact . Coin
ownsAllStake vrfKey = IndividualPoolStake 1 (coin 1) vrfKey
poolDistr = Map.fromList [(poolId, ownsAllStake hashVRFKey)]
abailly marked this conversation as resolved.
Show resolved Hide resolved
poolId = hashKey $ VKey $ deriveVerKeyDSIGN coldSignKey
hashVRFKey = hashVerKeyVRF $ deriveVerKeyVRF vrfSignKey

headerView = validateView @ConwayBlock undefined (mkShelleyHeader header)
validateKES = doValidateKESSignature praosMaxKESEvo praosSlotsPerKESPeriod poolDistr ocertCounters headerView
validateVRF = doValidateVRFSignature nonce poolDistr activeSlotCoeff headerView
2 changes: 2 additions & 0 deletions ouroboros-consensus-cardano/test/tools-test/Main.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -114,6 +115,7 @@ tests :: TestTree
tests =
testGroup "cardano-tools"
[ testCaseSteps "synthesize and analyse: blockCount\n" blockCountTest
, Test.Cardano.Tools.Headers.tests
]

main :: IO ()
Expand Down
Original file line number Diff line number Diff line change
@@ -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
Original file line number Diff line number Diff line change
@@ -0,0 +1,4 @@
### Patch

- Expose functions to simplify thorough testing of header validation
logic, and introduce generators and properties to actually test it.
Original file line number Diff line number Diff line change
Expand Up @@ -84,16 +84,27 @@ 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
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -29,6 +29,9 @@ module Ouroboros.Consensus.Protocol.Praos (
, Ticked (..)
, forgePraosFields
, praosCheckCanForge
-- * For testing purposes
, doValidateKESSignature
, doValidateVRFSignature
) where

import Cardano.Binary (FromCBOR (..), ToCBOR (..), enforceSize)
Expand Down Expand Up @@ -345,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
Expand Down Expand Up @@ -527,7 +531,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 _) =
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.
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
Expand Down Expand Up @@ -557,12 +574,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

Expand All @@ -573,7 +603,7 @@ validateKESSignature
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
Expand All @@ -594,7 +624,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

Expand Down Expand Up @@ -727,6 +757,7 @@ instance
Util
-------------------------------------------------------------------------------}

-- | Check value and raise error if it is false.
(?!) :: Bool -> e -> Except e ()
a ?! b = unless a $ throwError b

Expand Down
Loading
Loading