[ADP-3229] Move blockheader and block types to primitive lib (#4246)

Another primitive migration

- [x] Move BlockHeader, Block, PoolId, DelegationCertificate to
primitive lib

lib/primitive/cardano-wallet-primitive.cabal

@@ -97,19 +97,23 @@ library
     Cardano.Wallet.Primitive.NetworkId
     Cardano.Wallet.Primitive.Types.Address
     Cardano.Wallet.Primitive.Types.Address.Gen
+    Cardano.Wallet.Primitive.Types.Block
     Cardano.Wallet.Primitive.Types.Coin
     Cardano.Wallet.Primitive.Types.Coin.Gen
     Cardano.Wallet.Primitive.Types.DecentralizationLevel
+    Cardano.Wallet.Primitive.Types.DelegationCertificate
     Cardano.Wallet.Primitive.Types.EpochNo
     Cardano.Wallet.Primitive.Types.EraInfo
     Cardano.Wallet.Primitive.Types.ExecutionUnitPrices
     Cardano.Wallet.Primitive.Types.FeePolicy
     Cardano.Wallet.Primitive.Types.Hash
+    Cardano.Wallet.Primitive.Types.PoolId
     Cardano.Wallet.Primitive.Types.ProtocolMagic
     Cardano.Wallet.Primitive.Types.ProtocolParameters
     Cardano.Wallet.Primitive.Types.RewardAccount
     Cardano.Wallet.Primitive.Types.RewardAccount.Gen
     Cardano.Wallet.Primitive.Types.SlottingParameters
+    Cardano.Wallet.Primitive.Types.StakePoolSummary
     Cardano.Wallet.Primitive.Types.TokenBundle
     Cardano.Wallet.Primitive.Types.TokenBundle.Gen
     Cardano.Wallet.Primitive.Types.TokenBundleMaxSize
@@ -184,6 +188,7 @@ test-suite test
     Cardano.Wallet.Primitive.Types.AddressSpec
     Cardano.Wallet.Primitive.Types.CoinSpec
     Cardano.Wallet.Primitive.Types.HashSpec
+    Cardano.Wallet.Primitive.Types.PoolIdSpec
     Cardano.Wallet.Primitive.Types.TokenBundleSpec
     Cardano.Wallet.Primitive.Types.TokenMapSpec
     Cardano.Wallet.Primitive.Types.TokenPolicySpec

lib/primitive/lib/Cardano/Wallet/Primitive/Types/Block.hs

@@ -0,0 +1,180 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE RecordWildCards #-}
+
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Cardano.Wallet.Primitive.Types.Block
+    ( Block (..)
+    , BlockHeader (..)
+    , ChainPoint (..)
+    , Slot
+    , isGenesisBlockHeader
+    , compareSlot
+    , chainPointFromBlockHeader
+    , toSlot
+    )
+
+where
+
+import Prelude
+
+import Cardano.Slotting.Slot
+    ( SlotNo
+    , WithOrigin (..)
+    )
+import Cardano.Wallet.Primitive.Types.DelegationCertificate
+    ( DelegationCertificate
+    )
+import Cardano.Wallet.Primitive.Types.Hash
+    ( Hash (getHash)
+    )
+import Cardano.Wallet.Primitive.Types.Tx.Tx
+    ( Tx
+    )
+import Control.DeepSeq
+    ( NFData
+    )
+import Data.Quantity
+    ( Quantity (getQuantity)
+    )
+import Data.Word
+    ( Word32
+    )
+import Fmt
+    ( Buildable (..)
+    , blockListF
+    , indentF
+    , prefixF
+    , pretty
+    )
+import GHC.Generics
+    ( Generic
+    )
+import NoThunks.Class
+    ( NoThunks
+    )
+
+import Control.Lens
+    ( view
+    )
+import Data.ByteArray.Encoding
+    ( Base (Base16)
+    , convertToBase
+    )
+import Data.Maybe
+    ( isNothing
+    )
+import qualified Data.Text.Encoding as T
+
+data Block = Block
+    { header
+        :: !BlockHeader
+    , transactions
+        :: ![Tx]
+    , delegations
+        :: ![DelegationCertificate]
+    } deriving (Show, Eq, Ord, Generic)
+
+instance NFData Block
+
+instance Buildable (Block) where
+    build (Block h txs _) = mempty
+        <> build h
+        <> if null txs then " ∅" else "\n" <> indentF 4 (blockListF txs)
+
+data BlockHeader = BlockHeader
+    { slotNo
+        :: SlotNo
+    , blockHeight
+        :: Quantity "block" Word32
+    , headerHash
+        :: !(Hash "BlockHeader")
+    , parentHeaderHash
+        :: !(Maybe (Hash "BlockHeader"))
+    } deriving (Show, Eq, Ord, Generic)
+
+-- | Check whether a block with a given 'BlockHeader' is the genesis block.
+isGenesisBlockHeader :: BlockHeader -> Bool
+isGenesisBlockHeader = isNothing . view #parentHeaderHash
+
+instance NFData BlockHeader
+
+instance Buildable BlockHeader where
+    build BlockHeader{..} =
+        previous
+        <> "["
+        <> current
+        <> "-"
+        <> build slotNo
+        <> "#" <> (build . show . getQuantity) blockHeight
+        <> "]"
+      where
+        toHex = T.decodeUtf8 . convertToBase Base16
+        current = prefixF 8 $ build $ toHex $ getHash headerHash
+        previous = case parentHeaderHash of
+            Nothing -> ""
+            Just h  -> prefixF 8 (build $ toHex $ getHash h) <> "<-"
+
+-- | A point on the blockchain
+-- is either the genesis block, or a block with a hash that was
+-- created at a particular 'SlotNo'.
+--
+-- TODO:
+--
+-- * This type is essentially a copy of the 'Cardano.Api.Block.ChainPoint'
+-- type. We want to import it from there when overhauling our types.
+-- * That said, using 'WithOrigin' would not be bad.
+-- * 'BlockHeader' is also a good type for rerencing points on the chain,
+-- but it's less compatible with the types in ouroboros-network.
+data ChainPoint
+    = ChainPointAtGenesis
+    | ChainPoint !SlotNo !(Hash "BlockHeader")
+    deriving (Eq, Ord, Show, Generic)
+
+-- | Compare the slot numbers of two 'ChainPoint's,
+-- but where the 'ChainPointAtGenesis' comes before all other slot numbers.
+compareSlot :: ChainPoint -> ChainPoint -> Ordering
+compareSlot pt1 pt2 = compare (toSlot pt1) (toSlot pt2)
+
+-- | Convert a 'BlockHeader' into a 'ChainPoint'.
+chainPointFromBlockHeader :: BlockHeader -> ChainPoint
+chainPointFromBlockHeader header@(BlockHeader sl _ hash _)
+    | isGenesisBlockHeader header = ChainPointAtGenesis
+    | otherwise                   = ChainPoint sl hash
+
+instance NFData ChainPoint
+
+instance NoThunks ChainPoint
+
+instance Buildable ChainPoint where
+    build ChainPointAtGenesis    = "[point genesis]"
+    build (ChainPoint slot hash) =
+        "[point " <> hashF <> " at slot " <> pretty slot <> "]"
+      where
+        hashF = prefixF 8 $ T.decodeUtf8 $ convertToBase Base16 $ getHash hash
+
+-- | A point in (slot) time, which is either genesis ('Origin')
+-- or has a slot number ('At').
+--
+-- In contrast to 'ChainPoint', the type 'Slot' does not refer
+-- to a point on an actual chain with valid block hashes,
+-- but merely to a timeslot which can hold a single block.
+-- This implies:
+--
+-- * 'Slot' has a linear ordering implemented in the 'Ord' class
+--   (where @Origin < At slot@).
+-- * Using 'Slot' in QuickCheck testing requires less context
+-- (such as an actual simulated chain.)
+type Slot = WithOrigin SlotNo
+
+-- | Retrieve the slot of a 'ChainPoint'.
+toSlot :: ChainPoint -> Slot
+toSlot ChainPointAtGenesis = Origin
+toSlot (ChainPoint slot _) = At slot
+
+instance Buildable Slot where
+    build Origin    = "[genesis]"
+    build (At slot) = "[at slot " <> pretty slot <> "]"

lib/primitive/lib/Cardano/Wallet/Primitive/Types/DelegationCertificate.hs

@@ -0,0 +1,44 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE LambdaCase #-}
+
+module Cardano.Wallet.Primitive.Types.DelegationCertificate
+    ( DelegationCertificate (..)
+    , dlgCertAccount
+    , dlgCertPoolId
+    )
+where
+
+import Prelude
+
+import Cardano.Wallet.Primitive.Types.PoolId
+    ( PoolId
+    )
+import Cardano.Wallet.Primitive.Types.RewardAccount
+    ( RewardAccount
+    )
+import Control.DeepSeq
+    ( NFData
+    )
+import GHC.Generics
+    ( Generic
+    )
+
+data DelegationCertificate
+    = CertDelegateNone RewardAccount
+    | CertDelegateFull RewardAccount PoolId
+    | CertRegisterKey RewardAccount
+    deriving (Generic, Show, Eq, Ord)
+
+instance NFData DelegationCertificate
+
+dlgCertAccount :: DelegationCertificate -> RewardAccount
+dlgCertAccount = \case
+    CertDelegateNone acc -> acc
+    CertDelegateFull acc _ -> acc
+    CertRegisterKey acc -> acc
+
+dlgCertPoolId :: DelegationCertificate -> Maybe PoolId
+dlgCertPoolId = \case
+    CertDelegateNone{} -> Nothing
+    CertDelegateFull _ poolId -> Just poolId
+    CertRegisterKey _ -> Nothing

lib/primitive/lib/Cardano/Wallet/Primitive/Types/PoolId.hs

@@ -0,0 +1,111 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+module Cardano.Wallet.Primitive.Types.PoolId
+    ( PoolId (..)
+    , poolIdBytesLength
+    , decodePoolIdBech32
+    , encodePoolIdBech32
+    )
+where
+
+import Prelude
+
+import Control.DeepSeq
+    ( NFData
+    )
+import Data.ByteArray.Encoding
+    ( Base (Base16)
+    , convertFromBase
+    , convertToBase
+    )
+import Data.ByteString
+    ( ByteString
+    )
+import Data.List
+    ( intercalate
+    )
+import Data.Text.Class
+    ( FromText (..)
+    , TextDecodingError (TextDecodingError)
+    , ToText (..)
+    )
+import Data.Text.Encoding
+    ( decodeUtf8
+    , encodeUtf8
+    )
+import Fmt
+    ( Buildable (..)
+    , prefixF
+    )
+import GHC.Generics
+    ( Generic
+    )
+
+import qualified Codec.Binary.Bech32 as Bech32
+import qualified Codec.Binary.Bech32.TH as Bech32
+import qualified Data.ByteString as BS
+import qualified Data.Text as T
+
+-- | Identifies a stake pool.
+-- For Jörmungandr a 'PoolId' is the blake2b-256 hash of the stake pool
+-- registration certificate.
+newtype PoolId = PoolId { getPoolId :: ByteString }
+    deriving (Generic, Eq, Ord)
+
+instance Show PoolId where
+    show p = "(PoolId " <> show (encodePoolIdBech32 p) <> ")"
+
+poolIdBytesLength :: [Int]
+poolIdBytesLength = [28, 32]
+
+instance NFData PoolId
+
+instance Buildable PoolId where
+    build poolId = mempty
+        <> prefixF 8 poolIdF
+      where
+        poolIdF = build (toText poolId)
+
+instance ToText PoolId where
+    toText = decodeUtf8
+        . convertToBase Base16
+        . getPoolId
+
+instance FromText PoolId where
+    fromText t = case convertFromBase Base16 $ encodeUtf8 t of
+        Left _ ->
+            textDecodingError
+        Right bytes | BS.length bytes `elem` poolIdBytesLength ->
+            Right $ PoolId bytes
+        Right _ ->
+            textDecodingError
+      where
+        textDecodingError = Left $ TextDecodingError $ unwords
+            [ "Invalid stake pool id: expecting a hex-encoded value that is"
+            , intercalate " or " (show <$> poolIdBytesLength)
+            , "bytes in length."
+            ]
+
+-- | Encode 'PoolId' as Bech32 with "pool" hrp.
+encodePoolIdBech32 :: PoolId -> T.Text
+encodePoolIdBech32 =
+    Bech32.encodeLenient hrp
+        . Bech32.dataPartFromBytes
+        . getPoolId
+  where
+    hrp = [Bech32.humanReadablePart|pool|]
+
+-- | Decode a Bech32 encoded 'PoolId'.
+decodePoolIdBech32 :: T.Text -> Either TextDecodingError PoolId
+decodePoolIdBech32 t =
+    case fmap Bech32.dataPartToBytes <$> Bech32.decodeLenient t of
+        Left _ -> Left textDecodingError
+        Right (_, Just bytes) ->
+            Right $ PoolId bytes
+        Right _ -> Left textDecodingError
+      where
+        textDecodingError = TextDecodingError $ unwords
+            [ "Invalid stake pool id: expecting a Bech32 encoded value"
+            , "with human readable part of 'pool'."
+            ]