miscelaneous small changes

chainweb.cabal

@@ -169,6 +169,7 @@ library
         , Chainweb.BlockHeaderDB.RestAPI.Client
         , Chainweb.BlockHeaderDB.RestAPI.Server
         , Chainweb.BlockHeight
+        , Chainweb.BlockPayloadHash
         , Chainweb.BlockWeight
         , Chainweb.ChainId
         , Chainweb.ChainValue
@@ -226,6 +227,7 @@ library
         , Chainweb.Payload.RestAPI.Server
         , Chainweb.Payload.RestAPI.Client
         , Chainweb.PowHash
+        , Chainweb.Ranked
         , Chainweb.RestAPI
         , Chainweb.RestAPI.Backup
         , Chainweb.RestAPI.Config

src/Chainweb/BlockHash.hs

@@ -18,6 +18,7 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE PatternSynonyms #-}
 
 -- |
 -- Module: Chainweb.BlockHash
@@ -52,6 +53,14 @@ module Chainweb.BlockHash
 , blockHashRecordFromVector
 , blockHashRecordChainIdx
 
+-- * Blockheight Ranked BlockHash
+, type RankedBlockHash
+, pattern RankedBlockHash
+, _rankedBlockHashHash
+, _rankedBlockHashHeight
+, encodeRankedBlockHash
+, decodeRankedBlockHash
+
 -- * Exceptions
 ) where
 
@@ -77,11 +86,13 @@ import Numeric.Natural
 
 -- internal imports
 
+import Chainweb.BlockHeight
 import Chainweb.ChainId
 import Chainweb.Crypto.MerkleLog
 import Chainweb.Graph
 import Chainweb.MerkleLogHash
 import Chainweb.MerkleUniverse
+import Chainweb.Ranked
 import Chainweb.Utils
 import Chainweb.Utils.Serialization
 
@@ -252,3 +263,20 @@ blockHashRecordFromVector g cid = BlockHashRecord
     . HM.fromList
     . zip (L.sort $ toList $ adjacentChainIds (_chainGraph g) cid)
     . toList
+
+-- -------------------------------------------------------------------------- --
+-- Ranked Block Hash
+
+type RankedBlockHash = Ranked BlockHash
+
+pattern RankedBlockHash :: BlockHeight -> BlockHash -> RankedBlockHash
+pattern RankedBlockHash { _rankedBlockHashHeight, _rankedBlockHashHash }
+    = Ranked _rankedBlockHashHeight _rankedBlockHashHash
+{-# COMPLETE RankedBlockHash #-}
+
+encodeRankedBlockHash :: RankedBlockHash -> Put
+encodeRankedBlockHash = encodeRanked encodeBlockHash
+
+decodeRankedBlockHash :: Get RankedBlockHash
+decodeRankedBlockHash = decodeRanked decodeBlockHash
+

src/Chainweb/BlockHeader.hs

@@ -61,6 +61,10 @@ module Chainweb.BlockHeader
 -- ** Utilities
 , I._blockPow
 , I.blockPow
+, I.rankedBlockHash
+, I._rankedBlockHash
+, I.rankedBlockPayloadHash
+, I._rankedBlockPayloadHash
 , I._blockAdjacentChainIds
 , I.blockAdjacentChainIds
 , I.encodeBlockHeader

src/Chainweb/BlockHeader/Internal.hs

@@ -94,6 +94,10 @@ module Chainweb.BlockHeader.Internal
 , blockPow
 , _blockAdjacentChainIds
 , blockAdjacentChainIds
+, _rankedBlockHash
+, rankedBlockHash
+, _rankedBlockPayloadHash
+, rankedBlockPayloadHash
 , encodeBlockHeader
 , encodeBlockHeaderWithoutHash
 , decodeBlockHeader
@@ -119,28 +123,30 @@ module Chainweb.BlockHeader.Internal
 , genesisBlockHeaders
 , genesisBlockHeadersAtHeight
 , genesisHeight
-, headerSizes
-, headerSizeBytes
-, workSizeBytes
 
 -- * Create a new BlockHeader
 , newBlockHeader
 
 -- * CAS Constraint
 , BlockHeaderCas
+
+-- * Misc
+, headerSizes
+, headerSizeBytes
+, workSizeBytes
 ) where
 
 import Chainweb.BlockCreationTime
 import Chainweb.BlockHash
 import Chainweb.BlockHeight
+import Chainweb.BlockPayloadHash
 import Chainweb.BlockWeight
 import Chainweb.ChainId
 import Chainweb.Crypto.MerkleLog
 import Chainweb.Difficulty
 import Chainweb.Graph
 import Chainweb.MerkleLogHash
 import Chainweb.MerkleUniverse
-import Chainweb.Payload
 import Chainweb.PowHash
 import Chainweb.Storage.Table
 import Chainweb.Time
@@ -162,21 +168,21 @@ import Data.Aeson
 import Data.Aeson.Types (Parser)
 import Data.Function (on)
 import Data.HashMap.Strict (HashMap)
+import Data.HashMap.Strict qualified as HM
+import Data.HashSet qualified as HS
 import Data.Hashable
 import Data.IORef
 import Data.Kind
+import Data.Memory.Endian qualified as BA
 import Data.MerkleLog hiding (Actual, Expected, MerkleHash)
+import Data.Text qualified as T
 import Data.Word
 import GHC.Generics (Generic)
 import GHC.Stack
 import Numeric.AffineSpace
 import Numeric.Natural
 import System.IO.Unsafe
 import Text.Read (readEither)
-import Data.HashMap.Strict qualified as HM
-import Data.HashSet qualified as HS
-import Data.Memory.Endian qualified as BA
-import Data.Text qualified as T
 
 -- -------------------------------------------------------------------------- --
 -- Nonce
@@ -391,6 +397,7 @@ type BlockHeaderCas tbl = Cas tbl BlockHeader
 -- | Used for quickly identifying "which block" this is.
 -- Example output:
 -- "0 @ bSQgL5 (height 4810062)"
+--
 blockHeaderShortDescription :: BlockHeader -> T.Text
 blockHeaderShortDescription bh =
     T.unwords
@@ -1107,6 +1114,9 @@ instance TreeDbEntry BlockHeader where
         | isGenesisBlockHeader e = Nothing
         | otherwise = Just (_blockParent e)
 
+-- -------------------------------------------------------------------------- --
+-- Misc
+
 -- | This is an internal function. Use 'headerSizeBytes' instead.
 --
 -- Postconditions: for all @v@
@@ -1160,3 +1170,26 @@ workSizeBytes
     -> BlockHeight
     -> Natural
 workSizeBytes v h = headerSizeBytes v (unsafeChainId 0) h - 32
+
+_rankedBlockHash :: BlockHeader -> RankedBlockHash
+_rankedBlockHash h = RankedBlockHash
+    { _rankedBlockHashHeight = _blockHeight h
+    , _rankedBlockHashHash = _blockHash h
+    }
+{-# INLINE _rankedBlockHash #-}
+
+rankedBlockHash :: Getter BlockHeader RankedBlockHash
+rankedBlockHash = to _rankedBlockHash
+{-# INLINE rankedBlockHash #-}
+
+_rankedBlockPayloadHash :: BlockHeader -> RankedBlockPayloadHash
+_rankedBlockPayloadHash h = RankedBlockPayloadHash
+    { _rankedBlockPayloadHashHeight = _blockHeight h
+    , _rankedBlockPayloadHashHash = _blockPayloadHash h
+    }
+{-# INLINE _rankedBlockPayloadHash #-}
+
+rankedBlockPayloadHash :: Getter BlockHeader RankedBlockPayloadHash
+rankedBlockPayloadHash = to _rankedBlockPayloadHash
+{-# INLINE rankedBlockPayloadHash #-}
+

src/Chainweb/BlockHeaderDB/Internal.hs

@@ -29,7 +29,6 @@ module Chainweb.BlockHeaderDB.Internal
 (
 -- * Internal Types
   RankedBlockHeader(..)
-, RankedBlockHash(..)
 , BlockRank(..)
 
 -- * Chain Database Handle
@@ -113,16 +112,6 @@ instance Ord RankedBlockHeader where
     compare = compare `on` ((view blockHeight &&& id) . _getRankedBlockHeader)
     {-# INLINE compare #-}
 
--- -------------------------------------------------------------------------- --
--- Ranked Block Hash
-
-data RankedBlockHash = RankedBlockHash
-    { _rankedBlockHashHeight :: !BlockHeight
-    , _rankedBlockHash :: !BlockHash
-    }
-    deriving (Show, Eq, Ord, Generic)
-    deriving anyclass (Hashable, NFData)
-
 instance IsCasValue RankedBlockHeader where
     type CasKeyType RankedBlockHeader = RankedBlockHash
     casKey (RankedBlockHeader bh)
@@ -152,18 +141,6 @@ decodeRankedBlockHeader :: Get RankedBlockHeader
 decodeRankedBlockHeader = RankedBlockHeader <$!> decodeBlockHeader
 {-# INLINE decodeRankedBlockHeader #-}
 
-encodeRankedBlockHash :: RankedBlockHash -> Put
-encodeRankedBlockHash (RankedBlockHash r bh) = do
-    encodeBlockHeightBe r -- big endian encoding for lexicographical order
-    encodeBlockHash bh
-{-# INLINE encodeRankedBlockHash #-}
-
-decodeRankedBlockHash :: Get RankedBlockHash
-decodeRankedBlockHash = RankedBlockHash
-    <$!> decodeBlockHeightBe
-    <*> decodeBlockHash
-{-# INLINE decodeRankedBlockHash #-}
-
 -- -------------------------------------------------------------------------- --
 -- BlockHeader DB
 
@@ -314,7 +291,7 @@ instance TreeDb BlockHeaderDb where
     keys db k l mir mar f = withSeekTreeDb db k mir $ \it -> f $ do
         iterToKeyStream it
             & maybe id (\x -> S.takeWhile (\a -> int (_rankedBlockHashHeight a) <= x)) mar
-            & S.map _rankedBlockHash
+            & S.map _rankedBlockHashHash
             & limitStream l
     {-# INLINEABLE keys #-}
 

src/Chainweb/BlockPayloadHash.hs

@@ -0,0 +1,137 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ImportQualifiedPost #-}
+
+-- |
+-- Module: Chainweb.BlockPayloadHash
+-- Copyright: Copyright © 2024 Kadena LLC.
+-- License: MIT
+-- Maintainer: Lars Kuhtz <[email protected]>
+-- Stability: experimental
+--
+module Chainweb.BlockPayloadHash
+( BlockPayloadHash
+, BlockPayloadHash_(..)
+, encodeBlockPayloadHash
+, decodeBlockPayloadHash
+, nullBlockPayloadHash
+
+-- * Ranked Block Payload Hash
+, type RankedBlockPayloadHash
+, pattern RankedBlockPayloadHash
+, _rankedBlockPayloadHashHash
+, _rankedBlockPayloadHashHeight
+, encodeRankedBlockPayloadHash
+, decodeRankedBlockPayloadHash
+) where
+
+import Control.DeepSeq
+import Control.Monad
+
+import Data.Aeson
+import Data.ByteArray qualified as BA
+import Data.Hashable
+
+import GHC.Generics (Generic)
+
+-- internal modules
+
+import Chainweb.BlockHeight
+import Chainweb.Crypto.MerkleLog
+import Chainweb.MerkleLogHash
+import Chainweb.MerkleUniverse
+import Chainweb.Ranked
+import Chainweb.Utils
+import Chainweb.Utils.Serialization
+
+-- -------------------------------------------------------------------------- --
+-- BlockPayloadHash
+
+-- | The Merkle root of a block payload evaluation
+--
+-- NOTE: for historic reasons this is called `BlockPayloadHash`. A more accurate
+-- name would be `PayloadEvaluationHash`.
+--
+-- This is computed by payload provider of the respective block payload. It is
+-- treated by Chainweb consensus as the root of a Chainweb Merkle (sub-) tree.
+-- It is the responsibility of the payload provider that this interpretation is
+-- cryptographically sound.
+--
+-- Semantically, the hash must completely authenticate the block payload and
+-- payload evaluation results, including all updates to the internal state of
+-- the payload provider (but not complete state itself).
+--
+-- It is not required to authenticate the complete internal state of the payload
+-- provider. (Although it is strongly recommended that payload providers support
+-- this by including a state root into the payload Merkle tree. Pact currently
+-- does not support this.)
+--
+-- Beside of unambiguously authenticating the evaluation of the payload, it is
+-- up to the respective payload provider to decide what cryptographic protocol
+-- is used to compute this value and what can be proven about the payload.
+--
+-- Binary format: 32 bytes.
+--
+type BlockPayloadHash = BlockPayloadHash_ ChainwebMerkleHashAlgorithm
+
+newtype BlockPayloadHash_ a = BlockPayloadHash (MerkleLogHash a)
+    deriving (Show, Eq, Ord, Generic)
+    deriving anyclass (NFData)
+    deriving newtype (BA.ByteArrayAccess)
+    deriving newtype (Hashable, ToJSON, FromJSON)
+    deriving newtype (ToJSONKey, FromJSONKey)
+
+encodeBlockPayloadHash :: BlockPayloadHash_ a -> Put
+encodeBlockPayloadHash (BlockPayloadHash w) = encodeMerkleLogHash w
+
+decodeBlockPayloadHash
+    :: MerkleHashAlgorithm a
+    => Get (BlockPayloadHash_ a)
+decodeBlockPayloadHash = BlockPayloadHash <$!> decodeMerkleLogHash
+
+instance MerkleHashAlgorithm a => IsMerkleLogEntry a ChainwebHashTag (BlockPayloadHash_ a) where
+    type Tag (BlockPayloadHash_ a) = 'BlockPayloadHashTag
+    toMerkleNode = encodeMerkleTreeNode
+    fromMerkleNode = decodeMerkleTreeNode
+    {-# INLINE toMerkleNode #-}
+    {-# INLINE fromMerkleNode #-}
+
+instance HasTextRepresentation BlockPayloadHash where
+  toText (BlockPayloadHash h) = toText h
+  fromText = fmap BlockPayloadHash . fromText
+  {-# INLINE toText #-}
+  {-# INLINE fromText #-}
+
+nullBlockPayloadHash :: MerkleHashAlgorithm a => BlockPayloadHash_ a
+nullBlockPayloadHash = BlockPayloadHash nullHashBytes
+{-# INLINE nullBlockPayloadHash #-}
+
+-- -------------------------------------------------------------------------- --
+-- Ranked Block Payload Hash
+
+type RankedBlockPayloadHash = Ranked BlockPayloadHash
+
+pattern RankedBlockPayloadHash
+    :: BlockHeight
+    -> BlockPayloadHash
+    -> RankedBlockPayloadHash
+pattern RankedBlockPayloadHash
+    { _rankedBlockPayloadHashHeight
+    , _rankedBlockPayloadHashHash
+    }
+    = Ranked _rankedBlockPayloadHashHeight _rankedBlockPayloadHashHash
+{-# COMPLETE RankedBlockPayloadHash #-}
+
+encodeRankedBlockPayloadHash :: RankedBlockPayloadHash -> Put
+encodeRankedBlockPayloadHash = encodeRanked encodeBlockPayloadHash
+
+decodeRankedBlockPayloadHash :: Get RankedBlockPayloadHash
+decodeRankedBlockPayloadHash = decodeRanked decodeBlockPayloadHash
+