{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}

-- DUPLICATE -- adapted from: cardano-node/src/Cardano/Node/Protocol/Shelley.hs

module Cardano.Node.Protocol.Shelley
  ( -- * Errors
    GenesisReadError (..)
  , GenesisValidationError (..)
  , PraosLeaderCredentialsError (..)
  , ShelleyProtocolInstantiationError (..)

    -- * Reusable parts
  , 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 Cardano.Api.SerialiseTextEnvelope
import qualified Cardano.Crypto.Hash.Class as Crypto
import Cardano.Ledger.Keys (coerceKeyRole)
import qualified Cardano.Ledger.Shelley.Genesis as Shelley
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 Ouroboros.Consensus.Protocol.Praos.Common
  ( PraosCanBeLeader (..)
  , PraosCredentialsSource (..)
  )
import Ouroboros.Consensus.Shelley.Node
  ( Nonce (..)
  , ShelleyGenesis (..)
  , ShelleyLeaderCredentials (..)
  )
import Prelude (String, id)

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

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 [Char]
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 ([Char] -> IOException -> GenesisReadError
GenesisReadFileError [Char]
file)
      (IO ByteString -> ExceptT GenesisReadError IO ByteString)
-> IO ByteString -> ExceptT GenesisReadError IO ByteString
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ByteString
BS.readFile [Char]
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) =
  -- The set of credentials is a sum total of what comes from the CLI,
  -- as well as what's in the bulk credentials file.
  [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]
-- It's OK to supply none of the files on the CLI
readLeaderCredentialsSingleton :: ProtocolFilepaths
-> ExceptT
     PraosLeaderCredentialsError
     IO
     [ShelleyLeaderCredentials StandardCrypto]
readLeaderCredentialsSingleton
  ProtocolFilepaths
    { shelleyCertFile :: ProtocolFilepaths -> Maybe [Char]
shelleyCertFile = Maybe [Char]
Nothing
    , shelleyVRFFile :: ProtocolFilepaths -> Maybe [Char]
shelleyVRFFile = Maybe [Char]
Nothing
    , shelleyKESFile :: ProtocolFilepaths -> Maybe [Char]
shelleyKESFile = Maybe [Char]
Nothing
    } = [ShelleyLeaderCredentials StandardCrypto]
-> ExceptT
     PraosLeaderCredentialsError
     IO
     [ShelleyLeaderCredentials StandardCrypto]
forall a. a -> ExceptT PraosLeaderCredentialsError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
-- Or to supply all of the files
readLeaderCredentialsSingleton
  ProtocolFilepaths
    { shelleyCertFile :: ProtocolFilepaths -> Maybe [Char]
shelleyCertFile = Just [Char]
opCertFile
    , shelleyVRFFile :: ProtocolFilepaths -> Maybe [Char]
shelleyVRFFile = Just [Char]
vrfFile
    , shelleyKESFile :: ProtocolFilepaths -> Maybe [Char]
shelleyKESFile = Just [Char]
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)
-> [Char]
-> IO (Either (FileError TextEnvelopeError) (SigningKey VrfKey))
forall a.
HasTextEnvelope a =>
AsType a -> [Char] -> IO (Either (FileError TextEnvelopeError) a)
readFileTextEnvelope (AsType VrfKey -> AsType (SigningKey VrfKey)
forall a. AsType a -> AsType (SigningKey a)
AsSigningKey AsType VrfKey
AsVrfKey) [Char]
vrfFile)

    (opCert, kesSKey) <- opCertKesKeyCheck kesFile opCertFile

    return [mkPraosLeaderCredentials opCert vrfSKey kesSKey]

-- But not OK to supply some of the files without the others.
readLeaderCredentialsSingleton ProtocolFilepaths{shelleyCertFile :: ProtocolFilepaths -> Maybe [Char]
shelleyCertFile = Maybe [Char]
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 [Char]
shelleyVRFFile = Maybe [Char]
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 [Char]
shelleyKESFile = Maybe [Char]
Nothing} =
  PraosLeaderCredentialsError
-> ExceptT
     PraosLeaderCredentialsError
     IO
     [ShelleyLeaderCredentials StandardCrypto]
forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left PraosLeaderCredentialsError
KESKeyNotSpecified

opCertKesKeyCheck ::
  -- | KES key
  FilePath ->
  -- | Operational certificate
  FilePath ->
  ExceptT PraosLeaderCredentialsError IO (OperationalCertificate, SigningKey UnsoundPureKesKey)
opCertKesKeyCheck :: [Char]
-> [Char]
-> ExceptT
     PraosLeaderCredentialsError
     IO
     (OperationalCertificate, SigningKey UnsoundPureKesKey)
opCertKesKeyCheck [Char]
kesFile [Char]
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
-> [Char]
-> IO (Either (FileError TextEnvelopeError) OperationalCertificate)
forall a.
HasTextEnvelope a =>
AsType a -> [Char] -> IO (Either (FileError TextEnvelopeError) a)
readFileTextEnvelope AsType OperationalCertificate
AsOperationalCertificate [Char]
certFile)
  kesSKey <-
    firstExceptT
      FileError
      (newExceptT $ readFileTextEnvelope (AsSigningKey AsUnsoundPureKesKey) kesFile)
  let opCertSpecifiedKesKeyhash = VerificationKey UnsoundPureKesKey -> Hash UnsoundPureKesKey
forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
verificationKeyHash (VerificationKey UnsoundPureKesKey -> Hash UnsoundPureKesKey)
-> VerificationKey UnsoundPureKesKey -> Hash UnsoundPureKesKey
forall a b. (a -> b) -> a -> b
$ OperationalCertificate -> VerificationKey UnsoundPureKesKey
getHotKey OperationalCertificate
opCert
      suppliedKesKeyHash = VerificationKey UnsoundPureKesKey -> Hash UnsoundPureKesKey
forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
verificationKeyHash (VerificationKey UnsoundPureKesKey -> Hash UnsoundPureKesKey)
-> VerificationKey UnsoundPureKesKey -> Hash UnsoundPureKesKey
forall a b. (a -> b) -> a -> b
$ SigningKey UnsoundPureKesKey -> VerificationKey UnsoundPureKesKey
forall keyrole.
Key keyrole =>
SigningKey keyrole -> VerificationKey keyrole
getVerificationKey SigningKey UnsoundPureKesKey
kesSKey
  -- Specified KES key in operational certificate should match the one
  -- supplied to the node.
  if suppliedKesKeyHash /= opCertSpecifiedKesKeyhash
    then left $ MismatchedKesKey kesFile certFile
    else return (opCert, kesSKey)

data ShelleyCredentials
  = ShelleyCredentials
  { ShelleyCredentials -> (TextEnvelope, [Char])
scCert :: (TextEnvelope, FilePath)
  , ShelleyCredentials -> (TextEnvelope, [Char])
scVrf :: (TextEnvelope, FilePath)
  , ShelleyCredentials -> (TextEnvelope, [Char])
scKes :: (TextEnvelope, FilePath)
  }

readLeaderCredentialsBulk ::
  ProtocolFilepaths ->
  ExceptT PraosLeaderCredentialsError IO [ShelleyLeaderCredentials StandardCrypto]
readLeaderCredentialsBulk :: ProtocolFilepaths
-> ExceptT
     PraosLeaderCredentialsError
     IO
     [ShelleyLeaderCredentials StandardCrypto]
readLeaderCredentialsBulk ProtocolFilepaths{shelleyBulkCredsFile :: ProtocolFilepaths -> Maybe [Char]
shelleyBulkCredsFile = Maybe [Char]
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 [Char]
-> ExceptT PraosLeaderCredentialsError IO [ShelleyCredentials]
readBulkFile Maybe [Char]
mfp
 where
  parseShelleyCredentials ::
    ShelleyCredentials ->
    ExceptT PraosLeaderCredentialsError IO (ShelleyLeaderCredentials StandardCrypto)
  parseShelleyCredentials :: ShelleyCredentials
-> ExceptT
     PraosLeaderCredentialsError
     IO
     (ShelleyLeaderCredentials StandardCrypto)
parseShelleyCredentials ShelleyCredentials{(TextEnvelope, [Char])
scCert :: ShelleyCredentials -> (TextEnvelope, [Char])
scCert :: (TextEnvelope, [Char])
scCert, (TextEnvelope, [Char])
scVrf :: ShelleyCredentials -> (TextEnvelope, [Char])
scVrf :: (TextEnvelope, [Char])
scVrf, (TextEnvelope, [Char])
scKes :: ShelleyCredentials -> (TextEnvelope, [Char])
scKes :: (TextEnvelope, [Char])
scKes} =
    OperationalCertificate
-> SigningKey VrfKey
-> SigningKey UnsoundPureKesKey
-> ShelleyLeaderCredentials StandardCrypto
mkPraosLeaderCredentials
      (OperationalCertificate
 -> SigningKey VrfKey
 -> SigningKey UnsoundPureKesKey
 -> ShelleyLeaderCredentials StandardCrypto)
-> ExceptT PraosLeaderCredentialsError IO OperationalCertificate
-> ExceptT
     PraosLeaderCredentialsError
     IO
     (SigningKey VrfKey
      -> SigningKey UnsoundPureKesKey
      -> ShelleyLeaderCredentials StandardCrypto)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AsType OperationalCertificate
-> (TextEnvelope, [Char])
-> ExceptT PraosLeaderCredentialsError IO OperationalCertificate
forall a.
HasTextEnvelope a =>
AsType a
-> (TextEnvelope, [Char])
-> ExceptT PraosLeaderCredentialsError IO a
parseEnvelope AsType OperationalCertificate
AsOperationalCertificate (TextEnvelope, [Char])
scCert
      ExceptT
  PraosLeaderCredentialsError
  IO
  (SigningKey VrfKey
   -> SigningKey UnsoundPureKesKey
   -> ShelleyLeaderCredentials StandardCrypto)
-> ExceptT PraosLeaderCredentialsError IO (SigningKey VrfKey)
-> ExceptT
     PraosLeaderCredentialsError
     IO
     (SigningKey UnsoundPureKesKey
      -> 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, [Char])
-> ExceptT PraosLeaderCredentialsError IO (SigningKey VrfKey)
forall a.
HasTextEnvelope a =>
AsType a
-> (TextEnvelope, [Char])
-> ExceptT PraosLeaderCredentialsError IO a
parseEnvelope (AsType VrfKey -> AsType (SigningKey VrfKey)
forall a. AsType a -> AsType (SigningKey a)
AsSigningKey AsType VrfKey
AsVrfKey) (TextEnvelope, [Char])
scVrf
      ExceptT
  PraosLeaderCredentialsError
  IO
  (SigningKey UnsoundPureKesKey
   -> ShelleyLeaderCredentials StandardCrypto)
-> ExceptT
     PraosLeaderCredentialsError IO (SigningKey UnsoundPureKesKey)
-> 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 UnsoundPureKesKey)
-> (TextEnvelope, [Char])
-> ExceptT
     PraosLeaderCredentialsError IO (SigningKey UnsoundPureKesKey)
forall a.
HasTextEnvelope a =>
AsType a
-> (TextEnvelope, [Char])
-> ExceptT PraosLeaderCredentialsError IO a
parseEnvelope (AsType UnsoundPureKesKey -> AsType (SigningKey UnsoundPureKesKey)
forall a. AsType a -> AsType (SigningKey a)
AsSigningKey AsType UnsoundPureKesKey
AsUnsoundPureKesKey) (TextEnvelope, [Char])
scKes

  readBulkFile ::
    Maybe FilePath ->
    ExceptT PraosLeaderCredentialsError IO [ShelleyCredentials]
  readBulkFile :: Maybe [Char]
-> ExceptT PraosLeaderCredentialsError IO [ShelleyCredentials]
readBulkFile Maybe [Char]
Nothing = [ShelleyCredentials]
-> ExceptT PraosLeaderCredentialsError IO [ShelleyCredentials]
forall a. a -> ExceptT PraosLeaderCredentialsError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  readBulkFile (Just [Char]
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 ([Char] -> IOException -> PraosLeaderCredentialsError
CredentialsReadError [Char]
fp)
        (IO ByteString
 -> ExceptT PraosLeaderCredentialsError IO ByteString)
-> IO ByteString
-> ExceptT PraosLeaderCredentialsError IO ByteString
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ByteString
BS.readFile [Char]
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 :: [Char] -> [Char]
loc [Char]
ty = [Char]
fp [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"." [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a b. (Show a, ConvertText [Char] b) => a -> b
show Int
ix [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
ty
       in (TextEnvelope, [Char])
-> (TextEnvelope, [Char])
-> (TextEnvelope, [Char])
-> ShelleyCredentials
ShelleyCredentials
            (TextEnvelope
teCert, [Char] -> [Char]
loc [Char]
"cert")
            (TextEnvelope
teVrf, [Char] -> [Char]
loc [Char]
"vrf")
            (TextEnvelope
teKes, [Char] -> [Char]
loc [Char]
"kes")

mkPraosLeaderCredentials ::
  OperationalCertificate ->
  SigningKey VrfKey ->
  SigningKey UnsoundPureKesKey ->
  ShelleyLeaderCredentials StandardCrypto
mkPraosLeaderCredentials :: OperationalCertificate
-> SigningKey VrfKey
-> SigningKey UnsoundPureKesKey
-> 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
            { 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
            , praosCanBeLeaderCredentialsSource :: PraosCredentialsSource StandardCrypto
praosCanBeLeaderCredentialsSource = OCert StandardCrypto
-> UnsoundPureSignKeyKES (KES StandardCrypto)
-> PraosCredentialsSource StandardCrypto
forall c.
OCert c
-> UnsoundPureSignKeyKES (KES c) -> PraosCredentialsSource c
PraosCredentialsUnsound OCert StandardCrypto
opcert 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, [Char])
-> ExceptT PraosLeaderCredentialsError IO a
parseEnvelope AsType a
as (TextEnvelope
te, [Char]
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
. [Char] -> TextEnvelopeError -> FileError TextEnvelopeError
forall e. [Char] -> e -> FileError e
Api.FileError [Char]
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

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

data ShelleyProtocolInstantiationError
  = GenesisReadError GenesisReadError
  | GenesisValidationError GenesisValidationError
  | PraosLeaderCredentialsError PraosLeaderCredentialsError
  deriving Int -> ShelleyProtocolInstantiationError -> [Char] -> [Char]
[ShelleyProtocolInstantiationError] -> [Char] -> [Char]
ShelleyProtocolInstantiationError -> [Char]
(Int -> ShelleyProtocolInstantiationError -> [Char] -> [Char])
-> (ShelleyProtocolInstantiationError -> [Char])
-> ([ShelleyProtocolInstantiationError] -> [Char] -> [Char])
-> Show ShelleyProtocolInstantiationError
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> ShelleyProtocolInstantiationError -> [Char] -> [Char]
showsPrec :: Int -> ShelleyProtocolInstantiationError -> [Char] -> [Char]
$cshow :: ShelleyProtocolInstantiationError -> [Char]
show :: ShelleyProtocolInstantiationError -> [Char]
$cshowList :: [ShelleyProtocolInstantiationError] -> [Char] -> [Char]
showList :: [ShelleyProtocolInstantiationError] -> [Char] -> [Char]
Show

instance Error ShelleyProtocolInstantiationError where
  displayError :: ShelleyProtocolInstantiationError -> [Char]
displayError (GenesisReadError GenesisReadError
err) = GenesisReadError -> [Char]
forall e. Error e => e -> [Char]
displayError GenesisReadError
err
  displayError (GenesisValidationError GenesisValidationError
err) = GenesisValidationError -> [Char]
forall e. Error e => e -> [Char]
displayError GenesisValidationError
err
  displayError (PraosLeaderCredentialsError PraosLeaderCredentialsError
err) = PraosLeaderCredentialsError -> [Char]
forall e. Error e => e -> [Char]
displayError PraosLeaderCredentialsError
err

data GenesisReadError
  = GenesisReadFileError !FilePath !IOException
  | GenesisHashMismatch !GenesisHash !GenesisHash -- actual, expected
  | GenesisDecodeError !FilePath !String
  deriving Int -> GenesisReadError -> [Char] -> [Char]
[GenesisReadError] -> [Char] -> [Char]
GenesisReadError -> [Char]
(Int -> GenesisReadError -> [Char] -> [Char])
-> (GenesisReadError -> [Char])
-> ([GenesisReadError] -> [Char] -> [Char])
-> Show GenesisReadError
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> GenesisReadError -> [Char] -> [Char]
showsPrec :: Int -> GenesisReadError -> [Char] -> [Char]
$cshow :: GenesisReadError -> [Char]
show :: GenesisReadError -> [Char]
$cshowList :: [GenesisReadError] -> [Char] -> [Char]
showList :: [GenesisReadError] -> [Char] -> [Char]
Show

instance Error GenesisReadError where
  displayError :: GenesisReadError -> [Char]
displayError (GenesisReadFileError [Char]
fp IOException
err) =
    [Char]
"There was an error reading the genesis file: "
      [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> [Char]
forall a b. ConvertText a b => a -> b
toS [Char]
fp
      [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" Error: "
      [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> IOException -> [Char]
forall a b. (Show a, ConvertText [Char] b) => a -> b
show IOException
err
  displayError (GenesisHashMismatch GenesisHash
actual GenesisHash
expected) =
    [Char]
"Wrong genesis file: the actual hash is "
      [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> GenesisHash -> [Char]
forall a b. (Show a, ConvertText [Char] b) => a -> b
show GenesisHash
actual
      [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
", but the expected genesis hash given in the node "
      [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"configuration file is "
      [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> GenesisHash -> [Char]
forall a b. (Show a, ConvertText [Char] b) => a -> b
show GenesisHash
expected
  displayError (GenesisDecodeError [Char]
fp [Char]
err) =
    [Char]
"There was an error parsing the genesis file: "
      [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> [Char]
forall a b. ConvertText a b => a -> b
toS [Char]
fp
      [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" Error: "
      [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> [Char]
forall a b. (Show a, ConvertText [Char] b) => a -> b
show [Char]
err

newtype GenesisValidationError = GenesisValidationErrors [Shelley.ValidationErr]
  deriving Int -> GenesisValidationError -> [Char] -> [Char]
[GenesisValidationError] -> [Char] -> [Char]
GenesisValidationError -> [Char]
(Int -> GenesisValidationError -> [Char] -> [Char])
-> (GenesisValidationError -> [Char])
-> ([GenesisValidationError] -> [Char] -> [Char])
-> Show GenesisValidationError
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> GenesisValidationError -> [Char] -> [Char]
showsPrec :: Int -> GenesisValidationError -> [Char] -> [Char]
$cshow :: GenesisValidationError -> [Char]
show :: GenesisValidationError -> [Char]
$cshowList :: [GenesisValidationError] -> [Char] -> [Char]
showList :: [GenesisValidationError] -> [Char] -> [Char]
Show

instance Error GenesisValidationError where
  displayError :: GenesisValidationError -> [Char]
displayError (GenesisValidationErrors [ValidationErr]
vErrs) =
    Text -> [Char]
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
      -- KES signing key
      FilePath
  -- Operational certificate
  deriving Int -> PraosLeaderCredentialsError -> [Char] -> [Char]
[PraosLeaderCredentialsError] -> [Char] -> [Char]
PraosLeaderCredentialsError -> [Char]
(Int -> PraosLeaderCredentialsError -> [Char] -> [Char])
-> (PraosLeaderCredentialsError -> [Char])
-> ([PraosLeaderCredentialsError] -> [Char] -> [Char])
-> Show PraosLeaderCredentialsError
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> PraosLeaderCredentialsError -> [Char] -> [Char]
showsPrec :: Int -> PraosLeaderCredentialsError -> [Char] -> [Char]
$cshow :: PraosLeaderCredentialsError -> [Char]
show :: PraosLeaderCredentialsError -> [Char]
$cshowList :: [PraosLeaderCredentialsError] -> [Char] -> [Char]
showList :: [PraosLeaderCredentialsError] -> [Char] -> [Char]
Show

instance Error PraosLeaderCredentialsError where
  displayError :: PraosLeaderCredentialsError -> [Char]
displayError (CredentialsReadError [Char]
fp IOException
err) =
    [Char]
"There was an error reading a credentials file: "
      [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> [Char]
forall a b. ConvertText a b => a -> b
toS [Char]
fp
      [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" Error: "
      [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> IOException -> [Char]
forall a b. (Show a, ConvertText [Char] b) => a -> b
show IOException
err
  displayError (EnvelopeParseError [Char]
fp [Char]
err) =
    [Char]
"There was an error parsing a credentials envelope: "
      [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> [Char]
forall a b. ConvertText a b => a -> b
toS [Char]
fp
      [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" Error: "
      [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> [Char]
forall a b. (Show a, ConvertText [Char] b) => a -> b
show [Char]
err
  displayError (FileError FileError TextEnvelopeError
fileErr) = FileError TextEnvelopeError -> [Char]
forall e. Error e => e -> [Char]
displayError FileError TextEnvelopeError
fileErr
  displayError (MismatchedKesKey [Char]
kesFp [Char]
certFp) =
    [Char]
"The KES key provided at: "
      [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> [Char]
forall a b. (Show a, ConvertText [Char] b) => a -> b
show [Char]
kesFp
      [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" does not match the KES key specified in the operational certificate at: "
      [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> [Char]
forall a b. (Show a, ConvertText [Char] b) => a -> b
show [Char]
certFp
  displayError PraosLeaderCredentialsError
OCertNotSpecified = [Char] -> [Char]
missingFlagMessage [Char]
"shelley-operational-certificate"
  displayError PraosLeaderCredentialsError
VRFKeyNotSpecified = [Char] -> [Char]
missingFlagMessage [Char]
"shelley-vrf-key"
  displayError PraosLeaderCredentialsError
KESKeyNotSpecified = [Char] -> [Char]
missingFlagMessage [Char]
"shelley-kes-key"

missingFlagMessage :: String -> String
missingFlagMessage :: [Char] -> [Char]
missingFlagMessage [Char]
flag =
  [Char]
"To create blocks, the --" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
flag [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" must also be specified"