{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}

-- | Tooling to generate and validate (Praos) headers.
module Cardano.Tools.Headers
  ( Options (..)
  , ValidationResult (..)
  , run
  , validate
  ) where

import Cardano.Crypto.DSIGN (deriveVerKeyDSIGN)
import Cardano.Crypto.VRF.Class (deriveVerKeyVRF)
import Cardano.Ledger.Api (ConwayEra)
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Compactible (toCompact)
import Cardano.Ledger.Keys (VKey (..), hashKey)
import Cardano.Ledger.State (IndividualPoolStake (..))
import Cardano.Prelude
  ( ExitCode (..)
  , exitWith
  , forM_
  , hPutStrLn
  , stderr
  )
import Cardano.Protocol.Crypto (StandardCrypto, hashVerKeyVRF)
import Control.Monad.Except (runExcept)
import qualified Data.Aeson as Json
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Map as Map
import Data.Maybe (fromJust)
import Data.Maybe.Strict (StrictMaybe (..))
import Ouroboros.Consensus.Block (validateView)
import Ouroboros.Consensus.Protocol.Praos
  ( Praos
  , doValidateKESSignature
  , doValidateVRFSignature
  )
import Ouroboros.Consensus.Shelley.HFEras ()
import Ouroboros.Consensus.Shelley.Ledger
  ( ShelleyBlock
  , mkShelleyHeader
  )
import Ouroboros.Consensus.Shelley.Protocol.Praos ()
import Test.Ouroboros.Consensus.Protocol.Praos.Header
  ( GeneratorContext (..)
  , MutatedHeader (..)
  , Mutation (..)
  , Sample (..)
  , expectedError
  , generateSamples
  , header
  , mutation
  )

type ConwayBlock = ShelleyBlock (Praos StandardCrypto) ConwayEra

-- * Running Generator
data Options
  = Generate Int
  | Validate

run :: Options -> IO ()
run :: Options -> IO ()
run = \case
  Generate Int
n -> do
    sample <- Int -> IO Sample
generateSamples Int
n
    LBS.putStr $ Json.encode sample <> "\n"
  Options
Validate ->
    ByteString -> Either String Sample
forall a. FromJSON a => ByteString -> Either String a
Json.eitherDecode (ByteString -> Either String Sample)
-> IO ByteString -> IO (Either String Sample)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ByteString
LBS.getContents IO (Either String Sample)
-> (Either String Sample -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left String
err -> Handle -> String -> IO ()
forall a (m :: * -> *). (Print a, MonadIO m) => Handle -> a -> m ()
forall (m :: * -> *). MonadIO m => Handle -> String -> m ()
hPutStrLn Handle
stderr String
err IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)
      Right Sample{[(GeneratorContext, MutatedHeader)]
sample :: [(GeneratorContext, MutatedHeader)]
sample :: Sample -> [(GeneratorContext, MutatedHeader)]
sample} ->
        [(GeneratorContext, MutatedHeader)]
-> ((GeneratorContext, MutatedHeader) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(GeneratorContext, MutatedHeader)]
sample (((GeneratorContext, MutatedHeader) -> IO ()) -> IO ())
-> ((GeneratorContext, MutatedHeader) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(GeneratorContext
context, MutatedHeader
mutatedHeader) -> do
          ValidationResult -> IO ()
forall a. Show a => a -> IO ()
print (ValidationResult -> IO ()) -> ValidationResult -> IO ()
forall a b. (a -> b) -> a -> b
$ GeneratorContext -> MutatedHeader -> ValidationResult
validate GeneratorContext
context MutatedHeader
mutatedHeader

data ValidationResult = Valid !Mutation | Invalid !Mutation !String
  deriving (ValidationResult -> ValidationResult -> Bool
(ValidationResult -> ValidationResult -> Bool)
-> (ValidationResult -> ValidationResult -> Bool)
-> Eq ValidationResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ValidationResult -> ValidationResult -> Bool
== :: ValidationResult -> ValidationResult -> Bool
$c/= :: ValidationResult -> ValidationResult -> Bool
/= :: ValidationResult -> ValidationResult -> Bool
Eq, Int -> ValidationResult -> ShowS
[ValidationResult] -> ShowS
ValidationResult -> String
(Int -> ValidationResult -> ShowS)
-> (ValidationResult -> String)
-> ([ValidationResult] -> ShowS)
-> Show ValidationResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ValidationResult -> ShowS
showsPrec :: Int -> ValidationResult -> ShowS
$cshow :: ValidationResult -> String
show :: ValidationResult -> String
$cshowList :: [ValidationResult] -> ShowS
showList :: [ValidationResult] -> ShowS
Show)

validate :: GeneratorContext -> MutatedHeader -> ValidationResult
validate :: GeneratorContext -> MutatedHeader -> ValidationResult
validate GeneratorContext
context MutatedHeader{Header StandardCrypto
header :: MutatedHeader -> Header StandardCrypto
header :: Header StandardCrypto
header, Mutation
mutation :: MutatedHeader -> Mutation
mutation :: Mutation
mutation} =
  case (Except (PraosValidationErr StandardCrypto) ()
-> Either (PraosValidationErr StandardCrypto) ()
forall e a. Except e a -> Either e a
runExcept (Except (PraosValidationErr StandardCrypto) ()
 -> Either (PraosValidationErr StandardCrypto) ())
-> Except (PraosValidationErr StandardCrypto) ()
-> Either (PraosValidationErr StandardCrypto) ()
forall a b. (a -> b) -> a -> b
$ Except (PraosValidationErr StandardCrypto) ()
validateKES Except (PraosValidationErr StandardCrypto) ()
-> Except (PraosValidationErr StandardCrypto) ()
-> Except (PraosValidationErr StandardCrypto) ()
forall a b.
ExceptT (PraosValidationErr StandardCrypto) Identity a
-> ExceptT (PraosValidationErr StandardCrypto) Identity b
-> ExceptT (PraosValidationErr StandardCrypto) Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Except (PraosValidationErr StandardCrypto) ()
validateVRF, Mutation
mutation) of
    (Left PraosValidationErr StandardCrypto
err, Mutation
mut) | Mutation -> PraosValidationErr StandardCrypto -> Bool
expectedError Mutation
mut PraosValidationErr StandardCrypto
err -> Mutation -> ValidationResult
Valid Mutation
mut
    (Left PraosValidationErr StandardCrypto
err, Mutation
mut) -> Mutation -> String -> ValidationResult
Invalid Mutation
mut (PraosValidationErr StandardCrypto -> String
forall a. Show a => a -> String
show PraosValidationErr StandardCrypto
err)
    (Right ()
_, Mutation
NoMutation) -> Mutation -> ValidationResult
Valid Mutation
NoMutation
    (Right ()
_, Mutation
mut) -> Mutation -> String -> ValidationResult
Invalid Mutation
mut (String -> ValidationResult) -> String -> ValidationResult
forall a b. (a -> b) -> a -> b
$ String
"Expected error from mutation " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Mutation -> String
forall a. Show a => a -> String
show Mutation
mut String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", but validation succeeded"
 where
  GeneratorContext
    { Word64
praosSlotsPerKESPeriod :: Word64
praosSlotsPerKESPeriod :: GeneratorContext -> Word64
praosSlotsPerKESPeriod
    , Word64
praosMaxKESEvo :: Word64
praosMaxKESEvo :: GeneratorContext -> Word64
praosMaxKESEvo
    , Nonce
nonce :: Nonce
nonce :: GeneratorContext -> Nonce
nonce
    , SignKeyDSIGN Ed25519DSIGN
coldSignKey :: SignKeyDSIGN Ed25519DSIGN
coldSignKey :: GeneratorContext -> SignKeyDSIGN Ed25519DSIGN
coldSignKey
    , SignKeyVRF PraosVRF
vrfSignKey :: SignKeyVRF PraosVRF
vrfSignKey :: GeneratorContext -> SignKeyVRF PraosVRF
vrfSignKey
    , Map (KeyHash BlockIssuer) Word64
ocertCounters :: Map (KeyHash BlockIssuer) Word64
ocertCounters :: GeneratorContext -> Map (KeyHash BlockIssuer) Word64
ocertCounters
    , ActiveSlotCoeff
activeSlotCoeff :: ActiveSlotCoeff
activeSlotCoeff :: GeneratorContext -> ActiveSlotCoeff
activeSlotCoeff
    } = GeneratorContext
context
  -- TODO: get these from the context
  coin :: Integer -> CompactForm Coin
coin = Maybe (CompactForm Coin) -> CompactForm Coin
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (CompactForm Coin) -> CompactForm Coin)
-> (Integer -> Maybe (CompactForm Coin))
-> Integer
-> CompactForm Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coin -> Maybe (CompactForm Coin)
forall a. Compactible a => a -> Maybe (CompactForm a)
toCompact (Coin -> Maybe (CompactForm Coin))
-> (Integer -> Coin) -> Integer -> Maybe (CompactForm Coin)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Coin
Coin
  ownsAllStake :: VRFVerKeyHash StakePoolVRF -> IndividualPoolStake
ownsAllStake VRFVerKeyHash StakePoolVRF
vrfKey =
    IndividualPoolStake
      { individualPoolStake :: Ratio Integer
individualPoolStake = Ratio Integer
1
      , individualTotalPoolStake :: CompactForm Coin
individualTotalPoolStake = Integer -> CompactForm Coin
coin Integer
1
      , individualPoolStakeVrf :: VRFVerKeyHash StakePoolVRF
individualPoolStakeVrf = VRFVerKeyHash StakePoolVRF
vrfKey
      , individualPoolStakeBls :: StrictMaybe BlsKey
individualPoolStakeBls = StrictMaybe BlsKey
forall a. StrictMaybe a
SNothing
      }
  poolDistr :: Map (KeyHash kd) IndividualPoolStake
poolDistr = [(KeyHash kd, IndividualPoolStake)]
-> Map (KeyHash kd) IndividualPoolStake
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(KeyHash kd
forall {kd :: KeyRole}. KeyHash kd
poolId, VRFVerKeyHash StakePoolVRF -> IndividualPoolStake
ownsAllStake VRFVerKeyHash StakePoolVRF
forall {r :: KeyRoleVRF}. VRFVerKeyHash r
hashVRFKey)]
  poolId :: KeyHash kd
poolId = VKey kd -> KeyHash kd
forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey (VKey kd -> KeyHash kd) -> VKey kd -> KeyHash kd
forall a b. (a -> b) -> a -> b
$ VerKeyDSIGN Ed25519DSIGN -> VKey kd
forall (kd :: KeyRole). VerKeyDSIGN Ed25519DSIGN -> VKey kd
VKey (VerKeyDSIGN Ed25519DSIGN -> VKey kd)
-> VerKeyDSIGN Ed25519DSIGN -> VKey kd
forall a b. (a -> b) -> a -> b
$ SignKeyDSIGN Ed25519DSIGN -> VerKeyDSIGN Ed25519DSIGN
forall v. DSIGNAlgorithm v => SignKeyDSIGN v -> VerKeyDSIGN v
deriveVerKeyDSIGN SignKeyDSIGN Ed25519DSIGN
coldSignKey
  hashVRFKey :: VRFVerKeyHash r
hashVRFKey = forall c (r :: KeyRoleVRF).
Crypto c =>
VerKeyVRF (VRF c) -> VRFVerKeyHash r
hashVerKeyVRF @StandardCrypto (VerKeyVRF (VRF StandardCrypto) -> VRFVerKeyHash r)
-> VerKeyVRF (VRF StandardCrypto) -> VRFVerKeyHash r
forall a b. (a -> b) -> a -> b
$ SignKeyVRF (VRF StandardCrypto) -> VerKeyVRF (VRF StandardCrypto)
forall v. VRFAlgorithm v => SignKeyVRF v -> VerKeyVRF v
deriveVerKeyVRF SignKeyVRF PraosVRF
SignKeyVRF (VRF StandardCrypto)
vrfSignKey

  headerView :: ValidateView (BlockProtocol ConwayBlock)
headerView = forall blk.
BlockSupportsProtocol blk =>
BlockConfig blk -> Header blk -> ValidateView (BlockProtocol blk)
validateView @ConwayBlock BlockConfig ConwayBlock
forall a. HasCallStack => a
undefined (ShelleyProtocolHeader (Praos StandardCrypto) -> Header ConwayBlock
forall proto era.
ShelleyCompatible proto era =>
ShelleyProtocolHeader proto -> Header (ShelleyBlock proto era)
mkShelleyHeader Header StandardCrypto
ShelleyProtocolHeader (Praos StandardCrypto)
header)
  validateKES :: Except (PraosValidationErr StandardCrypto) ()
validateKES = Word64
-> Word64
-> Map (KeyHash StakePool) IndividualPoolStake
-> Map (KeyHash BlockIssuer) Word64
-> HeaderView StandardCrypto
-> Except (PraosValidationErr StandardCrypto) ()
forall c.
PraosCrypto c =>
Word64
-> Word64
-> Map (KeyHash StakePool) IndividualPoolStake
-> Map (KeyHash BlockIssuer) Word64
-> HeaderView c
-> Except (PraosValidationErr c) ()
doValidateKESSignature Word64
praosMaxKESEvo Word64
praosSlotsPerKESPeriod Map (KeyHash StakePool) IndividualPoolStake
forall {kd :: KeyRole}. Map (KeyHash kd) IndividualPoolStake
poolDistr Map (KeyHash BlockIssuer) Word64
ocertCounters HeaderView StandardCrypto
headerView
  validateVRF :: Except (PraosValidationErr StandardCrypto) ()
validateVRF = Nonce
-> Map (KeyHash StakePool) IndividualPoolStake
-> ActiveSlotCoeff
-> HeaderView StandardCrypto
-> Except (PraosValidationErr StandardCrypto) ()
forall c.
PraosCrypto c =>
Nonce
-> Map (KeyHash StakePool) IndividualPoolStake
-> ActiveSlotCoeff
-> HeaderView c
-> Except (PraosValidationErr c) ()
doValidateVRFSignature Nonce
nonce Map (KeyHash StakePool) IndividualPoolStake
forall {kd :: KeyRole}. Map (KeyHash kd) IndividualPoolStake
poolDistr ActiveSlotCoeff
activeSlotCoeff HeaderView StandardCrypto
headerView