Merge pull request IntersectMBO#3941 from input-output-hk/scp-2736-more-property-tests

Fix bug in transactionStatus, and TxIdState tracking when rolling-back

Author: silky

plutus-chain-index/src/Plutus/ChainIndex/TxIdState.hs

@@ -12,8 +12,7 @@
 {-# LANGUAGE ViewPatterns          #-}
 
 module Plutus.ChainIndex.TxIdState(
-    isConfirmed
-    , increaseDepth
+    increaseDepth
     , initialStatus
     , transactionStatus
     , fromTx
@@ -41,13 +40,6 @@ initialStatus :: OnChainTx -> TxStatus
 initialStatus =
   TentativelyConfirmed 0 . eitherTx (const TxInvalid) (const TxValid)
 
--- | Whether a 'TxStatus' counts as confirmed given the minimum depth
-isConfirmed :: Depth -> TxStatus -> Bool
-isConfirmed minDepth = \case
-    TentativelyConfirmed d _ | d >= minDepth -> True
-    Committed{}                              -> True
-    _                                        -> False
-
 -- | Increase the depth of a tentatively confirmed transaction
 increaseDepth :: TxStatus -> TxStatus
 increaseDepth (TentativelyConfirmed d s)
@@ -68,18 +60,32 @@ transactionStatus currentBlock txIdState txId
        (Nothing, _)      -> Right Unknown
 
        (Just TxConfirmedState{blockAdded=Last (Just block'), validity=Last (Just validity')}, Nothing) ->
-         if block' + (fromIntegral chainConstant) >= currentBlock
-            then Right $ newStatus block' validity'
-            else Right $ Committed validity'
+         if isCommitted block'
+            then Right $ Committed validity'
+            else Right $ newStatus block' validity'
 
        (Just TxConfirmedState{timesConfirmed=confirms, blockAdded=Last (Just block'), validity=Last (Just validity')}, Just deletes) ->
-         if confirms >= deletes
+         if confirms > deletes
+            -- It's fine, it's confirmed
             then Right $ newStatus block' validity'
-            else Right $ Unknown
+            -- Otherwise, throw an error if it looks deleted but we're too far
+            -- into the future.
+            else if isCommitted block'
+                    -- Illegal - We can't roll this transaction back.
+                    then Left $ InvalidRollbackAttempt currentBlock txId txIdState
+                    else Right $ Unknown
 
        _ -> Left $ TxIdStateInvalid currentBlock txId txIdState
     where
-      newStatus block' validity' = TentativelyConfirmed (Depth $ fromIntegral $ currentBlock - block') validity'
+      -- A block is committed at least 'chainConstant' number of blocks
+      -- has elapsed since the block was added.
+      isCommitted addedInBlock = currentBlock > addedInBlock + fromIntegral chainConstant
+
+      newStatus block' validity' =
+        if isCommitted block'
+           then Committed validity'
+           else TentativelyConfirmed (Depth $ fromIntegral $ currentBlock - block') validity'
+
       confirmed = Map.lookup txId (txnsConfirmed txIdState)
       deleted   = Map.lookup txId (txnsDeleted txIdState)
 
@@ -104,7 +110,7 @@ fromTx blockAdded tx =
         Map.singleton
           (tx ^. citxTxId)
           (TxConfirmedState { timesConfirmed = Sum 1
-                            , blockAdded = Last (Just blockAdded)
+                            , blockAdded = Last . Just $ blockAdded
                             , validity = Last . Just $ validityFromChainIndex tx })
     , txnsDeleted = mempty
     }
@@ -123,12 +129,14 @@ rollback targetPoint idx@(viewTip -> currentTip)
         case tip (measure before) of
             TipAtGenesis -> Left $ OldPointNotFound targetPoint
             oldTip | targetPoint `pointsToTip` oldTip ->
-                      let x = _usTxUtxoData (measure deleted)
+                      let oldTxIdState = _usTxUtxoData (measure deleted)
                           newTxIdState = TxIdState
                                             { txnsConfirmed = mempty
-                                            , txnsDeleted = const 1 <$> txnsConfirmed x
+                                            -- All the transactions that were confirmed in the deleted
+                                            -- section are now deleted.
+                                            , txnsDeleted = const 1 <$> txnsConfirmed oldTxIdState
                                             }
-                          newUtxoState = UtxoState newTxIdState oldTip
+                          newUtxoState = UtxoState (oldTxIdState <> newTxIdState) oldTip
                        in Right RollbackResult{newTip=oldTip, rolledBackIndex=before |> newUtxoState }
                    | otherwise -> Left  TipMismatch{foundTip=oldTip, targetPoint}
     where

plutus-chain-index/src/Plutus/ChainIndex/Types.hs

@@ -220,11 +220,12 @@ data Diagnostics =
         deriving stock (Eq, Ord, Show, Generic)
         deriving anyclass (ToJSON, FromJSON)
 
-data TxStatusFailure =
+data TxStatusFailure
       -- | We couldn't return the status because the 'TxIdState' was in a ...
       -- state ... that we didn't know how to decode in
       -- 'Plutus.ChainIndex.TxIdState.transactionStatus'.
-      TxIdStateInvalid BlockNumber TxId TxIdState
+      = TxIdStateInvalid BlockNumber TxId TxIdState
+      | InvalidRollbackAttempt BlockNumber TxId TxIdState
       deriving (Show, Eq)
 
 data TxIdState = TxIdState

plutus-chain-index/test/Generators.hs

@@ -25,7 +25,8 @@ module Generators(
     execTxIdGenState,
     txgsBlocks,
     txgsNumTransactions,
-    genTxIdStateTipAndTxId
+    genTxIdStateTipAndTxId,
+    txIdFromInt
     ) where
 
 import           Codec.Serialise             (serialise)

plutus-chain-index/test/Spec.hs

@@ -15,6 +15,7 @@ import           Data.Either                          (isRight)
 import           Data.FingerTree                      (Measured (..))
 import           Data.Foldable                        (fold, toList)
 import           Data.List                            (nub, sort)
+import qualified Data.Map                             as Map
 import qualified Data.Set                             as Set
 import qualified Generators                           as Gen
 import           Hedgehog                             (Property, annotateShow, assert, failure, forAll, property, (===))
@@ -24,7 +25,8 @@ import qualified Plutus.ChainIndex.Emulator.DiskState as DiskState
 import           Plutus.ChainIndex.Tx                 (citxTxId, txOutsWithRef)
 import           Plutus.ChainIndex.TxIdState          (increaseDepth, transactionStatus)
 import qualified Plutus.ChainIndex.TxIdState          as TxIdState
-import           Plutus.ChainIndex.Types              (BlockNumber (..), Depth (..), Tip (..), TxStatus (..),
+import           Plutus.ChainIndex.Types              (BlockNumber (..), Depth (..), Tip (..), TxConfirmedState (..),
+                                                       TxIdState (..), TxStatus (..), TxStatusFailure (..),
                                                        TxValidity (..), tipAsPoint)
 import           Plutus.ChainIndex.UtxoState          (InsertUtxoSuccess (..), RollbackResult (..), TxUtxoBalance (..))
 import qualified Plutus.ChainIndex.UtxoState          as UtxoState
@@ -97,13 +99,37 @@ rollbackTxIdState = property $ do
       Right s4 = UtxoState.insert (UtxoState.UtxoState (TxIdState.fromTx (BlockNumber 2) txB) tipB) f3
       f4 = newIndex s4
 
-      status2 = transactionStatus (BlockNumber 1) (getState f2) (txB ^. citxTxId)
-      status3 = transactionStatus (BlockNumber 2) (getState f3) (txB ^. citxTxId)
-      status4 = transactionStatus (BlockNumber 3) (getState f4) (txB ^. citxTxId)
-
-  status2 === (Right $ TentativelyConfirmed (Depth 0) TxValid)
-  status3 === (Right $ Unknown)
-  status4 === (Right $ TentativelyConfirmed (Depth 1) TxValid)
+  let confirmed tx txIdState = (timesConfirmed <$> ( Map.lookup (tx ^. citxTxId) $ txnsConfirmed $ getState txIdState))
+      deleted tx txIdState = (Map.lookup (tx ^. citxTxId) $ txnsDeleted $ getState txIdState)
+      status bn tx txIdState = transactionStatus (BlockNumber bn) (getState txIdState) (tx ^. citxTxId)
+
+      isInvalidRollback (Left (InvalidRollbackAttempt _ _ _)) = True
+      isInvalidRollback _                                     = False
+
+  -- It's inserted at f2, and is confirmed once and not deleted, resulting
+  -- in a tentatively-confirmed status.
+  confirmed txB f2 === Just 1
+  deleted txB f2   === Nothing
+  status 1 txB f2  === (Right $ TentativelyConfirmed (Depth 0) TxValid)
+
+  -- At f3, it's deleted once, and confirmed once, resulting in an unknown
+  -- status.
+  confirmed txB f3 === Just 1
+  deleted txB f3   === Just 1
+  status 2 txB f3  === (Right $ Unknown)
+
+  -- If we check the status far into the future, this should be an error, as
+  -- we're trying to rollback something that is committed.
+  isInvalidRollback (status 100 txB f3) === True
+
+  -- At f4, it's confirmed twice, and deleted once, resulting in a
+  -- tentatively-confirmed status again.
+  confirmed txB f4 === Just 2
+  deleted txB f4   === Just 1
+  status 3 txB f4  === (Right $ TentativelyConfirmed (Depth 1) TxValid)
+
+  -- Much later, it should be committed.
+  status 100 txB f4 === Right (Committed TxValid)
 
 transactionDepthIncreases :: Property
 transactionDepthIncreases = property $ do