From 371a4477ba0e439fe393f5c8a4023558e04db389 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jann=20M=C3=BCller?= Date: Thu, 4 Jan 2024 14:43:18 +0100 Subject: [PATCH] Update to ghc@9.6.3, cardano-node@8.7.2, cardano-api@8.36.1. --- .github/workflows/ci-linux.yaml | 86 +++--------------- .github/workflows/gh-pages.yaml | 78 ++-------------- cabal.project | 20 ++--- src/base/convex-base.cabal | 5 +- src/base/lib/Convex/BuildTx.hs | 36 ++++---- src/base/lib/Convex/Class.hs | 43 ++++----- src/base/lib/Convex/Lenses.hs | 88 ++++++++++--------- src/base/lib/Convex/NodeQueries.hs | 33 +++---- src/base/lib/Convex/PlutusLedger.hs | 4 +- src/base/lib/Convex/Scripts.hs | 20 ++--- src/base/lib/Convex/Utils.hs | 27 +++--- src/base/lib/Convex/Utxos.hs | 11 ++- .../convex-coin-selection.cabal | 1 - .../lib/Convex/CoinSelection.hs | 65 ++++++-------- .../lib/Convex/MockChain/CoinSelection.hs | 2 +- src/coin-selection/test/Spec.hs | 30 ++----- src/devnet/lib/Convex/Devnet/CardanoNode.hs | 5 +- src/devnet/lib/Convex/Devnet/NodeQueries.hs | 18 ++-- src/devnet/test/Spec.hs | 4 +- src/mockchain/convex-mockchain.cabal | 5 +- src/mockchain/lib/Convex/MockChain.hs | 70 ++++++--------- .../lib/Convex/MockChain/Defaults.hs | 26 +++--- src/mockchain/lib/Convex/NodeParams.hs | 12 +-- src/node-client/lib/Convex/NodeClient/Fold.hs | 18 ++-- .../lib/Convex/NodeClient/Progress.hs | 13 ++- .../lib/Convex/NodeClient/Resuming.hs | 8 +- .../lib/Convex/NodeClient/Types.hs | 12 +-- .../lib/Convex/NodeClient/WaitForTxnClient.hs | 15 ++-- src/wallet/lib/Convex/Wallet.hs | 13 +-- src/wallet/lib/Convex/Wallet/Cli.hs | 2 +- .../Convex/Wallet/NodeClient/BalanceClient.hs | 6 +- 31 files changed, 292 insertions(+), 484 deletions(-) diff --git a/.github/workflows/ci-linux.yaml b/.github/workflows/ci-linux.yaml index 98309a42..50309e67 100644 --- a/.github/workflows/ci-linux.yaml +++ b/.github/workflows/ci-linux.yaml @@ -5,6 +5,10 @@ on: tags: [ "*.*.*" ] pull_request: +concurrency: + group: ${{ github.ref }} + cancel-in-progress: true + jobs: build: runs-on: ubuntu-latest @@ -15,93 +19,29 @@ jobs: sudo apt-get update sudo apt-get install -y libsystemd-dev - # cache libsodium - - name: cache libsodium-1.0.18 - id: libsodium - uses: actions/cache@v2 - with: - path: ~/libsodium-stable - key: ${{ runner.os }}-libsodium-1.0.18 - - # install libsodium with cache - - name: Install cache libsodium-1.0.18 - if: steps.libsodium.outputs.cache-hit == 'true' - run: cd ~/libsodium-stable && ./configure && make -j2 && sudo make install - - # download & install libsodium without cache - - name: Install libsodium - if: steps.libsodium.outputs.cache-hit != 'true' - run: | - wget https://download.libsodium.org/libsodium/releases/libsodium-1.0.18-stable.tar.gz - tar -xvzf libsodium-1.0.18-stable.tar.gz -C ~ - cd ~/libsodium-stable - ./configure - make -j2 && make check - sudo make install - cd - - - # cache secp256K1 - - name: cache libsecp256k1 - id: libsecp256k1 - uses: actions/cache@v2 - with: - path: ~/secp256k1 - key: libsecp256k1 - - # install libsecp256k1 with cache - - name: Install cache libsecp256k1 - if: steps.libsecp256k1.outputs.cache-hit == 'true' - run: | - cd ~/secp256k1 - ./autogen.sh - ./configure --enable-module-schnorrsig --enable-experimental - make - sudo make install - cd - - - # download & install secp256k1 - - name: Install libsecp256k1 - if: steps.libsecp256k1.outputs.cache-hit != 'true' - run: | - git clone https://github.com/bitcoin-core/secp256k1 ~/secp256k1 - cd ~/secp256k1 - git checkout ac83be33 - ./autogen.sh - ./configure --enable-module-schnorrsig --enable-experimental - make - sudo make install - cd - - - # set up environment variables - - name: Setup environment variables - run: | - echo "LD_LIBRARY_PATH=/usr/local/lib:$LD_LIBRARY_PATH" >> $GITHUB_ENV - echo "PKG_CONFIG_PATH=/usr/local/lib/pkgconfig:$PKG_CONFIG_PATH" >> $GITHUB_ENV + - name: Install system dependencies + uses: input-output-hk/actions/base@latest - - uses: actions/checkout@v2 - uses: haskell-actions/setup@v2 - id: setuphaskell + id: cabal-setup with: - ghc-version: '9.2.8' + ghc-version: '9.6.3' cabal-version: '3.10.1.0' + - uses: actions/checkout@v4 + - name: Cache .cabal uses: actions/cache@v3 with: - path: ${{ steps.setuphaskell.outputs.cabal-store }} + path: ${{ steps.cabal-setup.outputs.cabal-store }} key: cabal-${{ hashFiles('cabal.project') }} - - name: Set up cabal.project.local - run: | - echo "package cardano-crypto-praos" > cabal.project.local - echo " flags: -external-libsodium-vrf" >> cabal.project.local - - name: Build dependencies for integration test run: | cabal update - cabal install -j cardano-node-8.1.1 --overwrite-policy=always - cabal install -j cardano-cli-8.4.0.0 --overwrite-policy=always + cabal install -j cardano-node-8.7.2 --overwrite-policy=always + cabal install -j cardano-cli-8.17.0.0 --overwrite-policy=always cabal install -j convex-wallet --overwrite-policy=always echo "/home/runner/.cabal/bin" >> $GITHUB_PATH diff --git a/.github/workflows/gh-pages.yaml b/.github/workflows/gh-pages.yaml index 5811ddd3..0b54aac7 100644 --- a/.github/workflows/gh-pages.yaml +++ b/.github/workflows/gh-pages.yaml @@ -16,88 +16,24 @@ jobs: sudo apt-get update sudo apt-get install -y libsystemd-dev - # cache libsodium - - name: cache libsodium-1.0.18 - id: libsodium - uses: actions/cache@v2 - with: - path: ~/libsodium-stable - key: ${{ runner.os }}-libsodium-1.0.18 - - # install libsodium with cache - - name: Install cache libsodium-1.0.18 - if: steps.libsodium.outputs.cache-hit == 'true' - run: cd ~/libsodium-stable && ./configure && make -j2 && sudo make install - - # download & install libsodium without cache - - name: Install libsodium - if: steps.libsodium.outputs.cache-hit != 'true' - run: | - wget https://download.libsodium.org/libsodium/releases/libsodium-1.0.18-stable.tar.gz - tar -xvzf libsodium-1.0.18-stable.tar.gz -C ~ - cd ~/libsodium-stable - ./configure - make -j2 && make check - sudo make install - cd - + - name: Install system dependencies + uses: input-output-hk/actions/base@latest - # cache secp256K1 - - name: cache libsecp256k1 - id: libsecp256k1 - uses: actions/cache@v2 - with: - path: ~/secp256k1 - key: libsecp256k1 - - # install libsecp256k1 with cache - - name: Install cache libsecp256k1 - if: steps.libsecp256k1.outputs.cache-hit == 'true' - run: | - cd ~/secp256k1 - ./autogen.sh - ./configure --enable-module-schnorrsig --enable-experimental - make - sudo make install - cd - - - # download & install secp256k1 - - name: Install libsecp256k1 - if: steps.libsecp256k1.outputs.cache-hit != 'true' - run: | - git clone https://github.com/bitcoin-core/secp256k1 ~/secp256k1 - cd ~/secp256k1 - git checkout ac83be33 - ./autogen.sh - ./configure --enable-module-schnorrsig --enable-experimental - make - sudo make install - cd - - - # set up environment variables - - name: Setup environment variables - run: | - echo "LD_LIBRARY_PATH=/usr/local/lib:$LD_LIBRARY_PATH" >> $GITHUB_ENV - echo "PKG_CONFIG_PATH=/usr/local/lib/pkgconfig:$PKG_CONFIG_PATH" >> $GITHUB_ENV - - - uses: actions/checkout@v2 - uses: haskell-actions/setup@v2 - id: setuphaskell + id: cabal-setup with: - ghc-version: '9.2.8' + ghc-version: '9.6.3' cabal-version: '3.10.1.0' + - uses: actions/checkout@v4 + - name: Cache .cabal uses: actions/cache@v3 with: - path: ${{ steps.setuphaskell.outputs.cabal-store }} + path: ${{ steps.cabal-setup.outputs.cabal-store }} key: cabal-haddocks-${{ hashFiles('cabal.project') }} - - name: Set up cabal.project.local - run: | - echo "package cardano-crypto-praos" > cabal.project.local - echo " flags: -external-libsodium-vrf" >> cabal.project.local - - name: Build haddocks run: | cabal update diff --git a/cabal.project b/cabal.project index 45848312..6c9e543d 100644 --- a/cabal.project +++ b/cabal.project @@ -1,9 +1,9 @@ -- Custom repository for cardano haskell packages, see --- https://github.com/input-output-hk/cardano-haskell-packages +-- https://github.com/IntersectMBO/cardano-haskell-packages -- for more information. repository cardano-haskell-packages - url: https://input-output-hk.github.io/cardano-haskell-packages + url: https://chap.intersectmbo.org/ secure: True root-keys: 3e0cce471cf09815f930210f7827266fd09045445d65923e6d0238a6cd15126f @@ -14,11 +14,14 @@ repository cardano-haskell-packages d4a35cd3121aa00d18544bb0ac01c3e1691d618f462c46129271bccf39f7e8ee index-state: - , hackage.haskell.org 2023-07-22T22:41:49Z - , cardano-haskell-packages 2023-07-26T01:36:26Z + , hackage.haskell.org 2023-11-20T23:52:53Z + , cardano-haskell-packages 2023-12-08T09:30:26Z +with-compiler: ghc-9.6.3 -with-compiler: ghc-9.2.8 +constraints: + cardano-api == 8.36.1.1, + cardano-node == 8.7.2 packages: src/base @@ -27,10 +30,3 @@ packages: src/mockchain src/coin-selection src/devnet - --- https://github.com/obsidiansystems/dependent-sum-template/issues/5 --- requires cabal 3.10 -if impl(ghc >= 9.2) - constraints : - dependent-sum-template < 0.1.2 - diff --git a/src/base/convex-base.cabal b/src/base/convex-base.cabal index 86ca29c0..de737051 100644 --- a/src/base/convex-base.cabal +++ b/src/base/convex-base.cabal @@ -54,7 +54,7 @@ library either-result build-depends: - cardano-api == 8.8.0.0, + cardano-api, cardano-ledger-core, cardano-crypto-wrapper, @@ -73,4 +73,5 @@ library serialise, bytestring, dlist, - either-result \ No newline at end of file + either-result, + strict-sop-core \ No newline at end of file diff --git a/src/base/lib/Convex/BuildTx.hs b/src/base/lib/Convex/BuildTx.hs index 3ad88ffe..56b43588 100644 --- a/src/base/lib/Convex/BuildTx.hs +++ b/src/base/lib/Convex/BuildTx.hs @@ -280,23 +280,23 @@ addAuxScript :: MonadBuildTx m => C.ScriptInEra C.BabbageEra -> m () addAuxScript s = addBtx (over (L.txAuxScripts . L._TxAuxScripts) ((:) s)) payToAddressTxOut :: C.AddressInEra C.BabbageEra -> C.Value -> C.TxOut C.CtxTx C.BabbageEra -payToAddressTxOut addr vl = C.TxOut addr (C.TxOutValue C.MultiAssetInBabbageEra vl) C.TxOutDatumNone C.ReferenceScriptNone +payToAddressTxOut addr vl = C.TxOut addr (C.TxOutValueShelleyBased C.ShelleyBasedEraBabbage $ C.toMaryValue vl) C.TxOutDatumNone C.ReferenceScriptNone payToAddress :: MonadBuildTx m => C.AddressInEra C.BabbageEra -> C.Value -> m () payToAddress addr vl = addBtx $ over L.txOuts ((:) (payToAddressTxOut addr vl)) payToPublicKey :: MonadBuildTx m => NetworkId -> Hash PaymentKey -> C.Value -> m () payToPublicKey network pk vl = - let val = C.TxOutValue C.MultiAssetInBabbageEra vl - addr = C.makeShelleyAddressInEra network (C.PaymentCredentialByKey pk) C.NoStakeAddress + let val = C.TxOutValueShelleyBased C.ShelleyBasedEraBabbage $ C.toMaryValue vl + addr = C.makeShelleyAddressInEra C.ShelleyBasedEraBabbage network (C.PaymentCredentialByKey pk) C.NoStakeAddress txo = C.TxOut addr val C.TxOutDatumNone C.ReferenceScriptNone in prependTxOut txo payToScriptHash :: MonadBuildTx m => NetworkId -> ScriptHash -> HashableScriptData -> C.StakeAddressReference -> C.Value -> m () payToScriptHash network script datum stakeAddress vl = - let val = C.TxOutValue C.MultiAssetInBabbageEra vl - addr = C.makeShelleyAddressInEra network (C.PaymentCredentialByScript script) stakeAddress - dat = C.TxOutDatumInTx C.ScriptDataInBabbageEra datum + let val = C.TxOutValueShelleyBased C.ShelleyBasedEraBabbage $ C.toMaryValue vl + addr = C.makeShelleyAddressInEra C.ShelleyBasedEraBabbage network (C.PaymentCredentialByScript script) stakeAddress + dat = C.TxOutDatumInTx C.AlonzoEraOnwardsBabbage datum txo = C.TxOut addr val dat C.ReferenceScriptNone in prependTxOut txo @@ -314,8 +314,8 @@ payToPlutusV2 network s datum stakeRef vl = payToPlutusV2InlineBase :: MonadBuildTx m => C.AddressInEra C.BabbageEra -> C.PlutusScript C.PlutusScriptV2 -> C.TxOutDatum C.CtxTx C.BabbageEra -> C.Value -> m () payToPlutusV2InlineBase addr script dat vl = - let refScript = C.ReferenceScript C.ReferenceTxInsScriptsInlineDatumsInBabbageEra (C.toScriptInAnyLang $ C.PlutusScript C.PlutusScriptV2 script) - txo = C.TxOut addr (C.TxOutValue C.MultiAssetInBabbageEra vl) dat refScript + let refScript = C.ReferenceScript C.BabbageEraOnwardsBabbage (C.toScriptInAnyLang $ C.PlutusScript C.PlutusScriptV2 script) + txo = C.TxOut addr (C.TxOutValueShelleyBased C.ShelleyBasedEraBabbage $ C.toMaryValue vl) dat refScript in prependTxOut txo payToPlutusV2Inline :: MonadBuildTx m => C.AddressInEra C.BabbageEra -> PlutusScript PlutusScriptV2 -> C.Value -> m () @@ -324,38 +324,38 @@ payToPlutusV2Inline addr script vl = payToPlutusV2InlineBase addr script C.TxOut {-| same as payToPlutusV2Inline but also specify an inline datum -} payToPlutusV2InlineWithInlineDatum :: forall a m. (MonadBuildTx m, Plutus.ToData a) => C.AddressInEra C.BabbageEra -> C.PlutusScript C.PlutusScriptV2 -> a -> C.Value -> m () payToPlutusV2InlineWithInlineDatum addr script datum vl = - let dat = C.TxOutDatumInline C.ReferenceTxInsScriptsInlineDatumsInBabbageEra (toHashableScriptData datum) + let dat = C.TxOutDatumInline C.BabbageEraOnwardsBabbage (toHashableScriptData datum) in payToPlutusV2InlineBase addr script dat vl {-| same as payToPlutusV2Inline but also specify a datum -} payToPlutusV2InlineWithDatum :: forall a m. (MonadBuildTx m, Plutus.ToData a) => C.AddressInEra C.BabbageEra -> C.PlutusScript C.PlutusScriptV2 -> a -> C.Value -> m () payToPlutusV2InlineWithDatum addr script datum vl = - let dat = C.TxOutDatumInTx C.ScriptDataInBabbageEra (toHashableScriptData datum) + let dat = C.TxOutDatumInTx C.AlonzoEraOnwardsBabbage (toHashableScriptData datum) in payToPlutusV2InlineBase addr script dat vl payToPlutusV2InlineDatum :: forall a m. (MonadBuildTx m, Plutus.ToData a) => NetworkId -> PlutusScript PlutusScriptV2 -> a -> C.StakeAddressReference -> C.Value -> m () payToPlutusV2InlineDatum network script datum stakeRef vl = - let val = C.TxOutValue C.MultiAssetInBabbageEra vl + let val = C.TxOutValueShelleyBased C.ShelleyBasedEraBabbage $ C.toMaryValue vl sh = C.hashScript (C.PlutusScript C.PlutusScriptV2 script) - addr = C.makeShelleyAddressInEra network (C.PaymentCredentialByScript sh) stakeRef - dat = C.TxOutDatumInline C.ReferenceTxInsScriptsInlineDatumsInBabbageEra (toHashableScriptData datum) + addr = C.makeShelleyAddressInEra C.ShelleyBasedEraBabbage network (C.PaymentCredentialByScript sh) stakeRef + dat = C.TxOutDatumInline C.BabbageEraOnwardsBabbage (toHashableScriptData datum) txo = C.TxOut addr val dat C.ReferenceScriptNone in prependTxOut txo -- TODO: Functions for building outputs (Output -> Output) setScriptsValid :: MonadBuildTx m => m () -setScriptsValid = addBtx $ set L.txScriptValidity (C.TxScriptValidity C.TxScriptValiditySupportedInBabbageEra C.ScriptValid) +setScriptsValid = addBtx $ set L.txScriptValidity (C.TxScriptValidity C.AlonzoEraOnwardsBabbage C.ScriptValid) {-| Set the Ada component in an output's value to at least the amount needed to cover the minimum UTxO deposit for this output -} -setMinAdaDeposit :: C.BundledProtocolParameters C.BabbageEra -> C.TxOut C.CtxTx C.BabbageEra -> C.TxOut C.CtxTx C.BabbageEra +setMinAdaDeposit :: C.LedgerProtocolParameters C.BabbageEra -> C.TxOut C.CtxTx C.BabbageEra -> C.TxOut C.CtxTx C.BabbageEra setMinAdaDeposit params txOut = let minUtxo = minAdaDeposit params txOut in txOut & over (L._TxOut . _2 . L._TxOutValue . L._Value . at C.AdaAssetId) (maybe (Just minUtxo) (Just . max minUtxo)) -minAdaDeposit :: C.BundledProtocolParameters C.BabbageEra -> C.TxOut C.CtxTx C.BabbageEra -> C.Quantity -minAdaDeposit params txOut = +minAdaDeposit :: C.LedgerProtocolParameters C.BabbageEra -> C.TxOut C.CtxTx C.BabbageEra -> C.Quantity +minAdaDeposit (C.LedgerProtocolParameters params) txOut = let minAdaValue = C.Quantity 3_000_000 txo = txOut -- set the Ada value to a dummy amount to ensure that it is not 0 (if it was 0, the size of the output @@ -367,7 +367,7 @@ minAdaDeposit params txOut = {-| Apply 'setMinAdaDeposit' to all outputs -} -setMinAdaDepositAll :: MonadBuildTx m => C.BundledProtocolParameters C.BabbageEra -> m () +setMinAdaDepositAll :: MonadBuildTx m => C.LedgerProtocolParameters C.BabbageEra -> m () setMinAdaDepositAll params = addBtx $ over (L.txOuts . mapped) (setMinAdaDeposit params) {-| Add a public key hash to the list of required signatures. diff --git a/src/base/lib/Convex/Class.hs b/src/base/lib/Convex/Class.hs index c1144efb..ec7ab8e6 100644 --- a/src/base/lib/Convex/Class.hs +++ b/src/base/lib/Convex/Class.hs @@ -25,9 +25,9 @@ module Convex.Class( import qualified Cardano.Api as C import Cardano.Api.Shelley (BabbageEra, - CardanoMode, EraHistory (..), Hash, + LedgerProtocolParameters (..), LocalNodeConnectInfo, NetworkId, PoolId, @@ -60,7 +60,6 @@ import Convex.Utils (posixTimeToS import Data.Aeson (FromJSON, ToJSON) import Data.Set (Set) -import qualified Data.Text as Text import Data.Time.Clock (UTCTime) import GHC.Generics (Generic) import Ouroboros.Consensus.HardFork.History (interpretQuery, @@ -73,10 +72,10 @@ import qualified PlutusLedgerApi.V1 as PV1 class Monad m => MonadBlockchain m where sendTx :: Tx BabbageEra -> m TxId -- ^ Submit a transaction to the network utxoByTxIn :: Set C.TxIn -> m (C.UTxO C.BabbageEra) -- ^ Resolve tx inputs - queryProtocolParameters :: m (C.BundledProtocolParameters C.BabbageEra) -- ^ Get the protocol parameters + queryProtocolParameters :: m (LedgerProtocolParameters C.BabbageEra) -- ^ Get the protocol parameters queryStakePools :: m (Set PoolId) -- ^ Get the stake pools querySystemStart :: m SystemStart - queryEraHistory :: m (EraHistory CardanoMode) + queryEraHistory :: m EraHistory querySlotNo :: m (SlotNo, SlotLength, UTCTime) -- ^ returns the current slot number, slot length and begin utc time for slot. -- Slot 0 is returned when at genesis. @@ -198,7 +197,7 @@ This MAY move the clock backwards! setTimeToValidRange :: MonadMockchain m => (C.TxValidityLowerBound C.BabbageEra, C.TxValidityUpperBound C.BabbageEra) -> m () setTimeToValidRange = \case (C.TxValidityLowerBound _ lowerSlot, _) -> setSlot lowerSlot - (_, C.TxValidityUpperBound _ upperSlot) -> setSlot (pred upperSlot) + (_, C.TxValidityUpperBound _ (Just upperSlot)) -> setSlot (pred upperSlot) _ -> pure () {-| Increase the slot number by 1. @@ -208,32 +207,27 @@ nextSlot = modifySlot (\s -> (succ s, ())) data MonadBlockchainError e = MonadBlockchainError e - | ProtocolConversionError Text.Text | FailWith String deriving stock (Eq, Functor, Generic) deriving anyclass (ToJSON, FromJSON) -protocolConversionError :: C.ProtocolParametersConversionError -> MonadBlockchainError e -protocolConversionError = ProtocolConversionError . C.textShow - instance Show e => Show (MonadBlockchainError e) where - show (MonadBlockchainError e) = show e - show (FailWith str) = str - show (ProtocolConversionError e) = show e + show (MonadBlockchainError e) = show e + show (FailWith str) = str {-| 'MonadBlockchain' implementation that connects to a cardano node -} -newtype MonadBlockchainCardanoNodeT e m a = MonadBlockchainCardanoNodeT { unMonadBlockchainCardanoNodeT :: ReaderT (LocalNodeConnectInfo CardanoMode) (ExceptT (MonadBlockchainError e) m) a } +newtype MonadBlockchainCardanoNodeT e m a = MonadBlockchainCardanoNodeT { unMonadBlockchainCardanoNodeT :: ReaderT LocalNodeConnectInfo (ExceptT (MonadBlockchainError e) m) a } deriving newtype (Functor, Applicative, Monad, MonadIO) instance Monad m => MonadError e (MonadBlockchainCardanoNodeT e m) where throwError = MonadBlockchainCardanoNodeT . throwError . MonadBlockchainError catchError (MonadBlockchainCardanoNodeT action) handler = MonadBlockchainCardanoNodeT $ catchError action (\case { MonadBlockchainError e -> unMonadBlockchainCardanoNodeT (handler e); e' -> throwError e' }) -runMonadBlockchainCardanoNodeT :: LocalNodeConnectInfo CardanoMode -> MonadBlockchainCardanoNodeT e m a -> m (Either (MonadBlockchainError e) a) +runMonadBlockchainCardanoNodeT :: LocalNodeConnectInfo -> MonadBlockchainCardanoNodeT e m a -> m (Either (MonadBlockchainError e) a) runMonadBlockchainCardanoNodeT info (MonadBlockchainCardanoNodeT action) = runExceptT (runReaderT action info) -runQuery :: (MonadIO m, MonadLog m) => C.QueryInMode CardanoMode a -> MonadBlockchainCardanoNodeT e m a +runQuery :: (MonadIO m, MonadLog m) => C.QueryInMode a -> MonadBlockchainCardanoNodeT e m a runQuery qry = MonadBlockchainCardanoNodeT $ do info <- ask result <- liftIO (C.queryNodeLocalState info Nothing qry) @@ -245,7 +239,7 @@ runQuery qry = MonadBlockchainCardanoNodeT $ do Right result' -> do pure result' -runQuery' :: (MonadIO m, MonadLog m, Show e1) => C.QueryInMode CardanoMode (Either e1 a) -> MonadBlockchainCardanoNodeT e2 m a +runQuery' :: (MonadIO m, MonadLog m, Show e1) => C.QueryInMode (Either e1 a) -> MonadBlockchainCardanoNodeT e2 m a runQuery' qry = runQuery qry >>= \case Left err -> MonadBlockchainCardanoNodeT $ do let msg = "runQuery': Era mismatch: " <> show err @@ -257,7 +251,7 @@ instance (MonadLog m, MonadIO m) => MonadBlockchain (MonadBlockchainCardanoNodeT sendTx tx = MonadBlockchainCardanoNodeT $ do let txId = C.getTxId (C.getTxBody tx) info <- ask - result <- liftIO (C.submitTxToNodeLocal info (C.TxInMode tx C.BabbageEraInCardanoMode)) + result <- liftIO (C.submitTxToNodeLocal info (C.TxInMode C.ShelleyBasedEraBabbage tx)) -- TODO: Error should be reflected in return type of 'sendTx' case result of SubmitSuccess -> do @@ -269,24 +263,21 @@ instance (MonadLog m, MonadIO m) => MonadBlockchain (MonadBlockchainCardanoNodeT throwError $ FailWith msg utxoByTxIn txIns = - runQuery' (C.QueryInEra C.BabbageEraInCardanoMode (C.QueryInShelleyBasedEra C.ShelleyBasedEraBabbage (C.QueryUTxO (C.QueryUTxOByTxIn txIns)))) + runQuery' (C.QueryInEra (C.QueryInShelleyBasedEra C.ShelleyBasedEraBabbage (C.QueryUTxO (C.QueryUTxOByTxIn txIns)))) queryProtocolParameters = do - p <- runQuery' (C.QueryInEra C.BabbageEraInCardanoMode (C.QueryInShelleyBasedEra C.ShelleyBasedEraBabbage C.QueryProtocolParameters)) - case C.bundleProtocolParams C.BabbageEra p of - Right x -> pure x - Left err -> MonadBlockchainCardanoNodeT $ throwError (protocolConversionError err) + LedgerProtocolParameters <$> runQuery' (C.QueryInEra (C.QueryInShelleyBasedEra C.ShelleyBasedEraBabbage C.QueryProtocolParameters)) queryStakePools = - runQuery' (C.QueryInEra C.BabbageEraInCardanoMode (C.QueryInShelleyBasedEra C.ShelleyBasedEraBabbage C.QueryStakePools)) + runQuery' (C.QueryInEra (C.QueryInShelleyBasedEra C.ShelleyBasedEraBabbage C.QueryStakePools)) querySystemStart = runQuery C.QuerySystemStart - queryEraHistory = runQuery (C.QueryEraHistory C.CardanoModeIsMultiEra) + queryEraHistory = runQuery C.QueryEraHistory querySlotNo = do - (eraHistory@(EraHistory _ interpreter), systemStart) <- (,) <$> queryEraHistory <*> querySystemStart - slotNo <- runQuery (C.QueryChainPoint C.CardanoMode) >>= \case + (eraHistory@(EraHistory interpreter), systemStart) <- (,) <$> queryEraHistory <*> querySystemStart + slotNo <- runQuery C.QueryChainPoint >>= \case C.ChainPointAtGenesis -> pure $ fromIntegral (0 :: Integer) C.ChainPoint slot _hsh -> pure slot MonadBlockchainCardanoNodeT $ do diff --git a/src/base/lib/Convex/Lenses.hs b/src/base/lib/Convex/Lenses.hs index 613d189f..6dda25cc 100644 --- a/src/base/lib/Convex/Lenses.hs +++ b/src/base/lib/Convex/Lenses.hs @@ -18,7 +18,8 @@ module Convex.Lenses( txMintValue, txFee, txFee', - txValidityRange, + txValidityLowerBound, + txValidityUpperBound, txMetadata, txProtocolParams, txInsCollateral, @@ -45,7 +46,6 @@ module Convex.Lenses( -- ** Validity intervals _TxValidityNoLowerBound, _TxValidityLowerBound, - _TxValidityNoUpperBound, _TxValidityUpperBound, _TxValidityFiniteRange, @@ -100,7 +100,7 @@ import qualified Cardano.Ledger.Hashes as Hashes import qualified Cardano.Ledger.Keys as Keys import Cardano.Ledger.Shelley.API (Coin, LedgerEnv (..), UTxO, UTxOState (..)) -import Cardano.Ledger.Shelley.Governance (EraGovernance (GovernanceState)) +import Cardano.Ledger.Shelley.Governance (GovState) import Cardano.Ledger.Shelley.LedgerState (LedgerState (..), updateStakeDistribution) import Control.Lens (Iso', Lens', Prism', iso, @@ -125,8 +125,9 @@ emptyTx = , C.txOuts = [] , C.txTotalCollateral = C.TxTotalCollateralNone , C.txReturnCollateral = C.TxReturnCollateralNone - , C.txFee = C.TxFeeExplicit C.TxFeesExplicitInBabbageEra 0 - , C.txValidityRange = (C.TxValidityNoLowerBound, C.TxValidityNoUpperBound C.ValidityNoUpperBoundInBabbageEra) + , C.txFee = C.TxFeeExplicit C.ShelleyBasedEraBabbage 0 + , C.txValidityLowerBound = C.TxValidityNoLowerBound + , C.txValidityUpperBound = C.TxValidityUpperBound C.ShelleyBasedEraBabbage Nothing , C.txMetadata = C.TxMetadataNone , C.txAuxScripts = C.TxAuxScriptsNone , C.txExtraKeyWits = C.TxExtraKeyWitnessesNone @@ -136,14 +137,14 @@ emptyTx = , C.txUpdateProposal = C.TxUpdateProposalNone , C.txMintValue = C.TxMintNone , C.txScriptValidity = C.TxScriptValidityNone - , C.txGovernanceActions = C.TxGovernanceActionsNone - , C.txVotes = C.TxVotesNone + , C.txProposalProcedures = Nothing + , C.txVotingProcedures = Nothing } {-| A transaction output with no value -} emptyTxOut :: AddressInEra BabbageEra -> C.TxOut C.CtxTx C.BabbageEra -emptyTxOut addr = C.TxOut addr (C.lovelaceToTxOutValue 0) C.TxOutDatumNone C.ReferenceScriptNone +emptyTxOut addr = C.TxOut addr (C.lovelaceToTxOutValue C.ShelleyBasedEraBabbage 0) C.TxOutDatumNone C.ReferenceScriptNone type TxIn v = (C.TxIn, BuildTxWith v (C.Witness C.WitCtxTxIn BabbageEra)) @@ -168,18 +169,23 @@ txFee' = lens get set_ where get = C.txFee set_ body fee = body{C.txFee = fee} -txValidityRange :: Lens' (C.TxBodyContent v e) (C.TxValidityLowerBound e, C.TxValidityUpperBound e) -txValidityRange = lens get set_ where - get = C.txValidityRange - set_ body range = body{C.txValidityRange = range} +txValidityUpperBound :: Lens' (C.TxBodyContent v e) (C.TxValidityUpperBound e) +txValidityUpperBound = lens get set_ where + get = C.txValidityUpperBound + set_ body range = body{C.txValidityUpperBound = range} + +txValidityLowerBound :: Lens' (C.TxBodyContent v e) (C.TxValidityLowerBound e) +txValidityLowerBound = lens get set_ where + get = C.txValidityLowerBound + set_ body range = body{C.txValidityLowerBound = range} txFee :: Lens' (C.TxBodyContent v BabbageEra) C.Lovelace txFee = lens get set_ where get :: C.TxBodyContent v BabbageEra -> C.Lovelace - get b = case C.txFee b of { C.TxFeeExplicit C.TxFeesExplicitInBabbageEra t_fee -> t_fee; C.TxFeeImplicit{} -> error "not possible in babbage era" } - set_ body fee = body{C.txFee = C.TxFeeExplicit C.TxFeesExplicitInBabbageEra fee} + get b = case C.txFee b of { C.TxFeeExplicit C.ShelleyBasedEraBabbage t_fee -> t_fee } + set_ body fee = body{C.txFee = C.TxFeeExplicit C.ShelleyBasedEraBabbage fee} -txProtocolParams :: Lens' (C.TxBodyContent v e) (BuildTxWith v (Maybe C.ProtocolParameters)) +txProtocolParams :: Lens' (C.TxBodyContent v e) (BuildTxWith v (Maybe (C.LedgerProtocolParameters e))) txProtocolParams = lens get set_ where get = C.txProtocolParams set_ body params = body{C.txProtocolParams = params} @@ -216,7 +222,7 @@ _TxExtraKeyWitnesses = iso from to where from (C.TxExtraKeyWitnesses _ keys) = keys to [] = C.TxExtraKeyWitnessesNone - to keys = C.TxExtraKeyWitnesses C.ExtraKeyWitnessesInBabbageEra keys + to keys = C.TxExtraKeyWitnesses C.AlonzoEraOnwardsBabbage keys txAuxScripts :: Lens' (C.TxBodyContent v BabbageEra) (C.TxAuxScripts BabbageEra) txAuxScripts = lens get set_ where @@ -230,7 +236,7 @@ _TxAuxScripts = iso from to where C.TxAuxScriptsNone -> [] C.TxAuxScripts _ s -> s to s | null s = C.TxAuxScriptsNone - | otherwise = C.TxAuxScripts C.AuxScriptsInBabbageEra s + | otherwise = C.TxAuxScripts C.AllegraEraOnwardsBabbage s _TxMetadata :: Iso' (C.TxMetadataInEra BabbageEra) (Map Word64 C.TxMetadataValue) _TxMetadata = iso from to where @@ -239,7 +245,7 @@ _TxMetadata = iso from to where C.TxMetadataNone -> Map.empty C.TxMetadataInEra _ (C.TxMetadata m) -> m to m | Map.null m = C.TxMetadataNone - | otherwise = C.TxMetadataInEra C.TxMetadataInBabbageEra (C.TxMetadata m) + | otherwise = C.TxMetadataInEra C.ShelleyBasedEraBabbage (C.TxMetadata m) _TxInsCollateral :: Iso' (C.TxInsCollateral BabbageEra) [C.TxIn] _TxInsCollateral = iso from to where @@ -249,7 +255,7 @@ _TxInsCollateral = iso from to where C.TxInsCollateral _ xs -> xs to = \case [] -> C.TxInsCollateralNone - xs -> C.TxInsCollateral C.CollateralInBabbageEra xs + xs -> C.TxInsCollateral C.AlonzoEraOnwardsBabbage xs _TxMintValue :: Iso' (TxMintValue BuildTx BabbageEra) (Value, Map PolicyId (ScriptWitness WitCtxMint BabbageEra)) _TxMintValue = iso from to where @@ -259,7 +265,7 @@ _TxMintValue = iso from to where C.TxMintValue _ vl (C.BuildTxWith mp) -> (vl, mp) to (vl, mp) | Map.null mp && vl == mempty = C.TxMintNone - | otherwise = C.TxMintValue C.MultiAssetInBabbageEra vl (C.BuildTxWith mp) + | otherwise = C.TxMintValue C.MaryEraOnwardsBabbage vl (C.BuildTxWith mp) _TxInsReference :: Iso' (C.TxInsReference build BabbageEra) [C.TxIn] _TxInsReference = iso from to where @@ -269,7 +275,7 @@ _TxInsReference = iso from to where C.TxInsReference _ ins -> ins to = \case [] -> C.TxInsReferenceNone - xs -> C.TxInsReference C.ReferenceTxInsScriptsInlineDatumsInBabbageEra xs + xs -> C.TxInsReference C.BabbageEraOnwardsBabbage xs _Value :: Iso' Value (Map AssetId Quantity) @@ -289,7 +295,7 @@ _TxOutDatumHash = prism' from to where to (C.TxOutDatumHash _ h) = Just h to _ = Nothing from :: C.Hash C.ScriptData -> TxOutDatum ctx C.BabbageEra - from h = C.TxOutDatumHash C.ScriptDataInBabbageEra h + from h = C.TxOutDatumHash C.AlonzoEraOnwardsBabbage h _TxOutDatumInTx :: Prism' (TxOutDatum CtxTx C.BabbageEra) C.HashableScriptData _TxOutDatumInTx = prism' from to where @@ -297,7 +303,7 @@ _TxOutDatumInTx = prism' from to where to (C.TxOutDatumInTx _ k) = Just k to _ = Nothing from :: C.HashableScriptData -> TxOutDatum CtxTx C.BabbageEra - from cd = C.TxOutDatumInTx C.ScriptDataInBabbageEra cd + from cd = C.TxOutDatumInTx C.AlonzoEraOnwardsBabbage cd _TxOutDatumInline :: forall ctx. Prism' (TxOutDatum ctx C.BabbageEra) C.HashableScriptData _TxOutDatumInline = prism' from to where @@ -305,7 +311,7 @@ _TxOutDatumInline = prism' from to where to (C.TxOutDatumInline _ k) = Just k to _ = Nothing from :: C.HashableScriptData -> TxOutDatum ctx C.BabbageEra - from cd = C.TxOutDatumInline C.ReferenceTxInsScriptsInlineDatumsInBabbageEra cd + from cd = C.TxOutDatumInline C.BabbageEraOnwardsBabbage cd _ShelleyAddressInBabbageEra :: Prism' (C.AddressInEra C.BabbageEra) (Shelley.Network, Credential.PaymentCredential StandardCrypto, Credential.StakeReference StandardCrypto) _ShelleyAddressInBabbageEra = prism' from to where @@ -372,7 +378,8 @@ _BuildTxWith = iso from to where _TxOutValue :: Iso' (TxOutValue BabbageEra) Value _TxOutValue = iso from to where from = C.txOutValueToValue - to = C.TxOutValue C.MultiAssetInBabbageEra + to :: Value -> TxOutValue BabbageEra + to = C.TxOutValueShelleyBased C.ShelleyBasedEraBabbage . C.toMaryValue slot :: Lens' (LedgerEnv era) SlotNo slot = lens get set_ where @@ -382,10 +389,10 @@ slot = lens get set_ where {-| 'UTxOState' iso. Note that this doesn't touch the '_stakeDistro' field. This is because the stake distro is a function of @utxo :: UTxO era@ and can be computed by @updateStakeDistribution mempty mempty utxo@. -} -_UTxOState :: forall era. (Core.EraTxOut era) => Core.PParams era -> Iso' (UTxOState era) (UTxO era, Coin, Coin, GovernanceState era) +_UTxOState :: forall era. (Core.EraTxOut era) => Core.PParams era -> Iso' (UTxOState era) (UTxO era, Coin, Coin, GovState era, Coin) _UTxOState pp = iso from to where - from UTxOState{utxosUtxo, utxosDeposited, utxosFees, utxosGovernance} = (utxosUtxo, utxosDeposited, utxosFees, utxosGovernance) - to (utxosUtxo, utxosDeposited, utxosFees, utxosGovernance) = UTxOState{utxosUtxo, utxosDeposited, utxosFees, utxosGovernance, utxosStakeDistr = updateStakeDistribution pp mempty mempty utxosUtxo} + from UTxOState{utxosUtxo, utxosDeposited, utxosFees, utxosGovState, utxosDonation} = (utxosUtxo, utxosDeposited, utxosFees, utxosGovState, utxosDonation) + to (utxosUtxo, utxosDeposited, utxosFees, utxosGovState, utxosDonation) = UTxOState{utxosUtxo, utxosDeposited, utxosFees, utxosGovState, utxosDonation, utxosStakeDistr = updateStakeDistribution pp mempty mempty utxosUtxo} utxoState :: Lens' (LedgerState era) (UTxOState era) @@ -469,30 +476,25 @@ _TxValidityNoLowerBound = prism' from to where C.TxValidityNoLowerBound -> Just () _ -> Nothing -_TxValidityLowerBound :: forall era. Prism' (C.TxValidityLowerBound era) (C.ValidityLowerBoundSupportedInEra era, C.SlotNo) +_TxValidityLowerBound :: forall era. Prism' (C.TxValidityLowerBound era) (C.AllegraEraOnwards era, C.SlotNo) _TxValidityLowerBound = prism' from to where from (s, e) = C.TxValidityLowerBound s e to = \case C.TxValidityLowerBound s e -> Just (s, e) _ -> Nothing -_TxValidityNoUpperBound :: forall era. Prism' (C.TxValidityUpperBound era) (C.ValidityNoUpperBoundSupportedInEra era) -_TxValidityNoUpperBound = prism' from to where - from = C.TxValidityNoUpperBound - to = \case - C.TxValidityNoUpperBound k -> Just k - _ -> Nothing +_TxValidityUpperBound :: forall era. Iso' (C.TxValidityUpperBound era) (C.ShelleyBasedEra era, Maybe SlotNo) +_TxValidityUpperBound = iso from to where + from :: C.TxValidityUpperBound era -> (C.ShelleyBasedEra era, Maybe SlotNo) + from = \case + C.TxValidityUpperBound k s -> (k, s) -_TxValidityUpperBound :: forall era. Prism' (C.TxValidityUpperBound era) (C.ValidityUpperBoundSupportedInEra era, SlotNo) -_TxValidityUpperBound = prism' from to where - from (k, s) = C.TxValidityUpperBound k s - to = \case - C.TxValidityUpperBound k s -> Just (k, s) - _ -> Nothing + to :: (C.ShelleyBasedEra era, Maybe SlotNo) -> C.TxValidityUpperBound era + to (k, s) = C.TxValidityUpperBound k s _TxValidityFiniteRange :: Prism' (C.TxValidityLowerBound C.BabbageEra, C.TxValidityUpperBound C.BabbageEra) (SlotNo, SlotNo) _TxValidityFiniteRange = prism' from to where - from (l, u) = (C.TxValidityLowerBound C.ValidityLowerBoundInBabbageEra l, C.TxValidityUpperBound C.ValidityUpperBoundInBabbageEra u) + from (l, u) = (C.TxValidityLowerBound C.AllegraEraOnwardsBabbage l, C.TxValidityUpperBound C.ShelleyBasedEraBabbage (Just u)) to = \case - (C.TxValidityLowerBound _ l, C.TxValidityUpperBound _ u) -> Just (l, u) + (C.TxValidityLowerBound _ l, C.TxValidityUpperBound _ (Just u)) -> Just (l, u) _ -> Nothing diff --git a/src/base/lib/Convex/NodeQueries.hs b/src/base/lib/Convex/NodeQueries.hs index ba53d1d8..9ede3afc 100644 --- a/src/base/lib/Convex/NodeQueries.hs +++ b/src/base/lib/Convex/NodeQueries.hs @@ -11,10 +11,7 @@ module Convex.NodeQueries( queryProtocolParameters ) where -import Cardano.Api (BabbageEra, - BundledProtocolParameters, - CardanoMode, - ChainPoint, +import Cardano.Api (ChainPoint, ConsensusModeParams (..), Env (..), EpochSlots (..), @@ -29,6 +26,7 @@ import qualified Cardano.Api as CAPI import qualified Cardano.Chain.Genesis import Cardano.Crypto (RequiresNetworkMagic (..), getProtocolMagic) +import Cardano.Ledger.Core (PParams) import Control.Monad.Except (MonadError, throwError) import Control.Monad.IO.Class (MonadIO (..)) @@ -38,6 +36,7 @@ import qualified Ouroboros.Consensus.Cardano.CanHardFork as Consensus import qualified Ouroboros.Consensus.HardFork.Combinator as Consensus import qualified Ouroboros.Consensus.HardFork.Combinator.AcrossEras as HFC import qualified Ouroboros.Consensus.HardFork.Combinator.Basics as HFC +import Ouroboros.Consensus.Shelley.Eras (StandardBabbage) {-| Load the node config file and create 'LocalNodeConnectInfo' and 'Env' values that can be used to talk to the node. -} @@ -47,7 +46,7 @@ loadConnectInfo :: -- ^ Node config file (JSON) -> FilePath -- ^ Node socket - -> m (LocalNodeConnectInfo CardanoMode, Env) + -> m (LocalNodeConnectInfo, Env) loadConnectInfo nodeConfigFilePath socketPath = do (env, _) <- liftIO (runExceptT (CAPI.initialLedgerState (CAPI.File nodeConfigFilePath))) >>= either throwError pure @@ -70,7 +69,7 @@ loadConnectInfo nodeConfigFilePath socketPath = do cardanoModeParams = CardanoModeParams . EpochSlots $ 10 * envSecurityParam env -- Connect to the node. - let connectInfo :: LocalNodeConnectInfo CardanoMode + let connectInfo :: LocalNodeConnectInfo connectInfo = LocalNodeConnectInfo { localConsensusModeParams = cardanoModeParams, @@ -80,19 +79,19 @@ loadConnectInfo nodeConfigFilePath socketPath = do pure (connectInfo, env) -- | Get the system start from the local cardano node -querySystemStart :: LocalNodeConnectInfo CardanoMode -> IO SystemStart +querySystemStart :: LocalNodeConnectInfo -> IO SystemStart querySystemStart = queryLocalState CAPI.QuerySystemStart -- | Get the era history from the local cardano node -queryEraHistory :: LocalNodeConnectInfo CardanoMode -> IO (EraHistory CardanoMode) -queryEraHistory = queryLocalState (CAPI.QueryEraHistory CAPI.CardanoModeIsMultiEra) +queryEraHistory :: LocalNodeConnectInfo -> IO EraHistory +queryEraHistory = queryLocalState CAPI.QueryEraHistory -- | Get the tip from the local cardano node -queryTip :: LocalNodeConnectInfo CardanoMode -> IO ChainPoint -queryTip = queryLocalState (CAPI.QueryChainPoint CAPI.CardanoMode) +queryTip :: LocalNodeConnectInfo -> IO ChainPoint +queryTip = queryLocalState CAPI.QueryChainPoint -- | Run a local state query on the local cardano node -queryLocalState :: CAPI.QueryInMode CardanoMode b -> LocalNodeConnectInfo CardanoMode -> IO b +queryLocalState :: CAPI.QueryInMode b -> LocalNodeConnectInfo -> IO b queryLocalState query connectInfo = do CAPI.queryNodeLocalState connectInfo Nothing query >>= \case Left err -> do @@ -100,14 +99,10 @@ queryLocalState query connectInfo = do Right result -> pure result -- | Get the protocol parameters from the local cardano node -queryProtocolParameters :: LocalNodeConnectInfo CardanoMode -> IO (BundledProtocolParameters BabbageEra) +queryProtocolParameters :: LocalNodeConnectInfo -> IO (PParams StandardBabbage) queryProtocolParameters connectInfo = do - result <- queryLocalState (CAPI.QueryInEra CAPI.BabbageEraInCardanoMode (CAPI.QueryInShelleyBasedEra CAPI.ShelleyBasedEraBabbage CAPI.QueryProtocolParameters)) connectInfo + result <- queryLocalState (CAPI.QueryInEra (CAPI.QueryInShelleyBasedEra CAPI.ShelleyBasedEraBabbage CAPI.QueryProtocolParameters)) connectInfo case result of Left err -> do fail ("queryProtocolParameters: failed with: " <> show err) - -- Right k -> pure (CAPI.bundleProtocolParams k) - Right x -> case CAPI.bundleProtocolParams CAPI.BabbageEra x of - Left err -> do - fail ("queryProtocolParameters: bundleProtocolParams failed with: " <> show err) - Right k -> pure k + Right x -> pure x diff --git a/src/base/lib/Convex/PlutusLedger.hs b/src/base/lib/Convex/PlutusLedger.hs index 16cd85a5..9ff42ba9 100644 --- a/src/base/lib/Convex/PlutusLedger.hs +++ b/src/base/lib/Convex/PlutusLedger.hs @@ -218,7 +218,7 @@ unTransPOSIXTime :: PV1.POSIXTime -> POSIXTime unTransPOSIXTime (PV1.POSIXTime pt) = realToFrac @Rational $ fromIntegral pt / 1000 unTransTxOutValue :: PV1.Value -> Either C.SerialiseAsRawBytesError (C.TxOutValue C.BabbageEra) -unTransTxOutValue value = C.TxOutValue C.MultiAssetInBabbageEra <$> unTransValue value +unTransTxOutValue value = C.TxOutValueShelleyBased C.ShelleyBasedEraBabbage . C.toMaryValue <$> unTransValue value unTransValue :: PV1.Value -> Either C.SerialiseAsRawBytesError C.Value unTransValue = @@ -247,7 +247,7 @@ unTransScriptDataHash (P.DatumHash bs) = C.deserialiseFromRawBytes (C.AsHash C.AsScriptData) (PlutusTx.fromBuiltin bs) unTransTxOutDatumHash :: P.DatumHash -> Either C.SerialiseAsRawBytesError (C.TxOutDatum ctx C.BabbageEra) -unTransTxOutDatumHash datumHash = C.TxOutDatumHash C.ScriptDataInBabbageEra <$> unTransScriptDataHash datumHash +unTransTxOutDatumHash datumHash = C.TxOutDatumHash C.AlonzoEraOnwardsBabbage <$> unTransScriptDataHash datumHash _Interval :: Iso' (Interval a) (LowerBound a, UpperBound a) _Interval = iso from to where diff --git a/src/base/lib/Convex/Scripts.hs b/src/base/lib/Convex/Scripts.hs index 1d585766..b3daf5e1 100644 --- a/src/base/lib/Convex/Scripts.hs +++ b/src/base/lib/Convex/Scripts.hs @@ -14,16 +14,16 @@ module Convex.Scripts( ) where -import Cardano.Api (PlutusScript) -import qualified Cardano.Api.Shelley as C -import Cardano.Ledger.Alonzo.Scripts.Data (Data (..)) -import Codec.Serialise (serialise) -import Data.ByteString.Lazy (toStrict) -import Data.ByteString.Short (toShort) -import Ouroboros.Consensus.Shelley.Eras (StandardBabbage) -import PlutusLedgerApi.Common (serialiseCompiledCode) -import qualified PlutusLedgerApi.V1 as PV1 -import PlutusTx.Code (CompiledCode) +import Cardano.Api (PlutusScript) +import qualified Cardano.Api.Shelley as C +import Cardano.Ledger.Plutus.Data (Data (..)) +import Codec.Serialise (serialise) +import Data.ByteString.Lazy (toStrict) +import Data.ByteString.Short (toShort) +import Ouroboros.Consensus.Shelley.Eras (StandardBabbage) +import PlutusLedgerApi.Common (serialiseCompiledCode) +import qualified PlutusLedgerApi.V1 as PV1 +import PlutusTx.Code (CompiledCode) {-| Get the 'PlutusScript' of a 'CompiledCode' -} diff --git a/src/base/lib/Convex/Utils.hs b/src/base/lib/Convex/Utils.hs index 0d60031a..12d1817d 100644 --- a/src/base/lib/Convex/Utils.hs +++ b/src/base/lib/Convex/Utils.hs @@ -46,7 +46,6 @@ module Convex.Utils( import Cardano.Api (BabbageEra, Block (..), BlockInMode (..), - CardanoMode, NetworkId, PaymentCredential (..), PlutusScript, @@ -103,7 +102,7 @@ unsafeScriptFromCborV1 = either error id . scriptFromCborV1 scriptAddressV1 :: NetworkId -> PlutusScript PlutusScriptV1 -> C.AddressInEra C.BabbageEra scriptAddressV1 network script = let hash = C.hashScript (C.PlutusScript C.PlutusScriptV1 script) - in C.makeShelleyAddressInEra network (C.PaymentCredentialByScript hash) C.NoStakeAddress + in C.makeShelleyAddressInEra C.ShelleyBasedEraBabbage network (C.PaymentCredentialByScript hash) C.NoStakeAddress scriptFromCbor :: String -> Either String (PlutusScript PlutusScriptV2) scriptFromCbor cbor = do @@ -128,14 +127,14 @@ unsafeTxFromCbor = either error id . txFromCbor scriptAddress :: NetworkId -> PlutusScript PlutusScriptV2 -> C.AddressInEra C.BabbageEra scriptAddress network script = let hash = C.hashScript (C.PlutusScript C.PlutusScriptV2 script) - in C.makeShelleyAddressInEra network (C.PaymentCredentialByScript hash) C.NoStakeAddress + in C.makeShelleyAddressInEra C.ShelleyBasedEraBabbage network (C.PaymentCredentialByScript hash) C.NoStakeAddress s :: String -> String s = id {-| Search for interesting transactions in a block and serialise them to JSON files -} -extractTx :: forall m. MonadIO m => Set C.TxId -> BlockInMode CardanoMode -> m () +extractTx :: forall m. MonadIO m => Set C.TxId -> BlockInMode -> m () extractTx txIds = let extractTx' :: C.Tx C.BabbageEra -> m () extractTx' tx@(C.Tx txBody _) = do @@ -143,7 +142,7 @@ extractTx txIds = when (txi `Set.member` txIds) $ void $ liftIO $ C.writeFileTextEnvelope (C.File $ show txi <> ".json") Nothing tx in \case - BlockInMode (Block _ txns) C.BabbageEraInCardanoMode -> + BlockInMode C.BabbageEra (Block _ txns) -> traverse_ extractTx' txns _ -> pure () @@ -157,13 +156,13 @@ txnUtxos tx = {-| Convert a slot number to UTC time -} -slotToUtcTime :: C.EraHistory mode -> C.SystemStart -> SlotNo -> Either String UTCTime +slotToUtcTime :: C.EraHistory -> C.SystemStart -> SlotNo -> Either String UTCTime slotToUtcTime (toLedgerEpochInfo -> info) systemStart slot = epochInfoSlotToUTCTime info systemStart slot {-| Convert a UTC time to slot no. Returns the time spent and time left in this slot. -} -utcTimeToSlot :: C.EraHistory mode -> C.SystemStart -> UTCTime -> Either String (SlotNo, NominalDiffTime, NominalDiffTime) -utcTimeToSlot (C.EraHistory _ interpreter) systemStart t = first show $ +utcTimeToSlot :: C.EraHistory -> C.SystemStart -> UTCTime -> Either String (SlotNo, NominalDiffTime, NominalDiffTime) +utcTimeToSlot (C.EraHistory interpreter) systemStart t = first show $ Qry.interpretQuery interpreter (Qry.wallclockToSlot (Time.toRelativeTime systemStart t)) utcTimeToPosixTime :: UTCTime -> PV1.POSIXTime @@ -171,7 +170,7 @@ utcTimeToPosixTime = transPOSIXTime . utcTimeToPOSIXSeconds {-| Convert a 'PV1.POSIXTime' to slot no. Returns the time spent and time left in this slot. -} -posixTimeToSlot :: C.EraHistory mode -> C.SystemStart -> PV1.POSIXTime -> Either String (SlotNo, NominalDiffTime, NominalDiffTime) +posixTimeToSlot :: C.EraHistory -> C.SystemStart -> PV1.POSIXTime -> Either String (SlotNo, NominalDiffTime, NominalDiffTime) posixTimeToSlot eraHistory systemStart (posixSecondsToUTCTime . unTransPOSIXTime -> utcTime) = utcTimeToSlot eraHistory systemStart utcTime @@ -180,19 +179,19 @@ Extends the interpreter range to infinity before running the query, ignoring any future hard forks. This avoids horizon errors for times that are in the future. It may still fail for times that are in the past (before the beginning of the horizin) -} -utcTimeToSlotUnsafe :: C.EraHistory mode -> C.SystemStart -> UTCTime -> Either String (SlotNo, NominalDiffTime, NominalDiffTime) -utcTimeToSlotUnsafe (C.EraHistory _ interpreter) systemStart t = first show $ +utcTimeToSlotUnsafe :: C.EraHistory -> C.SystemStart -> UTCTime -> Either String (SlotNo, NominalDiffTime, NominalDiffTime) +utcTimeToSlotUnsafe (C.EraHistory interpreter) systemStart t = first show $ Qry.interpretQuery (Qry.unsafeExtendSafeZone interpreter) (Qry.wallclockToSlot (Time.toRelativeTime systemStart t)) {-| Convert a 'PV1.POSIXTime' to slot no. Returns the time spent and time left in this slot. -} -posixTimeToSlotUnsafe :: C.EraHistory mode -> C.SystemStart -> PV1.POSIXTime -> Either String (SlotNo, NominalDiffTime, NominalDiffTime) +posixTimeToSlotUnsafe :: C.EraHistory -> C.SystemStart -> PV1.POSIXTime -> Either String (SlotNo, NominalDiffTime, NominalDiffTime) posixTimeToSlotUnsafe eraHistory systemStart (posixSecondsToUTCTime . unTransPOSIXTime -> utcTime) = utcTimeToSlotUnsafe eraHistory systemStart utcTime -- FIXME: Looks like this function is exposed by Cardano.Api in cardano-node@v1.36 -toLedgerEpochInfo :: C.EraHistory mode -> EpochInfo (Either String) -toLedgerEpochInfo (C.EraHistory _ interpreter) = +toLedgerEpochInfo :: C.EraHistory -> EpochInfo (Either String) +toLedgerEpochInfo (C.EraHistory interpreter) = hoistEpochInfo (first show . runExcept) $ Consensus.interpreterToEpochInfo interpreter diff --git a/src/base/lib/Convex/Utxos.hs b/src/base/lib/Convex/Utxos.hs index efc90500..d944c56b 100644 --- a/src/base/lib/Convex/Utxos.hs +++ b/src/base/lib/Convex/Utxos.hs @@ -59,7 +59,6 @@ module Convex.Utxos( import Cardano.Api (AddressInEra, BabbageEra, Block (..), BlockInMode (..), - CardanoMode, EraInMode (..), HashableScriptData, PaymentCredential, StakeCredential, Tx (..), TxId, @@ -379,14 +378,14 @@ inv (UtxoChange added removed) = UtxoChange removed added {-| Extract from a block the UTXO changes at the given address. Returns the 'UtxoChange' itself and a set of all transactions that affected the change. -} -extract :: (C.TxIn -> C.TxOut C.CtxTx C.BabbageEra -> Maybe a) -> Maybe AddressCredential -> UtxoSet C.CtxTx a -> BlockInMode CardanoMode -> [UtxoChangeEvent a] +extract :: (C.TxIn -> C.TxOut C.CtxTx C.BabbageEra -> Maybe a) -> Maybe AddressCredential -> UtxoSet C.CtxTx a -> BlockInMode -> [UtxoChangeEvent a] extract ex cred state = DList.toList . \case - BlockInMode block BabbageEraInCardanoMode -> extractBabbage ex state cred block + BlockInMode C.BabbageEra block -> extractBabbage ex state cred block _ -> mempty {-| Extract from a block the UTXO changes at the given address -} -extract_ :: AddressCredential -> UtxoSet C.CtxTx () -> BlockInMode CardanoMode -> UtxoChange C.CtxTx () +extract_ :: AddressCredential -> UtxoSet C.CtxTx () -> BlockInMode -> UtxoChange C.CtxTx () extract_ a b = foldMap fromEvent . extract (\_ -> const $ Just ()) (Just a) b {-| Extract from a transaction the UTXO changes at the given address} @@ -406,8 +405,8 @@ extractBabbageTxn' ex UtxoSet{_utxos} cred theTx@(Tx txBody _) = allOuts = C.fromLedgerTxOuts C.ShelleyBasedEraBabbage txBody' scriptData txReds = case scriptData of - C.TxBodyScriptData C.ScriptDataInBabbageEra _ r -> unRedeemers r - _ -> mempty + C.TxBodyScriptData _ _ r -> unRedeemers r + _ -> mempty checkInput :: (Word64, TxIn) -> Maybe (TxIn, ((C.TxOut C.CtxTx C.BabbageEra, a), Maybe (HashableScriptData, ExecutionUnits))) checkInput (idx, txIn) = fmap (txIn,) $ do diff --git a/src/coin-selection/convex-coin-selection.cabal b/src/coin-selection/convex-coin-selection.cabal index 92e46591..1ba13a5d 100644 --- a/src/coin-selection/convex-coin-selection.cabal +++ b/src/coin-selection/convex-coin-selection.cabal @@ -82,6 +82,5 @@ test-suite convex-coin-selection-test containers, plutus-ledger-api:{plutus-ledger-api, plutus-ledger-api-testlib}, plutus-ledger-api, - cardano-ledger-core, mtl, transformers \ No newline at end of file diff --git a/src/coin-selection/lib/Convex/CoinSelection.hs b/src/coin-selection/lib/Convex/CoinSelection.hs index 74392b88..afd4ee67 100644 --- a/src/coin-selection/lib/Convex/CoinSelection.hs +++ b/src/coin-selection/lib/Convex/CoinSelection.hs @@ -42,9 +42,11 @@ module Convex.CoinSelection( publicKeyCredential ) where -import Cardano.Api.Shelley (BabbageEra, BuildTx, CardanoMode, - EraHistory, PoolId, TxBodyContent, - TxOut, UTxO (..)) +import qualified Cardano.Api as Cardano.Api +import Cardano.Api.Pretty (docToString) +import Cardano.Api.Shelley (BabbageEra, BuildTx, EraHistory, + PoolId, TxBodyContent, TxOut, + UTxO (..)) import qualified Cardano.Api.Shelley as C import Cardano.Ledger.Crypto (StandardCrypto) import qualified Cardano.Ledger.Keys as Keys @@ -129,7 +131,7 @@ data CoinSelectionError = deriving anyclass (ToJSON, FromJSON) bodyError :: C.TxBodyError -> CoinSelectionError -bodyError = BodyError . Text.pack . C.displayError +bodyError = BodyError . Text.pack . docToString . C.prettyError data BalancingError = BalancingError Text @@ -140,7 +142,7 @@ data BalancingError = deriving anyclass (ToJSON, FromJSON) balancingError :: MonadError BalancingError m => Either C.TxBodyErrorAutoBalance a -> m a -balancingError = either (throwError . BalancingError . Text.pack . C.displayError) pure +balancingError = either (throwError . BalancingError . Text.pack . docToString . C.prettyError) pure -- | Messages that are produced during coin selection and balancing data TxBalancingMessage = @@ -158,7 +160,7 @@ data TxBalancingMessage = {-| Perform transaction balancing -} -balanceTransactionBody :: (MonadError BalancingError m) => Tracer m TxBalancingMessage -> SystemStart -> EraHistory CardanoMode -> C.BundledProtocolParameters C.BabbageEra -> Set PoolId -> CSInputs -> m (C.BalancedTxBody ERA, BalanceChanges) +balanceTransactionBody :: (MonadError BalancingError m) => Tracer m TxBalancingMessage -> SystemStart -> EraHistory -> C.LedgerProtocolParameters BabbageEra -> Set PoolId -> CSInputs -> m (C.BalancedTxBody ERA, BalanceChanges) balanceTransactionBody tracer systemStart eraHistory protocolParams stakePools CSInputs{csiUtxo, csiTxBody, csiChangeOutput, csiNumWitnesses=TransactionSignatureCount numWits} = do let mkChangeOutputFor i = csiChangeOutput & L._TxOut . _2 . L._TxOutValue . L._Value . at C.AdaAssetId ?~ i changeOutputSmall = mkChangeOutputFor 1 @@ -168,16 +170,16 @@ balanceTransactionBody tracer systemStart eraHistory protocolParams stakePools C -- append output instead of prepending txbody0 <- - balancingError . first C.TxBodyError $ C.createAndValidateTransactionBody $ csiTxBody & appendTxOut changeOutputSmall + balancingError . first C.TxBodyError $ C.createAndValidateTransactionBody C.ShelleyBasedEraBabbage $ csiTxBody & appendTxOut changeOutputSmall exUnitsMap <- balancingError . first C.TxBodyErrorValidityInterval $ - C.evaluateTransactionExecutionUnits + C.evaluateTransactionExecutionUnits C.BabbageEra systemStart (C.toLedgerEpochInfo eraHistory) protocolParams csiUtxo txbody0 - traceWith tracer $ ExUnitsMap $ fmap (second (first C.displayError)) $ Map.toList exUnitsMap + traceWith tracer $ ExUnitsMap $ fmap (second (first (docToString . C.prettyError))) $ Map.toList exUnitsMap exUnitsMap' <- balancingError $ case Map.mapEither id exUnitsMap of @@ -188,48 +190,39 @@ balanceTransactionBody tracer systemStart eraHistory protocolParams stakePools C txbodycontent1' = txbodycontent1 & set L.txFee (C.Lovelace (2^(32 :: Integer) - 1)) & over L.txOuts (|> changeOutputLarge) -- append output instead of prepending - txbody1 <- balancingError . first C.TxBodyError $ C.createAndValidateTransactionBody txbodycontent1' + txbody1 <- balancingError . first C.TxBodyError $ C.createAndValidateTransactionBody C.ShelleyBasedEraBabbage txbodycontent1' - let !t_fee = C.evaluateTransactionFee protocolParams txbody1 numWits 0 + let !t_fee = C.evaluateTransactionFee C.ShelleyBasedEraBabbage (C.unLedgerProtocolParameters protocolParams) txbody1 numWits 0 traceWith tracer Txfee{fee = t_fee} let txbodycontent2 = txbodycontent1 & set L.txFee t_fee & appendTxOut csiChangeOutput - txbody2 <- balancingError . first C.TxBodyError $ C.createAndValidateTransactionBody txbodycontent2 + txbody2 <- balancingError . first C.TxBodyError $ C.createAndValidateTransactionBody C.ShelleyBasedEraBabbage txbodycontent2 -- TODO: If there are any stake pool unregistration certificates in the transaction -- then we need to provide a @Map StakeCredential Lovelace@ here. -- See https://github.com/input-output-hk/cardano-api/commit/d23f964d311282b1950b2fd840bcc57ae40a0998 let unregPoolStakeBalance = mempty - let !balance = C.evaluateTransactionBalance protocolParams stakePools unregPoolStakeBalance csiUtxo txbody2 + let !balance = view L._TxOutValue (Cardano.Api.evaluateTransactionBalance C.ShelleyBasedEraBabbage (C.unLedgerProtocolParameters protocolParams) stakePools unregPoolStakeBalance mempty csiUtxo txbody2) - traceWith tracer TxRemainingBalance{remainingBalance = view L._TxOutValue balance} + traceWith tracer TxRemainingBalance{remainingBalance = balance} mapM_ (`checkMinUTxOValue` protocolParams) $ C.txOuts txbodycontent1 -- debug "balanceTransactionBody: changeOutputBalance" - changeOutputBalance <- case balance of - C.TxOutAdaOnly _ b -> do + changeOutputBalance <- case C.valueToLovelace balance of + Just b -> do let op = csiChangeOutput & L._TxOut . _2 . L._TxOutValue . L._Value . at C.AdaAssetId <>~ (Just $ C.lovelaceToQuantity b) balanceCheck protocolParams op pure op - C.TxOutValue _ v -> do - case C.valueToLovelace v of - -- FIXME: Support non Ada assets. This isn't as easy as just adding @v@ to the change output, - -- because any non-Ada that are not present in the original change output will increase - -- the output's size, so the fee will need to be computed again. - Nothing -> balancingError $ Left $ C.TxBodyErrorNonAdaAssetsUnbalanced v - Just lvl -> do - let op = csiChangeOutput & L._TxOut . _2 . L._TxOutValue . L._Value . at C.AdaAssetId <>~ (Just $ C.lovelaceToQuantity lvl) - balanceCheck protocolParams op - pure op + Nothing -> balancingError $ Left $ C.TxBodyErrorNonAdaAssetsUnbalanced balance let finalBodyContent = txbodycontent1 & set L.txFee t_fee & appendTxOut changeOutputBalance - txbody3 <- balancingError . first C.TxBodyError $ C.createAndValidateTransactionBody finalBodyContent + txbody3 <- balancingError . first C.TxBodyError $ C.createAndValidateTransactionBody C.ShelleyBasedEraBabbage finalBodyContent balances <- maybe (throwError ComputeBalanceChangeError) pure (balanceChanges csiUtxo finalBodyContent) @@ -239,10 +232,10 @@ balanceTransactionBody tracer systemStart eraHistory protocolParams stakePools C checkMinUTxOValue :: MonadError BalancingError m => C.TxOut C.CtxTx C.BabbageEra - -> C.BundledProtocolParameters C.BabbageEra + -> C.LedgerProtocolParameters BabbageEra -> m () checkMinUTxOValue txout@(C.TxOut _ v _ _) pparams' = do - let minUTxO = C.calculateMinimumUTxO C.ShelleyBasedEraBabbage txout pparams' + let minUTxO = C.calculateMinimumUTxO C.ShelleyBasedEraBabbage txout (C.unLedgerProtocolParameters pparams') if C.txOutValueToLovelace v >= minUTxO then pure () else throwError (CheckMinUtxoValueError txout minUTxO) @@ -253,7 +246,7 @@ appendTxOut out = over L.txOuts (|> out) {-| Check that the output has a positive Ada balance greater than or equal to the minimum UTxO requirement -} -balanceCheck :: MonadError BalancingError m => C.BundledProtocolParameters C.BabbageEra -> C.TxOut C.CtxTx C.BabbageEra -> m () +balanceCheck :: MonadError BalancingError m => C.LedgerProtocolParameters BabbageEra -> C.TxOut C.CtxTx C.BabbageEra -> m () balanceCheck pparams output = let balance = view (L._TxOut . _2) output in if view L._TxOutValue balance == mempty @@ -392,7 +385,7 @@ balanceTx :: balanceTx dbg returnUTxO0 walletUtxo txb = do params <- queryProtocolParameters pools <- queryStakePools - let txb0 = txb & L.txProtocolParams .~ C.BuildTxWith (Just $ C.unbundleProtocolParams params) + let txb0 = txb & L.txProtocolParams .~ C.BuildTxWith (Just params) -- TODO: Better error handling (better than 'fail') otherInputs <- lookupTxIns (requiredTxIns txb) let combinedTxIns = @@ -425,7 +418,7 @@ balanceForWalletReturn dbg wallet walletUtxo returnOutput txb = do -} signForWallet :: Wallet -> C.BalancedTxBody ERA -> C.Tx ERA signForWallet wallet (C.BalancedTxBody _ txbody _changeOutput _fee) = - let wit = [C.makeShelleyKeyWitness txbody $ C.WitnessPaymentKey (Wallet.getWallet wallet)] + let wit = [C.makeShelleyKeyWitness C.ShelleyBasedEraBabbage txbody $ C.WitnessPaymentKey (Wallet.getWallet wallet)] in C.makeSignedTransaction wit txbody addOwnInput :: TxBodyContent BuildTx ERA -> UtxoSet ctx a -> TxBodyContent BuildTx ERA @@ -454,10 +447,10 @@ runsScripts body = {-| Add inputs to ensure that the balance is strictly positive -} -addMissingInputs :: MonadError CoinSelectionError m => Tracer m TxBalancingMessage -> Set PoolId -> C.BundledProtocolParameters BabbageEra -> C.UTxO ERA -> C.TxOut C.CtxTx C.BabbageEra -> UtxoSet ctx a -> TxBodyContent BuildTx ERA -> m (TxBodyContent BuildTx ERA, C.TxOut C.CtxTx C.BabbageEra) +addMissingInputs :: MonadError CoinSelectionError m => Tracer m TxBalancingMessage -> Set PoolId -> C.LedgerProtocolParameters BabbageEra -> C.UTxO ERA -> C.TxOut C.CtxTx C.BabbageEra -> UtxoSet ctx a -> TxBodyContent BuildTx ERA -> m (TxBodyContent BuildTx ERA, C.TxOut C.CtxTx C.BabbageEra) addMissingInputs dbg poolIds ledgerPPs utxo_ returnUTxO0 walletUtxo txBodyContent0 = do - txb <- either (throwError . bodyError) pure (C.createAndValidateTransactionBody txBodyContent0) - let bal = C.evaluateTransactionBalance ledgerPPs poolIds mempty utxo_ txb & view L._TxOutValue + txb <- either (throwError . bodyError) pure (C.createAndValidateTransactionBody C.ShelleyBasedEraBabbage txBodyContent0) + let bal = C.evaluateTransactionBalance C.ShelleyBasedEraBabbage (C.unLedgerProtocolParameters ledgerPPs) poolIds mempty mempty utxo_ txb & view L._TxOutValue available = Utxos.removeUtxos (spentTxIns txBodyContent0) walletUtxo traceWith dbg PrepareInputs { walletBalance = Utxos.totalBalance walletUtxo @@ -520,7 +513,7 @@ any non-Ada asset it contains. If the positive part only contains Ada then no output is added. -} addOutputForNonAdaAssets :: - C.BundledProtocolParameters BabbageEra -> -- ^ Protocol parameters (for computing the minimum lovelace amount in the output) + C.LedgerProtocolParameters BabbageEra -> -- ^ Protocol parameters (for computing the minimum lovelace amount in the output) C.TxOut C.CtxTx C.BabbageEra -> -- ^ Address of the newly created output C.Value -> -- ^ The balance of the transaction (C.TxOut C.CtxTx C.BabbageEra, C.Lovelace) -- ^ The modified transaction body and the lovelace portion of the change output's value. If no output was added then the amount will be 0. diff --git a/src/coin-selection/lib/Convex/MockChain/CoinSelection.hs b/src/coin-selection/lib/Convex/MockChain/CoinSelection.hs index 7d925588..899b2169 100644 --- a/src/coin-selection/lib/Convex/MockChain/CoinSelection.hs +++ b/src/coin-selection/lib/Convex/MockChain/CoinSelection.hs @@ -67,7 +67,7 @@ payToOperator' :: (MonadMockchain m, MonadError BalanceTxError m) => Tracer m Tx payToOperator' dbg value wFrom Operator{oPaymentKey} = do p <- queryProtocolParameters let addr = - C.makeShelleyAddressInEra Defaults.networkId + C.makeShelleyAddressInEra C.ShelleyBasedEraBabbage Defaults.networkId (C.PaymentCredentialByKey $ C.verificationKeyHash $ verificationKey oPaymentKey) C.NoStakeAddress tx = execBuildTx' $ payToAddress addr value >> setMinAdaDepositAll p diff --git a/src/coin-selection/test/Spec.hs b/src/coin-selection/test/Spec.hs index 840004f1..d33c1397 100644 --- a/src/coin-selection/test/Spec.hs +++ b/src/coin-selection/test/Spec.hs @@ -7,18 +7,13 @@ module Main(main) where import qualified Cardano.Api.Shelley as C import Cardano.Ledger.Alonzo.Rules (AlonzoUtxoPredFailure (..)) -import Cardano.Ledger.Alonzo.Scripts (AlonzoScript (..), - transProtocolVersion, - validScript) import Cardano.Ledger.Babbage.Rules (BabbageUtxoPredFailure (..), BabbageUtxowPredFailure (..)) -import Cardano.Ledger.Language (Language (..)) import Cardano.Ledger.Shelley.API (ApplyTxError (..)) import Cardano.Ledger.Shelley.Rules (ShelleyLedgerPredFailure (..)) import Control.Lens (_3, _4, view, (&), (.~)) import Control.Monad (void, when) -import Control.Monad.Except (MonadError, runExcept, - runExceptT) +import Control.Monad.Except (MonadError, runExceptT) import Control.Monad.State.Strict (execStateT, modify) import Control.Monad.Trans.Class (MonadTrans (..)) import Convex.BuildTx (BuildTxT, addRequiredSignature, @@ -67,8 +62,7 @@ import qualified Scripts import qualified Test.QuickCheck.Gen as Gen import Test.Tasty (TestTree, defaultMain, testGroup) -import Test.Tasty.HUnit (Assertion, assertBool, - testCase) +import Test.Tasty.HUnit (Assertion, testCase) import qualified Test.Tasty.QuickCheck as QC import Test.Tasty.QuickCheck (Property, classify, testProperty) @@ -87,7 +81,6 @@ tests = testGroup "unit tests" [ testCase "paying to a plutus script" (mockchainSucceeds $ failOnError payToPlutusScript) , testCase "spending a plutus script output" (mockchainSucceeds $ failOnError (payToPlutusScript >>= spendPlutusScript)) , testCase "spending a plutus script (V2) output" (mockchainSucceeds $ failOnError (payToPlutusV2Script >>= spendPlutusV2Script)) - , testCase "well-formed scripts" wellFormedScripts , testCase "creating a reference script output" (mockchainSucceeds $ failOnError $ putReferenceScript Wallet.w1) , testCase "using a reference script" (mockchainSucceeds $ failOnError (payToPlutusV2Script >>= spendPlutusScriptReference)) , testCase "minting a token" (mockchainSucceeds $ failOnError mintingPlutus) @@ -103,13 +96,6 @@ tests = testGroup "unit tests" spendPublicKeyOutput :: Assertion spendPublicKeyOutput = mockchainSucceeds $ failOnError (Wallet.w2 `paymentTo` Wallet.w1) -wellFormedScripts :: Assertion -wellFormedScripts = do - let protVer = Defaults.protVer Defaults.nodeParams - s = Cardano.Ledger.Alonzo.Scripts.PlutusScript PlutusV2 Scripts.v2SpendingScriptSerialised - either (fail . show) pure (runExcept (PV2.assertScriptWellFormed (transProtocolVersion protVer) Scripts.v2SpendingScriptSerialised)) - assertBool "validScript" (validScript protVer s) - makeSeveralPayments :: Assertion makeSeveralPayments = mockchainSucceeds $ failOnError $ do void $ Wallet.w1 `paymentTo` Wallet.w2 @@ -148,7 +134,7 @@ spendPlutusV2Script ref = do putReferenceScript :: (MonadFail m, MonadMockchain m, MonadError BalanceTxError m) => Wallet -> m C.TxIn putReferenceScript wallet = do let hsh = C.hashScript (C.PlutusScript C.PlutusScriptV2 Scripts.v2SpendingScript) - addr = C.makeShelleyAddressInEra Defaults.networkId (C.PaymentCredentialByScript hsh) C.NoStakeAddress + addr = C.makeShelleyAddressInEra C.ShelleyBasedEraBabbage Defaults.networkId (C.PaymentCredentialByScript hsh) C.NoStakeAddress tx = execBuildTx' $ payToPlutusV2Inline addr Scripts.v2SpendingScript (C.lovelaceToValue 10_000_000) >> setMinAdaDepositAll Defaults.bundledProtocolParameters @@ -218,7 +204,7 @@ checkResolveDatumHash = do -- 1. resolve an inline datum let datum1 = C.unsafeHashableScriptData (C.ScriptDataConstructor 5 []) - dat = C.TxOutDatumInline C.ReferenceTxInsScriptsInlineDatumsInBabbageEra datum1 + dat = C.TxOutDatumInline C.BabbageEraOnwardsBabbage datum1 txOut = payToAddressTxOut addr mempty & L._TxOut . _3 .~ dat @@ -237,9 +223,9 @@ checkResolveDatumHash = do datum3 = C.unsafeHashableScriptData $ C.fromPlutusData $ PV2.toData d3 txo = C.TxOut - (C.makeShelleyAddressInEra Defaults.networkId (C.PaymentCredentialByScript (C.hashScript (C.PlutusScript C.PlutusScriptV1 txInscript))) C.NoStakeAddress) - (C.TxOutValue C.MultiAssetInBabbageEra mempty) - (C.TxOutDatumHash C.ScriptDataInBabbageEra (C.hashScriptDataBytes datum3)) + (C.makeShelleyAddressInEra C.ShelleyBasedEraBabbage Defaults.networkId (C.PaymentCredentialByScript (C.hashScript (C.PlutusScript C.PlutusScriptV1 txInscript))) C.NoStakeAddress) + (C.TxOutValueShelleyBased C.ShelleyBasedEraBabbage mempty) + (C.TxOutDatumHash C.AlonzoEraOnwardsBabbage (C.hashScriptDataBytes datum3)) C.ReferenceScriptNone txId <- execBuildTxWallet Wallet.w1 (prependTxOut txo) _ <- execBuildTxWallet Wallet.w1 (spendPlutusV1 (C.TxIn txId (C.TxIx 0)) txInscript d3 ()) @@ -303,5 +289,5 @@ largeTransactionTest = do -- the tx should succeed after setting the max tx size to exactly 20311 (see the error message in the test above) let protParams = Defaults.protocolParameters & maxTxSize .~ 20311 - params' = Defaults.nodeParams & protocolParameters .~ (either (error. show) id (C.bundleProtocolParams C.BabbageEra protParams)) + params' = Defaults.nodeParams & protocolParameters .~ (either (error. show) id (C.convertToLedgerProtocolParameters C.ShelleyBasedEraBabbage protParams)) mockchainSucceedsWith params' (failOnError largeDatumTx) diff --git a/src/devnet/lib/Convex/Devnet/CardanoNode.hs b/src/devnet/lib/Convex/Devnet/CardanoNode.hs index 2043975b..02719a54 100644 --- a/src/devnet/lib/Convex/Devnet/CardanoNode.hs +++ b/src/devnet/lib/Convex/Devnet/CardanoNode.hs @@ -26,8 +26,7 @@ module Convex.Devnet.CardanoNode( withCardanoNodeDevnetConfig ) where -import Cardano.Api (CardanoMode, Env, - LocalNodeConnectInfo, +import Cardano.Api (Env, LocalNodeConnectInfo, NetworkId) import qualified Cardano.Api as C import Cardano.Ledger.Alonzo.Genesis (AlonzoGenesis) @@ -86,7 +85,7 @@ data RunningNode = RunningNode { rnNodeSocket :: FilePath -- ^ Cardano node socket , rnNetworkId :: NetworkId -- ^ Network ID used by the cardano node , rnNodeConfigFile :: FilePath -- ^ Cardano node config file (JSON) - , rnConnectInfo :: (LocalNodeConnectInfo CardanoMode, Env) -- ^ Connection info for node queries + , rnConnectInfo :: (LocalNodeConnectInfo, Env) -- ^ Connection info for node queries } -- | Configuration parameters for a single node devnet diff --git a/src/devnet/lib/Convex/Devnet/NodeQueries.hs b/src/devnet/lib/Convex/Devnet/NodeQueries.hs index 6a7af8ee..82e26ee4 100644 --- a/src/devnet/lib/Convex/Devnet/NodeQueries.hs +++ b/src/devnet/lib/Convex/Devnet/NodeQueries.hs @@ -22,7 +22,6 @@ module Convex.Devnet.NodeQueries( import Cardano.Api (Address, BabbageEra, BlockNo, - CardanoMode, EraHistory (..), LocalNodeConnectInfo (..), NetworkId, @@ -75,10 +74,10 @@ queryEraHistory :: -- ^ network Id to use for node query FilePath -> -- ^ Node socket - IO (EraHistory CardanoMode) -queryEraHistory = queryLocalState (C.QueryEraHistory C.CardanoModeIsMultiEra) + IO EraHistory +queryEraHistory = queryLocalState C.QueryEraHistory -queryLocalState :: QueryInMode CardanoMode b -> NetworkId -> FilePath -> IO b +queryLocalState :: QueryInMode b -> NetworkId -> FilePath -> IO b queryLocalState query networkId socket = do C.queryNodeLocalState (localNodeConnectInfo networkId socket) Nothing query >>= \case Left err -> do @@ -86,7 +85,7 @@ queryLocalState query networkId socket = do Right result -> pure result -localNodeConnectInfo :: NetworkId -> FilePath -> C.LocalNodeConnectInfo C.CardanoMode +localNodeConnectInfo :: NetworkId -> FilePath -> C.LocalNodeConnectInfo localNodeConnectInfo localNodeNetworkId (C.File -> localNodeSocketPath) = C.LocalNodeConnectInfo { localConsensusModeParams = cardanoModeParams @@ -94,7 +93,7 @@ localNodeConnectInfo localNodeNetworkId (C.File -> localNodeSocketPath) = , localNodeSocketPath } -cardanoModeParams :: C.ConsensusModeParams C.CardanoMode +cardanoModeParams :: C.ConsensusModeParams cardanoModeParams = C.CardanoModeParams $ C.EpochSlots defaultByronEpochSlots where -- NOTE(AB): extracted from Parsers in cardano-cli, this is needed to run in 'cardanoMode' which @@ -111,14 +110,14 @@ queryTip :: FilePath -> -- ^ Node socket IO (SlotNo, SlotLength, C.Hash C.BlockHeader) -queryTip networkId socket = queryLocalState (C.QueryChainPoint C.CardanoMode) networkId socket >>= \case +queryTip networkId socket = queryLocalState C.QueryChainPoint networkId socket >>= \case C.ChainPointAtGenesis -> failure "queryTip: chain point at genesis" C.ChainPoint slot hsh -> getSlotLength slot >>= (\i -> pure (slot, i, hsh)) where getSlotLength :: SlotNo -> IO SlotLength getSlotLength slotNo = do - (EraHistory _ interpreter) <- queryEraHistory networkId socket + (EraHistory interpreter) <- queryEraHistory networkId socket case interpretQuery interpreter (slotToSlotLength slotNo) of Left err -> failure $ "queryTip: Failed with " <> show err Right slength -> pure $ slength @@ -139,7 +138,6 @@ queryUTxOFilter :: NetworkId -> FilePath -> QueryUTxOFilter -> IO (UTxO C.Babbag queryUTxOFilter networkId socket flt = let query = C.QueryInEra - C.BabbageEraInCardanoMode ( C.QueryInShelleyBasedEra C.ShelleyBasedEraBabbage ( C.QueryUTxO flt) @@ -171,7 +169,6 @@ waitForTxIn :: NetworkId -> FilePath -> TxIn -> IO () waitForTxIn networkId socket txIn = do let query = C.QueryInEra - C.BabbageEraInCardanoMode ( C.QueryInShelleyBasedEra C.ShelleyBasedEraBabbage ( C.QueryUTxO @@ -194,7 +191,6 @@ waitForTxInSpend :: NetworkId -> FilePath -> TxIn -> IO () waitForTxInSpend networkId socket txIn = do let query = C.QueryInEra - C.BabbageEraInCardanoMode ( C.QueryInShelleyBasedEra C.ShelleyBasedEraBabbage ( C.QueryUTxO diff --git a/src/devnet/test/Spec.hs b/src/devnet/test/Spec.hs index bb2595fa..aafe048c 100644 --- a/src/devnet/test/Spec.hs +++ b/src/devnet/test/Spec.hs @@ -43,7 +43,7 @@ main = do checkCardanoNode :: IO () checkCardanoNode = - let expectedVersion = "8.1.1" + let expectedVersion = "8.7.2" in getCardanoNodeVersion >>= assertBool ("cardano-node version should be " <> expectedVersion) . isInfixOf expectedVersion startLocalNode :: IO () @@ -81,7 +81,7 @@ runWalletServer = changeMaxTxSize :: IO () changeMaxTxSize = - let getMaxTxSize = fmap (C.protocolParamMaxTxSize . C.unbundleProtocolParams) . queryProtocolParameters . fst . rnConnectInfo in + let getMaxTxSize = fmap (C.protocolParamMaxTxSize . C.fromLedgerPParams C.ShelleyBasedEraBabbage) . queryProtocolParameters . fst . rnConnectInfo in showLogsOnFailure $ \tr -> do withTempDir "cardano-cluster" $ \tmp -> do standardTxSize <- withCardanoNodeDevnetConfig (contramap TLNode tr) tmp mempty getMaxTxSize diff --git a/src/mockchain/convex-mockchain.cabal b/src/mockchain/convex-mockchain.cabal index ed299a02..03f14e17 100644 --- a/src/mockchain/convex-mockchain.cabal +++ b/src/mockchain/convex-mockchain.cabal @@ -46,7 +46,10 @@ library transformers, HUnit, QuickCheck, - bytestring + bytestring, + sop-extras, + strict-sop-core, + sop-core -- cardano dependencies build-depends: diff --git a/src/mockchain/lib/Convex/MockChain.hs b/src/mockchain/lib/Convex/MockChain.hs index 37ea2e9e..0558f09f 100644 --- a/src/mockchain/lib/Convex/MockChain.hs +++ b/src/mockchain/lib/Convex/MockChain.hs @@ -5,6 +5,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} {-| Minimal mockchain -} @@ -35,7 +36,7 @@ module Convex.MockChain( evaluateTx, applyTransaction, -- * Plutus scripts - ScriptContext, + PlutusWithContext(..), fullyAppliedScript, -- * Mockchain implementation MockchainError(..), @@ -69,15 +70,10 @@ import Cardano.Api.Shelley (AddressInEra, SlotNo, Tx, TxBody (ShelleyTxBody)) import qualified Cardano.Api.Shelley as Cardano.Api -import Cardano.Ledger.Alonzo.Language (Language (..)) +import Cardano.Ledger.Alonzo.Plutus.TxInfo as Ledger import Cardano.Ledger.Alonzo.PlutusScriptApi (CollectError, - collectTwoPhaseScriptInputs, - evalScripts) -import Cardano.Ledger.Alonzo.Scripts (CostModel, ExUnits) -import Cardano.Ledger.Alonzo.Scripts.Data (Data) -import qualified Cardano.Ledger.Alonzo.Scripts.Data as Ledger -import Cardano.Ledger.Alonzo.TxInfo (ScriptResult (..)) -import qualified Cardano.Ledger.Alonzo.TxInfo as Ledger + collectPlutusScriptsWithContext, + evalPlutusScripts) import Cardano.Ledger.Alonzo.TxWits (unTxDats) import Cardano.Ledger.Babbage (Babbage) import Cardano.Ledger.Babbage.Tx (AlonzoTx (..), @@ -86,6 +82,10 @@ import Cardano.Ledger.BaseTypes (Globals (systemStart), ProtVer, epochInfo) import qualified Cardano.Ledger.Core as Core import Cardano.Ledger.Crypto (StandardCrypto) +import qualified Cardano.Ledger.Plutus.Data as Ledger +import Cardano.Ledger.Plutus.Language (BinaryPlutus (..), + Language (..), + Plutus (..)) import Cardano.Ledger.Shelley.API (AccountState (..), ApplyTxError, Coin (..), GenDelegs (..), @@ -129,7 +129,6 @@ import Convex.Utxos (UtxoSet (..), import Convex.Wallet (Wallet, addressInEra, paymentCredential) import Data.Bifunctor (Bifunctor (..)) -import Data.ByteString.Short (ShortByteString) import Data.Default (Default (def)) import Data.Foldable (for_, traverse_) import Data.Functor.Identity (Identity (..)) @@ -141,30 +140,26 @@ import PlutusLedgerApi.Common (mkTermToEvaluate) import qualified PlutusLedgerApi.Common as Plutus import qualified UntypedPlutusCore as UPLC -{-| All the information needed to evaluate a Plutus script: The script itself, the -script language, redeemers and datums, execution units required, and the cost model. --} -type ScriptContext era = (ShortByteString, Language, [Data era], ExUnits, CostModel) - {-| Apply the plutus script to all its arguments and return a plutus program -} -fullyAppliedScript :: NodeParams -> ScriptContext ERA -> Either String (UPLC.Program UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun ()) -fullyAppliedScript params (script, lang, arguments, _, _) = do +fullyAppliedScript :: NodeParams -> PlutusWithContext Babbage -> Either String (UPLC.Program UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun ()) +fullyAppliedScript params PlutusWithContext{pwcScript=Plutus{plutusLanguage, plutusScript}, pwcDatums} = do let pv = Ledger.transProtocolVersion (Defaults.protVer params) - pArgs = Ledger.getPlutusData <$> arguments - lng = case lang of + pArgs = Ledger.getPlutusData <$> pwcDatums + lng = case plutusLanguage of PlutusV1 -> Plutus.PlutusV1 PlutusV2 -> Plutus.PlutusV2 PlutusV3 -> Plutus.PlutusV3 - appliedTerm <- first show $ mkTermToEvaluate lng pv script pArgs + scriptForEval <- first show $ Plutus.deserialiseScript lng pv (unBinaryPlutus plutusScript) + appliedTerm <- first show $ mkTermToEvaluate lng pv scriptForEval pArgs pure $ UPLC.Program () PLC.latestVersion appliedTerm data MockChainState = MockChainState { mcsEnv :: MempoolEnv ERA , mcsPoolState :: MempoolState ERA - , mcsTransactions :: [(Validated (Core.Tx ERA), [ScriptContext ERA])] + , mcsTransactions :: [(Validated (Core.Tx ERA), [PlutusWithContext Babbage])] , mcsDatums :: Map (Hash ScriptData) ScriptData } @@ -211,7 +206,7 @@ initialStateFor params@NodeParams{npNetworkId} utxos = , ledgerAccount = AccountState (Coin 0) (Coin 0) } , mcsPoolState = LedgerState - { lsUTxOState = smartUTxOState (Defaults.pParams params) utxo (Coin 0) (Coin 0) def + { lsUTxOState = smartUTxOState (Defaults.pParams params) utxo (Coin 0) (Coin 0) def (Coin 0) , lsCertState = def } , mcsTransactions = [] @@ -244,7 +239,7 @@ getTxExUnits :: Cardano.Api.Tx Cardano.Api.BabbageEra -> Either ExUnitsError (Map.Map Cardano.Api.ScriptWitnessIndex Cardano.Api.ExecutionUnits) getTxExUnits NodeParams{npSystemStart, npEraHistory, npProtocolParameters} utxo (Cardano.Api.getTxBody -> tx) = - case Cardano.Api.evaluateTransactionExecutionUnits npSystemStart (Cardano.Api.toLedgerEpochInfo npEraHistory) npProtocolParameters (fromLedgerUTxO Cardano.Api.ShelleyBasedEraBabbage utxo) tx of + case Cardano.Api.evaluateTransactionExecutionUnits Cardano.Api.BabbageEra npSystemStart (Cardano.Api.toLedgerEpochInfo npEraHistory) npProtocolParameters (fromLedgerUTxO Cardano.Api.ShelleyBasedEraBabbage utxo) tx of Left e -> Left (Phase1Error e) Right rdmrs -> traverse (either (Left . Phase2Error) Right) rdmrs @@ -252,7 +247,7 @@ applyTransaction :: NodeParams -> MockChainState -> Cardano.Api.Tx Cardano.Api.B applyTransaction params state tx'@(Cardano.Api.ShelleyTx _era tx) = do let currentSlot = state ^. env . L.slot utxoState_ = state ^. poolState . L.utxoState - utxo = utxoState_ ^. L._UTxOState (unbundleLedgerShelleyBasedProtocolParams Cardano.Api.ShelleyBasedEraBabbage $ npProtocolParameters params) . _1 + utxo = utxoState_ ^. L._UTxOState (Cardano.Api.unLedgerProtocolParameters $ npProtocolParameters params) . _1 (vtx, scripts) <- first PredicateFailures (constructValidated (Defaults.protVer params) (Defaults.globals params) (utxoEnv params currentSlot) utxoState_ tx) result <- applyTx params state vtx scripts @@ -263,7 +258,7 @@ applyTransaction params state tx'@(Cardano.Api.ShelleyTx _era tx) = do {-| Evaluate a transaction, returning all of its script contexts. -} -evaluateTx :: NodeParams -> SlotNo -> UTxO ERA -> Cardano.Api.Tx Cardano.Api.BabbageEra -> Either ValidationError [ScriptContext ERA] +evaluateTx :: NodeParams -> SlotNo -> UTxO ERA -> Cardano.Api.Tx Cardano.Api.BabbageEra -> Either ValidationError [PlutusWithContext Babbage] evaluateTx params slotNo utxo (Cardano.Api.ShelleyTx _ tx) = do (vtx, scripts) <- first PredicateFailures (constructValidated (Defaults.protVer params) (Defaults.globals params) (utxoEnv params slotNo) (lsUTxOState (mcsPoolState state)) tx) _ <- applyTx params state vtx scripts @@ -272,7 +267,7 @@ evaluateTx params slotNo utxo (Cardano.Api.ShelleyTx _ tx) = do state = initialState params & env . L.slot .~ slotNo - & poolState . L.utxoState . L._UTxOState (unbundleLedgerShelleyBasedProtocolParams Cardano.Api.ShelleyBasedEraBabbage $ npProtocolParameters params) . _1 .~ utxo + & poolState . L.utxoState . L._UTxOState (Cardano.Api.unLedgerProtocolParameters $ npProtocolParameters params) . _1 .~ utxo -- | Construct a 'ValidatedTx' from a 'Core.Tx' by setting the `IsValid` -- flag. @@ -292,12 +287,12 @@ constructValidated :: UtxoEnv Babbage -> UTxOState Babbage -> Core.Tx Babbage -> - m (AlonzoTx Babbage, [ScriptContext Babbage]) + m (AlonzoTx Babbage, [PlutusWithContext Babbage]) constructValidated pv globals (UtxoEnv _ pp _ _) st tx = - case collectTwoPhaseScriptInputs ei sysS pp tx utxo of + case collectPlutusScriptsWithContext ei sysS pp tx utxo of Left errs -> throwError errs Right sLst -> - let scriptEvalResult = evalScripts @Babbage pv tx sLst + let scriptEvalResult = evalPlutusScripts @Babbage pv tx sLst vTx = AlonzoTx (body tx) @@ -316,7 +311,7 @@ applyTx :: NodeParams -> MockChainState -> Core.Tx ERA -> - [ScriptContext ERA] -> + [PlutusWithContext ERA] -> Either ValidationError (MockChainState, Validated (Core.Tx ERA)) applyTx params oldState@MockChainState{mcsEnv, mcsPoolState} tx context = do (newMempool, vtx) <- first ApplyTxFailure (Cardano.Ledger.Shelley.API.applyTx (Defaults.globals params) mcsEnv mcsPoolState tx) @@ -392,7 +387,7 @@ addDatumHashes (Cardano.Api.Tx (ShelleyTxBody Cardano.Api.ShelleyBasedEraBabbage _ -> pure () case scriptData of - Cardano.Api.TxBodyScriptData Cardano.Api.ScriptDataInBabbageEra (unTxDats -> txDats) _redeemers -> do + Cardano.Api.TxBodyScriptData _ (unTxDats -> txDats) _redeemers -> do traverse_ (insertHashableScriptData . Cardano.Api.fromAlonzoData) txDats _ -> pure () @@ -487,16 +482,3 @@ fromLedgerUTxO era (UTxO utxo) = . map (bimap Cardano.Api.fromShelleyTxIn (Cardano.Api.fromShelleyTxOut era)) . Map.toList $ utxo - --- not exported by cardano-api -unbundleLedgerShelleyBasedProtocolParams - :: Cardano.Api.ShelleyBasedEra era - -> Cardano.Api.BundledProtocolParameters era - -> Core.PParams (ShelleyLedgerEra era) -unbundleLedgerShelleyBasedProtocolParams = \case - Cardano.Api.ShelleyBasedEraShelley -> \(Cardano.Api.BundleAsShelleyBasedProtocolParameters _ _ lpp) -> lpp - Cardano.Api.ShelleyBasedEraAllegra -> \(Cardano.Api.BundleAsShelleyBasedProtocolParameters _ _ lpp) -> lpp - Cardano.Api.ShelleyBasedEraMary -> \(Cardano.Api.BundleAsShelleyBasedProtocolParameters _ _ lpp) -> lpp - Cardano.Api.ShelleyBasedEraAlonzo -> \(Cardano.Api.BundleAsShelleyBasedProtocolParameters _ _ lpp) -> lpp - Cardano.Api.ShelleyBasedEraBabbage -> \(Cardano.Api.BundleAsShelleyBasedProtocolParameters _ _ lpp) -> lpp - Cardano.Api.ShelleyBasedEraConway -> \(Cardano.Api.BundleAsShelleyBasedProtocolParameters _ _ lpp) -> lpp diff --git a/src/mockchain/lib/Convex/MockChain/Defaults.hs b/src/mockchain/lib/Convex/MockChain/Defaults.hs index 556a0834..59fad654 100644 --- a/src/mockchain/lib/Convex/MockChain/Defaults.hs +++ b/src/mockchain/lib/Convex/MockChain/Defaults.hs @@ -16,10 +16,7 @@ module Convex.MockChain.Defaults( nodeParams ) where -import qualified Cardano.Api as C import Cardano.Api.Shelley (AnyPlutusScriptVersion (..), - CardanoMode, - ConsensusMode (..), EpochNo (..), EraHistory (EraHistory), ExecutionUnitPrices (..), @@ -32,6 +29,7 @@ import Cardano.Api.Shelley (AnyPlutusScriptVersion (. ShelleyBasedEra (..), shelleyGenesisDefaults, toLedgerPParams) +import qualified Cardano.Api.Shelley as C import Cardano.Ledger.Alonzo.PParams (DowngradeAlonzoPParams (..)) import Cardano.Ledger.Babbage (Babbage) import Cardano.Ledger.Babbage.Core (CoinPerByte (..), @@ -56,9 +54,10 @@ import Convex.NodeParams (NodeParams (..)) import Data.Map (fromList) import Data.Maybe (fromMaybe) import Data.Ratio ((%)) -import Data.SOP.Counting (Exactly (..), - nonEmptyHead) -import Data.SOP.Strict (K (K), NP (..)) +import Data.SOP (K (K)) +import Data.SOP.Counting (Exactly (..)) +import Data.SOP.NonEmpty (nonEmptyHead) +import Data.SOP.Strict (NP (..)) import Data.Time.Calendar (fromGregorian) import Data.Time.Clock (UTCTime (..)) import qualified Ouroboros.Consensus.HardFork.History as Ouroboros @@ -75,9 +74,9 @@ systemStart = SystemStart startTime -- Defaults are from plutus-apps/plutus-ledger/Ledger.Params -eraHistory :: EraHistory CardanoMode +eraHistory :: EraHistory eraHistory = - EraHistory CardanoMode (Ouroboros.mkInterpreter $ Ouroboros.summaryWithExactly list) -- $ Ouroboros.summaryWithExactly list) + EraHistory (Ouroboros.mkInterpreter $ Ouroboros.summaryWithExactly list) -- $ Ouroboros.summaryWithExactly list) where one = nonEmptyHead $ Ouroboros.getSummary $ Ouroboros.neverForksSummary epochSize slotLength list = Exactly $ K one :* K one :* K one :* K one :* K one :* K one :* K one :* Nil @@ -140,7 +139,6 @@ protocolParameters = , protocolParamPoolPledgeInfluence = 3 % 10 , protocolParamMonetaryExpansion = 3 % 1_000 , protocolParamTreasuryCut = 1 % 5 - , protocolParamUTxOCostPerWord = Nothing -- Obsolete from babbage onwards , protocolParamCostModels = fromList [ (AnyPlutusScriptVersion PlutusScriptV1, defaultV1CostModel) , (AnyPlutusScriptVersion PlutusScriptV2, defaultV2CostModel) ] @@ -163,10 +161,10 @@ globals :: NodeParams -> Globals globals params@NodeParams { npProtocolParameters, npSlotLength } = mkShelleyGlobals (genesisDefaultsFromParams params) (fixedEpochInfo epochSize npSlotLength) - (fromMaybe (error "globals: Invalid version") $ Version.mkVersion $ fst $ protocolParamProtocolVersion $ C.unbundleProtocolParams npProtocolParameters) + (fromMaybe (error "globals: Invalid version") $ Version.mkVersion $ fst $ protocolParamProtocolVersion $ C.fromLedgerPParams C.ShelleyBasedEraBabbage $ C.unLedgerProtocolParameters npProtocolParameters) protVer :: NodeParams -> ProtVer -protVer = lederPPProtVer . C.unbundleProtocolParams . npProtocolParameters +protVer = lederPPProtVer . C.fromLedgerPParams C.ShelleyBasedEraBabbage . C.unLedgerProtocolParameters . npProtocolParameters lederPPProtVer :: ProtocolParameters -> ProtVer lederPPProtVer k = @@ -192,7 +190,7 @@ genesisDefaultsFromParams params@NodeParams { npNetworkId } = shelleyGenesisDefa -- | Convert `Params` to cardano-ledger `PParams` pParams :: NodeParams -> PParams Babbage pParams NodeParams { npProtocolParameters } = case npProtocolParameters of - C.BundleAsShelleyBasedProtocolParameters _ _ p -> p + C.LedgerProtocolParameters p -> p {-| 'NodeParams' with default values for testing -} @@ -207,5 +205,5 @@ nodeParams = , npSlotLength = slotLength } -bundledProtocolParameters :: C.BundledProtocolParameters C.BabbageEra -bundledProtocolParameters = either (error . (<>) "nodeParams: bundleProtocolParams failed: " . show) id (C.bundleProtocolParams C.BabbageEra protocolParameters) +bundledProtocolParameters :: C.LedgerProtocolParameters C.BabbageEra +bundledProtocolParameters = C.LedgerProtocolParameters $ either (error . (<>) "toLedgerPParams failed: " . show) id $ C.toLedgerPParams C.ShelleyBasedEraBabbage protocolParameters diff --git a/src/mockchain/lib/Convex/NodeParams.hs b/src/mockchain/lib/Convex/NodeParams.hs index c7d5f2ed..12fb4bdc 100644 --- a/src/mockchain/lib/Convex/NodeParams.hs +++ b/src/mockchain/lib/Convex/NodeParams.hs @@ -29,7 +29,6 @@ module Convex.NodeParams( poolPledgeInfluence, monetaryExpansion, treasuryCut, - uTxOCostPerWord, costModels, prices, maxTxExUnits, @@ -40,9 +39,10 @@ module Convex.NodeParams( uTxOCostPerByte ) where -import Cardano.Api (BabbageEra, BundledProtocolParameters) -import Cardano.Api.Shelley (CardanoMode, EraHistory, NetworkId (..), - PoolId, ProtocolParameters (..)) +import Cardano.Api (BabbageEra) +import Cardano.Api.Shelley (EraHistory, LedgerProtocolParameters, + NetworkId (..), PoolId, + ProtocolParameters (..)) import Cardano.Slotting.Time (SlotLength, SystemStart) import Control.Lens.TH (makeLensesFor) import Data.Set as Set (Set) @@ -50,9 +50,9 @@ import Data.Set as Set (Set) data NodeParams = NodeParams { npNetworkId :: NetworkId - , npProtocolParameters :: BundledProtocolParameters BabbageEra + , npProtocolParameters :: LedgerProtocolParameters BabbageEra , npSystemStart :: SystemStart - , npEraHistory :: EraHistory CardanoMode + , npEraHistory :: EraHistory , npStakePools :: Set PoolId , npSlotLength :: SlotLength } diff --git a/src/node-client/lib/Convex/NodeClient/Fold.hs b/src/node-client/lib/Convex/NodeClient/Fold.hs index 8817c6e5..75cfeb4d 100644 --- a/src/node-client/lib/Convex/NodeClient/Fold.hs +++ b/src/node-client/lib/Convex/NodeClient/Fold.hs @@ -27,7 +27,6 @@ import Cardano.Api (Block (. BlockHeader (..), BlockInMode (..), BlockNo (..), - CardanoMode, ChainPoint (..), ChainTip (..), Env, @@ -41,8 +40,7 @@ import Convex.NodeClient.ChainTip (JSONBloc blockHeaderPoint) import Convex.NodeClient.Resuming (ResumingFrom) import qualified Convex.NodeClient.Resuming as R -import Convex.NodeClient.Types (ClientBlock, - PipelinedLedgerStateClient (..), +import Convex.NodeClient.Types (PipelinedLedgerStateClient (..), fromChainTip) import Data.Aeson (FromJSON, ToJSON) @@ -113,7 +111,7 @@ foldClient :: -- | Node connection data Env -> -- | Fold - (CatchingUp -> s -> BlockInMode CardanoMode -> IO (Maybe s)) -> + (CatchingUp -> s -> BlockInMode -> IO (Maybe s)) -> PipelinedLedgerStateClient foldClient initialState env applyBlock = foldClient' @s @() @@ -134,7 +132,7 @@ foldClient' :: -- | Rollback (ChainPoint -> w -> s -> IO (w, s)) -> -- | Fold - (CatchingUp -> s -> BlockInMode CardanoMode -> IO (Maybe (w, s))) -> -- ^ Fold + (CatchingUp -> s -> BlockInMode -> IO (Maybe (w, s))) -> -- ^ Fold PipelinedLedgerStateClient foldClient' initialState env applyRollback applyBlock = PipelinedLedgerStateClient $ CSP.ChainSyncClientPipelined $ do @@ -150,7 +148,7 @@ foldClient' initialState env applyRollback applyBlock = PipelinedLedgerStateClie -> WithOrigin BlockNo -> Nat n -- Number of requests inflight. -> History (w, s) - -> CSP.ClientPipelinedStIdle n ClientBlock ChainPoint ChainTip IO () + -> CSP.ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO () clientIdle_RequestMoreN clientTip_ serverTip_ n history = case pipelineDecisionMax pipelineSize n clientTip_ serverTip_ of Collect -> case n of @@ -160,11 +158,11 @@ foldClient' initialState env applyRollback applyBlock = PipelinedLedgerStateClie clientNextN :: Nat n -> History (w, s) - -> ClientStNext n ClientBlock ChainPoint ChainTip IO () + -> ClientStNext n BlockInMode ChainPoint ChainTip IO () clientNextN n history = ClientStNext { recvMsgRollForward = \newBlock serverChainTip -> do - let BlockInMode (Block bh@(BlockHeader slotNo _blockHash currBlockNo) _) _ = newBlock + let BlockInMode _ (Block bh@(BlockHeader slotNo _blockHash currBlockNo) _) = newBlock newClientTip = At currBlockNo newServerTip = fromChainTip serverChainTip cu = if newClientTip == newServerTip @@ -199,7 +197,7 @@ foldClient' initialState env applyRollback applyBlock = PipelinedLedgerStateClie clientIdle_DoneN :: Nat n - -> IO (ClientPipelinedStIdle n ClientBlock ChainPoint ChainTip IO ()) + -> IO (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ()) clientIdle_DoneN n = case n of Succ predN -> do return $ CollectResponse Nothing (clientNext_DoneN predN) -- Ignore remaining message responses @@ -208,7 +206,7 @@ foldClient' initialState env applyRollback applyBlock = PipelinedLedgerStateClie clientNext_DoneN :: Nat n - -> ClientStNext n ClientBlock ChainPoint ChainTip IO () + -> ClientStNext n BlockInMode ChainPoint ChainTip IO () clientNext_DoneN n = ClientStNext { recvMsgRollForward = \_ _ -> clientIdle_DoneN n diff --git a/src/node-client/lib/Convex/NodeClient/Progress.hs b/src/node-client/lib/Convex/NodeClient/Progress.hs index 287d6e97..c6d8b8bf 100644 --- a/src/node-client/lib/Convex/NodeClient/Progress.hs +++ b/src/node-client/lib/Convex/NodeClient/Progress.hs @@ -14,8 +14,7 @@ import Cardano.Api (Block (. import qualified Cardano.Api as CAPI import Cardano.Slotting.Slot (WithOrigin (At)) import Control.Monad (when) -import Convex.NodeClient.Types (ClientBlock, - PipelinedLedgerStateClient (..), +import Convex.NodeClient.Types (PipelinedLedgerStateClient (..), fromChainTip) import qualified Data.Text as Text import Data.Time (diffUTCTime, @@ -40,17 +39,17 @@ progressClient = PipelinedLedgerStateClient $ CSP.ChainSyncClientPipelined $ do :: WithOrigin BlockNo -> WithOrigin BlockNo -> Nat n -- Number of requests inflight. - -> CSP.ClientPipelinedStIdle n ClientBlock ChainPoint ChainTip IO () + -> CSP.ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO () clientIdle_RequestMoreN clientTip serverTip n = case pipelineDecisionMax pipelineSize n clientTip serverTip of Collect -> case n of Succ predN -> CSP.CollectResponse Nothing (clientNextN predN) _ -> CSP.SendMsgRequestNextPipelined (clientIdle_RequestMoreN clientTip serverTip (Succ n)) - clientNextN :: Nat n -> ClientStNext n ClientBlock ChainPoint ChainTip IO () + clientNextN :: Nat n -> ClientStNext n BlockInMode ChainPoint ChainTip IO () clientNextN n = ClientStNext { - recvMsgRollForward = \(BlockInMode block@(Block (BlockHeader _ _ currBlockNo@(BlockNo blockNo)) _) _) serverChainTip -> do + recvMsgRollForward = \(BlockInMode _era block@(Block (BlockHeader _ _ currBlockNo@(BlockNo blockNo)) _)) serverChainTip -> do let newClientTip = At currBlockNo newServerTip = fromChainTip serverChainTip when (blockNo `mod` 10_000 == 0) $ do @@ -72,7 +71,7 @@ progressClient = PipelinedLedgerStateClient $ CSP.ChainSyncClientPipelined $ do return (clientIdle_RequestMoreN newClientTip newServerTip n) } - clientIdle_DoneN :: Nat n -> IO (ClientPipelinedStIdle n ClientBlock ChainPoint ChainTip IO ()) + clientIdle_DoneN :: Nat n -> IO (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ()) clientIdle_DoneN n = case n of Succ predN -> do putStrLn "Chain Sync: done! (Ignoring remaining responses)" @@ -81,7 +80,7 @@ progressClient = PipelinedLedgerStateClient $ CSP.ChainSyncClientPipelined $ do putStrLn "Chain Sync: done!" return $ SendMsgDone () - clientNext_DoneN :: Nat n -> ClientStNext n ClientBlock ChainPoint ChainTip IO () + clientNext_DoneN :: Nat n -> ClientStNext n BlockInMode ChainPoint ChainTip IO () clientNext_DoneN n = ClientStNext { recvMsgRollForward = \_ _ -> clientIdle_DoneN n diff --git a/src/node-client/lib/Convex/NodeClient/Resuming.hs b/src/node-client/lib/Convex/NodeClient/Resuming.hs index 1d83df4c..ed389926 100644 --- a/src/node-client/lib/Convex/NodeClient/Resuming.hs +++ b/src/node-client/lib/Convex/NodeClient/Resuming.hs @@ -5,10 +5,10 @@ module Convex.NodeClient.Resuming( ResumingFrom(..), resumingClient) where -import Cardano.Api (ChainPoint (..), +import Cardano.Api (BlockInMode, + ChainPoint (..), ChainTip (..)) -import Convex.NodeClient.Types (ClientBlock, - PipelinedLedgerStateClient (..)) +import Convex.NodeClient.Types (PipelinedLedgerStateClient (..)) import Network.TypedProtocol.Pipelined (N (Z)) import qualified Ouroboros.Network.Protocol.ChainSync.ClientPipelined as CSP @@ -29,7 +29,7 @@ resumingClient :: (ResumingFrom -> PipelinedLedgerStateClient) -> PipelinedLedgerStateClient resumingClient syncPoints f = PipelinedLedgerStateClient $ CSP.ChainSyncClientPipelined $ do - let initialise :: CSP.ClientPipelinedStIdle 'Z ClientBlock ChainPoint ChainTip IO () + let initialise :: CSP.ClientPipelinedStIdle 'Z BlockInMode ChainPoint ChainTip IO () initialise = CSP.SendMsgFindIntersect syncPoints $ CSP.ClientPipelinedStIntersect { CSP.recvMsgIntersectFound = \chainPoint srvTip -> do diff --git a/src/node-client/lib/Convex/NodeClient/Types.hs b/src/node-client/lib/Convex/NodeClient/Types.hs index 97dff8c4..061ecbfe 100644 --- a/src/node-client/lib/Convex/NodeClient/Types.hs +++ b/src/node-client/lib/Convex/NodeClient/Types.hs @@ -6,7 +6,6 @@ {-# LANGUAGE OverloadedStrings #-} module Convex.NodeClient.Types( PipelinedLedgerStateClient(..), - ClientBlock, runNodeClient, protocols, -- * Sync points @@ -16,7 +15,6 @@ module Convex.NodeClient.Types( import Cardano.Api (BlockInMode (..), BlockNo (..), - CardanoMode, ChainPoint (..), ChainSyncClientPipelined, ChainTip (..), @@ -38,7 +36,7 @@ import qualified Ouroboros.Network.Protocol.ChainSync.ClientPipelined as CSP -} newtype PipelinedLedgerStateClient = PipelinedLedgerStateClient - { getPipelinedLedgerStateClient :: ChainSyncClientPipelined (BlockInMode CardanoMode) ChainPoint ChainTip IO () + { getPipelinedLedgerStateClient :: ChainSyncClientPipelined BlockInMode ChainPoint ChainTip IO () } runNodeClient :: @@ -47,7 +45,7 @@ runNodeClient :: -- | Path to local cardano-node socket. This is the path specified by the @--socket-path@ command line option when running the node. -> FilePath -- | Client - -> (LocalNodeConnectInfo CardanoMode -> Env -> IO PipelinedLedgerStateClient) + -> (LocalNodeConnectInfo -> Env -> IO PipelinedLedgerStateClient) -- | Final state -> ExceptT InitialLedgerStateError IO () runNodeClient nodeConfigFilePath socketPath client = do @@ -55,7 +53,7 @@ runNodeClient nodeConfigFilePath socketPath client = do c <- liftIO (client connectInfo env) lift $ connectToLocalNode connectInfo (protocols c) -protocols :: PipelinedLedgerStateClient -> LocalNodeClientProtocolsInMode CardanoMode +protocols :: PipelinedLedgerStateClient -> LocalNodeClientProtocolsInMode protocols client = LocalNodeClientProtocols { localChainSyncClient = LocalChainSyncClientPipelined (chainSyncClient client), @@ -64,13 +62,11 @@ protocols client = localTxMonitoringClient = Nothing } -chainSyncClient :: PipelinedLedgerStateClient -> ChainSyncClientPipelined (BlockInMode CardanoMode) ChainPoint ChainTip IO () +chainSyncClient :: PipelinedLedgerStateClient -> ChainSyncClientPipelined BlockInMode ChainPoint ChainTip IO () chainSyncClient PipelinedLedgerStateClient{getPipelinedLedgerStateClient} = CSP.ChainSyncClientPipelined $ let CSP.ChainSyncClientPipelined{CSP.runChainSyncClientPipelined} = getPipelinedLedgerStateClient in runChainSyncClientPipelined -type ClientBlock = BlockInMode CardanoMode - fromChainTip :: ChainTip -> WithOrigin BlockNo fromChainTip ct = case ct of ChainTipAtGenesis -> Origin diff --git a/src/node-client/lib/Convex/NodeClient/WaitForTxnClient.hs b/src/node-client/lib/Convex/NodeClient/WaitForTxnClient.hs index 10f7676e..67ad3a15 100644 --- a/src/node-client/lib/Convex/NodeClient/WaitForTxnClient.hs +++ b/src/node-client/lib/Convex/NodeClient/WaitForTxnClient.hs @@ -10,8 +10,7 @@ module Convex.NodeClient.WaitForTxnClient( runMonadBlockchainWaitingT ) where -import Cardano.Api (BlockInMode, CardanoMode, - ChainPoint, Env, +import Cardano.Api (BlockInMode, ChainPoint, Env, LocalNodeConnectInfo, TxId) import qualified Cardano.Api as C import Control.Concurrent (forkIO) @@ -32,7 +31,7 @@ import qualified Convex.NodeQueries as NodeQueries {-| Start a 'waitForTxnClient' in a separate thread. Returns a TMVar that will contain the block that has the given transaction. -} -runWaitForTxn :: LocalNodeConnectInfo CardanoMode -> Env -> TxId -> IO (TMVar (BlockInMode CardanoMode)) +runWaitForTxn :: LocalNodeConnectInfo -> Env -> TxId -> IO (TMVar BlockInMode) runWaitForTxn connectInfo env txi = do tip' <- NodeQueries.queryTip connectInfo tmv <- atomically newEmptyTMVar @@ -41,15 +40,15 @@ runWaitForTxn connectInfo env txi = do {-| Scan the new blocks until the transaction appears -} -waitForTxnClient :: TMVar (BlockInMode CardanoMode) -> ChainPoint -> TxId -> Env -> PipelinedLedgerStateClient +waitForTxnClient :: TMVar BlockInMode -> ChainPoint -> TxId -> Env -> PipelinedLedgerStateClient waitForTxnClient tmv cp txId env = resumingClient [cp] $ \_ -> foldClient () env (applyBlock tmv txId) -applyBlock :: TMVar (BlockInMode CardanoMode) -> TxId -> CatchingUp -> () -> BlockInMode CardanoMode -> IO (Maybe ()) +applyBlock :: TMVar BlockInMode -> TxId -> CatchingUp -> () -> BlockInMode -> IO (Maybe ()) applyBlock tmv txi _ () block = do case block of - C.BlockInMode blck C.BabbageEraInCardanoMode -> + C.BlockInMode C.BabbageEra blck -> if checkTxIds txi blck then do liftIO $ atomically $ putTMVar tmv block @@ -63,10 +62,10 @@ checkTxIds txi ((C.Block _ txns)) = any (checkTxId txi) txns checkTxId :: TxId -> C.Tx C.BabbageEra -> Bool checkTxId txi tx = txi == C.getTxId (C.getTxBody tx) -newtype MonadBlockchainWaitingT m a = MonadBlockchainWaitingT{unMonadBlockchainWaitingT :: ReaderT (LocalNodeConnectInfo CardanoMode, Env) m a } +newtype MonadBlockchainWaitingT m a = MonadBlockchainWaitingT{unMonadBlockchainWaitingT :: ReaderT (LocalNodeConnectInfo, Env) m a } deriving newtype (Functor, Applicative, Monad, MonadIO, MonadFail) -runMonadBlockchainWaitingT :: LocalNodeConnectInfo CardanoMode -> Env -> MonadBlockchainWaitingT m a -> m a +runMonadBlockchainWaitingT :: LocalNodeConnectInfo -> Env -> MonadBlockchainWaitingT m a -> m a runMonadBlockchainWaitingT connectInfo env (MonadBlockchainWaitingT action) = runReaderT action (connectInfo, env) instance MonadError e m => MonadError e (MonadBlockchainWaitingT m) where diff --git a/src/wallet/lib/Convex/Wallet.hs b/src/wallet/lib/Convex/Wallet.hs index f6d5f84e..04cd7363 100644 --- a/src/wallet/lib/Convex/Wallet.hs +++ b/src/wallet/lib/Convex/Wallet.hs @@ -3,6 +3,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} {-| Primitive wallet -} @@ -80,20 +81,20 @@ shelleyPaymentCredential = {-| Sign the transaction body with the signing key and attach the signature to the transaction -} -addSignature :: IsShelleyBasedEra era => SigningKey PaymentKey -> C.Tx era -> C.Tx era +addSignature :: forall era. IsShelleyBasedEra era => SigningKey PaymentKey -> C.Tx era -> C.Tx era addSignature (C.WitnessPaymentKey -> key) tx = let C.Tx body wits = tx - wit = nub $ C.makeShelleyKeyWitness body key : wits + wit = nub $ C.makeShelleyKeyWitness (C.shelleyBasedEra @era) body key : wits stx = C.makeSignedTransaction wit body in stx {-| Sign the transaction body with the extended signing key and attach the signature to the transaction -} -addSignatureExtended :: IsShelleyBasedEra era => SigningKey PaymentExtendedKey -> C.Tx era -> C.Tx era +addSignatureExtended :: forall era. IsShelleyBasedEra era => SigningKey PaymentExtendedKey -> C.Tx era -> C.Tx era addSignatureExtended (C.WitnessPaymentExtendedKey -> key) tx = let C.Tx body wits = tx - wit = nub $ C.makeShelleyKeyWitness body key : wits + wit = nub $ C.makeShelleyKeyWitness (C.shelleyBasedEra @era) body key : wits stx = C.makeSignedTransaction wit body in stx @@ -108,9 +109,9 @@ address :: NetworkId -> Wallet -> Address ShelleyAddr address networkId wallet = C.makeShelleyAddress networkId (paymentCredential wallet) C.NoStakeAddress -addressInEra :: IsShelleyBasedEra era => NetworkId -> Wallet -> AddressInEra era +addressInEra :: forall era. IsShelleyBasedEra era => NetworkId -> Wallet -> AddressInEra era addressInEra networkId wallet = - C.makeShelleyAddressInEra networkId (paymentCredential wallet) C.NoStakeAddress + C.makeShelleyAddressInEra (C.shelleyBasedEra @era) networkId (paymentCredential wallet) C.NoStakeAddress {-| The wallet's private key (serialised) -} diff --git a/src/wallet/lib/Convex/Wallet/Cli.hs b/src/wallet/lib/Convex/Wallet/Cli.hs index a4837328..e3baf67d 100644 --- a/src/wallet/lib/Convex/Wallet/Cli.hs +++ b/src/wallet/lib/Convex/Wallet/Cli.hs @@ -77,7 +77,7 @@ generateSigningKey verificationKeyFile signingKeyFile = do C.writeFileTextEnvelope (C.File signingKeyFile) Nothing signingKey >>= either (error . show) pure C.writeFileTextEnvelope (C.File verificationKeyFile) Nothing (C.getVerificationKey signingKey) >>= either (error . show) pure -showAddress :: (MonadLog m, MonadError C.InitialLedgerStateError m, MonadIO m) => Config -> OperatorConfigVerification -> m (C.LocalNodeConnectInfo C.CardanoMode) +showAddress :: (MonadLog m, MonadError C.InitialLedgerStateError m, MonadIO m) => Config -> OperatorConfigVerification -> m C.LocalNodeConnectInfo showAddress Config{cardanoNodeConfigFile, cardanoNodeSocket} operatorConfig = do op <- liftIO (loadOperatorFilesVerification operatorConfig) (info_@C.LocalNodeConnectInfo{C.localNodeNetworkId}, _) <- loadConnectInfo cardanoNodeConfigFile cardanoNodeSocket diff --git a/src/wallet/lib/Convex/Wallet/NodeClient/BalanceClient.hs b/src/wallet/lib/Convex/Wallet/NodeClient/BalanceClient.hs index f2d3cb20..5ca3beab 100644 --- a/src/wallet/lib/Convex/Wallet/NodeClient/BalanceClient.hs +++ b/src/wallet/lib/Convex/Wallet/NodeClient/BalanceClient.hs @@ -9,7 +9,7 @@ module Convex.Wallet.NodeClient.BalanceClient( balanceClient ) where -import Cardano.Api (BlockInMode, CardanoMode, Env) +import Cardano.Api (BlockInMode, Env) import qualified Cardano.Api as C import Control.Concurrent.STM (TVar, atomically, newTVarIO, writeTVar) @@ -53,11 +53,11 @@ balanceClient logEnv ns clientEnv walletState wallet env = {-| Apply a new block -} -applyBlock :: K.LogEnv -> K.Namespace -> BalanceClientEnv -> C.PaymentCredential -> CatchingUp -> (CatchingUp, UtxoSet C.CtxTx ()) -> BlockInMode CardanoMode -> IO (Maybe (CatchingUp, UtxoSet C.CtxTx ())) +applyBlock :: K.LogEnv -> K.Namespace -> BalanceClientEnv -> C.PaymentCredential -> CatchingUp -> (CatchingUp, UtxoSet C.CtxTx ()) -> BlockInMode -> IO (Maybe (CatchingUp, UtxoSet C.CtxTx ())) applyBlock logEnv ns BalanceClientEnv{bceFile, bceState} wallet c (oldC, state) block = K.runKatipContextT logEnv () ns $ runMonadLogKatipT $ runMaybeT $ do let change = Utxos.extract_ (toShelleyPaymentCredential wallet) state block newUTxOs = apply state change - C.BlockInMode (C.getBlockHeader -> header) _ = block + C.BlockInMode _ (C.getBlockHeader -> header) = block newState = WalletState.walletState newUTxOs header when (not $ Utxos.null change) $ do