New schema with higher reliance on BlockNo

Needed to drop the reliance of foreign key constraints because their
use forced PostgreSQL to validate the foreign keys before the data
was inserted. Therefore using `BlockNo` should result in faster data
insertion into the database.

This also required massive changes across most of the code base.

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

@@ -32,7 +32,7 @@ module Cardano.Mock.Forging.Interpreter
 
 import           Cardano.Prelude (bimap, getField, throwIO)
 
-import           Control.Monad (forM, when)
+import           Control.Monad (forM, void, when)
 import           Control.Monad.Except (runExcept)
 import           Control.Tracer (Tracer)
 
@@ -271,20 +271,20 @@ forgeNext interpreter testBlock =
 
 forgeNextLeaders :: Interpreter -> [TxEra] -> [BlockForging IO CardanoBlock] -> IO CardanoBlock
 forgeNextLeaders interpreter txes possibleLeaders = do
-        interState <- getCurrentInterpreterState interpreter
-        (blk, fingerprint) <- tryOrValidateSlot interState possibleLeaders
-        let !chain' = extendChainDB (istChain interState) blk
-        let !newSt = currentState chain'
-        let newInterState =
-              InterpreterState
-                { istChain = chain'
-                , istForecast = mkForecast cfg newSt
-                , istSlot = blockSlot blk + 1
-                , istNextBlockNo = blockNo blk + 1
-                , istFingerprint = fingerprint
-                }
-        _ <- swapMVar (interpState interpreter) newInterState
-        pure blk
+    interState <- getCurrentInterpreterState interpreter
+    (blk, fingerprint) <- tryOrValidateSlot interState possibleLeaders
+    let !chain' = extendChainDB (istChain interState) blk
+    let !newSt = currentState chain'
+    let newInterState =
+          InterpreterState
+            { istChain = chain'
+            , istForecast = mkForecast cfg newSt
+            , istSlot = blockSlot blk + 1
+            , istNextBlockNo = blockNo blk + 1
+            , istFingerprint = fingerprint
+            }
+    void $ swapMVar (interpState interpreter) newInterState
+    pure blk
   where
     cfg :: TopLevelConfig CardanoBlock
     cfg = interpTopLeverConfig interpreter

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

@@ -79,17 +79,17 @@ import           Cardano.Node.Types (ProtocolFilepaths (..))
 
 
 data Config = Config
-    { topLevelConfig :: TopLevelConfig CardanoBlock
-    , protocolInfo :: Consensus.ProtocolInfo IO CardanoBlock
-    , protocolInfoForging :: Consensus.ProtocolInfo IO CardanoBlock
-    , syncNodeParams :: SyncNodeParams
-    }
+  { topLevelConfig :: TopLevelConfig CardanoBlock
+  , protocolInfo :: Consensus.ProtocolInfo IO CardanoBlock
+  , protocolInfoForging :: Consensus.ProtocolInfo IO CardanoBlock
+  , syncNodeParams :: SyncNodeParams
+  }
 
 data DBSyncEnv = DBSyncEnv
-    { dbSyncParams :: SyncNodeParams
-    , dbSyncForkDB :: IO (Async ())
-    , dbSyncThreadVar :: TMVar (Async ())
-    }
+  { dbSyncParams :: SyncNodeParams
+  , dbSyncForkDB :: IO (Async ())
+  , dbSyncThreadVar :: TMVar (Async ())
+  }
 
 rootTestDir :: FilePath
 rootTestDir = "test/testfiles"
@@ -110,10 +110,10 @@ mkDBSyncEnv :: SyncNodeParams -> IO () -> IO DBSyncEnv
 mkDBSyncEnv params runDBSync = do
   runningVar <- newEmptyTMVarIO
   pure $ DBSyncEnv
-    { dbSyncParams = params
-    , dbSyncForkDB = async runDBSync
-    , dbSyncThreadVar = runningVar
-    }
+          { dbSyncParams = params
+          , dbSyncForkDB = async runDBSync
+          , dbSyncThreadVar = runningVar
+          }
 
 stopDBSync :: DBSyncEnv -> IO ()
 stopDBSync env = do
@@ -123,7 +123,7 @@ stopDBSync env = do
     Just a -> do
       cancel a
       -- make it empty
-      _ <- atomically $ takeTMVar (dbSyncThreadVar env)
+      void . atomically $ takeTMVar (dbSyncThreadVar env)
       pure ()
 
 stopDBSyncIfRunning :: DBSyncEnv -> IO ()
@@ -135,17 +135,15 @@ stopDBSyncIfRunning env = do
       cancel a
       -- make it empty
       void . atomically $ takeTMVar (dbSyncThreadVar env)
-      pure ()
 
 startDBSync :: DBSyncEnv -> IO ()
 startDBSync env = do
-    thr <- atomically $ tryReadTMVar $ dbSyncThreadVar env
-    case thr of
-      Just _a -> error "db-sync already running"
-      Nothing -> do
-        a <- dbSyncForkDB env
-        _ <- atomically $ tryPutTMVar (dbSyncThreadVar env) a
-        pure ()
+  thr <- atomically $ tryReadTMVar (dbSyncThreadVar env)
+  case thr of
+    Just _a -> error "db-sync already running"
+    Nothing -> do
+      a <- dbSyncForkDB env
+      void . atomically $ tryPutTMVar (dbSyncThreadVar env) a
 
 pollDBSync :: DBSyncEnv -> IO (Maybe (Either SomeException ()))
 pollDBSync env = do
@@ -155,8 +153,7 @@ pollDBSync env = do
     Just a -> poll a
 
 withDBSyncEnv :: IO DBSyncEnv -> (DBSyncEnv -> IO a) -> IO a
-withDBSyncEnv mkEnv action = do
-  bracket mkEnv stopDBSyncIfRunning action
+withDBSyncEnv mkEnv = bracket mkEnv stopDBSyncIfRunning
 
 getDBSyncPGPass :: DBSyncEnv -> Db.PGPassSource
 getDBSyncPGPass = enpPGPassSource . dbSyncParams
@@ -174,19 +171,19 @@ getPoolLayer env = do
 
 setupTestsDir :: FilePath -> IO ()
 setupTestsDir dir = do
-    eitherM (panic . textShow) pure $ runExceptT $
-      CLI.runGenesisCmd $ GenesisCreateStaked
-        (CLI.GenesisDir dir) 3 3 3 3 Nothing (Just 3000000) 3000000 (Testnet $ NetworkMagic 42) 1 3 0
+  eitherM (panic . textShow) pure $ runExceptT $
+    CLI.runGenesisCmd $ GenesisCreateStaked
+      (CLI.GenesisDir dir) 3 3 3 3 Nothing (Just 3000000) 3000000 (Testnet $ NetworkMagic 42) 1 3 0
 
 mkConfig :: FilePath -> FilePath -> IO Config
 mkConfig staticDir mutableDir = do
-    config <- readSyncNodeConfig $ ConfigFile ( staticDir </> "test-db-sync-config.json")
-    genCfg <- either (error . Text.unpack . renderSyncNodeError) id <$> runExceptT (readCardanoGenesisConfig config)
-    let pInfoDbSync = mkProtocolInfoCardano genCfg []
-    creds <- mkShelleyCredentials $ staticDir </> "pools" </> "bulk1.creds"
-    let pInfoForger = mkProtocolInfoCardano genCfg creds
-    syncPars <- mkSyncNodeParams staticDir mutableDir
-    pure $ Config (Consensus.pInfoConfig pInfoDbSync) pInfoDbSync pInfoForger syncPars
+  config <- readSyncNodeConfig $ ConfigFile ( staticDir </> "test-db-sync-config.json")
+  genCfg <- either (error . Text.unpack . renderSyncNodeError) id <$> runExceptT (readCardanoGenesisConfig config)
+  let pInfoDbSync = mkProtocolInfoCardano genCfg []
+  creds <- mkShelleyCredentials $ staticDir </> "pools" </> "bulk1.creds"
+  let pInfoForger = mkProtocolInfoCardano genCfg creds
+  syncPars <- mkSyncNodeParams staticDir mutableDir
+  pure $ Config (Consensus.pInfoConfig pInfoDbSync) pInfoDbSync pInfoForger syncPars
 
 mkShelleyCredentials :: FilePath -> IO [ShelleyLeaderCredentials StandardCrypto]
 mkShelleyCredentials bulkFile = do
@@ -218,16 +215,18 @@ mkSyncNodeParams staticDir mutableDir = do
     }
 
 emptyMetricsSetters :: MetricSetters
-emptyMetricsSetters = MetricSetters
-  { metricsSetNodeBlockHeight = \_ -> pure ()
-  , metricsSetDbQueueLength = \_ -> pure ()
-  , metricsSetDbBlockHeight = \_ -> pure ()
-  , metricsSetDbSlotHeight = \_ -> pure ()
-  }
+emptyMetricsSetters =
+  MetricSetters
+    { metricsSetNodeBlockHeight = \_ -> pure ()
+    , metricsSetDbQueueLength = \_ -> pure ()
+    , metricsSetDbBlockHeight = \_ -> pure ()
+    , metricsSetDbSlotHeight = \_ -> pure ()
+    }
 
-withFullConfig :: FilePath -> FilePath
-               -> (Interpreter -> ServerHandle IO CardanoBlock -> DBSyncEnv -> IO ())
-               -> IOManager -> [(Text, Text)] -> IO ()
+withFullConfig
+    :: FilePath -> FilePath
+    -> (Interpreter -> ServerHandle IO CardanoBlock -> DBSyncEnv -> IO ())
+    -> IOManager -> [(Text, Text)] -> IO ()
 withFullConfig config testLabel action iom migr = do
     recreateDir mutableDir
     cfg <- mkConfig configDir mutableDir
@@ -246,7 +245,7 @@ withFullConfig config testLabel action iom migr = do
         $ \mockServer ->
           -- we dont fork dbsync here. Just prepare it as an action
           withDBSyncEnv (mkDBSyncEnv dbsyncParams dbsyncRun) $ \dbSync -> do
-            _ <- hSilence [stderr] $ Db.recreateDB (getDBSyncPGPass dbSync)
+            void . hSilence [stderr] $ Db.recreateDB (getDBSyncPGPass dbSync)
             action interpreter mockServer dbSync
   where
     configDir = mkConfigDir config

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

@@ -20,22 +20,24 @@ module Test.Cardano.Db.Mock.UnifiedApi
 
 import           Data.Word (Word64)
 
-import           Cardano.Slotting.Slot (SlotNo (..))
-
+import           Cardano.Ledger.Alonzo (AlonzoEra)
 import qualified Cardano.Ledger.Core as Core
 
-import           Ouroboros.Consensus.Cardano.Block (StandardAlonzo, StandardBabbage,
-                   StandardShelley)
-import           Ouroboros.Consensus.Ledger.Basics (LedgerState)
-import           Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock)
-
 import           Cardano.Mock.ChainSync.Server
 import           Cardano.Mock.Forging.Interpreter
 import           Cardano.Mock.Forging.Types
 
+import           Cardano.Slotting.Slot (SlotNo (..))
+
 import           Control.Monad (forM, replicateM)
 import           Control.Monad.Class.MonadSTM.Strict (atomically)
 
+import           Ouroboros.Consensus.Cardano.Block (ShelleyEra, StandardAlonzo, StandardBabbage,
+                   StandardCrypto)
+import           Ouroboros.Consensus.Ledger.Basics (LedgerState)
+import           Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock)
+
+
 
 forgeNextAndSubmit :: Interpreter -> ServerHandle IO CardanoBlock -> MockBlock -> IO CardanoBlock
 forgeNextAndSubmit inter mockServer testBlock = do
@@ -45,9 +47,9 @@ forgeNextAndSubmit inter mockServer testBlock = do
 
 forgeNextFindLeaderAndSubmit :: Interpreter -> ServerHandle IO CardanoBlock -> [TxEra] -> IO CardanoBlock
 forgeNextFindLeaderAndSubmit interpreter mockServer txs'  = do
-    blk <- forgeNextFindLeader interpreter txs'
-    atomically $ addBlock mockServer blk
-    pure blk
+  blk <- forgeNextFindLeader interpreter txs'
+  atomically $ addBlock mockServer blk
+  pure blk
 
 forgeNextSkipSlotsFindLeaderAndSubmit :: Interpreter -> ServerHandle IO CardanoBlock -> Word64 -> [TxEra] -> IO CardanoBlock
 forgeNextSkipSlotsFindLeaderAndSubmit interpreter mockServer skipSlots txs'  = do
@@ -56,12 +58,13 @@ forgeNextSkipSlotsFindLeaderAndSubmit interpreter mockServer skipSlots txs'  = d
     pure blk
 
 forgeAndSubmitBlocks :: Interpreter -> ServerHandle IO CardanoBlock -> Int -> IO [CardanoBlock]
-forgeAndSubmitBlocks interpreter mockServer blocksToCreate = do
+forgeAndSubmitBlocks interpreter mockServer blocksToCreate =
     forM [1..blocksToCreate] $ \_ -> forgeNextFindLeaderAndSubmit interpreter mockServer []
 
 withAlonzoFindLeaderAndSubmit
     :: Interpreter -> ServerHandle IO CardanoBlock
-    -> (LedgerState (ShelleyBlock TPraosStandard StandardAlonzo) -> Either ForgingError [Core.Tx StandardAlonzo])
+    -> (LedgerState (ShelleyBlock TPraosStandard StandardAlonzo)
+    -> Either ForgingError [Core.Tx (AlonzoEra StandardCrypto)])
     -> IO CardanoBlock
 withAlonzoFindLeaderAndSubmit interpreter mockServer mkTxs = do
     alTxs <- withAlonzoLedgerState interpreter mkTxs
@@ -77,7 +80,8 @@ withBabbageFindLeaderAndSubmit interpreter mockServer mkTxs = do
 
 withAlonzoFindLeaderAndSubmitTx
     :: Interpreter -> ServerHandle IO CardanoBlock
-    -> (LedgerState (ShelleyBlock TPraosStandard StandardAlonzo) -> Either ForgingError (Core.Tx StandardAlonzo))
+    -> (LedgerState (ShelleyBlock TPraosStandard StandardAlonzo)
+    -> Either ForgingError (Core.Tx (AlonzoEra StandardCrypto)))
     -> IO CardanoBlock
 withAlonzoFindLeaderAndSubmitTx interpreter mockServer mkTxs = do
     withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do
@@ -95,20 +99,22 @@ withBabbageFindLeaderAndSubmitTx interpreter mockServer mkTxs = do
 
 withShelleyFindLeaderAndSubmit
     :: Interpreter -> ServerHandle IO CardanoBlock
-    -> (LedgerState (ShelleyBlock TPraosStandard StandardShelley) -> Either ForgingError [Core.Tx StandardShelley])
+    -> (LedgerState (ShelleyBlock TPraosStandard (ShelleyEra StandardCrypto))
+    -> Either ForgingError [Core.Tx (ShelleyEra StandardCrypto)])
     -> IO CardanoBlock
 withShelleyFindLeaderAndSubmit interpreter mockServer mkTxs = do
     alTxs <- withShelleyLedgerState interpreter mkTxs
     forgeNextFindLeaderAndSubmit interpreter mockServer (TxShelley <$> alTxs)
 
 withShelleyFindLeaderAndSubmitTx
     :: Interpreter -> ServerHandle IO CardanoBlock
-    -> (LedgerState (ShelleyBlock TPraosStandard StandardShelley) -> Either ForgingError (Core.Tx StandardShelley))
+    -> (LedgerState (ShelleyBlock TPraosStandard (ShelleyEra StandardCrypto))
+    -> Either ForgingError (Core.Tx (ShelleyEra StandardCrypto)))
     -> IO CardanoBlock
-withShelleyFindLeaderAndSubmitTx interpreter mockServer mkTxs = do
-    withShelleyFindLeaderAndSubmit interpreter mockServer $ \st -> do
-        tx <- mkTxs st
-        pure [tx]
+withShelleyFindLeaderAndSubmitTx interpreter mockServer mkTxs =
+  withShelleyFindLeaderAndSubmit interpreter mockServer $ \st -> do
+    tx <- mkTxs st
+    pure [tx]
 
 getAlonzoLedgerState :: Interpreter -> IO (LedgerState (ShelleyBlock TPraosStandard StandardAlonzo))
 getAlonzoLedgerState interpreter = withAlonzoLedgerState interpreter Right
@@ -118,44 +124,44 @@ getBabbageLedgerState interpreter = withBabbageLedgerState interpreter Right
 
 skipUntilNextEpoch :: Interpreter -> ServerHandle IO CardanoBlock -> [TxEra] -> IO CardanoBlock
 skipUntilNextEpoch interpreter mockServer txsEra = do
-    slot <- getCurrentSlot interpreter
-    let skipSlots = 500 - mod (unSlotNo slot) 500
-    blk <- forgeNextAfter interpreter skipSlots txsEra
-    atomically $ addBlock mockServer blk
-    pure blk
+  slot <- getCurrentSlot interpreter
+  let skipSlots = 500 - mod (unSlotNo slot) 500
+  blk <- forgeNextAfter interpreter skipSlots txsEra
+  atomically $ addBlock mockServer blk
+  pure blk
 
 -- First block of next epoch is also submited
 fillUntilNextEpoch :: Interpreter -> ServerHandle IO CardanoBlock -> IO [CardanoBlock]
 fillUntilNextEpoch interpreter mockServer = do
-    startingEpochNo <- getCurrentEpoch interpreter
-    let
-      go n blks = do
-        blk <- forgeNextFindLeader interpreter []
-        atomically $ addBlock mockServer blk
-        epochNo' <- getCurrentEpoch interpreter
-        if epochNo' == startingEpochNo
+  startingEpochNo <- getCurrentEpoch interpreter
+  let
+    go :: Int -> [CardanoBlock] -> IO [CardanoBlock]
+    go n blks = do
+      blk <- forgeNextFindLeader interpreter []
+      atomically $ addBlock mockServer blk
+      epochNo' <- getCurrentEpoch interpreter
+      if epochNo' == startingEpochNo
         then go (n + 1) (blk : blks)
         else pure $ reverse (blk : blks)
-    go (0 :: Int) []
+  go (0 :: Int) []
 
 -- | Returns number of blocks submitted
 fillEpochs :: Interpreter -> ServerHandle IO CardanoBlock -> Int -> IO [CardanoBlock]
-fillEpochs interpreter mockServer epochs = do
-    blks <- replicateM epochs $ fillUntilNextEpoch interpreter mockServer
-    pure $ concat blks
+fillEpochs interpreter mockServer epochs =
+  concat <$> replicateM epochs (fillUntilNextEpoch interpreter mockServer)
 
 -- | Providing 30 in percentage will create blocks that approximately fill 30% of epoch.
 -- Returns number of blocks submitted
 fillEpochPercentage :: Interpreter -> ServerHandle IO CardanoBlock -> Int -> IO [CardanoBlock]
 fillEpochPercentage interpreter mockServer percentage = do
-    let blocksToCreate = div (percentage * blocksPerEpoch) 100
-    replicateM blocksToCreate $forgeNextFindLeaderAndSubmit interpreter mockServer []
+  let blocksToCreate = div (percentage * blocksPerEpoch) 100
+  replicateM blocksToCreate $forgeNextFindLeaderAndSubmit interpreter mockServer []
 
 registerAllStakeCreds :: Interpreter -> ServerHandle IO CardanoBlock -> IO CardanoBlock
 registerAllStakeCreds interpreter mockServer = do
-    blk <- forgeWithStakeCreds interpreter
-    atomically $ addBlock mockServer blk
-    pure blk
+  blk <- forgeWithStakeCreds interpreter
+  atomically $ addBlock mockServer blk
+  pure blk
 
 -- Expected number. This should be taken from the parameters, instead of hardcoded.
 blocksPerEpoch :: Int