Consolidate a number of PRs

.hlint.yaml

@@ -37,6 +37,7 @@
   - {name: [Data.Text], as: Text}
   - {name: [Data.ByteString.Char8], as: BS}
   - {name: [Data.ByteString.Lazy.Char8], as: LBS}
+  - {name: [Data.ByteString.Short], as: SBS}
 
 # Banned functions
 - functions:

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

@@ -5,7 +5,7 @@ module Cardano.DbSync.Era.Cardano.Util
 
 import           Cardano.Prelude
 
-import qualified Data.ByteString.Short as BSS
+import qualified Data.ByteString.Short as SBS
 
 import           Ouroboros.Consensus.Cardano.Block (CardanoBlock)
 import qualified Ouroboros.Consensus.HardFork.Combinator as Consensus
@@ -16,5 +16,5 @@ unChainHash :: ChainHash (CardanoBlock era) -> ByteString
 unChainHash ch =
   case ch of
     GenesisHash -> "genesis"
-    BlockHash bh -> BSS.fromShort (Consensus.getOneEraHash bh)
+    BlockHash bh -> SBS.fromShort (Consensus.getOneEraHash bh)
 

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

@@ -55,7 +55,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
@@ -157,11 +157,11 @@ blockHash =
 blockNumber :: ShelleyBasedEra era => ShelleyBlock era -> BlockNo
 blockNumber = Protocol.bheaderBlockNo . blockBody
 
-blockPrevHash :: ShelleyBasedEra era => ShelleyBlock era -> ByteString
+blockPrevHash :: ShelleyBasedEra era => ShelleyBlock era -> Maybe ByteString
 blockPrevHash blk =
   case Protocol.bheaderPrev (Protocol.bhbody . Shelley.bheader $ Consensus.shelleyBlockRaw blk) of
-    Protocol.GenesisHash -> "Cardano.DbSync.Era.Shelley.Generic.Block.blockPrevHash"
-    Protocol.BlockHash (Protocol.HashHeader h) -> Crypto.hashToBytes h
+    Protocol.GenesisHash -> Just "Cardano.DbSync.Era.Shelley.Generic.Block.blockPrevHash"
+    Protocol.BlockHash (Protocol.HashHeader h) -> Just $ Crypto.hashToBytes h
 
 blockOpCert :: ShelleyBasedEra era => ShelleyBlock era -> ByteString
 blockOpCert = KES.rawSerialiseVerKeyKES . Protocol.ocertVkHot . Protocol.bheaderOCert . blockBody

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

@@ -69,6 +69,7 @@ import           Ouroboros.Consensus.Cardano.Block (StandardAllegra, StandardAlo
                    StandardMary, StandardShelley)
 import           Ouroboros.Consensus.Shelley.Ledger.Block (ShelleyBasedEra)
 
+import qualified Shelley.Spec.Ledger.CompactAddr as Ledger
 import           Shelley.Spec.Ledger.Scripts (ScriptHash)
 import qualified Shelley.Spec.Ledger.Tx as Shelley
 import qualified Shelley.Spec.Ledger.TxBody as Shelley
@@ -119,6 +120,7 @@ data TxIn = TxIn
 data TxOut = TxOut
   { txOutIndex :: !Word16
   , txOutAddress :: !(Ledger.Addr StandardCrypto)
+  , txOutAddressRaw :: !ByteString
   , txOutAdaValue :: !Coin
   , txOutMaValue :: !(Map (PolicyID StandardCrypto) (Map AssetName Integer))
   , txOutDataHash :: !(Maybe ByteString)
@@ -173,14 +175,20 @@ fromAllegraTx (blkIndex, tx) =
       }
   where
     fromTxOut :: Word16 -> Shelley.TxOut StandardAllegra -> TxOut
-    fromTxOut index (Shelley.TxOut addr ada) =
+    fromTxOut index txOut =
       TxOut
         { txOutIndex = index
         , txOutAddress = addr
+        , txOutAddressRaw = SBS.fromShort bs
         , txOutAdaValue = ada
         , txOutMaValue = mempty -- Allegra does not support Multi-Assets
         , txOutDataHash = mempty -- Allegra does not support scripts
         }
+      where
+        Shelley.TxOutCompact (Ledger.UnsafeCompactAddr bs) _ = txOut
+        -- This pattern match also does the deserialisation of the address
+        Shelley.TxOut addr ada = txOut
+
 
     txMeta :: Shelley.Tx StandardAllegra -> Maybe (ShelleyMa.AuxiliaryData StandardAllegra)
     txMeta (Shelley.Tx _body _wit md) = strictMaybeToMaybe md
@@ -243,14 +251,19 @@ fromShelleyTx (blkIndex, tx) =
       }
   where
     fromTxOut :: Word16 -> Shelley.TxOut StandardShelley -> TxOut
-    fromTxOut index (Shelley.TxOut addr ada) =
+    fromTxOut index txOut =
       TxOut
         { txOutIndex = index
         , txOutAddress = addr
+        , txOutAddressRaw = SBS.fromShort bs
         , txOutAdaValue = ada
         , txOutMaValue = mempty -- Shelley does not support Multi-Assets
         , txOutDataHash = mempty -- Shelley does not support scripts
         }
+      where
+        Shelley.TxOutCompact (Ledger.UnsafeCompactAddr bs) _ = txOut
+        -- This pattern match also does the deserialisation of the address
+        Shelley.TxOut addr ada = txOut
 
     txOutValue :: Shelley.TxOut StandardShelley -> Integer
     txOutValue (Shelley.TxOut _ (Coin coin)) = coin
@@ -284,14 +297,19 @@ fromMaryTx (blkIndex, tx) =
       }
   where
     fromTxOut :: Word16 -> Shelley.TxOut StandardMary -> TxOut
-    fromTxOut index (Shelley.TxOut addr (Value ada maMap)) =
+    fromTxOut index txOut =
       TxOut
         { txOutIndex = index
         , txOutAddress = addr
+        , txOutAddressRaw = SBS.fromShort bs
         , txOutAdaValue = Coin ada
         , txOutMaValue = maMap
         , txOutDataHash = mempty -- Mary does not support scripts
         }
+      where
+        Shelley.TxOutCompact (Ledger.UnsafeCompactAddr bs) _ = txOut
+        -- This pattern match also does the deserialisation of the address
+        Shelley.TxOut addr (Value ada maMap) = txOut
 
     txMeta :: Shelley.Tx StandardMary -> Maybe (ShelleyMa.AuxiliaryData StandardMary)
     txMeta (Shelley.Tx _body _wit md) = strictMaybeToMaybe md
@@ -358,14 +376,22 @@ fromAlonzoTx pp (blkIndex, tx) =
       }
   where
     fromTxOut :: Word16 -> Alonzo.TxOut StandardAlonzo -> TxOut
-    fromTxOut index (Alonzo.TxOut addr (Value ada maMap) mDataHash) =
+    fromTxOut index txOut =
       TxOut
         { txOutIndex = index
         , txOutAddress = addr
+        , txOutAddressRaw = SBS.fromShort caddr
         , txOutAdaValue = Coin ada
         , txOutMaValue = maMap
         , txOutDataHash = getDataHash <$> strictMaybeToMaybe mDataHash
         }
+      where
+        caddr = case txOut of
+          Alonzo.TxOutCompact (Ledger.UnsafeCompactAddr bs) _-> bs
+          Alonzo.TxOutCompactDH (Ledger.UnsafeCompactAddr bs) _ _-> bs
+        -- This pattern match also does the deserialisation of the address
+        Alonzo.TxOut addr (Value ada maMap) mDataHash = txOut
+
 
     txBody :: Ledger.TxBody StandardAlonzo
     txBody = getField @"body" tx

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 =