Fix currentChainIndexSlot

IntersectMBO · Nov 21, 2022 · 4014ac2 · 4014ac2
1 parent 2ae43b9
commit 4014ac2
Show file tree

Hide file tree

Showing 4 changed files with 57 additions and 20 deletions.
diff --git a/plutus-chain-index-core/src/Plutus/ChainIndex/Emulator/Handlers.hs b/plutus-chain-index-core/src/Plutus/ChainIndex/Emulator/Handlers.hs
@@ -278,16 +278,14 @@ appendBlocks [] = pure ()
 appendBlocks blocks = do
     let
         processBlock (utxoIndexState, txs) (Block tip_ transactions) = do
-            if null transactions then return (utxoIndexState, txs)
-            else do
-                case UtxoState.insert (TxUtxoBalance.fromBlock tip_ (map fst transactions)) utxoIndexState of
-                    Left err -> do
-                        let reason = InsertionFailed err
-                        logError $ Err reason
-                        return (utxoIndexState, txs)
-                    Right InsertUtxoSuccess{newIndex, insertPosition} -> do
-                        logDebug $ InsertionSuccess tip_ insertPosition
-                        return (newIndex, transactions ++ txs)
+            case UtxoState.insert (TxUtxoBalance.fromBlock tip_ (map fst transactions)) utxoIndexState of
+                Left err -> do
+                    let reason = InsertionFailed err
+                    logError $ Err reason
+                    return (utxoIndexState, txs)
+                Right InsertUtxoSuccess{newIndex, insertPosition} -> do
+                    logDebug $ InsertionSuccess tip_ insertPosition
+                    return (newIndex, transactions ++ txs)
     oldState <- get @ChainIndexEmulatorState
     (newIndex, transactions) <- foldM processBlock (view utxoIndex oldState, []) blocks
     put $ oldState

diff --git a/plutus-chain-index-core/src/Plutus/ChainIndex/Types.hs b/plutus-chain-index-core/src/Plutus/ChainIndex/Types.hs
@@ -315,9 +315,10 @@ instance Monoid Point where
     mempty = PointAtGenesis
 
 instance Ord Tip where
-    TipAtGenesis <= _            = True
-    _            <= TipAtGenesis = False
-    (Tip _ _ lb) <= (Tip _ _ rb) = lb <= rb
+    compare TipAtGenesis TipAtGenesis   = EQ
+    compare TipAtGenesis _              = LT
+    compare _            TipAtGenesis   = GT
+    compare (Tip ls _ lb) (Tip rs _ rb) = compare ls rs <> compare lb rb
 
 instance Pretty Tip where
     pretty TipAtGenesis = "TipAtGenesis"

diff --git a/plutus-chain-index-core/test/Plutus/ChainIndex/Emulator/HandlersSpec.hs b/plutus-chain-index-core/test/Plutus/ChainIndex/Emulator/HandlersSpec.hs
@@ -21,11 +21,11 @@ import Data.Sequence (Seq)
 import Data.Set qualified as S
 import Generators qualified as Gen
 import Plutus.ChainIndex (ChainIndexLog, ChainSyncBlock (Block), Page (pageItems), PageQuery (PageQuery),
-                          TxProcessOption (TxProcessOption, tpoStoreTx), appendBlocks, citxTxId, txFromTxId,
-                          unspentTxOutFromRef, utxoSetMembership, utxoSetWithCurrency)
+                          Tip (Tip, TipAtGenesis), TxProcessOption (TxProcessOption, tpoStoreTx), appendBlocks,
+                          citxTxId, tipSlot, txFromTxId, unspentTxOutFromRef, utxoSetMembership, utxoSetWithCurrency)
 import Plutus.ChainIndex.Api (UtxosResponse (UtxosResponse), isUtxo)
 import Plutus.ChainIndex.ChainIndexError (ChainIndexError)
-import Plutus.ChainIndex.Effects (ChainIndexControlEffect, ChainIndexQueryEffect)
+import Plutus.ChainIndex.Effects (ChainIndexControlEffect, ChainIndexQueryEffect, getTip)
 import Plutus.ChainIndex.Emulator.Handlers (ChainIndexEmulatorState, handleControl, handleQuery)
 import Plutus.ChainIndex.Tx (ChainIndexTxOut (citoValue), txOuts)
 import Plutus.V1.Ledger.Value (AssetClass (AssetClass), flattenValue)
@@ -41,6 +41,9 @@ tests = do
     [ testGroup "txFromTxId"
       [ testPropertyNamed "get tx from tx id" "txFromTxIdSpec" txFromTxIdSpec
       ]
+    , testGroup "noTxSlot"
+      [ testPropertyNamed "Adding empty slot updates the tip" "noTxSlot" noTxSlot
+      ]
     , testGroup "utxoSetAtAddress"
       [ testPropertyNamed "each txOutRef should be unspent" "eachTxOutRefAtAddressShouldBeUnspentSpec" eachTxOutRefAtAddressShouldBeUnspentSpec
       ]
@@ -73,6 +76,23 @@ txFromTxIdSpec = property $ do
     Right (Just tx, Nothing) -> fstTx === tx
     _                        -> Hedgehog.assert False
 
+-- | Test that when a new slot is appended without any blocks, the tip is still updated to the new slot.
+noTxSlot :: Property
+noTxSlot = property $ do
+  (tip, block) <- forAll $ Gen.evalTxGenState Gen.genNonEmptyBlock
+  case tip of
+    TipAtGenesis -> pure ()
+    (Tip _ blockId blockNo) -> do
+      let newSlot = succ $ tipSlot tip
+      res <- liftIO $ runEmulatedChainIndex mempty $ do
+          appendBlocks [Block tip (map (, def) block)]
+          appendBlocks [Block (Tip newSlot blockId blockNo) []]
+          tipSlot <$> getTip
+
+      case res of
+        Right slot' -> newSlot === slot'
+        Left _      -> Hedgehog.assert False
+
 -- | After generating and appending a block in the chain index, verify that
 -- querying the chain index with each of the addresses in the block returns
 -- unspent 'TxOutRef's.

diff --git a/plutus-chain-index-core/test/Plutus/ChainIndex/HandlersSpec.hs b/plutus-chain-index-core/test/Plutus/ChainIndex/HandlersSpec.hs
@@ -26,12 +26,12 @@ import Generators qualified as Gen
 import Hedgehog (MonadTest, Property, assert, failure, forAll, property, (===))
 import Ledger.Ada qualified as Ada
 import Plutus.ChainIndex (ChainIndexTxOut (citoValue), ChainSyncBlock (Block), Page (pageItems), PageQuery (PageQuery),
-                          RunRequirements (RunRequirements), TxProcessOption (TxProcessOption, tpoStoreTx),
-                          appendBlocks, citxTxId, runChainIndexEffects, txFromTxId, txOuts, unspentTxOutFromRef,
-                          utxoSetMembership, utxoSetWithCurrency)
+                          RunRequirements (RunRequirements), Tip (Tip, TipAtGenesis),
+                          TxProcessOption (TxProcessOption, tpoStoreTx), appendBlocks, citxTxId, runChainIndexEffects,
+                          tipSlot, txFromTxId, txOuts, unspentTxOutFromRef, utxoSetMembership, utxoSetWithCurrency)
 import Plutus.ChainIndex.Api (UtxosResponse (UtxosResponse), isUtxo)
 import Plutus.ChainIndex.DbSchema (checkedSqliteDb)
-import Plutus.ChainIndex.Effects (ChainIndexControlEffect, ChainIndexQueryEffect)
+import Plutus.ChainIndex.Effects (ChainIndexControlEffect, ChainIndexQueryEffect, getTip)
 import Plutus.V1.Ledger.Value (AssetClass (AssetClass), flattenValue)
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.Hedgehog (testPropertyNamed)
@@ -43,6 +43,9 @@ tests = do
     [ testGroup "txFromTxId"
       [ testPropertyNamed "get tx from tx id" "txFromTxIdSpec" txFromTxIdSpec
       ]
+    , testGroup "noTxSlot"
+      [ testPropertyNamed "Adding empty slot updates the tip" "noTxSlot" noTxSlot
+      ]
     , testGroup "utxoSetAtAddress"
       [ testPropertyNamed "each txOutRef should be unspent" "eachTxOutRefAtAddressShouldBeUnspentSpec" eachTxOutRefAtAddressShouldBeUnspentSpec
       ]
@@ -74,6 +77,21 @@ txFromTxIdSpec = property $ do
     (Just tx, Nothing) -> fstTx === tx
     _                  -> Hedgehog.assert False
 
+-- | Test that when a new slot is appended without any blocks, the tip is still updated to the new slot.
+noTxSlot :: Property
+noTxSlot = property $ do
+  (tip, block) <- forAll $ Gen.evalTxGenState Gen.genNonEmptyBlock
+  case tip of
+    TipAtGenesis -> pure ()
+    (Tip _ blockId blockNo) -> do
+      let newSlot = succ $ tipSlot tip
+      slot' <- runChainIndexTest $ do
+          appendBlocks [Block tip (map (, def) block)]
+          appendBlocks [Block (Tip newSlot blockId blockNo) []]
+          tipSlot <$> getTip
+
+      newSlot === slot'
+
 -- | After generating and appending a block in the chain index, verify that
 -- querying the chain index with each of the addresses in the block returns
 -- unspent 'TxOutRef's.