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 =