From cb1b4c1ce6407f1a0ac8cbbb3251ddbc26f0487a Mon Sep 17 00:00:00 2001 From: chessai Date: Mon, 1 Jul 2024 17:26:43 -0500 Subject: [PATCH] stop exporting BlockHeader constructor from Chainweb.BlockHeader Change-Id: Id6200af01359d9012ea532a485ac25d2ab36d0c5 --- bench/Chainweb/Pact/Backend/Bench.hs | 16 +- bench/Chainweb/Pact/Backend/ForkingBench.hs | 8 +- chainweb.cabal | 1 + node/ChainwebNode.hs | 2 +- src/Chainweb/BlockHeader.hs | 1247 ++--------------- src/Chainweb/BlockHeader/Internal.hs | 1182 ++++++++++++++++ src/Chainweb/BlockHeader/Validation.hs | 74 +- src/Chainweb/BlockHeaderDB/Internal.hs | 10 +- src/Chainweb/BlockHeaderDB/PruneForks.hs | 27 +- src/Chainweb/BlockHeaderDB/RestAPI/Server.hs | 12 +- src/Chainweb/Chainweb/MinerResources.hs | 2 +- src/Chainweb/Chainweb/PruneChainDatabase.hs | 11 +- src/Chainweb/Cut.hs | 40 +- src/Chainweb/Cut/Create.hs | 26 +- src/Chainweb/Cut/CutHashes.hs | 4 +- src/Chainweb/CutDB.hs | 12 +- src/Chainweb/Mempool/Consensus.hs | 9 +- src/Chainweb/Miner/Coordinator.hs | 14 +- src/Chainweb/Pact/Backend/ChainwebPactDb.hs | 4 +- .../Backend/PactState/GrandHash/Import.hs | 8 +- .../Pact/Backend/PactState/GrandHash/Utils.hs | 18 +- .../Pact/Backend/RelationalCheckpointer.hs | 21 +- src/Chainweb/Pact/PactService.hs | 62 +- src/Chainweb/Pact/PactService/Checkpointer.hs | 18 +- src/Chainweb/Pact/PactService/ExecBlock.hs | 14 +- src/Chainweb/Pact/RestAPI/Server.hs | 16 +- src/Chainweb/Pact/SPV.hs | 20 +- src/Chainweb/Pact/TransactionExec.hs | 8 +- src/Chainweb/Pact/Types.hs | 18 +- src/Chainweb/Pact/Validations.hs | 4 +- src/Chainweb/Rosetta/Internal.hs | 8 +- src/Chainweb/Rosetta/Utils.hs | 17 +- src/Chainweb/SPV/CreateProof.hs | 28 +- src/Chainweb/SPV/EventProof.hs | 11 +- src/Chainweb/SPV/OutputProof.hs | 11 +- src/Chainweb/Sync/WebBlockHeaderStore.hs | 20 +- src/Chainweb/TreeDB/RemoteDB.hs | 5 +- src/Chainweb/WebBlockHeaderDB.hs | 14 +- test/Chainweb/Test/BlockHeader/Genesis.hs | 10 +- test/Chainweb/Test/BlockHeader/Validation.hs | 10 +- .../Chainweb/Test/BlockHeaderDB/PruneForks.hs | 28 +- test/Chainweb/Test/Cut.hs | 8 +- test/Chainweb/Test/CutDB.hs | 28 +- test/Chainweb/Test/Mempool/Consensus.hs | 25 +- test/Chainweb/Test/MultiNode.hs | 14 +- test/Chainweb/Test/Orphans/Internal.hs | 3 +- test/Chainweb/Test/Pact/Checkpointer.hs | 15 +- .../Test/Pact/ModuleCacheOnRestart.hs | 5 +- test/Chainweb/Test/Pact/PactMultiChainTest.hs | 12 +- test/Chainweb/Test/Pact/PactReplay.hs | 26 +- .../Chainweb/Test/Pact/PactSingleChainTest.hs | 28 +- test/Chainweb/Test/Pact/SPV.hs | 8 +- test/Chainweb/Test/Pact/TTL.hs | 11 +- test/Chainweb/Test/Pact/TransactionTests.hs | 21 +- test/Chainweb/Test/Pact/Utils.hs | 4 +- .../VerifierPluginTest/Transaction/Utils.hs | 10 +- test/Chainweb/Test/RestAPI.hs | 6 +- test/Chainweb/Test/SPV.hs | 30 +- test/Chainweb/Test/TreeDB.hs | 10 +- test/Chainweb/Test/Utils.hs | 14 +- test/Chainweb/Test/Utils/BlockHeader.hs | 14 +- test/Chainweb/Test/Utils/TestHeader.hs | 8 +- test/Chainweb/Test/Version.hs | 11 +- tools/cwtool/TxSimulator.hs | 4 +- tools/header-dump/HeaderDump.hs | 22 +- tools/txstream/TxStream.hs | 12 +- 66 files changed, 1785 insertions(+), 1634 deletions(-) create mode 100644 src/Chainweb/BlockHeader/Internal.hs diff --git a/bench/Chainweb/Pact/Backend/Bench.hs b/bench/Chainweb/Pact/Backend/Bench.hs index 0968229ee9..1cf6ac962e 100644 --- a/bench/Chainweb/Pact/Backend/Bench.hs +++ b/bench/Chainweb/Pact/Backend/Bench.hs @@ -14,9 +14,11 @@ module Chainweb.Pact.Backend.Bench import Control.Concurrent +import Control.Lens (view, (.~)) import Control.Monad import Control.Monad.Catch import qualified Criterion.Main as C +import Data.Function ((&)) import qualified Data.Vector as V import qualified Data.ByteString as B @@ -46,7 +48,7 @@ import qualified Pact.Types.SQLite as PSQL -- chainweb imports import Chainweb.BlockHash -import Chainweb.BlockHeader +import Chainweb.BlockHeader.Internal import Chainweb.Graph import Chainweb.Logger import Chainweb.MerkleLogHash @@ -78,11 +80,13 @@ cpRestoreAndSave cp pc blks = snd <$> _cpRestoreAndSave cp (ParentHeader <$> pc) -- | fabricate a `BlockHeader` for a block given its hash and its parent. childOf :: Maybe BlockHeader -> BlockHash -> BlockHeader -childOf (Just bh) bhsh = - bh { _blockHash = bhsh, _blockParent = _blockHash bh, _blockHeight = _blockHeight bh + 1 } -childOf Nothing bhsh = - (genesisBlockHeader testVer testChainId) { _blockHash = bhsh } - +childOf m bhsh = case m of + Just bh -> bh + & blockHash .~ bhsh + & blockParent .~ view blockHash bh + & blockHeight .~ view blockHeight bh + 1 + Nothing -> genesisBlockHeader testVer testChainId + & blockHash .~ bhsh bench :: C.Benchmark bench = C.bgroup "pact-backend" $ diff --git a/bench/Chainweb/Pact/Backend/ForkingBench.hs b/bench/Chainweb/Pact/Backend/ForkingBench.hs index 2487557bd7..758192fcca 100644 --- a/bench/Chainweb/Pact/Backend/ForkingBench.hs +++ b/bench/Chainweb/Pact/Backend/ForkingBench.hs @@ -207,7 +207,7 @@ playLine pdb bhdb trunkLength startingBlock pactQueue counter = do evalStateT (runReaderT (mapM (const go) [startHeight :: Word64 .. pred (startHeight + l)]) pactQueue) start where startHeight :: Num a => a - startHeight = fromIntegral $ _blockHeight start + startHeight = fromIntegral $ view blockHeight start go = do r <- ask pblock <- gets ParentHeader @@ -226,7 +226,7 @@ mineBlock -> IO (T3 ParentHeader BlockHeader PayloadWithOutputs) mineBlock parent nonce pdb bhdb pact = do r@(T3 _ newHeader payload) <- createBlock DoValidate parent nonce pact - addNewPayload pdb (succ (_blockHeight (_parentHeader parent))) payload + addNewPayload pdb (succ (view blockHeight (_parentHeader parent))) payload -- NOTE: this doesn't validate the block header, which is fine in this test case unsafeInsertBlockHeaderDb bhdb newHeader return r @@ -244,7 +244,7 @@ createBlock validate parent nonce pact = do bip <- throwIfNoHistory =<< newBlock noMiner NewBlockFill parent pact let payload = blockInProgressToPayloadWithOutputs bip - let creationTime = add second $ _blockCreationTime $ _parentHeader parent + let creationTime = add second $ view blockCreationTime $ _parentHeader parent let bh = newBlockHeader mempty (_payloadWithOutputsPayloadHash payload) @@ -368,7 +368,7 @@ testMemPoolAccess txsPerBlock accounts = do return $ mempty { mpaGetBlock = \bf validate bh hash header -> do if _bfCount bf /= 0 then pure mempty else do - testBlock <- getTestBlock accounts (_bct $ _blockCreationTime header) validate bh hash + testBlock <- getTestBlock accounts (_bct $ view blockCreationTime header) validate bh hash pure testBlock } where diff --git a/chainweb.cabal b/chainweb.cabal index a8b1bfde49..c62ab0e340 100644 --- a/chainweb.cabal +++ b/chainweb.cabal @@ -136,6 +136,7 @@ library , Chainweb.BlockCreationTime , Chainweb.BlockHash , Chainweb.BlockHeader + , Chainweb.BlockHeader.Internal , Chainweb.BlockHeader.Genesis.RecapDevelopment0Payload , Chainweb.BlockHeader.Genesis.RecapDevelopment1to9Payload , Chainweb.BlockHeader.Genesis.RecapDevelopment10to19Payload diff --git a/node/ChainwebNode.hs b/node/ChainwebNode.hs index 057f33e485..f67ea568cc 100644 --- a/node/ChainwebNode.hs +++ b/node/ChainwebNode.hs @@ -251,7 +251,7 @@ runBlockUpdateMonitor logger db = L.withLoggerLabel ("component", "block-update- txCount :: BlockHeader -> IO Int txCount bh = do - bp <- lookupPayloadDataWithHeight payloadDb (Just $ _blockHeight bh) (_blockPayloadHash bh) >>= \case + bp <- lookupPayloadDataWithHeight payloadDb (Just $ view blockHeight bh) (view blockPayloadHash bh) >>= \case Nothing -> error "block payload not found" Just x -> return x return $ length $ _payloadDataTransactions bp diff --git a/src/Chainweb/BlockHeader.hs b/src/Chainweb/BlockHeader.hs index ccf7da04c8..c675850411 100644 --- a/src/Chainweb/BlockHeader.hs +++ b/src/Chainweb/BlockHeader.hs @@ -1,1188 +1,143 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE EmptyCase #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ImportQualifiedPost #-} --- | --- Module: Chainweb.BlockHeader --- Copyright: Copyright © 2018 Kadena LLC. --- License: MIT --- Maintainer: Lars Kuhtz --- Stability: experimental --- module Chainweb.BlockHeader ( -- * Newtype wrappers for function parameters - ParentHeader(..) -, parentHeader -, ParentCreationTime(..) + I.ParentHeader(..) +, I.parentHeader +, I.ParentCreationTime(..) -- * Block Payload Hash -, BlockPayloadHash -, BlockPayloadHash_(..) -, encodeBlockPayloadHash -, decodeBlockPayloadHash +, I.BlockPayloadHash +, I.BlockPayloadHash_(..) +, I.encodeBlockPayloadHash +, I.decodeBlockPayloadHash -- * Nonce -, Nonce(..) -, encodeNonce -, encodeNonceToWord64 -, decodeNonce +, I.Nonce(..) +, I.encodeNonce +, I.encodeNonceToWord64 +, I.decodeNonce -- * EpochStartTime -, EpochStartTime(..) -, encodeEpochStartTime -, decodeEpochStartTime -, epochStart +, I.EpochStartTime(..) +, I.encodeEpochStartTime +, I.decodeEpochStartTime +, I.epochStart -- * FeatureFlags -, FeatureFlags -, mkFeatureFlags -, encodeFeatureFlags -, decodeFeatureFlags +, I.FeatureFlags +, I.mkFeatureFlags +, I.encodeFeatureFlags +, I.decodeFeatureFlags -- * POW Target -, powTarget +, I.powTarget -- * BlockHeader -, BlockHeader(..) -, blockNonce -, blockChainId -, blockHeight -, blockWeight -, blockChainwebVersion -, blockAdjacentHashes +, I.BlockHeader +-- ** Getters +, blockFlags , blockCreationTime -, blockHash , blockParent -, blockPayloadHash +, blockAdjacentHashes , blockTarget +, blockPayloadHash +, blockChainId +, blockWeight +, blockHeight +, blockChainwebVersion , blockEpochStart -, blockFlags -, _blockPow -, blockPow -, _blockAdjacentChainIds -, blockAdjacentChainIds -, encodeBlockHeader -, encodeBlockHeaderWithoutHash -, decodeBlockHeader -, decodeBlockHeaderWithoutHash -, decodeBlockHeaderChecked -, decodeBlockHeaderCheckedChainId -, blockHeaderShortDescription -, ObjectEncoded(..) - -, timeBetween -, getAdjacentHash -, computeBlockHash -, adjacentChainIds -, absBlockHeightDiff +, blockNonce +, blockHash +-- ** Utilities +, I._blockPow +, I.blockPow +, I._blockAdjacentChainIds +, I.blockAdjacentChainIds +, I.encodeBlockHeader +, I.encodeBlockHeaderWithoutHash +, I.decodeBlockHeader +, I.decodeBlockHeaderWithoutHash +, I.decodeBlockHeaderChecked +, I.decodeBlockHeaderCheckedChainId +, I.blockHeaderShortDescription +, I.ObjectEncoded(..) + +, I.timeBetween +, I.getAdjacentHash +, I.computeBlockHash +, I.adjacentChainIds +, I.absBlockHeightDiff -- * IsBlockHeader -, IsBlockHeader(..) +, I.IsBlockHeader(..) -- * Genesis BlockHeader -, isGenesisBlockHeader -, genesisParentBlockHash -, genesisBlockHeader -, genesisBlockHeaders -, genesisBlockHeadersAtHeight -, genesisHeight -, headerSizes -, headerSizeBytes -, workSizeBytes +, I.isGenesisBlockHeader +, I.genesisParentBlockHash +, I.genesisBlockHeader +, I.genesisBlockHeaders +, I.genesisBlockHeadersAtHeight +, I.genesisHeight +, I.headerSizes +, I.headerSizeBytes +, I.workSizeBytes -- * Create a new BlockHeader -, newBlockHeader +, I.newBlockHeader -- * CAS Constraint -, BlockHeaderCas -) where - -import Control.DeepSeq -import Control.Exception -import Control.Lens hiding ((.=)) -import Control.Monad.Catch - -import Data.Aeson -import Data.Aeson.Types (Parser) -import Data.Function (on) -import Data.Hashable -import qualified Data.HashMap.Strict as HM -import Data.HashMap.Strict (HashMap) -import qualified Data.HashSet as HS -import Data.IORef -import qualified Data.List.NonEmpty as NE -import Data.Kind -import qualified Data.Memory.Endian as BA -import Data.MerkleLog hiding (Actual, Expected, MerkleHash) -import qualified Data.Text as T -import Data.Word - -import GHC.Generics (Generic) -import GHC.Stack -import Numeric.Natural - --- Internal imports - -import Chainweb.BlockCreationTime -import Chainweb.BlockHash -import Chainweb.BlockHeight -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.Time -import Chainweb.TreeDB (TreeDbEntry(..)) -import Chainweb.Utils -import Chainweb.Utils.Rule -import Chainweb.Utils.Serialization -import Chainweb.Version -import Chainweb.Version.Guards -import Chainweb.Version.Mainnet -import Chainweb.Version.Testnet -import Chainweb.Version.Registry (lookupVersionByName) - -import Chainweb.Storage.Table - -import Crypto.Hash.Algorithms - -import Numeric.AffineSpace - -import System.IO.Unsafe -import Text.Read (readEither) - --- -------------------------------------------------------------------------- -- --- Nonce - -newtype Nonce = Nonce Word64 - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData) - deriving newtype (Hashable,Enum) - -instance MerkleHashAlgorithm a => IsMerkleLogEntry a ChainwebHashTag Nonce where - type Tag Nonce = 'BlockNonceTag - toMerkleNode = encodeMerkleInputNode encodeNonce - fromMerkleNode = decodeMerkleInputNode decodeNonce - {-# INLINE toMerkleNode #-} - {-# INLINE fromMerkleNode #-} - -encodeNonce :: Nonce -> Put -encodeNonce (Nonce n) = putWord64le n - -encodeNonceToWord64 :: Nonce -> Word64 -encodeNonceToWord64 (Nonce n) = BA.unLE $ BA.toLE n - -decodeNonce :: Get Nonce -decodeNonce = Nonce <$> getWord64le - -instance ToJSON Nonce where - toJSON (Nonce i) = toJSON $ show i - toEncoding (Nonce i) = toEncoding $ show i - {-# INLINE toJSON #-} - {-# INLINE toEncoding #-} - -instance FromJSON Nonce where - parseJSON = withText "Nonce" - $ either fail (return . Nonce) . readEither . T.unpack - --- -------------------------------------------------------------------------- -- --- POW Target Computation - -newtype EpochStartTime = EpochStartTime (Time Micros) - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData) - deriving newtype (ToJSON, FromJSON, Hashable, LeftTorsor) - -instance MerkleHashAlgorithm a => IsMerkleLogEntry a ChainwebHashTag EpochStartTime where - type Tag EpochStartTime = 'EpochStartTimeTag - toMerkleNode = encodeMerkleInputNode encodeEpochStartTime - fromMerkleNode = decodeMerkleInputNode decodeEpochStartTime - {-# INLINE toMerkleNode #-} - {-# INLINE fromMerkleNode #-} - -encodeEpochStartTime :: EpochStartTime -> Put -encodeEpochStartTime (EpochStartTime t) = encodeTime t - -decodeEpochStartTime :: Get EpochStartTime -decodeEpochStartTime = EpochStartTime <$> decodeTime - --- ----------------------------------------------------------------------------- --- Feature Flags - -newtype FeatureFlags = FeatureFlags Word64 - deriving stock (Show, Eq, Generic) - deriving anyclass (NFData) - deriving newtype (ToJSON, FromJSON) - -encodeFeatureFlags :: FeatureFlags -> Put -encodeFeatureFlags (FeatureFlags ff) = putWord64le ff - -decodeFeatureFlags :: Get FeatureFlags -decodeFeatureFlags = FeatureFlags <$> getWord64le - -instance MerkleHashAlgorithm a => IsMerkleLogEntry a ChainwebHashTag FeatureFlags where - type Tag FeatureFlags = 'FeatureFlagsTag - toMerkleNode = encodeMerkleInputNode encodeFeatureFlags - fromMerkleNode = decodeMerkleInputNode decodeFeatureFlags - -mkFeatureFlags :: FeatureFlags -mkFeatureFlags = FeatureFlags 0x0 - --- -------------------------------------------------------------------------- -- --- Block Header - --- | BlockHeader --- --- Values of this type should never be constructed directly by external code. --- Instead the 'newBlockHeader' smart constructor should be used. Once --- constructed 'BlockHeader' values must not be modified. --- --- Some redundant, aggregated information is included in the block and the block --- hash. This enables nodes to check blocks inductively with respect to existing --- blocks without recalculating the aggregated value from the genesis block --- onward. --- --- The POW hash is not included, since it can be derived from the Nonce and the --- other fields of the 'BlockHeader'. --- --- /IMPORTANT/: Fields in this record must have pairwise distinct types. --- -data BlockHeader :: Type where - BlockHeader :: - { _blockFlags :: {-# UNPACK #-} !FeatureFlags - -- ^ An 8-byte bitmask reserved for the future addition of boolean - -- "feature flags". - - , _blockCreationTime :: {-# UNPACK #-} !BlockCreationTime - -- ^ The time when the block was creates as recorded by the miner - -- of the block. The value must be strictly monotonically increasing - -- within the chain of blocks. Nodes must ignore blocks with values - -- that are in the future and reconsider a block when its value is - -- in the past. Nodes do not have to store blocks until they become - -- recent (but may do it). - -- - -- The block creation time is used to determine the block difficulty for - -- future blocks. - -- - -- Nodes are not supposed to consider the creation time when - -- choosing between two valid (this implies that creation time of a - -- block is not the future) forks. - -- - -- This creates an incentive for nodes to maintain an accurate clock - -- with respect to an (unspecified) commonly accepted time source, - -- such as the public NTP network. - -- - -- It is possible that a miner always chooses the smallest possible - -- creation time value. It is not clear what advantage a miner would - -- gain from doing so, but attack models should consider and - -- investigate such behavior. - -- - -- On the other hand miners may choose to compute forks with creation - -- time long in the future. By doing so, the difficulty on such a fork - -- would decrease allowing the miner to compute very long chains very - -- quickly. However, those chains would become valid only after a long - -- time passed and would be of low PoW weight. The algorithm for - -- computing the difficulty must ensure this strategy doesn't give - -- an advantage to an attacker that would increase the success - -- probability for an attack. - - , _blockParent :: {-# UNPACK #-} !BlockHash - -- ^ authoritative - - , _blockAdjacentHashes :: !BlockHashRecord - -- ^ authoritative - - , _blockTarget :: {-# UNPACK #-} !HashTarget - -- ^ authoritative - - , _blockPayloadHash :: {-# UNPACK #-} !BlockPayloadHash - -- ^ authoritative - - , _blockChainId :: {-# UNPACK #-} !ChainId - - , _blockWeight :: {-# UNPACK #-} !BlockWeight - -- ^ the accumulated weight of the chain. It is redundant information - -- that is subject to the inductive property that the block weight - -- of a block is the block weight of the parent plus the difficulty - -- of the block. - - , _blockHeight :: {-# UNPACK #-} !BlockHeight - -- ^ block height records the length of the chain. It is redundant - -- information and thus subject the inductive property that - -- the block height of a block is the block height of its parent - -- plus one. - - , _blockChainwebVersion :: !ChainwebVersionCode - -- ^ the Chainweb version is a constant for the chain. A chain - -- is uniquely identified by its genesis block. Thus this is - -- redundant information and thus subject to the inductive property - -- that the Chainweb version of a block equals the Chainweb version - -- of its parent. - - , _blockEpochStart :: {-# UNPACK #-} !EpochStartTime - -- ^ The start time of the current difficulty adjustment epoch. - -- Epochs divide the sequence of blocks in the chain into continuous - -- ranges of blocks. Each epoch is defined by the minimal block - -- height of the blocks in the epoch. - - , _blockNonce :: {-# UNPACK #-} !Nonce - -- ^ authoritative - - , _blockHash :: {-# UNPACK #-} !BlockHash - -- ^ the hash of the block. It includes all of the above block properties. - } - -> BlockHeader - deriving (Show, Generic) - deriving anyclass (NFData) - -instance Eq BlockHeader where - (==) = (==) `on` _blockHash - {-# INLINE (==) #-} - -instance Ord BlockHeader where - compare = compare `on` _blockHash - -instance Hashable BlockHeader where - hashWithSalt s = hashWithSalt s . _blockHash - -instance HasChainId BlockHeader where - _chainId = _blockChainId - -instance HasChainGraph BlockHeader where - _chainGraph h = _chainGraph (_chainwebVersion h, _blockHeight h) - -instance HasChainwebVersion BlockHeader where - _chainwebVersion = _chainwebVersion . _blockChainwebVersion - -instance IsCasValue BlockHeader where - type CasKeyType BlockHeader = BlockHash - casKey = _blockHash - {-# INLINE casKey #-} - -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 - [ toText (_chainId bh) - , "@" - , blockHashToTextShort (_blockHash bh) - , "(height " <> sshow (getBlockHeight $ _blockHeight bh) <> ")" - ] - -makeLenses ''BlockHeader - --- | During the first epoch after genesis there are 10 extra difficulty --- adjustments. This is to account for rapidly changing total hash power in the --- early stages of the network. --- -effectiveWindow :: BlockHeader -> Maybe WindowWidth -effectiveWindow h = WindowWidth <$> case _versionWindow (_chainwebVersion h) of - WindowWidth w - | int (_blockHeight h) <= w -> Just $ max 1 $ w `div` 10 - | otherwise -> Just w - --- | Return whether the given 'BlockHeader' is the last header in its epoch. --- -isLastInEpoch :: BlockHeader -> Bool -isLastInEpoch h = case effectiveWindow h of - Nothing -> False - Just (WindowWidth w) - | (int (_blockHeight h) + 1) `mod` w == 0 -> True - | otherwise -> False - --- | If it is discovered that the last DA occured significantly in the past, we --- assume that a large amount of hash power has suddenly dropped out of the --- network. Thus we must perform Emergency Difficulty Adjustment to avoid --- stalling the chain. --- --- NOTE: emergency DAs are now regarded a misfeature and have been disabled in --- all chainweb version. Emergency DAs are enabled (and have occured) only on --- mainnet01 for cut heights smaller than 80,000. --- -slowEpoch :: ParentHeader -> BlockCreationTime -> Bool -slowEpoch (ParentHeader p) (BlockCreationTime ct) = actual > (expected * 5) - where - EpochStartTime es = _blockEpochStart p - v = _chainwebVersion p - BlockDelay bd = _versionBlockDelay v - WindowWidth ww = _versionWindow v - - expected :: Micros - expected = bd * int ww - - actual :: Micros - actual = timeSpanToMicros $ ct .-. es - --- | Compute the POW target for a new BlockHeader. --- --- Alternatively, the new chains can use a higher target and the target of the --- old chains arent' adjusted. That includes the risk of larger orphan rates. In --- particular after the first and second DA, the current DA will compute targets --- that are averages between chains, which cause the difficulty to go donwn --- globally. This is usually mostly mitigated after the third DA after the --- transition. --- -powTarget - :: ParentHeader - -- ^ parent header - -> HM.HashMap ChainId ParentHeader - -- ^ adjacent Parents - -> BlockCreationTime - -- ^ block creation time of new block - -- - -- This parameter is used only when @oldTargetGuard@ is @True@. - -- - -> HashTarget - -- ^ POW target of new block -powTarget p@(ParentHeader ph) as bct = case effectiveWindow ph of - Nothing -> maxTarget - Just w - -- Emergency DA, legacy - | slowEpochGuard ver (_chainId ph) (_blockHeight ph) && slowEpoch p bct -> - activeAdjust w - | isLastInEpoch ph -> activeAdjust w - | otherwise -> _blockTarget ph - where - ver = _chainwebVersion ph - t = EpochStartTime $ if oldTargetGuard ver (_chainId ph) (_blockHeight ph) - then _bct bct - else _bct (_blockCreationTime ph) - - activeAdjust w - | oldDaGuard ver (_chainId ph) (_blockHeight ph + 1) - = legacyAdjust (_versionBlockDelay ver) w (t .-. _blockEpochStart ph) (_blockTarget ph) - | otherwise - = avgTarget $ adjustForParent w <$> (p : HM.elems as) - - adjustForParent w (ParentHeader a) - = adjust (_versionBlockDelay ver) w (toEpochStart a .-. _blockEpochStart a) (_blockTarget a) - - toEpochStart = EpochStartTime . _bct . _blockCreationTime - - avgTarget targets = HashTarget $ floor $ s / int (length targets) - where - s = sum $ fmap (int @_ @Rational . _hashTarget) targets -{-# INLINE powTarget #-} - --- | Compute the epoch start value for a new BlockHeader --- -epochStart - :: ParentHeader - -- ^ parent header - -> HM.HashMap ChainId ParentHeader - -- ^ Adjacent parents of the block. It is not checked whether the - -- set of adjacent parents conforms with the current graph. - -> BlockCreationTime - -- ^ block creation time of new block - -- - -- This parameter is used only when @oldTargetGuard@ is @True@. - -- - -> EpochStartTime - -- ^ epoch start time of new block -epochStart ph@(ParentHeader p) adj (BlockCreationTime bt) - | Nothing <- effectiveWindow p = _blockEpochStart p - - -- A special case for starting a new devnet, to compensate the inaccurate - -- creation time of the genesis blocks. This would result in a very long - -- first epoch that cause a trivial target in the second epoch. - | ver ^. versionCheats . fakeFirstEpochStart, _blockHeight p == 1 = EpochStartTime (_bct $ _blockCreationTime p) - - -- New Graph: the block time of the genesis block isn't accurate, we thus - -- use the block time of the first block on the chain. Depending on where - -- this is within an epoch, this can cause a shorter epoch, which could - -- cause a larger difficulty and a reduced target. That is fine, since new - -- chains are expected to start with a low difficulty. - | parentIsFirstOnNewChain = EpochStartTime (_bct $ _blockCreationTime p) - - -- End of epoch, DA adjustment (legacy version) - | isLastInEpoch p && oldTargetGuard ver (_chainId p) (_blockHeight p) = EpochStartTime bt - - -- End of epoch, DA adjustment - | isLastInEpoch p = EpochStartTime (_bct $ _blockCreationTime p) - - -- Within epoch with old legacy DA - | oldDaGuard ver (_chainId p) (_blockHeight p + 1) = _blockEpochStart p - - -- Within an epoch with new DA - | otherwise = _blockEpochStart p - - -- Experimental, allow DA to support multiple hash functions - -- | otherwise = _blockEpochStart p .+^ _adjustmentAvg - where - ver = _chainwebVersion p - cid = _chainId p - - -- Add a penalty for fast chains by adding the different between the - -- creation time of the current chain and the maximum of the adjacent chains - -- to the epoch start time. By shortening the epoch DA is going to adjust to - -- a higher difficulty. - -- - -- This DA has the disadvantage, that it adjusts to a block rate that is - -- smaller than the targeted blockrate, because with high probablity all - -- chains are receiving some positive penalty. - -- - -- Properties of DA: - -- - -- * Requires that miners set creation time >0.5 of solve time. - -- * Requires correction factor for targeted block rate. - -- * Can handle non continuous non uniform distribution of hash power - -- accross chains. - -- - _adjustmentMax = maximum adjCreationTimes .-. _blockCreationTime p - -- the maximum is at least @_blockCreationTime p@ and thus the result is - -- greater or equal 0. - - -- This computes @mean adjCreationTimes - _blockCreationTime p - -- - -- It holds that - -- - -- \(\left(mean_{0 \leq i < n} a_i\right) - -- = \frac{\sum_{0 \leq i < n} a_i}{n} - t - -- = \frac{\left(sum_{0 \leq i < n} a_i\right) - \left(\sum_{0 \leq i < n} t\right)}{n} - -- = \frac{sum_{0 \leq i < n} (a_i - t)}{n} - -- \) - -- - -- this is numberically sound because we compute the differences on integral - -- types without rounding. - -- - -- Properties of DA: - -- - -- * Requires that miners set creation time >0.5 of solve time - -- * Can handle non continuous non uniform distribution of hash power - -- accross chains. - -- - _adjustmentAvg = x `divTimeSpan` length adjCreationTimes - where - x :: TimeSpan Micros - x = foldr1 addTimeSpan $ (.-. _blockCreationTime p) <$> adjCreationTimes - - -- This includes the parent header itself, but excludes any adjacent genesis - -- headers which usually don't have accurate creation time. - -- - -- The result is guaranteed to be non-empty - -- - adjCreationTimes = fmap (_blockCreationTime) - $ HM.insert cid (_parentHeader ph) - $ HM.filter (not . isGenesisBlockHeader) - $ fmap _parentHeader adj - - parentIsFirstOnNewChain - = _blockHeight p > 1 && _blockHeight p == genesisHeight ver cid + 1 -{-# INLINE epochStart #-} - --- -------------------------------------------------------------------------- -- --- Newtype wrappers for function parameters - -newtype ParentCreationTime = ParentCreationTime - { _parentCreationTime :: BlockCreationTime } - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData) - deriving newtype (ToJSON, FromJSON, Hashable, LeftTorsor) - -newtype ParentHeader = ParentHeader - { _parentHeader :: BlockHeader } - deriving (Show, Eq, Ord, Generic) - deriving anyclass (NFData) - -parentHeader :: Lens' ParentHeader BlockHeader -parentHeader = lens _parentHeader $ \_ hdr -> ParentHeader hdr - -instance HasChainId ParentHeader where - _chainId = _chainId . _parentHeader - {-# INLINE _chainId #-} - -instance HasChainwebVersion ParentHeader where - _chainwebVersion = _chainwebVersion . _parentHeader - {-# INLINE _chainwebVersion #-} - -instance HasChainGraph ParentHeader where - _chainGraph = _chainGraph . _parentHeader - {-# INLINE _chainGraph #-} - -isGenesisBlockHeader :: BlockHeader -> Bool -isGenesisBlockHeader b = - _blockHeight b == genesisHeight (_chainwebVersion b) (_chainId b) - --- | The genesis block hash includes the Chainweb version and the 'ChainId' --- within the Chainweb version. --- --- It is the '_blockParent' of the genesis block --- -genesisParentBlockHash :: HasChainId p => ChainwebVersion -> p -> BlockHash -genesisParentBlockHash v p = BlockHash $ MerkleLogHash - $ merkleRoot $ merkleTree @ChainwebMerkleHashAlgorithm - [ InputNode "CHAINWEB_GENESIS" - , encodeMerkleInputNode encodeChainwebVersionCode (_versionCode v) - , encodeMerkleInputNode encodeChainId (_chainId p) - ] - -{-# NOINLINE genesisBlockHeaderCache #-} -genesisBlockHeaderCache :: IORef (HashMap ChainwebVersionCode (HashMap ChainId BlockHeader)) -genesisBlockHeaderCache = unsafePerformIO $ do - newIORef HM.empty - --- | A block chain is globally uniquely identified by its genesis hash. --- Internally, we use the 'ChainwebVersionTag value and the 'ChainId' --- as identifiers. We thus include the 'ChainwebVersionTag value and the --- 'ChainId' into the genesis block hash. --- --- We assume that there is always only a single 'ChainwebVersionTag in --- scope and identify chains only by their internal 'ChainId'. --- -genesisBlockHeaders :: ChainwebVersion -> HashMap ChainId BlockHeader -genesisBlockHeaders = \v -> - if _versionCode v == _versionCode mainnet then mainnetGenesisHeaders - else if _versionCode v == _versionCode testnet then testnetGenesisHeaders - else unsafeDupablePerformIO $ - HM.lookup (_versionCode v) <$> readIORef genesisBlockHeaderCache >>= \case - Just hs -> return hs - Nothing -> do - let freshGenesisHeaders = makeGenesisBlockHeaders v - modifyIORef' genesisBlockHeaderCache $ HM.insert (_versionCode v) freshGenesisHeaders - return freshGenesisHeaders - where - mainnetGenesisHeaders = makeGenesisBlockHeaders mainnet - testnetGenesisHeaders = makeGenesisBlockHeaders testnet - -genesisBlockHeader :: (HasCallStack, HasChainId p) => ChainwebVersion -> p -> BlockHeader -genesisBlockHeader v p = genesisBlockHeaders v ^?! at (_chainId p) . _Just - -makeGenesisBlockHeaders :: ChainwebVersion -> HashMap ChainId BlockHeader -makeGenesisBlockHeaders v = HM.fromList [ (cid, makeGenesisBlockHeader v cid) | cid <- HS.toList (chainIds v)] - -makeGenesisBlockHeader :: ChainwebVersion -> ChainId -> BlockHeader -makeGenesisBlockHeader v cid = - makeGenesisBlockHeader' v cid (_genesisTime (_versionGenesis v) ^?! onChain cid) (Nonce 0) - -genesisHeight' :: HasCallStack => ChainwebVersion -> ChainId -> BlockHeight -genesisHeight' v c = fst - $ head - $ NE.dropWhile (not . flip isWebChain c . snd) - $ NE.reverse (ruleElems (BlockHeight 0) $ _versionGraphs v) - --- | Like `genesisBlockHeader`, but with slightly more control. --- --- This call generates the block header from the definitions in --- "Chainweb.Version". It is a somewhat expensive call, since it involves --- building the Merkle tree. --- -makeGenesisBlockHeader' - :: HasChainId p - => ChainwebVersion - -> p - -> BlockCreationTime - -> Nonce - -> BlockHeader -makeGenesisBlockHeader' v p ct@(BlockCreationTime t) n = - fromLog @ChainwebMerkleHashAlgorithm mlog - where - g = genesisGraph v p - cid = _chainId p - - mlog = newMerkleLog - $ mkFeatureFlags - :+: ct - :+: genesisParentBlockHash v cid - :+: (v ^?! versionGenesis . genesisBlockTarget . onChain cid) - :+: genesisBlockPayloadHash v cid - :+: cid - :+: BlockWeight 0 - :+: genesisHeight' v cid -- because of chain graph changes (new chains) not all chains start at 0 - :+: _versionCode v - :+: EpochStartTime t - :+: n - :+: MerkleLogBody (blockHashRecordToVector adjParents) - adjParents = BlockHashRecord $ HM.fromList $ - (\c -> (c, genesisParentBlockHash v c)) <$> HS.toList (adjacentChainIds g p) - --- | The set of genesis block headers as it exited at a particular block height --- -genesisBlockHeadersAtHeight - :: ChainwebVersion - -> BlockHeight - -> HashMap ChainId BlockHeader -genesisBlockHeadersAtHeight v h = - HM.filter (\hdr -> _blockHeight hdr <= h) (genesisBlockHeaders v) --- --- -------------------------------------------------------------------------- -- --- Genesis Height --- --- | The genesis graph for a given Chain --- --- Invariant: --- --- * The given ChainId exists in the first graph of the graph history. --- (We generally assume that this invariant holds throughout the code base. --- It is enforced via the 'mkChainId' smart constructor for ChainId.) --- -genesisGraph - :: HasCallStack - => HasChainwebVersion v - => HasChainId c - => v - -> c - -> ChainGraph -genesisGraph v = chainGraphAt v_ . genesisHeight' v_ . _chainId - where - v_ = _chainwebVersion v - --- | Returns the height of the genesis block for a chain. --- --- Invariant: --- --- * The given ChainId exists in the first graph of the graph history. --- (We generally assume that this invariant holds throughout the code base. --- It is enforced via the 'mkChainId' smart constructor for ChainId.) --- -genesisHeight :: HasCallStack => ChainwebVersion -> ChainId -> BlockHeight -genesisHeight v c = _blockHeight (genesisBlockHeader v c) - -instance HasMerkleLog ChainwebMerkleHashAlgorithm ChainwebHashTag BlockHeader where - - -- /IMPORTANT/ a types must occur at most once in this list - type MerkleLogHeader BlockHeader = - '[ FeatureFlags - , BlockCreationTime - , BlockHash - , HashTarget - , BlockPayloadHash - , ChainId - , BlockWeight - , BlockHeight - , ChainwebVersionCode - , EpochStartTime - , Nonce - ] - type MerkleLogBody BlockHeader = BlockHash - - toLog bh = merkleLog @ChainwebMerkleHashAlgorithm root entries - where - BlockHash (MerkleLogHash root) = _blockHash bh - entries - = _blockFlags bh - :+: _blockCreationTime bh - :+: _blockParent bh - :+: _blockTarget bh - :+: _blockPayloadHash bh - :+: _blockChainId bh - :+: _blockWeight bh - :+: _blockHeight bh - :+: _blockChainwebVersion bh - :+: _blockEpochStart bh - :+: _blockNonce bh - :+: MerkleLogBody (blockHashRecordToVector $ _blockAdjacentHashes bh) - - fromLog l = BlockHeader - { _blockFlags = flags - , _blockCreationTime = time - , _blockHash = BlockHash (MerkleLogHash $ _merkleLogRoot l) - , _blockParent = parentHash - , _blockTarget = target - , _blockPayloadHash = payload - , _blockChainId = cid - , _blockWeight = weight - , _blockHeight = height - , _blockChainwebVersion = cwvc - , _blockEpochStart = es - , _blockNonce = nonce - , _blockAdjacentHashes = blockHashRecordFromVector adjGraph cid adjParents - } - where - ( flags - :+: time - :+: parentHash - :+: target - :+: payload - :+: cid - :+: weight - :+: height - :+: cwvc - :+: es - :+: nonce - :+: MerkleLogBody adjParents - ) = _merkleLogEntries l - cwv = _chainwebVersion cwvc - - adjGraph - | height == genesisHeight' cwv cid = chainGraphAt cwv height - | otherwise = chainGraphAt cwv (height - 1) - -encodeBlockHeaderWithoutHash :: BlockHeader -> Put -encodeBlockHeaderWithoutHash b = do - encodeFeatureFlags (_blockFlags b) - encodeBlockCreationTime (_blockCreationTime b) - encodeBlockHash (_blockParent b) - encodeBlockHashRecord (_blockAdjacentHashes b) - encodeHashTarget (_blockTarget b) - encodeBlockPayloadHash (_blockPayloadHash b) - encodeChainId (_blockChainId b) - encodeBlockWeight (_blockWeight b) - encodeBlockHeight (_blockHeight b) - encodeChainwebVersionCode (_blockChainwebVersion b) - encodeEpochStartTime (_blockEpochStart b) - encodeNonce (_blockNonce b) - -encodeBlockHeader :: BlockHeader -> Put -encodeBlockHeader b = do - encodeBlockHeaderWithoutHash b - encodeBlockHash (_blockHash b) - --- | Decode and check that --- --- 1. chain id is in graph --- 2. all adjacentParent match adjacents in graph --- -decodeBlockHeaderChecked :: Get BlockHeader -decodeBlockHeaderChecked = do - !bh <- decodeBlockHeader - _ <- checkAdjacentChainIds bh bh (Expected $ _blockAdjacentChainIds bh) - return bh - --- | Decode and check that --- --- 1. chain id is in graph --- 2. all adjacentParent match adjacents in graph --- 3. chainId matches the expected chain id --- -decodeBlockHeaderCheckedChainId - :: HasChainId p - => Expected p - -> Get BlockHeader -decodeBlockHeaderCheckedChainId p = do - !bh <- decodeBlockHeaderChecked - _ <- checkChainId p (Actual (_chainId bh)) - return bh - --- | Decode a BlockHeader and trust the result --- -decodeBlockHeaderWithoutHash :: Get BlockHeader -decodeBlockHeaderWithoutHash = do - a0 <- decodeFeatureFlags - a1 <- decodeBlockCreationTime - a2 <- decodeBlockHash -- parent hash - a3 <- decodeBlockHashRecord - a4 <- decodeHashTarget - a5 <- decodeBlockPayloadHash - a6 <- decodeChainId - a7 <- decodeBlockWeight - a8 <- decodeBlockHeight - a9 <- decodeChainwebVersionCode - a11 <- decodeEpochStartTime - a12 <- decodeNonce - return - $! fromLog @ChainwebMerkleHashAlgorithm - $ newMerkleLog - $ a0 - :+: a1 - :+: a2 - :+: a4 - :+: a5 - :+: a6 - :+: a7 - :+: a8 - :+: a9 - :+: a11 - :+: a12 - :+: MerkleLogBody (blockHashRecordToVector a3) - --- | Decode a BlockHeader and trust the result --- -decodeBlockHeader :: Get BlockHeader -decodeBlockHeader = BlockHeader - <$> decodeFeatureFlags - <*> decodeBlockCreationTime - <*> decodeBlockHash -- parent hash - <*> decodeBlockHashRecord - <*> decodeHashTarget - <*> decodeBlockPayloadHash - <*> decodeChainId - <*> decodeBlockWeight - <*> decodeBlockHeight - <*> decodeChainwebVersionCode - <*> decodeEpochStartTime - <*> decodeNonce - <*> decodeBlockHash - -instance ToJSON BlockHeader where - toJSON = toJSON . encodeB64UrlNoPaddingText . runPutS . encodeBlockHeader - toEncoding = b64UrlNoPaddingTextEncoding . runPutS . encodeBlockHeader - {-# INLINE toJSON #-} - {-# INLINE toEncoding #-} - -instance FromJSON BlockHeader where - parseJSON = withText "BlockHeader" $ \t -> - case runGetS decodeBlockHeader =<< decodeB64UrlNoPaddingText t of - Left (e :: SomeException) -> fail (sshow e) - (Right !x) -> return x - -_blockAdjacentChainIds :: BlockHeader -> HS.HashSet ChainId -_blockAdjacentChainIds = - HS.fromList . HM.keys . _getBlockHashRecord . _blockAdjacentHashes - -blockAdjacentChainIds :: Getter BlockHeader (HS.HashSet ChainId) -blockAdjacentChainIds = to _blockAdjacentChainIds - --- | @getAdjacentHash cid h@ returns the adjacent hash of h for chain cid. It --- throws a @ChainNotAdjacentException@ if @cid@ is not adajcent with @_chainId --- h@ in the chain graph of @h@. --- -getAdjacentHash :: MonadThrow m => HasChainId p => p -> BlockHeader -> m BlockHash -getAdjacentHash p b = firstOf (blockAdjacentHashes . ixg (_chainId p)) b - ??? ChainNotAdjacentException - (_chainId b) - (Expected $ _chainId p) - (Actual $ _blockAdjacentChainIds b) -{-# INLINE getAdjacentHash #-} - -computeBlockHash :: BlockHeader -> BlockHash -computeBlockHash h = BlockHash $ MerkleLogHash $ computeMerkleLogRoot h -{-# INLINE computeBlockHash #-} - --- | The Proof-Of-Work hash includes all data in the block except for the --- '_blockHash'. The value (interpreted as 'BlockHashNat' must be smaller than --- the value of '_blockTarget' (interpreted as 'BlockHashNat'). --- -_blockPow :: BlockHeader -> PowHash -_blockPow h = cryptoHash @Blake2s_256 - $ runPutS $ encodeBlockHeaderWithoutHash h - -blockPow :: Getter BlockHeader PowHash -blockPow = to _blockPow -{-# INLINE blockPow #-} - --- | The number of microseconds between the creation time of two `BlockHeader`s. --- -timeBetween :: BlockCreationTime -> BlockCreationTime -> Micros -timeBetween after before = f after - f before - where - f :: BlockCreationTime -> Micros - f (BlockCreationTime (Time (TimeSpan ts))) = ts - --- | Absolute BlockHeight Difference --- -absBlockHeightDiff :: BlockHeader -> BlockHeader -> BlockHeight -absBlockHeightDiff a b - | _blockHeight a >= _blockHeight b = _blockHeight a - _blockHeight b - | otherwise = _blockHeight b - _blockHeight a - --- -------------------------------------------------------------------------- -- --- Object JSON encoding - --- | By default a binary encoding of block headers is used as JSON encoding. In --- some circumstance, like logging and configuration files, a textual encoding --- is desired. --- -newtype ObjectEncoded a = ObjectEncoded { _objectEncoded :: a } - deriving (Show, Generic) - deriving newtype (Eq, Ord, Hashable, NFData) +, I.BlockHeaderCas +) +where -blockHeaderProperties - :: KeyValue e kv - => ObjectEncoded BlockHeader - -> [kv] -blockHeaderProperties (ObjectEncoded b) = - [ "nonce" .= _blockNonce b - , "creationTime" .= _blockCreationTime b - , "parent" .= _blockParent b - , "adjacents" .= _blockAdjacentHashes b - , "target" .= _blockTarget b - , "payloadHash" .= _blockPayloadHash b - , "chainId" .= _chainId b - , "weight" .= _blockWeight b - , "height" .= _blockHeight b - , "chainwebVersion" .= _versionName (_chainwebVersion b) - , "epochStart" .= _blockEpochStart b - , "featureFlags" .= _blockFlags b - , "hash" .= _blockHash b - ] -{-# INLINE blockHeaderProperties #-} +import Chainweb.ChainId (ChainId) +import Chainweb.BlockWeight (BlockWeight) +import Chainweb.BlockHeight (BlockHeight) +import Chainweb.Version (ChainwebVersionCode) +import Chainweb.Payload (BlockPayloadHash) +import Chainweb.Difficulty (HashTarget) +import Chainweb.BlockHash (BlockHash, BlockHashRecord) +import Chainweb.BlockHeader.Internal qualified as I +import Chainweb.BlockCreationTime (BlockCreationTime) +import Control.Lens (Getter) -instance ToJSON (ObjectEncoded BlockHeader) where - toJSON = object . blockHeaderProperties - toEncoding = pairs . mconcat . blockHeaderProperties - {-# INLINE toJSON #-} - {-# INLINE toEncoding #-} +blockFlags :: Getter I.BlockHeader I.FeatureFlags +blockFlags = I.blockFlags -parseBlockHeaderObject :: Object -> Parser BlockHeader -parseBlockHeaderObject o = BlockHeader - <$> o .: "featureFlags" - <*> o .: "creationTime" - <*> o .: "parent" - <*> o .: "adjacents" - <*> o .: "target" - <*> o .: "payloadHash" - <*> o .: "chainId" - <*> o .: "weight" - <*> o .: "height" - -- TODO: lookupVersionByName should probably be deprecated for performance, - -- so perhaps we move this codec outside of the node proper. - <*> (_versionCode . lookupVersionByName <$> (o .: "chainwebVersion")) - <*> o .: "epochStart" - <*> o .: "nonce" - <*> o .: "hash" +blockCreationTime :: Getter I.BlockHeader BlockCreationTime +blockCreationTime = I.blockCreationTime -instance FromJSON (ObjectEncoded BlockHeader) where - parseJSON = withObject "BlockHeader" - $ fmap ObjectEncoded . parseBlockHeaderObject - {-# INLINE parseJSON #-} +blockParent :: Getter I.BlockHeader BlockHash +blockParent = I.blockParent --- -------------------------------------------------------------------------- -- --- IsBlockHeader +blockAdjacentHashes :: Getter I.BlockHeader BlockHashRecord +blockAdjacentHashes = I.blockAdjacentHashes --- | Any type which can purely produce a `BlockHeader`, or purely construct one. --- -class IsBlockHeader t where - isoBH :: Iso' t BlockHeader +blockTarget :: Getter I.BlockHeader HashTarget +blockTarget = I.blockTarget -instance IsBlockHeader BlockHeader where - isoBH = id +blockPayloadHash :: Getter I.BlockHeader BlockPayloadHash +blockPayloadHash = I.blockPayloadHash --- -------------------------------------------------------------------------- -- --- Create new BlockHeader +blockChainId :: Getter I.BlockHeader ChainId +blockChainId = I.blockChainId --- | Creates a new block header. No validation of the input parameters is --- performaned. --- --- It's not guaranteed that the result is a valid block header. It is, however, --- guaranteed by construction that --- --- * the target, --- * the weight, --- * the block height, --- * the version, --- * the chain id, and --- * the epoch start time --- --- are valid with respect to the given parent header and adjacent parent --- headers. --- --- TODO: also check adjacent chains. This would probably break a lot of tests, --- but might be worth it! --- -newBlockHeader - :: HM.HashMap ChainId ParentHeader - -- ^ Adjacent parent hashes. - -> BlockPayloadHash - -- ^ payload hash - -> Nonce - -- ^ Randomness to affect the block hash. It is not verified that the - -- nonce is valid with respect to the target. - -> BlockCreationTime - -- ^ Creation time of the block. - -> ParentHeader - -- ^ parent block header - -> BlockHeader -newBlockHeader adj pay nonce t p@(ParentHeader b) = - fromLog @ChainwebMerkleHashAlgorithm $ newMerkleLog - $ mkFeatureFlags - :+: t - :+: _blockHash b - :+: target - :+: pay - :+: cid - :+: _blockWeight b + BlockWeight (targetToDifficulty target) - :+: _blockHeight b + 1 - :+: _versionCode v - :+: epochStart p adj t - :+: nonce - :+: MerkleLogBody (blockHashRecordToVector adjHashes) - where - cid = _chainId p - v = _chainwebVersion p - target = powTarget p adj t - adjHashes = BlockHashRecord $ (_blockHash . _parentHeader) <$> adj +blockWeight :: Getter I.BlockHeader BlockWeight +blockWeight = I.blockWeight --- -------------------------------------------------------------------------- -- --- TreeDBEntry instance +blockHeight :: Getter I.BlockHeader BlockHeight +blockHeight = I.blockHeight -instance TreeDbEntry BlockHeader where - type Key BlockHeader = BlockHash - key = _blockHash - rank = int . _blockHeight - parent e - | isGenesisBlockHeader e = Nothing - | otherwise = Just (_blockParent e) +blockChainwebVersion :: Getter I.BlockHeader ChainwebVersionCode +blockChainwebVersion = I.blockChainwebVersion --- | This is an internal function. Use 'headerSizeBytes' instead. --- --- Postconditions: for all @v@ --- --- * @not . null $ headerSizes v@, and --- * @0 == (fst . last) (headerSizes v)@. --- --- Note that for all but genesis headers the number of adjacent hashes depends --- on the graph of the parent. --- -headerSizes :: ChainwebVersion -> Rule BlockHeight Natural -headerSizes v = fmap (\g -> _versionHeaderBaseSizeBytes v + 36 * degree g + 2) $ _versionGraphs v +blockEpochStart :: Getter I.BlockHeader I.EpochStartTime +blockEpochStart = I.blockEpochStart --- | The size of the serialized block header. --- --- This function is safe because of the invariant of 'headerSize' that there --- exists and entry for block height 0. --- --- Note that for all but genesis headers the number of adjacent hashes depends --- on the graph of the parent. --- -headerSizeBytes - :: HasCallStack - => ChainwebVersion - -> ChainId - -> BlockHeight - -> Natural -headerSizeBytes v cid h = snd - $ ruleHead - $ ruleDropWhile (> relevantHeight) - $ headerSizes v - where - relevantHeight - | genesisHeight v cid == h = h - | otherwise = h - 1 +blockNonce :: Getter I.BlockHeader I.Nonce +blockNonce = I.blockNonce --- | The size of the work bytes /without/ the preamble of the chain id and target --- --- The chain graph, and therefore also the header size, is constant for all --- blocks at the same height except for genesis blocks. Because genesis blocks --- are never mined, we can ignore this difference here and just return the --- result for chain 0. --- --- NOTE: For production versions we require that the value is constant for a --- given chainweb version. This would only ever change as part of the --- introduction of new block header format. --- -workSizeBytes - :: HasCallStack - => ChainwebVersion - -> BlockHeight - -> Natural -workSizeBytes v h = headerSizeBytes v (unsafeChainId 0) h - 32 +blockHash :: Getter I.BlockHeader BlockHash +blockHash = I.blockHash diff --git a/src/Chainweb/BlockHeader/Internal.hs b/src/Chainweb/BlockHeader/Internal.hs new file mode 100644 index 0000000000..00e8add02e --- /dev/null +++ b/src/Chainweb/BlockHeader/Internal.hs @@ -0,0 +1,1182 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module: Chainweb.BlockHeader +-- Copyright: Copyright © 2018 Kadena LLC. +-- License: MIT +-- Maintainer: Lars Kuhtz +-- Stability: experimental +-- +module Chainweb.BlockHeader.Internal +( +-- * Newtype wrappers for function parameters + ParentHeader(..) +, parentHeader +, ParentCreationTime(..) + +-- * Block Payload Hash +, BlockPayloadHash +, BlockPayloadHash_(..) +, encodeBlockPayloadHash +, decodeBlockPayloadHash + +-- * Nonce +, Nonce(..) +, encodeNonce +, encodeNonceToWord64 +, decodeNonce + +-- * EpochStartTime +, EpochStartTime(..) +, encodeEpochStartTime +, decodeEpochStartTime +, epochStart + +-- * FeatureFlags +, FeatureFlags +, mkFeatureFlags +, encodeFeatureFlags +, decodeFeatureFlags + +-- * POW Target +, powTarget + +-- * BlockHeader +, BlockHeader(..) +-- ** Getters +, blockFlags +, blockCreationTime +, blockParent +, blockAdjacentHashes +, blockTarget +, blockPayloadHash +, blockChainId +, blockWeight +, blockHeight +, blockChainwebVersion +, blockEpochStart +, blockNonce +, blockHash +-- ** Utilities +, _blockPow +, blockPow +, _blockAdjacentChainIds +, blockAdjacentChainIds +, encodeBlockHeader +, encodeBlockHeaderWithoutHash +, decodeBlockHeader +, decodeBlockHeaderWithoutHash +, decodeBlockHeaderChecked +, decodeBlockHeaderCheckedChainId +, blockHeaderShortDescription +, ObjectEncoded(..) + +, timeBetween +, getAdjacentHash +, computeBlockHash +, adjacentChainIds +, absBlockHeightDiff + +-- * IsBlockHeader +, IsBlockHeader(..) + +-- * Genesis BlockHeader +, isGenesisBlockHeader +, genesisParentBlockHash +, genesisBlockHeader +, genesisBlockHeaders +, genesisBlockHeadersAtHeight +, genesisHeight +, headerSizes +, headerSizeBytes +, workSizeBytes + +-- * Create a new BlockHeader +, newBlockHeader + +-- * CAS Constraint +, BlockHeaderCas +) where + +import Chainweb.BlockCreationTime +import Chainweb.BlockHash +import Chainweb.BlockHeight +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 +import Chainweb.TreeDB (TreeDbEntry(..)) +import Chainweb.Utils +import Chainweb.Utils.Rule +import Chainweb.Utils.Serialization +import Chainweb.Version +import Chainweb.Version.Guards +import Chainweb.Version.Mainnet +import Chainweb.Version.Registry (lookupVersionByName) +import Chainweb.Version.Testnet +import Control.DeepSeq +import Control.Exception +import Control.Lens hiding ((.=)) +import Control.Monad.Catch +import Crypto.Hash.Algorithms +import Data.Aeson +import Data.Aeson.Types (Parser) +import Data.Function (on) +import Data.HashMap.Strict (HashMap) +import Data.Hashable +import Data.IORef +import Data.Kind +import Data.MerkleLog hiding (Actual, Expected, MerkleHash) +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.List.NonEmpty qualified as NE +import Data.Memory.Endian qualified as BA +import Data.Text qualified as T + +-- -------------------------------------------------------------------------- -- +-- Nonce + +newtype Nonce = Nonce Word64 + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + deriving newtype (Hashable,Enum) + +instance MerkleHashAlgorithm a => IsMerkleLogEntry a ChainwebHashTag Nonce where + type Tag Nonce = 'BlockNonceTag + toMerkleNode = encodeMerkleInputNode encodeNonce + fromMerkleNode = decodeMerkleInputNode decodeNonce + {-# INLINE toMerkleNode #-} + {-# INLINE fromMerkleNode #-} + +encodeNonce :: Nonce -> Put +encodeNonce (Nonce n) = putWord64le n + +encodeNonceToWord64 :: Nonce -> Word64 +encodeNonceToWord64 (Nonce n) = BA.unLE $ BA.toLE n + +decodeNonce :: Get Nonce +decodeNonce = Nonce <$> getWord64le + +instance ToJSON Nonce where + toJSON (Nonce i) = toJSON $ show i + toEncoding (Nonce i) = toEncoding $ show i + {-# INLINE toJSON #-} + {-# INLINE toEncoding #-} + +instance FromJSON Nonce where + parseJSON = withText "Nonce" + $ either fail (return . Nonce) . readEither . T.unpack + +-- -------------------------------------------------------------------------- -- +-- POW Target Computation + +newtype EpochStartTime = EpochStartTime (Time Micros) + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + deriving newtype (ToJSON, FromJSON, Hashable, LeftTorsor) + +instance MerkleHashAlgorithm a => IsMerkleLogEntry a ChainwebHashTag EpochStartTime where + type Tag EpochStartTime = 'EpochStartTimeTag + toMerkleNode = encodeMerkleInputNode encodeEpochStartTime + fromMerkleNode = decodeMerkleInputNode decodeEpochStartTime + {-# INLINE toMerkleNode #-} + {-# INLINE fromMerkleNode #-} + +encodeEpochStartTime :: EpochStartTime -> Put +encodeEpochStartTime (EpochStartTime t) = encodeTime t + +decodeEpochStartTime :: Get EpochStartTime +decodeEpochStartTime = EpochStartTime <$> decodeTime + +-- ----------------------------------------------------------------------------- +-- Feature Flags + +newtype FeatureFlags = FeatureFlags Word64 + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData) + deriving newtype (ToJSON, FromJSON) + +encodeFeatureFlags :: FeatureFlags -> Put +encodeFeatureFlags (FeatureFlags ff) = putWord64le ff + +decodeFeatureFlags :: Get FeatureFlags +decodeFeatureFlags = FeatureFlags <$> getWord64le + +instance MerkleHashAlgorithm a => IsMerkleLogEntry a ChainwebHashTag FeatureFlags where + type Tag FeatureFlags = 'FeatureFlagsTag + toMerkleNode = encodeMerkleInputNode encodeFeatureFlags + fromMerkleNode = decodeMerkleInputNode decodeFeatureFlags + +mkFeatureFlags :: FeatureFlags +mkFeatureFlags = FeatureFlags 0x0 + +-- -------------------------------------------------------------------------- -- +-- Block Header + +-- | BlockHeader +-- +-- Values of this type should never be constructed directly by external code. +-- Instead the 'newBlockHeader' smart constructor should be used. Once +-- constructed 'BlockHeader' values must not be modified. +-- +-- Some redundant, aggregated information is included in the block and the block +-- hash. This enables nodes to check blocks inductively with respect to existing +-- blocks without recalculating the aggregated value from the genesis block +-- onward. +-- +-- The POW hash is not included, since it can be derived from the Nonce and the +-- other fields of the 'BlockHeader'. +-- +-- /IMPORTANT/: Fields in this record must have pairwise distinct types. +-- +data BlockHeader :: Type where + BlockHeader :: + { _blockFlags :: {-# UNPACK #-} !FeatureFlags + -- ^ An 8-byte bitmask reserved for the future addition of boolean + -- "feature flags". + + , _blockCreationTime :: {-# UNPACK #-} !BlockCreationTime + -- ^ The time when the block was creates as recorded by the miner + -- of the block. The value must be strictly monotonically increasing + -- within the chain of blocks. Nodes must ignore blocks with values + -- that are in the future and reconsider a block when its value is + -- in the past. Nodes do not have to store blocks until they become + -- recent (but may do it). + -- + -- The block creation time is used to determine the block difficulty for + -- future blocks. + -- + -- Nodes are not supposed to consider the creation time when + -- choosing between two valid (this implies that creation time of a + -- block is not the future) forks. + -- + -- This creates an incentive for nodes to maintain an accurate clock + -- with respect to an (unspecified) commonly accepted time source, + -- such as the public NTP network. + -- + -- It is possible that a miner always chooses the smallest possible + -- creation time value. It is not clear what advantage a miner would + -- gain from doing so, but attack models should consider and + -- investigate such behavior. + -- + -- On the other hand miners may choose to compute forks with creation + -- time long in the future. By doing so, the difficulty on such a fork + -- would decrease allowing the miner to compute very long chains very + -- quickly. However, those chains would become valid only after a long + -- time passed and would be of low PoW weight. The algorithm for + -- computing the difficulty must ensure this strategy doesn't give + -- an advantage to an attacker that would increase the success + -- probability for an attack. + + , _blockParent :: {-# UNPACK #-} !BlockHash + -- ^ authoritative + + , _blockAdjacentHashes :: !BlockHashRecord + -- ^ authoritative + + , _blockTarget :: {-# UNPACK #-} !HashTarget + -- ^ authoritative + + , _blockPayloadHash :: {-# UNPACK #-} !BlockPayloadHash + -- ^ authoritative + + , _blockChainId :: {-# UNPACK #-} !ChainId + + , _blockWeight :: {-# UNPACK #-} !BlockWeight + -- ^ the accumulated weight of the chain. It is redundant information + -- that is subject to the inductive property that the block weight + -- of a block is the block weight of the parent plus the difficulty + -- of the block. + + , _blockHeight :: {-# UNPACK #-} !BlockHeight + -- ^ block height records the length of the chain. It is redundant + -- information and thus subject the inductive property that + -- the block height of a block is the block height of its parent + -- plus one. + + , _blockChainwebVersion :: !ChainwebVersionCode + -- ^ the Chainweb version is a constant for the chain. A chain + -- is uniquely identified by its genesis block. Thus this is + -- redundant information and thus subject to the inductive property + -- that the Chainweb version of a block equals the Chainweb version + -- of its parent. + + , _blockEpochStart :: {-# UNPACK #-} !EpochStartTime + -- ^ The start time of the current difficulty adjustment epoch. + -- Epochs divide the sequence of blocks in the chain into continuous + -- ranges of blocks. Each epoch is defined by the minimal block + -- height of the blocks in the epoch. + + , _blockNonce :: {-# UNPACK #-} !Nonce + -- ^ authoritative + + , _blockHash :: {-# UNPACK #-} !BlockHash + -- ^ the hash of the block. It includes all of the above block properties. + } + -> BlockHeader + deriving (Show, Generic) + deriving anyclass (NFData) + +instance Eq BlockHeader where + (==) = (==) `on` _blockHash + {-# INLINE (==) #-} + +instance Ord BlockHeader where + compare = compare `on` _blockHash + +instance Hashable BlockHeader where + hashWithSalt s = hashWithSalt s . _blockHash + +instance HasChainId BlockHeader where + _chainId = _blockChainId + +instance HasChainGraph BlockHeader where + _chainGraph h = _chainGraph (_chainwebVersion h, _blockHeight h) + +instance HasChainwebVersion BlockHeader where + _chainwebVersion = _chainwebVersion . _blockChainwebVersion + +instance IsCasValue BlockHeader where + type CasKeyType BlockHeader = BlockHash + casKey = _blockHash + {-# INLINE casKey #-} + +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 + [ toText (_chainId bh) + , "@" + , blockHashToTextShort (_blockHash bh) + , "(height " <> sshow (getBlockHeight $ _blockHeight bh) <> ")" + ] + +makeLenses ''BlockHeader + +-- | During the first epoch after genesis there are 10 extra difficulty +-- adjustments. This is to account for rapidly changing total hash power in the +-- early stages of the network. +-- +effectiveWindow :: BlockHeader -> Maybe WindowWidth +effectiveWindow h = WindowWidth <$> case _versionWindow (_chainwebVersion h) of + WindowWidth w + | int (_blockHeight h) <= w -> Just $ max 1 $ w `div` 10 + | otherwise -> Just w + +-- | Return whether the given 'BlockHeader' is the last header in its epoch. +-- +isLastInEpoch :: BlockHeader -> Bool +isLastInEpoch h = case effectiveWindow h of + Nothing -> False + Just (WindowWidth w) + | (int (_blockHeight h) + 1) `mod` w == 0 -> True + | otherwise -> False + +-- | If it is discovered that the last DA occured significantly in the past, we +-- assume that a large amount of hash power has suddenly dropped out of the +-- network. Thus we must perform Emergency Difficulty Adjustment to avoid +-- stalling the chain. +-- +-- NOTE: emergency DAs are now regarded a misfeature and have been disabled in +-- all chainweb version. Emergency DAs are enabled (and have occured) only on +-- mainnet01 for cut heights smaller than 80,000. +-- +slowEpoch :: ParentHeader -> BlockCreationTime -> Bool +slowEpoch (ParentHeader p) (BlockCreationTime ct) = actual > (expected * 5) + where + EpochStartTime es = _blockEpochStart p + v = _chainwebVersion p + BlockDelay bd = _versionBlockDelay v + WindowWidth ww = _versionWindow v + + expected :: Micros + expected = bd * int ww + + actual :: Micros + actual = timeSpanToMicros $ ct .-. es + +-- | Compute the POW target for a new BlockHeader. +-- +-- Alternatively, the new chains can use a higher target and the target of the +-- old chains arent' adjusted. That includes the risk of larger orphan rates. In +-- particular after the first and second DA, the current DA will compute targets +-- that are averages between chains, which cause the difficulty to go donwn +-- globally. This is usually mostly mitigated after the third DA after the +-- transition. +-- +powTarget + :: ParentHeader + -- ^ parent header + -> HM.HashMap ChainId ParentHeader + -- ^ adjacent Parents + -> BlockCreationTime + -- ^ block creation time of new block + -- + -- This parameter is used only when @oldTargetGuard@ is @True@. + -- + -> HashTarget + -- ^ POW target of new block +powTarget p@(ParentHeader ph) as bct = case effectiveWindow ph of + Nothing -> maxTarget + Just w + -- Emergency DA, legacy + | slowEpochGuard ver (_chainId ph) (_blockHeight ph) && slowEpoch p bct -> + activeAdjust w + | isLastInEpoch ph -> activeAdjust w + | otherwise -> _blockTarget ph + where + ver = _chainwebVersion ph + t = EpochStartTime $ if oldTargetGuard ver (_chainId ph) (_blockHeight ph) + then _bct bct + else _bct (_blockCreationTime ph) + + activeAdjust w + | oldDaGuard ver (_chainId ph) (_blockHeight ph + 1) + = legacyAdjust (_versionBlockDelay ver) w (t .-. _blockEpochStart ph) (_blockTarget ph) + | otherwise + = avgTarget $ adjustForParent w <$> (p : HM.elems as) + + adjustForParent w (ParentHeader a) + = adjust (_versionBlockDelay ver) w (toEpochStart a .-. _blockEpochStart a) (_blockTarget a) + + toEpochStart = EpochStartTime . _bct . _blockCreationTime + + avgTarget targets = HashTarget $ floor $ s / int (length targets) + where + s = sum $ fmap (int @_ @Rational . _hashTarget) targets +{-# INLINE powTarget #-} + +-- | Compute the epoch start value for a new BlockHeader +-- +epochStart + :: ParentHeader + -- ^ parent header + -> HM.HashMap ChainId ParentHeader + -- ^ Adjacent parents of the block. It is not checked whether the + -- set of adjacent parents conforms with the current graph. + -> BlockCreationTime + -- ^ block creation time of new block + -- + -- This parameter is used only when @oldTargetGuard@ is @True@. + -- + -> EpochStartTime + -- ^ epoch start time of new block +epochStart ph@(ParentHeader p) adj (BlockCreationTime bt) + | Nothing <- effectiveWindow p = _blockEpochStart p + + -- A special case for starting a new devnet, to compensate the inaccurate + -- creation time of the genesis blocks. This would result in a very long + -- first epoch that cause a trivial target in the second epoch. + | ver ^. versionCheats . fakeFirstEpochStart, _blockHeight p == 1 = EpochStartTime (_bct $ _blockCreationTime p) + + -- New Graph: the block time of the genesis block isn't accurate, we thus + -- use the block time of the first block on the chain. Depending on where + -- this is within an epoch, this can cause a shorter epoch, which could + -- cause a larger difficulty and a reduced target. That is fine, since new + -- chains are expected to start with a low difficulty. + | parentIsFirstOnNewChain = EpochStartTime (_bct $ _blockCreationTime p) + + -- End of epoch, DA adjustment (legacy version) + | isLastInEpoch p && oldTargetGuard ver (_chainId p) (_blockHeight p) = EpochStartTime bt + + -- End of epoch, DA adjustment + | isLastInEpoch p = EpochStartTime (_bct $ _blockCreationTime p) + + -- Within epoch with old legacy DA + | oldDaGuard ver (_chainId p) (_blockHeight p + 1) = _blockEpochStart p + + -- Within an epoch with new DA + | otherwise = _blockEpochStart p + + -- Experimental, allow DA to support multiple hash functions + -- | otherwise = _blockEpochStart p .+^ _adjustmentAvg + where + ver = _chainwebVersion p + cid = _chainId p + + -- Add a penalty for fast chains by adding the different between the + -- creation time of the current chain and the maximum of the adjacent chains + -- to the epoch start time. By shortening the epoch DA is going to adjust to + -- a higher difficulty. + -- + -- This DA has the disadvantage, that it adjusts to a block rate that is + -- smaller than the targeted blockrate, because with high probablity all + -- chains are receiving some positive penalty. + -- + -- Properties of DA: + -- + -- * Requires that miners set creation time >0.5 of solve time. + -- * Requires correction factor for targeted block rate. + -- * Can handle non continuous non uniform distribution of hash power + -- accross chains. + -- + _adjustmentMax = maximum adjCreationTimes .-. _blockCreationTime p + -- the maximum is at least @_blockCreationTime p@ and thus the result is + -- greater or equal 0. + + -- This computes @mean adjCreationTimes - _blockCreationTime p + -- + -- It holds that + -- + -- \(\left(mean_{0 \leq i < n} a_i\right) + -- = \frac{\sum_{0 \leq i < n} a_i}{n} - t + -- = \frac{\left(sum_{0 \leq i < n} a_i\right) - \left(\sum_{0 \leq i < n} t\right)}{n} + -- = \frac{sum_{0 \leq i < n} (a_i - t)}{n} + -- \) + -- + -- this is numberically sound because we compute the differences on integral + -- types without rounding. + -- + -- Properties of DA: + -- + -- * Requires that miners set creation time >0.5 of solve time + -- * Can handle non continuous non uniform distribution of hash power + -- accross chains. + -- + _adjustmentAvg = x `divTimeSpan` length adjCreationTimes + where + x :: TimeSpan Micros + x = foldr1 addTimeSpan $ (.-. _blockCreationTime p) <$> adjCreationTimes + + -- This includes the parent header itself, but excludes any adjacent genesis + -- headers which usually don't have accurate creation time. + -- + -- The result is guaranteed to be non-empty + -- + adjCreationTimes = fmap (_blockCreationTime) + $ HM.insert cid (_parentHeader ph) + $ HM.filter (not . isGenesisBlockHeader) + $ fmap _parentHeader adj + + parentIsFirstOnNewChain + = _blockHeight p > 1 && _blockHeight p == genesisHeight ver cid + 1 +{-# INLINE epochStart #-} + +-- -------------------------------------------------------------------------- -- +-- Newtype wrappers for function parameters + +newtype ParentCreationTime = ParentCreationTime + { _parentCreationTime :: BlockCreationTime } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + deriving newtype (ToJSON, FromJSON, Hashable, LeftTorsor) + +newtype ParentHeader = ParentHeader + { _parentHeader :: BlockHeader } + deriving (Show, Eq, Ord, Generic) + deriving anyclass (NFData) + +parentHeader :: Lens' ParentHeader BlockHeader +parentHeader = lens _parentHeader $ \_ hdr -> ParentHeader hdr + +instance HasChainId ParentHeader where + _chainId = _chainId . _parentHeader + {-# INLINE _chainId #-} + +instance HasChainwebVersion ParentHeader where + _chainwebVersion = _chainwebVersion . _parentHeader + {-# INLINE _chainwebVersion #-} + +instance HasChainGraph ParentHeader where + _chainGraph = _chainGraph . _parentHeader + {-# INLINE _chainGraph #-} + +isGenesisBlockHeader :: BlockHeader -> Bool +isGenesisBlockHeader b = + _blockHeight b == genesisHeight (_chainwebVersion b) (_chainId b) + +-- | The genesis block hash includes the Chainweb version and the 'ChainId' +-- within the Chainweb version. +-- +-- It is the '_blockParent' of the genesis block +-- +genesisParentBlockHash :: HasChainId p => ChainwebVersion -> p -> BlockHash +genesisParentBlockHash v p = BlockHash $ MerkleLogHash + $ merkleRoot $ merkleTree @ChainwebMerkleHashAlgorithm + [ InputNode "CHAINWEB_GENESIS" + , encodeMerkleInputNode encodeChainwebVersionCode (_versionCode v) + , encodeMerkleInputNode encodeChainId (_chainId p) + ] + +{-# NOINLINE genesisBlockHeaderCache #-} +genesisBlockHeaderCache :: IORef (HashMap ChainwebVersionCode (HashMap ChainId BlockHeader)) +genesisBlockHeaderCache = unsafePerformIO $ do + newIORef HM.empty + +-- | A block chain is globally uniquely identified by its genesis hash. +-- Internally, we use the 'ChainwebVersionTag value and the 'ChainId' +-- as identifiers. We thus include the 'ChainwebVersionTag value and the +-- 'ChainId' into the genesis block hash. +-- +-- We assume that there is always only a single 'ChainwebVersionTag in +-- scope and identify chains only by their internal 'ChainId'. +-- +genesisBlockHeaders :: ChainwebVersion -> HashMap ChainId BlockHeader +genesisBlockHeaders = \v -> + if _versionCode v == _versionCode mainnet then mainnetGenesisHeaders + else if _versionCode v == _versionCode testnet then testnetGenesisHeaders + else unsafeDupablePerformIO $ + HM.lookup (_versionCode v) <$> readIORef genesisBlockHeaderCache >>= \case + Just hs -> return hs + Nothing -> do + let freshGenesisHeaders = makeGenesisBlockHeaders v + modifyIORef' genesisBlockHeaderCache $ HM.insert (_versionCode v) freshGenesisHeaders + return freshGenesisHeaders + where + mainnetGenesisHeaders = makeGenesisBlockHeaders mainnet + testnetGenesisHeaders = makeGenesisBlockHeaders testnet + +genesisBlockHeader :: (HasCallStack, HasChainId p) => ChainwebVersion -> p -> BlockHeader +genesisBlockHeader v p = genesisBlockHeaders v ^?! at (_chainId p) . _Just + +makeGenesisBlockHeaders :: ChainwebVersion -> HashMap ChainId BlockHeader +makeGenesisBlockHeaders v = HM.fromList [ (cid, makeGenesisBlockHeader v cid) | cid <- HS.toList (chainIds v)] + +makeGenesisBlockHeader :: ChainwebVersion -> ChainId -> BlockHeader +makeGenesisBlockHeader v cid = + makeGenesisBlockHeader' v cid (_genesisTime (_versionGenesis v) ^?! onChain cid) (Nonce 0) + +genesisHeight' :: HasCallStack => ChainwebVersion -> ChainId -> BlockHeight +genesisHeight' v c = fst + $ head + $ NE.dropWhile (not . flip isWebChain c . snd) + $ NE.reverse (ruleElems (BlockHeight 0) $ _versionGraphs v) + +-- | Like `genesisBlockHeader`, but with slightly more control. +-- +-- This call generates the block header from the definitions in +-- "Chainweb.Version". It is a somewhat expensive call, since it involves +-- building the Merkle tree. +-- +makeGenesisBlockHeader' + :: HasChainId p + => ChainwebVersion + -> p + -> BlockCreationTime + -> Nonce + -> BlockHeader +makeGenesisBlockHeader' v p ct@(BlockCreationTime t) n = + fromLog @ChainwebMerkleHashAlgorithm mlog + where + g = genesisGraph v p + cid = _chainId p + + mlog = newMerkleLog + $ mkFeatureFlags + :+: ct + :+: genesisParentBlockHash v cid + :+: (v ^?! versionGenesis . genesisBlockTarget . onChain cid) + :+: genesisBlockPayloadHash v cid + :+: cid + :+: BlockWeight 0 + :+: genesisHeight' v cid -- because of chain graph changes (new chains) not all chains start at 0 + :+: _versionCode v + :+: EpochStartTime t + :+: n + :+: MerkleLogBody (blockHashRecordToVector adjParents) + adjParents = BlockHashRecord $ HM.fromList $ + (\c -> (c, genesisParentBlockHash v c)) <$> HS.toList (adjacentChainIds g p) + +-- | The set of genesis block headers as it exited at a particular block height +-- +genesisBlockHeadersAtHeight + :: ChainwebVersion + -> BlockHeight + -> HashMap ChainId BlockHeader +genesisBlockHeadersAtHeight v h = + HM.filter (\hdr -> _blockHeight hdr <= h) (genesisBlockHeaders v) +-- +-- -------------------------------------------------------------------------- -- +-- Genesis Height +-- +-- | The genesis graph for a given Chain +-- +-- Invariant: +-- +-- * The given ChainId exists in the first graph of the graph history. +-- (We generally assume that this invariant holds throughout the code base. +-- It is enforced via the 'mkChainId' smart constructor for ChainId.) +-- +genesisGraph + :: HasCallStack + => HasChainwebVersion v + => HasChainId c + => v + -> c + -> ChainGraph +genesisGraph v = chainGraphAt v_ . genesisHeight' v_ . _chainId + where + v_ = _chainwebVersion v + +-- | Returns the height of the genesis block for a chain. +-- +-- Invariant: +-- +-- * The given ChainId exists in the first graph of the graph history. +-- (We generally assume that this invariant holds throughout the code base. +-- It is enforced via the 'mkChainId' smart constructor for ChainId.) +-- +genesisHeight :: HasCallStack => ChainwebVersion -> ChainId -> BlockHeight +genesisHeight v c = _blockHeight (genesisBlockHeader v c) + +instance HasMerkleLog ChainwebMerkleHashAlgorithm ChainwebHashTag BlockHeader where + + -- /IMPORTANT/ a types must occur at most once in this list + type MerkleLogHeader BlockHeader = + '[ FeatureFlags + , BlockCreationTime + , BlockHash + , HashTarget + , BlockPayloadHash + , ChainId + , BlockWeight + , BlockHeight + , ChainwebVersionCode + , EpochStartTime + , Nonce + ] + type MerkleLogBody BlockHeader = BlockHash + + toLog bh = merkleLog @ChainwebMerkleHashAlgorithm root entries + where + BlockHash (MerkleLogHash root) = _blockHash bh + entries + = _blockFlags bh + :+: _blockCreationTime bh + :+: _blockParent bh + :+: _blockTarget bh + :+: _blockPayloadHash bh + :+: _blockChainId bh + :+: _blockWeight bh + :+: _blockHeight bh + :+: _blockChainwebVersion bh + :+: _blockEpochStart bh + :+: _blockNonce bh + :+: MerkleLogBody (blockHashRecordToVector $ _blockAdjacentHashes bh) + + fromLog l = BlockHeader + { _blockFlags = flags + , _blockCreationTime = time + , _blockHash = BlockHash (MerkleLogHash $ _merkleLogRoot l) + , _blockParent = parentHash + , _blockTarget = target + , _blockPayloadHash = payload + , _blockChainId = cid + , _blockWeight = weight + , _blockHeight = height + , _blockChainwebVersion = cwvc + , _blockEpochStart = es + , _blockNonce = nonce + , _blockAdjacentHashes = blockHashRecordFromVector adjGraph cid adjParents + } + where + ( flags + :+: time + :+: parentHash + :+: target + :+: payload + :+: cid + :+: weight + :+: height + :+: cwvc + :+: es + :+: nonce + :+: MerkleLogBody adjParents + ) = _merkleLogEntries l + cwv = _chainwebVersion cwvc + + adjGraph + | height == genesisHeight' cwv cid = chainGraphAt cwv height + | otherwise = chainGraphAt cwv (height - 1) + +encodeBlockHeaderWithoutHash :: BlockHeader -> Put +encodeBlockHeaderWithoutHash b = do + encodeFeatureFlags (_blockFlags b) + encodeBlockCreationTime (_blockCreationTime b) + encodeBlockHash (_blockParent b) + encodeBlockHashRecord (_blockAdjacentHashes b) + encodeHashTarget (_blockTarget b) + encodeBlockPayloadHash (_blockPayloadHash b) + encodeChainId (_blockChainId b) + encodeBlockWeight (_blockWeight b) + encodeBlockHeight (_blockHeight b) + encodeChainwebVersionCode (_blockChainwebVersion b) + encodeEpochStartTime (_blockEpochStart b) + encodeNonce (_blockNonce b) + +encodeBlockHeader :: BlockHeader -> Put +encodeBlockHeader b = do + encodeBlockHeaderWithoutHash b + encodeBlockHash (_blockHash b) + +-- | Decode and check that +-- +-- 1. chain id is in graph +-- 2. all adjacentParent match adjacents in graph +-- +decodeBlockHeaderChecked :: Get BlockHeader +decodeBlockHeaderChecked = do + !bh <- decodeBlockHeader + _ <- checkAdjacentChainIds bh bh (Expected $ _blockAdjacentChainIds bh) + return bh + +-- | Decode and check that +-- +-- 1. chain id is in graph +-- 2. all adjacentParent match adjacents in graph +-- 3. chainId matches the expected chain id +-- +decodeBlockHeaderCheckedChainId + :: HasChainId p + => Expected p + -> Get BlockHeader +decodeBlockHeaderCheckedChainId p = do + !bh <- decodeBlockHeaderChecked + _ <- checkChainId p (Actual (_chainId bh)) + return bh + +-- | Decode a BlockHeader and trust the result +-- +decodeBlockHeaderWithoutHash :: Get BlockHeader +decodeBlockHeaderWithoutHash = do + a0 <- decodeFeatureFlags + a1 <- decodeBlockCreationTime + a2 <- decodeBlockHash -- parent hash + a3 <- decodeBlockHashRecord + a4 <- decodeHashTarget + a5 <- decodeBlockPayloadHash + a6 <- decodeChainId + a7 <- decodeBlockWeight + a8 <- decodeBlockHeight + a9 <- decodeChainwebVersionCode + a11 <- decodeEpochStartTime + a12 <- decodeNonce + return + $! fromLog @ChainwebMerkleHashAlgorithm + $ newMerkleLog + $ a0 + :+: a1 + :+: a2 + :+: a4 + :+: a5 + :+: a6 + :+: a7 + :+: a8 + :+: a9 + :+: a11 + :+: a12 + :+: MerkleLogBody (blockHashRecordToVector a3) + +-- | Decode a BlockHeader and trust the result +-- +decodeBlockHeader :: Get BlockHeader +decodeBlockHeader = BlockHeader + <$> decodeFeatureFlags + <*> decodeBlockCreationTime + <*> decodeBlockHash -- parent hash + <*> decodeBlockHashRecord + <*> decodeHashTarget + <*> decodeBlockPayloadHash + <*> decodeChainId + <*> decodeBlockWeight + <*> decodeBlockHeight + <*> decodeChainwebVersionCode + <*> decodeEpochStartTime + <*> decodeNonce + <*> decodeBlockHash + +instance ToJSON BlockHeader where + toJSON = toJSON . encodeB64UrlNoPaddingText . runPutS . encodeBlockHeader + toEncoding = b64UrlNoPaddingTextEncoding . runPutS . encodeBlockHeader + {-# INLINE toJSON #-} + {-# INLINE toEncoding #-} + +instance FromJSON BlockHeader where + parseJSON = withText "BlockHeader" $ \t -> + case runGetS decodeBlockHeader =<< decodeB64UrlNoPaddingText t of + Left (e :: SomeException) -> fail (sshow e) + (Right !x) -> return x + +_blockAdjacentChainIds :: BlockHeader -> HS.HashSet ChainId +_blockAdjacentChainIds = + HS.fromList . HM.keys . _getBlockHashRecord . _blockAdjacentHashes + +blockAdjacentChainIds :: Getter BlockHeader (HS.HashSet ChainId) +blockAdjacentChainIds = to _blockAdjacentChainIds + +-- | @getAdjacentHash cid h@ returns the adjacent hash of h for chain cid. It +-- throws a @ChainNotAdjacentException@ if @cid@ is not adajcent with @_chainId +-- h@ in the chain graph of @h@. +-- +getAdjacentHash :: MonadThrow m => HasChainId p => p -> BlockHeader -> m BlockHash +getAdjacentHash p b = firstOf (blockAdjacentHashes . ixg (_chainId p)) b + ??? ChainNotAdjacentException + (_chainId b) + (Expected $ _chainId p) + (Actual $ _blockAdjacentChainIds b) +{-# INLINE getAdjacentHash #-} + +computeBlockHash :: BlockHeader -> BlockHash +computeBlockHash h = BlockHash $ MerkleLogHash $ computeMerkleLogRoot h +{-# INLINE computeBlockHash #-} + +-- | The Proof-Of-Work hash includes all data in the block except for the +-- '_blockHash'. The value (interpreted as 'BlockHashNat' must be smaller than +-- the value of '_blockTarget' (interpreted as 'BlockHashNat'). +-- +_blockPow :: BlockHeader -> PowHash +_blockPow h = cryptoHash @Blake2s_256 + $ runPutS $ encodeBlockHeaderWithoutHash h + +blockPow :: Getter BlockHeader PowHash +blockPow = to _blockPow +{-# INLINE blockPow #-} + +-- | The number of microseconds between the creation time of two `BlockHeader`s. +-- +timeBetween :: BlockCreationTime -> BlockCreationTime -> Micros +timeBetween after before = f after - f before + where + f :: BlockCreationTime -> Micros + f (BlockCreationTime (Time (TimeSpan ts))) = ts + +-- | Absolute BlockHeight Difference +-- +absBlockHeightDiff :: BlockHeader -> BlockHeader -> BlockHeight +absBlockHeightDiff a b + | _blockHeight a >= _blockHeight b = _blockHeight a - _blockHeight b + | otherwise = _blockHeight b - _blockHeight a + +-- -------------------------------------------------------------------------- -- +-- Object JSON encoding + +-- | By default a binary encoding of block headers is used as JSON encoding. In +-- some circumstance, like logging and configuration files, a textual encoding +-- is desired. +-- +newtype ObjectEncoded a = ObjectEncoded { _objectEncoded :: a } + deriving (Show, Generic) + deriving newtype (Eq, Ord, Hashable, NFData) + +blockHeaderProperties + :: KeyValue e kv + => ObjectEncoded BlockHeader + -> [kv] +blockHeaderProperties (ObjectEncoded b) = + [ "nonce" .= _blockNonce b + , "creationTime" .= _blockCreationTime b + , "parent" .= _blockParent b + , "adjacents" .= _blockAdjacentHashes b + , "target" .= _blockTarget b + , "payloadHash" .= _blockPayloadHash b + , "chainId" .= _chainId b + , "weight" .= _blockWeight b + , "height" .= _blockHeight b + , "chainwebVersion" .= _versionName (_chainwebVersion b) + , "epochStart" .= _blockEpochStart b + , "featureFlags" .= _blockFlags b + , "hash" .= _blockHash b + ] +{-# INLINE blockHeaderProperties #-} + +instance ToJSON (ObjectEncoded BlockHeader) where + toJSON = object . blockHeaderProperties + toEncoding = pairs . mconcat . blockHeaderProperties + {-# INLINE toJSON #-} + {-# INLINE toEncoding #-} + +parseBlockHeaderObject :: Object -> Parser BlockHeader +parseBlockHeaderObject o = BlockHeader + <$> o .: "featureFlags" + <*> o .: "creationTime" + <*> o .: "parent" + <*> o .: "adjacents" + <*> o .: "target" + <*> o .: "payloadHash" + <*> o .: "chainId" + <*> o .: "weight" + <*> o .: "height" + -- TODO: lookupVersionByName should probably be deprecated for performance, + -- so perhaps we move this codec outside of the node proper. + <*> (_versionCode . lookupVersionByName <$> (o .: "chainwebVersion")) + <*> o .: "epochStart" + <*> o .: "nonce" + <*> o .: "hash" + +instance FromJSON (ObjectEncoded BlockHeader) where + parseJSON = withObject "BlockHeader" + $ fmap ObjectEncoded . parseBlockHeaderObject + {-# INLINE parseJSON #-} + +-- -------------------------------------------------------------------------- -- +-- IsBlockHeader + +-- | Any type which can purely produce a `BlockHeader`, or purely construct one. +-- +class IsBlockHeader t where + isoBH :: Iso' t BlockHeader + +instance IsBlockHeader BlockHeader where + isoBH = id + +-- -------------------------------------------------------------------------- -- +-- Create new BlockHeader + +-- | Creates a new block header. No validation of the input parameters is +-- performaned. +-- +-- It's not guaranteed that the result is a valid block header. It is, however, +-- guaranteed by construction that +-- +-- * the target, +-- * the weight, +-- * the block height, +-- * the version, +-- * the chain id, and +-- * the epoch start time +-- +-- are valid with respect to the given parent header and adjacent parent +-- headers. +-- +-- TODO: also check adjacent chains. This would probably break a lot of tests, +-- but might be worth it! +-- +newBlockHeader + :: HM.HashMap ChainId ParentHeader + -- ^ Adjacent parent hashes. + -> BlockPayloadHash + -- ^ payload hash + -> Nonce + -- ^ Randomness to affect the block hash. It is not verified that the + -- nonce is valid with respect to the target. + -> BlockCreationTime + -- ^ Creation time of the block. + -> ParentHeader + -- ^ parent block header + -> BlockHeader +newBlockHeader adj pay nonce t p@(ParentHeader b) = + fromLog @ChainwebMerkleHashAlgorithm $ newMerkleLog + $ mkFeatureFlags + :+: t + :+: _blockHash b + :+: target + :+: pay + :+: cid + :+: _blockWeight b + BlockWeight (targetToDifficulty target) + :+: _blockHeight b + 1 + :+: _versionCode v + :+: epochStart p adj t + :+: nonce + :+: MerkleLogBody (blockHashRecordToVector adjHashes) + where + cid = _chainId p + v = _chainwebVersion p + target = powTarget p adj t + adjHashes = BlockHashRecord $ (_blockHash . _parentHeader) <$> adj + +-- -------------------------------------------------------------------------- -- +-- TreeDBEntry instance + +instance TreeDbEntry BlockHeader where + type Key BlockHeader = BlockHash + key = _blockHash + rank = int . _blockHeight + parent e + | isGenesisBlockHeader e = Nothing + | otherwise = Just (_blockParent e) + +-- | This is an internal function. Use 'headerSizeBytes' instead. +-- +-- Postconditions: for all @v@ +-- +-- * @not . null $ headerSizes v@, and +-- * @0 == (fst . last) (headerSizes v)@. +-- +-- Note that for all but genesis headers the number of adjacent hashes depends +-- on the graph of the parent. +-- +headerSizes :: ChainwebVersion -> Rule BlockHeight Natural +headerSizes v = fmap (\g -> _versionHeaderBaseSizeBytes v + 36 * degree g + 2) $ _versionGraphs v + +-- | The size of the serialized block header. +-- +-- This function is safe because of the invariant of 'headerSize' that there +-- exists and entry for block height 0. +-- +-- Note that for all but genesis headers the number of adjacent hashes depends +-- on the graph of the parent. +-- +headerSizeBytes + :: HasCallStack + => ChainwebVersion + -> ChainId + -> BlockHeight + -> Natural +headerSizeBytes v cid h = snd + $ ruleHead + $ ruleDropWhile (> relevantHeight) + $ headerSizes v + where + relevantHeight + | genesisHeight v cid == h = h + | otherwise = h - 1 + +-- | The size of the work bytes /without/ the preamble of the chain id and target +-- +-- The chain graph, and therefore also the header size, is constant for all +-- blocks at the same height except for genesis blocks. Because genesis blocks +-- are never mined, we can ignore this difference here and just return the +-- result for chain 0. +-- +-- NOTE: For production versions we require that the value is constant for a +-- given chainweb version. This would only ever change as part of the +-- introduction of new block header format. +-- +workSizeBytes + :: HasCallStack + => ChainwebVersion + -> BlockHeight + -> Natural +workSizeBytes v h = headerSizeBytes v (unsafeChainId 0) h - 32 diff --git a/src/Chainweb/BlockHeader/Validation.hs b/src/Chainweb/BlockHeader/Validation.hs index 87c4ebfc2a..50f46c7524 100644 --- a/src/Chainweb/BlockHeader/Validation.hs +++ b/src/Chainweb/BlockHeader/Validation.hs @@ -189,7 +189,7 @@ instance Exception InvalidValidationParameters where -- | Witnesses at runtime that -- --- prop> \(ChainStep p h) -> _blockParent h == _blockHash p +-- prop> \(ChainStep p h) -> view blockParent h == view blockHash p -- -- NOTE: the constructor of this type is intentionally NOT exported. -- @@ -212,13 +212,13 @@ chainStep -- ^ Block header under scrutiny -> m ChainStep chainStep p b - | _blockParent b == _blockHash (_parentHeader p) + | view blockParent b == view blockHash (_parentHeader p) = return $ ChainStep p b | otherwise = throwM $ InvalidChainStepParameters p b -- | Witnesses at runtime that -- --- prop> \(WebStep as (ChainStep _ h)) -> and $ HM.zipWith ((==) . _blockHash) as (_blockAdjacentHashes h) +-- prop> \(WebStep as (ChainStep _ h)) -> and $ HM.zipWith ((==) . view blockHash) as (view blockAdjacentHashes h) -- -- It doesn't witness that @as@ is of the same size as @_blockAdjacentHashes -- h@ or that @_blockAdjacentHashes h@ covers all adjacent chains. @@ -242,7 +242,7 @@ webStep as hp@(ChainStep _ h) = WebStep f cid a = case HM.lookup cid as of Nothing -> throwM $ InvalidWebStepParameters as hp Just x - | _blockHash (_parentHeader x) == a -> return x + | view blockHash (_parentHeader x) == a -> return x | otherwise -> throwM $ InvalidWebStepParameters as hp _webStepAdjs :: WebStep -> HM.HashMap ChainId ParentHeader @@ -546,7 +546,7 @@ validateBlockParentExists -> m (Either ValidationFailureType ChainStep) validateBlockParentExists lookupParent h | isGenesisBlockHeader h = return $ Right $ ChainStep (ParentHeader h) h - | otherwise = lookupParent (_blockParent h) >>= \case + | otherwise = lookupParent (view blockParent h) >>= \case (Just !p) -> return $ Right $ ChainStep (ParentHeader p) h Nothing -> return $ Left MissingParent @@ -678,10 +678,10 @@ prop_block_pow b | isGenesisBlockHeader b = True -- Genesis block headers are not mined. So there's not need for POW | b ^. chainwebVersion . versionCheats . disablePow = True - | otherwise = checkTarget (_blockTarget b) (_blockPow b) + | otherwise = checkTarget (view blockTarget b) (view blockPow b) prop_block_hash :: BlockHeader -> Bool -prop_block_hash b = _blockHash b == computeBlockHash b +prop_block_hash b = view blockHash b == computeBlockHash b prop_block_genesis_parent :: BlockHeader -> Bool prop_block_genesis_parent b @@ -689,22 +689,22 @@ prop_block_genesis_parent b && hasGenesisParentHash b ==> isGenesisBlockHeader b where hasGenesisParentHash b' = - _blockParent b' == genesisParentBlockHash (_chainwebVersion b') (_chainId b') + view blockParent b' == genesisParentBlockHash (_chainwebVersion b') (_chainId b') prop_block_genesis_target :: BlockHeader -> Bool prop_block_genesis_target b = isGenesisBlockHeader b - ==> _blockTarget b == _chainwebVersion b ^?! versionGenesis . genesisBlockTarget . onChain (_chainId b) + ==> view blockTarget b == _chainwebVersion b ^?! versionGenesis . genesisBlockTarget . onChain (_chainId b) prop_block_current :: Time Micros -> BlockHeader -> Bool -prop_block_current t b = BlockCreationTime t >= _blockCreationTime b +prop_block_current t b = BlockCreationTime t >= view blockCreationTime b prop_block_featureFlags :: BlockHeader -> Bool prop_block_featureFlags b | skipFeatureFlagValidationGuard v cid h = True - | otherwise = _blockFlags b == mkFeatureFlags + | otherwise = view blockFlags b == mkFeatureFlags where v = _chainwebVersion b - h = _blockHeight b + h = view blockHeight b cid = _chainId b -- | Verify that the adjacent hashes of the block are for the correct set of @@ -712,11 +712,11 @@ prop_block_featureFlags b -- prop_block_adjacent_chainIds :: BlockHeader -> Bool prop_block_adjacent_chainIds b - = isJust $ checkAdjacentChainIds adjGraph b (Expected $ _blockAdjacentChainIds b) + = isJust $ checkAdjacentChainIds adjGraph b (Expected $ view blockAdjacentChainIds b) where adjGraph | isGenesisBlockHeader b = _chainGraph b - | otherwise = chainGraphAt (_chainwebVersion b) (_blockHeight b - 1) + | otherwise = chainGraphAt (_chainwebVersion b) (view blockHeight b - 1) -- -------------------------------------------------------------------------- -- -- Inductive BlockHeader Properties @@ -727,50 +727,50 @@ prop_block_adjacent_chainIds b prop_block_height :: ChainStep -> Bool prop_block_height (ChainStep (ParentHeader p) b) - | isGenesisBlockHeader b = _blockHeight b == _blockHeight p - | otherwise = _blockHeight b == _blockHeight p + 1 + | isGenesisBlockHeader b = view blockHeight b == view blockHeight p + | otherwise = view blockHeight b == view blockHeight p + 1 prop_block_chainwebVersion :: ChainStep -> Bool prop_block_chainwebVersion (ChainStep (ParentHeader p) b) = - _blockChainwebVersion p == _blockChainwebVersion b + view blockChainwebVersion p == view blockChainwebVersion b prop_block_weight :: ChainStep -> Bool prop_block_weight (ChainStep (ParentHeader p) b) - | isGenesisBlockHeader b = _blockWeight b == _blockWeight p - | otherwise = _blockWeight b == expectedWeight + | isGenesisBlockHeader b = view blockWeight b == view blockWeight p + | otherwise = view blockWeight b == expectedWeight where - expectedWeight = int (targetToDifficulty (_blockTarget b)) + _blockWeight p + expectedWeight = int (targetToDifficulty (view blockTarget b)) + view blockWeight p prop_block_chainId :: ChainStep -> Bool prop_block_chainId (ChainStep (ParentHeader p) b) - = _blockChainId p == _blockChainId b + = view blockChainId p == view blockChainId b -- -------------------------------------------------------------------------- -- -- Multi chain inductive properties prop_block_target :: WebStep -> Bool prop_block_target (WebStep as (ChainStep p b)) - = _blockTarget b == powTarget p as (_blockCreationTime b) + = view blockTarget b == powTarget p as (view blockCreationTime b) prop_block_epoch :: WebStep -> Bool prop_block_epoch (WebStep as (ChainStep p b)) - | oldDaGuard (_chainwebVersion b) (_chainId b) (_blockHeight b) - = _blockEpochStart b <= EpochStartTime (_bct $ _blockCreationTime b) - && _blockEpochStart (_parentHeader p) <= _blockEpochStart b - && _blockEpochStart b == epochStart p as (_blockCreationTime b) + | oldDaGuard (_chainwebVersion b) (_chainId b) (view blockHeight b) + = view blockEpochStart b <= EpochStartTime (_bct $ view blockCreationTime b) + && view blockEpochStart (_parentHeader p) <= view blockEpochStart b + && view blockEpochStart b == epochStart p as (view blockCreationTime b) | otherwise - = _blockEpochStart b <= EpochStartTime (_bct $ _blockCreationTime b) - && _blockEpochStart b == epochStart p as (_blockCreationTime b) + = view blockEpochStart b <= EpochStartTime (_bct $ view blockCreationTime b) + && view blockEpochStart b == epochStart p as (view blockCreationTime b) prop_block_creationTime :: WebStep -> Bool prop_block_creationTime (WebStep as (ChainStep (ParentHeader p) b)) | isGenesisBlockHeader b - = _blockCreationTime b == _blockCreationTime p - | oldDaGuard (_chainwebVersion b) (_chainId b) (_blockHeight b) - = _blockCreationTime b > _blockCreationTime p + = view blockCreationTime b == view blockCreationTime p + | oldDaGuard (_chainwebVersion b) (_chainId b) (view blockHeight b) + = view blockCreationTime b > view blockCreationTime p | otherwise - = _blockCreationTime b > _blockCreationTime p - && all (\x -> _blockCreationTime b > _blockCreationTime (_parentHeader x)) as + = view blockCreationTime b > view blockCreationTime p + && all (\x -> view blockCreationTime b > view blockCreationTime (_parentHeader x)) as -- | The chainId index of the adjacent parents of the header and the blocks -- in the webstep reference the same hashes and the chain Ids in of the @@ -787,21 +787,21 @@ prop_block_adjacent_parents (WebStep as (ChainStep _ b)) -- chainId indexes in web adjadent parent record references the -- genesis block parent hashes | otherwise - = adjsHashes == (_blockHash . _parentHeader <$> as) + = adjsHashes == (view blockHash . _parentHeader <$> as) -- chainId indexes in web adjadent parent record and web step are -- referencing the same hashes && iall (\cid h -> cid == _chainId h) as -- chainIds of adjancent parent header match the chainId under which -- it is indexed where - adjsHashes = _getBlockHashRecord (_blockAdjacentHashes b) + adjsHashes = _getBlockHashRecord (view blockAdjacentHashes b) v = _chainwebVersion b prop_block_adjacent_parents_version :: WebStep -> Bool prop_block_adjacent_parents_version (WebStep as (ChainStep _ b)) - = all ((== v) . _blockChainwebVersion . _parentHeader) as + = all ((== v) . view blockChainwebVersion . _parentHeader) as where - v = _blockChainwebVersion b + v = view blockChainwebVersion b -- | TODO: we don't current check this here. It is enforced in the cut merge -- algorithm , namely in 'monotonicCutExtension'. The property that is checked diff --git a/src/Chainweb/BlockHeaderDB/Internal.hs b/src/Chainweb/BlockHeaderDB/Internal.hs index 419e950375..fd13e8db40 100644 --- a/src/Chainweb/BlockHeaderDB/Internal.hs +++ b/src/Chainweb/BlockHeaderDB/Internal.hs @@ -110,7 +110,7 @@ instance HasChainGraph RankedBlockHeader where {-# INLINE _chainGraph #-} instance Ord RankedBlockHeader where - compare = compare `on` ((_blockHeight &&& id) . _getRankedBlockHeader) + compare = compare `on` ((view blockHeight &&& id) . _getRankedBlockHeader) {-# INLINE compare #-} -- -------------------------------------------------------------------------- -- @@ -126,7 +126,7 @@ data RankedBlockHash = RankedBlockHash instance IsCasValue RankedBlockHeader where type CasKeyType RankedBlockHeader = RankedBlockHash casKey (RankedBlockHeader bh) - = RankedBlockHash (_blockHeight bh) (_blockHash bh) + = RankedBlockHash (view blockHeight bh) (view blockHash bh) {-# INLINE casKey #-} -- -------------------------------------------------------------------------- -- @@ -205,7 +205,7 @@ dbAddChecked :: BlockHeaderDb -> BlockHeader -> IO () dbAddChecked db e = unlessM (tableMember (_chainDbCas db) ek) dbAddCheckedInternal where r = int $ rank e - ek = RankedBlockHash r (_blockHash e) + ek = RankedBlockHash r (view blockHash e) -- Internal helper methods @@ -227,7 +227,7 @@ dbAddChecked db e = unlessM (tableMember (_chainDbCas db) ek) dbAddCheckedIntern add = updateBatch [ RocksDbInsert (_chainDbCas db) (casKey rbh) rbh - , RocksDbInsert (_chainDbRankTable db) (_blockHash e) (_blockHeight e) + , RocksDbInsert (_chainDbRankTable db) (view blockHash e) (view blockHeight e) ] where rbh = RankedBlockHeader e @@ -304,7 +304,7 @@ instance TreeDb BlockHeaderDb where entries db k l mir mar f = withSeekTreeDb db k mir $ \it -> f $ do iterToValueStream it & S.map _getRankedBlockHeader - & maybe id (\x -> S.takeWhile (\a -> int (_blockHeight a) <= x)) mar + & maybe id (\x -> S.takeWhile (\a -> int (view blockHeight a) <= x)) mar & limitStream l {-# INLINEABLE entries #-} diff --git a/src/Chainweb/BlockHeaderDB/PruneForks.hs b/src/Chainweb/BlockHeaderDB/PruneForks.hs index 5c966365d6..d79f88c2f4 100644 --- a/src/Chainweb/BlockHeaderDB/PruneForks.hs +++ b/src/Chainweb/BlockHeaderDB/PruneForks.hs @@ -26,6 +26,7 @@ module Chainweb.BlockHeaderDB.PruneForks import Control.DeepSeq import Control.Exception (evaluate) +import Control.Lens (view) import Control.Monad import Control.Monad.Catch @@ -121,18 +122,18 @@ pruneForks pruneForks logg cdb depth callback = do hdr <- maxEntry cdb if - | int (_blockHeight hdr) <= depth -> do + | int (view blockHeight hdr) <= depth -> do logg Info $ "Skipping database pruning because the maximum block height " - <> sshow (_blockHeight hdr) <> " is not larger than then requested depth " + <> sshow (view blockHeight hdr) <> " is not larger than then requested depth " <> sshow depth return 0 - | int (_blockHeight hdr) <= int genHeight + depth -> do + | int (view blockHeight hdr) <= int genHeight + depth -> do logg Info $ "Skipping database pruning because there are not yet" <> " enough block headers on the chain" return 0 | otherwise -> do - let mar = MaxRank $ Max $ int (_blockHeight hdr) - depth + let mar = MaxRank $ Max $ int (view blockHeight hdr) - depth pruneForks_ logg cdb mar (MinRank $ Min $ int genHeight) callback where v = _chainwebVersion cdb @@ -173,7 +174,7 @@ pruneForks_ logg cdb mar mir callback = do -- parent hashes of all blocks at height max rank @mar@. -- !pivots <- entries cdb Nothing Nothing (Just $ MinRank $ Min $ _getMaxRank mar) (Just mar) - $ fmap (force . L.nub) . S.toList_ . S.map _blockParent + $ fmap (force . L.nub) . S.toList_ . S.map (view blockParent) -- the set of pivots is expected to be very small. In fact it is -- almost always a singleton set. @@ -191,7 +192,7 @@ pruneForks_ logg cdb mar mir callback = do reportProgress i a = logg Info $ "inspected " <> sshow i <> " block headers. Current height " - <> sshow (_blockHeight a) + <> sshow (view blockHeight a) go :: ([BlockHash], BlockHeight, Int) -> BlockHeader -> IO ([BlockHash], BlockHeight, Int) go ([], _, _) cur = throwM $ InternalInvariantViolation @@ -207,25 +208,25 @@ pruneForks_ logg cdb mar mir callback = do <> ". Current pivots: " <> encodeToText pivots <> ". Current header: " <> encodeToText (ObjectEncoded cur) <> ". Previous height: " <> sshow prevHeight - | _blockHash cur `elem` pivots = do + | view blockHash cur `elem` pivots = do callback False cur - let !pivots' = force $ L.nub $ _blockParent cur : L.delete (_blockHash cur) pivots + let !pivots' = force $ L.nub $ view blockParent cur : L.delete (view blockHash cur) pivots return (pivots', curHeight, n) | otherwise = do deleteHdr cur callback True cur return (pivots, curHeight, n+1) where - curHeight = _blockHeight cur + curHeight = view blockHeight cur deleteHdr k = do -- TODO: make this atomic (create boilerplate to combine queries for -- different tables) casDelete (_chainDbCas cdb) (RankedBlockHeader k) - tableDelete (_chainDbRankTable cdb) (_blockHash k) + tableDelete (_chainDbRankTable cdb) (view blockHash k) logg Debug - $ "pruned block header " <> encodeToText (_blockHash k) - <> " at height " <> sshow (_blockHeight k) + $ "pruned block header " <> encodeToText (view blockHash k) + <> " at height " <> sshow (view blockHeight k) -- -------------------------------------------------------------------------- -- -- Utils @@ -243,7 +244,7 @@ withReverseHeaderStream db mar mir inner = withTableIterator headerTbl $ \it -> iterPrev it inner $ iterToReverseValueStream it & S.map _getRankedBlockHeader - & S.takeWhile (\a -> int (_blockHeight a) >= mir) + & S.takeWhile (\a -> int (view blockHeight a) >= mir) where headerTbl = _chainDbCas db diff --git a/src/Chainweb/BlockHeaderDB/RestAPI/Server.hs b/src/Chainweb/BlockHeaderDB/RestAPI/Server.hs index cfafe0112e..1ddc3c1085 100644 --- a/src/Chainweb/BlockHeaderDB/RestAPI/Server.hs +++ b/src/Chainweb/BlockHeaderDB/RestAPI/Server.hs @@ -62,7 +62,7 @@ import qualified Streaming.Prelude as SP -- internal modules import Chainweb.BlockHash -import Chainweb.BlockHeader (BlockHeader(..), ObjectEncoded(..), _blockPow) +import Chainweb.BlockHeader import Chainweb.BlockHeaderDB import Chainweb.BlockHeaderDB.RestAPI import Chainweb.ChainId @@ -243,7 +243,7 @@ branchBlocksHandler bhdb pdb (BranchBoundsLimit boundsLimit) maxLimit limit next effectiveLimit = min maxLimit <$> (limit <|> Just maxLimit) grabPayload :: BlockHeader -> IO Block grabPayload h = do - Just x <- lookupPayloadWithHeight pdb (Just $ _blockHeight h) (_blockPayloadHash h) + Just x <- lookupPayloadWithHeight pdb (Just $ view blockHeight h) (view blockPayloadHash h) pure (Block h x) -- | Every `TreeDb` key within a given range. @@ -315,7 +315,7 @@ blocksHandler bhdb pdb maxLimit limit next minr maxr = do effectiveLimit = min maxLimit <$> (limit <|> Just maxLimit) grabPayload :: BlockHeader -> IO Block grabPayload h = do - Just x <- lookupPayloadWithHeight pdb (Just $ _blockHeight h) (_blockPayloadHash h) + Just x <- lookupPayloadWithHeight pdb (Just $ view blockHeight h) (view blockPayloadHash h) pure (Block h x) -- | Query a single 'BlockHeader' by its 'BlockHash' @@ -416,14 +416,14 @@ blockStreamHandler db withPayloads = Tagged $ \req resp -> do g :: BlockHeader -> IO HeaderUpdate g bh = do - Just x <- lookupPayloadWithHeight cas (Just $ _blockHeight bh) (_blockPayloadHash bh) + Just x <- lookupPayloadWithHeight cas (Just $ view blockHeight bh) (view blockPayloadHash bh) pure $ HeaderUpdate { _huHeader = ObjectEncoded bh , _huPayloadWithOutputs = x <$ guard withPayloads , _huTxCount = length $ _payloadWithOutputsTransactions x - , _huPowHash = decodeUtf8 . B16.encode . BS.reverse . fromShort . powHashBytes $ _blockPow bh - , _huTarget = showTargetHex $ _blockTarget bh + , _huPowHash = decodeUtf8 . B16.encode . BS.reverse . fromShort . powHashBytes $ view blockPow bh + , _huTarget = showTargetHex $ view blockTarget bh } f :: HeaderUpdate -> ServerEvent diff --git a/src/Chainweb/Chainweb/MinerResources.hs b/src/Chainweb/Chainweb/MinerResources.hs index b911939bc8..ed9d517c31 100644 --- a/src/Chainweb/Chainweb/MinerResources.hs +++ b/src/Chainweb/Chainweb/MinerResources.hs @@ -187,7 +187,7 @@ withMiningCoordination logger conf cdb inner ourMiner = workForMiner miner cid let !outdatedPayload = fromJuste $ pw ^? ourMiner let outdatedParentHash = case outdatedPayload of - WorkReady outdatedBlock -> _blockHash (_parentHeader (newBlockParentHeader outdatedBlock)) + WorkReady outdatedBlock -> view blockHash (_parentHeader (newBlockParentHeader outdatedBlock)) WorkAlreadyMined outdatedBlockHash -> outdatedBlockHash WorkStale -> error "primeWork loop: Invariant Violation: Stale work should be an impossibility" diff --git a/src/Chainweb/Chainweb/PruneChainDatabase.hs b/src/Chainweb/Chainweb/PruneChainDatabase.hs index c4d74ca683..08963bef0e 100644 --- a/src/Chainweb/Chainweb/PruneChainDatabase.hs +++ b/src/Chainweb/Chainweb/PruneChainDatabase.hs @@ -91,6 +91,7 @@ module Chainweb.Chainweb.PruneChainDatabase import Chainweb.BlockHeader import Control.Concurrent.Async +import Control.Lens (view) import Control.Monad import Control.Monad.Catch @@ -216,7 +217,7 @@ instance Exception DatabaseCheckException -- checkPayloads :: PayloadDb RocksDbTable -> Bool -> BlockHeader -> IO () checkPayloads _ True _ = return () -checkPayloads pdb False h = lookupPayloadWithHeight pdb (Just $ _blockHeight h) (_blockPayloadHash h) >>= \case +checkPayloads pdb False h = lookupPayloadWithHeight pdb (Just $ view blockHeight h) (view blockPayloadHash h) >>= \case Just p | verifyPayloadWithOutputs p -> return () | otherwise -> throwM $ InconsistentPaylaod h p @@ -232,7 +233,7 @@ checkPayloads pdb False h = lookupPayloadWithHeight pdb (Just $ _blockHeight h) checkPayloadsExist :: PayloadDb RocksDbTable -> Bool -> BlockHeader -> IO () checkPayloadsExist _ True _ = return () checkPayloadsExist pdb False h = do - lookupPayloadDataWithHeight pdb (Just $ _blockHeight h) (_blockPayloadHash h) >>= \case + lookupPayloadDataWithHeight pdb (Just $ view blockHeight h) (view blockPayloadHash h) >>= \case Just _ -> return () Nothing -> throwM $ MissingPayloadException h {-# INLINE checkPayloadsExist #-} @@ -333,8 +334,8 @@ fullGc logger rdb v = do chainLogg Info "start pruning block header database" x <- pruneForksLogg chainLogger cdb depth $ \isDeleted hdr -> case isDeleted of True -> chainLogg Debug - $ "pruned header " <> toText (_blockHash hdr) - <> " at height " <> sshow (_blockHeight hdr) + $ "pruned header " <> toText (view blockHash hdr) + <> " at height " <> sshow (view blockHeight hdr) False -> markPayload markedPayloads hdr chainLogg Info $ "finished pruning block header database. Deleted " <> sshow x <> " block headers." @@ -346,7 +347,7 @@ fullGc logger rdb v = do -- | Mark Payloads of non-deleted block headers. -- markPayload :: Filter BlockPayloadHash -> BlockHeader -> IO () -markPayload f = tryInsert f "payload hash" . _blockPayloadHash +markPayload f = tryInsert f "payload hash" . view blockPayloadHash {-# INLINE markPayload #-} -- | Mark Payload Transactions diff --git a/src/Chainweb/Cut.hs b/src/Chainweb/Cut.hs index faef8b6d2f..32407a9580 100644 --- a/src/Chainweb/Cut.hs +++ b/src/Chainweb/Cut.hs @@ -290,7 +290,7 @@ cutAdjPairs = to _cutAdjPairs -- Chain Heights chainHeights :: Cut -> [BlockHeight] -chainHeights = fmap (_blockHeight) . toList . _cutHeaders +chainHeights = fmap (view blockHeight) . toList . _cutHeaders {-# INLINE chainHeights #-} meanChainHeight :: Cut -> BlockHeight @@ -334,7 +334,7 @@ isTransitionCut c = minChainHeight c < lastGraphChange c (maxChainHeight c) -- old chains have transitioned to the minimum block height of the new graph. cutHeadersMinHeight :: HM.HashMap ChainId BlockHeader -> BlockHeight -cutHeadersMinHeight = minimum . fmap _blockHeight +cutHeadersMinHeight = minimum . fmap (view blockHeight) {-# INLINE cutHeadersMinHeight #-} cutHeadersChainwebVersion :: HM.HashMap ChainId BlockHeader -> ChainwebVersion @@ -416,7 +416,7 @@ limitCut -> Cut -> IO Cut limitCut wdb h c - | all (\bh -> h >= _blockHeight bh) (view cutHeaders c) = + | all (\bh -> h >= view blockHeight bh) (view cutHeaders c) = return c | otherwise = do hdrs <- itraverse go $ view cutHeaders c @@ -424,11 +424,11 @@ limitCut wdb h c where go :: ChainId -> BlockHeader -> IO (Maybe BlockHeader) go cid bh = do - if h >= _blockHeight bh + if h >= view blockHeight bh then return (Just bh) else do !db <- getWebBlockHeaderDb wdb cid - seekAncestor db bh (min (int $ _blockHeight bh) (int h)) + seekAncestor db bh (min (int $ view blockHeight bh) (int h)) -- this is safe because it's guaranteed that the requested rank is -- smaller then the block height of the argument @@ -447,7 +447,7 @@ tryLimitCut -> Cut -> IO Cut tryLimitCut wdb h c - | all (\bh -> h >= _blockHeight bh) (view cutHeaders c) = + | all (\bh -> h >= view blockHeight bh) (view cutHeaders c) = return c | otherwise = do hdrs <- itraverse go $ view cutHeaders c @@ -456,13 +456,13 @@ tryLimitCut wdb h c v = _chainwebVersion wdb go :: ChainId -> BlockHeader -> IO BlockHeader go cid bh = do - if h >= _blockHeight bh + if h >= view blockHeight bh then return bh else do !db <- getWebBlockHeaderDb wdb cid -- this is safe because it's guaranteed that the requested rank is -- smaller then the block height of the argument - let ancestorHeight = min (int $ _blockHeight bh) (int h) + let ancestorHeight = min (int $ view blockHeight bh) (int h) if ancestorHeight <= fromIntegral (genesisHeight v cid) then return $ genesisBlockHeader v cid else fromJuste <$> seekAncestor db bh ancestorHeight @@ -574,9 +574,9 @@ checkBraidingOfCutPair s t = do -- ab <- getAdjacentHash b a -- adjacent of a on chain of b -- ba <- getAdjacentHash a b -- adjacent of b on chain of a -- return --- $! (_blockParent a == ba && _blockParent b == ab) --- || ab == _blockHash b --- || ba == _blockHash a +-- $! (view blockParent a == ba && view blockParent b == ab) +-- || ab == view blockHash b +-- || ba == view blockHash a -- @ -- -- The actual implementation is a it more complex because headers of different @@ -601,9 +601,9 @@ isBraidingOfCutPair a b = do ab <- getAdjacentHash b a -- adjacent of a on chain of b ba <- getAdjacentHash a b -- adjacent of b on chain of a return - $! (_blockParent a == ba && _blockParent b == ab) -- same graph - || (_blockHeight a > _blockHeight b) && ab == _blockHash b - || (_blockHeight a < _blockHeight b) && True {- if same graph: ba == _blockHash a -} + $! (view blockParent a == ba && view blockParent b == ab) -- same graph + || (view blockHeight a > view blockHeight b) && ab == view blockHash b + || (view blockHeight a < view blockHeight b) && True {- if same graph: ba == view blockHash a -} -- -------------------------------------------------------------------------- -- -- Extending Cuts @@ -635,16 +635,16 @@ isMonotonicCutExtension c h = do checkBlockHeaderGraph h return $! monotonic && validBraiding where - monotonic = _blockParent h == case c ^? ixg (_chainId h) . blockHash of + monotonic = view blockParent h == case c ^? ixg (_chainId h) . blockHash of Nothing -> error $ T.unpack $ "isMonotonicCutExtension.monotonic: missing parent in cut. " <> encodeToText h Just x -> x validBraiding = getAll $ ifoldMap (\cid -> All . validBraidingCid cid) - (_getBlockHashRecord $ _blockAdjacentHashes h) + (_getBlockHashRecord $ view blockAdjacentHashes h) validBraidingCid cid a - | Just b <- c ^? ixg cid = _blockHash b == a || _blockParent b == a - | _blockHeight h == genesisHeight v cid = a == genesisParentBlockHash v cid + | Just b <- c ^? ixg cid = view blockHash b == a || view blockParent b == a + | view blockHeight h == genesisHeight v cid = a == genesisParentBlockHash v cid | otherwise = error $ T.unpack $ "isMonotonicCutExtension.validBraiding: missing adjacent parent on chain " <> toText cid <> " in cut. " <> encodeToText h v = _chainwebVersion c @@ -752,7 +752,7 @@ join_ wdb prioFun a b = do -> (BlockHeader, Maybe a) -> H.Heap (H.Entry (BlockHeight, a) BlockHeader) maybeInsert !q (_, Nothing) = q - maybeInsert !q (!h, (Just !p)) = H.insert (H.Entry (_blockHeight h, p) h) q + maybeInsert !q (!h, (Just !p)) = H.insert (H.Entry (view blockHeight h, p) h) q -- | Only chain ids of the intersection are included in the result. -- @@ -900,7 +900,7 @@ forkDepth wdb a b = do return $! int $ max (maxDepth m a) (maxDepth m b) where maxDepth l u = maximum - $ (\(_, x, y) -> _blockHeight y - _blockHeight x) + $ (\(_, x, y) -> view blockHeight y - view blockHeight x) <$> zipCuts l u cutToTextShort :: Cut -> [Text] diff --git a/src/Chainweb/Cut/Create.hs b/src/Chainweb/Cut/Create.hs index f224a723da..74b5af3f0b 100644 --- a/src/Chainweb/Cut/Create.hs +++ b/src/Chainweb/Cut/Create.hs @@ -183,7 +183,7 @@ getCutExtension c cid = do where p = c ^?! ixg (_chainId cid) v = _chainwebVersion c - parentHeight = _blockHeight p + parentHeight = view blockHeight p targetHeight = parentHeight + 1 parentGraph = chainGraphAt p parentHeight isGraphTransitionPost = isGraphChange c parentHeight @@ -213,20 +213,20 @@ getCutExtension c cid = do tryAdj b -- When the block is behind, we can move ahead - | _blockHeight b == targetHeight = Just $! _blockParent b + | view blockHeight b == targetHeight = Just $! view blockParent b -- if the block is ahead it's blocked - | _blockHeight b + 1 == parentHeight = Nothing -- chain is blocked + | view blockHeight b + 1 == parentHeight = Nothing -- chain is blocked -- If this is not a graph transition cut we can move ahead - | _blockHeight b == parentHeight = Just $! _blockHash b + | view blockHeight b == parentHeight = Just $! view blockHash b -- The cut is invalid - | _blockHeight b > targetHeight = error $ T.unpack + | view blockHeight b > targetHeight = error $ T.unpack $ "getAdjacentParents: detected invalid cut (adjacent parent too far ahead)." <> "\n Parent: " <> encodeToText (ObjectEncoded p) <> "\n Conflict: " <> encodeToText (ObjectEncoded b) - | _blockHeight b + 1 < parentHeight = error $ T.unpack + | view blockHeight b + 1 < parentHeight = error $ T.unpack $ "getAdjacentParents: detected invalid cut (adjacent parent too far behind)." <> "\n Parent: " <> encodeToText (ObjectEncoded p) <> "\n Conflict: " <> encodeToText (ObjectEncoded b) @@ -304,7 +304,7 @@ newWorkHeaderPure hdb creationTime extension phash = do -- FIXME: check that parents also include hashes on new chains! in WorkHeader { _workHeaderBytes = SB.toShort $ runPutS $ encodeBlockHeaderWithoutHash nh - , _workHeaderTarget = _blockTarget nh + , _workHeaderTarget = view blockTarget nh , _workHeaderChainId = _chainId nh } @@ -338,7 +338,7 @@ getAdjacentParentHeaders hdb extension c = _cutExtensionCut extension select cid h = case c ^? ixg cid of - Just ch -> ParentHeader <$> if _blockHash ch == h + Just ch -> ParentHeader <$> if view blockHash ch == h then pure ch else hdb (ChainValue cid h) @@ -398,11 +398,11 @@ extend c pwo s = do where toCutHashes bh c' = cutToCutHashes Nothing c' & set cutHashesHeaders - (HM.singleton (_blockHash bh) bh) + (HM.singleton (view blockHash bh) bh) & set cutHashesPayloads - (HM.singleton (_blockPayloadHash bh) (payloadWithOutputsToPayloadData pwo)) + (HM.singleton (view blockPayloadHash bh) (payloadWithOutputsToPayloadData pwo)) & set cutHashesLocalPayload - (Just (_blockPayloadHash bh, pwo)) + (Just (view blockPayloadHash bh, pwo)) -- | For internal use and testing -- @@ -422,9 +422,9 @@ extendCut c ph (SolvedWork bh) = do -- Fail Early: check that the given payload matches the new block. -- - unless (_blockPayloadHash bh == ph) $ throwM $ InvalidSolvedHeader bh + unless (view blockPayloadHash bh == ph) $ throwM $ InvalidSolvedHeader bh $ "Invalid payload hash" - <> ". Expected: " <> sshow (_blockPayloadHash bh) + <> ". Expected: " <> sshow (view blockPayloadHash bh) <> ", Got: " <> sshow ph -- If the `BlockHeader` is already stale and can't be appended to the diff --git a/src/Chainweb/Cut/CutHashes.hs b/src/Chainweb/Cut/CutHashes.hs index 84ceb5b224..f1b3246480 100644 --- a/src/Chainweb/Cut/CutHashes.hs +++ b/src/Chainweb/Cut/CutHashes.hs @@ -207,7 +207,7 @@ instance HasCutId (HM.HashMap x BlockHash) where {-# INLINE _cutId #-} instance HasCutId (HM.HashMap x BlockHeader) where - _cutId = _cutId . fmap _blockHash + _cutId = _cutId . fmap (view blockHash) {-# INLINE _cutId #-} instance HasCutId (HM.HashMap x (y, BlockHash)) where @@ -360,7 +360,7 @@ instance FromJSON CutHashes where -- cutToCutHashes :: Maybe PeerInfo -> Cut -> CutHashes cutToCutHashes p c = CutHashes - { _cutHashes = (\x -> BlockHashWithHeight (_blockHeight x) (_blockHash x)) <$> _cutMap c + { _cutHashes = (\x -> BlockHashWithHeight (view blockHeight x) (view blockHash x)) <$> _cutMap c , _cutOrigin = p , _cutHashesWeight = _cutWeight c , _cutHashesHeight = _cutHeight c diff --git a/src/Chainweb/CutDB.hs b/src/Chainweb/CutDB.hs index d958fbb8e9..e86f7bb351 100644 --- a/src/Chainweb/CutDB.hs +++ b/src/Chainweb/CutDB.hs @@ -358,7 +358,7 @@ awaitNewBlockStm :: CutDb tbl -> ChainId -> BlockHash -> STM BlockHeader awaitNewBlockStm cdb cid bHash = do c <- _cutStm cdb case HM.lookup cid (_cutMap c) of - Just bh' | _blockHash bh' /= bHash -> return bh' + Just bh' | view blockHash bh' /= bHash -> return bh' _ -> retry -- | As in `awaitNewCut`, but only updates when the specified `ChainId` has @@ -698,8 +698,8 @@ cutStreamToHeaderStream db s = S.for (go Nothing s) $ \(T2 p n) -> branch :: ChainId -> BlockHeader -> BlockHeader -> S.Stream (Of BlockHeader) m () branch cid p n = hoist liftIO $ getBranch (db ^?! cutDbBlockHeaderDb cid) - (HS.singleton $ LowerBound $ _blockHash p) - (HS.singleton $ UpperBound $ _blockHash n) + (HS.singleton $ LowerBound $ view blockHash p) + (HS.singleton $ UpperBound $ view blockHash n) -- | Given a stream of cuts, produce a stream of all blocks included in those -- cuts. Blocks of the same chain are sorted by block height. @@ -744,7 +744,7 @@ cutStreamToHeaderDiffStream db s = S.for (cutUpdates Nothing s) $ \(T2 p n) -> -- uniqueBlockNumber :: BlockHeader -> Natural uniqueBlockNumber bh - = chainIdInt (_chainId bh) + int (_blockHeight bh) * order (_chainGraph bh) + = chainIdInt (_chainId bh) + int (view blockHeight bh) * order (_chainGraph bh) blockStream :: MonadIO m => CutDb tbl -> S.Stream (Of BlockHeader) m r blockStream db = cutStreamToHeaderStream db $ cutStream db @@ -833,9 +833,9 @@ memberOfHeader memberOfHeader db cid h ctx = do lookup chainDb h >>= \case Nothing -> return False - Just lh -> seekAncestor chainDb ctx (int $ _blockHeight lh) >>= \case + Just lh -> seekAncestor chainDb ctx (int $ view blockHeight lh) >>= \case Nothing -> return False - Just x -> return $ _blockHash x == h + Just x -> return $ view blockHash x == h where chainDb = db ^?! cutDbWebBlockHeaderDb . ixg cid diff --git a/src/Chainweb/Mempool/Consensus.hs b/src/Chainweb/Mempool/Consensus.hs index 63c1d8ab51..1eb78973e7 100644 --- a/src/Chainweb/Mempool/Consensus.hs +++ b/src/Chainweb/Mempool/Consensus.hs @@ -22,6 +22,7 @@ module Chainweb.Mempool.Consensus ------------------------------------------------------------------------------ import Control.DeepSeq import Control.Exception +import Control.Lens (view) import Control.Monad import Data.Aeson @@ -108,7 +109,7 @@ processFork blockHeaderDb payloadStore lastHeaderRef logFun newHeader = do lastHeader <- readIORef lastHeaderRef let v = _chainwebVersion blockHeaderDb cid = _chainId blockHeaderDb - height = _blockHeight newHeader + height = view blockHeight newHeader (a, b) <- processFork' logFun blockHeaderDb newHeader lastHeader (payloadLookup payloadStore) (processForkCheckTTL (pactParserVersion v cid height) now) @@ -176,9 +177,9 @@ payloadLookup payloadStore bh = case payloadStore of Nothing -> return mempty Just s -> do - pd <- lookupPayloadDataWithHeight s (Just (_blockHeight bh)) (_blockPayloadHash bh) - pd' <- maybe (throwIO $ PayloadNotFoundException (_blockPayloadHash bh)) pure pd - chainwebTxsFromPd (pactParserVersion (_chainwebVersion bh) (_chainId bh) (_blockHeight bh)) pd' + pd <- lookupPayloadDataWithHeight s (Just (view blockHeight bh)) (view blockPayloadHash bh) + pd' <- maybe (throwIO $ PayloadNotFoundException (view blockPayloadHash bh)) pure pd + chainwebTxsFromPd (pactParserVersion (_chainwebVersion bh) (_chainId bh) (view blockHeight bh)) pd' ------------------------------------------------------------------------------ chainwebTxsFromPd diff --git a/src/Chainweb/Miner/Coordinator.hs b/src/Chainweb/Miner/Coordinator.hs index 5d5356e518..5e37d140dc 100644 --- a/src/Chainweb/Miner/Coordinator.hs +++ b/src/Chainweb/Miner/Coordinator.hs @@ -236,7 +236,7 @@ newWork logFun choice eminer@(Miner mid _) hdb pact tpw c = do newWork logFun Anything eminer hdb pact tpw c Just (T2 (WorkReady newBlock) extension) -> do let ParentHeader primedParent = newBlockParentHeader newBlock - if _blockHash primedParent == _blockHash (_parentHeader (_cutExtensionParent extension)) + if view blockHash primedParent == view blockHash (_parentHeader (_cutExtensionParent extension)) then do let payload = newBlockToPayloadWithOutputs newBlock let !phash = _payloadWithOutputsPayloadHash payload @@ -252,10 +252,10 @@ newWork logFun choice eminer@(Miner mid _) hdb pact tpw c = do let !extensionParent = _parentHeader (_cutExtensionParent extension) logFun @T.Text Info $ "newWork: chain " <> toText cid <> " not mineable because of parent header mismatch" - <> ". Primed parent hash: " <> toText (_blockHash primedParent) - <> ". Primed parent height: " <> sshow (_blockHeight primedParent) - <> ". Extension parent: " <> toText (_blockHash extensionParent) - <> ". Extension height: " <> sshow (_blockHeight extensionParent) + <> ". Primed parent hash: " <> toText (view blockHash primedParent) + <> ". Primed parent height: " <> sshow (view blockHeight primedParent) + <> ". Extension parent: " <> toText (view blockHash extensionParent) + <> ". Extension height: " <> sshow (view blockHeight extensionParent) return Nothing @@ -284,7 +284,7 @@ publish lf cdb pwVar miner pwo s = do -- reset the primed payload for this cut extension atomically $ modifyTVar pwVar $ \(PrimedWork pw) -> - PrimedWork $! HM.adjust (HM.insert (_chainId bh) (WorkAlreadyMined (_blockParent bh))) miner pw + PrimedWork $! HM.adjust (HM.insert (_chainId bh) (WorkAlreadyMined (view blockParent bh))) miner pw addCutHashes cdb ch @@ -442,7 +442,7 @@ solve mr solved@(SolvedWork hdr) = do -- doesn't get deleted. Items get GCed on a regular basis by -- the coordinator. where - key = _blockPayloadHash hdr + key = view blockPayloadHash hdr tms = _coordState mr lf :: LogFunction diff --git a/src/Chainweb/Pact/Backend/ChainwebPactDb.hs b/src/Chainweb/Pact/Backend/ChainwebPactDb.hs index 4d958e1747..9ed2b9ee5b 100644 --- a/src/Chainweb/Pact/Backend/ChainwebPactDb.hs +++ b/src/Chainweb/Pact/Backend/ChainwebPactDb.hs @@ -663,7 +663,7 @@ rewindDbTo db mh@(Just (ParentHeader ph)) = do <> sshow ph Historical endingTxId -> return endingTxId - rewindDbToBlock db (_blockHeight ph) endingTxId + rewindDbToBlock db (view blockHeight ph) endingTxId return endingTxId -- rewind before genesis, delete all user tables and all rows in all tables @@ -875,7 +875,7 @@ initSchema logger sql = getEndTxId :: Text -> SQLiteEnv -> Maybe ParentHeader -> IO (Historical TxId) getEndTxId msg sql pc = case pc of Nothing -> return (Historical 0) - Just (ParentHeader ph) -> getEndTxId' msg sql (_blockHeight ph) (_blockHash ph) + Just (ParentHeader ph) -> getEndTxId' msg sql (view blockHeight ph) (view blockHash ph) getEndTxId' :: Text -> SQLiteEnv -> BlockHeight -> BlockHash -> IO (Historical TxId) getEndTxId' msg sql bh bhsh = do diff --git a/src/Chainweb/Pact/Backend/PactState/GrandHash/Import.hs b/src/Chainweb/Pact/Backend/PactState/GrandHash/Import.hs index 3bf90f33d5..6a4d814aba 100644 --- a/src/Chainweb/Pact/Backend/PactState/GrandHash/Import.hs +++ b/src/Chainweb/Pact/Backend/PactState/GrandHash/Import.hs @@ -52,7 +52,7 @@ module Chainweb.Pact.Backend.PactState.GrandHash.Import ) where -import Chainweb.BlockHeader (BlockHeader(..), ParentHeader(..)) +import Chainweb.BlockHeader (ParentHeader(..), blockHash) import Chainweb.BlockHeight (BlockHeight(..)) import Chainweb.ChainId (ChainId, chainIdToText) import Chainweb.Logger (Logger, logFunctionText) @@ -68,7 +68,7 @@ import Chainweb.Storage.Table.RocksDB (RocksDb, withReadOnlyRocksDb, modernDefau import Chainweb.Utils (sshow) import Chainweb.Version (ChainwebVersion(..)) import Control.Applicative (optional) -import Control.Lens ((^?!), ix) +import Control.Lens ((^?!), ix, view) import Control.Monad (forM_, when) import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HM @@ -133,8 +133,8 @@ pactVerify logger v pactConns rocksDb grands = do logFunctionText logger' Error $ Text.unlines [ "Chain " <> chainIdToText cid , "Block Header mismatch" - , " Expected: " <> sshow (_blockHash eHeader) - , " Actual: " <> sshow (_blockHash header) + , " Expected: " <> sshow (view blockHash eHeader) + , " Actual: " <> sshow (view blockHash header) ] when (hash /= eHash) $ do diff --git a/src/Chainweb/Pact/Backend/PactState/GrandHash/Utils.hs b/src/Chainweb/Pact/Backend/PactState/GrandHash/Utils.hs index 532fc98482..33352bf162 100644 --- a/src/Chainweb/Pact/Backend/PactState/GrandHash/Utils.hs +++ b/src/Chainweb/Pact/Backend/PactState/GrandHash/Utils.hs @@ -25,7 +25,7 @@ module Chainweb.Pact.Backend.PactState.GrandHash.Utils ) where -import Chainweb.BlockHeader (BlockHeader(..)) +import Chainweb.BlockHeader (BlockHeader, blockHeight) import Chainweb.BlockHeight (BlockHeight(..)) import Chainweb.ChainId (ChainId, chainIdToText) import Chainweb.CutDB (cutHashesTable, readHighestCutHeaders) @@ -43,7 +43,7 @@ import Chainweb.Version.Mainnet (mainnet) import Chainweb.Version.Registry (lookupVersionByName) import Chainweb.WebBlockHeaderDB (WebBlockHeaderDb, getWebBlockHeaderDb, initWebBlockHeaderDb) import Control.Exception (bracket) -import Control.Lens ((^?!), ix) +import Control.Lens ((^?!), ix, view) import Control.Monad (forM, when) import Data.ByteString (ByteString) import Data.ByteString.Base16 qualified as Base16 @@ -72,28 +72,28 @@ limitCut :: (Logger logger) -> HashMap ChainId SQLiteEnv -> BlockHeight -> IO (HashMap ChainId BlockHeader) -limitCut logger wbhdb latestCutHeaders pactConns blockHeight = do +limitCut logger wbhdb latestCutHeaders pactConns bHeight = do fmap (HM.mapMaybe id) $ flip HM.traverseWithKey latestCutHeaders $ \cid latestCutHeader -> do let logger' = addChainIdLabel cid logger bdb <- getWebBlockHeaderDb wbhdb cid - seekAncestor bdb latestCutHeader (fromIntegral blockHeight) >>= \case + seekAncestor bdb latestCutHeader (fromIntegral bHeight) >>= \case -- Block exists on that chain Just h -> do -- Sanity check, should absolutely never happen - when (_blockHeight h /= blockHeight) $ do + when (view blockHeight h /= bHeight) $ do exitLog logger' "expected seekAncestor behaviour is broken" -- Confirm that PactDB is not behind RocksDB (it can be ahead though) let db = pactConns ^?! ix cid latestPactHeight <- getLatestBlockHeight db - when (latestPactHeight < blockHeight) $ do + when (latestPactHeight < bHeight) $ do exitLog logger' "Pact State is behind RocksDB. This should never happen." pure (Just h) -- Block does not exist on that chain Nothing -> do - logFunctionText logger' Debug $ "Block " <> sshow blockHeight <> " is not accessible on this chain." + logFunctionText logger' Debug $ "Block " <> sshow bHeight <> " is not accessible on this chain." pure Nothing -- | Get the latest cut headers. @@ -122,7 +122,7 @@ resolveLatestCutHeaders :: (Logger logger) -> IO (BlockHeight, HashMap ChainId BlockHeader) resolveLatestCutHeaders logger v pactConns rocksDb = do (wbhdb, latestCutHeaders) <- getLatestCutHeaders v rocksDb - let latestCommonBlockHeight = minimum $ fmap _blockHeight latestCutHeaders + let latestCommonBlockHeight = minimum $ fmap (view blockHeight) latestCutHeaders headers <- limitCut logger wbhdb latestCutHeaders pactConns latestCommonBlockHeight pure (latestCommonBlockHeight, headers) @@ -168,7 +168,7 @@ computeGrandHashesAt :: () computeGrandHashesAt pactConns cutHeader = do fmap HM.fromList $ pooledForConcurrently (HM.toList cutHeader) $ \(cid, bHeader) -> do let db = pactConns ^?! ix cid - (hash, ()) <- computeGrandHash (getLatestPactStateAt db (_blockHeight bHeader)) + (hash, ()) <- computeGrandHash (getLatestPactStateAt db (view blockHeight bHeader)) pure (cid, Snapshot hash bHeader) checkPactDbsExist :: FilePath -> [ChainId] -> IO () diff --git a/src/Chainweb/Pact/Backend/RelationalCheckpointer.hs b/src/Chainweb/Pact/Backend/RelationalCheckpointer.hs index e7ffea5467..3775475c4a 100644 --- a/src/Chainweb/Pact/Backend/RelationalCheckpointer.hs +++ b/src/Chainweb/Pact/Backend/RelationalCheckpointer.hs @@ -25,6 +25,7 @@ module Chainweb.Pact.Backend.RelationalCheckpointer import Control.Concurrent (threadDelay) import Control.Concurrent.Async import Control.Concurrent.MVar +import Control.Lens (view) import Control.Monad import Control.Monad.Catch import Control.Monad.IO.Class @@ -151,7 +152,7 @@ doReadFrom doReadFrom logger v cid sql moduleCacheVar maybeParent doRead = do let currentHeight = case maybeParent of Nothing -> genesisHeight v cid - Just parent -> succ . _blockHeight . _parentHeader $ parent + Just parent -> succ . view blockHeight . _parentHeader $ parent modifyMVar moduleCacheVar $ \sharedModuleCache -> do bracket @@ -170,7 +171,7 @@ doReadFrom logger v cid sql moduleCacheVar maybeParent doRead = do parentIsLatestHeader = case (latestHeader, maybeParent) of (Nothing, Nothing) -> True (Just (_, latestHash), Just (ParentHeader ph)) -> - _blockHash ph == latestHash + view blockHash ph == latestHash _ -> False let @@ -228,7 +229,7 @@ doRestoreAndSave logger v cid sql p moduleCacheVar rewindParent blocks = let !bh = case maybeParent of Nothing -> genesisHeight v cid - Just parent -> (succ . _blockHeight . _parentHeader) parent + Just parent -> (succ . view blockHeight . _parentHeader) parent -- prepare the block state let handlerEnv = mkBlockHandlerEnv v cid bh sql p logger let state = (initBlockState defaultModuleCacheLimit txid) { _bsModuleCache = moduleCache } @@ -255,15 +256,15 @@ doRestoreAndSave logger v cid sql p moduleCacheVar rewindParent blocks = -- of the previous block case maybeParent of Nothing - | genesisHeight v cid /= _blockHeight newBh -> internalError + | genesisHeight v cid /= view blockHeight newBh -> internalError "doRestoreAndSave: block with no parent, genesis block, should have genesis height but doesn't," Just (ParentHeader ph) - | succ (_blockHeight ph) /= _blockHeight newBh -> internalError $ + | succ (view blockHeight ph) /= view blockHeight newBh -> internalError $ "doRestoreAndSave: non-genesis block should be one higher than its parent. parent at " - <> sshow (_blockHeight ph) <> ", child height " <> sshow (_blockHeight newBh) + <> sshow (view blockHeight ph) <> ", child height " <> sshow (view blockHeight newBh) _ -> return () -- persist any changes to the database - commitBlockStateToDatabase sql (_blockHash newBh) (_blockHeight newBh) nextState + commitBlockStateToDatabase sql (view blockHash newBh) (view blockHeight newBh) nextState return (m'', Just (ParentHeader newBh), nextTxId, nextModuleCache) ) (return (mempty, rewindParent, startTxId, startModuleCache)) @@ -373,7 +374,7 @@ doGetBlockHistory db blockHeader d = do startTxId <- if bHeight == genesisHeight v cid then return 0 - else getEndTxId' "doGetBlockHistory" db (pred bHeight) (_blockParent blockHeader) >>= \case + else getEndTxId' "doGetBlockHistory" db (pred bHeight) (view blockParent blockHeader) >>= \case NoHistory -> internalError $ "doGetBlockHistory: missing parent for: " <> sshow blockHeader Historical startTxId -> @@ -386,8 +387,8 @@ doGetBlockHistory db blockHeader d = do return $ BlockTxHistory tmap prev where v = _chainwebVersion blockHeader - cid = _blockChainId blockHeader - bHeight = _blockHeight blockHeader + cid = view blockChainId blockHeader + bHeight = view blockHeight blockHeader procTxHist :: (S.Set Utf8, M.Map TxId [TxLog RowData]) diff --git a/src/Chainweb/Pact/PactService.hs b/src/Chainweb/Pact/PactService.hs index 4db1638cea..2ea2d39d54 100644 --- a/src/Chainweb/Pact/PactService.hs +++ b/src/Chainweb/Pact/PactService.hs @@ -256,7 +256,7 @@ initializeCoinContract memPoolAccess v cid pwo = do -- We check the block hash because it's more principled and -- we don't have to compute it, so the comparison is still relatively -- cheap. We could also check the height but that would be redundant. - if _blockHash (_parentHeader currentBlockHeader) /= _blockHash genesisHeader + if view blockHash (_parentHeader currentBlockHeader) /= view blockHash genesisHeader then do !mc <- readFrom (Just currentBlockHeader) readInitModules >>= \case NoHistory -> throwM $ BlockHeaderLookupFailure @@ -469,8 +469,8 @@ execNewBlock execNewBlock mpAccess miner fill newBlockParent = pactLabel "execNewBlock" $ do readFrom (Just newBlockParent) $ do blockDbEnv <- view psBlockDbEnv - let pHeight = _blockHeight $ _parentHeader newBlockParent - let pHash = _blockHash $ _parentHeader newBlockParent + let pHeight = view blockHeight $ _parentHeader newBlockParent + let pHash = view blockHash $ _parentHeader newBlockParent liftPactServiceM $ logInfo $ "(parent height = " <> sshow pHeight <> ")" <> " (parent hash = " <> sshow pHash <> ")" @@ -597,7 +597,7 @@ continueBlock mpAccess blockInProgress = do newBlockParent = _blockInProgressParentHeader blockInProgress !parentTime = - ParentCreationTime (_blockCreationTime $ _parentHeader newBlockParent) + ParentCreationTime (view blockCreationTime $ _parentHeader newBlockParent) getBlockTxs :: BlockFill -> PactBlockM logger tbl (Vector ChainwebTransaction) getBlockTxs bfState = do @@ -723,8 +723,8 @@ continueBlock mpAccess blockInProgress = do throwM $ MempoolFillFailure $ "Duplicate transaction: " <> sshow rk | otherwise = return $ S.insert rk rks - pHeight = _blockHeight $ _parentHeader newBlockParent - pHash = _blockHash $ _parentHeader newBlockParent + pHeight = view blockHeight $ _parentHeader newBlockParent + pHash = view blockHash $ _parentHeader newBlockParent updateMempool = liftIO $ do mpaProcessFork mpAccess $ _parentHeader newBlockParent @@ -767,30 +767,30 @@ execReadOnlyReplay lowerBound maybeUpperBound = pactLabel "execReadOnlyReplay" $ -- lower bound must be an ancestor of upper. upperBound <- case maybeUpperBound of Just upperBound -> do - liftIO (ancestorOf bhdb (_blockHash lowerBound) (_blockHash upperBound)) >>= + liftIO (ancestorOf bhdb (view blockHash lowerBound) (view blockHash upperBound)) >>= flip unless (internalError "lower bound is not an ancestor of upper bound") -- upper bound must be an ancestor of latest header. - liftIO (ancestorOf bhdb (_blockHash upperBound) (_blockHash cur)) >>= + liftIO (ancestorOf bhdb (view blockHash upperBound) (view blockHash cur)) >>= flip unless (internalError "upper bound is not an ancestor of latest header") return upperBound Nothing -> do - liftIO (ancestorOf bhdb (_blockHash lowerBound) (_blockHash cur)) >>= + liftIO (ancestorOf bhdb (view blockHash lowerBound) (view blockHash cur)) >>= flip unless (internalError "lower bound is not an ancestor of latest header") return cur liftIO $ logFunctionText logger Info $ "pact db replaying between blocks " - <> sshow (_blockHeight lowerBound, _blockHash lowerBound) <> " and " - <> sshow (_blockHeight upperBound, _blockHash upperBound) + <> sshow (view blockHeight lowerBound, view blockHash lowerBound) <> " and " + <> sshow (view blockHeight upperBound, view blockHash upperBound) let genHeight = genesisHeight v cid -- we don't want to replay the genesis header in here. - let lowerHeight = max (succ genHeight) (_blockHeight lowerBound) + let lowerHeight = max (succ genHeight) (view blockHeight lowerBound) withPactState $ \runPact -> liftIO $ getBranchIncreasing bhdb upperBound (int lowerHeight) $ \blocks -> do heightRef <- newIORef lowerHeight - withAsync (heightProgress lowerHeight (_blockHeight upperBound) heightRef (logInfo_ logger)) $ \_ -> do + withAsync (heightProgress lowerHeight (view blockHeight upperBound) heightRef (logInfo_ logger)) $ \_ -> do blocks & Stream.hoist liftIO & play bhdb pdb heightRef runPact @@ -821,11 +821,11 @@ execReadOnlyReplay lowerBound maybeUpperBound = pactLabel "execReadOnlyReplay" $ $ (handleMissingBlock =<<) $ runPact $ readFrom (Just $ ParentHeader bhParent) $ do - liftIO $ writeIORef heightRef (_blockHeight bh) + liftIO $ writeIORef heightRef (view blockHeight bh) payload <- liftIO $ fromJuste <$> - lookupPayloadDataWithHeight pdb (Just $ _blockHeight bh) (_blockPayloadHash bh) + lookupPayloadDataWithHeight pdb (Just $ view blockHeight bh) (view blockPayloadHash bh) let isPayloadEmpty = V.null (_payloadDataTransactions payload) - let isUpgradeBlock = isJust $ _chainwebVersion bhdb ^? versionUpgrades . onChain (_chainId bhdb) . ix (_blockHeight bh) + let isUpgradeBlock = isJust $ _chainwebVersion bhdb ^? versionUpgrades . onChain (_chainId bhdb) . ix (view blockHeight bh) unless (isPayloadEmpty && not isUpgradeBlock) $ void $ execBlock bh (CheckablePayload payload) ) @@ -952,18 +952,18 @@ execSyncToBlock targetHeader = pactLabel "execSyncToBlock" $ do if latestHeader == targetHeader then do logInfo $ "checkpointer at checkpointer target" - <> ". target height: " <> sshow (_blockHeight latestHeader) - <> "; target hash: " <> blockHashToText (_blockHash latestHeader) + <> ". target height: " <> sshow (view blockHeight latestHeader) + <> "; target hash: " <> blockHashToText (view blockHash latestHeader) else do logInfo $ "rewind to checkpointer target" - <> ". current height: " <> sshow (_blockHeight latestHeader) - <> "; current hash: " <> blockHashToText (_blockHash latestHeader) + <> ". current height: " <> sshow (view blockHeight latestHeader) + <> "; current hash: " <> blockHashToText (view blockHash latestHeader) <> "; target height: " <> sshow targetHeight <> "; target hash: " <> blockHashToText targetHash rewindToIncremental Nothing (ParentHeader targetHeader) where - targetHeight = _blockHeight targetHeader - targetHash = _blockHash targetHeader + targetHeight = view blockHeight targetHeader + targetHash = view blockHash targetHeader failNonGenesisOnEmptyDb = error "impossible: playing non-genesis block to empty DB" -- | Validate a mined block `(headerToValidate, payloadToValidate). @@ -993,7 +993,7 @@ execValidateBlock memPoolAccess headerToValidate payloadToValidate = pactLabel " -- Add block-hash to the logs if presented let logBlockHash = - localLabel ("block-hash", blockHashToText (_blockParent headerToValidate)) + localLabel ("block-hash", blockHashToText (view blockParent headerToValidate)) logBlockHash $ do currHeader <- findLatestValidBlockHeader' @@ -1006,8 +1006,8 @@ execValidateBlock memPoolAccess headerToValidate payloadToValidate = pactLabel " -- check that we don't exceed the rewind limit. for the purpose -- of this check, the genesis block and the genesis parent -- have the same height. - let !currHeight = maybe (genesisHeight v cid) _blockHeight currHeader - let !ancestorHeight = maybe (genesisHeight v cid) _blockHeight commonAncestor + let !currHeight = maybe (genesisHeight v cid) (view blockHeight) currHeader + let !ancestorHeight = maybe (genesisHeight v cid) (view blockHeight) commonAncestor let !rewindLimitSatisfied = ancestorHeight + fromIntegral reorgLimit >= currHeight unless rewindLimitSatisfied $ throwM $ RewindLimitExceeded @@ -1021,7 +1021,7 @@ execValidateBlock memPoolAccess headerToValidate payloadToValidate = pactLabel " -- we're validating a genesis block, so there are no fork blocks to speak of. kont (pure ()) Just (ParentHeader parentHeaderOfHeaderToValidate) -> - let forkStartHeight = maybe (genesisHeight v cid) (succ . _blockHeight) commonAncestor + let forkStartHeight = maybe (genesisHeight v cid) (succ . view blockHeight) commonAncestor in getBranchIncreasing bhdb parentHeaderOfHeaderToValidate (fromIntegral forkStartHeight) kont ((), results) <- @@ -1031,10 +1031,10 @@ execValidateBlock memPoolAccess headerToValidate payloadToValidate = pactLabel " -- given a header for a block in the fork, fetch its payload -- and run its transactions, validating its hashes let runForkBlockHeaders = Stream.map (\forkBh -> do - payload <- liftIO $ lookupPayloadWithHeight payloadDb (Just $ _blockHeight forkBh) (_blockPayloadHash forkBh) >>= \case + payload <- liftIO $ lookupPayloadWithHeight payloadDb (Just $ view blockHeight forkBh) (view blockPayloadHash forkBh) >>= \case Nothing -> internalError $ "execValidateBlock: lookup of payload failed" - <> ". BlockPayloadHash: " <> encodeToText (_blockPayloadHash forkBh) + <> ". BlockPayloadHash: " <> encodeToText (view blockPayloadHash forkBh) <> ". Block: " <> encodeToText (ObjectEncoded forkBh) Just x -> return $ payloadWithOutputsToPayloadData x void $ execBlock forkBh (CheckablePayload payload) @@ -1087,7 +1087,7 @@ execValidateBlock memPoolAccess headerToValidate payloadToValidate = pactLabel " getTarget | isGenesisBlockHeader headerToValidate = return Nothing | otherwise = Just . ParentHeader - <$> lookupBlockHeader (_blockParent headerToValidate) "execValidateBlock" + <$> lookupBlockHeader (view blockParent headerToValidate) "execValidateBlock" -- It is up to the user of pact service to guaranteed that this -- succeeds. If this fails it usually means that the block -- header database is corrupted. @@ -1127,8 +1127,8 @@ execPreInsertCheckReq txs = pactLabel "execPreInsertCheckReq" $ do pdb <- view psBlockDbEnv pc <- view psParentHeader let - parentTime = ParentCreationTime (_blockCreationTime $ _parentHeader pc) - currHeight = succ $ _blockHeight $ _parentHeader pc + parentTime = ParentCreationTime (view blockCreationTime $ _parentHeader pc) + currHeight = succ $ view blockHeight $ _parentHeader pc v = _chainwebVersion pc cid = _chainId pc liftIO $ validateChainwebTxs logger v cid pdb parentTime currHeight txs diff --git a/src/Chainweb/Pact/PactService/Checkpointer.hs b/src/Chainweb/Pact/PactService/Checkpointer.hs index c3f322debd..2173798cea 100644 --- a/src/Chainweb/Pact/PactService/Checkpointer.hs +++ b/src/Chainweb/Pact/PactService/Checkpointer.hs @@ -117,7 +117,7 @@ readFromNthParent n doRead = go 0 let parentHeight = -- guarantees that the subtraction doesn't overflow -- this will never give us before genesis - fromIntegral $ max (genesisHeight v cid + fromIntegral n) (_blockHeight latest) - fromIntegral n + fromIntegral $ max (genesisHeight v cid + fromIntegral n) (view blockHeight latest) - fromIntegral n nthParent <- liftIO $ seekAncestor bhdb latest parentHeight >>= \case Nothing -> internalError @@ -243,7 +243,7 @@ rewindToIncremental rewindLimit (ParentHeader parent) = do playFork latestHeader where - parentHeight = _blockHeight parent + parentHeight = view blockHeight parent failOnTooLowRequestedHeight lastHeader = case rewindLimit of @@ -253,7 +253,7 @@ rewindToIncremental rewindLimit (ParentHeader parent) = do throwM $ RewindLimitExceeded limit (Just lastHeader) (Just parent) _ -> return () where - lastHeight = _blockHeight lastHeader + lastHeight = view blockHeight lastHeader failNonGenesisOnEmptyDb = error "impossible: playing non-genesis block to empty DB" @@ -263,7 +263,7 @@ rewindToIncremental rewindLimit (ParentHeader parent) = do commonAncestor <- liftIO $ forkEntry bhdb lastHeader parent cp <- view psCheckpointer payloadDb <- view psPdb - let ancestorHeight = _blockHeight commonAncestor + let ancestorHeight = view blockHeight commonAncestor logger <- view psLogger @@ -285,13 +285,13 @@ rewindToIncremental rewindLimit (ParentHeader parent) = do $ blockChunk & S.map (\blockHeader -> do - payload <- liftIO $ lookupPayloadWithHeight payloadDb (Just $ _blockHeight blockHeader) (_blockPayloadHash blockHeader) >>= \case + payload <- liftIO $ lookupPayloadWithHeight payloadDb (Just $ view blockHeight blockHeader) (view blockPayloadHash blockHeader) >>= \case Nothing -> internalError $ "Checkpointer.rewindTo.fastForward: lookup of payload failed" - <> ". BlockPayloadHash: " <> encodeToText (_blockPayloadHash blockHeader) + <> ". BlockPayloadHash: " <> encodeToText (view blockPayloadHash blockHeader) <> ". Block: "<> encodeToText (ObjectEncoded blockHeader) Just x -> return $ payloadWithOutputsToPayloadData x - liftIO $ writeIORef heightRef (_blockHeight blockHeader) + liftIO $ writeIORef heightRef (view blockHeight blockHeader) void $ execBlock blockHeader (CheckablePayload payload) return (Last (Just blockHeader), blockHeader) -- double check output hash here? @@ -307,8 +307,8 @@ rewindToIncremental rewindLimit (ParentHeader parent) = do _cpRewindTo cp (Just $ ParentHeader curHdr) - heightRef <- newIORef (_blockHeight curHdr) - withAsync (heightProgress (_blockHeight curHdr) heightRef (logInfo_ logger)) $ \_ -> + heightRef <- newIORef (view blockHeight curHdr) + withAsync (heightProgress (view blockHeight curHdr) heightRef (logInfo_ logger)) $ \_ -> remaining & S.copy & S.length_ diff --git a/src/Chainweb/Pact/PactService/ExecBlock.hs b/src/Chainweb/Pact/PactService/ExecBlock.hs index 6ce53da607..dc967ae431 100644 --- a/src/Chainweb/Pact/PactService/ExecBlock.hs +++ b/src/Chainweb/Pact/PactService/ExecBlock.hs @@ -110,7 +110,7 @@ execBlock currHeader payload = do dbEnv <- view psBlockDbEnv miner <- decodeStrictOrThrow' (_minerData $ _payloadDataMiner plData) trans <- liftIO $ transactionsFromPayload - (pactParserVersion v (_blockChainId currHeader) (_blockHeight currHeader)) + (pactParserVersion v (view blockChainId currHeader) (view blockHeight currHeader)) plData logger <- view (psServiceEnv . psLogger) @@ -120,13 +120,13 @@ execBlock currHeader payload = do -- The new default behavior is to use the creation time of the /parent/ header. -- txValidationTime <- if isGenesisBlockHeader currHeader - then return (ParentCreationTime $ _blockCreationTime currHeader) - else ParentCreationTime . _blockCreationTime . _parentHeader <$> view psParentHeader + then return (ParentCreationTime $ view blockCreationTime currHeader) + else ParentCreationTime . view blockCreationTime . _parentHeader <$> view psParentHeader -- prop_tx_ttl_validate valids <- liftIO $ V.zip trans <$> validateChainwebTxs logger v cid dbEnv txValidationTime - (_blockHeight currHeader) trans skipDebitGas + (view blockHeight currHeader) trans skipDebitGas case foldr handleValids [] valids of [] -> return () @@ -143,7 +143,7 @@ execBlock currHeader payload = do return (totalGasUsed, pwo) where blockGasLimit = - fromIntegral <$> maxBlockGasLimit v (_blockHeight currHeader) + fromIntegral <$> maxBlockGasLimit v (view blockHeight currHeader) logInitCache = liftPactServiceM $ do mc <- fmap (fmap instr . _getModuleCache) <$> use psInitCache @@ -320,7 +320,7 @@ execTransactionsOnly miner ctxs mc txTimeLimit = do initModuleCacheForBlock :: (Logger logger) => Bool -> PactBlockM logger tbl ModuleCache initModuleCacheForBlock isGenesis = do PactServiceState{..} <- get - pbh <- views psParentHeader (_blockHeight . _parentHeader) + pbh <- views psParentHeader (view blockHeight . _parentHeader) case Map.lookupLE pbh _psInitCache of Nothing -> if isGenesis then return mempty @@ -573,7 +573,7 @@ validateHashes bHeader payload miner transactions = pwo = toPayloadWithOutputs miner transactions newHash = _payloadWithOutputsPayloadHash pwo - prevHash = _blockPayloadHash bHeader + prevHash = view blockPayloadHash bHeader -- The following JSON encodings are used in the BlockValidationFailure message diff --git a/src/Chainweb/Pact/RestAPI/Server.hs b/src/Chainweb/Pact/RestAPI/Server.hs index f690dec32b..f6dfd0bcfa 100644 --- a/src/Chainweb/Pact/RestAPI/Server.hs +++ b/src/Chainweb/Pact/RestAPI/Server.hs @@ -64,7 +64,7 @@ import Data.Vector (Vector) import qualified Data.Vector as V import Ethereum.Block -import Ethereum.Header +import Ethereum.Header hiding (blockHash) import Ethereum.Misc (bytes) import Ethereum.Receipt import Ethereum.Receipt.ReceiptProof @@ -354,7 +354,7 @@ listenHandler logger cdb cid pact mem (ListenerRequest key) = do then do pure Nothing else do - Just <$!> CutDB.awaitNewBlockStm cdb cid (_blockHash lastBlockHeader) + Just <$!> CutDB.awaitNewBlockStm cdb cid (view blockHash lastBlockHeader) -- TODO: make configurable defaultTimeout = 180 * 1000000 -- two minutes @@ -634,8 +634,8 @@ internalPoll pdb bhdb mempool pactEx confDepth requestKeys0 = do let pactHash = Pact.fromUntypedHash keyHash let matchingHash = (== pactHash) . _cmdHash . fst blockHeader <- liftIO $ TreeDB.lookupM bhdb bHash - let payloadHash = _blockPayloadHash blockHeader - (_payloadWithOutputsTransactions -> txsBs) <- barf "tablelookupFailed" =<< liftIO (lookupPayloadWithHeight pdb (Just $ _blockHeight blockHeader) payloadHash) + let payloadHash = view blockPayloadHash blockHeader + (_payloadWithOutputsTransactions -> txsBs) <- barf "tablelookupFailed" =<< liftIO (lookupPayloadWithHeight pdb (Just $ view blockHeight blockHeader) payloadHash) !txs <- mapM fromTx txsBs case find matchingHash txs of Just (_cmd, TransactionOutput output) -> do @@ -669,10 +669,10 @@ internalPoll pdb bhdb mempool pactEx confDepth requestKeys0 = do enrichCR :: BlockHeader -> CommandResult Hash -> ExceptT String IO (CommandResult Hash) enrichCR bh = return . set crMetaData (Just $ object - [ "blockHeight" .= _blockHeight bh - , "blockTime" .= _blockCreationTime bh - , "blockHash" .= _blockHash bh - , "prevBlockHash" .= _blockParent bh + [ "blockHeight" .= view blockHeight bh + , "blockTime" .= view blockCreationTime bh + , "blockHash" .= view blockHash bh + , "prevBlockHash" .= view blockParent bh ]) -- -------------------------------------------------------------------------- -- diff --git a/src/Chainweb/Pact/SPV.hs b/src/Chainweb/Pact/SPV.hs index cda8f24f55..308ac6c7a4 100644 --- a/src/Chainweb/Pact/SPV.hs +++ b/src/Chainweb/Pact/SPV.hs @@ -50,7 +50,7 @@ import Text.Read (readMaybe) import Crypto.Hash.Algorithms -import Ethereum.Header as EthHeader +import qualified Ethereum.Header as EthHeader import Ethereum.Misc import Ethereum.Receipt import Ethereum.Receipt.ReceiptProof @@ -87,7 +87,7 @@ import Pact.Types.SPV catchAndDisplaySPVError :: BlockHeader -> ExceptT Text IO a -> ExceptT Text IO a catchAndDisplaySPVError bh = - if CW.chainweb219Pact (CW._chainwebVersion bh) (_blockChainId bh) (_blockHeight bh) + if CW.chainweb219Pact (CW._chainwebVersion bh) (view blockChainId bh) (view blockHeight bh) then flip catch $ \case SpvExceptionVerificationFailed m -> throwError ("spv verification failed: " <> m) spvErr -> throwM spvErr @@ -95,7 +95,7 @@ catchAndDisplaySPVError bh = forkedThrower :: BlockHeader -> Text -> ExceptT Text IO a forkedThrower bh = - if CW.chainweb219Pact (CW._chainwebVersion bh) (_blockChainId bh) (_blockHeight bh) + if CW.chainweb219Pact (CW._chainwebVersion bh) (view blockChainId bh) (view blockHeight bh) then throwError else internalError @@ -127,7 +127,7 @@ verifySPV verifySPV bdb bh typ proof = runExceptT $ go typ proof where cid = CW._chainId bdb - enableBridge = CW.enableSPVBridge (CW._chainwebVersion bh) cid (_blockHeight bh) + enableBridge = CW.enableSPVBridge (CW._chainwebVersion bh) cid (view blockHeight bh) mkSPVResult' cr j | enableBridge = @@ -159,7 +159,7 @@ verifySPV bdb bh typ proof = runExceptT $ go typ proof -- 3. Extract tx outputs as a pact object and return the -- object. - TransactionOutput p <- catchAndDisplaySPVError bh $ liftIO $ verifyTransactionOutputProofAt_ bdb u (_blockHash bh) + TransactionOutput p <- catchAndDisplaySPVError bh $ liftIO $ verifyTransactionOutputProofAt_ bdb u (view blockHash bh) q <- case decodeStrict' p :: Maybe (CommandResult Hash) of Nothing -> forkedThrower bh "unable to decode spv transaction output" @@ -261,8 +261,8 @@ verifyCont bdb bh (ContProof cp) = runExceptT $ do let errorMessageType = if CW.chainweb221Pact (CW._chainwebVersion bh) - (_blockChainId bh) - (_blockHeight bh) + (view blockChainId bh) + (view blockHeight bh) then Simplified else Legacy t <- decodeB64UrlNoPaddingTextWithFixedErrorMessage errorMessageType $ Text.decodeUtf8 cp @@ -282,7 +282,7 @@ verifyCont bdb bh (ContProof cp) = runExceptT $ do -- 3. Extract continuation 'PactExec' from decoded result -- and return the cont exec object - TransactionOutput p <- catchAndDisplaySPVError bh $ liftIO $ verifyTransactionOutputProofAt_ bdb u (_blockHash bh) + TransactionOutput p <- catchAndDisplaySPVError bh $ liftIO $ verifyTransactionOutputProofAt_ bdb u (view blockHash bh) q <- case decodeStrict' p :: Maybe (CommandResult Hash) of Nothing -> forkedThrower bh "unable to decode spv transaction output" @@ -350,7 +350,7 @@ ethResultToPactValue ReceiptProofValidation{..} = mkObject , ("topics",toTList TyAny def $ map topic _logEntryTopics) , ("data",jsonStr _logEntryData)] topic t = jsonStr t - header ch@ConsensusHeader{..} = obj + header ch@EthHeader.ConsensusHeader{..} = obj [ ("difficulty", jsonStr _hdrDifficulty) , ("extra-data", jsonStr _hdrExtraData) , ("gas-limit", tInt _hdrGasLimit) @@ -391,7 +391,7 @@ getTxIdx bdb pdb bh th = do -- get BlockPayloadHash m <- maxEntry bdb ph <- seekAncestor bdb m (int bh) >>= \case - Just x -> return $ Right $! _blockPayloadHash x + Just x -> return $ Right $! view blockPayloadHash x Nothing -> return $ Left "unable to find payload associated with transaction hash" case ph of diff --git a/src/Chainweb/Pact/TransactionExec.hs b/src/Chainweb/Pact/TransactionExec.hs index 3a23d81832..c7a0ad0783 100644 --- a/src/Chainweb/Pact/TransactionExec.hs +++ b/src/Chainweb/Pact/TransactionExec.hs @@ -352,7 +352,7 @@ applyGenesisCmd logger dbEnv spv txCtx cmd = , _txRequestKey = rk , _txGasLimit = 0 , _txExecutionConfig = ExecutionConfig - $ flagsFor (ctxVersion txCtx) (ctxChainId txCtx) (_blockHeight $ ctxBlockHeader txCtx) + $ flagsFor (ctxVersion txCtx) (ctxChainId txCtx) (view blockHeight $ ctxBlockHeader txCtx) -- TODO this is very ugly. Genesis blocks need to install keysets -- outside of namespaces so we need to disable Pact 4.4. It would be -- preferable to have a flag specifically for the namespaced keyset @@ -455,8 +455,8 @@ applyCoinbase v logger dbEnv (Miner mid mks@(MinerKeys mk)) reward@(ParsedDecima bh = ctxCurrentBlockHeight txCtx cid = Chainweb._chainId parent - chash = Pact.Hash $ SB.toShort $ encodeToByteString $ _blockHash $ _parentHeader parent - -- NOTE: it holds that @ _pdPrevBlockHash pd == encode _blockHash@ + chash = Pact.Hash $ SB.toShort $ encodeToByteString $ view blockHash $ _parentHeader parent + -- NOTE: it holds that @ _pdPrevBlockHash pd == encode view blockHash@ -- NOTE: chash includes the /quoted/ text of the parent header. go interp cexec = evalTransactionM tenv txst $! do @@ -579,7 +579,7 @@ readInitModules = do parent = _tcParentHeader txCtx v = ctxVersion txCtx cid = ctxChainId txCtx - h = _blockHeight (_parentHeader parent) + 1 + h = view blockHeight (_parentHeader parent) + 1 rk = RequestKey chash nid = Nothing chash = pactInitialHash diff --git a/src/Chainweb/Pact/Types.hs b/src/Chainweb/Pact/Types.hs index 445919cadd..5c33aeed4a 100644 --- a/src/Chainweb/Pact/Types.hs +++ b/src/Chainweb/Pact/Types.hs @@ -496,8 +496,8 @@ ctxToPublicData ctx@(TxContext _ pm) = PublicData where h = ctxBlockHeader ctx BlockHeight bh = ctxCurrentBlockHeight ctx - BlockCreationTime (Time (TimeSpan (Micros !bt))) = _blockCreationTime h - BlockHash hsh = _blockParent h + BlockCreationTime (Time (TimeSpan (Micros !bt))) = view blockCreationTime h + BlockHash hsh = view blockParent h -- | Convert context to datatype for Pact environment using the -- current blockheight, referencing the parent header (not grandparent!) @@ -512,10 +512,10 @@ ctxToPublicData' (TxContext ph pm) = PublicData } where bheader = _parentHeader ph - BlockHeight !bh = succ $ _blockHeight bheader + BlockHeight !bh = succ $ view blockHeight bheader BlockCreationTime (Time (TimeSpan (Micros !bt))) = - _blockCreationTime bheader - BlockHash h = _blockHash bheader + view blockCreationTime bheader + BlockHash h = view blockHash bheader -- | Retreive parent header as 'BlockHeader' ctxBlockHeader :: TxContext -> BlockHeader @@ -525,10 +525,10 @@ ctxBlockHeader = _parentHeader . _tcParentHeader -- This reflects Pact environment focus on current block height, -- which influenced legacy switch checks as well. ctxCurrentBlockHeight :: TxContext -> BlockHeight -ctxCurrentBlockHeight = succ . _blockHeight . ctxBlockHeader +ctxCurrentBlockHeight = succ . view blockHeight . ctxBlockHeader ctxChainId :: TxContext -> ChainId -ctxChainId = _blockChainId . ctxBlockHeader +ctxChainId = view blockChainId . ctxBlockHeader ctxVersion :: TxContext -> ChainwebVersion ctxVersion = _chainwebVersion . ctxBlockHeader @@ -596,7 +596,7 @@ liftPactServiceM (PactServiceM a) = PactBlockM (magnify psServiceEnv a) -- | Look up an init cache that is stored at or before the height of the current parent header. getInitCache :: PactBlockM logger tbl ModuleCache getInitCache = do - ph <- views psParentHeader (_blockHeight . _parentHeader) + ph <- views psParentHeader (view blockHeight . _parentHeader) get >>= \PactServiceState{..} -> case M.lookupLE ph _psInitCache of Just (_,mc) -> return mc @@ -609,7 +609,7 @@ updateInitCache :: ModuleCache -> ParentHeader -> PactServiceM logger tbl () updateInitCache mc ph = get >>= \PactServiceState{..} -> do let bf 0 = 0 bf h = succ h - let pbh = bf (_blockHeight $ _parentHeader ph) + let pbh = bf (view blockHeight $ _parentHeader ph) v <- view psVersion cid <- view chainId diff --git a/src/Chainweb/Pact/Validations.hs b/src/Chainweb/Pact/Validations.hs index 1fc507817b..dd9f859af5 100644 --- a/src/Chainweb/Pact/Validations.hs +++ b/src/Chainweb/Pact/Validations.hs @@ -48,7 +48,7 @@ import Data.Word (Word8) -- internal modules -import Chainweb.BlockHeader (ParentCreationTime(..), BlockHeader(..), ParentHeader(..)) +import Chainweb.BlockHeader (ParentCreationTime(..), ParentHeader(..), blockCreationTime) import Chainweb.BlockCreationTime (BlockCreationTime(..)) import Chainweb.Pact.Types import Chainweb.Pact.Utils (fromPactChainId) @@ -107,7 +107,7 @@ assertLocalMetadata cmd@(P.Command pay sigs hsh) txCtx sigVerify = do | otherwise = assertValidateSigs validSchemes webAuthnPrefixLegal hsh signers sigs pct = ParentCreationTime - . _blockCreationTime + . view blockCreationTime . _parentHeader . _tcParentHeader $ txCtx diff --git a/src/Chainweb/Rosetta/Internal.hs b/src/Chainweb/Rosetta/Internal.hs index b5f7b88732..48a7a88c5e 100644 --- a/src/Chainweb/Rosetta/Internal.hs +++ b/src/Chainweb/Rosetta/Internal.hs @@ -126,8 +126,8 @@ matchLogs typ bh logs coinbase txs | Just upg <- v ^? versionUpgrades . onChain cid . at bheight . _Just = matchRemediation upg | otherwise = matchRest where - bheight = _blockHeight bh - cid = _blockChainId bh + bheight = view blockHeight bh + cid = view blockChainId bh v = _chainwebVersion bh matchGenesis = hoistEither $ case typ of @@ -529,7 +529,7 @@ findBlockHeaderInCurrFork cutDb cid someHeight someHash = do (Just hi, Just hsh) -> do bh <- byHeight chainDb latestBlock hi bhashExpected <- blockHashFromText hsh ?? RosettaUnparsableBlockHash - if _blockHash bh == bhashExpected + if view blockHash bh == bhashExpected then pure bh else throwError RosettaMismatchBlockHashHeight (Nothing, Just hsh) -> do @@ -552,7 +552,7 @@ getBlockOutputs -> BlockHeader -> ExceptT RosettaFailure Handler (CoinbaseTx (CommandResult Hash), V.Vector (CommandResult Hash)) getBlockOutputs payloadDb bh = do - someOut <- liftIO $ lookupPayloadWithHeight payloadDb (Just $ _blockHeight bh) (_blockPayloadHash bh) + someOut <- liftIO $ lookupPayloadWithHeight payloadDb (Just $ view blockHeight bh) (view blockPayloadHash bh) outputs <- someOut ?? RosettaPayloadNotFound txsOut <- decodeTxsOut outputs ?? RosettaUnparsableTxOut coinbaseOut <- decodeCoinbaseOut outputs ?? RosettaUnparsableTxOut diff --git a/src/Chainweb/Rosetta/Utils.hs b/src/Chainweb/Rosetta/Utils.hs index ee45f60d0e..4be7eaca76 100644 --- a/src/Chainweb/Rosetta/Utils.hs +++ b/src/Chainweb/Rosetta/Utils.hs @@ -14,6 +14,7 @@ module Chainweb.Rosetta.Utils where import Control.Monad (when) import Control.Error.Util +import Control.Lens (view) import Data.Aeson import Data.Aeson.Types (Pair) import qualified Data.Aeson.KeyMap as KM @@ -847,18 +848,18 @@ parentBlockId bh | bHeight == genesisHeight v cid = blockId bh -- genesis | otherwise = parent where - bHeight = _blockHeight bh - cid = _blockChainId bh - v = _chainwebVersion bh + bHeight = view blockHeight bh + cid = view blockChainId bh + v = view chainwebVersion bh parent = BlockId - { _blockId_index = getBlockHeight (pred $ _blockHeight bh) - , _blockId_hash = blockHashToText (_blockParent bh) + { _blockId_index = getBlockHeight (pred $ view blockHeight bh) + , _blockId_hash = blockHashToText (view blockParent bh) } blockId :: BlockHeader -> BlockId blockId bh = BlockId - { _blockId_index = getBlockHeight (_blockHeight bh) - , _blockId_hash = blockHashToText (_blockHash bh) + { _blockId_index = getBlockHeight (view blockHeight bh) + , _blockId_hash = blockHashToText (view blockHash bh) } cmdToTransactionId :: Command T.Text -> TransactionId @@ -1031,7 +1032,7 @@ rosettaTimestamp bh = BA.unLE . BA.toLE $ fromInteger msTime where msTime = int $ microTime `div` ms TimeSpan ms = millisecond - microTime = encodeTimeToWord64 $ _bct (_blockCreationTime bh) + microTime = encodeTimeToWord64 $ _bct (view blockCreationTime bh) -- | How to convert from atomic units to standard units in Rosetta Currency. diff --git a/src/Chainweb/SPV/CreateProof.hs b/src/Chainweb/SPV/CreateProof.hs index e28cbf3f63..538a54cf0d 100644 --- a/src/Chainweb/SPV/CreateProof.hs +++ b/src/Chainweb/SPV/CreateProof.hs @@ -358,16 +358,16 @@ createPayloadProof_ getPrefix headerDb payloadDb tcid scid txHeight txIx trgHead , _spvExceptionSourceChainId = scid , _spvExceptionSourceHeight = txHeight , _spvExceptionTargetChainId = tcid - , _spvExceptionTargetHeight = _blockHeight trgHeader + , _spvExceptionTargetHeight = view blockHeight trgHeader } - unless (_blockHeight srcHeadHeader >= txHeight) + unless (view blockHeight srcHeadHeader >= txHeight) $ throwM $ SpvExceptionTargetNotReachable { _spvExceptionMsg = "Target of SPV proof can't be reached from the source transaction" , _spvExceptionSourceChainId = scid , _spvExceptionSourceHeight = txHeight , _spvExceptionTargetChainId = tcid - , _spvExceptionTargetHeight = _blockHeight trgHeader + , _spvExceptionTargetHeight = view blockHeight trgHeader } -- chain == [srcHeader, srcHeadHeader] @@ -378,10 +378,10 @@ createPayloadProof_ getPrefix headerDb payloadDb tcid scid txHeight txIx trgHead , _spvExceptionSourceChainId = scid , _spvExceptionSourceHeight = txHeight , _spvExceptionTargetChainId = tcid - , _spvExceptionTargetHeight = _blockHeight trgHeader + , _spvExceptionTargetHeight = view blockHeight trgHeader } - Just pd <- lookupPayloadDataWithHeight payloadDb (Just $ _blockHeight txHeader) (_blockPayloadHash txHeader) + Just pd <- lookupPayloadDataWithHeight payloadDb (Just $ view blockHeight txHeader) (view blockPayloadHash txHeader) let payload = BlockPayload { _blockPayloadTransactionsHash = _payloadDataTransactionsHash pd , _blockPayloadOutputsHash = _payloadDataOutputsHash pd @@ -397,10 +397,10 @@ createPayloadProof_ getPrefix headerDb payloadDb tcid scid txHeight txIx trgHead -- 2. BlockHeader proof -- - unless (_blockPayloadHash txHeader == _blockPayloadPayloadHash payload) + unless (view blockPayloadHash txHeader == _blockPayloadPayloadHash payload) $ throwM $ SpvExceptionInconsistentPayloadData { _spvExceptionMsg = "The stored payload hash doesn't match the the db index" - , _spvExceptionMsgPayloadHash = _blockPayloadHash txHeader + , _spvExceptionMsgPayloadHash = view blockPayloadHash txHeader } -- this indicates that the payload store is inconsistent let blockHeaderTree = headerTree_ @BlockPayloadHash txHeader @@ -430,7 +430,7 @@ createPayloadProof_ getPrefix headerDb payloadDb tcid scid txHeight txIx trgHead -- | Walk down a chain along the parent relation and create a path of bread -- crumbs from the target header to the source height -- --- Returns 'Nothing' if @i >= _blockHeight h@. +-- Returns 'Nothing' if @i >= view blockHeight h@. -- crumbsOnChain :: WebBlockHeaderDb @@ -438,11 +438,11 @@ crumbsOnChain -> BlockHeight -> IO (Maybe (N.NonEmpty BlockHeader)) crumbsOnChain db trgHeader srcHeight - | srcHeight > _blockHeight trgHeader = return Nothing + | srcHeight > view blockHeight trgHeader = return Nothing | otherwise = Just <$> go trgHeader [] where go cur acc - | srcHeight == _blockHeight cur = return $! (cur N.:| acc) + | srcHeight == view blockHeight cur = return $! (cur N.:| acc) | otherwise = do p <- lookupParentHeader db cur go p (cur : acc) @@ -459,10 +459,10 @@ crumbsToChain -> IO (Maybe (BlockHeader, [(Int, BlockHeader)])) -- ^ bread crumbs that lead from to source Chain to targetHeader crumbsToChain db srcCid trgHeader - | (int (_blockHeight trgHeader) + 1) < length path = return Nothing + | (int (view blockHeight trgHeader) + 1) < length path = return Nothing | otherwise = Just <$> go trgHeader path [] where - graph = chainGraphAt db (_blockHeight trgHeader) + graph = chainGraphAt db (view blockHeight trgHeader) path = shortestPath (_chainId trgHeader) srcCid graph go @@ -473,11 +473,11 @@ crumbsToChain db srcCid trgHeader go !cur [] !acc = return (cur, acc) go !cur ((!h):t) !acc = do adjpHdr <- lookupAdjacentParentHeader db cur h - unless (_blockHeight adjpHdr >= 0) $ throwM + unless (view blockHeight adjpHdr >= 0) $ throwM $ InternalInvariantViolation $ "crumbsToChain: Encountered Genesis block. Chain can't be reached for SPV proof." - let !adjIdx = fromJuste $ blockHashRecordChainIdx (_blockAdjacentHashes cur) h + let !adjIdx = fromJuste $ blockHashRecordChainIdx (view blockAdjacentHashes cur) h go adjpHdr t ((adjIdx, cur) : acc) minimumTrgHeader diff --git a/src/Chainweb/SPV/EventProof.hs b/src/Chainweb/SPV/EventProof.hs index de256da33b..a8320b7d66 100644 --- a/src/Chainweb/SPV/EventProof.hs +++ b/src/Chainweb/SPV/EventProof.hs @@ -100,6 +100,7 @@ import Chainweb.Crypto.MerkleLog import Control.DeepSeq import Control.Exception (throw) +import Control.Lens (view) import Control.Monad import Control.Monad.Catch @@ -589,18 +590,18 @@ createEventsProofDb_ -> IO (PayloadProof a) createEventsProofDb_ headerDb payloadDb d h reqKey = do hdr <- casLookupM headerDb h - Just pwo <- lookupPayloadWithHeight payloadDb (Just $ _blockHeight hdr) (_blockPayloadHash hdr) - unless (_payloadWithOutputsPayloadHash pwo == _blockPayloadHash hdr) $ + Just pwo <- lookupPayloadWithHeight payloadDb (Just $ view blockHeight hdr) (view blockPayloadHash hdr) + unless (_payloadWithOutputsPayloadHash pwo == view blockPayloadHash hdr) $ throwM $ SpvExceptionInconsistentPayloadData { _spvExceptionMsg = "The stored payload hash doesn't match the the db index" - , _spvExceptionMsgPayloadHash = _blockPayloadHash hdr + , _spvExceptionMsgPayloadHash = view blockPayloadHash hdr } curRank <- maxRank headerDb - unless (int (_blockHeight hdr) + d <= curRank) $ + unless (int (view blockHeight hdr) + d <= curRank) $ throwM $ SpvExceptionInsufficientProofDepth { _spvExceptionMsg = "Insufficient depth of root header for SPV proof" , _spvExceptionExpectedDepth = Expected d - , _spvExceptionActualDepth = Actual $ curRank `minusOrZero` int (_blockHeight hdr) + , _spvExceptionActualDepth = Actual $ curRank `minusOrZero` int (view blockHeight hdr) } createEventsProof_ pwo reqKey diff --git a/src/Chainweb/SPV/OutputProof.hs b/src/Chainweb/SPV/OutputProof.hs index 644f5ab667..adb6794501 100644 --- a/src/Chainweb/SPV/OutputProof.hs +++ b/src/Chainweb/SPV/OutputProof.hs @@ -32,6 +32,7 @@ module Chainweb.SPV.OutputProof , getRequestKey ) where +import Control.Lens (view) import Control.Monad import Control.Monad.Catch @@ -210,18 +211,18 @@ createOutputProofDb_ -> IO (PayloadProof a) createOutputProofDb_ headerDb payloadDb d h reqKey = do hdr <- casLookupM headerDb h - Just pwo <- lookupPayloadWithHeight payloadDb (Just $ _blockHeight hdr) (_blockPayloadHash hdr) - unless (_payloadWithOutputsPayloadHash pwo /= _blockPayloadHash hdr) $ + Just pwo <- lookupPayloadWithHeight payloadDb (Just $ view blockHeight hdr) (view blockPayloadHash hdr) + unless (_payloadWithOutputsPayloadHash pwo /= view blockPayloadHash hdr) $ throwM $ SpvExceptionInconsistentPayloadData { _spvExceptionMsg = "The stored payload hash doesn't match the the db index" - , _spvExceptionMsgPayloadHash = _blockPayloadHash hdr + , _spvExceptionMsgPayloadHash = view blockPayloadHash hdr } curRank <- maxRank headerDb - unless (int (_blockHeight hdr) + d <= curRank) $ + unless (int (view blockHeight hdr) + d <= curRank) $ throwM $ SpvExceptionInsufficientProofDepth { _spvExceptionMsg = "Insufficient depth of root header for SPV proof" , _spvExceptionExpectedDepth = Expected d - , _spvExceptionActualDepth = Actual $ curRank `minusOrZero` int (_blockHeight hdr) + , _spvExceptionActualDepth = Actual $ curRank `minusOrZero` int (view blockHeight hdr) } createOutputProof_ @a pwo reqKey diff --git a/src/Chainweb/Sync/WebBlockHeaderStore.hs b/src/Chainweb/Sync/WebBlockHeaderStore.hs index 6efba47c06..c19c8a04ea 100644 --- a/src/Chainweb/Sync/WebBlockHeaderStore.hs +++ b/src/Chainweb/Sync/WebBlockHeaderStore.hs @@ -215,19 +215,19 @@ getBlockPayload s candidateStore priority maybeOrigin h = do logfun Debug $ "getBlockPayload: " <> sshow h tableLookup candidateStore payloadHash >>= \case Just !x -> return x - Nothing -> lookupPayloadWithHeight cas (Just $ _blockHeight h) payloadHash >>= \case + Nothing -> lookupPayloadWithHeight cas (Just $ view blockHeight h) payloadHash >>= \case Just !x -> return $! payloadWithOutputsToPayloadData x Nothing -> memo memoMap payloadHash $ \k -> - pullOrigin (_blockHeight h) k maybeOrigin >>= \case + pullOrigin (view blockHeight h) k maybeOrigin >>= \case Nothing -> do - t <- queryPayloadTask (_blockHeight h) k + t <- queryPayloadTask (view blockHeight h) k pQueueInsert queue t awaitTask t (Just !x) -> return x where v = _chainwebVersion h - payloadHash = _blockPayloadHash h + payloadHash = view blockPayloadHash h cid = _chainId h mgr = _webBlockPayloadStoreMgr s @@ -241,7 +241,7 @@ getBlockPayload s candidateStore priority maybeOrigin h = do traceLogfun :: LogMessage a => LogLevel -> a -> IO () traceLogfun = _webBlockPayloadStoreLogFunction s - taskMsg k msg = "payload task " <> sshow k <> " @ " <> sshow (_blockHash h) <> ": " <> msg + taskMsg k msg = "payload task " <> sshow k <> " @ " <> sshow (view blockHash h) <> ": " <> msg traceLabel subfun = "Chainweb.Sync.WebBlockHeaderStore.getBlockPayload." <> subfun @@ -394,7 +394,7 @@ getBlockHeaderInternal headerStore payloadStore candidateHeaderCas candidatePayl -- query parent (recursively) -- - <* queryParent (_blockParent <$> chainValue header) + <* queryParent (view blockParent <$> chainValue header) -- query adjacent parents (recursively) <* mconcat (queryAdjacentParent <$> adjParents header) @@ -481,15 +481,15 @@ getBlockHeaderInternal headerStore payloadStore candidateHeaderCas candidatePayl validateAndInsertPayload hdr p = do let payload = case localPayload of Just (hsh, pwo) - | hsh == _blockPayloadHash hdr + | hsh == view blockPayloadHash hdr -> CheckablePayloadWithOutputs pwo _ -> CheckablePayload p outs <- trace logfun (traceLabel "pact") - (_blockHash hdr) + (view blockHash hdr) (length (_payloadDataTransactions p)) $ pact hdr payload - addNewPayload (_webBlockPayloadStoreCas payloadStore) (_blockHeight hdr) outs + addNewPayload (_webBlockPayloadStoreCas payloadStore) (view blockHeight hdr) outs queryBlockHeaderTask ck@(ChainValue cid k) = newTask (sshow ck) priority $ \l env -> chainValue <$> do @@ -510,7 +510,7 @@ getBlockHeaderInternal headerStore payloadStore candidateHeaderCas candidatePayl , _remoteChainId = cid } - adjParents = toList . imap ChainValue . _getBlockHashRecord . _blockAdjacentHashes + adjParents = toList . imap ChainValue . _getBlockHashRecord . view blockAdjacentHashes pullOrigin :: ChainValue BlockHash diff --git a/src/Chainweb/TreeDB/RemoteDB.hs b/src/Chainweb/TreeDB/RemoteDB.hs index 2eefecfc84..b2710e6dd4 100644 --- a/src/Chainweb/TreeDB/RemoteDB.hs +++ b/src/Chainweb/TreeDB/RemoteDB.hs @@ -22,6 +22,7 @@ module Chainweb.TreeDB.RemoteDB ) where import Control.Error.Util (hush) +import Control.Lens (view) import Control.Monad.Catch (handle, throwM) import qualified Data.Text as T @@ -38,7 +39,7 @@ import System.LogLevel -- internal modules import Chainweb.BlockHash (BlockHash) -import Chainweb.BlockHeader (BlockHeader(..)) +import Chainweb.BlockHeader (BlockHeader, blockChainId) import Chainweb.BlockHeaderDB.RestAPI.Client import Chainweb.TreeDB import Chainweb.Utils @@ -137,4 +138,4 @@ remoteDb -> IO RemoteDb remoteDb db logg env = do h <- root db - pure $! RemoteDb env (ALogFunction logg) (_chainwebVersion h) (_blockChainId h) + pure $! RemoteDb env (ALogFunction logg) (_chainwebVersion h) (view blockChainId h) diff --git a/src/Chainweb/WebBlockHeaderDB.hs b/src/Chainweb/WebBlockHeaderDB.hs index 3d6d2b091b..0ad9bc06b8 100644 --- a/src/Chainweb/WebBlockHeaderDB.hs +++ b/src/Chainweb/WebBlockHeaderDB.hs @@ -106,7 +106,7 @@ webEntries db f = go (view (webBlockHeaderDb . to HM.elems) db) mempty where go [] s = f s go (h:t) s = entries h Nothing Nothing Nothing Nothing $ \x -> - go t (() <$ S.mergeOn _blockCreationTime s x) + go t (() <$ S.mergeOn (view blockCreationTime) s x) -- FIXME: should we include the rank in the order? type instance Index WebBlockHeaderDb = ChainId @@ -170,7 +170,7 @@ blockAdjacentParentHeaders blockAdjacentParentHeaders db h = itraverse (lookupWebBlockHeaderDb db) $ _getBlockHashRecord - $ _blockAdjacentHashes h + $ view blockAdjacentHashes h lookupAdjacentParentHeader :: WebBlockHeaderDb @@ -178,7 +178,7 @@ lookupAdjacentParentHeader -> ChainId -> IO BlockHeader lookupAdjacentParentHeader db h cid = do - checkWebChainId (db, _blockHeight h) h + checkWebChainId (db, view blockHeight h) h let ph = h ^?! (blockAdjacentHashes . ix cid) lookupWebBlockHeaderDb db cid ph @@ -187,8 +187,8 @@ lookupParentHeader -> BlockHeader -> IO BlockHeader lookupParentHeader db h = do - checkWebChainId (db, _blockHeight h) h - lookupWebBlockHeaderDb db (_chainId h) (_blockParent h) + checkWebChainId (db, view blockHeight h) h + lookupWebBlockHeaderDb db (_chainId h) (view blockParent h) -- -------------------------------------------------------------------------- -- -- Insertion @@ -254,11 +254,11 @@ checkBlockHeaderGraph => BlockHeader -> m () checkBlockHeaderGraph b = void - $ checkAdjacentChainIds graph b $ Expected $ _blockAdjacentChainIds b + $ checkAdjacentChainIds graph b $ Expected $ view blockAdjacentChainIds b where graph | isGenesisBlockHeader b = _chainGraph b - | otherwise = chainGraphAt (_blockChainwebVersion b) (_blockHeight b - 1) + | otherwise = chainGraphAt (view blockChainwebVersion b) (view blockHeight b - 1) {-# INLINE checkBlockHeaderGraph #-} -- | Given a 'WebBlockHeaderDb' @db@, @checkBlockAdjacentParents h@ checks that diff --git a/test/Chainweb/Test/BlockHeader/Genesis.hs b/test/Chainweb/Test/BlockHeader/Genesis.hs index 61740efc5b..7b1b9cde19 100644 --- a/test/Chainweb/Test/BlockHeader/Genesis.hs +++ b/test/Chainweb/Test/BlockHeader/Genesis.hs @@ -28,7 +28,7 @@ import Test.Tasty.QuickCheck (testProperty, testProperties) -- internal modules import Chainweb.BlockHash (encodeBlockHash) -import Chainweb.BlockHeader hiding (blockHash) +import Chainweb.BlockHeader import Chainweb.Difficulty import Chainweb.Test.Utils (golden) import Chainweb.Utils @@ -44,7 +44,7 @@ import Chainweb.Version.Testnet -- new `ChainwebVersion` value! tests :: TestTree tests = testGroup "Chainweb.Test.BlockHeader.Genesis" - [ testGroup "genesis header golden tests" $ blockHash <$> + [ testGroup "genesis header golden tests" $ versionBlockHashTree <$> [ RecapDevelopment , Testnet04 , Mainnet01 @@ -57,10 +57,10 @@ blockHashes = BB.toLazyByteString . foldMap (hash . snd) . sortBy (compare `on` fst) . HM.toList where hash :: BlockHeader -> BB.Builder - hash = BB.byteString . B64U.encode . runPutS . encodeBlockHash . _blockHash + hash = BB.byteString . B64U.encode . runPutS . encodeBlockHash . view blockHash -blockHash :: ChainwebVersion -> TestTree -blockHash v = golden (sshow v <> "-block-hashes") $ +versionBlockHashTree :: ChainwebVersion -> TestTree +versionBlockHashTree v = golden (sshow v <> "-block-hashes") $ pure $ blockHashes $ genesisBlockHeaders v -- -------------------------------------------------------------------------- -- diff --git a/test/Chainweb/Test/BlockHeader/Validation.hs b/test/Chainweb/Test/BlockHeader/Validation.hs index eceaa99870..273db49a70 100644 --- a/test/Chainweb/Test/BlockHeader/Validation.hs +++ b/test/Chainweb/Test/BlockHeader/Validation.hs @@ -42,7 +42,7 @@ import Test.Tasty.QuickCheck import Chainweb.BlockCreationTime import Chainweb.BlockHash -import Chainweb.BlockHeader +import Chainweb.BlockHeader.Internal import Chainweb.BlockHeader.Validation import Chainweb.BlockHeight import Chainweb.Difficulty @@ -166,8 +166,8 @@ validate_cases msg testCases = testCase msg $ do $ "Validation of test case " <> sshow i <> " failed with unexpected errors for BlockHeader" <> ", expected: " <> sshow expectedErrs <> ", actual: " <> sshow errs - <> ", header: " <> sshow (_blockHash $ _testHeaderHdr h) - <> ", height: " <> sshow (_blockHeight $ _testHeaderHdr h) + <> ", header: " <> sshow (view blockHash $ _testHeaderHdr h) + <> ", height: " <> sshow (view blockHeight $ _testHeaderHdr h) | otherwise -> return () -- -------------------------------------------------------------------------- -- @@ -194,7 +194,7 @@ validateTestHeader h = case try val of Right _ -> property True Left err -> throw err where - now = add second $ _bct $ _blockCreationTime $ _testHeaderHdr h + now = add second $ _bct $ view blockCreationTime $ _testHeaderHdr h val = validateBlockHeaderM now (testHeaderChainLookup h) (_testHeaderHdr h) verify :: [ValidationFailureType] -> Property verify es = L.delete IncorrectPow es === [] @@ -213,7 +213,7 @@ validationFailures = , ( hdr & testHeaderHdr . blockHash .~ nullBlockHash , [IncorrectHash] ) - , ( hdr & testHeaderHdr . blockCreationTime .~ (_blockCreationTime . _parentHeader $ _testHeaderParent hdr) + , ( hdr & testHeaderHdr . blockCreationTime .~ (view blockCreationTime . _parentHeader $ _testHeaderParent hdr) , [IncorrectHash, IncorrectPow, CreatedBeforeParent] ) , ( hdr & testHeaderHdr . blockHash %~ messWords encodeBlockHash decodeBlockHash (flip complementBit 0) diff --git a/test/Chainweb/Test/BlockHeaderDB/PruneForks.hs b/test/Chainweb/Test/BlockHeaderDB/PruneForks.hs index d96eb7a8e1..b8a886b384 100644 --- a/test/Chainweb/Test/BlockHeaderDB/PruneForks.hs +++ b/test/Chainweb/Test/BlockHeaderDB/PruneForks.hs @@ -16,6 +16,7 @@ module Chainweb.Test.BlockHeaderDB.PruneForks ( tests ) where +import Control.Lens (view, (.~)) import Control.Monad import Control.Monad.Catch @@ -31,7 +32,7 @@ import Test.Tasty.HUnit -- internal modules -import Chainweb.BlockHeader +import Chainweb.BlockHeader.Internal import Chainweb.BlockHeader.Validation import Chainweb.BlockHeaderDB import Chainweb.BlockHeaderDB.Internal @@ -104,7 +105,7 @@ insertWithPayloads bdb pdb h n l = do hdrs <- insertN_ n l h bdb forM_ hdrs $ \hd -> let payload = testBlockPayload_ hd - in addNewPayload pdb (_blockHeight hd) payload + in addNewPayload pdb (view blockHeight hd) payload return hdrs cid :: ChainId @@ -113,7 +114,7 @@ cid = unsafeChainId 0 delHdr :: BlockHeaderDb -> BlockHeader -> IO () delHdr cdb k = do tableDelete (_chainDbCas cdb) (casKey $ RankedBlockHeader k) - tableDelete (_chainDbRankTable cdb) (_blockHash k) + tableDelete (_chainDbRankTable cdb) (view blockHash k) -- -------------------------------------------------------------------------- -- -- Test cases @@ -175,7 +176,7 @@ singleForkTest rio step d expect msg = withDbs rio $ \_rdb db pdb h -> do (f0, f1) <- createForks db pdb h n <- pruneForks logg db d $ \_ x -> - logg Info (sshow $ _blockHeight x) + logg Info (sshow $ view blockHeight x) assertHeaders db f0 when (expect > 0) $ assertPrunedHeaders db f1 assertEqual msg expect n @@ -184,17 +185,17 @@ singleForkTest rio step d expect msg = assertHeaders :: BlockHeaderDb -> [BlockHeader] -> IO () assertHeaders db f = - unlessM (fmap and $ mapM (tableMember db) $ _blockHash <$> f) $ + unlessM (fmap and $ mapM (tableMember db) $ view blockHash <$> f) $ assertFailure "missing block header that should not have been pruned" assertPrunedHeaders :: BlockHeaderDb -> [BlockHeader] -> IO () assertPrunedHeaders db f = - whenM (fmap or $ mapM (tableMember db) $ _blockHash <$> f) $ + whenM (fmap or $ mapM (tableMember db) $ view blockHash <$> f) $ assertFailure "failed to prune some block header" assertPayloads :: PayloadDb RocksDbTable -> [BlockHeader] -> IO () assertPayloads db f = do - let fs = (\h -> (Just $ _blockHeight h, _blockPayloadHash h)) <$> f + let fs = (\h -> (Just $ view blockHeight h, view blockPayloadHash h)) <$> f unlessM (and <$> mapM (uncurry $ lookupPayloadWithHeightExists db) fs) $ assertFailure "missing block payload that should not have been garbage collected" @@ -202,7 +203,7 @@ assertPayloads db f = do -- assertPrunedPayloads :: PayloadDb RocksDbTable -> [BlockHeader] -> IO () assertPrunedPayloads db f = do - let fs = (\h -> (Just $ _blockHeight h, _blockPayloadHash h)) <$> f + let fs = (\h -> (Just $ view blockHeight h, view blockPayloadHash h)) <$> f results <- mapM (uncurry $ lookupPayloadWithHeightExists db) fs let remained = length (filter id results) when (remained > 1) $ @@ -255,7 +256,7 @@ failTest rio n step = withDbs rio $ \_rdb db pdb h -> do return () where prune db d = pruneForks logg db d $ \_ h -> - logg Info (sshow $ _blockHeight h) + logg Info (sshow $ view blockHeight h) logg = logFunctionText $ genericLogger testLogLevel (step . T.unpack) @@ -289,7 +290,8 @@ failIntrinsicCheck rio checks n step = withDbs rio $ \rdb bdb pdb h -> do (f0, _) <- createForks bdb pdb h let b = f0 !! int n delHdr bdb b - unsafeInsertBlockHeaderDb bdb $ b { _blockChainwebVersion = _versionCode RecapDevelopment } + unsafeInsertBlockHeaderDb bdb $ b + & blockChainwebVersion .~ _versionCode RecapDevelopment try (pruneAllChains logger rdb toyVersion checks) >>= \case Left e | CheckFull `elem` checks @@ -319,7 +321,7 @@ failPayloadCheck :: IO RocksDb -> [PruningChecks] -> Natural -> (String -> IO () failPayloadCheck rio checks n step = withDbs rio $ \rdb bdb pdb h -> do (f0, _) <- createForks bdb pdb h let b = f0 !! int n - p <- lookupPayloadDataWithHeight pdb (Just $ _blockHeight b) (_blockPayloadHash b) >>= \case + p <- lookupPayloadDataWithHeight pdb (Just $ view blockHeight b) (view blockPayloadHash b) >>= \case Nothing -> assertFailure "missing payload" Just x -> return x deletePayload pdb (payloadDataToBlockPayload p) @@ -345,11 +347,11 @@ failPayloadCheck2 :: IO RocksDb -> [PruningChecks] -> Natural -> (String -> IO ( failPayloadCheck2 rio checks n step = withDbs rio $ \rdb bdb pdb h -> do (f0, _) <- createForks bdb pdb h let b = f0 !! int n - payload <- lookupPayloadWithHeight pdb (Just $ _blockHeight b) (_blockPayloadHash b) >>= \case + payload <- lookupPayloadWithHeight pdb (Just $ view blockHeight b) (view blockPayloadHash b) >>= \case Nothing -> assertFailure "missing payload" Just x -> return x tableDelete (_newTransactionDbBlockTransactionsTbl $ _transactionDb pdb) - (_blockHeight b, _payloadWithOutputsTransactionsHash payload) + (view blockHeight b, _payloadWithOutputsTransactionsHash payload) try (pruneAllChains logger rdb toyVersion checks) >>= \case Left (MissingPayloadException{}) -> return () Left e -> assertFailure diff --git a/test/Chainweb/Test/Cut.hs b/test/Chainweb/Test/Cut.hs index c9262bcebe..60730fe63d 100644 --- a/test/Chainweb/Test/Cut.hs +++ b/test/Chainweb/Test/Cut.hs @@ -90,7 +90,7 @@ import qualified Test.QuickCheck.Monadic as T import Chainweb.BlockCreationTime import Chainweb.BlockHash -import Chainweb.BlockHeader +import Chainweb.BlockHeader.Internal import Chainweb.ChainId import Chainweb.ChainValue import Chainweb.Cut @@ -131,7 +131,7 @@ type GenBlockTime = Cut -> ChainId -> Time Micros offsetBlockTime :: TimeSpan Micros -> GenBlockTime offsetBlockTime offset cut cid = add offset $ maximum - $ fmap (_bct . _blockCreationTime) + $ fmap (_bct . view blockCreationTime) $ HM.insert cid (cut ^?! ixg cid) $ cutAdjs cut cid @@ -281,14 +281,14 @@ arbitraryCut v = T.sized $ \s -> do fst <$> foldlM (\x _ -> genCut x) (genesis, initDb) [0..(k-1)] where genesis = genesisCut v - initDb = foldl' (\d h -> HM.insert (_blockHash h) h d) mempty $ _cutMap genesis + initDb = foldl' (\d h -> HM.insert (view blockHash h) h d) mempty $ _cutMap genesis genCut :: (Cut, TestHeaderMap) -> T.Gen (Cut, TestHeaderMap) genCut (c, db) = do cids <- T.shuffle (toList $ chainIds v) S.each cids & S.mapMaybeM (mine db c) - & S.map (\(T2 h x) -> (x, HM.insert (_blockHash h) h db)) + & S.map (\(T2 h x) -> (x, HM.insert (view blockHash h) h db)) & S.head_ & fmap fromJuste diff --git a/test/Chainweb/Test/CutDB.hs b/test/Chainweb/Test/CutDB.hs index 48fded4fe8..03f6fc8c14 100644 --- a/test/Chainweb/Test/CutDB.hs +++ b/test/Chainweb/Test/CutDB.hs @@ -173,12 +173,12 @@ syncPact -> IO () syncPact cutDb pact = void $ webEntries bhdb $ \s -> s - & S.filter ((/= 0) . _blockHeight) + & S.filter ((/= 0) . view blockHeight) & S.mapM_ (\h -> payload h >>= _webPactValidateBlock pact h . CheckablePayload) where bhdb = view cutDbWebBlockHeaderDb cutDb pdb = view cutDbPayloadDb cutDb - payload h = lookupPayloadWithHeight pdb (Just $ _blockHeight h) (_blockPayloadHash h) >>= \case + payload h = lookupPayloadWithHeight pdb (Just $ view blockHeight h) (view blockPayloadHash h) >>= \case Nothing -> error $ "Corrupted database: failed to load payload data for block header " <> sshow h Just p -> return $ payloadWithOutputsToPayloadData p @@ -235,7 +235,7 @@ awaitBlockHeight -> IO Cut awaitBlockHeight cdb bh cid = atomically $ do c <- _cutStm cdb - let bh2 = _blockHeight $ c ^?! ixg cid + let bh2 = view blockHeight $ c ^?! ixg cid STM.check $ bh < bh2 return c @@ -378,14 +378,14 @@ getRandomUnblockedChain c = do shuffled <- generate $ shuffle $ toList $ _cutMap c S.each shuffled & S.filter isUnblocked - & S.map _blockChainId + & S.map (view blockChainId) & S.head_ & fmap fromJuste where isUnblocked h = - let bh = _blockHeight h - cid = _blockChainId h - in all (>= bh) $ fmap _blockHeight $ toList $ cutAdjs c cid + let bh = view blockHeight h + cid = view blockChainId h + in all (>= bh) $ fmap (view blockHeight) $ toList $ cutAdjs c cid -- | Build a linear chainweb (no forks). No POW or poison delay is applied. -- Block times are real times. @@ -413,8 +413,8 @@ tryMineForChain miner webPact cutDb c cid = do case x of Right (T2 h c') -> do addCutHashes cutDb (cutToCutHashes Nothing c') - { _cutHashesHeaders = HM.singleton (_blockHash h) h - , _cutHashesPayloads = HM.singleton (_blockPayloadHash h) (payloadWithOutputsToPayloadData outputs) + { _cutHashesHeaders = HM.singleton (view blockHash h) h + , _cutHashesPayloads = HM.singleton (view blockPayloadHash h) (payloadWithOutputsToPayloadData outputs) } return $ Right (c', cid, outputs) Left e -> return $ Left e @@ -438,8 +438,8 @@ randomBlockHeader cutDb = do & S.toList_ generate $ elements allBlockHeaders where - chainHeight curCut cid = _blockHeight (curCut ^?! ixg (_chainId cid)) - checkHeight curCut x = (_blockHeight x /= 0) && (_blockHeight x <= chainHeight curCut x) + chainHeight curCut cid = view blockHeight (curCut ^?! ixg (_chainId cid)) + checkHeight curCut x = (view blockHeight x /= 0) && (view blockHeight x <= chainHeight curCut x) -- | Picks a random transaction from a chain web, making sure that the -- transaction isn't ahead of the longest cut. @@ -451,7 +451,7 @@ randomTransaction -> IO (BlockHeader, Int, Transaction, TransactionOutput) randomTransaction cutDb = do bh <- randomBlockHeader cutDb - Just pd <- lookupPayloadDataWithHeight payloadDb (Just $ _blockHeight bh) (_blockPayloadHash bh) + Just pd <- lookupPayloadDataWithHeight payloadDb (Just $ view blockHeight bh) (view blockPayloadHash bh) let pay = BlockPayload { _blockPayloadTransactionsHash = _payloadDataTransactionsHash pd , _blockPayloadOutputsHash = _payloadDataOutputsHash pd @@ -461,12 +461,12 @@ randomTransaction cutDb = do Just btxs <- tableLookup (_newTransactionDbBlockTransactionsTbl $ _transactionDb payloadDb) - (_blockHeight bh, _blockPayloadTransactionsHash pay) + (view blockHeight bh, _blockPayloadTransactionsHash pay) txIx <- generate $ choose (0, length (_blockTransactions btxs) - 1) Just outs <- tableLookup (_newBlockOutputsTbl $ _payloadCacheBlockOutputs $ _payloadCache payloadDb) - (_blockHeight bh, _blockPayloadOutputsHash pay) + (view blockHeight bh, _blockPayloadOutputsHash pay) return ( bh , txIx diff --git a/test/Chainweb/Test/Mempool/Consensus.hs b/test/Chainweb/Test/Mempool/Consensus.hs index c04979e099..aaa57d76a7 100644 --- a/test/Chainweb/Test/Mempool/Consensus.hs +++ b/test/Chainweb/Test/Mempool/Consensus.hs @@ -8,6 +8,7 @@ module Chainweb.Test.Mempool.Consensus ( tests ) where +import Control.Lens (view) import Control.Monad.IO.Class import Control.Monad.Trans.Resource @@ -346,18 +347,18 @@ header' h = do . newMerkleLog $ mkFeatureFlags :+: t' - :+: _blockHash h + :+: view blockHash h :+: target :+: _payloadWithOutputsPayloadHash (testBlockPayload h) :+: _chainId h - :+: BlockWeight (targetToDifficulty target) + _blockWeight h - :+: succ (_blockHeight h) + :+: BlockWeight (targetToDifficulty target) + view blockWeight h + :+: succ (view blockHeight h) :+: _versionCode v :+: epochStart (ParentHeader h) mempty t' :+: nonce :+: MerkleLogBody mempty where - BlockCreationTime t = _blockCreationTime h + BlockCreationTime t = view blockCreationTime h target = powTarget (ParentHeader h) mempty t' v = _chainwebVersion h t' = BlockCreationTime (scaleTimeSpan (10 :: Int) second `add` t) @@ -433,12 +434,12 @@ instance Show ForkInfo where ++ debugTrans "newForkTrans" fiNewForkTrans ++ "\n\t" ++ "'head' of old fork:" - ++ "\n\t\tblock height: " ++ show (_blockHeight fiOldHeader) - ++ "\n\t\tblock hash: " ++ show (_blockHash fiOldHeader) + ++ "\n\t\tblock height: " ++ show (view blockHeight fiOldHeader) + ++ "\n\t\tblock hash: " ++ show (view blockHash fiOldHeader) ++ "\n\t" ++ "'head' of new fork:" - ++ "\n\t\tblock height: " ++ show (_blockHeight fiNewHeader) - ++ "\n\t\tblock hash: " ++ show (_blockHash fiNewHeader) + ++ "\n\t\tblock height: " ++ show (view blockHeight fiNewHeader) + ++ "\n\t\tblock hash: " ++ show (view blockHash fiNewHeader) ++ concatMap (debugHeader "main trunk headers") fiPreForkHeaders ++ concatMap (debugHeader "left fork headers") fiLeftForkHeaders ++ concatMap (debugHeader "right fork headers") fiRightForkHeaders @@ -446,11 +447,11 @@ instance Show ForkInfo where ---------------------------------------------------------------------------------------------------- debugHeader :: String -> BlockHeader -> String -debugHeader context BlockHeader{..} = +debugHeader context bh = "\nBlockheader from " ++ context ++ ": " - ++ "\n\t\tblockHeight: " ++ show _blockHeight ++ " (0-based)" - ++ "\n\t\tblockHash: " ++ show _blockHash - ++ "\n\t\tparentHash: " ++ show _blockParent + ++ "\n\t\tblockHeight: " ++ show (view blockHeight bh) ++ " (0-based)" + ++ "\n\t\tblockHash: " ++ show (view blockHash bh) + ++ "\n\t\tparentHash: " ++ show (view blockParent bh) ++ "\n" ---------------------------------------------------------------------------------------------------- diff --git a/test/Chainweb/Test/MultiNode.hs b/test/Chainweb/Test/MultiNode.hs index 9c624e8d34..2f99f7e951 100644 --- a/test/Chainweb/Test/MultiNode.hs +++ b/test/Chainweb/Test/MultiNode.hs @@ -429,7 +429,7 @@ pactImportTest logLevel v n rocksDb pactDir step = do latestBlockHeight <- do wbhdb <- initWebBlockHeaderDb rdb v latestCutHeaders <- readHighestCutHeaders v (\_ _ -> pure ()) wbhdb (cutHashesTable rdb) - pure $ maximum $ fmap _blockHeight latestCutHeaders + pure $ maximum $ fmap (view blockHeight) latestCutHeaders let targetChunkSize :: BlockHeight targetChunkSize = nextLowestPowerOfTen latestBlockHeight @@ -447,7 +447,7 @@ pactImportTest logLevel v n rocksDb pactDir step = do logFunctionText logger' Info "Verifying state" snapshot@(snapshotBlockHeight, snapshotHashes) <- GrandHash.Import.pactVerify logger' v pactConns rdb grands logFunctionText logger' Debug $ "SNAPSHOT BLOCKHEIGHT = " <> sshow (fst snapshot) - logFunctionText logger' Debug $ "SNAPSHOT HASHES = " <> sshow (HM.map (\s -> (T.decodeUtf8 (Base16.encode (getChainGrandHash s.pactHash)), _blockHeight s.blockHeader)) (snd snapshot)) + logFunctionText logger' Debug $ "SNAPSHOT HASHES = " <> sshow (HM.map (\s -> (T.decodeUtf8 (Base16.encode (getChainGrandHash s.pactHash)), view blockHeight s.blockHeader)) (snd snapshot)) logFunctionText logger' Info "Making a copy of the pact state, and dropping the post-verified content" withSystemTempDirectory "pact-copy" $ \copyPactDir -> do @@ -583,12 +583,12 @@ replayTest loglevel v n rdb pactDbDir step = do Replayed l (Just u) -> do writeIORef firstReplayCompleteRef True _ <- flip HM.traverseWithKey (_cutMap l) $ \cid bh -> - assertEqual ("lower chain " <> sshow cid) replayInitialHeight (_blockHeight bh) + assertEqual ("lower chain " <> sshow cid) replayInitialHeight (view blockHeight bh) -- TODO: this is flaky, presumably because a node's cutdb -- is not being cancelled synchronously enough assertEqual "upper cut" (_stateCutMap state2 HM.! nid) u _ <- flip HM.traverseWithKey (_cutMap u) $ \cid bh -> - assertGe ("upper chain " <> sshow cid) (Actual $ _blockHeight bh) (Expected replayInitialHeight) + assertGe ("upper chain " <> sshow cid) (Actual $ view blockHeight bh) (Expected replayInitialHeight) return () Replayed _ Nothing -> error "replayTest: no replay upper bound" _ -> error "replayTest: not a replay" @@ -605,9 +605,9 @@ replayTest loglevel v n rdb pactDbDir step = do Replayed l (Just u) -> do writeIORef secondReplayCompleteRef True _ <- flip HM.traverseWithKey (_cutMap l) $ \cid bh -> - assertEqual ("lower chain " <> sshow cid) replayInitialHeight (_blockHeight bh) + assertEqual ("lower chain " <> sshow cid) replayInitialHeight (view blockHeight bh) _ <- flip HM.traverseWithKey (_cutMap u) $ \cid bh -> - assertEqual ("upper chain " <> sshow cid) fastForwardHeight (_blockHeight bh) + assertEqual ("upper chain " <> sshow cid) fastForwardHeight (view blockHeight bh) return () Replayed _ Nothing -> do error "replayTest: no replay upper bound" @@ -699,7 +699,7 @@ sampleConsensusState sampleConsensusState nid bhdb cutdb s = do !hashes' <- webEntries bhdb $ S.fold_ (flip HS.insert) (_stateBlockHashes s) id - . S.map _blockHash + . S.map (view blockHash) !c <- _cut cutdb return $! s { _stateBlockHashes = hashes' diff --git a/test/Chainweb/Test/Orphans/Internal.hs b/test/Chainweb/Test/Orphans/Internal.hs index 65d312ae6d..777b854097 100644 --- a/test/Chainweb/Test/Orphans/Internal.hs +++ b/test/Chainweb/Test/Orphans/Internal.hs @@ -60,6 +60,7 @@ module Chainweb.Test.Orphans.Internal ) where import Control.Applicative +import Control.Lens (view) import Control.Monad import Control.Monad.Catch @@ -424,7 +425,7 @@ instance Arbitrary WorkHeader where hdr <- arbitrary return $ WorkHeader { _workHeaderChainId = _chainId hdr - , _workHeaderTarget = _blockTarget hdr + , _workHeaderTarget = view blockTarget hdr , _workHeaderBytes = BS.toShort $ runPutS $ encodeBlockHeaderWithoutHash hdr } diff --git a/test/Chainweb/Test/Pact/Checkpointer.hs b/test/Chainweb/Test/Pact/Checkpointer.hs index fe3370c597..12ee3c4be1 100644 --- a/test/Chainweb/Test/Pact/Checkpointer.hs +++ b/test/Chainweb/Test/Pact/Checkpointer.hs @@ -47,7 +47,7 @@ import Test.Tasty.HUnit -- internal imports import Chainweb.BlockHash -import Chainweb.BlockHeader +import Chainweb.BlockHeader.Internal import Chainweb.BlockHeight import Chainweb.Logger import Chainweb.MerkleLogHash (merkleLogHash) @@ -410,7 +410,7 @@ checkpointerTest name relational cenvIO = testCaseSteps name $ \next -> do next "Purposefully restore to an illegal checkpoint." - let pc10Invalid = pc10 { _blockHeight = 13 } + let pc10Invalid = pc10 & blockHeight .~ 13 void $ expectException "Illegal checkpoint successfully restored to" $ readFrom (Just pc10Invalid) $ \_ -> return () @@ -714,10 +714,13 @@ cpRestoreAndSave cp pc blks = snd <$> _cpRestoreAndSave cp (ParentHeader <$> pc) -- | fabricate a `BlockHeader` for a block given its hash and its parent. childOf :: Maybe BlockHeader -> BlockHash -> BlockHeader -childOf (Just bh) bhsh = - bh { _blockHash = bhsh, _blockParent = _blockHash bh, _blockHeight = _blockHeight bh + 1 } -childOf Nothing bhsh = - (genesisBlockHeader testVer testChainId) { _blockHash = bhsh } +childOf m bhsh = case m of + Just bh -> bh + & blockHash .~ bhsh + & blockParent .~ view blockHash bh + & blockHeight .~ view blockHeight bh + 1 + Nothing -> genesisBlockHeader testVer testChainId + & blockHash .~ bhsh -- initialize a block env without actually restoring the checkpointer, before -- genesis. diff --git a/test/Chainweb/Test/Pact/ModuleCacheOnRestart.hs b/test/Chainweb/Test/Pact/ModuleCacheOnRestart.hs index 10565f7024..3576ce752c 100644 --- a/test/Chainweb/Test/Pact/ModuleCacheOnRestart.hs +++ b/test/Chainweb/Test/Pact/ModuleCacheOnRestart.hs @@ -255,7 +255,7 @@ doNextCoinbase iobdb = do let prevH' = _blockInProgressParentHeader bip let pwo = blockInProgressToPayloadWithOutputs bip liftIO $ ParentHeader prevH @?= prevH' - void $ liftIO $ addTestBlockDb bdb (succ $ _blockHeight prevH) (Nonce 0) (offsetBlockTime second) testChainId pwo + void $ liftIO $ addTestBlockDb bdb (succ $ view blockHeight prevH) (Nonce 0) (offsetBlockTime second) testChainId pwo nextH <- liftIO $ getParentTestBlockDb bdb testChainId (valPWO, _g) <- execValidateBlock mempty nextH (CheckablePayloadWithOutputs pwo) return (nextH, valPWO) @@ -265,8 +265,7 @@ doNextCoinbaseN_ => Int -> IO TestBlockDb -> PactServiceM logger cas (BlockHeader, PayloadWithOutputs) -doNextCoinbaseN_ n iobdb = fmap last $ forM [1..n] $ \_ -> - doNextCoinbase iobdb +doNextCoinbaseN_ n iobdb = fmap last $ replicateM n $ doNextCoinbase iobdb -- | Interfaces can't be upgraded, but modules can, so verify hash in that case. justModuleHashes :: ModuleInitCache -> HM.HashMap ModuleName (Maybe ModuleHash) diff --git a/test/Chainweb/Test/Pact/PactMultiChainTest.hs b/test/Chainweb/Test/Pact/PactMultiChainTest.hs index ed3f6cc7ac..49cdb38c11 100644 --- a/test/Chainweb/Test/Pact/PactMultiChainTest.hs +++ b/test/Chainweb/Test/Pact/PactMultiChainTest.hs @@ -214,7 +214,7 @@ txTimeoutTest = do liftIO $ do badlisted <- readIORef mempoolBadlistRef assertEqual "number of badlisted transactions is 1 after runCut'" 1 (Set.size badlisted) - assertEqual "block is still made despite timeout" (succ (_blockHeight blockBefore)) (_blockHeight blockAfter) + assertEqual "block is still made despite timeout" (succ (view blockHeight blockBefore)) (view blockHeight blockAfter) rs <- txResults liftIO $ assertEqual "number of transactions in block should be one (1) when second transaction times out" 1 (length rs) @@ -1569,7 +1569,7 @@ filterBlock f (MempoolBlock b) = MempoolBlock $ \mi -> blockForChain :: ChainId -> MempoolBlock -> MempoolBlock blockForChain chid = filterBlock $ \bh -> - _blockChainId bh == chid + view blockChainId bh == chid runCut' :: PactTestM () runCut' = do @@ -1691,7 +1691,7 @@ runToHeight :: BlockHeight -> PactTestM () runToHeight bhi = do chid <- view menvChainId bh <- getHeader chid - when (_blockHeight bh < bhi) $ do + when (view blockHeight bh < bhi) $ do runCut' runToHeight bhi @@ -1751,8 +1751,8 @@ signSender00 = set cbSigners [mkEd25519Signer' sender00 []] setFromHeader :: BlockHeader -> CmdBuilder -> CmdBuilder setFromHeader bh = - set cbChainId (_blockChainId bh) - . set cbCreationTime (toTxCreationTime $ _bct $ _blockCreationTime bh) + set cbChainId (view blockChainId bh) + . set cbCreationTime (toTxCreationTime $ _bct $ view blockCreationTime bh) buildBasic :: PactRPC T.Text @@ -1804,7 +1804,7 @@ getPWO :: ChainId -> PactTestM (PayloadWithOutputs,BlockHeader) getPWO chid = do (TestBlockDb _ pdb _) <- view menvBdb h <- getHeader chid - Just pwo <- liftIO $ lookupPayloadWithHeight pdb (Just $ _blockHeight h) (_blockPayloadHash h) + Just pwo <- liftIO $ lookupPayloadWithHeight pdb (Just $ view blockHeight h) (view blockPayloadHash h) return (pwo,h) getHeader :: ChainId -> PactTestM BlockHeader diff --git a/test/Chainweb/Test/Pact/PactReplay.hs b/test/Chainweb/Test/Pact/PactReplay.hs index d1542bc63f..ace3ab3c7c 100644 --- a/test/Chainweb/Test/Pact/PactReplay.hs +++ b/test/Chainweb/Test/Pact/PactReplay.hs @@ -96,16 +96,16 @@ onRestart mpio iop step = do (_, _, bdb) <- iop bhdb' <- getBlockHeaderDb cid bdb block <- maxEntry bhdb' - step $ "max block has height " <> sshow (_blockHeight block) - let nonce = Nonce $ fromIntegral $ _blockHeight block + step $ "max block has height " <> sshow (view blockHeight block) + let nonce = Nonce $ fromIntegral $ view blockHeight block step "mine block on top of max block" T3 _ b _ <- mineBlock (ParentHeader block) nonce iop - assertEqual "Invalid BlockHeight" 1 (_blockHeight b) + assertEqual "Invalid BlockHeight" 1 (view blockHeight b) testMemPoolAccess :: MemPoolAccess testMemPoolAccess = mempty { mpaGetBlock = \_g validate bh hash ph -> do - let (BlockCreationTime t) = _blockCreationTime ph + let (BlockCreationTime t) = view blockCreationTime ph getTestBlock t validate bh hash } where @@ -182,7 +182,7 @@ serviceInitializationAfterFork mpio genesisBlock iop = do mineLine start ncounter len = evalStateT (mapM (const go) [startHeight :: Word64 .. (startHeight + len)]) start where - startHeight = fromIntegral $ _blockHeight start + startHeight = fromIntegral $ view blockHeight start go = do pblock <- gets ParentHeader n <- liftIO $ Nonce <$> readIORef ncounter @@ -231,7 +231,7 @@ firstPlayThrough mpio genesisBlock iop = do mineLine start ncounter len = evalStateT (mapM (const go) [startHeight :: Word64 .. (startHeight + len)]) start where - startHeight = fromIntegral $ _blockHeight start + startHeight = fromIntegral $ view blockHeight start go = do pblock <- gets ParentHeader n <- liftIO $ Nonce <$> readIORef ncounter @@ -284,11 +284,11 @@ testDeepForkLimit mpio (RewindLimit deepForkLimit) iop step = do let pdb = _bdbPayloadDb bdb step "query max db entry" maxblock <- maxEntry bhdb - pd <- lookupPayloadWithHeight pdb (Just $ _blockHeight maxblock) (_blockPayloadHash maxblock) >>= \case + pd <- lookupPayloadWithHeight pdb (Just $ view blockHeight maxblock) (view blockPayloadHash maxblock) >>= \case Nothing -> assertFailure "max block payload not found" Just x -> return x - step $ "max block has height " <> sshow (_blockHeight maxblock) - nonceCounterMain <- newIORef (fromIntegral $ _blockHeight maxblock) + step $ "max block has height " <> sshow (view blockHeight maxblock) + nonceCounterMain <- newIORef (fromIntegral $ view blockHeight maxblock) -- mine the main line a bit more step "mine (deepForkLimit + 1) many blocks on top of max block" @@ -305,11 +305,11 @@ testDeepForkLimit mpio (RewindLimit deepForkLimit) iop step = do mineLine start ncounter len = evalStateT (mapM (const go) [startHeight :: Word64 .. (startHeight + len)]) start where - startHeight = fromIntegral $ _blockHeight start + startHeight = fromIntegral $ view blockHeight start go = do pblock <- gets ParentHeader n <- liftIO $ Nonce <$> readIORef ncounter - liftIO $ step $ "mine block on top of height " <> sshow (_blockHeight $ _parentHeader pblock) + liftIO $ step $ "mine block on top of height " <> sshow (view blockHeight $ _parentHeader pblock) ret@(T3 _ newblock _) <- liftIO $ mineBlock pblock n iop liftIO $ modifyIORef' ncounter succ put newblock @@ -335,7 +335,7 @@ mineBlock ph nonce iop = timeout 5000000 go >>= \case let creationTime = BlockCreationTime . add (TimeSpan 1_000_000) - . _bct . _blockCreationTime + . _bct . view blockCreationTime $ _parentHeader ph let bh = newBlockHeader @@ -348,7 +348,7 @@ mineBlock ph nonce iop = timeout 5000000 go >>= \case _ <- validateBlock bh (CheckablePayloadWithOutputs payload) q let pdb = _bdbPayloadDb bdb - addNewPayload pdb (succ $ _blockHeight $ _parentHeader ph) payload + addNewPayload pdb (succ $ view blockHeight $ _parentHeader ph) payload bhdb <- getBlockHeaderDb cid bdb unsafeInsertBlockHeaderDb bhdb bh diff --git a/test/Chainweb/Test/Pact/PactSingleChainTest.hs b/test/Chainweb/Test/Pact/PactSingleChainTest.hs index ee0127485b..78755bc972 100644 --- a/test/Chainweb/Test/Pact/PactSingleChainTest.hs +++ b/test/Chainweb/Test/Pact/PactSingleChainTest.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} @@ -7,12 +6,10 @@ {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} module Chainweb.Test.Pact.PactSingleChainTest ( tests @@ -64,7 +61,7 @@ import Pact.JSON.Yaml import Chainweb.BlockCreationTime import Chainweb.BlockHash (BlockHash) -import Chainweb.BlockHeader +import Chainweb.BlockHeader.Internal import Chainweb.BlockHeight (BlockHeight(..)) import Chainweb.Graph import Chainweb.Logger (genericLogger) @@ -186,11 +183,11 @@ runBlockE q bdb timeOffset = do ph <- getParentTestBlockDb bdb cid bip <- throwIfNoHistory =<< newBlock noMiner NewBlockFill (ParentHeader ph) q let nb = blockInProgressToPayloadWithOutputs bip - let blockTime = add timeOffset $ _bct $ _blockCreationTime ph + let blockTime = add timeOffset $ _bct $ view blockCreationTime ph forM_ (chainIds testVersion) $ \c -> do let o | c == cid = nb | otherwise = emptyPayload - addTestBlockDb bdb (succ $ _blockHeight ph) (Nonce 0) (\_ _ -> blockTime) c o + addTestBlockDb bdb (succ $ view blockHeight ph) (Nonce 0) (\_ _ -> blockTime) c o nextH <- getParentTestBlockDb bdb cid try (validateBlock nextH (CheckablePayloadWithOutputs nb) q) @@ -246,11 +243,11 @@ newBlockAndContinue refIO reqIO = testCase "newBlockAndContinue" $ do (bipContinued /= bipFinal) let nbContinued = blockInProgressToPayloadWithOutputs bipFinal -- add block to database - let blockTime = add second $ _bct $ _blockCreationTime ph + let blockTime = add second $ _bct $ view blockCreationTime ph forM_ (chainIds testVersion) $ \c -> do let o | c == cid = nbContinued | otherwise = emptyPayload - addTestBlockDb bdb (succ $ _blockHeight ph) (Nonce 0) (\_ _ -> blockTime) c o + addTestBlockDb bdb (succ $ view blockHeight ph) (Nonce 0) (\_ _ -> blockTime) c o nextH <- getParentTestBlockDb bdb cid -- a continued block must be valid _ <- validateBlock nextH (CheckablePayloadWithOutputs nbContinued) q @@ -300,15 +297,16 @@ newBlockAndValidationFailure refIO reqIO = testCase "newBlockAndValidationFailur bip <- throwIfNoHistory =<< newBlock noMiner NewBlockFill (ParentHeader genesisHeader) q let nb = blockInProgressToPayloadWithOutputs bip - let blockTime = add second $ _bct $ _blockCreationTime genesisHeader + let blockTime = add second $ _bct $ view blockCreationTime genesisHeader forM_ (chainIds testVersion) $ \c -> do let o | c == cid = nb | otherwise = emptyPayload - addTestBlockDb bdb (succ $ _blockHeight genesisHeader) (Nonce 0) (\_ _ -> blockTime) c o + addTestBlockDb bdb (succ $ view blockHeight genesisHeader) (Nonce 0) (\_ _ -> blockTime) c o nextH <- getParentTestBlockDb bdb cid - let nextH' = nextH { _blockPayloadHash = BlockPayloadHash $ unsafeMerkleLogHash "0000000000000000000000000000001d" } + let nextH' = nextH + & blockPayloadHash .~ BlockPayloadHash (unsafeMerkleLogHash "0000000000000000000000000000001d") let nb' = nb { _payloadWithOutputsOutputsHash = BlockOutputsHash (unsafeMerkleLogHash "0000000000000000000000000000001d")} try (validateBlock nextH' (CheckablePayloadWithOutputs nb') q) >>= \case Left BlockValidationFailure {} -> do @@ -746,8 +744,8 @@ signSender00 = set cbSigners [mkEd25519Signer' sender00 []] setFromHeader :: BlockHeader -> CmdBuilder -> CmdBuilder setFromHeader bh = - set cbChainId (_blockChainId bh) - . set cbCreationTime (toTxCreationTime $ _bct $ _blockCreationTime bh) + set cbChainId (view blockChainId bh) + . set cbCreationTime (toTxCreationTime $ _bct $ view blockCreationTime bh) -- this test relies on block gas errors being thrown before other Pact errors. @@ -891,7 +889,7 @@ moduleNameMempool ns mn = mempty fmap V.fromList $ forM (zip txs [0..]) $ \(code,n :: Int) -> buildCwCmd ("1" <> sshow n) testVersion $ signSender00 $ - set cbCreationTime (toTxCreationTime $ _bct $ _blockCreationTime bh) $ + set cbCreationTime (toTxCreationTime $ _bct $ view blockCreationTime bh) $ set cbRPC (mkExec' code) $ defaultCmd @@ -931,7 +929,7 @@ mempoolCreationTimeTest mpRefIO reqIO = testCase "mempoolCreationTimeTest" $ do getBlock bh tx valid = do let txs = V.singleton tx - oks <- valid (_blockHeight bh) (_blockHash bh) txs + oks <- valid (view blockHeight bh) (view blockHash bh) txs unless (V.and oks) $ throwM $ userError "Insert failed" return txs diff --git a/test/Chainweb/Test/Pact/SPV.hs b/test/Chainweb/Test/Pact/SPV.hs index 0cb7467ab2..f12117d35a 100644 --- a/test/Chainweb/Test/Pact/SPV.hs +++ b/test/Chainweb/Test/Pact/SPV.hs @@ -282,8 +282,8 @@ roundtrip' v sid0 tid0 burn create step = withTestBlockDb v $ \bdb -> do -- setup create txgen with cut 1 step "setup create txgen with cut 1" - (BlockCreationTime t2) <- _blockCreationTime <$> getParentTestBlockDb bdb tid - hi <- _blockHeight <$> getParentTestBlockDb bdb sid + (BlockCreationTime t2) <- view blockCreationTime <$> getParentTestBlockDb bdb tid + hi <- view blockHeight <$> getParentTestBlockDb bdb sid txGen2 <- create v t2 bdb pidv sid tid hi -- cut 2: empty cut for diameter 1 @@ -317,7 +317,7 @@ cutToPayloadOutputs -> IO CutOutputs cutToPayloadOutputs c pdb = do forM (_cutMap c) $ \bh -> do - Just pwo <- lookupPayloadWithHeight pdb (Just $ _blockHeight bh) (_blockPayloadHash bh) + Just pwo <- lookupPayloadWithHeight pdb (Just $ view blockHeight bh) (view blockPayloadHash bh) let txs = Vector.map (toTx *** toCR) (_payloadWithOutputsTransactions pwo) toTx :: Transaction -> Command Text toTx (Transaction t) = fromJuste $ decodeStrict' t @@ -329,7 +329,7 @@ chainToMPA' :: MVar TransactionGenerator -> MemPoolAccess chainToMPA' f = mempty { mpaGetBlock = \_g _pc hi ha he -> do tg <- readMVar f - tg (_blockChainId he) hi ha he + tg (view blockChainId he) hi ha he } diff --git a/test/Chainweb/Test/Pact/TTL.hs b/test/Chainweb/Test/Pact/TTL.hs index 461e1e0020..8f34c9fa7f 100644 --- a/test/Chainweb/Test/Pact/TTL.hs +++ b/test/Chainweb/Test/Pact/TTL.hs @@ -1,18 +1,15 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} module Chainweb.Test.Pact.TTL ( tests ) where import Control.Concurrent.MVar -import Control.Lens (set) +import Control.Lens (set, view) import Control.Monad import Control.Monad.Catch @@ -178,7 +175,7 @@ modAt f = modAtTtl f defTtl modAtTtl :: (Time Micros -> Time Micros) -> Seconds -> MemPoolAccess modAtTtl f (Seconds t) = mempty { mpaGetBlock = \_ validate bh hash ph -> do - let txTime = toTxCreationTime $ f $ _bct $ _blockCreationTime ph + let txTime = toTxCreationTime $ f $ _bct $ view blockCreationTime ph tt = TTLSeconds (int t) outtxs <- fmap V.singleton $ buildCwCmd (sshow bh) testVer $ set cbCreationTime txTime @@ -227,7 +224,7 @@ doNewBlock ctxIO mempool parent nonce t = do let creationTime = BlockCreationTime . add (secondsToTimeSpan t) -- 10 seconds - . _bct . _blockCreationTime + . _bct . view blockCreationTime $ _parentHeader parent bh = newBlockHeader mempty @@ -249,7 +246,7 @@ doValidateBlock doValidateBlock ctxIO header payload = do ctx <- ctxIO _mv' <- validateBlock header (CheckablePayloadWithOutputs payload) $ _ctxQueue ctx - addNewPayload (_ctxPdb ctx) (_blockHeight header) payload + addNewPayload (_ctxPdb ctx) (view blockHeight header) payload unsafeInsertBlockHeaderDb (_ctxBdb ctx) header -- FIXME FIXME FIXME: do at least some checks? diff --git a/test/Chainweb/Test/Pact/TransactionTests.hs b/test/Chainweb/Test/Pact/TransactionTests.hs index 3a215377ce..144ef7aaa0 100644 --- a/test/Chainweb/Test/Pact/TransactionTests.hs +++ b/test/Chainweb/Test/Pact/TransactionTests.hs @@ -50,7 +50,7 @@ import Pact.Types.SPV -- internal chainweb modules import Chainweb.BlockCreationTime -import Chainweb.BlockHeader +import Chainweb.BlockHeader.Internal import Chainweb.BlockHeight import Chainweb.Logger import Chainweb.Miner.Pact @@ -281,8 +281,8 @@ testCoinbase797DateFix = testCaseSteps "testCoinbase791Fix" $ \step -> do -- of mining a full chain we fake the height. -- mkTestParentHeader :: BlockHeight -> ParentHeader - mkTestParentHeader h = ParentHeader $ (someBlockHeader (slowForkingCpmTestVersion singleton) 10) - { _blockHeight = h } + mkTestParentHeader h = ParentHeader $ someBlockHeader (slowForkingCpmTestVersion singleton) 10 + & blockHeight .~ h testCoinbaseEnforceFailure :: Assertion testCoinbaseEnforceFailure = do @@ -301,9 +301,8 @@ testCoinbaseEnforceFailure = do badMiner = Miner (MinerId "") (MinerKeys $ mkKeySet [] "<") blockHeight' = 123 someParentHeader = ParentHeader $ someTestVersionHeader - { _blockHeight = blockHeight' - , _blockCreationTime = BlockCreationTime [timeMicrosQQ| 2019-12-10T01:00:00.0 |] - } + & blockHeight .~ blockHeight' + & blockCreationTime .~ BlockCreationTime [timeMicrosQQ| 2019-12-10T01:00:00.0 |] testCoinbaseUpgradeDevnet :: V.ChainId -> BlockHeight -> Assertion testCoinbaseUpgradeDevnet cid upgradeHeight = @@ -371,11 +370,11 @@ testUpgradeScript script cid bh test = do Left e -> assertFailure $ "tx execution failed: " ++ show e Right cr -> test cr where - parent = ParentHeader (someBlockHeader v bh) - { _blockChainwebVersion = _versionCode v - , _blockChainId = cid - , _blockHeight = pred bh - } + parent = ParentHeader $ someBlockHeader v bh + & blockChainwebVersion .~ _versionCode v + & blockChainId .~ cid + & blockHeight .~ pred bh + matchLogs :: [(Text, Text, Maybe Value)] -> [(Text, Text, Maybe Value)] -> IO () matchLogs expectedResults actualResults | length actualResults /= length expectedResults = void $ diff --git a/test/Chainweb/Test/Pact/Utils.hs b/test/Chainweb/Test/Pact/Utils.hs index b36c8e1a3f..40038799c2 100644 --- a/test/Chainweb/Test/Pact/Utils.hs +++ b/test/Chainweb/Test/Pact/Utils.hs @@ -786,7 +786,7 @@ runCut v bdb pact genTime noncer miner = n <- noncer cid -- skip this chain if mining fails and retry with the next chain. - whenM (addTestBlockDb bdb (succ $ _blockHeight $ _parentHeader ph) n genTime cid pout) $ do + whenM (addTestBlockDb bdb (succ $ view blockHeight $ _parentHeader ph) n genTime cid pout) $ do h <- getParentTestBlockDb bdb cid void $ _webPactValidateBlock pact h (CheckablePayloadWithOutputs pout) @@ -1093,6 +1093,6 @@ compactUntilAvailable target logger db flags = do getPWOByHeader :: BlockHeader -> TestBlockDb -> IO PayloadWithOutputs getPWOByHeader h (TestBlockDb _ pdb _) = - lookupPayloadWithHeight pdb (Just $ _blockHeight h) (_blockPayloadHash h) >>= \case + lookupPayloadWithHeight pdb (Just $ view blockHeight h) (view blockPayloadHash h) >>= \case Nothing -> throwM $ userError "getPWOByHeader: payload not found" Just pwo -> return pwo diff --git a/test/Chainweb/Test/Pact/VerifierPluginTest/Transaction/Utils.hs b/test/Chainweb/Test/Pact/VerifierPluginTest/Transaction/Utils.hs index 32caa02df8..030371c2b4 100644 --- a/test/Chainweb/Test/Pact/VerifierPluginTest/Transaction/Utils.hs +++ b/test/Chainweb/Test/Pact/VerifierPluginTest/Transaction/Utils.hs @@ -130,7 +130,7 @@ filterBlock f (MempoolBlock b) = MempoolBlock $ \mi -> blockForChain :: ChainId -> MempoolBlock -> MempoolBlock blockForChain chid = filterBlock $ \bh -> - _blockChainId bh == chid + view blockChainId bh == chid runCut' :: PactTestM () runCut' = do @@ -189,7 +189,7 @@ runToHeight :: BlockHeight -> PactTestM () runToHeight bhi = do chid <- view menvChainId bh <- getHeader chid - when (_blockHeight bh < bhi) $ do + when (view blockHeight bh < bhi) $ do runCut' runToHeight bhi @@ -198,8 +198,8 @@ signSender00 = set cbSigners [mkEd25519Signer' sender00 []] setFromHeader :: BlockHeader -> CmdBuilder -> CmdBuilder setFromHeader bh = - set cbChainId (_blockChainId bh) - . set cbCreationTime (toTxCreationTime $ _bct $ _blockCreationTime bh) + set cbChainId (view blockChainId bh) + . set cbCreationTime (toTxCreationTime $ _bct $ view blockCreationTime bh) buildBasic :: PactRPC T.Text @@ -225,7 +225,7 @@ getPWO :: ChainId -> PactTestM (PayloadWithOutputs,BlockHeader) getPWO chid = do (TestBlockDb _ pdb _) <- view menvBdb h <- getHeader chid - Just pwo <- liftIO $ lookupPayloadWithHeight pdb (Just $ _blockHeight h) (_blockPayloadHash h) + Just pwo <- liftIO $ lookupPayloadWithHeight pdb (Just $ view blockHeight h) (view blockPayloadHash h) return (pwo,h) getHeader :: ChainId -> PactTestM BlockHeader diff --git a/test/Chainweb/Test/RestAPI.hs b/test/Chainweb/Test/RestAPI.hs index 68df76041f..d1deea3e84 100644 --- a/test/Chainweb/Test/RestAPI.hs +++ b/test/Chainweb/Test/RestAPI.hs @@ -241,7 +241,7 @@ simpleClientSession envIO cid = void $ liftIO $ step "put 3 new blocks" let newHeaders = take 3 $ testBlockHeaders (ParentHeader gbh0) liftIO $ traverse_ (unsafeInsertBlockHeaderDb bhdb) newHeaders - liftIO $ traverse_ (\x -> addNewPayload pdb (_blockHeight x) (testBlockPayload_ x)) newHeaders + liftIO $ traverse_ (\x -> addNewPayload pdb (view blockHeight x) (testBlockPayload_ x)) newHeaders void $ liftIO $ step "headersClient: get all 4 block headers" bhs2 <- headersClient version cid Nothing Nothing Nothing Nothing @@ -265,7 +265,7 @@ simpleClientSession envIO cid = (Actual $ _pageItems hs2) forM_ newHeaders $ \h -> do - void $ liftIO $ step $ "headerClient: " <> T.unpack (encodeToText (_blockHash h)) + void $ liftIO $ step $ "headerClient: " <> T.unpack (encodeToText (view blockHash h)) r <- headerClient version cid (key h) assertExpectation "header client returned wrong entry" (Expected h) @@ -406,7 +406,7 @@ simpleClientSession envIO cid = void $ liftIO $ step "headerPutClient: put 3 new blocks on a new fork" let newHeaders2 = take 3 $ testBlockHeadersWithNonce (Nonce 17) (ParentHeader gbh0) liftIO $ traverse_ (unsafeInsertBlockHeaderDb bhdb) newHeaders2 - liftIO $ traverse_ (\x -> addNewPayload pdb (_blockHeight x) (testBlockPayload_ x)) newHeaders2 + liftIO $ traverse_ (\x -> addNewPayload pdb (view blockHeight x) (testBlockPayload_ x)) newHeaders2 let lower = last newHeaders forM_ ([1..] `zip` newHeaders2) $ \(i, h) -> do diff --git a/test/Chainweb/Test/SPV.hs b/test/Chainweb/Test/SPV.hs index 7db7d26c2c..e91ba937ff 100644 --- a/test/Chainweb/Test/SPV.hs +++ b/test/Chainweb/Test/SPV.hs @@ -125,10 +125,10 @@ targetChain c srcBlock = do <> ". current cut: " <> sshow c go (h:t) = if isReachable h then return h else go t - chainHeight trgChain = _blockHeight (c ^?! ixg trgChain) + chainHeight trgChain = view blockHeight (c ^?! ixg trgChain) isReachable trgChain - = _blockHeight srcBlock <= chainHeight trgChain - distance trgChain + = view blockHeight srcBlock <= chainHeight trgChain - distance trgChain distance x = len $ shortestPath (_chainId srcBlock) x graph @@ -221,7 +221,7 @@ spvTest rdb v step = do -- for each blockheader h in cut samples <- S.each (toList curCut) -- for each ancestor ah of h - & flip S.for (\h -> ancestors (cutDb ^?! cutDbBlockHeaderDb h) (_blockHash h)) + & flip S.for (\h -> ancestors (cutDb ^?! cutDbBlockHeaderDb h) (view blockHash h)) -- for each transaction in ah & flip S.for (getPayloads cutDb) -- for each target chain c @@ -256,7 +256,7 @@ spvTest rdb v step = do -> BlockHeader -> S.Stream (Of (BlockHeader, Int, Int, TransactionOutput)) IO () getPayloads cutDb h = do - Just pay <- liftIO $ lookupPayloadWithHeight (view cutDbPayloadDb cutDb) (Just $ _blockHeight h) (_blockPayloadHash h) + Just pay <- liftIO $ lookupPayloadWithHeight (view cutDbPayloadDb cutDb) (Just $ view blockHeight h) (view blockPayloadHash h) let n = length $ _payloadWithOutputsTransactions pay S.each (zip [0..] $ fmap snd $ toList $ _payloadWithOutputsTransactions pay) & S.map (\(b,c) -> (h,n,b,c)) @@ -286,7 +286,7 @@ spvTest rdb v step = do -- create inclusion proof for transaction proof <- createTransactionOutputProof cutDb trgChain (_chainId h) -- source chain - (_blockHeight h) -- source block height + (view blockHeight h) -- source block height txIx -- transaction index subj <- verifyTransactionOutputProof cutDb proof assertEqual "transaction output proof subject matches transaction" txOut subj @@ -295,7 +295,7 @@ spvTest rdb v step = do return [ int $ BL.length $ encode proof , int n - , int $ _blockHeight h + , int $ view blockHeight h , int $ distance cutDb h trgChain , int $ B.length (_transactionOutputBytes txOut) ] @@ -304,14 +304,14 @@ spvTest rdb v step = do try inner >>= \case Right x -> do let msg = "SPV proof creation succeeded although target chain is not reachable (" - <> "source height: " <> sshow (_blockHeight h) + <> "source height: " <> sshow (view blockHeight h) <> ", distance: " <> sshow (distance cutDb h trgChain) <> ")" assertBool msg isReachable return (Just x) Left SpvExceptionTargetNotReachable{} -> do let msg = "SPV proof creation failed although target chain is reachable (" - <> "source height: " <> sshow (_blockHeight h) + <> "source height: " <> sshow (view blockHeight h) <> ", distance: " <> sshow (distance cutDb h trgChain) <> ")" assertBool msg (not isReachable) @@ -322,14 +322,14 @@ spvTest rdb v step = do -- distance cutDb h trgChain = length $ shortestPath (_chainId h) trgChain - $ chainGraphAt cutDb (_blockHeight h) + $ chainGraphAt cutDb (view blockHeight h) -- Check whether target chain is reachable from the source block -- reachable :: CutDb as -> BlockHeader -> ChainId -> IO Bool reachable cutDb h trgChain = do m <- maxRank $ cutDb ^?! cutDbBlockHeaderDb trgChain - return $ (int m - int (_blockHeight h)) >= distance cutDb h trgChain + return $ (int m - int (view blockHeight h)) >= distance cutDb h trgChain -- regression model with @createTransactionOutputProof@. Proof size doesn't -- depend on target height. @@ -373,7 +373,7 @@ spvTransactionRoundtripTest rdb v step = do -- target chain (_chainId h) -- source chain - (_blockHeight h) + (view blockHeight h) -- source block height txIx -- transaction index @@ -409,7 +409,7 @@ spvTransactionOutputRoundtripTest rdb v step = do -- target chain (_chainId h) -- source chain - (_blockHeight h) + (view blockHeight h) -- source block height outIx -- transaction index @@ -451,7 +451,7 @@ txApiTests envIO step = do step "pick random transaction" (h, txIx, tx, out) <- randomTransaction cutDb - step $ "picked random transaction, height: " <> sshow (_blockHeight h) <> ", ix: " <> sshow txIx + step $ "picked random transaction, height: " <> sshow (view blockHeight h) <> ", ix: " <> sshow txIx curCut <- _cut cutDb trgChain <- targetChain curCut h @@ -461,7 +461,7 @@ txApiTests envIO step = do step "request transaction proof" txProof <- flip runClientM env $ - spvGetTransactionProofClient v trgChain (_chainId h) (_blockHeight h) (int txIx) + spvGetTransactionProofClient v trgChain (_chainId h) (view blockHeight h) (int txIx) case txProof of @@ -479,7 +479,7 @@ txApiTests envIO step = do step "request transaction output proof" outProof <- flip runClientM env $ - spvGetTransactionOutputProofClient v trgChain (_chainId h) (_blockHeight h) (int txIx) + spvGetTransactionOutputProofClient v trgChain (_chainId h) (view blockHeight h) (int txIx) case outProof of diff --git a/test/Chainweb/Test/TreeDB.hs b/test/Chainweb/Test/TreeDB.hs index 47348f925a..aca17c229a 100644 --- a/test/Chainweb/Test/TreeDB.hs +++ b/test/Chainweb/Test/TreeDB.hs @@ -41,7 +41,7 @@ import Test.Tasty.QuickCheck -- internal modules -import Chainweb.BlockHeader +import Chainweb.BlockHeader.Internal import Chainweb.BlockHeader.Validation import Chainweb.Test.Utils import Chainweb.Test.Utils.BlockHeader @@ -217,7 +217,7 @@ maxRank_prop -> Property maxRank_prop f (SparseTree t0) = ioProperty . withTreeDb f t $ \db _ -> do r <- maxRank db - let h = fromIntegral . maximum . (^.. each . isoBH . to _blockHeight) $ treeLeaves t + let h = fromIntegral . maximum . (^.. each . isoBH . to (view blockHeight)) $ treeLeaves t pure $ r == h where t :: Tree (DbEntry db) @@ -234,8 +234,8 @@ entryOrder_prop f (SparseTree t0) = ioProperty . withTreeDb f t $ \db _ -> do hs <- entries db Nothing Nothing Nothing Nothing $ P.toList_ . P.map (^. isoBH) pure . isJust $ foldlM g S.empty hs where - g acc h = let acc' = S.insert (_blockHash h) acc - in bool Nothing (Just acc') $ isGenesisBlockHeader h || S.member (_blockParent h) acc' + g acc h = let acc' = S.insert (view blockHash h) acc + in bool Nothing (Just acc') $ isGenesisBlockHeader h || S.member (view blockParent h) acc' t :: Tree (DbEntry db) t = fmap (^. from isoBH) t0 @@ -369,7 +369,7 @@ prop_getBranchIncreasing_parents f (SparseTree t0) = forAll (int <$> choose (0,m ioProperty $ withTreeDb f t $ \db _ -> do e <- maxEntry db branch <- getBranchIncreasing db e i $ \s -> P.toList_ $ P.map (view isoBH) s - return $ and $ zipWith (\a b -> _blockHash a == _blockParent b) branch (drop 1 branch) + return $ and $ zipWith (\a b -> view blockHash a == view blockParent b) branch (drop 1 branch) where m = length $ levels t0 t = fmap (^. from isoBH) t0 diff --git a/test/Chainweb/Test/Utils.hs b/test/Chainweb/Test/Utils.hs index 328de94b22..73688b08db 100644 --- a/test/Chainweb/Test/Utils.hs +++ b/test/Chainweb/Test/Utils.hs @@ -399,8 +399,8 @@ prettyTree :: Tree BlockHeader -> String prettyTree = drawTree . fmap f where f h = printf "%d - %s" - (coerce @BlockHeight @Word64 $ _blockHeight h) - (take 12 . drop 1 . show $ _blockHash h) + (coerce @BlockHeight @Word64 $ view blockHeight h) + (take 12 . drop 1 . show $ view blockHash h) normalizeTree :: Ord a => Tree a -> Tree a normalizeTree n@(Node _ []) = n @@ -440,7 +440,7 @@ genesis v = either (error . sshow) return $ genesisBlockHeaderForChain v 0 forest :: Growth -> BlockHeader -> Gen (Forest BlockHeader) forest Randomly h = randomTrunk h -forest g@(AtMost n) h | n < _blockHeight h = pure [] +forest g@(AtMost n) h | n < view blockHeight h = pure [] | otherwise = fixedTrunk g h fixedTrunk :: Growth -> BlockHeader -> Gen (Forest BlockHeader) @@ -472,18 +472,18 @@ header p = do . newMerkleLog $ mkFeatureFlags :+: t' - :+: _blockHash p + :+: view blockHash p :+: target :+: casKey (testBlockPayloadFromParent (ParentHeader p)) :+: _chainId p - :+: BlockWeight (targetToDifficulty target) + _blockWeight p - :+: succ (_blockHeight p) + :+: BlockWeight (targetToDifficulty target) + view blockWeight p + :+: succ (view blockHeight p) :+: _versionCode v :+: epochStart (ParentHeader p) mempty t' :+: nonce :+: MerkleLogBody mempty where - BlockCreationTime t = _blockCreationTime p + BlockCreationTime t = view blockCreationTime p target = powTarget (ParentHeader p) mempty t' v = _chainwebVersion p t' = BlockCreationTime (scaleTimeSpan (10 :: Int) second `add` t) diff --git a/test/Chainweb/Test/Utils/BlockHeader.hs b/test/Chainweb/Test/Utils/BlockHeader.hs index ec93a8d6de..785ed0c50e 100644 --- a/test/Chainweb/Test/Utils/BlockHeader.hs +++ b/test/Chainweb/Test/Utils/BlockHeader.hs @@ -69,7 +69,7 @@ testPayload n = newPayloadWithOutputs testBlockPayloadFromParent :: ParentHeader -> PayloadWithOutputs testBlockPayloadFromParent (ParentHeader b) = testPayload $ B8.intercalate "," [ sshow (_chainwebVersion b) - , sshow (_blockHeight b + 1) + , sshow (view blockHeight b + 1) ] -- | Generate a test payload for a given header. Includes the block height of @@ -81,7 +81,7 @@ testBlockPayloadFromParent (ParentHeader b) = testPayload $ B8.intercalate "," testBlockPayload :: BlockHeader -> PayloadWithOutputs testBlockPayload b = testPayload $ B8.intercalate "," [ sshow (_chainwebVersion b) - , sshow (_blockHeight b) + , sshow (view blockHeight b) ] -- | Generate a test payload for a given parent header. Includes the block @@ -94,7 +94,7 @@ testBlockPayload b = testPayload $ B8.intercalate "," testBlockPayloadFromParent_ :: Nonce -> ParentHeader -> PayloadWithOutputs testBlockPayloadFromParent_ n (ParentHeader b) = testPayload $ B8.intercalate "," [ sshow (_chainwebVersion b) - , sshow (_blockHeight b + 1) + , sshow (view blockHeight b + 1) , sshow n ] @@ -107,8 +107,8 @@ testBlockPayloadFromParent_ n (ParentHeader b) = testPayload $ B8.intercalate ", testBlockPayload_ :: BlockHeader -> PayloadWithOutputs testBlockPayload_ b = testPayload $ B8.intercalate "," [ sshow (_chainwebVersion b) - , sshow (_blockHeight b) - , sshow (_blockNonce b) + , sshow (view blockHeight b) + , sshow (view blockNonce b) ] -- -------------------------------------------------------------------------- -- @@ -140,7 +140,7 @@ testBlockHeader adj nonce p@(ParentHeader b) = newBlockHeader adj payload nonce (BlockCreationTime $ add second t) p where payload = _payloadWithOutputsPayloadHash $ testBlockPayloadFromParent_ nonce p - BlockCreationTime t = _blockCreationTime b + BlockCreationTime t = view blockCreationTime b -- | Given a `BlockHeader` of some initial parent, generate an infinite stream -- of `BlockHeader`s which form a legal chain. @@ -150,7 +150,7 @@ testBlockHeader adj nonce p@(ParentHeader b) = testBlockHeaders :: ParentHeader -> [BlockHeader] testBlockHeaders (ParentHeader p) = L.unfoldr (Just . (id &&& id) . f) p where - f b = testBlockHeader mempty (_blockNonce b) $ ParentHeader b + f b = testBlockHeader mempty (view blockNonce b) $ ParentHeader b -- | Given a `BlockHeader` of some initial parent, generate an infinite stream -- of `BlockHeader`s which form a legal chain. diff --git a/test/Chainweb/Test/Utils/TestHeader.hs b/test/Chainweb/Test/Utils/TestHeader.hs index 59f11c3f51..7eb9a858d9 100644 --- a/test/Chainweb/Test/Utils/TestHeader.hs +++ b/test/Chainweb/Test/Utils/TestHeader.hs @@ -93,9 +93,9 @@ testHeaderLookup testHdr x = lookup x tbl p = _parentHeader $ _testHeaderParent testHdr a = _testHeaderAdjs testHdr tbl - = (_blockHash h, h) - : (_blockHash p, p) - : fmap (\(ParentHeader b) -> (_blockHash b, b)) a + = (view blockHash h, h) + : (view blockHash p, p) + : fmap (\(ParentHeader b) -> (view blockHash b, b)) a instance FromJSON TestHeader where parseJSON = withObject "TestHeader" $ \o -> TestHeader @@ -149,7 +149,7 @@ arbitraryTestHeaderHeight v cid h = do $ adjacentChainIds (chainGraphAt v h) cid nonce <- arbitrary payloadHash <- arbitrary - let pt = maximum $ _bct . _blockCreationTime + let pt = maximum $ _bct . view blockCreationTime <$> HM.insert cid (_parentHeader parent) as t <- BlockCreationTime <$> chooseEnum (pt, maxBound) return $ TestHeader diff --git a/test/Chainweb/Test/Version.hs b/test/Chainweb/Test/Version.hs index 97e4bf48ec..942bcc0af2 100644 --- a/test/Chainweb/Test/Version.hs +++ b/test/Chainweb/Test/Version.hs @@ -15,6 +15,7 @@ module Chainweb.Test.Version ( tests ) where +import Control.Lens (view) import qualified Data.ByteString as B import Data.Foldable import qualified Data.List.NonEmpty as NE @@ -107,7 +108,7 @@ prop_headerBaseSizeBytes v = property $ do cid <- elements $ toList $ chainIds v let genHdr = genesisBlockHeader v cid gen = runPutS $ encodeBlockHeader genHdr - as = runPutS $ encodeBlockHashRecord (_blockAdjacentHashes genHdr) + as = runPutS $ encodeBlockHashRecord (view blockAdjacentHashes genHdr) return $ _versionHeaderBaseSizeBytes v === int (B.length gen - B.length as) prop_headerSizes_sorted :: ChainwebVersion -> Property @@ -126,7 +127,7 @@ prop_headerSizeBytes_gen v = property $ do l = int $ B.length $ runPutS $ encodeBlockHeader $ hdr return $ counterexample ("chain: " <> sshow cid) - $ headerSizeBytes v cid (_blockHeight hdr) === l + $ headerSizeBytes v cid (view blockHeight hdr) === l prop_headerSizeBytes :: ChainwebVersion -> Property prop_headerSizeBytes v = property $ do @@ -134,15 +135,15 @@ prop_headerSizeBytes v = property $ do let l = int $ B.length $ runPutS $ encodeBlockHeader h return $ counterexample ("header: " <> sshow h) - $ headerSizeBytes (_chainwebVersion h) (_blockChainId h) (_blockHeight h) === l + $ headerSizeBytes (_chainwebVersion h) (view blockChainId h) (view blockHeight h) === l prop_workSizeBytes :: ChainwebVersion -> Property prop_workSizeBytes v = property $ do h <- arbitraryBlockHeaderVersion v - if (_blockHeight h == genesisHeight v (_chainId h)) + if (view blockHeight h == genesisHeight v (_chainId h)) then discard else do let l = int $ B.length $ runPutS $ encodeBlockHeaderWithoutHash h return $ counterexample ("header: " <> sshow h) - $ workSizeBytes (_chainwebVersion h) (_blockHeight h) === l + $ workSizeBytes (_chainwebVersion h) (view blockHeight h) === l diff --git a/tools/cwtool/TxSimulator.hs b/tools/cwtool/TxSimulator.hs index 472d9abc4f..a500fc7238 100644 --- a/tools/cwtool/TxSimulator.hs +++ b/tools/cwtool/TxSimulator.hs @@ -247,7 +247,7 @@ spvSim sc bh pwo = do go mv cp = modifyMVar mv $ searchOuts cp searchOuts _ [] = return ([],Left "spv: proof not found") searchOuts cp@(ContProof pf) ((Transaction ti,TransactionOutput _o):txs) = - case codecDecode (chainwebPayloadCodec (pactParserVersion (scVersion sc) (_chainId bh) (_blockHeight bh))) ti of + case codecDecode (chainwebPayloadCodec (pactParserVersion (scVersion sc) (_chainId bh) (view blockHeight bh))) ti of Left {} -> internalError "input decode failed" Right cmd -> case _pPayload $ payloadObj $ _cmdPayload cmd of Continuation cm | _cmProof cm == Just cp -> do @@ -287,7 +287,7 @@ fetchHeaders sc cenv = do fetchOutputs :: SimConfig -> ClientEnv -> [BlockHeader] -> IO [PayloadWithOutputs] fetchOutputs sc cenv bhs = do r <- (`runClientM` cenv) $ do - outputsBatchClient (scVersion sc) (scChain sc) (WithHeights $ map (\bh -> (_blockHeight bh, _blockPayloadHash bh)) bhs) + outputsBatchClient (scVersion sc) (scChain sc) (WithHeights $ map (\bh -> (view blockHeight bh, view blockPayloadHash bh)) bhs) case r of Left e -> throwM e Right ps -> return (_payloadWithOutputsList ps) diff --git a/tools/header-dump/HeaderDump.hs b/tools/header-dump/HeaderDump.hs index 5255799fca..77afd13a47 100644 --- a/tools/header-dump/HeaderDump.hs +++ b/tools/header-dump/HeaderDump.hs @@ -491,10 +491,10 @@ validate s = do -> (BlockHeight, [BlockHeader], [BlockHeader], Bool) update (h, parents, currents, i) c -- initially set the block height to the current header - | i = (_blockHeight c, parents, c : currents, i) - | _blockHeight c == h = (h, parents, c : currents, i) - | _blockHeight c == (h + 1) = (h + 1, currents, [c], False) - | _blockHeight c < h = error "height invariant violation in enumeration of headers. Height of current header smaller than previous headers" + | i = (view blockHeight c, parents, c : currents, i) + | view blockHeight c == h = (h, parents, c : currents, i) + | view blockHeight c == (h + 1) = (h + 1, currents, [c], False) + | view blockHeight c < h = error "height invariant violation in enumeration of headers. Height of current header smaller than previous headers" | otherwise = error $ "height invariant violation in enumeration of headers." <> " Height of current header skips block height." @@ -508,7 +508,7 @@ validate s = do => [BlockHeader] -> ChainValue BlockHash -> m (Maybe BlockHeader) - lookupHdr hdrs h = pure $ find ((== _chainValueValue h) . _blockHash) hdrs + lookupHdr hdrs h = pure $ find ((== _chainValueValue h) . view blockHash) hdrs val :: Time Micros @@ -527,8 +527,8 @@ progress :: LogFunctionText -> S.Stream (Of BlockHeader) IO a -> S.Stream (Of Bl progress logg s = s & S.chain (logg Debug . sshow) & S.chain - (\x -> when (_blockHeight x `mod` 100 == 0) $ - logg Info ("BlockHeight: " <> sshow (_blockHeight x)) + (\x -> when (view blockHeight x `mod` 100 == 0) $ + logg Info ("BlockHeight: " <> sshow (view blockHeight x)) ) miner :: MonadThrow m @@ -545,12 +545,12 @@ payloadsCid -> BlockHeader -> m (ChainData PayloadWithOutputs) payloadsCid pdb bh = do - payload <- liftIO $ lookupPayloadWithHeight pdb (Just $ _blockHeight bh) (_blockPayloadHash bh) >>= \case + payload <- liftIO $ lookupPayloadWithHeight pdb (Just $ view blockHeight bh) (view blockPayloadHash bh) >>= \case Nothing -> throwM $ userError "payload not found" Just p -> return p pure $ ChainData - { _cdChainId = _blockChainId bh - , _cdHeight = _blockHeight bh + { _cdChainId = view blockChainId bh + , _cdHeight = view blockHeight bh , _cdData = payload } @@ -640,7 +640,7 @@ withChainDbs rdb v cids doValidation start end f = go cids mempty go [] !s = f s go (cid:t) !s = withBlockHeaderDb rdb v cid $ \cdb -> entries cdb Nothing Nothing start end $ \x -> - go t (() <$ S.mergeOn _blockHeight s (val $ () <$ x)) + go t (() <$ S.mergeOn (view blockHeight) s (val $ () <$ x)) val = if doValidation then validate else id diff --git a/tools/txstream/TxStream.hs b/tools/txstream/TxStream.hs index 55dd2812b6..e3b2516e0c 100644 --- a/tools/txstream/TxStream.hs +++ b/tools/txstream/TxStream.hs @@ -257,10 +257,10 @@ txStream config mgr logg = do getBranch hdb mempty (HS.singleton (UpperBound h)) & S.chain (logg @T.Text Debug . sshow) & S.chain - (\x -> when (_blockHeight x `mod` 100 == 0) $ - logg @T.Text Info ("BlockHeight: " <> sshow (_blockHeight x)) + (\x -> when (view blockHeight x `mod` 100 == 0) $ + logg @T.Text Info ("BlockHeight: " <> sshow (view blockHeight x)) ) - & S.mapM (\x -> (_blockHeight x,) <$> devNetPayload config mgr (_blockHeight x) (_blockPayloadHash x)) + & S.mapM (\x -> (view blockHeight x,) <$> devNetPayload config mgr (view blockHeight x) (view blockPayloadHash x)) & flip S.for (S.each . traverse _payloadDataTransactions) & S.map (fmap _transactionBytes) & S.mapM (traverse decodeStrictOrThrow') @@ -312,11 +312,11 @@ txOutputsStream config mgr logg = do getBranch hdb mempty (HS.singleton (UpperBound h)) & S.chain (logg @T.Text Debug . sshow) & S.chain - (\x -> when (_blockHeight x `mod` 100 == 0) $ - logg @T.Text Info ("BlockHeight: " <> sshow (_blockHeight x)) + (\x -> when (view blockHeight x `mod` 100 == 0) $ + logg @T.Text Info ("BlockHeight: " <> sshow (view blockHeight x)) ) - & S.mapM (\x -> (_blockHeight x,) <$> devNetPayloadWithOutput config mgr (_blockHeight x) (_blockPayloadHash x)) + & S.mapM (\x -> (view blockHeight x,) <$> devNetPayloadWithOutput config mgr (view blockHeight x) (view blockPayloadHash x)) & flip S.for ( S.each . traverse _payloadWithOutputsTransactions