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

Commit 96c3277

Browse files
kk-hainqkk-hainq
committed
ChainIndex: users can configure to only store txs from Alonzo onward
1 parent 56fc3fa commit 96c3277

File tree

8 files changed

+45
-27
lines changed

8 files changed

+45
-27
lines changed

‎plutus-chain-index/app/Config.hs‎

Lines changed: 9 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -17,7 +17,8 @@ module Config(
1717
port,
1818
networkId,
1919
securityParam,
20-
slotConfig
20+
slotConfig,
21+
alonzoOnward
2122
) where
2223

2324
import Cardano.Api (NetworkId (..))
@@ -34,8 +35,9 @@ data ChainIndexConfig = ChainIndexConfig
3435
, cicDbPath :: String
3536
, cicPort :: Int
3637
, cicNetworkId :: NetworkId
37-
, cicSecurityParam :: Int -- ^ The number of blocks after which a transaction cannot be rolled back anymore
38+
, cicSecurityParam :: Int -- ^ The number of blocks after which a transaction cannot be rolled back anymore.
3839
, cicSlotConfig :: SlotConfig
40+
, cicAlonzoOnward :: Bool -- ^ Only store transactions from Alonzo onward, only process tips and UTXOs before that.
3941
}
4042
deriving stock (Show, Eq, Generic)
4143
deriving anyclass (FromJSON, ToJSON)
@@ -61,15 +63,17 @@ defaultConfig = ChainIndexConfig
6163
{ scSlotZeroTime = 1591566291000
6264
, scSlotLength = 1000
6365
}
66+
, cicAlonzoOnward = False
6467
}
6568

6669
instance Pretty ChainIndexConfig where
67-
pretty ChainIndexConfig{cicSocketPath, cicDbPath, cicPort, cicNetworkId, cicSecurityParam} =
70+
pretty ChainIndexConfig{cicSocketPath, cicDbPath, cicPort, cicNetworkId, cicSecurityParam, cicAlonzoOnward} =
6871
vsep [ "Socket:" <+> pretty cicSocketPath
6972
, "Db:" <+> pretty cicDbPath
7073
, "Port:" <+> pretty cicPort
7174
, "Network Id:" <+> viaShow cicNetworkId
7275
, "Security Param:" <+> pretty cicSecurityParam
76+
, "Alonzo Onward:" <+> pretty cicAlonzoOnward
7377
]
7478

7579
makeLensesFor [
@@ -78,7 +82,8 @@ makeLensesFor [
7882
("cicPort", "port"),
7983
("cicNetworkId", "networkId"),
8084
("cicSecurityParam", "securityParam"),
81-
("cicSlotConfig", "slotConfig")
85+
("cicSlotConfig", "slotConfig"),
86+
("cicAlonzoOnward", "alonzoOnward")
8287
] 'ChainIndexConfig
8388

8489
newtype DecodeConfigException = DecodeConfigException String

‎plutus-chain-index/app/Main.hs‎

Lines changed: 17 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,7 @@
22
{-# LANGUAGE DeriveAnyClass #-}
33
{-# LANGUAGE DeriveGeneric #-}
44
{-# LANGUAGE DerivingStrategies #-}
5+
{-# LANGUAGE GADTs #-}
56
{-# LANGUAGE LambdaCase #-}
67
{-# LANGUAGE NamedFieldPuns #-}
78
{-# LANGUAGE OverloadedStrings #-}
@@ -34,7 +35,7 @@ import qualified Cardano.BM.Configuration.Model as CM
3435
import Cardano.BM.Setup (setupTrace_)
3536
import Cardano.BM.Trace (Trace, logDebug, logError)
3637

37-
import Cardano.Api (ChainPoint)
38+
import qualified Cardano.Api as C
3839
import Cardano.Protocol.Socket.Client (ChainSyncEvent (..), runChainSync)
3940
import CommandLine (AppConfig (..), Command (..), applyOverrides, cmdWithHelpParser)
4041
import qualified Config
@@ -69,31 +70,38 @@ runChainIndex runReq effect = do
6970

7071
chainSyncHandler
7172
:: RunRequirements
73+
-> Bool -- TODO: Needs to be a lot clearer
7274
-> ChainSyncEvent
7375
-> Slot
7476
-> IO ()
75-
chainSyncHandler runReq
76-
(RollForward block _) _ = do
77+
chainSyncHandler runReq alonzoOnward
78+
(RollForward block@(C.BlockInMode _ eraInMode) _) _ = do
7779
let ciBlock = fromCardanoBlock block
7880
case ciBlock of
7981
Left err ->
8082
logError (trace runReq) (ConversionFailed err)
81-
Right txs ->
82-
void $ runChainIndex runReq $ appendBlock (tipFromCardanoBlock block) txs
83-
chainSyncHandler runReq
83+
Right txs -> void $
84+
let toStoreTxs = not alonzoOnward || case eraInMode of
85+
C.ByronEraInCardanoMode -> False
86+
C.ShelleyEraInCardanoMode -> False
87+
C.AllegraEraInCardanoMode -> False
88+
C.MaryEraInCardanoMode -> False
89+
C.AlonzoEraInCardanoMode -> True
90+
in runChainIndex runReq $ appendBlock (tipFromCardanoBlock block) txs toStoreTxs
91+
chainSyncHandler runReq _
8492
(RollBackward point _) _ = do
8593
putStr "Rolling back to "
8694
print point
8795
-- Do we really want to pass the tip of the new blockchain to the
8896
-- rollback function (rather than the point where the chains diverge)?
8997
void $ runChainIndex runReq $ rollback (fromCardanoPoint point)
90-
chainSyncHandler runReq
98+
chainSyncHandler runReq _
9199
(Resume point) _ = do
92100
putStr "Resuming from "
93101
print point
94102
void $ runChainIndex runReq $ resumeSync $ fromCardanoPoint point
95103

96-
showResumePoints :: [ChainPoint] -> String
104+
showResumePoints :: [C.ChainPoint] -> String
97105
showResumePoints = \case
98106
[] -> "none"
99107
[x] -> showPoint x
@@ -167,7 +175,7 @@ main = do
167175
(Config.cicSlotConfig config)
168176
(Config.cicNetworkId config)
169177
resumePoints
170-
(chainSyncHandler runReq)
178+
(chainSyncHandler runReq (Config.cicAlonzoOnward config))
171179

172180
putStrLn $ "Starting webserver on port " <> show (Config.cicPort config)
173181
Server.serveChainIndexQueryServer (Config.cicPort config) runReq

‎plutus-chain-index/src/Plutus/ChainIndex/Effects.hs‎

Lines changed: 5 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -79,7 +79,11 @@ makeEffect ''ChainIndexQueryEffect
7979
data ChainIndexControlEffect r where
8080

8181
-- | Add a new block to the chain index by giving a new tip and list of tx.
82-
AppendBlock :: Tip -> [ChainIndexTx] -> ChainIndexControlEffect ()
82+
--
83+
-- The extra `Bool` determines if we want to store this batch of transactions.
84+
-- If `True` then yes, else only handle the tip and UTXOs.
85+
-- This, for example, enables applications to skip unneeded pre-Alonzo transactions.
86+
AppendBlock :: Tip -> [ChainIndexTx] -> Bool -> ChainIndexControlEffect ()
8387

8488
-- | Roll back to a previous state (previous tip)
8589
Rollback :: Point -> ChainIndexControlEffect ()

‎plutus-chain-index/src/Plutus/ChainIndex/Emulator/Handlers.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -164,7 +164,7 @@ handleControl ::
164164
=> ChainIndexControlEffect
165165
~> Eff effs
166166
handleControl = \case
167-
AppendBlock tip_ transactions -> do
167+
AppendBlock tip_ transactions toStoreTxs -> do
168168
oldState <- get @ChainIndexEmulatorState
169169
case UtxoState.insert (TxUtxoBalance.fromBlock tip_ transactions) (view utxoIndex oldState) of
170170
Left err -> do
@@ -174,7 +174,7 @@ handleControl = \case
174174
Right InsertUtxoSuccess{newIndex, insertPosition} -> do
175175
put $ oldState
176176
& set utxoIndex newIndex
177-
& over diskState (mappend $ foldMap DiskState.fromTx transactions)
177+
& over diskState (mappend $ foldMap DiskState.fromTx (if toStoreTxs then transactions else []))
178178
logDebug $ InsertionSuccess tip_ insertPosition
179179
Rollback tip_ -> do
180180
oldState <- get @ChainIndexEmulatorState

‎plutus-chain-index/src/Plutus/ChainIndex/Handlers.hs‎

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -21,6 +21,7 @@ module Plutus.ChainIndex.Handlers
2121
import qualified Cardano.Api as C
2222
import Control.Applicative (Const (..))
2323
import Control.Lens (Lens', _Just, ix, view, (^?))
24+
import Control.Monad (when)
2425
import Control.Monad.Freer (Eff, Member, type (~>))
2526
import Control.Monad.Freer.Error (Error, throwError)
2627
import Control.Monad.Freer.Extras.Beam (BeamEffect (..), BeamableSqlite, addRowsInBatches, combined,
@@ -241,7 +242,7 @@ handleControl ::
241242
=> ChainIndexControlEffect
242243
~> Eff effs
243244
handleControl = \case
244-
AppendBlock tip_ transactions -> do
245+
AppendBlock tip_ transactions toStoreTxs -> do
245246
oldIndex <- get @ChainIndexState
246247
let newUtxoState = TxUtxoBalance.fromBlock tip_ transactions
247248
case UtxoState.insert newUtxoState oldIndex of
@@ -256,7 +257,7 @@ handleControl = \case
256257
lbcResult -> do
257258
put $ UtxoState.reducedIndex lbcResult
258259
reduceOldUtxoDb $ UtxoState._usTip $ UtxoState.combinedState lbcResult
259-
insert $ foldMap fromTx transactions
260+
when toStoreTxs $ insert $ foldMap fromTx transactions
260261
insertUtxoDb newUtxoState
261262
logDebug $ InsertionSuccess tip_ insertPosition
262263
Rollback tip_ -> do

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

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -54,7 +54,7 @@ txFromTxIdSpec = property $ do
5454
(tip, block@(fstTx:_)) <- forAll $ Gen.evalTxGenState Gen.genNonEmptyBlock
5555
unknownTxId <- forAll Gen.genRandomTxId
5656
txs <- liftIO $ runEmulatedChainIndex mempty $ do
57-
appendBlock tip block
57+
appendBlock tip block True
5858
tx <- txFromTxId (view citxTxId fstTx)
5959
tx' <- txFromTxId unknownTxId
6060
pure (tx, tx')
@@ -76,7 +76,7 @@ eachTxOutRefAtAddressShouldBeUnspentSpec = property $ do
7676

7777
result <- liftIO $ runEmulatedChainIndex mempty $ do
7878
-- Append the generated block in the chain index
79-
appendBlock tip block
79+
appendBlock tip block True
8080

8181
forM addresses $ \addr -> do
8282
let pq = PageQuery 200 Nothing
@@ -103,7 +103,7 @@ eachTxOutRefWithCurrencyShouldBeUnspentSpec = property $ do
103103

104104
result <- liftIO $ runEmulatedChainIndex mempty $ do
105105
-- Append the generated block in the chain index
106-
appendBlock tip block
106+
appendBlock tip block True
107107

108108
forM assetClasses $ \ac -> do
109109
let pq = PageQuery 200 Nothing
@@ -126,7 +126,7 @@ cantRequestForTxOutRefsWithAdaSpec = property $ do
126126

127127
result <- liftIO $ runEmulatedChainIndex mempty $ do
128128
-- Append the generated block in the chain index
129-
appendBlock tip block
129+
appendBlock tip block True
130130

131131
let pq = PageQuery 200 Nothing
132132
(_, utxoRefs) <- utxoSetWithCurrency pq (AssetClass ("", ""))

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

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -59,7 +59,7 @@ txFromTxIdSpec = property $ do
5959
txs <- liftIO $ Sqlite.withConnection ":memory:" $ \conn -> do
6060
Sqlite.runBeamSqlite conn $ autoMigrate Sqlite.migrationBackend checkedSqliteDb
6161
liftIO $ runChainIndex conn $ do
62-
appendBlock tip block
62+
appendBlock tip block True
6363
tx <- txFromTxId (view citxTxId fstTx)
6464
tx' <- txFromTxId unknownTxId
6565
pure (tx, tx')
@@ -83,7 +83,7 @@ eachTxOutRefAtAddressShouldBeUnspentSpec = property $ do
8383
Sqlite.runBeamSqlite conn $ autoMigrate Sqlite.migrationBackend checkedSqliteDb
8484
liftIO $ runChainIndex conn $ do
8585
-- Append the generated block in the chain index
86-
appendBlock tip block
86+
appendBlock tip block True
8787

8888
forM addresses $ \addr -> do
8989
let pq = PageQuery 200 Nothing
@@ -113,7 +113,7 @@ eachTxOutRefWithCurrencyShouldBeUnspentSpec = property $ do
113113
Sqlite.runBeamSqlite conn $ autoMigrate Sqlite.migrationBackend checkedSqliteDb
114114
liftIO $ runChainIndex conn $ do
115115
-- Append the generated block in the chain index
116-
appendBlock tip block
116+
appendBlock tip block True
117117

118118
forM assetClasses $ \ac -> do
119119
let pq = PageQuery 200 Nothing
@@ -137,7 +137,7 @@ cantRequestForTxOutRefsWithAdaSpec = property $ do
137137
Sqlite.runBeamSqlite conn $ autoMigrate Sqlite.migrationBackend checkedSqliteDb
138138
liftIO $ runChainIndex conn $ do
139139
-- Append the generated block in the chain index
140-
appendBlock tip block
140+
appendBlock tip block True
141141

142142
let pq = PageQuery 200 Nothing
143143
(_, utxoRefs) <- utxoSetWithCurrency pq (AssetClass (Ada.adaSymbol, Ada.adaToken))

‎plutus-contract/src/Plutus/Trace/Emulator/System.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -150,4 +150,4 @@ appendNewTipBlock lastTip block newSlot = do
150150
$ (Text.encodeUtf8 . Text.pack . show . hash)
151151
$ foldMap (getTxId . eitherTx txId txId) block
152152
let newTip = Tip newSlot blockId nextBlockNo
153-
appendBlock newTip (fmap fromOnChainTx block)
153+
appendBlock newTip (fmap fromOnChainTx block) True

0 commit comments

Comments
 (0)