{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

module Cardano.Api.Protocol
  ( BlockType (..)
  , SomeBlockType (..)
  , reflBlockType
  , Protocol (..)
  , ProtocolInfoArgs (..)
  , ProtocolClient (..)
  , ProtocolClientInfoArgs (..)
  )
where

import           Cardano.Api.Modes

import           Ouroboros.Consensus.Block.Forging (BlockForging)
import           Ouroboros.Consensus.Cardano
import           Ouroboros.Consensus.Cardano.Block
import           Ouroboros.Consensus.Cardano.ByronHFC (ByronBlockHFC)
import           Ouroboros.Consensus.Cardano.Node
import           Ouroboros.Consensus.HardFork.Combinator.Embed.Unary
import qualified Ouroboros.Consensus.Ledger.SupportsProtocol as Consensus (LedgerSupportsProtocol)
import           Ouroboros.Consensus.Node.ProtocolInfo (ProtocolClientInfo (..), ProtocolInfo (..))
import           Ouroboros.Consensus.Node.Run (RunNode)
import qualified Ouroboros.Consensus.Protocol.TPraos as Consensus
import qualified Ouroboros.Consensus.Shelley.Eras as Consensus (ShelleyEra)
import qualified Ouroboros.Consensus.Shelley.Ledger.Block as Consensus (ShelleyBlock)
import           Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol ()
import           Ouroboros.Consensus.Shelley.ShelleyHFC (ShelleyBlockHFC)
import           Ouroboros.Consensus.Util.IOLike (IOLike)

import           Data.Bifunctor (bimap)

import           Type.Reflection ((:~:) (..))

class (RunNode blk, IOLike m) => Protocol m blk where
  data ProtocolInfoArgs blk
  protocolInfo :: ProtocolInfoArgs blk -> (ProtocolInfo blk, m [BlockForging m blk])

-- | Node client support for each consensus protocol.
--
-- This is like 'Protocol' but for clients of the node, so with less onerous
-- requirements than to run a node.
class RunNode blk => ProtocolClient blk where
  data ProtocolClientInfoArgs blk
  protocolClientInfo :: ProtocolClientInfoArgs blk -> ProtocolClientInfo blk

-- | Run PBFT against the Byron ledger
instance IOLike m => Protocol m ByronBlockHFC where
  data ProtocolInfoArgs ByronBlockHFC = ProtocolInfoArgsByron ProtocolParamsByron
  protocolInfo :: ProtocolInfoArgs (HardForkBlock '[ByronBlock])
-> (ProtocolInfo (HardForkBlock '[ByronBlock]),
    m [BlockForging m (HardForkBlock '[ByronBlock])])
protocolInfo (ProtocolInfoArgsByron ProtocolParamsByron
params) =
    ( ProtocolInfo ByronBlock
-> ProtocolInfo (HardForkBlock '[ByronBlock])
forall blk.
NoHardForks blk =>
ProtocolInfo blk -> ProtocolInfo (HardForkBlock '[blk])
forall (f :: * -> *) blk.
(Isomorphic f, NoHardForks blk) =>
f blk -> f (HardForkBlock '[blk])
inject (ProtocolInfo ByronBlock
 -> ProtocolInfo (HardForkBlock '[ByronBlock]))
-> ProtocolInfo ByronBlock
-> ProtocolInfo (HardForkBlock '[ByronBlock])
forall a b. (a -> b) -> a -> b
$ ProtocolParamsByron -> ProtocolInfo ByronBlock
protocolInfoByron ProtocolParamsByron
params
    , [BlockForging m (HardForkBlock '[ByronBlock])]
-> m [BlockForging m (HardForkBlock '[ByronBlock])]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([BlockForging m (HardForkBlock '[ByronBlock])]
 -> m [BlockForging m (HardForkBlock '[ByronBlock])])
-> ([BlockForging m ByronBlock]
    -> [BlockForging m (HardForkBlock '[ByronBlock])])
-> [BlockForging m ByronBlock]
-> m [BlockForging m (HardForkBlock '[ByronBlock])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BlockForging m ByronBlock
 -> BlockForging m (HardForkBlock '[ByronBlock]))
-> [BlockForging m ByronBlock]
-> [BlockForging m (HardForkBlock '[ByronBlock])]
forall a b. (a -> b) -> [a] -> [b]
map BlockForging m ByronBlock
-> BlockForging m (HardForkBlock '[ByronBlock])
forall blk.
NoHardForks blk =>
BlockForging m blk -> BlockForging m (HardForkBlock '[blk])
forall (f :: * -> *) blk.
(Isomorphic f, NoHardForks blk) =>
f blk -> f (HardForkBlock '[blk])
inject ([BlockForging m ByronBlock]
 -> m [BlockForging m (HardForkBlock '[ByronBlock])])
-> [BlockForging m ByronBlock]
-> m [BlockForging m (HardForkBlock '[ByronBlock])]
forall a b. (a -> b) -> a -> b
$ ProtocolParamsByron -> [BlockForging m ByronBlock]
forall (m :: * -> *).
Monad m =>
ProtocolParamsByron -> [BlockForging m ByronBlock]
blockForgingByron ProtocolParamsByron
params
    )

instance (CardanoHardForkConstraints StandardCrypto, IOLike m) => Protocol m (CardanoBlock StandardCrypto) where
  data ProtocolInfoArgs (CardanoBlock StandardCrypto)
    = ProtocolInfoArgsCardano
        (CardanoProtocolParams StandardCrypto)

  protocolInfo :: ProtocolInfoArgs (HardForkBlock (CardanoEras StandardCrypto))
-> (ProtocolInfo (HardForkBlock (CardanoEras StandardCrypto)),
    m [BlockForging m (HardForkBlock (CardanoEras StandardCrypto))])
protocolInfo (ProtocolInfoArgsCardano CardanoProtocolParams StandardCrypto
paramsCardano) =
    CardanoProtocolParams StandardCrypto
-> (ProtocolInfo (HardForkBlock (CardanoEras StandardCrypto)),
    m [BlockForging m (HardForkBlock (CardanoEras StandardCrypto))])
forall c (m :: * -> *).
(IOLike m, CardanoHardForkConstraints c) =>
CardanoProtocolParams c
-> (ProtocolInfo (CardanoBlock c),
    m [BlockForging m (CardanoBlock c)])
protocolInfoCardano CardanoProtocolParams StandardCrypto
paramsCardano

instance ProtocolClient ByronBlockHFC where
  data ProtocolClientInfoArgs ByronBlockHFC
    = ProtocolClientInfoArgsByron EpochSlots
  protocolClientInfo :: ProtocolClientInfoArgs (HardForkBlock '[ByronBlock])
-> ProtocolClientInfo (HardForkBlock '[ByronBlock])
protocolClientInfo (ProtocolClientInfoArgsByron EpochSlots
epochSlots) =
    ProtocolClientInfo ByronBlock
-> ProtocolClientInfo (HardForkBlock '[ByronBlock])
forall blk.
NoHardForks blk =>
ProtocolClientInfo blk -> ProtocolClientInfo (HardForkBlock '[blk])
forall (f :: * -> *) blk.
(Isomorphic f, NoHardForks blk) =>
f blk -> f (HardForkBlock '[blk])
inject (ProtocolClientInfo ByronBlock
 -> ProtocolClientInfo (HardForkBlock '[ByronBlock]))
-> ProtocolClientInfo ByronBlock
-> ProtocolClientInfo (HardForkBlock '[ByronBlock])
forall a b. (a -> b) -> a -> b
$ EpochSlots -> ProtocolClientInfo ByronBlock
protocolClientInfoByron EpochSlots
epochSlots

instance CardanoHardForkConstraints StandardCrypto => ProtocolClient (CardanoBlock StandardCrypto) where
  data ProtocolClientInfoArgs (CardanoBlock StandardCrypto)
    = ProtocolClientInfoArgsCardano EpochSlots
  protocolClientInfo :: ProtocolClientInfoArgs (HardForkBlock (CardanoEras StandardCrypto))
-> ProtocolClientInfo (HardForkBlock (CardanoEras StandardCrypto))
protocolClientInfo (ProtocolClientInfoArgsCardano EpochSlots
epochSlots) =
    EpochSlots
-> ProtocolClientInfo (HardForkBlock (CardanoEras StandardCrypto))
forall c. EpochSlots -> ProtocolClientInfo (CardanoBlock c)
protocolClientInfoCardano EpochSlots
epochSlots

instance
  ( IOLike m
  , Consensus.LedgerSupportsProtocol
      ( Consensus.ShelleyBlock
          (Consensus.TPraos StandardCrypto)
          (ShelleyEra StandardCrypto)
      )
  )
  => Protocol m (ShelleyBlockHFC (Consensus.TPraos StandardCrypto) StandardShelley)
  where
  data ProtocolInfoArgs (ShelleyBlockHFC (Consensus.TPraos StandardCrypto) StandardShelley)
    = ProtocolInfoArgsShelley
        (ShelleyGenesis StandardCrypto)
        (ProtocolParamsShelleyBased StandardCrypto)
        ProtVer
  protocolInfo :: ProtocolInfoArgs
  (HardForkBlock
     '[ShelleyBlock (TPraos StandardCrypto) StandardShelley])
-> (ProtocolInfo
      (HardForkBlock
         '[ShelleyBlock (TPraos StandardCrypto) StandardShelley]),
    m [BlockForging
         m
         (HardForkBlock
            '[ShelleyBlock (TPraos StandardCrypto) StandardShelley])])
protocolInfo (ProtocolInfoArgsShelley ShelleyGenesis StandardCrypto
genesis ProtocolParamsShelleyBased StandardCrypto
paramsShelleyBased_ ProtVer
paramsShelley_) =
    (ProtocolInfo
   (ShelleyBlock (TPraos StandardCrypto) StandardShelley)
 -> ProtocolInfo
      (HardForkBlock
         '[ShelleyBlock (TPraos StandardCrypto) StandardShelley]))
-> (m [BlockForging
         m (ShelleyBlock (TPraos StandardCrypto) StandardShelley)]
    -> m [BlockForging
            m
            (HardForkBlock
               '[ShelleyBlock (TPraos StandardCrypto) StandardShelley])])
-> (ProtocolInfo
      (ShelleyBlock (TPraos StandardCrypto) StandardShelley),
    m [BlockForging
         m (ShelleyBlock (TPraos StandardCrypto) StandardShelley)])
-> (ProtocolInfo
      (HardForkBlock
         '[ShelleyBlock (TPraos StandardCrypto) StandardShelley]),
    m [BlockForging
         m
         (HardForkBlock
            '[ShelleyBlock (TPraos StandardCrypto) StandardShelley])])
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ProtocolInfo (ShelleyBlock (TPraos StandardCrypto) StandardShelley)
-> ProtocolInfo
     (HardForkBlock
        '[ShelleyBlock (TPraos StandardCrypto) StandardShelley])
forall blk.
NoHardForks blk =>
ProtocolInfo blk -> ProtocolInfo (HardForkBlock '[blk])
forall (f :: * -> *) blk.
(Isomorphic f, NoHardForks blk) =>
f blk -> f (HardForkBlock '[blk])
inject (([BlockForging
    m (ShelleyBlock (TPraos StandardCrypto) StandardShelley)]
 -> [BlockForging
       m
       (HardForkBlock
          '[ShelleyBlock (TPraos StandardCrypto) StandardShelley])])
-> m [BlockForging
        m (ShelleyBlock (TPraos StandardCrypto) StandardShelley)]
-> m [BlockForging
        m
        (HardForkBlock
           '[ShelleyBlock (TPraos StandardCrypto) StandardShelley])]
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([BlockForging
     m (ShelleyBlock (TPraos StandardCrypto) StandardShelley)]
  -> [BlockForging
        m
        (HardForkBlock
           '[ShelleyBlock (TPraos StandardCrypto) StandardShelley])])
 -> m [BlockForging
         m (ShelleyBlock (TPraos StandardCrypto) StandardShelley)]
 -> m [BlockForging
         m
         (HardForkBlock
            '[ShelleyBlock (TPraos StandardCrypto) StandardShelley])])
-> ([BlockForging
       m (ShelleyBlock (TPraos StandardCrypto) StandardShelley)]
    -> [BlockForging
          m
          (HardForkBlock
             '[ShelleyBlock (TPraos StandardCrypto) StandardShelley])])
-> m [BlockForging
        m (ShelleyBlock (TPraos StandardCrypto) StandardShelley)]
-> m [BlockForging
        m
        (HardForkBlock
           '[ShelleyBlock (TPraos StandardCrypto) StandardShelley])]
forall a b. (a -> b) -> a -> b
$ (BlockForging
   m (ShelleyBlock (TPraos StandardCrypto) StandardShelley)
 -> BlockForging
      m
      (HardForkBlock
         '[ShelleyBlock (TPraos StandardCrypto) StandardShelley]))
-> [BlockForging
      m (ShelleyBlock (TPraos StandardCrypto) StandardShelley)]
-> [BlockForging
      m
      (HardForkBlock
         '[ShelleyBlock (TPraos StandardCrypto) StandardShelley])]
forall a b. (a -> b) -> [a] -> [b]
map BlockForging
  m (ShelleyBlock (TPraos StandardCrypto) StandardShelley)
-> BlockForging
     m
     (HardForkBlock
        '[ShelleyBlock (TPraos StandardCrypto) StandardShelley])
forall blk.
NoHardForks blk =>
BlockForging m blk -> BlockForging m (HardForkBlock '[blk])
forall (f :: * -> *) blk.
(Isomorphic f, NoHardForks blk) =>
f blk -> f (HardForkBlock '[blk])
inject) ((ProtocolInfo
    (ShelleyBlock (TPraos StandardCrypto) StandardShelley),
  m [BlockForging
       m (ShelleyBlock (TPraos StandardCrypto) StandardShelley)])
 -> (ProtocolInfo
       (HardForkBlock
          '[ShelleyBlock (TPraos StandardCrypto) StandardShelley]),
     m [BlockForging
          m
          (HardForkBlock
             '[ShelleyBlock (TPraos StandardCrypto) StandardShelley])]))
-> (ProtocolInfo
      (ShelleyBlock (TPraos StandardCrypto) StandardShelley),
    m [BlockForging
         m (ShelleyBlock (TPraos StandardCrypto) StandardShelley)])
-> (ProtocolInfo
      (HardForkBlock
         '[ShelleyBlock (TPraos StandardCrypto) StandardShelley]),
    m [BlockForging
         m
         (HardForkBlock
            '[ShelleyBlock (TPraos StandardCrypto) StandardShelley])])
forall a b. (a -> b) -> a -> b
$
      ShelleyGenesis StandardCrypto
-> ProtocolParamsShelleyBased StandardCrypto
-> ProtVer
-> (ProtocolInfo
      (ShelleyBlock (TPraos StandardCrypto) StandardShelley),
    m [BlockForging
         m (ShelleyBlock (TPraos StandardCrypto) StandardShelley)])
forall (m :: * -> *) c.
(IOLike m, PraosCrypto c,
 ShelleyCompatible (TPraos c) (ShelleyEra c),
 TxLimits (ShelleyBlock (TPraos c) (ShelleyEra c))) =>
ShelleyGenesis c
-> ProtocolParamsShelleyBased c
-> ProtVer
-> (ProtocolInfo (ShelleyBlock (TPraos c) (ShelleyEra c)),
    m [BlockForging m (ShelleyBlock (TPraos c) (ShelleyEra c))])
protocolInfoShelley ShelleyGenesis StandardCrypto
genesis ProtocolParamsShelleyBased StandardCrypto
paramsShelleyBased_ ProtVer
paramsShelley_

instance
  Consensus.LedgerSupportsProtocol
    ( Consensus.ShelleyBlock
        (Consensus.TPraos StandardCrypto)
        (Consensus.ShelleyEra StandardCrypto)
    )
  => ProtocolClient (ShelleyBlockHFC (Consensus.TPraos StandardCrypto) StandardShelley)
  where
  data ProtocolClientInfoArgs (ShelleyBlockHFC (Consensus.TPraos StandardCrypto) StandardShelley)
    = ProtocolClientInfoArgsShelley
  protocolClientInfo :: ProtocolClientInfoArgs
  (HardForkBlock
     '[ShelleyBlock (TPraos StandardCrypto) StandardShelley])
-> ProtocolClientInfo
     (HardForkBlock
        '[ShelleyBlock (TPraos StandardCrypto) StandardShelley])
protocolClientInfo ProtocolClientInfoArgs
  (HardForkBlock
     '[ShelleyBlock (TPraos StandardCrypto) StandardShelley])
R:ProtocolClientInfoArgsHardForkBlock
ProtocolClientInfoArgsShelley =
    ProtocolClientInfo
  (ShelleyBlock (TPraos StandardCrypto) StandardShelley)
-> ProtocolClientInfo
     (HardForkBlock
        '[ShelleyBlock (TPraos StandardCrypto) StandardShelley])
forall blk.
NoHardForks blk =>
ProtocolClientInfo blk -> ProtocolClientInfo (HardForkBlock '[blk])
forall (f :: * -> *) blk.
(Isomorphic f, NoHardForks blk) =>
f blk -> f (HardForkBlock '[blk])
inject ProtocolClientInfo
  (ShelleyBlock (TPraos StandardCrypto) StandardShelley)
forall proto era. ProtocolClientInfo (ShelleyBlock proto era)
protocolClientInfoShelley

data BlockType blk where
  ByronBlockType :: BlockType ByronBlockHFC
  ShelleyBlockType :: BlockType (ShelleyBlockHFC (Consensus.TPraos StandardCrypto) StandardShelley)
  CardanoBlockType :: BlockType (CardanoBlock StandardCrypto)

deriving instance Eq (BlockType blk)

deriving instance Show (BlockType blk)

reflBlockType :: BlockType blk -> BlockType blk' -> Maybe (blk :~: blk')
reflBlockType :: forall blk blk'.
BlockType blk -> BlockType blk' -> Maybe (blk :~: blk')
reflBlockType BlockType blk
ByronBlockType BlockType blk'
ByronBlockType = (blk :~: blk') -> Maybe (blk :~: blk')
forall a. a -> Maybe a
Just blk :~: blk
blk :~: blk'
forall {k} (a :: k). a :~: a
Refl
reflBlockType BlockType blk
ShelleyBlockType BlockType blk'
ShelleyBlockType = (blk :~: blk') -> Maybe (blk :~: blk')
forall a. a -> Maybe a
Just blk :~: blk
blk :~: blk'
forall {k} (a :: k). a :~: a
Refl
reflBlockType BlockType blk
CardanoBlockType BlockType blk'
CardanoBlockType = (blk :~: blk') -> Maybe (blk :~: blk')
forall a. a -> Maybe a
Just blk :~: blk
blk :~: blk'
forall {k} (a :: k). a :~: a
Refl
reflBlockType BlockType blk
_ BlockType blk'
_ = Maybe (blk :~: blk')
forall a. Maybe a
Nothing

data SomeBlockType where
  SomeBlockType :: BlockType blk -> SomeBlockType

deriving instance Show SomeBlockType