{-# LANGUAGE NamedFieldPuns #-}

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

import           Cardano.Prelude

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

import           Cardano.Api

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

import           Cardano.Node.Orphans ()
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
                                       NodeAlonzoProtocolConfiguration
alonzoConfig
                                       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
-> NodeAlonzoProtocolConfiguration
-> NodeHardForkProtocolConfiguration
-> Maybe ProtocolFilepaths
-> ExceptT
     CardanoProtocolInstantiationError IO SomeConsensusProtocol
mkSomeConsensusProtocolCardano
            NodeByronProtocolConfiguration
byronConfig
            NodeShelleyProtocolConfiguration
shelleyConfig
            NodeAlonzoProtocolConfiguration
alonzoConfig
            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


instance Error ProtocolInstantiationError where
  displayError :: ProtocolInstantiationError -> String
displayError (ByronProtocolInstantiationError   ByronProtocolInstantiationError
err) = ByronProtocolInstantiationError -> String
forall e. Error e => e -> String
displayError ByronProtocolInstantiationError
err
  displayError (ShelleyProtocolInstantiationError ShelleyProtocolInstantiationError
err) = ShelleyProtocolInstantiationError -> String
forall e. Error e => e -> String
displayError ShelleyProtocolInstantiationError
err
  displayError (CardanoProtocolInstantiationError CardanoProtocolInstantiationError
err) = CardanoProtocolInstantiationError -> String
forall e. Error e => e -> String
displayError CardanoProtocolInstantiationError
err