db-sync: Fix handling of StakeRefPtr (#1024)

Previously `insertStakeAddressRefIfMissing` was returning `Nothing` if it received a stake address of type `StakeRefPtr`. Now it returns a proper `StakeAddressId`. Closes: #1016
IntersectMBO · Jan 22, 2022 · c238e60 · c238e60
1 parent 058f229
commit c238e60
Show file tree

Hide file tree

Showing 3 changed files with 34 additions and 15 deletions.
diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Genesis.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Genesis.hs
@@ -137,7 +137,7 @@ insertValidateGenesisDist backend tracer networkName cfg shelleyInitiation = do
                             , DB.blockOpCert = Nothing
                             , DB.blockOpCertCounter = Nothing
                             }
-                lift $ mapM_ (insertTxOuts bid) $ genesisUtxOs cfg
+                lift $ mapM_ (insertTxOuts tracer bid) $ genesisUtxOs cfg
                 liftIO . logInfo tracer $ "Initial genesis distribution populated. Hash "
                                 <> renderByteArray (configGenesisHash cfg)
                 when hasStakes $
@@ -195,9 +195,9 @@ validateGenesisDistribution tracer networkName cfg bid expectedTxCount =
 
 insertTxOuts
     :: (MonadBaseControl IO m, MonadIO m)
-    => DB.BlockId -> (ShelleyTx.TxIn (Crypto StandardShelley), Shelley.TxOut StandardShelley)
+    => Trace IO Text -> DB.BlockId -> (ShelleyTx.TxIn (Crypto StandardShelley), Shelley.TxOut StandardShelley)
     -> ReaderT SqlBackend m ()
-insertTxOuts blkId (ShelleyTx.TxIn txInId _, txOut) = do
+insertTxOuts trce blkId (ShelleyTx.TxIn txInId _, txOut) = do
   -- Each address/value pair of the initial coin distribution comes from an artifical transaction
   -- with a hash generated by hashing the address.
   txId <- DB.insertTx $
@@ -214,7 +214,7 @@ insertTxOuts blkId (ShelleyTx.TxIn txInId _, txOut) = do
               , DB.txValidContract = True
               , DB.txScriptSize = 0
               }
-  _ <- insertStakeAddressRefIfMissing txId (txOutAddress txOut)
+  _ <- insertStakeAddressRefIfMissing trce txId (txOutAddress txOut)
   void . DB.insertTxOut $
             DB.TxOut
               { DB.txOutTxId = txId

diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert.hs
@@ -256,7 +256,7 @@ prepareTxOut
     => Trace IO Text -> (DB.TxId, ByteString) -> Generic.TxOut
     -> ExceptT SyncNodeError (ReaderT SqlBackend m) (ExtendedTxOut, [MissingMaTxOut])
 prepareTxOut tracer (txId, txHash) (Generic.TxOut index addr addrRaw value maMap dataHash) = do
-    mSaId <- lift $ insertStakeAddressRefIfMissing txId addr
+    mSaId <- lift $ insertStakeAddressRefIfMissing tracer txId addr
     let txOut = DB.TxOut
                   { DB.txOutTxId = txId
                   , DB.txOutIndex = index
@@ -447,9 +447,9 @@ insertStakeAddress txId rewardAddr =
 -- whether it is newly inserted or it is already there, we retrun the `StakeAddressId`.
 insertStakeAddressRefIfMissing
     :: (MonadBaseControl IO m, MonadIO m)
-    => DB.TxId -> Ledger.Addr StandardCrypto
+    => Trace IO Text -> DB.TxId -> Ledger.Addr StandardCrypto
     -> ReaderT SqlBackend m (Maybe DB.StakeAddressId)
-insertStakeAddressRefIfMissing txId addr =
+insertStakeAddressRefIfMissing trce txId addr =
     maybe insertSAR (pure . Just) =<< queryStakeAddressRef addr
   where
     insertSAR :: (MonadBaseControl IO m, MonadIO m) => ReaderT SqlBackend m (Maybe DB.StakeAddressId)
@@ -460,10 +460,11 @@ insertStakeAddressRefIfMissing txId addr =
           case sref of
             Ledger.StakeRefBase cred ->
               Just <$> insertStakeAddress txId (Shelley.RewardAcnt nw cred)
-            Ledger.StakeRefPtr {} ->
-              -- This happens when users pay to payment addresses that refer to a stake addresses
-              -- by pointer, but where the pointer does not refer to a registered stake address.
-              pure Nothing
+            Ledger.StakeRefPtr ptr -> do
+              mid <- queryStakeRefPtr ptr
+              when (isNothing mid) .
+                liftIO . logWarning trce $ "insertStakeRefIfMissing: query of " <> textShow ptr <> " returns Nothing"
+              pure mid
             Ledger.StakeRefNull -> pure Nothing
 
 insertPoolOwner

diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Query.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Query.hs
@@ -8,6 +8,7 @@ module Cardano.DbSync.Era.Shelley.Query
   ( queryPoolHashId
   , queryStakeAddress
   , queryStakePoolKeyHash
+  , queryStakeRefPtr
   , queryStakeAddressRef
   , queryResolveInput
   , queryResolveInputCredentials
@@ -17,7 +18,7 @@ module Cardano.DbSync.Era.Shelley.Query
   , queryPoolUpdateByBlock
   ) where
 
-import           Cardano.Prelude hiding (from, maybeToEither, on)
+import           Cardano.Prelude hiding (Ptr, from, maybeToEither, on)
 
 import           Cardano.Db
 import qualified Cardano.DbSync.Era.Shelley.Generic as Generic
@@ -36,6 +37,8 @@ import           Database.Persist.Sql (SqlBackend)
 
 import           Ouroboros.Consensus.Cardano.Block (StandardCrypto)
 
+{- HLINT ignore "Reduce duplication" -}
+
 
 queryPoolHashId :: MonadIO m => ByteString -> ReaderT SqlBackend m (Maybe PoolHashId)
 queryPoolHashId hash = do
@@ -82,14 +85,14 @@ queryStakeAddressRef addr =
           StakeRefBase cred -> do
             eres <- queryStakeAddress $ Ledger.serialiseRewardAcnt (Ledger.RewardAcnt nw cred)
             pure $ either (const Nothing) Just eres
-          StakeRefPtr (Ptr slotNo txIx certIx) -> queryStakeDelegation slotNo (fromIntegral txIx) (fromIntegral certIx)
+          StakeRefPtr ptr -> queryStakeDelegation ptr
           StakeRefNull -> pure Nothing
   where
     queryStakeDelegation
         :: MonadIO m
-        => SlotNo -> Natural -> Natural
+        => Ptr
         -> ReaderT SqlBackend m (Maybe StakeAddressId)
-    queryStakeDelegation (SlotNo slot) txIx certIx = do
+    queryStakeDelegation (Ptr (SlotNo slot) txIx certIx) = do
       res <- select . from $ \ (blk `InnerJoin` tx `InnerJoin` dlg) -> do
                 on (tx ^. TxId ==. dlg ^. DelegationTxId)
                 on (blk ^. BlockId ==. tx ^. TxBlockId)
@@ -121,6 +124,21 @@ queryStakeAddressIdPair cred@(Generic.StakeCred bs) = do
     convert :: Value StakeAddressId -> (Generic.StakeCred, StakeAddressId)
     convert (Value said) = (cred, said)
 
+queryStakeRefPtr :: MonadIO m => Ptr -> ReaderT SqlBackend m (Maybe StakeAddressId)
+queryStakeRefPtr (Ptr (SlotNo slot) txIx certIx) = do
+  res <- select . from $ \ (sr `InnerJoin` tx `InnerJoin` blk) -> do
+            on (blk ^. BlockId ==. tx ^. TxBlockId)
+            on (sr ^. StakeRegistrationTxId ==. tx ^. TxId)
+            where_ (blk ^. BlockSlotNo ==. just (val slot))
+            where_ (tx ^. TxBlockIndex ==. val (fromIntegral txIx))
+            where_ (sr ^. StakeRegistrationCertIndex ==. val (fromIntegral certIx))
+            -- Need to order by DelegationSlotNo descending for correct behavior when there are two
+            -- or more delegation certificates in a single epoch.
+            orderBy [desc (blk ^. BlockSlotNo)]
+            limit 1
+            pure (sr ^. StakeRegistrationAddrId)
+  pure $ unValue <$> listToMaybe res
+
 queryPoolHashIdPair
     :: MonadIO m
     => Generic.StakePoolKeyHash