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

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

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

src/Chainweb/Pact/Backend/RelationalCheckpointer.hs

@@ -157,18 +157,22 @@ 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)
               { _bsModuleCache = sharedModuleCache }
           -- 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

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"

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"))
     }

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

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,16 +89,15 @@ 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
 
 -- | 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"

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

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

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.
 --

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

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

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