diff --git a/cardano-db-sync/src/Cardano/DbSync/Default.hs b/cardano-db-sync/src/Cardano/DbSync/Default.hs index 0285533c1..c474f1b38 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Default.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Default.hs @@ -94,7 +94,7 @@ applyAndInsertBlockMaybe syncEnv tracer cblk = do Right _ | Just epochNo <- getNewEpoch applyRes -> liftIO $ logInfo tracer $ "Reached " <> textShow epochNo - _ -> pure () + _otherwise -> pure () where mkApplyResult :: Bool -> IO (ApplyResult, Bool) mkApplyResult isCons = do diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/StakeDist.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/StakeDist.hs index 3246ddc9d..fa57d2812 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/StakeDist.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/StakeDist.hs @@ -3,7 +3,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeOperators #-} @@ -46,12 +45,13 @@ import Prelude (id) data StakeSliceRes = Slice !StakeSlice !Bool -- True if this is the final slice for this epoch. Can be used for logging. | NoSlices + deriving (Show) data StakeSlice = StakeSlice { sliceEpochNo :: !EpochNo , sliceDistr :: !(Map StakeCred (Coin, PoolKeyHash)) } - deriving (Eq) + deriving (Show, Eq) emptySlice :: EpochNo -> StakeSlice emptySlice epoch = StakeSlice epoch Map.empty @@ -95,11 +95,13 @@ genericStakeSlice :: 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 +genericStakeSlice pInfo epochBlockNo lstate isMigration = do + case compare index delegationsLen of + GT -> NoSlices + EQ -> Slice (emptySlice epoch) True + LT -> case compare (index + size) delegationsLen of + GT -> Slice (mkSlice (delegationsLen - index)) True + _otherwise -> Slice (mkSlice size) False where epoch :: EpochNo epoch = EpochNo $ 1 + unEpochNo (Shelley.nesEL (Consensus.shelleyLedgerState lstate)) @@ -149,10 +151,10 @@ genericStakeSlice pInfo epochBlockNo lstate isMigration -- 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. - | otherwise = (epochBlockNo - k) * epochSliceSize + index = + if isMigration + then 0 + else (epochBlockNo - k) * epochSliceSize size :: Word64 size @@ -176,6 +178,121 @@ genericStakeSlice pInfo epochBlockNo lstate isMigration VMap.mapMaybe id $ VMap.mapWithKey (\a p -> (,p) <$> lookupStake a) delegationsSliced +-- 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 -> +-- IO StakeSliceRes +-- genericStakeSlice trce pInfo epochBlockNo lstate isMigration = do +-- let shouldLog = unEpochNo epoch `elem` [12, 14] +-- when shouldLog logStakeSliceInfo +-- -- when shouldLog $ logStakeSliceInfo trce epochBlockNo delegationsLen index size k epochSliceSize isMigration epoch +-- let result = case compare index delegationsLen of +-- GT -> NoSlices +-- EQ -> Slice (emptySlice epoch) True +-- LT -> case compare (index + size) delegationsLen of +-- GT -> Slice (mkSlice (delegationsLen - index)) True +-- _other -> Slice (mkSlice size) False + +-- -- when shouldLog $ logResult trce result +-- pure result +-- where +-- index :: Word64 +-- index +-- | isMigration = 0 +-- | epochBlockNo < k = 0 -- Changed from delegationsLen + 1 +-- | otherwise = min ((epochBlockNo - k) * epochSliceSize) delegationsLen + +-- size :: Word64 +-- size +-- | isMigration, epochBlockNo + 1 < k = 0 +-- | isMigration = (epochBlockNo + 1 - k) * epochSliceSize +-- | otherwise = max 1 (min epochSliceSize delegationsLen) -- Ensure we always process at least one delegation + +-- epochSliceSize :: Word64 +-- epochSliceSize = +-- max minSliceSize (max 1 defaultEpochSliceSize) -- Ensure epochSliceSize is never 0 + +-- defaultEpochSliceSize :: Word64 +-- defaultEpochSliceSize = max 1 (1 + div (delegationsLen * 5) expectedBlocks) -- Ensure it's never 0 + +-- delegationsLen :: Word64 +-- delegationsLen = fromIntegral $ VG.length delegations + +-- delegations :: VMap.KVVector VB VB (Credential 'Staking c, KeyHash 'StakePool c) +-- delegations = VMap.unVMap $ Ledger.ssDelegations stakeSnapshot + +-- epoch :: EpochNo +-- epoch = EpochNo $ 1 + unEpochNo (Shelley.nesEL (Consensus.shelleyLedgerState lstate)) + +-- minSliceSize :: Word64 +-- minSliceSize = 2000 + +-- -- On mainnet this is 2160 +-- k :: Word64 +-- k = getSecurityParameter pInfo + +-- -- We use 'ssStakeMark' here. That means that when these values +-- -- are added to the database, the epoch number where they become active is the current +-- -- epoch plus one. +-- stakeSnapshot :: Ledger.SnapShot c +-- stakeSnapshot = +-- Ledger.ssStakeMark . Shelley.esSnapshots . Shelley.nesEs $ +-- Consensus.shelleyLedgerState lstate + +-- stakes :: VMap VB VP (Credential 'Staking c) (Ledger.CompactForm Coin) +-- stakes = Ledger.unStake $ Ledger.ssStake stakeSnapshot + +-- lookupStake :: Credential 'Staking c -> Maybe Coin +-- lookupStake cred = Ledger.fromCompact <$> VMap.lookup cred stakes + +-- -- On mainnet this is 21600 +-- expectedBlocks :: Word64 +-- expectedBlocks = 10 * k + +-- mkSlice :: Word64 -> StakeSlice +-- mkSlice actualSize = +-- StakeSlice +-- { sliceEpochNo = epoch +-- , sliceDistr = distribution +-- } +-- where +-- delegationsSliced :: VMap VB VB (Credential 'Staking c) (KeyHash 'StakePool c) +-- delegationsSliced = VMap $ VG.slice (fromIntegral index) (fromIntegral actualSize) delegations + +-- distribution :: Map StakeCred (Coin, PoolKeyHash) +-- distribution = +-- VMap.toMap $ +-- VMap.mapMaybe id $ +-- VMap.mapWithKey (\a p -> (,p) <$> lookupStake a) delegationsSliced + +-- logStakeSliceInfo = do +-- logInfo trce $ unlines +-- [ "Stake Slice Debug Info:" +-- , " epoch: " <> (pack . show $ unEpochNo epoch) +-- , " epochBlockNo: " <> show epochBlockNo +-- , " isMigration: " <> show isMigration +-- , " index: " <> show index +-- , " delegationsLen: " <> show delegationsLen +-- , " size: " <> show size +-- , " epochSliceSize: " <> show epochSliceSize +-- , " remaining: " <> show (delegationsLen - index) +-- , " k: " <> show k +-- , " expectedBlocks: " <> show expectedBlocks +-- , " defaultEpochSliceSize: " <> show defaultEpochSliceSize +-- ] + +-- _logResult :: Trace IO Text -> StakeSliceRes -> IO () +-- _logResult trce result = +-- logInfo trce $ unlines +-- [ "Stake Slice Result:" +-- , " " <> show result +-- ] + getPoolDistr :: ExtLedgerState CardanoBlock -> Maybe (Map PoolKeyHash (Coin, Word64), Map PoolKeyHash Natural) diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Epoch.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Epoch.hs index cc1f86205..8eb2b46a2 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Epoch.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Epoch.hs @@ -198,15 +198,21 @@ insertStakeSlice :: SyncEnv -> 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 stakeSliceRes = do + case stakeSliceRes of + Generic.NoSlices -> pure () + Generic.Slice slice isfinalSlice -> do + insertEpochStake + syncEnv + network + (Generic.sliceEpochNo slice) + (Map.toList $ Generic.sliceDistr slice) + when isfinalSlice $ 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 +374,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) => diff --git a/cardano-db-sync/src/Cardano/DbSync/Fix/EpochStake.hs b/cardano-db-sync/src/Cardano/DbSync/Fix/EpochStake.hs index c1ff28caf..eeb273963 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Fix/EpochStake.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Fix/EpochStake.hs @@ -40,9 +40,9 @@ migrateStakeDistr env mcls = lift $ DB.insertEpochStakeProgress (mkProgress True <$> [minEpoch .. (maxEpoch - 1)]) lift $ DB.insertEpochStakeProgress [mkProgress isFinal maxEpoch] - _ -> pure () + _otherwise -> pure () lift $ DB.insertExtraMigration DB.StakeDistrEnded - _ -> pure False + _otherwise -> pure False where trce = getTrace env mkProgress isCompleted e = diff --git a/cardano-db-sync/src/Cardano/DbSync/Ledger/State.hs b/cardano-db-sync/src/Cardano/DbSync/Ledger/State.hs index 8df2f9a65..a6228e615 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Ledger/State.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Ledger/State.hs @@ -314,7 +314,7 @@ getStakeSlice env cls isMigration = n (clsState cls) isMigration - _ -> Generic.NoSlices + _otherwise -> Generic.NoSlices getSliceMeta :: Generic.StakeSliceRes -> Maybe (Bool, EpochNo) getSliceMeta (Generic.Slice (Generic.StakeSlice epochNo _) isFinal) = Just (isFinal, epochNo) diff --git a/cardano-db-sync/src/Cardano/DbSync/Rollback.hs b/cardano-db-sync/src/Cardano/DbSync/Rollback.hs index 7f677f265..a53ed9779 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Rollback.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Rollback.hs @@ -55,6 +55,7 @@ rollbackFromBlockNo syncEnv blkNo = do DB.deleteDrepDistr epochNo DB.deleteRewardRest epochNo DB.deletePoolStat epochNo + DB.deleteEpochStake epochNo DB.setNullEnacted epochNo DB.setNullRatified epochNo DB.setNullDropped epochNo diff --git a/cardano-db/src/Cardano/Db/Delete.hs b/cardano-db/src/Cardano/Db/Delete.hs index d26a32e65..ce1e85293 100644 --- a/cardano-db/src/Cardano/Db/Delete.hs +++ b/cardano-db/src/Cardano/Db/Delete.hs @@ -19,6 +19,7 @@ module Cardano.Db.Delete ( deletePoolStat, deleteAdaPots, deleteTxOut, + deleteEpochStake, -- for testing queryFirstAndDeleteAfter, ) where @@ -255,3 +256,7 @@ deleteAdaPots blkId = do deleteTxOut :: MonadIO m => ReaderT SqlBackend m Int64 deleteTxOut = deleteWhereCount ([] :: [Filter TxOut]) + +deleteEpochStake :: MonadIO m => Word64 -> ReaderT SqlBackend m () +deleteEpochStake epochNum = + deleteWhere [EpochStakeEpochNo >=. epochNum]