From 3394f73057898f86e2682d9fbb09f1bb6ff6a986 Mon Sep 17 00:00:00 2001 From: chessai Date: Wed, 20 Nov 2024 18:10:57 -0600 Subject: [PATCH 1/4] Add expiration to SPV output proofs Change-Id: I81f175cee19c8a19a1a14af0beb0f7bdef3cb9c3 wip spv expiration Change-Id: If3ae29fb08b9c0b20db330a3953bde9c8b4bddc6 spv proof expiration test fix Change-Id: I5965386a4594281855bf4afbdc1a824aa6ddff48 --- chainweb.cabal | 1 + src/Chainweb/Crypto/MerkleLog.hs | 2 +- .../Pact/Backend/RelationalCheckpointer.hs | 4 + src/Chainweb/Pact/SPV.hs | 38 +-- src/Chainweb/Pact/Types.hs | 2 - src/Chainweb/SPV.hs | 12 +- src/Chainweb/SPV/VerifyProof.hs | 71 +++-- src/Chainweb/Version.hs | 3 + src/Chainweb/Version/Development.hs | 2 + src/Chainweb/Version/Guards.hs | 9 + src/Chainweb/Version/Mainnet.hs | 4 + src/Chainweb/Version/RecapDevelopment.hs | 2 + src/Chainweb/Version/Testnet.hs | 4 + test/lib/Chainweb/Test/TestVersions.hs | 1 + .../Chainweb/Test/Pact/PactSingleChainTest.hs | 286 +++++++++++++++++- test/unit/Chainweb/Test/Pact/SPV.hs | 1 - 16 files changed, 387 insertions(+), 55 deletions(-) diff --git a/chainweb.cabal b/chainweb.cabal index 58a440fab2..fc9beb73f1 100644 --- a/chainweb.cabal +++ b/chainweb.cabal @@ -677,6 +677,7 @@ test-suite chainweb-tests , lens >= 4.17 , lens-aeson >= 1.2.2 , loglevel >= 0.1 + , pretty-show , memory >=0.14 , merkle-log >=0.2 , mtl >= 2.3 diff --git a/src/Chainweb/Crypto/MerkleLog.hs b/src/Chainweb/Crypto/MerkleLog.hs index 64c18df8ba..ea160f0b80 100644 --- a/src/Chainweb/Crypto/MerkleLog.hs +++ b/src/Chainweb/Crypto/MerkleLog.hs @@ -491,7 +491,7 @@ toMerkleNodeTagged b = case toMerkleNode @a @u @b b of tag :: Word16 tag = tagVal @u @(Tag b) --- | /Internal:/ Decode Merkle nodes that are tagged with the respedtive type +-- | /Internal:/ Decode Merkle nodes that are tagged with the respective type -- from the Merkle universe. -- fromMerkleNodeTagged diff --git a/src/Chainweb/Pact/Backend/RelationalCheckpointer.hs b/src/Chainweb/Pact/Backend/RelationalCheckpointer.hs index 7a80196143..37931a4b9c 100644 --- a/src/Chainweb/Pact/Backend/RelationalCheckpointer.hs +++ b/src/Chainweb/Pact/Backend/RelationalCheckpointer.hs @@ -157,11 +157,14 @@ doReadFrom logger v cid sql moduleCacheVar maybeParent doRead = do Nothing -> genesisHeight v cid Just parent -> succ . view blockHeight . _parentHeader $ parent + logFunctionText logger Debug $ "doReadFrom: currentHeight=" <> sshow currentHeight + modifyMVar moduleCacheVar $ \sharedModuleCache -> do bracket (beginSavepoint sql BatchSavepoint) (\_ -> abortSavepoint sql BatchSavepoint) $ \() -> do h <- getEndTxId "doReadFrom" sql maybeParent >>= traverse \startTxId -> do + logFunctionText logger Debug $ "doReadFrom: startTxId=" <> sshow startTxId newDbEnv <- newMVar $ BlockEnv (mkBlockHandlerEnv v cid currentHeight sql DoNotPersistIntraBlockWrites logger) (initBlockState defaultModuleCacheLimit startTxId) @@ -169,6 +172,7 @@ doReadFrom logger v cid sql moduleCacheVar maybeParent doRead = do -- NB it's important to do this *after* you start the savepoint (and thus -- the db transaction) to make sure that the latestHeader check is up to date. latestHeader <- doGetLatestBlock sql + logFunctionText logger Debug $ "doReadFrom: latestHeader=" <> sshow latestHeader let -- is the parent the latest header, i.e., can we get away without rewinding? parentIsLatestHeader = case (latestHeader, maybeParent) of diff --git a/src/Chainweb/Pact/SPV.hs b/src/Chainweb/Pact/SPV.hs index 9fe921d4c4..aa0a99e864 100644 --- a/src/Chainweb/Pact/SPV.hs +++ b/src/Chainweb/Pact/SPV.hs @@ -1,10 +1,11 @@ -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} @@ -27,37 +28,30 @@ module Chainweb.Pact.SPV , getTxIdx ) where - -import GHC.Stack - import Control.Error import Control.Lens hiding (index) import Control.Monad import Control.Monad.Catch import Control.Monad.Except import Control.Monad.Trans.Except - +import Crypto.Hash.Algorithms import Data.Aeson hiding (Object, (.=)) import Data.Bifunctor -import qualified Data.ByteString as B -import qualified Data.ByteString.Base64.URL as B64U -import qualified Data.Map.Strict as M +import Data.ByteString qualified as B +import Data.ByteString.Base64.URL qualified as B64U +import Data.Map.Strict qualified as M import Data.Text (Text, pack) -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import Text.Read (readMaybe) - -import Crypto.Hash.Algorithms - -import qualified Ethereum.Header as EthHeader +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text +import Ethereum.Header qualified as EthHeader import Ethereum.Misc +import Ethereum.RLP import Ethereum.Receipt import Ethereum.Receipt.ReceiptProof -import Ethereum.RLP - +import GHC.Stack import Numeric.Natural - -import qualified Streaming.Prelude as S +import Streaming.Prelude qualified as S +import Text.Read (readMaybe) -- internal chainweb modules @@ -158,7 +152,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 (view blockHash bh) + TransactionOutput p <- catchAndDisplaySPVError bh $ liftIO $ verifyTransactionOutputProofAt_ bdb u bh q <- case decodeStrict' p :: Maybe (CommandResult Hash) of Nothing -> forkedThrower bh "unable to decode spv transaction output" @@ -281,7 +275,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 (view blockHash bh) + TransactionOutput p <- catchAndDisplaySPVError bh $ liftIO $ verifyTransactionOutputProofAt_ bdb u bh q <- case decodeStrict' p :: Maybe (CommandResult Hash) of Nothing -> forkedThrower bh "unable to decode spv transaction output" diff --git a/src/Chainweb/Pact/Types.hs b/src/Chainweb/Pact/Types.hs index c0433d5433..b463ce76de 100644 --- a/src/Chainweb/Pact/Types.hs +++ b/src/Chainweb/Pact/Types.hs @@ -380,9 +380,7 @@ data PactServiceEnv logger tbl = PactServiceEnv , _psAllowReadsInLocal :: !Bool , _psLogger :: !logger , _psGasLogger :: !(Maybe logger) - , _psBlockGasLimit :: !GasLimit - , _psEnableLocalTimeout :: !Bool , _psTxFailuresCounter :: !(Maybe (Counter "txFailures")) } diff --git a/src/Chainweb/SPV.hs b/src/Chainweb/SPV.hs index 3c58fb1b71..6987802311 100644 --- a/src/Chainweb/SPV.hs +++ b/src/Chainweb/SPV.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -30,19 +31,14 @@ import Control.DeepSeq import Control.Lens (Getter, to) import Control.Monad import Control.Monad.Catch - import Crypto.Hash.Algorithms - import Data.Aeson -import qualified Data.Aeson.Types as Aeson -import qualified Data.ByteString as B +import Data.Aeson.Types qualified as Aeson +import Data.ByteString qualified as B import Data.MerkleLog hiding (Expected, Actual) -import qualified Data.Text as T - +import Data.Text qualified as T import GHC.Generics (Generic) - import Numeric.Natural - import Prelude hiding (lookup) -- internal modules diff --git a/src/Chainweb/SPV/VerifyProof.hs b/src/Chainweb/SPV/VerifyProof.hs index ee5d3de238..b41fb6a836 100644 --- a/src/Chainweb/SPV/VerifyProof.hs +++ b/src/Chainweb/SPV/VerifyProof.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} -- | -- Module: Chainweb.SPV.VerifyProof @@ -25,17 +26,21 @@ module Chainweb.SPV.VerifyProof , verifyTransactionOutputProofAt_ ) where +import Chainweb.BlockHeight (BlockHeight(..)) +import Chainweb.Version (HasChainwebVersion(..)) +import Chainweb.Version.Guards (spvProofExpirationWindow) +import Control.Lens (view) +import Control.Monad (when) import Control.Monad.Catch - import Crypto.Hash.Algorithms - import Data.MerkleLog - +import Data.Text (Text) import Prelude hiding (lookup) -- internal modules import Chainweb.BlockHash +import Chainweb.BlockHeader import Chainweb.BlockHeaderDB import Chainweb.Crypto.MerkleLog import Chainweb.CutDB @@ -65,7 +70,7 @@ verifyTransactionProof -> IO Transaction verifyTransactionProof cutDb proof@(TransactionProof cid p) = do unlessM (member cutDb cid h) $ throwM - $ SpvExceptionVerificationFailed "target header is not in the chain" + $ SpvExceptionVerificationFailed targetHeaderMissing proofSubject p where h = runTransactionProof proof @@ -84,7 +89,7 @@ verifyTransactionProofAt -> IO Transaction verifyTransactionProofAt cutDb proof@(TransactionProof cid p) ctx = do unlessM (memberOfM cutDb cid h ctx) $ throwM - $ SpvExceptionVerificationFailed "target header is not in the chain" + $ SpvExceptionVerificationFailed targetHeaderMissing proofSubject p where h = runTransactionProof proof @@ -92,8 +97,7 @@ verifyTransactionProofAt cutDb proof@(TransactionProof cid p) ctx = do -- | Verifies the proof for the given block hash. The result confirms that the -- subject of the proof occurs in the history of the target chain before the -- given block hash. --- --- Throws 'TreeDbKeyNotFound' if the given block hash doesn't exist on target +-- -- Throws 'TreeDbKeyNotFound' if the given block hash doesn't exist on target -- then chain or when the given BlockHeaderDb is not for the target chain. -- verifyTransactionProofAt_ @@ -103,10 +107,10 @@ verifyTransactionProofAt_ -> IO Transaction verifyTransactionProofAt_ bdb proof@(TransactionProof _cid p) ctx = do unlessM (ancestorOf bdb h ctx) $ throwM - $ SpvExceptionVerificationFailed "target header is not in the chain" + $ SpvExceptionVerificationFailed targetHeaderMissing proofSubject p - where - h = runTransactionProof proof + where + h = runTransactionProof proof -- -------------------------------------------------------------------------- -- -- Output Proofs @@ -128,7 +132,7 @@ verifyTransactionOutputProof -> IO TransactionOutput verifyTransactionOutputProof cutDb proof@(TransactionOutputProof cid p) = do unlessM (member cutDb cid h) $ throwM - $ SpvExceptionVerificationFailed "target header is not in the chain" + $ SpvExceptionVerificationFailed targetHeaderMissing proofSubject p where h = runTransactionOutputProof proof @@ -147,7 +151,7 @@ verifyTransactionOutputProofAt -> IO TransactionOutput verifyTransactionOutputProofAt cutDb proof@(TransactionOutputProof cid p) ctx = do unlessM (memberOfM cutDb cid h ctx) $ throwM - $ SpvExceptionVerificationFailed "target header is not in the chain" + $ SpvExceptionVerificationFailed targetHeaderMissing proofSubject p where h = runTransactionOutputProof proof @@ -162,11 +166,42 @@ verifyTransactionOutputProofAt cutDb proof@(TransactionOutputProof cid p) ctx = verifyTransactionOutputProofAt_ :: BlockHeaderDb -> TransactionOutputProof SHA512t_256 - -> BlockHash + -> BlockHeader + -- ^ latest block header -> IO TransactionOutput -verifyTransactionOutputProofAt_ bdb proof@(TransactionOutputProof _cid p) ctx = do - unlessM (ancestorOf bdb h ctx) $ throwM - $ SpvExceptionVerificationFailed "target header is not in the chain" +verifyTransactionOutputProofAt_ bdb proof@(TransactionOutputProof _cid p) latestHeader = do + let bHash = runTransactionOutputProof proof + -- Some thoughts: + + -- Add a variant of ancestorOf that makes sure that the ancestor is not too far in the past + -- w.r.t. the current block + -- Benefits: + -- 1. Re-usable everywhere + + -- Perhaps a more limited version of the block header db, called a "header oracle", that just + -- provides the minimal operation set needed to verify proofs + unlessM (ancestorOf bdb bHash (view blockHash latestHeader)) $ do + throwM $ SpvExceptionVerificationFailed targetHeaderMissing + + let v = _chainwebVersion latestHeader + let latestHeight = view blockHeight latestHeader + case spvProofExpirationWindow v latestHeight of + Just expirationWindow -> do + -- This height is of the root on the target chain. + -- It's at least one more than the height of the block containing the submitted tx. + bHeight <- view blockHeight <$> lookupM bdb bHash + -- I thought to add the diameter to the expiration window before, but it's probably wrong for two reasons: + -- 1. The expiration is always relative to the source chain, so it doesn't matter if the source and target are out of sync. + -- 2. At a chaingraph transition, the diameter of the graph can change, and thus change the expiration window. + when (latestHeight > bHeight + BlockHeight expirationWindow) $ do + throwM $ SpvExceptionVerificationFailed transactionOutputIsExpired + Nothing -> do + pure () proofSubject p - where - h = runTransactionOutputProof proof + +-- | Constant used to avoid inconsistent error messages on-chain across the different failures in this module. +targetHeaderMissing :: Text +targetHeaderMissing = "target header is not in the chain" + +transactionOutputIsExpired :: Text +transactionOutputIsExpired = "transaction output is expired" diff --git a/src/Chainweb/Version.hs b/src/Chainweb/Version.hs index dbf6d196c2..d9e264e158 100644 --- a/src/Chainweb/Version.hs +++ b/src/Chainweb/Version.hs @@ -63,6 +63,7 @@ module Chainweb.Version , versionGraphs , versionHeaderBaseSizeBytes , versionMaxBlockGasLimit + , versionSpvProofExpirationWindow , versionName , versionWindow , versionGenesis @@ -405,6 +406,8 @@ data ChainwebVersion -- use 'headerSizeBytes'. , _versionMaxBlockGasLimit :: Rule BlockHeight (Maybe Natural) -- ^ The maximum gas limit for an entire block. + , _versionSpvProofExpirationWindow :: Rule BlockHeight (Maybe Word64) + -- ^ The number of blocks after which an SPV proof is considered expired. , _versionBootstraps :: [PeerInfo] -- ^ The locations of the bootstrap peers. , _versionGenesis :: VersionGenesis diff --git a/src/Chainweb/Version/Development.hs b/src/Chainweb/Version/Development.hs index 6867a0c650..98294b24fe 100644 --- a/src/Chainweb/Version/Development.hs +++ b/src/Chainweb/Version/Development.hs @@ -50,6 +50,8 @@ devnet = ChainwebVersion -- still the *default* block gas limit is set, see -- defaultChainwebConfiguration._configBlockGasLimit , _versionMaxBlockGasLimit = Bottom (minBound, Nothing) + -- TODO: see what this should be instead of Nothing + , _versionSpvProofExpirationWindow = Bottom (minBound, Nothing) , _versionCheats = VersionCheats { _disablePow = True , _fakeFirstEpochStart = True diff --git a/src/Chainweb/Version/Guards.hs b/src/Chainweb/Version/Guards.hs index acc8f05c47..051aa38dd6 100644 --- a/src/Chainweb/Version/Guards.hs +++ b/src/Chainweb/Version/Guards.hs @@ -47,9 +47,11 @@ module Chainweb.Version.Guards , chainweb224Pact , chainweb225Pact , chainweb226Pact + , chainweb227Pact , pact44NewTrans , pactParserVersion , maxBlockGasLimit + , spvProofExpirationWindow , validPPKSchemes , isWebAuthnPrefixLegal , validKeyFormats @@ -63,6 +65,7 @@ module Chainweb.Version.Guards ) where import Control.Lens +import Data.Word (Word64) import Numeric.Natural import Pact.Types.KeySet (PublicKeyText, ed25519HexFormat, webAuthnFormat) import Pact.Types.Scheme (PPKScheme(ED25519, WebAuthn)) @@ -261,6 +264,9 @@ chainweb225Pact = checkFork atOrAfter Chainweb225Pact chainweb226Pact :: ChainwebVersion -> ChainId -> BlockHeight -> Bool chainweb226Pact = checkFork before Chainweb226Pact +chainweb227Pact :: ChainwebVersion -> ChainId -> BlockHeight -> Bool +chainweb227Pact = checkFork before Chainweb227Pact + pactParserVersion :: ChainwebVersion -> ChainId -> BlockHeight -> PactParserVersion pactParserVersion v cid bh | chainweb213Pact v cid bh = PactParserChainweb213 @@ -270,6 +276,9 @@ maxBlockGasLimit :: ChainwebVersion -> BlockHeight -> Maybe Natural maxBlockGasLimit v bh = snd $ ruleZipperHere $ snd $ ruleSeek (\h _ -> bh >= h) (_versionMaxBlockGasLimit v) +spvProofExpirationWindow :: ChainwebVersion -> BlockHeight -> Maybe Word64 +spvProofExpirationWindow v bh = snd $ ruleZipperHere $ snd + $ ruleSeek (\h _ -> bh >= h) (_versionSpvProofExpirationWindow v) -- | Different versions of Chainweb allow different PPKSchemes. -- diff --git a/src/Chainweb/Version/Mainnet.hs b/src/Chainweb/Version/Mainnet.hs index 6aae0d9556..979cf54ff9 100644 --- a/src/Chainweb/Version/Mainnet.hs +++ b/src/Chainweb/Version/Mainnet.hs @@ -162,6 +162,10 @@ mainnet = ChainwebVersion , _versionMaxBlockGasLimit = (succ $ mainnet ^?! versionForks . at Chainweb216Pact . _Just . onChain (unsafeChainId 0) . _ForkAtBlockHeight, Just 180_000) `Above` Bottom (minBound, Nothing) + , _versionSpvProofExpirationWindow = + -- FIXME: pin down what this should be + --(succ $ mainnet ^?! versionForks . at Chainweb227Pact . _Just . onChain (unsafeChainId 0) . _ForkAtBlockHeight, Nothing) `Above` + Bottom (minBound, Nothing) , _versionBootstraps = domainAddr2PeerInfo mainnetBootstrapHosts , _versionGenesis = VersionGenesis { _genesisBlockTarget = OnChains $ HM.fromList $ concat diff --git a/src/Chainweb/Version/RecapDevelopment.hs b/src/Chainweb/Version/RecapDevelopment.hs index c671106df3..95b4011030 100644 --- a/src/Chainweb/Version/RecapDevelopment.hs +++ b/src/Chainweb/Version/RecapDevelopment.hs @@ -109,6 +109,8 @@ recapDevnet = ChainwebVersion } , _versionMaxBlockGasLimit = Bottom (minBound, Just 180_000) + -- TODO: See what this should be instead of Nothing + , _versionSpvProofExpirationWindow = Bottom (minBound, Nothing) , _versionCheats = VersionCheats { _disablePow = False , _fakeFirstEpochStart = True diff --git a/src/Chainweb/Version/Testnet.hs b/src/Chainweb/Version/Testnet.hs index 7cf11ab8bf..c299a1d819 100644 --- a/src/Chainweb/Version/Testnet.hs +++ b/src/Chainweb/Version/Testnet.hs @@ -142,6 +142,10 @@ testnet = ChainwebVersion , _versionMaxBlockGasLimit = (succ $ testnet ^?! versionForks . at Chainweb216Pact . _Just . onChain (unsafeChainId 0) . _ForkAtBlockHeight, Just 180_000) `Above` Bottom (minBound, Nothing) + , _versionSpvProofExpirationWindow = + -- FIXME: pin down what this should be + --(succ $ testnet ^?! versionForks . at Chainweb227Pact . _Just . onChain (unsafeChainId 0) . _ForkAtBlockHeight, Nothing) `Above` + Bottom (minBound, Nothing) , _versionBootstraps = domainAddr2PeerInfo testnetBootstrapHosts , _versionGenesis = VersionGenesis { _genesisBlockTarget = OnChains $ HM.fromList $ concat diff --git a/test/lib/Chainweb/Test/TestVersions.hs b/test/lib/Chainweb/Test/TestVersions.hs index 06ee7e2fe2..b707b828da 100644 --- a/test/lib/Chainweb/Test/TestVersions.hs +++ b/test/lib/Chainweb/Test/TestVersions.hs @@ -129,6 +129,7 @@ testVersionTemplate v = v & versionVerifierPluginNames .~ AllChains (Bottom (minBound, mempty)) & versionQuirks .~ noQuirks & versionServiceDate .~ Nothing + & versionSpvProofExpirationWindow .~ Bottom (minBound, Just 20) -- | A set of fork heights which are relatively fast, but not fast enough to break anything. fastForks :: HashMap Fork (ChainMap ForkHeight) diff --git a/test/unit/Chainweb/Test/Pact/PactSingleChainTest.hs b/test/unit/Chainweb/Test/Pact/PactSingleChainTest.hs index e40cdba8e7..3d091f7348 100644 --- a/test/unit/Chainweb/Test/Pact/PactSingleChainTest.hs +++ b/test/unit/Chainweb/Test/Pact/PactSingleChainTest.hs @@ -15,6 +15,9 @@ module Chainweb.Test.Pact.PactSingleChainTest ( tests ) where +import Chainweb.Graph (diameter) +import Data.ByteString.Base64.URL qualified as B64U +import Pact.JSON.Legacy.Value qualified as J import Control.Arrow ((&&&)) import Control.Concurrent.Async (withAsync) import Control.Concurrent.MVar @@ -27,8 +30,12 @@ import Patience.Map qualified as PatienceM import Patience.Map (Delta(..)) import Streaming.Prelude qualified as S +import Chainweb.SPV.CreateProof +import Chainweb.WebPactExecutionService +import Text.Show.Pretty (pPrint) import Data.Int (Int64) -import Data.Aeson (object, (.=), Value(..), eitherDecode) +import Data.Aeson (object, (.=), Value(..), eitherDecode, eitherDecodeStrict') +import Data.Aeson qualified as A import qualified Data.ByteString.Lazy as BL import Data.Either (isLeft, isRight, fromRight) import Data.Foldable @@ -36,7 +43,7 @@ import qualified Data.HashMap.Strict as HM import Data.IORef import qualified Data.List as List import qualified Data.Map.Strict as M -import Data.Maybe (isJust, isNothing) +import Data.Maybe (isJust, isNothing, fromMaybe) import qualified Data.Text as T import Data.Text (Text) import qualified Data.Text.Encoding as T @@ -52,6 +59,8 @@ import Test.Tasty.HUnit -- internal modules import Pact.Types.Command +import Pact.Types.SPV (ContProof(..)) +import Pact.Types.Continuation (PactExec(..)) import Pact.Types.Hash import Pact.Types.Info import Pact.Types.Persistence @@ -83,7 +92,7 @@ import Chainweb.Pact.Types import Chainweb.Pact.Utils (emptyPayload) import Chainweb.Payload import Chainweb.Test.Cut.TestBlockDb -import Chainweb.Test.Pact.Utils +import Chainweb.Test.Pact.Utils hiding (runCut) import Chainweb.Test.Pact.Utils qualified as Utils import Chainweb.Test.Utils import Chainweb.Test.TestVersions @@ -91,6 +100,7 @@ import Chainweb.Time import Chainweb.Transaction (ChainwebTransaction) import Chainweb.Utils import Chainweb.Version +import Chainweb.Version.Guards (spvProofExpirationWindow) import Chainweb.Version.Utils import Chainweb.WebBlockHeaderDB (getWebBlockHeaderDb) import Pact.Types.SQLite (SType(..), RType(..)) @@ -139,6 +149,8 @@ tests rdb = testGroup testName , compactionGrandHashUnchanged rdb , compactionDoesNotDisruptDuplicateDetection rdb , compactionResilientToRowIdOrdering rdb + --, spvMinimal rdb + , spvExpirationTest rdb ] where testName = "Chainweb.Test.Pact.PactSingleChainTest" @@ -197,6 +209,31 @@ runBlockE q bdb timeOffset = do nextH <- getParentTestBlockDb bdb cid try (validateBlock nextH (CheckablePayloadWithOutputs nb) q) +runBlockEWithChainId :: (HasCallStack) => ChainId -> ChainMap PactExecutionService -> TestBlockDb -> TimeSpan Micros -> IO PayloadWithOutputs +runBlockEWithChainId c pacts bdb timeOffset = do + ph <- getParentTestBlockDb bdb c + -- We can run with non-total pact execution service, so we have to account for when we don't have one. + case pacts ^? onChain c of + Nothing -> do + let pwo = emptyPayload + let blockTime = add timeOffset $ _bct $ view blockCreationTime ph + void $ addTestBlockDb bdb (succ $ view blockHeight ph) (Nonce 0) (\_ _ -> blockTime) c pwo + pure pwo + Just pact -> do + pwo <- fmap newBlockToPayloadWithOutputs (throwIfNoHistory =<< _pactNewBlock pact c noMiner NewBlockFill (ParentHeader ph)) + let blockTime = add timeOffset $ _bct $ view blockCreationTime ph + _ <- addTestBlockDb bdb (succ $ view blockHeight ph) (Nonce 0) (\_ _ -> blockTime) c pwo + nextH <- getParentTestBlockDb bdb c + _pactValidateBlock pact nextH (CheckablePayloadWithOutputs pwo) + +runCut :: (HasCallStack) => ChainwebVersion -> ChainMap PactExecutionService -> TestBlockDb -> TimeSpan Micros -> IO (ChainMap PayloadWithOutputs) +runCut v queues bdb timeOffset = do + --runExceptT $ do + pwos <- forM (toList (chainIds v)) $ \c -> do + pwo <- runBlockEWithChainId c queues bdb timeOffset + pure (c, pwo) + pure $ onChains pwos + -- edmund: why does any of this return PayloadWithOutputs instead of a -- list of Pact CommandResult? runBlock :: (HasCallStack) => PactQueue -> TestBlockDb -> TimeSpan Micros -> IO PayloadWithOutputs @@ -330,6 +367,223 @@ toRowData v = case eitherDecode encV of where encV = J.encode v +spvMinimal :: () + => RocksDb + -> TestTree +spvMinimal rdb = + let v = instantCpmTestVersion petersonChainGraph + srcChain = minimum $ chainIdsAt v minBound + targetChain = maximum $ chainIdsAt v maxBound + in + withTemporaryDir $ \srcDir -> withSqliteDb cid srcDir $ \srcSqlEnvIO -> + withTemporaryDir $ \targetDir -> withSqliteDb cid targetDir $ \targetSqlEnvIO -> + withDelegateMempool $ \srcDm -> + withDelegateMempool $ \targetDm -> + testCase "spvMinimal" $ do + T.putStrLn "" + when (srcChain == targetChain) $ assertFailure "source and target chains must be different" + blockDb <- mkTestBlockDb v rdb + srcBhDb <- getWebBlockHeaderDb (_bdbWebBlockHeaderDb blockDb) srcChain + targetBhDb <- getWebBlockHeaderDb (_bdbWebBlockHeaderDb blockDb) targetChain + let payloadDb = _bdbPayloadDb blockDb + srcSqlEnv <- srcSqlEnvIO + targetSqlEnv <- targetSqlEnvIO + (srcMempoolRef, srcMempool) <- do + (ref, nonRef) <- srcDm + pure (pure ref, nonRef) + (targetMempoolRef, targetMempool) <- do + (ref, nonRef) <- targetDm + pure (pure @IO ref, nonRef) + srcPactQueue <- newPactQueue 2_000 + targetPactQueue <- newPactQueue 2_000 + + let logger = genericLogger System.LogLevel.Warn T.putStrLn + + -- Start pact service for the src and target + let pactCfg = testPactServiceConfig + let srcPactService = runPactService v srcChain logger Nothing srcPactQueue srcMempool srcBhDb payloadDb srcSqlEnv pactCfg + let targetPactService = runPactService v targetChain logger Nothing targetPactQueue targetMempool targetBhDb payloadDb targetSqlEnv pactCfg + + --setOneShotMempool mempoolRef =<< goldenMemPool + + withAsync srcPactService $ \_ -> do + withAsync targetPactService $ \_ -> do + let pacts = onChains + [ (srcChain, mkPactExecutionService srcPactQueue) + , (targetChain, mkPactExecutionService targetPactQueue) + ] + + _ <- runCut v pacts blockDb second + + -- Initiate the transfer + sendPwos <- runCutWithTx v pacts srcMempoolRef blockDb $ \_n _bHeight _bHash bHeader -> do + buildCwCmd "transfer-crosschain" v + $ set cbSigners [mkEd25519Signer' sender00 [mkGasCap, mkXChainTransferCap "sender00" "sender01" 1.0 (chainIdToText targetChain)]] + $ set cbRPC (mkExec ("(coin.transfer-crosschain \"sender00\" \"sender01\" (read-keyset 'k) \"" <> chainIdToText targetChain <> "\" 1.0)") (mkKeySetData "k" [sender01])) + $ setFromHeader bHeader + $ set cbChainId srcChain + $ set cbGasPrice 0.01 + $ set cbTTL 100 + $ defaultCmd + + cut <- readMVar (_bdbCut blockDb) + let height :: BlockHeight + height = view blockHeight (cut ^?! ixg srcChain) + + -- You have to wait at least N blocks before attempting to run the continuation, + -- where N is the diameter of the graph + some constant (either 1 or 2, currently unsure). + -- 10 is a safe bet. + replicateM_ 10 $ runCut v pacts blockDb second + + --forM_ (_payloadWithOutputsTransactions $ sendPwos ^?! onChain srcChain) $ \(tx, txOut) -> do + -- pPrint $ eitherDecodeStrict' @(CommandResult Text) (_transactionOutputBytes txOut) + + let sendCr :: CommandResult Text + sendCr = case eitherDecodeStrict' (_transactionOutputBytes $ snd $ V.head $ _payloadWithOutputsTransactions $ sendPwos ^?! onChain srcChain) of + Right cmdRes -> cmdRes + Left err -> error $ "Failed to decode transaction output bytes as CommandResult Text: " ++ err + --pPrint sendCr + let cont = fromMaybe (error "missing continuation") (_crContinuation sendCr) + -- TODO: why is this index -1? It fails with 0. + spvProof <- createTransactionOutputProof_ (_bdbWebBlockHeaderDb blockDb) payloadDb targetChain srcChain height 0 + let contMsg = ContMsg + { _cmPactId = _pePactId cont + , _cmStep = succ $ _peStep cont + , _cmRollback = _peStepHasRollback cont + , _cmData = J.toLegacyJson Null + , _cmProof = Just (ContProof (B64U.encode (BL.toStrict (A.encode spvProof)))) + } + + recvPwos <- runCutWithTx v pacts targetMempoolRef blockDb $ \n _bHeight _bHash bHeader -> do + buildCwCmd "transfer-crosschain" v + $ set cbSigners [mkEd25519Signer' sender00 [mkGasCap]] + $ set cbRPC (mkCont contMsg) + $ setFromHeader bHeader + $ set cbChainId targetChain + $ set cbGasPrice 0.01 + $ set cbTTL 100 + $ defaultCmd + + let recvCr :: CommandResult Text + recvCr = case eitherDecodeStrict' (_transactionOutputBytes $ snd $ V.head $ _payloadWithOutputsTransactions $ recvPwos ^?! onChain targetChain) of + Right cmdRes -> cmdRes + Left err -> error $ "Failed to decode transaction output bytes as CommandResult Text: " ++ err + pPrint recvCr + pure () + +spvExpirationTest :: () + => RocksDb + -> TestTree +spvExpirationTest rdb = + -- This version has an spv expiration window of 5 blocks + let v = instantCpmTestVersion petersonChainGraph + srcChain = minimum $ chainIdsAt v minBound + targetChain = maximum $ chainIdsAt v maxBound + in + withTemporaryDir $ \srcDir -> withSqliteDb cid srcDir $ \srcSqlEnvIO -> + withTemporaryDir $ \targetDir -> withSqliteDb cid targetDir $ \targetSqlEnvIO -> + withDelegateMempool $ \srcDm -> + withDelegateMempool $ \targetDm -> + testCase "spvExpiration" $ do + T.putStrLn "" + when (srcChain == targetChain) $ assertFailure "source and target chains must be different" + blockDb <- mkTestBlockDb v rdb + srcBhDb <- getWebBlockHeaderDb (_bdbWebBlockHeaderDb blockDb) srcChain + targetBhDb <- getWebBlockHeaderDb (_bdbWebBlockHeaderDb blockDb) targetChain + let payloadDb = _bdbPayloadDb blockDb + srcSqlEnv <- srcSqlEnvIO + targetSqlEnv <- targetSqlEnvIO + (srcMempoolRef, srcMempool) <- do + (ref, nonRef) <- srcDm + pure (pure ref, nonRef) + (targetMempoolRef, targetMempool) <- do + (ref, nonRef) <- targetDm + pure (pure @IO ref, nonRef) + srcPactQueue <- newPactQueue 2_000 + targetPactQueue <- newPactQueue 2_000 + + let logger = genericLogger System.LogLevel.Warn T.putStrLn + + -- Start pact service for the src and target + let pactCfg = testPactServiceConfig + let srcPactService = runPactService v srcChain logger Nothing srcPactQueue srcMempool srcBhDb payloadDb srcSqlEnv pactCfg + let targetPactService = runPactService v targetChain logger Nothing targetPactQueue targetMempool targetBhDb payloadDb targetSqlEnv pactCfg + + --setOneShotMempool mempoolRef =<< goldenMemPool + + withAsync srcPactService $ \_ -> do + withAsync targetPactService $ \_ -> do + let pacts = onChains + [ (srcChain, mkPactExecutionService srcPactQueue) + , (targetChain, mkPactExecutionService targetPactQueue) + ] + + replicateM_ 10 $ runCut v pacts blockDb second + + -- Initiate the transfer + sendPwos <- runCutWithTx v pacts srcMempoolRef blockDb $ \n _bHeight _bHash bHeader -> do + buildCwCmd "transfer-crosschain" v + $ set cbSigners [mkEd25519Signer' sender00 [mkGasCap, mkXChainTransferCap "sender00" "sender01" 1.0 (chainIdToText targetChain)]] + $ set cbRPC (mkExec ("(coin.transfer-crosschain \"sender00\" \"sender01\" (read-keyset 'k) \"" <> chainIdToText targetChain <> "\" 1.0)") (mkKeySetData "k" [sender01])) + $ setFromHeader bHeader + $ set cbChainId srcChain + $ set cbGasPrice 0.01 + $ set cbTTL 100 + $ defaultCmd + + cut <- readMVar (_bdbCut blockDb) + let sendHeight = view blockHeight (cut ^?! ixg srcChain) + + -- You have to wait at least N blocks before attempting to run the continuation, + -- where N is the diameter of the graph + some constant (either 1 or 2, currently unsure). + -- 10 is a safe bet. + let waitBlocks = 10 + replicateM_ waitBlocks $ runCut v pacts blockDb second + + let sendCr :: CommandResult Text + sendCr = case eitherDecodeStrict' (_transactionOutputBytes $ snd $ V.head $ _payloadWithOutputsTransactions $ sendPwos ^?! onChain srcChain) of + Right cmdRes -> cmdRes + Left err -> error $ "Failed to decode transaction output bytes as CommandResult Text: " ++ err + let cont = fromMaybe (error "missing continuation") (_crContinuation sendCr) + spvProof <- createTransactionOutputProof_ (_bdbWebBlockHeaderDb blockDb) payloadDb targetChain srcChain sendHeight 0 + let contMsg = ContMsg + { _cmPactId = _pePactId cont + , _cmStep = succ $ _peStep cont + , _cmRollback = _peStepHasRollback cont + , _cmData = J.toLegacyJson Null + , _cmProof = Just (ContProof (B64U.encode (BL.toStrict (A.encode spvProof)))) + } + + let fullWindow = fromMaybe (error "missing spv proof expiration window") + (spvProofExpirationWindow v sendHeight) + -- We have already run an extra 10 blocks since the starting the transfer. + -- We need to wait for the full window to expire. + let remainingTime = fromIntegral @_ @Int fullWindow - waitBlocks + fromIntegral @_ @Int (diameter (chainGraphAt v sendHeight)) + 1 + replicateM_ remainingTime $ runCut v pacts blockDb second + + recvPwos <- runCutWithTx v pacts targetMempoolRef blockDb $ \_n _bHeight _bHash bHeader -> do + buildCwCmd "transfer-crosschain" v + $ set cbSigners [mkEd25519Signer' sender00 [mkGasCap]] + $ set cbRPC (mkCont contMsg) + $ setFromHeader bHeader + $ set cbChainId targetChain + $ set cbGasPrice 0.01 + $ set cbTTL 100 + $ defaultCmd + + let recvCr :: CommandResult Text + recvCr = case eitherDecodeStrict' (_transactionOutputBytes $ snd $ V.head $ _payloadWithOutputsTransactions $ recvPwos ^?! onChain targetChain) of + Right cmdRes -> cmdRes + Left err -> error $ "Failed to decode transaction output bytes as CommandResult Text: " ++ err + + case _pactResult (_crResult recvCr) of + Right _ -> do + assertFailure "Expected a failed continuation" + Left (PactError ContinuationError _ _ errMsg) -> do + assertBool "Expected a continuation error message" ("transaction output is expired" `T.isInfixOf` (sshow errMsg)) + Left err -> do + assertFailure $ "Expected a failed continuation, but got: " ++ show err + -- Test that PactService fails if Rosetta is enabled and we don't have all of -- the history. -- @@ -1186,6 +1440,32 @@ compactionSetup pat rdb pactCfg f = , blockDb = blockDb } +runCutWithTx :: () + => ChainwebVersion + -> ChainMap PactExecutionService + -> IO (IORef MemPoolAccess) -- ^ mempoolRef + -> TestBlockDb + -> (Word -> BlockHeight -> BlockHash -> BlockHeader -> IO ChainwebTransaction) + -> IO (ChainMap PayloadWithOutputs) +runCutWithTx v pacts mempoolRef blockDb makeTx = do + madeTx <- newIORef @Bool False + supply <- newIORef @Word 0 + setMempool mempoolRef $ mempty { + mpaGetBlock = \_ _ bHeight bHash bHeader -> do + madeTxYet <- readIORef madeTx + if madeTxYet + then do + pure mempty + else do + n <- atomicModifyIORef' supply $ \a -> (a + 1, a) + tx <- makeTx n bHeight bHash bHeader + writeIORef madeTx True + pure $ V.fromList [tx] + } + e <- runCut v pacts blockDb second + writeIORef madeTx False + pure e + runBlockWithTx :: () => IO (IORef MemPoolAccess) -- ^ mempoolRef -> PactQueue diff --git a/test/unit/Chainweb/Test/Pact/SPV.hs b/test/unit/Chainweb/Test/Pact/SPV.hs index f12117d35a..6d58c47a59 100644 --- a/test/unit/Chainweb/Test/Pact/SPV.hs +++ b/test/unit/Chainweb/Test/Pact/SPV.hs @@ -124,7 +124,6 @@ logg l | l <= Warn = T.putStrLn . logText | otherwise = const $ return () - -- debugging _handle' :: SomeException -> IO (Bool, String) _handle' e = From a3ce78b988b1cf26f935281d804ee1a4ff0d62de Mon Sep 17 00:00:00 2001 From: chessai Date: Fri, 6 Dec 2024 17:08:45 -0600 Subject: [PATCH 2/4] implement HeaderOracle and get SPV functions to use that Change-Id: Ie1996cf9f50c73f16a4e5a1fa30aea67e648d188 remove redundant prett-show dependency Change-Id: I2a4e0ca1a615c0edf28576ee763af6b16aebc234 --- chainweb.cabal | 2 +- src/Chainweb/BlockHeaderDB/HeaderOracle.hs | 124 +++++++++++ src/Chainweb/Pact/SPV.hs | 12 +- src/Chainweb/SPV/VerifyProof.hs | 203 +++++------------- .../Chainweb/Test/Pact/PactSingleChainTest.hs | 115 +--------- test/unit/Chainweb/Test/SPV.hs | 22 +- 6 files changed, 202 insertions(+), 276 deletions(-) create mode 100644 src/Chainweb/BlockHeaderDB/HeaderOracle.hs diff --git a/chainweb.cabal b/chainweb.cabal index fc9beb73f1..7a4eb74e40 100644 --- a/chainweb.cabal +++ b/chainweb.cabal @@ -154,6 +154,7 @@ library , Chainweb.BlockHeader.Genesis.Mainnet10to19Payload , Chainweb.BlockHeader.Validation , Chainweb.BlockHeaderDB + , Chainweb.BlockHeaderDB.HeaderOracle , Chainweb.BlockHeaderDB.Internal , Chainweb.BlockHeaderDB.PruneForks , Chainweb.BlockHeaderDB.RemoteDB @@ -677,7 +678,6 @@ test-suite chainweb-tests , lens >= 4.17 , lens-aeson >= 1.2.2 , loglevel >= 0.1 - , pretty-show , memory >=0.14 , merkle-log >=0.2 , mtl >= 2.3 diff --git a/src/Chainweb/BlockHeaderDB/HeaderOracle.hs b/src/Chainweb/BlockHeaderDB/HeaderOracle.hs new file mode 100644 index 0000000000..77b1fc92ca --- /dev/null +++ b/src/Chainweb/BlockHeaderDB/HeaderOracle.hs @@ -0,0 +1,124 @@ +{-# language + DerivingStrategies + , ImportQualifiedPost + , LambdaCase + , OverloadedRecordDot + , RecordWildCards + , ScopedTypeVariables + , TypeApplications +#-} + +module Chainweb.BlockHeaderDB.HeaderOracle + ( + -- * Oracle type + HeaderOracle + -- ** Accessors + , lowerBound + , upperBound + + -- * Oracle creation + , create + , createSpv + -- ** Oracle creation Exceptions + , InvalidHeaderOracleBounds(..) + + -- * Oracle querying + , query + , HeaderOracleResponse(..) + ) + where + +import Chainweb.BlockHash (BlockHash) +import Chainweb.BlockHeader (BlockHeader, blockHash, blockHeight, genesisBlockHeader) +import Chainweb.BlockHeaderDB (BlockHeaderDb) +import Chainweb.TreeDB (seekAncestor) +import Chainweb.TreeDB qualified as TreeDB +import Chainweb.Version (_chainwebVersion) +import Chainweb.Version.Guards (spvProofExpirationWindow) +import Control.Exception (Exception(..), throwIO) +import Control.Lens (view) +import Numeric.Natural (Natural) + +-- | A 'HeaderOracle' is a 'BlockHeaderDb' with a lower and upper bound, and the only +-- query on it is whether a given block is within those bounds. +data HeaderOracle = HeaderOracle + { lowerBound :: !BlockHeader + , upperBound :: !BlockHeader + , db :: !BlockHeaderDb + } + +-- | Create a new 'HeaderOracle' specifically for SPV verification, with the given upper bound. +-- +-- The lower bound of the oracle is determined by the 'spvProofExpirationWindow'. +createSpv :: BlockHeaderDb -> BlockHeader -> IO HeaderOracle +createSpv db upperBound = do + let mWindow = spvProofExpirationWindow (_chainwebVersion upperBound) (view blockHeight upperBound) + let gh = genesisBlockHeader (_chainwebVersion upperBound) upperBound + let defaultOracle = create db gh upperBound + + case mWindow of + Nothing -> do + defaultOracle + Just window -> do + mWindowthAncestor <- do + let w = fromIntegral @_ @Natural window + let ur = TreeDB.rank upperBound + let gr = TreeDB.rank gh + -- Saturated subtraction with the genesis rank as origin + if w + gr <= ur + then do + seekAncestor db upperBound (ur - w) + else do + return Nothing + case mWindowthAncestor of + Nothing -> do + defaultOracle + Just windowthAncestor -> do + create db windowthAncestor upperBound + +-- | Exception thrown when creating a new 'HeaderOracle' with invalid bounds. +data InvalidHeaderOracleBounds = InvalidHeaderOracleBounds !BlockHash !BlockHash + deriving stock (Eq, Show) + +instance Exception InvalidHeaderOracleBounds where + displayException (InvalidHeaderOracleBounds l u) = "Header Oracle `create` called with a (lower, upper) pair, where `lower` is not an ancestor of `upper`: " ++ show (l, u) + +-- | Create a new 'HeaderOracle' with the given lower and upper bounds. +-- +-- Throws an 'InvalidHeaderOracleBounds' exception if the lower bound is not an ancestor of the upper bound. +create :: BlockHeaderDb -> BlockHeader -> BlockHeader -> IO HeaderOracle +create db lowerBound upperBound = do + valid <- TreeDB.ancestorOf db (view blockHash lowerBound) (view blockHash upperBound) + if valid + then do + return HeaderOracle + { .. + } + else do + throwIO $ InvalidHeaderOracleBounds (view blockHash lowerBound) (view blockHash upperBound) + +-- TODO: add note about we can't have two different errors here, because shallow nodes can't determine which one is the case +-- eg we cant have data Response = TooLate | OutOfBounds | Success + +-- | The response from the oracle when querying a block. +data HeaderOracleResponse + = OutOfBounds + -- ^ The block is not within the oracle's bounds. + | InBounds + -- ^ The block is within the oracle's bounds. + deriving stock (Eq) + +-- | Query the oracle, asking if the block is within its bounds. +query :: () + => HeaderOracle + -> BlockHash + -> IO HeaderOracleResponse +query oracle subject = do + -- Check if the lower bound is an ancestor of the header + -- Check if the header is an ancestor of the upper bound + r <- (&&) + <$> TreeDB.ancestorOf oracle.db (view blockHash oracle.lowerBound) subject + <*> TreeDB.ancestorOf oracle.db subject (view blockHash oracle.upperBound) + return $ if r + then InBounds + else OutOfBounds \ No newline at end of file diff --git a/src/Chainweb/Pact/SPV.hs b/src/Chainweb/Pact/SPV.hs index aa0a99e864..e1753e46e8 100644 --- a/src/Chainweb/Pact/SPV.hs +++ b/src/Chainweb/Pact/SPV.hs @@ -63,6 +63,7 @@ import Chainweb.Pact.Utils (aeson) import Chainweb.Payload import Chainweb.Payload.PayloadStore import Chainweb.SPV +import Chainweb.BlockHeaderDB.HeaderOracle qualified as Oracle import Chainweb.SPV.VerifyProof import Chainweb.TreeDB import Chainweb.Utils @@ -117,7 +118,9 @@ verifySPV -> Object Name -- ^ the proof object to validate -> IO (Either Text (Object Name)) -verifySPV bdb bh typ proof = runExceptT $ go typ proof +verifySPV bdb bh typ proof = do + oracle <- Oracle.createSpv bdb bh + runExceptT $ go oracle typ proof where cid = CW._chainId bdb enableBridge = CW.enableSPVBridge (CW._chainwebVersion bh) cid (view blockHeight bh) @@ -129,7 +132,7 @@ verifySPV bdb bh typ proof = runExceptT $ go typ proof TObject o _ -> return o _ -> throwError "spv-verified tx output has invalid type" - go s o = case s of + go oracle s o = case s of -- Ethereum Receipt Proof "ETH" | enableBridge -> except (extractEthProof o) >>= @@ -152,7 +155,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 bh + TransactionOutput p <- catchAndDisplaySPVError bh $ liftIO $ verifyTransactionOutputProof oracle u q <- case decodeStrict' p :: Maybe (CommandResult Hash) of Nothing -> forkedThrower bh "unable to decode spv transaction output" @@ -251,6 +254,7 @@ verifyCont -- ^ bytestring of 'TransactionOutputP roof' object to validate -> IO (Either Text PactExec) verifyCont bdb bh (ContProof cp) = runExceptT $ do + oracle <- liftIO $ Oracle.createSpv bdb bh let errorMessageType = if CW.chainweb221Pact (CW._chainwebVersion bh) @@ -275,7 +279,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 bh + TransactionOutput p <- catchAndDisplaySPVError bh $ liftIO $ verifyTransactionOutputProof oracle u q <- case decodeStrict' p :: Maybe (CommandResult Hash) of Nothing -> forkedThrower bh "unable to decode spv transaction output" diff --git a/src/Chainweb/SPV/VerifyProof.hs b/src/Chainweb/SPV/VerifyProof.hs index b41fb6a836..917ed55116 100644 --- a/src/Chainweb/SPV/VerifyProof.hs +++ b/src/Chainweb/SPV/VerifyProof.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -13,195 +14,93 @@ -- module Chainweb.SPV.VerifyProof ( --- * Transaction Proofs - runTransactionProof -, verifyTransactionProof -, verifyTransactionProofAt -, verifyTransactionProofAt_ + -- * Transaction Proofs + runTransactionProof + , verifyTransactionProof --- * Transaction Output Proofs -, runTransactionOutputProof -, verifyTransactionOutputProof -, verifyTransactionOutputProofAt -, verifyTransactionOutputProofAt_ + -- * Transaction Output Proofs + , runTransactionOutputProof + , verifyTransactionOutputProof ) where -import Chainweb.BlockHeight (BlockHeight(..)) -import Chainweb.Version (HasChainwebVersion(..)) -import Chainweb.Version.Guards (spvProofExpirationWindow) -import Control.Lens (view) -import Control.Monad (when) -import Control.Monad.Catch -import Crypto.Hash.Algorithms -import Data.MerkleLog -import Data.Text (Text) -import Prelude hiding (lookup) - --- internal modules - import Chainweb.BlockHash -import Chainweb.BlockHeader -import Chainweb.BlockHeaderDB +import Chainweb.BlockHeader (blockHeight) +import Chainweb.BlockHeight (BlockHeight) +import Chainweb.ChainId (ChainId) +import Chainweb.ChainId (_chainId) import Chainweb.Crypto.MerkleLog -import Chainweb.CutDB import Chainweb.MerkleLogHash import Chainweb.Payload import Chainweb.SPV -import Chainweb.TreeDB +import Chainweb.BlockHeaderDB.HeaderOracle (HeaderOracle) +import Chainweb.BlockHeaderDB.HeaderOracle qualified as Oracle import Chainweb.Utils +import Chainweb.Version (ChainwebVersion, _chainwebVersion) +import Chainweb.Version.Guards qualified as CW +import Control.Lens (view) +import Control.Monad.Catch +import Crypto.Hash.Algorithms +import Data.MerkleLog +import Data.Text (Text) +import Prelude hiding (lookup) -- -------------------------------------------------------------------------- -- -- Transaction Proofs --- | Runs a transaction Proof. Returns the block hash on the target chain for --- which inclusion is proven. +-- | Runs a transaction proof. Returns the block hash on the target chain for +-- which inclusion is proven. -- runTransactionProof :: TransactionProof SHA512t_256 -> BlockHash -runTransactionProof (TransactionProof _ p) - = BlockHash $ MerkleLogHash $ runMerkleProof p +runTransactionProof (TransactionProof _ p) = BlockHash $ MerkleLogHash $ runMerkleProof p -- | Verifies the proof against the current state of consensus. The result -- confirms that the subject of the proof occurs in the history of the winning -- fork of the target chain. -- verifyTransactionProof - :: CutDb tbl - -> TransactionProof SHA512t_256 - -> IO Transaction -verifyTransactionProof cutDb proof@(TransactionProof cid p) = do - unlessM (member cutDb cid h) $ throwM - $ SpvExceptionVerificationFailed targetHeaderMissing - proofSubject p - where - h = runTransactionProof proof - --- | Verifies the proof for the given block hash. The result confirms that the --- subject of the proof occurs in the history of the target chain before the --- given block hash. --- --- Throws 'TreeDbKeyNotFound' if the given block hash doesn't exist on target --- chain. --- -verifyTransactionProofAt - :: CutDb tbl - -> TransactionProof SHA512t_256 - -> BlockHash - -> IO Transaction -verifyTransactionProofAt cutDb proof@(TransactionProof cid p) ctx = do - unlessM (memberOfM cutDb cid h ctx) $ throwM - $ SpvExceptionVerificationFailed targetHeaderMissing - proofSubject p - where - h = runTransactionProof proof - --- | Verifies the proof for the given block hash. The result confirms that the --- subject of the proof occurs in the history of the target chain before the --- given block hash. --- -- Throws 'TreeDbKeyNotFound' if the given block hash doesn't exist on target --- then chain or when the given BlockHeaderDb is not for the target chain. --- -verifyTransactionProofAt_ - :: BlockHeaderDb + :: HeaderOracle -> TransactionProof SHA512t_256 - -> BlockHash -> IO Transaction -verifyTransactionProofAt_ bdb proof@(TransactionProof _cid p) ctx = do - unlessM (ancestorOf bdb h ctx) $ throwM - $ SpvExceptionVerificationFailed targetHeaderMissing +verifyTransactionProof oracle proof@(TransactionProof _cid p) = do + let h = runTransactionProof proof + whenM ((== Oracle.OutOfBounds) <$> Oracle.query oracle h) $ do + let u = Oracle.upperBound oracle + forkedError (_chainwebVersion u) (_chainId u) (view blockHeight u) proofSubject p - where - h = runTransactionProof proof -- -------------------------------------------------------------------------- -- -- Output Proofs --- | Runs a transaction Proof. Returns the block hash on the target chain for --- which inclusion is proven. +-- | Runs a transaction output proof. Returns the block hash on the target chain for +-- which inclusion is proven. -- runTransactionOutputProof :: TransactionOutputProof SHA512t_256 -> BlockHash -runTransactionOutputProof (TransactionOutputProof _ p) - = BlockHash $ MerkleLogHash $ runMerkleProof p - --- | Verifies the proof against the current state of consensus. The result --- confirms that the subject of the proof occurs in the history of the winning --- fork of the target chain. --- -verifyTransactionOutputProof - :: CutDb tbl - -> TransactionOutputProof SHA512t_256 - -> IO TransactionOutput -verifyTransactionOutputProof cutDb proof@(TransactionOutputProof cid p) = do - unlessM (member cutDb cid h) $ throwM - $ SpvExceptionVerificationFailed targetHeaderMissing - proofSubject p - where - h = runTransactionOutputProof proof +runTransactionOutputProof (TransactionOutputProof _ p) = BlockHash $ MerkleLogHash $ runMerkleProof p -- | Verifies the proof for the given block hash. The result confirms that the --- subject of the proof occurs in the history of the target chain before the --- given block hash. +-- subject of the proof occurs in the history of the target chain before the +-- given block hash. -- --- Throws 'TreeDbKeyNotFound' if the given block hash doesn't exist on target --- chain. +-- Throws 'TreeDbKeyNotFound' if the given block hash doesn't exist on target +-- the chain or when the given BlockHeaderDb is not for the target chain. -- -verifyTransactionOutputProofAt - :: CutDb tbl +verifyTransactionOutputProof + :: HeaderOracle -> TransactionOutputProof SHA512t_256 - -> BlockHash -> IO TransactionOutput -verifyTransactionOutputProofAt cutDb proof@(TransactionOutputProof cid p) ctx = do - unlessM (memberOfM cutDb cid h ctx) $ throwM - $ SpvExceptionVerificationFailed targetHeaderMissing +verifyTransactionOutputProof oracle proof@(TransactionOutputProof _cid p) = do + let h = runTransactionOutputProof proof + whenM ((== Oracle.OutOfBounds) <$> Oracle.query oracle h) $ do + let u = Oracle.upperBound oracle + forkedError (_chainwebVersion u) (_chainId u) (view blockHeight u) proofSubject p - where - h = runTransactionOutputProof proof - --- | Verifies the proof for the given block hash. The result confirms that the --- subject of the proof occurs in the history of the target chain before the --- given block hash. --- --- Throws 'TreeDbKeyNotFound' if the given block hash doesn't exist on target --- the chain or when the given BlockHeaderDb is not for the target chain. --- -verifyTransactionOutputProofAt_ - :: BlockHeaderDb - -> TransactionOutputProof SHA512t_256 - -> BlockHeader - -- ^ latest block header - -> IO TransactionOutput -verifyTransactionOutputProofAt_ bdb proof@(TransactionOutputProof _cid p) latestHeader = do - let bHash = runTransactionOutputProof proof - -- Some thoughts: - - -- Add a variant of ancestorOf that makes sure that the ancestor is not too far in the past - -- w.r.t. the current block - -- Benefits: - -- 1. Re-usable everywhere - -- Perhaps a more limited version of the block header db, called a "header oracle", that just - -- provides the minimal operation set needed to verify proofs - unlessM (ancestorOf bdb bHash (view blockHash latestHeader)) $ do - throwM $ SpvExceptionVerificationFailed targetHeaderMissing - - let v = _chainwebVersion latestHeader - let latestHeight = view blockHeight latestHeader - case spvProofExpirationWindow v latestHeight of - Just expirationWindow -> do - -- This height is of the root on the target chain. - -- It's at least one more than the height of the block containing the submitted tx. - bHeight <- view blockHeight <$> lookupM bdb bHash - -- I thought to add the diameter to the expiration window before, but it's probably wrong for two reasons: - -- 1. The expiration is always relative to the source chain, so it doesn't matter if the source and target are out of sync. - -- 2. At a chaingraph transition, the diameter of the graph can change, and thus change the expiration window. - when (latestHeight > bHeight + BlockHeight expirationWindow) $ do - throwM $ SpvExceptionVerificationFailed transactionOutputIsExpired - Nothing -> do - pure () - proofSubject p +forkedError :: ChainwebVersion -> ChainId -> BlockHeight -> IO a +forkedError v cid h = throwM $ SpvExceptionVerificationFailed $ if CW.chainweb227Pact v cid h then errMsgPost227 else errMsgPre227 + where + errMsgPre227 :: Text + errMsgPre227 = "target header is not in the chain" --- | Constant used to avoid inconsistent error messages on-chain across the different failures in this module. -targetHeaderMissing :: Text -targetHeaderMissing = "target header is not in the chain" + errMsgPost227 :: Text + errMsgPost227 = "target header is not in the chain or is out of bounds" -transactionOutputIsExpired :: Text -transactionOutputIsExpired = "transaction output is expired" diff --git a/test/unit/Chainweb/Test/Pact/PactSingleChainTest.hs b/test/unit/Chainweb/Test/Pact/PactSingleChainTest.hs index 3d091f7348..e181414a3d 100644 --- a/test/unit/Chainweb/Test/Pact/PactSingleChainTest.hs +++ b/test/unit/Chainweb/Test/Pact/PactSingleChainTest.hs @@ -15,7 +15,6 @@ module Chainweb.Test.Pact.PactSingleChainTest ( tests ) where -import Chainweb.Graph (diameter) import Data.ByteString.Base64.URL qualified as B64U import Pact.JSON.Legacy.Value qualified as J import Control.Arrow ((&&&)) @@ -32,7 +31,6 @@ import Streaming.Prelude qualified as S import Chainweb.SPV.CreateProof import Chainweb.WebPactExecutionService -import Text.Show.Pretty (pPrint) import Data.Int (Int64) import Data.Aeson (object, (.=), Value(..), eitherDecode, eitherDecodeStrict') import Data.Aeson qualified as A @@ -149,7 +147,6 @@ tests rdb = testGroup testName , compactionGrandHashUnchanged rdb , compactionDoesNotDisruptDuplicateDetection rdb , compactionResilientToRowIdOrdering rdb - --, spvMinimal rdb , spvExpirationTest rdb ] where @@ -367,110 +364,6 @@ toRowData v = case eitherDecode encV of where encV = J.encode v -spvMinimal :: () - => RocksDb - -> TestTree -spvMinimal rdb = - let v = instantCpmTestVersion petersonChainGraph - srcChain = minimum $ chainIdsAt v minBound - targetChain = maximum $ chainIdsAt v maxBound - in - withTemporaryDir $ \srcDir -> withSqliteDb cid srcDir $ \srcSqlEnvIO -> - withTemporaryDir $ \targetDir -> withSqliteDb cid targetDir $ \targetSqlEnvIO -> - withDelegateMempool $ \srcDm -> - withDelegateMempool $ \targetDm -> - testCase "spvMinimal" $ do - T.putStrLn "" - when (srcChain == targetChain) $ assertFailure "source and target chains must be different" - blockDb <- mkTestBlockDb v rdb - srcBhDb <- getWebBlockHeaderDb (_bdbWebBlockHeaderDb blockDb) srcChain - targetBhDb <- getWebBlockHeaderDb (_bdbWebBlockHeaderDb blockDb) targetChain - let payloadDb = _bdbPayloadDb blockDb - srcSqlEnv <- srcSqlEnvIO - targetSqlEnv <- targetSqlEnvIO - (srcMempoolRef, srcMempool) <- do - (ref, nonRef) <- srcDm - pure (pure ref, nonRef) - (targetMempoolRef, targetMempool) <- do - (ref, nonRef) <- targetDm - pure (pure @IO ref, nonRef) - srcPactQueue <- newPactQueue 2_000 - targetPactQueue <- newPactQueue 2_000 - - let logger = genericLogger System.LogLevel.Warn T.putStrLn - - -- Start pact service for the src and target - let pactCfg = testPactServiceConfig - let srcPactService = runPactService v srcChain logger Nothing srcPactQueue srcMempool srcBhDb payloadDb srcSqlEnv pactCfg - let targetPactService = runPactService v targetChain logger Nothing targetPactQueue targetMempool targetBhDb payloadDb targetSqlEnv pactCfg - - --setOneShotMempool mempoolRef =<< goldenMemPool - - withAsync srcPactService $ \_ -> do - withAsync targetPactService $ \_ -> do - let pacts = onChains - [ (srcChain, mkPactExecutionService srcPactQueue) - , (targetChain, mkPactExecutionService targetPactQueue) - ] - - _ <- runCut v pacts blockDb second - - -- Initiate the transfer - sendPwos <- runCutWithTx v pacts srcMempoolRef blockDb $ \_n _bHeight _bHash bHeader -> do - buildCwCmd "transfer-crosschain" v - $ set cbSigners [mkEd25519Signer' sender00 [mkGasCap, mkXChainTransferCap "sender00" "sender01" 1.0 (chainIdToText targetChain)]] - $ set cbRPC (mkExec ("(coin.transfer-crosschain \"sender00\" \"sender01\" (read-keyset 'k) \"" <> chainIdToText targetChain <> "\" 1.0)") (mkKeySetData "k" [sender01])) - $ setFromHeader bHeader - $ set cbChainId srcChain - $ set cbGasPrice 0.01 - $ set cbTTL 100 - $ defaultCmd - - cut <- readMVar (_bdbCut blockDb) - let height :: BlockHeight - height = view blockHeight (cut ^?! ixg srcChain) - - -- You have to wait at least N blocks before attempting to run the continuation, - -- where N is the diameter of the graph + some constant (either 1 or 2, currently unsure). - -- 10 is a safe bet. - replicateM_ 10 $ runCut v pacts blockDb second - - --forM_ (_payloadWithOutputsTransactions $ sendPwos ^?! onChain srcChain) $ \(tx, txOut) -> do - -- pPrint $ eitherDecodeStrict' @(CommandResult Text) (_transactionOutputBytes txOut) - - let sendCr :: CommandResult Text - sendCr = case eitherDecodeStrict' (_transactionOutputBytes $ snd $ V.head $ _payloadWithOutputsTransactions $ sendPwos ^?! onChain srcChain) of - Right cmdRes -> cmdRes - Left err -> error $ "Failed to decode transaction output bytes as CommandResult Text: " ++ err - --pPrint sendCr - let cont = fromMaybe (error "missing continuation") (_crContinuation sendCr) - -- TODO: why is this index -1? It fails with 0. - spvProof <- createTransactionOutputProof_ (_bdbWebBlockHeaderDb blockDb) payloadDb targetChain srcChain height 0 - let contMsg = ContMsg - { _cmPactId = _pePactId cont - , _cmStep = succ $ _peStep cont - , _cmRollback = _peStepHasRollback cont - , _cmData = J.toLegacyJson Null - , _cmProof = Just (ContProof (B64U.encode (BL.toStrict (A.encode spvProof)))) - } - - recvPwos <- runCutWithTx v pacts targetMempoolRef blockDb $ \n _bHeight _bHash bHeader -> do - buildCwCmd "transfer-crosschain" v - $ set cbSigners [mkEd25519Signer' sender00 [mkGasCap]] - $ set cbRPC (mkCont contMsg) - $ setFromHeader bHeader - $ set cbChainId targetChain - $ set cbGasPrice 0.01 - $ set cbTTL 100 - $ defaultCmd - - let recvCr :: CommandResult Text - recvCr = case eitherDecodeStrict' (_transactionOutputBytes $ snd $ V.head $ _payloadWithOutputsTransactions $ recvPwos ^?! onChain targetChain) of - Right cmdRes -> cmdRes - Left err -> error $ "Failed to decode transaction output bytes as CommandResult Text: " ++ err - pPrint recvCr - pure () - spvExpirationTest :: () => RocksDb -> TestTree @@ -509,8 +402,6 @@ spvExpirationTest rdb = let srcPactService = runPactService v srcChain logger Nothing srcPactQueue srcMempool srcBhDb payloadDb srcSqlEnv pactCfg let targetPactService = runPactService v targetChain logger Nothing targetPactQueue targetMempool targetBhDb payloadDb targetSqlEnv pactCfg - --setOneShotMempool mempoolRef =<< goldenMemPool - withAsync srcPactService $ \_ -> do withAsync targetPactService $ \_ -> do let pacts = onChains @@ -521,7 +412,7 @@ spvExpirationTest rdb = replicateM_ 10 $ runCut v pacts blockDb second -- Initiate the transfer - sendPwos <- runCutWithTx v pacts srcMempoolRef blockDb $ \n _bHeight _bHash bHeader -> do + sendPwos <- runCutWithTx v pacts srcMempoolRef blockDb $ \_n _bHeight _bHash bHeader -> do buildCwCmd "transfer-crosschain" v $ set cbSigners [mkEd25519Signer' sender00 [mkGasCap, mkXChainTransferCap "sender00" "sender01" 1.0 (chainIdToText targetChain)]] $ set cbRPC (mkExec ("(coin.transfer-crosschain \"sender00\" \"sender01\" (read-keyset 'k) \"" <> chainIdToText targetChain <> "\" 1.0)") (mkKeySetData "k" [sender01])) @@ -579,8 +470,8 @@ spvExpirationTest rdb = case _pactResult (_crResult recvCr) of Right _ -> do assertFailure "Expected a failed continuation" - Left (PactError ContinuationError _ _ errMsg) -> do - assertBool "Expected a continuation error message" ("transaction output is expired" `T.isInfixOf` (sshow errMsg)) + Left (PactError ContinuationError _ _ _) -> do + pure () Left err -> do assertFailure $ "Expected a failed continuation, but got: " ++ show err diff --git a/test/unit/Chainweb/Test/SPV.hs b/test/unit/Chainweb/Test/SPV.hs index e91ba937ff..ee71ab21bb 100644 --- a/test/unit/Chainweb/Test/SPV.hs +++ b/test/unit/Chainweb/Test/SPV.hs @@ -1,6 +1,7 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -63,6 +64,7 @@ import Chainweb.Crypto.MerkleLog import Chainweb.Cut hiding (join) import Chainweb.CutDB import Chainweb.Graph +import Chainweb.BlockHeaderDB.HeaderOracle qualified as Oracle import Chainweb.Mempool.Mempool (MockTx) import Chainweb.MerkleUniverse import Chainweb.Payload @@ -91,8 +93,8 @@ import Chainweb.Storage.Table.RocksDB -- tests :: RocksDb -> TestTree tests rdb = testGroup "SPV tests" - [ testCaseStepsN "SPV transaction proof" 10 (spvTransactionRoundtripTest rdb version) - , testCaseStepsN "SPV transaction output proof" 10 (spvTransactionOutputRoundtripTest rdb version) + [ testCaseStepsN "SPV transaction roundtrip" 10 (spvTransactionRoundtripTest rdb version) + , testCaseStepsN "SPV transaction output proof roundtrip" 10 (spvTransactionOutputRoundtripTest rdb version) , apiTests rdb version , testCaseSteps "SPV transaction proof test" (spvTest rdb version) , properties @@ -288,7 +290,9 @@ spvTest rdb v step = do (_chainId h) -- source chain (view blockHeight h) -- source block height txIx -- transaction index - subj <- verifyTransactionOutputProof cutDb proof + curCut <- _cut cutDb + oracle <- Oracle.createSpv (cutDb ^?! cutDbBlockHeaderDb trgChain) (curCut ^?! ixg trgChain) + subj <- verifyTransactionOutputProof oracle proof assertEqual "transaction output proof subject matches transaction" txOut subj -- return (proof size, block size, height, distance, tx size) @@ -384,7 +388,8 @@ spvTransactionRoundtripTest rdb v step = do (eitherDecode (encode proof)) step "verify proof" - subj <- verifyTransactionProof cutDb proof + oracle <- Oracle.createSpv (cutDb ^?! cutDbBlockHeaderDb trgChain) (curCut ^?! ixg trgChain) + subj <- verifyTransactionProof oracle proof step "confirm that proof subject matches transaction" assertEqual "proof subject matches transaction" tx subj @@ -420,7 +425,8 @@ spvTransactionOutputRoundtripTest rdb v step = do (eitherDecode (encode proof)) step "verify proof" - subj <- verifyTransactionOutputProof cutDb proof + oracle <- Oracle.createSpv (cutDb ^?! cutDbBlockHeaderDb trgChain) (curCut ^?! ixg trgChain) + subj <- verifyTransactionOutputProof oracle proof step "confirm that proof subject matches transaction output" assertEqual "proof subject matches transaction output" out subj @@ -463,6 +469,8 @@ txApiTests envIO step = do txProof <- flip runClientM env $ spvGetTransactionProofClient v trgChain (_chainId h) (view blockHeight h) (int txIx) + oracle <- Oracle.createSpv (cutDb ^?! cutDbBlockHeaderDb trgChain) (curCut ^?! ixg trgChain) + case txProof of Left err -> @@ -470,7 +478,7 @@ txApiTests envIO step = do Right proof -> do step "verify transaction proof" - subj <- verifyTransactionProof cutDb proof + subj <- verifyTransactionProof oracle proof step "confirm that transaction proof subject matches transaction" assertEqual "proof subject matches transaction" tx subj @@ -488,7 +496,7 @@ txApiTests envIO step = do Right proof -> do step "verify transaction output proof" - subj <- verifyTransactionOutputProof cutDb proof + subj <- verifyTransactionOutputProof oracle proof step "confirm that transaction output proof subject matches transaction output" assertEqual "proof subject matches transaction output" out subj From 95f549e3369c51f74edafd4b4ad54f581d7f8e71 Mon Sep 17 00:00:00 2001 From: chessai Date: Thu, 12 Dec 2024 21:26:57 -0600 Subject: [PATCH 3/4] set testnet spv proof expiration window to 23_040 Change-Id: I65b8c82d9c26b327a9052b5091a9a8930abd2538 --- src/Chainweb/Version/Testnet.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Chainweb/Version/Testnet.hs b/src/Chainweb/Version/Testnet.hs index c299a1d819..5297b2e291 100644 --- a/src/Chainweb/Version/Testnet.hs +++ b/src/Chainweb/Version/Testnet.hs @@ -143,8 +143,8 @@ testnet = ChainwebVersion (succ $ testnet ^?! versionForks . at Chainweb216Pact . _Just . onChain (unsafeChainId 0) . _ForkAtBlockHeight, Just 180_000) `Above` Bottom (minBound, Nothing) , _versionSpvProofExpirationWindow = - -- FIXME: pin down what this should be - --(succ $ testnet ^?! versionForks . at Chainweb227Pact . _Just . onChain (unsafeChainId 0) . _ForkAtBlockHeight, Nothing) `Above` + -- 23_040 is 4x current max TTL + (succ $ testnet ^?! versionForks . at Chainweb227Pact . _Just . onChain (unsafeChainId 0) . _ForkAtBlockHeight, 23_040) `Above` Bottom (minBound, Nothing) , _versionBootstraps = domainAddr2PeerInfo testnetBootstrapHosts , _versionGenesis = VersionGenesis From fae2052914358be33d77beaf40143ad55f374555 Mon Sep 17 00:00:00 2001 From: chessai Date: Fri, 13 Dec 2024 15:35:25 -0600 Subject: [PATCH 4/4] in testnet, spv expiration is a Maybe Word64, not Word64 --- src/Chainweb/Version/Testnet.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Chainweb/Version/Testnet.hs b/src/Chainweb/Version/Testnet.hs index 5297b2e291..dd38228a52 100644 --- a/src/Chainweb/Version/Testnet.hs +++ b/src/Chainweb/Version/Testnet.hs @@ -144,7 +144,7 @@ testnet = ChainwebVersion Bottom (minBound, Nothing) , _versionSpvProofExpirationWindow = -- 23_040 is 4x current max TTL - (succ $ testnet ^?! versionForks . at Chainweb227Pact . _Just . onChain (unsafeChainId 0) . _ForkAtBlockHeight, 23_040) `Above` + (succ $ testnet ^?! versionForks . at Chainweb227Pact . _Just . onChain (unsafeChainId 0) . _ForkAtBlockHeight, Just 23_040) `Above` Bottom (minBound, Nothing) , _versionBootstraps = domainAddr2PeerInfo testnetBootstrapHosts , _versionGenesis = VersionGenesis