{-# 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 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 = Rational
-> CompactForm Coin
-> VRFVerKeyHash 'StakePoolVRF
-> IndividualPoolStake
IndividualPoolStake Rational
1 (Integer -> CompactForm Coin
coin Integer
1) VRFVerKeyHash 'StakePoolVRF
vrfKey
  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 PraosVRF -> VerKeyVRF PraosVRF
forall v. VRFAlgorithm v => SignKeyVRF v -> VerKeyVRF v
deriveVerKeyVRF SignKeyVRF PraosVRF
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 ShelleyProtocolHeader (Praos StandardCrypto)
Header 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