[ADP-3350] Add Read.ChainTip type (#4541)

This pull request adds a data type `ChainTip` to the
`Cardano.Wallet.Read` hierarchy.

This type `ChainTip` is used in the ChainSync protocol to advertise the
tip of the server's chain. It combines the information of a `ChainPoint`
with a `BlockNo`.

This pull requests also adds

* Conversions to/from types in `ouroboros-consensus` for the networking
layer

### Comments

* The `NetworkLayer` currently uses the `BlockHeader` type for
advertising the tip of the chain. However, this is strictly speaking
incorrect, as the `BlockHeader` also includes a reference to the
previous block header, which `ChainTip` does not. In the legacy code, we
currently invent a value out of thin air — the new type `ChainTip` is
more correct.
* Subsequent pull requests will change the `NetworkLayer` interface to
use `Read.ChainPoint` and `Read.ChainTip`.

### Issue Number

ADP-3350

lib/network-layer/src/Cardano/Wallet/Network/Implementation/Types.hs

@@ -8,13 +8,17 @@ and "Cardano.Wallet.Read".
 module Cardano.Wallet.Network.Implementation.Types
     ( fromOuroborosPoint
     , toOuroborosPoint
+    , fromOuroborosTip
+    , toOuroborosTip
     ) where
 
 import Prelude
 
 import Cardano.Wallet.Read
     ( BHeader
+    , BlockNo (..)
     , ChainPoint (..)
+    , ChainTip (..)
     , SlotNo (..)
     )
 import Cardano.Wallet.Read.Hash
@@ -46,20 +50,48 @@ toOuroborosPoint GenesisPoint =
 toOuroborosPoint (BlockPoint slot h) =
     O.BlockPoint (toCardanoSlotNo slot) (toCardanoHash h)
 
-toCardanoSlotNo :: SlotNo -> O.SlotNo
-toCardanoSlotNo (SlotNo slot) = O.SlotNo (toEnum $ fromEnum slot)
-
-toCardanoHash :: Hash Blake2b_256 BHeader -> OneEraHash (CardanoEras sc)
-toCardanoHash = OneEraHash . hashToBytesShort
-
 fromOuroborosPoint :: O.Point (CardanoBlock sc) -> ChainPoint
 fromOuroborosPoint O.GenesisPoint =
     GenesisPoint
 fromOuroborosPoint (O.BlockPoint slot h) =
     BlockPoint (fromCardanoSlotNo slot) (fromCardanoHash h)
 
+{-----------------------------------------------------------------------------
+    ChainTip conversions
+------------------------------------------------------------------------------}
+
+toOuroborosTip :: ChainTip -> O.Tip (CardanoBlock sc)
+toOuroborosTip GenesisTip =
+    O.TipGenesis
+toOuroborosTip (BlockTip slot h blockNo) =
+    O.Tip (toCardanoSlotNo slot) (toCardanoHash h) (toCardanoBlockNo blockNo)
+
+fromOuroborosTip :: O.Tip (CardanoBlock sc) -> ChainTip
+fromOuroborosTip O.TipGenesis =
+    GenesisTip
+fromOuroborosTip (O.Tip slot h blockNo) =
+    BlockTip
+        (fromCardanoSlotNo slot)
+        (fromCardanoHash h)
+        (fromCardanoBlockNo blockNo)
+
+{-----------------------------------------------------------------------------
+    Helper conversions
+------------------------------------------------------------------------------}
+toCardanoSlotNo :: SlotNo -> O.SlotNo
+toCardanoSlotNo (SlotNo slot) = O.SlotNo (toEnum $ fromEnum slot)
+
 fromCardanoSlotNo :: O.SlotNo -> SlotNo
 fromCardanoSlotNo (O.SlotNo slot) = SlotNo (fromIntegral slot)
 
+toCardanoHash :: Hash Blake2b_256 BHeader -> OneEraHash (CardanoEras sc)
+toCardanoHash = OneEraHash . hashToBytesShort
+
 fromCardanoHash :: OneEraHash (CardanoEras sc) -> Hash Blake2b_256 BHeader
 fromCardanoHash = fromJust . hashFromBytesShort . getOneEraHash
+
+toCardanoBlockNo :: BlockNo -> O.BlockNo
+toCardanoBlockNo (BlockNo blockNo) = O.BlockNo (toEnum $ fromEnum blockNo)
+
+fromCardanoBlockNo :: O.BlockNo -> BlockNo
+fromCardanoBlockNo (O.BlockNo blockNo) = BlockNo (fromIntegral blockNo)

lib/read/lib/Cardano/Wallet/Read/Block/BlockNo.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
@@ -27,6 +28,12 @@ import Cardano.Wallet.Read.Eras.KnownEras
     ( Era (..)
     , IsEra (..)
     )
+import GHC.Generics
+    ( Generic
+    )
+import NoThunks.Class
+    ( NoThunks (..)
+    )
 import Numeric.Natural
     ( Natural
     )
@@ -58,7 +65,9 @@ getEraBlockNo = case theEra @era of
     k = BlockNo . fromIntegral . O.unBlockNo
 
 newtype BlockNo = BlockNo {unBlockNo :: Natural}
-    deriving (Eq, Show, Enum)
+    deriving (Eq, Ord, Show, Generic, Enum)
+
+instance NoThunks BlockNo
 
 getBlockNoShelley
     :: (L.Era era, EncCBORGroup (TxSeq era), Crypto c)

lib/read/lib/Cardano/Wallet/Read/Chain.hs

@@ -6,17 +6,26 @@ License: Apache-2.0
 Data types relating to the consensus about the blockchain.
 -}
 module Cardano.Wallet.Read.Chain
-    ( ChainPoint (GenesisPoint, BlockPoint)
+    ( -- * ChainPoint
+      ChainPoint (GenesisPoint, BlockPoint)
     , getChainPoint
     , prettyChainPoint
+    , chainPointFromChainTip
+
+    -- * ChainTip
+    , ChainTip (GenesisTip, BlockTip)
+    , getChainTip
+    , prettyChainTip
     ) where
 
 import Prelude
 
 import Cardano.Wallet.Read.Block
     ( Block
+    , BlockNo (..)
     , RawHeaderHash
     , SlotNo (..)
+    , getEraBlockNo
     , getEraHeaderHash
     , getEraSlotNo
     , getRawHeaderHash
@@ -62,3 +71,42 @@ prettyChainPoint (BlockPoint slot hash) =
   where
     hashF = T.take 8 . Hash.hashToTextAsHex
     slotF (SlotNo n) = T.pack (show n)
+
+chainPointFromChainTip :: ChainTip -> ChainPoint
+chainPointFromChainTip GenesisTip = GenesisPoint
+chainPointFromChainTip (BlockTip slot hash _) = BlockPoint slot hash
+
+{-----------------------------------------------------------------------------
+    Tip
+------------------------------------------------------------------------------}
+
+-- | Used in chain-sync protocol to advertise the tip of the server's chain.
+-- Records the 'ChainPoint' and the 'BlockNo' of the block.
+data ChainTip
+    = GenesisTip
+    | BlockTip !SlotNo !RawHeaderHash !BlockNo
+    deriving (Eq, Ord, Show, Generic)
+
+instance NoThunks ChainTip
+
+{-# INLINABLE getChainTip #-}
+getChainTip :: IsEra era => Block era -> ChainTip
+getChainTip block =
+    BlockTip
+        (getEraSlotNo block)
+        (getRawHeaderHash $ getEraHeaderHash block)
+        (getEraBlockNo block)
+
+-- | Short printed representation of a 'ChainPoint'.
+prettyChainTip :: ChainTip -> T.Text
+prettyChainTip GenesisTip =
+    "[tip genesis]"
+prettyChainTip (BlockTip slotNo hash blockNo) =
+    "[tip " <> hashF hash
+        <> " at slot " <> slotNoF slotNo
+        <> " at blockNo " <> blockNoF blockNo
+        <> "]"
+  where
+    hashF = T.take 8 . Hash.hashToTextAsHex
+    slotNoF (SlotNo n) = T.pack (show n)
+    blockNoF (BlockNo n) = T.pack (show n)