{-# 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
                     (VRFAlgorithm (deriveVerKeyVRF, hashVerKeyVRF))
import           Cardano.Ledger.Api (ConwayEra, StandardCrypto)
import           Cardano.Ledger.Coin (Coin (..))
import           Cardano.Ledger.Compactible (toCompact)
import           Cardano.Ledger.Keys (VKey (..), hashKey)
import           Cardano.Ledger.PoolDistr (IndividualPoolStake (..))
import           Cardano.Prelude (ExitCode (..), exitWith, forM_, hPutStrLn,
                     stderr)
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 StandardCrypto)

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

run :: Options -> IO ()
run :: Options -> IO ()
run = \case
    Generate Int
n -> do
        Sample
sample <- Int -> IO Sample
generateSamples Int
n
        ByteString -> IO ()
LBS.putStr (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Sample -> ByteString
forall a. ToJSON a => a -> ByteString
Json.encode Sample
sample ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\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 StandardCrypto) Word64
ocertCounters :: Map (KeyHash 'BlockIssuer StandardCrypto) Word64
ocertCounters :: GeneratorContext
-> Map (KeyHash 'BlockIssuer StandardCrypto) 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 :: Hash (HASH c) (VerKeyVRF (VRF c)) -> IndividualPoolStake c
ownsAllStake Hash (HASH c) (VerKeyVRF (VRF c))
vrfKey = Rational
-> CompactForm Coin
-> Hash (HASH c) (VerKeyVRF (VRF c))
-> IndividualPoolStake c
forall c.
Rational
-> CompactForm Coin
-> Hash c (VerKeyVRF c)
-> IndividualPoolStake c
IndividualPoolStake Rational
1 (Integer -> CompactForm Coin
coin Integer
1) Hash (HASH c) (VerKeyVRF (VRF c))
vrfKey
    poolDistr :: Map
  (KeyHash kd StandardCrypto) (IndividualPoolStake StandardCrypto)
poolDistr = [(KeyHash kd StandardCrypto, IndividualPoolStake StandardCrypto)]
-> Map
     (KeyHash kd StandardCrypto) (IndividualPoolStake StandardCrypto)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(KeyHash kd StandardCrypto
forall {kd :: KeyRole}. KeyHash kd StandardCrypto
poolId, Hash (HASH StandardCrypto) (VerKeyVRF (VRF StandardCrypto))
-> IndividualPoolStake StandardCrypto
forall {c}.
Hash (HASH c) (VerKeyVRF (VRF c)) -> IndividualPoolStake c
ownsAllStake Hash (HASH StandardCrypto) (VerKeyVRF PraosVRF)
Hash (HASH StandardCrypto) (VerKeyVRF (VRF StandardCrypto))
hashVRFKey)]
    poolId :: KeyHash kd StandardCrypto
poolId = VKey kd StandardCrypto -> KeyHash kd StandardCrypto
forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
hashKey (VKey kd StandardCrypto -> KeyHash kd StandardCrypto)
-> VKey kd StandardCrypto -> KeyHash kd StandardCrypto
forall a b. (a -> b) -> a -> b
$ VerKeyDSIGN (DSIGN StandardCrypto) -> VKey kd StandardCrypto
forall (kd :: KeyRole) c. VerKeyDSIGN (DSIGN c) -> VKey kd c
VKey (VerKeyDSIGN (DSIGN StandardCrypto) -> VKey kd StandardCrypto)
-> VerKeyDSIGN (DSIGN StandardCrypto) -> VKey kd StandardCrypto
forall a b. (a -> b) -> a -> b
$ SignKeyDSIGN Ed25519DSIGN -> VerKeyDSIGN Ed25519DSIGN
forall v. DSIGNAlgorithm v => SignKeyDSIGN v -> VerKeyDSIGN v
deriveVerKeyDSIGN SignKeyDSIGN Ed25519DSIGN
coldSignKey
    hashVRFKey :: Hash (HASH StandardCrypto) (VerKeyVRF PraosVRF)
hashVRFKey = VerKeyVRF PraosVRF
-> Hash (HASH StandardCrypto) (VerKeyVRF PraosVRF)
forall h.
HashAlgorithm h =>
VerKeyVRF PraosVRF -> Hash h (VerKeyVRF PraosVRF)
forall v h.
(VRFAlgorithm v, HashAlgorithm h) =>
VerKeyVRF v -> Hash h (VerKeyVRF v)
hashVerKeyVRF (VerKeyVRF PraosVRF
 -> Hash (HASH StandardCrypto) (VerKeyVRF PraosVRF))
-> VerKeyVRF PraosVRF
-> Hash (HASH StandardCrypto) (VerKeyVRF PraosVRF)
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 StandardCrypto)
     (IndividualPoolStake StandardCrypto)
-> Map (KeyHash 'BlockIssuer StandardCrypto) Word64
-> HeaderView StandardCrypto
-> Except (PraosValidationErr StandardCrypto) ()
forall c.
PraosCrypto c =>
Word64
-> Word64
-> Map (KeyHash 'StakePool c) (IndividualPoolStake c)
-> Map (KeyHash 'BlockIssuer c) Word64
-> HeaderView c
-> Except (PraosValidationErr c) ()
doValidateKESSignature Word64
praosMaxKESEvo Word64
praosSlotsPerKESPeriod Map
  (KeyHash 'StakePool StandardCrypto)
  (IndividualPoolStake StandardCrypto)
forall {kd :: KeyRole}.
Map
  (KeyHash kd StandardCrypto) (IndividualPoolStake StandardCrypto)
poolDistr Map (KeyHash 'BlockIssuer StandardCrypto) Word64
ocertCounters HeaderView StandardCrypto
headerView
    validateVRF :: Except (PraosValidationErr StandardCrypto) ()
validateVRF = Nonce
-> Map
     (KeyHash 'StakePool StandardCrypto)
     (IndividualPoolStake StandardCrypto)
-> ActiveSlotCoeff
-> HeaderView StandardCrypto
-> Except (PraosValidationErr StandardCrypto) ()
forall c.
PraosCrypto c =>
Nonce
-> Map (KeyHash 'StakePool c) (IndividualPoolStake c)
-> ActiveSlotCoeff
-> HeaderView c
-> Except (PraosValidationErr c) ()
doValidateVRFSignature Nonce
nonce Map
  (KeyHash 'StakePool StandardCrypto)
  (IndividualPoolStake StandardCrypto)
forall {kd :: KeyRole}.
Map
  (KeyHash kd StandardCrypto) (IndividualPoolStake StandardCrypto)
poolDistr ActiveSlotCoeff
activeSlotCoeff HeaderView StandardCrypto
headerView