implement shelley stake address whitelist

Author: Cmdv

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

@@ -246,7 +246,7 @@ extractSyncOptions snp aop snc =
       InsertOptions
         { ioInOut = isTxOutEnabled'
         , ioUseLedger = useLedger
-        , ioShelley = isShelleyEnabled (sioShelley (dncInsertOptions snc))
+        , ioShelley = sioShelley (dncInsertOptions snc)
         , -- Rewards are only disabled on "disable_all" and "only_gov" presets
           ioRewards = True
         , ioMultiAssets = sioMultiAsset (dncInsertOptions snc)

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

@@ -39,6 +39,7 @@ import Data.ByteString (ByteString)
 import Data.List.Extra
 import Data.Map (Map)
 import qualified Data.Map.Strict as Map
+import Data.Maybe (catMaybes)
 import qualified Data.Text as Text
 import Database.Persist.Sql (SqlBackend)
 import Lens.Micro
@@ -145,7 +146,7 @@ storePage ::
   ExceptT SyncNodeError (ReaderT SqlBackend m) ()
 storePage syncEnv cache percQuantum (n, ls) = do
   when (n `mod` 10 == 0) $ liftIO $ logInfo trce $ "Bootstrap in progress " <> prc <> "%"
-  txOuts <- mapM (prepareTxOut syncEnv cache) ls
+  txOuts <- catMaybes <$> mapM (prepareTxOut syncEnv cache) ls
   txOutIds <- lift . DB.insertManyTxOutPlex True False $ etoTxOut . fst <$> txOuts
   let maTxOuts = concatMap mkmaTxOuts $ zip txOutIds (snd <$> txOuts)
   void . lift $ DB.insertManyMaTxOut maTxOuts
@@ -166,14 +167,13 @@ prepareTxOut ::
   SyncEnv ->
   TxCache ->
   (TxIn StandardCrypto, BabbageTxOut era) ->
-  ExceptT SyncNodeError (ReaderT SqlBackend m) (ExtendedTxOut, [MissingMaTxOut])
+  ExceptT SyncNodeError (ReaderT SqlBackend m) (Maybe (ExtendedTxOut, [MissingMaTxOut]))
 prepareTxOut syncEnv txCache (TxIn txHash (TxIx index), txOut) = do
   let txHashByteString = Generic.safeHashToByteString $ unTxId txHash
   let genTxOut = fromTxOut index txOut
   txId <- queryTxIdWithCache txCache txHashByteString
-  insertTxOut trce cache iopts (txId, txHashByteString) genTxOut
+  insertTxOut syncEnv cache iopts (txId, txHashByteString) genTxOut
   where
-    trce = getTrace syncEnv
     cache = envCache syncEnv
     iopts = soptInsertOptions $ envOptions syncEnv
 

cardano-db-sync/src/Cardano/DbSync/Api/Types.hs

@@ -15,7 +15,7 @@ module Cardano.DbSync.Api.Types (
 
 import qualified Cardano.Db as DB
 import Cardano.DbSync.Cache.Types (CacheStatus)
-import Cardano.DbSync.Config.Types (MetadataConfig, MultiAssetConfig, PlutusConfig, SyncNodeConfig)
+import Cardano.DbSync.Config.Types (MetadataConfig, MultiAssetConfig, PlutusConfig, ShelleyInsertConfig, SyncNodeConfig)
 import Cardano.DbSync.Ledger.Types (HasLedgerEnv)
 import Cardano.DbSync.LocalStateQuery (NoLedgerEnv)
 import Cardano.DbSync.Types (
@@ -81,7 +81,7 @@ data InsertOptions = InsertOptions
   , ioOffChainPoolData :: !Bool
   , ioPlutus :: !PlutusConfig
   , ioRewards :: !Bool
-  , ioShelley :: !Bool
+  , ioShelley :: !ShelleyInsertConfig
   , ioUseLedger :: !Bool
   }
   deriving (Show)

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

@@ -11,23 +11,26 @@ module Cardano.DbSync.Cache (
   insertBlockAndCache,
   insertDatumAndCache,
   insertPoolKeyWithCache,
+  insertStakeAddress,
   queryDatum,
   queryMAWithCache,
+  queryOrInsertRewardAccount,
+  queryOrInsertStakeAddress,
   queryPoolKeyOrInsert,
   queryPoolKeyWithCache,
   queryPrevBlockWithCache,
-  queryOrInsertStakeAddress,
-  queryOrInsertRewardAccount,
-  insertStakeAddress,
   queryStakeAddrWithCache,
   rollbackCache,
 
   -- * CacheStatistics
   getCacheStatistics,
-) where
+)
+where
 
 import Cardano.BM.Trace
 import qualified Cardano.Db as DB
+import Cardano.DbSync.Api (getTrace)
+import Cardano.DbSync.Api.Types (InsertOptions (..), SyncEnv (..), SyncOptions (..))
 import Cardano.DbSync.Cache.Epoch (rollbackMapEpochInCache)
 import qualified Cardano.DbSync.Cache.LRU as LRU
 import Cardano.DbSync.Cache.Types (CacheAction (..), CacheInternal (..), CacheStatistics (..), CacheStatus (..), initCacheStatistics, isCacheActionUpdate)
@@ -36,6 +39,7 @@ import Cardano.DbSync.Era.Shelley.Query
 import Cardano.DbSync.Era.Util
 import Cardano.DbSync.Error
 import Cardano.DbSync.Types
+import Cardano.DbSync.Util.Whitelist (shelleyInsertWhitelistCheck)
 import qualified Cardano.Ledger.Address as Ledger
 import Cardano.Ledger.BaseTypes (Network)
 import Cardano.Ledger.Mary.Value
@@ -68,8 +72,8 @@ import Ouroboros.Consensus.Cardano.Block (StandardCrypto)
 -- a different id.
 -- NOTE: Other tables are not cleaned up since they are not rollbacked.
 rollbackCache :: MonadIO m => CacheStatus -> DB.BlockId -> ReaderT SqlBackend m ()
-rollbackCache NoCache _ = pure ()
-rollbackCache (ActiveCache cache) blockId = do
+rollbackCache UninitiatedCache _ = pure ()
+rollbackCache (Cache cache) blockId = do
   liftIO $ do
     atomically $ writeTVar (cPrevBlock cache) Nothing
     atomically $ modifyTVar (cDatum cache) LRU.cleanup
@@ -83,44 +87,61 @@ getCacheStatistics cs =
 
 queryOrInsertRewardAccount ::
   (MonadBaseControl IO m, MonadIO m) =>
-  Trace IO Text ->
+  SyncEnv ->
   CacheStatus ->
   CacheAction ->
   Ledger.RewardAccount StandardCrypto ->
-  ReaderT SqlBackend m DB.StakeAddressId
-queryOrInsertRewardAccount trce cache cacheUA rewardAddr = do
-  eiAddrId <- queryRewardAccountWithCacheRetBs trce cache cacheUA rewardAddr
-  case eiAddrId of
-    Left (_err, bs) -> insertStakeAddress rewardAddr (Just bs)
-    Right addrId -> pure addrId
+  ReaderT SqlBackend m (Maybe DB.StakeAddressId)
+queryOrInsertRewardAccount syncEnv cache cacheUA rewardAddr = do
+  -- check if the stake address is in the whitelist
+  if shelleyInsertWhitelistCheck (ioShelley iopts) laBs
+    then do
+      eiAddrId <- queryRewardAccountWithCacheRetBs cache cacheUA rewardAddr
+      case eiAddrId of
+        Left (_err, bs) -> insertStakeAddress syncEnv rewardAddr (Just bs)
+        Right addrId -> pure $ Just addrId
+    else pure Nothing
+  where
+    nw = Ledger.getRwdNetwork rewardAddr
+    cred = Ledger.getRwdCred rewardAddr
+    !laBs = Ledger.serialiseRewardAcnt (Ledger.RewardAcnt nw cred)
+    iopts = soptInsertOptions $ envOptions syncEnv
 
 queryOrInsertStakeAddress ::
   (MonadBaseControl IO m, MonadIO m) =>
-  Trace IO Text ->
+  SyncEnv ->
   CacheStatus ->
   CacheAction ->
   Network ->
   StakeCred ->
-  ReaderT SqlBackend m DB.StakeAddressId
-queryOrInsertStakeAddress trce cache cacheUA nw cred =
-  queryOrInsertRewardAccount trce cache cacheUA $ Ledger.RewardAccount nw cred
+  ReaderT SqlBackend m (Maybe DB.StakeAddressId)
+queryOrInsertStakeAddress syncEnv cache cacheUA nw cred =
+  queryOrInsertRewardAccount syncEnv cache cacheUA $ Ledger.RewardAccount nw cred
 
 -- If the address already exists in the table, it will not be inserted again (due to
 -- the uniqueness constraint) but the function will return the 'StakeAddressId'.
 insertStakeAddress ::
   (MonadBaseControl IO m, MonadIO m) =>
+  SyncEnv ->
   Ledger.RewardAccount StandardCrypto ->
   Maybe ByteString ->
-  ReaderT SqlBackend m DB.StakeAddressId
-insertStakeAddress rewardAddr stakeCredBs = do
-  DB.insertStakeAddress $
-    DB.StakeAddress
-      { DB.stakeAddressHashRaw = addrBs
-      , DB.stakeAddressView = Generic.renderRewardAccount rewardAddr
-      , DB.stakeAddressScriptHash = Generic.getCredentialScriptHash $ Ledger.raCredential rewardAddr
-      }
+  ReaderT SqlBackend m (Maybe DB.StakeAddressId)
+insertStakeAddress syncEnv rewardAddr stakeCredBs =
+  -- check if the address is in the whitelist
+  if shelleyInsertWhitelistCheck ioptsShelley addrBs
+    then do
+      stakeAddrsId <-
+        DB.insertStakeAddress $
+          DB.StakeAddress
+            { DB.stakeAddressHashRaw = addrBs
+            , DB.stakeAddressView = Generic.renderRewardAcnt rewardAddr
+            , DB.stakeAddressScriptHash = Generic.getCredentialScriptHash $ Ledger.getRwdCred rewardAddr
+            }
+      pure $ Just stakeAddrsId
+    else pure Nothing
   where
-    addrBs = fromMaybe (Ledger.serialiseRewardAccount rewardAddr) stakeCredBs
+    addrBs = fromMaybe (Ledger.serialiseRewardAcnt rewardAddr) stakeCredBs
+    ioptsShelley = ioShelley . soptInsertOptions $ envOptions syncEnv
 
 queryRewardAccountWithCacheRetBs ::
   forall m.
@@ -154,8 +175,7 @@ queryStakeAddrWithCacheRetBs ::
   Network ->
   StakeCred ->
   ReaderT SqlBackend m (Either (DB.LookupFail, ByteString) DB.StakeAddressId)
-queryStakeAddrWithCacheRetBs trce cache cacheUA nw cred = do
-  let !bs = Ledger.serialiseRewardAccount (Ledger.RewardAccount nw cred)
+queryStakeAddrWithCacheRetBs cache cacheUA nw cred = do
   case cache of
     NoCache -> do
       mapLeft (,bs) <$> queryStakeAddress bs
@@ -198,11 +218,12 @@ queryStakeAddrWithCacheRetBs trce cache cacheUA nw cred = do
 
 queryPoolKeyWithCache ::
   MonadIO m =>
+  SyncEnv ->
   CacheStatus ->
   CacheAction ->
   PoolKeyHash ->
   ReaderT SqlBackend m (Either DB.LookupFail DB.PoolHashId)
-queryPoolKeyWithCache cache cacheUA hsh =
+queryPoolKeyWithCache syncEnv cache cacheUA hsh =
   case cache of
     NoCache -> do
       mPhId <- queryPoolHashId (Generic.unKeyHashRaw hsh)
@@ -278,14 +299,14 @@ insertPoolKeyWithCache cache cacheUA pHash =
 queryPoolKeyOrInsert ::
   (MonadBaseControl IO m, MonadIO m) =>
   Text ->
-  Trace IO Text ->
+  SyncEnv ->
   CacheStatus ->
   CacheAction ->
   Bool ->
   PoolKeyHash ->
   ReaderT SqlBackend m DB.PoolHashId
-queryPoolKeyOrInsert txt trce cache cacheUA logsWarning hsh = do
-  pk <- queryPoolKeyWithCache cache cacheUA hsh
+queryPoolKeyOrInsert txt syncEnv cache cacheUA logsWarning hsh = do
+  pk <- queryPoolKeyWithCache syncEnv cache cacheUA hsh
   case pk of
     Right poolHashId -> pure poolHashId
     Left err -> do
@@ -304,8 +325,8 @@ queryPoolKeyOrInsert txt trce cache cacheUA logsWarning hsh = do
       insertPoolKeyWithCache cache cacheUA hsh
 
 queryMAWithCache ::
-  MonadIO m =>
-  CacheStatus ->
+  (MonadIO m) =>
+  Cache ->
   PolicyID StandardCrypto ->
   AssetName ->
   ReaderT SqlBackend m (Either (ByteString, ByteString) DB.MultiAssetId)
@@ -329,11 +350,14 @@ queryMAWithCache cache policyId asset =
           let !assetNameBs = Generic.unAssetName asset
           maId <- maybe (Left (policyBs, assetNameBs)) Right <$> DB.queryMultiAssetId policyBs assetNameBs
           whenRight maId $
-            liftIO . atomically . modifyTVar (cMultiAssets ci) . LRU.insert (policyId, asset)
+            liftIO
+              . atomically
+              . modifyTVar (cMultiAssets ci)
+              . LRU.insert (policyId, asset)
           pure maId
 
 queryPrevBlockWithCache ::
-  MonadIO m =>
+  (MonadIO m) =>
   Text ->
   CacheStatus ->
   ByteString ->
@@ -354,7 +378,7 @@ queryPrevBlockWithCache msg cache hsh =
         Nothing -> queryFromDb ci
   where
     queryFromDb ::
-      MonadIO m =>
+      (MonadIO m) =>
       CacheInternal ->
       ExceptT SyncNodeError (ReaderT SqlBackend m) DB.BlockId
     queryFromDb ci = do

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

@@ -8,6 +8,7 @@
 module Cardano.DbSync.Era.Shelley.Query (
   queryPoolHashId,
   queryStakeAddress,
+  queryMultipleStakeAddress,
   queryStakeRefPtr,
   resolveInputTxId,
   resolveInputTxOutId,
@@ -29,6 +30,7 @@ import Database.Esqueleto.Experimental (
   Value (..),
   desc,
   from,
+  in_,
   innerJoin,
   just,
   limit,
@@ -37,6 +39,7 @@ import Database.Esqueleto.Experimental (
   select,
   table,
   val,
+  valList,
   where_,
   (:&) ((:&)),
   (==.),
@@ -64,6 +67,17 @@ queryStakeAddress addr = do
     pure (saddr ^. StakeAddressId)
   pure $ maybeToEither (DbLookupMessage $ "StakeAddress " <> renderByteArray addr) unValue (listToMaybe res)
 
+queryMultipleStakeAddress ::
+  MonadIO m =>
+  [ByteString] ->
+  ReaderT SqlBackend m (Either LookupFail [StakeAddressId])
+queryMultipleStakeAddress addrs = do
+  res <- select $ do
+    saddr <- from $ table @StakeAddress
+    where_ (saddr ^. StakeAddressHashRaw `in_` valList addrs)
+    pure (saddr ^. StakeAddressId)
+  pure $ Right $ map unValue res
+
 resolveInputTxId :: MonadIO m => Generic.TxIn -> ReaderT SqlBackend m (Either LookupFail TxId)
 resolveInputTxId = queryTxId . Generic.txInHash
 

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

@@ -5,10 +5,13 @@
 
 module Cardano.DbSync.Era.Universal.Adjust (
   adjustEpochRewards,
-) where
+)
+where
 
-import Cardano.BM.Trace (Trace, logInfo)
+import Cardano.BM.Trace (logInfo)
 import qualified Cardano.Db as Db
+import Cardano.DbSync.Api (getTrace)
+import Cardano.DbSync.Api.Types (SyncEnv (..))
 import Cardano.DbSync.Cache (
   queryPoolKeyWithCache,
   queryStakeAddrWithCache,
@@ -48,38 +51,37 @@ import Database.Esqueleto.Experimental (
 
 adjustEpochRewards ::
   (MonadBaseControl IO m, MonadIO m) =>
-  Trace IO Text ->
+  SyncEnv ->
   Network ->
-  CacheStatus ->
   EpochNo ->
   Generic.Rewards ->
   Set StakeCred ->
   ReaderT SqlBackend m ()
-adjustEpochRewards trce nw cache epochNo rwds creds = do
+adjustEpochRewards syncEnv nw epochNo rwds creds = do
   let eraIgnored = Map.toList $ Generic.unRewards rwds
-  liftIO . logInfo trce $
-    mconcat
+  liftIO
+    . Cardano.BM.Trace.logInfo (getTrace syncEnv)
+    $ mconcat
       [ "Removing "
       , if null eraIgnored then "" else Db.textShow (length eraIgnored) <> " rewards and "
       , show (length creds)
       , " orphaned rewards"
       ]
   forM_ eraIgnored $ \(cred, rewards) ->
     forM_ (Set.toList rewards) $ \rwd ->
-      deleteReward trce nw cache epochNo (cred, rwd)
-  crds <- rights <$> forM (Set.toList creds) (queryStakeAddrWithCache trce cache DoNotUpdateCache nw)
+      deleteReward nw cache epochNo (cred, rwd)
+  crds <- rights <$> forM (Set.toList creds) (queryStakeAddrWithCache (envCache syncEnv) DoNotUpdateCache nw)
   deleteOrphanedRewards epochNo crds
 
 deleteReward ::
   (MonadBaseControl IO m, MonadIO m) =>
-  Trace IO Text ->
+  SyncEnv ->
   Network ->
-  CacheStatus ->
   EpochNo ->
   (StakeCred, Generic.Reward) ->
   ReaderT SqlBackend m ()
-deleteReward trce nw cache epochNo (cred, rwd) = do
-  mAddrId <- queryStakeAddrWithCache trce cache DoNotUpdateCache nw cred
+deleteReward syncEnv nw epochNo (cred, rwd) = do
+  mAddrId <- queryStakeAddrWithCache cache DoNotUpdateCache nw cred
   eiPoolId <- queryPoolKeyWithCache cache DoNotUpdateCache (Generic.rewardPool rwd)
   case (mAddrId, eiPoolId) of
     (Right addrId, Right poolId) -> do
@@ -90,8 +92,10 @@ deleteReward trce nw cache epochNo (cred, rwd) = do
         where_ (rwdDb ^. Db.RewardSpendableEpoch ==. val (unEpochNo epochNo))
         where_ (rwdDb ^. Db.RewardPoolId ==. val poolId)
     _ -> pure ()
+  where
+    cache = envCache syncEnv
 
-deleteOrphanedRewards :: MonadIO m => EpochNo -> [Db.StakeAddressId] -> ReaderT SqlBackend m ()
+deleteOrphanedRewards :: (MonadIO m) => EpochNo -> [Db.StakeAddressId] -> ReaderT SqlBackend m ()
 deleteOrphanedRewards (EpochNo epochNo) xs =
   delete $ do
     rwd <- from $ table @Db.Reward