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

-- 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.Update as Update
import qualified Cardano.Chain.UTxO as UTxO
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"