spv expiration

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

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

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
 
@@ -69,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
@@ -123,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)
@@ -135,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) >>=
@@ -158,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 (view blockHash 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"
@@ -257,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)
@@ -281,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 (view blockHash 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"

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