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

module Bcc.Node.Protocol.Types
  ( Protocol(..)
  , SomeConsensusProtocol(..)
  ) where

import           Bcc.Prelude

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

import qualified Bcc.Api.Protocol.Types as Bcc

import           Bcc.Node.Orphans ()
import           Bcc.Tracing.Constraints (TraceConstraints)
import           Bcc.Tracing.Metrics (HasKESInfo, HasKESMetricsData)

data Protocol = ColeProtocol
              | SophieProtocol
              | BccProtocol
  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
"Cole" -> Protocol -> Parser Protocol
forall (f :: * -> *) a. Applicative f => a -> f a
pure Protocol
ColeProtocol
      Text
"Sophie" -> Protocol -> Parser Protocol
forall (f :: * -> *) a. Applicative f => a -> f a
pure Protocol
SophieProtocol
      Text
"Bcc" -> Protocol -> Parser Protocol
forall (f :: * -> *) a. Applicative f => a -> f a
pure Protocol
BccProtocol

      -- The old names
      Text
"RealPBFT" -> Protocol -> Parser Protocol
forall (f :: * -> *) a. Applicative f => a -> f a
pure Protocol
ColeProtocol
      Text
"TOptimum" -> Protocol -> Parser Protocol
forall (f :: * -> *) a. Applicative f => a -> f a
pure Protocol
SophieProtocol

      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"



data SomeConsensusProtocol where

     SomeConsensusProtocol :: forall blk. ( Bcc.Protocol IO blk
                                          , HasKESMetricsData blk
                                          , HasKESInfo blk
                                          , TraceConstraints blk
                                          )
                           => Bcc.BlockType blk
                           -> Bcc.ProtocolInfoArgs IO blk
                           -> SomeConsensusProtocol