{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
module Cardano.Tools.Headers
( Options (..)
, ValidationResult (..)
, run
, validate
) where
import Cardano.Crypto.DSIGN (deriveVerKeyDSIGN)
import Cardano.Crypto.VRF.Class (deriveVerKeyVRF)
import Cardano.Ledger.Api (ConwayEra)
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Compactible (toCompact)
import Cardano.Ledger.Keys (VKey (..), hashKey)
import Cardano.Ledger.State (IndividualPoolStake (..))
import Cardano.Prelude
( ExitCode (..)
, exitWith
, forM_
, hPutStrLn
, stderr
)
import Cardano.Protocol.Crypto (StandardCrypto, hashVerKeyVRF)
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
data Options
= Generate Int
| Validate
run :: Options -> IO ()
run :: Options -> IO ()
run = \case
Generate Int
n -> do
sample <- Int -> IO Sample
generateSamples Int
n
LBS.putStr $ Json.encode sample <> "\n"
Options
Validate ->
ByteString -> Either String Sample
forall a. FromJSON a => ByteString -> Either String a
Json.eitherDecode (ByteString -> Either String Sample)
-> IO ByteString -> IO (Either String Sample)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ByteString
LBS.getContents IO (Either String Sample)
-> (Either String Sample -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left String
err -> Handle -> String -> IO ()
forall a (m :: * -> *). (Print a, MonadIO m) => Handle -> a -> m ()
forall (m :: * -> *). MonadIO m => Handle -> String -> m ()
hPutStrLn Handle
stderr String
err IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)
Right Sample{[(GeneratorContext, MutatedHeader)]
sample :: [(GeneratorContext, MutatedHeader)]
sample :: Sample -> [(GeneratorContext, MutatedHeader)]
sample} ->
[(GeneratorContext, MutatedHeader)]
-> ((GeneratorContext, MutatedHeader) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(GeneratorContext, MutatedHeader)]
sample (((GeneratorContext, MutatedHeader) -> IO ()) -> IO ())
-> ((GeneratorContext, MutatedHeader) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(GeneratorContext
context, MutatedHeader
mutatedHeader) -> do
ValidationResult -> IO ()
forall a. Show a => a -> IO ()
print (ValidationResult -> IO ()) -> ValidationResult -> IO ()
forall a b. (a -> b) -> a -> b
$ GeneratorContext -> MutatedHeader -> ValidationResult
validate GeneratorContext
context MutatedHeader
mutatedHeader
data ValidationResult = Valid !Mutation | Invalid !Mutation !String
deriving (ValidationResult -> ValidationResult -> Bool
(ValidationResult -> ValidationResult -> Bool)
-> (ValidationResult -> ValidationResult -> Bool)
-> Eq ValidationResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ValidationResult -> ValidationResult -> Bool
== :: ValidationResult -> ValidationResult -> Bool
$c/= :: ValidationResult -> ValidationResult -> Bool
/= :: ValidationResult -> ValidationResult -> Bool
Eq, Int -> ValidationResult -> ShowS
[ValidationResult] -> ShowS
ValidationResult -> String
(Int -> ValidationResult -> ShowS)
-> (ValidationResult -> String)
-> ([ValidationResult] -> ShowS)
-> Show ValidationResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ValidationResult -> ShowS
showsPrec :: Int -> ValidationResult -> ShowS
$cshow :: ValidationResult -> String
show :: ValidationResult -> String
$cshowList :: [ValidationResult] -> ShowS
showList :: [ValidationResult] -> ShowS
Show)
validate :: GeneratorContext -> MutatedHeader -> ValidationResult
validate :: GeneratorContext -> MutatedHeader -> ValidationResult
validate GeneratorContext
context MutatedHeader{Header StandardCrypto
header :: MutatedHeader -> Header StandardCrypto
header :: Header StandardCrypto
header, Mutation
mutation :: MutatedHeader -> Mutation
mutation :: Mutation
mutation} =
case (Except (PraosValidationErr StandardCrypto) ()
-> Either (PraosValidationErr StandardCrypto) ()
forall e a. Except e a -> Either e a
runExcept (Except (PraosValidationErr StandardCrypto) ()
-> Either (PraosValidationErr StandardCrypto) ())
-> Except (PraosValidationErr StandardCrypto) ()
-> Either (PraosValidationErr StandardCrypto) ()
forall a b. (a -> b) -> a -> b
$ Except (PraosValidationErr StandardCrypto) ()
validateKES Except (PraosValidationErr StandardCrypto) ()
-> Except (PraosValidationErr StandardCrypto) ()
-> Except (PraosValidationErr StandardCrypto) ()
forall a b.
ExceptT (PraosValidationErr StandardCrypto) Identity a
-> ExceptT (PraosValidationErr StandardCrypto) Identity b
-> ExceptT (PraosValidationErr StandardCrypto) Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Except (PraosValidationErr StandardCrypto) ()
validateVRF, Mutation
mutation) of
(Left PraosValidationErr StandardCrypto
err, Mutation
mut) | Mutation -> PraosValidationErr StandardCrypto -> Bool
expectedError Mutation
mut PraosValidationErr StandardCrypto
err -> Mutation -> ValidationResult
Valid Mutation
mut
(Left PraosValidationErr StandardCrypto
err, Mutation
mut) -> Mutation -> String -> ValidationResult
Invalid Mutation
mut (PraosValidationErr StandardCrypto -> String
forall a. Show a => a -> String
show PraosValidationErr StandardCrypto
err)
(Right ()
_, Mutation
NoMutation) -> Mutation -> ValidationResult
Valid Mutation
NoMutation
(Right ()
_, Mutation
mut) -> Mutation -> String -> ValidationResult
Invalid Mutation
mut (String -> ValidationResult) -> String -> ValidationResult
forall a b. (a -> b) -> a -> b
$ String
"Expected error from mutation " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Mutation -> String
forall a. Show a => a -> String
show Mutation
mut String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", but validation succeeded"
where
GeneratorContext
{ Word64
praosSlotsPerKESPeriod :: Word64
praosSlotsPerKESPeriod :: GeneratorContext -> Word64
praosSlotsPerKESPeriod
, Word64
praosMaxKESEvo :: Word64
praosMaxKESEvo :: GeneratorContext -> Word64
praosMaxKESEvo
, Nonce
nonce :: Nonce
nonce :: GeneratorContext -> Nonce
nonce
, SignKeyDSIGN Ed25519DSIGN
coldSignKey :: SignKeyDSIGN Ed25519DSIGN
coldSignKey :: GeneratorContext -> SignKeyDSIGN Ed25519DSIGN
coldSignKey
, SignKeyVRF PraosVRF
vrfSignKey :: SignKeyVRF PraosVRF
vrfSignKey :: GeneratorContext -> SignKeyVRF PraosVRF
vrfSignKey
, Map (KeyHash 'BlockIssuer) Word64
ocertCounters :: Map (KeyHash 'BlockIssuer) Word64
ocertCounters :: GeneratorContext -> Map (KeyHash 'BlockIssuer) Word64
ocertCounters
, ActiveSlotCoeff
activeSlotCoeff :: ActiveSlotCoeff
activeSlotCoeff :: GeneratorContext -> ActiveSlotCoeff
activeSlotCoeff
} = GeneratorContext
context
coin :: Integer -> CompactForm Coin
coin = Maybe (CompactForm Coin) -> CompactForm Coin
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (CompactForm Coin) -> CompactForm Coin)
-> (Integer -> Maybe (CompactForm Coin))
-> Integer
-> CompactForm Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coin -> Maybe (CompactForm Coin)
forall a. Compactible a => a -> Maybe (CompactForm a)
toCompact (Coin -> Maybe (CompactForm Coin))
-> (Integer -> Coin) -> Integer -> Maybe (CompactForm Coin)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Coin
Coin
ownsAllStake :: VRFVerKeyHash 'StakePoolVRF -> IndividualPoolStake
ownsAllStake VRFVerKeyHash 'StakePoolVRF
vrfKey = Rational
-> CompactForm Coin
-> VRFVerKeyHash 'StakePoolVRF
-> IndividualPoolStake
IndividualPoolStake Rational
1 (Integer -> CompactForm Coin
coin Integer
1) VRFVerKeyHash 'StakePoolVRF
vrfKey
poolDistr :: Map (KeyHash kd) IndividualPoolStake
poolDistr = [(KeyHash kd, IndividualPoolStake)]
-> Map (KeyHash kd) IndividualPoolStake
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(KeyHash kd
forall {kd :: KeyRole}. KeyHash kd
poolId, VRFVerKeyHash 'StakePoolVRF -> IndividualPoolStake
ownsAllStake VRFVerKeyHash 'StakePoolVRF
forall {r :: KeyRoleVRF}. VRFVerKeyHash r
hashVRFKey)]
poolId :: KeyHash kd
poolId = VKey kd -> KeyHash kd
forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey (VKey kd -> KeyHash kd) -> VKey kd -> KeyHash kd
forall a b. (a -> b) -> a -> b
$ VerKeyDSIGN Ed25519DSIGN -> VKey kd
forall (kd :: KeyRole). VerKeyDSIGN Ed25519DSIGN -> VKey kd
VKey (VerKeyDSIGN Ed25519DSIGN -> VKey kd)
-> VerKeyDSIGN Ed25519DSIGN -> VKey kd
forall a b. (a -> b) -> a -> b
$ SignKeyDSIGN Ed25519DSIGN -> VerKeyDSIGN Ed25519DSIGN
forall v. DSIGNAlgorithm v => SignKeyDSIGN v -> VerKeyDSIGN v
deriveVerKeyDSIGN SignKeyDSIGN Ed25519DSIGN
coldSignKey
hashVRFKey :: VRFVerKeyHash r
hashVRFKey = forall c (r :: KeyRoleVRF).
Crypto c =>
VerKeyVRF (VRF c) -> VRFVerKeyHash r
hashVerKeyVRF @StandardCrypto (VerKeyVRF (VRF StandardCrypto) -> VRFVerKeyHash r)
-> VerKeyVRF (VRF StandardCrypto) -> VRFVerKeyHash r
forall a b. (a -> b) -> a -> b
$ SignKeyVRF PraosVRF -> VerKeyVRF PraosVRF
forall v. VRFAlgorithm v => SignKeyVRF v -> VerKeyVRF v
deriveVerKeyVRF SignKeyVRF PraosVRF
vrfSignKey
headerView :: ValidateView (BlockProtocol ConwayBlock)
headerView = forall blk.
BlockSupportsProtocol blk =>
BlockConfig blk -> Header blk -> ValidateView (BlockProtocol blk)
validateView @ConwayBlock BlockConfig ConwayBlock
forall a. HasCallStack => a
undefined (ShelleyProtocolHeader (Praos StandardCrypto) -> Header ConwayBlock
forall proto era.
ShelleyCompatible proto era =>
ShelleyProtocolHeader proto -> Header (ShelleyBlock proto era)
mkShelleyHeader ShelleyProtocolHeader (Praos StandardCrypto)
Header StandardCrypto
header)
validateKES :: Except (PraosValidationErr StandardCrypto) ()
validateKES = Word64
-> Word64
-> Map (KeyHash 'StakePool) IndividualPoolStake
-> Map (KeyHash 'BlockIssuer) Word64
-> HeaderView StandardCrypto
-> Except (PraosValidationErr StandardCrypto) ()
forall c.
PraosCrypto c =>
Word64
-> Word64
-> Map (KeyHash 'StakePool) IndividualPoolStake
-> Map (KeyHash 'BlockIssuer) Word64
-> HeaderView c
-> Except (PraosValidationErr c) ()
doValidateKESSignature Word64
praosMaxKESEvo Word64
praosSlotsPerKESPeriod Map (KeyHash 'StakePool) IndividualPoolStake
forall {kd :: KeyRole}. Map (KeyHash kd) IndividualPoolStake
poolDistr Map (KeyHash 'BlockIssuer) Word64
ocertCounters HeaderView StandardCrypto
headerView
validateVRF :: Except (PraosValidationErr StandardCrypto) ()
validateVRF = Nonce
-> Map (KeyHash 'StakePool) IndividualPoolStake
-> ActiveSlotCoeff
-> HeaderView StandardCrypto
-> Except (PraosValidationErr StandardCrypto) ()
forall c.
PraosCrypto c =>
Nonce
-> Map (KeyHash 'StakePool) IndividualPoolStake
-> ActiveSlotCoeff
-> HeaderView c
-> Except (PraosValidationErr c) ()
doValidateVRFSignature Nonce
nonce Map (KeyHash 'StakePool) IndividualPoolStake
forall {kd :: KeyRole}. Map (KeyHash kd) IndividualPoolStake
poolDistr ActiveSlotCoeff
activeSlotCoeff HeaderView StandardCrypto
headerView