{-# 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 Bcc.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(..),
  ) 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           Bcc.Slotting.Block (BlockNo)
import           Bcc.Slotting.Slot (EpochNo, SlotNo)

import qualified Bcc.Crypto.Hash.Class
import qualified Bcc.Crypto.Hashing
import qualified Shardagnostic.Consensus.Block as Consensus
import qualified Shardagnostic.Consensus.Cole.Ledger as Consensus
import qualified Shardagnostic.Consensus.Bcc.Block as Consensus
import qualified Shardagnostic.Consensus.Bcc.ColeHFC as Consensus
import qualified Shardagnostic.Consensus.HardFork.Combinator as Consensus
import qualified Shardagnostic.Consensus.HardFork.Combinator.Degenerate as Consensus
import qualified Shardagnostic.Consensus.Sophie.Ledger as Consensus
import qualified Shardagnostic.Consensus.Sophie.SophieHFC as Consensus
import qualified Shardagnostic.Network.Block as Consensus

import qualified Bcc.Chain.Block as Cole
import qualified Bcc.Chain.UTxO as Cole
import qualified Bcc.Ledger.Era as Ledger
import qualified Bcc.Protocol.TOptimum.BHeader as Optimum
import qualified Sophie.Spec.Ledger.BlockChain as Ledger

import           Bcc.Api.Eras
import           Bcc.Api.HasTypeProxy
import           Bcc.Api.Hash
import           Bcc.Api.Modes
import           Bcc.Api.SerialiseRaw
import           Bcc.Api.Tx

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

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

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

     ColeBlock :: Consensus.ColeBlock
                -> Block ColeEra

     SophieBlock :: SophieBasedEra era
                  -> Consensus.SophieBlock (SophieLedgerEra 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 SophieBlock case requires a custom instance
instance Show (Block era) where
    showsPrec :: Int -> Block era -> ShowS
showsPrec Int
p (ColeBlock ColeBlock
block) =
      Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
11)
        ( String -> ShowS
showString String
"ColeBlock "
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ColeBlock -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 ColeBlock
block
        )

    showsPrec Int
p (SophieBlock SophieBasedEra era
SophieBasedEraSophie SophieBlock (SophieLedgerEra era)
block) =
      Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
11)
        ( String -> ShowS
showString String
"SophieBlock SophieBasedEraSophie "
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> SophieBlock StandardSophie -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 SophieBlock StandardSophie
SophieBlock (SophieLedgerEra era)
block
        )

    showsPrec Int
p (SophieBlock SophieBasedEra era
SophieBasedEraEvie SophieBlock (SophieLedgerEra era)
block) =
      Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
11)
        ( String -> ShowS
showString String
"SophieBlock SophieBasedEraEvie "
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> SophieBlock StandardEvie -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 SophieBlock StandardEvie
SophieBlock (SophieLedgerEra era)
block
        )

    showsPrec Int
p (SophieBlock SophieBasedEra era
SophieBasedEraJen SophieBlock (SophieLedgerEra era)
block) =
      Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
11)
        ( String -> ShowS
showString String
"SophieBlock SophieBasedEraJen "
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> SophieBlock StandardJen -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 SophieBlock StandardJen
SophieBlock (SophieLedgerEra era)
block
        )

    showsPrec Int
p (SophieBlock SophieBasedEra era
SophieBasedEraAurum SophieBlock (SophieLedgerEra era)
block) =
      Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
11)
        ( String -> ShowS
showString String
"SophieBlock SophieBasedEraAurum "
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> SophieBlock StandardAurum -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 SophieBlock StandardAurum
SophieBlock (SophieLedgerEra era)
block
        )

getBlockTxs :: forall era . Block era -> [Tx era]
getBlockTxs :: Block era -> [Tx era]
getBlockTxs (ColeBlock Consensus.ColeBlock { ABlockOrBoundary ByteString
coleBlockRaw :: ColeBlock -> ABlockOrBoundary ByteString
coleBlockRaw :: ABlockOrBoundary ByteString
Consensus.coleBlockRaw }) =
    case ABlockOrBoundary ByteString
coleBlockRaw of
      Cole.ABOBBoundary{} -> [] -- no txs in EBBs
      Cole.ABOBBlock Cole.ABlock {
          blockBody :: forall a. ABlock a -> ABody a
Cole.blockBody =
            Cole.ABody {
              bodyTxPayload :: forall a. ABody a -> ATxPayload a
Cole.bodyTxPayload = Cole.ATxPayload [ATxAux ByteString]
txs
            }
        } -> (ATxAux ByteString -> Tx ColeEra)
-> [ATxAux ByteString] -> [Tx ColeEra]
forall a b. (a -> b) -> [a] -> [b]
map ATxAux ByteString -> Tx ColeEra
ColeTx [ATxAux ByteString]
txs
getBlockTxs (SophieBlock SophieBasedEra era
era Consensus.SophieBlock{Block (SophieLedgerEra era)
sophieBlockRaw :: forall era. SophieBlock era -> Block era
sophieBlockRaw :: Block (SophieLedgerEra era)
Consensus.sophieBlockRaw}) =
    SophieBasedEra era
-> (SophieBasedEra (SophieLedgerEra era) => [Tx era]) -> [Tx era]
forall era ledgerera a.
(ledgerera ~ SophieLedgerEra era) =>
SophieBasedEra era -> (SophieBasedEra ledgerera => a) -> a
obtainConsensusSophieBasedEra SophieBasedEra era
era ((SophieBasedEra (SophieLedgerEra era) => [Tx era]) -> [Tx era])
-> (SophieBasedEra (SophieLedgerEra era) => [Tx era]) -> [Tx era]
forall a b. (a -> b) -> a -> b
$
      SophieBasedEra era -> Block (SophieLedgerEra era) -> [Tx era]
forall era ledgerera.
(ledgerera ~ SophieLedgerEra era, SophieBasedEra ledgerera) =>
SophieBasedEra era -> Block ledgerera -> [Tx era]
getSophieBlockTxs SophieBasedEra era
era Block (SophieLedgerEra era)
sophieBlockRaw

getSophieBlockTxs :: forall era ledgerera.
                      ledgerera ~ SophieLedgerEra era
                   => Consensus.SophieBasedEra ledgerera
                   => SophieBasedEra era
                   -> Ledger.Block ledgerera
                   -> [Tx era]
getSophieBlockTxs :: SophieBasedEra era -> Block ledgerera -> [Tx era]
getSophieBlockTxs SophieBasedEra era
era (Ledger.Block BHeader (Crypto ledgerera)
_header TxSeq ledgerera
txs) =
  [ SophieBasedEra era -> Tx (SophieLedgerEra era) -> Tx era
forall era.
SophieBasedEra era -> Tx (SophieLedgerEra era) -> Tx era
SophieTx SophieBasedEra era
era Tx ledgerera
Tx (SophieLedgerEra 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) ]

obtainConsensusSophieBasedEra
  :: forall era ledgerera a.
     ledgerera ~ SophieLedgerEra era
  => SophieBasedEra era
  -> (Consensus.SophieBasedEra ledgerera => a) -> a
obtainConsensusSophieBasedEra :: SophieBasedEra era -> (SophieBasedEra ledgerera => a) -> a
obtainConsensusSophieBasedEra SophieBasedEra era
SophieBasedEraSophie SophieBasedEra ledgerera => a
f = a
SophieBasedEra ledgerera => a
f
obtainConsensusSophieBasedEra SophieBasedEra era
SophieBasedEraEvie SophieBasedEra ledgerera => a
f = a
SophieBasedEra ledgerera => a
f
obtainConsensusSophieBasedEra SophieBasedEra era
SophieBasedEraJen    SophieBasedEra ledgerera => a
f = a
SophieBasedEra ledgerera => a
f
obtainConsensusSophieBasedEra SophieBasedEra era
SophieBasedEraAurum  SophieBasedEra ledgerera => a
f = a
SophieBasedEra 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 'BccMode' 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
ColeMode =
    \block
b -> case block
b of
      Consensus.DegenBlock b' ->
        Block ColeEra -> EraInMode ColeEra ColeMode -> BlockInMode ColeMode
forall era mode.
Block era -> EraInMode era mode -> BlockInMode mode
BlockInMode (ColeBlock -> Block ColeEra
ColeBlock ColeBlock
b') EraInMode ColeEra ColeMode
ColeEraInColeMode

fromConsensusBlock ConsensusMode mode
SophieMode =
    \block
b -> case block
b of
      Consensus.DegenBlock b' ->
        Block SophieEra
-> EraInMode SophieEra SophieMode -> BlockInMode SophieMode
forall era mode.
Block era -> EraInMode era mode -> BlockInMode mode
BlockInMode (SophieBasedEra SophieEra
-> SophieBlock (SophieLedgerEra SophieEra) -> Block SophieEra
forall era.
SophieBasedEra era
-> SophieBlock (SophieLedgerEra era) -> Block era
SophieBlock SophieBasedEra SophieEra
SophieBasedEraSophie SophieBlock StandardSophie
SophieBlock (SophieLedgerEra SophieEra)
b')
                     EraInMode SophieEra SophieMode
SophieEraInSophieMode

fromConsensusBlock ConsensusMode mode
BccMode =
    \block
b -> case block
b of
      Consensus.BlockCole b' ->
        Block ColeEra -> EraInMode ColeEra BccMode -> BlockInMode BccMode
forall era mode.
Block era -> EraInMode era mode -> BlockInMode mode
BlockInMode (ColeBlock -> Block ColeEra
ColeBlock ColeBlock
b') EraInMode ColeEra BccMode
ColeEraInBccMode

      Consensus.BlockSophie b' ->
        Block SophieEra
-> EraInMode SophieEra BccMode -> BlockInMode BccMode
forall era mode.
Block era -> EraInMode era mode -> BlockInMode mode
BlockInMode (SophieBasedEra SophieEra
-> SophieBlock (SophieLedgerEra SophieEra) -> Block SophieEra
forall era.
SophieBasedEra era
-> SophieBlock (SophieLedgerEra era) -> Block era
SophieBlock SophieBasedEra SophieEra
SophieBasedEraSophie SophieBlock StandardSophie
SophieBlock (SophieLedgerEra SophieEra)
b')
                     EraInMode SophieEra BccMode
SophieEraInBccMode

      Consensus.BlockEvie b' ->
        Block EvieEra -> EraInMode EvieEra BccMode -> BlockInMode BccMode
forall era mode.
Block era -> EraInMode era mode -> BlockInMode mode
BlockInMode (SophieBasedEra EvieEra
-> SophieBlock (SophieLedgerEra EvieEra) -> Block EvieEra
forall era.
SophieBasedEra era
-> SophieBlock (SophieLedgerEra era) -> Block era
SophieBlock SophieBasedEra EvieEra
SophieBasedEraEvie SophieBlock StandardEvie
SophieBlock (SophieLedgerEra EvieEra)
b')
                     EraInMode EvieEra BccMode
EvieEraInBccMode

      Consensus.BlockJen b' ->
        Block JenEra -> EraInMode JenEra BccMode -> BlockInMode BccMode
forall era mode.
Block era -> EraInMode era mode -> BlockInMode mode
BlockInMode (SophieBasedEra JenEra
-> SophieBlock (SophieLedgerEra JenEra) -> Block JenEra
forall era.
SophieBasedEra era
-> SophieBlock (SophieLedgerEra era) -> Block era
SophieBlock SophieBasedEra JenEra
SophieBasedEraJen SophieBlock StandardJen
SophieBlock (SophieLedgerEra JenEra)
b')
                     EraInMode JenEra BccMode
JenEraInBccMode

      Consensus.BlockAurum b' ->
        Block AurumEra -> EraInMode AurumEra BccMode -> BlockInMode BccMode
forall era mode.
Block era -> EraInMode era mode -> BlockInMode mode
BlockInMode (SophieBasedEra AurumEra
-> SophieBlock (SophieLedgerEra AurumEra) -> Block AurumEra
forall era.
SophieBasedEra era
-> SophieBlock (SophieLedgerEra era) -> Block era
SophieBlock SophieBasedEra AurumEra
SophieBasedEraAurum SophieBlock StandardAurum
SophieBlock (SophieLedgerEra AurumEra)
b')
                     EraInMode AurumEra BccMode
AurumEraInBccMode

-- ----------------------------------------------------------------------------
-- 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 (SophieBlock SophieBasedEra era
sophieEra SophieBlock (SophieLedgerEra era)
block) = case SophieBasedEra era
sophieEra of
  SophieBasedEra era
SophieBasedEraSophie -> BlockHeader
SophieBasedEra (SophieLedgerEra era) => BlockHeader
go
  SophieBasedEra era
SophieBasedEraEvie -> BlockHeader
SophieBasedEra (SophieLedgerEra era) => BlockHeader
go
  SophieBasedEra era
SophieBasedEraJen -> BlockHeader
SophieBasedEra (SophieLedgerEra era) => BlockHeader
go
  SophieBasedEra era
SophieBasedEraAurum -> BlockHeader
SophieBasedEra (SophieLedgerEra era) => BlockHeader
go
  where
    go :: Consensus.SophieBasedEra (SophieLedgerEra 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.SophieHash (Optimum.HashHeader (Bcc.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
          } = SophieBlock (SophieLedgerEra era)
-> HeaderFields (SophieBlock (SophieLedgerEra era))
forall b. HasHeader b => b -> HeaderFields b
Consensus.getHeaderFields SophieBlock (SophieLedgerEra era)
block
getBlockHeader (ColeBlock ColeBlock
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
Bcc.Crypto.Hashing.abstractHashToShort AbstractHash Blake2b_256 Header
coleHeaderHash)
      BlockNo
headerFieldBlockNo
  where
    Consensus.HeaderFields {
      headerFieldHash :: forall b. HeaderFields b -> HeaderHash b
Consensus.headerFieldHash = Consensus.ColeHash coleHeaderHash,
      SlotNo
headerFieldSlot :: SlotNo
headerFieldSlot :: forall b. HeaderFields b -> SlotNo
Consensus.headerFieldSlot,
      BlockNo
headerFieldBlockNo :: BlockNo
headerFieldBlockNo :: forall b. HeaderFields b -> BlockNo
Consensus.headerFieldBlockNo
    } = ColeBlock -> HeaderFields ColeBlock
forall b. HasHeader b => b -> HeaderFields b
Consensus.getHeaderFields ColeBlock
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
ColeMode   = ChainPoint -> Point (ConsensusBlockForMode mode)
forall block (xs :: [*]).
(HeaderHash block ~ OneEraHash xs) =>
ChainPoint -> Point block
toConsensusPointHF
toConsensusPointInMode ConsensusMode mode
SophieMode = ChainPoint -> Point (ConsensusBlockForMode mode)
forall block (xs :: [*]).
(HeaderHash block ~ OneEraHash xs) =>
ChainPoint -> Point block
toConsensusPointHF
toConsensusPointInMode ConsensusMode mode
BccMode = 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
ColeMode   = Point (ConsensusBlockForMode mode) -> ChainPoint
forall block (xs :: [*]).
(HeaderHash block ~ OneEraHash xs) =>
Point block -> ChainPoint
fromConsensusPointHF
fromConsensusPointInMode ConsensusMode mode
SophieMode = Point (ConsensusBlockForMode mode) -> ChainPoint
forall block (xs :: [*]).
(HeaderHash block ~ OneEraHash xs) =>
Point block -> ChainPoint
fromConsensusPointHF
fromConsensusPointInMode ConsensusMode mode
BccMode = 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 Sophie-era block type
--
toConsensusPoint :: forall ledgerera.
                      Consensus.SophieBasedEra ledgerera
                   => ChainPoint
                   -> Consensus.Point (Consensus.SophieBlock ledgerera)
toConsensusPoint :: ChainPoint -> Point (SophieBlock ledgerera)
toConsensusPoint ChainPoint
ChainPointAtGenesis = Point (SophieBlock ledgerera)
forall block. Point block
Consensus.GenesisPoint
toConsensusPoint (ChainPoint SlotNo
slot (HeaderHash h)) =
    SlotNo
-> HeaderHash (SophieBlock ledgerera)
-> Point (SophieBlock ledgerera)
forall block. SlotNo -> HeaderHash block -> Point block
Consensus.BlockPoint SlotNo
slot (Proxy (SophieBlock ledgerera)
-> ShortByteString -> HeaderHash (SophieBlock ledgerera)
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> ShortByteString -> HeaderHash blk
Consensus.fromShortRawHash Proxy (SophieBlock ledgerera)
proxy ShortByteString
h)
  where
    proxy :: Proxy (Consensus.SophieBlock ledgerera)
    proxy :: Proxy (SophieBlock ledgerera)
proxy = Proxy (SophieBlock ledgerera)
forall k (t :: k). Proxy t
Proxy

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


-- ----------------------------------------------------------------------------
-- 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


fromConsensusTip  :: ConsensusBlockForMode mode ~ block
                  => ConsensusMode mode
                  -> Consensus.Tip block
                  -> ChainTip
fromConsensusTip :: ConsensusMode mode -> Tip block -> ChainTip
fromConsensusTip ConsensusMode mode
ColeMode = Tip block -> ChainTip
Tip ColeBlockHFC -> ChainTip
conv
  where
    conv :: Consensus.Tip Consensus.ColeBlockHFC -> ChainTip
    conv :: Tip ColeBlockHFC -> ChainTip
conv Tip ColeBlockHFC
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
SophieMode = Tip block -> ChainTip
Tip (SophieBlockHFC StandardSophie) -> ChainTip
conv
  where
    conv :: Consensus.Tip (Consensus.SophieBlockHFC Consensus.StandardSophie)
         -> ChainTip
    conv :: Tip (SophieBlockHFC StandardSophie) -> ChainTip
conv Tip (SophieBlockHFC StandardSophie)
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
BccMode = Tip block -> ChainTip
Tip (BccBlock StandardCrypto) -> ChainTip
conv
  where
    conv :: Consensus.Tip (Consensus.BccBlock Consensus.StandardCrypto)
         -> ChainTip
    conv :: Tip (BccBlock StandardCrypto) -> ChainTip
conv Tip (BccBlock 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
      ColeMode   -> conv
      SophieMode -> conv
      BccMode -> conv
  where
    conv :: HeaderHash block ~ OneEraHash xs
         => Tip block -> ChainTip
    conv TipGenesis                      = ChainTipAtGenesis
    conv (Tip slot (OneEraHash h) block) = ChainTip slot (HeaderHash h) block
-}