From 6d8a93ea9ed4033408de2a4d96d792a80bc932b5 Mon Sep 17 00:00:00 2001 From: Shea Levy Date: Thu, 28 Mar 2024 11:10:43 -0400 Subject: [PATCH 01/11] mkSomeConsensusProtocolCardano: Factor out non-existential core. --- .../Cardano/Node/Protocol/Cardano.hs | 317 +++++++++--------- 1 file changed, 165 insertions(+), 152 deletions(-) diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Cardano.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Cardano.hs index f63ada1f0c..20d905ed39 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Cardano.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Cardano.hs @@ -33,8 +33,10 @@ import Ouroboros.Consensus.Cardano import qualified Ouroboros.Consensus.Cardano as Consensus import qualified Ouroboros.Consensus.Cardano.CanHardFork as Consensus import Ouroboros.Consensus.Cardano.Condense () +import Ouroboros.Consensus.Cardano.Node (CardanoProtocolParams) import Ouroboros.Consensus.Config (emptyCheckpointsMap) import Ouroboros.Consensus.HardFork.Combinator.Condense () +import Ouroboros.Consensus.Shelley.Crypto (StandardCrypto) import qualified Ouroboros.Consensus.Mempool as Mempool @@ -62,7 +64,20 @@ mkSomeConsensusProtocolCardano :: -> NodeHardForkProtocolConfiguration -> Maybe ProtocolFilepaths -> ExceptT CardanoProtocolInstantiationError IO SomeConsensusProtocol -mkSomeConsensusProtocolCardano NodeByronProtocolConfiguration { +mkSomeConsensusProtocolCardano nbpc nspc napc ncpc nhpc files = do + params <- mkConsensusProtocolCardano nbpc nspc napc ncpc nhpc files + return $! + SomeConsensusProtocol CardanoBlockType $ ProtocolInfoArgsCardano params + +mkConsensusProtocolCardano :: + NodeByronProtocolConfiguration + -> NodeShelleyProtocolConfiguration + -> NodeAlonzoProtocolConfiguration + -> NodeConwayProtocolConfiguration + -> NodeHardForkProtocolConfiguration + -> Maybe ProtocolFilepaths + -> ExceptT CardanoProtocolInstantiationError IO (CardanoProtocolParams StandardCrypto) +mkConsensusProtocolCardano NodeByronProtocolConfiguration { npcByronGenesisFile, npcByronGenesisFileHash, npcByronReqNetworkMagic, @@ -141,164 +156,162 @@ mkSomeConsensusProtocolCardano NodeByronProtocolConfiguration { --TODO: all these protocol versions below are confusing and unnecessary. -- It could and should all be automated and these config entries eliminated. return $! - SomeConsensusProtocol CardanoBlockType $ ProtocolInfoArgsCardano - (CardanoProtocolParams - Consensus.ProtocolParamsByron { - byronGenesis = byronGenesis, - byronPbftSignatureThreshold = - PBftSignatureThreshold <$> npcByronPbftSignatureThresh, + CardanoProtocolParams + Consensus.ProtocolParamsByron { + byronGenesis = byronGenesis, + byronPbftSignatureThreshold = + PBftSignatureThreshold <$> npcByronPbftSignatureThresh, - -- This is /not/ the Byron protocol version. It is the protocol - -- version that this node will use in blocks it creates. It is used - -- in the Byron update mechanism to signal that this block-producing - -- node is ready to move to the new protocol. For example, when the - -- protocol version (according to the ledger state) is 0, this setting - -- should be 1 when we are ready to move. Similarly when the current - -- protocol version is 1, this should be 2 to indicate we are ready - -- to move into the Shelley era. - byronProtocolVersion = - Byron.ProtocolVersion - npcByronSupportedProtocolVersionMajor - npcByronSupportedProtocolVersionMinor - npcByronSupportedProtocolVersionAlt, - byronSoftwareVersion = - Byron.SoftwareVersion - npcByronApplicationName - npcByronApplicationVersion, - byronLeaderCredentials = - byronLeaderCredentials, - byronMaxTxCapacityOverrides = - Mempool.mkOverrides Mempool.noOverridesMeasure - } - Consensus.ProtocolParamsShelleyBased { - shelleyBasedInitialNonce = Shelley.genesisHashToPraosNonce - shelleyGenesisHash, - shelleyBasedLeaderCredentials = shelleyLeaderCredentials - } - Consensus.ProtocolParamsShelley { - -- This is /not/ the Shelley protocol version. It is the protocol - -- version that this node will declare that it understands, when it - -- is in the Shelley era. That is, it is the version of protocol - -- /after/ Shelley, i.e. Allegra. - shelleyProtVer = - ProtVer (natVersion @3) 0, - shelleyMaxTxCapacityOverrides = - Mempool.mkOverrides Mempool.noOverridesMeasure - } - Consensus.ProtocolParamsAllegra { - -- This is /not/ the Allegra protocol version. It is the protocol - -- version that this node will declare that it understands, when it - -- is in the Allegra era. That is, it is the version of protocol - -- /after/ Allegra, i.e. Mary. - allegraProtVer = - ProtVer (natVersion @4) 0, - allegraMaxTxCapacityOverrides = - Mempool.mkOverrides Mempool.noOverridesMeasure - } - Consensus.ProtocolParamsMary { - -- This is /not/ the Mary protocol version. It is the protocol - -- version that this node will declare that it understands, when it - -- is in the Mary era. That is, it is the version of protocol - -- /after/ Mary, i.e. Alonzo. - maryProtVer = ProtVer (natVersion @5) 0, - maryMaxTxCapacityOverrides = - Mempool.mkOverrides Mempool.noOverridesMeasure - } - Consensus.ProtocolParamsAlonzo { - -- This is /not/ the Alonzo protocol version. It is the protocol - -- version that this node will declare that it understands, when it - -- is in the Alonzo era. That is, it is the version of protocol - -- /after/ Alonzo, i.e. Babbage. - alonzoProtVer = ProtVer (natVersion @6) 0, - alonzoMaxTxCapacityOverrides = - Mempool.mkOverrides Mempool.noOverridesMeasure - } - Consensus.ProtocolParamsBabbage { - -- This is /not/ the Babbage protocol version. It is the protocol - -- version that this node will declare that it understands, when it - -- is in the Babbage era. - Consensus.babbageProtVer = ProtVer (natVersion @7) 0, - Consensus.babbageMaxTxCapacityOverrides = - Mempool.mkOverrides Mempool.noOverridesMeasure - } - Consensus.ProtocolParamsConway { - -- This is /not/ the Conway protocol version. It is the protocol - -- version that this node will declare that it understands, when it - -- is in the Conway era. - Consensus.conwayProtVer = - if npcTestEnableDevelopmentHardForkEras - then ProtVer (natVersion @9) 0 -- Advertise we can support Conway - else ProtVer (natVersion @8) 0, -- Otherwise we only advertise we know about Babbage - Consensus.conwayMaxTxCapacityOverrides = - Mempool.mkOverrides Mempool.noOverridesMeasure - } - -- The 'CardanoHardForkTriggers' specify the parameters needed to - -- transition between two eras. The comments below also apply for all - -- subsequent hard forks. - -- - -- Byron to Shelley hard fork parameters - Consensus.CardanoHardForkTriggers' { - triggerHardForkShelley = - -- What will trigger the Byron -> Shelley hard fork? - case npcTestShelleyHardForkAtEpoch of + -- This is /not/ the Byron protocol version. It is the protocol + -- version that this node will use in blocks it creates. It is used + -- in the Byron update mechanism to signal that this block-producing + -- node is ready to move to the new protocol. For example, when the + -- protocol version (according to the ledger state) is 0, this setting + -- should be 1 when we are ready to move. Similarly when the current + -- protocol version is 1, this should be 2 to indicate we are ready + -- to move into the Shelley era. + byronProtocolVersion = + Byron.ProtocolVersion + npcByronSupportedProtocolVersionMajor + npcByronSupportedProtocolVersionMinor + npcByronSupportedProtocolVersionAlt, + byronSoftwareVersion = + Byron.SoftwareVersion + npcByronApplicationName + npcByronApplicationVersion, + byronLeaderCredentials = + byronLeaderCredentials, + byronMaxTxCapacityOverrides = + Mempool.mkOverrides Mempool.noOverridesMeasure + } + Consensus.ProtocolParamsShelleyBased { + shelleyBasedInitialNonce = Shelley.genesisHashToPraosNonce + shelleyGenesisHash, + shelleyBasedLeaderCredentials = shelleyLeaderCredentials + } + Consensus.ProtocolParamsShelley { + -- This is /not/ the Shelley protocol version. It is the protocol + -- version that this node will declare that it understands, when it + -- is in the Shelley era. That is, it is the version of protocol + -- /after/ Shelley, i.e. Allegra. + shelleyProtVer = + ProtVer (natVersion @3) 0, + shelleyMaxTxCapacityOverrides = + Mempool.mkOverrides Mempool.noOverridesMeasure + } + Consensus.ProtocolParamsAllegra { + -- This is /not/ the Allegra protocol version. It is the protocol + -- version that this node will declare that it understands, when it + -- is in the Allegra era. That is, it is the version of protocol + -- /after/ Allegra, i.e. Mary. + allegraProtVer = + ProtVer (natVersion @4) 0, + allegraMaxTxCapacityOverrides = + Mempool.mkOverrides Mempool.noOverridesMeasure + } + Consensus.ProtocolParamsMary { + -- This is /not/ the Mary protocol version. It is the protocol + -- version that this node will declare that it understands, when it + -- is in the Mary era. That is, it is the version of protocol + -- /after/ Mary, i.e. Alonzo. + maryProtVer = ProtVer (natVersion @5) 0, + maryMaxTxCapacityOverrides = + Mempool.mkOverrides Mempool.noOverridesMeasure + } + Consensus.ProtocolParamsAlonzo { + -- This is /not/ the Alonzo protocol version. It is the protocol + -- version that this node will declare that it understands, when it + -- is in the Alonzo era. That is, it is the version of protocol + -- /after/ Alonzo, i.e. Babbage. + alonzoProtVer = ProtVer (natVersion @6) 0, + alonzoMaxTxCapacityOverrides = + Mempool.mkOverrides Mempool.noOverridesMeasure + } + Consensus.ProtocolParamsBabbage { + -- This is /not/ the Babbage protocol version. It is the protocol + -- version that this node will declare that it understands, when it + -- is in the Babbage era. + Consensus.babbageProtVer = ProtVer (natVersion @7) 0, + Consensus.babbageMaxTxCapacityOverrides = + Mempool.mkOverrides Mempool.noOverridesMeasure + } + Consensus.ProtocolParamsConway { + -- This is /not/ the Conway protocol version. It is the protocol + -- version that this node will declare that it understands, when it + -- is in the Conway era. + Consensus.conwayProtVer = + if npcTestEnableDevelopmentHardForkEras + then ProtVer (natVersion @9) 0 -- Advertise we can support Conway + else ProtVer (natVersion @8) 0, -- Otherwise we only advertise we know about Babbage + Consensus.conwayMaxTxCapacityOverrides = + Mempool.mkOverrides Mempool.noOverridesMeasure + } + -- The 'CardanoHardForkTriggers' specify the parameters needed to + -- transition between two eras. The comments below also apply for all + -- subsequent hard forks. + -- + -- Byron to Shelley hard fork parameters + Consensus.CardanoHardForkTriggers' { + triggerHardForkShelley = + -- What will trigger the Byron -> Shelley hard fork? + case npcTestShelleyHardForkAtEpoch of - -- This specifies the major protocol version number update that will - -- trigger us moving to the Shelley protocol. - -- - -- Version 0 is Byron with Ouroboros classic - -- Version 1 is Byron with Ouroboros Permissive BFT - -- Version 2 is Shelley - -- Version 3 is Allegra - -- Version 4 is Mary - -- Version 5 is Alonzo - -- Version 6 is Alonzo (intra era hardfork) - -- Version 7 is Babbage - -- Version 8 is Babbage (intra era hardfork) - -- Version 9 is Conway - -- - -- But we also provide an override to allow for simpler test setups - -- such as triggering at the 0 -> 1 transition . - -- - Nothing -> Consensus.TriggerHardForkAtVersion - (maybe 2 fromIntegral npcTestShelleyHardForkAtVersion) + -- This specifies the major protocol version number update that will + -- trigger us moving to the Shelley protocol. + -- + -- Version 0 is Byron with Ouroboros classic + -- Version 1 is Byron with Ouroboros Permissive BFT + -- Version 2 is Shelley + -- Version 3 is Allegra + -- Version 4 is Mary + -- Version 5 is Alonzo + -- Version 6 is Alonzo (intra era hardfork) + -- Version 7 is Babbage + -- Version 8 is Babbage (intra era hardfork) + -- Version 9 is Conway + -- + -- But we also provide an override to allow for simpler test setups + -- such as triggering at the 0 -> 1 transition . + -- + Nothing -> Consensus.TriggerHardForkAtVersion + (maybe 2 fromIntegral npcTestShelleyHardForkAtVersion) - -- Alternatively, for testing we can transition at a specific epoch. - -- - Just epochNo -> Consensus.TriggerHardForkAtEpoch epochNo - -- Shelley to Allegra hard fork parameters - , triggerHardForkAllegra = - case npcTestAllegraHardForkAtEpoch of - Nothing -> Consensus.TriggerHardForkAtVersion - (maybe 3 fromIntegral npcTestAllegraHardForkAtVersion) - Just epochNo -> Consensus.TriggerHardForkAtEpoch epochNo - -- Allegra to Mary hard fork parameters - , triggerHardForkMary = - case npcTestMaryHardForkAtEpoch of + -- Alternatively, for testing we can transition at a specific epoch. + -- + Just epochNo -> Consensus.TriggerHardForkAtEpoch epochNo + -- Shelley to Allegra hard fork parameters + , triggerHardForkAllegra = + case npcTestAllegraHardForkAtEpoch of + Nothing -> Consensus.TriggerHardForkAtVersion + (maybe 3 fromIntegral npcTestAllegraHardForkAtVersion) + Just epochNo -> Consensus.TriggerHardForkAtEpoch epochNo + -- Allegra to Mary hard fork parameters + , triggerHardForkMary = + case npcTestMaryHardForkAtEpoch of + Nothing -> Consensus.TriggerHardForkAtVersion + (maybe 4 fromIntegral npcTestMaryHardForkAtVersion) + Just epochNo -> Consensus.TriggerHardForkAtEpoch epochNo + -- Mary to Alonzo hard fork parameters + , triggerHardForkAlonzo = + case npcTestAlonzoHardForkAtEpoch of + Nothing -> Consensus.TriggerHardForkAtVersion + (maybe 5 fromIntegral npcTestAlonzoHardForkAtVersion) + Just epochNo -> Consensus.TriggerHardForkAtEpoch epochNo + -- Alonzo to Babbage hard fork parameters + , triggerHardForkBabbage = + case npcTestBabbageHardForkAtEpoch of Nothing -> Consensus.TriggerHardForkAtVersion - (maybe 4 fromIntegral npcTestMaryHardForkAtVersion) + (maybe 7 fromIntegral npcTestBabbageHardForkAtVersion) Just epochNo -> Consensus.TriggerHardForkAtEpoch epochNo - -- Mary to Alonzo hard fork parameters - , triggerHardForkAlonzo = - case npcTestAlonzoHardForkAtEpoch of + -- Babbage to Conway hard fork parameters + , triggerHardForkConway = + case npcTestConwayHardForkAtEpoch of Nothing -> Consensus.TriggerHardForkAtVersion - (maybe 5 fromIntegral npcTestAlonzoHardForkAtVersion) + (maybe 9 fromIntegral npcTestConwayHardForkAtVersion) Just epochNo -> Consensus.TriggerHardForkAtEpoch epochNo - -- Alonzo to Babbage hard fork parameters - , triggerHardForkBabbage = - case npcTestBabbageHardForkAtEpoch of - Nothing -> Consensus.TriggerHardForkAtVersion - (maybe 7 fromIntegral npcTestBabbageHardForkAtVersion) - Just epochNo -> Consensus.TriggerHardForkAtEpoch epochNo - -- Babbage to Conway hard fork parameters - , triggerHardForkConway = - case npcTestConwayHardForkAtEpoch of - Nothing -> Consensus.TriggerHardForkAtVersion - (maybe 9 fromIntegral npcTestConwayHardForkAtVersion) - Just epochNo -> Consensus.TriggerHardForkAtEpoch epochNo - } - transitionLedgerConfig - emptyCheckpointsMap - ) + } + transitionLedgerConfig + emptyCheckpointsMap ------------------------------------------------------------------------------ -- Errors From 54eaf6e16a6aa5d6347e1992afa656cb70b0a408 Mon Sep 17 00:00:00 2001 From: Shea Levy Date: Thu, 28 Mar 2024 11:15:33 -0400 Subject: [PATCH 02/11] DBSynthesizer: initialize: existentialize the protocol at the edges. --- .../Cardano/Node/Protocol/Cardano.hs | 1 + .../Cardano/Tools/DBSynthesizer/Run.hs | 19 ++++++++++++------- 2 files changed, 13 insertions(+), 7 deletions(-) diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Cardano.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Cardano.hs index 20d905ed39..1236aced28 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Cardano.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Cardano.hs @@ -12,6 +12,7 @@ module Cardano.Node.Protocol.Cardano ( mkSomeConsensusProtocolCardano + , mkConsensusProtocolCardano -- * Errors , CardanoProtocolInstantiationError (..) ) where diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs index f13d870162..f10682062f 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs @@ -7,8 +7,9 @@ module Cardano.Tools.DBSynthesizer.Run ( ) where import Cardano.Api.Any (displayError) -import Cardano.Api.Protocol.Types (protocolInfo) +import Cardano.Api.Protocol.Types (protocolInfo, ProtocolInfoArgs(ProtocolInfoArgsCardano), BlockType(CardanoBlockType)) import Cardano.Node.Protocol +import Cardano.Node.Protocol.Cardano (mkConsensusProtocolCardano) import Cardano.Node.Types import Cardano.Tools.DBSynthesizer.Forging import Cardano.Tools.DBSynthesizer.Orphans () @@ -21,6 +22,7 @@ import Data.Aeson as Aeson (FromJSON, Result (..), Value, eitherDecodeFileStrict', eitherDecodeStrict', fromJSON) import Data.Bool (bool) import Data.ByteString as BS (ByteString, readFile) +import Ouroboros.Consensus.Cardano.Node import Ouroboros.Consensus.Config (configStorage) import qualified Ouroboros.Consensus.Fragment.InFuture as InFuture (dontCheck) import qualified Ouroboros.Consensus.Node as Node (mkChainDbArgs, @@ -28,6 +30,7 @@ import qualified Ouroboros.Consensus.Node as Node (mkChainDbArgs, import qualified Ouroboros.Consensus.Node.InitStorage as Node (nodeImmutableDbChunkInfo) import Ouroboros.Consensus.Node.ProtocolInfo (ProtocolInfo (..)) +import Ouroboros.Consensus.Shelley.Crypto import Ouroboros.Consensus.Shelley.Node (ShelleyGenesis (..), validateGenesis) import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB @@ -52,7 +55,7 @@ initialize NodeFilePaths{nfpConfig, nfpChainDB} creds synthOptions = do runExceptT $ do conf <- initConf relativeToConfig proto <- initProtocol relativeToConfig conf - pure (conf, proto) + pure (conf, SomeConsensusProtocol CardanoBlockType $ ProtocolInfoArgsCardano proto) where initConf :: (FilePath -> FilePath) -> ExceptT String IO DBSynthesizerConfig initConf relativeToConfig = do @@ -77,18 +80,20 @@ initialize NodeFilePaths{nfpConfig, nfpChainDB} creds synthOptions = do , confDbDir = nfpChainDB } - initProtocol :: (FilePath -> FilePath) -> DBSynthesizerConfig -> ExceptT String IO SomeConsensusProtocol + initProtocol :: (FilePath -> FilePath) -> DBSynthesizerConfig -> ExceptT String IO (CardanoProtocolParams StandardCrypto) initProtocol relativeToConfig DBSynthesizerConfig{confConfigStub, confProtocolCredentials} = do hfConfig :: NodeHardForkProtocolConfiguration <- hoistEither hfConfig_ byronConfig :: NodeByronProtocolConfiguration <- adjustFilePaths relativeToConfig <$> hoistEither byConfig_ - let - cardanoConfig = NodeProtocolConfigurationCardano byronConfig shelleyConfig alonzoConfig conwayConfig hfConfig firstExceptT displayError $ - mkConsensusProtocol - cardanoConfig + mkConsensusProtocolCardano + byronConfig + shelleyConfig + alonzoConfig + conwayConfig + hfConfig (Just confProtocolCredentials) where shelleyConfig = NodeShelleyProtocolConfiguration (GenesisFile $ ncsShelleyGenesisFile confConfigStub) Nothing From 791419c6ef63977c75853268f376dbcad48e9b62 Mon Sep 17 00:00:00 2001 From: Shea Levy Date: Thu, 28 Mar 2024 11:25:21 -0400 Subject: [PATCH 03/11] DBSynthesizer: Bypass the SomeConsensusProtocol abstraction. --- .../Cardano/Tools/DBSynthesizer/Run.hs | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs index f10682062f..b52eda35ff 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs @@ -7,8 +7,6 @@ module Cardano.Tools.DBSynthesizer.Run ( ) where import Cardano.Api.Any (displayError) -import Cardano.Api.Protocol.Types (protocolInfo, ProtocolInfoArgs(ProtocolInfoArgsCardano), BlockType(CardanoBlockType)) -import Cardano.Node.Protocol import Cardano.Node.Protocol.Cardano (mkConsensusProtocolCardano) import Cardano.Node.Types import Cardano.Tools.DBSynthesizer.Forging @@ -48,14 +46,14 @@ initialize :: NodeFilePaths -> NodeCredentials -> DBSynthesizerOptions - -> IO (Either String (DBSynthesizerConfig, SomeConsensusProtocol)) + -> IO (Either String (DBSynthesizerConfig, CardanoProtocolParams StandardCrypto)) initialize NodeFilePaths{nfpConfig, nfpChainDB} creds synthOptions = do relativeToConfig :: (FilePath -> FilePath) <- () . takeDirectory <$> makeAbsolute nfpConfig runExceptT $ do conf <- initConf relativeToConfig proto <- initProtocol relativeToConfig conf - pure (conf, SomeConsensusProtocol CardanoBlockType $ ProtocolInfoArgsCardano proto) + pure (conf, proto) where initConf :: (FilePath -> FilePath) -> ExceptT String IO DBSynthesizerConfig initConf relativeToConfig = do @@ -113,8 +111,8 @@ eitherParseJson v = case fromJSON v of Error err -> Left err Success a -> Right a -synthesize :: DBSynthesizerConfig -> SomeConsensusProtocol -> IO ForgeResult -synthesize DBSynthesizerConfig{confOptions, confShelleyGenesis, confDbDir} (SomeConsensusProtocol _ runP) = +synthesize :: DBSynthesizerConfig -> (CardanoProtocolParams StandardCrypto) -> IO ForgeResult +synthesize DBSynthesizerConfig{confOptions, confShelleyGenesis, confDbDir} runP = withRegistry $ \registry -> do let epochSize = sgEpochLength confShelleyGenesis @@ -153,7 +151,7 @@ synthesize DBSynthesizerConfig{confOptions, confShelleyGenesis, confDbDir} (Some , pInfoInitLedger } , blockForging - ) = protocolInfo runP + ) = protocolInfoCardano runP preOpenChainDB :: DBSynthesizerOpenMode -> FilePath -> IO () preOpenChainDB mode db = From fe837c026120e576bfdd5cdd3d6e503982a018d6 Mon Sep 17 00:00:00 2001 From: Shea Levy Date: Thu, 28 Mar 2024 11:41:08 -0400 Subject: [PATCH 04/11] DBSynthesizer: pass a tx-generating function to runForge --- .../Cardano/Tools/DBSynthesizer/Forging.hs | 9 ++++++--- .../Cardano/Tools/DBSynthesizer/Run.hs | 2 +- 2 files changed, 7 insertions(+), 4 deletions(-) diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Forging.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Forging.hs index f6fe2e2e23..28bfb8e8c2 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Forging.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Forging.hs @@ -25,8 +25,10 @@ import Ouroboros.Consensus.Config (TopLevelConfig, configConsensus, import Ouroboros.Consensus.Forecast (forecastFor) import Ouroboros.Consensus.HeaderValidation (BasicEnvelopeValidation (..), HeaderState (..)) +import Ouroboros.Consensus.Ledger.Abstract (Validated) import Ouroboros.Consensus.Ledger.Basics import Ouroboros.Consensus.Ledger.Extended +import Ouroboros.Consensus.Ledger.SupportsMempool (GenTx) import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Protocol.Abstract (ChainDepState, tickChainDepState) @@ -63,8 +65,9 @@ runForge :: -> ChainDB IO blk -> [BlockForging IO blk] -> TopLevelConfig blk + -> (SlotNo -> IO [Validated (GenTx blk)]) -> IO ForgeResult -runForge epochSize_ nextSlot opts chainDB blockForging cfg = do +runForge epochSize_ nextSlot opts chainDB blockForging cfg genTxs = do putStrLn $ "--> epoch size: " ++ show epochSize_ putStrLn $ "--> will process until: " ++ show opts endState <- go initialForgeState {currentSlot = nextSlot} @@ -155,8 +158,8 @@ runForge epochSize_ nextSlot opts chainDB blockForging cfg = do currentSlot (ledgerState unticked) - -- Block won't contain any transactions - let txs = [] + -- Let the caller generate transactions + txs <- lift $ genTxs currentSlot -- Actually produce the block newBlock <- lift $ diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs index b52eda35ff..437aadc640 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs @@ -137,7 +137,7 @@ synthesize DBSynthesizerConfig{confOptions, confShelleyGenesis, confDbDir} runP At s -> succ s putStrLn $ "--> starting at: " ++ show slotNo - runForge epochSize slotNo synthLimit chainDB forgers pInfoConfig + runForge epochSize slotNo synthLimit chainDB forgers pInfoConfig (const $ pure []) else do putStrLn "--> no forgers found; leaving possibly existing ChainDB untouched" pure $ ForgeResult 0 From b65aa7f9558088ca9b0a55f848420cfa0c096cfb Mon Sep 17 00:00:00 2001 From: Shea Levy Date: Thu, 28 Mar 2024 11:52:09 -0400 Subject: [PATCH 05/11] DBSynthesizer: Enable caller to specify transaction generation. --- ouroboros-consensus-cardano/app/db-synthesizer.hs | 2 +- .../Cardano/Tools/DBSynthesizer/Run.hs | 9 +++++---- ouroboros-consensus-cardano/test/tools-test/Main.hs | 6 ++++-- 3 files changed, 10 insertions(+), 7 deletions(-) diff --git a/ouroboros-consensus-cardano/app/db-synthesizer.hs b/ouroboros-consensus-cardano/app/db-synthesizer.hs index 40bd7fa887..ede3d436de 100644 --- a/ouroboros-consensus-cardano/app/db-synthesizer.hs +++ b/ouroboros-consensus-cardano/app/db-synthesizer.hs @@ -34,5 +34,5 @@ main :: IO () main = withStdTerminalHandles $ do cryptoInit (paths, creds, forgeOpts) <- parseCommandLine - result <- initialize paths creds forgeOpts >>= either die (uncurry synthesize) + result <- initialize paths creds forgeOpts >>= either die (uncurry (synthesize $ const (pure []))) putStrLn $ "--> done; result: " ++ show result diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs index 437aadc640..26d088189c 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs @@ -20,15 +20,16 @@ import Data.Aeson as Aeson (FromJSON, Result (..), Value, eitherDecodeFileStrict', eitherDecodeStrict', fromJSON) import Data.Bool (bool) import Data.ByteString as BS (ByteString, readFile) +import Ouroboros.Consensus.Cardano.Block import Ouroboros.Consensus.Cardano.Node import Ouroboros.Consensus.Config (configStorage) import qualified Ouroboros.Consensus.Fragment.InFuture as InFuture (dontCheck) +import Ouroboros.Consensus.Ledger.Abstract (Validated) import qualified Ouroboros.Consensus.Node as Node (mkChainDbArgs, stdMkChainDbHasFS) import qualified Ouroboros.Consensus.Node.InitStorage as Node (nodeImmutableDbChunkInfo) import Ouroboros.Consensus.Node.ProtocolInfo (ProtocolInfo (..)) -import Ouroboros.Consensus.Shelley.Crypto import Ouroboros.Consensus.Shelley.Node (ShelleyGenesis (..), validateGenesis) import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB @@ -111,8 +112,8 @@ eitherParseJson v = case fromJSON v of Error err -> Left err Success a -> Right a -synthesize :: DBSynthesizerConfig -> (CardanoProtocolParams StandardCrypto) -> IO ForgeResult -synthesize DBSynthesizerConfig{confOptions, confShelleyGenesis, confDbDir} runP = +synthesize :: (SlotNo -> IO [Validated (GenTx (CardanoBlock StandardCrypto))]) -> DBSynthesizerConfig -> (CardanoProtocolParams StandardCrypto) -> IO ForgeResult +synthesize genTxs DBSynthesizerConfig{confOptions, confShelleyGenesis, confDbDir} runP = withRegistry $ \registry -> do let epochSize = sgEpochLength confShelleyGenesis @@ -137,7 +138,7 @@ synthesize DBSynthesizerConfig{confOptions, confShelleyGenesis, confDbDir} runP At s -> succ s putStrLn $ "--> starting at: " ++ show slotNo - runForge epochSize slotNo synthLimit chainDB forgers pInfoConfig (const $ pure []) + runForge epochSize slotNo synthLimit chainDB forgers pInfoConfig genTxs else do putStrLn "--> no forgers found; leaving possibly existing ChainDB untouched" pure $ ForgeResult 0 diff --git a/ouroboros-consensus-cardano/test/tools-test/Main.hs b/ouroboros-consensus-cardano/test/tools-test/Main.hs index 335bdc9c39..0502dce8d1 100644 --- a/ouroboros-consensus-cardano/test/tools-test/Main.hs +++ b/ouroboros-consensus-cardano/test/tools-test/Main.hs @@ -75,12 +75,12 @@ blockCountTest logStep = do testNodeFilePaths testNodeCredentials testSynthOptionsCreate - resultCreate <- DBSynthesizer.synthesize options protocol + resultCreate <- DBSynthesizer.synthesize genTxs options protocol let blockCountCreate = resultForged resultCreate blockCountCreate > 0 @? "no blocks have been forged during create step" logStep "running synthesis - append" - resultAppend <- DBSynthesizer.synthesize options {confOptions = testSynthOptionsAppend} protocol + resultAppend <- DBSynthesizer.synthesize genTxs options {confOptions = testSynthOptionsAppend} protocol let blockCountAppend = resultForged resultAppend blockCountAppend > 0 @? "no blocks have been forged during append step" @@ -91,6 +91,8 @@ blockCountTest logStep = do resultAnalysis == Just (ResultCountBlock blockCount) @? "wrong number of blocks encountered during analysis \ \ (counted: " ++ show resultAnalysis ++ "; expected: " ++ show blockCount ++ ")" + where + genTxs _ = pure [] tests :: TestTree tests = From 4fe75a7a7f06408888f9774db981299f9ea91cda Mon Sep 17 00:00:00 2001 From: Shea Levy Date: Wed, 3 Apr 2024 13:12:32 -0400 Subject: [PATCH 06/11] DBSynthesizer: Pass the ledger state to transaction generator --- .../Cardano/Tools/DBSynthesizer/Forging.hs | 4 ++-- .../unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs | 3 ++- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Forging.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Forging.hs index 28bfb8e8c2..133430716f 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Forging.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Forging.hs @@ -65,7 +65,7 @@ runForge :: -> ChainDB IO blk -> [BlockForging IO blk] -> TopLevelConfig blk - -> (SlotNo -> IO [Validated (GenTx blk)]) + -> (ExtLedgerState blk -> IO [Validated (GenTx blk)]) -> IO ForgeResult runForge epochSize_ nextSlot opts chainDB blockForging cfg genTxs = do putStrLn $ "--> epoch size: " ++ show epochSize_ @@ -159,7 +159,7 @@ runForge epochSize_ nextSlot opts chainDB blockForging cfg genTxs = do (ledgerState unticked) -- Let the caller generate transactions - txs <- lift $ genTxs currentSlot + txs <- lift $ genTxs unticked -- Actually produce the block newBlock <- lift $ diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs index 26d088189c..0da2e00177 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs @@ -25,6 +25,7 @@ import Ouroboros.Consensus.Cardano.Node import Ouroboros.Consensus.Config (configStorage) import qualified Ouroboros.Consensus.Fragment.InFuture as InFuture (dontCheck) import Ouroboros.Consensus.Ledger.Abstract (Validated) +import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState) import qualified Ouroboros.Consensus.Node as Node (mkChainDbArgs, stdMkChainDbHasFS) import qualified Ouroboros.Consensus.Node.InitStorage as Node @@ -112,7 +113,7 @@ eitherParseJson v = case fromJSON v of Error err -> Left err Success a -> Right a -synthesize :: (SlotNo -> IO [Validated (GenTx (CardanoBlock StandardCrypto))]) -> DBSynthesizerConfig -> (CardanoProtocolParams StandardCrypto) -> IO ForgeResult +synthesize :: (ExtLedgerState (CardanoBlock StandardCrypto) -> IO [Validated (GenTx (CardanoBlock StandardCrypto))]) -> DBSynthesizerConfig -> (CardanoProtocolParams StandardCrypto) -> IO ForgeResult synthesize genTxs DBSynthesizerConfig{confOptions, confShelleyGenesis, confDbDir} runP = withRegistry $ \registry -> do let From 3aed570f1108fa1c9192c79e5a5224492e102805 Mon Sep 17 00:00:00 2001 From: Shea Levy Date: Sat, 6 Apr 2024 06:43:47 -0400 Subject: [PATCH 07/11] DBSynthesizer: Define makeGenTxs for declarative UTxO generation. --- .../app/db-synthesizer.hs | 4 +- .../ouroboros-consensus-cardano.cabal | 14 +- .../Cardano/Tools/DBSynthesizer/Forging.hs | 8 +- .../Cardano/Tools/DBSynthesizer/Run.hs | 8 +- .../Cardano/Tools/DBSynthesizer/Tx.hs | 407 ++++++++++++++++++ .../test/tools-test/Main.hs | 48 ++- .../disk/config/genesis-shelley.json | 4 +- .../disk/config/genesis.alonzo.json | 177 ++++++++ .../disk/config/utxo-keys/utxo1.skey | 5 + .../disk/config/utxo-keys/utxo1.vkey | 5 + 10 files changed, 664 insertions(+), 16 deletions(-) create mode 100644 ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Tx.hs create mode 100644 ouroboros-consensus-cardano/test/tools-test/disk/config/utxo-keys/utxo1.skey create mode 100644 ouroboros-consensus-cardano/test/tools-test/disk/config/utxo-keys/utxo1.vkey diff --git a/ouroboros-consensus-cardano/app/db-synthesizer.hs b/ouroboros-consensus-cardano/app/db-synthesizer.hs index ede3d436de..c74d7bd79c 100644 --- a/ouroboros-consensus-cardano/app/db-synthesizer.hs +++ b/ouroboros-consensus-cardano/app/db-synthesizer.hs @@ -34,5 +34,7 @@ main :: IO () main = withStdTerminalHandles $ do cryptoInit (paths, creds, forgeOpts) <- parseCommandLine - result <- initialize paths creds forgeOpts >>= either die (uncurry (synthesize $ const (pure []))) + let + genTxs _ _ _ = pure [] + result <- initialize paths creds forgeOpts >>= either die (uncurry (synthesize genTxs)) putStrLn $ "--> done; result: " ++ show result diff --git a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal index 570fdd46f1..8fce900d3f 100644 --- a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal +++ b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal @@ -470,20 +470,21 @@ library unstable-cardano-tools Cardano.Tools.DBSynthesizer.Forging Cardano.Tools.DBSynthesizer.Orphans Cardano.Tools.DBSynthesizer.Run + Cardano.Tools.DBSynthesizer.Tx Cardano.Tools.DBSynthesizer.Types Cardano.Tools.DBTruncater.Run Cardano.Tools.DBTruncater.Types Cardano.Tools.GitRev Cardano.Tools.ImmDBServer.Diffusion Cardano.Tools.ImmDBServer.MiniProtocols + Cardano.Api.SerialiseTextEnvelope + Cardano.Api.KeysShelley + Cardano.Api.Key other-modules: - Cardano.Api.Key Cardano.Api.KeysByron Cardano.Api.KeysPraos - Cardano.Api.KeysShelley Cardano.Api.OperationalCertificate - Cardano.Api.SerialiseTextEnvelope Cardano.Api.SerialiseUsing Cardano.Node.Protocol.Alonzo Cardano.Node.Protocol.Byron @@ -497,6 +498,9 @@ library unstable-cardano-tools , base16-bytestring >=1.0 , bytestring >=0.10 && <0.13 , cardano-crypto + , plutus-core + , groups + , plutus-ledger-api , cardano-crypto-class , cardano-crypto-wrapper , cardano-git-rev ^>=0.2.1 @@ -518,6 +522,7 @@ library unstable-cardano-tools , compact , containers >=0.5 && <0.7 , contra-tracer + , data-default , directory , filepath , fs-api ^>=0.2 @@ -627,6 +632,9 @@ test-suite tools-test build-depends: , base , ouroboros-consensus-cardano + , cardano-ledger-core + , cardano-ledger-shelley + , containers , ouroboros-consensus:unstable-consensus-testlib , tasty , tasty-hunit diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Forging.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Forging.hs index 133430716f..f0782bf833 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Forging.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Forging.hs @@ -4,7 +4,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -module Cardano.Tools.DBSynthesizer.Forging (runForge) where +module Cardano.Tools.DBSynthesizer.Forging (runForge, GenTxs) where import Cardano.Tools.DBSynthesizer.Types (ForgeLimit (..), ForgeResult (..)) @@ -56,6 +56,8 @@ initialForgeState = ForgeState 0 0 0 0 -- DUPLICATE: runForge mirrors forging loop from ouroboros-consensus/src/Ouroboros/Consensus/NodeKernel.hs -- For an extensive commentary of the forging loop, see there. +type GenTxs blk = SlotNo -> TickedLedgerState blk -> IO [Validated (GenTx blk)] + runForge :: forall blk. ( LedgerSupportsProtocol blk ) @@ -65,7 +67,7 @@ runForge :: -> ChainDB IO blk -> [BlockForging IO blk] -> TopLevelConfig blk - -> (ExtLedgerState blk -> IO [Validated (GenTx blk)]) + -> GenTxs blk -> IO ForgeResult runForge epochSize_ nextSlot opts chainDB blockForging cfg genTxs = do putStrLn $ "--> epoch size: " ++ show epochSize_ @@ -159,7 +161,7 @@ runForge epochSize_ nextSlot opts chainDB blockForging cfg genTxs = do (ledgerState unticked) -- Let the caller generate transactions - txs <- lift $ genTxs unticked + txs <- lift $ genTxs currentSlot tickedLedgerState -- Actually produce the block newBlock <- lift $ diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs index 0da2e00177..4dd308a631 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs @@ -22,10 +22,8 @@ import Data.Bool (bool) import Data.ByteString as BS (ByteString, readFile) import Ouroboros.Consensus.Cardano.Block import Ouroboros.Consensus.Cardano.Node -import Ouroboros.Consensus.Config (configStorage) +import Ouroboros.Consensus.Config (configStorage, TopLevelConfig) import qualified Ouroboros.Consensus.Fragment.InFuture as InFuture (dontCheck) -import Ouroboros.Consensus.Ledger.Abstract (Validated) -import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState) import qualified Ouroboros.Consensus.Node as Node (mkChainDbArgs, stdMkChainDbHasFS) import qualified Ouroboros.Consensus.Node.InitStorage as Node @@ -113,7 +111,7 @@ eitherParseJson v = case fromJSON v of Error err -> Left err Success a -> Right a -synthesize :: (ExtLedgerState (CardanoBlock StandardCrypto) -> IO [Validated (GenTx (CardanoBlock StandardCrypto))]) -> DBSynthesizerConfig -> (CardanoProtocolParams StandardCrypto) -> IO ForgeResult +synthesize :: (TopLevelConfig (CardanoBlock StandardCrypto) -> GenTxs (CardanoBlock StandardCrypto)) -> DBSynthesizerConfig -> (CardanoProtocolParams StandardCrypto) -> IO ForgeResult synthesize genTxs DBSynthesizerConfig{confOptions, confShelleyGenesis, confDbDir} runP = withRegistry $ \registry -> do let @@ -139,7 +137,7 @@ synthesize genTxs DBSynthesizerConfig{confOptions, confShelleyGenesis, confDbDir At s -> succ s putStrLn $ "--> starting at: " ++ show slotNo - runForge epochSize slotNo synthLimit chainDB forgers pInfoConfig genTxs + runForge epochSize slotNo synthLimit chainDB forgers pInfoConfig $ genTxs pInfoConfig else do putStrLn "--> no forgers found; leaving possibly existing ChainDB untouched" pure $ ForgeResult 0 diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Tx.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Tx.hs new file mode 100644 index 0000000000..bf2b745b6f --- /dev/null +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Tx.hs @@ -0,0 +1,407 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ConstraintKinds #-} + +module Cardano.Tools.DBSynthesizer.Tx + ( makeGenTxs + , OwnedTxIn(..) + , UTxOSetSpec + , TxOutsSpec(..) + , TxOutSpec(..) + , DelegationSpec(..) + , NativeAssetMintsSpec(..) + , DatumSpec(..) + , TxGenCompatibleEra + , NoV2Support(..) + , AddTxException(..) + ) where + +import Cardano.Ledger.Plutus.ExUnits +import qualified Cardano.Crypto.DSIGN.Class as Crypto +import Cardano.Ledger.Api.Tx.Wits +import Cardano.Ledger.Api.Tx.Out +import Cardano.Ledger.SafeHash +import Cardano.Ledger.Keys +import Cardano.Ledger.Crypto +import Control.Monad.Trans.Except +import Data.Proxy +import Data.SOP.Classes +import Data.SOP.BasicFunctors +import Ouroboros.Consensus.Byron.Ledger.Block +import Ouroboros.Consensus.Cardano.CanHardFork +import Control.Exception +import Ouroboros.Consensus.Ledger.SupportsMempool +import Ouroboros.Consensus.Config +import Cardano.Tools.DBSynthesizer.Forging +import Ouroboros.Consensus.Ledger.Basics +import Cardano.Ledger.Alonzo.TxBody +import Cardano.Ledger.Alonzo.Tx +import Data.Group +import Universe +import Data.Default +import Cardano.Ledger.Credential +import Control.Concurrent.MVar +import Cardano.Ledger.Coin +import Cardano.Ledger.Shelley.LedgerState hiding (LedgerState) +import Ouroboros.Consensus.Shelley.Ledger +import Cardano.Ledger.Api.PParams +import Cardano.Ledger.Plutus.Language +import Cardano.Ledger.Alonzo.Scripts +import Data.Word +import Cardano.Ledger.Api.Scripts +import Ouroboros.Consensus.Cardano.Block +import Ouroboros.Consensus.HardFork.Combinator +import Data.Coerce +import Lens.Micro +import qualified Data.Map.Strict as Map +import Cardano.Ledger.TxIn +import Cardano.Ledger.UTxO hiding (balance) +import Cardano.Ledger.Core +import Ouroboros.Consensus.Protocol.Praos +import qualified Data.Set as Set +import Cardano.Ledger.Mary.Value +import Data.Sequence.Strict as Seq +import Numeric.Natural +import PlutusLedgerApi.V1 hiding (TxOut, ScriptHash, Value) +import PlutusCore.Version +import UntypedPlutusCore hiding (Constr) +import qualified Data.ByteString.Short as SBS +import qualified Data.ByteString as BS +import Cardano.Ledger.Plutus.Data as PData + +-- TODO: Distributions +-- TODO: reference scripts +data TxOutSpec = TxOutSpec + { nativeAssets :: ![NativeAssetMintsSpec] + , datum :: !(Maybe DatumSpec) + , delegation :: !DelegationSpec + } deriving stock Show + +-- Intentionally omit Pointers +data DelegationSpec = DelegateHash | NoDelegate deriving stock Show + +newtype NativeAssetMintsSpec = NativeAssetMintsSpec + { nameLengths :: Set.Set Natural + } deriving stock Show + +data DatumSpec = ByHash | Inline !Natural deriving stock Show + +data TxOutsSpec = TxOutsSpec + { duplicates :: !Natural + , txOut :: !TxOutSpec + } deriving stock Show + +type UTxOSetSpec = [TxOutsSpec] + +data NoV2Support = NoV2Support deriving stock Show + +instance Exception NoV2Support + +mkMint :: (AlonzoEraScript era) => Natural -> (ScriptHash (EraCrypto era), Script era) +mkMint n = (hashScript script, script) + where + script = fromPlutusScript pScript + pScript = case mkPlutusScript taggedSerialized of + Nothing -> throw NoV2Support + Just s -> s + taggedSerialized = Plutus @'PlutusV2 $ PlutusBinary serialized + serialized = serialiseUPLC prog + prog = Program () plcVersion100 $ LamAbs () (DeBruijn 0) + (LamAbs () (DeBruijn 0) (Constant () (someValue $ toInteger n))) + +mkAssetName :: Natural -> AssetName +mkAssetName n = coerce (SBS.replicate (fromIntegral n) 0) + +txGenLedgerState :: forall c. (CardanoHardForkConstraints c) => TickedLedgerState (CardanoBlock c) -> Maybe (TxGenLedgerState c) +txGenLedgerState = hcollapse . hcmap (Proxy @(MaybeTxGenLedgerState c)) (K . maybeTxGenLedgerState @c . unComp) . tickedHardForkLedgerStatePerEra + +utxoLookupLedgerState :: forall c. (CardanoHardForkConstraints c) => TickedLedgerState (CardanoBlock c) -> TxIn c -> Maybe (Addr c, Coin) +utxoLookupLedgerState = hcollapse . hcmap (Proxy @(UTxOLookup c)) (K . utxoLookup @c . unComp) . tickedHardForkLedgerStatePerEra + +-- | At least Babbage +type TxGenCompatibleEra era = + ( ShelleyBasedEra era + , Value era ~ MaryValue (EraCrypto era) + , AlonzoEraTxBody era + , AlonzoEraTxWits era + , BabbageEraTxOut era + ) +data TxGenLedgerState c = forall era proto . (c ~ EraCrypto era, TxGenCompatibleEra era) => TxGenLedgerState + { nes :: !(NewEpochState era) + , mkCardanoTx :: !(GenTx (ShelleyBlock proto era) -> CardanoGenTx c) + , mkMintingPurpose :: !(forall f. f Word32 (PolicyID (EraCrypto era)) -> PlutusPurpose f era) + } + +data AddTxException c = AddTxException + { tx :: !(GenTx (CardanoBlock c)) + , err :: !(ApplyTxErr (CardanoBlock c)) + } + +deriving stock instance (CardanoHardForkConstraints c) => Show (AddTxException c) + +instance (CardanoHardForkConstraints c) => Exception (AddTxException c) + +class MaybeTxGenLedgerState c blk where + maybeTxGenLedgerState :: Ticked (LedgerState blk) -> Maybe (TxGenLedgerState c) + +instance MaybeTxGenLedgerState c ByronBlock where + maybeTxGenLedgerState = const Nothing + +class ShelleyTxGenLedgerState era where + maybeShelleyTxGenLedgerState :: NewEpochState era -> Maybe (TxGenLedgerState (EraCrypto era)) + +-- Duplicate instead of an overlappable not-supported case so we get an error in new eras +instance ShelleyTxGenLedgerState (ShelleyEra c) where + maybeShelleyTxGenLedgerState = const Nothing +instance ShelleyTxGenLedgerState (AllegraEra c) where + maybeShelleyTxGenLedgerState = const Nothing +instance ShelleyTxGenLedgerState (MaryEra c) where + maybeShelleyTxGenLedgerState = const Nothing +instance ShelleyTxGenLedgerState (AlonzoEra c) where + maybeShelleyTxGenLedgerState = const Nothing +instance (PraosCrypto c) => ShelleyTxGenLedgerState (BabbageEra c) where + maybeShelleyTxGenLedgerState nes = Just $ TxGenLedgerState + { nes + , mkCardanoTx = GenTxBabbage + , mkMintingPurpose = AlonzoMinting + } +instance (PraosCrypto c) => ShelleyTxGenLedgerState (ConwayEra c) where + maybeShelleyTxGenLedgerState nes = Just $ TxGenLedgerState + { nes + , mkCardanoTx = GenTxConway + , mkMintingPurpose = ConwayMinting + } + +instance (ShelleyTxGenLedgerState era, c ~ EraCrypto era) => MaybeTxGenLedgerState c (ShelleyBlock proto era) where + maybeTxGenLedgerState st = maybeShelleyTxGenLedgerState st.tickedShelleyLedgerState + +class UTxOLookup c blk where + utxoLookup :: Ticked (LedgerState blk) -> TxIn c -> Maybe (Addr c, Coin) + +instance UTxOLookup c ByronBlock where + utxoLookup _ _ = Nothing + +instance (c ~ EraCrypto era, EraTxOut era) => UTxOLookup c (ShelleyBlock proto era) where + utxoLookup tls txIn = extract <$> Map.lookup txIn utxoMap + where + utxoMap = unUTxO . utxosUtxo . lsUTxOState . esLState . nesEs $ tls.tickedShelleyLedgerState + extract txOut = (txOut ^. addrTxOutL, txOut ^. coinTxOutL) + +data OwnedTxIn c = OwnedTxIn + { owned :: !(TxIn c) + , skey :: !(Crypto.SignKeyDSIGN (DSIGN c)) + } + +deriving stock instance (Crypto c) => Show (OwnedTxIn c) + +data ProducingState c = ProducingState + { spec :: !UTxOSetSpec + , uTxOIn :: !(TxIn c) + , addr :: !(Addr c) + , balance :: !Coin + } deriving stock Show + +data InitState c = InitState + { initSpec :: !UTxOSetSpec + , initIn :: !(TxIn c) + } deriving stock Show + +data MakeGenTxsState c + = InitUTxONotFound !(InitState c) + | Producing !(ProducingState c) deriving stock Show + +makeGenTxs :: forall c. (CardanoHardForkConstraints c) => OwnedTxIn c -> UTxOSetSpec -> IO (TopLevelConfig (CardanoBlock c) -> GenTxs (CardanoBlock c)) +makeGenTxs (OwnedTxIn { owned, skey }) initSpec = do + stVar <- newMVar . InitUTxONotFound $ InitState { initIn = owned, initSpec } + pure $ \cfg slot tls -> modifyMVar stVar $ pure . \case + InitUTxONotFound st -> tryInitialize tls cfg slot st + Producing st -> go tls cfg slot st + where + vkey = VKey @Witness @c $ Crypto.deriveVerKeyDSIGN skey + -- A dummy txbody signature to initialize the tx with the appropriate size + dummySig = signedDSIGN @c skey . extractHash . hashAnnotated $ mkBasicTxBody @(BabbageEra c) + tryInitialize tls cfg slot st = case utxoLookupLedgerState tls uTxOIn of + Nothing -> (InitUTxONotFound st, []) + Just (addr, balance) -> go tls cfg slot $ ProducingState + { spec = st.initSpec + , uTxOIn + , addr + , balance + } + where + uTxOIn = st.initIn + go tls cfg slot st = case txGenLedgerState tls of + Nothing -> (Producing st, []) + Just TxGenLedgerState {nes, mkCardanoTx, mkMintingPurpose} -> + let + params = getPParams nes + langViews = Set.singleton (getLanguageView params PlutusV2) + net = getNetwork $ st.addr + undelegAddr = Addr net def StakeRefNull + delegAddr = Addr net def (StakeRefBase def) + + -- Create as many transactions as we can fit in this block (unless we finish everything + -- our specs request) and update our state accordingly + makeTxs currSt currTls remainingBodySize = + if txFits + then (lastSt, vtx : lastTxs) + else (currSt, []) + where + -- The transaction fits if we were able to add any outputs at all, and if we have outputs we need some min-ADA for them + txFits = minAda /= mempty + + -- Make more transactions, if there's room + (lastSt, lastTxs) = makeTxs nextSt nextTls nextBodySize + + nextSt = currSt + { spec = nextSpec + , -- Use the change output as the input to the next transaction + -- Note that this will fail disastrously if we have a transaction + -- rejected (e.g. because we miscalulated block limits) or there + -- is a rollback. Oh well, we'll get an exception when validating + -- in that case. + uTxOIn = TxIn (txIdTx tx) minBound + , balance = change + } + + -- Validate the transaction we've constructed + (nextTls, vtx) = case runExcept eVtx of + Left err -> throw $ AddTxException { tx = gtx, err } -- TODO put makeTxs in IO and throwIO here? + Right x -> x + eVtx = applyTx + (configLedger cfg) + Intervene + slot + gtx + currTls + gtx = mkCardanoTx $ mkShelleyTx tx + + -- Initialize the transaction + -- We add a dummy tx witness so our size checks are accurate + initTx = mkBasicTx initTxBody + & witsTxL . addrTxWitsL .~ Set.singleton (WitVKey vkey dummySig) + initTxBody = mkBasicTxBody + & inputsTxBodyL .~ Set.singleton currSt.uTxOIn -- Take all of our ADA from the pool + & outputsTxBodyL .~ Seq.singleton initChange -- Add a change output, which we'll adjust later + & collateralInputsTxBodyL .~ Set.singleton currSt.uTxOIn -- Use the same input for collateral (which we'll never use, but may need to put up if we're minting) + -- A change output sent back to the pool owner addr + initChange = mkBasicTxOut currSt.addr $ MaryValue currSt.balance mempty + + -- Add as many outputs as will fit in this tx + -- (bounded by both the tx size limit and the amount + -- of space left in this block) + (noFeeTx, minAda, nextSpec) = addOuts initTx currSt.spec + addOuts txSoFar [] = (txSoFar, mempty, []) -- Our spec doesn't need any more outputs + addOuts txSoFar specSoFar@(TxOutsSpec { duplicates, txOut } : outss) = + if outFits + then (finalTx, finalAda <> minOut, finalSpecOuts) + else (txSoFar, mempty, specSoFar) + where + -- We can add an output if the transaction with that output fits in the max tx size and the remaining block space + outFits = params ^. ppMaxTxSizeL > (fromIntegral $ txStep ^. sizeTxF) && remainingBodySize > (txInBlockSize . mkCardanoTx $ mkShelleyTx txStep) + + -- Add more UTxOs, if we have room + (finalTx, finalAda, finalSpecOuts) = + addOuts txStep specStep + + -- What does our spec look like after adding one instance + -- of txOut? + specStep = if duplicates == 0 + then outss + else TxOutsSpec { duplicates = duplicates - 1, txOut } : outss + + -- The transaction after adding this output + txStep = txNoOut + & bodyTxL . outputsTxBodyL %~ (|> nextOut) + + -- TODO The txout is a function of pparams (for min-ADA) and txOut, + -- but we're constantly recalculating it. We should cache it. + + -- Add the min-ADA to the output + nextOut = setMinCoinTxOut params noMinOut + minOut = nextOut ^. coinTxOutL + + -- Set the output's native assets + noMinOut = noMA + & valueTxOutL .~ MaryValue mempty (MultiAsset nextMA) + + -- Set the destination address of this UTxO by our spec + nextAddr = case txOut.delegation of + DelegateHash -> delegAddr + NoDelegate -> undelegAddr + + -- Initialize the UTxO with the specified address and datum + noMA = mkBasicTxOut nextAddr mempty + & datumTxOutL .~ case txOut.datum of + Nothing -> NoDatum + Just ByHash -> PData.DatumHash def + Just (Inline sz) -> + -- Set the datum to a bytestring of zeroes of the requested length + -- TODO There is probably some overhead for serializing a bytestring, if so we need to subtract that out + PData.Datum . dataToBinaryData . PData.Data . B $ + BS.replicate (fromIntegral sz) 0 + + -- Fold over the native asset specification, accumulating the needed amounts to + -- add to this UTxO and adding needed minting configuration to the transaction + (txNoOut, nextMA, _) = foldr accMA (txSoFar, mempty, 0) txOut.nativeAssets + accMA nams (txAcc, maAcc, idx) = (txAcc', maAcc', idx + 1) + where + -- Use a redeemer of (), execution units determined empirically + -- TODO actually calculate the needed execution units + rdmr = (PData.Data $ Constr 0 [], ExUnits 800 162400) + -- Modify the transaction with needed mint scripts/redeemers and update the + -- mint field + txNoIntegrity = txAcc + & witsTxL . scriptTxWitsL %~ Map.insert mintHash mintBytes + & witsTxL . rdmrsTxWitsL %~ (\(Redeemers rdmrs) -> Redeemers $ Map.insert (mkMintingPurpose . AsIndex $ fromIntegral idx) rdmr rdmrs) + & bodyTxL . mintTxBodyL %~ \(MultiAsset m) -> MultiAsset $ Map.alter mintAlter (PolicyID mintHash) m + mintAlter Nothing = Just mintUpdates + mintAlter (Just orig) = Just $ Map.unionWith (+) mintUpdates orig + + -- Update the script integrity hash to include the current scripts + -- TODO cache/defer this somehow? + txAcc' = txNoIntegrity + & bodyTxL . scriptIntegrityHashTxBodyL .~ hashScriptIntegrity langViews (txNoIntegrity ^. witsTxL . rdmrsTxWitsL) (TxDats mempty) + + -- Add the requested native assets to this txout + maAcc' = Map.insert (PolicyID mintHash) mintUpdates maAcc + -- For each requested asset name length, create 1 new token whose name has that length + mintUpdates = Map.fromSet (const 1) $ Set.map mkAssetName nams.nameLengths + + -- Make a new always-succeeding mint script (whose hash depends on the index in the native assets specification) + (mintHash, mintBytes) = mkMint idx + + -- Finalize the transaction with the fee and setting the change output to balance + fee = getMinFeeTx params noFeeTx + change = currSt.balance ~~ (minAda <> fee) + setChange Seq.Empty = Seq.Empty + setChange (x :<| outs) = (x & coinTxOutL .~ change) :<| outs + unsignedTx = noFeeTx + & bodyTxL . feeTxBodyL .~ fee + & bodyTxL . outputsTxBodyL %~ setChange + + -- Witness the transaction + tx = unsignedTx + & witsTxL . addrTxWitsL .~ Set.singleton (WitVKey vkey sig) + sig = signedDSIGN @c skey hash + hash = extractHash . hashAnnotated $ unsignedTx ^. bodyTxL + + -- How much space is left in the block after this transaction? + nextBodySize = remainingBodySize - txInBlockSize gtx + (finalSt, txs) = makeTxs st tls (txsMaxBytes tls) + in (Producing finalSt, txs) diff --git a/ouroboros-consensus-cardano/test/tools-test/Main.hs b/ouroboros-consensus-cardano/test/tools-test/Main.hs index 0502dce8d1..2622a5a7dc 100644 --- a/ouroboros-consensus-cardano/test/tools-test/Main.hs +++ b/ouroboros-consensus-cardano/test/tools-test/Main.hs @@ -1,10 +1,23 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} module Main (main) where +import qualified Data.Set as Set +import Cardano.Ledger.Credential +import Cardano.Ledger.Keys +import Cardano.Api.Any +import Cardano.Api.Key +import Cardano.Ledger.Address +import Cardano.Ledger.BaseTypes +import Cardano.Ledger.Shelley.Genesis +import Cardano.Api.KeysShelley +import Cardano.Api.SerialiseTextEnvelope import qualified Cardano.Tools.DBAnalyser.Block.Cardano as Cardano import qualified Cardano.Tools.DBAnalyser.Run as DBAnalyser import Cardano.Tools.DBAnalyser.Types import qualified Cardano.Tools.DBSynthesizer.Run as DBSynthesizer import Cardano.Tools.DBSynthesizer.Types +import Cardano.Tools.DBSynthesizer.Tx import Ouroboros.Consensus.Cardano.Block import Test.Tasty import Test.Tasty.HUnit @@ -75,10 +88,43 @@ blockCountTest logStep = do testNodeFilePaths testNodeCredentials testSynthOptionsCreate + (skey, cred) <- readFileTextEnvelope (AsSigningKey AsGenesisUTxOKey) "test/tools-test/disk/config/utxo-keys/utxo1.skey" >>= \case + Left e -> throwErrorAsException e + Right sk@(GenesisUTxOSigningKey k) + | GenesisUTxOVerificationKey vk <- getVerificationKey sk -> pure (k, KeyHashObj (hashKey vk)) + let + addr = Addr Testnet cred StakeRefNull + utxo = OwnedTxIn + { owned = initialFundsPseudoTxIn addr + , skey + } + spec = + [ TxOutsSpec + { duplicates = 999 + , txOut = TxOutSpec + { nativeAssets = [] + , datum = Nothing + , delegation = DelegateHash + } + } + , TxOutsSpec + { duplicates = 4999 + , txOut = TxOutSpec + { nativeAssets = [ NativeAssetMintsSpec { nameLengths = Set.fromList [ 0, 3, 6 ] } + , NativeAssetMintsSpec { nameLengths = Set.singleton 5 } + ] + , datum = Just $ Inline 52 + , delegation = NoDelegate + } + } + ] + genTxs <- makeGenTxs utxo spec resultCreate <- DBSynthesizer.synthesize genTxs options protocol let blockCountCreate = resultForged resultCreate blockCountCreate > 0 @? "no blocks have been forged during create step" + -- TODO check for txn gen + logStep "running synthesis - append" resultAppend <- DBSynthesizer.synthesize genTxs options {confOptions = testSynthOptionsAppend} protocol let blockCountAppend = resultForged resultAppend @@ -91,8 +137,6 @@ blockCountTest logStep = do resultAnalysis == Just (ResultCountBlock blockCount) @? "wrong number of blocks encountered during analysis \ \ (counted: " ++ show resultAnalysis ++ "; expected: " ++ show blockCount ++ ")" - where - genTxs _ = pure [] tests :: TestTree tests = diff --git a/ouroboros-consensus-cardano/test/tools-test/disk/config/genesis-shelley.json b/ouroboros-consensus-cardano/test/tools-test/disk/config/genesis-shelley.json index 7755bcd224..82131d06f5 100644 --- a/ouroboros-consensus-cardano/test/tools-test/disk/config/genesis-shelley.json +++ b/ouroboros-consensus-cardano/test/tools-test/disk/config/genesis-shelley.json @@ -5,7 +5,7 @@ "initialFunds": { "0032635dc627da054f2a9e99559c56e16b02cf5f9237ba586ee1e648336b47a4e6e19ac5257fc97bd220bd9ae368aa2d775d86315ab7ef058f": 999500000000000, "0064f4987ff07483636803f71f5f8442dad7f7fc46d83e2242d1548ad5d1f6f71a04ca856cc569fd068b069a555999c4776ad50b4cdd049d13": 999500000000000, - "602b43cb2b891e2dc9f5b07e051fb8d221a4a88ca161d95e859aa9ad8a": 9000000000000 + "604592a46fc7dc7ccd140550081f08ade3c2552464b40d4cbeda492e3f": 9000000000000 }, "maxKESEvolutions": 60, "maxLovelaceSupply": 2010000000000000, @@ -29,7 +29,7 @@ "nOpt": 50, "poolDeposit": 500000000, "protocolVersion": { - "major": 5, + "major": 8, "minor": 0 }, "rho": 0.0022, diff --git a/ouroboros-consensus-cardano/test/tools-test/disk/config/genesis.alonzo.json b/ouroboros-consensus-cardano/test/tools-test/disk/config/genesis.alonzo.json index 093071bb39..8b6561c0cf 100644 --- a/ouroboros-consensus-cardano/test/tools-test/disk/config/genesis.alonzo.json +++ b/ouroboros-consensus-cardano/test/tools-test/disk/config/genesis.alonzo.json @@ -189,6 +189,183 @@ "verifySignature-memory-arguments": 1, "cekLamCost-exBudgetMemory": 100, "sliceByteString-cpu-arguments-intercept": 150000 + }, + "PlutusV2": { + "addInteger-cpu-arguments-intercept": 205665, + "addInteger-cpu-arguments-slope": 812, + "addInteger-memory-arguments-intercept": 1, + "addInteger-memory-arguments-slope": 1, + "appendByteString-cpu-arguments-intercept": 1000, + "appendByteString-cpu-arguments-slope": 571, + "appendByteString-memory-arguments-intercept": 0, + "appendByteString-memory-arguments-slope": 1, + "appendString-cpu-arguments-intercept": 1000, + "appendString-cpu-arguments-slope": 24177, + "appendString-memory-arguments-intercept": 4, + "appendString-memory-arguments-slope": 1, + "bData-cpu-arguments": 1000, + "bData-memory-arguments": 32, + "blake2b_256-cpu-arguments-intercept": 117366, + "blake2b_256-cpu-arguments-slope": 10475, + "blake2b_256-memory-arguments": 4, + "cekApplyCost-exBudgetCPU": 23000, + "cekApplyCost-exBudgetMemory": 100, + "cekBuiltinCost-exBudgetCPU": 23000, + "cekBuiltinCost-exBudgetMemory": 100, + "cekConstCost-exBudgetCPU": 23000, + "cekConstCost-exBudgetMemory": 100, + "cekDelayCost-exBudgetCPU": 23000, + "cekDelayCost-exBudgetMemory": 100, + "cekForceCost-exBudgetCPU": 23000, + "cekForceCost-exBudgetMemory": 100, + "cekLamCost-exBudgetCPU": 23000, + "cekLamCost-exBudgetMemory": 100, + "cekStartupCost-exBudgetCPU": 100, + "cekStartupCost-exBudgetMemory": 100, + "cekVarCost-exBudgetCPU": 23000, + "cekVarCost-exBudgetMemory": 100, + "chooseData-cpu-arguments": 19537, + "chooseData-memory-arguments": 32, + "chooseList-cpu-arguments": 175354, + "chooseList-memory-arguments": 32, + "chooseUnit-cpu-arguments": 46417, + "chooseUnit-memory-arguments": 4, + "consByteString-cpu-arguments-intercept": 221973, + "consByteString-cpu-arguments-slope": 511, + "consByteString-memory-arguments-intercept": 0, + "consByteString-memory-arguments-slope": 1, + "constrData-cpu-arguments": 89141, + "constrData-memory-arguments": 32, + "decodeUtf8-cpu-arguments-intercept": 497525, + "decodeUtf8-cpu-arguments-slope": 14068, + "decodeUtf8-memory-arguments-intercept": 4, + "decodeUtf8-memory-arguments-slope": 2, + "divideInteger-cpu-arguments-constant": 196500, + "divideInteger-cpu-arguments-model-arguments-intercept": 453240, + "divideInteger-cpu-arguments-model-arguments-slope": 220, + "divideInteger-memory-arguments-intercept": 0, + "divideInteger-memory-arguments-minimum": 1, + "divideInteger-memory-arguments-slope": 1, + "encodeUtf8-cpu-arguments-intercept": 1000, + "encodeUtf8-cpu-arguments-slope": 28662, + "encodeUtf8-memory-arguments-intercept": 4, + "encodeUtf8-memory-arguments-slope": 2, + "equalsByteString-cpu-arguments-constant": 245000, + "equalsByteString-cpu-arguments-intercept": 216773, + "equalsByteString-cpu-arguments-slope": 62, + "equalsByteString-memory-arguments": 1, + "equalsData-cpu-arguments-intercept": 1060367, + "equalsData-cpu-arguments-slope": 12586, + "equalsData-memory-arguments": 1, + "equalsInteger-cpu-arguments-intercept": 208512, + "equalsInteger-cpu-arguments-slope": 421, + "equalsInteger-memory-arguments": 1, + "equalsString-cpu-arguments-constant": 187000, + "equalsString-cpu-arguments-intercept": 1000, + "equalsString-cpu-arguments-slope": 52998, + "equalsString-memory-arguments": 1, + "fstPair-cpu-arguments": 80436, + "fstPair-memory-arguments": 32, + "headList-cpu-arguments": 43249, + "headList-memory-arguments": 32, + "iData-cpu-arguments": 1000, + "iData-memory-arguments": 32, + "ifThenElse-cpu-arguments": 80556, + "ifThenElse-memory-arguments": 1, + "indexByteString-cpu-arguments": 57667, + "indexByteString-memory-arguments": 4, + "lengthOfByteString-cpu-arguments": 1000, + "lengthOfByteString-memory-arguments": 10, + "lessThanByteString-cpu-arguments-intercept": 197145, + "lessThanByteString-cpu-arguments-slope": 156, + "lessThanByteString-memory-arguments": 1, + "lessThanEqualsByteString-cpu-arguments-intercept": 197145, + "lessThanEqualsByteString-cpu-arguments-slope": 156, + "lessThanEqualsByteString-memory-arguments": 1, + "lessThanEqualsInteger-cpu-arguments-intercept": 204924, + "lessThanEqualsInteger-cpu-arguments-slope": 473, + "lessThanEqualsInteger-memory-arguments": 1, + "lessThanInteger-cpu-arguments-intercept": 208896, + "lessThanInteger-cpu-arguments-slope": 511, + "lessThanInteger-memory-arguments": 1, + "listData-cpu-arguments": 52467, + "listData-memory-arguments": 32, + "mapData-cpu-arguments": 64832, + "mapData-memory-arguments": 32, + "mkCons-cpu-arguments": 65493, + "mkCons-memory-arguments": 32, + "mkNilData-cpu-arguments": 22558, + "mkNilData-memory-arguments": 32, + "mkNilPairData-cpu-arguments": 16563, + "mkNilPairData-memory-arguments": 32, + "mkPairData-cpu-arguments": 76511, + "mkPairData-memory-arguments": 32, + "modInteger-cpu-arguments-constant": 196500, + "modInteger-cpu-arguments-model-arguments-intercept": 453240, + "modInteger-cpu-arguments-model-arguments-slope": 220, + "modInteger-memory-arguments-intercept": 0, + "modInteger-memory-arguments-minimum": 1, + "modInteger-memory-arguments-slope": 1, + "multiplyInteger-cpu-arguments-intercept": 69522, + "multiplyInteger-cpu-arguments-slope": 11687, + "multiplyInteger-memory-arguments-intercept": 0, + "multiplyInteger-memory-arguments-slope": 1, + "nullList-cpu-arguments": 60091, + "nullList-memory-arguments": 32, + "quotientInteger-cpu-arguments-constant": 196500, + "quotientInteger-cpu-arguments-model-arguments-intercept": 453240, + "quotientInteger-cpu-arguments-model-arguments-slope": 220, + "quotientInteger-memory-arguments-intercept": 0, + "quotientInteger-memory-arguments-minimum": 1, + "quotientInteger-memory-arguments-slope": 1, + "remainderInteger-cpu-arguments-constant": 196500, + "remainderInteger-cpu-arguments-model-arguments-intercept": 453240, + "remainderInteger-cpu-arguments-model-arguments-slope": 220, + "remainderInteger-memory-arguments-intercept": 0, + "remainderInteger-memory-arguments-minimum": 1, + "remainderInteger-memory-arguments-slope": 1, + "serialiseData-cpu-arguments-intercept": 1159724, + "serialiseData-cpu-arguments-slope": 392670, + "serialiseData-memory-arguments-intercept": 0, + "serialiseData-memory-arguments-slope": 2, + "sha2_256-cpu-arguments-intercept": 806990, + "sha2_256-cpu-arguments-slope": 30482, + "sha2_256-memory-arguments": 4, + "sha3_256-cpu-arguments-intercept": 1927926, + "sha3_256-cpu-arguments-slope": 82523, + "sha3_256-memory-arguments": 4, + "sliceByteString-cpu-arguments-intercept": 265318, + "sliceByteString-cpu-arguments-slope": 0, + "sliceByteString-memory-arguments-intercept": 4, + "sliceByteString-memory-arguments-slope": 0, + "sndPair-cpu-arguments": 85931, + "sndPair-memory-arguments": 32, + "subtractInteger-cpu-arguments-intercept": 205665, + "subtractInteger-cpu-arguments-slope": 812, + "subtractInteger-memory-arguments-intercept": 1, + "subtractInteger-memory-arguments-slope": 1, + "tailList-cpu-arguments": 41182, + "tailList-memory-arguments": 32, + "trace-cpu-arguments": 212342, + "trace-memory-arguments": 32, + "unBData-cpu-arguments": 31220, + "unBData-memory-arguments": 32, + "unConstrData-cpu-arguments": 32696, + "unConstrData-memory-arguments": 32, + "unIData-cpu-arguments": 43357, + "unIData-memory-arguments": 32, + "unListData-cpu-arguments": 32247, + "unListData-memory-arguments": 32, + "unMapData-cpu-arguments": 38314, + "unMapData-memory-arguments": 32, + "verifyEcdsaSecp256k1Signature-cpu-arguments": 35892428, + "verifyEcdsaSecp256k1Signature-memory-arguments": 10, + "verifyEd25519Signature-cpu-arguments-intercept": 57996947, + "verifyEd25519Signature-cpu-arguments-slope": 18975, + "verifyEd25519Signature-memory-arguments": 10, + "verifySchnorrSecp256k1Signature-cpu-arguments-intercept": 38887044, + "verifySchnorrSecp256k1Signature-cpu-arguments-slope": 32947, + "verifySchnorrSecp256k1Signature-memory-arguments": 10 } } } diff --git a/ouroboros-consensus-cardano/test/tools-test/disk/config/utxo-keys/utxo1.skey b/ouroboros-consensus-cardano/test/tools-test/disk/config/utxo-keys/utxo1.skey new file mode 100644 index 0000000000..59e54a61fb --- /dev/null +++ b/ouroboros-consensus-cardano/test/tools-test/disk/config/utxo-keys/utxo1.skey @@ -0,0 +1,5 @@ +{ + "type": "GenesisUTxOSigningKey_ed25519", + "description": "Genesis Initial UTxO Signing Key", + "cborHex": "5820a14c708700ffd39c44c3f573db8a57d9cb66f3ea408cf38d29997307b69bf062" +} diff --git a/ouroboros-consensus-cardano/test/tools-test/disk/config/utxo-keys/utxo1.vkey b/ouroboros-consensus-cardano/test/tools-test/disk/config/utxo-keys/utxo1.vkey new file mode 100644 index 0000000000..c5fd7fa09d --- /dev/null +++ b/ouroboros-consensus-cardano/test/tools-test/disk/config/utxo-keys/utxo1.vkey @@ -0,0 +1,5 @@ +{ + "type": "GenesisUTxOVerificationKey_ed25519", + "description": "Genesis Initial UTxO Verification Key", + "cborHex": "5820b9e110a9c7e1b06438b1d92f6d84b3f5ffa97b003571178304540999adb15b10" +} From 559e51bd6afa472a782a289d5fa62341bef11cc6 Mon Sep 17 00:00:00 2001 From: Shea Levy Date: Mon, 8 Apr 2024 06:22:01 -0400 Subject: [PATCH 08/11] db-synthesizer: Create a (hard-coded) specified UTxO set --- .../app/DBSynthesizer/Parsers.hs | 51 +++++++++++++++---- .../app/db-synthesizer.hs | 25 ++++++++- .../ouroboros-consensus-cardano.cabal | 4 +- 3 files changed, 68 insertions(+), 12 deletions(-) diff --git a/ouroboros-consensus-cardano/app/DBSynthesizer/Parsers.hs b/ouroboros-consensus-cardano/app/DBSynthesizer/Parsers.hs index 761d54f5e2..78d139808d 100644 --- a/ouroboros-consensus-cardano/app/DBSynthesizer/Parsers.hs +++ b/ouroboros-consensus-cardano/app/DBSynthesizer/Parsers.hs @@ -1,25 +1,48 @@ - +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} module DBSynthesizer.Parsers (parseCommandLine) where import Cardano.Tools.DBSynthesizer.Types import Data.Word (Word64) import Options.Applicative as Opt -import Ouroboros.Consensus.Block.Abstract (SlotNo (..)) - - -parseCommandLine :: IO (NodeFilePaths, NodeCredentials, DBSynthesizerOptions) -parseCommandLine = - Opt.customExecParser p opts +import Cardano.Tools.DBSynthesizer.Tx +import Cardano.Ledger.Crypto +import Cardano.Ledger.Shelley.Genesis +import Cardano.Api.Any +import Cardano.Api.KeysShelley +import Cardano.Api.Key +import Cardano.Api.SerialiseTextEnvelope +import Cardano.Ledger.Credential +import Cardano.Ledger.Keys +import Cardano.Ledger.Address +import Cardano.Ledger.BaseTypes + +parseCommandLine :: IO (NodeFilePaths, NodeCredentials, DBSynthesizerOptions, OwnedTxIn StandardCrypto) +parseCommandLine = do + (nfp, nc, dbso, genesisKeyPath) <- Opt.customExecParser p opts + (skey, cred) <- readFileTextEnvelope (AsSigningKey AsGenesisUTxOKey) genesisKeyPath >>= \case + Left e -> throwErrorAsException e + Right sk@(GenesisUTxOSigningKey k) + | GenesisUTxOVerificationKey vk <- getVerificationKey sk -> pure (k, KeyHashObj (hashKey vk)) + pure ( nfp + , nc + , dbso + , OwnedTxIn + { owned = initialFundsPseudoTxIn $ Addr Testnet cred StakeRefNull + , skey + } + ) where p = Opt.prefs Opt.showHelpOnEmpty opts = Opt.info parserCommandLine mempty -parserCommandLine :: Parser (NodeFilePaths, NodeCredentials, DBSynthesizerOptions) +parserCommandLine :: Parser (NodeFilePaths, NodeCredentials, DBSynthesizerOptions, FilePath) parserCommandLine = - (,,) + (,,,) <$> parseNodeFilePaths <*> parseNodeCredentials <*> parseDBSynthesizerOptions + <*> parseGenesisUTxOKeyPath parseNodeFilePaths :: Parser NodeFilePaths parseNodeFilePaths = @@ -101,6 +124,16 @@ parseBulkFilePath = <> completer (bashCompleter "file") ) +-- TODO Support arbitrary UTxOs not just genesis, on the command line +parseGenesisUTxOKeyPath :: Parser FilePath +parseGenesisUTxOKeyPath = + strOption + ( long "genesis-utxo-signing-key-file" + <> metavar "FILE" + <> help "Path to the signing key file of the genesis UTxO to use to create UTxOs" + <> completer (bashCompleter "file") + ) + parseSlotLimit :: Parser SlotNo parseSlotLimit = SlotNo <$> option auto diff --git a/ouroboros-consensus-cardano/app/db-synthesizer.hs b/ouroboros-consensus-cardano/app/db-synthesizer.hs index c74d7bd79c..4712e58808 100644 --- a/ouroboros-consensus-cardano/app/db-synthesizer.hs +++ b/ouroboros-consensus-cardano/app/db-synthesizer.hs @@ -25,16 +25,37 @@ module Main (main) where import Cardano.Crypto.Init (cryptoInit) import Cardano.Tools.DBSynthesizer.Run +import Cardano.Tools.DBSynthesizer.Tx import DBSynthesizer.Parsers import Main.Utf8 (withStdTerminalHandles) +import qualified Data.Set as Set import System.Exit main :: IO () main = withStdTerminalHandles $ do cryptoInit - (paths, creds, forgeOpts) <- parseCommandLine + (paths, creds, forgeOpts, utxo) <- parseCommandLine let - genTxs _ _ _ = pure [] + -- TODO Parse this from a config file + spec = + [ TxOutsSpec + { duplicates = 14999999 + , txOut = TxOutSpec + { nativeAssets = [] + , datum = Nothing + , delegation = DelegateHash + } + } + , TxOutsSpec + { duplicates = 14999999 + , txOut = TxOutSpec + { nativeAssets = [ NativeAssetMintsSpec { nameLengths = Set.singleton 5 } ] + , datum = Just $ Inline 54 + , delegation = NoDelegate + } + } + ] + genTxs <- makeGenTxs utxo spec result <- initialize paths creds forgeOpts >>= either die (uncurry (synthesize genTxs)) putStrLn $ "--> done; result: " ++ show result diff --git a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal index 8fce900d3f..18cfa6503a 100644 --- a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal +++ b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal @@ -587,8 +587,10 @@ executable db-synthesizer build-depends: , base , cardano-crypto-class + , cardano-ledger-core + , cardano-ledger-shelley + , containers , optparse-applicative - , ouroboros-consensus , unstable-cardano-tools , with-utf8 From daa99d171611bffeabdd626c5f0d5ecb2fbb903e Mon Sep 17 00:00:00 2001 From: Shea Levy Date: Mon, 8 Apr 2024 22:17:23 -0400 Subject: [PATCH 09/11] genTxs: Fix minimum fee calculation --- .../Cardano/Tools/DBSynthesizer/Tx.hs | 22 +++++++++++++------ 1 file changed, 15 insertions(+), 7 deletions(-) diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Tx.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Tx.hs index bf2b745b6f..6ebb13f45e 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Tx.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Tx.hs @@ -33,6 +33,7 @@ module Cardano.Tools.DBSynthesizer.Tx import Cardano.Ledger.Plutus.ExUnits import qualified Cardano.Crypto.DSIGN.Class as Crypto +import Cardano.Ledger.Api.Tx (calcMinFeeTx) import Cardano.Ledger.Api.Tx.Wits import Cardano.Ledger.Api.Tx.Out import Cardano.Ledger.SafeHash @@ -140,6 +141,7 @@ type TxGenCompatibleEra era = , AlonzoEraTxBody era , AlonzoEraTxWits era , BabbageEraTxOut era + , EraUTxO era ) data TxGenLedgerState c = forall era proto . (c ~ EraCrypto era, TxGenCompatibleEra era) => TxGenLedgerState { nes :: !(NewEpochState era) @@ -249,6 +251,7 @@ makeGenTxs (OwnedTxIn { owned, skey }) initSpec = do Nothing -> (Producing st, []) Just TxGenLedgerState {nes, mkCardanoTx, mkMintingPurpose} -> let + utxos = utxosUtxo . lsUTxOState . esLState $ nesEs nes params = getPParams nes langViews = Set.singleton (getLanguageView params PlutusV2) net = getNetwork $ st.addr @@ -387,13 +390,18 @@ makeGenTxs (OwnedTxIn { owned, skey }) initSpec = do (mintHash, mintBytes) = mkMint idx -- Finalize the transaction with the fee and setting the change output to balance - fee = getMinFeeTx params noFeeTx - change = currSt.balance ~~ (minAda <> fee) - setChange Seq.Empty = Seq.Empty - setChange (x :<| outs) = (x & coinTxOutL .~ change) :<| outs - unsignedTx = noFeeTx - & bodyTxL . feeTxBodyL .~ fee - & bodyTxL . outputsTxBodyL %~ setChange + setMinFee prevTx = if prevTx ^. bodyTxL . feeTxBodyL == neededFee + then (neededChange, nextTx) + else setMinFee nextTx + where + neededFee = calcMinFeeTx utxos params prevTx 0 + neededChange = currSt.balance ~~ (minAda <> neededFee) + nextTx = prevTx + & bodyTxL . feeTxBodyL .~ neededFee + & bodyTxL . outputsTxBodyL %~ setChange neededChange + (change, unsignedTx) = setMinFee noFeeTx + setChange _ Seq.Empty = Seq.Empty + setChange c (x :<| outs) = (x & coinTxOutL .~ c) :<| outs -- Witness the transaction tx = unsignedTx From 7c916f5c4db968e33c27da82eb77f9da0109ba1c Mon Sep 17 00:00:00 2001 From: Shea Levy Date: Tue, 9 Apr 2024 00:54:03 -0400 Subject: [PATCH 10/11] genTxs: Use in-progress UTxO set for cost calculation --- .../Cardano/Tools/DBSynthesizer/Tx.hs | 116 +++++++++++------- 1 file changed, 71 insertions(+), 45 deletions(-) diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Tx.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Tx.hs index 6ebb13f45e..cc222f4dd1 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Tx.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Tx.hs @@ -31,6 +31,8 @@ module Cardano.Tools.DBSynthesizer.Tx , AddTxException(..) ) where +import Data.Typeable +import Data.SOP.Strict.NS import Cardano.Ledger.Plutus.ExUnits import qualified Cardano.Crypto.DSIGN.Class as Crypto import Cardano.Ledger.Api.Tx (calcMinFeeTx) @@ -40,11 +42,11 @@ import Cardano.Ledger.SafeHash import Cardano.Ledger.Keys import Cardano.Ledger.Crypto import Control.Monad.Trans.Except -import Data.Proxy import Data.SOP.Classes import Data.SOP.BasicFunctors import Ouroboros.Consensus.Byron.Ledger.Block import Ouroboros.Consensus.Cardano.CanHardFork +import Ouroboros.Consensus.TypeFamilyWrappers import Control.Exception import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Config @@ -67,6 +69,8 @@ import Data.Word import Cardano.Ledger.Api.Scripts import Ouroboros.Consensus.Cardano.Block import Ouroboros.Consensus.HardFork.Combinator +import Ouroboros.Consensus.HardFork.Combinator.AcrossEras +import Ouroboros.Consensus.HardFork.Combinator.State import Data.Coerce import Lens.Micro import qualified Data.Map.Strict as Map @@ -74,6 +78,7 @@ import Cardano.Ledger.TxIn import Cardano.Ledger.UTxO hiding (balance) import Cardano.Ledger.Core import Ouroboros.Consensus.Protocol.Praos +import Ouroboros.Consensus.Shelley.HFEras () import qualified Data.Set as Set import Cardano.Ledger.Mary.Value import Data.Sequence.Strict as Seq @@ -129,69 +134,82 @@ mkAssetName :: Natural -> AssetName mkAssetName n = coerce (SBS.replicate (fromIntegral n) 0) txGenLedgerState :: forall c. (CardanoHardForkConstraints c) => TickedLedgerState (CardanoBlock c) -> Maybe (TxGenLedgerState c) -txGenLedgerState = hcollapse . hcmap (Proxy @(MaybeTxGenLedgerState c)) (K . maybeTxGenLedgerState @c . unComp) . tickedHardForkLedgerStatePerEra +txGenLedgerState tls = hcollapse $ hcmap (Proxy @(MaybeTxGenLedgerState c)) (K . maybeTxGenLedgerState @c tls . unComp) tls.tickedHardForkLedgerStatePerEra utxoLookupLedgerState :: forall c. (CardanoHardForkConstraints c) => TickedLedgerState (CardanoBlock c) -> TxIn c -> Maybe (Addr c, Coin) utxoLookupLedgerState = hcollapse . hcmap (Proxy @(UTxOLookup c)) (K . utxoLookup @c . unComp) . tickedHardForkLedgerStatePerEra -- | At least Babbage -type TxGenCompatibleEra era = - ( ShelleyBasedEra era +type TxGenCompatibleEra proto era = + ( ShelleyCompatible proto era , Value era ~ MaryValue (EraCrypto era) , AlonzoEraTxBody era , AlonzoEraTxWits era , BabbageEraTxOut era , EraUTxO era ) -data TxGenLedgerState c = forall era proto . (c ~ EraCrypto era, TxGenCompatibleEra era) => TxGenLedgerState - { nes :: !(NewEpochState era) - , mkCardanoTx :: !(GenTx (ShelleyBlock proto era) -> CardanoGenTx c) +data TxGenLedgerState c = forall era proto . (c ~ EraCrypto era, TxGenCompatibleEra proto era) => TxGenLedgerState + { st :: !(Ticked (LedgerState (ShelleyBlock proto era))) , mkMintingPurpose :: !(forall f. f Word32 (PolicyID (EraCrypto era)) -> PlutusPurpose f era) + , extractLedgerConfig :: !(CardanoLedgerConfig c -> LedgerConfig (ShelleyBlock proto era)) + , cardanifyValidated :: !(Validated (GenTx (ShelleyBlock proto era)) -> Validated (CardanoGenTx c)) } -data AddTxException c = AddTxException - { tx :: !(GenTx (CardanoBlock c)) - , err :: !(ApplyTxErr (CardanoBlock c)) +data AddTxException proto era = AddTxException + { tx :: !(GenTx (ShelleyBlock proto era)) + , err :: !(ApplyTxError era) } -deriving stock instance (CardanoHardForkConstraints c) => Show (AddTxException c) +deriving stock instance (ShelleyBasedEra era) => Show (AddTxException proto era) -instance (CardanoHardForkConstraints c) => Exception (AddTxException c) +instance (ShelleyBasedEra era, Typeable proto) => Exception (AddTxException proto era) class MaybeTxGenLedgerState c blk where - maybeTxGenLedgerState :: Ticked (LedgerState blk) -> Maybe (TxGenLedgerState c) - -instance MaybeTxGenLedgerState c ByronBlock where - maybeTxGenLedgerState = const Nothing - -class ShelleyTxGenLedgerState era where - maybeShelleyTxGenLedgerState :: NewEpochState era -> Maybe (TxGenLedgerState (EraCrypto era)) + maybeTxGenLedgerState :: Ticked (LedgerState (CardanoBlock c)) -> Ticked (LedgerState blk) -> Maybe (TxGenLedgerState c) -- Duplicate instead of an overlappable not-supported case so we get an error in new eras -instance ShelleyTxGenLedgerState (ShelleyEra c) where - maybeShelleyTxGenLedgerState = const Nothing -instance ShelleyTxGenLedgerState (AllegraEra c) where - maybeShelleyTxGenLedgerState = const Nothing -instance ShelleyTxGenLedgerState (MaryEra c) where - maybeShelleyTxGenLedgerState = const Nothing -instance ShelleyTxGenLedgerState (AlonzoEra c) where - maybeShelleyTxGenLedgerState = const Nothing -instance (PraosCrypto c) => ShelleyTxGenLedgerState (BabbageEra c) where - maybeShelleyTxGenLedgerState nes = Just $ TxGenLedgerState - { nes - , mkCardanoTx = GenTxBabbage +instance MaybeTxGenLedgerState c ByronBlock where + maybeTxGenLedgerState _ _ = Nothing +instance MaybeTxGenLedgerState c (ShelleyBlock proto (ShelleyEra c)) where + maybeTxGenLedgerState _ _ = Nothing +instance MaybeTxGenLedgerState c (ShelleyBlock proto (AllegraEra c)) where + maybeTxGenLedgerState _ _ = Nothing +instance MaybeTxGenLedgerState c (ShelleyBlock proto (MaryEra c)) where + maybeTxGenLedgerState _ _ = Nothing +instance MaybeTxGenLedgerState c (ShelleyBlock proto (AlonzoEra c)) where + maybeTxGenLedgerState _ _ = Nothing + +extractLedgerConfig' + :: forall proxy proto era + . (ShelleyCompatible proto era) + => proxy (ShelleyBlock proto era) + -> (CardanoLedgerConfig (EraCrypto era) -> PartialLedgerConfig (ShelleyBlock proto era)) + -> Ticked (LedgerState (CardanoBlock (EraCrypto era))) + -> CardanoLedgerConfig (EraCrypto era) + -> LedgerConfig (ShelleyBlock proto era) +extractLedgerConfig' proxy extractPartial tls cfg = completeLedgerConfig proxy eInfo $ extractPartial cfg + where + eInfo = + epochInfoPrecomputedTransitionInfo + cfg.hardForkLedgerConfigShape + tls.tickedHardForkLedgerStateTransition + tls.tickedHardForkLedgerStatePerEra + +instance (PraosCrypto c) => MaybeTxGenLedgerState c (ShelleyBlock (Praos c) (BabbageEra c)) where + maybeTxGenLedgerState tls st = Just $ TxGenLedgerState + { st , mkMintingPurpose = AlonzoMinting + , extractLedgerConfig = extractLedgerConfig' (Proxy @(ShelleyBlock (Praos c) (BabbageEra c))) (\(CardanoLedgerConfig _ _ _ _ _ pCfg _) -> pCfg) tls + , cardanifyValidated = \vtx -> HardForkValidatedGenTx . OneEraValidatedGenTx $ S (S (S (S (S (Z $ coerce vtx))))) } -instance (PraosCrypto c) => ShelleyTxGenLedgerState (ConwayEra c) where - maybeShelleyTxGenLedgerState nes = Just $ TxGenLedgerState - { nes - , mkCardanoTx = GenTxConway +instance (PraosCrypto c) => MaybeTxGenLedgerState c (ShelleyBlock (Praos c) (ConwayEra c)) where + maybeTxGenLedgerState tls st = Just $ TxGenLedgerState + { st , mkMintingPurpose = ConwayMinting + , extractLedgerConfig = extractLedgerConfig' (Proxy @(ShelleyBlock (Praos c) (ConwayEra c))) (\(CardanoLedgerConfig _ _ _ _ _ _ pCfg) -> pCfg) tls + , cardanifyValidated = \vtx -> HardForkValidatedGenTx . OneEraValidatedGenTx $ S (S (S (S (S (S (Z $ coerce vtx)))))) } -instance (ShelleyTxGenLedgerState era, c ~ EraCrypto era) => MaybeTxGenLedgerState c (ShelleyBlock proto era) where - maybeTxGenLedgerState st = maybeShelleyTxGenLedgerState st.tickedShelleyLedgerState - class UTxOLookup c blk where utxoLookup :: Ticked (LedgerState blk) -> TxIn c -> Maybe (Addr c, Coin) @@ -249,25 +267,32 @@ makeGenTxs (OwnedTxIn { owned, skey }) initSpec = do uTxOIn = st.initIn go tls cfg slot st = case txGenLedgerState tls of Nothing -> (Producing st, []) - Just TxGenLedgerState {nes, mkCardanoTx, mkMintingPurpose} -> + Just TxGenLedgerState {st = initTls, mkMintingPurpose, extractLedgerConfig, cardanifyValidated} -> let - utxos = utxosUtxo . lsUTxOState . esLState $ nesEs nes + nes = initTls.tickedShelleyLedgerState params = getPParams nes langViews = Set.singleton (getLanguageView params PlutusV2) net = getNetwork $ st.addr undelegAddr = Addr net def StakeRefNull delegAddr = Addr net def (StakeRefBase def) + -- Work around inability to match on existential type variables + specializeTxInBlockSize :: (LedgerSupportsMempool blk) => f (g blk) -> GenTx blk -> Word32 + specializeTxInBlockSize _ = txInBlockSize + txInBlockSize' = specializeTxInBlockSize initTls + -- Create as many transactions as we can fit in this block (unless we finish everything -- our specs request) and update our state accordingly makeTxs currSt currTls remainingBodySize = if txFits - then (lastSt, vtx : lastTxs) + then (lastSt, cardanifyValidated vtx : lastTxs) else (currSt, []) where -- The transaction fits if we were able to add any outputs at all, and if we have outputs we need some min-ADA for them txFits = minAda /= mempty + utxos = utxosUtxo . lsUTxOState . esLState . nesEs $ currTls.tickedShelleyLedgerState + -- Make more transactions, if there's room (lastSt, lastTxs) = makeTxs nextSt nextTls nextBodySize @@ -287,12 +312,13 @@ makeGenTxs (OwnedTxIn { owned, skey }) initSpec = do Left err -> throw $ AddTxException { tx = gtx, err } -- TODO put makeTxs in IO and throwIO here? Right x -> x eVtx = applyTx - (configLedger cfg) + (extractLedgerConfig $ configLedger cfg) Intervene slot gtx currTls - gtx = mkCardanoTx $ mkShelleyTx tx + gtx = mkShelleyTx tx + -- Initialize the transaction -- We add a dummy tx witness so our size checks are accurate @@ -316,7 +342,7 @@ makeGenTxs (OwnedTxIn { owned, skey }) initSpec = do else (txSoFar, mempty, specSoFar) where -- We can add an output if the transaction with that output fits in the max tx size and the remaining block space - outFits = params ^. ppMaxTxSizeL > (fromIntegral $ txStep ^. sizeTxF) && remainingBodySize > (txInBlockSize . mkCardanoTx $ mkShelleyTx txStep) + outFits = params ^. ppMaxTxSizeL > (fromIntegral $ txStep ^. sizeTxF) && remainingBodySize > (txInBlockSize' $ mkShelleyTx txStep) -- Add more UTxOs, if we have room (finalTx, finalAda, finalSpecOuts) = @@ -411,5 +437,5 @@ makeGenTxs (OwnedTxIn { owned, skey }) initSpec = do -- How much space is left in the block after this transaction? nextBodySize = remainingBodySize - txInBlockSize gtx - (finalSt, txs) = makeTxs st tls (txsMaxBytes tls) + (finalSt, txs) = makeTxs st initTls (txsMaxBytes initTls) in (Producing finalSt, txs) From 6eadc33b761ccafef0189058f26d5aabbbc003f1 Mon Sep 17 00:00:00 2001 From: Shea Levy Date: Wed, 10 Apr 2024 10:02:41 -0400 Subject: [PATCH 11/11] tmp: logging --- ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal | 1 + .../Cardano/Tools/DBSynthesizer/Forging.hs | 4 ++++ 2 files changed, 5 insertions(+) diff --git a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal index 18cfa6503a..53ff8bf504 100644 --- a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal +++ b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal @@ -494,6 +494,7 @@ library unstable-cardano-tools build-depends: , aeson + , time , base >=4.14 && <4.20 , base16-bytestring >=1.0 , bytestring >=0.10 && <0.13 diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Forging.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Forging.hs index f0782bf833..1325c4f9de 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Forging.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Forging.hs @@ -6,6 +6,7 @@ module Cardano.Tools.DBSynthesizer.Forging (runForge, GenTxs) where +import Data.Time import Cardano.Tools.DBSynthesizer.Types (ForgeLimit (..), ForgeResult (..)) import Control.Monad (when) @@ -180,6 +181,9 @@ runForge epochSize_ nextSlot opts chainDB blockForging cfg genTxs = do when (mbCurTip /= SuccesfullyAddedBlock (blockPoint newBlock)) $ exitEarly' "block not adopted" + now <- lift $ getCurrentTime + lift . putStrLn $ show now ++ ": forged block " ++ show bcBlockNo ++ " at slot " ++ show currentSlot + -- | Context required to forge a block data BlockContext blk = BlockContext