{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Test.Cardano.Protocol.Leios.BlockHeaderSpec (spec) where

import qualified Cardano.Crypto.KES as KES
import Cardano.Crypto.Seed (mkSeedFromBytes)
import Cardano.Ledger.Binary (
  Annotator,
  DecCBOR (decCBOR),
  EncCBOR (encCBOR),
  decodeFullAnnotator,
  encodeBreak,
  encodeFixedSized,
  encodeListLenIndef,
  encodeNullStrictMaybe,
  natVersion,
  serialize,
 )
import Cardano.Ledger.MemoBytes (mkMemoized)
import Cardano.Protocol.Crypto (KES, StandardCrypto)
import Cardano.Protocol.Leios.BlockHeader (
  Header,
  HeaderBody (..),
  HeaderRaw (HeaderRaw),
  headerBody,
  headerSig,
 )
import Control.Monad (foldM)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import Data.Proxy (Proxy (..))
import Test.Cardano.Ledger.Common
import Test.Cardano.Protocol.Leios.BlockHeader.Arbitrary ()

newtype IndefiniteLength = IndefiniteLength (HeaderBody StandardCrypto)

instance EncCBOR IndefiniteLength where
  encCBOR :: IndefiniteLength -> Encoding
encCBOR (IndefiniteLength HeaderBody {Bool
Word32
Hash Blake2b_256 EraIndependentBlockBody
CertifiedVRF (VRF StandardCrypto) InputVRF
VerKeyVRF (VRF StandardCrypto)
StrictMaybe EbReferencesAnnouncement
BlockNo
SlotNo
VKey BlockIssuer
BlockHeaderVersionInfo
OCert StandardCrypto
PrevHash
hbBlockNo :: BlockNo
hbSlotNo :: SlotNo
hbPrev :: PrevHash
hbVk :: VKey BlockIssuer
hbVrfVk :: VerKeyVRF (VRF StandardCrypto)
hbVrfRes :: CertifiedVRF (VRF StandardCrypto) InputVRF
hbBodySize :: Word32
hbBodyHash :: Hash Blake2b_256 EraIndependentBlockBody
hbOCert :: OCert StandardCrypto
hbVersionInfo :: BlockHeaderVersionInfo
hbBlockBodyContainsLeiosCert :: Bool
hbEbReferencesAnnouncement :: StrictMaybe EbReferencesAnnouncement
hbBlockNo :: forall crypto. HeaderBody crypto -> BlockNo
hbSlotNo :: forall crypto. HeaderBody crypto -> SlotNo
hbPrev :: forall crypto. HeaderBody crypto -> PrevHash
hbVk :: forall crypto. HeaderBody crypto -> VKey BlockIssuer
hbVrfVk :: forall crypto. HeaderBody crypto -> VerKeyVRF (VRF crypto)
hbVrfRes :: forall crypto.
HeaderBody crypto -> CertifiedVRF (VRF crypto) InputVRF
hbBodySize :: forall crypto. HeaderBody crypto -> Word32
hbBodyHash :: forall crypto.
HeaderBody crypto -> Hash Blake2b_256 EraIndependentBlockBody
hbOCert :: forall crypto. HeaderBody crypto -> OCert crypto
hbVersionInfo :: forall crypto. HeaderBody crypto -> BlockHeaderVersionInfo
hbBlockBodyContainsLeiosCert :: forall crypto. HeaderBody crypto -> Bool
hbEbReferencesAnnouncement :: forall crypto.
HeaderBody crypto -> StrictMaybe EbReferencesAnnouncement
..}) =
    Encoding
encodeListLenIndef
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> BlockNo -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR BlockNo
hbBlockNo
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> SlotNo -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR SlotNo
hbSlotNo
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> PrevHash -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR PrevHash
hbPrev
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> VKey BlockIssuer -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR VKey BlockIssuer
hbVk
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> VerKeyVRF PraosVRF -> Encoding
forall a. FixedSizeCodec a => a -> Encoding
encodeFixedSized VerKeyVRF PraosVRF
VerKeyVRF (VRF StandardCrypto)
hbVrfVk
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> CertifiedVRF PraosVRF InputVRF -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR CertifiedVRF PraosVRF InputVRF
CertifiedVRF (VRF StandardCrypto) InputVRF
hbVrfRes
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word32 -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Word32
hbBodySize
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Hash Blake2b_256 EraIndependentBlockBody -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Hash Blake2b_256 EraIndependentBlockBody
hbBodyHash
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> OCert StandardCrypto -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR OCert StandardCrypto
hbOCert
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> BlockHeaderVersionInfo -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR BlockHeaderVersionInfo
hbVersionInfo
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Bool -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Bool
hbBlockBodyContainsLeiosCert
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> (EbReferencesAnnouncement -> Encoding)
-> StrictMaybe EbReferencesAnnouncement -> Encoding
forall a. (a -> Encoding) -> StrictMaybe a -> Encoding
encodeNullStrictMaybe EbReferencesAnnouncement -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR StrictMaybe EbReferencesAnnouncement
hbEbReferencesAnnouncement
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Encoding
encodeBreak

spec :: Spec
spec :: Spec
spec =
  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Leios header KES signature over an encoded header body" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$
    [Version] -> (Version -> Spec) -> Spec
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @12 .. Version
forall a. Bounded a => a
maxBound] ((Version -> Spec) -> Spec) -> (Version -> Spec) -> Spec
forall a b. (a -> b) -> a -> b
$ \Version
version ->
      String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe (Version -> String
forall a. Show a => a -> String
show Version
version) (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$
        [(String, HeaderBody StandardCrypto -> Encoding)]
-> ((String, HeaderBody StandardCrypto -> Encoding) -> Spec)
-> Spec
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(String
"canonical", HeaderBody StandardCrypto -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR), (String
"indefinite length", IndefiniteLength -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (IndefiniteLength -> Encoding)
-> (HeaderBody StandardCrypto -> IndefiniteLength)
-> HeaderBody StandardCrypto
-> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderBody StandardCrypto -> IndefiniteLength
IndefiniteLength)] (((String, HeaderBody StandardCrypto -> Encoding) -> Spec) -> Spec)
-> ((String, HeaderBody StandardCrypto -> Encoding) -> Spec)
-> Spec
forall a b. (a -> b) -> a -> b
$
          \(String
encodingName, HeaderBody StandardCrypto -> Encoding
encodeBody) ->
            String
-> (HeaderBody StandardCrypto -> [Word8] -> Gen Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
encodingName ((HeaderBody StandardCrypto -> [Word8] -> Gen Property) -> Spec)
-> (HeaderBody StandardCrypto -> [Word8] -> Gen Property) -> Spec
forall a b. (a -> b) -> a -> b
$ \(HeaderBody StandardCrypto
body :: HeaderBody StandardCrypto) [Word8]
seed -> do
              period <- (Word, Word) -> Gen Word
forall a. (Bounded a, Integral a) => (a, a) -> Gen a
chooseBoundedIntegral (Word
0, Proxy (Sum6KES Ed25519DSIGN Blake2b_256) -> Word
forall v (proxy :: * -> *). KESAlgorithm v => proxy v -> Word
forall (proxy :: * -> *).
proxy (Sum6KES Ed25519DSIGN Blake2b_256) -> Word
KES.totalPeriodsKES (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(KES StandardCrypto)) Word -> Word -> Word
forall a. Num a => a -> a -> a
- Word
1)
              pure $ ioProperty $ do
                let initialSignKey = Seed -> UnsoundPureSignKeyKES (Sum6KES Ed25519DSIGN Blake2b_256)
forall v.
UnsoundPureKESAlgorithm v =>
Seed -> UnsoundPureSignKeyKES v
KES.unsoundPureGenKeyKES (Seed -> UnsoundPureSignKeyKES (Sum6KES Ed25519DSIGN Blake2b_256))
-> Seed -> UnsoundPureSignKeyKES (Sum6KES Ed25519DSIGN Blake2b_256)
forall a b. (a -> b) -> a -> b
$ StrictByteString -> Seed
mkSeedFromBytes (StrictByteString -> Seed) -> StrictByteString -> Seed
forall a b. (a -> b) -> a -> b
$ [Word8] -> StrictByteString
BS.pack [Word8]
seed
                    verificationKey = UnsoundPureSignKeyKES (Sum6KES Ed25519DSIGN Blake2b_256)
-> VerKeyKES (Sum6KES Ed25519DSIGN Blake2b_256)
forall v.
UnsoundPureKESAlgorithm v =>
UnsoundPureSignKeyKES v -> VerKeyKES v
KES.unsoundPureDeriveVerKeyKES UnsoundPureSignKeyKES (Sum6KES Ed25519DSIGN Blake2b_256)
initialSignKey
                signKey <-
                  expectJust $ foldM (KES.unsoundPureUpdateKES ()) initialSignKey $ takeWhile (< period) [0 ..]
                let bodyBytes = Version -> Encoding -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
serialize Version
version (Encoding -> ByteString) -> Encoding -> ByteString
forall a b. (a -> b) -> a -> b
$ HeaderBody StandardCrypto -> Encoding
encodeBody HeaderBody StandardCrypto
body
                signedBody <-
                  expectRight $
                    decodeFullAnnotator
                      version
                      "HeaderBody"
                      (decCBOR @(Annotator (HeaderBody StandardCrypto)))
                      bodyBytes
                let header :: Header StandardCrypto
                    header =
                      Version -> RawType (Header StandardCrypto) -> Header StandardCrypto
forall t.
(EncCBOR (RawType t), Memoized t) =>
Version -> RawType t -> t
mkMemoized Version
version (RawType (Header StandardCrypto) -> Header StandardCrypto)
-> RawType (Header StandardCrypto) -> Header StandardCrypto
forall a b. (a -> b) -> a -> b
$
                        HeaderBody StandardCrypto
-> SignedKES (KES StandardCrypto) (HeaderBody StandardCrypto)
-> HeaderRaw StandardCrypto
forall crypto.
HeaderBody crypto
-> SignedKES (KES crypto) (HeaderBody crypto) -> HeaderRaw crypto
HeaderRaw HeaderBody StandardCrypto
signedBody (SignedKES (KES StandardCrypto) (HeaderBody StandardCrypto)
 -> HeaderRaw StandardCrypto)
-> SignedKES (KES StandardCrypto) (HeaderBody StandardCrypto)
-> HeaderRaw StandardCrypto
forall a b. (a -> b) -> a -> b
$
                          SigKES (KES StandardCrypto)
-> SignedKES (KES StandardCrypto) (HeaderBody StandardCrypto)
forall v a. SigKES v -> SignedKES v a
KES.SignedKES (SigKES (KES StandardCrypto)
 -> SignedKES (KES StandardCrypto) (HeaderBody StandardCrypto))
-> SigKES (KES StandardCrypto)
-> SignedKES (KES StandardCrypto) (HeaderBody StandardCrypto)
forall a b. (a -> b) -> a -> b
$
                            ContextKES (Sum6KES Ed25519DSIGN Blake2b_256)
-> Word
-> StrictByteString
-> UnsoundPureSignKeyKES (Sum6KES Ed25519DSIGN Blake2b_256)
-> 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
-> UnsoundPureSignKeyKES (Sum6KES Ed25519DSIGN Blake2b_256)
-> SigKES (Sum6KES Ed25519DSIGN Blake2b_256)
KES.unsoundPureSignKES () Word
period (ByteString -> StrictByteString
BSL.toStrict ByteString
bodyBytes) UnsoundPureSignKeyKES (Sum6KES Ed25519DSIGN Blake2b_256)
signKey
                decodedHeader <-
                  expectRight $
                    decodeFullAnnotator version "Header" (decCBOR @(Annotator (Header StandardCrypto))) $
                      serialize version header
                KES.verifySignedKES () verificationKey period (headerBody decodedHeader) (headerSig decodedHeader)
                  `shouldBe` Right ()