Introduce Conway block and simplify getTx

Author: kderme

cabal.project

@@ -10,8 +10,8 @@ repository cardano-haskell-packages
     d4a35cd3121aa00d18544bb0ac01c3e1691d618f462c46129271bccf39f7e8ee
 
 index-state:
-  , hackage.haskell.org 2023-05-10T10:34:57Z
-  , cardano-haskell-packages 2023-06-06T08:18:38Z
+  , hackage.haskell.org 2023-07-10T14:55:34Z
+  , cardano-haskell-packages 2023-07-16T00:00:00Z
 
 packages:
   cardano-db
@@ -24,6 +24,8 @@ packages:
 
 constraints:
     persistent-postgresql >= 2.11.0.1,
+    optparse-applicative >= 0.16.0 && < 0.16.1,
+    cardano-api < 8.8.1
 
 package cardano-db
   ghc-options: -Wall -Werror -Wredundant-constraints -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -Wunused-imports -Wunused-packages

cardano-db-sync/cardano-db-sync.cabal

@@ -74,6 +74,7 @@ library
                         Cardano.DbSync.Era.Shelley.Generic.Tx.Allegra
                         Cardano.DbSync.Era.Shelley.Generic.Tx.Alonzo
                         Cardano.DbSync.Era.Shelley.Generic.Tx.Babbage
+                        Cardano.DbSync.Era.Shelley.Generic.Tx.Conway
                         Cardano.DbSync.Era.Shelley.Generic.Tx.Mary
                         Cardano.DbSync.Era.Shelley.Generic.Tx.Shelley
                         Cardano.DbSync.Era.Shelley.Generic.Tx.Types

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

@@ -2,6 +2,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE NoImplicitPrelude #-}
@@ -14,10 +15,10 @@ module Cardano.DbSync.Era.Shelley.Generic.Block (
   fromMaryBlock,
   fromAlonzoBlock,
   fromBabbageBlock,
+  fromConwayBlock,
+  getTxs,
   blockHash,
   blockPrevHash,
-  alonzoBlockTxs,
-  babbageBlockTxs,
 ) where
 
 import qualified Cardano.Api.Shelley as Api
@@ -33,8 +34,6 @@ import qualified Cardano.Ledger.Core as Ledger
 import Cardano.Ledger.Crypto (Crypto, StandardCrypto)
 import Cardano.Ledger.Era (EraSegWits (..))
 import Cardano.Ledger.Keys (KeyHash, KeyRole (..), VerKeyVRF, hashKey)
-import qualified Cardano.Ledger.Shelley.BlockChain as Shelley
-import qualified Cardano.Ledger.Shelley.Tx as Shelley
 import Cardano.Prelude
 import qualified Cardano.Protocol.TPraos.BHeader as TPraos
 import qualified Cardano.Protocol.TPraos.OCert as TPraos
@@ -43,11 +42,12 @@ import Ouroboros.Consensus.Cardano.Block (
   StandardAllegra,
   StandardAlonzo,
   StandardBabbage,
+  StandardConway,
   StandardMary,
   StandardShelley,
  )
 import qualified Ouroboros.Consensus.Protocol.Praos.Header as Praos
-import Ouroboros.Consensus.Shelley.Ledger.Block (ShelleyBasedEra, ShelleyBlock)
+import Ouroboros.Consensus.Shelley.Ledger.Block (ShelleyBlock)
 import qualified Ouroboros.Consensus.Shelley.Ledger.Block as Consensus
 import Ouroboros.Consensus.Shelley.Protocol.Abstract
 import Ouroboros.Network.Block (BlockNo (..))
@@ -81,7 +81,7 @@ fromAllegraBlock blk =
     , blkVrfKey = blockVrfKeyView $ blockVrfVkTPraos blk
     , blkOpCert = blockOpCertKeyTPraos blk
     , blkOpCertCounter = blockOpCertCounterTPraos blk
-    , blkTxs = map fromAllegraTx (blockTxs blk)
+    , blkTxs = map fromAllegraTx (getTxs blk)
     }
 
 fromShelleyBlock :: ShelleyBlock TPraosStandard StandardShelley -> Block
@@ -98,7 +98,7 @@ fromShelleyBlock blk =
     , blkVrfKey = blockVrfKeyView $ blockVrfVkTPraos blk
     , blkOpCert = blockOpCertKeyTPraos blk
     , blkOpCertCounter = blockOpCertCounterTPraos blk
-    , blkTxs = map fromShelleyTx (blockTxs blk)
+    , blkTxs = map fromShelleyTx (getTxs blk)
     }
 
 fromMaryBlock :: ShelleyBlock TPraosStandard StandardMary -> Block
@@ -115,7 +115,7 @@ fromMaryBlock blk =
     , blkVrfKey = blockVrfKeyView $ blockVrfVkTPraos blk
     , blkOpCert = blockOpCertKeyTPraos blk
     , blkOpCertCounter = blockOpCertCounterTPraos blk
-    , blkTxs = map fromMaryTx (blockTxs blk)
+    , blkTxs = map fromMaryTx (getTxs blk)
     }
 
 fromAlonzoBlock :: Bool -> Maybe Prices -> ShelleyBlock TPraosStandard StandardAlonzo -> Block
@@ -132,7 +132,7 @@ fromAlonzoBlock iope mprices blk =
     , blkVrfKey = blockVrfKeyView $ blockVrfVkTPraos blk
     , blkOpCert = blockOpCertKeyTPraos blk
     , blkOpCertCounter = blockOpCertCounterTPraos blk
-    , blkTxs = map (fromAlonzoTx iope mprices) (alonzoBlockTxs blk)
+    , blkTxs = map (fromAlonzoTx iope mprices) (getTxs blk)
     }
 
 fromBabbageBlock :: Bool -> Maybe Prices -> ShelleyBlock PraosStandard StandardBabbage -> Block
@@ -149,16 +149,30 @@ fromBabbageBlock iope mprices blk =
     , blkVrfKey = blockVrfKeyView $ blockVrfVkPraos blk
     , blkOpCert = blockOpCertKeyPraos blk
     , blkOpCertCounter = blockOpCertCounterPraos blk
-    , blkTxs = map (fromBabbageTx iope mprices) (babbageBlockTxs blk)
+    , blkTxs = map (fromBabbageTx iope mprices) (getTxs blk)
     }
 
--- -------------------------------------------------------------------------------------------------
+fromConwayBlock :: Bool -> Maybe Prices -> ShelleyBlock PraosStandard StandardConway -> Block
+fromConwayBlock iope mprices blk =
+  Block
+    { blkEra = Babbage
+    , blkHash = blockHash blk
+    , blkPreviousHash = blockPrevHash blk
+    , blkSlotLeader = blockIssuer blk
+    , blkSlotNo = slotNumber blk
+    , blkBlockNo = blockNumber blk
+    , blkSize = blockSize blk
+    , blkProto = blockProtoVersionPraos blk
+    , blkVrfKey = blockVrfKeyView $ blockVrfVkPraos blk
+    , blkOpCert = blockOpCertKeyPraos blk
+    , blkOpCertCounter = blockOpCertCounterPraos blk
+    , blkTxs = map (fromConwayTx iope mprices) (getTxs blk)
+    }
 
-babbageBlockTxs :: ShelleyBlock p StandardBabbage -> [(Word64, Ledger.Tx StandardBabbage)]
-babbageBlockTxs = zip [0 ..] . toList . fromTxSeq @StandardBabbage . Ledger.bbody . Consensus.shelleyBlockRaw
+-- -------------------------------------------------------------------------------------------------
 
-alonzoBlockTxs :: ShelleyBlock p StandardAlonzo -> [(Word64, Ledger.Tx StandardAlonzo)]
-alonzoBlockTxs = zip [0 ..] . toList . fromTxSeq @StandardAlonzo . Ledger.bbody . Consensus.shelleyBlockRaw
+getTxs :: forall p era. EraSegWits era => ShelleyBlock p era -> [(Word64, Ledger.Tx era)]
+getTxs = zip [0 ..] . toList . fromTxSeq @era . Ledger.bbody . Consensus.shelleyBlockRaw
 
 blockHeader :: ShelleyBlock p era -> ShelleyProtocolHeader p
 blockHeader = Ledger.bheader . Consensus.shelleyBlockRaw
@@ -205,15 +219,6 @@ blockProtoVersionPraos = Praos.hbProtVer . getHeaderBodyPraos . blockHeader
 blockSize :: ProtocolHeaderSupportsEnvelope p => ShelleyBlock p era -> Word64
 blockSize = fromIntegral . pHeaderSize . blockHeader
 
-blockTxs ::
-  ( ShelleyBasedEra era
-  , Ledger.TxSeq era ~ Shelley.ShelleyTxSeq era
-  , Ledger.Tx era ~ Shelley.ShelleyTx era
-  ) =>
-  ShelleyBlock p era ->
-  [(Word64, Shelley.ShelleyTx era)]
-blockTxs = zip [0 ..] . unTxSeq . Ledger.bbody . Consensus.shelleyBlockRaw
-
 blockVrfKeyView :: VerKeyVRF StandardCrypto -> Text
 blockVrfKeyView = Api.serialiseToBech32 . Api.VrfVerificationKey
 
@@ -234,12 +239,3 @@ blockIssuer = hashKey . pHeaderIssuer . blockHeader
 
 slotNumber :: ShelleyProtocol p => ShelleyBlock p era -> SlotNo
 slotNumber = pHeaderSlot . blockHeader
-
-unTxSeq ::
-  ( ShelleyBasedEra era
-  , Ledger.TxSeq era ~ Shelley.ShelleyTxSeq era
-  , Ledger.Tx era ~ Shelley.ShelleyTx era
-  ) =>
-  Shelley.ShelleyTxSeq era ->
-  [Shelley.ShelleyTx era]
-unTxSeq = toList . Ledger.fromTxSeq

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

@@ -4,12 +4,14 @@ module Cardano.DbSync.Era.Shelley.Generic.Tx (
   fromMaryTx,
   fromAlonzoTx,
   fromBabbageTx,
+  fromConwayTx,
   module X,
 ) where
 
 import Cardano.DbSync.Era.Shelley.Generic.Tx.Allegra
 import Cardano.DbSync.Era.Shelley.Generic.Tx.Alonzo
 import Cardano.DbSync.Era.Shelley.Generic.Tx.Babbage
+import Cardano.DbSync.Era.Shelley.Generic.Tx.Conway
 import Cardano.DbSync.Era.Shelley.Generic.Tx.Mary
 import Cardano.DbSync.Era.Shelley.Generic.Tx.Shelley
 import Cardano.DbSync.Era.Shelley.Generic.Tx.Types as X

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

@@ -0,0 +1,21 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+
+module Cardano.DbSync.Era.Shelley.Generic.Tx.Conway (
+  fromConwayTx,
+) where
+
+import Prelude
+import qualified Cardano.Ledger.Core as Core
+import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo
+import Ouroboros.Consensus.Cardano.Block (StandardConway)
+import Data.Word (Word64)
+import Cardano.DbSync.Era.Shelley.Generic.Tx.Types
+
+fromConwayTx :: Bool -> Maybe Alonzo.Prices -> (Word64, Core.Tx StandardConway) -> Tx
+fromConwayTx = undefined

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

@@ -252,8 +252,8 @@ fixPlutusData tracer cblk fds = do
 scrapDatumsBlock :: CardanoBlock -> Map ByteString ByteString
 scrapDatumsBlock cblk = case cblk of
   BlockConway _blk -> panic "TODO: Conway 4"
-  BlockBabbage blk -> Map.unions $ scrapDatumsTxBabbage . snd <$> babbageBlockTxs blk
-  BlockAlonzo blk -> Map.unions $ scrapDatumsTxAlonzo . snd <$> alonzoBlockTxs blk
+  BlockBabbage blk -> Map.unions $ scrapDatumsTxBabbage . snd <$> getTxs blk
+  BlockAlonzo blk -> Map.unions $ scrapDatumsTxAlonzo . snd <$> getTxs blk
   BlockByron _ -> error "No Datums in Byron"
   BlockShelley _ -> error "No Datums in Shelley"
   BlockAllegra _ -> error "No Datums in Allegra"
@@ -288,8 +288,8 @@ scrapDatumsTxAlonzo tx =
 scrapRedeemerDataBlock :: CardanoBlock -> Map ByteString ByteString
 scrapRedeemerDataBlock cblk = case cblk of
   BlockConway _blk -> panic "TODO: Conway 5"
-  BlockBabbage blk -> Map.unions $ scrapRedeemerDataTx . snd <$> babbageBlockTxs blk
-  BlockAlonzo blk -> Map.unions $ scrapRedeemerDataTx . snd <$> alonzoBlockTxs blk
+  BlockBabbage blk -> Map.unions $ scrapRedeemerDataTx . snd <$> getTxs blk
+  BlockAlonzo blk -> Map.unions $ scrapRedeemerDataTx . snd <$> getTxs blk
   BlockByron _ -> error "No RedeemerData in Byron"
   BlockShelley _ -> error "No RedeemerData in Shelley"
   BlockAllegra _ -> error "No RedeemerData in Allegra"

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

@@ -141,8 +141,8 @@ fixPlutusScripts tracer cblk fpss = do
 
 scrapScriptBlock :: CardanoBlock -> Map ByteString ByteString
 scrapScriptBlock cblk = case cblk of
-  BlockBabbage blk -> Map.unions $ scrapScriptTxBabbage . snd <$> babbageBlockTxs blk
-  BlockAlonzo blk -> Map.unions $ scrapScriptTxAlonzo . snd <$> alonzoBlockTxs blk
+  BlockBabbage blk -> Map.unions $ scrapScriptTxBabbage . snd <$> getTxs blk
+  BlockAlonzo blk -> Map.unions $ scrapScriptTxAlonzo . snd <$> getTxs blk
   BlockByron _ -> error "No Plutus Scripts in Byron"
   BlockShelley _ -> error "No Plutus Scripts in Shelley"
   BlockAllegra _ -> error "No Plutus Scripts in Allegra"