{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Test.Cardano.Protocol.TPraos.Create (
  AllIssuerKeys (..),
  genAllIssuerKeys,
  KESKeyPair (..),
  VRFKeyPair (..),
  mkOCert,
  mkBHBody,
  mkBHBodyFakeVRF,
  mkBHeader,
  mkBlock,
  mkBlockFakeVRF,
  evolveKESUntil,
) where

import qualified Cardano.Crypto.KES.Class as KES
import qualified Cardano.Crypto.VRF.Class as VRF
import Cardano.Ledger.BaseTypes (
  BlockNo,
  Nonce,
  ProtVer (..),
  Seed,
  SlotNo,
  UnitInterval,
  unboundRational,
 )
import Cardano.Ledger.Block
import Cardano.Ledger.Core
import Cardano.Ledger.Keys (HasKeyRole (coerceKeyRole), signedDSIGN)
import Cardano.Protocol.Crypto
import Cardano.Protocol.TPraos.BHeader (
  BHBody (..),
  BHeader (..),
  PrevHash (BlockHash),
  mkSeed,
  seedEta,
  seedL,
 )
import Cardano.Protocol.TPraos.OCert (
  KESPeriod (..),
  OCert (..),
  OCertSignable (..),
 )
import Control.Monad (forM)
import Data.Coerce
import Data.List.NonEmpty as NE
import Data.Ratio (denominator, numerator, (%))
import Data.Sequence.Strict as StrictSeq
import Data.Word
import Lens.Micro
import Numeric.Natural
import Test.Cardano.Ledger.Common
import Test.Cardano.Ledger.Core.KeyPair (KeyPair (..))
import Test.Cardano.Protocol.Crypto.KES (KESKeyPair (..))
import Test.Cardano.Protocol.Crypto.VRF (VRFKeyPair (..))
import Test.Cardano.Protocol.Crypto.VRF.Fake (NatNonce (..), WithResult (..))

data AllIssuerKeys c (r :: KeyRole) = AllIssuerKeys
  { forall c (r :: KeyRole). AllIssuerKeys c r -> KeyPair r
aikCold :: KeyPair r
  , forall c (r :: KeyRole). AllIssuerKeys c r -> VRFKeyPair c
aikVrf :: VRFKeyPair c
  , forall c (r :: KeyRole).
AllIssuerKeys c r -> NonEmpty (KESPeriod, KESKeyPair c)
aikHot :: NonEmpty (KESPeriod, KESKeyPair c)
  , forall c (r :: KeyRole). AllIssuerKeys c r -> KeyHash r
aikColdKeyHash :: KeyHash r
  }

deriving instance
  (Show (VRF.SignKeyVRF (VRF c)), Show (VRF.VerKeyVRF (VRF c)), Show (KES.VerKeyKES (KES c))) =>
  Show (AllIssuerKeys c r)

genAllIssuerKeys ::
  Crypto c =>
  -- | Maxium slot number
  Int ->
  -- | This corresponds to number of KES evolutions `Cardano.Ledger.BaseTypes.maxKESEvo` from
  -- `Cardano.Ledger.BaseTypes.Globals`.
  Word64 ->
  -- | This corresponds to number of KES evolutions `Cardano.Ledger.BaseTypes.slotsPerKESPeriod` from
  -- `Cardano.Ledger.BaseTypes.Globals`.
  Word64 ->
  Gen (AllIssuerKeys c r)
genAllIssuerKeys :: forall c (r :: KeyRole).
Crypto c =>
Int -> Word64 -> Word64 -> Gen (AllIssuerKeys c r)
genAllIssuerKeys Int
maxSlotNumber Word64
maxKESIterations Word64
slotsPerKESPeriod = do
  KeyPair r
coldKeyPair <- Gen (KeyPair r)
forall a. Arbitrary a => Gen a
arbitrary
  let maxIter :: Int
maxIter =
        Int
maxSlotNumber Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
maxKESIterations Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
slotsPerKESPeriod)
      iters :: NonEmpty Int
iters = Int
0 Int -> [Int] -> NonEmpty Int
forall a. a -> [a] -> NonEmpty a
:| [Int
1 .. Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
maxIter]
  NonEmpty (KESPeriod, KESKeyPair c)
hotKESKeys <- NonEmpty Int
-> (Int -> Gen (KESPeriod, KESKeyPair c))
-> Gen (NonEmpty (KESPeriod, KESKeyPair c))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM NonEmpty Int
iters ((Int -> Gen (KESPeriod, KESKeyPair c))
 -> Gen (NonEmpty (KESPeriod, KESKeyPair c)))
-> (Int -> Gen (KESPeriod, KESKeyPair c))
-> Gen (NonEmpty (KESPeriod, KESKeyPair c))
forall a b. (a -> b) -> a -> b
$ \Int
iter ->
    (Word -> KESPeriod
KESPeriod (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
iter Int -> Int -> Int
forall a. Num a => a -> a -> a
* Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
maxKESIterations)),) (KESKeyPair c -> (KESPeriod, KESKeyPair c))
-> Gen (KESKeyPair c) -> Gen (KESPeriod, KESKeyPair c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (KESKeyPair c)
forall a. Arbitrary a => Gen a
arbitrary
  VRFKeyPair c
vrfKeyPair <- Gen (VRFKeyPair c)
forall a. Arbitrary a => Gen a
arbitrary
  AllIssuerKeys c r -> Gen (AllIssuerKeys c r)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AllIssuerKeys c r -> Gen (AllIssuerKeys c r))
-> AllIssuerKeys c r -> Gen (AllIssuerKeys c r)
forall a b. (a -> b) -> a -> b
$
    AllIssuerKeys
      { aikCold :: KeyPair r
aikCold = KeyPair r
coldKeyPair
      , aikHot :: NonEmpty (KESPeriod, KESKeyPair c)
aikHot = NonEmpty (KESPeriod, KESKeyPair c)
hotKESKeys
      , aikVrf :: VRFKeyPair c
aikVrf = VRFKeyPair c
vrfKeyPair
      , aikColdKeyHash :: KeyHash r
aikColdKeyHash = VKey r -> KeyHash r
forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey (KeyPair r -> VKey r
forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey KeyPair r
coldKeyPair)
      }

mkOCert ::
  forall c r.
  Crypto c =>
  AllIssuerKeys c r ->
  Word64 ->
  KESPeriod ->
  OCert c
mkOCert :: forall c (r :: KeyRole).
Crypto c =>
AllIssuerKeys c r -> Word64 -> KESPeriod -> OCert c
mkOCert AllIssuerKeys c r
pKeys Word64
kesPeriod KESPeriod
keyRegKesPeriod =
  let vKeyHot :: VerKeyKES (KES c)
vKeyHot = KESKeyPair c -> VerKeyKES (KES c)
forall c. KESKeyPair c -> VerKeyKES (KES c)
kesVerKey (KESKeyPair c -> VerKeyKES (KES c))
-> KESKeyPair c -> VerKeyKES (KES c)
forall a b. (a -> b) -> a -> b
$ (KESPeriod, KESKeyPair c) -> KESKeyPair c
forall a b. (a, b) -> b
snd ((KESPeriod, KESKeyPair c) -> KESKeyPair c)
-> (KESPeriod, KESKeyPair c) -> KESKeyPair c
forall a b. (a -> b) -> a -> b
$ NonEmpty (KESPeriod, KESKeyPair c) -> (KESPeriod, KESKeyPair c)
forall a. NonEmpty a -> a
NE.head (NonEmpty (KESPeriod, KESKeyPair c) -> (KESPeriod, KESKeyPair c))
-> NonEmpty (KESPeriod, KESKeyPair c) -> (KESPeriod, KESKeyPair c)
forall a b. (a -> b) -> a -> b
$ AllIssuerKeys c r -> NonEmpty (KESPeriod, KESKeyPair c)
forall c (r :: KeyRole).
AllIssuerKeys c r -> NonEmpty (KESPeriod, KESKeyPair c)
aikHot AllIssuerKeys c r
pKeys
      sKeyCold :: SignKeyDSIGN DSIGN
sKeyCold = KeyPair r -> SignKeyDSIGN DSIGN
forall (kd :: KeyRole). KeyPair kd -> SignKeyDSIGN DSIGN
sKey (KeyPair r -> SignKeyDSIGN DSIGN)
-> KeyPair r -> SignKeyDSIGN DSIGN
forall a b. (a -> b) -> a -> b
$ AllIssuerKeys c r -> KeyPair r
forall c (r :: KeyRole). AllIssuerKeys c r -> KeyPair r
aikCold AllIssuerKeys c r
pKeys
   in OCert
        { ocertVkHot :: VerKeyKES (KES c)
ocertVkHot = VerKeyKES (KES c)
vKeyHot
        , ocertN :: Word64
ocertN = Word64
kesPeriod
        , ocertKESPeriod :: KESPeriod
ocertKESPeriod = KESPeriod
keyRegKesPeriod
        , ocertSigma :: SignedDSIGN DSIGN (OCertSignable c)
ocertSigma = SignKeyDSIGN DSIGN
-> OCertSignable c -> SignedDSIGN DSIGN (OCertSignable c)
forall a.
Signable DSIGN a =>
SignKeyDSIGN DSIGN -> a -> SignedDSIGN DSIGN a
signedDSIGN SignKeyDSIGN DSIGN
sKeyCold (VerKeyKES (KES c) -> Word64 -> KESPeriod -> OCertSignable c
forall c.
VerKeyKES (KES c) -> Word64 -> KESPeriod -> OCertSignable c
OCertSignable VerKeyKES (KES c)
vKeyHot Word64
kesPeriod KESPeriod
keyRegKesPeriod)
        }

mkBHBody ::
  ( VRF.ContextVRF (VRF c) ~ ()
  , VRF.Signable (VRF c) Seed
  , VRF.VRFAlgorithm (VRF c)
  ) =>
  ProtVer ->
  HashHeader ->
  AllIssuerKeys c r ->
  SlotNo ->
  BlockNo ->
  Nonce ->
  OCert c ->
  Word32 ->
  Hash HASH EraIndependentBlockBody ->
  BHBody c
mkBHBody :: forall c (r :: KeyRole).
(ContextVRF (VRF c) ~ (), Signable (VRF c) Seed,
 VRFAlgorithm (VRF c)) =>
ProtVer
-> HashHeader
-> AllIssuerKeys c r
-> SlotNo
-> BlockNo
-> Nonce
-> OCert c
-> Word32
-> Hash HASH EraIndependentBlockBody
-> BHBody c
mkBHBody = (Seed -> SignKeyVRF (VRF c) -> CertifiedVRF (VRF c) Seed)
-> (Seed -> SignKeyVRF (VRF c) -> CertifiedVRF (VRF c) Seed)
-> ProtVer
-> HashHeader
-> AllIssuerKeys c r
-> SlotNo
-> BlockNo
-> Nonce
-> OCert c
-> Word32
-> Hash HASH EraIndependentBlockBody
-> BHBody c
forall a c b (r :: KeyRole).
(Coercible a (CertifiedVRF (VRF c) Nonce),
 Coercible b (CertifiedVRF (VRF c) Natural)) =>
(Seed -> SignKeyVRF (VRF c) -> a)
-> (Seed -> SignKeyVRF (VRF c) -> b)
-> ProtVer
-> HashHeader
-> AllIssuerKeys c r
-> SlotNo
-> BlockNo
-> Nonce
-> OCert c
-> Word32
-> Hash HASH EraIndependentBlockBody
-> BHBody c
mkBHBodyWithVRF (ContextVRF (VRF c)
-> Seed -> SignKeyVRF (VRF c) -> CertifiedVRF (VRF c) Seed
forall v a.
(VRFAlgorithm v, Signable v a) =>
ContextVRF v -> a -> SignKeyVRF v -> CertifiedVRF v a
VRF.evalCertified ()) (ContextVRF (VRF c)
-> Seed -> SignKeyVRF (VRF c) -> CertifiedVRF (VRF c) Seed
forall v a.
(VRFAlgorithm v, Signable v a) =>
ContextVRF v -> a -> SignKeyVRF v -> CertifiedVRF v a
VRF.evalCertified ())

mkBHBodyFakeVRF ::
  ( VRF.ContextVRF (VRF c) ~ ()
  , VRF.Signable (VRF c) (WithResult Seed)
  , VRF.VRFAlgorithm (VRF c)
  ) =>
  NatNonce ->
  UnitInterval ->
  ProtVer ->
  HashHeader ->
  AllIssuerKeys c r ->
  SlotNo ->
  BlockNo ->
  Nonce ->
  OCert c ->
  Word32 ->
  Hash HASH EraIndependentBlockBody ->
  BHBody c
mkBHBodyFakeVRF :: forall c (r :: KeyRole).
(ContextVRF (VRF c) ~ (), Signable (VRF c) (WithResult Seed),
 VRFAlgorithm (VRF c)) =>
NatNonce
-> UnitInterval
-> ProtVer
-> HashHeader
-> AllIssuerKeys c r
-> SlotNo
-> BlockNo
-> Nonce
-> OCert c
-> Word32
-> Hash HASH EraIndependentBlockBody
-> BHBody c
mkBHBodyFakeVRF (NatNonce Natural
bnonce) UnitInterval
l =
  (Seed
 -> SignKeyVRF (VRF c) -> CertifiedVRF (VRF c) (WithResult Seed))
-> (Seed
    -> SignKeyVRF (VRF c) -> CertifiedVRF (VRF c) (WithResult Seed))
-> ProtVer
-> HashHeader
-> AllIssuerKeys c r
-> SlotNo
-> BlockNo
-> Nonce
-> OCert c
-> Word32
-> Hash HASH EraIndependentBlockBody
-> BHBody c
forall a c b (r :: KeyRole).
(Coercible a (CertifiedVRF (VRF c) Nonce),
 Coercible b (CertifiedVRF (VRF c) Natural)) =>
(Seed -> SignKeyVRF (VRF c) -> a)
-> (Seed -> SignKeyVRF (VRF c) -> b)
-> ProtVer
-> HashHeader
-> AllIssuerKeys c r
-> SlotNo
-> BlockNo
-> Nonce
-> OCert c
-> Word32
-> Hash HASH EraIndependentBlockBody
-> BHBody c
mkBHBodyWithVRF
    (\Seed
nonce -> ContextVRF (VRF c)
-> WithResult Seed
-> SignKeyVRF (VRF c)
-> CertifiedVRF (VRF c) (WithResult Seed)
forall v a.
(VRFAlgorithm v, Signable v a) =>
ContextVRF v -> a -> SignKeyVRF v -> CertifiedVRF v a
VRF.evalCertified () (Seed -> Word64 -> WithResult Seed
forall a. a -> Word64 -> WithResult a
WithResult Seed
nonce (Natural -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
bnonce)))
    (\Seed
nonce -> ContextVRF (VRF c)
-> WithResult Seed
-> SignKeyVRF (VRF c)
-> CertifiedVRF (VRF c) (WithResult Seed)
forall v a.
(VRFAlgorithm v, Signable v a) =>
ContextVRF v -> a -> SignKeyVRF v -> CertifiedVRF v a
VRF.evalCertified () (Seed -> Word64 -> WithResult Seed
forall a. a -> Word64 -> WithResult a
WithResult Seed
nonce (UnitInterval -> Word64
unitIntervalToWord64 UnitInterval
l)))

-- | Try to map the unit interval to a 64bit natural number. We don't care whether
-- this is surjective. But it should be right inverse to `fromNatural` - that
-- is, one should be able to recover the `UnitInterval` value used here.
unitIntervalToWord64 :: UnitInterval -> Word64
unitIntervalToWord64 :: UnitInterval -> Word64
unitIntervalToWord64 UnitInterval
ui =
  Ratio Integer -> Word64
forall {a}. Num a => Ratio Integer -> a
toWord64 ((Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Word64
forall a. Bounded a => a
maxBound :: Word64) Integer -> Integer -> Ratio Integer
forall a. Integral a => a -> a -> Ratio a
% Integer
1) Ratio Integer -> Ratio Integer -> Ratio Integer
forall a. Num a => a -> a -> a
* UnitInterval -> Ratio Integer
forall r. BoundedRational r => r -> Ratio Integer
unboundRational UnitInterval
ui)
  where
    toWord64 :: Ratio Integer -> a
toWord64 Ratio Integer
r = Integer -> a
forall a. Num a => Integer -> a
fromInteger (Ratio Integer -> Integer
forall a. Ratio a -> a
numerator Ratio Integer
r Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`quot` Ratio Integer -> Integer
forall a. Ratio a -> a
denominator Ratio Integer
r)

mkBHBodyWithVRF ::
  ( Coercible a (VRF.CertifiedVRF (VRF c) Nonce)
  , Coercible b (VRF.CertifiedVRF (VRF c) Natural)
  ) =>
  (Seed -> VRF.SignKeyVRF (VRF c) -> a) ->
  (Seed -> VRF.SignKeyVRF (VRF c) -> b) ->
  ProtVer ->
  HashHeader ->
  AllIssuerKeys c r ->
  SlotNo ->
  BlockNo ->
  Nonce ->
  OCert c ->
  Word32 ->
  Hash HASH EraIndependentBlockBody ->
  BHBody c
mkBHBodyWithVRF :: forall a c b (r :: KeyRole).
(Coercible a (CertifiedVRF (VRF c) Nonce),
 Coercible b (CertifiedVRF (VRF c) Natural)) =>
(Seed -> SignKeyVRF (VRF c) -> a)
-> (Seed -> SignKeyVRF (VRF c) -> b)
-> ProtVer
-> HashHeader
-> AllIssuerKeys c r
-> SlotNo
-> BlockNo
-> Nonce
-> OCert c
-> Word32
-> Hash HASH EraIndependentBlockBody
-> BHBody c
mkBHBodyWithVRF Seed -> SignKeyVRF (VRF c) -> a
mkVrfEta Seed -> SignKeyVRF (VRF c) -> b
mkVrfL ProtVer
protVer HashHeader
prev AllIssuerKeys c r
pKeys SlotNo
slotNo BlockNo
blockNo Nonce
enonce OCert c
oCert Word32
bodySize Hash HASH EraIndependentBlockBody
bodyHash =
  let nonceNonce :: Seed
nonceNonce = Nonce -> SlotNo -> Nonce -> Seed
mkSeed Nonce
seedEta SlotNo
slotNo Nonce
enonce
      leaderNonce :: Seed
leaderNonce = Nonce -> SlotNo -> Nonce -> Seed
mkSeed Nonce
seedL SlotNo
slotNo Nonce
enonce
      vKeyCold :: VKey r
vKeyCold = KeyPair r -> VKey r
forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey (KeyPair r -> VKey r) -> KeyPair r -> VKey r
forall a b. (a -> b) -> a -> b
$ AllIssuerKeys c r -> KeyPair r
forall c (r :: KeyRole). AllIssuerKeys c r -> KeyPair r
aikCold AllIssuerKeys c r
pKeys
   in BHBody
        { bheaderBlockNo :: BlockNo
bheaderBlockNo = BlockNo
blockNo
        , bheaderSlotNo :: SlotNo
bheaderSlotNo = SlotNo
slotNo
        , bheaderPrev :: PrevHash
bheaderPrev = HashHeader -> PrevHash
BlockHash HashHeader
prev
        , bheaderVk :: VKey 'BlockIssuer
bheaderVk = VKey r -> VKey 'BlockIssuer
forall (r :: KeyRole) (r' :: KeyRole). VKey r -> VKey r'
forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole VKey r
vKeyCold
        , bheaderVrfVk :: VerKeyVRF (VRF c)
bheaderVrfVk = VRFKeyPair c -> VerKeyVRF (VRF c)
forall c. VRFKeyPair c -> VerKeyVRF (VRF c)
vrfVerKey (VRFKeyPair c -> VerKeyVRF (VRF c))
-> VRFKeyPair c -> VerKeyVRF (VRF c)
forall a b. (a -> b) -> a -> b
$ AllIssuerKeys c r -> VRFKeyPair c
forall c (r :: KeyRole). AllIssuerKeys c r -> VRFKeyPair c
aikVrf AllIssuerKeys c r
pKeys
        , bheaderEta :: CertifiedVRF (VRF c) Nonce
bheaderEta = a -> CertifiedVRF (VRF c) Nonce
forall a b. Coercible a b => a -> b
coerce (a -> CertifiedVRF (VRF c) Nonce)
-> a -> CertifiedVRF (VRF c) Nonce
forall a b. (a -> b) -> a -> b
$ Seed -> SignKeyVRF (VRF c) -> a
mkVrfEta Seed
nonceNonce (VRFKeyPair c -> SignKeyVRF (VRF c)
forall c. VRFKeyPair c -> SignKeyVRF (VRF c)
vrfSignKey (VRFKeyPair c -> SignKeyVRF (VRF c))
-> VRFKeyPair c -> SignKeyVRF (VRF c)
forall a b. (a -> b) -> a -> b
$ AllIssuerKeys c r -> VRFKeyPair c
forall c (r :: KeyRole). AllIssuerKeys c r -> VRFKeyPair c
aikVrf AllIssuerKeys c r
pKeys)
        , bheaderL :: CertifiedVRF (VRF c) Natural
bheaderL = b -> CertifiedVRF (VRF c) Natural
forall a b. Coercible a b => a -> b
coerce (b -> CertifiedVRF (VRF c) Natural)
-> b -> CertifiedVRF (VRF c) Natural
forall a b. (a -> b) -> a -> b
$ Seed -> SignKeyVRF (VRF c) -> b
mkVrfL Seed
leaderNonce (VRFKeyPair c -> SignKeyVRF (VRF c)
forall c. VRFKeyPair c -> SignKeyVRF (VRF c)
vrfSignKey (VRFKeyPair c -> SignKeyVRF (VRF c))
-> VRFKeyPair c -> SignKeyVRF (VRF c)
forall a b. (a -> b) -> a -> b
$ AllIssuerKeys c r -> VRFKeyPair c
forall c (r :: KeyRole). AllIssuerKeys c r -> VRFKeyPair c
aikVrf AllIssuerKeys c r
pKeys)
        , bsize :: Word32
bsize = Word32
bodySize
        , bhash :: Hash HASH EraIndependentBlockBody
bhash = Hash HASH EraIndependentBlockBody
bodyHash
        , bheaderOCert :: OCert c
bheaderOCert = OCert c
oCert
        , bprotver :: ProtVer
bprotver = ProtVer
protVer
        }

mkBHeader ::
  (Crypto c, KES.Signable (KES c) (BHBody c)) =>
  AllIssuerKeys c r ->
  Word ->
  -- | KES period of key registration
  Word ->
  BHBody c ->
  BHeader c
mkBHeader :: forall c (r :: KeyRole).
(Crypto c, Signable (KES c) (BHBody c)) =>
AllIssuerKeys c r -> Word -> Word -> BHBody c -> BHeader c
mkBHeader AllIssuerKeys c r
pKeys Word
kesPeriod Word
keyRegKesPeriod BHBody c
bhBody =
  let sHot :: UnsoundPureSignKeyKES (KES c)
sHot = KESKeyPair c -> UnsoundPureSignKeyKES (KES c)
forall c. KESKeyPair c -> UnsoundPureSignKeyKES (KES c)
kesSignKey (KESKeyPair c -> UnsoundPureSignKeyKES (KES c))
-> KESKeyPair c -> UnsoundPureSignKeyKES (KES c)
forall a b. (a -> b) -> a -> b
$ (KESPeriod, KESKeyPair c) -> KESKeyPair c
forall a b. (a, b) -> b
snd ((KESPeriod, KESKeyPair c) -> KESKeyPair c)
-> (KESPeriod, KESKeyPair c) -> KESKeyPair c
forall a b. (a -> b) -> a -> b
$ NonEmpty (KESPeriod, KESKeyPair c) -> (KESPeriod, KESKeyPair c)
forall a. NonEmpty a -> a
NE.head (NonEmpty (KESPeriod, KESKeyPair c) -> (KESPeriod, KESKeyPair c))
-> NonEmpty (KESPeriod, KESKeyPair c) -> (KESPeriod, KESKeyPair c)
forall a b. (a -> b) -> a -> b
$ AllIssuerKeys c r -> NonEmpty (KESPeriod, KESKeyPair c)
forall c (r :: KeyRole).
AllIssuerKeys c r -> NonEmpty (KESPeriod, KESKeyPair c)
aikHot AllIssuerKeys c r
pKeys
      kpDiff :: Word
kpDiff = Word
kesPeriod Word -> Word -> Word
forall a. Num a => a -> a -> a
- Word
keyRegKesPeriod
      hotKey :: UnsoundPureSignKeyKES (KES c)
hotKey = case UnsoundPureSignKeyKES (KES c)
-> KESPeriod -> KESPeriod -> Maybe (UnsoundPureSignKeyKES (KES c))
forall c.
(UnsoundPureKESAlgorithm c, ContextKES c ~ ()) =>
UnsoundPureSignKeyKES c
-> KESPeriod -> KESPeriod -> Maybe (UnsoundPureSignKeyKES c)
evolveKESUntil UnsoundPureSignKeyKES (KES c)
sHot (Word -> KESPeriod
KESPeriod Word
0) (Word -> KESPeriod
KESPeriod Word
kpDiff) of
        Maybe (UnsoundPureSignKeyKES (KES c))
Nothing ->
          String -> UnsoundPureSignKeyKES (KES c)
forall a. HasCallStack => String -> a
error (String -> UnsoundPureSignKeyKES (KES c))
-> String -> UnsoundPureSignKeyKES (KES c)
forall a b. (a -> b) -> a -> b
$
            [String] -> String
forall a. Monoid a => [a] -> a
mconcat
              [ String
"Could not evolve key to iteration. "
              , String
"keyRegKesPeriod: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word -> String
forall a. Show a => a -> String
show Word
keyRegKesPeriod
              , String
"kesPeriod: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word -> String
forall a. Show a => a -> String
show Word
kesPeriod
              , String
"kpDiff: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word -> String
forall a. Show a => a -> String
show Word
kpDiff
              ]
        Just UnsoundPureSignKeyKES (KES c)
hKey -> UnsoundPureSignKeyKES (KES c)
hKey
      sig :: SignedKES (KES c) (BHBody c)
sig = ContextKES (KES c)
-> Word
-> BHBody c
-> UnsoundPureSignKeyKES (KES c)
-> SignedKES (KES c) (BHBody c)
forall v a.
(UnsoundPureKESAlgorithm v, Signable v a) =>
ContextKES v
-> Word -> a -> UnsoundPureSignKeyKES v -> SignedKES v a
KES.unsoundPureSignedKES () Word
kpDiff BHBody c
bhBody UnsoundPureSignKeyKES (KES c)
hotKey
   in BHBody c -> SignedKES (KES c) (BHBody c) -> BHeader c
forall c.
Crypto c =>
BHBody c -> SignedKES (KES c) (BHBody c) -> BHeader c
BHeader BHBody c
bhBody SignedKES (KES c) (BHBody c)
sig

-- | Try to evolve KES key until specific KES period is reached, given the
-- current KES period.
evolveKESUntil ::
  (KES.UnsoundPureKESAlgorithm c, KES.ContextKES c ~ ()) =>
  KES.UnsoundPureSignKeyKES c ->
  -- | Current KES period
  KESPeriod ->
  -- | Target KES period
  KESPeriod ->
  Maybe (KES.UnsoundPureSignKeyKES c)
evolveKESUntil :: forall c.
(UnsoundPureKESAlgorithm c, ContextKES c ~ ()) =>
UnsoundPureSignKeyKES c
-> KESPeriod -> KESPeriod -> Maybe (UnsoundPureSignKeyKES c)
evolveKESUntil UnsoundPureSignKeyKES c
sk1 (KESPeriod Word
current) (KESPeriod Word
target) = UnsoundPureSignKeyKES c
-> Word -> Word -> Maybe (UnsoundPureSignKeyKES c)
forall {v}.
(ContextKES v ~ (), UnsoundPureKESAlgorithm v) =>
UnsoundPureSignKeyKES v
-> Word -> Word -> Maybe (UnsoundPureSignKeyKES v)
go UnsoundPureSignKeyKES c
sk1 Word
current Word
target
  where
    go :: UnsoundPureSignKeyKES v
-> Word -> Word -> Maybe (UnsoundPureSignKeyKES v)
go !UnsoundPureSignKeyKES v
_ Word
c Word
t | Word
t Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
< Word
c = Maybe (UnsoundPureSignKeyKES v)
forall a. Maybe a
Nothing
    go !UnsoundPureSignKeyKES v
sk Word
c Word
t | Word
c Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
== Word
t = UnsoundPureSignKeyKES v -> Maybe (UnsoundPureSignKeyKES v)
forall a. a -> Maybe a
Just UnsoundPureSignKeyKES v
sk
    go !UnsoundPureSignKeyKES v
sk Word
c Word
t = case ContextKES v
-> UnsoundPureSignKeyKES v
-> Word
-> Maybe (UnsoundPureSignKeyKES v)
forall v.
UnsoundPureKESAlgorithm v =>
ContextKES v
-> UnsoundPureSignKeyKES v
-> Word
-> Maybe (UnsoundPureSignKeyKES v)
KES.unsoundPureUpdateKES () UnsoundPureSignKeyKES v
sk Word
c of
      Maybe (UnsoundPureSignKeyKES v)
Nothing -> Maybe (UnsoundPureSignKeyKES v)
forall a. Maybe a
Nothing
      Just UnsoundPureSignKeyKES v
sk' -> UnsoundPureSignKeyKES v
-> Word -> Word -> Maybe (UnsoundPureSignKeyKES v)
go UnsoundPureSignKeyKES v
sk' (Word
c Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
1) Word
t

mkBlock ::
  forall era r c.
  ( Crypto c
  , EraBlockBody era
  , VRF.Signable (VRF c) Seed
  , KES.Signable (KES c) (BHBody c)
  ) =>
  -- | Hash of previous block
  HashHeader ->
  -- | All keys in the stake pool
  AllIssuerKeys c r ->
  -- | Transactions to record
  [Tx era] ->
  -- | Current slot
  SlotNo ->
  -- | Block number/chain length/chain "difficulty"
  BlockNo ->
  -- | EpochNo nonce
  Nonce ->
  -- | Period of KES (key evolving signature scheme)
  Word ->
  -- | KES period of key registration
  Word ->
  -- | Operational certificate
  OCert c ->
  Block (BHeader c) era
mkBlock :: forall era (r :: KeyRole) c.
(Crypto c, EraBlockBody era, Signable (VRF c) Seed,
 Signable (KES c) (BHBody c)) =>
HashHeader
-> AllIssuerKeys c r
-> [Tx era]
-> SlotNo
-> BlockNo
-> Nonce
-> Word
-> Word
-> OCert c
-> Block (BHeader c) era
mkBlock HashHeader
prev AllIssuerKeys c r
pKeys [Tx era]
txns SlotNo
slotNo BlockNo
blockNo Nonce
enonce Word
kesPeriod Word
keyRegKesPeriod OCert c
oCert =
  let protVer :: ProtVer
protVer = Version -> Natural -> ProtVer
ProtVer (forall era. Era era => Version
eraProtVerHigh @era) Natural
0
      blockBody :: BlockBody era
blockBody = BlockBody era
forall era. EraBlockBody era => BlockBody era
mkBasicBlockBody BlockBody era -> (BlockBody era -> BlockBody era) -> BlockBody era
forall a b. a -> (a -> b) -> b
& (StrictSeq (Tx era) -> Identity (StrictSeq (Tx era)))
-> BlockBody era -> Identity (BlockBody era)
forall era.
EraBlockBody era =>
Lens' (BlockBody era) (StrictSeq (Tx era))
Lens' (BlockBody era) (StrictSeq (Tx era))
txSeqBlockBodyL ((StrictSeq (Tx era) -> Identity (StrictSeq (Tx era)))
 -> BlockBody era -> Identity (BlockBody era))
-> StrictSeq (Tx era) -> BlockBody era -> BlockBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Tx era] -> StrictSeq (Tx era)
forall a. [a] -> StrictSeq a
StrictSeq.fromList [Tx era]
txns
      bodySize :: Word32
bodySize = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ ProtVer -> BlockBody era -> Int
forall era. EraBlockBody era => ProtVer -> BlockBody era -> Int
bBodySize ProtVer
protVer BlockBody era
blockBody
      bodyHash :: Hash HASH EraIndependentBlockBody
bodyHash = forall era.
EraBlockBody era =>
BlockBody era -> Hash HASH EraIndependentBlockBody
hashBlockBody @era BlockBody era
blockBody
      bhBody :: BHBody c
bhBody = ProtVer
-> HashHeader
-> AllIssuerKeys c r
-> SlotNo
-> BlockNo
-> Nonce
-> OCert c
-> Word32
-> Hash HASH EraIndependentBlockBody
-> BHBody c
forall c (r :: KeyRole).
(ContextVRF (VRF c) ~ (), Signable (VRF c) Seed,
 VRFAlgorithm (VRF c)) =>
ProtVer
-> HashHeader
-> AllIssuerKeys c r
-> SlotNo
-> BlockNo
-> Nonce
-> OCert c
-> Word32
-> Hash HASH EraIndependentBlockBody
-> BHBody c
mkBHBody ProtVer
protVer HashHeader
prev AllIssuerKeys c r
pKeys SlotNo
slotNo BlockNo
blockNo Nonce
enonce OCert c
oCert Word32
bodySize Hash HASH EraIndependentBlockBody
bodyHash
      bHeader :: BHeader c
bHeader = AllIssuerKeys c r -> Word -> Word -> BHBody c -> BHeader c
forall c (r :: KeyRole).
(Crypto c, Signable (KES c) (BHBody c)) =>
AllIssuerKeys c r -> Word -> Word -> BHBody c -> BHeader c
mkBHeader AllIssuerKeys c r
pKeys Word
kesPeriod Word
keyRegKesPeriod BHBody c
bhBody
   in BHeader c -> BlockBody era -> Block (BHeader c) era
forall h era. h -> BlockBody era -> Block h era
Block BHeader c
bHeader BlockBody era
blockBody

-- | Create a block with a faked VRF result.
mkBlockFakeVRF ::
  forall era r c.
  ( Crypto c
  , EraBlockBody era
  , VRF.Signable (VRF c) (WithResult Seed)
  , KES.Signable (KES c) (BHBody c)
  ) =>
  -- | Hash of previous block
  HashHeader ->
  -- | All keys in the stake pool
  AllIssuerKeys c r ->
  -- | Transactions to record
  [Tx era] ->
  -- | Current slot
  SlotNo ->
  -- | Block number\/chain length\/chain "difficulty"
  BlockNo ->
  -- | EpochNo nonce
  Nonce ->
  -- | Block nonce
  NatNonce ->
  -- | Praos leader value
  UnitInterval ->
  -- | Period of KES (key evolving signature scheme)
  Word ->
  -- | KES period of key registration
  Word ->
  -- | Operational certificate
  OCert c ->
  Block (BHeader c) era
mkBlockFakeVRF :: forall era (r :: KeyRole) c.
(Crypto c, EraBlockBody era, Signable (VRF c) (WithResult Seed),
 Signable (KES c) (BHBody c)) =>
HashHeader
-> AllIssuerKeys c r
-> [Tx era]
-> SlotNo
-> BlockNo
-> Nonce
-> NatNonce
-> UnitInterval
-> Word
-> Word
-> OCert c
-> Block (BHeader c) era
mkBlockFakeVRF HashHeader
prev AllIssuerKeys c r
pKeys [Tx era]
txns SlotNo
slotNo BlockNo
blockNo Nonce
enonce NatNonce
bnonce UnitInterval
l Word
kesPeriod Word
keyRegKesPeriod OCert c
oCert =
  let protVer :: ProtVer
protVer = Version -> Natural -> ProtVer
ProtVer (forall era. Era era => Version
eraProtVerHigh @era) Natural
0
      blockBody :: BlockBody era
blockBody = BlockBody era
forall era. EraBlockBody era => BlockBody era
mkBasicBlockBody BlockBody era -> (BlockBody era -> BlockBody era) -> BlockBody era
forall a b. a -> (a -> b) -> b
& (StrictSeq (Tx era) -> Identity (StrictSeq (Tx era)))
-> BlockBody era -> Identity (BlockBody era)
forall era.
EraBlockBody era =>
Lens' (BlockBody era) (StrictSeq (Tx era))
Lens' (BlockBody era) (StrictSeq (Tx era))
txSeqBlockBodyL ((StrictSeq (Tx era) -> Identity (StrictSeq (Tx era)))
 -> BlockBody era -> Identity (BlockBody era))
-> StrictSeq (Tx era) -> BlockBody era -> BlockBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Tx era] -> StrictSeq (Tx era)
forall a. [a] -> StrictSeq a
StrictSeq.fromList [Tx era]
txns
      bodySize :: Word32
bodySize = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ ProtVer -> BlockBody era -> Int
forall era. EraBlockBody era => ProtVer -> BlockBody era -> Int
bBodySize ProtVer
protVer BlockBody era
blockBody
      bodyHash :: Hash HASH EraIndependentBlockBody
bodyHash = BlockBody era -> Hash HASH EraIndependentBlockBody
forall era.
EraBlockBody era =>
BlockBody era -> Hash HASH EraIndependentBlockBody
hashBlockBody BlockBody era
blockBody
      bhBody :: BHBody c
bhBody =
        NatNonce
-> UnitInterval
-> ProtVer
-> HashHeader
-> AllIssuerKeys c r
-> SlotNo
-> BlockNo
-> Nonce
-> OCert c
-> Word32
-> Hash HASH EraIndependentBlockBody
-> BHBody c
forall c (r :: KeyRole).
(ContextVRF (VRF c) ~ (), Signable (VRF c) (WithResult Seed),
 VRFAlgorithm (VRF c)) =>
NatNonce
-> UnitInterval
-> ProtVer
-> HashHeader
-> AllIssuerKeys c r
-> SlotNo
-> BlockNo
-> Nonce
-> OCert c
-> Word32
-> Hash HASH EraIndependentBlockBody
-> BHBody c
mkBHBodyFakeVRF NatNonce
bnonce UnitInterval
l ProtVer
protVer HashHeader
prev AllIssuerKeys c r
pKeys SlotNo
slotNo BlockNo
blockNo Nonce
enonce OCert c
oCert Word32
bodySize Hash HASH EraIndependentBlockBody
bodyHash
      bHeader :: BHeader c
bHeader = AllIssuerKeys c r -> Word -> Word -> BHBody c -> BHeader c
forall c (r :: KeyRole).
(Crypto c, Signable (KES c) (BHBody c)) =>
AllIssuerKeys c r -> Word -> Word -> BHBody c -> BHeader c
mkBHeader AllIssuerKeys c r
pKeys Word
kesPeriod Word
keyRegKesPeriod BHBody c
bhBody
   in BHeader c -> BlockBody era -> Block (BHeader c) era
forall h era. h -> BlockBody era -> Block h era
Block BHeader c
bHeader BlockBody era
blockBody