{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Cardano.Node.Protocol.Shelley (
mkSomeConsensusProtocolShelley
, GenesisReadError (..)
, GenesisValidationError (..)
, PraosLeaderCredentialsError (..)
, ShelleyProtocolInstantiationError (..)
, genesisHashToPraosNonce
, readGenesis
, readGenesisAny
, readLeaderCredentials
, validateGenesis
) where
import Cardano.Api.Any hiding (FileError (..))
import qualified Cardano.Api.Any as Api (FileError (..))
import Cardano.Api.Key
import Cardano.Api.KeysPraos as Praos
import Cardano.Api.KeysShelley
import Cardano.Api.OperationalCertificate
import qualified Cardano.Api.Protocol.Types as Protocol
import Cardano.Api.SerialiseTextEnvelope
import qualified Cardano.Crypto.Hash.Class as Crypto
import Cardano.Ledger.BaseTypes (ProtVer (..), natVersion)
import Cardano.Ledger.Keys (coerceKeyRole)
import qualified Cardano.Ledger.Shelley.Genesis as Shelley
import Cardano.Node.Protocol.Types
import Cardano.Node.Types
import Cardano.Prelude
import Cardano.Protocol.Crypto (StandardCrypto)
import Control.Monad.Trans.Except.Extra (firstExceptT,
handleIOExceptT, hoistEither, left, newExceptT)
import qualified Data.Aeson as Aeson (FromJSON (..), eitherDecodeStrict')
import qualified Data.ByteString as BS
import qualified Data.Text as T
import qualified Ouroboros.Consensus.Cardano as Consensus
import Ouroboros.Consensus.Protocol.Praos.Common
(PraosCanBeLeader (..))
import Ouroboros.Consensus.Shelley.Node (Nonce (..),
ProtocolParamsShelleyBased (..), ShelleyGenesis (..),
ShelleyLeaderCredentials (..))
import Prelude (String, id)
mkSomeConsensusProtocolShelley ::
NodeShelleyProtocolConfiguration
-> Maybe ProtocolFilepaths
-> ExceptT ShelleyProtocolInstantiationError IO SomeConsensusProtocol
mkSomeConsensusProtocolShelley :: NodeShelleyProtocolConfiguration
-> Maybe ProtocolFilepaths
-> ExceptT
ShelleyProtocolInstantiationError IO SomeConsensusProtocol
mkSomeConsensusProtocolShelley NodeShelleyProtocolConfiguration {
GenesisFile
npcShelleyGenesisFile :: GenesisFile
npcShelleyGenesisFile :: NodeShelleyProtocolConfiguration -> GenesisFile
npcShelleyGenesisFile,
Maybe GenesisHash
npcShelleyGenesisFileHash :: Maybe GenesisHash
npcShelleyGenesisFileHash :: NodeShelleyProtocolConfiguration -> Maybe GenesisHash
npcShelleyGenesisFileHash
}
Maybe ProtocolFilepaths
files = do
(genesis, genesisHash) <- (GenesisReadError -> ShelleyProtocolInstantiationError)
-> ExceptT GenesisReadError IO (ShelleyGenesis, GenesisHash)
-> ExceptT
ShelleyProtocolInstantiationError IO (ShelleyGenesis, GenesisHash)
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT GenesisReadError -> ShelleyProtocolInstantiationError
GenesisReadError (ExceptT GenesisReadError IO (ShelleyGenesis, GenesisHash)
-> ExceptT
ShelleyProtocolInstantiationError IO (ShelleyGenesis, GenesisHash))
-> ExceptT GenesisReadError IO (ShelleyGenesis, GenesisHash)
-> ExceptT
ShelleyProtocolInstantiationError IO (ShelleyGenesis, GenesisHash)
forall a b. (a -> b) -> a -> b
$
GenesisFile
-> Maybe GenesisHash
-> ExceptT GenesisReadError IO (ShelleyGenesis, GenesisHash)
readGenesis GenesisFile
npcShelleyGenesisFile
Maybe GenesisHash
npcShelleyGenesisFileHash
firstExceptT GenesisValidationError $ validateGenesis genesis
leaderCredentials <- firstExceptT PraosLeaderCredentialsError $
readLeaderCredentials files
return $ SomeConsensusProtocol Protocol.ShelleyBlockType $ Protocol.ProtocolInfoArgsShelley
genesis
Consensus.ProtocolParamsShelleyBased {
shelleyBasedInitialNonce = genesisHashToPraosNonce genesisHash,
shelleyBasedLeaderCredentials =
leaderCredentials
}
(ProtVer (natVersion @2) 0)
genesisHashToPraosNonce :: GenesisHash -> Nonce
genesisHashToPraosNonce :: GenesisHash -> Nonce
genesisHashToPraosNonce (GenesisHash Hash Blake2b_256 ByteString
h) = Hash Blake2b_256 Nonce -> Nonce
Nonce (Hash Blake2b_256 ByteString -> Hash Blake2b_256 Nonce
forall h a b. Hash h a -> Hash h b
Crypto.castHash Hash Blake2b_256 ByteString
h)
readGenesis :: GenesisFile
-> Maybe GenesisHash
-> ExceptT GenesisReadError IO
(ShelleyGenesis, GenesisHash)
readGenesis :: GenesisFile
-> Maybe GenesisHash
-> ExceptT GenesisReadError IO (ShelleyGenesis, GenesisHash)
readGenesis = GenesisFile
-> Maybe GenesisHash
-> ExceptT GenesisReadError IO (ShelleyGenesis, GenesisHash)
forall genesis.
FromJSON genesis =>
GenesisFile
-> Maybe GenesisHash
-> ExceptT GenesisReadError IO (genesis, GenesisHash)
readGenesisAny
readGenesisAny :: Aeson.FromJSON genesis
=> GenesisFile
-> Maybe GenesisHash
-> ExceptT GenesisReadError IO (genesis, GenesisHash)
readGenesisAny :: forall genesis.
FromJSON genesis =>
GenesisFile
-> Maybe GenesisHash
-> ExceptT GenesisReadError IO (genesis, GenesisHash)
readGenesisAny (GenesisFile String
file) Maybe GenesisHash
mbExpectedGenesisHash = do
content <- (IOException -> GenesisReadError)
-> IO ByteString -> ExceptT GenesisReadError IO ByteString
forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT (String -> IOException -> GenesisReadError
GenesisReadFileError String
file) (IO ByteString -> ExceptT GenesisReadError IO ByteString)
-> IO ByteString -> ExceptT GenesisReadError IO ByteString
forall a b. (a -> b) -> a -> b
$
String -> IO ByteString
BS.readFile String
file
let genesisHash = Hash Blake2b_256 ByteString -> GenesisHash
GenesisHash ((ByteString -> ByteString)
-> ByteString -> Hash Blake2b_256 ByteString
forall h a. HashAlgorithm h => (a -> ByteString) -> a -> Hash h a
Crypto.hashWith ByteString -> ByteString
forall a. a -> a
id ByteString
content)
checkExpectedGenesisHash genesisHash
genesis <- firstExceptT (GenesisDecodeError file) $ hoistEither $
Aeson.eitherDecodeStrict' content
return (genesis, genesisHash)
where
checkExpectedGenesisHash :: GenesisHash
-> ExceptT GenesisReadError IO ()
checkExpectedGenesisHash :: GenesisHash -> ExceptT GenesisReadError IO ()
checkExpectedGenesisHash GenesisHash
actual =
case Maybe GenesisHash
mbExpectedGenesisHash of
Just GenesisHash
expected | GenesisHash
actual GenesisHash -> GenesisHash -> Bool
forall a. Eq a => a -> a -> Bool
/= GenesisHash
expected
-> GenesisReadError -> ExceptT GenesisReadError IO ()
forall a. GenesisReadError -> ExceptT GenesisReadError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GenesisHash -> GenesisHash -> GenesisReadError
GenesisHashMismatch GenesisHash
actual GenesisHash
expected)
Maybe GenesisHash
_ -> () -> ExceptT GenesisReadError IO ()
forall a. a -> ExceptT GenesisReadError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
validateGenesis :: ShelleyGenesis
-> ExceptT GenesisValidationError IO ()
validateGenesis :: ShelleyGenesis -> ExceptT GenesisValidationError IO ()
validateGenesis ShelleyGenesis
genesis =
([ValidationErr] -> GenesisValidationError)
-> ExceptT [ValidationErr] IO ()
-> ExceptT GenesisValidationError IO ()
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT [ValidationErr] -> GenesisValidationError
GenesisValidationErrors (ExceptT [ValidationErr] IO ()
-> ExceptT GenesisValidationError IO ())
-> (Either [ValidationErr] () -> ExceptT [ValidationErr] IO ())
-> Either [ValidationErr] ()
-> ExceptT GenesisValidationError IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Either [ValidationErr] () -> ExceptT [ValidationErr] IO ()
forall (m :: * -> *) x a. Monad m => Either x a -> ExceptT x m a
hoistEither (Either [ValidationErr] () -> ExceptT GenesisValidationError IO ())
-> Either [ValidationErr] ()
-> ExceptT GenesisValidationError IO ()
forall a b. (a -> b) -> a -> b
$
ShelleyGenesis -> Either [ValidationErr] ()
Shelley.validateGenesis ShelleyGenesis
genesis
readLeaderCredentials ::
Maybe ProtocolFilepaths
-> ExceptT PraosLeaderCredentialsError IO [ShelleyLeaderCredentials StandardCrypto]
readLeaderCredentials :: Maybe ProtocolFilepaths
-> ExceptT
PraosLeaderCredentialsError
IO
[ShelleyLeaderCredentials StandardCrypto]
readLeaderCredentials Maybe ProtocolFilepaths
Nothing = [ShelleyLeaderCredentials StandardCrypto]
-> ExceptT
PraosLeaderCredentialsError
IO
[ShelleyLeaderCredentials StandardCrypto]
forall a. a -> ExceptT PraosLeaderCredentialsError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
readLeaderCredentials (Just ProtocolFilepaths
pfp) =
[ShelleyLeaderCredentials StandardCrypto]
-> [ShelleyLeaderCredentials StandardCrypto]
-> [ShelleyLeaderCredentials StandardCrypto]
forall a. Semigroup a => a -> a -> a
(<>) ([ShelleyLeaderCredentials StandardCrypto]
-> [ShelleyLeaderCredentials StandardCrypto]
-> [ShelleyLeaderCredentials StandardCrypto])
-> ExceptT
PraosLeaderCredentialsError
IO
[ShelleyLeaderCredentials StandardCrypto]
-> ExceptT
PraosLeaderCredentialsError
IO
([ShelleyLeaderCredentials StandardCrypto]
-> [ShelleyLeaderCredentials StandardCrypto])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProtocolFilepaths
-> ExceptT
PraosLeaderCredentialsError
IO
[ShelleyLeaderCredentials StandardCrypto]
readLeaderCredentialsSingleton ProtocolFilepaths
pfp
ExceptT
PraosLeaderCredentialsError
IO
([ShelleyLeaderCredentials StandardCrypto]
-> [ShelleyLeaderCredentials StandardCrypto])
-> ExceptT
PraosLeaderCredentialsError
IO
[ShelleyLeaderCredentials StandardCrypto]
-> ExceptT
PraosLeaderCredentialsError
IO
[ShelleyLeaderCredentials StandardCrypto]
forall a b.
ExceptT PraosLeaderCredentialsError IO (a -> b)
-> ExceptT PraosLeaderCredentialsError IO a
-> ExceptT PraosLeaderCredentialsError IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ProtocolFilepaths
-> ExceptT
PraosLeaderCredentialsError
IO
[ShelleyLeaderCredentials StandardCrypto]
readLeaderCredentialsBulk ProtocolFilepaths
pfp
readLeaderCredentialsSingleton ::
ProtocolFilepaths ->
ExceptT PraosLeaderCredentialsError IO
[ShelleyLeaderCredentials StandardCrypto]
readLeaderCredentialsSingleton :: ProtocolFilepaths
-> ExceptT
PraosLeaderCredentialsError
IO
[ShelleyLeaderCredentials StandardCrypto]
readLeaderCredentialsSingleton
ProtocolFilepaths
{ shelleyCertFile :: ProtocolFilepaths -> Maybe String
shelleyCertFile = Maybe String
Nothing,
shelleyVRFFile :: ProtocolFilepaths -> Maybe String
shelleyVRFFile = Maybe String
Nothing,
shelleyKESFile :: ProtocolFilepaths -> Maybe String
shelleyKESFile = Maybe String
Nothing
} = [ShelleyLeaderCredentials StandardCrypto]
-> ExceptT
PraosLeaderCredentialsError
IO
[ShelleyLeaderCredentials StandardCrypto]
forall a. a -> ExceptT PraosLeaderCredentialsError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
readLeaderCredentialsSingleton
ProtocolFilepaths { shelleyCertFile :: ProtocolFilepaths -> Maybe String
shelleyCertFile = Just String
opCertFile,
shelleyVRFFile :: ProtocolFilepaths -> Maybe String
shelleyVRFFile = Just String
vrfFile,
shelleyKESFile :: ProtocolFilepaths -> Maybe String
shelleyKESFile = Just String
kesFile
} = do
vrfSKey <-
(FileError TextEnvelopeError -> PraosLeaderCredentialsError)
-> ExceptT (FileError TextEnvelopeError) IO (SigningKey VrfKey)
-> ExceptT PraosLeaderCredentialsError IO (SigningKey VrfKey)
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT FileError TextEnvelopeError -> PraosLeaderCredentialsError
FileError (IO (Either (FileError TextEnvelopeError) (SigningKey VrfKey))
-> ExceptT (FileError TextEnvelopeError) IO (SigningKey VrfKey)
forall (m :: * -> *) x a. m (Either x a) -> ExceptT x m a
newExceptT (IO (Either (FileError TextEnvelopeError) (SigningKey VrfKey))
-> ExceptT (FileError TextEnvelopeError) IO (SigningKey VrfKey))
-> IO (Either (FileError TextEnvelopeError) (SigningKey VrfKey))
-> ExceptT (FileError TextEnvelopeError) IO (SigningKey VrfKey)
forall a b. (a -> b) -> a -> b
$ AsType (SigningKey VrfKey)
-> String
-> IO (Either (FileError TextEnvelopeError) (SigningKey VrfKey))
forall a.
HasTextEnvelope a =>
AsType a -> String -> IO (Either (FileError TextEnvelopeError) a)
readFileTextEnvelope (AsType VrfKey -> AsType (SigningKey VrfKey)
forall a. AsType a -> AsType (SigningKey a)
AsSigningKey AsType VrfKey
AsVrfKey) String
vrfFile)
(opCert, kesSKey) <- opCertKesKeyCheck kesFile opCertFile
return [mkPraosLeaderCredentials opCert vrfSKey kesSKey]
readLeaderCredentialsSingleton ProtocolFilepaths {shelleyCertFile :: ProtocolFilepaths -> Maybe String
shelleyCertFile = Maybe String
Nothing} =
PraosLeaderCredentialsError
-> ExceptT
PraosLeaderCredentialsError
IO
[ShelleyLeaderCredentials StandardCrypto]
forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left PraosLeaderCredentialsError
OCertNotSpecified
readLeaderCredentialsSingleton ProtocolFilepaths {shelleyVRFFile :: ProtocolFilepaths -> Maybe String
shelleyVRFFile = Maybe String
Nothing} =
PraosLeaderCredentialsError
-> ExceptT
PraosLeaderCredentialsError
IO
[ShelleyLeaderCredentials StandardCrypto]
forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left PraosLeaderCredentialsError
VRFKeyNotSpecified
readLeaderCredentialsSingleton ProtocolFilepaths {shelleyKESFile :: ProtocolFilepaths -> Maybe String
shelleyKESFile = Maybe String
Nothing} =
PraosLeaderCredentialsError
-> ExceptT
PraosLeaderCredentialsError
IO
[ShelleyLeaderCredentials StandardCrypto]
forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left PraosLeaderCredentialsError
KESKeyNotSpecified
opCertKesKeyCheck ::
FilePath
-> FilePath
-> ExceptT PraosLeaderCredentialsError IO (OperationalCertificate, SigningKey KesKey)
opCertKesKeyCheck :: String
-> String
-> ExceptT
PraosLeaderCredentialsError
IO
(OperationalCertificate, SigningKey KesKey)
opCertKesKeyCheck String
kesFile String
certFile = do
opCert <-
(FileError TextEnvelopeError -> PraosLeaderCredentialsError)
-> ExceptT (FileError TextEnvelopeError) IO OperationalCertificate
-> ExceptT PraosLeaderCredentialsError IO OperationalCertificate
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT FileError TextEnvelopeError -> PraosLeaderCredentialsError
FileError (IO (Either (FileError TextEnvelopeError) OperationalCertificate)
-> ExceptT (FileError TextEnvelopeError) IO OperationalCertificate
forall (m :: * -> *) x a. m (Either x a) -> ExceptT x m a
newExceptT (IO (Either (FileError TextEnvelopeError) OperationalCertificate)
-> ExceptT (FileError TextEnvelopeError) IO OperationalCertificate)
-> IO (Either (FileError TextEnvelopeError) OperationalCertificate)
-> ExceptT (FileError TextEnvelopeError) IO OperationalCertificate
forall a b. (a -> b) -> a -> b
$ AsType OperationalCertificate
-> String
-> IO (Either (FileError TextEnvelopeError) OperationalCertificate)
forall a.
HasTextEnvelope a =>
AsType a -> String -> IO (Either (FileError TextEnvelopeError) a)
readFileTextEnvelope AsType OperationalCertificate
AsOperationalCertificate String
certFile)
kesSKey <-
firstExceptT FileError (newExceptT $ readFileTextEnvelope (AsSigningKey AsKesKey) kesFile)
let opCertSpecifiedKesKeyhash = VerificationKey KesKey -> Hash KesKey
forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
verificationKeyHash (VerificationKey KesKey -> Hash KesKey)
-> VerificationKey KesKey -> Hash KesKey
forall a b. (a -> b) -> a -> b
$ OperationalCertificate -> VerificationKey KesKey
getHotKey OperationalCertificate
opCert
suppliedKesKeyHash = VerificationKey KesKey -> Hash KesKey
forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
verificationKeyHash (VerificationKey KesKey -> Hash KesKey)
-> VerificationKey KesKey -> Hash KesKey
forall a b. (a -> b) -> a -> b
$ SigningKey KesKey -> VerificationKey KesKey
forall keyrole.
Key keyrole =>
SigningKey keyrole -> VerificationKey keyrole
getVerificationKey SigningKey KesKey
kesSKey
if suppliedKesKeyHash /= opCertSpecifiedKesKeyhash
then left $ MismatchedKesKey kesFile certFile
else return (opCert, kesSKey)
data ShelleyCredentials
= ShelleyCredentials
{ ShelleyCredentials -> (TextEnvelope, String)
scCert :: (TextEnvelope, FilePath)
, ShelleyCredentials -> (TextEnvelope, String)
scVrf :: (TextEnvelope, FilePath)
, ShelleyCredentials -> (TextEnvelope, String)
scKes :: (TextEnvelope, FilePath)
}
readLeaderCredentialsBulk ::
ProtocolFilepaths
-> ExceptT PraosLeaderCredentialsError IO [ShelleyLeaderCredentials StandardCrypto]
readLeaderCredentialsBulk :: ProtocolFilepaths
-> ExceptT
PraosLeaderCredentialsError
IO
[ShelleyLeaderCredentials StandardCrypto]
readLeaderCredentialsBulk ProtocolFilepaths { shelleyBulkCredsFile :: ProtocolFilepaths -> Maybe String
shelleyBulkCredsFile = Maybe String
mfp } =
(ShelleyCredentials
-> ExceptT
PraosLeaderCredentialsError
IO
(ShelleyLeaderCredentials StandardCrypto))
-> [ShelleyCredentials]
-> ExceptT
PraosLeaderCredentialsError
IO
[ShelleyLeaderCredentials StandardCrypto]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ShelleyCredentials
-> ExceptT
PraosLeaderCredentialsError
IO
(ShelleyLeaderCredentials StandardCrypto)
parseShelleyCredentials ([ShelleyCredentials]
-> ExceptT
PraosLeaderCredentialsError
IO
[ShelleyLeaderCredentials StandardCrypto])
-> ExceptT PraosLeaderCredentialsError IO [ShelleyCredentials]
-> ExceptT
PraosLeaderCredentialsError
IO
[ShelleyLeaderCredentials StandardCrypto]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe String
-> ExceptT PraosLeaderCredentialsError IO [ShelleyCredentials]
readBulkFile Maybe String
mfp
where
parseShelleyCredentials
:: ShelleyCredentials
-> ExceptT PraosLeaderCredentialsError IO (ShelleyLeaderCredentials StandardCrypto)
parseShelleyCredentials :: ShelleyCredentials
-> ExceptT
PraosLeaderCredentialsError
IO
(ShelleyLeaderCredentials StandardCrypto)
parseShelleyCredentials ShelleyCredentials { (TextEnvelope, String)
scCert :: ShelleyCredentials -> (TextEnvelope, String)
scCert :: (TextEnvelope, String)
scCert, (TextEnvelope, String)
scVrf :: ShelleyCredentials -> (TextEnvelope, String)
scVrf :: (TextEnvelope, String)
scVrf, (TextEnvelope, String)
scKes :: ShelleyCredentials -> (TextEnvelope, String)
scKes :: (TextEnvelope, String)
scKes } = do
OperationalCertificate
-> SigningKey VrfKey
-> SigningKey KesKey
-> ShelleyLeaderCredentials StandardCrypto
mkPraosLeaderCredentials
(OperationalCertificate
-> SigningKey VrfKey
-> SigningKey KesKey
-> ShelleyLeaderCredentials StandardCrypto)
-> ExceptT PraosLeaderCredentialsError IO OperationalCertificate
-> ExceptT
PraosLeaderCredentialsError
IO
(SigningKey VrfKey
-> SigningKey KesKey -> ShelleyLeaderCredentials StandardCrypto)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AsType OperationalCertificate
-> (TextEnvelope, String)
-> ExceptT PraosLeaderCredentialsError IO OperationalCertificate
forall a.
HasTextEnvelope a =>
AsType a
-> (TextEnvelope, String)
-> ExceptT PraosLeaderCredentialsError IO a
parseEnvelope AsType OperationalCertificate
AsOperationalCertificate (TextEnvelope, String)
scCert
ExceptT
PraosLeaderCredentialsError
IO
(SigningKey VrfKey
-> SigningKey KesKey -> ShelleyLeaderCredentials StandardCrypto)
-> ExceptT PraosLeaderCredentialsError IO (SigningKey VrfKey)
-> ExceptT
PraosLeaderCredentialsError
IO
(SigningKey KesKey -> ShelleyLeaderCredentials StandardCrypto)
forall a b.
ExceptT PraosLeaderCredentialsError IO (a -> b)
-> ExceptT PraosLeaderCredentialsError IO a
-> ExceptT PraosLeaderCredentialsError IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AsType (SigningKey VrfKey)
-> (TextEnvelope, String)
-> ExceptT PraosLeaderCredentialsError IO (SigningKey VrfKey)
forall a.
HasTextEnvelope a =>
AsType a
-> (TextEnvelope, String)
-> ExceptT PraosLeaderCredentialsError IO a
parseEnvelope (AsType VrfKey -> AsType (SigningKey VrfKey)
forall a. AsType a -> AsType (SigningKey a)
AsSigningKey AsType VrfKey
AsVrfKey) (TextEnvelope, String)
scVrf
ExceptT
PraosLeaderCredentialsError
IO
(SigningKey KesKey -> ShelleyLeaderCredentials StandardCrypto)
-> ExceptT PraosLeaderCredentialsError IO (SigningKey KesKey)
-> ExceptT
PraosLeaderCredentialsError
IO
(ShelleyLeaderCredentials StandardCrypto)
forall a b.
ExceptT PraosLeaderCredentialsError IO (a -> b)
-> ExceptT PraosLeaderCredentialsError IO a
-> ExceptT PraosLeaderCredentialsError IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AsType (SigningKey KesKey)
-> (TextEnvelope, String)
-> ExceptT PraosLeaderCredentialsError IO (SigningKey KesKey)
forall a.
HasTextEnvelope a =>
AsType a
-> (TextEnvelope, String)
-> ExceptT PraosLeaderCredentialsError IO a
parseEnvelope (AsType KesKey -> AsType (SigningKey KesKey)
forall a. AsType a -> AsType (SigningKey a)
AsSigningKey AsType KesKey
AsKesKey) (TextEnvelope, String)
scKes
readBulkFile
:: Maybe FilePath
-> ExceptT PraosLeaderCredentialsError IO [ShelleyCredentials]
readBulkFile :: Maybe String
-> ExceptT PraosLeaderCredentialsError IO [ShelleyCredentials]
readBulkFile Maybe String
Nothing = [ShelleyCredentials]
-> ExceptT PraosLeaderCredentialsError IO [ShelleyCredentials]
forall a. a -> ExceptT PraosLeaderCredentialsError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
readBulkFile (Just String
fp) = do
content <- (IOException -> PraosLeaderCredentialsError)
-> IO ByteString
-> ExceptT PraosLeaderCredentialsError IO ByteString
forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT (String -> IOException -> PraosLeaderCredentialsError
CredentialsReadError String
fp) (IO ByteString
-> ExceptT PraosLeaderCredentialsError IO ByteString)
-> IO ByteString
-> ExceptT PraosLeaderCredentialsError IO ByteString
forall a b. (a -> b) -> a -> b
$
String -> IO ByteString
BS.readFile String
fp
envelopes <- firstExceptT (EnvelopeParseError fp) $ hoistEither $
Aeson.eitherDecodeStrict' content
pure $ uncurry mkCredentials <$> zip [0..] envelopes
where
mkCredentials :: Int -> (TextEnvelope, TextEnvelope, TextEnvelope)
-> ShelleyCredentials
mkCredentials :: Int
-> (TextEnvelope, TextEnvelope, TextEnvelope) -> ShelleyCredentials
mkCredentials Int
ix (TextEnvelope
teCert, TextEnvelope
teVrf, TextEnvelope
teKes) =
let loc :: String -> String
loc String
ty = String
fp String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a b. (Show a, ConvertText String b) => a -> b
show Int
ix String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
ty
in (TextEnvelope, String)
-> (TextEnvelope, String)
-> (TextEnvelope, String)
-> ShelleyCredentials
ShelleyCredentials (TextEnvelope
teCert, String -> String
loc String
"cert")
(TextEnvelope
teVrf, String -> String
loc String
"vrf")
(TextEnvelope
teKes, String -> String
loc String
"kes")
mkPraosLeaderCredentials ::
OperationalCertificate
-> SigningKey VrfKey
-> SigningKey KesKey
-> ShelleyLeaderCredentials StandardCrypto
mkPraosLeaderCredentials :: OperationalCertificate
-> SigningKey VrfKey
-> SigningKey KesKey
-> ShelleyLeaderCredentials StandardCrypto
mkPraosLeaderCredentials
(OperationalCertificate OCert StandardCrypto
opcert (StakePoolVerificationKey VKey 'StakePool
vkey))
(VrfSigningKey SignKeyVRF (VRF StandardCrypto)
vrfKey)
(KesSigningKey UnsoundPureSignKeyKES (KES StandardCrypto)
kesKey) =
ShelleyLeaderCredentials
{ shelleyLeaderCredentialsCanBeLeader :: PraosCanBeLeader StandardCrypto
shelleyLeaderCredentialsCanBeLeader =
PraosCanBeLeader {
praosCanBeLeaderOpCert :: OCert StandardCrypto
praosCanBeLeaderOpCert = OCert StandardCrypto
opcert,
praosCanBeLeaderColdVerKey :: VKey 'BlockIssuer
praosCanBeLeaderColdVerKey = VKey 'StakePool -> 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 'StakePool
vkey,
praosCanBeLeaderSignKeyVRF :: SignKeyVRF (VRF StandardCrypto)
praosCanBeLeaderSignKeyVRF = SignKeyVRF (VRF StandardCrypto)
vrfKey
},
shelleyLeaderCredentialsInitSignKey :: UnsoundPureSignKeyKES (KES StandardCrypto)
shelleyLeaderCredentialsInitSignKey = UnsoundPureSignKeyKES (KES StandardCrypto)
kesKey,
shelleyLeaderCredentialsLabel :: Text
shelleyLeaderCredentialsLabel = Text
"Shelley"
}
parseEnvelope ::
HasTextEnvelope a
=> AsType a
-> (TextEnvelope, String)
-> ExceptT PraosLeaderCredentialsError IO a
parseEnvelope :: forall a.
HasTextEnvelope a =>
AsType a
-> (TextEnvelope, String)
-> ExceptT PraosLeaderCredentialsError IO a
parseEnvelope AsType a
as (TextEnvelope
te, String
loc) =
(TextEnvelopeError -> PraosLeaderCredentialsError)
-> ExceptT TextEnvelopeError IO a
-> ExceptT PraosLeaderCredentialsError IO a
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT (FileError TextEnvelopeError -> PraosLeaderCredentialsError
FileError (FileError TextEnvelopeError -> PraosLeaderCredentialsError)
-> (TextEnvelopeError -> FileError TextEnvelopeError)
-> TextEnvelopeError
-> PraosLeaderCredentialsError
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> TextEnvelopeError -> FileError TextEnvelopeError
forall e. String -> e -> FileError e
Api.FileError String
loc) (ExceptT TextEnvelopeError IO a
-> ExceptT PraosLeaderCredentialsError IO a)
-> (Either TextEnvelopeError a -> ExceptT TextEnvelopeError IO a)
-> Either TextEnvelopeError a
-> ExceptT PraosLeaderCredentialsError IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Either TextEnvelopeError a -> ExceptT TextEnvelopeError IO a
forall (m :: * -> *) x a. Monad m => Either x a -> ExceptT x m a
hoistEither (Either TextEnvelopeError a
-> ExceptT PraosLeaderCredentialsError IO a)
-> Either TextEnvelopeError a
-> ExceptT PraosLeaderCredentialsError IO a
forall a b. (a -> b) -> a -> b
$
AsType a -> TextEnvelope -> Either TextEnvelopeError a
forall a.
HasTextEnvelope a =>
AsType a -> TextEnvelope -> Either TextEnvelopeError a
deserialiseFromTextEnvelope AsType a
as TextEnvelope
te
data ShelleyProtocolInstantiationError =
GenesisReadError GenesisReadError
| GenesisValidationError GenesisValidationError
| PraosLeaderCredentialsError PraosLeaderCredentialsError
deriving Int -> ShelleyProtocolInstantiationError -> String -> String
[ShelleyProtocolInstantiationError] -> String -> String
ShelleyProtocolInstantiationError -> String
(Int -> ShelleyProtocolInstantiationError -> String -> String)
-> (ShelleyProtocolInstantiationError -> String)
-> ([ShelleyProtocolInstantiationError] -> String -> String)
-> Show ShelleyProtocolInstantiationError
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ShelleyProtocolInstantiationError -> String -> String
showsPrec :: Int -> ShelleyProtocolInstantiationError -> String -> String
$cshow :: ShelleyProtocolInstantiationError -> String
show :: ShelleyProtocolInstantiationError -> String
$cshowList :: [ShelleyProtocolInstantiationError] -> String -> String
showList :: [ShelleyProtocolInstantiationError] -> String -> String
Show
instance Error ShelleyProtocolInstantiationError where
displayError :: ShelleyProtocolInstantiationError -> String
displayError (GenesisReadError GenesisReadError
err) = GenesisReadError -> String
forall e. Error e => e -> String
displayError GenesisReadError
err
displayError (GenesisValidationError GenesisValidationError
err) = GenesisValidationError -> String
forall e. Error e => e -> String
displayError GenesisValidationError
err
displayError (PraosLeaderCredentialsError PraosLeaderCredentialsError
err) = PraosLeaderCredentialsError -> String
forall e. Error e => e -> String
displayError PraosLeaderCredentialsError
err
data GenesisReadError =
GenesisReadFileError !FilePath !IOException
| GenesisHashMismatch !GenesisHash !GenesisHash
| GenesisDecodeError !FilePath !String
deriving Int -> GenesisReadError -> String -> String
[GenesisReadError] -> String -> String
GenesisReadError -> String
(Int -> GenesisReadError -> String -> String)
-> (GenesisReadError -> String)
-> ([GenesisReadError] -> String -> String)
-> Show GenesisReadError
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> GenesisReadError -> String -> String
showsPrec :: Int -> GenesisReadError -> String -> String
$cshow :: GenesisReadError -> String
show :: GenesisReadError -> String
$cshowList :: [GenesisReadError] -> String -> String
showList :: [GenesisReadError] -> String -> String
Show
instance Error GenesisReadError where
displayError :: GenesisReadError -> String
displayError (GenesisReadFileError String
fp IOException
err) =
String
"There was an error reading the genesis file: "
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a b. ConvertText a b => a -> b
toS String
fp String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" Error: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> IOException -> String
forall a b. (Show a, ConvertText String b) => a -> b
show IOException
err
displayError (GenesisHashMismatch GenesisHash
actual GenesisHash
expected) =
String
"Wrong genesis file: the actual hash is " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> GenesisHash -> String
forall a b. (Show a, ConvertText String b) => a -> b
show GenesisHash
actual
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", but the expected genesis hash given in the node "
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"configuration file is " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> GenesisHash -> String
forall a b. (Show a, ConvertText String b) => a -> b
show GenesisHash
expected
displayError (GenesisDecodeError String
fp String
err) =
String
"There was an error parsing the genesis file: "
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a b. ConvertText a b => a -> b
toS String
fp String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" Error: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a b. (Show a, ConvertText String b) => a -> b
show String
err
newtype GenesisValidationError = GenesisValidationErrors [Shelley.ValidationErr]
deriving Int -> GenesisValidationError -> String -> String
[GenesisValidationError] -> String -> String
GenesisValidationError -> String
(Int -> GenesisValidationError -> String -> String)
-> (GenesisValidationError -> String)
-> ([GenesisValidationError] -> String -> String)
-> Show GenesisValidationError
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> GenesisValidationError -> String -> String
showsPrec :: Int -> GenesisValidationError -> String -> String
$cshow :: GenesisValidationError -> String
show :: GenesisValidationError -> String
$cshowList :: [GenesisValidationError] -> String -> String
showList :: [GenesisValidationError] -> String -> String
Show
instance Error GenesisValidationError where
displayError :: GenesisValidationError -> String
displayError (GenesisValidationErrors [ValidationErr]
vErrs) =
Text -> String
T.unpack ([Text] -> Text
unlines ((ValidationErr -> Text) -> [ValidationErr] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map ValidationErr -> Text
Shelley.describeValidationErr [ValidationErr]
vErrs))
data PraosLeaderCredentialsError =
CredentialsReadError !FilePath !IOException
| EnvelopeParseError !FilePath !String
| FileError !(Api.FileError TextEnvelopeError)
| OCertNotSpecified
| VRFKeyNotSpecified
| KESKeyNotSpecified
| MismatchedKesKey
FilePath
FilePath
deriving Int -> PraosLeaderCredentialsError -> String -> String
[PraosLeaderCredentialsError] -> String -> String
PraosLeaderCredentialsError -> String
(Int -> PraosLeaderCredentialsError -> String -> String)
-> (PraosLeaderCredentialsError -> String)
-> ([PraosLeaderCredentialsError] -> String -> String)
-> Show PraosLeaderCredentialsError
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> PraosLeaderCredentialsError -> String -> String
showsPrec :: Int -> PraosLeaderCredentialsError -> String -> String
$cshow :: PraosLeaderCredentialsError -> String
show :: PraosLeaderCredentialsError -> String
$cshowList :: [PraosLeaderCredentialsError] -> String -> String
showList :: [PraosLeaderCredentialsError] -> String -> String
Show
instance Error PraosLeaderCredentialsError where
displayError :: PraosLeaderCredentialsError -> String
displayError (CredentialsReadError String
fp IOException
err) =
String
"There was an error reading a credentials file: "
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a b. ConvertText a b => a -> b
toS String
fp String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" Error: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> IOException -> String
forall a b. (Show a, ConvertText String b) => a -> b
show IOException
err
displayError (EnvelopeParseError String
fp String
err) =
String
"There was an error parsing a credentials envelope: "
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a b. ConvertText a b => a -> b
toS String
fp String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" Error: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a b. (Show a, ConvertText String b) => a -> b
show String
err
displayError (FileError FileError TextEnvelopeError
fileErr) = FileError TextEnvelopeError -> String
forall e. Error e => e -> String
displayError FileError TextEnvelopeError
fileErr
displayError (MismatchedKesKey String
kesFp String
certFp) =
String
"The KES key provided at: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a b. (Show a, ConvertText String b) => a -> b
show String
kesFp
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" does not match the KES key specified in the operational certificate at: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a b. (Show a, ConvertText String b) => a -> b
show String
certFp
displayError PraosLeaderCredentialsError
OCertNotSpecified = String -> String
missingFlagMessage String
"shelley-operational-certificate"
displayError PraosLeaderCredentialsError
VRFKeyNotSpecified = String -> String
missingFlagMessage String
"shelley-vrf-key"
displayError PraosLeaderCredentialsError
KESKeyNotSpecified = String -> String
missingFlagMessage String
"shelley-kes-key"
missingFlagMessage :: String -> String
missingFlagMessage :: String -> String
missingFlagMessage String
flag =
String
"To create blocks, the --" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
flag String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" must also be specified"