1678: epoch_stake missing entries

cardano-db-sync/src/Cardano/DbSync/Default.hs

@@ -99,7 +99,7 @@ applyAndInsertBlockMaybe syncEnv tracer cblk = do
     mkApplyResult :: Bool -> IO (ApplyResult, Bool)
     mkApplyResult isCons = do
       case envLedgerEnv syncEnv of
-        HasLedger hle -> applyBlockAndSnapshot hle cblk isCons
+        HasLedger hle -> applyBlockAndSnapshot tracer hle cblk isCons
         NoLedger nle -> do
           slotDetails <- getSlotDetailsNode nle (cardanoBlockSlotNo cblk)
           pure (defaultApplyResult slotDetails, False)

cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/StakeDist.hs

@@ -17,6 +17,8 @@ module Cardano.DbSync.Era.Shelley.Generic.StakeDist (
   getPoolDistr,
 ) where
 
+import Cardano.BM.Data.Trace (Trace)
+import Cardano.BM.Trace (logInfo)
 import Cardano.DbSync.Types
 import Cardano.Ledger.Coin (Coin (..))
 import qualified Cardano.Ledger.Compactible as Ledger
@@ -72,35 +74,55 @@ getSecurityParameter = maxRollbacks . configSecurityParam . pInfoConfig
 -- will be adjusted.
 getStakeSlice ::
   ConsensusProtocol (BlockProtocol blk) =>
+  Trace IO Text ->
   ProtocolInfo blk ->
   Word64 ->
   ExtLedgerState CardanoBlock ->
   Bool ->
-  StakeSliceRes
-getStakeSlice pInfo !epochBlockNo els isMigration =
+  IO StakeSliceRes
+getStakeSlice trce pInfo !epochBlockNo els isMigration =
   case ledgerState els of
-    LedgerStateByron _ -> NoSlices
-    LedgerStateShelley sls -> genericStakeSlice pInfo epochBlockNo sls isMigration
-    LedgerStateAllegra als -> genericStakeSlice pInfo epochBlockNo als isMigration
-    LedgerStateMary mls -> genericStakeSlice pInfo epochBlockNo mls isMigration
-    LedgerStateAlonzo als -> genericStakeSlice pInfo epochBlockNo als isMigration
-    LedgerStateBabbage bls -> genericStakeSlice pInfo epochBlockNo bls isMigration
-    LedgerStateConway cls -> genericStakeSlice pInfo epochBlockNo cls isMigration
-
+    LedgerStateByron _ -> pure NoSlices
+    LedgerStateShelley sls -> genericStakeSlice trce pInfo epochBlockNo sls isMigration
+    LedgerStateAllegra als -> genericStakeSlice trce pInfo epochBlockNo als isMigration
+    LedgerStateMary mls -> genericStakeSlice trce pInfo epochBlockNo mls isMigration
+    LedgerStateAlonzo als -> genericStakeSlice trce pInfo epochBlockNo als isMigration
+    LedgerStateBabbage bls -> genericStakeSlice trce pInfo epochBlockNo bls isMigration
+    LedgerStateConway cls -> genericStakeSlice trce pInfo epochBlockNo cls isMigration
+
+-- TODO: Cmdv
 genericStakeSlice ::
   forall era c blk p.
   (c ~ StandardCrypto, EraCrypto era ~ c, ConsensusProtocol (BlockProtocol blk)) =>
+  Trace IO Text ->
   ProtocolInfo blk ->
   Word64 ->
   LedgerState (ShelleyBlock p era) ->
   Bool ->
-  StakeSliceRes
-genericStakeSlice pInfo epochBlockNo lstate isMigration
-  | index > delegationsLen = NoSlices
-  | index == delegationsLen = Slice (emptySlice epoch) True
-  | index + size > delegationsLen = Slice (mkSlice (delegationsLen - index)) True
-  | otherwise = Slice (mkSlice size) False
+  IO StakeSliceRes
+genericStakeSlice trce pInfo epochBlockNo lstate isMigration =
+  case compare index delegationsLen of
+    GT -> pure NoSlices
+    EQ -> pure $ Slice (emptySlice epoch) True
+    LT -> case compare (index + size) delegationsLen of
+      GT -> pure $ Slice (mkSlice (delegationsLen - index)) True
+      _other -> pure $ Slice (mkSlice size) False
   where
+    _logStuff :: Text -> IO ()
+    _logStuff text = do
+      when (unEpochNo epoch > 11 && unEpochNo epoch < 24) $ do
+        liftIO $ logInfo trce ("----- " <> show epochBlockNo <> " -----")
+        liftIO $ logInfo trce $ "----- " <> text
+        liftIO $ logInfo trce $ "----- k: " <> show k
+        liftIO $ logInfo trce $ "----- isMigration: " <> show isMigration
+        liftIO $ logInfo trce $ "----- index: " <> show index
+        liftIO $ logInfo trce $ "----- delegationsLen: " <> show delegationsLen
+        liftIO $ logInfo trce $ "----- size: " <> show size
+        liftIO $ logInfo trce $ "----- epochSliceSize: " <> show epochSliceSize
+        liftIO $ logInfo trce $ "----- minSliceSize: " <> show minSliceSize
+        liftIO $ logInfo trce $ "----- defaultEpochSliceSize: " <> show defaultEpochSliceSize
+        liftIO $ logInfo trce "--------------------"
+
     epoch :: EpochNo
     epoch = EpochNo $ 1 + unEpochNo (Shelley.nesEL (Consensus.shelleyLedgerState lstate))
 
@@ -137,21 +159,21 @@ genericStakeSlice pInfo epochBlockNo lstate isMigration
     epochSliceSize :: Word64
     epochSliceSize =
       max minSliceSize defaultEpochSliceSize
-      where
-        -- On mainnet this is 21600
-        expectedBlocks :: Word64
-        expectedBlocks = 10 * k
 
-        -- This size of slices is enough to cover the whole list, even if only
-        -- the 20% of the expected blocks appear in an epoch.
-        defaultEpochSliceSize :: Word64
-        defaultEpochSliceSize = 1 + div (delegationsLen * 5) expectedBlocks
+    -- On mainnet this is 21600
+    expectedBlocks :: Word64
+    expectedBlocks = 10 * k
+
+    -- This size of slices is enough to cover the whole list, even if only
+    -- the 20% of the expected blocks appear in an epoch.
+    defaultEpochSliceSize :: Word64
+    defaultEpochSliceSize = 1 + div (delegationsLen * 5) expectedBlocks
 
     -- The starting index of the data in the delegation vector.
     index :: Word64
     index
       | isMigration = 0
-      | epochBlockNo < k = delegationsLen + 1 -- so it creates the empty Slice.
+      | epochBlockNo < k = epochBlockNo * epochSliceSize
       | otherwise = (epochBlockNo - k) * epochSliceSize
 
     size :: Word64

cardano-db-sync/src/Cardano/DbSync/Era/Universal/Block.hs

@@ -149,7 +149,7 @@ insertBlockUniversal syncEnv shouldLog withinTwoMins withinHalfHour blk details
     whenStrictJust (apNewEpoch applyResult) $ \newEpoch -> do
       insertOnNewEpoch syncEnv blkId (Generic.blkSlotNo blk) epochNo newEpoch
 
-    insertStakeSlice syncEnv $ apStakeSlice applyResult
+    insertStakeSlice syncEnv (unEpochNo epochNo) $ apStakeSlice applyResult
 
     when (ioGov iopts && (withinHalfHour || unBlockNo (Generic.blkBlockNo blk) `mod` 10000 == 0))
       . lift

cardano-db-sync/src/Cardano/DbSync/Era/Universal/Epoch.hs

@@ -196,17 +196,31 @@ hasEpochStartEvent = any isNewEpoch
 insertStakeSlice ::
   (MonadBaseControl IO m, MonadIO m) =>
   SyncEnv ->
+  Word64 ->
   Generic.StakeSliceRes ->
   ExceptT SyncNodeError (ReaderT SqlBackend m) ()
-insertStakeSlice _ Generic.NoSlices = pure ()
-insertStakeSlice syncEnv (Generic.Slice slice finalSlice) = do
-  insertEpochStake syncEnv network (Generic.sliceEpochNo slice) (Map.toList $ Generic.sliceDistr slice)
-  when finalSlice $ do
-    lift $ DB.updateSetComplete $ unEpochNo $ Generic.sliceEpochNo slice
-    size <- lift $ DB.queryEpochStakeCount (unEpochNo $ Generic.sliceEpochNo slice)
-    liftIO
-      . logInfo tracer
-      $ mconcat ["Inserted ", show size, " EpochStake for ", show (Generic.sliceEpochNo slice)]
+insertStakeSlice syncEnv _epochNo stakeSliceRes = do
+  case stakeSliceRes of
+    Generic.NoSlices -> do
+      -- when (epochNo > 12 && epochNo < 23) $ do
+      --   liftIO . logInfo tracer $ "---------------------------------"
+      --   liftIO . logInfo tracer $ "----------- NoSlices epoch: " <> show epochNo <> " -------------"
+      --   liftIO . logInfo tracer $ "---------------------------------"
+      pure ()
+    (Generic.Slice slice finalSlice) -> do
+      let poo = Map.toList $ Generic.sliceDistr slice
+      -- epochNum = unEpochNo $ Generic.sliceEpochNo slice
+      -- when (epochNum > 12 && epochNum < 23) $ do
+      --   liftIO . logInfo tracer $ "---------------------------------"
+      --   liftIO . logInfo tracer $ mconcat ["Length of Generic.sliceDistr: ", show $ length poo]
+      --   liftIO . logInfo tracer $ "---------------------------------"
+      insertEpochStake syncEnv network (Generic.sliceEpochNo slice) poo
+      when finalSlice $ do
+        lift $ DB.updateSetComplete $ unEpochNo $ Generic.sliceEpochNo slice
+        size <- lift $ DB.queryEpochStakeCount (unEpochNo $ Generic.sliceEpochNo slice)
+        liftIO
+          . logInfo tracer
+          $ mconcat ["Inserted ", show size, " EpochStake for ", show (Generic.sliceEpochNo slice)]
   where
     tracer :: Trace IO Text
     tracer = getTrace syncEnv
@@ -368,8 +382,11 @@ splittRecordsEvery val = go
   where
     go [] = []
     go ys =
-      let (as, bs) = splitAt val ys
-       in as : go bs
+      if length ys > val
+        then
+          let (as, bs) = splitAt val ys
+           in as : go bs
+        else [ys]
 
 insertPoolDepositRefunds ::
   (MonadBaseControl IO m, MonadIO m) =>

cardano-db-sync/src/Cardano/DbSync/Fix/EpochStake.hs

@@ -25,13 +25,12 @@ migrateStakeDistr env mcls =
       ems <- lift DB.queryAllExtraMigrations
       runWhen (not $ DB.isStakeDistrComplete ems) $ do
         liftIO $ logInfo trce "Starting Stake Distribution migration on table epoch_stake"
-        let stakeSlice = getStakeSlice lenv cls True
+        stakeSlice <- liftIO $ getStakeSlice trce lenv cls True
         case stakeSlice of
-          NoSlices ->
-            liftIO $ logInsert 0
+          NoSlices -> liftIO $ logInsert 0
           Slice (StakeSlice _epochNo distr) isFinal -> do
             liftIO $ logInsert (Map.size distr)
-            insertStakeSlice env stakeSlice
+            insertStakeSlice env 0 stakeSlice
             (mminEpoch, mmaxEpoch) <- lift DB.queryMinMaxEpochStake
             liftIO $ logMinMax mminEpoch mmaxEpoch
             case (mminEpoch, mmaxEpoch) of

cardano-db-sync/src/Cardano/DbSync/Ledger/State.hs

@@ -214,19 +214,19 @@ readStateUnsafe env = do
     Strict.Nothing -> throwSTM $ userError "LedgerState.readStateUnsafe: Ledger state is not found"
     Strict.Just st -> pure st
 
-applyBlockAndSnapshot :: HasLedgerEnv -> CardanoBlock -> Bool -> IO (ApplyResult, Bool)
-applyBlockAndSnapshot ledgerEnv blk isCons = do
-  (oldState, appResult) <- applyBlock ledgerEnv blk
+applyBlockAndSnapshot :: Trace IO Text -> HasLedgerEnv -> CardanoBlock -> Bool -> IO (ApplyResult, Bool)
+applyBlockAndSnapshot trce ledgerEnv blk isCons = do
+  (oldState, appResult) <- applyBlock trce ledgerEnv blk
   tookSnapshot <- storeSnapshotAndCleanupMaybe ledgerEnv oldState appResult (blockNo blk) isCons (isSyncedWithinSeconds (apSlotDetails appResult) 600)
   pure (appResult, tookSnapshot)
 
 -- The function 'tickThenReapply' does zero validation, so add minimal validation ('blockPrevHash'
 -- matches the tip hash of the 'LedgerState'). This was originally for debugging but the check is
 -- cheap enough to keep.
-applyBlock :: HasLedgerEnv -> CardanoBlock -> IO (CardanoLedgerState, ApplyResult)
-applyBlock env blk = do
+applyBlock :: Trace IO Text -> HasLedgerEnv -> CardanoBlock -> IO (CardanoLedgerState, ApplyResult)
+applyBlock trce env blk = do
   time <- getCurrentTime
-  atomically $ do
+  (oldState, newState, intermediateResults) <- atomically $ do
     !ledgerDB <- readStateUnsafe env
     let oldState = ledgerDbCurrent ledgerDB
     !result <- fromEitherSTM $ tickThenReapplyCheckHash (ExtLedgerCfg (getTopLevelconfigHasLedger env)) blk (clsState oldState)
@@ -239,24 +239,29 @@ applyBlock env blk = do
     let !newState = CardanoLedgerState newLedgerState newEpochBlockNo
     let !ledgerDB' = pushLedgerDB ledgerDB newState
     writeTVar (leStateVar env) (Strict.Just ledgerDB')
-    let !appResult =
-          if leUseLedger env
-            then
-              ApplyResult
-                { apPrices = getPrices newState
-                , apGovExpiresAfter = getGovExpiration newState
-                , apPoolsRegistered = getRegisteredPools oldState
-                , apNewEpoch = maybeToStrict newEpoch
-                , apOldLedger = Strict.Just oldState
-                , apDeposits = maybeToStrict $ Generic.getDeposits newLedgerState
-                , apSlotDetails = details
-                , apStakeSlice = getStakeSlice env newState False
-                , apEvents = ledgerEvents
-                , apGovActionState = getGovState newLedgerState
-                , apDepositsMap = DepositsMap deposits
-                }
-            else defaultApplyResult details
-    pure (oldState, appResult)
+    pure (oldState, newState, (ledgerEvents, deposits, details, newEpoch))
+  stakeSlices <- liftIO $ getStakeSlice trce env newState False
+  appResult <- atomically $ do
+    let (ledgerEvents, deposits, details, newEpoch) = intermediateResults
+    pure $
+      if leUseLedger env
+        then
+          ApplyResult
+            { apPrices = getPrices newState
+            , apGovExpiresAfter = getGovExpiration newState
+            , apPoolsRegistered = getRegisteredPools oldState
+            , apNewEpoch = maybeToStrict newEpoch
+            , apOldLedger = Strict.Just oldState
+            , apDeposits = maybeToStrict $ Generic.getDeposits (clsState newState)
+            , apSlotDetails = details
+            , apStakeSlice = stakeSlices
+            , apEvents = ledgerEvents
+            , apGovActionState = getGovState (clsState newState)
+            , apDepositsMap = DepositsMap deposits
+            }
+        else defaultApplyResult details
+
+  pure (oldState, appResult)
   where
     mkOnNewEpoch :: ExtLedgerState CardanoBlock -> ExtLedgerState CardanoBlock -> Maybe AdaPots -> Either SyncNodeError (Maybe Generic.NewEpoch)
     mkOnNewEpoch oldState newState mPots = do
@@ -305,16 +310,17 @@ getGovState ls = case ledgerState ls of
     Just $ Consensus.shelleyLedgerState cls ^. Shelley.newEpochStateGovStateL
   _ -> Nothing
 
-getStakeSlice :: HasLedgerEnv -> CardanoLedgerState -> Bool -> Generic.StakeSliceRes
-getStakeSlice env cls isMigration =
+getStakeSlice :: Trace IO Text -> HasLedgerEnv -> CardanoLedgerState -> Bool -> IO Generic.StakeSliceRes
+getStakeSlice trce env cls isMigration =
   case clsEpochBlockNo cls of
     EpochBlockNo n ->
       Generic.getStakeSlice
+        trce
         (leProtocolInfo env)
         n
         (clsState cls)
         isMigration
-    _ -> Generic.NoSlices
+    _ -> pure Generic.NoSlices
 
 getSliceMeta :: Generic.StakeSliceRes -> Maybe (Bool, EpochNo)
 getSliceMeta (Generic.Slice (Generic.StakeSlice epochNo _) isFinal) = Just (isFinal, epochNo)