{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Cardano.Node.Protocol.Shelley
  (
    -- * Protocol exposing the specific type
    -- | Use this when you need the specific instance
    mkConsensusProtocolShelley

    -- * Protocols hiding the specific type
    -- | Use this when you want to handle protocols generically
  , mkSomeConsensusProtocolShelley

    -- * Errors
  , ShelleyProtocolInstantiationError(..)
  , renderShelleyProtocolInstantiationError

    -- * Reusable parts
  , readGenesis
  , readLeaderCredentials
  , genesisHashToPraosNonce
  ) where

import           Cardano.Prelude
import           Prelude (String, id)

import qualified Data.Aeson as Aeson
import qualified Data.ByteString as BS
import qualified Data.Text as T

import           Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT, hoistEither,
                     newExceptT)

import qualified Cardano.Crypto.Hash.Class as Crypto

import qualified Ouroboros.Consensus.Cardano as Consensus
import           Ouroboros.Consensus.Cardano.ShelleyHFC

import           Ouroboros.Consensus.Shelley.Node (Nonce (..),
                     ProtocolParamsShelley (..), ShelleyGenesis, TPraosLeaderCredentials (..))
import           Ouroboros.Consensus.Shelley.Protocol (TPraosCanBeLeader (..), StandardCrypto)

import           Shelley.Spec.Ledger.Genesis (ValidationErr (..), describeValidationErr,
                     validateGenesis)
import           Shelley.Spec.Ledger.Keys (coerceKeyRole)
import           Shelley.Spec.Ledger.PParams (ProtVer (..))

import           Cardano.Api.Typed hiding (FileError)
import qualified Cardano.Api.Typed as Api (FileError)

import           Cardano.Node.Types

import           Cardano.Tracing.OrphanInstances.HardFork ()
import           Cardano.Tracing.OrphanInstances.Shelley ()

import           Cardano.Node.Protocol.Types


------------------------------------------------------------------------------
-- Shelley protocol
--

-- | Make 'SomeConsensusProtocol' using the Shelley instance.
--
-- This lets us handle multiple protocols in a generic way.
--
-- This also serves a purpose as a sanity check that we have all the necessary
-- type class instances available.
--
mkSomeConsensusProtocolShelley
  :: NodeShelleyProtocolConfiguration
  -> Maybe ProtocolFilepaths
  -> ExceptT ShelleyProtocolInstantiationError IO SomeConsensusProtocol
mkSomeConsensusProtocolShelley :: NodeShelleyProtocolConfiguration
-> Maybe ProtocolFilepaths
-> ExceptT
     ShelleyProtocolInstantiationError IO SomeConsensusProtocol
mkSomeConsensusProtocolShelley NodeShelleyProtocolConfiguration
nc Maybe ProtocolFilepaths
files =

    -- Applying the SomeConsensusProtocol here is a check that
    -- the type of mkConsensusProtocolShelley fits all the class
    -- constraints we need to run the protocol.
    Protocol
  IO
  (ShelleyBlockHFC StandardShelley)
  (HardForkProtocol '[ShelleyBlock StandardShelley])
-> SomeConsensusProtocol
forall blk.
SomeConsensusProtocolConstraints blk =>
Protocol IO blk (BlockProtocol blk) -> SomeConsensusProtocol
SomeConsensusProtocol (Protocol
   IO
   (ShelleyBlockHFC StandardShelley)
   (HardForkProtocol '[ShelleyBlock StandardShelley])
 -> SomeConsensusProtocol)
-> ExceptT
     ShelleyProtocolInstantiationError
     IO
     (Protocol
        IO
        (ShelleyBlockHFC StandardShelley)
        (HardForkProtocol '[ShelleyBlock StandardShelley]))
-> ExceptT
     ShelleyProtocolInstantiationError IO SomeConsensusProtocol
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NodeShelleyProtocolConfiguration
-> Maybe ProtocolFilepaths
-> ExceptT
     ShelleyProtocolInstantiationError
     IO
     (Protocol
        IO
        (ShelleyBlockHFC StandardShelley)
        (HardForkProtocol '[ShelleyBlock StandardShelley]))
mkConsensusProtocolShelley NodeShelleyProtocolConfiguration
nc Maybe ProtocolFilepaths
files


-- | Instantiate 'Consensus.Protocol' for Shelley specifically.
--
-- Use this when you need to run the consensus with this specific protocol.
--
mkConsensusProtocolShelley
  :: NodeShelleyProtocolConfiguration
  -> Maybe ProtocolFilepaths
  -> ExceptT ShelleyProtocolInstantiationError IO
             (Consensus.Protocol IO (ShelleyBlockHFC StandardShelley)
                                 Consensus.ProtocolShelley)
mkConsensusProtocolShelley :: NodeShelleyProtocolConfiguration
-> Maybe ProtocolFilepaths
-> ExceptT
     ShelleyProtocolInstantiationError
     IO
     (Protocol
        IO
        (ShelleyBlockHFC StandardShelley)
        (HardForkProtocol '[ShelleyBlock StandardShelley]))
mkConsensusProtocolShelley NodeShelleyProtocolConfiguration {
                            GenesisFile
npcShelleyGenesisFile :: NodeShelleyProtocolConfiguration -> GenesisFile
npcShelleyGenesisFile :: GenesisFile
npcShelleyGenesisFile,
                            Maybe GenesisHash
npcShelleyGenesisFileHash :: NodeShelleyProtocolConfiguration -> Maybe GenesisHash
npcShelleyGenesisFileHash :: Maybe GenesisHash
npcShelleyGenesisFileHash,
                            Natural
npcShelleySupportedProtocolVersionMajor :: NodeShelleyProtocolConfiguration -> Natural
npcShelleySupportedProtocolVersionMajor :: Natural
npcShelleySupportedProtocolVersionMajor,
                            Natural
npcShelleySupportedProtocolVersionMinor :: NodeShelleyProtocolConfiguration -> Natural
npcShelleySupportedProtocolVersionMinor :: Natural
npcShelleySupportedProtocolVersionMinor
                          }
                          Maybe ProtocolFilepaths
files = do
    (ShelleyGenesis StandardShelley
genesis, GenesisHash
genesisHash) <- GenesisFile
-> Maybe GenesisHash
-> ExceptT
     ShelleyProtocolInstantiationError
     IO
     (ShelleyGenesis StandardShelley, GenesisHash)
readGenesis GenesisFile
npcShelleyGenesisFile
                                          Maybe GenesisHash
npcShelleyGenesisFileHash
    ([ValidationErr] -> ShelleyProtocolInstantiationError)
-> ExceptT [ValidationErr] IO ()
-> ExceptT ShelleyProtocolInstantiationError IO ()
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT [ValidationErr] -> ShelleyProtocolInstantiationError
GenesisValidationFailure (ExceptT [ValidationErr] IO ()
 -> ExceptT ShelleyProtocolInstantiationError IO ())
-> (Either [ValidationErr] () -> ExceptT [ValidationErr] IO ())
-> Either [ValidationErr] ()
-> ExceptT ShelleyProtocolInstantiationError IO ()
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 ShelleyProtocolInstantiationError IO ())
-> Either [ValidationErr] ()
-> ExceptT ShelleyProtocolInstantiationError IO ()
forall a b. (a -> b) -> a -> b
$ ShelleyGenesis StandardShelley -> Either [ValidationErr] ()
forall era.
Era era =>
ShelleyGenesis era -> Either [ValidationErr] ()
validateGenesis ShelleyGenesis StandardShelley
genesis
    Maybe (TPraosLeaderCredentials StandardCrypto)
optionalLeaderCredentials <- Maybe ProtocolFilepaths
-> ExceptT
     ShelleyProtocolInstantiationError
     IO
     (Maybe (TPraosLeaderCredentials StandardCrypto))
readLeaderCredentials Maybe ProtocolFilepaths
files

    Protocol
  IO
  (ShelleyBlockHFC StandardShelley)
  (HardForkProtocol '[ShelleyBlock StandardShelley])
-> ExceptT
     ShelleyProtocolInstantiationError
     IO
     (Protocol
        IO
        (ShelleyBlockHFC StandardShelley)
        (HardForkProtocol '[ShelleyBlock StandardShelley]))
forall (m :: * -> *) a. Monad m => a -> m a
return (Protocol
   IO
   (ShelleyBlockHFC StandardShelley)
   (HardForkProtocol '[ShelleyBlock StandardShelley])
 -> ExceptT
      ShelleyProtocolInstantiationError
      IO
      (Protocol
         IO
         (ShelleyBlockHFC StandardShelley)
         (HardForkProtocol '[ShelleyBlock StandardShelley])))
-> Protocol
     IO
     (ShelleyBlockHFC StandardShelley)
     (HardForkProtocol '[ShelleyBlock StandardShelley])
-> ExceptT
     ShelleyProtocolInstantiationError
     IO
     (Protocol
        IO
        (ShelleyBlockHFC StandardShelley)
        (HardForkProtocol '[ShelleyBlock StandardShelley]))
forall a b. (a -> b) -> a -> b
$
      ProtocolParamsShelley StandardCrypto []
-> Protocol
     IO
     (ShelleyBlockHFC StandardShelley)
     (HardForkProtocol '[ShelleyBlock StandardShelley])
forall (m :: * -> *).
ProtocolParamsShelley StandardCrypto []
-> Protocol
     m
     (ShelleyBlockHFC StandardShelley)
     (HardForkProtocol '[ShelleyBlock StandardShelley])
Consensus.ProtocolShelley (ProtocolParamsShelley StandardCrypto []
 -> Protocol
      IO
      (ShelleyBlockHFC StandardShelley)
      (HardForkProtocol '[ShelleyBlock StandardShelley]))
-> ProtocolParamsShelley StandardCrypto []
-> Protocol
     IO
     (ShelleyBlockHFC StandardShelley)
     (HardForkProtocol '[ShelleyBlock StandardShelley])
forall a b. (a -> b) -> a -> b
$ ProtocolParamsShelley :: forall c (f :: * -> *).
ShelleyGenesis (ShelleyEra c)
-> Nonce
-> ProtVer
-> f (TPraosLeaderCredentials c)
-> ProtocolParamsShelley c f
Consensus.ProtocolParamsShelley {
        $sel:shelleyGenesis:ProtocolParamsShelley :: ShelleyGenesis StandardShelley
shelleyGenesis = ShelleyGenesis StandardShelley
genesis,
        $sel:shelleyInitialNonce:ProtocolParamsShelley :: Nonce
shelleyInitialNonce = GenesisHash -> Nonce
genesisHashToPraosNonce GenesisHash
genesisHash,
        $sel:shelleyProtVer:ProtocolParamsShelley :: ProtVer
shelleyProtVer =
          Natural -> Natural -> ProtVer
ProtVer
            Natural
npcShelleySupportedProtocolVersionMajor
            Natural
npcShelleySupportedProtocolVersionMinor,
        $sel:shelleyLeaderCredentials:ProtocolParamsShelley :: [TPraosLeaderCredentials StandardCrypto]
shelleyLeaderCredentials =
          Maybe (TPraosLeaderCredentials StandardCrypto)
-> [TPraosLeaderCredentials StandardCrypto]
forall a. Maybe a -> [a]
maybeToList Maybe (TPraosLeaderCredentials StandardCrypto)
optionalLeaderCredentials
      }

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 ShelleyProtocolInstantiationError IO
                       (ShelleyGenesis StandardShelley, GenesisHash)
readGenesis :: GenesisFile
-> Maybe GenesisHash
-> ExceptT
     ShelleyProtocolInstantiationError
     IO
     (ShelleyGenesis StandardShelley, GenesisHash)
readGenesis (GenesisFile FilePath
file) Maybe GenesisHash
mbExpectedGenesisHash = do
    ByteString
content <- (IOException -> ShelleyProtocolInstantiationError)
-> IO ByteString
-> ExceptT ShelleyProtocolInstantiationError IO ByteString
forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT (FilePath -> IOException -> ShelleyProtocolInstantiationError
GenesisReadError FilePath
file) (IO ByteString
 -> ExceptT ShelleyProtocolInstantiationError IO ByteString)
-> IO ByteString
-> ExceptT ShelleyProtocolInstantiationError IO ByteString
forall a b. (a -> b) -> a -> b
$
                 FilePath -> IO ByteString
BS.readFile FilePath
file
    let genesisHash :: GenesisHash
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)
    GenesisHash -> ExceptT ShelleyProtocolInstantiationError IO ()
checkExpectedGenesisHash GenesisHash
genesisHash
    ShelleyGenesis StandardShelley
genesis <- (FilePath -> ShelleyProtocolInstantiationError)
-> ExceptT FilePath IO (ShelleyGenesis StandardShelley)
-> ExceptT
     ShelleyProtocolInstantiationError
     IO
     (ShelleyGenesis StandardShelley)
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT (FilePath -> FilePath -> ShelleyProtocolInstantiationError
GenesisDecodeError FilePath
file) (ExceptT FilePath IO (ShelleyGenesis StandardShelley)
 -> ExceptT
      ShelleyProtocolInstantiationError
      IO
      (ShelleyGenesis StandardShelley))
-> ExceptT FilePath IO (ShelleyGenesis StandardShelley)
-> ExceptT
     ShelleyProtocolInstantiationError
     IO
     (ShelleyGenesis StandardShelley)
forall a b. (a -> b) -> a -> b
$ Either FilePath (ShelleyGenesis StandardShelley)
-> ExceptT FilePath IO (ShelleyGenesis StandardShelley)
forall (m :: * -> *) x a. Monad m => Either x a -> ExceptT x m a
hoistEither (Either FilePath (ShelleyGenesis StandardShelley)
 -> ExceptT FilePath IO (ShelleyGenesis StandardShelley))
-> Either FilePath (ShelleyGenesis StandardShelley)
-> ExceptT FilePath IO (ShelleyGenesis StandardShelley)
forall a b. (a -> b) -> a -> b
$
                 ByteString -> Either FilePath (ShelleyGenesis StandardShelley)
forall a. FromJSON a => ByteString -> Either FilePath a
Aeson.eitherDecodeStrict' ByteString
content
    (ShelleyGenesis StandardShelley, GenesisHash)
-> ExceptT
     ShelleyProtocolInstantiationError
     IO
     (ShelleyGenesis StandardShelley, GenesisHash)
forall (m :: * -> *) a. Monad m => a -> m a
return (ShelleyGenesis StandardShelley
genesis, GenesisHash
genesisHash)
  where
    checkExpectedGenesisHash :: GenesisHash
                             -> ExceptT ShelleyProtocolInstantiationError IO ()
    checkExpectedGenesisHash :: GenesisHash -> ExceptT ShelleyProtocolInstantiationError 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
          -> ShelleyProtocolInstantiationError
-> ExceptT ShelleyProtocolInstantiationError IO ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GenesisHash -> GenesisHash -> ShelleyProtocolInstantiationError
GenesisHashMismatch GenesisHash
actual GenesisHash
expected)
        Maybe GenesisHash
_ -> () -> ExceptT ShelleyProtocolInstantiationError IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


readLeaderCredentials :: Maybe ProtocolFilepaths
                      -> ExceptT ShelleyProtocolInstantiationError IO
                                 (Maybe (TPraosLeaderCredentials StandardCrypto))

-- It's OK to supply none of the files
readLeaderCredentials :: Maybe ProtocolFilepaths
-> ExceptT
     ShelleyProtocolInstantiationError
     IO
     (Maybe (TPraosLeaderCredentials StandardCrypto))
readLeaderCredentials Maybe ProtocolFilepaths
Nothing = Maybe (TPraosLeaderCredentials StandardCrypto)
-> ExceptT
     ShelleyProtocolInstantiationError
     IO
     (Maybe (TPraosLeaderCredentials StandardCrypto))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (TPraosLeaderCredentials StandardCrypto)
forall a. Maybe a
Nothing
readLeaderCredentials (Just ProtocolFilepaths {
                              shelleyCertFile :: ProtocolFilepaths -> Maybe FilePath
shelleyCertFile = Maybe FilePath
Nothing,
                              shelleyVRFFile :: ProtocolFilepaths -> Maybe FilePath
shelleyVRFFile  = Maybe FilePath
Nothing,
                              shelleyKESFile :: ProtocolFilepaths -> Maybe FilePath
shelleyKESFile  = Maybe FilePath
Nothing
                            }) = Maybe (TPraosLeaderCredentials StandardCrypto)
-> ExceptT
     ShelleyProtocolInstantiationError
     IO
     (Maybe (TPraosLeaderCredentials StandardCrypto))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (TPraosLeaderCredentials StandardCrypto)
forall a. Maybe a
Nothing

-- Or to supply all of the files
readLeaderCredentials (Just ProtocolFilepaths {
                              shelleyCertFile :: ProtocolFilepaths -> Maybe FilePath
shelleyCertFile = Just FilePath
certFile,
                              shelleyVRFFile :: ProtocolFilepaths -> Maybe FilePath
shelleyVRFFile  = Just FilePath
vrfFile,
                              shelleyKESFile :: ProtocolFilepaths -> Maybe FilePath
shelleyKESFile  = Just FilePath
kesFile
                            }) = do

    OperationalCertificate OCert StandardCrypto
opcert (StakePoolVerificationKey vkey) <-
      (FileError TextEnvelopeError -> ShelleyProtocolInstantiationError)
-> ExceptT (FileError TextEnvelopeError) IO OperationalCertificate
-> ExceptT
     ShelleyProtocolInstantiationError IO OperationalCertificate
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT FileError TextEnvelopeError -> ShelleyProtocolInstantiationError
FileError (ExceptT (FileError TextEnvelopeError) IO OperationalCertificate
 -> ExceptT
      ShelleyProtocolInstantiationError IO OperationalCertificate)
-> (IO
      (Either (FileError TextEnvelopeError) OperationalCertificate)
    -> ExceptT (FileError TextEnvelopeError) IO OperationalCertificate)
-> IO (Either (FileError TextEnvelopeError) OperationalCertificate)
-> ExceptT
     ShelleyProtocolInstantiationError IO OperationalCertificate
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. 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
      ShelleyProtocolInstantiationError IO OperationalCertificate)
-> IO (Either (FileError TextEnvelopeError) OperationalCertificate)
-> ExceptT
     ShelleyProtocolInstantiationError IO OperationalCertificate
forall a b. (a -> b) -> a -> b
$ AsType OperationalCertificate
-> FilePath
-> IO (Either (FileError TextEnvelopeError) OperationalCertificate)
forall a.
HasTextEnvelope a =>
AsType a -> FilePath -> IO (Either (FileError TextEnvelopeError) a)
readFileTextEnvelope AsType OperationalCertificate
AsOperationalCertificate FilePath
certFile
    VrfSigningKey vrfKey <-
      (FileError TextEnvelopeError -> ShelleyProtocolInstantiationError)
-> ExceptT (FileError TextEnvelopeError) IO (SigningKey VrfKey)
-> ExceptT ShelleyProtocolInstantiationError IO (SigningKey VrfKey)
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT FileError TextEnvelopeError -> ShelleyProtocolInstantiationError
FileError (ExceptT (FileError TextEnvelopeError) IO (SigningKey VrfKey)
 -> ExceptT
      ShelleyProtocolInstantiationError IO (SigningKey VrfKey))
-> (IO (Either (FileError TextEnvelopeError) (SigningKey VrfKey))
    -> ExceptT (FileError TextEnvelopeError) IO (SigningKey VrfKey))
-> IO (Either (FileError TextEnvelopeError) (SigningKey VrfKey))
-> ExceptT ShelleyProtocolInstantiationError IO (SigningKey VrfKey)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. 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
      ShelleyProtocolInstantiationError IO (SigningKey VrfKey))
-> IO (Either (FileError TextEnvelopeError) (SigningKey VrfKey))
-> ExceptT ShelleyProtocolInstantiationError IO (SigningKey VrfKey)
forall a b. (a -> b) -> a -> b
$ AsType (SigningKey VrfKey)
-> FilePath
-> IO (Either (FileError TextEnvelopeError) (SigningKey VrfKey))
forall a.
HasTextEnvelope a =>
AsType a -> FilePath -> IO (Either (FileError TextEnvelopeError) a)
readFileTextEnvelope (AsType VrfKey -> AsType (SigningKey VrfKey)
forall a. AsType a -> AsType (SigningKey a)
AsSigningKey AsType VrfKey
AsVrfKey) FilePath
vrfFile
    KesSigningKey kesKey <-
      (FileError TextEnvelopeError -> ShelleyProtocolInstantiationError)
-> ExceptT (FileError TextEnvelopeError) IO (SigningKey KesKey)
-> ExceptT ShelleyProtocolInstantiationError IO (SigningKey KesKey)
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT FileError TextEnvelopeError -> ShelleyProtocolInstantiationError
FileError (ExceptT (FileError TextEnvelopeError) IO (SigningKey KesKey)
 -> ExceptT
      ShelleyProtocolInstantiationError IO (SigningKey KesKey))
-> (IO (Either (FileError TextEnvelopeError) (SigningKey KesKey))
    -> ExceptT (FileError TextEnvelopeError) IO (SigningKey KesKey))
-> IO (Either (FileError TextEnvelopeError) (SigningKey KesKey))
-> ExceptT ShelleyProtocolInstantiationError IO (SigningKey KesKey)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. IO (Either (FileError TextEnvelopeError) (SigningKey KesKey))
-> ExceptT (FileError TextEnvelopeError) IO (SigningKey KesKey)
forall (m :: * -> *) x a. m (Either x a) -> ExceptT x m a
newExceptT (IO (Either (FileError TextEnvelopeError) (SigningKey KesKey))
 -> ExceptT
      ShelleyProtocolInstantiationError IO (SigningKey KesKey))
-> IO (Either (FileError TextEnvelopeError) (SigningKey KesKey))
-> ExceptT ShelleyProtocolInstantiationError IO (SigningKey KesKey)
forall a b. (a -> b) -> a -> b
$ AsType (SigningKey KesKey)
-> FilePath
-> IO (Either (FileError TextEnvelopeError) (SigningKey KesKey))
forall a.
HasTextEnvelope a =>
AsType a -> FilePath -> IO (Either (FileError TextEnvelopeError) a)
readFileTextEnvelope (AsType KesKey -> AsType (SigningKey KesKey)
forall a. AsType a -> AsType (SigningKey a)
AsSigningKey AsType KesKey
AsKesKey) FilePath
kesFile

    Maybe (TPraosLeaderCredentials StandardCrypto)
-> ExceptT
     ShelleyProtocolInstantiationError
     IO
     (Maybe (TPraosLeaderCredentials StandardCrypto))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (TPraosLeaderCredentials StandardCrypto)
 -> ExceptT
      ShelleyProtocolInstantiationError
      IO
      (Maybe (TPraosLeaderCredentials StandardCrypto)))
-> Maybe (TPraosLeaderCredentials StandardCrypto)
-> ExceptT
     ShelleyProtocolInstantiationError
     IO
     (Maybe (TPraosLeaderCredentials StandardCrypto))
forall a b. (a -> b) -> a -> b
$ TPraosLeaderCredentials StandardCrypto
-> Maybe (TPraosLeaderCredentials StandardCrypto)
forall a. a -> Maybe a
Just TPraosLeaderCredentials :: forall c.
SignKeyKES c
-> TPraosCanBeLeader c -> Text -> TPraosLeaderCredentials c
TPraosLeaderCredentials {
               $sel:tpraosLeaderCredentialsCanBeLeader:TPraosLeaderCredentials :: TPraosCanBeLeader StandardCrypto
tpraosLeaderCredentialsCanBeLeader =
                 TPraosCanBeLeader :: forall c.
OCert c
-> VKey 'BlockIssuer c -> SignKeyVRF c -> TPraosCanBeLeader c
TPraosCanBeLeader {
                   tpraosCanBeLeaderOpCert :: OCert StandardCrypto
tpraosCanBeLeaderOpCert     = OCert StandardCrypto
opcert,
                   tpraosCanBeLeaderColdVerKey :: VKey 'BlockIssuer StandardCrypto
tpraosCanBeLeaderColdVerKey = VKey 'StakePool StandardCrypto -> VKey 'BlockIssuer StandardCrypto
forall (a :: KeyRole -> * -> *) (r :: KeyRole) crypto
       (r' :: KeyRole).
HasKeyRole a =>
a r crypto -> a r' crypto
coerceKeyRole VKey 'StakePool StandardCrypto
vkey,
                   tpraosCanBeLeaderSignKeyVRF :: SignKeyVRF StandardCrypto
tpraosCanBeLeaderSignKeyVRF = SignKeyVRF StandardCrypto
vrfKey
                 },
               $sel:tpraosLeaderCredentialsInitSignKey:TPraosLeaderCredentials :: SignKeyKES StandardCrypto
tpraosLeaderCredentialsInitSignKey = SignKeyKES StandardCrypto
kesKey,
               $sel:tpraosLeaderCredentialsLabel:TPraosLeaderCredentials :: Text
tpraosLeaderCredentialsLabel = Text
"Shelley"
             }

-- But not OK to supply some of the files without the others.
readLeaderCredentials (Just ProtocolFilepaths {shelleyCertFile :: ProtocolFilepaths -> Maybe FilePath
shelleyCertFile = Maybe FilePath
Nothing}) =
    ShelleyProtocolInstantiationError
-> ExceptT
     ShelleyProtocolInstantiationError
     IO
     (Maybe (TPraosLeaderCredentials StandardCrypto))
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ShelleyProtocolInstantiationError
OCertNotSpecified
readLeaderCredentials (Just ProtocolFilepaths {shelleyVRFFile :: ProtocolFilepaths -> Maybe FilePath
shelleyVRFFile = Maybe FilePath
Nothing}) =
    ShelleyProtocolInstantiationError
-> ExceptT
     ShelleyProtocolInstantiationError
     IO
     (Maybe (TPraosLeaderCredentials StandardCrypto))
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ShelleyProtocolInstantiationError
VRFKeyNotSpecified
readLeaderCredentials (Just ProtocolFilepaths {shelleyKESFile :: ProtocolFilepaths -> Maybe FilePath
shelleyKESFile = Maybe FilePath
Nothing}) =
    ShelleyProtocolInstantiationError
-> ExceptT
     ShelleyProtocolInstantiationError
     IO
     (Maybe (TPraosLeaderCredentials StandardCrypto))
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ShelleyProtocolInstantiationError
KESKeyNotSpecified


------------------------------------------------------------------------------
-- Errors
--

data ShelleyProtocolInstantiationError =
       GenesisReadError !FilePath !IOException
     | GenesisHashMismatch !GenesisHash !GenesisHash -- actual, expected
     | GenesisDecodeError !FilePath !String
     | GenesisValidationFailure ![ValidationErr]
     | FileError !(Api.FileError TextEnvelopeError)
--TODO: pick a less generic constructor than FileError

     | OCertNotSpecified
     | VRFKeyNotSpecified
     | KESKeyNotSpecified
     deriving Int -> ShelleyProtocolInstantiationError -> ShowS
[ShelleyProtocolInstantiationError] -> ShowS
ShelleyProtocolInstantiationError -> FilePath
(Int -> ShelleyProtocolInstantiationError -> ShowS)
-> (ShelleyProtocolInstantiationError -> FilePath)
-> ([ShelleyProtocolInstantiationError] -> ShowS)
-> Show ShelleyProtocolInstantiationError
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ShelleyProtocolInstantiationError] -> ShowS
$cshowList :: [ShelleyProtocolInstantiationError] -> ShowS
show :: ShelleyProtocolInstantiationError -> FilePath
$cshow :: ShelleyProtocolInstantiationError -> FilePath
showsPrec :: Int -> ShelleyProtocolInstantiationError -> ShowS
$cshowsPrec :: Int -> ShelleyProtocolInstantiationError -> ShowS
Show


renderShelleyProtocolInstantiationError :: ShelleyProtocolInstantiationError
                                        -> Text
renderShelleyProtocolInstantiationError :: ShelleyProtocolInstantiationError -> Text
renderShelleyProtocolInstantiationError ShelleyProtocolInstantiationError
pie =
  case ShelleyProtocolInstantiationError
pie of
    GenesisReadError FilePath
fp IOException
err ->
        Text
"There was an error reading the genesis file: "
     Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
forall a b. ConvertText a b => a -> b
toS FilePath
fp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" Error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (IOException -> FilePath
forall a b. (Show a, ConvertText FilePath b) => a -> b
show IOException
err)

    GenesisHashMismatch GenesisHash
actual GenesisHash
expected ->
        Text
"Wrong Shelley genesis file: the actual hash is " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> GenesisHash -> Text
forall a b. (Show a, ConvertText FilePath b) => a -> b
show GenesisHash
actual
     Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", but the expected Shelley genesis hash given in the node "
     Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"configuration file is " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> GenesisHash -> Text
forall a b. (Show a, ConvertText FilePath b) => a -> b
show GenesisHash
expected

    GenesisDecodeError FilePath
fp FilePath
err ->
        Text
"There was an error parsing the genesis file: "
     Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
forall a b. ConvertText a b => a -> b
toS FilePath
fp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" Error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (ShowS
forall a b. (Show a, ConvertText FilePath b) => a -> b
show FilePath
err)

    GenesisValidationFailure [ValidationErr]
vErrs -> [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (ValidationErr -> Text) -> [ValidationErr] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map ValidationErr -> Text
describeValidationErr [ValidationErr]
vErrs

    FileError FileError TextEnvelopeError
fileErr -> FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FileError TextEnvelopeError -> FilePath
forall e. Error e => e -> FilePath
displayError FileError TextEnvelopeError
fileErr

    ShelleyProtocolInstantiationError
OCertNotSpecified  -> Text -> Text
forall a. (Semigroup a, IsString a) => a -> a
missingFlagMessage Text
"shelley-operational-certificate"
    ShelleyProtocolInstantiationError
VRFKeyNotSpecified -> Text -> Text
forall a. (Semigroup a, IsString a) => a -> a
missingFlagMessage Text
"shelley-vrf-key"
    ShelleyProtocolInstantiationError
KESKeyNotSpecified -> Text -> Text
forall a. (Semigroup a, IsString a) => a -> a
missingFlagMessage Text
"shelley-kes-key"
  where
    missingFlagMessage :: a -> a
missingFlagMessage a
flag =
      a
"To create blocks, the --" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
flag a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
" must also be specified"