% Example: A More Complex Example Protocol Involving Epochs

Introduction
============

This tutorial builds on the example in `Simple.lhs` by specifying a block,
ledger, and protocol for a blockchain that has a notion of epoch built into it -
serving as an example of a case where the state of the ledger is used as part of
the machinery of consensus.  It is highly recommended that the reader have read
`Simple.lhs` before this if they are not already familiar with concepts such
as `ConsensusProtocol` and `LedgerState`.

Much like the previous example of `BlockC` this blockchain (with block type
`BlockD`) models a single number resulting from a series of _increment_ and
_decrement_ transactions in the block bodies.  However, the slots are now
divided into **epochs** each of which has a fixed number of slots.

Further, the chain is set up such that there are 20 _nodes_ labelled with a
`NodeId` from 0 to 19 participating in the computation.

At the beginning of an epoch, the current value of the ledger - that is, the sum
of the _increment_ transactions minus the sum of the _decrement_ transactions is
snapshotted as part of the ledger.

During the epoch, the snapshot *from two epochs ago* determines which subset of
a set of 20 nodes is allowed to lead slots.  If the snapshot is even, then slots
contained in that epoch follow a round-robin leadership schedule among nodes 0
through 9 inclusive.  Similarly, if the snapshot is odd then the slots of that
epoch will be follow a round-robin leadership schedule from the set of nodes
from 10 to 19.

Though it is difficult to imagine a real system doing this, it is a simple
example of a case where the value computed by the blockchain (the `LedgerState`)
is relevant - through the leader schedule - to the behavior of consensus.  One
can perhaps view it as a very simplified analog to stake distribution.

Setup
-----

As before, we require a few language extensions:

> {-# OPTIONS_GHC -Wno-unused-top-binds   #-}
> {-# LANGUAGE TypeFamilies               #-}
> {-# LANGUAGE DerivingVia                #-}
> {-# LANGUAGE DataKinds                  #-}
> {-# LANGUAGE DeriveGeneric              #-}
> {-# LANGUAGE FlexibleInstances          #-}
> {-# LANGUAGE MultiParamTypeClasses      #-}
> {-# LANGUAGE GeneralizedNewtypeDeriving #-}
> {-# LANGUAGE DeriveAnyClass #-}
> {-# LANGUAGE StandaloneDeriving         #-}

> module Ouroboros.Consensus.Tutorial.WithEpoch () where

And imports, of course:

> import Control.Monad ()
> import Control.Monad.Except (MonadError (throwError))
> import Data.Word (Word64)
> import GHC.Generics (Generic)
> import NoThunks.Class (NoThunks, OnlyCheckWhnfNamed (..))
> import Data.Hashable (Hashable (hash))
> import Codec.Serialise (Serialise)
> import Ouroboros.Network.Point ()
> import Ouroboros.Network.Block ()
> import Ouroboros.Consensus.Block.Abstract
>  (Header, SlotNo (..), HeaderHash, ChainHash, GetHeader (..),
>   GetPrevHash (..), HasHeader (..), HeaderFields (..), StandardHash,
>   BlockProtocol, castHeaderFields, blockNo, BlockConfig, CodecConfig,
>   StorageConfig, Point, castPoint, WithOrigin (..), EpochNo (EpochNo),
>   pointSlot, blockPoint, BlockNo (..))
> import Ouroboros.Consensus.Block.SupportsProtocol
>   (BlockSupportsProtocol (..))
> import Ouroboros.Consensus.Protocol.Abstract
>   (ConsensusConfig, SecurityParam, ConsensusProtocol (..))
>
> import Ouroboros.Consensus.Ticked (Ticked)
> import Ouroboros.Consensus.Ledger.Abstract
>   (LedgerState, LedgerCfg, GetTip, LedgerResult (..), ApplyBlock (..),
>    UpdateLedger, IsLedger (..))
>
> import Ouroboros.Consensus.Ledger.SupportsMempool ()
> import Ouroboros.Consensus.Ledger.SupportsProtocol
>   (LedgerSupportsProtocol (..))
>
> import Ouroboros.Consensus.HeaderValidation
>   (ValidateEnvelope, BasicEnvelopeValidation, HasAnnTip)
> import Ouroboros.Consensus.Forecast
>   (Forecast (..), OutsideForecastRange (..))
> import Ouroboros.Consensus.Ledger.Basics (GetTip(..))


Epochs
------

Epochs occur at a fixed interval:

> slotsInEpoch :: Word64
> slotsInEpoch :: Word64
slotsInEpoch = Word64
50

We also write a function from `WithOrigin SlotNo` to the corresponding epoch
number to express this behavior.  The `WithOrigin` type allows us to describe
the behavior of this in the presence of the first (origin) block on the chain.
We will consider `Origin` to be a special epoch before the epochs of the slots
proper:

> epochOf :: WithOrigin SlotNo -> WithOrigin EpochNo
> epochOf :: WithOrigin SlotNo -> WithOrigin EpochNo
epochOf WithOrigin SlotNo
Origin = WithOrigin EpochNo
forall t. WithOrigin t
Origin
> epochOf (NotOrigin SlotNo
s) = EpochNo -> WithOrigin EpochNo
forall t. t -> WithOrigin t
NotOrigin (EpochNo -> WithOrigin EpochNo) -> EpochNo -> WithOrigin EpochNo
forall a b. (a -> b) -> a -> b
$ Word64 -> EpochNo
EpochNo (Word64 -> EpochNo) -> Word64 -> EpochNo
forall a b. (a -> b) -> a -> b
$ SlotNo -> Word64
unSlotNo SlotNo
s Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`div` Word64
slotsInEpoch

From a particular `WithOrigin Slot` we can also determine when the next epoch
will begin:

> nextEpochStartSlot :: WithOrigin SlotNo -> SlotNo
> nextEpochStartSlot :: WithOrigin SlotNo -> SlotNo
nextEpochStartSlot WithOrigin SlotNo
wo =
>   Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> Word64 -> SlotNo
forall a b. (a -> b) -> a -> b
$ case WithOrigin SlotNo
wo of
>              WithOrigin SlotNo
Origin -> Word64
slotsInEpoch
>              NotOrigin SlotNo
slot -> Word64
slotsInEpoch Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
slot' Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- (Word64
slot' Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`mod` Word64
slotsInEpoch)
>                                where
>                                 slot' :: Word64
slot' = SlotNo -> Word64
unSlotNo SlotNo
slot

Hashing
-------

In this tutorial, we'll use a more real (but still very contrived) hashing
infrastructure built on top of the `Hashable` class from the `hashable` package.

Our infastructure is quite simple - a `newtype` for hashes:

> newtype Hash = Hash Int
>   deriving stock (Hash -> Hash -> Bool
(Hash -> Hash -> Bool) -> (Hash -> Hash -> Bool) -> Eq Hash
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Hash -> Hash -> Bool
== :: Hash -> Hash -> Bool
$c/= :: Hash -> Hash -> Bool
/= :: Hash -> Hash -> Bool
Eq, Eq Hash
Eq Hash =>
(Hash -> Hash -> Ordering)
-> (Hash -> Hash -> Bool)
-> (Hash -> Hash -> Bool)
-> (Hash -> Hash -> Bool)
-> (Hash -> Hash -> Bool)
-> (Hash -> Hash -> Hash)
-> (Hash -> Hash -> Hash)
-> Ord Hash
Hash -> Hash -> Bool
Hash -> Hash -> Ordering
Hash -> Hash -> Hash
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
$ccompare :: Hash -> Hash -> Ordering
compare :: Hash -> Hash -> Ordering
$c< :: Hash -> Hash -> Bool
< :: Hash -> Hash -> Bool
$c<= :: Hash -> Hash -> Bool
<= :: Hash -> Hash -> Bool
$c> :: Hash -> Hash -> Bool
> :: Hash -> Hash -> Bool
$c>= :: Hash -> Hash -> Bool
>= :: Hash -> Hash -> Bool
$cmax :: Hash -> Hash -> Hash
max :: Hash -> Hash -> Hash
$cmin :: Hash -> Hash -> Hash
min :: Hash -> Hash -> Hash
Ord, Int -> Hash -> ShowS
[Hash] -> ShowS
Hash -> String
(Int -> Hash -> ShowS)
-> (Hash -> String) -> ([Hash] -> ShowS) -> Show Hash
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Hash -> ShowS
showsPrec :: Int -> Hash -> ShowS
$cshow :: Hash -> String
show :: Hash -> String
$cshowList :: [Hash] -> ShowS
showList :: [Hash] -> ShowS
Show, (forall x. Hash -> Rep Hash x)
-> (forall x. Rep Hash x -> Hash) -> Generic Hash
forall x. Rep Hash x -> Hash
forall x. Hash -> Rep Hash x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Hash -> Rep Hash x
from :: forall x. Hash -> Rep Hash x
$cto :: forall x. Rep Hash x -> Hash
to :: forall x. Rep Hash x -> Hash
Generic)
>   deriving newtype (Context -> Hash -> IO (Maybe ThunkInfo)
Proxy Hash -> String
(Context -> Hash -> IO (Maybe ThunkInfo))
-> (Context -> Hash -> IO (Maybe ThunkInfo))
-> (Proxy Hash -> String)
-> NoThunks Hash
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> Hash -> IO (Maybe ThunkInfo)
noThunks :: Context -> Hash -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> Hash -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> Hash -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy Hash -> String
showTypeOf :: Proxy Hash -> String
NoThunks, Eq Hash
Eq Hash => (Int -> Hash -> Int) -> (Hash -> Int) -> Hashable Hash
Int -> Hash -> Int
Hash -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> Hash -> Int
hashWithSalt :: Int -> Hash -> Int
$chash :: Hash -> Int
hash :: Hash -> Int
Hashable, [Hash] -> Encoding
Hash -> Encoding
(Hash -> Encoding)
-> (forall s. Decoder s Hash)
-> ([Hash] -> Encoding)
-> (forall s. Decoder s [Hash])
-> Serialise Hash
forall s. Decoder s [Hash]
forall s. Decoder s Hash
forall a.
(a -> Encoding)
-> (forall s. Decoder s a)
-> ([a] -> Encoding)
-> (forall s. Decoder s [a])
-> Serialise a
$cencode :: Hash -> Encoding
encode :: Hash -> Encoding
$cdecode :: forall s. Decoder s Hash
decode :: forall s. Decoder s Hash
$cencodeList :: [Hash] -> Encoding
encodeList :: [Hash] -> Encoding
$cdecodeList :: forall s. Decoder s [Hash]
decodeList :: forall s. Decoder s [Hash]
Serialise)

And a function to turn `Hashable` things into values of type `Hash`.

> mkHash :: Hashable a => a -> Hash
> mkHash :: forall a. Hashable a => a -> Hash
mkHash = Int -> Hash
Hash (Int -> Hash) -> (a -> Int) -> a -> Hash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Int
forall a. Hashable a => a -> Int
hash

We'll instantiate `Hashable` things as we need them throughout this example.


Node Identifiers
----------------

We'll also need a notion of node identity since this will be used to specify
some things with respect to leadership.  We'll assume all nodes that can lead
have identifiers in the range of 0..19.

> type NodeId = Word64

Block
=====

Block Type
----------

Our block and transaction type is structurally the same as `BlockC` - a header
followed by a list of transactions `Tx`:

> data BlockD = BlockD { BlockD -> Header BlockD
bd_header :: Header BlockD
>                      , BlockD -> [Tx]
bd_body :: [Tx]
>                      }
>   deriving Context -> BlockD -> IO (Maybe ThunkInfo)
Proxy BlockD -> String
(Context -> BlockD -> IO (Maybe ThunkInfo))
-> (Context -> BlockD -> IO (Maybe ThunkInfo))
-> (Proxy BlockD -> String)
-> NoThunks BlockD
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> BlockD -> IO (Maybe ThunkInfo)
noThunks :: Context -> BlockD -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> BlockD -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> BlockD -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy BlockD -> String
showTypeOf :: Proxy BlockD -> String
NoThunks via OnlyCheckWhnfNamed "BlockD" BlockD

> data Tx = Inc | Dec
>   deriving (Int -> Tx -> ShowS
[Tx] -> ShowS
Tx -> String
(Int -> Tx -> ShowS)
-> (Tx -> String) -> ([Tx] -> ShowS) -> Show Tx
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Tx -> ShowS
showsPrec :: Int -> Tx -> ShowS
$cshow :: Tx -> String
show :: Tx -> String
$cshowList :: [Tx] -> ShowS
showList :: [Tx] -> ShowS
Show, Tx -> Tx -> Bool
(Tx -> Tx -> Bool) -> (Tx -> Tx -> Bool) -> Eq Tx
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Tx -> Tx -> Bool
== :: Tx -> Tx -> Bool
$c/= :: Tx -> Tx -> Bool
/= :: Tx -> Tx -> Bool
Eq, (forall x. Tx -> Rep Tx x)
-> (forall x. Rep Tx x -> Tx) -> Generic Tx
forall x. Rep Tx x -> Tx
forall x. Tx -> Rep Tx x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Tx -> Rep Tx x
from :: forall x. Tx -> Rep Tx x
$cto :: forall x. Rep Tx x -> Tx
to :: forall x. Rep Tx x -> Tx
Generic, [Tx] -> Encoding
Tx -> Encoding
(Tx -> Encoding)
-> (forall s. Decoder s Tx)
-> ([Tx] -> Encoding)
-> (forall s. Decoder s [Tx])
-> Serialise Tx
forall s. Decoder s [Tx]
forall s. Decoder s Tx
forall a.
(a -> Encoding)
-> (forall s. Decoder s a)
-> ([a] -> Encoding)
-> (forall s. Decoder s [a])
-> Serialise a
$cencode :: Tx -> Encoding
encode :: Tx -> Encoding
$cdecode :: forall s. Decoder s Tx
decode :: forall s. Decoder s Tx
$cencodeList :: [Tx] -> Encoding
encodeList :: [Tx] -> Encoding
$cdecodeList :: forall s. Decoder s [Tx]
decodeList :: forall s. Decoder s [Tx]
Serialise, Context -> Tx -> IO (Maybe ThunkInfo)
Proxy Tx -> String
(Context -> Tx -> IO (Maybe ThunkInfo))
-> (Context -> Tx -> IO (Maybe ThunkInfo))
-> (Proxy Tx -> String)
-> NoThunks Tx
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> Tx -> IO (Maybe ThunkInfo)
noThunks :: Context -> Tx -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> Tx -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> Tx -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy Tx -> String
showTypeOf :: Proxy Tx -> String
NoThunks, Eq Tx
Eq Tx => (Int -> Tx -> Int) -> (Tx -> Int) -> Hashable Tx
Int -> Tx -> Int
Tx -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> Tx -> Int
hashWithSalt :: Int -> Tx -> Int
$chash :: Tx -> Int
hash :: Tx -> Int
Hashable)


Block Header
------------

However, the header is somewhat different as it includes the node identifier
that created the block.  Naturally in a more realistic system this would instead
be some value that provides stronger (probably cryptographic) evidence for this
block's provenance but since this is a simple example, we will simply use a
`NodeId`:

> data instance Header BlockD =
>   HdrBlockD
>     { Header BlockD -> SlotNo
hbd_SlotNo :: SlotNo
>     , Header BlockD -> BlockNo
hbd_BlockNo :: BlockNo
>     -- hash of whole block (excepting this field)
>     , Header BlockD -> HeaderHash BlockD
hbd_Hash :: HeaderHash BlockD
>     , Header BlockD -> ChainHash BlockD
hbd_prev :: ChainHash BlockD
>     , Header BlockD -> Word64
hbd_nodeId :: NodeId
>     }
>   deriving stock (Int -> Header BlockD -> ShowS
[Header BlockD] -> ShowS
Header BlockD -> String
(Int -> Header BlockD -> ShowS)
-> (Header BlockD -> String)
-> ([Header BlockD] -> ShowS)
-> Show (Header BlockD)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Header BlockD -> ShowS
showsPrec :: Int -> Header BlockD -> ShowS
$cshow :: Header BlockD -> String
show :: Header BlockD -> String
$cshowList :: [Header BlockD] -> ShowS
showList :: [Header BlockD] -> ShowS
Show, Header BlockD -> Header BlockD -> Bool
(Header BlockD -> Header BlockD -> Bool)
-> (Header BlockD -> Header BlockD -> Bool) -> Eq (Header BlockD)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Header BlockD -> Header BlockD -> Bool
== :: Header BlockD -> Header BlockD -> Bool
$c/= :: Header BlockD -> Header BlockD -> Bool
/= :: Header BlockD -> Header BlockD -> Bool
Eq, (forall x. Header BlockD -> Rep (Header BlockD) x)
-> (forall x. Rep (Header BlockD) x -> Header BlockD)
-> Generic (Header BlockD)
forall x. Rep (Header BlockD) x -> Header BlockD
forall x. Header BlockD -> Rep (Header BlockD) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Header BlockD -> Rep (Header BlockD) x
from :: forall x. Header BlockD -> Rep (Header BlockD) x
$cto :: forall x. Rep (Header BlockD) x -> Header BlockD
to :: forall x. Rep (Header BlockD) x -> Header BlockD
Generic)
>   deriving anyclass ([Header BlockD] -> Encoding
Header BlockD -> Encoding
(Header BlockD -> Encoding)
-> (forall s. Decoder s (Header BlockD))
-> ([Header BlockD] -> Encoding)
-> (forall s. Decoder s [Header BlockD])
-> Serialise (Header BlockD)
forall s. Decoder s [Header BlockD]
forall s. Decoder s (Header BlockD)
forall a.
(a -> Encoding)
-> (forall s. Decoder s a)
-> ([a] -> Encoding)
-> (forall s. Decoder s [a])
-> Serialise a
$cencode :: Header BlockD -> Encoding
encode :: Header BlockD -> Encoding
$cdecode :: forall s. Decoder s (Header BlockD)
decode :: forall s. Decoder s (Header BlockD)
$cencodeList :: [Header BlockD] -> Encoding
encodeList :: [Header BlockD] -> Encoding
$cdecodeList :: forall s. Decoder s [Header BlockD]
decodeList :: forall s. Decoder s [Header BlockD]
Serialise)
>   deriving Context -> Header BlockD -> IO (Maybe ThunkInfo)
Proxy (Header BlockD) -> String
(Context -> Header BlockD -> IO (Maybe ThunkInfo))
-> (Context -> Header BlockD -> IO (Maybe ThunkInfo))
-> (Proxy (Header BlockD) -> String)
-> NoThunks (Header BlockD)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> Header BlockD -> IO (Maybe ThunkInfo)
noThunks :: Context -> Header BlockD -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> Header BlockD -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> Header BlockD -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy (Header BlockD) -> String
showTypeOf :: Proxy (Header BlockD) -> String
NoThunks via OnlyCheckWhnfNamed "HdrBlockD" (Header BlockD)


Block Hashing
-------------

Since we're using a more complicated hashing scheme for `BlockD` than we used
for `BlockC` we'll also need to specify how we compute hashes for `BlockD`.
First, we specify the type of `HeaderHash BlockD` to be the `Hash` type we
defined earlier:

> type instance HeaderHash BlockD = Hash

> instance StandardHash BlockD

Then we define a function `computeBlockHash` which computes a `Hash` for a
`BlockD` - basically aggregating all the data in the block besides the hash
itself:

> computeBlockHash :: BlockD -> Hash
> computeBlockHash :: BlockD -> Hash
computeBlockHash (BlockD Header BlockD
hdr [Tx]
body) =
>   (Word64, Word64, ChainHash BlockD, [Tx]) -> Hash
forall a. Hashable a => a -> Hash
mkHash ( SlotNo -> Word64
unSlotNo (Header BlockD -> SlotNo
hbd_SlotNo Header BlockD
hdr)
>          , BlockNo -> Word64
unBlockNo (Header BlockD -> BlockNo
hbd_BlockNo Header BlockD
hdr)
>          , Header BlockD -> ChainHash BlockD
hbd_prev Header BlockD
hdr
>          , [Tx]
body
>          )

Finally, a convenience function `addBlockHash` allows us to properly set the
hash of a `BlockD` to its computed value:

> addBlockHash :: BlockD -> BlockD
> addBlockHash :: BlockD -> BlockD
addBlockHash BlockD
b = BlockD
b { bd_header = header' }
>   where
>     header' :: Header BlockD
header' = (BlockD -> Header BlockD
bd_header BlockD
b) { hbd_Hash = computeBlockHash b }

The preceding definitions require that `ChainHash BlockD` be `Hashable` so we
derive a suitable instance here:

> deriving instance Hashable (ChainHash BlockD)


Block Header
------------

As before, we to implement a few type families to fully specify the header -
`GetHeader`, `GetPrevHash`, and `HasHeader`:

> instance GetHeader BlockD where
>   getHeader :: BlockD -> Header BlockD
getHeader          = BlockD -> Header BlockD
bd_header
>
>   blockMatchesHeader :: Header BlockD -> BlockD -> Bool
blockMatchesHeader Header BlockD
hdr BlockD
blk =
>     Header BlockD -> HeaderHash BlockD
hbd_Hash Header BlockD
hdr Hash -> Hash -> Bool
forall a. Eq a => a -> a -> Bool
== BlockD -> Hash
computeBlockHash BlockD
blk
>
>   headerIsEBB :: Header BlockD -> Maybe EpochNo
headerIsEBB      Header BlockD
_ = Maybe EpochNo
forall a. Maybe a
Nothing

> instance GetPrevHash BlockD where
>   headerPrevHash :: Header BlockD -> ChainHash BlockD
headerPrevHash = Header BlockD -> ChainHash BlockD
hbd_prev

> instance HasHeader (Header BlockD) where
>   getHeaderFields :: Header BlockD -> HeaderFields (Header BlockD)
getHeaderFields Header BlockD
hdr = HeaderFields
>                           { headerFieldSlot :: SlotNo
headerFieldSlot = Header BlockD -> SlotNo
hbd_SlotNo Header BlockD
hdr
>                           , headerFieldBlockNo :: BlockNo
headerFieldBlockNo = Header BlockD -> BlockNo
hbd_BlockNo Header BlockD
hdr
>                           , headerFieldHash :: HeaderHash (Header BlockD)
headerFieldHash = Header BlockD -> HeaderHash BlockD
hbd_Hash Header BlockD
hdr
>                           }

> instance HasHeader BlockD where
>   getHeaderFields :: BlockD -> HeaderFields BlockD
getHeaderFields = HeaderFields (Header BlockD) -> HeaderFields BlockD
forall {k1} {k2} (b :: k1) (b' :: k2).
(HeaderHash b ~ HeaderHash b') =>
HeaderFields b -> HeaderFields b'
castHeaderFields
>                   (HeaderFields (Header BlockD) -> HeaderFields BlockD)
-> (BlockD -> HeaderFields (Header BlockD))
-> BlockD
-> HeaderFields BlockD
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header BlockD -> HeaderFields (Header BlockD)
forall b. HasHeader b => b -> HeaderFields b
getHeaderFields
>                   (Header BlockD -> HeaderFields (Header BlockD))
-> (BlockD -> Header BlockD)
-> BlockD
-> HeaderFields (Header BlockD)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockD -> Header BlockD
bd_header

As part of our implementation of hashing, note that `blockMatchesHeader` in
`GetHeader` now checks that the hash is correct.

Block Configuration
-------------------

In this example, there is no interesting static configuration for blocks - so
the following are trivial instances:

> data instance CodecConfig BlockD = CCfgBlockD
>   deriving ((forall x. CodecConfig BlockD -> Rep (CodecConfig BlockD) x)
-> (forall x. Rep (CodecConfig BlockD) x -> CodecConfig BlockD)
-> Generic (CodecConfig BlockD)
forall x. Rep (CodecConfig BlockD) x -> CodecConfig BlockD
forall x. CodecConfig BlockD -> Rep (CodecConfig BlockD) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CodecConfig BlockD -> Rep (CodecConfig BlockD) x
from :: forall x. CodecConfig BlockD -> Rep (CodecConfig BlockD) x
$cto :: forall x. Rep (CodecConfig BlockD) x -> CodecConfig BlockD
to :: forall x. Rep (CodecConfig BlockD) x -> CodecConfig BlockD
Generic, Context -> CodecConfig BlockD -> IO (Maybe ThunkInfo)
Proxy (CodecConfig BlockD) -> String
(Context -> CodecConfig BlockD -> IO (Maybe ThunkInfo))
-> (Context -> CodecConfig BlockD -> IO (Maybe ThunkInfo))
-> (Proxy (CodecConfig BlockD) -> String)
-> NoThunks (CodecConfig BlockD)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> CodecConfig BlockD -> IO (Maybe ThunkInfo)
noThunks :: Context -> CodecConfig BlockD -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> CodecConfig BlockD -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> CodecConfig BlockD -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy (CodecConfig BlockD) -> String
showTypeOf :: Proxy (CodecConfig BlockD) -> String
NoThunks)

> data instance StorageConfig BlockD = SCfgBlockD
>   deriving ((forall x. StorageConfig BlockD -> Rep (StorageConfig BlockD) x)
-> (forall x. Rep (StorageConfig BlockD) x -> StorageConfig BlockD)
-> Generic (StorageConfig BlockD)
forall x. Rep (StorageConfig BlockD) x -> StorageConfig BlockD
forall x. StorageConfig BlockD -> Rep (StorageConfig BlockD) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. StorageConfig BlockD -> Rep (StorageConfig BlockD) x
from :: forall x. StorageConfig BlockD -> Rep (StorageConfig BlockD) x
$cto :: forall x. Rep (StorageConfig BlockD) x -> StorageConfig BlockD
to :: forall x. Rep (StorageConfig BlockD) x -> StorageConfig BlockD
Generic, Context -> StorageConfig BlockD -> IO (Maybe ThunkInfo)
Proxy (StorageConfig BlockD) -> String
(Context -> StorageConfig BlockD -> IO (Maybe ThunkInfo))
-> (Context -> StorageConfig BlockD -> IO (Maybe ThunkInfo))
-> (Proxy (StorageConfig BlockD) -> String)
-> NoThunks (StorageConfig BlockD)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> StorageConfig BlockD -> IO (Maybe ThunkInfo)
noThunks :: Context -> StorageConfig BlockD -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> StorageConfig BlockD -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> StorageConfig BlockD -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy (StorageConfig BlockD) -> String
showTypeOf :: Proxy (StorageConfig BlockD) -> String
NoThunks)

> data instance BlockConfig BlockD = BCfgBlockD
>   deriving ((forall x. BlockConfig BlockD -> Rep (BlockConfig BlockD) x)
-> (forall x. Rep (BlockConfig BlockD) x -> BlockConfig BlockD)
-> Generic (BlockConfig BlockD)
forall x. Rep (BlockConfig BlockD) x -> BlockConfig BlockD
forall x. BlockConfig BlockD -> Rep (BlockConfig BlockD) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. BlockConfig BlockD -> Rep (BlockConfig BlockD) x
from :: forall x. BlockConfig BlockD -> Rep (BlockConfig BlockD) x
$cto :: forall x. Rep (BlockConfig BlockD) x -> BlockConfig BlockD
to :: forall x. Rep (BlockConfig BlockD) x -> BlockConfig BlockD
Generic, Context -> BlockConfig BlockD -> IO (Maybe ThunkInfo)
Proxy (BlockConfig BlockD) -> String
(Context -> BlockConfig BlockD -> IO (Maybe ThunkInfo))
-> (Context -> BlockConfig BlockD -> IO (Maybe ThunkInfo))
-> (Proxy (BlockConfig BlockD) -> String)
-> NoThunks (BlockConfig BlockD)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> BlockConfig BlockD -> IO (Maybe ThunkInfo)
noThunks :: Context -> BlockConfig BlockD -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> BlockConfig BlockD -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> BlockConfig BlockD -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy (BlockConfig BlockD) -> String
showTypeOf :: Proxy (BlockConfig BlockD) -> String
NoThunks)


Validation
----------

Similarly, this example does not have any interesting validation logic, but a
few more trivial implementations are needed:

> instance HasAnnTip BlockD where {}
> instance ValidateEnvelope BlockD where {}
> instance BasicEnvelopeValidation BlockD where {}


Ledger
======

While this is similar to the `LedgerState` for `BlockC` the `Ledger` instance
corresponding to `BlockD` needs to hold snapshots of the count at the last two
epoch boundaries - this is the `lsbd_snapshot1` and `lsbd_snapshot2` fields
below:

> data instance LedgerState BlockD =
>   LedgerD
>     { LedgerState BlockD -> Point BlockD
lsbd_tip :: Point BlockD    -- ^ Point of the last applied block.
>                                   --   (Point is header hash and slot no.)
>     , LedgerState BlockD -> Word64
lsbd_count :: Word64        -- ^ results of the up/down Txs
>     , LedgerState BlockD -> Word64
lsbd_snapshot1 :: Word64    -- ^ snapshot of lsbd_count at
>                                   --   end of previous epoch (1 epoch ago)
>     , LedgerState BlockD -> Word64
lsbd_snapshot2 :: Word64    -- ^ snapshot of lsbd_count at end
>                                   --   of epoch (2 epochs ago)
>                                   --   This will be the LedgerView that
>                                   --   influences the leader schedule.
>     }
>   deriving (Int -> LedgerState BlockD -> ShowS
[LedgerState BlockD] -> ShowS
LedgerState BlockD -> String
(Int -> LedgerState BlockD -> ShowS)
-> (LedgerState BlockD -> String)
-> ([LedgerState BlockD] -> ShowS)
-> Show (LedgerState BlockD)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LedgerState BlockD -> ShowS
showsPrec :: Int -> LedgerState BlockD -> ShowS
$cshow :: LedgerState BlockD -> String
show :: LedgerState BlockD -> String
$cshowList :: [LedgerState BlockD] -> ShowS
showList :: [LedgerState BlockD] -> ShowS
Show, LedgerState BlockD -> LedgerState BlockD -> Bool
(LedgerState BlockD -> LedgerState BlockD -> Bool)
-> (LedgerState BlockD -> LedgerState BlockD -> Bool)
-> Eq (LedgerState BlockD)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LedgerState BlockD -> LedgerState BlockD -> Bool
== :: LedgerState BlockD -> LedgerState BlockD -> Bool
$c/= :: LedgerState BlockD -> LedgerState BlockD -> Bool
/= :: LedgerState BlockD -> LedgerState BlockD -> Bool
Eq, (forall x. LedgerState BlockD -> Rep (LedgerState BlockD) x)
-> (forall x. Rep (LedgerState BlockD) x -> LedgerState BlockD)
-> Generic (LedgerState BlockD)
forall x. Rep (LedgerState BlockD) x -> LedgerState BlockD
forall x. LedgerState BlockD -> Rep (LedgerState BlockD) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. LedgerState BlockD -> Rep (LedgerState BlockD) x
from :: forall x. LedgerState BlockD -> Rep (LedgerState BlockD) x
$cto :: forall x. Rep (LedgerState BlockD) x -> LedgerState BlockD
to :: forall x. Rep (LedgerState BlockD) x -> LedgerState BlockD
Generic, [LedgerState BlockD] -> Encoding
LedgerState BlockD -> Encoding
(LedgerState BlockD -> Encoding)
-> (forall s. Decoder s (LedgerState BlockD))
-> ([LedgerState BlockD] -> Encoding)
-> (forall s. Decoder s [LedgerState BlockD])
-> Serialise (LedgerState BlockD)
forall s. Decoder s [LedgerState BlockD]
forall s. Decoder s (LedgerState BlockD)
forall a.
(a -> Encoding)
-> (forall s. Decoder s a)
-> ([a] -> Encoding)
-> (forall s. Decoder s [a])
-> Serialise a
$cencode :: LedgerState BlockD -> Encoding
encode :: LedgerState BlockD -> Encoding
$cdecode :: forall s. Decoder s (LedgerState BlockD)
decode :: forall s. Decoder s (LedgerState BlockD)
$cencodeList :: [LedgerState BlockD] -> Encoding
encodeList :: [LedgerState BlockD] -> Encoding
$cdecodeList :: forall s. Decoder s [LedgerState BlockD]
decodeList :: forall s. Decoder s [LedgerState BlockD]
Serialise, Context -> LedgerState BlockD -> IO (Maybe ThunkInfo)
Proxy (LedgerState BlockD) -> String
(Context -> LedgerState BlockD -> IO (Maybe ThunkInfo))
-> (Context -> LedgerState BlockD -> IO (Maybe ThunkInfo))
-> (Proxy (LedgerState BlockD) -> String)
-> NoThunks (LedgerState BlockD)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> LedgerState BlockD -> IO (Maybe ThunkInfo)
noThunks :: Context -> LedgerState BlockD -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> LedgerState BlockD -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> LedgerState BlockD -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy (LedgerState BlockD) -> String
showTypeOf :: Proxy (LedgerState BlockD) -> String
NoThunks)

There is no interesting static configuration for this ledger:

> type instance LedgerCfg (LedgerState BlockD) = ()

Our `GetTip` implementation retrieves the tip from the `lsbd_tip` field:

> instance GetTip (Ticked (LedgerState BlockD)) where
>  getTip :: Ticked (LedgerState BlockD) -> Point (Ticked (LedgerState BlockD))
getTip = Point BlockD -> Point (Ticked (LedgerState BlockD))
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point BlockD -> Point (Ticked (LedgerState BlockD)))
-> (Ticked (LedgerState BlockD) -> Point BlockD)
-> Ticked (LedgerState BlockD)
-> Point (Ticked (LedgerState BlockD))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState BlockD -> Point BlockD
lsbd_tip (LedgerState BlockD -> Point BlockD)
-> (Ticked (LedgerState BlockD) -> LedgerState BlockD)
-> Ticked (LedgerState BlockD)
-> Point BlockD
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ticked (LedgerState BlockD) -> LedgerState BlockD
unTickedLedgerStateD

> instance GetTip (LedgerState BlockD) where
>   getTip :: LedgerState BlockD -> Point (LedgerState BlockD)
getTip = Point BlockD -> Point (LedgerState BlockD)
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point BlockD -> Point (LedgerState BlockD))
-> (LedgerState BlockD -> Point BlockD)
-> LedgerState BlockD
-> Point (LedgerState BlockD)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState BlockD -> Point BlockD
lsbd_tip

Ticking
-------

`LedgerState BlockD` also needs a corresponding `Ticked` instance which is still
very simple:

> newtype instance Ticked (LedgerState BlockD) =
>   TickedLedgerStateD {
>     Ticked (LedgerState BlockD) -> LedgerState BlockD
unTickedLedgerStateD :: LedgerState BlockD
>   }
>   deriving stock (Int -> Ticked (LedgerState BlockD) -> ShowS
[Ticked (LedgerState BlockD)] -> ShowS
Ticked (LedgerState BlockD) -> String
(Int -> Ticked (LedgerState BlockD) -> ShowS)
-> (Ticked (LedgerState BlockD) -> String)
-> ([Ticked (LedgerState BlockD)] -> ShowS)
-> Show (Ticked (LedgerState BlockD))
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Ticked (LedgerState BlockD) -> ShowS
showsPrec :: Int -> Ticked (LedgerState BlockD) -> ShowS
$cshow :: Ticked (LedgerState BlockD) -> String
show :: Ticked (LedgerState BlockD) -> String
$cshowList :: [Ticked (LedgerState BlockD)] -> ShowS
showList :: [Ticked (LedgerState BlockD)] -> ShowS
Show, Ticked (LedgerState BlockD) -> Ticked (LedgerState BlockD) -> Bool
(Ticked (LedgerState BlockD)
 -> Ticked (LedgerState BlockD) -> Bool)
-> (Ticked (LedgerState BlockD)
    -> Ticked (LedgerState BlockD) -> Bool)
-> Eq (Ticked (LedgerState BlockD))
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Ticked (LedgerState BlockD) -> Ticked (LedgerState BlockD) -> Bool
== :: Ticked (LedgerState BlockD) -> Ticked (LedgerState BlockD) -> Bool
$c/= :: Ticked (LedgerState BlockD) -> Ticked (LedgerState BlockD) -> Bool
/= :: Ticked (LedgerState BlockD) -> Ticked (LedgerState BlockD) -> Bool
Eq, (forall x.
 Ticked (LedgerState BlockD) -> Rep (Ticked (LedgerState BlockD)) x)
-> (forall x.
    Rep (Ticked (LedgerState BlockD)) x -> Ticked (LedgerState BlockD))
-> Generic (Ticked (LedgerState BlockD))
forall x.
Rep (Ticked (LedgerState BlockD)) x -> Ticked (LedgerState BlockD)
forall x.
Ticked (LedgerState BlockD) -> Rep (Ticked (LedgerState BlockD)) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x.
Ticked (LedgerState BlockD) -> Rep (Ticked (LedgerState BlockD)) x
from :: forall x.
Ticked (LedgerState BlockD) -> Rep (Ticked (LedgerState BlockD)) x
$cto :: forall x.
Rep (Ticked (LedgerState BlockD)) x -> Ticked (LedgerState BlockD)
to :: forall x.
Rep (Ticked (LedgerState BlockD)) x -> Ticked (LedgerState BlockD)
Generic)
>   deriving newtype (Context -> Ticked (LedgerState BlockD) -> IO (Maybe ThunkInfo)
Proxy (Ticked (LedgerState BlockD)) -> String
(Context -> Ticked (LedgerState BlockD) -> IO (Maybe ThunkInfo))
-> (Context -> Ticked (LedgerState BlockD) -> IO (Maybe ThunkInfo))
-> (Proxy (Ticked (LedgerState BlockD)) -> String)
-> NoThunks (Ticked (LedgerState BlockD))
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> Ticked (LedgerState BlockD) -> IO (Maybe ThunkInfo)
noThunks :: Context -> Ticked (LedgerState BlockD) -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> Ticked (LedgerState BlockD) -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> Ticked (LedgerState BlockD) -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy (Ticked (LedgerState BlockD)) -> String
showTypeOf :: Proxy (Ticked (LedgerState BlockD)) -> String
NoThunks, [Ticked (LedgerState BlockD)] -> Encoding
Ticked (LedgerState BlockD) -> Encoding
(Ticked (LedgerState BlockD) -> Encoding)
-> (forall s. Decoder s (Ticked (LedgerState BlockD)))
-> ([Ticked (LedgerState BlockD)] -> Encoding)
-> (forall s. Decoder s [Ticked (LedgerState BlockD)])
-> Serialise (Ticked (LedgerState BlockD))
forall s. Decoder s [Ticked (LedgerState BlockD)]
forall s. Decoder s (Ticked (LedgerState BlockD))
forall a.
(a -> Encoding)
-> (forall s. Decoder s a)
-> ([a] -> Encoding)
-> (forall s. Decoder s [a])
-> Serialise a
$cencode :: Ticked (LedgerState BlockD) -> Encoding
encode :: Ticked (LedgerState BlockD) -> Encoding
$cdecode :: forall s. Decoder s (Ticked (LedgerState BlockD))
decode :: forall s. Decoder s (Ticked (LedgerState BlockD))
$cencodeList :: [Ticked (LedgerState BlockD)] -> Encoding
encodeList :: [Ticked (LedgerState BlockD)] -> Encoding
$cdecodeList :: forall s. Decoder s [Ticked (LedgerState BlockD)]
decodeList :: forall s. Decoder s [Ticked (LedgerState BlockD)]
Serialise)

Because the ledger now needs to track the snapshots in `lsbd_snapshot1` and
`lsbd_snapshot2` we can express this in terms of ticking a `LedgerState BlockD`.
We'll write a function (that we'll use later) to express this relationship
computing the `Ticked (LedgerState BlockD)` resulting from a starting
`LedgerState BlockD` being ticked to some slot in the future - assuming no
intervening blocks are applied:

> tickLedgerStateD ::
>   SlotNo -> LedgerState BlockD -> Ticked (LedgerState BlockD)
> tickLedgerStateD :: SlotNo -> LedgerState BlockD -> Ticked (LedgerState BlockD)
tickLedgerStateD SlotNo
newSlot LedgerState BlockD
ldgrSt =
>   LedgerState BlockD -> Ticked (LedgerState BlockD)
TickedLedgerStateD (LedgerState BlockD -> Ticked (LedgerState BlockD))
-> LedgerState BlockD -> Ticked (LedgerState BlockD)
forall a b. (a -> b) -> a -> b
$
>     if Bool
isNewEpoch then
>       LedgerState BlockD
ldgrSt{ lsbd_snapshot2 = lsbd_snapshot1 ldgrSt
>                  -- save previous epoch snapshot (assumes we do not
>                  -- go a full epoch without ticking)
>             , lsbd_snapshot1 = lsbd_count ldgrSt
>                  -- snapshot the count (at end of previous epoch)
>             }
>     else
>       LedgerState BlockD
ldgrSt
>
>   where
>   isNewEpoch :: Bool
isNewEpoch =
>     case WithOrigin EpochNo -> WithOrigin EpochNo -> Ordering
forall a. Ord a => a -> a -> Ordering
compare
>            (WithOrigin SlotNo -> WithOrigin EpochNo
epochOf (Point BlockD -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot (Point BlockD -> WithOrigin SlotNo)
-> Point BlockD -> WithOrigin SlotNo
forall a b. (a -> b) -> a -> b
$ LedgerState BlockD -> Point BlockD
lsbd_tip LedgerState BlockD
ldgrSt)) -- epoch of last block added
>            (WithOrigin SlotNo -> WithOrigin EpochNo
epochOf (SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin SlotNo
newSlot))           -- epoch of newSlot
>     of
>       Ordering
LT -> Bool
True
>       Ordering
EQ -> Bool
False
>       Ordering
GT -> String -> Bool
forall a. HasCallStack => String -> a
error String
"cannot tick slots backwards"

Note that this implementation merely projects the current `lsbd_count` into the
snapshot indefinitely far in the future - consistent with the assumption that no
blocks are applied during the span of time represented by the slot argument.

We can now use `tickLedgerStateD` to instantiate `IsLedger`:

> instance IsLedger (LedgerState BlockD) where
>   type instance LedgerErr (LedgerState BlockD) = String
>   type instance AuxLedgerEvent (LedgerState BlockD) = ()
>
>   applyChainTickLedgerResult :: LedgerCfg (LedgerState BlockD)
-> SlotNo
-> LedgerState BlockD
-> LedgerResult (LedgerState BlockD) (Ticked (LedgerState BlockD))
applyChainTickLedgerResult LedgerCfg (LedgerState BlockD)
_cfg SlotNo
slot LedgerState BlockD
ldgrSt =
>     LedgerResult { lrEvents :: [AuxLedgerEvent (LedgerState BlockD)]
lrEvents = []
>                  , lrResult :: Ticked (LedgerState BlockD)
lrResult = SlotNo -> LedgerState BlockD -> Ticked (LedgerState BlockD)
tickLedgerStateD SlotNo
slot LedgerState BlockD
ldgrSt
>                  }

`UpdateLedger` is necessary but its implementation is always empty:

> instance UpdateLedger BlockD where {}

Applying Blocks
---------------

Applying a `BlockD` to a `Ticked (LedgerState BlockD)` is (again) the result of
applying each individual transaction - exactly as it was in for `BlockC`:

> applyBlockTo :: BlockD -> Ticked (LedgerState BlockD) -> LedgerState BlockD
> applyBlockTo :: BlockD -> Ticked (LedgerState BlockD) -> LedgerState BlockD
applyBlockTo BlockD
block Ticked (LedgerState BlockD)
tickedLedgerState =
>   LedgerState BlockD
ledgerState { lsbd_tip = blockPoint block
>               , lsbd_count = lsbc_count'
>               }
>   where
>     ledgerState :: LedgerState BlockD
ledgerState = Ticked (LedgerState BlockD) -> LedgerState BlockD
unTickedLedgerStateD Ticked (LedgerState BlockD)
tickedLedgerState
>     lsbc_count' :: Word64
lsbc_count' = (Word64 -> Tx -> Word64) -> Word64 -> [Tx] -> Word64
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Word64 -> Tx -> Word64
forall {a}. Num a => a -> Tx -> a
txDelta (LedgerState BlockD -> Word64
lsbd_count LedgerState BlockD
ledgerState) (BlockD -> [Tx]
bd_body BlockD
block)
>     txDelta :: a -> Tx -> a
txDelta a
i Tx
tx =
>       case Tx
tx of
>         Tx
Inc -> a
i a -> a -> a
forall a. Num a => a -> a -> a
+ a
1
>         Tx
Dec -> a
i a -> a -> a
forall a. Num a => a -> a -> a
- a
1

> instance ApplyBlock (LedgerState BlockD) BlockD where
>   applyBlockLedgerResult :: HasCallStack =>
LedgerCfg (LedgerState BlockD)
-> BlockD
-> Ticked (LedgerState BlockD)
-> Except
     (LedgerErr (LedgerState BlockD))
     (LedgerResult (LedgerState BlockD) (LedgerState BlockD))
applyBlockLedgerResult LedgerCfg (LedgerState BlockD)
_ldgrCfg BlockD
b Ticked (LedgerState BlockD)
tickedLdgrSt =
>     LedgerResult (LedgerState BlockD) (LedgerState BlockD)
-> ExceptT
     String
     Identity
     (LedgerResult (LedgerState BlockD) (LedgerState BlockD))
forall a. a -> ExceptT String Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LedgerResult { lrResult :: LedgerState BlockD
lrResult = BlockD
b BlockD -> Ticked (LedgerState BlockD) -> LedgerState BlockD
`applyBlockTo` Ticked (LedgerState BlockD)
tickedLdgrSt
>                       , lrEvents :: [AuxLedgerEvent (LedgerState BlockD)]
lrEvents = []
>                       }
>
>   reapplyBlockLedgerResult :: HasCallStack =>
LedgerCfg (LedgerState BlockD)
-> BlockD
-> Ticked (LedgerState BlockD)
-> LedgerResult (LedgerState BlockD) (LedgerState BlockD)
reapplyBlockLedgerResult LedgerCfg (LedgerState BlockD)
_ldgrCfg BlockD
b Ticked (LedgerState BlockD)
tickedLdgrSt =
>     LedgerResult { lrResult :: LedgerState BlockD
lrResult = BlockD
b BlockD -> Ticked (LedgerState BlockD) -> LedgerState BlockD
`applyBlockTo` Ticked (LedgerState BlockD)
tickedLdgrSt
>                  , lrEvents :: [AuxLedgerEvent (LedgerState BlockD)]
lrEvents = []
>                  }

Note that prior to `applyBlockLedgerResult` being invoked, the calling code will
have already established that the header is valid and that the header matches
the block.  As a result, we do not need to check that the leader is correct
here.  Also, for this tutorial's notion of blocks applying blocks cannot fail
because applying transactions cannot fail - even in cases where there is
overflow `Data.Word` will wrap around.

Protocol
========

Following the practice earlier established, we define an empty marker type for
the protocol - `PrtclD`:

> data PrtclD

However, due to the fact that ability to be a slot leader now depends on the
ledger we'll have a (slightly) more interesting set of evidence that a
particular `NodeId` can be a leader.  This just consists of the `NodeId` itself
- which is obviously insecure in that the proof we can be a leader should not be
easy to falsify - it is fine for our example:

> data PrtclD_CanBeLeader = PrtclD_CanBeLeader NodeId
>   deriving (PrtclD_CanBeLeader -> PrtclD_CanBeLeader -> Bool
(PrtclD_CanBeLeader -> PrtclD_CanBeLeader -> Bool)
-> (PrtclD_CanBeLeader -> PrtclD_CanBeLeader -> Bool)
-> Eq PrtclD_CanBeLeader
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PrtclD_CanBeLeader -> PrtclD_CanBeLeader -> Bool
== :: PrtclD_CanBeLeader -> PrtclD_CanBeLeader -> Bool
$c/= :: PrtclD_CanBeLeader -> PrtclD_CanBeLeader -> Bool
/= :: PrtclD_CanBeLeader -> PrtclD_CanBeLeader -> Bool
Eq, Int -> PrtclD_CanBeLeader -> ShowS
[PrtclD_CanBeLeader] -> ShowS
PrtclD_CanBeLeader -> String
(Int -> PrtclD_CanBeLeader -> ShowS)
-> (PrtclD_CanBeLeader -> String)
-> ([PrtclD_CanBeLeader] -> ShowS)
-> Show PrtclD_CanBeLeader
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PrtclD_CanBeLeader -> ShowS
showsPrec :: Int -> PrtclD_CanBeLeader -> ShowS
$cshow :: PrtclD_CanBeLeader -> String
show :: PrtclD_CanBeLeader -> String
$cshowList :: [PrtclD_CanBeLeader] -> ShowS
showList :: [PrtclD_CanBeLeader] -> ShowS
Show, (forall x. PrtclD_CanBeLeader -> Rep PrtclD_CanBeLeader x)
-> (forall x. Rep PrtclD_CanBeLeader x -> PrtclD_CanBeLeader)
-> Generic PrtclD_CanBeLeader
forall x. Rep PrtclD_CanBeLeader x -> PrtclD_CanBeLeader
forall x. PrtclD_CanBeLeader -> Rep PrtclD_CanBeLeader x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. PrtclD_CanBeLeader -> Rep PrtclD_CanBeLeader x
from :: forall x. PrtclD_CanBeLeader -> Rep PrtclD_CanBeLeader x
$cto :: forall x. Rep PrtclD_CanBeLeader x -> PrtclD_CanBeLeader
to :: forall x. Rep PrtclD_CanBeLeader x -> PrtclD_CanBeLeader
Generic, Context -> PrtclD_CanBeLeader -> IO (Maybe ThunkInfo)
Proxy PrtclD_CanBeLeader -> String
(Context -> PrtclD_CanBeLeader -> IO (Maybe ThunkInfo))
-> (Context -> PrtclD_CanBeLeader -> IO (Maybe ThunkInfo))
-> (Proxy PrtclD_CanBeLeader -> String)
-> NoThunks PrtclD_CanBeLeader
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> PrtclD_CanBeLeader -> IO (Maybe ThunkInfo)
noThunks :: Context -> PrtclD_CanBeLeader -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> PrtclD_CanBeLeader -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> PrtclD_CanBeLeader -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy PrtclD_CanBeLeader -> String
showTypeOf :: Proxy PrtclD_CanBeLeader -> String
NoThunks)

The proof that we are a slot leader should be evident from the context - the
combination of the slot number and the ledger's snapshot parity is sufficient
evidence that a particular node is the leader for that slot - this makes our
evidence that a particular node is the leader uninteresting given that security
is not being considered in this example:

> data PrtclD_IsLeader    = PrtclD_IsLeader

With some notions of the types involved in leadership defined, we can now
instantiate the `ConsensusConfig` with our security parameter as well as the
particular `NodeId` - expressed as a `PrtclD_CanBeLeader` - that a particular
instance of the `ConsensusProtocol` should be running as:

> data instance ConsensusConfig PrtclD =
>   PrtclD_Config
>     { ConsensusConfig PrtclD -> SecurityParam
ccpd_securityParam :: SecurityParam  -- ^ i.e., 'k'
>     , ConsensusConfig PrtclD -> Maybe PrtclD_CanBeLeader
ccpd_mbCanBeLeader :: Maybe PrtclD_CanBeLeader
>
>       -- ^ To lead, a node must have a 'ccpd_mbCanBeLeader' equal to
>       -- `Just (PrtclD_CanBeLeader nodeid)`.
>       -- We expect this value would be extracted from a config file.
>       --
>       -- Invariant: nodeid's are unique.
>     }
>   deriving (ConsensusConfig PrtclD -> ConsensusConfig PrtclD -> Bool
(ConsensusConfig PrtclD -> ConsensusConfig PrtclD -> Bool)
-> (ConsensusConfig PrtclD -> ConsensusConfig PrtclD -> Bool)
-> Eq (ConsensusConfig PrtclD)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ConsensusConfig PrtclD -> ConsensusConfig PrtclD -> Bool
== :: ConsensusConfig PrtclD -> ConsensusConfig PrtclD -> Bool
$c/= :: ConsensusConfig PrtclD -> ConsensusConfig PrtclD -> Bool
/= :: ConsensusConfig PrtclD -> ConsensusConfig PrtclD -> Bool
Eq, Int -> ConsensusConfig PrtclD -> ShowS
[ConsensusConfig PrtclD] -> ShowS
ConsensusConfig PrtclD -> String
(Int -> ConsensusConfig PrtclD -> ShowS)
-> (ConsensusConfig PrtclD -> String)
-> ([ConsensusConfig PrtclD] -> ShowS)
-> Show (ConsensusConfig PrtclD)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ConsensusConfig PrtclD -> ShowS
showsPrec :: Int -> ConsensusConfig PrtclD -> ShowS
$cshow :: ConsensusConfig PrtclD -> String
show :: ConsensusConfig PrtclD -> String
$cshowList :: [ConsensusConfig PrtclD] -> ShowS
showList :: [ConsensusConfig PrtclD] -> ShowS
Show)
>   deriving Context -> ConsensusConfig PrtclD -> IO (Maybe ThunkInfo)
Proxy (ConsensusConfig PrtclD) -> String
(Context -> ConsensusConfig PrtclD -> IO (Maybe ThunkInfo))
-> (Context -> ConsensusConfig PrtclD -> IO (Maybe ThunkInfo))
-> (Proxy (ConsensusConfig PrtclD) -> String)
-> NoThunks (ConsensusConfig PrtclD)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> ConsensusConfig PrtclD -> IO (Maybe ThunkInfo)
noThunks :: Context -> ConsensusConfig PrtclD -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> ConsensusConfig PrtclD -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> ConsensusConfig PrtclD -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy (ConsensusConfig PrtclD) -> String
showTypeOf :: Proxy (ConsensusConfig PrtclD) -> String
NoThunks via OnlyCheckWhnfNamed "PrtclD_Config"
>                         (ConsensusConfig PrtclD)

We will also need to have a view of the ledger that contains enough information
for the protocol to validate the leadership claim.  Since the leader for a slot
is determined by the parity of the epoch snapshot along with the slot number,
our `LedgerView` for `PrtclD` will simply be the snapshot (though we could have
just as easily used a `Bool` representing the parity):

> newtype LedgerViewD = LVD Word64
>   deriving stock (Int -> LedgerViewD -> ShowS
[LedgerViewD] -> ShowS
LedgerViewD -> String
(Int -> LedgerViewD -> ShowS)
-> (LedgerViewD -> String)
-> ([LedgerViewD] -> ShowS)
-> Show LedgerViewD
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LedgerViewD -> ShowS
showsPrec :: Int -> LedgerViewD -> ShowS
$cshow :: LedgerViewD -> String
show :: LedgerViewD -> String
$cshowList :: [LedgerViewD] -> ShowS
showList :: [LedgerViewD] -> ShowS
Show, LedgerViewD -> LedgerViewD -> Bool
(LedgerViewD -> LedgerViewD -> Bool)
-> (LedgerViewD -> LedgerViewD -> Bool) -> Eq LedgerViewD
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LedgerViewD -> LedgerViewD -> Bool
== :: LedgerViewD -> LedgerViewD -> Bool
$c/= :: LedgerViewD -> LedgerViewD -> Bool
/= :: LedgerViewD -> LedgerViewD -> Bool
Eq, (forall x. LedgerViewD -> Rep LedgerViewD x)
-> (forall x. Rep LedgerViewD x -> LedgerViewD)
-> Generic LedgerViewD
forall x. Rep LedgerViewD x -> LedgerViewD
forall x. LedgerViewD -> Rep LedgerViewD x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. LedgerViewD -> Rep LedgerViewD x
from :: forall x. LedgerViewD -> Rep LedgerViewD x
$cto :: forall x. Rep LedgerViewD x -> LedgerViewD
to :: forall x. Rep LedgerViewD x -> LedgerViewD
Generic)
>   deriving newtype ([LedgerViewD] -> Encoding
LedgerViewD -> Encoding
(LedgerViewD -> Encoding)
-> (forall s. Decoder s LedgerViewD)
-> ([LedgerViewD] -> Encoding)
-> (forall s. Decoder s [LedgerViewD])
-> Serialise LedgerViewD
forall s. Decoder s [LedgerViewD]
forall s. Decoder s LedgerViewD
forall a.
(a -> Encoding)
-> (forall s. Decoder s a)
-> ([a] -> Encoding)
-> (forall s. Decoder s [a])
-> Serialise a
$cencode :: LedgerViewD -> Encoding
encode :: LedgerViewD -> Encoding
$cdecode :: forall s. Decoder s LedgerViewD
decode :: forall s. Decoder s LedgerViewD
$cencodeList :: [LedgerViewD] -> Encoding
encodeList :: [LedgerViewD] -> Encoding
$cdecodeList :: forall s. Decoder s [LedgerViewD]
decodeList :: forall s. Decoder s [LedgerViewD]
Serialise, Context -> LedgerViewD -> IO (Maybe ThunkInfo)
Proxy LedgerViewD -> String
(Context -> LedgerViewD -> IO (Maybe ThunkInfo))
-> (Context -> LedgerViewD -> IO (Maybe ThunkInfo))
-> (Proxy LedgerViewD -> String)
-> NoThunks LedgerViewD
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> LedgerViewD -> IO (Maybe ThunkInfo)
noThunks :: Context -> LedgerViewD -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> LedgerViewD -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> LedgerViewD -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy LedgerViewD -> String
showTypeOf :: Proxy LedgerViewD -> String
NoThunks)

The parity of the epoch snapshot and the slot are together _sufficient_ to
determine the leadership schedule.  As such, we do not need any notion of state
specific to `PrtclD`:

> data ChainDepStateD = ChainDepStateD
>   deriving (ChainDepStateD -> ChainDepStateD -> Bool
(ChainDepStateD -> ChainDepStateD -> Bool)
-> (ChainDepStateD -> ChainDepStateD -> Bool) -> Eq ChainDepStateD
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ChainDepStateD -> ChainDepStateD -> Bool
== :: ChainDepStateD -> ChainDepStateD -> Bool
$c/= :: ChainDepStateD -> ChainDepStateD -> Bool
/= :: ChainDepStateD -> ChainDepStateD -> Bool
Eq,Int -> ChainDepStateD -> ShowS
[ChainDepStateD] -> ShowS
ChainDepStateD -> String
(Int -> ChainDepStateD -> ShowS)
-> (ChainDepStateD -> String)
-> ([ChainDepStateD] -> ShowS)
-> Show ChainDepStateD
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ChainDepStateD -> ShowS
showsPrec :: Int -> ChainDepStateD -> ShowS
$cshow :: ChainDepStateD -> String
show :: ChainDepStateD -> String
$cshowList :: [ChainDepStateD] -> ShowS
showList :: [ChainDepStateD] -> ShowS
Show,(forall x. ChainDepStateD -> Rep ChainDepStateD x)
-> (forall x. Rep ChainDepStateD x -> ChainDepStateD)
-> Generic ChainDepStateD
forall x. Rep ChainDepStateD x -> ChainDepStateD
forall x. ChainDepStateD -> Rep ChainDepStateD x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ChainDepStateD -> Rep ChainDepStateD x
from :: forall x. ChainDepStateD -> Rep ChainDepStateD x
$cto :: forall x. Rep ChainDepStateD x -> ChainDepStateD
to :: forall x. Rep ChainDepStateD x -> ChainDepStateD
Generic,Context -> ChainDepStateD -> IO (Maybe ThunkInfo)
Proxy ChainDepStateD -> String
(Context -> ChainDepStateD -> IO (Maybe ThunkInfo))
-> (Context -> ChainDepStateD -> IO (Maybe ThunkInfo))
-> (Proxy ChainDepStateD -> String)
-> NoThunks ChainDepStateD
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> ChainDepStateD -> IO (Maybe ThunkInfo)
noThunks :: Context -> ChainDepStateD -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> ChainDepStateD -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> ChainDepStateD -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy ChainDepStateD -> String
showTypeOf :: Proxy ChainDepStateD -> String
NoThunks)

However, the `Ticked` representation contains the `LedgerViewD` containing the
epoch snapshot.  This is due to functions for `ConsensusProtocol` only taking
the `LedgerView` as an argument in some cases:

> data instance Ticked ChainDepStateD =
>   TickedChainDepStateD { Ticked ChainDepStateD -> LedgerViewD
tickedChainDepLV :: LedgerViewD }
>   deriving (Ticked ChainDepStateD -> Ticked ChainDepStateD -> Bool
(Ticked ChainDepStateD -> Ticked ChainDepStateD -> Bool)
-> (Ticked ChainDepStateD -> Ticked ChainDepStateD -> Bool)
-> Eq (Ticked ChainDepStateD)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Ticked ChainDepStateD -> Ticked ChainDepStateD -> Bool
== :: Ticked ChainDepStateD -> Ticked ChainDepStateD -> Bool
$c/= :: Ticked ChainDepStateD -> Ticked ChainDepStateD -> Bool
/= :: Ticked ChainDepStateD -> Ticked ChainDepStateD -> Bool
Eq, Int -> Ticked ChainDepStateD -> ShowS
[Ticked ChainDepStateD] -> ShowS
Ticked ChainDepStateD -> String
(Int -> Ticked ChainDepStateD -> ShowS)
-> (Ticked ChainDepStateD -> String)
-> ([Ticked ChainDepStateD] -> ShowS)
-> Show (Ticked ChainDepStateD)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Ticked ChainDepStateD -> ShowS
showsPrec :: Int -> Ticked ChainDepStateD -> ShowS
$cshow :: Ticked ChainDepStateD -> String
show :: Ticked ChainDepStateD -> String
$cshowList :: [Ticked ChainDepStateD] -> ShowS
showList :: [Ticked ChainDepStateD] -> ShowS
Show, (forall x. Ticked ChainDepStateD -> Rep (Ticked ChainDepStateD) x)
-> (forall x.
    Rep (Ticked ChainDepStateD) x -> Ticked ChainDepStateD)
-> Generic (Ticked ChainDepStateD)
forall x. Rep (Ticked ChainDepStateD) x -> Ticked ChainDepStateD
forall x. Ticked ChainDepStateD -> Rep (Ticked ChainDepStateD) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Ticked ChainDepStateD -> Rep (Ticked ChainDepStateD) x
from :: forall x. Ticked ChainDepStateD -> Rep (Ticked ChainDepStateD) x
$cto :: forall x. Rep (Ticked ChainDepStateD) x -> Ticked ChainDepStateD
to :: forall x. Rep (Ticked ChainDepStateD) x -> Ticked ChainDepStateD
Generic, Context -> Ticked ChainDepStateD -> IO (Maybe ThunkInfo)
Proxy (Ticked ChainDepStateD) -> String
(Context -> Ticked ChainDepStateD -> IO (Maybe ThunkInfo))
-> (Context -> Ticked ChainDepStateD -> IO (Maybe ThunkInfo))
-> (Proxy (Ticked ChainDepStateD) -> String)
-> NoThunks (Ticked ChainDepStateD)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> Ticked ChainDepStateD -> IO (Maybe ThunkInfo)
noThunks :: Context -> Ticked ChainDepStateD -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> Ticked ChainDepStateD -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> Ticked ChainDepStateD -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy (Ticked ChainDepStateD) -> String
showTypeOf :: Proxy (Ticked ChainDepStateD) -> String
NoThunks)

`ConsensusProtocol` is set up this way mostly because this is what
implementations thus far have required, but the organization of the functions
interacting with `ChainDepState` is currently under review.

We can determine if a particular node is the leader of a slot given the slot
number along with the epoch snapshot.  We can express this determination via a
function modeling the leadership schedule.  For ease of use in our instantiation
of `ConsensusProtocol PrtclD` we will represent the epoch snapshot using the
`LedgerView` we just defined:

> isLeader :: NodeId -> SlotNo -> LedgerView PrtclD -> Bool
> isLeader :: Word64 -> SlotNo -> LedgerView PrtclD -> Bool
isLeader Word64
nodeId (SlotNo Word64
slot) (LVD Word64
cntr) =
>   case Word64
cntr Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`mod` Word64
2 of
>     -- nodes [0..9]   do round-robin (if even cntr)
>     Word64
0 -> Word64
slot Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`mod` Word64
10      Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
nodeId
>     -- nodes [10..19] do round-robin (if odd cntr)
>     Word64
1 -> (Word64
slot Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`mod` Word64
10)Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+Word64
10 Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
nodeId
>     Word64
_ -> String -> Bool
forall a. HasCallStack => String -> a
error String
"panic: the impossible ..."

Now we can instantiate `ConsensusProtocol PrtclD` proper with the types and
functions defined above:

> instance ConsensusProtocol PrtclD where
>
>   type ChainDepState PrtclD = ChainDepStateD
>   type IsLeader PrtclD = PrtclD_IsLeader
>   type CanBeLeader PrtclD = PrtclD_CanBeLeader
>
>   -- | View on a block header required for chain selection.  Here, BlockNo is
>   --   sufficient. (BlockNo is also the default type for this type family.)
>   type SelectView PrtclD = BlockNo
>
>   -- | View on the ledger required by the protocol
>   type LedgerView PrtclD = LedgerViewD
>
>   -- | View on a block header required for header validation
>   type ValidateView  PrtclD = NodeId  -- need this for the leader check
>                                       -- currently not doing other checks
>
>   type ValidationErr PrtclD = String
>
>   -- | checkIsLeader - Am I the leader this slot?
>   checkIsLeader :: HasCallStack =>
ConsensusConfig PrtclD
-> CanBeLeader PrtclD
-> SlotNo
-> Ticked (ChainDepState PrtclD)
-> Maybe (IsLeader PrtclD)
checkIsLeader ConsensusConfig PrtclD
cfg CanBeLeader PrtclD
_cbl SlotNo
slot Ticked (ChainDepState PrtclD)
tcds =
>     case ConsensusConfig PrtclD -> Maybe PrtclD_CanBeLeader
ccpd_mbCanBeLeader ConsensusConfig PrtclD
cfg of
>       Just (PrtclD_CanBeLeader Word64
nodeId)
>         -- not providing any cryptographic proof
>         | Word64 -> SlotNo -> LedgerView PrtclD -> Bool
isLeader Word64
nodeId SlotNo
slot (Ticked ChainDepStateD -> LedgerViewD
tickedChainDepLV Ticked (ChainDepState PrtclD)
Ticked ChainDepStateD
tcds) -> PrtclD_IsLeader -> Maybe PrtclD_IsLeader
forall a. a -> Maybe a
Just PrtclD_IsLeader
PrtclD_IsLeader
>       Maybe PrtclD_CanBeLeader
_                             -> Maybe (IsLeader PrtclD)
Maybe PrtclD_IsLeader
forall a. Maybe a
Nothing
>
>   protocolSecurityParam :: ConsensusConfig PrtclD -> SecurityParam
protocolSecurityParam = ConsensusConfig PrtclD -> SecurityParam
ccpd_securityParam
>
>   tickChainDepState :: ConsensusConfig PrtclD
-> LedgerView PrtclD
-> SlotNo
-> ChainDepState PrtclD
-> Ticked (ChainDepState PrtclD)
tickChainDepState ConsensusConfig PrtclD
_cfg LedgerView PrtclD
lv SlotNo
_slot ChainDepState PrtclD
_cds = LedgerViewD -> Ticked ChainDepStateD
TickedChainDepStateD LedgerView PrtclD
LedgerViewD
lv
>
>   -- | apply the header (hdrView) and do a header check.
>   --
>   -- Here we check the block's claim to lead the slot (though in Protocol D,
>   -- this doesn't give us too much confidence, as there is nothing that
>   -- precludes a node from masquerading as any other node).
>
>   updateChainDepState :: HasCallStack =>
ConsensusConfig PrtclD
-> ValidateView PrtclD
-> SlotNo
-> Ticked (ChainDepState PrtclD)
-> Except (ValidationErr PrtclD) (ChainDepState PrtclD)
updateChainDepState ConsensusConfig PrtclD
_cfg ValidateView PrtclD
hdrView SlotNo
slot Ticked (ChainDepState PrtclD)
tcds =
>     if Word64 -> SlotNo -> LedgerView PrtclD -> Bool
isLeader Word64
ValidateView PrtclD
hdrView SlotNo
slot (Ticked ChainDepStateD -> LedgerViewD
tickedChainDepLV Ticked (ChainDepState PrtclD)
Ticked ChainDepStateD
tcds) then
>       ChainDepStateD -> ExceptT String Identity ChainDepStateD
forall a. a -> ExceptT String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ChainDepStateD
ChainDepStateD
>     else
>       String -> Except (ValidationErr PrtclD) (ChainDepState PrtclD)
forall a. String -> ExceptT (ValidationErr PrtclD) Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Except (ValidationErr PrtclD) (ChainDepState PrtclD))
-> String -> Except (ValidationErr PrtclD) (ChainDepState PrtclD)
forall a b. (a -> b) -> a -> b
$ String
"leader check failed: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Word64, SlotNo) -> String
forall a. Show a => a -> String
show (Word64
ValidateView PrtclD
hdrView,SlotNo
slot)
>
>   reupdateChainDepState :: HasCallStack =>
ConsensusConfig PrtclD
-> ValidateView PrtclD
-> SlotNo
-> Ticked (ChainDepState PrtclD)
-> ChainDepState PrtclD
reupdateChainDepState ConsensusConfig PrtclD
_ ValidateView PrtclD
_ SlotNo
_ Ticked (ChainDepState PrtclD)
_ = ChainDepState PrtclD
ChainDepStateD
ChainDepStateD

Integration
===========

Block/Protocol Integration
--------------------------

Our implementation of `BlockSupportsProtocol BlockD` supports our definition of
`ConsensusProtocol PrtclD` closely, with `validateView` extracting the `NodeId`
from the block header, and `selectView` projecting out the block number:

> instance BlockSupportsProtocol BlockD where
>   validateView :: BlockConfig BlockD
-> Header BlockD -> ValidateView (BlockProtocol BlockD)
validateView BlockConfig BlockD
_bcfg Header BlockD
hdr = Header BlockD -> Word64
hbd_nodeId Header BlockD
hdr
>
>   selectView :: BlockConfig BlockD
-> Header BlockD -> SelectView (BlockProtocol BlockD)
selectView BlockConfig BlockD
_bcfg Header BlockD
hdr = Header BlockD -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo Header BlockD
hdr

All that remains is to establish `PrtclD` as the protocol for
`BlockD`:

> type instance BlockProtocol BlockD = PrtclD

Ledger/Protocol Integration
---------------------------

Implementing `LedgerSupportsProtocol` requires us to put a little more thought
into forecasting.  Our range of forecasting now ends at the last slot in the
following epoch.  There are two cases for which we can forecast the ticked
ledger view: (1) the slot (`for` in the code below) is in the current epoch and
(2) the slot is in the following epoch.

> instance LedgerSupportsProtocol BlockD where
>   protocolLedgerView :: LedgerCfg (LedgerState BlockD)
-> Ticked (LedgerState BlockD) -> LedgerView (BlockProtocol BlockD)
protocolLedgerView LedgerCfg (LedgerState BlockD)
_ldgrCfg (TickedLedgerStateD LedgerState BlockD
ldgrSt) =
>     Word64 -> LedgerViewD
LVD (Word64 -> LedgerViewD) -> Word64 -> LedgerViewD
forall a b. (a -> b) -> a -> b
$ LedgerState BlockD -> Word64
lsbd_snapshot2 LedgerState BlockD
ldgrSt
>       -- note that we use the snapshot from 2 epochs ago.
>
>   -- | Borrowing somewhat from Ouroboros/Consensus/Byron/Ledger/Ledger.hs
>   ledgerViewForecastAt :: HasCallStack =>
LedgerCfg (LedgerState BlockD)
-> LedgerState BlockD
-> Forecast (LedgerView (BlockProtocol BlockD))
ledgerViewForecastAt LedgerCfg (LedgerState BlockD)
_lccf LedgerState BlockD
ldgrSt =
>     Forecast { forecastAt :: WithOrigin SlotNo
forecastAt = WithOrigin SlotNo
at
>              , forecastFor :: SlotNo -> Except OutsideForecastRange LedgerViewD
forecastFor = \SlotNo
for->
>                  if SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin SlotNo
for WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< WithOrigin SlotNo
at then
>                    String -> Except OutsideForecastRange LedgerViewD
forall a. HasCallStack => String -> a
error String
"this precondition violated: 'NotOrigin for < at'"
>                  else if SlotNo
for SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
>= SlotNo
maxFor then
>                    OutsideForecastRange -> Except OutsideForecastRange LedgerViewD
forall a.
OutsideForecastRange -> ExceptT OutsideForecastRange Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
>                      OutsideForecastRange
>                         { outsideForecastAt :: WithOrigin SlotNo
outsideForecastAt     = WithOrigin SlotNo
at
>                         , outsideForecastMaxFor :: SlotNo
outsideForecastMaxFor = SlotNo
maxFor
>                         , outsideForecastFor :: SlotNo
outsideForecastFor    = SlotNo
for
>                         }
>                  else
>                    LedgerViewD -> Except OutsideForecastRange LedgerViewD
forall a. a -> ExceptT OutsideForecastRange Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return
>                      (LedgerViewD -> Except OutsideForecastRange LedgerViewD)
-> LedgerViewD -> Except OutsideForecastRange LedgerViewD
forall a b. (a -> b) -> a -> b
$ Word64 -> LedgerViewD
LVD
>                      (Word64 -> LedgerViewD) -> Word64 -> LedgerViewD
forall a b. (a -> b) -> a -> b
$ if SlotNo
for SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< WithOrigin SlotNo -> SlotNo
nextEpochStartSlot WithOrigin SlotNo
at then
>                          LedgerState BlockD -> Word64
lsbd_snapshot2 LedgerState BlockD
ldgrSt
>                            -- for the rest of the current epoch,
>                            -- it's the same as 'protocolLedgerView',
>                            -- using snapshot from 2 epochs ago.
>                        else
>                          LedgerState BlockD -> Word64
lsbd_snapshot1 LedgerState BlockD
ldgrSt
>                            -- we can forecast into the following epoch because
>                            -- we have the snapshot from 1 epoch ago.
>              }
>
>     where
>     -- | the current slot that the ledger reflects
>     at :: WithOrigin SlotNo
>     at :: WithOrigin SlotNo
at = Point BlockD -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot (Point BlockD -> WithOrigin SlotNo)
-> Point BlockD -> WithOrigin SlotNo
forall a b. (a -> b) -> a -> b
$ LedgerState BlockD -> Point BlockD
lsbd_tip LedgerState BlockD
ldgrSt
>
>     -- | 'maxFor' is the "exclusive upper bound on the range of the forecast"
>     -- (the name "max" does seem wrong, but we are following suit with the names
>     -- and terminology in the 'Ouroboros.Consensus.Forecast' module)
>     --
>     -- In our case we can forecast for the current epoch and the following
>     -- epoch.  The forecast becomes unknown at the start of the epoch
>     -- after the following epoch:
>     maxFor :: SlotNo
>     maxFor :: SlotNo
maxFor = WithOrigin SlotNo -> SlotNo
nextEpochStartSlot WithOrigin SlotNo
at SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ Word64 -> SlotNo
SlotNo Word64
slotsInEpoch

Summary and Review
==================

Above, we defined a block, ledger, and consensus protocol as well as wrote the
class/family instances necessary to connect them together.  The behavior of the
blockchain modeled by these is very simple and does not deal with security
considerations in any depth but does implement behavior - the leadership
schedule - such that the valid future states of the chain depend on the value
(aka `LedgerState`) computed by the chain in previous epochs.

To review, we made a few changes from our even more trivial prior example
involving `BlockC`:

- We implemented a slightly more realistic version of hashing
- Nodes participating in the protocols were given identifiers allowing a less
  trivial version of leadership to be implemented
- A node identifier was added to our block type
- The `LedgerState` for our block type required the relevant data to be
  snapshotted so that it could be tracked
- The logic for applying blocks to the ledger in `ApplyBlock` needed to be aware
  of the epoch changes such that it could update the snapshots accordingly when
  blocks are applied
- The `checkIsLeader` in the protocol changed to reflect the leadership schedule
- The protocol's `LedgerView` also needed access to the relevant snapshot for
  the epoch
- Forecasting, as implemented in `LedgerSupportsProtocol`, needed to know when
  to stop being able to forecast - namely when the supply of snapshot data is
  exhausted

While this is a large ecosystem of interrelated typeclasses and families, the
overall organization of things is such that Haskell's type checking can help
guide the implementation.