{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
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]
)
class RunNode blk => ProtocolClient blk where
data ProtocolClientInfoArgs blk
protocolClientInfo :: ProtocolClientInfoArgs blk -> ProtocolClientInfo blk
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)