Attempt to produce SPV proofs in the valid history window (#2280)

When an SPV proof would have a root outside of the valid history window,
i.e. the proof would be expired, attempt to produce a proof which has a
root inside the valid history window instead if possible.

Co-authored-by: Lars Kuhtz <lars@kadena.io>

Author: edmundnoble

src/Chainweb/SPV/CreateProof.hs

@@ -56,6 +56,7 @@ import Chainweb.SPV
 import Chainweb.TreeDB
 import Chainweb.Utils
 import Chainweb.Version
+import Chainweb.Version.Guards
 import Chainweb.WebBlockHeaderDB
 
 import Chainweb.Storage.Table
@@ -109,7 +110,7 @@ createTransactionProof_
         -- ^ The index of the transaction in the block
     -> IO (TransactionProof SHA512t_256)
 createTransactionProof_ headerDb payloadDb tcid scid bh i = do
-    trgHeader <- minimumTrgHeader headerDb tcid scid bh
+    trgHeader <- findTrgHeader headerDb tcid scid bh
     TransactionProof tcid
         <$> createPayloadProof_ transactionProofPrefix headerDb payloadDb tcid scid bh i trgHeader
 
@@ -215,7 +216,7 @@ createTransactionOutputProof_
         -- ^ The index of the transaction in the block
     -> IO (TransactionOutputProof SHA512t_256)
 createTransactionOutputProof_ headerDb payloadDb tcid scid bh i = do
-    trgHeader <- minimumTrgHeader headerDb tcid scid bh
+    trgHeader <- findTrgHeader headerDb tcid scid bh
     TransactionOutputProof tcid
         <$> createPayloadProof_ outputProofPrefix headerDb payloadDb tcid scid bh i trgHeader
 
@@ -480,7 +481,11 @@ crumbsToChain db srcCid trgHeader
         let !adjIdx = fromJuste $ blockHashRecordChainIdx (view blockAdjacentHashes cur) h
         go adjpHdr t ((adjIdx, cur) : acc)
 
-minimumTrgHeader
+-- | The minimum number of blocks before a newly created proof root expires.
+proofSlack :: BlockHeight
+proofSlack = 100
+
+findTrgHeader
     :: WebBlockHeaderDb
     -> ChainId
         -- ^ target chain. The proof asserts that the subject is included in
@@ -491,8 +496,26 @@ minimumTrgHeader
         -- ^ The block height of the transaction, i.e. the subject on the source
         -- chain.
     -> IO BlockHeader
-minimumTrgHeader headerDb tcid scid bh = do
+findTrgHeader headerDb tcid scid bh = do
     trgHeadHeader <- maxEntry trgChain
+    let trgHeadHeight = trgHeadHeader ^. blockHeight
+    let trgHeight = int $
+            case minimumBlockHeaderHistory (_chainwebVersion headerDb) trgHeadHeight of
+                Nothing ->
+                    minTrgHeight
+                Just minHist -> do
+                    -- if there is a block header history limit by now, then any
+                    -- proof with a target outside of that window will not be
+                    -- usable. so ideally, the proof we produce is in that
+                    -- window. that is no guarantee that such a proof is small
+                    -- enough to store on-chain, if the subject is far in the
+                    -- past, but it's better to try than do nothing.
+                    let trgLowestKnownHeight = max trgHeadHeight (int minHist) - int minHist
+                    -- we don't use the lowest known height directly, we try to
+                    -- increase it by a few block heights to avoid the proof
+                    -- immediately expiring before it can be used.
+                    let trgLowestSafeHeight = min trgHeadHeight (trgLowestKnownHeight + proofSlack)
+                    max minTrgHeight trgLowestSafeHeight
     seekAncestor trgChain trgHeadHeader trgHeight >>= \case
         Just x -> return $! x
         Nothing -> throwM $ SpvExceptionTargetNotReachable
@@ -504,12 +527,11 @@ minimumTrgHeader headerDb tcid scid bh = do
             }
   where
     trgChain = headerDb ^?! ixg tcid
-    trgHeight
+    minTrgHeight
         | srcGraph == trgGraph = int bh + int srcDistance
         | otherwise = int bh + int srcDistance + int trgDistance
             -- This assumes that graph changes are at least graph-diameter
             -- blocks appart.
-
     srcGraph = chainGraphAt headerDb bh
     srcDistance = length $ shortestPath tcid scid srcGraph
     trgGraph = chainGraphAt headerDb (bh + int srcDistance)

test/unit/Chainweb/Test/Pact5/RemotePactTest.hs

@@ -363,44 +363,65 @@ spvExpirationTest baseRdb _step = runResourceT $ do
         send fx v srcChain [initiator]
         let initiatorReqKey = cmdToRequestKey initiator
 
-        -- You have to wait at least N blocks before attempting to run the continuation,
+        -- You have to wait at least a diameter to get the block.
         -- where N is the diameter of the graph + some constant. Here, we just run 10 blocks,
         -- because it is less than the minimumBlockHeaderHistory of the test version, but
         -- more than sufficient for the target chain to be aware of the source xchain transfer.
         let waitBlocks :: Integral a => a
-            waitBlocks = 10
+            waitBlocks = int $ diameter (chainGraphAt v maxBound) + 1
         let expirationWindow = fromMaybe (error "missing minimumBlockHeaderHistory") (minimumBlockHeaderHistory v maxBound)
         when (int expirationWindow < waitBlocks + diameter (chainGraphAt v maxBound)) $ assertFailure "test version has a minimumBlockHeaderHistory that is too short to test"
 
         replicateM_ waitBlocks $ advanceAllChains_ fx
+
         [Just sendCr] <- pollWithDepth fx v srcChain [initiatorReqKey] (Just (ConfirmationDepth 0))
         let cont = fromMaybe (error "missing continuation") (_crContinuation sendCr)
-        TransactionOutputProofB64 spvProof <- spvTxOutProof fx v targetChain srcChain initiatorReqKey
-        let contMsg = ContMsg
+
+        TransactionOutputProofB64 expiringSpvProof <- spvTxOutProof fx v targetChain srcChain initiatorReqKey
+        let expiringContMsg = ContMsg
                 { _cmPactId = _peDefPactId cont
                 , _cmStep = succ $ _peStep cont
                 , _cmRollback = _peStepHasRollback cont
                 , _cmData = PUnit
-                , _cmProof = Just (ContProof (T.encodeUtf8 spvProof))
+                , _cmProof = Just (ContProof (T.encodeUtf8 expiringSpvProof))
                 }
 
-        -- We have already run an extra 10 blocks since initiating the transfer.
         -- We need to wait for the full window to expire.
-
         -- still accessible at remainingWindow + diameter + 1 so we have to go one beyond
         let remainingWindow = int @_ @Int (int expirationWindow - waitBlocks + diameter (chainGraphAt v maxBound) + 2)
         replicateM_ remainingWindow $ advanceAllChains_ fx
 
+        expiringRecv <- buildTextCmd v
+            $ set cbRPC (mkCont expiringContMsg)
+            $ defaultCmd targetChain
+        send fx v targetChain [expiringRecv]
+        let expiringRecvReqKey = cmdToRequestKey expiringRecv
+        advanceAllChains_ fx
+        poll fx v targetChain [expiringRecvReqKey]
+            >>= P.match (_head . _Just)
+            ? P.checkAll
+                [ P.fun _crResult ? P.match _PactResultErr ? P.fun _peMsg ? P.equals "Continuation error: spv verification failed: target header is not in the chain or is out of bounds"
+                ]
+
+        TransactionOutputProofB64 spvWorkingProof <- spvTxOutProof fx v targetChain srcChain initiatorReqKey
+        let currentContMsg = ContMsg
+                { _cmPactId = _peDefPactId cont
+                , _cmStep = succ $ _peStep cont
+                , _cmRollback = _peStepHasRollback cont
+                , _cmData = PUnit
+                , _cmProof = Just (ContProof (T.encodeUtf8 spvWorkingProof))
+                }
+
         recv <- buildTextCmd v
-            $ set cbRPC (mkCont contMsg)
+            $ set cbRPC (mkCont currentContMsg)
             $ defaultCmd targetChain
         send fx v targetChain [recv]
         let recvReqKey = cmdToRequestKey recv
         advanceAllChains_ fx
         poll fx v targetChain [recvReqKey]
             >>= P.match (_head . _Just)
             ? P.checkAll
-                [ P.fun _crResult ? P.match _PactResultErr ? P.fun _peMsg ? P.equals "Continuation error: spv verification failed: target header is not in the chain or is out of bounds"
+                [ P.fun _crResult ? P.match _PactResultOk P.succeed
                 ]