Skip to content

Commit 4675c19

Browse files
erikderikd
authored
Merge pull request IntersectMBO#1223 from input-output-hk/erikd/no-foreign-keys-does-this-work-3
Reduce use of foreign key constraints and depend more heavily on BlockNo
2 parents 5d26190 + 58147d5 commit 4675c19

Some content is hidden

Large Commits have some content hidden by default. Use the searchbox below for content that may be hidden.

64 files changed

+1248
-1652
lines changed

‎cardano-chain-gen/src/Cardano/Mock/Forging/Interpreter.hs

+15-15
Original file line numberDiff line numberDiff line change
@@ -32,7 +32,7 @@ module Cardano.Mock.Forging.Interpreter
3232

3333
import Cardano.Prelude (bimap, getField, throwIO)
3434

35-
import Control.Monad (forM, when)
35+
import Control.Monad (forM, void, when)
3636
import Control.Monad.Except (runExcept)
3737
import Control.Tracer (Tracer)
3838

@@ -271,20 +271,20 @@ forgeNext interpreter testBlock =
271271

272272
forgeNextLeaders :: Interpreter -> [TxEra] -> [BlockForging IO CardanoBlock] -> IO CardanoBlock
273273
forgeNextLeaders interpreter txes possibleLeaders = do
274-
interState <- getCurrentInterpreterState interpreter
275-
(blk, fingerprint) <- tryOrValidateSlot interState possibleLeaders
276-
let !chain' = extendChainDB (istChain interState) blk
277-
let !newSt = currentState chain'
278-
let newInterState =
279-
InterpreterState
280-
{ istChain = chain'
281-
, istForecast = mkForecast cfg newSt
282-
, istSlot = blockSlot blk + 1
283-
, istNextBlockNo = blockNo blk + 1
284-
, istFingerprint = fingerprint
285-
}
286-
_ <- swapMVar (interpState interpreter) newInterState
287-
pure blk
274+
interState <- getCurrentInterpreterState interpreter
275+
(blk, fingerprint) <- tryOrValidateSlot interState possibleLeaders
276+
let !chain' = extendChainDB (istChain interState) blk
277+
let !newSt = currentState chain'
278+
let newInterState =
279+
InterpreterState
280+
{ istChain = chain'
281+
, istForecast = mkForecast cfg newSt
282+
, istSlot = blockSlot blk + 1
283+
, istNextBlockNo = blockNo blk + 1
284+
, istFingerprint = fingerprint
285+
}
286+
void $ swapMVar (interpState interpreter) newInterState
287+
pure blk
288288
where
289289
cfg :: TopLevelConfig CardanoBlock
290290
cfg = interpTopLeverConfig interpreter

‎cardano-chain-gen/test/Test/Cardano/Db/Mock/Config.hs

+43-44
Original file line numberDiff line numberDiff line change
@@ -79,17 +79,17 @@ import Cardano.Node.Types (ProtocolFilepaths (..))
7979

8080

8181
data Config = Config
82-
{ topLevelConfig :: TopLevelConfig CardanoBlock
83-
, protocolInfo :: Consensus.ProtocolInfo IO CardanoBlock
84-
, protocolInfoForging :: Consensus.ProtocolInfo IO CardanoBlock
85-
, syncNodeParams :: SyncNodeParams
86-
}
82+
{ topLevelConfig :: TopLevelConfig CardanoBlock
83+
, protocolInfo :: Consensus.ProtocolInfo IO CardanoBlock
84+
, protocolInfoForging :: Consensus.ProtocolInfo IO CardanoBlock
85+
, syncNodeParams :: SyncNodeParams
86+
}
8787

8888
data DBSyncEnv = DBSyncEnv
89-
{ dbSyncParams :: SyncNodeParams
90-
, dbSyncForkDB :: IO (Async ())
91-
, dbSyncThreadVar :: TMVar (Async ())
92-
}
89+
{ dbSyncParams :: SyncNodeParams
90+
, dbSyncForkDB :: IO (Async ())
91+
, dbSyncThreadVar :: TMVar (Async ())
92+
}
9393

9494
rootTestDir :: FilePath
9595
rootTestDir = "test/testfiles"
@@ -110,10 +110,10 @@ mkDBSyncEnv :: SyncNodeParams -> IO () -> IO DBSyncEnv
110110
mkDBSyncEnv params runDBSync = do
111111
runningVar <- newEmptyTMVarIO
112112
pure $ DBSyncEnv
113-
{ dbSyncParams = params
114-
, dbSyncForkDB = async runDBSync
115-
, dbSyncThreadVar = runningVar
116-
}
113+
{ dbSyncParams = params
114+
, dbSyncForkDB = async runDBSync
115+
, dbSyncThreadVar = runningVar
116+
}
117117

118118
stopDBSync :: DBSyncEnv -> IO ()
119119
stopDBSync env = do
@@ -123,7 +123,7 @@ stopDBSync env = do
123123
Just a -> do
124124
cancel a
125125
-- make it empty
126-
_ <- atomically $ takeTMVar (dbSyncThreadVar env)
126+
void . atomically $ takeTMVar (dbSyncThreadVar env)
127127
pure ()
128128

129129
stopDBSyncIfRunning :: DBSyncEnv -> IO ()
@@ -135,17 +135,15 @@ stopDBSyncIfRunning env = do
135135
cancel a
136136
-- make it empty
137137
void . atomically $ takeTMVar (dbSyncThreadVar env)
138-
pure ()
139138

140139
startDBSync :: DBSyncEnv -> IO ()
141140
startDBSync env = do
142-
thr <- atomically $ tryReadTMVar $ dbSyncThreadVar env
143-
case thr of
144-
Just _a -> error "db-sync already running"
145-
Nothing -> do
146-
a <- dbSyncForkDB env
147-
_ <- atomically $ tryPutTMVar (dbSyncThreadVar env) a
148-
pure ()
141+
thr <- atomically $ tryReadTMVar (dbSyncThreadVar env)
142+
case thr of
143+
Just _a -> error "db-sync already running"
144+
Nothing -> do
145+
a <- dbSyncForkDB env
146+
void . atomically $ tryPutTMVar (dbSyncThreadVar env) a
149147

150148
pollDBSync :: DBSyncEnv -> IO (Maybe (Either SomeException ()))
151149
pollDBSync env = do
@@ -155,8 +153,7 @@ pollDBSync env = do
155153
Just a -> poll a
156154

157155
withDBSyncEnv :: IO DBSyncEnv -> (DBSyncEnv -> IO a) -> IO a
158-
withDBSyncEnv mkEnv action = do
159-
bracket mkEnv stopDBSyncIfRunning action
156+
withDBSyncEnv mkEnv = bracket mkEnv stopDBSyncIfRunning
160157

161158
getDBSyncPGPass :: DBSyncEnv -> Db.PGPassSource
162159
getDBSyncPGPass = enpPGPassSource . dbSyncParams
@@ -174,19 +171,19 @@ getPoolLayer env = do
174171

175172
setupTestsDir :: FilePath -> IO ()
176173
setupTestsDir dir = do
177-
eitherM (panic . textShow) pure $ runExceptT $
178-
CLI.runGenesisCmd $ GenesisCreateStaked
179-
(CLI.GenesisDir dir) 3 3 3 3 Nothing (Just 3000000) 3000000 (Testnet $ NetworkMagic 42) 1 3 0
174+
eitherM (panic . textShow) pure $ runExceptT $
175+
CLI.runGenesisCmd $ GenesisCreateStaked
176+
(CLI.GenesisDir dir) 3 3 3 3 Nothing (Just 3000000) 3000000 (Testnet $ NetworkMagic 42) 1 3 0
180177

181178
mkConfig :: FilePath -> FilePath -> IO Config
182179
mkConfig staticDir mutableDir = do
183-
config <- readSyncNodeConfig $ ConfigFile ( staticDir </> "test-db-sync-config.json")
184-
genCfg <- either (error . Text.unpack . renderSyncNodeError) id <$> runExceptT (readCardanoGenesisConfig config)
185-
let pInfoDbSync = mkProtocolInfoCardano genCfg []
186-
creds <- mkShelleyCredentials $ staticDir </> "pools" </> "bulk1.creds"
187-
let pInfoForger = mkProtocolInfoCardano genCfg creds
188-
syncPars <- mkSyncNodeParams staticDir mutableDir
189-
pure $ Config (Consensus.pInfoConfig pInfoDbSync) pInfoDbSync pInfoForger syncPars
180+
config <- readSyncNodeConfig $ ConfigFile ( staticDir </> "test-db-sync-config.json")
181+
genCfg <- either (error . Text.unpack . renderSyncNodeError) id <$> runExceptT (readCardanoGenesisConfig config)
182+
let pInfoDbSync = mkProtocolInfoCardano genCfg []
183+
creds <- mkShelleyCredentials $ staticDir </> "pools" </> "bulk1.creds"
184+
let pInfoForger = mkProtocolInfoCardano genCfg creds
185+
syncPars <- mkSyncNodeParams staticDir mutableDir
186+
pure $ Config (Consensus.pInfoConfig pInfoDbSync) pInfoDbSync pInfoForger syncPars
190187

191188
mkShelleyCredentials :: FilePath -> IO [ShelleyLeaderCredentials StandardCrypto]
192189
mkShelleyCredentials bulkFile = do
@@ -218,16 +215,18 @@ mkSyncNodeParams staticDir mutableDir = do
218215
}
219216

220217
emptyMetricsSetters :: MetricSetters
221-
emptyMetricsSetters = MetricSetters
222-
{ metricsSetNodeBlockHeight = \_ -> pure ()
223-
, metricsSetDbQueueLength = \_ -> pure ()
224-
, metricsSetDbBlockHeight = \_ -> pure ()
225-
, metricsSetDbSlotHeight = \_ -> pure ()
226-
}
218+
emptyMetricsSetters =
219+
MetricSetters
220+
{ metricsSetNodeBlockHeight = \_ -> pure ()
221+
, metricsSetDbQueueLength = \_ -> pure ()
222+
, metricsSetDbBlockHeight = \_ -> pure ()
223+
, metricsSetDbSlotHeight = \_ -> pure ()
224+
}
227225

228-
withFullConfig :: FilePath -> FilePath
229-
-> (Interpreter -> ServerHandle IO CardanoBlock -> DBSyncEnv -> IO ())
230-
-> IOManager -> [(Text, Text)] -> IO ()
226+
withFullConfig
227+
:: FilePath -> FilePath
228+
-> (Interpreter -> ServerHandle IO CardanoBlock -> DBSyncEnv -> IO ())
229+
-> IOManager -> [(Text, Text)] -> IO ()
231230
withFullConfig config testLabel action iom migr = do
232231
recreateDir mutableDir
233232
cfg <- mkConfig configDir mutableDir
@@ -246,7 +245,7 @@ withFullConfig config testLabel action iom migr = do
246245
$ \mockServer ->
247246
-- we dont fork dbsync here. Just prepare it as an action
248247
withDBSyncEnv (mkDBSyncEnv dbsyncParams dbsyncRun) $ \dbSync -> do
249-
_ <- hSilence [stderr] $ Db.recreateDB (getDBSyncPGPass dbSync)
248+
void . hSilence [stderr] $ Db.recreateDB (getDBSyncPGPass dbSync)
250249
action interpreter mockServer dbSync
251250
where
252251
configDir = mkConfigDir config

‎cardano-chain-gen/test/Test/Cardano/Db/Mock/UnifiedApi.hs

+46-40
Original file line numberDiff line numberDiff line change
@@ -20,22 +20,24 @@ module Test.Cardano.Db.Mock.UnifiedApi
2020

2121
import Data.Word (Word64)
2222

23-
import Cardano.Slotting.Slot (SlotNo (..))
24-
23+
import Cardano.Ledger.Alonzo (AlonzoEra)
2524
import qualified Cardano.Ledger.Core as Core
2625

27-
import Ouroboros.Consensus.Cardano.Block (StandardAlonzo, StandardBabbage,
28-
StandardShelley)
29-
import Ouroboros.Consensus.Ledger.Basics (LedgerState)
30-
import Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock)
31-
3226
import Cardano.Mock.ChainSync.Server
3327
import Cardano.Mock.Forging.Interpreter
3428
import Cardano.Mock.Forging.Types
3529

30+
import Cardano.Slotting.Slot (SlotNo (..))
31+
3632
import Control.Monad (forM, replicateM)
3733
import Control.Monad.Class.MonadSTM.Strict (atomically)
3834

35+
import Ouroboros.Consensus.Cardano.Block (ShelleyEra, StandardAlonzo, StandardBabbage,
36+
StandardCrypto)
37+
import Ouroboros.Consensus.Ledger.Basics (LedgerState)
38+
import Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock)
39+
40+
3941

4042
forgeNextAndSubmit :: Interpreter -> ServerHandle IO CardanoBlock -> MockBlock -> IO CardanoBlock
4143
forgeNextAndSubmit inter mockServer testBlock = do
@@ -45,9 +47,9 @@ forgeNextAndSubmit inter mockServer testBlock = do
4547

4648
forgeNextFindLeaderAndSubmit :: Interpreter -> ServerHandle IO CardanoBlock -> [TxEra] -> IO CardanoBlock
4749
forgeNextFindLeaderAndSubmit interpreter mockServer txs' = do
48-
blk <- forgeNextFindLeader interpreter txs'
49-
atomically $ addBlock mockServer blk
50-
pure blk
50+
blk <- forgeNextFindLeader interpreter txs'
51+
atomically $ addBlock mockServer blk
52+
pure blk
5153

5254
forgeNextSkipSlotsFindLeaderAndSubmit :: Interpreter -> ServerHandle IO CardanoBlock -> Word64 -> [TxEra] -> IO CardanoBlock
5355
forgeNextSkipSlotsFindLeaderAndSubmit interpreter mockServer skipSlots txs' = do
@@ -56,12 +58,13 @@ forgeNextSkipSlotsFindLeaderAndSubmit interpreter mockServer skipSlots txs' = d
5658
pure blk
5759

5860
forgeAndSubmitBlocks :: Interpreter -> ServerHandle IO CardanoBlock -> Int -> IO [CardanoBlock]
59-
forgeAndSubmitBlocks interpreter mockServer blocksToCreate = do
61+
forgeAndSubmitBlocks interpreter mockServer blocksToCreate =
6062
forM [1..blocksToCreate] $ \_ -> forgeNextFindLeaderAndSubmit interpreter mockServer []
6163

6264
withAlonzoFindLeaderAndSubmit
6365
:: Interpreter -> ServerHandle IO CardanoBlock
64-
-> (LedgerState (ShelleyBlock TPraosStandard StandardAlonzo) -> Either ForgingError [Core.Tx StandardAlonzo])
66+
-> (LedgerState (ShelleyBlock TPraosStandard StandardAlonzo)
67+
-> Either ForgingError [Core.Tx (AlonzoEra StandardCrypto)])
6568
-> IO CardanoBlock
6669
withAlonzoFindLeaderAndSubmit interpreter mockServer mkTxs = do
6770
alTxs <- withAlonzoLedgerState interpreter mkTxs
@@ -77,7 +80,8 @@ withBabbageFindLeaderAndSubmit interpreter mockServer mkTxs = do
7780

7881
withAlonzoFindLeaderAndSubmitTx
7982
:: Interpreter -> ServerHandle IO CardanoBlock
80-
-> (LedgerState (ShelleyBlock TPraosStandard StandardAlonzo) -> Either ForgingError (Core.Tx StandardAlonzo))
83+
-> (LedgerState (ShelleyBlock TPraosStandard StandardAlonzo)
84+
-> Either ForgingError (Core.Tx (AlonzoEra StandardCrypto)))
8185
-> IO CardanoBlock
8286
withAlonzoFindLeaderAndSubmitTx interpreter mockServer mkTxs = do
8387
withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do
@@ -95,20 +99,22 @@ withBabbageFindLeaderAndSubmitTx interpreter mockServer mkTxs = do
9599

96100
withShelleyFindLeaderAndSubmit
97101
:: Interpreter -> ServerHandle IO CardanoBlock
98-
-> (LedgerState (ShelleyBlock TPraosStandard StandardShelley) -> Either ForgingError [Core.Tx StandardShelley])
102+
-> (LedgerState (ShelleyBlock TPraosStandard (ShelleyEra StandardCrypto))
103+
-> Either ForgingError [Core.Tx (ShelleyEra StandardCrypto)])
99104
-> IO CardanoBlock
100105
withShelleyFindLeaderAndSubmit interpreter mockServer mkTxs = do
101106
alTxs <- withShelleyLedgerState interpreter mkTxs
102107
forgeNextFindLeaderAndSubmit interpreter mockServer (TxShelley <$> alTxs)
103108

104109
withShelleyFindLeaderAndSubmitTx
105110
:: Interpreter -> ServerHandle IO CardanoBlock
106-
-> (LedgerState (ShelleyBlock TPraosStandard StandardShelley) -> Either ForgingError (Core.Tx StandardShelley))
111+
-> (LedgerState (ShelleyBlock TPraosStandard (ShelleyEra StandardCrypto))
112+
-> Either ForgingError (Core.Tx (ShelleyEra StandardCrypto)))
107113
-> IO CardanoBlock
108-
withShelleyFindLeaderAndSubmitTx interpreter mockServer mkTxs = do
109-
withShelleyFindLeaderAndSubmit interpreter mockServer $ \st -> do
110-
tx <- mkTxs st
111-
pure [tx]
114+
withShelleyFindLeaderAndSubmitTx interpreter mockServer mkTxs =
115+
withShelleyFindLeaderAndSubmit interpreter mockServer $ \st -> do
116+
tx <- mkTxs st
117+
pure [tx]
112118

113119
getAlonzoLedgerState :: Interpreter -> IO (LedgerState (ShelleyBlock TPraosStandard StandardAlonzo))
114120
getAlonzoLedgerState interpreter = withAlonzoLedgerState interpreter Right
@@ -118,44 +124,44 @@ getBabbageLedgerState interpreter = withBabbageLedgerState interpreter Right
118124

119125
skipUntilNextEpoch :: Interpreter -> ServerHandle IO CardanoBlock -> [TxEra] -> IO CardanoBlock
120126
skipUntilNextEpoch interpreter mockServer txsEra = do
121-
slot <- getCurrentSlot interpreter
122-
let skipSlots = 500 - mod (unSlotNo slot) 500
123-
blk <- forgeNextAfter interpreter skipSlots txsEra
124-
atomically $ addBlock mockServer blk
125-
pure blk
127+
slot <- getCurrentSlot interpreter
128+
let skipSlots = 500 - mod (unSlotNo slot) 500
129+
blk <- forgeNextAfter interpreter skipSlots txsEra
130+
atomically $ addBlock mockServer blk
131+
pure blk
126132

127133
-- First block of next epoch is also submited
128134
fillUntilNextEpoch :: Interpreter -> ServerHandle IO CardanoBlock -> IO [CardanoBlock]
129135
fillUntilNextEpoch interpreter mockServer = do
130-
startingEpochNo <- getCurrentEpoch interpreter
131-
let
132-
go n blks = do
133-
blk <- forgeNextFindLeader interpreter []
134-
atomically $ addBlock mockServer blk
135-
epochNo' <- getCurrentEpoch interpreter
136-
if epochNo' == startingEpochNo
136+
startingEpochNo <- getCurrentEpoch interpreter
137+
let
138+
go :: Int -> [CardanoBlock] -> IO [CardanoBlock]
139+
go n blks = do
140+
blk <- forgeNextFindLeader interpreter []
141+
atomically $ addBlock mockServer blk
142+
epochNo' <- getCurrentEpoch interpreter
143+
if epochNo' == startingEpochNo
137144
then go (n + 1) (blk : blks)
138145
else pure $ reverse (blk : blks)
139-
go (0 :: Int) []
146+
go (0 :: Int) []
140147

141148
-- | Returns number of blocks submitted
142149
fillEpochs :: Interpreter -> ServerHandle IO CardanoBlock -> Int -> IO [CardanoBlock]
143-
fillEpochs interpreter mockServer epochs = do
144-
blks <- replicateM epochs $ fillUntilNextEpoch interpreter mockServer
145-
pure $ concat blks
150+
fillEpochs interpreter mockServer epochs =
151+
concat <$> replicateM epochs (fillUntilNextEpoch interpreter mockServer)
146152

147153
-- | Providing 30 in percentage will create blocks that approximately fill 30% of epoch.
148154
-- Returns number of blocks submitted
149155
fillEpochPercentage :: Interpreter -> ServerHandle IO CardanoBlock -> Int -> IO [CardanoBlock]
150156
fillEpochPercentage interpreter mockServer percentage = do
151-
let blocksToCreate = div (percentage * blocksPerEpoch) 100
152-
replicateM blocksToCreate $forgeNextFindLeaderAndSubmit interpreter mockServer []
157+
let blocksToCreate = div (percentage * blocksPerEpoch) 100
158+
replicateM blocksToCreate $forgeNextFindLeaderAndSubmit interpreter mockServer []
153159

154160
registerAllStakeCreds :: Interpreter -> ServerHandle IO CardanoBlock -> IO CardanoBlock
155161
registerAllStakeCreds interpreter mockServer = do
156-
blk <- forgeWithStakeCreds interpreter
157-
atomically $ addBlock mockServer blk
158-
pure blk
162+
blk <- forgeWithStakeCreds interpreter
163+
atomically $ addBlock mockServer blk
164+
pure blk
159165

160166
-- Expected number. This should be taken from the parameters, instead of hardcoded.
161167
blocksPerEpoch :: Int

0 commit comments

Comments
 (0)