From 88f9ecc4c739a6864e23921d0e3a2c24018f6666 Mon Sep 17 00:00:00 2001 From: Kostas Dermentzis Date: Mon, 1 Dec 2025 13:28:24 +0200 Subject: [PATCH 1/8] Update to Node 10.6 --- cabal.project | 16 +- cardano-chain-gen/cardano-chain-gen.cabal | 8 +- .../src/Cardano/Mock/ChainSync/Server.hs | 103 ++++------ .../src/Cardano/Mock/Forging/Tx/Alonzo.hs | 92 +++++---- .../src/Cardano/Mock/Forging/Tx/Babbage.hs | 99 +++++----- .../src/Cardano/Mock/Forging/Tx/Conway.hs | 186 +++++++++--------- .../Mock/Forging/Tx/Conway/Scenarios.hs | 3 +- .../src/Cardano/Mock/Forging/Tx/Generic.hs | 56 +++--- .../src/Cardano/Mock/Forging/Tx/Shelley.hs | 19 +- cardano-chain-gen/test/Main.hs | 3 +- .../test/Test/Cardano/Db/Mock/Config.hs | 104 +++++----- .../Db/Mock/Unit/Conway/Config/Parse.hs | 17 +- .../Cardano/Db/Mock/Unit/Conway/Governance.hs | 4 +- .../config-conway-hf-epoch1/test-config.json | 2 +- .../config-conway-no-pools/test-config.json | 2 +- .../config-conway-no-stakes/test-config.json | 2 +- .../config-conway/genesis.conway.json | 18 ++ .../testfiles/config-conway/test-config.json | 2 +- cardano-db-sync/cardano-db-sync.cabal | 5 +- .../src/Cardano/DbSync/Api/Ledger.hs | 1 + .../src/Cardano/DbSync/Config/Cardano.hs | 72 +++---- cardano-db-sync/src/Cardano/DbSync/Default.hs | 3 + cardano-db-sync/src/Cardano/DbSync/Epoch.hs | 1 + .../DbSync/Era/Shelley/Generic/Block.hs | 24 ++- .../DbSync/Era/Shelley/Generic/EpochUpdate.hs | 1 + .../DbSync/Era/Shelley/Generic/ProtoParams.hs | 44 +++++ .../DbSync/Era/Shelley/Generic/Rewards.hs | 2 +- .../DbSync/Era/Shelley/Generic/Script.hs | 3 +- .../DbSync/Era/Shelley/Generic/StakeDist.hs | 2 + .../Cardano/DbSync/Era/Shelley/Generic/Tx.hs | 2 + .../DbSync/Era/Shelley/Generic/Tx/Allegra.hs | 7 +- .../DbSync/Era/Shelley/Generic/Tx/Alonzo.hs | 31 +-- .../DbSync/Era/Shelley/Generic/Tx/Babbage.hs | 17 +- .../DbSync/Era/Shelley/Generic/Tx/Conway.hs | 4 +- .../DbSync/Era/Shelley/Generic/Tx/Dijkstra.hs | 109 ++++++++++ .../DbSync/Era/Shelley/Generic/Tx/Shelley.hs | 2 +- .../DbSync/Era/Shelley/Generic/Tx/Types.hs | 33 +++- .../src/Cardano/DbSync/Era/Universal/Epoch.hs | 2 +- .../Era/Universal/Insert/Certificate.hs | 17 +- .../DbSync/Era/Universal/Insert/GovAction.hs | 2 +- .../DbSync/Era/Universal/Insert/Pool.hs | 2 +- .../Cardano/DbSync/Era/Universal/Validate.hs | 15 +- .../src/Cardano/DbSync/Ledger/Event.hs | 13 +- .../src/Cardano/DbSync/Ledger/State.hs | 3 +- .../src/Cardano/DbSync/Ledger/Types.hs | 6 + cardano-db-sync/src/Cardano/DbSync/Sync.hs | 2 + cardano-db-sync/src/Cardano/DbSync/Types.hs | 1 + .../src/Cardano/DbTool/Validate/Balance.hs | 11 +- .../src/Cardano/Db/Statement/Constraint.hs | 5 +- cardano-db/src/Cardano/Db/Types.hs | 3 + .../src/Cardano/SMASH/Server/Types.hs | 9 +- flake.lock | 66 +++---- 52 files changed, 740 insertions(+), 516 deletions(-) create mode 100644 cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Dijkstra.hs diff --git a/cabal.project b/cabal.project index c62d03b1e..d850dcca7 100644 --- a/cabal.project +++ b/cabal.project @@ -10,8 +10,8 @@ repository cardano-haskell-packages d4a35cd3121aa00d18544bb0ac01c3e1691d618f462c46129271bccf39f7e8ee index-state: - , hackage.haskell.org 2025-08-03T21:32:16Z - , cardano-haskell-packages 2025-07-30T14:13:57Z + , hackage.haskell.org 2025-10-17T00:26:22Z + , cardano-haskell-packages 2025-11-07T15:42:47Z packages: cardano-db @@ -75,7 +75,6 @@ constraints: -- then clashes with the `show` in `Prelude`. , text < 2.1.2 - , cardano-node ^>= 10.4 if impl (ghc >= 9.12) allow-newer: @@ -86,3 +85,14 @@ if impl (ghc >= 9.12) -- when using the "cabal" wrapper script provided by nix-shell. -- --------------------------- 8< -------------------------- -- Please do not put any `source-repository-package` clause above this line. + +source-repository-package + type: git + location: https://github.com/IntersectMBO/cardano-node + tag: f5ac0eb01b56af80e8d430828ff6000b6abb92e9 + --sha256: sha256-pm+lbEiRdQesnkaXmzn58aWlBhD29l7QHGNtJiDlzuA= + subdir: + cardano-node + trace-dispatcher + trace-forward + trace-resources diff --git a/cardano-chain-gen/cardano-chain-gen.cabal b/cardano-chain-gen/cardano-chain-gen.cabal index 07e63cde0..893bc7559 100644 --- a/cardano-chain-gen/cardano-chain-gen.cabal +++ b/cardano-chain-gen/cardano-chain-gen.cabal @@ -83,7 +83,7 @@ library , extra , mtl , microlens - , network-mux + , network , nothunks , ouroboros-consensus , ouroboros-consensus-cardano @@ -97,10 +97,10 @@ library , plutus-ledger-api:{plutus-ledger-api-testlib} , serialise , strict-sop-core - , strict-stm + , io-classes:strict-stm , text , typed-protocols - , typed-protocols-stateful + , typed-protocols:stateful test-suite cardano-chain-gen type: exitcode-stdio-1.0 @@ -183,9 +183,9 @@ test-suite cardano-chain-gen , extra , filepath , int-cast + , io-classes:strict-stm , silently , stm - , strict-stm , tasty , tasty-quickcheck , text diff --git a/cardano-chain-gen/src/Cardano/Mock/ChainSync/Server.hs b/cardano-chain-gen/src/Cardano/Mock/ChainSync/Server.hs index 6db91a4ee..e785320e7 100644 --- a/cardano-chain-gen/src/Cardano/Mock/ChainSync/Server.hs +++ b/cardano-chain-gen/src/Cardano/Mock/ChainSync/Server.hs @@ -48,10 +48,8 @@ import Control.Tracer (nullTracer) import Data.ByteString.Lazy.Char8 (ByteString) import qualified Data.Map.Strict as Map import Data.Maybe (fromJust) -import Data.Void (Void) -import qualified Network.Mux as Mux import Network.TypedProtocol.Peer (Peer (..)) -import Network.TypedProtocol.Stateful.Codec () +import qualified Network.Socket as Socket import qualified Network.TypedProtocol.Stateful.Peer as St import Ouroboros.Consensus.Block (CodecConfig, HasHeader, Point, StandardHash, castPoint) import Ouroboros.Consensus.Config (TopLevelConfig, configCodec) @@ -65,7 +63,6 @@ import Ouroboros.Consensus.Node.DbMarker () import Ouroboros.Consensus.Node.InitStorage () import Ouroboros.Consensus.Node.NetworkProtocolVersion ( BlockNodeToClientVersion, - NodeToClientVersion, SupportedNetworkProtocolVersion, latestReleasedNodeVersion, supportedNodeToClientVersions, @@ -87,14 +84,9 @@ import Ouroboros.Network.Block ( ) import Ouroboros.Network.Channel (Channel) import Ouroboros.Network.Driver.Simple (runPeer) -import qualified Ouroboros.Network.Driver.Stateful as St (runPeer) -import Ouroboros.Network.IOManager (IOManager) -import qualified Ouroboros.Network.IOManager as IOManager +import qualified Ouroboros.Network.Driver.Stateful as Stateful import Ouroboros.Network.Magic (NetworkMagic) -import Ouroboros.Network.Mux (OuroborosApplicationWithMinimalCtx) -import Ouroboros.Network.NodeToClient (NodeToClientVersionData (..)) -import qualified Ouroboros.Network.NodeToClient as NodeToClient -import Ouroboros.Network.NodeToNode (Versions) +import Ouroboros.Network.NodeToClient import Ouroboros.Network.Protocol.ChainSync.Server ( ChainSyncServer (..), ServerStIdle (..), @@ -102,10 +94,12 @@ import Ouroboros.Network.Protocol.ChainSync.Server ( ServerStNext (SendMsgRollBackward, SendMsgRollForward), chainSyncServerPeer, ) -import Ouroboros.Network.Protocol.Handshake.Version (simpleSingletonVersions) +import Ouroboros.Network.Protocol.Handshake import qualified Ouroboros.Network.Protocol.LocalStateQuery.Type as LocalStateQuery -import Ouroboros.Network.Snocket (LocalAddress, LocalSnocket, LocalSocket (..)) +import Ouroboros.Network.Server.Simple as Server +import Ouroboros.Network.Snocket import qualified Ouroboros.Network.Snocket as Snocket +import Ouroboros.Network.Socket import Ouroboros.Network.Util.ShowProxy (Proxy (..), ShowProxy (..)) {- HLINT ignore "Use readTVarIO" -} @@ -212,25 +206,33 @@ runLocalServer :: FilePath -> StrictTVar IO (ChainProducerState blk) -> IO () -runLocalServer iom codecConfig netMagic localDomainSock chainProdState = - withSnocket iom localDomainSock $ \localSocket localSnocket -> do - networkState <- NodeToClient.newNetworkMutableState - _ <- - NodeToClient.withServer - localSnocket - NodeToClient.nullNetworkServerTracers -- debuggingNetworkServerTracers - networkState - localSocket - (versions chainProdState) - NodeToClient.networkErrorPolicies - pure () +runLocalServer iom codecConfig netMagic localDomainSock chainProdState = do + _ <- + Server.with + (Snocket.socketSnocket iom) + makeSocketBearer -- makeLocalBearer -- + (\_ _ -> pure ()) + (Socket.SockAddrUnix localDomainSock) + ( HandshakeArguments + { haHandshakeTracer = nullTracer + , haBearerTracer = nullTracer + , haHandshakeCodec = codecHandshake nodeToClientVersionCodec + , haVersionDataCodec = cborTermVersionDataCodec nodeToClientCodecCBORTerm + , haAcceptVersion = acceptableVersion + , haQueryVersion = queryVersion + , haTimeLimits = noTimeLimitsHandshake + } + ) + (versions chainProdState) + (\_ serverAsync -> wait serverAsync) + pure () where versions :: StrictTVar IO (ChainProducerState blk) -> Versions NodeToClientVersion NodeToClientVersionData - (OuroborosApplicationWithMinimalCtx 'Mux.ResponderMode LocalAddress ByteString IO Void ()) + (SomeResponderApplication Socket.SockAddr ByteString IO ()) versions state = let version = fromJust $ snd $ latestReleasedNodeVersion (Proxy @blk) allVersions = supportedNodeToClientVersions (Proxy @blk) @@ -238,7 +240,7 @@ runLocalServer iom codecConfig netMagic localDomainSock chainProdState = in simpleSingletonVersions version (NodeToClientVersionData netMagic False) - (\versionData -> NTC.responder version versionData $ mkApps state version blockVersion (NTC.defaultCodecs codecConfig blockVersion version)) + (\versionData' -> SomeResponderApplication $ NTC.responder version versionData' $ mkApps state version blockVersion (NTC.defaultCodecs codecConfig blockVersion version)) mkApps :: StrictTVar IO (ChainProducerState blk) -> @@ -260,11 +262,10 @@ runLocalServer iom codecConfig netMagic localDomainSock chainProdState = IO ((), Maybe ByteString) chainSyncServer' _them channel = runPeer - nullTracer -- TODO add a tracer! + nullTracer (cChainSyncCodec codecs) channel - $ chainSyncServerPeer - $ chainSyncServer state codecConfig blockVersion + (chainSyncServerPeer $ chainSyncServer state codecConfig blockVersion) txSubmitServer :: localPeer -> @@ -277,12 +278,8 @@ runLocalServer iom codecConfig netMagic localDomainSock chainProdState = channel (Effect (forever $ threadDelay 3_600_000_000)) - stateQueryServer :: - localPeer -> - Channel IO ByteString -> - IO ((), Maybe ByteString) stateQueryServer _them channel = - St.runPeer + Stateful.runPeer nullTracer (cStateQueryCodec codecs) channel @@ -354,8 +351,7 @@ chainSyncServer state codec _blockVersion = (Tip blk, ChainUpdate blk blk) -> ServerStNext (Serialised blk) (Point blk) (Tip blk) m () sendNext r (tip, AddBlock b) = - -- SendMsgRollForward -- (Serialised $ toLazyByteString $ encodeNodeToClient codec blockVersion b) tip (idle' r) - SendMsgRollForward (mkSerialised (encodeDisk codec) b) tip (idle' r) -- encodeNodeToClient codec blockVersion -- mkSerialised encode b + SendMsgRollForward (mkSerialised (encodeDisk codec) b) tip (idle' r) sendNext r (tip, RollBack p) = SendMsgRollBackward (castPoint p) tip (idle' r) newFollower :: m FollowerId @@ -404,36 +400,3 @@ chainSyncServer state codec _blockVersion = writeTVar state cps' let chain = chainDB cps' pure (castTip (headTip chain), u) - -withSnocket :: - forall a. - IOManager -> - FilePath -> - (LocalSocket -> LocalSnocket -> IO a) -> - IO a -withSnocket iocp localDomainSock k = - bracket localServerInit localServerCleanup localServerBody - where - localServerInit :: IO (LocalSocket, LocalSnocket) - localServerInit = do - let sn = Snocket.localSnocket iocp - sd <- - Snocket.open - sn - ( Snocket.addrFamily sn $ - Snocket.localAddressFromPath localDomainSock - ) - pure (sd, sn) - - -- We close the socket here, even if it was provided for us. - localServerCleanup :: (LocalSocket, LocalSnocket) -> IO () - localServerCleanup (sd, sn) = Snocket.close sn sd - - localServerBody :: (LocalSocket, LocalSnocket) -> IO a - localServerBody (sd, sn) = do - Snocket.bind sn sd (Snocket.localAddressFromPath localDomainSock) - Snocket.listen sn sd - k sd sn - -withIOManager :: (IOManager -> IO a) -> IO a -withIOManager = IOManager.withIOManager diff --git a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Alonzo.hs b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Alonzo.hs index ebdbfca7c..f7e32159b 100644 --- a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Alonzo.hs +++ b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Alonzo.hs @@ -78,7 +78,7 @@ consTxBody :: MultiAsset -> [ShelleyTxCert AlonzoEra] -> Withdrawals -> - AlonzoTxBody AlonzoEra + TxBody AlonzoEra consTxBody ins cols outs fees minted certs wdrl = AlonzoTxBody ins @@ -96,15 +96,15 @@ consTxBody ins cols outs fees minted certs wdrl = (Strict.SJust Testnet) addValidityInterval :: - AlonzoEraTxBody era => + forall era. + (AlonzoEraTxBody era, EraTx era) => SlotNo -> - AlonzoTx era -> - AlonzoTx era + Core.Tx era -> + Core.Tx era addValidityInterval slotNo tx = - tx {body = txBody'} + set (bodyTxL @era . vldtTxBodyL @era) interval tx where interval = ValidityInterval Strict.SNothing (Strict.SJust slotNo) - txBody' = set vldtTxBodyL interval (body tx) consPaymentTxBody :: Set TxIn -> @@ -112,10 +112,10 @@ consPaymentTxBody :: StrictSeq (AlonzoTxOut AlonzoEra) -> Coin -> MultiAsset -> - AlonzoTxBody AlonzoEra + TxBody AlonzoEra consPaymentTxBody ins cols outs fees minted = consTxBody ins cols outs fees minted mempty (Withdrawals mempty) -consCertTxBody :: [ShelleyTxCert AlonzoEra] -> Withdrawals -> AlonzoTxBody AlonzoEra +consCertTxBody :: [ShelleyTxCert AlonzoEra] -> Withdrawals -> TxBody AlonzoEra consCertTxBody = consTxBody mempty mempty mempty (Coin 0) mempty mkPaymentTx :: @@ -124,7 +124,7 @@ mkPaymentTx :: Integer -> Integer -> AlonzoLedgerState mk -> - Either ForgingError (AlonzoTx AlonzoEra) + Either ForgingError (Core.Tx AlonzoEra) mkPaymentTx inputIndex outputIndex amount fees sta = do (inputPair, _) <- resolveUTxOIndex inputIndex sta addr <- resolveAddress outputIndex sta @@ -139,7 +139,7 @@ mkPaymentTx' :: AlonzoUTxOIndex -> [(AlonzoUTxOIndex, MaryValue)] -> AlonzoLedgerState mk -> - Either ForgingError (AlonzoTx AlonzoEra) + Either ForgingError (Core.Tx AlonzoEra) mkPaymentTx' inputIndex outputIndex sta = do inputPair <- fst <$> resolveUTxOIndex inputIndex sta outps <- mapM mkOuts outputIndex @@ -160,7 +160,7 @@ mkLockByScriptTx :: Integer -> Integer -> AlonzoLedgerState mk -> - Either ForgingError (AlonzoTx AlonzoEra) + Either ForgingError (Core.Tx AlonzoEra) mkLockByScriptTx inputIndex spendable amount fees sta = do (inputPair, _) <- resolveUTxOIndex inputIndex sta @@ -184,7 +184,7 @@ mkUnlockScriptTx :: Integer -> Integer -> AlonzoLedgerState mk -> - Either ForgingError (AlonzoTx AlonzoEra) + Either ForgingError (Core.Tx AlonzoEra) mkUnlockScriptTx inputIndex colInputIndex outputIndex succeeds amount fees sta = do inputPairs <- fmap fst <$> mapM (`resolveUTxOIndex` sta) inputIndex (colInputPair, _) <- resolveUTxOIndex colInputIndex sta @@ -194,6 +194,7 @@ mkUnlockScriptTx inputIndex colInputIndex outputIndex succeeds amount fees sta = colInput = Set.singleton $ fst colInputPair output = AlonzoTxOut addr (valueFromList (Coin amount) []) Strict.SNothing Right + $ MkAlonzoTx $ mkScriptTx succeeds (mapMaybe mkScriptInp' $ zip [0 ..] inputPairs) @@ -250,7 +251,7 @@ mkMAssetsScriptTx :: Bool -> Integer -> AlonzoLedgerState mk -> - Either ForgingError (AlonzoTx AlonzoEra) + Either ForgingError (Core.Tx AlonzoEra) mkMAssetsScriptTx inputIndex colInputIndex outputIndex minted succeeds fees sta = do inputPairs <- fmap fst <$> mapM (`resolveUTxOIndex` sta) inputIndex colInput <- Set.singleton . fst . fst <$> resolveUTxOIndex colInputIndex sta @@ -258,6 +259,7 @@ mkMAssetsScriptTx inputIndex colInputIndex outputIndex minted succeeds fees sta let inpts = Set.fromList $ fst <$> inputPairs Right + $ MkAlonzoTx $ mkScriptTx succeeds ( mapMaybe mkScriptInp' (zip [0 ..] inputPairs) @@ -272,13 +274,13 @@ mkMAssetsScriptTx inputIndex colInputIndex outputIndex minted succeeds fees sta mkDCertTx :: [ShelleyTxCert AlonzoEra] -> Withdrawals -> - Either ForgingError (AlonzoTx AlonzoEra) + Either ForgingError (Core.Tx AlonzoEra) mkDCertTx certs wdrl = Right $ mkSimpleTx True $ consCertTxBody certs wdrl mkSimpleDCertTx :: [(StakeIndex, StakeCredential -> ShelleyTxCert AlonzoEra)] -> AlonzoLedgerState mk -> - Either ForgingError (AlonzoTx AlonzoEra) + Either ForgingError (Core.Tx AlonzoEra) mkSimpleDCertTx consDert st = do dcerts <- forM consDert $ \(stakeIndex, mkDCert) -> do cred <- resolveStakeCreds stakeIndex st @@ -292,7 +294,7 @@ mkDCertPoolTx :: ) ] -> AlonzoLedgerState mk -> - Either ForgingError (AlonzoTx AlonzoEra) + Either ForgingError (Core.Tx AlonzoEra) mkDCertPoolTx consDert st = do dcerts <- forM consDert $ \(stakeIxs, poolIx, mkDCert) -> do stakeCreds <- forM stakeIxs $ \stix -> resolveStakeCreds stix st @@ -304,14 +306,15 @@ mkScriptDCertTx :: [(StakeIndex, Bool, StakeCredential -> ShelleyTxCert AlonzoEra)] -> Bool -> AlonzoLedgerState mk -> - Either ForgingError (AlonzoTx AlonzoEra) + Either ForgingError (Core.Tx AlonzoEra) mkScriptDCertTx consDert valid st = do dcerts <- forM consDert $ \(stakeIndex, _, mkDCert) -> do cred <- resolveStakeCreds stakeIndex st pure $ mkDCert cred Right $ - mkScriptTx valid (mapMaybe (map (second Just) . prepareRedeemer) $ zip [0 ..] consDert) $ - consCertTxBody dcerts (Withdrawals mempty) + MkAlonzoTx $ + mkScriptTx valid (mapMaybe (map (second Just) . prepareRedeemer) $ zip [0 ..] consDert) $ + consCertTxBody dcerts (Withdrawals mempty) where prepareRedeemer (n, (StakeIndexScript bl, addRedeemer, _)) = if not addRedeemer @@ -327,7 +330,7 @@ mkDepositTxPools :: AlonzoUTxOIndex -> Integer -> AlonzoLedgerState mk -> - Either ForgingError (AlonzoTx AlonzoEra) + Either ForgingError (Core.Tx AlonzoEra) mkDepositTxPools inputIndex deposit sta = do (inputPair, _) <- resolveUTxOIndex inputIndex sta @@ -338,17 +341,18 @@ mkDepositTxPools inputIndex deposit sta = do mkDCertTxPools :: AlonzoLedgerState mk -> - Either ForgingError (AlonzoTx AlonzoEra) + Either ForgingError (Core.Tx AlonzoEra) mkDCertTxPools sta = Right $ mkSimpleTx True $ consCertTxBody (allPoolStakeCert sta) (Withdrawals mempty) -mkSimpleTx :: Bool -> AlonzoTxBody AlonzoEra -> AlonzoTx AlonzoEra +mkSimpleTx :: Bool -> TxBody AlonzoEra -> Core.Tx AlonzoEra mkSimpleTx valid txBody = - AlonzoTx - { body = txBody - , wits = mempty - , isValid = IsValid valid - , auxiliaryData = maybeToStrictMaybe Nothing - } + MkAlonzoTx $ + AlonzoTx + { atBody = txBody + , atWits = mempty + , atIsValid = IsValid valid + , atAuxData = maybeToStrictMaybe Nothing + } consPoolParamsTwoOwners :: [StakeCredential] -> @@ -370,10 +374,10 @@ mkScriptTx :: AlonzoTx era mkScriptTx valid rdmrs txBody = AlonzoTx - { body = txBody - , wits = witnesses - , isValid = IsValid valid - , auxiliaryData = maybeToStrictMaybe Nothing + { atBody = txBody + , atWits = witnesses + , atIsValid = IsValid valid + , atAuxData = maybeToStrictMaybe Nothing } where witnesses = @@ -402,18 +406,19 @@ mkWitnesses rdmrs datas = (fst <$> rdmrs) mkUTxOAlonzo :: - (Core.EraTx era, Core.Tx era ~ AlonzoTx era) => - AlonzoTx era -> + forall era. + Core.EraTx era => + Core.Tx era -> [(TxIn, Core.TxOut era)] mkUTxOAlonzo tx = [ (TxIn transId idx, out) | (out, idx) <- zip (toList (tx ^. outputsL)) (TxIx <$> [0 ..]) ] where - transId = txIdTx tx + transId = txIdTx @era tx outputsL = Core.bodyTxL . Core.outputsTxBodyL -emptyTxBody :: AlonzoTxBody AlonzoEra +emptyTxBody :: TxBody AlonzoEra emptyTxBody = AlonzoTxBody mempty @@ -430,11 +435,12 @@ emptyTxBody = Strict.SNothing (Strict.SJust Testnet) -emptyTx :: AlonzoTx AlonzoEra +emptyTx :: Core.Tx AlonzoEra emptyTx = - AlonzoTx - { body = emptyTxBody - , wits = mempty - , isValid = IsValid True - , auxiliaryData = maybeToStrictMaybe Nothing - } + MkAlonzoTx $ + AlonzoTx + { atBody = emptyTxBody + , atWits = mempty + , atIsValid = IsValid True + , atAuxData = maybeToStrictMaybe Nothing + } diff --git a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Babbage.hs b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Babbage.hs index 4b3b87c61..1b2e3ae11 100644 --- a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Babbage.hs +++ b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Babbage.hs @@ -122,7 +122,7 @@ consTxBody :: MultiAsset -> [ShelleyTxCert BabbageEra] -> Withdrawals -> - BabbageTxBody BabbageEra + TxBody BabbageEra consTxBody ins cols ref outs collOut fees minted certs wdrl = BabbageTxBody ins @@ -150,10 +150,10 @@ consPaymentTxBody :: StrictMaybe (BabbageTxOut BabbageEra) -> Coin -> MultiAsset -> - BabbageTxBody BabbageEra + TxBody BabbageEra consPaymentTxBody ins cols ref outs colOut fees minted = consTxBody ins cols ref outs colOut fees minted mempty (Withdrawals mempty) -consCertTxBody :: Maybe TxIn -> [ShelleyTxCert BabbageEra] -> Withdrawals -> BabbageTxBody BabbageEra +consCertTxBody :: Maybe TxIn -> [ShelleyTxCert BabbageEra] -> Withdrawals -> TxBody BabbageEra consCertTxBody ref = consTxBody mempty mempty (toSet ref) mempty SNothing (Coin 0) mempty where toSet Nothing = mempty @@ -165,7 +165,7 @@ mkPaymentTx :: Integer -> Integer -> BabbageLedgerState mk -> - Either ForgingError (AlonzoTx BabbageEra) + Either ForgingError (Core.Tx BabbageEra) mkPaymentTx inputIndex outputIndex amount fees sta = do (inputPair, _) <- resolveUTxOIndex inputIndex sta addr <- resolveAddress outputIndex sta @@ -180,7 +180,7 @@ mkPaymentTx' :: BabbageUTxOIndex -> [(BabbageUTxOIndex, MaryValue)] -> BabbageLedgerState mk -> - Either ForgingError (AlonzoTx BabbageEra) + Either ForgingError (Core.Tx BabbageEra) mkPaymentTx' inputIndex outputIndex sta = do inputPair <- fst <$> resolveUTxOIndex inputIndex sta outps <- mapM mkOuts outputIndex @@ -222,7 +222,7 @@ mkLockByScriptTx :: Integer -> Integer -> BabbageLedgerState mk -> - Either ForgingError (AlonzoTx BabbageEra) + Either ForgingError (Core.Tx BabbageEra) mkLockByScriptTx inputIndex txOutTypes amount fees sta = do (inputPair, _) <- resolveUTxOIndex inputIndex sta @@ -255,7 +255,7 @@ mkUnlockScriptTx :: Integer -> Integer -> BabbageLedgerState mk -> - Either ForgingError (AlonzoTx BabbageEra) + Either ForgingError (Core.Tx BabbageEra) mkUnlockScriptTx inputIndex colInputIndex outputIndex succeeds amount fees sta = do inputPairs <- fmap fst <$> mapM (`resolveUTxOIndex` sta) inputIndex (colInputPair, _) <- resolveUTxOIndex colInputIndex sta @@ -265,6 +265,7 @@ mkUnlockScriptTx inputIndex colInputIndex outputIndex succeeds amount fees sta = colInput = Set.singleton $ fst colInputPair output = BabbageTxOut addr (valueFromList (Coin amount) []) Alonzo.NoDatum SNothing Right + $ MkBabbageTx $ mkScriptTx succeeds (mapMaybe mkScriptInp' $ zip [0 ..] inputPairs) @@ -280,7 +281,7 @@ mkUnlockScriptTxBabbage :: Integer -> Integer -> BabbageLedgerState mk -> - Either ForgingError (AlonzoTx BabbageEra) + Either ForgingError (Core.Tx BabbageEra) mkUnlockScriptTxBabbage inputIndex colInputIndex outputIndex refInput compl succeeds amount fees sta = do inputPairs <- fmap fst <$> mapM (`resolveUTxOIndex` sta) inputIndex refInputPairs <- fmap fst <$> mapM (`resolveUTxOIndex` sta) refInput @@ -293,6 +294,7 @@ mkUnlockScriptTxBabbage inputIndex colInputIndex outputIndex refInput compl succ colInput = Set.singleton $ fst colInputPair output = BabbageTxOut addr (valueFromList (Coin amount) []) Alonzo.NoDatum SNothing Right + $ MkBabbageTx $ mkScriptTx succeeds (mapMaybe mkScriptInp' $ zip [0 ..] inputPairs) @@ -340,7 +342,7 @@ mkMAssetsScriptTx :: Bool -> Integer -> BabbageLedgerState mk -> - Either ForgingError (AlonzoTx BabbageEra) + Either ForgingError (Core.Tx BabbageEra) mkMAssetsScriptTx inputIndex colInputIndex outputIndex refInput minted succeeds fees sta = do inputPairs <- fmap fst <$> mapM (`resolveUTxOIndex` sta) inputIndex refInputPairs <- fmap fst <$> mapM (`resolveUTxOIndex` sta) refInput @@ -349,6 +351,7 @@ mkMAssetsScriptTx inputIndex colInputIndex outputIndex refInput minted succeeds let inpts = Set.fromList $ fst <$> inputPairs refInpts = Set.fromList $ fst <$> refInputPairs Right + $ MkBabbageTx $ mkScriptTx succeeds ( mapMaybe mkScriptInp' (zip [0 ..] inputPairs) @@ -364,20 +367,20 @@ mkDCertTx :: [ShelleyTxCert BabbageEra] -> Withdrawals -> Maybe TxIn -> - Either ForgingError (AlonzoTx BabbageEra) + Either ForgingError (Core.Tx BabbageEra) mkDCertTx certs wdrl ref = Right $ mkSimpleTx True $ consCertTxBody ref certs wdrl mkSimpleDCertTx :: [(StakeIndex, StakeCredential -> ShelleyTxCert BabbageEra)] -> BabbageLedgerState mk -> - Either ForgingError (AlonzoTx BabbageEra) + Either ForgingError (Core.Tx BabbageEra) mkSimpleDCertTx consDert st = do dcerts <- forM consDert $ \(stakeIndex, mkDCert) -> do cred <- resolveStakeCreds stakeIndex st pure $ mkDCert cred mkDCertTx dcerts (Withdrawals mempty) Nothing -mkDummyRegisterTx :: Int -> Int -> Either ForgingError (AlonzoTx BabbageEra) +mkDummyRegisterTx :: Int -> Int -> Either ForgingError (Core.Tx BabbageEra) mkDummyRegisterTx n m = mkDCertTx (ShelleyTxCertDelegCert . ShelleyRegCert . KeyHashObj . KeyHash . mkDummyHash (Proxy @ADDRHASH) . fromIntegral <$> [n, m]) @@ -391,7 +394,7 @@ mkDCertPoolTx :: ) ] -> BabbageLedgerState mk -> - Either ForgingError (AlonzoTx BabbageEra) + Either ForgingError (Core.Tx BabbageEra) mkDCertPoolTx consDert st = do dcerts <- forM consDert $ \(stakeIxs, poolIx, mkDCert) -> do stakeCreds <- forM stakeIxs $ \stix -> resolveStakeCreds stix st @@ -403,14 +406,15 @@ mkScriptDCertTx :: [(StakeIndex, Bool, StakeCredential -> ShelleyTxCert BabbageEra)] -> Bool -> BabbageLedgerState mk -> - Either ForgingError (AlonzoTx BabbageEra) + Either ForgingError (Core.Tx BabbageEra) mkScriptDCertTx consDert valid st = do dcerts <- forM consDert $ \(stakeIndex, _, mkDCert) -> do cred <- resolveStakeCreds stakeIndex st pure $ mkDCert cred Right $ - mkScriptTx valid (mapMaybe prepareRedeemer $ zip [0 ..] consDert) $ - consCertTxBody Nothing dcerts (Withdrawals mempty) + MkBabbageTx $ + mkScriptTx valid (mapMaybe prepareRedeemer $ zip [0 ..] consDert) $ + consCertTxBody Nothing dcerts (Withdrawals mempty) where prepareRedeemer (n, (StakeIndexScript bl, addRedeemer, _)) = if not addRedeemer @@ -426,7 +430,7 @@ mkDepositTxPools :: BabbageUTxOIndex -> Integer -> BabbageLedgerState mk -> - Either ForgingError (AlonzoTx BabbageEra) + Either ForgingError (Core.Tx BabbageEra) mkDepositTxPools inputIndex deposit sta = do (inputPair, _) <- resolveUTxOIndex inputIndex sta @@ -437,17 +441,18 @@ mkDepositTxPools inputIndex deposit sta = do mkDCertTxPools :: BabbageLedgerState mk -> - Either ForgingError (AlonzoTx BabbageEra) + Either ForgingError (Core.Tx BabbageEra) mkDCertTxPools sta = Right $ mkSimpleTx True $ consCertTxBody Nothing (allPoolStakeCert sta) (Withdrawals mempty) -mkSimpleTx :: Bool -> BabbageTxBody BabbageEra -> AlonzoTx BabbageEra +mkSimpleTx :: Bool -> TxBody BabbageEra -> Core.Tx BabbageEra mkSimpleTx valid txBody = - AlonzoTx - { body = txBody - , wits = mempty - , isValid = IsValid valid - , auxiliaryData = maybeToStrictMaybe Nothing - } + MkBabbageTx $ + AlonzoTx + { atBody = txBody + , atWits = mempty + , atIsValid = IsValid valid + , atAuxData = maybeToStrictMaybe Nothing + } consPoolParamsTwoOwners :: [StakeCredential] -> @@ -457,16 +462,16 @@ consPoolParamsTwoOwners [rwCred, KeyHashObj owner0, KeyHashObj owner1] poolId = ShelleyTxCertPool $ RegPool $ consPoolParams poolId rwCred [owner0, owner1] consPoolParamsTwoOwners _ _ = panic "expected 2 pool owners" -mkUTxOBabbage :: AlonzoTx BabbageEra -> [(TxIn, BabbageTxOut BabbageEra)] +mkUTxOBabbage :: Core.Tx BabbageEra -> [(TxIn, BabbageTxOut BabbageEra)] mkUTxOBabbage = mkUTxOAlonzo mkUTxOCollBabbage :: - BabbageEraTxBody era => - AlonzoTx era -> + (BabbageEraTxBody era, EraTx era) => + Core.Tx era -> [(TxIn, TxOut era)] -mkUTxOCollBabbage tx = Map.toList $ unUTxO $ collOuts $ getField @"body" tx +mkUTxOCollBabbage tx = Map.toList $ unUTxO $ collOuts (tx ^. bodyTxL) -emptyTxBody :: BabbageTxBody BabbageEra +emptyTxBody :: TxBody BabbageEra emptyTxBody = BabbageTxBody mempty @@ -486,16 +491,17 @@ emptyTxBody = Strict.SNothing (Strict.SJust Testnet) -emptyTx :: AlonzoTx BabbageEra +emptyTx :: Core.Tx BabbageEra emptyTx = - AlonzoTx - { body = emptyTxBody - , wits = mempty - , isValid = IsValid True - , auxiliaryData = maybeToStrictMaybe Nothing - } - -mkParamUpdateTx :: Either ForgingError (AlonzoTx BabbageEra) + MkBabbageTx $ + AlonzoTx + { atBody = emptyTxBody + , atWits = mempty + , atIsValid = IsValid True + , atAuxData = maybeToStrictMaybe Nothing + } + +mkParamUpdateTx :: Either ForgingError (Core.Tx BabbageEra) mkParamUpdateTx = Right (mkSimpleTx True txBody) where txBody = @@ -530,7 +536,7 @@ mkFullTx :: Int -> Integer -> BabbageLedgerState mk -> - Either ForgingError (AlonzoTx BabbageEra) + Either ForgingError (Core.Tx BabbageEra) mkFullTx n m sta = do inputPairs <- fmap fst <$> mapM (`resolveUTxOIndex` sta) inps let rdmrs = mapMaybe mkScriptInp' $ zip [0 ..] inputPairs @@ -538,12 +544,13 @@ mkFullTx n m sta = do refInputPairs <- fmap fst <$> mapM (`resolveUTxOIndex` sta) refInps colInput <- Set.singleton . fst . fst <$> resolveUTxOIndex colInps sta Right $ - AlonzoTx - { body = txBody (mkInps inputPairs) (mkInps refInputPairs) colInput - , wits = witnesses - , isValid = IsValid True - , auxiliaryData = Strict.SJust auxiliaryData' - } + MkBabbageTx $ + AlonzoTx + { atBody = txBody (mkInps inputPairs) (mkInps refInputPairs) colInput + , atWits = witnesses + , atIsValid = IsValid True + , atAuxData = Strict.SJust auxiliaryData' + } where mkInps ins = Set.fromList $ fst <$> ins txBody ins cols ref = diff --git a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Conway.hs b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Conway.hs index 24ca8245f..5c8eeb378 100644 --- a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Conway.hs +++ b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Conway.hs @@ -70,25 +70,25 @@ import Cardano.Ledger.Allegra.Scripts import Cardano.Ledger.Alonzo.Scripts import Cardano.Ledger.Alonzo.Tx (IsValid (..)) import Cardano.Ledger.Alonzo.TxAuxData (AlonzoTxAuxData (..), mkAlonzoTxAuxData) +import qualified Cardano.Ledger.Babbage.Core as Core import Cardano.Ledger.Babbage.TxOut (BabbageEraTxOut, BabbageTxOut (..)) import Cardano.Ledger.BaseTypes import Cardano.Ledger.Binary (Sized (..)) import Cardano.Ledger.Coin (Coin (..)) import qualified Cardano.Ledger.Conway.Governance as Governance import Cardano.Ledger.Conway.Scripts -import Cardano.Ledger.Conway.Tx (AlonzoTx (..)) -import Cardano.Ledger.Conway.TxBody (ConwayTxBody (..)) +import Cardano.Ledger.Conway.Tx (AlonzoTx (..), Tx (..)) +import Cardano.Ledger.Conway.TxBody (TxBody (..)) import Cardano.Ledger.Conway.TxCert hiding (mkDelegTxCert) import Cardano.Ledger.Core (ADDRHASH) -import qualified Cardano.Ledger.Core as Core import Cardano.Ledger.Credential (Credential (..), StakeCredential, StakeReference (..)) import Cardano.Ledger.Keys (KeyHash (..), KeyRole (..)) import Cardano.Ledger.Mary.Value (MaryValue (..), MultiAsset (..), PolicyID (..), valueFromList) import Cardano.Ledger.Plutus.Data import Cardano.Ledger.Plutus.Language (Language (..)) -import Cardano.Ledger.Shelley.LedgerState (certPStateL) import qualified Cardano.Ledger.Shelley.LedgerState as LedgerState import Cardano.Ledger.Shelley.TxAuxData (Metadatum (..)) +import Cardano.Ledger.State import Cardano.Ledger.TxIn (TxIn (..)) import Cardano.Ledger.Val (Val (..), coin) import Cardano.Mock.Forging.Tx.Alonzo ( @@ -133,7 +133,7 @@ consTxBody :: [ConwayTxCert ConwayEra] -> Withdrawals -> Coin -> - ConwayTxBody ConwayEra + TxBody ConwayEra consTxBody ins cols ref outs colOut fees minted certs withdrawals donation = ConwayTxBody { ctbSpendInputs = ins @@ -161,7 +161,7 @@ consCertTxBody :: Maybe TxIn -> [ConwayTxCert ConwayEra] -> Withdrawals -> - ConwayTxBody ConwayEra + TxBody ConwayEra consCertTxBody ref certs withdrawals = consTxBody mempty @@ -200,7 +200,7 @@ mkPaymentTx :: Integer -> Integer -> ConwayLedgerState mk -> - Either ForgingError (AlonzoTx ConwayEra) + Either ForgingError (Core.Tx ConwayEra) mkPaymentTx inputIndex outputIndex amount = mkPaymentTx' inputIndex outputIndices where @@ -212,7 +212,7 @@ mkPaymentTx' :: Integer -> Integer -> ConwayLedgerState mk -> - Either ForgingError (AlonzoTx ConwayEra) + Either ForgingError (Core.Tx ConwayEra) mkPaymentTx' inputIndex outputIndices fees donation state' = do (inputPair, _) <- resolveUTxOIndex inputIndex state' outputs <- mapM mkOutputs outputIndices @@ -243,7 +243,7 @@ mkPaymentTx' inputIndex outputIndices fees donation state' = do addr <- resolveAddress outIx state' pure (BabbageTxOut addr val NoDatum SNothing) -mkDonationTx :: Coin -> AlonzoTx ConwayEra +mkDonationTx :: Coin -> Core.Tx ConwayEra mkDonationTx amount = mkSimpleTx True txBody where txBody = mkDummyTxBody {ctbTreasuryDonation = amount} @@ -254,7 +254,7 @@ mkLockByScriptTx :: Integer -> Integer -> ConwayLedgerState mk -> - Either ForgingError (AlonzoTx ConwayEra) + Either ForgingError (Core.Tx ConwayEra) mkLockByScriptTx inputIndex txOutTypes amount fees state' = do (inputPair, _) <- resolveUTxOIndex inputIndex state' @@ -288,7 +288,7 @@ mkUnlockScriptTx :: Integer -> Integer -> ConwayLedgerState mk -> - Either ForgingError (AlonzoTx ConwayEra) + Either ForgingError (Core.Tx ConwayEra) mkUnlockScriptTx inputIndex colInputIndex outputIndex = mkUnlockScriptTx' inputIndex colInputIndex outputIndex mempty Nothing @@ -302,7 +302,7 @@ mkUnlockScriptTxBabbage :: Integer -> Integer -> ConwayLedgerState mk -> - Either ForgingError (AlonzoTx ConwayEra) + Either ForgingError (Core.Tx ConwayEra) mkUnlockScriptTxBabbage inputIndex colInputIndex outputIndex refInput compl succeeds amount fees state' = do let colTxOutType = if compl @@ -325,7 +325,7 @@ mkDCertTx :: [ConwayTxCert ConwayEra] -> Withdrawals -> Maybe TxIn -> - Either ForgingError (AlonzoTx ConwayEra) + Either ForgingError (Core.Tx ConwayEra) mkDCertTx certs wdrl ref = Right (mkSimpleTx True $ consCertTxBody ref certs wdrl) mkDCertPoolTx :: @@ -337,7 +337,7 @@ mkDCertPoolTx :: ) ] -> ConwayLedgerState mk -> - Either ForgingError (AlonzoTx ConwayEra) + Either ForgingError (Core.Tx ConwayEra) mkDCertPoolTx consDCert state' = do dcerts <- forM consDCert $ \(stakeIxs, poolIx, mkDCert) -> do stakeCreds <- forM stakeIxs $ \stakeIx -> resolveStakeCreds stakeIx state' @@ -346,38 +346,40 @@ mkDCertPoolTx consDCert state' = do mkDCertTx dcerts (Withdrawals mempty) Nothing -mkDCertTxPools :: ConwayLedgerState mk -> Either ForgingError (AlonzoTx ConwayEra) +mkDCertTxPools :: ConwayLedgerState mk -> Either ForgingError (Core.Tx ConwayEra) mkDCertTxPools state' = Right $ mkSimpleTx True $ consCertTxBody Nothing (allPoolStakeCert' state') (Withdrawals mempty) -mkSimpleTx :: Bool -> ConwayTxBody ConwayEra -> AlonzoTx ConwayEra +mkSimpleTx :: Bool -> TxBody ConwayEra -> Core.Tx ConwayEra mkSimpleTx isValid' txBody = - AlonzoTx - { body = txBody - , wits = mempty - , isValid = IsValid isValid' - , auxiliaryData = maybeToStrictMaybe Nothing - } + MkConwayTx $ + AlonzoTx + { atBody = txBody + , atWits = mempty + , atIsValid = IsValid isValid' + , atAuxData = maybeToStrictMaybe Nothing + } mkAuxDataTx :: Bool -> - ConwayTxBody ConwayEra -> + TxBody ConwayEra -> Map Word64 Metadatum -> - AlonzoTx ConwayEra + Core.Tx ConwayEra mkAuxDataTx isValid' txBody auxData = - AlonzoTx - { body = txBody - , wits = mempty - , isValid = IsValid isValid' - , auxiliaryData = SJust (mkAlonzoTxAuxData auxData []) - } + MkConwayTx $ + AlonzoTx + { atBody = txBody + , atWits = mempty + , atIsValid = IsValid isValid' + , atAuxData = SJust (mkAlonzoTxAuxData auxData []) + } mkSimpleDCertTx :: [(StakeIndex, StakeCredential -> ConwayTxCert ConwayEra)] -> ConwayLedgerState mk -> - Either ForgingError (AlonzoTx ConwayEra) + Either ForgingError (Core.Tx ConwayEra) mkSimpleDCertTx consDCert st = do dcerts <- forM consDCert $ \(stakeIndex, mkDCert) -> do cred <- resolveStakeCreds stakeIndex st @@ -388,15 +390,16 @@ mkScriptDCertTx :: [(StakeIndex, Bool, StakeCredential -> ConwayTxCert ConwayEra)] -> Bool -> ConwayLedgerState mk -> - Either ForgingError (AlonzoTx ConwayEra) + Either ForgingError (Core.Tx ConwayEra) mkScriptDCertTx consCert isValid' state' = do dcerts <- forM consCert $ \(stakeIndex, _, mkDCert) -> do cred <- resolveStakeCreds stakeIndex state' pure $ mkDCert cred pure $ - mkScriptTx isValid' (mapMaybe prepareRedeemer . zip [0 ..] $ consCert) $ - consCertTxBody Nothing dcerts (Withdrawals mempty) + MkConwayTx $ + mkScriptTx isValid' (mapMaybe prepareRedeemer . zip [0 ..] $ consCert) $ + consCertTxBody Nothing dcerts (Withdrawals mempty) where prepareRedeemer (n, (StakeIndexScript bl, shouldAddRedeemer, _)) | not shouldAddRedeemer = Nothing @@ -417,7 +420,7 @@ mkMultiAssetsScriptTx :: Bool -> Integer -> ConwayLedgerState mk -> - Either ForgingError (AlonzoTx ConwayEra) + Either ForgingError (Core.Tx ConwayEra) mkMultiAssetsScriptTx inputIx colInputIx outputIx refInput minted succeeds fees state' = do inputs <- mapM (`resolveUTxOIndex` state') inputIx refs <- mapM (`resolveUTxOIndex` state') refInput @@ -429,18 +432,19 @@ mkMultiAssetsScriptTx inputIx colInputIx outputIx refInput minted succeeds fees colInputs' = Set.singleton $ fst colInput pure $ - mkScriptTx succeeds (mkScriptInps (map fst inputs) ++ mkScriptMint' minted) $ - consTxBody - inputs' - colInputs' - refInputs' - (StrictSeq.fromList outputs) - SNothing - (Coin fees) - mempty - mempty -- TODO[sgillespie]: minted? - (Withdrawals mempty) - (Coin 0) + MkConwayTx $ + mkScriptTx succeeds (mkScriptInps (map fst inputs) ++ mkScriptMint' minted) $ + consTxBody + inputs' + colInputs' + refInputs' + (StrictSeq.fromList outputs) + SNothing + (Coin fees) + mempty + mempty -- TODO[sgillespie]: minted? + (Withdrawals mempty) + (Coin 0) where mkOuts (outIx, val) = do addr <- resolveAddress outIx state' @@ -455,7 +459,7 @@ mkDepositTxPools :: ConwayUTxOIndex -> Integer -> ConwayLedgerState mk -> - Either ForgingError (AlonzoTx ConwayEra) + Either ForgingError (Core.Tx ConwayEra) mkDepositTxPools inputIndex deposit state' = do (inputPair, _) <- resolveUTxOIndex inputIndex state' @@ -484,7 +488,7 @@ mkDepositTxPools inputIndex deposit state' = do mkRegisterDRepTx :: Credential 'DRepRole -> - Either ForgingError (AlonzoTx ConwayEra) + Either ForgingError (Core.Tx ConwayEra) mkRegisterDRepTx cred = mkDCertTx [cert] (Withdrawals mempty) Nothing where cert = ConwayTxCertGov (ConwayRegDRep cred deposit SNothing) @@ -493,12 +497,12 @@ mkRegisterDRepTx cred = mkDCertTx [cert] (Withdrawals mempty) Nothing mkCommitteeAuthTx :: Credential 'ColdCommitteeRole -> Credential 'HotCommitteeRole -> - Either ForgingError (AlonzoTx ConwayEra) + Either ForgingError (Core.Tx ConwayEra) mkCommitteeAuthTx cold hot = mkDCertTx [cert] (Withdrawals mempty) Nothing where cert = ConwayTxCertGov (ConwayAuthCommitteeHotKey cold hot) -mkDummyRegisterTx :: Int -> Int -> Either ForgingError (AlonzoTx ConwayEra) +mkDummyRegisterTx :: Int -> Int -> Either ForgingError (Core.Tx ConwayEra) mkDummyRegisterTx n m = mkDCertTx consDelegCert (Withdrawals mempty) Nothing where consDelegCert = @@ -542,9 +546,9 @@ mkTxDelegCert :: mkTxDelegCert f = ConwayTxCertDeleg . f mkAddCommitteeTx :: - Maybe (Governance.GovPurposeId 'Governance.CommitteePurpose ConwayEra) -> + Maybe (Governance.GovPurposeId 'Governance.CommitteePurpose) -> Credential 'ColdCommitteeRole -> - AlonzoTx ConwayEra + Core.Tx ConwayEra mkAddCommitteeTx prevGovAction cred = mkGovActionProposalTx govAction where govAction = Governance.UpdateCommittee prevGovAction' mempty newMembers threshold @@ -554,7 +558,7 @@ mkAddCommitteeTx prevGovAction cred = mkGovActionProposalTx govAction mkNewConstitutionTx :: Anchor -> - AlonzoTx ConwayEra + Core.Tx ConwayEra mkNewConstitutionTx anchor = mkGovActionProposalTx govAction where govAction = Governance.NewConstitution SNothing constitution @@ -563,34 +567,34 @@ mkNewConstitutionTx anchor = mkGovActionProposalTx govAction mkTreasuryWithdrawalTx :: RewardAccount -> Coin -> - AlonzoTx ConwayEra + Core.Tx ConwayEra mkTreasuryWithdrawalTx rewardAccount amount = mkGovActionProposalTx govAction where govAction = Governance.TreasuryWithdrawals withdrawals hashProtection withdrawals = Map.singleton rewardAccount amount hashProtection = SNothing -mkParamChangeTx :: AlonzoTx ConwayEra +mkParamChangeTx :: Core.Tx ConwayEra mkParamChangeTx = mkGovActionProposalTx govAction where govAction = Governance.ParameterChange SNothing paramUpdate hasProtection paramUpdate = Core.emptyPParamsUpdate & Core.ppuMaxTxSizeL .~ SJust 32_000 hasProtection = SNothing -mkHardForkInitTx :: AlonzoTx ConwayEra +mkHardForkInitTx :: Core.Tx ConwayEra mkHardForkInitTx = mkGovActionProposalTx govAction where govAction = Governance.HardForkInitiation SNothing protoVersion protoVersion = ProtVer (natVersion @11) 0 -mkInfoTx :: AlonzoTx ConwayEra +mkInfoTx :: Core.Tx ConwayEra mkInfoTx = mkGovActionProposalTx govAction where govAction = Governance.InfoAction mkGovActionProposalTx :: Governance.GovAction ConwayEra -> - AlonzoTx ConwayEra + Core.Tx ConwayEra mkGovActionProposalTx govAction = mkSimpleTx True txBody where txBody = mkDummyTxBody {ctbProposalProcedures = OSet.singleton proposal} @@ -613,14 +617,14 @@ mkGovActionProposalTx govAction = mkSimpleTx True txBody mkGovVoteYesTx :: Governance.GovActionId -> [Governance.Voter] -> - AlonzoTx ConwayEra + Core.Tx ConwayEra mkGovVoteYesTx govAction = mkGovVoteTx govAction . Map.fromList . map (,Governance.VoteYes) mkGovVoteTx :: Governance.GovActionId -> Map Governance.Voter Governance.Vote -> - AlonzoTx ConwayEra + Core.Tx ConwayEra mkGovVoteTx govAction votes = mkSimpleTx True txBody where txBody = mkDummyTxBody {ctbVotingProcedures = Governance.VotingProcedures votes'} @@ -632,7 +636,7 @@ mkGovVoteTx govAction votes = mkSimpleTx True txBody , Governance.vProcAnchor = SNothing } -mkDummyTxBody :: ConwayTxBody ConwayEra +mkDummyTxBody :: TxBody ConwayEra mkDummyTxBody = consTxBody mempty @@ -650,7 +654,7 @@ mkFullTx :: Int -> Integer -> ConwayLedgerState mk -> - Either ForgingError (AlonzoTx ConwayEra) + Either ForgingError (Core.Tx ConwayEra) mkFullTx n m state' = do inputPairs <- fmap fst <$> mapM (`resolveUTxOIndex` state') inputs let redeemers = mkScriptInps inputPairs @@ -666,16 +670,17 @@ mkFullTx n m state' = do collateralInput <- Set.singleton . fst . fst <$> resolveUTxOIndex collateralInputs state' pure $ - AlonzoTx - { body = - txBody - (mkInputs inputPairs) - (mkInputs refInputPairs) - collateralInput - , wits = witnesses - , isValid = IsValid True - , auxiliaryData = SJust auxiliaryData' - } + MkConwayTx $ + AlonzoTx + { atBody = + txBody + (mkInputs inputPairs) + (mkInputs refInputPairs) + collateralInput + , atWits = witnesses + , atIsValid = IsValid True + , atAuxData = SJust auxiliaryData' + } where inputs = [UTxOIndex $ n * 3 + 0] refInputs = [UTxOIndex $ n * 3 + 1] @@ -827,18 +832,19 @@ consPaymentTxBody :: Coin -> MultiAsset -> Coin -> - ConwayTxBody ConwayEra + TxBody ConwayEra consPaymentTxBody ins cols ref outs colOut fees minted = consTxBody ins cols ref outs colOut fees minted mempty (Withdrawals mempty) mkUTxOConway :: - AlonzoTx ConwayEra -> + Core.Tx ConwayEra -> [(TxIn, BabbageTxOut ConwayEra)] mkUTxOConway = mkUTxOAlonzo mkUTxOCollConway :: - AlonzoTx ConwayEra -> - [(TxIn, BabbageTxOut ConwayEra)] + (Core.BabbageEraTxBody era, Core.EraTx era) => + Core.Tx era -> + [(TxIn, Core.TxOut era)] mkUTxOCollConway = Babbage.mkUTxOCollBabbage mkOutFromType :: @@ -884,7 +890,7 @@ mkUnlockScriptTx' :: Integer -> Integer -> ConwayLedgerState mk -> - Either ForgingError (AlonzoTx ConwayEra) + Either ForgingError (Core.Tx ConwayEra) mkUnlockScriptTx' inputIndex colInputIndex outputIndex refInput colOut succeeds amount fees state' = do inputPairs <- map fst <$> mapM (`resolveUTxOIndex` state') inputIndex refInputPairs <- map fst <$> mapM (`resolveUTxOIndex` state') refInput @@ -902,16 +908,17 @@ mkUnlockScriptTx' inputIndex colInputIndex outputIndex refInput colOut succeeds SNothing pure $ - mkScriptTx succeeds (mkScriptInps inputPairs) $ - consPaymentTxBody - inputs - colInputs - refInputs - (StrictSeq.singleton output) - (maybeToStrictMaybe colOut) - (Coin fees) - mempty - (Coin 0) + MkConwayTx $ + mkScriptTx succeeds (mkScriptInps inputPairs) $ + consPaymentTxBody + inputs + colInputs + refInputs + (StrictSeq.singleton output) + (maybeToStrictMaybe colOut) + (Coin fees) + mempty + (Coin 0) allPoolStakeCert' :: ConwayLedgerState mk -> [ConwayTxCert ConwayEra] allPoolStakeCert' st = map (mkRegTxCert SNothing) (getCreds st) @@ -919,7 +926,8 @@ allPoolStakeCert' st = map (mkRegTxCert SNothing) (getCreds st) getCreds = nub . concatMap getPoolStakeCreds . Map.elems . stakePoolParams stakePoolParams = - LedgerState.psStakePoolParams + Map.mapWithKey stakePoolStateToPoolParams + . LedgerState.psStakePools . (^. certPStateL) . LedgerState.lsCertState . LedgerState.esLState diff --git a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Conway/Scenarios.hs b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Conway/Scenarios.hs index 78328a057..93c2e420e 100644 --- a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Conway/Scenarios.hs +++ b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Conway/Scenarios.hs @@ -16,7 +16,6 @@ module Cardano.Mock.Forging.Tx.Conway.Scenarios ( ) where import Cardano.Ledger.Address (Addr (..), Withdrawals (..)) -import Cardano.Ledger.Alonzo.Tx (AlonzoTx (..)) import Cardano.Ledger.BaseTypes (Network (..)) import Cardano.Ledger.Coin import Cardano.Ledger.Conway.TxCert (Delegatee (..)) @@ -111,7 +110,7 @@ registerDRepAndDelegateVotes' :: Credential 'DRepRole -> StakeIndex -> Conway.ConwayLedgerState mk -> - Either ForgingError [AlonzoTx ConwayEra] + Either ForgingError [Tx ConwayEra] registerDRepAndDelegateVotes' drepId stakeIx ledger = do stakeCreds <- resolveStakeCreds stakeIx ledger diff --git a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Generic.hs b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Generic.hs index 5dc6c4d78..a8aae2623 100644 --- a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Generic.hs +++ b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Generic.hs @@ -44,11 +44,10 @@ import qualified Cardano.Ledger.Core as Core import Cardano.Ledger.Credential import Cardano.Ledger.Hashes (ADDRHASH, ScriptHash (ScriptHash)) import Cardano.Ledger.Keys (KeyHash (..), KeyRole (..), hashWithSerialiser) -import Cardano.Ledger.PoolParams import Cardano.Ledger.Shelley.LedgerState hiding (LedgerState) import Cardano.Ledger.Shelley.TxCert +import Cardano.Ledger.State import Cardano.Ledger.TxIn (TxIn (..)) -import qualified Cardano.Ledger.UMap as UMap import Cardano.Mock.Forging.Crypto import Cardano.Mock.Forging.Tx.Alonzo.ScriptsExamples import Cardano.Mock.Forging.Types @@ -128,29 +127,26 @@ resolveStakeCreds :: LedgerState (ShelleyBlock p era) mk -> Either ForgingError StakeCredential resolveStakeCreds indx st = case indx of - StakeIndex n -> toEither $ fst <$> (rewardAccs !? n) + StakeIndex n -> toEither $ fst <$> (Map.toList rewardAccs !? n) StakeAddress addr -> Right addr StakeIndexNew n -> toEither $ unregisteredStakeCredentials !? n StakeIndexScript bl -> Right $ if bl then alwaysSucceedsScriptStake else alwaysFailsScriptStake StakeIndexPoolLeader poolIndex -> Right $ raCredential $ ppRewardAccount $ findPoolParams poolIndex StakeIndexPoolMember n poolIndex -> Right $ resolvePoolMember n poolIndex where - rewardAccs = - Map.toList $ - UMap.rewardMap $ - dsUnified dstate + rewardAccs :: Map StakeCredential (AccountState era) + rewardAccs = dsAccounts dstate ^. accountsMapL poolParams :: Map (KeyHash 'StakePool) PoolParams poolParams = - psStakePoolParams $ - let certState = - lsCertState $ - esLState $ - nesEs $ - Consensus.shelleyLedgerState st - in certState ^. certPStateL - - delegs = UMap.sPoolMap $ dsUnified dstate + let certState = + lsCertState $ + esLState $ + nesEs $ + Consensus.shelleyLedgerState st + in Map.mapWithKey stakePoolStateToPoolParams $ psStakePools (certState ^. certPStateL) -- . psStakePoolsL + delegs :: Map StakeCredential (KeyHash 'StakePool) + delegs = Map.mapMaybe (^. stakePoolDelegationAccountStateL) rewardAccs dstate = let certState = @@ -185,28 +181,24 @@ resolvePool pix st = case pix of PoolIndexNew n -> unregisteredPools !! n where poolParams = - Map.elems $ - psStakePoolParams $ - let certState = - lsCertState $ - esLState $ - nesEs $ - Consensus.shelleyLedgerState st - in certState ^. certPStateL + let certState = + lsCertState $ + esLState $ + nesEs $ + Consensus.shelleyLedgerState st + in Map.elems $ Map.mapWithKey stakePoolStateToPoolParams (certState ^. certPStateL . psStakePoolsL) allPoolStakeCert :: EraCertState era => LedgerState (ShelleyBlock p era) mk -> [ShelleyTxCert era] allPoolStakeCert st = ShelleyTxCertDelegCert . ShelleyRegCert <$> nub creds where poolParms = - Map.elems $ - psStakePoolParams $ - let certState = - lsCertState $ - esLState $ - nesEs $ - Consensus.shelleyLedgerState st - in certState ^. certPStateL + let certState = + lsCertState $ + esLState $ + nesEs $ + Consensus.shelleyLedgerState st + in Map.elems $ Map.mapWithKey stakePoolStateToPoolParams (certState ^. certPStateL . psStakePoolsL) creds = concatMap getPoolStakeCreds poolParms getPoolStakeCreds :: PoolParams -> [StakeCredential] diff --git a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Shelley.hs b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Shelley.hs index ff3cbe7be..95ec89c7b 100644 --- a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Shelley.hs +++ b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Shelley.hs @@ -38,7 +38,7 @@ type ShelleyUTxOIndex = UTxOIndex ShelleyEra type ShelleyLedgerState = LedgerState (ShelleyBlock TPraosStandard ShelleyEra) -type ShelleyTx = ShelleyTx.ShelleyTx ShelleyEra +type ShelleyTx = Core.Tx ShelleyEra mkPaymentTx :: ShelleyUTxOIndex -> @@ -62,12 +62,13 @@ mkPaymentTx inputIndex outputIndex amount fees st = do mkDCertTxPools :: ShelleyLedgerState mk -> Either ForgingError ShelleyTx mkDCertTxPools sta = Right $ mkSimpleTx $ consCertTxBody (allPoolStakeCert sta) (Withdrawals mempty) -mkSimpleTx :: ShelleyTxBody ShelleyEra -> ShelleyTx +mkSimpleTx :: TxBody ShelleyEra -> ShelleyTx mkSimpleTx txBody = - ShelleyTx.ShelleyTx - txBody - mempty - (maybeToStrictMaybe Nothing) + ShelleyTx.MkShelleyTx $ + ShelleyTx.ShelleyTx + txBody + mempty + (maybeToStrictMaybe Nothing) mkDCertTx :: [ShelleyTxCert ShelleyEra] -> Withdrawals -> Either ForgingError ShelleyTx mkDCertTx certs wdrl = Right $ mkSimpleTx $ consCertTxBody certs wdrl @@ -86,10 +87,10 @@ consPaymentTxBody :: Set TxIn -> StrictSeq (ShelleyTxOut ShelleyEra) -> Coin -> - ShelleyTxBody ShelleyEra + TxBody ShelleyEra consPaymentTxBody ins outs fees = consTxBody ins outs fees mempty (Withdrawals mempty) -consCertTxBody :: [ShelleyTxCert ShelleyEra] -> Withdrawals -> ShelleyTxBody ShelleyEra +consCertTxBody :: [ShelleyTxCert ShelleyEra] -> Withdrawals -> TxBody ShelleyEra consCertTxBody = consTxBody mempty mempty (Coin 0) consTxBody :: @@ -98,7 +99,7 @@ consTxBody :: Coin -> [ShelleyTxCert ShelleyEra] -> Withdrawals -> - ShelleyTxBody ShelleyEra + TxBody ShelleyEra consTxBody ins outs fees certs wdrl = ShelleyTxBody ins diff --git a/cardano-chain-gen/test/Main.hs b/cardano-chain-gen/test/Main.hs index 9a9e4ffda..338ea20c7 100644 --- a/cardano-chain-gen/test/Main.hs +++ b/cardano-chain-gen/test/Main.hs @@ -3,7 +3,7 @@ import Cardano.Prelude (Text) import Control.Monad (when, (>=>)) import Data.Maybe (isNothing) import MigrationValidations (KnownMigration (..), knownMigrations) -import System.Directory (getCurrentDirectory) +import System.Directory (getCurrentDirectory) -- , setCurrentDirectory) import System.Environment (lookupEnv, setEnv) import System.FilePath (()) import qualified Test.Cardano.Db.Mock.Property.Property as Property @@ -20,6 +20,7 @@ main = do mPgPassFile <- lookupEnv "PGPASSFILE" when (isNothing mPgPassFile) $ do currentDir <- getCurrentDirectory + print currentDir setEnv "PGPASSFILE" (currentDir "test/testfiles/pgpass-testing") withIOManager $ tests >=> defaultMain diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Config.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Config.hs index 6190c4912..7ba73d8e2 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Config.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Config.hs @@ -19,7 +19,7 @@ module Test.Cardano.Db.Mock.Config ( getPoolLayer, -- * Configs - mkConfig, + withConfig, mkSyncNodeConfig, mkConfigDir, configPruneForceTxIn, @@ -164,7 +164,7 @@ mkMutableDir :: FilePath -> FilePath mkMutableDir testLabel = rootTestDir "temp" testLabel mkConfigDir :: FilePath -> FilePath -mkConfigDir config = rootTestDir config +mkConfigDir config = "cardano-chain-gen" rootTestDir config fingerprintRoot :: FilePath fingerprintRoot = rootTestDir "fingerprint" @@ -250,16 +250,28 @@ getPoolLayer env = do nullTracer pool -mkConfig :: FilePath -> FilePath -> CommandLineArgs -> SyncNodeConfig -> IO Config -mkConfig staticDir mutableDir cmdLineArgs config = do +withConfig :: FilePath -> FilePath -> CommandLineArgs -> SyncNodeConfig -> (Config -> IO a) -> IO a +withConfig staticDir mutableDir cmdLineArgs config action = do let cfgDir = mkConfigDir staticDir genCfg <- runOrThrowIO $ runExceptT (readCardanoGenesisConfig config) let (pInfoDbSync, _) = mkProtocolInfoCardano genCfg [] creds <- mkShelleyCredentials $ cfgDir "pools" "bulk1.creds" - let (pInfoForger, forging) = mkProtocolInfoCardano genCfg creds - forging' <- forging - syncPars <- mkSyncNodeParams staticDir mutableDir cmdLineArgs - pure $ Config (Consensus.pInfoConfig pInfoDbSync) pInfoDbSync pInfoForger forging' syncPars + let (pInfoForger, mkForgings) = mkProtocolInfoCardano genCfg [(head creds)] + bracket + (allocateRes mkForgings) + (mapM finalize) + ( \forgings -> do + syncPars <- mkSyncNodeParams staticDir mutableDir cmdLineArgs + let cfg = Config (Consensus.pInfoConfig pInfoDbSync) pInfoDbSync pInfoForger forgings syncPars + action cfg + ) + where + allocateRes mkForgings = do + forgings <- mkForgings + -- _ <- throwIO $ userError "A" + forgings' <- mapM mkBlockForging forgings + -- _ <- throwIO $ userError "B" + pure forgings' mkSyncNodeConfig :: FilePath -> CommandLineArgs -> IO SyncNodeConfig mkSyncNodeConfig configFilePath cmdLineArgs = @@ -582,44 +594,44 @@ withFullConfig' WithConfigArgs {..} cmdLineArgs mSyncNodeConfig configFilePath t pure $ updateFn initConfigFile Nothing -> mkSyncNodeConfig configFilePath cmdLineArgs - cfg <- mkConfig configFilePath mutableDir cmdLineArgs syncNodeConfig - fingerFile <- if hasFingerprint then Just <$> prepareFingerprintFile testLabelFilePath else pure Nothing - let dbsyncParams = syncNodeParams cfg - trce <- - if shouldLog - then configureLogging syncNodeConfig "db-sync-node" - else pure nullTracer - -- runDbSync is partially applied so we can pass in syncNodeParams at call site / within tests - let partialDbSyncRun params cfg' = runDbSync emptyMetricsSetters iom trce params cfg' True - initSt = Consensus.pInfoInitLedger $ protocolInfo cfg - - withInterpreter (protocolInfoForging cfg) (protocolInfoForger cfg) nullTracer fingerFile $ \interpreter -> do - -- TODO: get 42 from config - withServerHandle @CardanoBlock - iom - (topLevelConfig cfg) - (forgetLedgerTables initSt, projectLedgerTables initSt) - (NetworkMagic 42) - (unSocketPath (enpSocketPath $ syncNodeParams cfg)) - $ \mockServer -> - -- we dont fork dbsync here. Just prepare it as an action - withDBSyncEnv (mkDBSyncEnv dbsyncParams syncNodeConfig partialDbSyncRun) $ \dbSyncEnv -> do - let pgPass = getDBSyncPGPass dbSyncEnv - tableNames <- DB.getAllTableNames pgPass - -- We only want to create the table schema once for the tests so here we check - -- if there are any table names. - if null tableNames || shouldDropDB - then void . hSilence [stderr] $ DB.recreateDB pgPass - else void . hSilence [stderr] $ DB.truncateTables pgPass tableNames - - -- Run migrations synchronously first - runMigrationsOnly - migr - trce - (syncNodeParams cfg) - syncNodeConfig - - action interpreter mockServer dbSyncEnv + withConfig configFilePath mutableDir cmdLineArgs syncNodeConfig $ \cfg -> do + fingerFile <- if hasFingerprint then Just <$> prepareFingerprintFile testLabelFilePath else pure Nothing + let dbsyncParams = syncNodeParams cfg + trce <- + if shouldLog + then configureLogging syncNodeConfig "db-sync-node" + else pure nullTracer + -- runDbSync is partially applied so we can pass in syncNodeParams at call site / within tests + let partialDbSyncRun params cfg' = runDbSync emptyMetricsSetters iom trce params cfg' True + initSt = Consensus.pInfoInitLedger $ protocolInfo cfg + + withInterpreter (protocolInfoForging cfg) (protocolInfoForger cfg) nullTracer fingerFile $ \interpreter -> do + -- TODO: get 42 from config + withServerHandle @CardanoBlock + iom + (topLevelConfig cfg) + (forgetLedgerTables initSt, projectLedgerTables initSt) + (NetworkMagic 42) + (unSocketPath (enpSocketPath $ syncNodeParams cfg)) + $ \mockServer -> + -- we dont fork dbsync here. Just prepare it as an action + withDBSyncEnv (mkDBSyncEnv dbsyncParams syncNodeConfig partialDbSyncRun) $ \dbSyncEnv -> do + let pgPass = getDBSyncPGPass dbSyncEnv + tableNames <- DB.getAllTableNames pgPass + -- We only want to create the table schema once for the tests so here we check + -- if there are any table names. + if null tableNames || shouldDropDB + then void . hSilence [stderr] $ DB.recreateDB pgPass + else void . hSilence [stderr] $ DB.truncateTables pgPass tableNames + + -- Run migrations synchronously first + runMigrationsOnly + migr + trce + (syncNodeParams cfg) + syncNodeConfig + + action interpreter mockServer dbSyncEnv where mutableDir = mkMutableDir testLabelFilePath diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Config/Parse.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Config/Parse.hs index 822e8efca..938d57895 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Config/Parse.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Config/Parse.hs @@ -21,9 +21,9 @@ import Test.Tasty.HUnit (Assertion (), assertBool, (@?=)) import Prelude () conwayGenesis :: Assertion -conwayGenesis = - mkSyncNodeConfig configDir initCommandLineArgs - >>= void . mkConfig configDir mutableDir cmdLineArgs +conwayGenesis = do + cfg <- mkSyncNodeConfig configDir initCommandLineArgs + withConfig configDir mutableDir cmdLineArgs cfg (\_ -> pure ()) where configDir = "config-conway" mutableDir = mkMutableDir "conwayConfigSimple" @@ -33,7 +33,7 @@ missingConwayGenesis :: Assertion missingConwayGenesis = do res <- try $ do cfg <- mkSyncNodeConfig configDir initCommandLineArgs - mkConfig configDir mutableDir cmdLineArgs cfg + withConfig configDir mutableDir cmdLineArgs cfg pure assertBool "Not a SyncNodeError" (isConwayConfigError res) where configDir = "config-conway-missing-genesis" @@ -44,8 +44,7 @@ noConwayGenesis :: Assertion noConwayGenesis = do cfg <- mkSyncNodeConfig configDir initCommandLineArgs let cfg' = cfg {dncConwayGenesisFile = Nothing} - void $ - mkConfig configDir mutableDir cmdLineArgs cfg' + withConfig configDir mutableDir cmdLineArgs cfg' (\_ -> pure ()) where configDir = "config-conway" mutableDir = mkMutableDir "conwayConfigNoGenesis" @@ -55,8 +54,7 @@ noConwayGenesisHash :: Assertion noConwayGenesisHash = do cfg <- mkSyncNodeConfig configDir initCommandLineArgs let cfg' = cfg {dncConwayGenesisHash = Nothing} - void $ - mkConfig configDir mutableDir initCommandLineArgs cfg' + withConfig configDir mutableDir initCommandLineArgs cfg' (\_ -> pure ()) where configDir = "config-conway" mutableDir = mkMutableDir "conwayConfigNoGenesis" @@ -66,8 +64,7 @@ wrongConwayGenesisHash = do cfg <- mkSyncNodeConfig configDir initCommandLineArgs hash <- Aeson.throwDecode "\"0000000000000000000000000000000000000000000000000000000000000000\"" let cfg' = cfg {dncConwayGenesisHash = Just hash} - - res <- try (mkConfig configDir mutableDir initCommandLineArgs cfg') + res <- try (withConfig configDir mutableDir initCommandLineArgs cfg' (\_ -> pure ())) assertBool "Not a SyncNodeError" (isConwayConfigError res) where configDir = "config-conway" diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Governance.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Governance.hs index 0d11df5ff..00eb46920 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Governance.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Governance.hs @@ -24,12 +24,12 @@ module Test.Cardano.Db.Mock.Unit.Conway.Governance ( import qualified Cardano.Db as DB import Cardano.DbSync.Era.Shelley.Generic.Util (unCredentialHash, unTxHash) import Cardano.Ledger.Address (RewardAccount (..)) -import Cardano.Ledger.Alonzo.Tx (AlonzoTx) import Cardano.Ledger.BaseTypes (AnchorData (..), Network (..), textToUrl) import Cardano.Ledger.Coin (Coin (..)) import Cardano.Ledger.Conway.Governance (GovActionId (..), GovActionIx (..)) import qualified Cardano.Ledger.Conway.Governance as Governance import Cardano.Ledger.Core (hashAnnotated, txIdTx) +import qualified Cardano.Ledger.Core as Core import Cardano.Ledger.Hashes (SafeToHash (..)) import Cardano.Mock.ChainSync.Server (IOManager, ServerHandle) import Cardano.Mock.Forging.Interpreter (Interpreter, getCurrentEpoch) @@ -258,7 +258,7 @@ enactNewCommittee interpreter server = do epochs <- Api.fillEpochs interpreter server 2 pure (blk : epochs) -proposeNewCommittee :: AlonzoTx Consensus.ConwayEra +proposeNewCommittee :: Core.Tx Consensus.ConwayEra proposeNewCommittee = Conway.mkAddCommitteeTx Nothing committeeCred where diff --git a/cardano-chain-gen/test/testfiles/config-conway-hf-epoch1/test-config.json b/cardano-chain-gen/test/testfiles/config-conway-hf-epoch1/test-config.json index 1883e9865..25ead08a9 100644 --- a/cardano-chain-gen/test/testfiles/config-conway-hf-epoch1/test-config.json +++ b/cardano-chain-gen/test/testfiles/config-conway-hf-epoch1/test-config.json @@ -4,7 +4,7 @@ "ByronGenesisFile": "genesis.byron.json", "ByronGenesisHash": "865a9da19944fc00cefe5a0cdcb6dc9d3964a74681d9488ab79967f13a6400b3", "ConwayGenesisFile": "genesis.conway.json", - "ConwayGenesisHash": "e061972cc4c8d2c76e15b30c3898ef291a533c8f82642c57c0610052599ce60e", + "ConwayGenesisHash": "f87ddecbbe549699b066eef38d36aee555f09be3fd766b40e0117a77435fb693", "LastKnownBlockVersion-Alt": 0, "LastKnownBlockVersion-Major": 9, "LastKnownBlockVersion-Minor": 1, diff --git a/cardano-chain-gen/test/testfiles/config-conway-no-pools/test-config.json b/cardano-chain-gen/test/testfiles/config-conway-no-pools/test-config.json index e2d7db5d7..2e64fedda 100644 --- a/cardano-chain-gen/test/testfiles/config-conway-no-pools/test-config.json +++ b/cardano-chain-gen/test/testfiles/config-conway-no-pools/test-config.json @@ -4,7 +4,7 @@ "ByronGenesisFile": "genesis.byron.json", "ByronGenesisHash": "865a9da19944fc00cefe5a0cdcb6dc9d3964a74681d9488ab79967f13a6400b3", "ConwayGenesisFile": "genesis.conway.json", - "ConwayGenesisHash": "e061972cc4c8d2c76e15b30c3898ef291a533c8f82642c57c0610052599ce60e", + "ConwayGenesisHash": "f87ddecbbe549699b066eef38d36aee555f09be3fd766b40e0117a77435fb693", "LastKnownBlockVersion-Alt": 0, "LastKnownBlockVersion-Major": 9, "LastKnownBlockVersion-Minor": 1, diff --git a/cardano-chain-gen/test/testfiles/config-conway-no-stakes/test-config.json b/cardano-chain-gen/test/testfiles/config-conway-no-stakes/test-config.json index e2d7db5d7..2e64fedda 100644 --- a/cardano-chain-gen/test/testfiles/config-conway-no-stakes/test-config.json +++ b/cardano-chain-gen/test/testfiles/config-conway-no-stakes/test-config.json @@ -4,7 +4,7 @@ "ByronGenesisFile": "genesis.byron.json", "ByronGenesisHash": "865a9da19944fc00cefe5a0cdcb6dc9d3964a74681d9488ab79967f13a6400b3", "ConwayGenesisFile": "genesis.conway.json", - "ConwayGenesisHash": "e061972cc4c8d2c76e15b30c3898ef291a533c8f82642c57c0610052599ce60e", + "ConwayGenesisHash": "f87ddecbbe549699b066eef38d36aee555f09be3fd766b40e0117a77435fb693", "LastKnownBlockVersion-Alt": 0, "LastKnownBlockVersion-Major": 9, "LastKnownBlockVersion-Minor": 1, diff --git a/cardano-chain-gen/test/testfiles/config-conway/genesis.conway.json b/cardano-chain-gen/test/testfiles/config-conway/genesis.conway.json index 5873665e0..b262ec08a 100644 --- a/cardano-chain-gen/test/testfiles/config-conway/genesis.conway.json +++ b/cardano-chain-gen/test/testfiles/config-conway/genesis.conway.json @@ -258,6 +258,24 @@ 49601, 237, 0, + 1, + 2174038, + 72, + 2261318, + 64571, + 4, + 207616, + 8310, + 4, + 1293828, + 28716, + 63, + 0, + 1, + 1006041, + 43623, + 251, + 0, 1 ], "constitution": { diff --git a/cardano-chain-gen/test/testfiles/config-conway/test-config.json b/cardano-chain-gen/test/testfiles/config-conway/test-config.json index e2d7db5d7..2e64fedda 100644 --- a/cardano-chain-gen/test/testfiles/config-conway/test-config.json +++ b/cardano-chain-gen/test/testfiles/config-conway/test-config.json @@ -4,7 +4,7 @@ "ByronGenesisFile": "genesis.byron.json", "ByronGenesisHash": "865a9da19944fc00cefe5a0cdcb6dc9d3964a74681d9488ab79967f13a6400b3", "ConwayGenesisFile": "genesis.conway.json", - "ConwayGenesisHash": "e061972cc4c8d2c76e15b30c3898ef291a533c8f82642c57c0610052599ce60e", + "ConwayGenesisHash": "f87ddecbbe549699b066eef38d36aee555f09be3fd766b40e0117a77435fb693", "LastKnownBlockVersion-Alt": 0, "LastKnownBlockVersion-Major": 9, "LastKnownBlockVersion-Minor": 1, diff --git a/cardano-db-sync/cardano-db-sync.cabal b/cardano-db-sync/cardano-db-sync.cabal index 09e7f9597..8b98dc24c 100644 --- a/cardano-db-sync/cardano-db-sync.cabal +++ b/cardano-db-sync/cardano-db-sync.cabal @@ -84,6 +84,7 @@ library 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.Dijkstra Cardano.DbSync.Era.Shelley.Generic.Tx.Mary Cardano.DbSync.Era.Shelley.Generic.Tx.Shelley Cardano.DbSync.Era.Shelley.Generic.Tx.Types @@ -169,6 +170,7 @@ library , cardano-ledger-core , cardano-ledger-conway >= 1.17.3 , cardano-ledger-binary + , cardano-ledger-dijkstra , cardano-ledger-mary , cardano-ledger-shelley >= 1.12.3.0 , cardano-node @@ -201,6 +203,7 @@ library , ouroboros-consensus-protocol , ouroboros-network , ouroboros-network-api + -- Note this has moved to ouroboros-network:framework on HEAD , ouroboros-network-framework , ouroboros-network-protocols , plutus-ledger-api @@ -212,10 +215,10 @@ library , small-steps , stm , strict + , io-classes:strict-stm , sop-core , sop-extras , strict-sop-core - , strict-stm , swagger2 , text , time diff --git a/cardano-db-sync/src/Cardano/DbSync/Api/Ledger.hs b/cardano-db-sync/src/Cardano/DbSync/Api/Ledger.hs index 46a7cc87a..26658ded9 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Api/Ledger.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Api/Ledger.hs @@ -80,6 +80,7 @@ storeUTxOFromLedger :: storeUTxOFromLedger env st = case ledgerState st of LedgerStateBabbage bts -> storeUTxO env (getUTxO bts) LedgerStateConway stc -> storeUTxO env (getUTxO stc) + LedgerStateDijkstra stc -> storeUTxO env (getUTxO stc) _otherwise -> liftIO $ logError trce "storeUTxOFromLedger is only supported after Babbage" where trce = getTrace env diff --git a/cardano-db-sync/src/Cardano/DbSync/Config/Cardano.hs b/cardano-db-sync/src/Cardano/DbSync/Config/Cardano.hs index 79cee6834..f0bc57c9a 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Config/Cardano.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Config/Cardano.hs @@ -28,7 +28,10 @@ import Cardano.Ledger.Alonzo.Genesis (AlonzoGenesis) import qualified Cardano.Ledger.Api.Transition as Ledger import Cardano.Ledger.Binary.Version import Cardano.Ledger.Conway.Genesis +import Cardano.Node.Protocol.Dijkstra +import Cardano.Prelude (second) import Control.Monad.Trans.Except (ExceptT) +import Control.Tracer (nullTracer) import Ouroboros.Consensus.Block.Forging import Ouroboros.Consensus.Cardano (Nonce (..), ProtVer (ProtVer)) import qualified Ouroboros.Consensus.Cardano as Consensus @@ -82,40 +85,43 @@ mkTopLevelConfig cfg = Consensus.pInfoConfig $ fst $ mkProtocolInfoCardano cfg [ mkProtocolInfoCardano :: GenesisConfig -> [Consensus.ShelleyLeaderCredentials StandardCrypto] -> -- this is not empty only in tests - (ProtocolInfo CardanoBlock, IO [BlockForging IO CardanoBlock]) + (ProtocolInfo CardanoBlock, IO [MkBlockForging IO CardanoBlock]) mkProtocolInfoCardano genesisConfig shelleyCred = - protocolInfoCardano $ - CardanoProtocolParams - { byronProtocolParams = - Consensus.ProtocolParamsByron - { Consensus.byronGenesis = bGenesis - , Consensus.byronPbftSignatureThreshold = Consensus.PBftSignatureThreshold <$> dncPBftSignatureThreshold dnc - , Consensus.byronProtocolVersion = dncByronProtocolVersion dnc - , Consensus.byronSoftwareVersion = mkByronSoftwareVersion - , Consensus.byronLeaderCredentials = Nothing - } - , shelleyBasedProtocolParams = - Consensus.ProtocolParamsShelleyBased - { Consensus.shelleyBasedInitialNonce = shelleyPraosNonce genesisHash - , Consensus.shelleyBasedLeaderCredentials = shelleyCred - } - , cardanoProtocolVersion = ProtVer (natVersion @10) 0 - , cardanoLedgerTransitionConfig = - Ledger.mkLatestTransitionConfig - shelleyGenesis - alonzoGenesis - conwayGenesis - , cardanoHardForkTriggers = - Consensus.CardanoHardForkTriggers' - { triggerHardForkShelley = dncShelleyHardFork dnc - , triggerHardForkAllegra = dncAllegraHardFork dnc - , triggerHardForkMary = dncMaryHardFork dnc - , triggerHardForkAlonzo = dncAlonzoHardFork dnc - , triggerHardForkBabbage = dncBabbageHardFork dnc - , triggerHardForkConway = dncConwayHardFork dnc - } - , cardanoCheckpoints = emptyCheckpointsMap - } + second (\f -> f nullTracer) $ + protocolInfoCardano $ + CardanoProtocolParams + { byronProtocolParams = + Consensus.ProtocolParamsByron + { Consensus.byronGenesis = bGenesis + , Consensus.byronPbftSignatureThreshold = Consensus.PBftSignatureThreshold <$> dncPBftSignatureThreshold dnc + , Consensus.byronProtocolVersion = dncByronProtocolVersion dnc + , Consensus.byronSoftwareVersion = mkByronSoftwareVersion + , Consensus.byronLeaderCredentials = Nothing + } + , shelleyBasedProtocolParams = + Consensus.ProtocolParamsShelleyBased + { Consensus.shelleyBasedInitialNonce = shelleyPraosNonce genesisHash + , Consensus.shelleyBasedLeaderCredentials = shelleyCred + } + , cardanoProtocolVersion = ProtVer (natVersion @10) 0 + , cardanoLedgerTransitionConfig = + Ledger.mkLatestTransitionConfig + shelleyGenesis + alonzoGenesis + conwayGenesis + emptyDijkstraGenesis -- TODO(Dijkstra) + , cardanoHardForkTriggers = + Consensus.CardanoHardForkTriggers' + { triggerHardForkShelley = dncShelleyHardFork dnc + , triggerHardForkAllegra = dncAllegraHardFork dnc + , triggerHardForkMary = dncMaryHardFork dnc + , triggerHardForkAlonzo = dncAlonzoHardFork dnc + , triggerHardForkBabbage = dncBabbageHardFork dnc + , triggerHardForkConway = dncConwayHardFork dnc + , triggerHardForkDijkstra = Consensus.CardanoTriggerHardForkAtDefaultVersion -- TODO(Dijkstra) + } + , cardanoCheckpoints = emptyCheckpointsMap + } where GenesisCardano dnc diff --git a/cardano-db-sync/src/Cardano/DbSync/Default.hs b/cardano-db-sync/src/Cardano/DbSync/Default.hs index 82a3946c3..f2ce4e40c 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Default.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Default.hs @@ -197,6 +197,9 @@ insertBlock syncEnv cblk applyRes firstAfterRollback tookSnapshot = do BlockConway blk -> insertBlockUniversal' $ Generic.fromConwayBlock (ioPlutusExtra iopts) (getPrices applyResult) blk + BlockDijkstra blk -> + insertBlockUniversal' $ + Generic.fromDijkstraBlock (ioPlutusExtra iopts) (getPrices applyResult) blk -- update the epoch updateEpoch details isNewEpochEvent whenPruneTxOut syncEnv $ diff --git a/cardano-db-sync/src/Cardano/DbSync/Epoch.hs b/cardano-db-sync/src/Cardano/DbSync/Epoch.hs index f20b8d04d..f73de12d4 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Epoch.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Epoch.hs @@ -55,6 +55,7 @@ epochHandler syncEnv trce cache isNewEpochEvent (BlockDetails cblk details) = BlockAlonzo {} -> epochSlotTimecheck BlockBabbage {} -> epochSlotTimecheck BlockConway {} -> epochSlotTimecheck + BlockDijkstra {} -> epochSlotTimecheck where -- What we do here is completely independent of Shelley/Allegra/Mary eras. epochSlotTimecheck :: ExceptT SyncNodeError DB.DbM () diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Block.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Block.hs index 4df4f537c..0d80485d5 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Block.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Block.hs @@ -16,6 +16,7 @@ module Cardano.DbSync.Era.Shelley.Generic.Block ( fromAlonzoBlock, fromBabbageBlock, fromConwayBlock, + fromDijkstraBlock, getTxs, blockHash, blockPrevHash, @@ -39,11 +40,13 @@ import Cardano.Protocol.Crypto (Crypto, StandardCrypto, VRF) import qualified Cardano.Protocol.TPraos.BHeader as TPraos import qualified Cardano.Protocol.TPraos.OCert as TPraos import Cardano.Slotting.Slot (SlotNo (..)) +import Lens.Micro ((^.)) import Ouroboros.Consensus.Cardano.Block ( AllegraEra, AlonzoEra, BabbageEra, ConwayEra, + DijkstraEra, MaryEra, ShelleyEra, ) @@ -171,10 +174,27 @@ fromConwayBlock iope mprices blk = , blkTxs = map (fromConwayTx iope mprices) (getTxs blk) } +fromDijkstraBlock :: Bool -> Maybe Prices -> ShelleyBlock (PraosStandard StandardCrypto) DijkstraEra -> Block +fromDijkstraBlock iope mprices blk = + Block + { blkEra = Dijkstra + , 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 (fromDijkstraTx iope mprices) (getTxs blk) + } + -- ------------------------------------------------------------------------------------------------- -getTxs :: forall p era. Ledger.EraSegWits era => ShelleyBlock p era -> [(Word64, Ledger.Tx era)] -getTxs = zip [0 ..] . toList . Ledger.fromTxSeq @era . Ledger.bbody . Consensus.shelleyBlockRaw +getTxs :: forall p era. Ledger.EraBlockBody era => ShelleyBlock p era -> [(Word64, Ledger.Tx era)] +getTxs blk = zip [0 ..] $ toList (Ledger.bbody (Consensus.shelleyBlockRaw blk) ^. Ledger.txSeqBlockBodyL) blockHeader :: ShelleyBlock p era -> ShelleyProtocolHeader p blockHeader = Ledger.bheader . Consensus.shelleyBlockRaw diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/EpochUpdate.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/EpochUpdate.hs index 1a42a560c..9d0a703ae 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/EpochUpdate.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/EpochUpdate.hs @@ -59,6 +59,7 @@ extractEpochNonce extLedgerState = ChainDepStateAlonzo st -> extractNonce st ChainDepStateBabbage st -> extractNoncePraos st ChainDepStateConway st -> extractNoncePraos st + ChainDepStateDijkstra st -> extractNoncePraos st where extractNonce :: Consensus.TPraosState -> Ledger.Nonce extractNonce = diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/ProtoParams.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/ProtoParams.hs index d015b9177..050ea9bf0 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/ProtoParams.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/ProtoParams.hs @@ -84,6 +84,7 @@ epochProtoParams lstate = LedgerStateAlonzo st -> Just $ fromAlonzoParams $ getProtoParams st LedgerStateBabbage st -> Just $ fromBabbageParams $ getProtoParams st LedgerStateConway st -> Just $ fromConwayParams $ getProtoParams st + LedgerStateDijkstra st -> Just $ fromDijkstraParams $ getProtoParams st -- TODO(Dijkstra): getProtoParams :: EraGov era => @@ -101,6 +102,7 @@ getDeposits lstate = LedgerStateAlonzo st -> Just $ getDopositsShelley $ getProtoParams st LedgerStateBabbage st -> Just $ getDopositsShelley $ getProtoParams st LedgerStateConway st -> Just $ getDopositsShelley $ getProtoParams st + LedgerStateDijkstra st -> Just $ getDopositsShelley $ getProtoParams st where getDopositsShelley :: EraPParams era => PParams era -> Deposits getDopositsShelley pp = @@ -111,6 +113,48 @@ getDeposits lstate = -- ------------------------------------------------------------------------------------------------- +fromDijkstraParams :: PParams DijkstraEra -> ProtoParams +fromDijkstraParams params = + ProtoParams + { ppMinfeeA = fromIntegral . unCoin $ params ^. ppMinFeeAL + , ppMinfeeB = fromIntegral . unCoin $ params ^. ppMinFeeBL + , ppMaxBBSize = params ^. ppMaxBBSizeL + , ppMaxTxSize = params ^. ppMaxTxSizeL + , ppMaxBHSize = params ^. ppMaxBHSizeL + , ppKeyDeposit = params ^. ppKeyDepositL + , ppPoolDeposit = params ^. ppPoolDepositL + , ppMaxEpoch = params ^. ppEMaxL + , ppOptimalPoolCount = params ^. ppNOptL + , ppInfluence = Ledger.unboundRational $ params ^. ppA0L + , ppMonetaryExpandRate = params ^. ppRhoL + , ppTreasuryGrowthRate = params ^. ppTauL + , ppDecentralisation = minBound -- can't change in Babbage + , ppExtraEntropy = NeutralNonce -- no extra entropy in Babbage + , ppProtocolVersion = params ^. ppProtocolVersionL + , ppMinUTxOValue = Coin 0 + , ppMinPoolCost = params ^. ppMinPoolCostL + , ppCoinsPerUtxo = Just $ unCoinPerByte (params ^. ppCoinsPerUTxOByteL) + , ppCostmdls = Just $ Alonzo.costModelsValid $ params ^. ppCostModelsL + , ppPriceMem = Just . Ledger.unboundRational $ Alonzo.prMem (params ^. ppPricesL) + , ppPriceStep = Just . Ledger.unboundRational $ Alonzo.prSteps (params ^. ppPricesL) + , ppMaxTxExMem = Just . fromIntegral $ Alonzo.exUnitsMem (params ^. ppMaxTxExUnitsL) + , ppMaxTxExSteps = Just . fromIntegral $ Alonzo.exUnitsSteps (params ^. ppMaxTxExUnitsL) + , ppMaxBlockExMem = Just . fromIntegral $ Alonzo.exUnitsMem (params ^. ppMaxBlockExUnitsL) + , ppMaxBlockExSteps = Just . fromIntegral $ Alonzo.exUnitsSteps (params ^. ppMaxBlockExUnitsL) + , ppMaxValSize = Just $ params ^. ppMaxValSizeL + , ppCollateralPercentage = Just $ params ^. ppCollateralPercentageL + , ppMaxCollateralInputs = Just $ params ^. ppMaxCollateralInputsL + , ppPoolVotingThresholds = Just $ params ^. ppPoolVotingThresholdsL + , ppDRepVotingThresholds = Just $ params ^. ppDRepVotingThresholdsL + , ppCommitteeMinSize = Just $ params ^. ppCommitteeMinSizeL + , ppCommitteeMaxTermLength = Just $ params ^. ppCommitteeMaxTermLengthL + , ppGovActionLifetime = Just $ params ^. ppGovActionLifetimeL + , ppGovActionDeposit = Just . fromIntegral . unCoin $ params ^. ppGovActionDepositL + , ppDRepDeposit = Just . fromIntegral . unCoin $ params ^. ppDRepDepositL + , ppDRepActivity = Just $ params ^. ppDRepActivityL + , ppMinFeeRefScriptCostPerByte = Just $ Ledger.unboundRational $ params ^. ppMinFeeRefScriptCostPerByteL + } + fromConwayParams :: PParams ConwayEra -> ProtoParams fromConwayParams params = ProtoParams diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Rewards.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Rewards.hs index ff35e7795..9f71806a0 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Rewards.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Rewards.hs @@ -22,7 +22,7 @@ import Ouroboros.Consensus.Cardano.CanHardFork () data Reward = Reward { rewardSource :: !RewardSource , rewardPool :: !PoolKeyHash - , rewardAmount :: !Coin + , rewardAmount :: !Word64 } deriving (Eq, Ord, Show) diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Script.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Script.hs index bbfe1c7de..b5b6e3a72 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Script.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Script.hs @@ -28,7 +28,7 @@ import qualified Data.Aeson as Aeson import Data.Aeson.Types (Parser ()) import Data.Sequence.Strict (fromList) import Text.Show (Show (..)) -import Prelude () +import Prelude (error) -- | Shelley multi signature scripts newtype MultiSigScript era = MultiSigScript {unMultiSigScript :: Shelley.MultiSig era} @@ -81,6 +81,7 @@ instance (Era era, Allegra.AllegraEraScript era, Core.NativeScript era ~ Allegra timelockToJSON (Shelley.RequireSignature sig) = requireSignatureToJSON sig timelockToJSON (Allegra.RequireTimeStart slot) = requireTimeStartToJSON slot timelockToJSON (Allegra.RequireTimeExpire slot) = requireTimeExpireToJSON slot + timelockToJSON _ = error "Impossible: All NativeScripts should have been accounted for" instance (Era era, Allegra.AllegraEraScript era, Core.NativeScript era ~ Allegra.Timelock era) => FromJSON (TimelockScript era) where parseJSON v = TimelockScript <$> parseTimelock v diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/StakeDist.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/StakeDist.hs index 1e45a4a08..ab6931b5c 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/StakeDist.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/StakeDist.hs @@ -84,6 +84,7 @@ getStakeSlice pInfo !epochBlockNo els isMigration = LedgerStateAlonzo als -> genericStakeSlice pInfo epochBlockNo als isMigration LedgerStateBabbage bls -> genericStakeSlice pInfo epochBlockNo bls isMigration LedgerStateConway cls -> genericStakeSlice pInfo epochBlockNo cls isMigration + LedgerStateDijkstra dls -> genericStakeSlice pInfo epochBlockNo dls isMigration genericStakeSlice :: forall era blk p mk. @@ -186,6 +187,7 @@ getPoolDistr els = LedgerStateAlonzo als -> Just $ genericPoolDistr als LedgerStateBabbage bls -> Just $ genericPoolDistr bls LedgerStateConway cls -> Just $ genericPoolDistr cls + LedgerStateDijkstra dls -> Just $ genericPoolDistr dls genericPoolDistr :: forall era p mk. diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx.hs index 153d80736..06f310520 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx.hs @@ -5,6 +5,7 @@ module Cardano.DbSync.Era.Shelley.Generic.Tx ( fromAlonzoTx, fromBabbageTx, fromConwayTx, + fromDijkstraTx, module X, ) where @@ -12,6 +13,7 @@ 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.Dijkstra 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 diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Allegra.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Allegra.hs index bec004472..468091319 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Allegra.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Allegra.hs @@ -38,7 +38,6 @@ import Cardano.Ledger.Allegra.Scripts import Cardano.Ledger.Allegra.TxAuxData import Cardano.Ledger.BaseTypes (StrictMaybe, strictMaybeToMaybe) import qualified Cardano.Ledger.Core as Core -import Cardano.Ledger.Shelley.Tx (ShelleyTx) import Cardano.Prelude import Cardano.Slotting.Slot (SlotNo (..)) import qualified Data.Aeson as Aeson @@ -94,8 +93,8 @@ fromAllegraTx (blkIndex, tx) = getScripts :: forall era. - (NativeScript era ~ Timelock era, AllegraEraScript era, Core.Tx era ~ ShelleyTx era, TxAuxData era ~ AllegraTxAuxData era, Script era ~ Timelock era, EraTx era) => - ShelleyTx era -> + (NativeScript era ~ Timelock era, AllegraEraScript era, TxAuxData era ~ AllegraTxAuxData era, Script era ~ Timelock era, EraTx era) => + Core.Tx era -> [TxScript] getScripts tx = mkTxScript @@ -105,7 +104,7 @@ getScripts tx = getAuxScripts :: forall era. - (EraScript era, Script era ~ Timelock era) => + (NativeScript era ~ Timelock era, EraScript era, Script era ~ Timelock era) => StrictMaybe (AllegraTxAuxData era) -> [(ScriptHash, Timelock era)] getAuxScripts maux = diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Alonzo.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Alonzo.hs index ef4647ba0..3a5718539 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Alonzo.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Alonzo.hs @@ -89,7 +89,7 @@ fromAlonzoTx ioExtraPlutus mprices (blkIndex, tx) = , txFees = if not isValid2 then Nothing - else Just $ Alonzo.txfee' txBody + else Just $ txBody ^. Core.feeTxBodyL , txOutSum = if not isValid2 then Coin 0 @@ -101,7 +101,7 @@ fromAlonzoTx ioExtraPlutus mprices (blkIndex, tx) = , txCertificates = snd <$> rmCerts finalMaps , txWithdrawals = Map.elems $ rmWdrl finalMaps , txParamProposal = mkTxParamProposal (Alonzo Standard) txBody - , txMint = Alonzo.mint' txBody + , txMint = txBody ^. Alonzo.mintTxBodyL , txRedeemer = redeemers , txData = txDataWitness tx , txScriptSizes = getPlutusSizes tx @@ -112,11 +112,11 @@ fromAlonzoTx ioExtraPlutus mprices (blkIndex, tx) = , txTreasuryDonation = mempty -- Alonzo does not support treasury donations } where - txBody :: Alonzo.AlonzoTxBody AlonzoEra + -- txBody :: Alonzo.AlonzoTxBody AlonzoEra txBody = tx ^. Core.bodyTxL outputs :: [TxOut] - outputs = zipWith fromTxOut [0 ..] $ toList (Alonzo.outputs' txBody) + outputs = zipWith fromTxOut [0 ..] $ toList (txBody ^. Core.outputsTxBodyL) fromTxOut :: Word64 -> AlonzoTxOut AlonzoEra -> TxOut fromTxOut index txOut = @@ -132,12 +132,12 @@ fromAlonzoTx ioExtraPlutus mprices (blkIndex, tx) = MaryValue ada (MultiAsset maMap) = txOut ^. Core.valueTxOutL mDataHash = txOut ^. Alonzo.dataHashTxOutL - (finalMaps, redeemers) = resolveRedeemers ioExtraPlutus mprices tx (Left . toShelleyCert) + (finalMaps, redeemers) = resolveRedeemers ioExtraPlutus mprices tx (SCert . toShelleyCert) -- This is true if second stage contract validation passes or there are no contracts. isValid2 :: Bool isValid2 = - case Alonzo.isValid tx of + case tx ^. Alonzo.isValidTxL of Alonzo.IsValid x -> x (invalidBefore, invalidAfter) = getInterval txBody @@ -307,20 +307,20 @@ mkTxScript (hsh, script) = getScriptType :: DB.ScriptType getScriptType = case script of - Alonzo.TimelockScript {} -> DB.Timelock + Alonzo.NativeScript {} -> DB.Timelock Alonzo.PlutusScript ps -> getPlutusScriptType ps timelockJsonScript :: Maybe ByteString timelockJsonScript = case script of - Alonzo.TimelockScript s -> + Alonzo.NativeScript s -> Just . LBS.toStrict . Aeson.encode $ fromTimelock s Alonzo.PlutusScript {} -> Nothing plutusCborScript :: Maybe ByteString plutusCborScript = case script of - Alonzo.TimelockScript {} -> Nothing + Alonzo.NativeScript {} -> Nothing plScript -> Just $ Core.originalBytes plScript getPlutusSizes :: @@ -341,16 +341,16 @@ getPlutusSizes tx = getPlutusScriptSize :: Alonzo.AlonzoEraScript era => Alonzo.AlonzoScript era -> Maybe Word64 getPlutusScriptSize script = case script of - Alonzo.TimelockScript {} -> Nothing + Alonzo.NativeScript {} -> Nothing Alonzo.PlutusScript ps -> Just $ fromIntegral $ SBS.length $ unPlutusBinary $ Alonzo.plutusScriptBinary ps txDataWitness :: - (Core.TxWits era ~ Alonzo.AlonzoTxWits era, Core.EraTx era) => + (Alonzo.AlonzoEraScript era, Core.TxWits era ~ Alonzo.AlonzoTxWits era, Core.EraTx era) => Core.Tx era -> [PlutusData] txDataWitness tx = - mkTxData <$> Map.toList (Alonzo.unTxDats $ Alonzo.txdats' (tx ^. Core.witsTxL)) + mkTxData <$> Map.toList (Alonzo.unTxDats $ Alonzo.txdats (tx ^. Core.witsTxL)) mkTxData :: (DataHash, Alonzo.Data era) -> PlutusData mkTxData (dataHash, dt) = PlutusData dataHash (jsonData dt) (Core.originalBytes dt) @@ -362,7 +362,7 @@ mkTxData (dataHash, dt) = PlutusData dataHash (jsonData dt) (Core.originalBytes . ScriptData extraKeyWits :: - AlonzoEraTxBody era => + (AlonzoEraTxBody era, Core.AtMostEra "Conway" era) => Core.TxBody era -> [ByteString] extraKeyWits txBody = @@ -375,8 +375,9 @@ scriptHashAcnt rewardAddr = getCredentialScriptHash $ Ledger.raCredential reward scriptHashCert :: Cert -> Maybe ByteString scriptHashCert cert = case cert of - Left scert -> scriptHashCertShelley scert - Right ccert -> scriptHashCertConway ccert + SCert scert -> scriptHashCertShelley scert + CCert ccert -> scriptHashCertConway ccert + DCert _ -> Nothing -- TODO(Dijkstra) scriptHashCertConway :: ConwayCert -> Maybe ByteString scriptHashCertConway cert = unScriptHash <$> getScriptWitnessTxCert cert diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Babbage.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Babbage.hs index a69884fb8..fd79a3817 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Babbage.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Babbage.hs @@ -24,7 +24,6 @@ import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo import qualified Cardano.Ledger.Alonzo.Tx as Alonzo import Cardano.Ledger.Babbage.Core as Core hiding (Tx, TxOut) import Cardano.Ledger.Babbage.TxBody (BabbageTxOut) -import qualified Cardano.Ledger.Babbage.TxBody as Babbage import Cardano.Ledger.BaseTypes import qualified Cardano.Ledger.Core as Core import Cardano.Ledger.Mary.Value (MaryValue (..), MultiAsset (..)) @@ -48,7 +47,7 @@ fromBabbageTx ioExtraPlutus mprices (blkIndex, tx) = then collInputs else Map.elems $ rmInps finalMaps , txCollateralInputs = collInputs - , txReferenceInputs = map fromTxIn . toList $ Babbage.referenceInputs' txBody + , txReferenceInputs = map fromTxIn . toList $ txBody ^. referenceInputsTxBodyL , txOutputs = if not isValid2 then collOutputs @@ -57,8 +56,8 @@ fromBabbageTx ioExtraPlutus mprices (blkIndex, tx) = collOutputs , txFees = if not isValid2 - then strictMaybeToMaybe $ Babbage.totalCollateral' txBody - else Just $ Babbage.txfee' txBody + then strictMaybeToMaybe $ txBody ^. totalCollateralTxBodyL + else Just $ txBody ^. feeTxBodyL , txOutSum = if not isValid2 then sumTxOutCoin collOutputs @@ -70,7 +69,7 @@ fromBabbageTx ioExtraPlutus mprices (blkIndex, tx) = , txCertificates = snd <$> rmCerts finalMaps , txWithdrawals = Map.elems $ rmWdrl finalMaps , txParamProposal = mkTxParamProposal (Babbage Standard) txBody - , txMint = Babbage.mint' txBody + , txMint = txBody ^. mintTxBodyL , txRedeemer = redeemers , txData = txDataWitness tx , txScriptSizes = getPlutusSizes tx @@ -85,12 +84,12 @@ fromBabbageTx ioExtraPlutus mprices (blkIndex, tx) = txBody = tx ^. Core.bodyTxL outputs :: [TxOut] - outputs = zipWith fromTxOut [0 ..] $ toList (Babbage.outputs' txBody) + outputs = zipWith fromTxOut [0 ..] $ toList (txBody ^. outputsTxBodyL) -- TODO when collateral output is used as output, its index is not 0, but length of outputs -- even though it is the unique output of the tx. collOutputs :: [TxOut] - collOutputs = zipWith fromTxOut [collIndex ..] . toList $ Babbage.collateralReturn' txBody + collOutputs = zipWith fromTxOut [collIndex ..] . toList $ txBody ^. collateralReturnTxBodyL collIndex :: Word64 collIndex = @@ -101,10 +100,10 @@ fromBabbageTx ioExtraPlutus mprices (blkIndex, tx) = -- This is true if second stage contract validation passes. isValid2 :: Bool isValid2 = - case Alonzo.isValid tx of + case tx ^. Alonzo.isValidTxL of Alonzo.IsValid x -> x - (finalMaps, redeemers) = resolveRedeemers ioExtraPlutus mprices tx (Left . toShelleyCert) + (finalMaps, redeemers) = resolveRedeemers ioExtraPlutus mprices tx (SCert . toShelleyCert) (invalidBef, invalidAfter) = getInterval txBody collInputs = mkCollTxIn txBody diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Conway.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Conway.hs index 01f5dce56..8b0131d4e 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Conway.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Conway.hs @@ -97,10 +97,10 @@ fromConwayTx ioExtraPlutus mprices (blkIndex, tx) = -- This is true if second stage contract validation passes. isValid2 :: Bool isValid2 = - case Alonzo.isValid tx of + case tx ^. Alonzo.isValidTxL of Alonzo.IsValid x -> x - (finalMaps, redeemers) = resolveRedeemers ioExtraPlutus mprices tx Right + (finalMaps, redeemers) = resolveRedeemers ioExtraPlutus mprices tx CCert (invalidBef, invalidAfter) = getInterval txBody collInputs = mkCollTxIn txBody diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Dijkstra.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Dijkstra.hs new file mode 100644 index 000000000..012067797 --- /dev/null +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Dijkstra.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Cardano.DbSync.Era.Shelley.Generic.Tx.Dijkstra ( + fromDijkstraTx, +) where + +import Cardano.DbSync.Era.Shelley.Generic.Metadata +import Cardano.DbSync.Era.Shelley.Generic.Tx.Allegra (getInterval) +import Cardano.DbSync.Era.Shelley.Generic.Tx.Alonzo +import qualified Cardano.DbSync.Era.Shelley.Generic.Tx.Babbage as Babbage +import Cardano.DbSync.Era.Shelley.Generic.Tx.Shelley +import Cardano.DbSync.Era.Shelley.Generic.Tx.Types +import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo +import qualified Cardano.Ledger.Alonzo.Tx as Alonzo +import Cardano.Ledger.Babbage.Core as Core hiding (Tx, TxOut) +import Cardano.Ledger.BaseTypes +import Cardano.Ledger.Conway.Governance +import qualified Cardano.Ledger.Core as Core +import Cardano.Ledger.Dijkstra.TxBody +import Cardano.Ledger.TxIn +import Cardano.Prelude +import qualified Data.Map.Strict as Map +import Lens.Micro +import Ouroboros.Consensus.Cardano.Block (DijkstraEra) + +fromDijkstraTx :: Bool -> Maybe Alonzo.Prices -> (Word64, Core.Tx DijkstraEra) -> Tx +fromDijkstraTx ioExtraPlutus mprices (blkIndex, tx) = + Tx + { txHash = txHashId tx + , txLedgerTxId = mkTxId tx + , txBlockIndex = blkIndex + , txCBOR = getTxCBOR tx + , txSize = getTxSize tx + , txValidContract = isValid2 + , txInputs = + if not isValid2 + then collInputs + else Map.elems $ rmInps finalMaps + , txCollateralInputs = collInputs + , txReferenceInputs = map fromTxIn . toList $ txBody ^. referenceInputsTxBodyL + , txOutputs = + if not isValid2 + then collOutputs + else outputs + , txCollateralOutputs = + collOutputs + , txFees = + if not isValid2 + then strictMaybeToMaybe $ txBody ^. totalCollateralTxBodyL + else Just $ txBody ^. feeTxBodyL + , txOutSum = + if not isValid2 + then sumTxOutCoin collOutputs + else sumTxOutCoin outputs + , txInvalidBefore = invalidBef + , txInvalidHereafter = invalidAfter + , txWithdrawalSum = calcWithdrawalSum txBody + , txMetadata = fromAlonzoMetadata <$> getTxMetadata tx + , txCertificates = snd <$> rmCerts finalMaps + , txWithdrawals = Map.elems $ rmWdrl finalMaps + , txParamProposal = [] + , txMint = txBody ^. mintTxBodyL + , txRedeemer = redeemers + , txData = txDataWitness tx + , txScriptSizes = getPlutusSizes tx + , txScripts = getScripts tx + , txExtraKeyWitnesses = [] -- TODO(Dijkstra) + , txVotingProcedure = [] -- TODO(Dijkstra) Map.toList $ fmap Map.toList (unVotingProcedures $ dtbrVotingProcedures txBody) + , txProposalProcedure = [] -- TODO (Dijkskra) zipWith mkProposalIndex [0 ..] $ toList $ dtbProposalProcedures txBody + , txTreasuryDonation = dtbTreasuryDonation txBody + } + where + txBody :: Core.TxBody DijkstraEra + txBody = tx ^. Core.bodyTxL + + txId :: TxId + txId = mkTxId tx + + outputs :: [TxOut] + outputs = zipWith Babbage.fromTxOut [0 ..] $ toList (txBody ^. Core.outputsTxBodyL) + + -- TODO when collateral output is used as output, its index is not 0, but length of outputs + -- even though it is the unique output of the tx. + collOutputs :: [TxOut] + collOutputs = zipWith Babbage.fromTxOut [collIndex ..] . toList $ (txBody ^. collateralReturnTxBodyL) + + collIndex :: Word64 + collIndex = + case txIxFromIntegral (length outputs) of + Just (TxIx i) -> fromIntegral i + Nothing -> fromIntegral (maxBound :: Word16) + + -- This is true if second stage contract validation passes. + isValid2 :: Bool + isValid2 = + case tx ^. Alonzo.isValidTxL of + Alonzo.IsValid x -> x + + (finalMaps, redeemers) = resolveRedeemers ioExtraPlutus mprices tx DCert + (invalidBef, invalidAfter) = getInterval txBody + + collInputs = mkCollTxIn txBody + + _mkProposalIndex :: Word16 -> a -> (GovActionId, a) + _mkProposalIndex gix a = (GovActionId txId (GovActionIx gix), a) diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Shelley.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Shelley.hs index a879195df..fbebb4702 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Shelley.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Shelley.hs @@ -208,5 +208,5 @@ mkTxCertificate idx dcert = TxCertificate { txcRedeemerIndex = Nothing , txcIndex = idx - , txcCert = Left dcert + , txcCert = SCert dcert } diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Types.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Types.hs index 1553d128b..a698e6f36 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Types.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Types.hs @@ -8,7 +8,7 @@ module Cardano.DbSync.Era.Shelley.Generic.Tx.Types ( Tx (..), ShelleyCert, ConwayCert, - Cert, + Cert (..), TxCertificate (..), TxWithdrawal (..), TxIn (..), @@ -41,14 +41,15 @@ import Cardano.Ledger.Coin (Coin (..)) import Cardano.Ledger.Conway.Governance import Cardano.Ledger.Conway.Scripts import Cardano.Ledger.Conway.TxCert (ConwayTxCert) -import Cardano.Ledger.Core (TxBody) +import Cardano.Ledger.Dijkstra.Scripts +import Cardano.Ledger.Dijkstra.TxCert import Cardano.Ledger.Mary.Value (AssetName, MultiAsset, PolicyID) import qualified Cardano.Ledger.Shelley.TxBody as Shelley import Cardano.Ledger.Shelley.TxCert import qualified Cardano.Ledger.TxIn as Ledger import Cardano.Prelude import Cardano.Slotting.Slot (SlotNo (..)) -import Ouroboros.Consensus.Cardano.Block (AlonzoEra, BabbageEra, ConwayEra, ShelleyEra) +import Ouroboros.Consensus.Cardano.Block (AlonzoEra, BabbageEra, ConwayEra, DijkstraEra, ShelleyEra) data Tx = Tx { txHash :: !ByteString @@ -84,7 +85,9 @@ data Tx = Tx type ShelleyCert = ShelleyTxCert ShelleyEra type ConwayCert = ConwayTxCert ConwayEra -type Cert = Either ShelleyCert ConwayCert +type DijkstraCert = DijkstraTxCert DijkstraEra +data Cert = SCert ShelleyCert | CCert ConwayCert | DCert DijkstraCert + deriving (Eq) data TxCertificate = TxCertificate { txcRedeemerIndex :: !(Maybe Word64) @@ -222,6 +225,22 @@ instance DBScriptPurpose ConwayEra where ConwayProposing _ -> Nothing a -> Just $ Right a +instance DBScriptPurpose DijkstraEra where + getPurpose = \case + DijkstraSpending idx -> (DB.Spend, unAsIx idx) + DijkstraMinting idx -> (DB.Mint, unAsIx idx) + DijkstraCertifying idx -> (DB.Cert, unAsIx idx) + DijkstraRewarding idx -> (DB.Rewrd, unAsIx idx) + DijkstraVoting idx -> (DB.Vote, unAsIx idx) + DijkstraProposing idx -> (DB.Propose, unAsIx idx) + DijkstraGuarding idx -> (DB.Propose, unAsIx idx) -- TODO(Dijkstra) + + toAlonzoPurpose _ = \case + DijkstraVoting _ -> Nothing + DijkstraProposing _ -> Nothing + DijkstraGuarding _ -> Nothing + _ -> Nothing -- TODO(Dijkstra) + class AlonzoEraScript era => DBPlutusScript era where getPlutusScriptType :: PlutusScript era -> DB.ScriptType @@ -236,3 +255,9 @@ instance DBPlutusScript ConwayEra where getPlutusScriptType (ConwayPlutusV1 _) = DB.PlutusV1 getPlutusScriptType (ConwayPlutusV2 _) = DB.PlutusV2 getPlutusScriptType (ConwayPlutusV3 _) = DB.PlutusV3 + +instance DBPlutusScript DijkstraEra where + getPlutusScriptType (DijkstraPlutusV1 _) = DB.PlutusV1 + getPlutusScriptType (DijkstraPlutusV2 _) = DB.PlutusV2 + getPlutusScriptType (DijkstraPlutusV3 _) = DB.PlutusV3 + getPlutusScriptType (DijkstraPlutusV4 _) = DB.PlutusV4 diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Epoch.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Epoch.hs index 8b7c30051..427066d01 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Epoch.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Epoch.hs @@ -270,7 +270,7 @@ insertRewards syncEnv nw earnedEpoch spendableEpoch rewardsChunk = do DB.Reward { DB.rewardAddrId = saId , DB.rewardType = Generic.rewardSource rwd - , DB.rewardAmount = Generic.coinToDbLovelace (Generic.rewardAmount rwd) + , DB.rewardAmount = DB.DbLovelace (Generic.rewardAmount rwd) , DB.rewardEarnedEpoch = unEpochNo earnedEpoch , DB.rewardSpendableEpoch = unEpochNo spendableEpoch , DB.rewardPoolId = poolId diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Certificate.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Certificate.hs index cdbff63e0..48503f041 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Certificate.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Certificate.hs @@ -40,7 +40,6 @@ import Cardano.DbSync.Types import Cardano.DbSync.Util import Cardano.Ledger.BaseTypes import qualified Cardano.Ledger.BaseTypes as Ledger -import Cardano.Ledger.CertState import Cardano.Ledger.Coin (Coin (..)) import qualified Cardano.Ledger.Coin as Ledger import Cardano.Ledger.Conway.TxCert @@ -50,6 +49,7 @@ import qualified Cardano.Ledger.Keys as Ledger import qualified Cardano.Ledger.Shelley.AdaPots as Shelley import qualified Cardano.Ledger.Shelley.TxBody as Shelley import Cardano.Ledger.Shelley.TxCert +import Cardano.Ledger.State import Cardano.Prelude import Data.Group (invert) import qualified Data.Map.Strict as Map @@ -67,21 +67,21 @@ insertCertificate :: ExceptT SyncNodeError DB.DbM () insertCertificate syncEnv isMember mDeposits blkId txId epochNo slotNo redeemers (Generic.TxCertificate ridx idx cert) = case cert of - Left (ShelleyTxCertDelegCert deleg) -> + Generic.SCert (ShelleyTxCertDelegCert deleg) -> when (ioShelley iopts) $ insertDelegCert syncEnv mDeposits network txId idx mRedeemerId epochNo slotNo deleg - Left (ShelleyTxCertPool pool) -> + Generic.SCert (ShelleyTxCertPool pool) -> when (ioShelley iopts) $ insertPoolCert syncEnv isMember mDeposits network epochNo blkId txId idx pool - Left (ShelleyTxCertMir mir) -> + Generic.SCert (ShelleyTxCertMir mir) -> when (ioShelley iopts) $ insertMirCert syncEnv network txId idx mir - Left (ShelleyTxCertGenesisDeleg _gen) -> + Generic.SCert (ShelleyTxCertGenesisDeleg _gen) -> when (ioShelley iopts) $ liftIO $ logWarning tracer "insertCertificate: Unhandled DCertGenesis certificate" - Right (ConwayTxCertDeleg deleg) -> + Generic.CCert (ConwayTxCertDeleg deleg) -> insertConwayDelegCert syncEnv mDeposits txId idx mRedeemerId epochNo slotNo deleg - Right (ConwayTxCertPool pool) -> + Generic.CCert (ConwayTxCertPool pool) -> when (ioShelley iopts) $ insertPoolCert syncEnv isMember mDeposits network epochNo blkId txId idx pool - Right (ConwayTxCertGov c) -> + Generic.CCert (ConwayTxCertGov c) -> when (ioGov iopts) $ case c of ConwayRegDRep cred coin anchor -> insertDrepRegistration blkId txId idx cred (Just coin) (strictMaybeToMaybe anchor) @@ -93,6 +93,7 @@ insertCertificate syncEnv isMember mDeposits blkId txId epochNo slotNo redeemers insertCommitteeDeRegistration blkId txId idx khCold (strictMaybeToMaybe anchor) ConwayUpdateDRep cred anchor -> insertDrepRegistration blkId txId idx cred Nothing (strictMaybeToMaybe anchor) + Generic.DCert _ -> pure () -- TODO(Dijkstra) where tracer = getTrace syncEnv iopts = getInsertOptions syncEnv diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/GovAction.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/GovAction.hs index 2cdd944ec..7125bd46f 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/GovAction.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/GovAction.hs @@ -47,7 +47,6 @@ import Cardano.DbSync.Util import Cardano.DbSync.Util.Bech32 (serialiseDrepToBech32) import Cardano.Ledger.BaseTypes import qualified Cardano.Ledger.BaseTypes as Ledger -import Cardano.Ledger.CertState (DRep (..)) import Cardano.Ledger.Coin (Coin) import qualified Cardano.Ledger.Coin as Ledger import Cardano.Ledger.Compactible (Compactible (..)) @@ -59,6 +58,7 @@ import Cardano.Ledger.Keys (KeyRole (..)) import qualified Cardano.Ledger.Plutus.CostModels as Ledger import Cardano.Ledger.Plutus.Language (Language) import Cardano.Ledger.Shelley.API (Coin (..), RewardAccount) +import Cardano.Ledger.State (DRep (..)) import Cardano.Prelude import Control.Monad.Extra (whenJust) import qualified Data.Aeson as Aeson diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Pool.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Pool.hs index 3330cfe69..33a149211 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Pool.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Pool.hs @@ -37,8 +37,8 @@ import qualified Cardano.Ledger.BaseTypes as Ledger import Cardano.Ledger.Core (PoolCert (..)) import qualified Cardano.Ledger.Credential as Ledger import qualified Cardano.Ledger.Keys as Ledger -import qualified Cardano.Ledger.PoolParams as PoolP import qualified Cardano.Ledger.Shelley.TxBody as Shelley +import qualified Cardano.Ledger.State as PoolP import Cardano.Prelude type IsPoolMember = PoolKeyHash -> Bool diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Validate.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Validate.hs index 1ba528de8..975adeb56 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Validate.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Validate.hs @@ -9,7 +9,6 @@ module Cardano.DbSync.Era.Universal.Validate ( ) where import Cardano.BM.Trace (Trace, logError, logInfo, logWarning) -import Cardano.Ledger.Coin (Coin (..)) import Cardano.Ledger.Shelley.API (Network) import qualified Cardano.Ledger.Shelley.Rewards as Ledger import Cardano.Prelude hiding (from, on) @@ -73,7 +72,7 @@ logFullRewardMap tracer epochNo network ledgerMap = do liftIO $ diffRewardMap tracer network dbMap (Map.mapKeys (Generic.stakingCredHash network) $ Map.map convert $ Generic.unRewards ledgerMap) where - convert :: Set Generic.Reward -> [(DB.RewardSource, Coin)] + convert :: Set Generic.Reward -> [(DB.RewardSource, Word64)] convert = map (\rwd -> (Generic.rewardSource rwd, Generic.rewardAmount rwd)) . Set.toList queryRewardMap :: EpochNo -> ExceptT SyncNodeError DB.DbM (Map ByteString [(DB.RewardSource, DB.DbLovelace)]) @@ -98,7 +97,7 @@ diffRewardMap :: Trace IO Text -> Network -> Map ByteString [(DB.RewardSource, DB.DbLovelace)] -> - Map ByteString [(DB.RewardSource, Coin)] -> + Map ByteString [(DB.RewardSource, Word64)] -> IO () diffRewardMap tracer _nw dbMap ledgerMap = do when (Map.size diffMap > 0) $ do @@ -108,22 +107,22 @@ diffRewardMap tracer _nw dbMap ledgerMap = do keys :: [ByteString] keys = List.nubOrd (Map.keys dbMap ++ Map.keys ledgerMap) - diffMap :: Map ByteString ([(DB.RewardSource, DB.DbLovelace)], [(DB.RewardSource, Coin)]) + diffMap :: Map ByteString ([(DB.RewardSource, DB.DbLovelace)], [(DB.RewardSource, Word64)]) diffMap = List.foldl' mkDiff mempty keys mkDiff :: - Map ByteString ([(DB.RewardSource, DB.DbLovelace)], [(DB.RewardSource, Coin)]) -> + Map ByteString ([(DB.RewardSource, DB.DbLovelace)], [(DB.RewardSource, Word64)]) -> ByteString -> - Map ByteString ([(DB.RewardSource, DB.DbLovelace)], [(DB.RewardSource, Coin)]) + Map ByteString ([(DB.RewardSource, DB.DbLovelace)], [(DB.RewardSource, Word64)]) mkDiff !acc addr = case (Map.lookup addr dbMap, Map.lookup addr ledgerMap) of (Just xs, Just ys) -> - if fromIntegral (sum $ map (DB.unDbLovelace . snd) xs) == sum (map (unCoin . snd) ys) + if fromIntegral (sum $ map (DB.unDbLovelace . snd) xs) == sum (map snd ys) then acc else Map.insert addr (xs, ys) acc (Nothing, Just ys) -> Map.insert addr ([], ys) acc (Just xs, Nothing) -> Map.insert addr (xs, []) acc (Nothing, Nothing) -> acc - render :: (ByteString, ([(DB.RewardSource, DB.DbLovelace)], [(DB.RewardSource, Coin)])) -> Text + render :: (ByteString, ([(DB.RewardSource, DB.DbLovelace)], [(DB.RewardSource, Word64)])) -> Text render (cred, (xs, ys)) = mconcat [" ", show cred, ": ", show xs, " /= ", show ys] diff --git a/cardano-db-sync/src/Cardano/DbSync/Ledger/Event.hs b/cardano-db-sync/src/Cardano/DbSync/Ledger/Event.hs index ed7bea22a..53fe7cbc6 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Ledger/Event.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Ledger/Event.hs @@ -28,7 +28,7 @@ import Cardano.Ledger.Address (RewardAccount) import qualified Cardano.Ledger.Allegra.Rules as Allegra import Cardano.Ledger.Alonzo.Rules (AlonzoBbodyEvent (..), AlonzoUtxoEvent (..), AlonzoUtxowEvent (..)) import qualified Cardano.Ledger.Alonzo.Rules as Alonzo -import Cardano.Ledger.Coin (Coin (..)) +import Cardano.Ledger.Coin (Coin (..), CompactForm (..)) import Cardano.Ledger.Conway.Governance import Cardano.Ledger.Conway.Rules as Conway import qualified Cardano.Ledger.Core as Ledger @@ -154,6 +154,9 @@ instance ConvertLedgerEvent (ShelleyBlock protocol ConwayEra) where LEDepositsConway hsh coin -> Just $ LedgerDeposits hsh coin _ -> toLedgerEventConway evt hasRewards +instance ConvertLedgerEvent (ShelleyBlock protocol DijkstraEra) where + toLedgerEvent _ _ = Nothing -- TODO(Dijkstra) + toLedgerEventShelley :: ( Event (Ledger.EraRule "TICK" ledgerera) ~ ShelleyTickEvent ledgerera , Event (Ledger.EraRule "NEWEPOCH" ledgerera) ~ ShelleyNewEpochEvent ledgerera @@ -270,18 +273,18 @@ whenHasRew has a = if has then Just a else Nothing -------------------------------------------------------------------------------- convertPoolDepositRefunds :: - Map StakeCred (Map PoolKeyHash Coin) -> + Map StakeCred (Map PoolKeyHash (CompactForm Coin)) -> Generic.Rewards convertPoolDepositRefunds rwds = Generic.Rewards $ Map.map (Set.fromList . map convert . Map.toList) rwds where - convert :: (PoolKeyHash, Coin) -> Generic.Reward + convert :: (PoolKeyHash, CompactForm Coin) -> Generic.Reward convert (kh, coin) = Generic.Reward { Generic.rewardSource = RwdDepositRefund , Generic.rewardPool = kh - , Generic.rewardAmount = coin + , Generic.rewardAmount = unCompactCoin coin } convertMirRewards :: @@ -323,7 +326,7 @@ convertPoolRewards rmap = convertReward sr = Generic.Reward { Generic.rewardSource = rewardTypeToSource $ Ledger.rewardType sr - , Generic.rewardAmount = Ledger.rewardAmount sr + , Generic.rewardAmount = fromIntegral $ unCoin $ Ledger.rewardAmount sr , Generic.rewardPool = Ledger.rewardPool sr } diff --git a/cardano-db-sync/src/Cardano/DbSync/Ledger/State.hs b/cardano-db-sync/src/Cardano/DbSync/Ledger/State.hs index 2df6f6b72..ce7059016 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Ledger/State.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Ledger/State.hs @@ -738,6 +738,7 @@ getRegisteredPools st = LedgerStateAlonzo ats -> getRegisteredPoolShelley ats LedgerStateBabbage bts -> getRegisteredPoolShelley bts LedgerStateConway stc -> getRegisteredPoolShelley stc + LedgerStateDijkstra stc -> getRegisteredPoolShelley stc getRegisteredPoolShelley :: forall p era mk. @@ -751,7 +752,7 @@ getRegisteredPoolShelley lState = Shelley.esLState $ Shelley.nesEs $ Consensus.shelleyLedgerState lState - in Shelley.psStakePoolParams $ certState ^. Shelley.certPStateL + in certState ^. Shelley.certPStateL . Shelley.psStakePoolsL ledgerEpochNo :: HasLedgerEnv -> ExtLedgerState CardanoBlock mk -> Either SyncNodeError (Maybe EpochNo) ledgerEpochNo env cls = diff --git a/cardano-db-sync/src/Cardano/DbSync/Ledger/Types.hs b/cardano-db-sync/src/Cardano/DbSync/Ledger/Types.hs index eade333f8..e4a58c97c 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Ledger/Types.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Ledger/Types.hs @@ -230,6 +230,7 @@ instance HasNewEpochState ShelleyEra where :* fn id :* fn id :* fn id + :* fn id :* Nil instance HasNewEpochState AllegraEra where @@ -245,6 +246,7 @@ instance HasNewEpochState AllegraEra where :* fn id :* fn id :* fn id + :* fn id :* Nil instance HasNewEpochState MaryEra where @@ -260,6 +262,7 @@ instance HasNewEpochState MaryEra where :* fn id :* fn id :* fn id + :* fn id :* Nil instance HasNewEpochState AlonzoEra where @@ -275,6 +278,7 @@ instance HasNewEpochState AlonzoEra where :* fn (applyNewEpochState' st) :* fn id :* fn id + :* fn id :* Nil instance HasNewEpochState BabbageEra where @@ -290,6 +294,7 @@ instance HasNewEpochState BabbageEra where :* fn id :* fn (applyNewEpochState' st) :* fn id + :* fn id :* Nil instance HasNewEpochState ConwayEra where @@ -305,6 +310,7 @@ instance HasNewEpochState ConwayEra where :* fn id :* fn id :* fn (applyNewEpochState' st) + :* fn id :* Nil hApplyExtLedgerState :: diff --git a/cardano-db-sync/src/Cardano/DbSync/Sync.hs b/cardano-db-sync/src/Cardano/DbSync/Sync.hs index 36cb7e42d..fca7c8a43 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Sync.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Sync.hs @@ -148,6 +148,8 @@ runSyncNodeClient metricsSetters syncEnv iomgr trce tc (SocketPath socketPath) = { stMuxTracer = muxTracer , stHandshakeTracer = handshakeTracer , stSubscriptionTracer = subscriptionTracer + , stMuxChannelTracer = Logging.nullTracer + , stMuxBearerTracer = Logging.nullTracer } muxTracer :: Tracer IO (Mux.WithBearer (ConnectionId LocalAddress) MuxTrace) diff --git a/cardano-db-sync/src/Cardano/DbSync/Types.hs b/cardano-db-sync/src/Cardano/DbSync/Types.hs index 5dc2cc58e..d1403ec90 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Types.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Types.hs @@ -95,6 +95,7 @@ data BlockEra = Byron | Shelley | Allegra + | Dijkstra | Mary | Alonzo | Babbage diff --git a/cardano-db-tool/src/Cardano/DbTool/Validate/Balance.hs b/cardano-db-tool/src/Cardano/DbTool/Validate/Balance.hs index 5f75d4198..30830ea1a 100644 --- a/cardano-db-tool/src/Cardano/DbTool/Validate/Balance.hs +++ b/cardano-db-tool/src/Cardano/DbTool/Validate/Balance.hs @@ -12,7 +12,7 @@ module Cardano.DbTool.Validate.Balance ( ledgerAddrBalance, ) where -import qualified Cardano.Api.Shelley as Api +import qualified Cardano.Api as Api import qualified Cardano.Chain.Block as Byron import Cardano.Chain.Common ( CompactAddress, @@ -47,8 +47,7 @@ data ValidateBalanceError | VBErrAllegra String | VBErrMary String | VBErrAlonzo String - | VBErrBabbage String - | VBErrConway String + | VBErrUndefined String instance Exception ValidateBalanceError @@ -60,8 +59,7 @@ instance Show ValidateBalanceError where VBErrAllegra err -> vBErr <> "Allegra: " <> err VBErrMary err -> vBErr <> "Mary: " <> err VBErrAlonzo err -> vBErr <> "Alonzo: " <> err - VBErrBabbage err -> vBErr <> "Babbage: " <> err - VBErrConway err -> vBErr <> "Conway: " <> err + VBErrUndefined err -> vBErr <> "Era: " <> err vBErr :: String vBErr = "Validation Balance Error - " @@ -78,8 +76,7 @@ ledgerAddrBalance addr lsc = LedgerStateAllegra st -> getShelleyBalance addr $ getUTxO st LedgerStateMary st -> getShelleyBalance addr $ getUTxO st LedgerStateAlonzo st -> getAlonzoBalance addr $ getUTxO st - LedgerStateBabbage _st -> Left $ VBErrBabbage "undefined Babbage ledgerAddrBalance" - LedgerStateConway _st -> Left $ VBErrConway "undefined Conway ledgerAddrBalance" + _ -> Left $ VBErrUndefined "undefined era ledgerAddrBalance" where getUTxO :: LedgerState (ShelleyBlock p era) mk -> Shelley.UTxO era getUTxO = Shelley.utxosUtxo . Shelley.lsUTxOState . Shelley.esLState . Shelley.nesEs . shelleyLedgerState diff --git a/cardano-db/src/Cardano/Db/Statement/Constraint.hs b/cardano-db/src/Cardano/Db/Statement/Constraint.hs index 0c089cfaf..281533efb 100644 --- a/cardano-db/src/Cardano/Db/Statement/Constraint.hs +++ b/cardano-db/src/Cardano/Db/Statement/Constraint.hs @@ -140,10 +140,7 @@ addEpochStakeTableConstraint trce = do alterTableAddUniqueConstraint proxy constraintNameEpochStake - [ FieldNameDB "epoch_no" - , FieldNameDB "addr_id" - , FieldNameDB "pool_id" - ] + (FieldNameDB <$> uniqueFields proxy) liftIO $ logNewConstraint trce tbName (unConstraintNameDB constraintNameEpochStake) -- | Log new constraint creation diff --git a/cardano-db/src/Cardano/Db/Types.hs b/cardano-db/src/Cardano/Db/Types.hs index 673f2b814..400448bac 100644 --- a/cardano-db/src/Cardano/Db/Types.hs +++ b/cardano-db/src/Cardano/Db/Types.hs @@ -285,6 +285,7 @@ data ScriptType | PlutusV1 | PlutusV2 | PlutusV3 + | PlutusV4 deriving (Eq, Generic, Show) scriptTypeDecoder :: HsqlD.Value ScriptType @@ -294,6 +295,7 @@ scriptTypeDecoder = HsqlD.enum $ \case "plutusV1" -> Just PlutusV1 "plutusV2" -> Just PlutusV2 "plutusV3" -> Just PlutusV3 + "plutusV4" -> Just PlutusV4 -- TODO(Dijkstra): Add to Schema _ -> Nothing scriptTypeEncoder :: HsqlE.Value ScriptType @@ -303,6 +305,7 @@ scriptTypeEncoder = HsqlE.enum $ \case PlutusV1 -> "plutusV1" PlutusV2 -> "plutusV2" PlutusV3 -> "plutusV3" + PlutusV4 -> "plutusV4" -------------------------------------------------------------------------------- data PoolCertAction diff --git a/cardano-smash-server/src/Cardano/SMASH/Server/Types.hs b/cardano-smash-server/src/Cardano/SMASH/Server/Types.hs index 0b818cddc..a38728ab8 100644 --- a/cardano-smash-server/src/Cardano/SMASH/Server/Types.hs +++ b/cardano-smash-server/src/Cardano/SMASH/Server/Types.hs @@ -25,13 +25,14 @@ module Cardano.SMASH.Server.Types ( ) where import Cardano.Api ( - AsType (..), Hash, deserialiseFromBech32, deserialiseFromRawBytesHex, serialiseToRawBytes, ) -import Cardano.Api.Shelley (StakePoolKey) +import Cardano.Api.Key (StakePoolKey) + +-- import Cardano.Api.Shelley (StakePoolKey) import Cardano.Db (DbSessionError, PoolMetaHash (..)) import Cardano.Prelude import Control.Monad.Fail (fail) @@ -99,7 +100,7 @@ parsePoolId poolId = pHexStakePoolId :: Text -> Maybe (Hash StakePoolKey) pHexStakePoolId = either (const Nothing) Just - . deserialiseFromRawBytesHex (AsHash AsStakePoolKey) + . deserialiseFromRawBytesHex . BS.pack . toS @@ -107,7 +108,7 @@ parsePoolId poolId = pBech32StakePoolId :: Text -> Maybe (Hash StakePoolKey) pBech32StakePoolId = either (const Nothing) Just - . deserialiseFromBech32 (AsHash AsStakePoolKey) + . deserialiseFromBech32 -- | The hash of a stake pool's metadata. -- diff --git a/flake.lock b/flake.lock index d307e7c3f..0c3994aaf 100644 --- a/flake.lock +++ b/flake.lock @@ -3,11 +3,11 @@ "CHaP": { "flake": false, "locked": { - "lastModified": 1758727647, - "narHash": "sha256-J0PlznW05SByIJZvP90JvFMvnHsP+Rs/qwLogpConI4=", + "lastModified": 1763036723, + "narHash": "sha256-1cPd4Ji72LJVNkMH7UQj/iI8nXRGiURAu6Eynod+nvM=", "owner": "IntersectMBO", "repo": "cardano-haskell-packages", - "rev": "bbf172e0d11e3842e543df101dee223f05a2332e", + "rev": "b9bc5ff7a64bbbc8bd794ce191e05e01551a91f1", "type": "github" }, "original": { @@ -151,31 +151,14 @@ "type": "github" } }, - "ghc-8.6.5-iohk": { - "flake": false, - "locked": { - "lastModified": 1600920045, - "narHash": "sha256-DO6kxJz248djebZLpSzTGD6s8WRpNI9BTwUeOf5RwY8=", - "owner": "input-output-hk", - "repo": "ghc", - "rev": "95713a6ecce4551240da7c96b6176f980af75cae", - "type": "github" - }, - "original": { - "owner": "input-output-hk", - "ref": "release/8.6.5-iohk", - "repo": "ghc", - "type": "github" - } - }, "hackage-for-stackage": { "flake": false, "locked": { - "lastModified": 1750552134, - "narHash": "sha256-KC/e7tQOID9SgRkmH3BNlnPZ7sn3v5k5GyllLmSZicY=", + "lastModified": 1763080018, + "narHash": "sha256-dhF1WJwKf3crYYZ1IzpZKvYrL2Vn9wJkaiwWz7KKLLU=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "a5d60b2d3c435cf26848e34b92e28f96e13cde7c", + "rev": "0fe00885ac43275b806a5f357bd1bb543f4bd0dc", "type": "github" }, "original": { @@ -204,11 +187,11 @@ "hackageNix": { "flake": false, "locked": { - "lastModified": 1758633641, - "narHash": "sha256-F70VZjt/AlmelvF9VHbHP6UaUnUgeWR5t/r0jsmAPVg=", + "lastModified": 1763068137, + "narHash": "sha256-podXboSHDcngPxdItaXzUOmgxDs1wj6TAAQFV/WPFqo=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "4601442c80824463bc4794a70a04091f2bf87a22", + "rev": "3293a346ee802c7d0ec0e834c74e65aa575f79ef", "type": "github" }, "original": { @@ -225,7 +208,6 @@ "cabal-36": "cabal-36", "cardano-shell": "cardano-shell", "flake-compat": "flake-compat_2", - "ghc-8.6.5-iohk": "ghc-8.6.5-iohk", "hackage": [ "hackageNix" ], @@ -260,11 +242,11 @@ "stackage": "stackage" }, "locked": { - "lastModified": 1750665090, - "narHash": "sha256-IUGsndRxeVge1tcBZbUwy5IYV2nB2XBXFiY2qqY7HKI=", + "lastModified": 1763081503, + "narHash": "sha256-4IBIATcInZQj3fMIB9nYxxCoXVUHTMlp6QvwVl4f0o4=", "owner": "input-output-hk", "repo": "haskell.nix", - "rev": "78ebf39d6f8386718b16f6cfc096232a4d42d34c", + "rev": "7631ffad2f38eacd75afa1dfa1c86ec1af548f16", "type": "github" }, "original": { @@ -535,11 +517,11 @@ "iserv-proxy": { "flake": false, "locked": { - "lastModified": 1750543273, - "narHash": "sha256-WaswH0Y+Fmupvv8AkIlQBlUy/IdD3Inx9PDuE+5iRYY=", + "lastModified": 1755243078, + "narHash": "sha256-GLbl1YaohKdpzZVJFRdcI1O1oE3F3uBer4lFv3Yy0l8=", "owner": "stable-haskell", "repo": "iserv-proxy", - "rev": "a53c57c9a8d22a66a2f0c4c969e806da03f08c28", + "rev": "150605195cb7183a6fb7bed82f23fedf37c6f52a", "type": "github" }, "original": { @@ -615,11 +597,11 @@ }, "nixpkgs-2505": { "locked": { - "lastModified": 1748852332, - "narHash": "sha256-r/wVJWmLYEqvrJKnL48r90Wn9HWX9SHFt6s4LhuTh7k=", + "lastModified": 1757716134, + "narHash": "sha256-OYoZLWvmCnCTCJQwaQlpK1IO5nkLnLLoUW8wwmPmrfU=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "a8167f3cc2f991dd4d0055746df53dae5fd0c953", + "rev": "e85b5aa112a98805a016bbf6291e726debbc448a", "type": "github" }, "original": { @@ -631,11 +613,11 @@ }, "nixpkgs-unstable": { "locked": { - "lastModified": 1748856973, - "narHash": "sha256-RlTsJUvvr8ErjPBsiwrGbbHYW8XbB/oek0Gi78XdWKg=", + "lastModified": 1759070547, + "narHash": "sha256-JVZl8NaVRYb0+381nl7LvPE+A774/dRpif01FKLrYFQ=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "e4b09e47ace7d87de083786b404bf232eb6c89d8", + "rev": "647e5c14cbd5067f44ac86b74f014962df460840", "type": "github" }, "original": { @@ -713,11 +695,11 @@ "stackage": { "flake": false, "locked": { - "lastModified": 1750292027, - "narHash": "sha256-rmEsCxLWS/rAdIzZPSi0XbrY2BOztBlSHQHgYoXyovU=", + "lastModified": 1763079199, + "narHash": "sha256-3DEm6AtrCHJhmkOPNXPZ40YQ2E7vrpgXuuASu/Bff5A=", "owner": "input-output-hk", "repo": "stackage.nix", - "rev": "3f8c717e24953914821f1ddb4797dd768326faa6", + "rev": "183c1aa28a2bf3c1a73ed879b7b22620af628f4e", "type": "github" }, "original": { From 9911efdb571a48af0c338491845c66875a1c245d Mon Sep 17 00:00:00 2001 From: Sean D Gillespie Date: Tue, 2 Dec 2025 15:37:26 -0500 Subject: [PATCH 2/8] Fix nix devShell First, pin the cabal-install version to <3.16, as it does not work with haskell-language-server 2.11, and haskell.nix doesn't yet have this available. Then pin all the other standard dev tools to the expected versions: * cabal-3.14.2.0 * fourmolu-0.17.0.0 * hlint-3.8 --- flake.nix | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/flake.nix b/flake.nix index 795150342..7ae5556a9 100644 --- a/flake.nix +++ b/flake.nix @@ -188,9 +188,9 @@ shell = { tools = { - cabal = "latest"; - fourmolu = "latest"; - hlint = "latest"; + cabal = "3.14.2.0"; + fourmolu = "0.17.0.0"; + hlint = "3.8"; haskell-language-server = { src = nixpkgs.haskell-nix.sources."hls-2.11"; From 1ecfcd0b9f34d0843c172a64e399a1438b5d59b2 Mon Sep 17 00:00:00 2001 From: Sean D Gillespie Date: Tue, 2 Dec 2025 15:36:05 -0500 Subject: [PATCH 3/8] Fix hlint violations --- .../src/Cardano/Mock/Forging/Tx/Alonzo.hs | 4 ++-- cardano-chain-gen/test/Test/Cardano/Db/Mock/Config.hs | 10 ++++++++-- .../src/Cardano/DbSync/Era/Shelley/Generic/Block.hs | 1 - 3 files changed, 10 insertions(+), 5 deletions(-) diff --git a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Alonzo.hs b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Alonzo.hs index f7e32159b..640c108d5 100644 --- a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Alonzo.hs +++ b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Alonzo.hs @@ -101,8 +101,8 @@ addValidityInterval :: SlotNo -> Core.Tx era -> Core.Tx era -addValidityInterval slotNo tx = - set (bodyTxL @era . vldtTxBodyL @era) interval tx +addValidityInterval slotNo = + set (bodyTxL @era . vldtTxBodyL @era) interval where interval = ValidityInterval Strict.SNothing (Strict.SJust slotNo) diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Config.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Config.hs index 7ba73d8e2..9203f47b5 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Config.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Config.hs @@ -1,7 +1,11 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +#if __GLASGOW_HASKELL__ >= 908 +{-# OPTIONS_GHC -Wno-x-partial #-} +#endif module Test.Cardano.Db.Mock.Config ( Config (..), @@ -164,7 +168,7 @@ mkMutableDir :: FilePath -> FilePath mkMutableDir testLabel = rootTestDir "temp" testLabel mkConfigDir :: FilePath -> FilePath -mkConfigDir config = "cardano-chain-gen" rootTestDir config +mkConfigDir config = rootTestDir config fingerprintRoot :: FilePath fingerprintRoot = rootTestDir "fingerprint" @@ -256,7 +260,7 @@ withConfig staticDir mutableDir cmdLineArgs config action = do genCfg <- runOrThrowIO $ runExceptT (readCardanoGenesisConfig config) let (pInfoDbSync, _) = mkProtocolInfoCardano genCfg [] creds <- mkShelleyCredentials $ cfgDir "pools" "bulk1.creds" - let (pInfoForger, mkForgings) = mkProtocolInfoCardano genCfg [(head creds)] + let (pInfoForger, mkForgings) = mkProtocolInfoCardano genCfg [head creds] bracket (allocateRes mkForgings) (mapM finalize) @@ -273,6 +277,8 @@ withConfig staticDir mutableDir cmdLineArgs config action = do -- _ <- throwIO $ userError "B" pure forgings' +{-# ANN withConfig ("HLint: ignore Redundant pure" :: String) #-} + mkSyncNodeConfig :: FilePath -> CommandLineArgs -> IO SyncNodeConfig mkSyncNodeConfig configFilePath cmdLineArgs = readSyncNodeConfig $ mkConfigFile configDir configFilename diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Block.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Block.hs index 0d80485d5..122c93e93 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Block.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Block.hs @@ -3,7 +3,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoImplicitPrelude #-} From e2ac86f3277dd2b0aa73fe9b181bbc2eb8666293 Mon Sep 17 00:00:00 2001 From: Sean D Gillespie Date: Tue, 2 Dec 2025 15:52:56 -0500 Subject: [PATCH 4/8] Bump hlint@3.10 As 3.8 does not seem to work with GHC 9.10 --- flake.nix | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/flake.nix b/flake.nix index 7ae5556a9..d22871ef2 100644 --- a/flake.nix +++ b/flake.nix @@ -190,7 +190,7 @@ tools = { cabal = "3.14.2.0"; fourmolu = "0.17.0.0"; - hlint = "3.8"; + hlint = "3.10"; haskell-language-server = { src = nixpkgs.haskell-nix.sources."hls-2.11"; From 69055be81ac7dd30815ac7defefb1b5ebb1f96ab Mon Sep 17 00:00:00 2001 From: Sean D Gillespie Date: Tue, 2 Dec 2025 15:58:10 -0500 Subject: [PATCH 5/8] Update hlint versions again Don't fix the hlint version in the devShell, as any given version won't support all of our compilers. Instead we'll let the solver decide on a version, but we'll pin it in the CI check. --- flake.nix | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/flake.nix b/flake.nix index d22871ef2..b43eba6a2 100644 --- a/flake.nix +++ b/flake.nix @@ -81,12 +81,11 @@ (final: prev: { hlint = final.haskell-nix.tool "ghc96" "hlint" { - version = "latest"; + version = "3.8"; }; - # Fourmolu 0.10.x requires GHC >= 9.0 && < 9.6 fourmolu = final.haskell-nix.tool "ghc96" "fourmolu" { - version = "latest"; + version = "0.17.0.0"; }; }) @@ -190,7 +189,10 @@ tools = { cabal = "3.14.2.0"; fourmolu = "0.17.0.0"; - hlint = "3.10"; + + # We'd prefer 3.8, but it won't work on all compilers we support. Instead + # we'll let solver sort it out. + hlint = "latest"; haskell-language-server = { src = nixpkgs.haskell-nix.sources."hls-2.11"; From 4b5eae88454f7caded13a638881fb444c52737c7 Mon Sep 17 00:00:00 2001 From: Sean D Gillespie Date: Thu, 4 Dec 2025 14:52:23 -0500 Subject: [PATCH 6/8] Fix GHC 9.12 devShell Pin fourmolu and hlint to our usual versions, but only provide them in the default devShell (9.6) --- flake.nix | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/flake.nix b/flake.nix index b43eba6a2..f22fdc961 100644 --- a/flake.nix +++ b/flake.nix @@ -188,16 +188,15 @@ shell = { tools = { cabal = "3.14.2.0"; - fourmolu = "0.17.0.0"; - - # We'd prefer 3.8, but it won't work on all compilers we support. Instead - # we'll let solver sort it out. - hlint = "latest"; haskell-language-server = { src = nixpkgs.haskell-nix.sources."hls-2.11"; }; } // lib.optionalAttrs (config.compiler-nix-name == "ghc967") { + # These versions work with GHC 9.6, but not with 9.10 and 9.12 + fourmolu = "0.17.0.0"; + hlint = "3.8"; + weeder = "latest"; }; From dd69152248e935d67c3b3f14db8cc072afab21bd Mon Sep 17 00:00:00 2001 From: Sean D Gillespie Date: Thu, 4 Dec 2025 16:14:50 -0500 Subject: [PATCH 7/8] Fourmolize! --- cardano-chain-gen/src/Cardano/Mock/ChainSync/Server.hs | 2 +- cardano-chain-gen/test/Test/Cardano/Db/Mock/Config.hs | 1 - 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/cardano-chain-gen/src/Cardano/Mock/ChainSync/Server.hs b/cardano-chain-gen/src/Cardano/Mock/ChainSync/Server.hs index e785320e7..930c00190 100644 --- a/cardano-chain-gen/src/Cardano/Mock/ChainSync/Server.hs +++ b/cardano-chain-gen/src/Cardano/Mock/ChainSync/Server.hs @@ -48,8 +48,8 @@ import Control.Tracer (nullTracer) import Data.ByteString.Lazy.Char8 (ByteString) import qualified Data.Map.Strict as Map import Data.Maybe (fromJust) -import Network.TypedProtocol.Peer (Peer (..)) import qualified Network.Socket as Socket +import Network.TypedProtocol.Peer (Peer (..)) import qualified Network.TypedProtocol.Stateful.Peer as St import Ouroboros.Consensus.Block (CodecConfig, HasHeader, Point, StandardHash, castPoint) import Ouroboros.Consensus.Config (TopLevelConfig, configCodec) diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Config.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Config.hs index 9203f47b5..aeaf4b477 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Config.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Config.hs @@ -276,7 +276,6 @@ withConfig staticDir mutableDir cmdLineArgs config action = do forgings' <- mapM mkBlockForging forgings -- _ <- throwIO $ userError "B" pure forgings' - {-# ANN withConfig ("HLint: ignore Redundant pure" :: String) #-} mkSyncNodeConfig :: FilePath -> CommandLineArgs -> IO SyncNodeConfig From cb8f287e2747cdc6d49d20f7d0f5c8c7a01a83e5 Mon Sep 17 00:00:00 2001 From: Sean D Gillespie Date: Thu, 4 Dec 2025 16:27:42 -0500 Subject: [PATCH 8/8] Add native aarch64-linux builds Previously, we were cross building for aarch64-linux, but now we're running into the following problem: qemu: uncaught target signal 11 (Segmentation fault) - core dumped iserv-proxy: {handle: }: GHCi.Message.remoteCall: end of file : error: ghc-iserv terminated (1) Now that we have an aarch64-linux runner, we'll just use that and we don't have to deal with cross builds and TH. --- flake.nix | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/flake.nix b/flake.nix index f22fdc961..2eb8b2fe8 100644 --- a/flake.nix +++ b/flake.nix @@ -32,6 +32,7 @@ "x86_64-linux" "x86_64-darwin" "aarch64-darwin" + "aarch64-linux" ]; in inputs.utils.lib.eachSystem supportedSystems (system: @@ -176,10 +177,7 @@ ''; crossPlatforms = p: - lib.optional (system == "x86_64-linux") p.musl64 ++ - lib.optional - (system == "x86_64-linux" && config.compiler-nix-name == "ghc967") - p.aarch64-multiplatform-musl; + lib.optional (system == "x86_64-linux") p.musl64; inputMap = { "https://chap.intersectmbo.org/" = inputs.CHaP;