{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}

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)
  , Ed25519DSIGN
  , deriveVerKeyDSIGN
  , rawDeserialiseSignKeyDSIGN
  )
import Cardano.Crypto.Hash
  ( Blake2b_256
  , Hash
  , hashFromBytes
  , hashToBytes
  , hashWith
  )
import qualified Cardano.Crypto.KES as KES
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 (defaultOptions, (.:), (.=))
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 GHC.Generics (Generic)
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
  , sized
  , suchThat
  , vectorOf
  )

-- * Test Vectors

generateSamples :: Int -> IO Sample
generateSamples :: Int -> IO Sample
generateSamples Int
n = Gen Sample -> IO Sample
forall a. Gen a -> IO a
generate (Int -> Gen Sample -> Gen Sample
forall a. HasCallStack => Int -> Gen a -> Gen a
resize Int
n Gen Sample
genSample)

-- FIXME: Should be defined according to some Era
testVersion :: Version
testVersion :: Version
testVersion = forall (v :: Natural).
(KnownNat v, 0 <= v, v <= MaxVersion) =>
Version
natVersion @MaxVersion

newtype Sample = Sample {Sample -> [(GeneratorContext, MutatedHeader)]
sample :: [(GeneratorContext, MutatedHeader)]}
  deriving (Int -> Sample -> ShowS
[Sample] -> ShowS
Sample -> String
(Int -> Sample -> ShowS)
-> (Sample -> String) -> ([Sample] -> ShowS) -> Show Sample
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Sample -> ShowS
showsPrec :: Int -> Sample -> ShowS
$cshow :: Sample -> String
show :: Sample -> String
$cshowList :: [Sample] -> ShowS
showList :: [Sample] -> ShowS
Show, Sample -> Sample -> Bool
(Sample -> Sample -> Bool)
-> (Sample -> Sample -> Bool) -> Eq Sample
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Sample -> Sample -> Bool
== :: Sample -> Sample -> Bool
$c/= :: Sample -> Sample -> Bool
/= :: Sample -> Sample -> Bool
Eq)

instance Json.ToJSON Sample where
  toJSON :: Sample -> Value
toJSON Sample{[(GeneratorContext, MutatedHeader)]
sample :: Sample -> [(GeneratorContext, MutatedHeader)]
sample :: [(GeneratorContext, MutatedHeader)]
sample} = [(GeneratorContext, MutatedHeader)] -> Value
forall a. ToJSON a => a -> Value
Json.toJSON [(GeneratorContext, MutatedHeader)]
sample

instance Json.FromJSON Sample where
  parseJSON :: Value -> Parser Sample
parseJSON = String -> (Array -> Parser Sample) -> Value -> Parser Sample
forall a. String -> (Array -> Parser a) -> Value -> Parser a
Json.withArray String
"Sample" ((Array -> Parser Sample) -> Value -> Parser Sample)
-> (Array -> Parser Sample) -> Value -> Parser Sample
forall a b. (a -> b) -> a -> b
$ \Array
arr -> do
    [(GeneratorContext, MutatedHeader)] -> Sample
Sample ([(GeneratorContext, MutatedHeader)] -> Sample)
-> (Vector (GeneratorContext, MutatedHeader)
    -> [(GeneratorContext, MutatedHeader)])
-> Vector (GeneratorContext, MutatedHeader)
-> Sample
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector (GeneratorContext, MutatedHeader)
-> [(GeneratorContext, MutatedHeader)]
forall a. Vector a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Vector (GeneratorContext, MutatedHeader) -> Sample)
-> Parser (Vector (GeneratorContext, MutatedHeader))
-> Parser Sample
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> Parser (GeneratorContext, MutatedHeader))
-> Array -> Parser (Vector (GeneratorContext, MutatedHeader))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Vector a -> f (Vector b)
traverse Value -> Parser (GeneratorContext, MutatedHeader)
forall a. FromJSON a => Value -> Parser a
Json.parseJSON Array
arr

genSample :: Gen Sample
genSample :: Gen Sample
genSample = do
  context <- Gen GeneratorContext
genContext
  sample <- sized $ \Int
n -> Int
-> Gen (GeneratorContext, MutatedHeader)
-> Gen [(GeneratorContext, MutatedHeader)]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
n (Gen (GeneratorContext, MutatedHeader)
 -> Gen [(GeneratorContext, MutatedHeader)])
-> Gen (GeneratorContext, MutatedHeader)
-> Gen [(GeneratorContext, MutatedHeader)]
forall a b. (a -> b) -> a -> b
$ GeneratorContext -> Gen (GeneratorContext, MutatedHeader)
genMutatedHeader GeneratorContext
context
  pure $ Sample{sample}

genMutatedHeader :: GeneratorContext -> Gen (GeneratorContext, MutatedHeader)
genMutatedHeader :: GeneratorContext -> Gen (GeneratorContext, MutatedHeader)
genMutatedHeader GeneratorContext
context = do
  header <- GeneratorContext -> Gen (Header StandardCrypto)
genHeader GeneratorContext
context
  mutation <- genMutation header
  mutate context header mutation

mutate ::
  GeneratorContext -> Header StandardCrypto -> Mutation -> Gen (GeneratorContext, MutatedHeader)
mutate :: GeneratorContext
-> Header StandardCrypto
-> Mutation
-> Gen (GeneratorContext, MutatedHeader)
mutate GeneratorContext
context Header StandardCrypto
header Mutation
mutation =
  (Header StandardCrypto -> MutatedHeader)
-> (GeneratorContext, Header StandardCrypto)
-> (GeneratorContext, MutatedHeader)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (\Header StandardCrypto
h -> MutatedHeader{header :: Header StandardCrypto
header = Header StandardCrypto
h, Mutation
mutation :: Mutation
mutation :: Mutation
mutation}) ((GeneratorContext, Header StandardCrypto)
 -> (GeneratorContext, MutatedHeader))
-> Gen (GeneratorContext, Header StandardCrypto)
-> Gen (GeneratorContext, MutatedHeader)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (GeneratorContext, Header StandardCrypto)
mutated
 where
  mutated :: Gen (GeneratorContext, Header StandardCrypto)
mutated =
    case Mutation
mutation of
      Mutation
NoMutation -> (GeneratorContext, Header StandardCrypto)
-> Gen (GeneratorContext, Header StandardCrypto)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GeneratorContext
context, Header StandardCrypto
header)
      Mutation
MutateKESKey -> do
        let Header HeaderBody StandardCrypto
body SignedKES (KES StandardCrypto) (HeaderBody StandardCrypto)
_ = Header StandardCrypto
header
        newKESSignKey <- ByteString -> KESKey
newKESSigningKey (ByteString -> KESKey) -> Gen ByteString -> Gen KESKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ByteString
gen32Bytes
        KESPeriod kesPeriod <- genValidKESPeriod (hbSlotNo body) praosSlotsPerKESPeriod
        let sig' = ContextKES (Sum6KES Ed25519DSIGN Blake2b_256)
-> Word
-> HeaderBody StandardCrypto
-> KESKey
-> SigKES (Sum6KES Ed25519DSIGN Blake2b_256)
forall v a.
(UnsoundPureKESAlgorithm v, Signable v a) =>
ContextKES v -> Word -> a -> UnsoundPureSignKeyKES v -> SigKES v
forall a.
Signable (Sum6KES Ed25519DSIGN Blake2b_256) a =>
ContextKES (Sum6KES Ed25519DSIGN Blake2b_256)
-> Word -> a -> KESKey -> SigKES (Sum6KES Ed25519DSIGN Blake2b_256)
KES.unsoundPureSignKES () Word
kesPeriod HeaderBody StandardCrypto
body KESKey
newKESSignKey
        pure (context, Header body (KES.SignedKES sig'))
      Mutation
MutateColdKey -> do
        let Header HeaderBody StandardCrypto
body SignedKES (KES StandardCrypto) (HeaderBody StandardCrypto)
_ = Header StandardCrypto
header
        newColdSignKey <- Seed -> SignKeyDSIGN Ed25519DSIGN
forall v. DSIGNAlgorithm v => Seed -> SignKeyDSIGN v
genKeyDSIGN (Seed -> SignKeyDSIGN Ed25519DSIGN)
-> (ByteString -> Seed) -> ByteString -> SignKeyDSIGN Ed25519DSIGN
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Seed
mkSeedFromBytes (ByteString -> SignKeyDSIGN Ed25519DSIGN)
-> Gen ByteString -> Gen (SignKeyDSIGN Ed25519DSIGN)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ByteString
gen32Bytes
        (hbOCert, KESPeriod kesPeriod) <- genCert (hbSlotNo body) context{coldSignKey = newColdSignKey}
        let newBody = HeaderBody StandardCrypto
body{hbOCert}
        let sig' = ContextKES (Sum6KES Ed25519DSIGN Blake2b_256)
-> Word
-> HeaderBody StandardCrypto
-> KESKey
-> SigKES (Sum6KES Ed25519DSIGN Blake2b_256)
forall v a.
(UnsoundPureKESAlgorithm v, Signable v a) =>
ContextKES v -> Word -> a -> UnsoundPureSignKeyKES v -> SigKES v
forall a.
Signable (Sum6KES Ed25519DSIGN Blake2b_256) a =>
ContextKES (Sum6KES Ed25519DSIGN Blake2b_256)
-> Word -> a -> KESKey -> SigKES (Sum6KES Ed25519DSIGN Blake2b_256)
KES.unsoundPureSignKES () Word
kesPeriod HeaderBody StandardCrypto
newBody KESKey
kesSignKey
        pure (context, Header newBody (KES.SignedKES sig'))
      Mutation
MutateKESPeriod -> do
        let Header HeaderBody StandardCrypto
body SignedKES (KES StandardCrypto) (HeaderBody StandardCrypto)
_ = Header StandardCrypto
header
        KESPeriod kesPeriod' <- SlotNo -> Word64 -> Gen KESPeriod
genKESPeriodAfterLimit (HeaderBody StandardCrypto -> SlotNo
forall crypto. HeaderBody crypto -> SlotNo
hbSlotNo HeaderBody StandardCrypto
body) Word64
praosSlotsPerKESPeriod
        let newKESPeriod = Word -> KESPeriod
KESPeriod Word
kesPeriod'
        let oldOCert@OCert{ocertVkHot, ocertN} = hbOCert body
        let newBody =
              HeaderBody StandardCrypto
body
                { hbOCert =
                    oldOCert
                      { ocertKESPeriod = newKESPeriod
                      , ocertSigma = signedDSIGN coldSignKey $ OCertSignable ocertVkHot ocertN newKESPeriod
                      }
                }
        let sig' = ContextKES (Sum6KES Ed25519DSIGN Blake2b_256)
-> Word
-> HeaderBody StandardCrypto
-> KESKey
-> SigKES (Sum6KES Ed25519DSIGN Blake2b_256)
forall v a.
(UnsoundPureKESAlgorithm v, Signable v a) =>
ContextKES v -> Word -> a -> UnsoundPureSignKeyKES v -> SigKES v
forall a.
Signable (Sum6KES Ed25519DSIGN Blake2b_256) a =>
ContextKES (Sum6KES Ed25519DSIGN Blake2b_256)
-> Word -> a -> KESKey -> SigKES (Sum6KES Ed25519DSIGN Blake2b_256)
KES.unsoundPureSignKES () Word
kesPeriod' HeaderBody StandardCrypto
newBody KESKey
kesSignKey
        pure (context, Header newBody (KES.SignedKES sig'))
      Mutation
MutateKESPeriodBefore -> do
        let Header HeaderBody StandardCrypto
body SignedKES (KES StandardCrypto) (HeaderBody StandardCrypto)
_ = Header StandardCrypto
header
            OCert{ocertKESPeriod :: forall c. OCert c -> KESPeriod
ocertKESPeriod = KESPeriod Word
kesPeriod} = HeaderBody StandardCrypto -> OCert StandardCrypto
forall crypto. HeaderBody crypto -> OCert crypto
hbOCert HeaderBody StandardCrypto
body
        newSlotNo <- Word64 -> Word64 -> Word64 -> Gen SlotNo
genSlotAfterKESPeriod (Word -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
kesPeriod) Word64
praosMaxKESEvo Word64
praosSlotsPerKESPeriod
        let rho' = SlotNo -> Nonce -> InputVRF
mkInputVRF SlotNo
newSlotNo Nonce
nonce
            period' = SlotNo -> Word64
unSlotNo SlotNo
newSlotNo Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`div` Word64
praosSlotsPerKESPeriod
            hbVrfRes = ContextVRF PraosVRF
-> InputVRF
-> SignKeyVRF PraosVRF
-> CertifiedVRF PraosVRF InputVRF
forall v a.
(VRFAlgorithm v, Signable v a) =>
ContextVRF v -> a -> SignKeyVRF v -> CertifiedVRF v a
VRF.evalCertified () InputVRF
rho' SignKeyVRF PraosVRF
vrfSignKey
            newBody = HeaderBody StandardCrypto
body{hbSlotNo = newSlotNo, hbVrfRes}
            sig' = ContextKES (Sum6KES Ed25519DSIGN Blake2b_256)
-> Word
-> HeaderBody StandardCrypto
-> KESKey
-> SigKES (Sum6KES Ed25519DSIGN Blake2b_256)
forall v a.
(UnsoundPureKESAlgorithm v, Signable v a) =>
ContextKES v -> Word -> a -> UnsoundPureSignKeyKES v -> SigKES v
forall a.
Signable (Sum6KES Ed25519DSIGN Blake2b_256) a =>
ContextKES (Sum6KES Ed25519DSIGN Blake2b_256)
-> Word -> a -> KESKey -> SigKES (Sum6KES Ed25519DSIGN Blake2b_256)
KES.unsoundPureSignKES () (Word64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
period' Word -> Word -> Word
forall a. Num a => a -> a -> a
- Word
kesPeriod) HeaderBody StandardCrypto
newBody KESKey
kesSignKey
        pure (context, Header newBody (KES.SignedKES sig'))
      Mutation
MutateCounterOver1 -> do
        let poolId :: KeyHash 'BlockIssuer
poolId = KeyHash Any -> KeyHash 'BlockIssuer
forall a b. Coercible a b => a -> b
coerce (KeyHash Any -> KeyHash 'BlockIssuer)
-> KeyHash Any -> KeyHash 'BlockIssuer
forall a b. (a -> b) -> a -> b
$ VKey Any -> KeyHash Any
forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey (VKey Any -> KeyHash Any) -> VKey Any -> KeyHash Any
forall a b. (a -> b) -> a -> b
$ VerKeyDSIGN Ed25519DSIGN -> VKey Any
forall (kd :: KeyRole). VerKeyDSIGN Ed25519DSIGN -> VKey kd
VKey (VerKeyDSIGN Ed25519DSIGN -> VKey Any)
-> VerKeyDSIGN Ed25519DSIGN -> VKey Any
forall a b. (a -> b) -> a -> b
$ SignKeyDSIGN Ed25519DSIGN -> VerKeyDSIGN Ed25519DSIGN
forall v. DSIGNAlgorithm v => SignKeyDSIGN v -> VerKeyDSIGN v
deriveVerKeyDSIGN SignKeyDSIGN Ed25519DSIGN
coldSignKey
            Header HeaderBody StandardCrypto
body SignedKES (KES StandardCrypto) (HeaderBody StandardCrypto)
_ = Header StandardCrypto
header
            OCert{Word64
ocertN :: forall c. OCert c -> Word64
ocertN :: Word64
ocertN} = HeaderBody StandardCrypto -> OCert StandardCrypto
forall crypto. HeaderBody crypto -> OCert crypto
hbOCert HeaderBody StandardCrypto
body
        newCounter <- (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
0, Word64
ocertN Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
2)
        let context' = GeneratorContext
context{ocertCounters = Map.insert poolId newCounter (ocertCounters context)}
        pure (context', header)
      Mutation
MutateCounterUnder -> do
        let poolId :: KeyHash 'BlockIssuer
poolId = KeyHash Any -> KeyHash 'BlockIssuer
forall a b. Coercible a b => a -> b
coerce (KeyHash Any -> KeyHash 'BlockIssuer)
-> KeyHash Any -> KeyHash 'BlockIssuer
forall a b. (a -> b) -> a -> b
$ VKey Any -> KeyHash Any
forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey (VKey Any -> KeyHash Any) -> VKey Any -> KeyHash Any
forall a b. (a -> b) -> a -> b
$ VerKeyDSIGN Ed25519DSIGN -> VKey Any
forall (kd :: KeyRole). VerKeyDSIGN Ed25519DSIGN -> VKey kd
VKey (VerKeyDSIGN Ed25519DSIGN -> VKey Any)
-> VerKeyDSIGN Ed25519DSIGN -> VKey Any
forall a b. (a -> b) -> a -> b
$ SignKeyDSIGN Ed25519DSIGN -> VerKeyDSIGN Ed25519DSIGN
forall v. DSIGNAlgorithm v => SignKeyDSIGN v -> VerKeyDSIGN v
deriveVerKeyDSIGN SignKeyDSIGN Ed25519DSIGN
coldSignKey
            oldCounter :: Word64
oldCounter = Word64 -> Maybe Word64 -> Word64
forall a. a -> Maybe a -> a
fromMaybe Word64
0 (Maybe Word64 -> Word64) -> Maybe Word64 -> Word64
forall a b. (a -> b) -> a -> b
$ KeyHash 'BlockIssuer
-> Map (KeyHash 'BlockIssuer) Word64 -> Maybe Word64
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'BlockIssuer
poolId (GeneratorContext -> Map (KeyHash 'BlockIssuer) Word64
ocertCounters GeneratorContext
context)
        newCounter <- Gen Word64
forall a. Arbitrary a => Gen a
arbitrary Gen Word64 -> (Word64 -> Bool) -> Gen Word64
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
oldCounter)
        let context' = GeneratorContext
context{ocertCounters = Map.insert poolId newCounter (ocertCounters context)}
        pure (context', header)
  GeneratorContext{Word64
praosSlotsPerKESPeriod :: Word64
praosSlotsPerKESPeriod :: GeneratorContext -> Word64
praosSlotsPerKESPeriod, Word64
praosMaxKESEvo :: Word64
praosMaxKESEvo :: GeneratorContext -> Word64
praosMaxKESEvo, KESKey
kesSignKey :: KESKey
kesSignKey :: GeneratorContext -> KESKey
kesSignKey, SignKeyVRF PraosVRF
vrfSignKey :: SignKeyVRF PraosVRF
vrfSignKey :: GeneratorContext -> SignKeyVRF PraosVRF
vrfSignKey, SignKeyDSIGN Ed25519DSIGN
coldSignKey :: GeneratorContext -> SignKeyDSIGN Ed25519DSIGN
coldSignKey :: SignKeyDSIGN Ed25519DSIGN
coldSignKey, Nonce
nonce :: Nonce
nonce :: GeneratorContext -> Nonce
nonce} = GeneratorContext
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 (Mutation -> Mutation -> Bool
(Mutation -> Mutation -> Bool)
-> (Mutation -> Mutation -> Bool) -> Eq Mutation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Mutation -> Mutation -> Bool
== :: Mutation -> Mutation -> Bool
$c/= :: Mutation -> Mutation -> Bool
/= :: Mutation -> Mutation -> Bool
Eq, Int -> Mutation -> ShowS
[Mutation] -> ShowS
Mutation -> String
(Int -> Mutation -> ShowS)
-> (Mutation -> String) -> ([Mutation] -> ShowS) -> Show Mutation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Mutation -> ShowS
showsPrec :: Int -> Mutation -> ShowS
$cshow :: Mutation -> String
show :: Mutation -> String
$cshowList :: [Mutation] -> ShowS
showList :: [Mutation] -> ShowS
Show, (forall x. Mutation -> Rep Mutation x)
-> (forall x. Rep Mutation x -> Mutation) -> Generic Mutation
forall x. Rep Mutation x -> Mutation
forall x. Mutation -> Rep Mutation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Mutation -> Rep Mutation x
from :: forall x. Mutation -> Rep Mutation x
$cto :: forall x. Rep Mutation x -> Mutation
to :: forall x. Rep Mutation x -> Mutation
Generic)

instance Json.ToJSON Mutation where
  toEncoding :: Mutation -> Encoding
toEncoding = Options -> Mutation -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
Json.genericToEncoding Options
defaultOptions

instance Json.FromJSON Mutation

expectedError :: Mutation -> PraosValidationErr StandardCrypto -> Bool
expectedError :: Mutation -> PraosValidationErr StandardCrypto -> Bool
expectedError = \case
  Mutation
NoMutation -> Bool -> PraosValidationErr StandardCrypto -> Bool
forall a b. a -> b -> a
const Bool
False
  Mutation
MutateKESKey -> \case
    InvalidKesSignatureOCERT{} -> Bool
True
    PraosValidationErr StandardCrypto
_ -> Bool
False
  Mutation
MutateColdKey -> \case
    InvalidSignatureOCERT{} -> Bool
True
    PraosValidationErr StandardCrypto
_ -> Bool
False
  Mutation
MutateKESPeriod -> \case
    KESBeforeStartOCERT{} -> Bool
True
    PraosValidationErr StandardCrypto
_ -> Bool
False
  Mutation
MutateKESPeriodBefore -> \case
    KESAfterEndOCERT{} -> Bool
True
    PraosValidationErr StandardCrypto
_ -> Bool
False
  Mutation
MutateCounterOver1 -> \case
    CounterOverIncrementedOCERT{} -> Bool
True
    PraosValidationErr StandardCrypto
_ -> Bool
False
  Mutation
MutateCounterUnder -> \case
    CounterTooSmallOCERT{} -> Bool
True
    PraosValidationErr StandardCrypto
_ -> Bool
False

genMutation :: Header StandardCrypto -> Gen Mutation
genMutation :: Header StandardCrypto -> Gen Mutation
genMutation Header StandardCrypto
header =
  [(Int, Gen Mutation)] -> Gen Mutation
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency ([(Int, Gen Mutation)] -> Gen Mutation)
-> [(Int, Gen Mutation)] -> Gen Mutation
forall a b. (a -> b) -> a -> b
$
    [ (Int
4, Mutation -> Gen Mutation
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Mutation
NoMutation)
    , (Int
1, Mutation -> Gen Mutation
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Mutation
MutateKESKey)
    , (Int
1, Mutation -> Gen Mutation
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Mutation
MutateColdKey)
    , (Int
1, Mutation -> Gen Mutation
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Mutation
MutateKESPeriod)
    , (Int
1, Mutation -> Gen Mutation
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Mutation
MutateKESPeriodBefore)
    , (Int
1, Mutation -> Gen Mutation
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Mutation
MutateCounterUnder)
    ]
      [(Int, Gen Mutation)]
-> [(Int, Gen Mutation)] -> [(Int, Gen Mutation)]
forall a. Semigroup a => a -> a -> a
<> [(Int, Gen Mutation)]
maybeCounterOver1
 where
  Header HeaderBody StandardCrypto
body SignedKES (KES StandardCrypto) (HeaderBody StandardCrypto)
_ = Header StandardCrypto
header
  OCert{Word64
ocertN :: forall c. OCert c -> Word64
ocertN :: Word64
ocertN} = HeaderBody StandardCrypto -> OCert StandardCrypto
forall crypto. HeaderBody crypto -> OCert crypto
hbOCert HeaderBody StandardCrypto
body
  maybeCounterOver1 :: [(Int, Gen Mutation)]
maybeCounterOver1 =
    if Word64
ocertN Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
10
      then [(Int
1, Mutation -> Gen Mutation
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Mutation
MutateCounterOver1)]
      else []

data MutatedHeader = MutatedHeader
  { MutatedHeader -> Header StandardCrypto
header :: !(Header StandardCrypto)
  , MutatedHeader -> Mutation
mutation :: !Mutation
  }
  deriving (Int -> MutatedHeader -> ShowS
[MutatedHeader] -> ShowS
MutatedHeader -> String
(Int -> MutatedHeader -> ShowS)
-> (MutatedHeader -> String)
-> ([MutatedHeader] -> ShowS)
-> Show MutatedHeader
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MutatedHeader -> ShowS
showsPrec :: Int -> MutatedHeader -> ShowS
$cshow :: MutatedHeader -> String
show :: MutatedHeader -> String
$cshowList :: [MutatedHeader] -> ShowS
showList :: [MutatedHeader] -> ShowS
Show, MutatedHeader -> MutatedHeader -> Bool
(MutatedHeader -> MutatedHeader -> Bool)
-> (MutatedHeader -> MutatedHeader -> Bool) -> Eq MutatedHeader
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MutatedHeader -> MutatedHeader -> Bool
== :: MutatedHeader -> MutatedHeader -> Bool
$c/= :: MutatedHeader -> MutatedHeader -> Bool
/= :: MutatedHeader -> MutatedHeader -> Bool
Eq)

instance Json.ToJSON MutatedHeader where
  toJSON :: MutatedHeader -> Value
toJSON MutatedHeader{Header StandardCrypto
header :: MutatedHeader -> Header StandardCrypto
header :: Header StandardCrypto
header, Mutation
mutation :: MutatedHeader -> Mutation
mutation :: Mutation
mutation} =
    [Pair] -> Value
Json.object
      [ Key
"header" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
cborHeader
      , Key
"mutation" Key -> Mutation -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Mutation
mutation
      ]
   where
    cborHeader :: Text
cborHeader = ByteString -> Text
decodeUtf8 (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base16.encode (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Version -> Header StandardCrypto -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
serialize' Version
testVersion Header StandardCrypto
header

instance Json.FromJSON MutatedHeader where
  parseJSON :: Value -> Parser MutatedHeader
parseJSON = String
-> (Object -> Parser MutatedHeader)
-> Value
-> Parser MutatedHeader
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Json.withObject String
"MutatedHeader" ((Object -> Parser MutatedHeader) -> Value -> Parser MutatedHeader)
-> (Object -> Parser MutatedHeader)
-> Value
-> Parser MutatedHeader
forall a b. (a -> b) -> a -> b
$ \Object
obj -> do
    cborHeader <- Object
obj Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"header"
    mutation <- obj .: "mutation"
    header <- parseHeader cborHeader
    pure MutatedHeader{header, mutation}
   where
    parseHeader :: Text -> f (Header StandardCrypto)
parseHeader Text
cborHeader = do
      let headerBytes :: ByteString
headerBytes = ByteString -> ByteString
Base16.decodeLenient (Text -> ByteString
encodeUtf8 Text
cborHeader)
      (DecoderError -> f (Header StandardCrypto))
-> (Header StandardCrypto -> f (Header StandardCrypto))
-> Either DecoderError (Header StandardCrypto)
-> f (Header StandardCrypto)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> f (Header StandardCrypto)
forall a. String -> f a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> f (Header StandardCrypto))
-> (DecoderError -> String)
-> DecoderError
-> f (Header StandardCrypto)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DecoderError -> String
forall a. Show a => a -> String
show) Header StandardCrypto -> f (Header StandardCrypto)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either DecoderError (Header StandardCrypto)
 -> f (Header StandardCrypto))
-> Either DecoderError (Header StandardCrypto)
-> f (Header StandardCrypto)
forall a b. (a -> b) -> a -> b
$
        forall a.
Version
-> Text
-> (forall s. Decoder s (Annotator a))
-> ByteString
-> Either DecoderError a
decodeFullAnnotator @(Header StandardCrypto) Version
testVersion Text
"Header" Decoder s (Annotator (Header StandardCrypto))
forall s. Decoder s (Annotator (Header StandardCrypto))
forall a s. DecCBOR a => Decoder s a
decCBOR (ByteString -> Either DecoderError (Header StandardCrypto))
-> ByteString -> Either DecoderError (Header StandardCrypto)
forall a b. (a -> b) -> a -> b
$
          ByteString -> ByteString
LBS.fromStrict ByteString
headerBytes

-- * Generators
type KESKey = KES.UnsoundPureSignKeyKES (KES.Sum6KES Ed25519DSIGN Blake2b_256)

newVRFSigningKey :: ByteString -> (VRF.SignKeyVRF VRF.PraosVRF, VRF.VerKeyVRF VRF.PraosVRF)
newVRFSigningKey :: ByteString -> (SignKeyVRF PraosVRF, VerKeyVRF PraosVRF)
newVRFSigningKey = Seed -> (SignKeyVRF PraosVRF, VerKeyVRF PraosVRF)
forall v. VRFAlgorithm v => Seed -> (SignKeyVRF v, VerKeyVRF v)
VRF.genKeyPairVRF (Seed -> (SignKeyVRF PraosVRF, VerKeyVRF PraosVRF))
-> (ByteString -> Seed)
-> ByteString
-> (SignKeyVRF PraosVRF, VerKeyVRF PraosVRF)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Seed
mkSeedFromBytes

newKESSigningKey :: ByteString -> KESKey
newKESSigningKey :: ByteString -> KESKey
newKESSigningKey = Seed -> KESKey
forall v.
UnsoundPureKESAlgorithm v =>
Seed -> UnsoundPureSignKeyKES v
KES.unsoundPureGenKeyKES (Seed -> KESKey) -> (ByteString -> Seed) -> ByteString -> KESKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Seed
mkSeedFromBytes

data GeneratorContext = GeneratorContext
  { GeneratorContext -> Word64
praosSlotsPerKESPeriod :: !Word64
  , GeneratorContext -> Word64
praosMaxKESEvo :: !Word64
  , GeneratorContext -> KESKey
kesSignKey :: !KESKey
  , GeneratorContext -> SignKeyDSIGN Ed25519DSIGN
coldSignKey :: !(SignKeyDSIGN Ed25519DSIGN)
  , GeneratorContext -> SignKeyVRF PraosVRF
vrfSignKey :: !(VRF.SignKeyVRF VRF.PraosVRF)
  , GeneratorContext -> Nonce
nonce :: !Nonce
  , GeneratorContext -> Map (KeyHash 'BlockIssuer) Word64
ocertCounters :: !(Map.Map (KeyHash BlockIssuer) Word64)
  , GeneratorContext -> ActiveSlotCoeff
activeSlotCoeff :: !ActiveSlotCoeff
  }
  deriving Int -> GeneratorContext -> ShowS
[GeneratorContext] -> ShowS
GeneratorContext -> String
(Int -> GeneratorContext -> ShowS)
-> (GeneratorContext -> String)
-> ([GeneratorContext] -> ShowS)
-> Show GeneratorContext
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GeneratorContext -> ShowS
showsPrec :: Int -> GeneratorContext -> ShowS
$cshow :: GeneratorContext -> String
show :: GeneratorContext -> String
$cshowList :: [GeneratorContext] -> ShowS
showList :: [GeneratorContext] -> ShowS
Show

instance Eq GeneratorContext where
  GeneratorContext
a == :: GeneratorContext -> GeneratorContext -> Bool
== GeneratorContext
b =
    GeneratorContext -> Word64
praosSlotsPerKESPeriod GeneratorContext
a Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== GeneratorContext -> Word64
praosSlotsPerKESPeriod GeneratorContext
b
      Bool -> Bool -> Bool
&& GeneratorContext -> Word64
praosMaxKESEvo GeneratorContext
a Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== GeneratorContext -> Word64
praosMaxKESEvo GeneratorContext
b
      Bool -> Bool -> Bool
&& Version -> Encoding -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
serialize' Version
testVersion (KESKey -> Encoding
forall v.
UnsoundPureKESAlgorithm v =>
UnsoundPureSignKeyKES v -> Encoding
KES.encodeUnsoundPureSignKeyKES (GeneratorContext -> KESKey
kesSignKey GeneratorContext
a))
        ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== Version -> Encoding -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
serialize' Version
testVersion (KESKey -> Encoding
forall v.
UnsoundPureKESAlgorithm v =>
UnsoundPureSignKeyKES v -> Encoding
KES.encodeUnsoundPureSignKeyKES (GeneratorContext -> KESKey
kesSignKey GeneratorContext
b))
      Bool -> Bool -> Bool
&& GeneratorContext -> SignKeyDSIGN Ed25519DSIGN
coldSignKey GeneratorContext
a SignKeyDSIGN Ed25519DSIGN -> SignKeyDSIGN Ed25519DSIGN -> Bool
forall a. Eq a => a -> a -> Bool
== GeneratorContext -> SignKeyDSIGN Ed25519DSIGN
coldSignKey GeneratorContext
b
      Bool -> Bool -> Bool
&& GeneratorContext -> SignKeyVRF PraosVRF
vrfSignKey GeneratorContext
a SignKeyVRF PraosVRF -> SignKeyVRF PraosVRF -> Bool
forall a. Eq a => a -> a -> Bool
== GeneratorContext -> SignKeyVRF PraosVRF
vrfSignKey GeneratorContext
b
      Bool -> Bool -> Bool
&& GeneratorContext -> Nonce
nonce GeneratorContext
a Nonce -> Nonce -> Bool
forall a. Eq a => a -> a -> Bool
== GeneratorContext -> Nonce
nonce GeneratorContext
b

instance Json.ToJSON GeneratorContext where
  toJSON :: GeneratorContext -> Value
toJSON GeneratorContext{Word64
Map (KeyHash 'BlockIssuer) Word64
SignKeyVRF PraosVRF
SignKeyDSIGN Ed25519DSIGN
KESKey
ActiveSlotCoeff
Nonce
coldSignKey :: GeneratorContext -> SignKeyDSIGN Ed25519DSIGN
ocertCounters :: GeneratorContext -> Map (KeyHash 'BlockIssuer) Word64
praosSlotsPerKESPeriod :: GeneratorContext -> Word64
praosMaxKESEvo :: GeneratorContext -> Word64
kesSignKey :: GeneratorContext -> KESKey
vrfSignKey :: GeneratorContext -> SignKeyVRF PraosVRF
nonce :: GeneratorContext -> Nonce
activeSlotCoeff :: GeneratorContext -> ActiveSlotCoeff
praosSlotsPerKESPeriod :: Word64
praosMaxKESEvo :: Word64
kesSignKey :: KESKey
coldSignKey :: SignKeyDSIGN Ed25519DSIGN
vrfSignKey :: SignKeyVRF PraosVRF
nonce :: Nonce
ocertCounters :: Map (KeyHash 'BlockIssuer) Word64
activeSlotCoeff :: ActiveSlotCoeff
..} =
    [Pair] -> Value
Json.object
      [ Key
"praosSlotsPerKESPeriod" Key -> Word64 -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Word64
praosSlotsPerKESPeriod
      , Key
"praosMaxKESEvo" Key -> Word64 -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Word64
praosMaxKESEvo
      , Key
"kesSignKey" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
rawKesSignKey
      , Key
"coldSignKey" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
rawColdSignKey
      , Key
"vrfSignKey" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
rawVrfSignKey
      , Key
"vrfVKeyHash" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
rawVrVKeyHash
      , Key
"nonce" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
rawNonce
      , Key
"ocertCounters" Key -> Map (KeyHash 'BlockIssuer) Word64 -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Map (KeyHash 'BlockIssuer) Word64
ocertCounters
      , Key
"activeSlotCoeff" Key -> PositiveUnitInterval -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ActiveSlotCoeff -> PositiveUnitInterval
activeSlotVal ActiveSlotCoeff
activeSlotCoeff
      ]
   where
    rawKesSignKey :: Text
rawKesSignKey = ByteString -> Text
decodeUtf8 (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base16.encode (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ KESKey -> ByteString
forall v.
UnsoundPureKESAlgorithm v =>
UnsoundPureSignKeyKES v -> ByteString
KES.rawSerialiseUnsoundPureSignKeyKES KESKey
kesSignKey
    rawColdSignKey :: Text
rawColdSignKey = ByteString -> Text
decodeUtf8 (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base16.encode (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ SignKeyDSIGN Ed25519DSIGN -> ByteString
forall v. DSIGNAlgorithm v => SignKeyDSIGN v -> ByteString
rawSerialiseSignKeyDSIGN SignKeyDSIGN Ed25519DSIGN
coldSignKey
    rawVrfSignKey :: Text
rawVrfSignKey = ByteString -> Text
decodeUtf8 (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base16.encode (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ SignKeyVRF PraosBatchCompatVRF -> ByteString
forall v. VRFAlgorithm v => SignKeyVRF v -> ByteString
rawSerialiseSignKeyVRF (SignKeyVRF PraosBatchCompatVRF -> ByteString)
-> SignKeyVRF PraosBatchCompatVRF -> ByteString
forall a b. (a -> b) -> a -> b
$ SignKeyVRF PraosVRF -> SignKeyVRF PraosBatchCompatVRF
skToBatchCompat SignKeyVRF PraosVRF
vrfSignKey
    rawVrVKeyHash :: Text
rawVrVKeyHash =
      ByteString -> Text
decodeUtf8 (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base16.encode (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$
        Hash Blake2b_256 (VerKeyVRF PraosVRF) -> ByteString
forall h a. Hash h a -> ByteString
hashToBytes (Hash Blake2b_256 (VerKeyVRF PraosVRF) -> ByteString)
-> Hash Blake2b_256 (VerKeyVRF PraosVRF) -> ByteString
forall a b. (a -> b) -> a -> b
$
          forall v h.
(VRFAlgorithm v, HashAlgorithm h) =>
VerKeyVRF v -> Hash h (VerKeyVRF v)
hashVerKeyVRF @_ @Blake2b_256 (VerKeyVRF PraosVRF -> Hash Blake2b_256 (VerKeyVRF PraosVRF))
-> VerKeyVRF PraosVRF -> Hash Blake2b_256 (VerKeyVRF PraosVRF)
forall a b. (a -> b) -> a -> b
$
            SignKeyVRF PraosVRF -> VerKeyVRF PraosVRF
forall v. VRFAlgorithm v => SignKeyVRF v -> VerKeyVRF v
deriveVerKeyVRF SignKeyVRF PraosVRF
vrfSignKey
    rawNonce :: Text
rawNonce = case Nonce
nonce of
      Nonce
NeutralNonce -> ByteString -> Text
decodeUtf8 (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base16.encode (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Int -> Word8 -> ByteString
BS.replicate Int
32 Word8
0
      Nonce Hash Blake2b_256 Nonce
hashNonce -> ByteString -> Text
decodeUtf8 (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base16.encode (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Hash Blake2b_256 Nonce -> ByteString
forall h a. Hash h a -> ByteString
hashToBytes Hash Blake2b_256 Nonce
hashNonce

instance Json.FromJSON GeneratorContext where
  parseJSON :: Value -> Parser GeneratorContext
parseJSON = String
-> (Object -> Parser GeneratorContext)
-> Value
-> Parser GeneratorContext
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Json.withObject String
"GeneratorContext" ((Object -> Parser GeneratorContext)
 -> Value -> Parser GeneratorContext)
-> (Object -> Parser GeneratorContext)
-> Value
-> Parser GeneratorContext
forall a b. (a -> b) -> a -> b
$ \Object
obj -> do
    praosSlotsPerKESPeriod <- Object
obj Object -> Key -> Parser Word64
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"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 :: Text -> f Nonce
parseNonce Text
rawNonce =
      case ByteString -> Either String ByteString
Base16.decode (Text -> ByteString
encodeUtf8 Text
rawNonce) of
        Left String
_ -> Nonce -> f Nonce
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Nonce
NeutralNonce
        Right ByteString
nonceBytes -> Hash Blake2b_256 Nonce -> Nonce
Nonce (Hash Blake2b_256 Nonce -> Nonce)
-> f (Hash Blake2b_256 Nonce) -> f Nonce
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (Hash Blake2b_256 Nonce)
-> (Hash Blake2b_256 Nonce -> f (Hash Blake2b_256 Nonce))
-> Maybe (Hash Blake2b_256 Nonce)
-> f (Hash Blake2b_256 Nonce)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> f (Hash Blake2b_256 Nonce)
forall a. String -> f a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid bytes for hash") Hash Blake2b_256 Nonce -> f (Hash Blake2b_256 Nonce)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Maybe (Hash Blake2b_256 Nonce)
forall h a. HashAlgorithm h => ByteString -> Maybe (Hash h a)
hashFromBytes ByteString
nonceBytes)
    parseColdSignKey :: Text -> m (SignKeyDSIGN v)
parseColdSignKey Text
rawKey = do
      case ByteString -> Either String ByteString
Base16.decode (Text -> ByteString
encodeUtf8 Text
rawKey) of
        Left String
err -> String -> m (SignKeyDSIGN v)
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
        Right ByteString
keyBytes ->
          case ByteString -> Maybe (SignKeyDSIGN v)
forall v. DSIGNAlgorithm v => ByteString -> Maybe (SignKeyDSIGN v)
rawDeserialiseSignKeyDSIGN ByteString
keyBytes of
            Maybe (SignKeyDSIGN v)
Nothing -> String -> m (SignKeyDSIGN v)
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m (SignKeyDSIGN v)) -> String -> m (SignKeyDSIGN v)
forall a b. (a -> b) -> a -> b
$ String
"Invalid cold key bytes: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
rawKey
            Just SignKeyDSIGN v
key -> SignKeyDSIGN v -> m (SignKeyDSIGN v)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SignKeyDSIGN v
key
    parseKesSignKey :: Text -> m (UnsoundPureSignKeyKES v)
parseKesSignKey Text
rawKey = do
      case ByteString -> Either String ByteString
Base16.decode (Text -> ByteString
encodeUtf8 Text
rawKey) of
        Left String
err -> String -> m (UnsoundPureSignKeyKES v)
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
        Right ByteString
keyBytes ->
          case ByteString -> Maybe (UnsoundPureSignKeyKES v)
forall v.
UnsoundPureKESAlgorithm v =>
ByteString -> Maybe (UnsoundPureSignKeyKES v)
KES.rawDeserialiseUnsoundPureSignKeyKES ByteString
keyBytes of
            Maybe (UnsoundPureSignKeyKES v)
Nothing -> String -> m (UnsoundPureSignKeyKES v)
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m (UnsoundPureSignKeyKES v))
-> String -> m (UnsoundPureSignKeyKES v)
forall a b. (a -> b) -> a -> b
$ String
"Invalid KES key bytes: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
rawKey
            Just UnsoundPureSignKeyKES v
key -> UnsoundPureSignKeyKES v -> m (UnsoundPureSignKeyKES v)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UnsoundPureSignKeyKES v
key
    parseVrfSignKey :: Text -> m (SignKeyVRF v)
parseVrfSignKey Text
rawKey = do
      case ByteString -> Either String ByteString
Base16.decode (Text -> ByteString
encodeUtf8 Text
rawKey) of
        Left String
err -> String -> m (SignKeyVRF v)
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
        Right ByteString
keyBytes ->
          case ByteString -> Maybe (SignKeyVRF v)
forall v. VRFAlgorithm v => ByteString -> Maybe (SignKeyVRF v)
rawDeserialiseSignKeyVRF ByteString
keyBytes of
            Maybe (SignKeyVRF v)
Nothing -> String -> m (SignKeyVRF v)
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m (SignKeyVRF v)) -> String -> m (SignKeyVRF v)
forall a b. (a -> b) -> a -> b
$ String
"Invalid VRF key bytes: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
rawKey
            Just SignKeyVRF v
key -> SignKeyVRF v -> m (SignKeyVRF v)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SignKeyVRF v
key

genContext :: Gen GeneratorContext
genContext :: Gen GeneratorContext
genContext = do
  praosSlotsPerKESPeriod <- (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
100, Word64
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 = KeyHash Any -> KeyHash 'BlockIssuer
forall a b. Coercible a b => a -> b
coerce (KeyHash Any -> KeyHash 'BlockIssuer)
-> KeyHash Any -> KeyHash 'BlockIssuer
forall a b. (a -> b) -> a -> b
$ VKey Any -> KeyHash Any
forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey (VKey Any -> KeyHash Any) -> VKey Any -> KeyHash Any
forall a b. (a -> b) -> a -> b
$ VerKeyDSIGN Ed25519DSIGN -> VKey Any
forall (kd :: KeyRole). VerKeyDSIGN Ed25519DSIGN -> VKey kd
VKey (VerKeyDSIGN Ed25519DSIGN -> VKey Any)
-> VerKeyDSIGN Ed25519DSIGN -> VKey Any
forall a b. (a -> b) -> a -> b
$ SignKeyDSIGN Ed25519DSIGN -> VerKeyDSIGN Ed25519DSIGN
forall v. DSIGNAlgorithm v => SignKeyDSIGN v -> VerKeyDSIGN v
deriveVerKeyDSIGN SignKeyDSIGN Ed25519DSIGN
coldSignKey
      ocertCounters = [(KeyHash 'BlockIssuer, Word64)]
-> Map (KeyHash 'BlockIssuer) Word64
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(KeyHash 'BlockIssuer
poolId, Word64
ocertCounter)]
  activeSlotCoeff <- genActiveSlotCoeff
  pure $ GeneratorContext{..}

genActiveSlotCoeff :: Gen ActiveSlotCoeff
genActiveSlotCoeff :: Gen ActiveSlotCoeff
genActiveSlotCoeff = do
  (Integer, Integer) -> Gen Integer
forall a. Random a => (a, a) -> Gen a
choose (Integer
1, Integer
100) Gen Integer
-> (Integer -> Gen ActiveSlotCoeff) -> Gen ActiveSlotCoeff
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Integer
n -> ActiveSlotCoeff -> Gen ActiveSlotCoeff
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ActiveSlotCoeff -> Gen ActiveSlotCoeff)
-> ActiveSlotCoeff -> Gen ActiveSlotCoeff
forall a b. (a -> b) -> a -> b
$ Rational -> ActiveSlotCoeff
activeSlotCoeff (Integer
n Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
100)
 where
  activeSlotCoeff :: Rational -> ActiveSlotCoeff
activeSlotCoeff = PositiveUnitInterval -> ActiveSlotCoeff
mkActiveSlotCoeff (PositiveUnitInterval -> ActiveSlotCoeff)
-> (Rational -> PositiveUnitInterval)
-> Rational
-> ActiveSlotCoeff
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe PositiveUnitInterval -> PositiveUnitInterval
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe PositiveUnitInterval -> PositiveUnitInterval)
-> (Rational -> Maybe PositiveUnitInterval)
-> Rational
-> PositiveUnitInterval
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. BoundedRational r => Rational -> Maybe r
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 :: GeneratorContext -> Gen (Header StandardCrypto)
genHeader GeneratorContext
context = do
  (body, KESPeriod kesPeriod) <- GeneratorContext -> Gen (HeaderBody StandardCrypto, KESPeriod)
genHeaderBody GeneratorContext
context
  let sign = SigKES (Sum6KES Ed25519DSIGN Blake2b_256)
-> SignedKES (Sum6KES Ed25519DSIGN Blake2b_256) a
forall v a. SigKES v -> SignedKES v a
KES.SignedKES (SigKES (Sum6KES Ed25519DSIGN Blake2b_256)
 -> SignedKES (Sum6KES Ed25519DSIGN Blake2b_256) a)
-> SigKES (Sum6KES Ed25519DSIGN Blake2b_256)
-> SignedKES (Sum6KES Ed25519DSIGN Blake2b_256) a
forall a b. (a -> b) -> a -> b
$ ContextKES (Sum6KES Ed25519DSIGN Blake2b_256)
-> Word
-> HeaderBody StandardCrypto
-> KESKey
-> SigKES (Sum6KES Ed25519DSIGN Blake2b_256)
forall v a.
(UnsoundPureKESAlgorithm v, Signable v a) =>
ContextKES v -> Word -> a -> UnsoundPureSignKeyKES v -> SigKES v
forall a.
Signable (Sum6KES Ed25519DSIGN Blake2b_256) a =>
ContextKES (Sum6KES Ed25519DSIGN Blake2b_256)
-> Word -> a -> KESKey -> SigKES (Sum6KES Ed25519DSIGN Blake2b_256)
KES.unsoundPureSignKES () Word
kesPeriod HeaderBody StandardCrypto
body KESKey
kesSignKey
  pure $ (Header body sign)
 where
  GeneratorContext{KESKey
kesSignKey :: GeneratorContext -> KESKey
kesSignKey :: KESKey
kesSignKey} = GeneratorContext
context

genHeaderBody :: GeneratorContext -> Gen (HeaderBody StandardCrypto, KESPeriod)
genHeaderBody :: GeneratorContext -> Gen (HeaderBody StandardCrypto, KESPeriod)
genHeaderBody GeneratorContext
context = do
  hbBlockNo <- Word64 -> BlockNo
BlockNo (Word64 -> BlockNo) -> Gen Word64 -> Gen BlockNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Word64
forall a. Arbitrary a => Gen a
arbitrary
  (hbSlotNo, hbVrfRes, hbVrfVk) <- genLeadingSlot context
  hbPrev <- BlockHash . HashHeader <$> genHash
  let hbVk = 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
  hbBodySize <- choose (1000, 90000)
  hbBodyHash <- genHash
  (hbOCert, kesPeriod) <- genCert hbSlotNo context
  let hbProtVer = ProtVer
protocolVersionZero
      headerBody = HeaderBody{Word32
Hash Blake2b_256 EraIndependentBlockBody
CertifiedVRF PraosVRF InputVRF
CertifiedVRF (VRF StandardCrypto) InputVRF
VerKeyVRF PraosVRF
VerKeyVRF (VRF StandardCrypto)
BlockNo
SlotNo
VKey 'BlockIssuer
ProtVer
OCert StandardCrypto
PrevHash
forall {kd :: KeyRole}. VKey kd
hbSlotNo :: SlotNo
hbOCert :: OCert StandardCrypto
hbVrfRes :: CertifiedVRF (VRF StandardCrypto) InputVRF
hbBlockNo :: BlockNo
hbSlotNo :: SlotNo
hbVrfRes :: CertifiedVRF PraosVRF InputVRF
hbVrfVk :: VerKeyVRF PraosVRF
hbPrev :: PrevHash
hbVk :: forall {kd :: KeyRole}. VKey kd
hbBodySize :: Word32
hbBodyHash :: Hash Blake2b_256 EraIndependentBlockBody
hbOCert :: OCert StandardCrypto
hbProtVer :: ProtVer
hbProtVer :: ProtVer
hbBodyHash :: Hash Blake2b_256 EraIndependentBlockBody
hbBodySize :: Word32
hbVrfVk :: VerKeyVRF (VRF StandardCrypto)
hbVk :: VKey 'BlockIssuer
hbPrev :: PrevHash
hbBlockNo :: BlockNo
..}
  pure $ (headerBody, kesPeriod)
 where
  GeneratorContext{SignKeyDSIGN Ed25519DSIGN
coldSignKey :: GeneratorContext -> SignKeyDSIGN Ed25519DSIGN
coldSignKey :: SignKeyDSIGN Ed25519DSIGN
coldSignKey} = GeneratorContext
context

genLeadingSlot ::
  GeneratorContext -> Gen (SlotNo, VRF.CertifiedVRF VRF.PraosVRF InputVRF, VRF.VerKeyVRF VRF.PraosVRF)
genLeadingSlot :: GeneratorContext
-> Gen (SlotNo, CertifiedVRF PraosVRF InputVRF, VerKeyVRF PraosVRF)
genLeadingSlot GeneratorContext
context = do
  slotNo <- Word64 -> SlotNo
SlotNo (Word64 -> SlotNo)
-> (Positive Word64 -> Word64) -> Positive Word64 -> SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Positive Word64 -> Word64
forall a. Positive a -> a
getPositive (Positive Word64 -> SlotNo) -> Gen (Positive Word64) -> Gen SlotNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Positive Word64)
forall a. Arbitrary a => Gen a
arbitrary Gen (Positive Word64)
-> (Positive Word64 -> Bool) -> Gen (Positive Word64)
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` Positive Word64 -> Bool
isLeader
  let rho' = SlotNo -> Nonce -> InputVRF
mkInputVRF SlotNo
slotNo Nonce
nonce
      hbVrfRes = ContextVRF PraosVRF
-> InputVRF
-> SignKeyVRF PraosVRF
-> CertifiedVRF PraosVRF InputVRF
forall v a.
(VRFAlgorithm v, Signable v a) =>
ContextVRF v -> a -> SignKeyVRF v -> CertifiedVRF v a
VRF.evalCertified () InputVRF
rho' SignKeyVRF PraosVRF
vrfSignKey
      hbVrfVk = SignKeyVRF PraosVRF -> VerKeyVRF PraosVRF
forall v. VRFAlgorithm v => SignKeyVRF v -> VerKeyVRF v
deriveVerKeyVRF SignKeyVRF PraosVRF
vrfSignKey
  pure (slotNo, hbVrfRes, hbVrfVk)
 where
  isLeader :: Positive Word64 -> Bool
isLeader Positive Word64
n =
    let slotNo :: SlotNo
slotNo = Word64 -> SlotNo
SlotNo (Word64 -> SlotNo)
-> (Positive Word64 -> Word64) -> Positive Word64 -> SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Positive Word64 -> Word64
forall a. Positive a -> a
getPositive (Positive Word64 -> SlotNo) -> Positive Word64 -> SlotNo
forall a b. (a -> b) -> a -> b
$ Positive Word64
n
        rho' :: InputVRF
rho' = SlotNo -> Nonce -> InputVRF
mkInputVRF SlotNo
slotNo Nonce
nonce
        certified :: CertifiedVRF PraosVRF InputVRF
certified = ContextVRF PraosVRF
-> InputVRF
-> SignKeyVRF PraosVRF
-> CertifiedVRF PraosVRF InputVRF
forall v a.
(VRFAlgorithm v, Signable v a) =>
ContextVRF v -> a -> SignKeyVRF v -> CertifiedVRF v a
VRF.evalCertified () InputVRF
rho' SignKeyVRF PraosVRF
vrfSignKey
     in BoundedNatural -> Rational -> ActiveSlotCoeff -> Bool
checkLeaderNatValue (Proxy StandardCrypto
-> CertifiedVRF (VRF StandardCrypto) InputVRF -> BoundedNatural
forall c (proxy :: * -> *).
proxy c -> CertifiedVRF (VRF c) InputVRF -> BoundedNatural
vrfLeaderValue (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @StandardCrypto) CertifiedVRF PraosVRF InputVRF
CertifiedVRF (VRF StandardCrypto) InputVRF
certified) Rational
sigma ActiveSlotCoeff
activeSlotCoeff
  sigma :: Rational
sigma = Rational
1
  GeneratorContext{SignKeyVRF PraosVRF
vrfSignKey :: GeneratorContext -> SignKeyVRF PraosVRF
vrfSignKey :: SignKeyVRF PraosVRF
vrfSignKey, Nonce
nonce :: GeneratorContext -> Nonce
nonce :: Nonce
nonce, ActiveSlotCoeff
activeSlotCoeff :: GeneratorContext -> ActiveSlotCoeff
activeSlotCoeff :: ActiveSlotCoeff
activeSlotCoeff} = GeneratorContext
context

protocolVersionZero :: ProtVer
protocolVersionZero :: ProtVer
protocolVersionZero = Version -> Natural -> ProtVer
ProtVer Version
versionZero Natural
0
 where
  versionZero :: Version
  versionZero :: Version
versionZero = forall (v :: Natural).
(KnownNat v, 0 <= v, v <= MaxVersion) =>
Version
natVersion @0

genCert :: SlotNo -> GeneratorContext -> Gen (OCert StandardCrypto, KESPeriod)
genCert :: SlotNo -> GeneratorContext -> Gen (OCert StandardCrypto, KESPeriod)
genCert SlotNo
slotNo GeneratorContext
context = do
  let ocertVkHot :: VerKeyKES (Sum6KES Ed25519DSIGN Blake2b_256)
ocertVkHot = KESKey -> VerKeyKES (Sum6KES Ed25519DSIGN Blake2b_256)
forall v.
UnsoundPureKESAlgorithm v =>
UnsoundPureSignKeyKES v -> VerKeyKES v
KES.unsoundPureDeriveVerKeyKES KESKey
kesSignKey
      poolId :: KeyHash 'BlockIssuer
poolId = KeyHash Any -> KeyHash 'BlockIssuer
forall a b. Coercible a b => a -> b
coerce (KeyHash Any -> KeyHash 'BlockIssuer)
-> KeyHash Any -> KeyHash 'BlockIssuer
forall a b. (a -> b) -> a -> b
$ VKey Any -> KeyHash Any
forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey (VKey Any -> KeyHash Any) -> VKey Any -> KeyHash Any
forall a b. (a -> b) -> a -> b
$ VerKeyDSIGN Ed25519DSIGN -> VKey Any
forall (kd :: KeyRole). VerKeyDSIGN Ed25519DSIGN -> VKey kd
VKey (VerKeyDSIGN Ed25519DSIGN -> VKey Any)
-> VerKeyDSIGN Ed25519DSIGN -> VKey Any
forall a b. (a -> b) -> a -> b
$ SignKeyDSIGN Ed25519DSIGN -> VerKeyDSIGN Ed25519DSIGN
forall v. DSIGNAlgorithm v => SignKeyDSIGN v -> VerKeyDSIGN v
deriveVerKeyDSIGN SignKeyDSIGN Ed25519DSIGN
coldSignKey
      ocertN :: Word64
ocertN = Word64 -> Maybe Word64 -> Word64
forall a. a -> Maybe a -> a
fromMaybe Word64
0 (Maybe Word64 -> Word64) -> Maybe Word64 -> Word64
forall a b. (a -> b) -> a -> b
$ KeyHash 'BlockIssuer
-> Map (KeyHash 'BlockIssuer) Word64 -> Maybe Word64
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'BlockIssuer
poolId Map (KeyHash 'BlockIssuer) Word64
ocertCounters
  ocertKESPeriod <- SlotNo -> Word64 -> Gen KESPeriod
genValidKESPeriod SlotNo
slotNo Word64
praosSlotsPerKESPeriod
  let ocertSigma = SignKeyDSIGN Ed25519DSIGN
-> OCertSignable StandardCrypto
-> SignedDSIGN Ed25519DSIGN (OCertSignable StandardCrypto)
forall a.
Signable Ed25519DSIGN a =>
SignKeyDSIGN Ed25519DSIGN -> a -> SignedDSIGN Ed25519DSIGN a
signedDSIGN SignKeyDSIGN Ed25519DSIGN
coldSignKey (OCertSignable StandardCrypto
 -> SignedDSIGN Ed25519DSIGN (OCertSignable StandardCrypto))
-> OCertSignable StandardCrypto
-> SignedDSIGN Ed25519DSIGN (OCertSignable StandardCrypto)
forall a b. (a -> b) -> a -> b
$ VerKeyKES (KES StandardCrypto)
-> Word64 -> KESPeriod -> OCertSignable StandardCrypto
forall c.
VerKeyKES (KES c) -> Word64 -> KESPeriod -> OCertSignable c
OCertSignable VerKeyKES (Sum6KES Ed25519DSIGN Blake2b_256)
VerKeyKES (KES StandardCrypto)
ocertVkHot Word64
ocertN KESPeriod
ocertKESPeriod
  pure (OCert{..}, ocertKESPeriod)
 where
  GeneratorContext{KESKey
kesSignKey :: GeneratorContext -> KESKey
kesSignKey :: KESKey
kesSignKey, Word64
praosSlotsPerKESPeriod :: GeneratorContext -> Word64
praosSlotsPerKESPeriod :: Word64
praosSlotsPerKESPeriod, SignKeyDSIGN Ed25519DSIGN
coldSignKey :: GeneratorContext -> SignKeyDSIGN Ed25519DSIGN
coldSignKey :: SignKeyDSIGN Ed25519DSIGN
coldSignKey, Map (KeyHash 'BlockIssuer) Word64
ocertCounters :: GeneratorContext -> Map (KeyHash 'BlockIssuer) Word64
ocertCounters :: Map (KeyHash 'BlockIssuer) Word64
ocertCounters} = GeneratorContext
context

genValidKESPeriod :: SlotNo -> Word64 -> Gen KESPeriod
genValidKESPeriod :: SlotNo -> Word64 -> Gen KESPeriod
genValidKESPeriod SlotNo
slotNo Word64
praosSlotsPerKESPeriod =
  KESPeriod -> Gen KESPeriod
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (KESPeriod -> Gen KESPeriod) -> KESPeriod -> Gen KESPeriod
forall a b. (a -> b) -> a -> b
$ Word -> KESPeriod
KESPeriod (Word -> KESPeriod) -> Word -> KESPeriod
forall a b. (a -> b) -> a -> b
$ Word64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word) -> Word64 -> Word
forall a b. (a -> b) -> a -> b
$ SlotNo -> Word64
unSlotNo SlotNo
slotNo Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`div` Word64
praosSlotsPerKESPeriod

genKESPeriodAfterLimit :: SlotNo -> Word64 -> Gen KESPeriod
genKESPeriodAfterLimit :: SlotNo -> Word64 -> Gen KESPeriod
genKESPeriodAfterLimit SlotNo
slotNo Word64
praosSlotsPerKESPeriod =
  Word -> KESPeriod
KESPeriod (Word -> KESPeriod) -> (Word64 -> Word) -> Word64 -> KESPeriod
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> KESPeriod) -> Gen Word64 -> Gen KESPeriod
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Word64
forall a. Arbitrary a => Gen a
arbitrary Gen Word64 -> (Word64 -> Bool) -> Gen Word64
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
currentKESPeriod)
 where
  currentKESPeriod :: Word64
currentKESPeriod = SlotNo -> Word64
unSlotNo SlotNo
slotNo Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`div` Word64
praosSlotsPerKESPeriod

genSlotAfterKESPeriod :: Word64 -> Word64 -> Word64 -> Gen SlotNo
genSlotAfterKESPeriod :: Word64 -> Word64 -> Word64 -> Gen SlotNo
genSlotAfterKESPeriod Word64
ocertKESPeriod Word64
praosMaxKESEvo Word64
praosSlotsPerKESPeriod = do
  -- kp_ < c0_ +  praosMaxKESEvo
  -- ! =>
  -- kp >=  c0_ +  praosMaxKESEvo
  -- c0 <=  kp -  praosMaxKESEvo
  Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> Gen Word64 -> Gen SlotNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Word64
forall a. Arbitrary a => Gen a
arbitrary Gen Word64 -> (Word64 -> Bool) -> Gen Word64
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
threshold)
 where
  threshold :: Word64
threshold = (Word64
ocertKESPeriod Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
praosMaxKESEvo Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
praosSlotsPerKESPeriod

genHash :: Gen (Hash Blake2b_256 a)
genHash :: forall a. Gen (Hash Blake2b_256 a)
genHash = Hash Blake2b_256 ByteString -> Hash Blake2b_256 a
forall a b. Coercible a b => a -> b
coerce (Hash Blake2b_256 ByteString -> Hash Blake2b_256 a)
-> (ByteString -> Hash Blake2b_256 ByteString)
-> ByteString
-> Hash Blake2b_256 a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> ByteString)
-> ByteString -> Hash Blake2b_256 ByteString
forall h a. HashAlgorithm h => (a -> ByteString) -> a -> Hash h a
hashWith ByteString -> ByteString
forall a. a -> a
id (ByteString -> Hash Blake2b_256 a)
-> Gen ByteString -> Gen (Hash Blake2b_256 a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ByteString
gen32Bytes

gen32Bytes :: Gen ByteString
gen32Bytes :: Gen ByteString
gen32Bytes = [Word8] -> ByteString
BS.pack ([Word8] -> ByteString) -> Gen [Word8] -> Gen ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen Word8 -> Gen [Word8]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
32 Gen Word8
forall a. Arbitrary a => Gen a
arbitrary