{-# 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 (..),
  HashHeader,
  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 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
  , EraSegWits 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, EraSegWits 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
      txseq :: TxSeq era
txseq = forall era. EraSegWits era => StrictSeq (Tx era) -> TxSeq era
toTxSeq @era ([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 -> TxSeq era -> Int
forall era. EraSegWits era => ProtVer -> TxSeq era -> Int
bBodySize ProtVer
protVer TxSeq era
txseq
      bodyHash :: Hash HASH EraIndependentBlockBody
bodyHash = forall era.
EraSegWits era =>
TxSeq era -> Hash HASH EraIndependentBlockBody
hashTxSeq @era TxSeq era
txseq
      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 -> TxSeq era -> Block (BHeader c) era
forall h era. h -> TxSeq era -> Block h era
Block BHeader c
bHeader TxSeq era
txseq

-- | Create a block with a faked VRF result.
mkBlockFakeVRF ::
  forall era r c.
  ( Crypto c
  , EraSegWits 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, EraSegWits 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
      txSeq :: TxSeq era
txSeq = forall era. EraSegWits era => StrictSeq (Tx era) -> TxSeq era
toTxSeq @era ([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 -> TxSeq era -> Int
forall era. EraSegWits era => ProtVer -> TxSeq era -> Int
bBodySize ProtVer
protVer TxSeq era
txSeq
      bodyHash :: Hash HASH EraIndependentBlockBody
bodyHash = TxSeq era -> Hash HASH EraIndependentBlockBody
forall era.
EraSegWits era =>
TxSeq era -> Hash HASH EraIndependentBlockBody
hashTxSeq TxSeq era
txSeq
      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 -> TxSeq era -> Block (BHeader c) era
forall h era. h -> TxSeq era -> Block h era
Block BHeader c
bHeader TxSeq era
txSeq