{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}

-- | Blocks in the blockchain
--
module Cardano.Api.Block (

    -- * Blocks in the context of an era
    Block(.., Block),
    BlockHeader(..),
    getBlockHeader,

    -- ** Blocks in the context of a consensus mode
    BlockInMode(..),
    fromConsensusBlock,
    toConsensusBlock,

    -- * Points on the chain
    ChainPoint(..),
    SlotNo(..),
    EpochNo(..),
    toConsensusPoint,
    fromConsensusPoint,
    toConsensusPointInMode,
    fromConsensusPointInMode,
    toConsensusPointHF,

    -- * Tip of the chain
    ChainTip(..),
    BlockNo(..),
    chainTipToChainPoint,
    fromConsensusTip,

    -- * Data family instances
    Hash(..),

    chainPointToHeaderHash,
    chainPointToSlotNo,
    makeChainTip,
  ) where

import           Data.Aeson (FromJSON (..), ToJSON (..), Value (..), object, withObject, (.:), (.=))
import qualified Data.Aeson as Aeson
import qualified Data.ByteString as BS
import qualified Data.ByteString.Short as SBS
import           Data.Foldable (Foldable (toList))
import           Data.String (IsString)
import           Data.Text (Text)

import           Cardano.Slotting.Block (BlockNo)
import           Cardano.Slotting.Slot (EpochNo, SlotNo, WithOrigin (..))

import qualified Cardano.Crypto.Hash.Class as Crypto
import qualified Cardano.Crypto.Hashing
import qualified Ouroboros.Consensus.Block as Consensus
import qualified Ouroboros.Consensus.Byron.Ledger as Consensus
import qualified Ouroboros.Consensus.Cardano.Block as Consensus
import qualified Ouroboros.Consensus.Cardano.ByronHFC as Consensus
import qualified Ouroboros.Consensus.HardFork.Combinator as Consensus
import qualified Ouroboros.Consensus.HardFork.Combinator.Degenerate as Consensus
import qualified Ouroboros.Consensus.Ledger.SupportsProtocol as Consensus
import qualified Ouroboros.Consensus.Protocol.TPraos as Consensus
import qualified Ouroboros.Consensus.Shelley.Ledger as Consensus
import qualified Ouroboros.Consensus.Shelley.Protocol.Abstract as Consensus
import qualified Ouroboros.Consensus.Shelley.ShelleyHFC as Consensus
import qualified Ouroboros.Network.Block as Consensus

import qualified Cardano.Chain.Block as Byron
import qualified Cardano.Chain.UTxO as Byron
import qualified Cardano.Ledger.Block as Ledger
import qualified Cardano.Ledger.Era as Ledger

import           Cardano.Api.Eras
import           Cardano.Api.Hash
import           Cardano.Api.HasTypeProxy
import           Cardano.Api.Keys.Shelley
import           Cardano.Api.Modes
import           Cardano.Api.SerialiseRaw
import           Cardano.Api.SerialiseUsing
import           Cardano.Api.Tx

{- HLINT ignore "Use lambda" -}
{- HLINT ignore "Use lambda-case" -}

-- ----------------------------------------------------------------------------
-- Blocks in an era
--

-- | A blockchain block in a particular Cardano era.
--
data Block era where

     ByronBlock :: Consensus.ByronBlock
                -> Block ByronEra

     ShelleyBlock :: ShelleyBasedEra era
                  -> Consensus.ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)
                  -> Block era

-- | A block consists of a header and a body containing transactions.
--
pattern Block :: BlockHeader -> [Tx era] -> Block era
pattern $mBlock :: forall {r} {era}.
Block era -> (BlockHeader -> [Tx era] -> r) -> ((# #) -> r) -> r
Block header txs <- (getBlockHeaderAndTxs -> (header, txs))

{-# COMPLETE Block #-}

getBlockHeaderAndTxs :: Block era -> (BlockHeader, [Tx era])
getBlockHeaderAndTxs :: forall era. Block era -> (BlockHeader, [Tx era])
getBlockHeaderAndTxs Block era
block = (forall era. Block era -> BlockHeader
getBlockHeader Block era
block, forall era. Block era -> [Tx era]
getBlockTxs Block era
block)

-- The GADT in the ShelleyBlock case requires a custom instance
instance Show (Block era) where
    showsPrec :: Int -> Block era -> ShowS
showsPrec Int
p (ByronBlock ByronBlock
block) =
      Bool -> ShowS -> ShowS
showParen (Int
p forall a. Ord a => a -> a -> Bool
>= Int
11)
        ( String -> ShowS
showString String
"ByronBlock "
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 ByronBlock
block
        )

    showsPrec Int
p (ShelleyBlock ShelleyBasedEra era
ShelleyBasedEraShelley ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)
block) =
      Bool -> ShowS -> ShowS
showParen (Int
p forall a. Ord a => a -> a -> Bool
>= Int
11)
        ( String -> ShowS
showString String
"ShelleyBlock ShelleyBasedEraShelley "
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)
block
        )

    showsPrec Int
p (ShelleyBlock ShelleyBasedEra era
ShelleyBasedEraAllegra ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)
block) =
      Bool -> ShowS -> ShowS
showParen (Int
p forall a. Ord a => a -> a -> Bool
>= Int
11)
        ( String -> ShowS
showString String
"ShelleyBlock ShelleyBasedEraAllegra "
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)
block
        )

    showsPrec Int
p (ShelleyBlock ShelleyBasedEra era
ShelleyBasedEraMary ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)
block) =
      Bool -> ShowS -> ShowS
showParen (Int
p forall a. Ord a => a -> a -> Bool
>= Int
11)
        ( String -> ShowS
showString String
"ShelleyBlock ShelleyBasedEraMary "
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)
block
        )

    showsPrec Int
p (ShelleyBlock ShelleyBasedEra era
ShelleyBasedEraAlonzo ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)
block) =
      Bool -> ShowS -> ShowS
showParen (Int
p forall a. Ord a => a -> a -> Bool
>= Int
11)
        ( String -> ShowS
showString String
"ShelleyBlock ShelleyBasedEraAlonzo "
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)
block
        )

    showsPrec Int
p (ShelleyBlock ShelleyBasedEra era
ShelleyBasedEraBabbage ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)
block) =
      Bool -> ShowS -> ShowS
showParen (Int
p forall a. Ord a => a -> a -> Bool
>= Int
11)
        ( String -> ShowS
showString String
"ShelleyBlock ShelleyBasedEraBabbage "
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)
block
        )

    showsPrec Int
p (ShelleyBlock ShelleyBasedEra era
ShelleyBasedEraConway ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)
block) =
      Bool -> ShowS -> ShowS
showParen (Int
p forall a. Ord a => a -> a -> Bool
>= Int
11)
        ( String -> ShowS
showString String
"ShelleyBlock ShelleyBasedEraConway "
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)
block
        )

getBlockTxs :: forall era . Block era -> [Tx era]
getBlockTxs :: forall era. Block era -> [Tx era]
getBlockTxs (ByronBlock Consensus.ByronBlock { ABlockOrBoundary ByteString
byronBlockRaw :: ByronBlock -> ABlockOrBoundary ByteString
byronBlockRaw :: ABlockOrBoundary ByteString
Consensus.byronBlockRaw }) =
    case ABlockOrBoundary ByteString
byronBlockRaw of
      Byron.ABOBBoundary{} -> [] -- no txs in EBBs
      Byron.ABOBBlock Byron.ABlock {
          blockBody :: forall a. ABlock a -> ABody a
Byron.blockBody =
            Byron.ABody {
              bodyTxPayload :: forall a. ABody a -> ATxPayload a
Byron.bodyTxPayload = Byron.ATxPayload [ATxAux ByteString]
txs
            }
        } -> forall a b. (a -> b) -> [a] -> [b]
map ATxAux ByteString -> Tx ByronEra
ByronTx [ATxAux ByteString]
txs
getBlockTxs (ShelleyBlock ShelleyBasedEra era
era Consensus.ShelleyBlock{Block
  (ShelleyProtocolHeader (ConsensusProtocol era))
  (ShelleyLedgerEra era)
shelleyBlockRaw :: forall proto era.
ShelleyBlock proto era -> Block (ShelleyProtocolHeader proto) era
shelleyBlockRaw :: Block
  (ShelleyProtocolHeader (ConsensusProtocol era))
  (ShelleyLedgerEra era)
Consensus.shelleyBlockRaw}) =
    forall era ledgerera a.
(ShelleyLedgerEra era ~ ledgerera) =>
ShelleyBasedEra era
-> (ShelleyCompatible (ConsensusProtocol era) ledgerera => a) -> a
obtainConsensusShelleyCompatibleEra ShelleyBasedEra era
era forall a b. (a -> b) -> a -> b
$
      forall era ledgerera blockheader.
(ShelleyLedgerEra era ~ ledgerera,
 ShelleyCompatible (ConsensusProtocol era) ledgerera,
 ShelleyProtocolHeader (ConsensusProtocol era) ~ blockheader) =>
ShelleyBasedEra era -> Block blockheader ledgerera -> [Tx era]
getShelleyBlockTxs ShelleyBasedEra era
era Block
  (ShelleyProtocolHeader (ConsensusProtocol era))
  (ShelleyLedgerEra era)
shelleyBlockRaw


getShelleyBlockTxs :: forall era ledgerera blockheader.
                      ShelleyLedgerEra era ~ ledgerera
                   => Consensus.ShelleyCompatible (ConsensusProtocol era) ledgerera
                   => Consensus.ShelleyProtocolHeader (ConsensusProtocol era) ~ blockheader
                   => ShelleyBasedEra era
                   -> Ledger.Block blockheader ledgerera
                   -> [Tx era]
getShelleyBlockTxs :: forall era ledgerera blockheader.
(ShelleyLedgerEra era ~ ledgerera,
 ShelleyCompatible (ConsensusProtocol era) ledgerera,
 ShelleyProtocolHeader (ConsensusProtocol era) ~ blockheader) =>
ShelleyBasedEra era -> Block blockheader ledgerera -> [Tx era]
getShelleyBlockTxs ShelleyBasedEra era
era (Ledger.Block blockheader
_header TxSeq ledgerera
txs) =
  [ forall era.
ShelleyBasedEra era -> Tx (ShelleyLedgerEra era) -> Tx era
ShelleyTx ShelleyBasedEra era
era Tx ledgerera
txinblock
  | Tx ledgerera
txinblock <- forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (forall era. EraSegWits era => TxSeq era -> StrictSeq (Tx era)
Ledger.fromTxSeq TxSeq ledgerera
txs) ]

obtainConsensusShelleyCompatibleEra
  :: forall era ledgerera a.
     ShelleyLedgerEra era ~ ledgerera
  => ShelleyBasedEra era
  -> (Consensus.ShelleyCompatible (ConsensusProtocol era) ledgerera => a)
  -> a
obtainConsensusShelleyCompatibleEra :: forall era ledgerera a.
(ShelleyLedgerEra era ~ ledgerera) =>
ShelleyBasedEra era
-> (ShelleyCompatible (ConsensusProtocol era) ledgerera => a) -> a
obtainConsensusShelleyCompatibleEra ShelleyBasedEra era
ShelleyBasedEraShelley ShelleyCompatible (ConsensusProtocol era) ledgerera => a
f = ShelleyCompatible (ConsensusProtocol era) ledgerera => a
f
obtainConsensusShelleyCompatibleEra ShelleyBasedEra era
ShelleyBasedEraAllegra ShelleyCompatible (ConsensusProtocol era) ledgerera => a
f = ShelleyCompatible (ConsensusProtocol era) ledgerera => a
f
obtainConsensusShelleyCompatibleEra ShelleyBasedEra era
ShelleyBasedEraMary    ShelleyCompatible (ConsensusProtocol era) ledgerera => a
f = ShelleyCompatible (ConsensusProtocol era) ledgerera => a
f
obtainConsensusShelleyCompatibleEra ShelleyBasedEra era
ShelleyBasedEraAlonzo  ShelleyCompatible (ConsensusProtocol era) ledgerera => a
f = ShelleyCompatible (ConsensusProtocol era) ledgerera => a
f
obtainConsensusShelleyCompatibleEra ShelleyBasedEra era
ShelleyBasedEraBabbage ShelleyCompatible (ConsensusProtocol era) ledgerera => a
f = ShelleyCompatible (ConsensusProtocol era) ledgerera => a
f
obtainConsensusShelleyCompatibleEra ShelleyBasedEra era
ShelleyBasedEraConway ShelleyCompatible (ConsensusProtocol era) ledgerera => a
f = ShelleyCompatible (ConsensusProtocol era) ledgerera => a
f

-- ----------------------------------------------------------------------------
-- Block in a consensus mode
--

-- | A 'Block' in one of the eras supported by a given protocol mode.
--
-- For multi-era modes such as the 'CardanoMode' this type is a sum of the
-- different block types for all the eras. It is used in the ChainSync protocol.
--
data BlockInMode mode where
     BlockInMode :: IsCardanoEra era => Block era -> EraInMode era mode -> BlockInMode mode

deriving instance Show (BlockInMode mode)

fromConsensusBlock :: ConsensusBlockForMode mode ~ block
                   => Consensus.LedgerSupportsProtocol
                        (Consensus.ShelleyBlock
                        (Consensus.TPraos Consensus.StandardCrypto)
                        (Consensus.ShelleyEra Consensus.StandardCrypto))
                   => ConsensusMode mode -> block -> BlockInMode mode
fromConsensusBlock :: forall mode block.
(ConsensusBlockForMode mode ~ block,
 LedgerSupportsProtocol
   (ShelleyBlock (TPraos StandardCrypto) StandardShelley)) =>
ConsensusMode mode -> block -> BlockInMode mode
fromConsensusBlock ConsensusMode mode
ByronMode =
    \block
b -> case block
b of
      Consensus.DegenBlock ByronBlock
b' ->
        forall era mode.
IsCardanoEra era =>
Block era -> EraInMode era mode -> BlockInMode mode
BlockInMode (ByronBlock -> Block ByronEra
ByronBlock ByronBlock
b') EraInMode ByronEra ByronMode
ByronEraInByronMode

fromConsensusBlock ConsensusMode mode
ShelleyMode =
  \block
b -> case block
b of
    Consensus.DegenBlock ShelleyBlock (TPraos StandardCrypto) StandardShelley
b' ->
      forall era mode.
IsCardanoEra era =>
Block era -> EraInMode era mode -> BlockInMode mode
BlockInMode (forall era.
ShelleyBasedEra era
-> ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)
-> Block era
ShelleyBlock ShelleyBasedEra ShelleyEra
ShelleyBasedEraShelley ShelleyBlock (TPraos StandardCrypto) StandardShelley
b')
                   EraInMode ShelleyEra ShelleyMode
ShelleyEraInShelleyMode

fromConsensusBlock ConsensusMode mode
CardanoMode =
    \block
b -> case block
b of
      Consensus.BlockByron ByronBlock
b' ->
        forall era mode.
IsCardanoEra era =>
Block era -> EraInMode era mode -> BlockInMode mode
BlockInMode (ByronBlock -> Block ByronEra
ByronBlock ByronBlock
b') EraInMode ByronEra CardanoMode
ByronEraInCardanoMode

      Consensus.BlockShelley ShelleyBlock (TPraos StandardCrypto) StandardShelley
b' ->
        forall era mode.
IsCardanoEra era =>
Block era -> EraInMode era mode -> BlockInMode mode
BlockInMode (forall era.
ShelleyBasedEra era
-> ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)
-> Block era
ShelleyBlock ShelleyBasedEra ShelleyEra
ShelleyBasedEraShelley ShelleyBlock (TPraos StandardCrypto) StandardShelley
b')
                     EraInMode ShelleyEra CardanoMode
ShelleyEraInCardanoMode

      Consensus.BlockAllegra ShelleyBlock (TPraos StandardCrypto) StandardAllegra
b' ->
        forall era mode.
IsCardanoEra era =>
Block era -> EraInMode era mode -> BlockInMode mode
BlockInMode (forall era.
ShelleyBasedEra era
-> ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)
-> Block era
ShelleyBlock ShelleyBasedEra AllegraEra
ShelleyBasedEraAllegra ShelleyBlock (TPraos StandardCrypto) StandardAllegra
b')
                     EraInMode AllegraEra CardanoMode
AllegraEraInCardanoMode

      Consensus.BlockMary ShelleyBlock (TPraos StandardCrypto) StandardMary
b' ->
        forall era mode.
IsCardanoEra era =>
Block era -> EraInMode era mode -> BlockInMode mode
BlockInMode (forall era.
ShelleyBasedEra era
-> ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)
-> Block era
ShelleyBlock ShelleyBasedEra MaryEra
ShelleyBasedEraMary ShelleyBlock (TPraos StandardCrypto) StandardMary
b')
                     EraInMode MaryEra CardanoMode
MaryEraInCardanoMode

      Consensus.BlockAlonzo ShelleyBlock (TPraos StandardCrypto) StandardAlonzo
b' ->
        forall era mode.
IsCardanoEra era =>
Block era -> EraInMode era mode -> BlockInMode mode
BlockInMode (forall era.
ShelleyBasedEra era
-> ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)
-> Block era
ShelleyBlock ShelleyBasedEra AlonzoEra
ShelleyBasedEraAlonzo ShelleyBlock (TPraos StandardCrypto) StandardAlonzo
b')
                     EraInMode AlonzoEra CardanoMode
AlonzoEraInCardanoMode

      Consensus.BlockBabbage ShelleyBlock (Praos StandardCrypto) StandardBabbage
b' ->
        forall era mode.
IsCardanoEra era =>
Block era -> EraInMode era mode -> BlockInMode mode
BlockInMode (forall era.
ShelleyBasedEra era
-> ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)
-> Block era
ShelleyBlock ShelleyBasedEra BabbageEra
ShelleyBasedEraBabbage ShelleyBlock (Praos StandardCrypto) StandardBabbage
b')
                     EraInMode BabbageEra CardanoMode
BabbageEraInCardanoMode

      Consensus.BlockConway ShelleyBlock (Praos StandardCrypto) StandardConway
b' ->
        forall era mode.
IsCardanoEra era =>
Block era -> EraInMode era mode -> BlockInMode mode
BlockInMode (forall era.
ShelleyBasedEra era
-> ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)
-> Block era
ShelleyBlock ShelleyBasedEra ConwayEra
ShelleyBasedEraConway ShelleyBlock (Praos StandardCrypto) StandardConway
b')
                     EraInMode ConwayEra CardanoMode
ConwayEraInCardanoMode

toConsensusBlock
  :: ConsensusBlockForMode mode ~ block
  => Consensus.LedgerSupportsProtocol
       (Consensus.ShelleyBlock
       (Consensus.TPraos Consensus.StandardCrypto)
       (Consensus.ShelleyEra Consensus.StandardCrypto))
  => BlockInMode mode -> block
toConsensusBlock :: forall mode block.
(ConsensusBlockForMode mode ~ block,
 LedgerSupportsProtocol
   (ShelleyBlock (TPraos StandardCrypto) StandardShelley)) =>
BlockInMode mode -> block
toConsensusBlock BlockInMode mode
bInMode =
  case BlockInMode mode
bInMode of
    -- Byron mode
    BlockInMode (ByronBlock ByronBlock
b') EraInMode era mode
ByronEraInByronMode -> forall b. NoHardForks b => b -> HardForkBlock '[b]
Consensus.DegenBlock ByronBlock
b'

    -- Shelley mode
    BlockInMode (ShelleyBlock ShelleyBasedEra era
ShelleyBasedEraShelley ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)
b') EraInMode era mode
ShelleyEraInShelleyMode -> forall b. NoHardForks b => b -> HardForkBlock '[b]
Consensus.DegenBlock ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)
b'

    -- Cardano mode
    BlockInMode (ByronBlock ByronBlock
b') EraInMode era mode
ByronEraInCardanoMode -> forall c. ByronBlock -> CardanoBlock c
Consensus.BlockByron ByronBlock
b'
    BlockInMode (ShelleyBlock ShelleyBasedEra era
ShelleyBasedEraShelley ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)
b') EraInMode era mode
ShelleyEraInCardanoMode -> forall c. ShelleyBlock (TPraos c) (ShelleyEra c) -> CardanoBlock c
Consensus.BlockShelley ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)
b'
    BlockInMode (ShelleyBlock ShelleyBasedEra era
ShelleyBasedEraAllegra ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)
b') EraInMode era mode
AllegraEraInCardanoMode -> forall c. ShelleyBlock (TPraos c) (AllegraEra c) -> CardanoBlock c
Consensus.BlockAllegra ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)
b'
    BlockInMode (ShelleyBlock ShelleyBasedEra era
ShelleyBasedEraMary ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)
b') EraInMode era mode
MaryEraInCardanoMode -> forall c. ShelleyBlock (TPraos c) (MaryEra c) -> CardanoBlock c
Consensus.BlockMary ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)
b'
    BlockInMode (ShelleyBlock ShelleyBasedEra era
ShelleyBasedEraAlonzo ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)
b') EraInMode era mode
AlonzoEraInCardanoMode -> forall c. ShelleyBlock (TPraos c) (AlonzoEra c) -> CardanoBlock c
Consensus.BlockAlonzo ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)
b'
    BlockInMode (ShelleyBlock ShelleyBasedEra era
ShelleyBasedEraBabbage ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)
b') EraInMode era mode
BabbageEraInCardanoMode -> forall c. ShelleyBlock (Praos c) (BabbageEra c) -> CardanoBlock c
Consensus.BlockBabbage ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)
b'
    BlockInMode (ShelleyBlock ShelleyBasedEra era
ShelleyBasedEraConway ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)
b') EraInMode era mode
ConwayEraInCardanoMode -> forall c. ShelleyBlock (Praos c) (ConwayEra c) -> CardanoBlock c
Consensus.BlockConway ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)
b'

-- ----------------------------------------------------------------------------
-- Block headers
--

data BlockHeader = BlockHeader !SlotNo
                               !(Hash BlockHeader)
                               !BlockNo

-- | For now at least we use a fixed concrete hash type for all modes and era.
-- The different eras do use different types, but it's all the same underlying
-- representation.
newtype instance Hash BlockHeader = HeaderHash SBS.ShortByteString
  deriving (Hash BlockHeader -> Hash BlockHeader -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Hash BlockHeader -> Hash BlockHeader -> Bool
$c/= :: Hash BlockHeader -> Hash BlockHeader -> Bool
== :: Hash BlockHeader -> Hash BlockHeader -> Bool
$c== :: Hash BlockHeader -> Hash BlockHeader -> Bool
Eq, Eq (Hash BlockHeader)
Hash BlockHeader -> Hash BlockHeader -> Bool
Hash BlockHeader -> Hash BlockHeader -> Ordering
Hash BlockHeader -> Hash BlockHeader -> Hash BlockHeader
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Hash BlockHeader -> Hash BlockHeader -> Hash BlockHeader
$cmin :: Hash BlockHeader -> Hash BlockHeader -> Hash BlockHeader
max :: Hash BlockHeader -> Hash BlockHeader -> Hash BlockHeader
$cmax :: Hash BlockHeader -> Hash BlockHeader -> Hash BlockHeader
>= :: Hash BlockHeader -> Hash BlockHeader -> Bool
$c>= :: Hash BlockHeader -> Hash BlockHeader -> Bool
> :: Hash BlockHeader -> Hash BlockHeader -> Bool
$c> :: Hash BlockHeader -> Hash BlockHeader -> Bool
<= :: Hash BlockHeader -> Hash BlockHeader -> Bool
$c<= :: Hash BlockHeader -> Hash BlockHeader -> Bool
< :: Hash BlockHeader -> Hash BlockHeader -> Bool
$c< :: Hash BlockHeader -> Hash BlockHeader -> Bool
compare :: Hash BlockHeader -> Hash BlockHeader -> Ordering
$ccompare :: Hash BlockHeader -> Hash BlockHeader -> Ordering
Ord, Int -> Hash BlockHeader -> ShowS
[Hash BlockHeader] -> ShowS
Hash BlockHeader -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Hash BlockHeader] -> ShowS
$cshowList :: [Hash BlockHeader] -> ShowS
show :: Hash BlockHeader -> String
$cshow :: Hash BlockHeader -> String
showsPrec :: Int -> Hash BlockHeader -> ShowS
$cshowsPrec :: Int -> Hash BlockHeader -> ShowS
Show)
  deriving ([Hash BlockHeader] -> Value
[Hash BlockHeader] -> Encoding
Hash BlockHeader -> Value
Hash BlockHeader -> Encoding
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Hash BlockHeader] -> Encoding
$ctoEncodingList :: [Hash BlockHeader] -> Encoding
toJSONList :: [Hash BlockHeader] -> Value
$ctoJSONList :: [Hash BlockHeader] -> Value
toEncoding :: Hash BlockHeader -> Encoding
$ctoEncoding :: Hash BlockHeader -> Encoding
toJSON :: Hash BlockHeader -> Value
$ctoJSON :: Hash BlockHeader -> Value
ToJSON, Value -> Parser [Hash BlockHeader]
Value -> Parser (Hash BlockHeader)
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [Hash BlockHeader]
$cparseJSONList :: Value -> Parser [Hash BlockHeader]
parseJSON :: Value -> Parser (Hash BlockHeader)
$cparseJSON :: Value -> Parser (Hash BlockHeader)
FromJSON) via UsingRawBytesHex (Hash BlockHeader)
  deriving String -> Hash BlockHeader
forall a. (String -> a) -> IsString a
fromString :: String -> Hash BlockHeader
$cfromString :: String -> Hash BlockHeader
IsString via UsingRawBytesHex (Hash BlockHeader)



instance SerialiseAsRawBytes (Hash BlockHeader) where
    serialiseToRawBytes :: Hash BlockHeader -> ByteString
serialiseToRawBytes (HeaderHash ShortByteString
bs) = ShortByteString -> ByteString
SBS.fromShort ShortByteString
bs

    deserialiseFromRawBytes :: AsType (Hash BlockHeader)
-> ByteString -> Either SerialiseAsRawBytesError (Hash BlockHeader)
deserialiseFromRawBytes (AsHash AsType BlockHeader
R:AsTypeBlockHeader
AsBlockHeader) ByteString
bs
      | ByteString -> Int
BS.length ByteString
bs forall a. Eq a => a -> a -> Bool
== Int
32 = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$! ShortByteString -> Hash BlockHeader
HeaderHash (ByteString -> ShortByteString
SBS.toShort ByteString
bs)
      | Bool
otherwise          = forall a b. a -> Either a b
Left (String -> SerialiseAsRawBytesError
SerialiseAsRawBytesError String
"Unable to deserialise Hash BlockHeader")

instance HasTypeProxy BlockHeader where
    data AsType BlockHeader = AsBlockHeader
    proxyToAsType :: Proxy BlockHeader -> AsType BlockHeader
proxyToAsType Proxy BlockHeader
_ = AsType BlockHeader
AsBlockHeader

getBlockHeader
  :: forall era . Block era -> BlockHeader
getBlockHeader :: forall era. Block era -> BlockHeader
getBlockHeader (ShelleyBlock ShelleyBasedEra era
shelleyEra ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)
block) = case ShelleyBasedEra era
shelleyEra of
  ShelleyBasedEra era
ShelleyBasedEraShelley -> ShelleyCompatible (ConsensusProtocol era) (ShelleyLedgerEra era) =>
BlockHeader
go
  ShelleyBasedEra era
ShelleyBasedEraAllegra -> ShelleyCompatible (ConsensusProtocol era) (ShelleyLedgerEra era) =>
BlockHeader
go
  ShelleyBasedEra era
ShelleyBasedEraMary -> ShelleyCompatible (ConsensusProtocol era) (ShelleyLedgerEra era) =>
BlockHeader
go
  ShelleyBasedEra era
ShelleyBasedEraAlonzo -> ShelleyCompatible (ConsensusProtocol era) (ShelleyLedgerEra era) =>
BlockHeader
go
  ShelleyBasedEra era
ShelleyBasedEraBabbage -> ShelleyCompatible (ConsensusProtocol era) (ShelleyLedgerEra era) =>
BlockHeader
go
  ShelleyBasedEra era
ShelleyBasedEraConway -> ShelleyCompatible (ConsensusProtocol era) (ShelleyLedgerEra era) =>
BlockHeader
go
  where
    go :: Consensus.ShelleyCompatible (ConsensusProtocol era) (ShelleyLedgerEra era)
       => BlockHeader
    go :: ShelleyCompatible (ConsensusProtocol era) (ShelleyLedgerEra era) =>
BlockHeader
go = SlotNo -> Hash BlockHeader -> BlockNo -> BlockHeader
BlockHeader SlotNo
headerFieldSlot (ShortByteString -> Hash BlockHeader
HeaderHash ShortByteString
hashSBS) BlockNo
headerFieldBlockNo
      where
        Consensus.HeaderFields {
            headerFieldHash :: forall b. HeaderFields b -> HeaderHash b
Consensus.headerFieldHash
              = Consensus.ShelleyHash (Crypto.UnsafeHash ShortByteString
hashSBS),
            SlotNo
headerFieldSlot :: forall b. HeaderFields b -> SlotNo
headerFieldSlot :: SlotNo
Consensus.headerFieldSlot,
            BlockNo
headerFieldBlockNo :: forall b. HeaderFields b -> BlockNo
headerFieldBlockNo :: BlockNo
Consensus.headerFieldBlockNo
          } = forall b. HasHeader b => b -> HeaderFields b
Consensus.getHeaderFields ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)
block
getBlockHeader (ByronBlock ByronBlock
block)
  = SlotNo -> Hash BlockHeader -> BlockNo -> BlockHeader
BlockHeader
      SlotNo
headerFieldSlot
      (ShortByteString -> Hash BlockHeader
HeaderHash forall a b. (a -> b) -> a -> b
$ forall algo a. AbstractHash algo a -> ShortByteString
Cardano.Crypto.Hashing.abstractHashToShort HeaderHash
byronHeaderHash)
      BlockNo
headerFieldBlockNo
  where
    Consensus.HeaderFields {
      headerFieldHash :: forall b. HeaderFields b -> HeaderHash b
Consensus.headerFieldHash = Consensus.ByronHash HeaderHash
byronHeaderHash,
      SlotNo
headerFieldSlot :: SlotNo
headerFieldSlot :: forall b. HeaderFields b -> SlotNo
Consensus.headerFieldSlot,
      BlockNo
headerFieldBlockNo :: BlockNo
headerFieldBlockNo :: forall b. HeaderFields b -> BlockNo
Consensus.headerFieldBlockNo
    } = forall b. HasHeader b => b -> HeaderFields b
Consensus.getHeaderFields ByronBlock
block


-- ----------------------------------------------------------------------------
-- Chain points
--

data ChainPoint = ChainPointAtGenesis
                | ChainPoint !SlotNo !(Hash BlockHeader)
  deriving (ChainPoint -> ChainPoint -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ChainPoint -> ChainPoint -> Bool
$c/= :: ChainPoint -> ChainPoint -> Bool
== :: ChainPoint -> ChainPoint -> Bool
$c== :: ChainPoint -> ChainPoint -> Bool
Eq, Int -> ChainPoint -> ShowS
[ChainPoint] -> ShowS
ChainPoint -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ChainPoint] -> ShowS
$cshowList :: [ChainPoint] -> ShowS
show :: ChainPoint -> String
$cshow :: ChainPoint -> String
showsPrec :: Int -> ChainPoint -> ShowS
$cshowsPrec :: Int -> ChainPoint -> ShowS
Show)

instance Ord ChainPoint where
  compare :: ChainPoint -> ChainPoint -> Ordering
compare ChainPoint
ChainPointAtGenesis ChainPoint
ChainPointAtGenesis = Ordering
EQ
  compare ChainPoint
ChainPointAtGenesis ChainPoint
_ = Ordering
LT
  compare ChainPoint
_ ChainPoint
ChainPointAtGenesis = Ordering
GT
  compare (ChainPoint SlotNo
sn Hash BlockHeader
_) (ChainPoint SlotNo
sn' Hash BlockHeader
_) = forall a. Ord a => a -> a -> Ordering
compare SlotNo
sn SlotNo
sn'

instance ToJSON ChainPoint where
  toJSON :: ChainPoint -> Value
toJSON = \case
    ChainPoint
ChainPointAtGenesis -> [Pair] -> Value
object [Key
"tag" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"ChainPointAtGenesis"]
    ChainPoint SlotNo
slot Hash BlockHeader
blockHash ->
      [Pair] -> Value
object
        [ Key
"tag" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"ChainPoint"
        , Key
"slot" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a. ToJSON a => a -> Value
toJSON SlotNo
slot
        , Key
"blockHash" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a. ToJSON a => a -> Value
toJSON Hash BlockHeader
blockHash
        ]

instance FromJSON ChainPoint where
  parseJSON :: Value -> Parser ChainPoint
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"ChainPoint" forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    Text
tag <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"tag"
    case Text
tag :: Text of
      Text
"ChainPointAtGenesis" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ChainPoint
ChainPointAtGenesis
      Text
"ChainPoint" -> SlotNo -> Hash BlockHeader -> ChainPoint
ChainPoint forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"slot" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"blockHash"
      Text
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected tag to be ChainPointAtGenesis | ChainPoint"

toConsensusPointInMode :: ConsensusMode mode
                       -> ChainPoint
                       -> Consensus.Point (ConsensusBlockForMode mode)
-- It's the same concrete impl in all cases, but we have to show
-- individually for each case that we satisfy the type equality constraint
-- HeaderHash block ~ OneEraHash xs
toConsensusPointInMode :: forall mode.
ConsensusMode mode
-> ChainPoint -> Point (ConsensusBlockForMode mode)
toConsensusPointInMode ConsensusMode mode
ByronMode   = forall block (xs :: [*]).
(HeaderHash block ~ OneEraHash xs) =>
ChainPoint -> Point block
toConsensusPointHF
toConsensusPointInMode ConsensusMode mode
ShelleyMode = forall block (xs :: [*]).
(HeaderHash block ~ OneEraHash xs) =>
ChainPoint -> Point block
toConsensusPointHF
toConsensusPointInMode ConsensusMode mode
CardanoMode = forall block (xs :: [*]).
(HeaderHash block ~ OneEraHash xs) =>
ChainPoint -> Point block
toConsensusPointHF

fromConsensusPointInMode :: ConsensusMode mode
                         -> Consensus.Point (ConsensusBlockForMode mode)
                         -> ChainPoint
fromConsensusPointInMode :: forall mode.
ConsensusMode mode
-> Point (ConsensusBlockForMode mode) -> ChainPoint
fromConsensusPointInMode ConsensusMode mode
ByronMode   = forall block (xs :: [*]).
(HeaderHash block ~ OneEraHash xs) =>
Point block -> ChainPoint
fromConsensusPointHF
fromConsensusPointInMode ConsensusMode mode
ShelleyMode = forall block (xs :: [*]).
(HeaderHash block ~ OneEraHash xs) =>
Point block -> ChainPoint
fromConsensusPointHF
fromConsensusPointInMode ConsensusMode mode
CardanoMode = forall block (xs :: [*]).
(HeaderHash block ~ OneEraHash xs) =>
Point block -> ChainPoint
fromConsensusPointHF


-- | Convert a 'Consensus.Point' for multi-era block type
--
toConsensusPointHF :: Consensus.HeaderHash block ~ Consensus.OneEraHash xs
                   => ChainPoint -> Consensus.Point block
toConsensusPointHF :: forall block (xs :: [*]).
(HeaderHash block ~ OneEraHash xs) =>
ChainPoint -> Point block
toConsensusPointHF  ChainPoint
ChainPointAtGenesis = forall block. Point block
Consensus.GenesisPoint
toConsensusPointHF (ChainPoint SlotNo
slot (HeaderHash ShortByteString
h)) =
    forall block. SlotNo -> HeaderHash block -> Point block
Consensus.BlockPoint SlotNo
slot (forall k (xs :: [k]). ShortByteString -> OneEraHash xs
Consensus.OneEraHash ShortByteString
h)

-- | Convert a 'Consensus.Point' for multi-era block type
--
fromConsensusPointHF :: Consensus.HeaderHash block ~ Consensus.OneEraHash xs
                   => Consensus.Point block -> ChainPoint
fromConsensusPointHF :: forall block (xs :: [*]).
(HeaderHash block ~ OneEraHash xs) =>
Point block -> ChainPoint
fromConsensusPointHF Point block
Consensus.GenesisPoint = ChainPoint
ChainPointAtGenesis
fromConsensusPointHF (Consensus.BlockPoint SlotNo
slot (Consensus.OneEraHash ShortByteString
h)) =
    SlotNo -> Hash BlockHeader -> ChainPoint
ChainPoint SlotNo
slot (ShortByteString -> Hash BlockHeader
HeaderHash ShortByteString
h)

-- | Convert a 'Consensus.Point' for single Shelley-era block type
--
toConsensusPoint :: forall ledgerera protocol.
                      Consensus.ShelleyCompatible protocol ledgerera
                   => ChainPoint
                   -> Consensus.Point (Consensus.ShelleyBlock protocol ledgerera)
toConsensusPoint :: forall ledgerera protocol.
ShelleyCompatible protocol ledgerera =>
ChainPoint -> Point (ShelleyBlock protocol ledgerera)
toConsensusPoint ChainPoint
ChainPointAtGenesis = forall block. Point block
Consensus.GenesisPoint
toConsensusPoint (ChainPoint SlotNo
slot (HeaderHash ShortByteString
h)) =
    forall block. SlotNo -> HeaderHash block -> Point block
Consensus.BlockPoint SlotNo
slot (forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> ShortByteString -> HeaderHash blk
Consensus.fromShortRawHash Proxy (ShelleyBlock protocol ledgerera)
proxy ShortByteString
h)
  where
    proxy :: Proxy (Consensus.ShelleyBlock protocol ledgerera)
    proxy :: Proxy (ShelleyBlock protocol ledgerera)
proxy = forall {k} (t :: k). Proxy t
Proxy

-- | Convert a 'Consensus.Point' for single Shelley-era block type
--
fromConsensusPoint :: forall protocol ledgerera.
                      Consensus.ShelleyCompatible protocol ledgerera
                   => Consensus.Point (Consensus.ShelleyBlock protocol ledgerera)
                   -> ChainPoint
fromConsensusPoint :: forall protocol ledgerera.
ShelleyCompatible protocol ledgerera =>
Point (ShelleyBlock protocol ledgerera) -> ChainPoint
fromConsensusPoint Point (ShelleyBlock protocol ledgerera)
Consensus.GenesisPoint = ChainPoint
ChainPointAtGenesis
fromConsensusPoint (Consensus.BlockPoint SlotNo
slot HeaderHash (ShelleyBlock protocol ledgerera)
h) =
    SlotNo -> Hash BlockHeader -> ChainPoint
ChainPoint SlotNo
slot (ShortByteString -> Hash BlockHeader
HeaderHash (forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> HeaderHash blk -> ShortByteString
Consensus.toShortRawHash Proxy (ShelleyBlock protocol ledgerera)
proxy HeaderHash (ShelleyBlock protocol ledgerera)
h))
  where
    proxy :: Proxy (Consensus.ShelleyBlock protocol ledgerera)
    proxy :: Proxy (ShelleyBlock protocol ledgerera)
proxy = forall {k} (t :: k). Proxy t
Proxy

chainPointToSlotNo :: ChainPoint -> Maybe SlotNo
chainPointToSlotNo :: ChainPoint -> Maybe SlotNo
chainPointToSlotNo ChainPoint
ChainPointAtGenesis = forall a. Maybe a
Nothing
chainPointToSlotNo (ChainPoint SlotNo
slotNo Hash BlockHeader
_) = forall a. a -> Maybe a
Just SlotNo
slotNo

chainPointToHeaderHash :: ChainPoint -> Maybe (Hash BlockHeader)
chainPointToHeaderHash :: ChainPoint -> Maybe (Hash BlockHeader)
chainPointToHeaderHash ChainPoint
ChainPointAtGenesis = forall a. Maybe a
Nothing
chainPointToHeaderHash (ChainPoint SlotNo
_ Hash BlockHeader
blockHeader) = forall a. a -> Maybe a
Just Hash BlockHeader
blockHeader


-- ----------------------------------------------------------------------------
-- Chain tips
--

-- | This is like a 'ChainPoint' but is conventionally used for the tip of the
-- chain: that is the most recent block at the end of the chain.
--
-- It also carries the 'BlockNo' of the chain tip.
--
data ChainTip = ChainTipAtGenesis
              | ChainTip !SlotNo !(Hash BlockHeader) !BlockNo
  deriving (ChainTip -> ChainTip -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ChainTip -> ChainTip -> Bool
$c/= :: ChainTip -> ChainTip -> Bool
== :: ChainTip -> ChainTip -> Bool
$c== :: ChainTip -> ChainTip -> Bool
Eq, Int -> ChainTip -> ShowS
[ChainTip] -> ShowS
ChainTip -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ChainTip] -> ShowS
$cshowList :: [ChainTip] -> ShowS
show :: ChainTip -> String
$cshow :: ChainTip -> String
showsPrec :: Int -> ChainTip -> ShowS
$cshowsPrec :: Int -> ChainTip -> ShowS
Show)

instance ToJSON ChainTip where
  toJSON :: ChainTip -> Value
toJSON ChainTip
ChainTipAtGenesis = Value
Aeson.Null
  toJSON (ChainTip SlotNo
slot Hash BlockHeader
headerHash (Consensus.BlockNo Word64
bNum)) =
    [Pair] -> Value
object [ Key
"slot" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= SlotNo
slot
           , Key
"hash" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a. SerialiseAsRawBytes a => a -> Text
serialiseToRawBytesHexText Hash BlockHeader
headerHash
           , Key
"block" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Word64
bNum
           ]

chainTipToChainPoint :: ChainTip -> ChainPoint
chainTipToChainPoint :: ChainTip -> ChainPoint
chainTipToChainPoint ChainTip
ChainTipAtGenesis = ChainPoint
ChainPointAtGenesis
chainTipToChainPoint (ChainTip SlotNo
s Hash BlockHeader
h BlockNo
_)  = SlotNo -> Hash BlockHeader -> ChainPoint
ChainPoint SlotNo
s Hash BlockHeader
h

makeChainTip :: WithOrigin BlockNo -> ChainPoint -> ChainTip
makeChainTip :: WithOrigin BlockNo -> ChainPoint -> ChainTip
makeChainTip WithOrigin BlockNo
woBlockNo ChainPoint
chainPoint = case WithOrigin BlockNo
woBlockNo of
  WithOrigin BlockNo
Origin -> ChainTip
ChainTipAtGenesis
  At BlockNo
blockNo -> case ChainPoint
chainPoint of
    ChainPoint
ChainPointAtGenesis -> ChainTip
ChainTipAtGenesis
    ChainPoint SlotNo
slotNo Hash BlockHeader
headerHash -> SlotNo -> Hash BlockHeader -> BlockNo -> ChainTip
ChainTip SlotNo
slotNo Hash BlockHeader
headerHash BlockNo
blockNo

fromConsensusTip  :: ConsensusBlockForMode mode ~ block
                  => ConsensusMode mode
                  -> Consensus.Tip block
                  -> ChainTip
fromConsensusTip :: forall mode block.
(ConsensusBlockForMode mode ~ block) =>
ConsensusMode mode -> Tip block -> ChainTip
fromConsensusTip ConsensusMode mode
ByronMode = Tip ByronBlockHFC -> ChainTip
conv
  where
    conv :: Consensus.Tip Consensus.ByronBlockHFC -> ChainTip
    conv :: Tip ByronBlockHFC -> ChainTip
conv Tip ByronBlockHFC
Consensus.TipGenesis = ChainTip
ChainTipAtGenesis
    conv (Consensus.Tip SlotNo
slot (Consensus.OneEraHash ShortByteString
h) BlockNo
block) =
      SlotNo -> Hash BlockHeader -> BlockNo -> ChainTip
ChainTip SlotNo
slot (ShortByteString -> Hash BlockHeader
HeaderHash ShortByteString
h) BlockNo
block

fromConsensusTip ConsensusMode mode
ShelleyMode = Tip (ShelleyBlockHFC (TPraos StandardCrypto) StandardShelley)
-> ChainTip
conv
  where
    conv :: Consensus.Tip (Consensus.ShelleyBlockHFC (Consensus.TPraos Consensus.StandardCrypto) Consensus.StandardShelley)
         -> ChainTip
    conv :: Tip (ShelleyBlockHFC (TPraos StandardCrypto) StandardShelley)
-> ChainTip
conv Tip (ShelleyBlockHFC (TPraos StandardCrypto) StandardShelley)
Consensus.TipGenesis = ChainTip
ChainTipAtGenesis
    conv (Consensus.Tip SlotNo
slot (Consensus.OneEraHash ShortByteString
hashSBS) BlockNo
block) =
      SlotNo -> Hash BlockHeader -> BlockNo -> ChainTip
ChainTip SlotNo
slot (ShortByteString -> Hash BlockHeader
HeaderHash ShortByteString
hashSBS) BlockNo
block

fromConsensusTip ConsensusMode mode
CardanoMode = Tip (CardanoBlock StandardCrypto) -> ChainTip
conv
  where
    conv :: Consensus.Tip (Consensus.CardanoBlock Consensus.StandardCrypto)
         -> ChainTip
    conv :: Tip (CardanoBlock StandardCrypto) -> ChainTip
conv Tip (CardanoBlock StandardCrypto)
Consensus.TipGenesis = ChainTip
ChainTipAtGenesis
    conv (Consensus.Tip SlotNo
slot (Consensus.OneEraHash ShortByteString
h) BlockNo
block) =
      SlotNo -> Hash BlockHeader -> BlockNo -> ChainTip
ChainTip SlotNo
slot (ShortByteString -> Hash BlockHeader
HeaderHash ShortByteString
h) BlockNo
block

{-
TODO: In principle we should be able to use this common implementation rather
      than repeating it for each mode above. It does actually type-check. The
      problem is that (at least with ghc-8.10.x) ghc's pattern match warning
      mechanism cannot see that the OneEraHash is a complete pattern match.
      I'm guessing that while the type checker can use the type equality to
      see that OneEraHash is a valid pattern, the exhaustiveness checker is for
      some reason not able to use it to see that it is indeed the only pattern.
fromConsensusTip =
    \mode -> case mode of
      ByronMode   -> conv
      ShelleyMode -> conv
      CardanoMode -> conv
  where
    conv :: HeaderHash block ~ OneEraHash xs
         => Tip block -> ChainTip
    conv TipGenesis                      = ChainTipAtGenesis
    conv (Tip slot (OneEraHash h) block) = ChainTip slot (HeaderHash h) block
-}