{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# 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(..),

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

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

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

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

    chainPointToHeaderHash,
    chainPointToSlotNo,
    makeChainTip,
  ) where

import           Prelude

import           Data.Aeson (ToJSON (..), object, (.=))
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           Cardano.Slotting.Block (BlockNo)
import           Cardano.Slotting.Slot (EpochNo, SlotNo, WithOrigin (..))

import qualified Cardano.Crypto.Hash.Class
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.Shelley.Ledger 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.Era as Ledger
import qualified Cardano.Protocol.TPraos.BHeader as TPraos
import qualified Cardano.Ledger.Block as Ledger

import           Cardano.Api.Eras
import           Cardano.Api.HasTypeProxy
import           Cardano.Api.Hash
import           Cardano.Api.Modes
import           Cardano.Api.SerialiseRaw
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 (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) -> (Void# -> r) -> r
Block header txs <- (getBlockHeaderAndTxs -> (header, txs))

{-# COMPLETE Block #-}

getBlockHeaderAndTxs :: Block era -> (BlockHeader, [Tx era])
getBlockHeaderAndTxs :: Block era -> (BlockHeader, [Tx era])
getBlockHeaderAndTxs Block era
block = (Block era -> BlockHeader
forall era. Block era -> BlockHeader
getBlockHeader Block era
block, Block era -> [Tx era]
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
11)
        ( String -> ShowS
showString String
"ByronBlock "
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByronBlock -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 ByronBlock
block
        )

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

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

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

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

getBlockTxs :: forall era . Block era -> [Tx era]
getBlockTxs :: 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
            }
        } -> (ATxAux ByteString -> Tx ByronEra)
-> [ATxAux ByteString] -> [Tx ByronEra]
forall a b. (a -> b) -> [a] -> [b]
map ATxAux ByteString -> Tx ByronEra
ByronTx [ATxAux ByteString]
txs
getBlockTxs (ShelleyBlock ShelleyBasedEra era
era Consensus.ShelleyBlock{Block BHeader (ShelleyLedgerEra era)
shelleyBlockRaw :: forall era. ShelleyBlock era -> Block BHeader era
shelleyBlockRaw :: Block BHeader (ShelleyLedgerEra era)
Consensus.shelleyBlockRaw}) =
    ShelleyBasedEra era
-> (ShelleyBasedEra (ShelleyLedgerEra era) => [Tx era]) -> [Tx era]
forall era ledgerera a.
(ledgerera ~ ShelleyLedgerEra era) =>
ShelleyBasedEra era -> (ShelleyBasedEra ledgerera => a) -> a
obtainConsensusShelleyBasedEra ShelleyBasedEra era
era ((ShelleyBasedEra (ShelleyLedgerEra era) => [Tx era]) -> [Tx era])
-> (ShelleyBasedEra (ShelleyLedgerEra era) => [Tx era]) -> [Tx era]
forall a b. (a -> b) -> a -> b
$
      ShelleyBasedEra era
-> Block BHeader (ShelleyLedgerEra era) -> [Tx era]
forall era ledgerera.
(ledgerera ~ ShelleyLedgerEra era, ShelleyBasedEra ledgerera) =>
ShelleyBasedEra era -> Block BHeader ledgerera -> [Tx era]
getShelleyBlockTxs ShelleyBasedEra era
era Block BHeader (ShelleyLedgerEra era)
shelleyBlockRaw

getShelleyBlockTxs :: forall era ledgerera.
                      ledgerera ~ ShelleyLedgerEra era
                   => Consensus.ShelleyBasedEra ledgerera
                   => ShelleyBasedEra era
                   -> Ledger.Block TPraos.BHeader ledgerera
                   -> [Tx era]
getShelleyBlockTxs :: ShelleyBasedEra era -> Block BHeader ledgerera -> [Tx era]
getShelleyBlockTxs ShelleyBasedEra era
era (Ledger.Block BHeader (Crypto ledgerera)
_header TxSeq ledgerera
txs) =
  [ ShelleyBasedEra era -> Tx (ShelleyLedgerEra era) -> Tx era
forall era.
ShelleyBasedEra era -> Tx (ShelleyLedgerEra era) -> Tx era
ShelleyTx ShelleyBasedEra era
era Tx ledgerera
Tx (ShelleyLedgerEra era)
txinblock
  | Tx ledgerera
txinblock <- StrictSeq (Tx ledgerera) -> [Tx ledgerera]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (TxSeq ledgerera -> StrictSeq (Tx ledgerera)
forall era. SupportsSegWit era => TxSeq era -> StrictSeq (Tx era)
Ledger.fromTxSeq TxSeq ledgerera
txs) ]

obtainConsensusShelleyBasedEra
  :: forall era ledgerera a.
     ledgerera ~ ShelleyLedgerEra era
  => ShelleyBasedEra era
  -> (Consensus.ShelleyBasedEra ledgerera => a) -> a
obtainConsensusShelleyBasedEra :: ShelleyBasedEra era -> (ShelleyBasedEra ledgerera => a) -> a
obtainConsensusShelleyBasedEra ShelleyBasedEra era
ShelleyBasedEraShelley ShelleyBasedEra ledgerera => a
f = a
ShelleyBasedEra ledgerera => a
f
obtainConsensusShelleyBasedEra ShelleyBasedEra era
ShelleyBasedEraAllegra ShelleyBasedEra ledgerera => a
f = a
ShelleyBasedEra ledgerera => a
f
obtainConsensusShelleyBasedEra ShelleyBasedEra era
ShelleyBasedEraMary    ShelleyBasedEra ledgerera => a
f = a
ShelleyBasedEra ledgerera => a
f
obtainConsensusShelleyBasedEra ShelleyBasedEra era
ShelleyBasedEraAlonzo  ShelleyBasedEra ledgerera => a
f = a
ShelleyBasedEra 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 :: Block era -> EraInMode era mode -> BlockInMode mode

deriving instance Show (BlockInMode mode)


fromConsensusBlock :: ConsensusBlockForMode mode ~ block
                   => ConsensusMode mode -> block -> BlockInMode mode
fromConsensusBlock :: ConsensusMode mode -> block -> BlockInMode mode
fromConsensusBlock ConsensusMode mode
ByronMode =
    \block
b -> case block
b of
      Consensus.DegenBlock b' ->
        Block ByronEra
-> EraInMode ByronEra ByronMode -> BlockInMode ByronMode
forall era mode.
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 b' ->
        Block ShelleyEra
-> EraInMode ShelleyEra ShelleyMode -> BlockInMode ShelleyMode
forall era mode.
Block era -> EraInMode era mode -> BlockInMode mode
BlockInMode (ShelleyBasedEra ShelleyEra
-> ShelleyBlock (ShelleyLedgerEra ShelleyEra) -> Block ShelleyEra
forall era.
ShelleyBasedEra era
-> ShelleyBlock (ShelleyLedgerEra era) -> Block era
ShelleyBlock ShelleyBasedEra ShelleyEra
ShelleyBasedEraShelley ShelleyBlock StandardShelley
ShelleyBlock (ShelleyLedgerEra ShelleyEra)
b')
                     EraInMode ShelleyEra ShelleyMode
ShelleyEraInShelleyMode

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

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

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

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

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

-- ----------------------------------------------------------------------------
-- 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
(Hash BlockHeader -> Hash BlockHeader -> Bool)
-> (Hash BlockHeader -> Hash BlockHeader -> Bool)
-> Eq (Hash BlockHeader)
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)
Eq (Hash BlockHeader)
-> (Hash BlockHeader -> Hash BlockHeader -> Ordering)
-> (Hash BlockHeader -> Hash BlockHeader -> Bool)
-> (Hash BlockHeader -> Hash BlockHeader -> Bool)
-> (Hash BlockHeader -> Hash BlockHeader -> Bool)
-> (Hash BlockHeader -> Hash BlockHeader -> Bool)
-> (Hash BlockHeader -> Hash BlockHeader -> Hash BlockHeader)
-> (Hash BlockHeader -> Hash BlockHeader -> Hash BlockHeader)
-> Ord (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
$cp1Ord :: Eq (Hash BlockHeader)
Ord, Int -> Hash BlockHeader -> ShowS
[Hash BlockHeader] -> ShowS
Hash BlockHeader -> String
(Int -> Hash BlockHeader -> ShowS)
-> (Hash BlockHeader -> String)
-> ([Hash BlockHeader] -> ShowS)
-> Show (Hash BlockHeader)
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)

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

    deserialiseFromRawBytes :: AsType (Hash BlockHeader) -> ByteString -> Maybe (Hash BlockHeader)
deserialiseFromRawBytes (AsHash AsBlockHeader) ByteString
bs
      | ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
32 = Hash BlockHeader -> Maybe (Hash BlockHeader)
forall a. a -> Maybe a
Just (Hash BlockHeader -> Maybe (Hash BlockHeader))
-> Hash BlockHeader -> Maybe (Hash BlockHeader)
forall a b. (a -> b) -> a -> b
$! ShortByteString -> Hash BlockHeader
HeaderHash (ByteString -> ShortByteString
SBS.toShort ByteString
bs)
      | Bool
otherwise          = Maybe (Hash BlockHeader)
forall a. Maybe a
Nothing

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 :: Block era -> BlockHeader
getBlockHeader (ShelleyBlock ShelleyBasedEra era
shelleyEra ShelleyBlock (ShelleyLedgerEra era)
block) = case ShelleyBasedEra era
shelleyEra of
  ShelleyBasedEra era
ShelleyBasedEraShelley -> BlockHeader
ShelleyBasedEra (ShelleyLedgerEra era) => BlockHeader
go
  ShelleyBasedEra era
ShelleyBasedEraAllegra -> BlockHeader
ShelleyBasedEra (ShelleyLedgerEra era) => BlockHeader
go
  ShelleyBasedEra era
ShelleyBasedEraMary -> BlockHeader
ShelleyBasedEra (ShelleyLedgerEra era) => BlockHeader
go
  ShelleyBasedEra era
ShelleyBasedEraAlonzo -> BlockHeader
ShelleyBasedEra (ShelleyLedgerEra era) => BlockHeader
go
  where
    go :: Consensus.ShelleyBasedEra (ShelleyLedgerEra era) => BlockHeader
    go :: 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 (TPraos.HashHeader (Cardano.Crypto.Hash.Class.UnsafeHash hashSBS)),
            SlotNo
headerFieldSlot :: forall b. HeaderFields b -> SlotNo
headerFieldSlot :: SlotNo
Consensus.headerFieldSlot,
            BlockNo
headerFieldBlockNo :: forall b. HeaderFields b -> BlockNo
headerFieldBlockNo :: BlockNo
Consensus.headerFieldBlockNo
          } = ShelleyBlock (ShelleyLedgerEra era)
-> HeaderFields (ShelleyBlock (ShelleyLedgerEra era))
forall b. HasHeader b => b -> HeaderFields b
Consensus.getHeaderFields ShelleyBlock (ShelleyLedgerEra era)
block
getBlockHeader (ByronBlock ByronBlock
block)
  = SlotNo -> Hash BlockHeader -> BlockNo -> BlockHeader
BlockHeader
      SlotNo
headerFieldSlot
      (ShortByteString -> Hash BlockHeader
HeaderHash (ShortByteString -> Hash BlockHeader)
-> ShortByteString -> Hash BlockHeader
forall a b. (a -> b) -> a -> b
$ AbstractHash Blake2b_256 Header -> ShortByteString
forall algo a. AbstractHash algo a -> ShortByteString
Cardano.Crypto.Hashing.abstractHashToShort AbstractHash Blake2b_256 Header
byronHeaderHash)
      BlockNo
headerFieldBlockNo
  where
    Consensus.HeaderFields {
      headerFieldHash :: forall b. HeaderFields b -> HeaderHash b
Consensus.headerFieldHash = Consensus.ByronHash byronHeaderHash,
      SlotNo
headerFieldSlot :: SlotNo
headerFieldSlot :: forall b. HeaderFields b -> SlotNo
Consensus.headerFieldSlot,
      BlockNo
headerFieldBlockNo :: BlockNo
headerFieldBlockNo :: forall b. HeaderFields b -> BlockNo
Consensus.headerFieldBlockNo
    } = ByronBlock -> HeaderFields ByronBlock
forall b. HasHeader b => b -> HeaderFields b
Consensus.getHeaderFields ByronBlock
block


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

data ChainPoint = ChainPointAtGenesis
                | ChainPoint !SlotNo !(Hash BlockHeader)
  deriving (ChainPoint -> ChainPoint -> Bool
(ChainPoint -> ChainPoint -> Bool)
-> (ChainPoint -> ChainPoint -> Bool) -> Eq ChainPoint
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
(Int -> ChainPoint -> ShowS)
-> (ChainPoint -> String)
-> ([ChainPoint] -> ShowS)
-> Show ChainPoint
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)


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 :: ConsensusMode mode
-> ChainPoint -> Point (ConsensusBlockForMode mode)
toConsensusPointInMode ConsensusMode mode
ByronMode   = ChainPoint -> Point (ConsensusBlockForMode mode)
forall block (xs :: [*]).
(HeaderHash block ~ OneEraHash xs) =>
ChainPoint -> Point block
toConsensusPointHF
toConsensusPointInMode ConsensusMode mode
ShelleyMode = ChainPoint -> Point (ConsensusBlockForMode mode)
forall block (xs :: [*]).
(HeaderHash block ~ OneEraHash xs) =>
ChainPoint -> Point block
toConsensusPointHF
toConsensusPointInMode ConsensusMode mode
CardanoMode = ChainPoint -> Point (ConsensusBlockForMode mode)
forall block (xs :: [*]).
(HeaderHash block ~ OneEraHash xs) =>
ChainPoint -> Point block
toConsensusPointHF

fromConsensusPointInMode :: ConsensusMode mode
                         -> Consensus.Point (ConsensusBlockForMode mode)
                         -> ChainPoint
fromConsensusPointInMode :: ConsensusMode mode
-> Point (ConsensusBlockForMode mode) -> ChainPoint
fromConsensusPointInMode ConsensusMode mode
ByronMode   = Point (ConsensusBlockForMode mode) -> ChainPoint
forall block (xs :: [*]).
(HeaderHash block ~ OneEraHash xs) =>
Point block -> ChainPoint
fromConsensusPointHF
fromConsensusPointInMode ConsensusMode mode
ShelleyMode = Point (ConsensusBlockForMode mode) -> ChainPoint
forall block (xs :: [*]).
(HeaderHash block ~ OneEraHash xs) =>
Point block -> ChainPoint
fromConsensusPointHF
fromConsensusPointInMode ConsensusMode mode
CardanoMode = Point (ConsensusBlockForMode mode) -> ChainPoint
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 :: ChainPoint -> Point block
toConsensusPointHF  ChainPoint
ChainPointAtGenesis = Point block
forall block. Point block
Consensus.GenesisPoint
toConsensusPointHF (ChainPoint SlotNo
slot (HeaderHash h)) =
    SlotNo -> HeaderHash block -> Point block
forall block. SlotNo -> HeaderHash block -> Point block
Consensus.BlockPoint SlotNo
slot (ShortByteString -> OneEraHash xs
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 :: Point block -> ChainPoint
fromConsensusPointHF Point block
Consensus.GenesisPoint = ChainPoint
ChainPointAtGenesis
fromConsensusPointHF (Consensus.BlockPoint SlotNo
slot (Consensus.OneEraHash 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.
                      Consensus.ShelleyBasedEra ledgerera
                   => ChainPoint
                   -> Consensus.Point (Consensus.ShelleyBlock ledgerera)
toConsensusPoint :: ChainPoint -> Point (ShelleyBlock ledgerera)
toConsensusPoint ChainPoint
ChainPointAtGenesis = Point (ShelleyBlock ledgerera)
forall block. Point block
Consensus.GenesisPoint
toConsensusPoint (ChainPoint SlotNo
slot (HeaderHash h)) =
    SlotNo
-> HeaderHash (ShelleyBlock ledgerera)
-> Point (ShelleyBlock ledgerera)
forall block. SlotNo -> HeaderHash block -> Point block
Consensus.BlockPoint SlotNo
slot (Proxy (ShelleyBlock ledgerera)
-> ShortByteString -> HeaderHash (ShelleyBlock ledgerera)
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> ShortByteString -> HeaderHash blk
Consensus.fromShortRawHash Proxy (ShelleyBlock ledgerera)
proxy ShortByteString
h)
  where
    proxy :: Proxy (Consensus.ShelleyBlock ledgerera)
    proxy :: Proxy (ShelleyBlock ledgerera)
proxy = Proxy (ShelleyBlock ledgerera)
forall k (t :: k). Proxy t
Proxy

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

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

chainPointToHeaderHash :: ChainPoint -> Maybe (Hash BlockHeader)
chainPointToHeaderHash :: ChainPoint -> Maybe (Hash BlockHeader)
chainPointToHeaderHash ChainPoint
ChainPointAtGenesis = Maybe (Hash BlockHeader)
forall a. Maybe a
Nothing
chainPointToHeaderHash (ChainPoint SlotNo
_ Hash BlockHeader
blockHeader) = Hash BlockHeader -> Maybe (Hash 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
(ChainTip -> ChainTip -> Bool)
-> (ChainTip -> ChainTip -> Bool) -> Eq ChainTip
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
(Int -> ChainTip -> ShowS)
-> (ChainTip -> String) -> ([ChainTip] -> ShowS) -> Show ChainTip
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 [ Text
"slot" Text -> SlotNo -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SlotNo
slot
           , Text
"hash" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Hash BlockHeader -> Text
forall a. SerialiseAsRawBytes a => a -> Text
serialiseToRawBytesHexText Hash BlockHeader
headerHash
           , Text
"block" Text -> Word64 -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> 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 :: ConsensusMode mode -> Tip block -> ChainTip
fromConsensusTip ConsensusMode mode
ByronMode = Tip block -> ChainTip
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 h) BlockNo
block) =
      SlotNo -> Hash BlockHeader -> BlockNo -> ChainTip
ChainTip SlotNo
slot (ShortByteString -> Hash BlockHeader
HeaderHash ShortByteString
h) BlockNo
block

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

fromConsensusTip ConsensusMode mode
CardanoMode = Tip block -> ChainTip
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 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
-}