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

-- DUPLICATE -- adapted from: cardano-api/src/Cardano/Api/Protocol/Types.hs

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

import Cardano.Chain.Slotting (EpochSlots)
import Data.Bifunctor (bimap)
import Ouroboros.Consensus.Block.Forging (BlockForging)
import Ouroboros.Consensus.Byron.ByronHFC (ByronBlockHFC)
import Ouroboros.Consensus.Cardano
import Ouroboros.Consensus.Cardano.Block
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 Ouroboros.Consensus.Shelley.HFEras ()
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)

class (RunNode blk, IOLike m) => Protocol m blk where
  data ProtocolInfoArgs m blk
  protocolInfo ::
    ProtocolInfoArgs m 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 m ByronBlockHFC = ProtocolInfoArgsByron ProtocolParamsByron
  protocolInfo :: ProtocolInfoArgs m (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 m (CardanoBlock StandardCrypto)
    = ProtocolInfoArgsCardano
        (CardanoProtocolParams StandardCrypto)

  protocolInfo :: ProtocolInfoArgs m (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
      )
  ) =>
  Protocol m (ShelleyBlockHFC (Consensus.TPraos StandardCrypto) ShelleyEra)
  where
  data ProtocolInfoArgs m (ShelleyBlockHFC (Consensus.TPraos StandardCrypto) ShelleyEra)
    = ProtocolInfoArgsShelley
        ShelleyGenesis
        (ProtocolParamsShelleyBased StandardCrypto)
        ProtVer
  protocolInfo :: ProtocolInfoArgs
  m
  (HardForkBlock '[ShelleyBlock (TPraos StandardCrypto) ShelleyEra])
-> (ProtocolInfo
      (HardForkBlock '[ShelleyBlock (TPraos StandardCrypto) ShelleyEra]),
    m [BlockForging
         m
         (HardForkBlock
            '[ShelleyBlock (TPraos StandardCrypto) ShelleyEra])])
protocolInfo (ProtocolInfoArgsShelley ShelleyGenesis
genesis ProtocolParamsShelleyBased StandardCrypto
shelleyBasedProtocolParams' ProtVer
protVer) =
    (ProtocolInfo (ShelleyBlock (TPraos StandardCrypto) ShelleyEra)
 -> ProtocolInfo
      (HardForkBlock '[ShelleyBlock (TPraos StandardCrypto) ShelleyEra]))
-> (m [BlockForging
         m (ShelleyBlock (TPraos StandardCrypto) ShelleyEra)]
    -> m [BlockForging
            m
            (HardForkBlock
               '[ShelleyBlock (TPraos StandardCrypto) ShelleyEra])])
-> (ProtocolInfo (ShelleyBlock (TPraos StandardCrypto) ShelleyEra),
    m [BlockForging
         m (ShelleyBlock (TPraos StandardCrypto) ShelleyEra)])
-> (ProtocolInfo
      (HardForkBlock '[ShelleyBlock (TPraos StandardCrypto) ShelleyEra]),
    m [BlockForging
         m
         (HardForkBlock
            '[ShelleyBlock (TPraos StandardCrypto) ShelleyEra])])
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) ShelleyEra)
-> ProtocolInfo
     (HardForkBlock '[ShelleyBlock (TPraos StandardCrypto) ShelleyEra])
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) ShelleyEra)]
 -> [BlockForging
       m
       (HardForkBlock
          '[ShelleyBlock (TPraos StandardCrypto) ShelleyEra])])
-> m [BlockForging
        m (ShelleyBlock (TPraos StandardCrypto) ShelleyEra)]
-> m [BlockForging
        m
        (HardForkBlock '[ShelleyBlock (TPraos StandardCrypto) ShelleyEra])]
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) ShelleyEra)]
  -> [BlockForging
        m
        (HardForkBlock
           '[ShelleyBlock (TPraos StandardCrypto) ShelleyEra])])
 -> m [BlockForging
         m (ShelleyBlock (TPraos StandardCrypto) ShelleyEra)]
 -> m [BlockForging
         m
         (HardForkBlock
            '[ShelleyBlock (TPraos StandardCrypto) ShelleyEra])])
-> ([BlockForging
       m (ShelleyBlock (TPraos StandardCrypto) ShelleyEra)]
    -> [BlockForging
          m
          (HardForkBlock
             '[ShelleyBlock (TPraos StandardCrypto) ShelleyEra])])
-> m [BlockForging
        m (ShelleyBlock (TPraos StandardCrypto) ShelleyEra)]
-> m [BlockForging
        m
        (HardForkBlock '[ShelleyBlock (TPraos StandardCrypto) ShelleyEra])]
forall a b. (a -> b) -> a -> b
$ (BlockForging m (ShelleyBlock (TPraos StandardCrypto) ShelleyEra)
 -> BlockForging
      m
      (HardForkBlock '[ShelleyBlock (TPraos StandardCrypto) ShelleyEra]))
-> [BlockForging
      m (ShelleyBlock (TPraos StandardCrypto) ShelleyEra)]
-> [BlockForging
      m
      (HardForkBlock '[ShelleyBlock (TPraos StandardCrypto) ShelleyEra])]
forall a b. (a -> b) -> [a] -> [b]
map BlockForging m (ShelleyBlock (TPraos StandardCrypto) ShelleyEra)
-> BlockForging
     m
     (HardForkBlock '[ShelleyBlock (TPraos StandardCrypto) ShelleyEra])
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) ShelleyEra),
  m [BlockForging
       m (ShelleyBlock (TPraos StandardCrypto) ShelleyEra)])
 -> (ProtocolInfo
       (HardForkBlock '[ShelleyBlock (TPraos StandardCrypto) ShelleyEra]),
     m [BlockForging
          m
          (HardForkBlock
             '[ShelleyBlock (TPraos StandardCrypto) ShelleyEra])]))
-> (ProtocolInfo (ShelleyBlock (TPraos StandardCrypto) ShelleyEra),
    m [BlockForging
         m (ShelleyBlock (TPraos StandardCrypto) ShelleyEra)])
-> (ProtocolInfo
      (HardForkBlock '[ShelleyBlock (TPraos StandardCrypto) ShelleyEra]),
    m [BlockForging
         m
         (HardForkBlock
            '[ShelleyBlock (TPraos StandardCrypto) ShelleyEra])])
forall a b. (a -> b) -> a -> b
$ ShelleyGenesis
-> ProtocolParamsShelleyBased StandardCrypto
-> ProtVer
-> (ProtocolInfo (ShelleyBlock (TPraos StandardCrypto) ShelleyEra),
    m [BlockForging
         m (ShelleyBlock (TPraos StandardCrypto) ShelleyEra)])
forall (m :: * -> *) c.
(IOLike m, ShelleyCompatible (TPraos c) ShelleyEra,
 TxLimits (ShelleyBlock (TPraos c) ShelleyEra)) =>
ShelleyGenesis
-> ProtocolParamsShelleyBased c
-> ProtVer
-> (ProtocolInfo (ShelleyBlock (TPraos c) ShelleyEra),
    m [BlockForging m (ShelleyBlock (TPraos c) ShelleyEra)])
protocolInfoShelley ShelleyGenesis
genesis ProtocolParamsShelleyBased StandardCrypto
shelleyBasedProtocolParams' ProtVer
protVer

instance
  Consensus.LedgerSupportsProtocol
    ( Consensus.ShelleyBlock
        (Consensus.TPraos StandardCrypto)
        Consensus.ShelleyEra
    ) =>
  ProtocolClient (ShelleyBlockHFC (Consensus.TPraos StandardCrypto) ShelleyEra)
  where
  data ProtocolClientInfoArgs (ShelleyBlockHFC (Consensus.TPraos StandardCrypto) ShelleyEra)
    = ProtocolClientInfoArgsShelley
  protocolClientInfo :: ProtocolClientInfoArgs
  (HardForkBlock '[ShelleyBlock (TPraos StandardCrypto) ShelleyEra])
-> ProtocolClientInfo
     (HardForkBlock '[ShelleyBlock (TPraos StandardCrypto) ShelleyEra])
protocolClientInfo ProtocolClientInfoArgs
  (HardForkBlock '[ShelleyBlock (TPraos StandardCrypto) ShelleyEra])
R:ProtocolClientInfoArgsHardForkBlock
ProtocolClientInfoArgsShelley =
    ProtocolClientInfo
  (ShelleyBlock (TPraos StandardCrypto) ShelleyEra)
-> ProtocolClientInfo
     (HardForkBlock '[ShelleyBlock (TPraos StandardCrypto) ShelleyEra])
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) ShelleyEra)
forall proto era. ProtocolClientInfo (ShelleyBlock proto era)
protocolClientInfoShelley

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

deriving instance Eq (BlockType blk)
deriving instance Show (BlockType blk)