add Chainweb.Ranked

chainweb.cabal

@@ -227,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

@@ -6,6 +6,8 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ImportQualifiedPost #-}
 
 -- |
 -- Module: Chainweb.BlockPayloadHash
@@ -19,22 +21,33 @@ module Chainweb.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 qualified Data.ByteArray as BA
+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
 
@@ -95,3 +108,30 @@ instance HasTextRepresentation BlockPayloadHash where
   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
+

src/Chainweb/Pact/Backend/Compaction.hs

@@ -65,8 +65,9 @@ import "unliftio" UnliftIO.Async (pooledForConcurrently_)
 import "yet-another-logger" System.Logger hiding (Logger)
 import "yet-another-logger" System.Logger qualified as YAL
 import "yet-another-logger" System.Logger.Backend.ColorOption (useColor)
+import Chainweb.BlockHash
 import Chainweb.BlockHeader (blockHeight, blockHash, blockPayloadHash)
-import Chainweb.BlockHeaderDB.Internal (BlockHeaderDb(..), RankedBlockHash(..), RankedBlockHeader(..))
+import Chainweb.BlockHeaderDB.Internal (BlockHeaderDb(..), RankedBlockHeader(..))
 import Chainweb.BlockHeight (BlockHeight(..))
 import Chainweb.Cut.CutHashes (cutIdToText)
 import Chainweb.CutDB (cutHashesTable)

src/Chainweb/Ranked.hs

@@ -0,0 +1,63 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
+
+-- |
+-- Module: Chainweb.Ranked
+-- Copyright: Copyright © 2024 Kadena LLC.
+-- License: MIT
+-- Maintainer: Lars Kuhtz <lars@kadena.io>
+-- Stability: experimental
+--
+-- Blockheight indexed data with an encoding that sort lexicographically by
+-- height.
+--
+-- The main purpose of this data structure is to provide locallity for
+-- blockheight indexed data in key-value databases.
+--
+module Chainweb.Ranked
+( Ranked(..)
+, encodeRanked
+, decodeRanked
+) where
+
+import Chainweb.BlockHeight
+import Chainweb.Utils.Serialization
+
+import Control.DeepSeq
+import Control.Monad
+
+import Data.Hashable
+
+import GHC.Generics
+
+-- -------------------------------------------------------------------------- --
+-- BlockHeight Ranked Data
+
+-- | BlockHeight Ranked Data
+--
+-- Blockheight indexed data with an encoding that sort lexicographically by
+-- height.
+--
+-- The main purpose of this data structure is to provide locallity for
+-- blockheight indexed data in key-value databases.
+--
+data Ranked a = Ranked
+    { _rankedHeight :: !BlockHeight
+    , _ranked :: !a
+    }
+    deriving (Show, Eq, Ord, Generic)
+    deriving anyclass (Hashable, NFData)
+
+encodeRanked :: (a -> Put) -> Ranked a -> Put
+encodeRanked putA (Ranked r a) = do
+    encodeBlockHeightBe r -- big endian encoding for lexicographical order
+    putA a
+{-# INLINE encodeRanked #-}
+
+decodeRanked :: Get a -> Get (Ranked a)
+decodeRanked decodeA = Ranked
+    <$!> decodeBlockHeightBe
+    <*> decodeA
+{-# INLINE decodeRanked #-}
+