{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTSyntax #-}
{-# LANGUAGE StandaloneDeriving #-}

module Cardano.Node.Protocol.Types
  ( Protocol(..)
  , SomeConsensusProtocol(..)
  , SomeConsensusProtocolConstraints
  ) where

import           Cardano.Prelude

import           Control.Monad.Fail (fail)
import           Data.Aeson
import           NoThunks.Class (NoThunks)

import           Ouroboros.Consensus.Block (BlockProtocol)
import qualified Ouroboros.Consensus.Cardano as Consensus (Protocol)
import           Ouroboros.Consensus.Node.Run (RunNode)

import           Cardano.Tracing.Constraints (TraceConstraints)
import           Cardano.Tracing.Metrics (HasKESMetricsData)

data Protocol = ByronProtocol
              | ShelleyProtocol
              | CardanoProtocol
  deriving (Protocol -> Protocol -> Bool
(Protocol -> Protocol -> Bool)
-> (Protocol -> Protocol -> Bool) -> Eq Protocol
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Protocol -> Protocol -> Bool
$c/= :: Protocol -> Protocol -> Bool
== :: Protocol -> Protocol -> Bool
$c== :: Protocol -> Protocol -> Bool
Eq, Int -> Protocol -> ShowS
[Protocol] -> ShowS
Protocol -> String
(Int -> Protocol -> ShowS)
-> (Protocol -> String) -> ([Protocol] -> ShowS) -> Show Protocol
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Protocol] -> ShowS
$cshowList :: [Protocol] -> ShowS
show :: Protocol -> String
$cshow :: Protocol -> String
showsPrec :: Int -> Protocol -> ShowS
$cshowsPrec :: Int -> Protocol -> ShowS
Show, (forall x. Protocol -> Rep Protocol x)
-> (forall x. Rep Protocol x -> Protocol) -> Generic Protocol
forall x. Rep Protocol x -> Protocol
forall x. Protocol -> Rep Protocol x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Protocol x -> Protocol
$cfrom :: forall x. Protocol -> Rep Protocol x
Generic)

deriving instance NFData Protocol
deriving instance NoThunks Protocol

instance FromJSON Protocol where
  parseJSON :: Value -> Parser Protocol
parseJSON =
    String -> (Text -> Parser Protocol) -> Value -> Parser Protocol
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"Protocol" ((Text -> Parser Protocol) -> Value -> Parser Protocol)
-> (Text -> Parser Protocol) -> Value -> Parser Protocol
forall a b. (a -> b) -> a -> b
$ \Text
str -> case Text
str of

      -- The new names
      Text
"Byron" -> Protocol -> Parser Protocol
forall (f :: * -> *) a. Applicative f => a -> f a
pure Protocol
ByronProtocol
      Text
"Shelley" -> Protocol -> Parser Protocol
forall (f :: * -> *) a. Applicative f => a -> f a
pure Protocol
ShelleyProtocol
      Text
"Cardano" -> Protocol -> Parser Protocol
forall (f :: * -> *) a. Applicative f => a -> f a
pure Protocol
CardanoProtocol

      -- The old names
      Text
"RealPBFT" -> Protocol -> Parser Protocol
forall (f :: * -> *) a. Applicative f => a -> f a
pure Protocol
ByronProtocol
      Text
"TPraos" -> Protocol -> Parser Protocol
forall (f :: * -> *) a. Applicative f => a -> f a
pure Protocol
ShelleyProtocol

      Text
_ -> String -> Parser Protocol
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser Protocol) -> String -> Parser Protocol
forall a b. (a -> b) -> a -> b
$ String
"Parsing of Protocol failed. "
                String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a b. (Show a, ConvertText String b) => a -> b
show Text
str String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" is not a valid protocol"

type SomeConsensusProtocolConstraints blk =
     ( HasKESMetricsData blk
     , RunNode blk
     , TraceConstraints blk
     )


data SomeConsensusProtocol where

     SomeConsensusProtocol :: SomeConsensusProtocolConstraints blk
                           => Consensus.Protocol IO blk (BlockProtocol blk)
                           -> SomeConsensusProtocol