{-# LANGUAGE NamedFieldPuns #-}

module Cardano.Node.Protocol
  ( mkConsensusProtocol
  , SomeConsensusProtocol(..)
  , ProtocolInstantiationError(..)
  , renderProtocolInstantiationError
  ) where

import           Cardano.Prelude

import           Control.Monad.Trans.Except.Extra (firstExceptT)

import           Cardano.Node.Configuration.POM (NodeConfiguration (..))
import           Cardano.Node.Types

import           Cardano.Node.Protocol.Byron
import           Cardano.Node.Protocol.Cardano
import           Cardano.Node.Protocol.Shelley
import           Cardano.Node.Protocol.Types (SomeConsensusProtocol (..))

------------------------------------------------------------------------------
-- Conversions from configuration into specific protocols and their params
--

mkConsensusProtocol
  :: NodeConfiguration
  -> ExceptT ProtocolInstantiationError IO SomeConsensusProtocol
mkConsensusProtocol :: NodeConfiguration
-> ExceptT ProtocolInstantiationError IO SomeConsensusProtocol
mkConsensusProtocol NodeConfiguration{NodeProtocolConfiguration
ncProtocolConfig :: NodeConfiguration -> NodeProtocolConfiguration
ncProtocolConfig :: NodeProtocolConfiguration
ncProtocolConfig, ProtocolFilepaths
ncProtocolFiles :: NodeConfiguration -> ProtocolFilepaths
ncProtocolFiles :: ProtocolFilepaths
ncProtocolFiles} =
    case NodeProtocolConfiguration
ncProtocolConfig of

      NodeProtocolConfigurationByron NodeByronProtocolConfiguration
config ->
        (ByronProtocolInstantiationError -> ProtocolInstantiationError)
-> ExceptT ByronProtocolInstantiationError IO SomeConsensusProtocol
-> ExceptT ProtocolInstantiationError IO SomeConsensusProtocol
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT ByronProtocolInstantiationError -> ProtocolInstantiationError
ByronProtocolInstantiationError (ExceptT ByronProtocolInstantiationError IO SomeConsensusProtocol
 -> ExceptT ProtocolInstantiationError IO SomeConsensusProtocol)
-> ExceptT ByronProtocolInstantiationError IO SomeConsensusProtocol
-> ExceptT ProtocolInstantiationError IO SomeConsensusProtocol
forall a b. (a -> b) -> a -> b
$
          NodeByronProtocolConfiguration
-> Maybe ProtocolFilepaths
-> ExceptT ByronProtocolInstantiationError IO SomeConsensusProtocol
mkSomeConsensusProtocolByron NodeByronProtocolConfiguration
config (ProtocolFilepaths -> Maybe ProtocolFilepaths
forall a. a -> Maybe a
Just ProtocolFilepaths
ncProtocolFiles)

      NodeProtocolConfigurationShelley NodeShelleyProtocolConfiguration
config ->
        (ShelleyProtocolInstantiationError -> ProtocolInstantiationError)
-> ExceptT
     ShelleyProtocolInstantiationError IO SomeConsensusProtocol
-> ExceptT ProtocolInstantiationError IO SomeConsensusProtocol
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT ShelleyProtocolInstantiationError -> ProtocolInstantiationError
ShelleyProtocolInstantiationError (ExceptT ShelleyProtocolInstantiationError IO SomeConsensusProtocol
 -> ExceptT ProtocolInstantiationError IO SomeConsensusProtocol)
-> ExceptT
     ShelleyProtocolInstantiationError IO SomeConsensusProtocol
-> ExceptT ProtocolInstantiationError IO SomeConsensusProtocol
forall a b. (a -> b) -> a -> b
$
          NodeShelleyProtocolConfiguration
-> Maybe ProtocolFilepaths
-> ExceptT
     ShelleyProtocolInstantiationError IO SomeConsensusProtocol
mkSomeConsensusProtocolShelley NodeShelleyProtocolConfiguration
config (ProtocolFilepaths -> Maybe ProtocolFilepaths
forall a. a -> Maybe a
Just ProtocolFilepaths
ncProtocolFiles)

      NodeProtocolConfigurationCardano NodeByronProtocolConfiguration
byronConfig
                                       NodeShelleyProtocolConfiguration
shelleyConfig
                                       NodeHardForkProtocolConfiguration
hardForkConfig ->
        (CardanoProtocolInstantiationError -> ProtocolInstantiationError)
-> ExceptT
     CardanoProtocolInstantiationError IO SomeConsensusProtocol
-> ExceptT ProtocolInstantiationError IO SomeConsensusProtocol
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT CardanoProtocolInstantiationError -> ProtocolInstantiationError
CardanoProtocolInstantiationError (ExceptT CardanoProtocolInstantiationError IO SomeConsensusProtocol
 -> ExceptT ProtocolInstantiationError IO SomeConsensusProtocol)
-> ExceptT
     CardanoProtocolInstantiationError IO SomeConsensusProtocol
-> ExceptT ProtocolInstantiationError IO SomeConsensusProtocol
forall a b. (a -> b) -> a -> b
$
          NodeByronProtocolConfiguration
-> NodeShelleyProtocolConfiguration
-> NodeHardForkProtocolConfiguration
-> Maybe ProtocolFilepaths
-> ExceptT
     CardanoProtocolInstantiationError IO SomeConsensusProtocol
mkSomeConsensusProtocolCardano
            NodeByronProtocolConfiguration
byronConfig
            NodeShelleyProtocolConfiguration
shelleyConfig
            NodeHardForkProtocolConfiguration
hardForkConfig
            (ProtocolFilepaths -> Maybe ProtocolFilepaths
forall a. a -> Maybe a
Just ProtocolFilepaths
ncProtocolFiles)

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

data ProtocolInstantiationError =
    ByronProtocolInstantiationError   ByronProtocolInstantiationError
  | ShelleyProtocolInstantiationError ShelleyProtocolInstantiationError
  | CardanoProtocolInstantiationError CardanoProtocolInstantiationError
  deriving Int -> ProtocolInstantiationError -> ShowS
[ProtocolInstantiationError] -> ShowS
ProtocolInstantiationError -> String
(Int -> ProtocolInstantiationError -> ShowS)
-> (ProtocolInstantiationError -> String)
-> ([ProtocolInstantiationError] -> ShowS)
-> Show ProtocolInstantiationError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ProtocolInstantiationError] -> ShowS
$cshowList :: [ProtocolInstantiationError] -> ShowS
show :: ProtocolInstantiationError -> String
$cshow :: ProtocolInstantiationError -> String
showsPrec :: Int -> ProtocolInstantiationError -> ShowS
$cshowsPrec :: Int -> ProtocolInstantiationError -> ShowS
Show


renderProtocolInstantiationError :: ProtocolInstantiationError -> Text
renderProtocolInstantiationError :: ProtocolInstantiationError -> Text
renderProtocolInstantiationError ProtocolInstantiationError
pie =
  case ProtocolInstantiationError
pie of
    ByronProtocolInstantiationError ByronProtocolInstantiationError
bpie ->
      ByronProtocolInstantiationError -> Text
renderByronProtocolInstantiationError ByronProtocolInstantiationError
bpie

    ShelleyProtocolInstantiationError ShelleyProtocolInstantiationError
spie ->
      ShelleyProtocolInstantiationError -> Text
renderShelleyProtocolInstantiationError ShelleyProtocolInstantiationError
spie

    CardanoProtocolInstantiationError CardanoProtocolInstantiationError
cpie ->
      CardanoProtocolInstantiationError -> Text
renderCardanoProtocolInstantiationError CardanoProtocolInstantiationError
cpie