From cc4cad9fcbce5ba0ccdff1468131a674131aa43d Mon Sep 17 00:00:00 2001 From: Lars Kuhtz Date: Mon, 18 Nov 2024 13:56:56 -0800 Subject: [PATCH 1/8] more type level utils and JsonTextRepresentation wrapper --- src/Chainweb/Utils.hs | 132 +++++++++++++++++++++++++++++------------- 1 file changed, 92 insertions(+), 40 deletions(-) diff --git a/src/Chainweb/Utils.hs b/src/Chainweb/Utils.hs index ae69591b0f..e32ea7c9ad 100644 --- a/src/Chainweb/Utils.hs +++ b/src/Chainweb/Utils.hs @@ -1,6 +1,7 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} @@ -10,7 +11,10 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} @@ -100,6 +104,7 @@ module Chainweb.Utils , unsafeFromText , parseM , parseText +, strip0x -- ** Base64 , encodeB64Text @@ -120,6 +125,7 @@ module Chainweb.Utils , decodeStrictOrThrow' , decodeFileStrictOrThrow' , parseJsonFromText +, JsonTextRepresentation(..) -- ** Cassava (CSV) , CsvDecimal(..) @@ -179,6 +185,9 @@ module Chainweb.Utils -- * Type Level , symbolText +, symbolVal_ +, natVal_ +, intVal_ -- * Resource Management , concurrentWith @@ -245,61 +254,64 @@ import Control.Monad.Primitive import Control.Monad.Reader as Reader import Data.Aeson.Text (encodeToLazyText) -import qualified Data.Aeson.Types as Aeson -import qualified Data.Attoparsec.Text as A +import Data.Aeson.Types qualified as Aeson +import Data.Attoparsec.Text qualified as A import Data.Bifunctor import Data.Bool (bool) import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as B8 -import qualified Data.ByteString.Base64 as B64 -import qualified Data.ByteString.Base64.URL as B64U -import qualified Data.ByteString.Builder as BB -import qualified Data.ByteString.Lazy as BL -import qualified Data.Csv as CSV +import Data.ByteString qualified as B +import Data.ByteString.Base64 qualified as B64 +import Data.ByteString.Base64.URL qualified as B64U +import Data.ByteString.Builder qualified as BB +import Data.ByteString.Char8 qualified as B8 +import Data.ByteString.Lazy qualified as BL +import Data.Csv qualified as CSV import Data.Decimal import Data.Functor.Of +import Data.HashMap.Strict qualified as HM +import Data.HashSet qualified as HS import Data.Hashable -import qualified Data.HashMap.Strict as HM -import qualified Data.HashSet as HS -import Data.Proxy import Data.String (IsString(..)) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.Lazy as TL +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import Data.Text.Lazy qualified as TL import Data.These (These(..)) import Data.Time -import qualified Data.Vector as V -import qualified Data.Vector.Mutable as MV +import Data.Vector qualified as V +import Data.Vector.Mutable qualified as MV import Data.Word +import GHC.Exts (proxy#) import GHC.Generics import GHC.Stack (HasCallStack, callStack, prettyCallStack) -import GHC.TypeLits (KnownSymbol, symbolVal) - -import qualified Network.Connection as HTTP -import qualified Network.HTTP.Client as HTTP -import qualified Network.HTTP.Client.TLS as HTTP +import GHC.TypeLits (KnownSymbol, Symbol, symbolVal') +import GHC.TypeLits qualified as Int (KnownNat, natVal') +import GHC.TypeNats qualified as Nat (KnownNat, natVal') + +import Network.Connection qualified as HTTP +import Network.HTTP.Client qualified as HTTP +import Network.HTTP.Client.TLS qualified as HTTP +import Network.HTTP.Types qualified as HTTP import Network.Socket hiding (Debug) -import qualified Network.TLS as HTTP +import Network.TLS qualified as HTTP import Numeric.Natural -import qualified Options.Applicative as O +import Options.Applicative qualified as O + +import Servant.Client qualified -import qualified Streaming as S (concats, effect, inspect) -import qualified Streaming.Prelude as S +import Streaming qualified as S (concats, effect, inspect) +import Streaming.Prelude qualified as S import System.IO.Unsafe (unsafeInterleaveIO, unsafePerformIO) import System.LogLevel -import qualified System.Random.MWC as Prob -import qualified System.Random.MWC.Probability as Prob -import qualified System.Timeout as Timeout +import System.Random.MWC qualified as Prob +import System.Random.MWC.Probability qualified as Prob +import System.Timeout qualified as Timeout import Text.Printf (printf) import Text.Read (readEither) -import qualified Servant.Client -import qualified Network.HTTP.Types as HTTP -- -------------------------------------------------------------------------- -- -- SI unit prefixes @@ -434,6 +446,27 @@ mutableVectorFromList as = do return vec {-# inline mutableVectorFromList #-} +-- -------------------------------------------------------------------------- -- +-- Typelevel + +-- | Return the value of a type level symbol as a value of a type that is an +-- instance of 'IsString'. +-- +symbolText :: forall s a . KnownSymbol s => IsString a => a +symbolText = fromString $ symbolVal' @s proxy# + +natVal_ :: forall n . Nat.KnownNat n => Natural +natVal_ = Nat.natVal' @n proxy# +{-# INLINE natVal_ #-} + +intVal_ :: forall n . Int.KnownNat n => Integer +intVal_ = Int.natVal' @n proxy# +{-# INLINE intVal_ #-} + +symbolVal_ :: forall n . KnownSymbol n => String +symbolVal_ = symbolVal' @n proxy# +{-# INLINE symbolVal_ #-} + -- -------------------------------------------------------------------------- -- -- * Read only Ixed @@ -601,6 +634,13 @@ iso8601DateTimeFormat :: String iso8601DateTimeFormat = iso8601DateFormat (Just "%H:%M:%SZ") {-# INLINE iso8601DateTimeFormat #-} +strip0x :: MonadThrow m => T.Text -> m T.Text +strip0x t = case T.stripPrefix "0x" t of + Just x -> return x + Nothing -> throwM $ TextFormatException + $ "Missing hex prefix 0x in " <> sshow t +{-# INLINE strip0x #-} + -- -------------------------------------------------------------------------- -- -- ** Base64 @@ -752,6 +792,27 @@ parseJsonFromText -> Aeson.Parser a parseJsonFromText l = withText l $! either fail return . eitherFromText +-- | A newtype wrapper for derving ToJSON and FromJSON instances via +-- a 'HasTextRepresentation' instance +-- +newtype JsonTextRepresentation (t :: Symbol) a = JsonTextRepresentation a + deriving newtype (Show, Eq, Ord, Generic) + +instance HasTextRepresentation a => ToJSON (JsonTextRepresentation s a) where + toEncoding (JsonTextRepresentation a) = toEncoding $ toText a + toJSON (JsonTextRepresentation a) = toJSON $ toText a + {-# INLINE toEncoding #-} + {-# INLINE toJSON #-} + +instance + ( KnownSymbol s + , HasTextRepresentation a + ) + => FromJSON (JsonTextRepresentation s a) + where + parseJSON = fmap JsonTextRepresentation . parseJsonFromText (symbolVal_ @s) + {-# INLINE parseJSON #-} + -- -------------------------------------------------------------------------- -- -- ** Cassava (CSV) @@ -1198,15 +1259,6 @@ data Codec t = Codec , codecDecode :: ByteString -> Either String t } --- -------------------------------------------------------------------------- -- --- Typelevel - --- | Return the value of a type level symbol as a value of a type that is an --- instance of 'IsString'. --- -symbolText :: forall s a . KnownSymbol s => IsString a => a -symbolText = fromString $ symbolVal (Proxy @s) - -- -------------------------------------------------------------------------- -- -- Resource Management From 9372b85a3cdad41f1a4c33acbc369bf148d2a6e5 Mon Sep 17 00:00:00 2001 From: Lars Kuhtz Date: Mon, 18 Nov 2024 17:31:44 -0800 Subject: [PATCH 2/8] add encodeB64UrlNoPadding --- src/Chainweb/Utils.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Chainweb/Utils.hs b/src/Chainweb/Utils.hs index e32ea7c9ad..baf2ca855d 100644 --- a/src/Chainweb/Utils.hs +++ b/src/Chainweb/Utils.hs @@ -111,6 +111,7 @@ module Chainweb.Utils , decodeB64Text , encodeB64UrlText , decodeB64UrlText +, encodeB64UrlNoPadding , encodeB64UrlNoPaddingText , b64UrlNoPaddingTextEncoding , decodeB64UrlNoPaddingText @@ -699,6 +700,13 @@ encodeB64UrlNoPaddingText :: B.ByteString -> T.Text encodeB64UrlNoPaddingText = T.dropWhileEnd (== '=') . T.decodeUtf8 . B64U.encode {-# INLINE encodeB64UrlNoPaddingText #-} +-- | Encode a binary value to a textual base64-url without padding +-- representation. +-- +encodeB64UrlNoPadding :: B.ByteString -> B.ByteString +encodeB64UrlNoPadding = B8.dropWhileEnd (== '=') . B64U.encode +{-# INLINE encodeB64UrlNoPadding #-} + -- | Encode a binary value to a base64-url (without padding) JSON encoding. -- b64UrlNoPaddingTextEncoding :: B.ByteString -> Encoding From c0e3a7b5b59d9ebdff175a94f4057db0b8819514 Mon Sep 17 00:00:00 2001 From: Lars Kuhtz Date: Mon, 16 Dec 2024 23:27:06 -0800 Subject: [PATCH 3/8] add HasTextRepresentation instance for Natural --- src/Chainweb/Utils.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Chainweb/Utils.hs b/src/Chainweb/Utils.hs index baf2ca855d..68794ecfab 100644 --- a/src/Chainweb/Utils.hs +++ b/src/Chainweb/Utils.hs @@ -574,6 +574,12 @@ instance HasTextRepresentation Integer where fromText = treadM {-# INLINE fromText #-} +instance HasTextRepresentation Natural where + toText = sshow + {-# INLINE toText #-} + fromText = treadM + {-# INLINE fromText #-} + instance HasTextRepresentation Word where toText = sshow {-# INLINE toText #-} From d23f9718308fbd724ee46d2e2dc642816d9edd2f Mon Sep 17 00:00:00 2001 From: Lars Kuhtz Date: Mon, 23 Dec 2024 11:40:23 -0800 Subject: [PATCH 4/8] add IdxGet instance for ChainMap --- src/Chainweb/ChainId.hs | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/src/Chainweb/ChainId.hs b/src/Chainweb/ChainId.hs index 6f9839f7f9..e42814bb44 100644 --- a/src/Chainweb/ChainId.hs +++ b/src/Chainweb/ChainId.hs @@ -90,7 +90,7 @@ import Chainweb.MerkleUniverse import Chainweb.Utils import Chainweb.Utils.Serialization -import Data.Singletons +import Data.Singletons hiding (Index) -- -------------------------------------------------------------------------- -- -- Exceptions @@ -268,6 +268,12 @@ chainIdInt :: Integral i => ChainId -> i chainIdInt (ChainId cid) = int cid {-# INLINE chainIdInt #-} +-- -------------------------------------------------------------------------- -- +-- ChainMap + +-- TODO: Shouldn't this type guarantee that the map is total, i.e. that there +-- exists a value for each chain? + -- | Values keyed by `ChainId`s, or a single value that applies for all chains. data ChainMap a = AllChains a | OnChains (HashMap ChainId a) deriving stock (Eq, Functor, Foldable, Generic, Ord, Show) @@ -305,3 +311,9 @@ atChain :: ChainId -> Fold (ChainMap a) a atChain cid = folding $ \case OnChains m -> m ^. at cid AllChains a -> Just a + +type instance Index (ChainMap a) = ChainId +type instance IxValue (ChainMap a) = a + +instance IxedGet (ChainMap a) where + ixg i = atChain i From 74125bf2eee819cf9decee7518648a4fe65de9ab Mon Sep 17 00:00:00 2001 From: Lars Kuhtz Date: Mon, 18 Nov 2024 22:36:14 -0800 Subject: [PATCH 5/8] Move BlockPayloadHash into separate module --- chainweb.cabal | 1 + src/Chainweb/BlockPayloadHash.hs | 97 ++++++++++++++++++++++++++++++++ src/Chainweb/Payload.hs | 34 +---------- 3 files changed, 99 insertions(+), 33 deletions(-) create mode 100644 src/Chainweb/BlockPayloadHash.hs diff --git a/chainweb.cabal b/chainweb.cabal index 57eac648ad..46e0c6a5fe 100644 --- a/chainweb.cabal +++ b/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 diff --git a/src/Chainweb/BlockPayloadHash.hs b/src/Chainweb/BlockPayloadHash.hs new file mode 100644 index 0000000000..3cf0e1ee88 --- /dev/null +++ b/src/Chainweb/BlockPayloadHash.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module: Chainweb.BlockPayloadHash +-- Copyright: Copyright © 2024 Kadena LLC. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +module Chainweb.BlockPayloadHash +( BlockPayloadHash +, BlockPayloadHash_(..) +, encodeBlockPayloadHash +, decodeBlockPayloadHash +) where + +import Control.DeepSeq +import Control.Monad + +import Data.Aeson +import qualified Data.ByteArray as BA +import Data.Hashable + +import GHC.Generics (Generic) + +-- internal modules + +import Chainweb.Crypto.MerkleLog +import Chainweb.MerkleLogHash +import Chainweb.MerkleUniverse +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 #-} diff --git a/src/Chainweb/Payload.hs b/src/Chainweb/Payload.hs index 83a375f716..0bb33152f8 100644 --- a/src/Chainweb/Payload.hs +++ b/src/Chainweb/Payload.hs @@ -163,6 +163,7 @@ import GHC.Stack -- internal modules +import Chainweb.BlockPayloadHash import Chainweb.Crypto.MerkleLog import Chainweb.MerkleLogHash import Chainweb.MerkleUniverse @@ -237,39 +238,6 @@ instance HasTextRepresentation BlockOutputsHash where {-# INLINE toText #-} {-# INLINE fromText #-} --- -------------------------------------------------------------------------- -- --- BlockPayloadHash - -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 #-} - -- -------------------------------------------------------------------------- -- -- Transaction From bdd6446f1cb722e86f6cd42805cdcaac27e39590 Mon Sep 17 00:00:00 2001 From: Lars Kuhtz Date: Mon, 16 Dec 2024 23:26:01 -0800 Subject: [PATCH 6/8] add Chainweb.Ranked --- chainweb.cabal | 1 + src/Chainweb/BlockHash.hs | 28 +++++++++++ src/Chainweb/BlockHeader.hs | 4 ++ src/Chainweb/BlockHeader/Internal.hs | 49 +++++++++++++++---- src/Chainweb/BlockHeaderDB/Internal.hs | 25 +--------- src/Chainweb/BlockPayloadHash.hs | 42 ++++++++++++++++- src/Chainweb/Pact/Backend/Compaction.hs | 3 +- src/Chainweb/Ranked.hs | 63 +++++++++++++++++++++++++ 8 files changed, 181 insertions(+), 34 deletions(-) create mode 100644 src/Chainweb/Ranked.hs diff --git a/chainweb.cabal b/chainweb.cabal index 46e0c6a5fe..571f490462 100644 --- a/chainweb.cabal +++ b/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 diff --git a/src/Chainweb/BlockHash.hs b/src/Chainweb/BlockHash.hs index 6c49da4ac8..7c1f6f340b 100644 --- a/src/Chainweb/BlockHash.hs +++ b/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 + diff --git a/src/Chainweb/BlockHeader.hs b/src/Chainweb/BlockHeader.hs index c844e834fd..9b3821d7d2 100644 --- a/src/Chainweb/BlockHeader.hs +++ b/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 diff --git a/src/Chainweb/BlockHeader/Internal.hs b/src/Chainweb/BlockHeader/Internal.hs index b3d75ca56d..30f5dbbb16 100644 --- a/src/Chainweb/BlockHeader/Internal.hs +++ b/src/Chainweb/BlockHeader/Internal.hs @@ -94,6 +94,10 @@ module Chainweb.BlockHeader.Internal , blockPow , _blockAdjacentChainIds , blockAdjacentChainIds +, _rankedBlockHash +, rankedBlockHash +, _rankedBlockPayloadHash +, rankedBlockPayloadHash , encodeBlockHeader , encodeBlockHeaderWithoutHash , decodeBlockHeader @@ -119,20 +123,23 @@ 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 @@ -140,7 +147,6 @@ 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,10 +168,14 @@ 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 @@ -173,10 +183,6 @@ 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 #-} + diff --git a/src/Chainweb/BlockHeaderDB/Internal.hs b/src/Chainweb/BlockHeaderDB/Internal.hs index fd13e8db40..f272bb8b7a 100644 --- a/src/Chainweb/BlockHeaderDB/Internal.hs +++ b/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 #-} diff --git a/src/Chainweb/BlockPayloadHash.hs b/src/Chainweb/BlockPayloadHash.hs index 3cf0e1ee88..02d3a4dee0 100644 --- a/src/Chainweb/BlockPayloadHash.hs +++ b/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 + diff --git a/src/Chainweb/Pact/Backend/Compaction.hs b/src/Chainweb/Pact/Backend/Compaction.hs index eae063fdbd..5e9bab3e6e 100644 --- a/src/Chainweb/Pact/Backend/Compaction.hs +++ b/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) diff --git a/src/Chainweb/Ranked.hs b/src/Chainweb/Ranked.hs new file mode 100644 index 0000000000..c6713e78dd --- /dev/null +++ b/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 +-- 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 #-} + From d1e8b648f59680fb4c86888c3da2964e4fd87a3f Mon Sep 17 00:00:00 2001 From: Lars Kuhtz Date: Mon, 23 Dec 2024 12:39:08 -0800 Subject: [PATCH 7/8] add Chainweb.MinerReward module --- chainweb.cabal | 3 + src/Chainweb/MinerReward.hs | 250 ++++++++++++++++++ .../Pact/PactService/Pact4/ExecBlock.hs | 27 +- .../Pact/PactService/Pact5/ExecBlock.hs | 17 +- test/unit/Chainweb/Test/MinerReward.hs | 183 +++++++++++++ test/unit/Chainweb/Test/Pact4/RewardsTest.hs | 16 +- test/unit/ChainwebTests.hs | 2 + 7 files changed, 455 insertions(+), 43 deletions(-) create mode 100644 src/Chainweb/MinerReward.hs create mode 100644 test/unit/Chainweb/Test/MinerReward.hs diff --git a/chainweb.cabal b/chainweb.cabal index 571f490462..e239f48578 100644 --- a/chainweb.cabal +++ b/chainweb.cabal @@ -217,6 +217,7 @@ library , Chainweb.Miner.RestAPI , Chainweb.Miner.RestAPI.Client , Chainweb.Miner.RestAPI.Server + , Chainweb.MinerReward , Chainweb.NodeVersion , Chainweb.OpenAPIValidation , Chainweb.Payload @@ -637,6 +638,7 @@ test-suite chainweb-tests Chainweb.Test.Mempool.InMem Chainweb.Test.Mempool.RestAPI Chainweb.Test.Mempool.Sync + Chainweb.Test.MinerReward Chainweb.Test.Mining Chainweb.Test.Misc Chainweb.Test.Pact4.Checkpointer @@ -696,6 +698,7 @@ test-suite chainweb-tests , byteslice >= 0.2.12 , bytesmith >= 0.3.10 , bytestring >= 0.10.12 + , cassava >= 0.5.1 , chainweb-storage >= 0.1 , containers >= 0.5 , crypton >= 0.31 diff --git a/src/Chainweb/MinerReward.hs b/src/Chainweb/MinerReward.hs new file mode 100644 index 0000000000..af33dc63a3 --- /dev/null +++ b/src/Chainweb/MinerReward.hs @@ -0,0 +1,250 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NumDecimals #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Module: Chainweb.MinerReward +-- Copyright: Copyright © 2024 Kadena LLC. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +-- Chainweb Miner reward. +-- +-- Morally this is a property of the Chainweb version, however there is no need +-- to use value different from what is used on Mainnet on any network. +-- +module Chainweb.MinerReward +( +-- * STU + Stu(..) +, divideStu + +-- * KDA +, Kda +, pattern Kda +, _kda +, stuToKda +, kdaToStu + +-- * Miner Reward +, MinerReward(..) +, minerRewardKda +, blockMinerReward + +-- * Internal +-- ** Miner Rewards Table +, minerRewards +, mkMinerRewards + +-- ** Miner Rewards File +, rawMinerRewards + +-- ** Consistency Checks +, rawMinerRewardsHash +, minerRewardsHash +, expectedMinerRewardsHash +, expectedRawMinerRewardsHash +) where + +import Chainweb.BlockHeight (BlockHeight(..), encodeBlockHeight) +import Chainweb.Utils +import Chainweb.Utils.Serialization +import Chainweb.Version +import Control.DeepSeq (NFData) +import Crypto.Hash (hash, Digest) +import Crypto.Hash.Algorithms (SHA512) +import Data.Aeson +import Data.ByteString qualified as B +import Data.ByteString.Lazy qualified as BL +import Data.Csv qualified as CSV +import Data.Decimal +import Data.FileEmbed (embedFile) +import Data.Foldable +import Data.Map.Strict qualified as M +import Data.Ratio +import Data.Vector qualified as V +import Data.Word +import GHC.Generics (Generic) +import GHC.Stack +import Numeric.Natural + +-- -------------------------------------------------------------------------- -- +-- STU + +-- | Smallest Unit of KDA: 1 KDA == 1e12 STU. +-- +-- Values are non-negative and substraction can result in an arithmetic +-- underflow. +-- +newtype Stu = Stu { _stu :: Natural } + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (Enum, Num, Real, Integral, NFData) + +instance HasTextRepresentation Stu where + toText = toText . _stu + fromText = fmap Stu . fromText + {-# INLINEABLE toText #-} + {-# INLINEABLE fromText #-} + +instance ToJSON Stu where + toJSON = toJSON . toText + toEncoding = toEncoding . toText + {-# INLINEABLE toJSON #-} + {-# INLINEABLE toEncoding #-} + +instance FromJSON Stu where + parseJSON = parseJsonFromText "Stu" + {-# INLINABLE parseJSON #-} + +-- | Divide a Stu by a Natural number. +-- +-- The result is rounded using bankers rounding. +-- +divideStu :: Stu -> Natural -> Stu +divideStu s n = round $ s % fromIntegral n + +-- -------------------------------------------------------------------------- -- +-- KDA + +-- | KDA encoded as Decimal. +-- +-- No arithmetic conversions or operations are provided. +-- +-- The precision of KDA values is 1e12 decimal digits. The value is stored in +-- a normalized format with the smallest possible mantissa. +-- +newtype Kda = Kda_ Decimal + deriving stock (Show, Eq, Ord, Generic) + +-- | Smart constructor for KDA. It is an error if the Decimal has more than +-- twelf decimal digits. +-- +pattern Kda :: HasCallStack => Decimal -> Kda +pattern Kda { _kda } <- Kda_ _kda where + Kda k + | roundTo 12 k /= k = error "KDA value with a precision of more than 12 decimal digits" + | otherwise = Kda_ $ normalizeDecimal k +{-# COMPLETE Kda #-} + +stuToKda :: HasCallStack => Stu -> Kda +stuToKda (Stu k) = Kda $ normalizeDecimal $ Decimal 12 (fromIntegral k) + +kdaToStu :: Kda -> Stu +kdaToStu (Kda { _kda = s }) = Stu $ round (s * 1e12) + +-- -------------------------------------------------------------------------- -- +-- Miner Reward + +-- | Miner Reward in Stu +-- +newtype MinerReward = MinerReward { _minerReward :: Stu } + deriving (Show, Eq, Ord, Generic) + +minerRewardKda :: MinerReward -> Kda +minerRewardKda (MinerReward d) = stuToKda d + +-- | Calculate miner reward for a block at the given height. +-- +-- NOTE: +-- This used to compute the value as @roundTo 8 $ (_kda $ stuToKda m) / n@. +-- The new caclulcation based on Stu is equivalent for 10 and 20 chains, +-- except for the pre-last entry in the miner rewards table, namely +-- @(125538056,0.023999333). However, since this value hasen't yet been used +-- in any network, we can still change the algorithm. +-- +blockMinerReward + :: ChainwebVersion + -> BlockHeight + -> MinerReward +blockMinerReward v h = case M.lookupGE h minerRewards of + Nothing -> MinerReward $ Stu 0 + Just (_, s) -> MinerReward $ divideStu s n + where + !n = int . order $ chainGraphAt v h + +-- -------------------------------------------------------------------------- -- +-- Internal +-- -------------------------------------------------------------------------- -- + +-- -------------------------------------------------------------------------- -- +-- Miner Rewards Table + +type MinerRewardsTable = M.Map BlockHeight Stu + +-- | Rewards table mapping 3-month periods to their rewards according to the +-- calculated exponential decay over about a 120 year period (125538057 block +-- heights). +-- +-- It provides the total reward per block height accross all chains. Use the +-- 'blockMinerReward' function to obtain the reward for a single block at a +-- given block height. +-- +-- Morally this is a property of the Chainweb version, however there is no need +-- to use value different from what is used on Mainnet on any network. +-- +-- Mining rewards are between 0 and 24 KDA. Values decrease monotonically over +-- 125538057 block heights (about 120 years). +-- +minerRewards :: MinerRewardsTable +minerRewards = mkMinerRewards +{-# NOINLINE minerRewards #-} + +-- | Compute the miner rewards table. +-- +-- The indirection from 'minerReward' to 'mkMinerReward' is required because the +-- HasCallStack constraints prevents this value from being a CAF that gets +-- cached. +-- +mkMinerRewards :: HasCallStack => MinerRewardsTable +mkMinerRewards = + case CSV.decode CSV.NoHeader (BL.fromStrict rawMinerRewards) of + Left e -> error + $ "cannot construct miner rewards table: " <> sshow e + Right vs -> + let rewards = M.fromList . V.toList . V.map formatRow $ vs + in if (minerRewardsHash rewards == expectedMinerRewardsHash) + then rewards + else error $ "hash of miner rewards table does not match expected hash" + where + formatRow :: (Word64, CsvDecimal) -> (BlockHeight, Stu) + formatRow (!a,!b) = (BlockHeight $ int a, kdaToStu (Kda $ _csvDecimal b)) + +-- -------------------------------------------------------------------------- -- +-- Miner Rewards File + +-- | Read in the reward csv via TH for deployment purposes. +-- +-- Rewards are encoded in KDA with a precision of up to nine decimal digits. +-- +rawMinerRewards :: HasCallStack => B.ByteString +rawMinerRewards + | rawMinerRewardsHash rawBytes == expectedRawMinerRewardsHash = rawBytes + | otherwise = error "hash of raw miner rewards file does not match expected value." + where + rawBytes = $(embedFile "rewards/miner_rewards.csv") + +-- -------------------------------------------------------------------------- +-- Consistency Checks + +rawMinerRewardsHash :: B.ByteString -> Digest SHA512 +rawMinerRewardsHash = hash + +minerRewardsHash :: MinerRewardsTable -> Digest SHA512 +minerRewardsHash = hash + . runPutS + . traverse_ (\(k,v) -> encodeBlockHeight k >> putWord64le (fromIntegral v)) + . M.toAscList + +expectedMinerRewardsHash :: Digest SHA512 +expectedMinerRewardsHash = read "8e4fb006c5045b3baab638d16d62c952e4981a4ba473ec63620dfb54093d5104abd0be1a62ce52113575d598881fb57e84a41ec5c617e4348e270b9eacd300c9" + +expectedRawMinerRewardsHash :: Digest SHA512 +expectedRawMinerRewardsHash = read "903d10b06666c0d619c8a28c74c3bb0af47209002f005b12bbda7b7df1131b2072ce758c1a8148facb1506022215ea201629f38863feb285c7e66f5965498fe0" + diff --git a/src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs b/src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs index 38806cc8b2..5baec59759 100644 --- a/src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs +++ b/src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs @@ -26,7 +26,6 @@ module Chainweb.Pact.PactService.Pact4.ExecBlock ( execBlock , execTransactions , continueBlock - , minerReward , toPayloadWithOutputs , validateParsedChainwebTx , validateRawChainwebTx @@ -51,7 +50,6 @@ import Control.Monad.State.Strict import System.LogLevel (LogLevel(..)) import qualified Data.Aeson as A import qualified Data.ByteString.Short as SB -import Data.Decimal import Data.List qualified as List import Data.Either import Data.Foldable (toList) @@ -84,6 +82,7 @@ import Chainweb.BlockHeader import Chainweb.BlockHeight import Chainweb.Logger import Chainweb.Mempool.Mempool as Mempool +import Chainweb.MinerReward import Chainweb.Miner.Pact import Chainweb.Pact.Types @@ -408,13 +407,12 @@ runCoinbase miner enfCBFail usePrecomp mc = do then return noCoinbase else do logger <- view (psServiceEnv . psLogger) - rs <- view (psServiceEnv . psMinerRewards) v <- view chainwebVersion txCtx <- getTxContext miner Pact4.noPublicMeta let !bh = ctxCurrentBlockHeight txCtx - reward <- liftIO $! minerReward v rs bh + let reward = minerReward v bh dbEnv <- view psBlockDbEnv let pactDb = _cpPactDbEnv dbEnv @@ -591,31 +589,22 @@ debugResult msg result = limit = 5000 --- | Calculate miner reward. We want this to error hard in the case where --- block times have finally exceeded the 120-year range. Rewards are calculated --- at regular blockheight intervals. +-- | Calculate miner reward. -- -- See: 'rewards/miner_rewards.csv' -- minerReward :: ChainwebVersion - -> MinerRewards -> BlockHeight - -> IO Pact4.ParsedDecimal -minerReward v (MinerRewards rs) bh = - case Map.lookupGE bh rs of - Nothing -> err - Just (_, m) -> pure $! Pact4.ParsedDecimal (roundTo 8 (m / n)) - where - !n = int . order $ chainGraphAt v bh - err = internalError "block heights have been exhausted" + -> Pact4.ParsedDecimal +minerReward v = Pact4.ParsedDecimal + . _kda + . minerRewardKda + . blockMinerReward v {-# INLINE minerReward #-} - data CRLogPair = CRLogPair Pact4.Hash [Pact4.TxLogJson] - - instance J.Encode CRLogPair where build (CRLogPair h logs) = J.object [ "hash" J..= h diff --git a/src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs b/src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs index 93fe5a7224..7b9896addf 100644 --- a/src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs +++ b/src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs @@ -26,6 +26,7 @@ import Chainweb.BlockHeader import Chainweb.BlockHeight import Chainweb.Logger import Chainweb.Mempool.Mempool(BlockFill (..), pact5RequestKeyToTransactionHash, InsertError (..)) +import Chainweb.MinerReward import Chainweb.Miner.Pact import Chainweb.Pact5.Backend.ChainwebPactDb (Pact5Db(doPact5DbTransaction)) import Chainweb.Pact5.SPV qualified as Pact5 @@ -53,13 +54,11 @@ import Data.Coerce import Data.Decimal import Data.Either (partitionEithers) import Data.Foldable -import Data.Map qualified as Map import Data.Maybe import Data.Text qualified as T import Data.Vector (Vector) import Data.Vector qualified as V import Data.Void -import Numeric.Natural import Pact.Core.ChainData hiding (ChainId) import Pact.Core.Command.Types qualified as Pact5 import Pact.Core.Persistence qualified as Pact5 @@ -97,16 +96,9 @@ import Chainweb.Pact.Backend.Types -- minerReward :: ChainwebVersion - -> MinerRewards -> BlockHeight - -> IO Decimal -minerReward v (MinerRewards rs) bh = - case Map.lookupGE bh rs of - Nothing -> err - Just (_, m) -> pure $! roundTo 8 (m / n) - where - !n = int @Natural @Decimal . order $ chainGraphAt v bh - err = internalError "block heights have been exhausted" + -> Decimal +minerReward v = _kda . minerRewardKda . blockMinerReward v {-# INLINE minerReward #-} runCoinbase @@ -119,13 +111,12 @@ runCoinbase miner = do then return $ Right noCoinbase else do logger <- view (psServiceEnv . psLogger) - rs <- view (psServiceEnv . psMinerRewards) v <- view chainwebVersion txCtx <- TxContext <$> view psParentHeader <*> pure miner let !bh = ctxCurrentBlockHeight txCtx + let reward = minerReward v bh - reward <- liftIO $ minerReward v rs bh -- the coinbase request key is not passed here because TransactionIndex -- does not contain coinbase transactions pactTransaction Nothing $ \db -> diff --git a/test/unit/Chainweb/Test/MinerReward.hs b/test/unit/Chainweb/Test/MinerReward.hs new file mode 100644 index 0000000000..b69d999637 --- /dev/null +++ b/test/unit/Chainweb/Test/MinerReward.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE NumDecimals #-} +{-# LANGUAGE TypeApplications #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | +-- Module: Chainweb.Test.MinerReward +-- Copyright: Copyright © 2024 Kadena LLC. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +module Chainweb.Test.MinerReward +( tests +) where + +import Chainweb.BlockHeight +import Chainweb.MinerReward +import Chainweb.Test.Orphans.Internal () +import Chainweb.Utils +import Chainweb.Version +import Chainweb.Version.Mainnet + +import Data.ByteString.Lazy qualified as BL +import Data.Csv qualified as CSV +import Data.Decimal +import Data.Map.Strict qualified as M +import Data.Vector qualified as V +import Data.Word + +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +instance Arbitrary Stu where + arbitrary = Stu <$> arbitrary + +instance Arbitrary Kda where + arbitrary = fmap Kda $ Decimal <$> choose (0,12) <*> arbitrary + +newtype PositiveKda = PositiveKda { _positive :: Kda } + deriving (Show, Eq, Ord) + +instance Arbitrary PositiveKda where + arbitrary = fmap (PositiveKda . Kda) $ Decimal + <$> choose (0,12) + <*> (getNonNegative <$> arbitrary) + +tests :: TestTree +tests = testGroup "MinerReward" + [ testProperty "kdaToStuToKda" prop_kdaToStuToKda + , testProperty "stuToKdaToStu" prop_stuToKdaToStu + , testCase "finalReward" test_finalMinerReward + , testCase "minerRewardsMax" test_minerRewardsMax + , testCase "minerRewardsFitWord64" test_minerRewardsFitWord64 + , testCase "expectedMinerRewardsHash" test_expectedMinerRewardsHash + , testCase "expectedRawMinerRewardsHash" test_expectedRawMinerRewardsHash + , testCase "assert blockMinerRewardLegacyCompact" test_blockMinerRewardLegacyCompat + , testProperty "blockMinerRewardLegacyCompat" prop_blockMinerRewardLegacyCompat + ] + +-- -------------------------------------------------------------------------- +-- Properties and Assertions + +maxRewardHeight :: BlockHeight +maxRewardHeight = 125538057 + +prop_kdaToStuToKda :: PositiveKda -> Property +prop_kdaToStuToKda (PositiveKda kda) = stuToKda (kdaToStu kda) === kda + +prop_stuToKdaToStu :: Stu -> Property +prop_stuToKdaToStu stu = kdaToStu (stuToKda stu) === stu + +prop_blockMinerRewardLegacyCompat :: BlockHeight -> Property +prop_blockMinerRewardLegacyCompat h + | h < maxRewardHeight - 2 = + legacyBlockMinerReward v h === minerRewardKda (blockMinerReward v h) + | h == maxRewardHeight - 1 = + legacyBlockMinerReward v h =/= minerRewardKda (blockMinerReward v h) + | h == maxRewardHeight = + legacyBlockMinerReward v h === minerRewardKda (blockMinerReward v h) + | otherwise = expectFailure + -- legacyMinerRewards is expected to throw an exception + $ legacyBlockMinerReward v h === minerRewardKda (blockMinerReward v h) + + where + v = Mainnet01 + +-- 2.304523 +-- +test_finalMinerReward :: Assertion +test_finalMinerReward = do + mapM_ rewardIsZero $ take 100 [maxRewardHeight..] + mapM_ rewardIsZero $ take 10 [maxRewardHeight, (maxRewardHeight + 1000)..] + where + rewardIsZero h = assertEqual + "The final miner reward is 0" + (Kda 0) + (minerRewardKda (blockMinerReward Mainnet01 h)) + +test_minerRewardsMax :: Assertion +test_minerRewardsMax = assertBool + "maximum miner reward is smaller than 1e12 * 24" + (_stu (maximum minerRewards) < 1e12 * 24) + +test_minerRewardsFitWord64 :: Assertion +test_minerRewardsFitWord64 = assertBool + "maximum miner reward fits into Word64" + (_stu (maximum minerRewards) <= fromIntegral (maxBound @Word64)) + +test_expectedMinerRewardsHash :: Assertion +test_expectedMinerRewardsHash = assertEqual + "expected miner rewards hash" + expectedMinerRewardsHash + (minerRewardsHash minerRewards) + +test_expectedRawMinerRewardsHash :: Assertion +test_expectedRawMinerRewardsHash = assertEqual + "expected raw miner rewards hash" + expectedRawMinerRewardsHash + (rawMinerRewardsHash rawMinerRewards) + +-- -------------------------------------------------------------------------- +-- Backward compatibility with legacy implementation + +-- | Miner rewards are expected to match the legacy values execpt for +-- +-- - block height 125538056 and +-- - block heights strictly larger than 125538057 +-- +test_blockMinerRewardLegacyCompat :: Assertion +test_blockMinerRewardLegacyCompat = do + mapM_ rewardsMatch [0..10000] + mapM_ rewardsMatch [0,1000..maxRewardHeight - 2] + mapM_ rewardsMatch [maxRewardHeight - 1000 .. maxRewardHeight - 2] + mapM_ rewardsMatch [maxRewardHeight] + assertEqual + "the only block height that is not compatible with the legacy reward computation is 125538056" + [maxRewardHeight - 1] + legacyCompatExceptions + where + v = Mainnet01 + rewardsMatch h = assertEqual + "miner reward value matches the legacy value" + (legacyBlockMinerReward v h) + (minerRewardKda (blockMinerReward v h)) + + legacyCompatExceptions = M.keys $ M.filterWithKey + (\k _ -> legacyBlockMinerReward v k /= minerRewardKda (blockMinerReward v k)) + minerRewards + +-- This should be a CAF and can thus not include the computation in +-- 'mkLegacyMinerRewards' which has a 'HasCallStack' constraint. +-- +legacyMinerRewards :: M.Map BlockHeight Kda +legacyMinerRewards = Kda <$> mkLegacyMinerRewards +{-# NOINLINE legacyMinerRewards #-} + +-- | The algorithm that was used to parse the rewards table until end of 2024. +-- +mkLegacyMinerRewards :: HasCallStack => M.Map BlockHeight Decimal +mkLegacyMinerRewards = + case CSV.decode CSV.NoHeader (BL.fromStrict rawMinerRewards) of + Left e -> error + $ "cannot construct miner reward map: " <> sshow e + Right vs -> M.fromList . V.toList . V.map formatRow $ vs + where + formatRow :: (Word64, CsvDecimal) -> (BlockHeight, Decimal) + formatRow (!a,!b) = (BlockHeight $ int a, (_csvDecimal b)) + +legacyBlockMinerReward + :: ChainwebVersion + -> BlockHeight + -> Kda +legacyBlockMinerReward v h = + case M.lookupGE h legacyMinerRewards of + Nothing -> error "The end of the chain has been reached" + Just (_, m) -> Kda $ roundTo 8 (_kda m / n) + where + !n = int . order $ chainGraphAt v h + diff --git a/test/unit/Chainweb/Test/Pact4/RewardsTest.hs b/test/unit/Chainweb/Test/Pact4/RewardsTest.hs index 04e9d74791..ad8037200e 100644 --- a/test/unit/Chainweb/Test/Pact4/RewardsTest.hs +++ b/test/unit/Chainweb/Test/Pact4/RewardsTest.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE RankNTypes #-} module Chainweb.Test.Pact4.RewardsTest ( tests @@ -8,11 +7,8 @@ module Chainweb.Test.Pact4.RewardsTest import Test.Tasty import Test.Tasty.HUnit -import Pact.Parse - import Chainweb.Graph -import Chainweb.Miner.Pact -import Chainweb.Pact.PactService.Pact4.ExecBlock +import Chainweb.MinerReward import Chainweb.Test.TestVersions import Chainweb.Version @@ -26,21 +22,19 @@ tests = testGroup "Chainweb.Test.Pact4.RewardsTest" ] ] - rewardsTest :: HasCallStack => TestTree rewardsTest = testCaseSteps "rewards" $ \step -> do - let rs = readRewards - k = minerReward v rs + let k = _kda . minerRewardKda . blockMinerReward v step "block heights below initial threshold" - ParsedDecimal a <- k 0 + let a = k 0 assertEqual "initial miner reward is 2.304523" 2.304523 a step "block heights at threshold" - ParsedDecimal b <- k 87600 + let b = k 87600 assertEqual "max threshold miner reward is 2.304523" 2.304523 b step "block heights exceeding thresholds change" - ParsedDecimal c <- k 87601 + let c = k 87601 assertEqual "max threshold miner reward is 2.297878" 2.297878 c diff --git a/test/unit/ChainwebTests.hs b/test/unit/ChainwebTests.hs index 4eed5ccbf1..1a6bebb132 100644 --- a/test/unit/ChainwebTests.hs +++ b/test/unit/ChainwebTests.hs @@ -54,6 +54,7 @@ import qualified Chainweb.Test.Mempool.Consensus (tests) import qualified Chainweb.Test.Mempool.InMem (tests) import qualified Chainweb.Test.Mempool.RestAPI (tests) import qualified Chainweb.Test.Mempool.Sync (tests) +import qualified Chainweb.Test.MinerReward (tests) import qualified Chainweb.Test.Mining (tests) import qualified Chainweb.Test.Misc (tests) import qualified Chainweb.Test.Pact4.Checkpointer (tests) @@ -176,6 +177,7 @@ suite rdb = , Chainweb.Test.Mempool.Sync.tests , Chainweb.Test.Mempool.RestAPI.tests , Chainweb.Test.Mining.tests rdb + , Chainweb.Test.MinerReward.tests , Chainweb.Test.Misc.tests , Chainweb.Test.BlockHeader.Genesis.tests , Chainweb.Test.BlockHeader.Validation.tests From dd779c89acc534dfab6fd72291d76f6de05d11d4 Mon Sep 17 00:00:00 2001 From: Lars Kuhtz Date: Fri, 3 Jan 2025 13:58:50 -0800 Subject: [PATCH 8/8] Apply suggestions from code review Co-authored-by: chessai Co-authored-by: Edmund Noble --- src/Chainweb/MinerReward.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Chainweb/MinerReward.hs b/src/Chainweb/MinerReward.hs index af33dc63a3..ec867a08d1 100644 --- a/src/Chainweb/MinerReward.hs +++ b/src/Chainweb/MinerReward.hs @@ -124,7 +124,7 @@ newtype Kda = Kda_ Decimal deriving stock (Show, Eq, Ord, Generic) -- | Smart constructor for KDA. It is an error if the Decimal has more than --- twelf decimal digits. +-- twelve decimal digits. -- pattern Kda :: HasCallStack => Decimal -> Kda pattern Kda { _kda } <- Kda_ _kda where @@ -209,12 +209,12 @@ mkMinerRewards = $ "cannot construct miner rewards table: " <> sshow e Right vs -> let rewards = M.fromList . V.toList . V.map formatRow $ vs - in if (minerRewardsHash rewards == expectedMinerRewardsHash) + in if minerRewardsHash rewards == expectedMinerRewardsHash then rewards else error $ "hash of miner rewards table does not match expected hash" where formatRow :: (Word64, CsvDecimal) -> (BlockHeight, Stu) - formatRow (!a,!b) = (BlockHeight $ int a, kdaToStu (Kda $ _csvDecimal b)) + formatRow (a, b) = (BlockHeight $ int a, kdaToStu (Kda $ _csvDecimal b)) -- -------------------------------------------------------------------------- -- -- Miner Rewards File