Skip to content
This repository was archived by the owner on Dec 2, 2024. It is now read-only.

Commit e7f560c

Browse files
kk-hainqkk-hainq
committed
plutus-chain-index-core: add BlockProcessOption tests.
Tighten and start sharing code among existing tests as well.
1 parent ffc5ed5 commit e7f560c

File tree

4 files changed

+93
-44
lines changed

4 files changed

+93
-44
lines changed

‎plutus-chain-index-core/plutus-chain-index-core.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -115,6 +115,7 @@ test-suite plutus-chain-index-test
115115
Plutus.ChainIndex.Emulator.DiskStateSpec
116116
Plutus.ChainIndex.Emulator.HandlersSpec
117117
Plutus.ChainIndex.HandlersSpec
118+
Util
118119
build-depends:
119120
plutus-ledger -any,
120121
plutus-ledger-api -any,

‎plutus-chain-index-core/test/Plutus/ChainIndex/Emulator/HandlersSpec.hs‎

Lines changed: 31 additions & 22 deletions
Original file line numberDiff line numberDiff line change
@@ -8,7 +8,7 @@
88
module Plutus.ChainIndex.Emulator.HandlersSpec (tests) where
99

1010
import Control.Lens
11-
import Control.Monad (forM, forM_)
11+
import Control.Monad (forM)
1212
import Control.Monad.Freer (Eff, interpret, reinterpret, runM)
1313
import Control.Monad.Freer.Error (Error, runError)
1414
import Control.Monad.Freer.Extras (LogMessage, LogMsg (..), handleLogWriter)
@@ -17,20 +17,22 @@ import Control.Monad.Freer.Writer (runWriter)
1717
import Control.Monad.IO.Class (liftIO)
1818
import Data.Default (def)
1919
import Data.Sequence (Seq)
20-
import Data.Set (member)
20+
import Data.Set qualified as S
2121
import Generators qualified as Gen
22-
import Ledger (Address (Address, addressCredential), TxOut (TxOut, txOutAddress), outValue)
22+
import Ledger (outValue)
2323
import Plutus.ChainIndex (ChainIndexLog, Page (pageItems), PageQuery (PageQuery), appendBlock, txFromTxId,
24-
utxoSetAtAddress, utxoSetWithCurrency)
24+
utxoSetMembership, utxoSetWithCurrency)
2525
import Plutus.ChainIndex.ChainIndexError (ChainIndexError)
2626
import Plutus.ChainIndex.Effects (ChainIndexControlEffect, ChainIndexQueryEffect)
2727
import Plutus.ChainIndex.Emulator.Handlers (ChainIndexEmulatorState, handleControl, handleQuery)
2828
import Plutus.ChainIndex.Tx (_ValidTx, citxOutputs, citxTxId)
29+
import Plutus.ChainIndex.Types (BlockProcessOption (..))
2930
import Plutus.V1.Ledger.Value (AssetClass (AssetClass), flattenValue)
3031

3132
import Hedgehog (Property, assert, forAll, property, (===))
3233
import Test.Tasty
3334
import Test.Tasty.Hedgehog (testProperty)
35+
import Util (utxoSetFromBlockAddrs)
3436

3537
tests :: TestTree
3638
tests = do
@@ -45,6 +47,9 @@ tests = do
4547
[ testProperty "each txOutRef should be unspent" eachTxOutRefWithCurrencyShouldBeUnspentSpec
4648
, testProperty "should restrict to non-ADA currencies" cantRequestForTxOutRefsWithAdaSpec
4749
]
50+
, testGroup "BlockProcessOption"
51+
[ testProperty "do not store txs" doNotStoreTxs
52+
]
4853
]
4954

5055
-- | Tests we can correctly query a tx in the database using a tx id. We also
@@ -70,24 +75,14 @@ eachTxOutRefAtAddressShouldBeUnspentSpec :: Property
7075
eachTxOutRefAtAddressShouldBeUnspentSpec = property $ do
7176
((tip, block), state) <- forAll $ Gen.runTxGenState Gen.genNonEmptyBlock
7277

73-
let addresses =
74-
fmap (\TxOut { txOutAddress = Address { addressCredential }} -> addressCredential)
75-
$ view (traverse . citxOutputs . _ValidTx) block
76-
7778
result <- liftIO $ runEmulatedChainIndex mempty $ do
7879
-- Append the generated block in the chain index
7980
appendBlock tip block def
80-
81-
forM addresses $ \addr -> do
82-
let pq = PageQuery 200 Nothing
83-
(_, utxoRefs) <- utxoSetAtAddress pq addr
84-
pure $ pageItems utxoRefs
81+
utxoSetFromBlockAddrs block
8582

8683
case result of
87-
Left _ -> Hedgehog.assert False
88-
Right utxoRefsGroups -> do
89-
forM_ (concat utxoRefsGroups) $ \utxoRef -> do
90-
Hedgehog.assert $ utxoRef `member` view Gen.txgsUtxoSet state
84+
Left _ -> Hedgehog.assert False
85+
Right utxoGroups -> S.fromList (concat utxoGroups) === view Gen.txgsUtxoSet state
9186

9287
-- | After generating and appending a block in the chain index, verify that
9388
-- querying the chain index with each of the asset classes in the block returns
@@ -111,11 +106,8 @@ eachTxOutRefWithCurrencyShouldBeUnspentSpec = property $ do
111106
pure $ pageItems utxoRefs
112107

113108
case result of
114-
Left _ -> Hedgehog.assert False
115-
Right utxoRefsGroups -> do
116-
let utxoRefs = concat utxoRefsGroups
117-
forM_ utxoRefs $ \utxoRef -> do
118-
Hedgehog.assert $ utxoRef `member` view Gen.txgsUtxoSet state
109+
Left _ -> Hedgehog.assert False
110+
Right utxoGroups -> S.fromList (concat utxoGroups) === view Gen.txgsUtxoSet state
119111

120112
-- | Requesting UTXOs containing Ada should not return anything because every
121113
-- transaction output must have a minimum of 1 ADA. So asking for UTXOs with ADA
@@ -136,6 +128,23 @@ cantRequestForTxOutRefsWithAdaSpec = property $ do
136128
Left _ -> Hedgehog.assert False
137129
Right utxoRefs -> Hedgehog.assert $ null utxoRefs
138130

131+
-- | Do not store txs through BlockProcessOption.
132+
-- The UTxO set must still be stored.
133+
-- But cannot be fetched through addresses as addresses are not stored.
134+
doNotStoreTxs :: Property
135+
doNotStoreTxs = property $ do
136+
((tip, block), state) <- forAll $ Gen.runTxGenState Gen.genNonEmptyBlock
137+
result <- liftIO $ runEmulatedChainIndex mempty $ do
138+
appendBlock tip block BlockProcessOption{bpoStoreTxs=False}
139+
tx <- txFromTxId (view citxTxId (head block))
140+
utxosFromAddr <- utxoSetFromBlockAddrs block
141+
utxosStored <- traverse utxoSetMembership (S.toList (view Gen.txgsUtxoSet state))
142+
pure (tx, concat utxosFromAddr, utxosStored)
143+
case result of
144+
Right (Nothing, [], utxosStored) -> Hedgehog.assert $ and (snd <$> utxosStored)
145+
_ -> Hedgehog.assert False
146+
147+
-- | Run an emulated chain index effect against a starting state
139148
runEmulatedChainIndex
140149
:: ChainIndexEmulatorState
141150
-> Eff '[ ChainIndexControlEffect

‎plutus-chain-index-core/test/Plutus/ChainIndex/HandlersSpec.hs‎

Lines changed: 34 additions & 22 deletions
Original file line numberDiff line numberDiff line change
@@ -8,31 +8,33 @@
88
module Plutus.ChainIndex.HandlersSpec (tests) where
99

1010
import Control.Concurrent.STM (newTVarIO)
11-
import Control.Lens
12-
import Control.Monad (forM, forM_)
11+
import Control.Lens (view)
12+
import Control.Monad (forM)
1313
import Control.Monad.Freer (Eff)
1414
import Control.Monad.Freer.Extras.Beam (BeamEffect)
1515
import Control.Monad.IO.Class (liftIO)
1616
import Control.Tracer (nullTracer)
1717
import Data.Default (def)
18-
import Data.Set (member)
18+
import Data.Set qualified as S
1919
import Database.Beam.Migrate.Simple (autoMigrate)
2020
import Database.Beam.Sqlite qualified as Sqlite
2121
import Database.Beam.Sqlite.Migrate qualified as Sqlite
2222
import Database.SQLite.Simple qualified as Sqlite
2323
import Generators qualified as Gen
2424
import Hedgehog (Property, assert, forAll, property, (===))
25-
import Ledger (Address (Address, addressCredential), TxOut (TxOut, txOutAddress), outValue)
25+
import Ledger (outValue)
2626
import Plutus.ChainIndex (Page (pageItems), PageQuery (PageQuery), RunRequirements (..), appendBlock, citxOutputs,
27-
runChainIndexEffects, txFromTxId, utxoSetAtAddress, utxoSetWithCurrency)
27+
runChainIndexEffects, txFromTxId, utxoSetMembership, utxoSetWithCurrency)
2828
import Plutus.ChainIndex.ChainIndexError (ChainIndexError (..))
2929
import Plutus.ChainIndex.DbSchema (checkedSqliteDb)
3030
import Plutus.ChainIndex.Effects (ChainIndexControlEffect, ChainIndexQueryEffect)
3131
import Plutus.ChainIndex.Tx (_ValidTx, citxTxId)
32+
import Plutus.ChainIndex.Types (BlockProcessOption (..))
3233
import Plutus.V1.Ledger.Ada qualified as Ada
3334
import Plutus.V1.Ledger.Value (AssetClass (AssetClass), flattenValue)
3435
import Test.Tasty
3536
import Test.Tasty.Hedgehog (testProperty)
37+
import Util (utxoSetFromBlockAddrs)
3638

3739
tests :: TestTree
3840
tests = do
@@ -47,6 +49,9 @@ tests = do
4749
[ testProperty "each txOutRef should be unspent" eachTxOutRefWithCurrencyShouldBeUnspentSpec
4850
, testProperty "should restrict to non-ADA currencies" cantRequestForTxOutRefsWithAdaSpec
4951
]
52+
, testGroup "BlockProcessOption"
53+
[ testProperty "do not store txs" doNotStoreTxs
54+
]
5055
]
5156

5257
-- | Tests we can correctly query a tx in the database using a tx id. We also
@@ -74,26 +79,16 @@ eachTxOutRefAtAddressShouldBeUnspentSpec :: Property
7479
eachTxOutRefAtAddressShouldBeUnspentSpec = property $ do
7580
((tip, block), state) <- forAll $ Gen.runTxGenState Gen.genNonEmptyBlock
7681

77-
let addresses =
78-
fmap (\TxOut { txOutAddress = Address { addressCredential }} -> addressCredential)
79-
$ view (traverse . citxOutputs . _ValidTx) block
80-
8182
result <- liftIO $ Sqlite.withConnection ":memory:" $ \conn -> do
8283
Sqlite.runBeamSqlite conn $ autoMigrate Sqlite.migrationBackend checkedSqliteDb
8384
liftIO $ runChainIndex conn $ do
8485
-- Append the generated block in the chain index
8586
appendBlock tip block def
86-
87-
forM addresses $ \addr -> do
88-
let pq = PageQuery 200 Nothing
89-
(_, utxoRefs) <- utxoSetAtAddress pq addr
90-
pure $ pageItems utxoRefs
87+
utxoSetFromBlockAddrs block
9188

9289
case result of
93-
Left _ -> Hedgehog.assert False
94-
Right utxoRefsGroups -> do
95-
forM_ (concat utxoRefsGroups) $ \utxoRef -> do
96-
Hedgehog.assert $ utxoRef `member` view Gen.txgsUtxoSet state
90+
Left _ -> Hedgehog.assert False
91+
Right utxoGroups -> S.fromList (concat utxoGroups) === view Gen.txgsUtxoSet state
9792

9893
-- | After generating and appending a block in the chain index, verify that
9994
-- querying the chain index with each of the addresses in the block returns
@@ -120,10 +115,8 @@ eachTxOutRefWithCurrencyShouldBeUnspentSpec = property $ do
120115
pure $ pageItems utxoRefs
121116

122117
case result of
123-
Left _ -> Hedgehog.assert False
124-
Right utxoRefsGroups -> do
125-
forM_ (concat utxoRefsGroups) $ \utxoRef ->
126-
Hedgehog.assert $ utxoRef `member` view Gen.txgsUtxoSet state
118+
Left _ -> Hedgehog.assert False
119+
Right utxoGroups -> S.fromList (concat utxoGroups) === view Gen.txgsUtxoSet state
127120

128121
-- | Requesting UTXOs containing Ada should not return anything because every
129122
-- transaction output must have a minimum of 1 ADA. So asking for UTXOs with ADA
@@ -146,6 +139,25 @@ cantRequestForTxOutRefsWithAdaSpec = property $ do
146139
Left _ -> Hedgehog.assert False
147140
Right utxoRefs -> Hedgehog.assert $ null utxoRefs
148141

142+
-- | Do not store txs through BlockProcessOption.
143+
-- The UTxO set must still be stored.
144+
-- But cannot be fetched through addresses as addresses are not stored.
145+
doNotStoreTxs :: Property
146+
doNotStoreTxs = property $ do
147+
((tip, block), state) <- forAll $ Gen.runTxGenState Gen.genNonEmptyBlock
148+
result <- liftIO $ Sqlite.withConnection ":memory:" $ \conn -> do
149+
Sqlite.runBeamSqlite conn $ autoMigrate Sqlite.migrationBackend checkedSqliteDb
150+
liftIO $ runChainIndex conn $ do
151+
appendBlock tip block BlockProcessOption{bpoStoreTxs=False}
152+
tx <- txFromTxId (view citxTxId (head block))
153+
utxosFromAddr <- utxoSetFromBlockAddrs block
154+
utxosStored <- traverse utxoSetMembership (S.toList (view Gen.txgsUtxoSet state))
155+
pure (tx, concat utxosFromAddr, utxosStored)
156+
case result of
157+
Right (Nothing, [], utxosStored) -> Hedgehog.assert $ and (snd <$> utxosStored)
158+
_ -> Hedgehog.assert False
159+
160+
-- | Run a chain index action against a SQLite connection.
149161
runChainIndex
150162
:: Sqlite.Connection
151163
-> Eff '[ ChainIndexQueryEffect

‎plutus-chain-index-core/test/Util.hs‎

Lines changed: 27 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,27 @@
1+
{-# LANGUAGE FlexibleContexts #-}
2+
{-# LANGUAGE MonoLocalBinds #-}
3+
{-# LANGUAGE NamedFieldPuns #-}
4+
5+
module Util where
6+
7+
import Control.Lens (view)
8+
import Control.Monad (forM)
9+
import Control.Monad.Freer (Eff, Member)
10+
import Ledger (Address (Address, addressCredential), TxOut (TxOut, txOutAddress), TxOutRef)
11+
import Ledger.Credential (Credential)
12+
import Plutus.ChainIndex (Page (pageItems), PageQuery (PageQuery), citxOutputs, utxoSetAtAddress)
13+
import Plutus.ChainIndex.Effects (ChainIndexQueryEffect)
14+
import Plutus.ChainIndex.Tx (ChainIndexTx, _ValidTx)
15+
16+
-- | Get all address credentials from a block.
17+
addrCredsFromBlock :: [ChainIndexTx] -> [Credential]
18+
addrCredsFromBlock =
19+
fmap (\TxOut { txOutAddress = Address { addressCredential }} -> addressCredential)
20+
. view (traverse . citxOutputs . _ValidTx)
21+
22+
-- | Get the UTxO set from a block.
23+
utxoSetFromBlockAddrs :: Member ChainIndexQueryEffect effs => [ChainIndexTx] -> Eff effs [[TxOutRef]]
24+
utxoSetFromBlockAddrs block = forM (addrCredsFromBlock block) $ \addr -> do
25+
let pq = PageQuery 200 Nothing
26+
(_, utxoRefs) <- utxoSetAtAddress pq addr
27+
pure $ pageItems utxoRefs

0 commit comments

Comments
 (0)