{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}

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

module Cardano.Node.Protocol.Byron
  ( mkSomeConsensusProtocolByron

    -- * Errors
  , ByronProtocolInstantiationError (..)

    -- * Reusable parts
  , readGenesis
  , readLeaderCredentials
  ) where

import Cardano.Api.Any
import Cardano.Api.KeysByron
import qualified Cardano.Api.Protocol.Types as Protocol
import qualified Cardano.Chain.Genesis as Genesis
import qualified Cardano.Chain.UTxO as UTxO
import qualified Cardano.Chain.Update as Update
import qualified Cardano.Crypto.Hash as Crypto
import qualified Cardano.Crypto.Hashing as Byron.Crypto
import Cardano.Crypto.ProtocolMagic (RequiresNetworkMagic)
import Cardano.Node.Protocol.Types
import Cardano.Node.Types
import Cardano.Prelude
import Control.Monad.Trans.Except.Extra
  ( bimapExceptT
  , firstExceptT
  , hoistEither
  , hoistMaybe
  , left
  )
import qualified Data.ByteString.Lazy as LB
import Data.Text as Text (unpack)
import Ouroboros.Consensus.Cardano
import qualified Ouroboros.Consensus.Cardano as Consensus
import Prelude hiding (show, (.))

------------------------------------------------------------------------------
-- Byron protocol
--

-- | Make 'SomeConsensusProtocol' using the Byron 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.
mkSomeConsensusProtocolByron ::
  NodeByronProtocolConfiguration ->
  Maybe ProtocolFilepaths ->
  ExceptT ByronProtocolInstantiationError IO SomeConsensusProtocol
mkSomeConsensusProtocolByron :: NodeByronProtocolConfiguration
-> Maybe ProtocolFilepaths
-> ExceptT ByronProtocolInstantiationError IO SomeConsensusProtocol
mkSomeConsensusProtocolByron
  NodeByronProtocolConfiguration
    { GenesisFile
npcByronGenesisFile :: GenesisFile
npcByronGenesisFile :: NodeByronProtocolConfiguration -> GenesisFile
npcByronGenesisFile
    , Maybe GenesisHash
npcByronGenesisFileHash :: Maybe GenesisHash
npcByronGenesisFileHash :: NodeByronProtocolConfiguration -> Maybe GenesisHash
npcByronGenesisFileHash
    , RequiresNetworkMagic
npcByronReqNetworkMagic :: RequiresNetworkMagic
npcByronReqNetworkMagic :: NodeByronProtocolConfiguration -> RequiresNetworkMagic
npcByronReqNetworkMagic
    , Maybe Double
npcByronPbftSignatureThresh :: Maybe Double
npcByronPbftSignatureThresh :: NodeByronProtocolConfiguration -> Maybe Double
npcByronPbftSignatureThresh
    , ApplicationName
npcByronApplicationName :: ApplicationName
npcByronApplicationName :: NodeByronProtocolConfiguration -> ApplicationName
npcByronApplicationName
    , NumSoftwareVersion
npcByronApplicationVersion :: NumSoftwareVersion
npcByronApplicationVersion :: NodeByronProtocolConfiguration -> NumSoftwareVersion
npcByronApplicationVersion
    , Word16
npcByronSupportedProtocolVersionMajor :: Word16
npcByronSupportedProtocolVersionMajor :: NodeByronProtocolConfiguration -> Word16
npcByronSupportedProtocolVersionMajor
    , Word16
npcByronSupportedProtocolVersionMinor :: Word16
npcByronSupportedProtocolVersionMinor :: NodeByronProtocolConfiguration -> Word16
npcByronSupportedProtocolVersionMinor
    , Word8
npcByronSupportedProtocolVersionAlt :: Word8
npcByronSupportedProtocolVersionAlt :: NodeByronProtocolConfiguration -> Word8
npcByronSupportedProtocolVersionAlt
    }
  Maybe ProtocolFilepaths
files = do
    genesisConfig <-
      GenesisFile
-> Maybe GenesisHash
-> RequiresNetworkMagic
-> ExceptT ByronProtocolInstantiationError IO Config
readGenesis
        GenesisFile
npcByronGenesisFile
        Maybe GenesisHash
npcByronGenesisFileHash
        RequiresNetworkMagic
npcByronReqNetworkMagic

    optionalLeaderCredentials <- readLeaderCredentials genesisConfig files

    return $
      SomeConsensusProtocol Protocol.ByronBlockType $
        Protocol.ProtocolInfoArgsByron $
          Consensus.ProtocolParamsByron
            { byronGenesis = genesisConfig
            , byronPbftSignatureThreshold =
                PBftSignatureThreshold <$> npcByronPbftSignatureThresh
            , byronProtocolVersion =
                Update.ProtocolVersion
                  npcByronSupportedProtocolVersionMajor
                  npcByronSupportedProtocolVersionMinor
                  npcByronSupportedProtocolVersionAlt
            , byronSoftwareVersion =
                Update.SoftwareVersion
                  npcByronApplicationName
                  npcByronApplicationVersion
            , byronLeaderCredentials = optionalLeaderCredentials
            }

readGenesis ::
  GenesisFile ->
  Maybe GenesisHash ->
  RequiresNetworkMagic ->
  ExceptT
    ByronProtocolInstantiationError
    IO
    Genesis.Config
readGenesis :: GenesisFile
-> Maybe GenesisHash
-> RequiresNetworkMagic
-> ExceptT ByronProtocolInstantiationError IO Config
readGenesis (GenesisFile FilePath
file) Maybe GenesisHash
mbExpectedGenesisHash RequiresNetworkMagic
ncReqNetworkMagic = do
  (genesisData, genesisHash) <-
    (GenesisDataError -> ByronProtocolInstantiationError)
-> ExceptT GenesisDataError IO (GenesisData, GenesisHash)
-> ExceptT
     ByronProtocolInstantiationError IO (GenesisData, GenesisHash)
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT (FilePath -> GenesisDataError -> ByronProtocolInstantiationError
GenesisReadError FilePath
file) (ExceptT GenesisDataError IO (GenesisData, GenesisHash)
 -> ExceptT
      ByronProtocolInstantiationError IO (GenesisData, GenesisHash))
-> ExceptT GenesisDataError IO (GenesisData, GenesisHash)
-> ExceptT
     ByronProtocolInstantiationError IO (GenesisData, GenesisHash)
forall a b. (a -> b) -> a -> b
$
      FilePath -> ExceptT GenesisDataError IO (GenesisData, GenesisHash)
forall (m :: * -> *).
(MonadError GenesisDataError m, MonadIO m) =>
FilePath -> m (GenesisData, GenesisHash)
Genesis.readGenesisData FilePath
file
  checkExpectedGenesisHash genesisHash
  return
    Genesis.Config
      { Genesis.configGenesisData = genesisData
      , Genesis.configGenesisHash = genesisHash
      , Genesis.configReqNetMagic = ncReqNetworkMagic
      , Genesis.configUTxOConfiguration = UTxO.defaultUTxOConfiguration
      -- TODO: add config support for the UTxOConfiguration if needed
      }
 where
  checkExpectedGenesisHash ::
    Genesis.GenesisHash ->
    ExceptT ByronProtocolInstantiationError IO ()
  checkExpectedGenesisHash :: GenesisHash -> ExceptT ByronProtocolInstantiationError 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 ->
            ByronProtocolInstantiationError
-> ExceptT ByronProtocolInstantiationError IO ()
forall a.
ByronProtocolInstantiationError
-> ExceptT ByronProtocolInstantiationError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GenesisHash -> GenesisHash -> ByronProtocolInstantiationError
GenesisHashMismatch GenesisHash
actual GenesisHash
expected)
       where
        actual :: GenesisHash
actual = GenesisHash -> GenesisHash
fromByronGenesisHash GenesisHash
actual'
      Maybe GenesisHash
_ -> () -> ExceptT ByronProtocolInstantiationError IO ()
forall a. a -> ExceptT ByronProtocolInstantiationError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  fromByronGenesisHash :: Genesis.GenesisHash -> GenesisHash
  fromByronGenesisHash :: GenesisHash -> GenesisHash
fromByronGenesisHash (Genesis.GenesisHash Hash Raw
h) =
    Hash Blake2b_256 ByteString -> GenesisHash
GenesisHash
      (Hash Blake2b_256 ByteString -> GenesisHash)
-> (Hash Raw -> Hash Blake2b_256 ByteString)
-> Hash Raw
-> GenesisHash
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
. Hash Blake2b_256 ByteString
-> Maybe (Hash Blake2b_256 ByteString)
-> Hash Blake2b_256 ByteString
forall a. a -> Maybe a -> a
fromMaybe Hash Blake2b_256 ByteString
forall {a}. a
impossible
      (Maybe (Hash Blake2b_256 ByteString)
 -> Hash Blake2b_256 ByteString)
-> (Hash Raw -> Maybe (Hash Blake2b_256 ByteString))
-> Hash Raw
-> Hash Blake2b_256 ByteString
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
. ByteString -> Maybe (Hash Blake2b_256 ByteString)
forall h a. HashAlgorithm h => ByteString -> Maybe (Hash h a)
Crypto.hashFromBytes
      (ByteString -> Maybe (Hash Blake2b_256 ByteString))
-> (Hash Raw -> ByteString)
-> Hash Raw
-> Maybe (Hash Blake2b_256 ByteString)
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
. Hash Raw -> ByteString
forall algo a. AbstractHash algo a -> ByteString
Byron.Crypto.hashToBytes
      (Hash Raw -> GenesisHash) -> Hash Raw -> GenesisHash
forall a b. (a -> b) -> a -> b
$ Hash Raw
h
   where
    impossible :: a
impossible =
      Text -> a
forall a. HasCallStack => Text -> a
panic Text
"fromByronGenesisHash: old and new crypto libs disagree on hash size"

readLeaderCredentials ::
  Genesis.Config ->
  Maybe ProtocolFilepaths ->
  ExceptT
    ByronProtocolInstantiationError
    IO
    (Maybe ByronLeaderCredentials)
readLeaderCredentials :: Config
-> Maybe ProtocolFilepaths
-> ExceptT
     ByronProtocolInstantiationError IO (Maybe ByronLeaderCredentials)
readLeaderCredentials Config
_ Maybe ProtocolFilepaths
Nothing = Maybe ByronLeaderCredentials
-> ExceptT
     ByronProtocolInstantiationError IO (Maybe ByronLeaderCredentials)
forall a. a -> ExceptT ByronProtocolInstantiationError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByronLeaderCredentials
forall a. Maybe a
Nothing
readLeaderCredentials
  Config
genesisConfig
  ( Just
      ProtocolFilepaths
        { Maybe FilePath
byronCertFile :: Maybe FilePath
byronCertFile :: ProtocolFilepaths -> Maybe FilePath
byronCertFile
        , Maybe FilePath
byronKeyFile :: Maybe FilePath
byronKeyFile :: ProtocolFilepaths -> Maybe FilePath
byronKeyFile
        }
    ) =
    case (Maybe FilePath
byronCertFile, Maybe FilePath
byronKeyFile) of
      (Maybe FilePath
Nothing, Maybe FilePath
Nothing) -> Maybe ByronLeaderCredentials
-> ExceptT
     ByronProtocolInstantiationError IO (Maybe ByronLeaderCredentials)
forall a. a -> ExceptT ByronProtocolInstantiationError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ByronLeaderCredentials
forall a. Maybe a
Nothing
      (Just FilePath
_, Maybe FilePath
Nothing) -> ByronProtocolInstantiationError
-> ExceptT
     ByronProtocolInstantiationError IO (Maybe ByronLeaderCredentials)
forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left ByronProtocolInstantiationError
SigningKeyFilepathNotSpecified
      (Maybe FilePath
Nothing, Just FilePath
_) -> ByronProtocolInstantiationError
-> ExceptT
     ByronProtocolInstantiationError IO (Maybe ByronLeaderCredentials)
forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left ByronProtocolInstantiationError
DelegationCertificateFilepathNotSpecified
      (Just FilePath
delegCertFile, Just FilePath
signingKeyFile) -> do
        signingKeyFileBytes <- IO ByteString
-> ExceptT ByronProtocolInstantiationError IO ByteString
forall a. IO a -> ExceptT ByronProtocolInstantiationError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString
 -> ExceptT ByronProtocolInstantiationError IO ByteString)
-> IO ByteString
-> ExceptT ByronProtocolInstantiationError IO ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ByteString
LB.readFile FilePath
signingKeyFile
        delegCertFileBytes <- liftIO $ LB.readFile delegCertFile
        ByronSigningKey signingKey <-
          hoistMaybe (SigningKeyDeserialiseFailure signingKeyFile) $
            deserialiseFromRawBytes (AsSigningKey AsByronKey) $
              LB.toStrict signingKeyFileBytes
        delegCert <-
          firstExceptT (CanonicalDecodeFailure delegCertFile)
            . hoistEither
            $ canonicalDecodePretty delegCertFileBytes

        bimapExceptT CredentialsError Just
          . hoistEither
          $ mkByronLeaderCredentials genesisConfig signingKey delegCert "Byron"

------------------------------------------------------------------------------
-- Byron Errors
--

data ByronProtocolInstantiationError
  = CanonicalDecodeFailure !FilePath !Text
  | GenesisHashMismatch !GenesisHash !GenesisHash -- actual, expected
  | DelegationCertificateFilepathNotSpecified
  | GenesisConfigurationError !FilePath !Genesis.ConfigurationError
  | GenesisReadError !FilePath !Genesis.GenesisDataError
  | CredentialsError !ByronLeaderCredentialsError
  | SigningKeyDeserialiseFailure !FilePath
  | SigningKeyFilepathNotSpecified
  deriving Int -> ByronProtocolInstantiationError -> ShowS
[ByronProtocolInstantiationError] -> ShowS
ByronProtocolInstantiationError -> FilePath
(Int -> ByronProtocolInstantiationError -> ShowS)
-> (ByronProtocolInstantiationError -> FilePath)
-> ([ByronProtocolInstantiationError] -> ShowS)
-> Show ByronProtocolInstantiationError
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ByronProtocolInstantiationError -> ShowS
showsPrec :: Int -> ByronProtocolInstantiationError -> ShowS
$cshow :: ByronProtocolInstantiationError -> FilePath
show :: ByronProtocolInstantiationError -> FilePath
$cshowList :: [ByronProtocolInstantiationError] -> ShowS
showList :: [ByronProtocolInstantiationError] -> ShowS
Show

instance Error ByronProtocolInstantiationError where
  displayError :: ByronProtocolInstantiationError -> FilePath
displayError (CanonicalDecodeFailure FilePath
fp Text
failure) =
    FilePath
"Canonical decode failure in "
      FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
fp
      FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
" Canonical failure: "
      FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
Text.unpack Text
failure
  displayError (GenesisHashMismatch GenesisHash
actual GenesisHash
expected) =
    FilePath
"Wrong Byron genesis file: the actual hash is "
      FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> GenesisHash -> FilePath
forall a b. (Show a, ConvertText FilePath b) => a -> b
show GenesisHash
actual
      FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
", but the expected Byron genesis hash given in the node configuration "
      FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"file is "
      FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> GenesisHash -> FilePath
forall a b. (Show a, ConvertText FilePath b) => a -> b
show GenesisHash
expected
  displayError ByronProtocolInstantiationError
DelegationCertificateFilepathNotSpecified =
    FilePath
"Delegation certificate filepath not specified"
  -- TODO: Implement configuration error render function in cardano-ledger
  displayError (GenesisConfigurationError FilePath
fp ConfigurationError
genesisConfigError) =
    FilePath
"Genesis configuration error in: "
      FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
forall a b. ConvertText a b => a -> b
toS FilePath
fp
      FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
" Error: "
      FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> ConfigurationError -> FilePath
forall a b. (Show a, ConvertText FilePath b) => a -> b
show ConfigurationError
genesisConfigError
  displayError (GenesisReadError FilePath
fp GenesisDataError
err) =
    FilePath
"There was an error parsing the genesis file: "
      FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
forall a b. ConvertText a b => a -> b
toS FilePath
fp
      FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
" Error: "
      FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> GenesisDataError -> FilePath
forall a b. (Show a, ConvertText FilePath b) => a -> b
show GenesisDataError
err
  -- TODO: Implement ByronLeaderCredentialsError render function in ouroboros-network
  displayError (CredentialsError ByronLeaderCredentialsError
byronLeaderCredentialsError) =
    FilePath
"Byron leader credentials error: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> ByronLeaderCredentialsError -> FilePath
forall a b. (Show a, ConvertText FilePath b) => a -> b
show ByronLeaderCredentialsError
byronLeaderCredentialsError
  displayError (SigningKeyDeserialiseFailure FilePath
fp) =
    FilePath
"Signing key deserialisation error in: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
forall a b. ConvertText a b => a -> b
toS FilePath
fp
  displayError ByronProtocolInstantiationError
SigningKeyFilepathNotSpecified =
    FilePath
"Signing key filepath not specified"