{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Ouroboros.Consensus.Byron.ByronHFC (
ByronBlockHFC
, ByronPartialLedgerConfig (..)
) where
import qualified Cardano.Chain.Common as CC
import qualified Cardano.Chain.Genesis as CC.Genesis
import qualified Cardano.Chain.Update as CC.Update
import Control.Monad
import qualified Data.Map.Strict as Map
import Data.Maybe (listToMaybe, mapMaybe)
import Data.Word
import GHC.Generics
import NoThunks.Class
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Byron.Ledger
import qualified Ouroboros.Consensus.Byron.Ledger.Inspect as Byron.Inspect
import Ouroboros.Consensus.Byron.Node ()
import Ouroboros.Consensus.Config
import Ouroboros.Consensus.HardFork.Combinator
import Ouroboros.Consensus.HardFork.Combinator.Degenerate
import Ouroboros.Consensus.HardFork.Combinator.Serialisation.Common
import Ouroboros.Consensus.HardFork.Simple
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Node.NetworkProtocolVersion
import Ouroboros.Consensus.Protocol.PBFT (PBft, PBftCrypto)
import Ouroboros.Consensus.Storage.Serialisation
type ByronBlockHFC = HardForkBlock '[ByronBlock]
instance NoHardForks ByronBlock where
getEraParams :: TopLevelConfig ByronBlock -> EraParams
getEraParams TopLevelConfig ByronBlock
cfg =
Config -> EraParams
byronEraParamsNeverHardForks (BlockConfig ByronBlock -> Config
byronGenesisConfig (TopLevelConfig ByronBlock -> BlockConfig ByronBlock
forall blk. TopLevelConfig blk -> BlockConfig blk
configBlock TopLevelConfig ByronBlock
cfg))
toPartialLedgerConfig :: forall (proxy :: * -> *).
proxy ByronBlock
-> LedgerConfig ByronBlock -> PartialLedgerConfig ByronBlock
toPartialLedgerConfig proxy ByronBlock
_ LedgerConfig ByronBlock
cfg = ByronPartialLedgerConfig {
byronLedgerConfig :: LedgerConfig ByronBlock
byronLedgerConfig = LedgerConfig ByronBlock
cfg
, byronTriggerHardFork :: TriggerHardFork
byronTriggerHardFork = TriggerHardFork
TriggerHardForkNotDuringThisExecution
}
instance SupportedNetworkProtocolVersion ByronBlockHFC where
supportedNodeToNodeVersions :: Proxy ByronBlockHFC
-> Map NodeToNodeVersion (BlockNodeToNodeVersion ByronBlockHFC)
supportedNodeToNodeVersions Proxy ByronBlockHFC
_ =
(BlockNodeToNodeVersion ByronBlock
-> BlockNodeToNodeVersion ByronBlockHFC)
-> Map NodeToNodeVersion (BlockNodeToNodeVersion ByronBlock)
-> Map NodeToNodeVersion (BlockNodeToNodeVersion ByronBlockHFC)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map BlockNodeToNodeVersion ByronBlock
-> BlockNodeToNodeVersion ByronBlockHFC
BlockNodeToNodeVersion ByronBlock
-> HardForkNodeToNodeVersion '[ByronBlock]
forall x (xs1 :: [*]).
BlockNodeToNodeVersion x -> HardForkNodeToNodeVersion (x : xs1)
HardForkNodeToNodeDisabled (Map NodeToNodeVersion (BlockNodeToNodeVersion ByronBlock)
-> Map NodeToNodeVersion (BlockNodeToNodeVersion ByronBlockHFC))
-> Map NodeToNodeVersion (BlockNodeToNodeVersion ByronBlock)
-> Map NodeToNodeVersion (BlockNodeToNodeVersion ByronBlockHFC)
forall a b. (a -> b) -> a -> b
$
Proxy ByronBlock
-> Map NodeToNodeVersion (BlockNodeToNodeVersion ByronBlock)
forall blk.
SupportedNetworkProtocolVersion blk =>
Proxy blk -> Map NodeToNodeVersion (BlockNodeToNodeVersion blk)
supportedNodeToNodeVersions (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @ByronBlock)
supportedNodeToClientVersions :: Proxy ByronBlockHFC
-> Map NodeToClientVersion (BlockNodeToClientVersion ByronBlockHFC)
supportedNodeToClientVersions Proxy ByronBlockHFC
_ =
(BlockNodeToClientVersion ByronBlock
-> BlockNodeToClientVersion ByronBlockHFC)
-> Map NodeToClientVersion (BlockNodeToClientVersion ByronBlock)
-> Map NodeToClientVersion (BlockNodeToClientVersion ByronBlockHFC)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map BlockNodeToClientVersion ByronBlock
-> BlockNodeToClientVersion ByronBlockHFC
BlockNodeToClientVersion ByronBlock
-> HardForkNodeToClientVersion '[ByronBlock]
forall x (xs1 :: [*]).
BlockNodeToClientVersion x -> HardForkNodeToClientVersion (x : xs1)
HardForkNodeToClientDisabled (Map NodeToClientVersion (BlockNodeToClientVersion ByronBlock)
-> Map
NodeToClientVersion (BlockNodeToClientVersion ByronBlockHFC))
-> Map NodeToClientVersion (BlockNodeToClientVersion ByronBlock)
-> Map NodeToClientVersion (BlockNodeToClientVersion ByronBlockHFC)
forall a b. (a -> b) -> a -> b
$
Proxy ByronBlock
-> Map NodeToClientVersion (BlockNodeToClientVersion ByronBlock)
forall blk.
SupportedNetworkProtocolVersion blk =>
Proxy blk -> Map NodeToClientVersion (BlockNodeToClientVersion blk)
supportedNodeToClientVersions (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @ByronBlock)
latestReleasedNodeVersion :: Proxy ByronBlockHFC
-> (Maybe NodeToNodeVersion, Maybe NodeToClientVersion)
latestReleasedNodeVersion = Proxy ByronBlockHFC
-> (Maybe NodeToNodeVersion, Maybe NodeToClientVersion)
forall blk.
SupportedNetworkProtocolVersion blk =>
Proxy blk -> (Maybe NodeToNodeVersion, Maybe NodeToClientVersion)
latestReleasedNodeVersionDefault
instance SerialiseConstraintsHFC ByronBlock
instance SerialiseHFC '[ByronBlock] where
encodeDiskHfcBlock :: CodecConfig ByronBlockHFC -> ByronBlockHFC -> Encoding
encodeDiskHfcBlock (DegenCodecConfig CodecConfig ByronBlock
ccfg) (DegenBlock ByronBlock
b) =
CodecConfig ByronBlock -> ByronBlock -> Encoding
forall blk a. EncodeDisk blk a => CodecConfig blk -> a -> Encoding
encodeDisk CodecConfig ByronBlock
ccfg ByronBlock
b
decodeDiskHfcBlock :: CodecConfig ByronBlockHFC
-> forall s. Decoder s (ByteString -> ByronBlockHFC)
decodeDiskHfcBlock (DegenCodecConfig CodecConfig ByronBlock
ccfg) =
(ByronBlock -> ByronBlockHFC)
-> (ByteString -> ByronBlock) -> ByteString -> ByronBlockHFC
forall a b. (a -> b) -> (ByteString -> a) -> ByteString -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByronBlock -> ByronBlockHFC
forall b. NoHardForks b => b -> HardForkBlock '[b]
DegenBlock ((ByteString -> ByronBlock) -> ByteString -> ByronBlockHFC)
-> Decoder s (ByteString -> ByronBlock)
-> Decoder s (ByteString -> ByronBlockHFC)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CodecConfig ByronBlock
-> forall s. Decoder s (ByteString -> ByronBlock)
forall blk a.
DecodeDisk blk a =>
CodecConfig blk -> forall s. Decoder s a
decodeDisk CodecConfig ByronBlock
ccfg
reconstructHfcPrefixLen :: forall (proxy :: * -> *). proxy (Header ByronBlockHFC) -> PrefixLen
reconstructHfcPrefixLen proxy (Header ByronBlockHFC)
_ =
Proxy (Header ByronBlock) -> PrefixLen
forall (proxy :: * -> *). proxy (Header ByronBlock) -> PrefixLen
forall (f :: * -> *) blk (proxy :: * -> *).
ReconstructNestedCtxt f blk =>
proxy (f blk) -> PrefixLen
reconstructPrefixLen (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(Header ByronBlock))
reconstructHfcNestedCtxt :: forall (proxy :: * -> *).
proxy (Header ByronBlockHFC)
-> ShortByteString
-> SizeInBytes
-> SomeSecond (NestedCtxt Header) ByronBlockHFC
reconstructHfcNestedCtxt proxy (Header ByronBlockHFC)
_ ShortByteString
prefix SizeInBytes
blockSize =
(forall a.
NestedCtxt_ ByronBlock Header a
-> NestedCtxt_ ByronBlockHFC Header a)
-> SomeSecond (NestedCtxt Header) ByronBlock
-> SomeSecond (NestedCtxt Header) ByronBlockHFC
forall blk (f :: * -> *) blk' (f' :: * -> *).
(forall a. NestedCtxt_ blk f a -> NestedCtxt_ blk' f' a)
-> SomeSecond (NestedCtxt f) blk -> SomeSecond (NestedCtxt f') blk'
mapSomeNestedCtxt NestedCtxt_ ByronBlock Header a
-> NestedCtxt_ ByronBlockHFC Header a
forall a.
NestedCtxt_ ByronBlock Header a
-> NestedCtxt_ ByronBlockHFC Header a
forall x (a :: * -> *) b (xs1 :: [*]).
NestedCtxt_ x a b -> NestedCtxt_ (HardForkBlock (x : xs1)) a b
NCZ (SomeSecond (NestedCtxt Header) ByronBlock
-> SomeSecond (NestedCtxt Header) ByronBlockHFC)
-> SomeSecond (NestedCtxt Header) ByronBlock
-> SomeSecond (NestedCtxt Header) ByronBlockHFC
forall a b. (a -> b) -> a -> b
$
Proxy (Header ByronBlock)
-> ShortByteString
-> SizeInBytes
-> SomeSecond (NestedCtxt Header) ByronBlock
forall (proxy :: * -> *).
proxy (Header ByronBlock)
-> ShortByteString
-> SizeInBytes
-> SomeSecond (NestedCtxt Header) ByronBlock
forall (f :: * -> *) blk (proxy :: * -> *).
ReconstructNestedCtxt f blk =>
proxy (f blk)
-> ShortByteString -> SizeInBytes -> SomeSecond (NestedCtxt f) blk
reconstructNestedCtxt (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(Header ByronBlock)) ShortByteString
prefix SizeInBytes
blockSize
getHfcBinaryBlockInfo :: ByronBlockHFC -> BinaryBlockInfo
getHfcBinaryBlockInfo (DegenBlock ByronBlock
b) =
ByronBlock -> BinaryBlockInfo
forall blk. HasBinaryBlockInfo blk => blk -> BinaryBlockInfo
getBinaryBlockInfo ByronBlock
b
byronTransition :: PartialLedgerConfig ByronBlock
-> Word16
-> LedgerState ByronBlock
-> Maybe EpochNo
byronTransition :: PartialLedgerConfig ByronBlock
-> Word16 -> LedgerState ByronBlock -> Maybe EpochNo
byronTransition PartialLedgerConfig ByronBlock
partialConfig Word16
shelleyMajorVersion LedgerState ByronBlock
state =
[EpochNo] -> Maybe EpochNo
forall a. [a] -> Maybe a
takeAny
([EpochNo] -> Maybe EpochNo)
-> (LedgerState ByronBlock -> [EpochNo])
-> LedgerState ByronBlock
-> Maybe EpochNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProtocolUpdate -> Maybe EpochNo) -> [ProtocolUpdate] -> [EpochNo]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ProtocolUpdate -> Maybe EpochNo
isTransitionToShelley
([ProtocolUpdate] -> [EpochNo])
-> (LedgerState ByronBlock -> [ProtocolUpdate])
-> LedgerState ByronBlock
-> [EpochNo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerConfig ByronBlock
-> LedgerState ByronBlock -> [ProtocolUpdate]
Byron.Inspect.protocolUpdates LedgerConfig ByronBlock
lConfig
(LedgerState ByronBlock -> Maybe EpochNo)
-> LedgerState ByronBlock -> Maybe EpochNo
forall a b. (a -> b) -> a -> b
$ LedgerState ByronBlock
state
where
ByronPartialLedgerConfig LedgerConfig ByronBlock
lConfig TriggerHardFork
_ = PartialLedgerConfig ByronBlock
partialConfig
ByronTransitionInfo Map ProtocolVersion BlockNo
transitionInfo = LedgerState ByronBlock -> ByronTransition
byronLedgerTransition LedgerState ByronBlock
state
k :: BlockCount
k = GenesisData -> BlockCount
CC.Genesis.gdK (GenesisData -> BlockCount) -> GenesisData -> BlockCount
forall a b. (a -> b) -> a -> b
$ Config -> GenesisData
CC.Genesis.configGenesisData Config
LedgerConfig ByronBlock
lConfig
isTransitionToShelley :: Byron.Inspect.ProtocolUpdate -> Maybe EpochNo
isTransitionToShelley :: ProtocolUpdate -> Maybe EpochNo
isTransitionToShelley ProtocolUpdate
update = do
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ ProtocolVersion -> Word16
CC.Update.pvMajor ProtocolVersion
version Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
shelleyMajorVersion
case ProtocolUpdate -> UpdateState
Byron.Inspect.protocolUpdateState ProtocolUpdate
update of
Byron.Inspect.UpdateCandidate SlotNo
_becameCandidateSlotNo EpochNo
adoptedIn -> do
BlockNo
becameCandidateBlockNo <- ProtocolVersion -> Map ProtocolVersion BlockNo -> Maybe BlockNo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ProtocolVersion
version Map ProtocolVersion BlockNo
transitionInfo
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ BlockNo -> Bool
isReallyStable BlockNo
becameCandidateBlockNo
EpochNo -> Maybe EpochNo
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return EpochNo
adoptedIn
Byron.Inspect.UpdateStableCandidate EpochNo
adoptedIn ->
EpochNo -> Maybe EpochNo
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return EpochNo
adoptedIn
UpdateState
_otherwise ->
Maybe EpochNo
forall a. Maybe a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
where
version :: CC.Update.ProtocolVersion
version :: ProtocolVersion
version = ProtocolUpdate -> ProtocolVersion
Byron.Inspect.protocolUpdateVersion ProtocolUpdate
update
isReallyStable :: BlockNo -> Bool
isReallyStable :: BlockNo -> Bool
isReallyStable (BlockNo Word64
bno) = Word64
distance Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= BlockCount -> Word64
CC.unBlockCount BlockCount
k
where
distance :: Word64
distance :: Word64
distance = case LedgerState ByronBlock -> WithOrigin BlockNo
byronLedgerTipBlockNo LedgerState ByronBlock
state of
WithOrigin BlockNo
Origin -> Word64
bno Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1
NotOrigin (BlockNo Word64
tip) -> Word64
tip Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
bno
takeAny :: [a] -> Maybe a
takeAny :: forall a. [a] -> Maybe a
takeAny = [a] -> Maybe a
forall a. [a] -> Maybe a
listToMaybe
instance SingleEraBlock ByronBlock where
singleEraTransition :: PartialLedgerConfig ByronBlock
-> EraParams -> Bound -> LedgerState ByronBlock -> Maybe EpochNo
singleEraTransition PartialLedgerConfig ByronBlock
pcfg EraParams
_eraParams Bound
_eraStart LedgerState ByronBlock
ledgerState =
case ByronPartialLedgerConfig -> TriggerHardFork
byronTriggerHardFork PartialLedgerConfig ByronBlock
ByronPartialLedgerConfig
pcfg of
TriggerHardFork
TriggerHardForkNotDuringThisExecution -> Maybe EpochNo
forall a. Maybe a
Nothing
TriggerHardForkAtEpoch EpochNo
epoch -> EpochNo -> Maybe EpochNo
forall a. a -> Maybe a
Just EpochNo
epoch
TriggerHardForkAtVersion Word16
shelleyMajorVersion ->
PartialLedgerConfig ByronBlock
-> Word16 -> LedgerState ByronBlock -> Maybe EpochNo
byronTransition
PartialLedgerConfig ByronBlock
pcfg
Word16
shelleyMajorVersion
LedgerState ByronBlock
ledgerState
singleEraInfo :: forall (proxy :: * -> *).
proxy ByronBlock -> SingleEraInfo ByronBlock
singleEraInfo proxy ByronBlock
_ = SingleEraInfo {
singleEraName :: Text
singleEraName = Text
"Byron"
}
instance PBftCrypto bc => HasPartialConsensusConfig (PBft bc)
data ByronPartialLedgerConfig = ByronPartialLedgerConfig {
ByronPartialLedgerConfig -> LedgerConfig ByronBlock
byronLedgerConfig :: !(LedgerConfig ByronBlock)
, ByronPartialLedgerConfig -> TriggerHardFork
byronTriggerHardFork :: !TriggerHardFork
}
deriving ((forall x.
ByronPartialLedgerConfig -> Rep ByronPartialLedgerConfig x)
-> (forall x.
Rep ByronPartialLedgerConfig x -> ByronPartialLedgerConfig)
-> Generic ByronPartialLedgerConfig
forall x.
Rep ByronPartialLedgerConfig x -> ByronPartialLedgerConfig
forall x.
ByronPartialLedgerConfig -> Rep ByronPartialLedgerConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x.
ByronPartialLedgerConfig -> Rep ByronPartialLedgerConfig x
from :: forall x.
ByronPartialLedgerConfig -> Rep ByronPartialLedgerConfig x
$cto :: forall x.
Rep ByronPartialLedgerConfig x -> ByronPartialLedgerConfig
to :: forall x.
Rep ByronPartialLedgerConfig x -> ByronPartialLedgerConfig
Generic, Context -> ByronPartialLedgerConfig -> IO (Maybe ThunkInfo)
Proxy ByronPartialLedgerConfig -> String
(Context -> ByronPartialLedgerConfig -> IO (Maybe ThunkInfo))
-> (Context -> ByronPartialLedgerConfig -> IO (Maybe ThunkInfo))
-> (Proxy ByronPartialLedgerConfig -> String)
-> NoThunks ByronPartialLedgerConfig
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> ByronPartialLedgerConfig -> IO (Maybe ThunkInfo)
noThunks :: Context -> ByronPartialLedgerConfig -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> ByronPartialLedgerConfig -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> ByronPartialLedgerConfig -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy ByronPartialLedgerConfig -> String
showTypeOf :: Proxy ByronPartialLedgerConfig -> String
NoThunks)
instance HasPartialLedgerConfig ByronBlock where
type PartialLedgerConfig ByronBlock = ByronPartialLedgerConfig
completeLedgerConfig :: forall (proxy :: * -> *).
proxy ByronBlock
-> EpochInfo (Except PastHorizonException)
-> PartialLedgerConfig ByronBlock
-> LedgerConfig ByronBlock
completeLedgerConfig proxy ByronBlock
_ EpochInfo (Except PastHorizonException)
_ = PartialLedgerConfig ByronBlock -> LedgerConfig ByronBlock
ByronPartialLedgerConfig -> LedgerConfig ByronBlock
byronLedgerConfig