Support networks that fork at 0

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

@@ -54,7 +54,7 @@ import qualified Shelley.Spec.Ledger.Tx as Shelley
 data Block = Block
   { blkEra :: !BlockEra
   , blkHash :: !ByteString
-  , blkPreviousHash :: !ByteString
+  , blkPreviousHash :: !(Maybe ByteString) -- Nothing is used for first block after Genesis.
   , blkCreatorPoolHash :: !ByteString
   , blkSlotLeader :: !ByteString
   , blkSlotNo :: !SlotNo
@@ -156,11 +156,11 @@ blockHash =
 blockNumber :: ShelleyBasedEra era => ShelleyBlock era -> BlockNo
 blockNumber = Shelley.bheaderBlockNo . blockBody
 
-blockPrevHash :: ShelleyBasedEra era => ShelleyBlock era -> ByteString
+blockPrevHash :: ShelleyBasedEra era => ShelleyBlock era -> Maybe ByteString
 blockPrevHash blk =
   case Shelley.bheaderPrev (Shelley.bhbody . Shelley.bheader $ Consensus.shelleyBlockRaw blk) of
-    Shelley.GenesisHash -> "Cardano.DbSync.Era.Shelley.Generic.Block.blockPrevHash"
-    Shelley.BlockHash h -> Crypto.hashToBytes (Shelley.unHashHeader h)
+    Shelley.GenesisHash -> Nothing
+    Shelley.BlockHash h -> Just $ Crypto.hashToBytes (Shelley.unHashHeader h)
 
 blockOpCert :: ShelleyBasedEra era => ShelleyBlock era -> ByteString
 blockOpCert = KES.rawSerialiseVerKeyKES . Shelley.ocertVkHot . Shelley.bheaderOCert . blockBody

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

@@ -23,12 +23,14 @@ import           Control.Monad.Trans.Except.Extra (newExceptT)
 import qualified Cardano.Db as DB
 
 import qualified Cardano.DbSync.Era.Shelley.Generic.Util as Generic
+import           Cardano.DbSync.Era.Shelley.Insert
 import           Cardano.DbSync.Era.Util (liftLookupFail)
 import           Cardano.Sync.Error
 import           Cardano.Sync.Util
 
 import qualified Cardano.Ledger.Address as Ledger
 import qualified Cardano.Ledger.Coin as Ledger
+import           Cardano.Ledger.Credential (Credential (KeyHashObj))
 import           Cardano.Ledger.Era (Crypto)
 
 import qualified Data.ByteString.Char8 as BS
@@ -40,7 +42,8 @@ import qualified Data.Time.Clock as Time
 import           Database.Persist.Sql (SqlBackend)
 
 import           Ouroboros.Consensus.Cardano.Block (StandardCrypto, StandardShelley)
-import           Ouroboros.Consensus.Shelley.Node (ShelleyGenesis (..))
+import           Ouroboros.Consensus.Shelley.Node (ShelleyGenesis (..), ShelleyGenesisStaking (..),
+                   emptyGenesisStaking)
 
 import qualified Shelley.Spec.Ledger.Genesis as Shelley
 import           Shelley.Spec.Ledger.Scripts ()
@@ -59,17 +62,23 @@ insertValidateGenesisDist backend tracer networkName cfg = do
       then newExceptT $ DB.runDbIohkLogging backend tracer insertAction
       else newExceptT $ DB.runDbIohkNoLogging backend insertAction
   where
+    hasInitialFunds :: Bool
+    hasInitialFunds = not $ Map.null $ sgInitialFunds cfg
+
+    hasStakes :: Bool
+    hasStakes = sgStaking cfg /= emptyGenesisStaking
+
     insertAction :: (MonadBaseControl IO m, MonadIO m) => ReaderT SqlBackend m (Either SyncNodeError ())
     insertAction = do
       ebid <- DB.queryBlockId (configGenesisHash cfg)
       case ebid of
-        Right bid -> validateGenesisDistribution tracer networkName cfg bid
+        Right bid -> validateGenesisDistribution tracer networkName cfg bid hasStakes
         Left _ ->
           runExceptT $ do
             liftIO $ logInfo tracer "Inserting Shelley Genesis distribution"
             emeta <- lift DB.queryMeta
             case emeta of
-              Right _ -> pure () -- Metadata from Byron era already exists. TODO Validate metadata.
+              Right _ -> pure () -- Metadata from Shelley era already exists. TODO Validate metadata.
               Left _ -> do
                 count <- lift DB.queryBlockCount
                 when (count > 0) $
@@ -79,6 +88,8 @@ insertValidateGenesisDist backend tracer networkName cfg = do
                               { DB.metaStartTime = configStartTime cfg
                               , DB.metaNetworkName = networkName
                               }
+            -- No reason to insert the artificial block if there are no funds or stakes definitions.
+            when (hasInitialFunds || hasStakes) $ do
                 -- Insert an 'artificial' Genesis block (with a genesis specific slot leader). We
                 -- need this block to attach the genesis distribution transactions to.
                 -- It would be nice to not need this artificial block, but that would
@@ -90,14 +101,21 @@ insertValidateGenesisDist backend tracer networkName cfg = do
                                   , DB.slotLeaderPoolHashId = Nothing
                                   , DB.slotLeaderDescription = "Shelley Genesis slot leader"
                                   }
+                -- We attach the Genesis Shelley Block after the block with the biggest Slot.
+                -- In most cases this will simply be the Genesis Byron artificial Block,
+                -- since this configuration is used for networks which start from Shelley.
+                -- This means the previous block will have two blocks after it, resulting in a
+                -- tree format, which is unavoidable.
+                pid <- lift DB.queryLatestBlockId
+                liftIO $ logInfo tracer $ textShow pid
                 bid <- lift . DB.insertBlock $
                           DB.Block
                             { DB.blockHash = configGenesisHash cfg
                             , DB.blockEpochNo = Nothing
                             , DB.blockSlotNo = Nothing
                             , DB.blockEpochSlotNo = Nothing
                             , DB.blockBlockNo = Nothing
-                            , DB.blockPreviousId = Nothing
+                            , DB.blockPreviousId = pid
                             , DB.blockSlotLeaderId = slid
                             , DB.blockSize = 0
                             , DB.blockTime = configStartTime cfg
@@ -113,16 +131,16 @@ insertValidateGenesisDist backend tracer networkName cfg = do
                 lift $ mapM_ (insertTxOuts bid) $ genesisUtxOs cfg
                 liftIO . logInfo tracer $ "Initial genesis distribution populated. Hash "
                                 <> renderByteArray (configGenesisHash cfg)
-
+                insertStaking tracer bid cfg
                 supply <- lift DB.queryTotalSupply
                 liftIO $ logInfo tracer ("Total genesis supply of Ada: " <> DB.renderAda supply)
 
 -- | Validate that the initial Genesis distribution in the DB matches the Genesis data.
 validateGenesisDistribution
     :: (MonadBaseControl IO m, MonadIO m)
-    => Trace IO Text -> Text -> ShelleyGenesis StandardShelley -> DB.BlockId
+    => Trace IO Text -> Text -> ShelleyGenesis StandardShelley -> DB.BlockId -> Bool
     -> ReaderT SqlBackend m (Either SyncNodeError ())
-validateGenesisDistribution tracer networkName cfg bid =
+validateGenesisDistribution tracer networkName cfg bid hasStakeTx =
   runExceptT $ do
     liftIO $ logInfo tracer "Validating Genesis distribution"
     meta <- liftLookupFail "Shelley.validateGenesisDistribution" DB.queryMeta
@@ -143,15 +161,15 @@ validateGenesisDistribution tracer networkName cfg bid =
             ]
 
     txCount <- lift $ DB.queryBlockTxCount bid
-    let expectedTxCount = fromIntegral $length (genesisTxos cfg)
+    let expectedTxCount = fromIntegral $length (genesisTxos cfg) + if hasStakeTx then 1 else 0
     when (txCount /= expectedTxCount) $
       dbSyncNodeError $ Text.concat
               [ "Shelley.validateGenesisDistribution: Expected initial block to have "
               , textShow expectedTxCount
               , " but got "
               , textShow txCount
               ]
-    totalSupply <- lift DB.queryGenesisSupply
+    totalSupply <- lift DB.queryShelleyGenesisSupply
     let expectedSupply = configGenesisSupply cfg
     when (expectedSupply /= totalSupply) $
       dbSyncNodeError  $ Text.concat
@@ -160,10 +178,9 @@ validateGenesisDistribution tracer networkName cfg bid =
          , " but got "
          , textShow totalSupply
          ]
-    supply <- lift DB.queryGenesisSupply
     liftIO $ do
       logInfo tracer "Initial genesis distribution present and correct"
-      logInfo tracer ("Total genesis supply of Ada: " <> DB.renderAda supply)
+      logInfo tracer ("Total genesis supply of Ada: " <> DB.renderAda totalSupply)
 
 -- -----------------------------------------------------------------------------
 
@@ -188,6 +205,7 @@ insertTxOuts blkId (Shelley.TxIn txInId _, txOut) = do
               , DB.txValidContract = True
               , DB.txScriptSize = 0
               }
+  _ <- insertStakeAddressRefIfMissing txId (txOutAddress txOut)
   void . DB.insertTxOut $
             DB.TxOut
               { DB.txOutTxId = txId
@@ -209,13 +227,45 @@ insertTxOuts blkId (Shelley.TxIn txInId _, txOut) = do
 
     hasScript addr = maybe False Generic.hasCredScript (Generic.getPaymentCred addr)
 
+-- Insert pools and delegations coming from Genesis.
+insertStaking
+    :: (MonadBaseControl IO m, MonadIO m)
+    => Trace IO Text
+    -> DB.BlockId
+    -> ShelleyGenesis StandardShelley
+    -> ExceptT SyncNodeError (ReaderT SqlBackend m) ()
+insertStaking tracer blkId genesis = do
+  -- All Genesis staking comes from an artifical transaction
+  -- with a hash generated by hashing the address.
+  txId <- lift $ DB.insertTx $
+            DB.Tx
+              { DB.txHash = configGenesisStakingHash
+              , DB.txBlockId = blkId
+              , DB.txBlockIndex = 0
+              , DB.txOutSum = DB.DbLovelace 0
+              , DB.txFee = DB.DbLovelace 0
+              , DB.txDeposit = 0
+              , DB.txSize = 0
+              , DB.txInvalidHereafter = Nothing
+              , DB.txInvalidBefore = Nothing
+              , DB.txValidContract = True
+              , DB.txScriptSize = 0
+              }
+  let params = zip [0..] $ Map.elems (sgsPools $ sgStaking genesis)
+  forM_ params $ uncurry (insertPoolRegister tracer (Left 2) (sgNetworkId genesis) 0 blkId txId)
+  let stakes = zip [0..] $ Map.toList (sgsStake $ sgStaking genesis)
+  forM_ stakes $ \(n, (keyStaking, keyPool)) -> insertDelegation tracer (sgNetworkId genesis) 0 0 txId n Nothing (KeyHashObj keyStaking) [] keyPool
+
 -- -----------------------------------------------------------------------------
 
 configGenesisHash :: ShelleyGenesis StandardShelley -> ByteString
-configGenesisHash _ =  BS.take 28 ("GenesisHash " <> BS.replicate 28 '\0')
+configGenesisHash _ =  BS.take 32 ("Shelley Genesis Block Hash " <> BS.replicate 32 '\0')
 
 genesisHashSlotLeader :: ShelleyGenesis StandardShelley -> ByteString
-genesisHashSlotLeader = configGenesisHash
+genesisHashSlotLeader _ = BS.take 28 ("Shelley Genesis SlotLeader Hash" <> BS.replicate 28 '\0')
+
+configGenesisStakingHash :: ByteString
+configGenesisStakingHash =  BS.take 32 ("Shelley Genesis Staking Tx Hash " <> BS.replicate 32 '\0')
 
 configGenesisSupply :: ShelleyGenesis StandardShelley -> DB.Ada
 configGenesisSupply =

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

@@ -12,6 +12,12 @@ module Cardano.DbSync.Era.Shelley.Insert
   , postEpochRewards
   , postEpochStake
 
+  -- These are exported for data in Shelley Genesis
+  , insertPoolRegister
+  , insertDelegation
+  , insertStakeAddressRefIfMissing
+
+  -- Util
   , containsUnicodeNul
   , safeDecodeUtf8
   ) where
@@ -29,10 +35,10 @@ import qualified Cardano.Crypto.Hash as Crypto
 import           Cardano.Db (DbLovelace (..), DbWord64 (..), SyncState (..))
 import qualified Cardano.Db as DB
 
-import           Cardano.DbSync.Era
 import qualified Cardano.DbSync.Era.Shelley.Generic as Generic
 import           Cardano.DbSync.Era.Shelley.Generic.ParamProposal
 import           Cardano.DbSync.Era.Shelley.Insert.Epoch
+import           Cardano.DbSync.Era.Shelley.Offline
 import           Cardano.DbSync.Era.Shelley.Query
 import           Cardano.DbSync.Era.Util (liftLookupFail, safeDecodeUtf8)
 
@@ -81,7 +87,9 @@ insertShelleyBlock
     -> ReaderT SqlBackend m (Either SyncNodeError ())
 insertShelleyBlock tracer lenv blk lStateSnap details = do
   runExceptT $ do
-    pbid <- liftLookupFail (renderInsertName (Generic.blkEra blk)) $ DB.queryBlockId (Generic.blkPreviousHash blk)
+    pbid <- case Generic.blkPreviousHash blk of
+      Nothing -> liftLookupFail (renderInsertName (Generic.blkEra blk)) DB.queryGenesis -- this is for networks that fork from Byron on epoch 0.
+      Just pHash -> liftLookupFail (renderInsertName (Generic.blkEra blk)) $ DB.queryBlockId pHash
     mPhid <- lift $ queryPoolHashId (Generic.blkCreatorPoolHash blk)
 
     slid <- lift . DB.insertSlotLeader $ Generic.mkSlotLeader (Generic.blkSlotLeader blk) mPhid
@@ -317,7 +325,7 @@ insertPoolCert
     -> ExceptT SyncNodeError (ReaderT SqlBackend m) ()
 insertPoolCert tracer lStateSnap network epoch blkId txId idx pCert =
   case pCert of
-    Shelley.RegPool pParams -> insertPoolRegister tracer lStateSnap network epoch blkId txId idx pParams
+    Shelley.RegPool pParams -> insertPoolRegister tracer (Right lStateSnap) network epoch blkId txId idx pParams
     Shelley.RetirePool keyHash epochNum -> insertPoolRetire txId epochNum idx keyHash
 
 insertDelegCert
@@ -334,9 +342,9 @@ insertDelegCert tracer network txId idx ridx epochNo slotNo redeemers dCert =
 
 insertPoolRegister
     :: (MonadBaseControl IO m, MonadIO m)
-    => Trace IO Text -> LedgerStateSnapshot -> Ledger.Network -> EpochNo -> DB.BlockId -> DB.TxId -> Word16 -> Shelley.PoolParams StandardCrypto
+    => Trace IO Text -> Either Word64 LedgerStateSnapshot -> Ledger.Network -> EpochNo -> DB.BlockId -> DB.TxId -> Word16 -> Shelley.PoolParams StandardCrypto
     -> ExceptT SyncNodeError (ReaderT SqlBackend m) ()
-insertPoolRegister tracer lStateSnap network (EpochNo epoch) blkId txId idx params = do
+insertPoolRegister tracer mlStateSnap network (EpochNo epoch) blkId txId idx params = do
 
     when (fromIntegral (Ledger.unCoin $ Shelley._poolPledge params) > maxLovelace) $
       liftIO . logWarning tracer $
@@ -379,8 +387,9 @@ insertPoolRegister tracer lStateSnap network (EpochNo epoch) blkId txId idx para
 
   where
     mkEpochActivationDelay :: MonadIO m => DB.PoolHashId -> ExceptT SyncNodeError (ReaderT SqlBackend m) Word64
-    mkEpochActivationDelay poolHashId =
-      if Set.member (Shelley._poolId params) $ getPoolParams (lssOldState lStateSnap)
+    mkEpochActivationDelay poolHashId = case mlStateSnap of
+      Left n -> pure n
+      Right lStateSnap -> if Set.member (Shelley._poolId params) $ getPoolParams (lssOldState lStateSnap)
         then pure 3
         else do
           -- if the pool is not registered at the end of the previous block, check for

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

@@ -8,7 +8,7 @@ module Cardano.DbSync.Plugin.Default
   ) where
 
 
-import           Cardano.Prelude
+import           Cardano.Prelude hiding (atomically)
 
 import           Cardano.BM.Trace (Trace, logDebug, logInfo)
 
@@ -38,7 +38,7 @@ import           Cardano.Sync.Plugin
 import           Cardano.Sync.Types
 import           Cardano.Sync.Util
 
-import           Control.Monad.Class.MonadSTM.Strict (putTMVar, tryTakeTMVar)
+import           Control.Monad.Class.MonadSTM.Strict (atomically, tryPutTMVar, tryTakeTMVar)
 import           Control.Monad.Trans.Control (MonadBaseControl)
 import           Control.Monad.Trans.Except.Extra (newExceptT)
 
@@ -179,7 +179,7 @@ stashPoolRewards tracer lenv epoch rmap = do
   mMirRwd <- liftIO . atomically $ tryTakeTMVar (leMirRewards lenv)
   case mMirRwd of
     Nothing ->
-      liftIO . atomically $ putTMVar (lePoolRewards lenv) (epoch, rmap)
+      void . liftIO . atomically $ tryPutTMVar (lePoolRewards lenv) (epoch, rmap)
     Just mirMap ->
       validateEpochRewards tracer (leNetwork lenv) (epoch - 2) (Map.unionWith plusCoin rmap mirMap)
 
@@ -191,6 +191,6 @@ stashMirRewards tracer lenv mirMap = do
     mRwds <- liftIO . atomically $ tryTakeTMVar (lePoolRewards lenv)
     case mRwds of
       Nothing ->
-        liftIO . atomically $ putTMVar (leMirRewards lenv) mirMap
+        void . liftIO . atomically $ tryPutTMVar (leMirRewards lenv) mirMap
       Just (epoch, rmap) ->
         validateEpochRewards tracer (leNetwork lenv) (epoch - 2) (Map.unionWith plusCoin rmap mirMap)

cardano-db/src/Cardano/Db/Delete.hs

@@ -10,7 +10,7 @@ import           Cardano.Slotting.Slot (SlotNo (..))
 import           Control.Monad.IO.Class (MonadIO)
 import           Control.Monad.Trans.Reader (ReaderT)
 
-import           Database.Persist.Sql (SqlBackend, delete, selectKeysList, (==.))
+import           Database.Persist.Sql (SqlBackend, delete, selectKeysList, (!=.), (==.))
 
 import           Cardano.Db.Schema
 
@@ -29,7 +29,8 @@ deleteCascadeBlock block = do
 -- deleted and 'False' if it did not exist.
 deleteCascadeAfter :: MonadIO m => BlockId -> ReaderT SqlBackend m Bool
 deleteCascadeAfter bid = do
-  keys <- selectKeysList [ BlockPreviousId ==. Just bid ] []
+  -- Genesis artificial blocks are not deleted (Byron or Shelley) since they have null epoch
+  keys <- selectKeysList [ BlockPreviousId ==. Just bid, BlockEpochNo !=. Nothing ] []
   mapM_ delete keys
   pure $ not (null keys)
 

cardano-db/src/Cardano/Db/Query.hs

@@ -23,6 +23,7 @@ module Cardano.Db.Query
   , queryFeesUpToBlockNo
   , queryFeesUpToSlotNo
   , queryGenesisSupply
+  , queryShelleyGenesisSupply
   , queryLatestBlock
   , queryLatestCachedEpochNo
   , queryLatestEpochNo
@@ -125,7 +126,7 @@ queryAddressBalanceAtSlot addr slotNo = do
 queryGenesis :: MonadIO m => ReaderT SqlBackend m (Either LookupFail BlockId)
 queryGenesis = do
   res <- select . from $ \ blk -> do
-            where_ (isNothing (blk ^. BlockEpochNo))
+            where_ (isNothing (blk ^. BlockPreviousId))
             pure $ blk ^. BlockId
   case res of
     [blk] -> pure $ Right (unValue blk)
@@ -337,6 +338,18 @@ queryGenesisSupply = do
     res <- select . from $ \ (txOut `InnerJoin` tx `InnerJoin` blk) -> do
                 on (tx ^. TxBlockId ==. blk ^. BlockId)
                 on (tx ^. TxId ==. txOut ^. TxOutTxId)
+                where_ (isNothing $ blk ^. BlockPreviousId)
+                pure $ sum_ (txOut ^. TxOutValue)
+    pure $ unValueSumAda (listToMaybe res)
+
+-- | Return the total Shelley Genesis coin supply. The Shelley Genesis Block
+-- is the unique which has a non-null PreviousId, but has null Epoch.
+queryShelleyGenesisSupply :: MonadIO m => ReaderT SqlBackend m Ada
+queryShelleyGenesisSupply = do
+    res <- select . from $ \ (txOut `InnerJoin` tx `InnerJoin` blk) -> do
+                on (tx ^. TxBlockId ==. blk ^. BlockId)
+                on (tx ^. TxId ==. txOut ^. TxOutTxId)
+                where_ (isJust $ blk ^. BlockPreviousId)
                 where_ (isNothing $ blk ^. BlockEpochNo)
                 pure $ sum_ (txOut ^. TxOutValue)
     pure $ unValueSumAda (listToMaybe res)

cardano-db/src/Cardano/Db/Schema.hs

@@ -414,7 +414,7 @@ share
     minPoolCost         DbLovelace Maybe    sqltype=lovelace
 
     coinsPerUtxoWord    DbLovelace Maybe    sqltype=lovelace
-    costModelsId        CostModelsId Maybe
+    costModelsId        CostModelsId Maybe  OnDeleteCascade
     priceMem            Double Maybe        -- sqltype=rational
     priceStep           Double Maybe        -- sqltype=rational
     maxTxExMem          DbWord64 Maybe      sqltype=word64type
@@ -452,7 +452,7 @@ share
     nonce               ByteString Maybe    sqltype=hash32type
 
     coinsPerUtxoWord    DbLovelace Maybe    sqltype=lovelace
-    costModelsId        CostModelsId Maybe
+    costModelsId        CostModelsId Maybe  OnDeleteCascade
     priceMem            Double Maybe        -- sqltype=rational
     priceStep           Double Maybe        -- sqltype=rational
     maxTxExMem          DbWord64 Maybe      sqltype=word64type

cardano-sync/src/Cardano/Sync/Era/Shelley/Generic/Rewards.hs

@@ -109,7 +109,8 @@ genericRewards network era epoch lstate =
     cleanup :: Map StakeCred (Set Reward) -> Rewards
     cleanup rmap =
       Rewards
-        { rwdEpoch = epoch - 1 -- Epoch in which rewards were earned.
+        { rwdEpoch = if epoch < 1 then 0 else epoch - 1 -- Epoch in which rewards were earned.
+                                                        -- The check exists for networks that start at Shelley.
         , rwdRewards = filterByEra era rmap
         }